Make tanks into decorated blocks

src/Dodge/Data.hs

@@ -986,6 +986,8 @@ data Block = Block
     , _blFootprint  :: [Point2]
     , _blPos        :: Point2
     , _blDir        :: Float
+    , _blHeight     :: Float
+    , _blMaterial   :: Material
     , _blDraw       :: Block -> SPic
     , _blDeath      :: Block -> World -> World
     , _blObstructs  :: [(Int,Int,PathEdge)]
@@ -1064,10 +1066,6 @@ data MachineType
         , _tuFireTime   :: Int
         , _tuMCrID      :: Maybe Int
         }
-data BlockShifter = BlockShifter
-    { _bsID :: Int
-    , _bsBlocks :: IS.IntSet
-    }
 data Door = Door
     { _drID :: Int
     , _drWallIDs :: IS.IntSet
@@ -1097,6 +1095,7 @@ data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
 data PushSource = PushesItself
     | PushedBy Int
     | NotPushed
+  deriving (Eq,Ord,Show)
 
 data ActionPlan
     = Inanimate

src/Dodge/Default/Block.hs

@@ -14,6 +14,8 @@ defaultBlock = Block
     , _blDir       = 0
     , _blDraw      = const mempty
     , _blDeath     = makeBlockDebris
+    , _blHeight     = 100
+    , _blMaterial   = Stone
     , _blObstructs = []
     }
 defaultDirtBlock :: Block

src/Dodge/Default/Wall.hs

@@ -38,7 +38,6 @@ defaultCrystalWall = defaultWall
 defaultMachineWall :: Wall
 defaultMachineWall = defaultWall
     { _wlOpacity = SeeAbove
-    , _wlUnshadowed = False
     , _wlRotateTo = False
     , _wlStructure = MachinePart 0
     , _wlMaterial  = Metal
@@ -51,7 +50,6 @@ defaultDirtWall = defaultWall
     , _wlSeen = False
     , _wlOpacity = Opaque
     , _wlRotateTo = False
-    , _wlUnshadowed = True
     , _wlFireThrough = True
     , _wlMaterial    = Dirt
     }
@@ -62,7 +60,6 @@ defaultWindow = defaultWall
     , _wlColor = withAlpha 0.5 cyan
     , _wlSeen = False
     , _wlOpacity = SeeThrough
-    , _wlUnshadowed = True
     , _wlFireThrough = True
     , _wlMaterial    = Glass
     }

src/Dodge/Placement/Instance/Block.hs

@@ -8,16 +8,20 @@ import Shape
 import Dodge.Default.Wall
 import Dodge.Default.Block
 
-lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
+decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType
-lowBlock mat col h ps = PutBlock bl wl $ reverse ps
+decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps
   where
     bl = defaultBlock
-        & blDraw .~ const (noPic $ colorSH col (upperPrismPoly h $ reverse ps))
+        & blDraw .~ (\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl'))
         & blDeath .~ const id
+        & blHeight .~ h
+        & blMaterial .~ mat
     wl = defaultWall 
-        & wlUnshadowed .~ False 
         & wlColor .~ col 
         & wlRotateTo .~ False  
         & wlOpacity .~ SeeAbove
         & wlMaterial .~ mat
         & wlHeight .~ h
+
+lowBlock :: Material -> Color -> Float -> [Point2] -> PSType
+lowBlock = decoratedBlock (const mempty)

src/Dodge/Placement/Instance/Tank.hs

@@ -4,17 +4,13 @@ module Dodge.Placement.Instance.Tank
     , roundTankCross
     ) where
 import Dodge.Data
-import Dodge.Default.Block
---import Dodge.Placement.PlaceSpot
 import Dodge.LevelGen.Data
 import Dodge.Room.Foreground
-import Dodge.Default.Wall
+import Dodge.Placement.Instance.Block
---import Dodge.Placement.TopDecoration
 import Geometry
 import Shape
-import ShapePicture
 import Color
-import LensHelp
+--import LensHelp
 --import Quaternion
 
 tankSquareDec :: (Float -> Float -> Float -> Color -> Color -> Shape) 
@@ -22,18 +18,17 @@ tankSquareDec :: (Float -> Float -> Float -> Color -> Color -> Shape)
 tankSquareDec dec = tankShape (square 20) (dec 20 20 31)
 
 tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement
-tankShape baseshape facade col col' 
+tankShape baseshape facade col col' = sps0 $ decoratedBlock (const $ facade col col') Metal col 31 baseshape
-    = sps0 $ PutBlock bl wl $ reverse baseshape
+--    = sps0 $ PutBlock bl wl $ reverse baseshape
-  where
+--  where
-    bl = defaultBlock
+--    bl = defaultBlock
-        & blDraw .~ const (noPic $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col')
+--        & blDraw .~ const (noPic $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col')
-        & blDeath .~ const id
+--        & blDeath .~ const id
-    wl = defaultWall 
+--    wl = defaultWall 
-        & wlUnshadowed .~ False 
+--        & wlColor .~ col 
-        & wlColor .~ col 
+--        & wlRotateTo .~ False  
-        & wlRotateTo .~ False  
+--        & wlOpacity .~ SeeAbove
-        & wlOpacity .~ SeeAbove
+--        & wlMaterial .~ Metal
-        & wlMaterial .~ Metal
 
 --    = ps0jPushPS
 --    (PutShape $ colorSH col (upperPrismPoly 31 baseshape) <> facade col col')

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -74,6 +74,8 @@ plLineBlock basePane blwidth a b gw = ( 0
         , _blDir = 0    -- THIS IS NOT SENSIBLE. TODO rethink block positioning
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
         , _blObstructs = []
+        , _blMaterial = _wlMaterial basePane
+        , _blHeight   = 100
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
         )
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -101,7 +101,9 @@ doorMechanism dr w = case mvDir of
     speed = _drSpeed dr
     drid = _drID dr
     moveUpdate = playSound . setStatus
-    playSound = soundContinue (WallSound drid) dpos slideDoorS (Just 1)
+    playSound 
+        | _drPushedBy dr == PushesItself = soundContinue (WallSound drid) dpos slideDoorS (Just 1)
+        | otherwise = id
     dpos = snd $ _drPos dr
     dop = snd $ _drOpenPos dr
     dcp = snd $ _drClosePos dr

src/Dodge/Render/Walls.hs

@@ -29,9 +29,9 @@ wallsToDraw w
     g (V2 i j) = w ^? wlZoning . znObjects . ix i . ix j
     
 wlOpaqueDraw :: Wall -> Bool
-wlOpaqueDraw wl = wlIsOpaque wl && _wlUnshadowed wl
+wlOpaqueDraw wl = wlIsOpaque wl && _wlHeight wl == 100
 wlSeeThroughDraw :: Wall -> Bool
-wlSeeThroughDraw wl = wlIsSeeThrough wl && _wlUnshadowed wl
+wlSeeThroughDraw wl = wlIsSeeThrough wl && _wlHeight wl == 100
 
 getWallSPic :: Wall -> SPic
 getWallSPic wl = case wl ^? wlOpacity . opDraw of