Add a base to blocks

src/Dodge/Material/Color.hs

@@ -2,17 +2,17 @@
 
 module Dodge.Material.Color (materialColor) where
 
-import Dodge.Data.Material
 import Color
+import Dodge.Data.Material
 
 materialColor :: Material -> Color
 materialColor = \case
-        Wood -> dark yellow
-        Dirt -> dark $ dark orange
-        Stone -> greyN 0.5
-        Glass -> aquamarine
-        Metal -> orange
-        Crystal -> green
-        Flesh -> red
-        Electronics -> greyN 0.2
-        ForceField -> magenta
+    Wood -> dark yellow
+    Dirt -> dark $ dark orange
+    Stone -> greyN 0.5
+    Glass -> aquamarine
+    Metal -> orange
+    Crystal -> green
+    Flesh -> red
+    Electronics -> greyN 0.2
+    ForceField -> magenta

src/Dodge/Placement/Instance/Wall.hs

@@ -38,14 +38,6 @@ invisibleWall ps =
 midWall :: [Point2] -> Placement
 midWall = heightWallPS (PS 0 0) 50
 
---singleBlock :: Point2 -> [Placement]
---singleBlock a =
---    [ sPS a 0 $
---        PutBlock defaultBlock baseBlockPane $
---            reverse $
---                square 10
---    ]
-
 {-
 Places a line of blocks between two points.
  -}
@@ -66,17 +58,6 @@ Width 7, also extends out from each point by 7.
 crystalLine :: Point2 -> Point2 -> Placement
 crystalLine a = sps0 . PutLineBlock defaultCrystalWall 7 a
 
---crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
---  where
---    ps =
---        [ a +.+ left +.+ up
---        , (a +.+ left) -.- up
---        , (b -.- left) -.- up
---        , (b -.- left) +.+ up
---        ]
---    left = 7 *.* normalizeV (a-.-b)
---    up   = vNormal left
---
 --{- Places an unbreakable wall between two points.
 --Depth 15, does not extend wider than points.
 -- -}
@@ -92,14 +73,9 @@ crystalLine a = sps0 . PutLineBlock defaultCrystalWall 7 a
 --    left = 15 *.* normalizeV (a -.- b)
 --    up = vNormal left
 
---windowLineType :: Point2 -> Point2 -> PSType
---windowLineType = PutLineBlock defaultWindow 8
-
 baseBlockPane :: Wall
 baseBlockPane = defaultWall & wlOpacity .~ Opaque 17
 
---    & wlPathFlag .~ S.fromList [WallBlockVisibility, WallNotAutoOpen]
-
 -- TODO find home for this
 {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
 replacePutID ::
@@ -132,19 +108,6 @@ subZipWith f g xs ys =
 isPutID :: Int -> Placement -> Bool
 isPutID i ps = Just i == ps ^? plType . putID
 
---putBlockRect' :: Float -> Float -> Placement
---putBlockRect' w h =
---    ps0jPushPS (aline tl tr) $
---        ps0jPushPS (aline tr br) $
---            ps0jPushPS (aline br bl) $
---                sps0 (aline bl tl)
---  where
---    tl = V2 (- w) h
---    tr = V2 w h
---    br = V2 w (- h)
---    bl = V2 (- w) (- h)
---    aline = PutLineBlock baseBlockPane 9
-
 putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
 putBlockRect a x b y = uncurry blockLine <$> loopPairs (rectNSWE b y a x)
 
@@ -154,13 +117,6 @@ putBlockV a x b y = uncurry blockLine <$>
     , (V2 x b, V2 a b)
     ]
 
---putBlockC :: Float -> Float -> Float -> Float -> [Placement]
---putBlockC a x b y =
---    [ blockLine (V2 a b) (V2 a y)
---    , blockLine (V2 x b) (V2 a b)
---    , blockLine (V2 a y) (V2 x y)
---    ]
-
 putBlockN :: Float -> Float -> Float -> Float -> [Placement]
 putBlockN a x b y = uncurry blockLine <$>
     [ (V2 a b, V2 a y)

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -6,7 +6,11 @@ module Dodge.Placement.PlaceSpot.Block (
     insertStructureWalls,
 ) where
 
-import Control.Lens
+import Dodge.Material.Color
+import Linear
+import ShapePicture
+import Shape
+import LensHelp
 import qualified Data.IntSet as IS
 import Data.List
 import qualified Data.Set as S
@@ -53,6 +57,7 @@ insertStructureWalls f wl ps sid wid =
 plLineBlock ::
     -- | Base pane
     Wall ->
+    -- | Block width
     Float ->
     -- | Start point (symmetric)
     Point2 ->
@@ -62,7 +67,7 @@ plLineBlock ::
     (Int, GenWorld)
 plLineBlock basePane blwidth a b gw =
     ( 0
-    , over gwWorld insertBlocks gw
+    , over gwWorld (insertBase . insertBlocks) gw
     )
   where
     depth = blwidth
@@ -76,6 +81,15 @@ plLineBlock basePane blwidth a b gw =
     linesAt p = loopPairs $ cornersAt p
     wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
     blid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . blocks
+    insertBase =  
+        cWorld . lWorld . foreShapes .:~ ForegroundShape
+        midp 0 (noPic . colorSH (materialColor $ basePane ^. wlMaterial) 
+            $ upperBox Medium Typical 3
+            [a + x + n - midp, a + x - (n + midp), b - (n + x + midp), b + n - (x + midp)]
+            )
+    midp = (0.5 * (a + b))
+    x = (blwidth + 1) *^ (normalize $ a - b)
+    n = vNormal x
     insertBlock (i, p) =
         insertWalls (makeWallAt p i)
             . over

src/Dodge/Render/ShapePicture.hs

@@ -26,8 +26,7 @@ worldSPic cfig u =
         <> foldMap' debrisSPic (filtOn' (xyV3 . _dbPos) _debris)
         <> foldup drawProjectile (filtOn (^. pjPos . _xy) _projectiles)
         <> foldup drawPulseBall (filtOn _pbPos _pulseBalls)
-        <> foldup (shiftDraw _blPos _blDir (const $ noPic . _blDraw)) 
-                (filtOn _blPos _blocks)
+        <> foldup (shiftDraw _blPos _blDir (const drawBlock)) (filtOn _blPos _blocks)
         <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foreShapes)
         <> foldup (drawCreature (lw ^. items)) (filtOn (^. crPos . _xy) _creatures)
         <> foldup
@@ -49,6 +48,9 @@ worldSPic cfig u =
     filtOn' f g = filter (pointIsClose . f) (g lw)
     pointIsClose = cullPoint cfig w
 
+drawBlock :: Block -> SPic
+drawBlock = (noPic . _blDraw)
+
 drawChasm :: [Point2] -> SPic
 drawChasm = foldMap (Prelude.uncurry drawCliff) . loopPairs
 

src/Framebuffer/Update.hs

@@ -25,7 +25,7 @@ sizeFBOs cfig rdata =
             (getWindowSize _gr_world_res cfig)
             GL_NEAREST
             GL_NEAREST
-            GL_RGBA16F
+            GL_RGBA16F -- not sure if the alpha is necessary here
             GL_RGB16F -- could possibly recover using depth in a clever way
             -- but probably not, because the projection matrix is
             -- not always on-center
@@ -54,7 +54,7 @@ sizeFBOs cfig rdata =
                 GL_LINEAR_MIPMAP_LINEAR
                 GL_LINEAR
                 GL_RGBA16F
-                [fboBloom, fboPos]
+                [fboBloom, fboPos] -- fboPos probably doesn't need the alpha channel
             >>= foldUpdateFBOTO
                 _gr_downsize_res
                 GL_LINEAR_MIPMAP_LINEAR

src/Shape.hs

@@ -70,12 +70,7 @@ prismPoly size shads upps downps = [Surface (RoundedFaces n) (cp : cp : f upps d
     f (a : as) (b : bs) = a : b : f as bs
     f _ _ = []
 
-prismBox ::
-    Size ->
-    Importance ->
-    [Point3] ->
-    [Point3] ->
-    Shape
+prismBox :: Size -> Importance -> [Point3] -> [Point3] -> Shape
 {-# INLINE prismBox #-}
 prismBox size shads upps downps = [Surface (FlatFaces n) (f upps downps) white shads size]
   where