Commit mid block refactor

src/Dodge/Base/Collide.hs

@@ -260,8 +260,10 @@ canSee i j w = hasLOS p1 p2 w
 --    jpos = _crPos (_creatures w IM.! j)
 
 canSeeIndirect :: Int -> Int -> World -> Bool
-canSeeIndirect i j w = not $ any (isJust . uncurry (intersectSegSeg ipos jpos) . _wlLine) 
+canSeeIndirect i j w = not 
-    $ IM.filter wlIsOpaque $ wallsAlongLine ipos jpos w
+    $ any (isJust . uncurry (intersectSegSeg ipos jpos) . _wlLine) 
+    $ IM.filter wlIsOpaque 
+    $ wallsAlongLine ipos jpos w
   where 
     ipos = _crPos (_creatures w IM.! i)
     jpos = _crPos (_creatures w IM.! j)

src/Dodge/Block.hs

@@ -11,14 +11,19 @@ import Geometry
 --import Geometry.ConvexPoly
 
 import Data.Function
+import Data.Maybe
 import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
 splinterBlock :: Block -> World -> World
 splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
-    & matSplintSound (_blMaterial bl) cen
+    & matSplintSound bm cen
   where
+    bm = fromMaybe Stone $ do
+        wlids <- w ^? blocks . ix (_blID bl) . blWallIDs
+        (wlid,_) <- IS.minView wlids
+        w ^? walls . ix wlid . wlMaterial
     cen = centroid $ fst . _wlLine <$> IM.restrictKeys (_walls w) (_blWallIDs bl)
 
 unshadowBlock :: Int -> World -> World
@@ -30,21 +35,21 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of
         (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
     Nothing -> w
 
-matSplintSound :: BlockMaterial -> Point2 -> World -> World
+matSplintSound :: Material -> Point2 -> World -> World
 matSplintSound mat = case mat of
-    GlassBlock -> mkSoundSplinterGlass
+    Glass -> mkSoundSplinterGlass
-    StoneBlock -> mkSoundSplinterBlock
+    Stone -> mkSoundSplinterBlock
-    CrystalBlock -> mkSoundSplinterBlock
+    Crystal -> mkSoundSplinterBlock
-    DirtBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
+    Dirt  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
-    WoodBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
+    Wood  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
-    MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
+    Metal -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
 
 destroyBlock :: Block -> World -> World
 destroyBlock bl w = w
     & flip (foldr unshadowBlock) (_blShadows bl)
     & deleteWallIDs wlids
     & blocks %~ IM.delete (_blID bl)
-    & matDesSound (_blMaterial bl) pos
+--    & matDesSound (_blMaterial bl) pos
     & _blDeath bl bl
     & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
   where

src/Dodge/Block/Debris.hs

@@ -13,27 +13,33 @@ import Color
 import LensHelp
 import RandomHelp
 import qualified Quaternion as Q
---import Data.List (zip4)
 
+import qualified Data.IntSet as IS
+import Data.Maybe
 makeBlockDebris :: Block -> World -> World
-makeBlockDebris bl = makeDebris (_blMaterial bl) (_blPos bl)
+makeBlockDebris bl w = w & makeDebris mt (_blPos bl)
+  where
+    mt = fromMaybe Stone $ do
+        wlids <- w ^? blocks . ix (_blID bl) . blWallIDs
+        (wlid,_) <- IS.minView wlids
+        w ^? walls . ix wlid . wlMaterial
 
-makeDebris :: BlockMaterial -> Point2 -> World -> World
+makeDebris :: Material -> Point2 -> World -> World
 makeDebris = makeDebrisDirected 1 2 (2*pi) 0
 makeDebrisDirected :: Float -> Float 
-    -> Float -> Float -> BlockMaterial -> Point2 -> World -> World
+    -> Float -> Float -> Material -> Point2 -> World -> World
 makeDebrisDirected mindist maxdist arcrad dir bm p w = w
         & flip (foldr (plNew props pjID)) thedebris
         & randGen .~ newg
         & matDesSound bm p
   where
     someDebris = case bm of
-        StoneBlock -> stoneDebris
+        Stone -> stoneDebris
-        GlassBlock -> glassDebris
+        Glass -> glassDebris
-        CrystalBlock -> crystalDebris
+        Crystal -> crystalDebris
-        DirtBlock   -> dirtDebris
+        Dirt   -> dirtDebris
-        WoodBlock   -> stoneDebris
+        Wood   -> stoneDebris
-        MetalBlock  -> stoneDebris
+        Metal  -> stoneDebris
     (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w
     f h = do
         v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
@@ -89,11 +95,11 @@ crystalDebris = glassDebris
 debrisShape :: Float -> Prop -> Shape
 debrisShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly 8 $ square size
 
-matDesSound :: BlockMaterial -> Point2 -> World -> World
+matDesSound :: Material -> Point2 -> World -> World
 matDesSound mat = case mat of
-    GlassBlock -> mkSoundBreakGlass
+    Glass -> mkSoundBreakGlass
-    CrystalBlock -> mkSoundBreakGlass -- this should be more crunchy
+    Crystal -> mkSoundBreakGlass -- this should be more crunchy
-    StoneBlock -> mkSoundSplinterBlock
+    Stone -> mkSoundSplinterBlock
-    DirtBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
+    Dirt  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
-    WoodBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
+    Wood  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
-    MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]
+    Metal -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]

src/Dodge/Data.hs

@@ -922,14 +922,13 @@ data Block = Block
     , _blWallIDs    :: IS.IntSet
     , _blHP         :: Int
     , _blShadows    :: [Int]   -- a list of blocks/walls? that are not shown when this block exists
-    , _blMaterial   :: BlockMaterial
     , _blFootprint  :: [Point2]
     , _blPos        :: Point2
     , _blDraw       :: Block -> SPic
     , _blDeath      :: Block -> World -> World
     }
-data BlockMaterial = WoodBlock | DirtBlock | StoneBlock | GlassBlock | MetalBlock
+data Material = Wood | Dirt | Stone | Glass | Metal | Crystal
-    | CrystalBlock
+  deriving (Eq,Ord,Show,Bounded,Enum)
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
   deriving (Eq,Ord,Show)
 data TerminalInput = TerminalInput
@@ -1032,7 +1031,7 @@ data Wall = Wall
     , _wlStructure      :: WallStructure
     , _wlHeight         :: Float
     , _wlDamageEff      :: Damage -> Wall -> World -> World
-    , _wlMaterial       :: BlockMaterial
+    , _wlMaterial       :: Material
     }
 data Opacity
     = SeeThrough
@@ -1402,12 +1401,12 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutTerminal {_unputTerminal :: Terminal}
     | PutFlIt Item
     | PutPPlate PressPlate
-    | PutBlock BlockMaterial Int Wall [Point2]
+    | PutBlock Block Wall [Point2]
     | PutCoord Point2
     | PutMod Modification
     | PutTrigger (World -> Bool)
-    | PutLineBlock {_putWall :: Wall, _putBlockMaterial :: BlockMaterial
+    | PutLineBlock {_putWall :: Wall , _putWidth :: Float
-        , _putWidth :: Float, _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
+        , _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]

src/Dodge/Default/Wall.hs

@@ -23,14 +23,14 @@ defaultWall = Wall
     , _wlWalkable = False
     , _wlHeight = 100
     , _wlDamageEff = defaultWallDamage
-    , _wlMaterial = StoneBlock
+    , _wlMaterial = Stone
     }
 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall
 defaultCrystalWall = defaultWall 
     { _wlColor = withAlpha 0.5 aquamarine
     , _wlOpacity = SeeThrough
-    , _wlMaterial = CrystalBlock
+    , _wlMaterial = Crystal
     }
 defaultMachineWall :: Wall
 defaultMachineWall = defaultWall
@@ -38,7 +38,7 @@ defaultMachineWall = defaultWall
     , _wlDraw = False
     , _wlRotateTo = False
     , _wlStructure = MachinePart 0
-    , _wlMaterial  = MetalBlock
+    , _wlMaterial  = Metal
     }
 defaultDirtWall :: Wall
 defaultDirtWall = defaultWall
@@ -50,7 +50,7 @@ defaultDirtWall = defaultWall
     , _wlRotateTo = False
     , _wlDraw = True
     , _wlFireThrough = True
-    , _wlMaterial    = DirtBlock
+    , _wlMaterial    = Dirt
     }
 defaultWindow :: Wall
 defaultWindow = defaultWall
@@ -62,5 +62,5 @@ defaultWindow = defaultWall
     , _wlOpacity = SeeThrough
     , _wlDraw = True
     , _wlFireThrough = True
-    , _wlMaterial    = GlassBlock
+    , _wlMaterial    = Glass
     }

src/Dodge/Placement/Instance/Wall.hs

@@ -1,6 +1,8 @@
 module Dodge.Placement.Instance.Wall
     where
 import Dodge.Data
+import Dodge.Default.Block
+import Dodge.Block.Debris
 import Dodge.LevelGen.Data
 import Dodge.Default.Wall
 --import Dodge.Wall.DamageEffect
@@ -56,7 +58,7 @@ midWall ps = ps0j (PutShape . colorSH col $ upperPrismPoly 50 ps)
 singleBlock :: Point2 -> [Placement]
 singleBlock a = 
     [sPS a 0 
-        $ PutBlock StoneBlock 100 baseBlockPane
+        $ PutBlock defaultBlock baseBlockPane
         $ reverse 
         $ square 10
     ]
@@ -65,20 +67,20 @@ Places a line of blocks between two points.
 Width 9, also extends out from each point by 9.
  -}
 blockLine :: Point2 -> Point2 -> Placement
-blockLine a b = sps0 $ PutLineBlock baseBlockPane StoneBlock 9 9 a b
+blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
 
 {-
 Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = sps0 $ PutLineBlock defaultWindow GlassBlock 8 8 a b
+windowLine a b = sps0 $ PutLineBlock defaultWindow 8 8 a b
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
  -}
 crystalLine :: Point2 -> Point2 -> Placement
-crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall CrystalBlock 7 7 a b
+crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 7 a b
 --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
 --  where
 --    ps = 
@@ -104,7 +106,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall
     up   = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
-windowLineType = PutLineBlock defaultWindow GlassBlock 8 8
+windowLineType = PutLineBlock defaultWindow 8 8
 
 baseBlockPane :: Wall
 baseBlockPane = defaultWall
@@ -151,7 +153,7 @@ putBlockRect' w h = ps0jPushPS (aline tl tr)
     tr = V2 w h
     br = V2 w (-h)
     bl = V2 (-w) (-h)
-    aline = PutLineBlock baseBlockPane StoneBlock 9 9
+    aline = PutLineBlock baseBlockPane 9 9
 
 putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
 putBlockRect a x b y =

src/Dodge/Placement/PlaceSpot.hs

@@ -103,9 +103,9 @@ placeSpotID ps pt w = case pt of
     PutCoord    cp          -> plNewID   coordinates (doShift cp) w
     PutSlideDr  pth col f off  a   b spd 
                             -> plSlideDoor pth col f off (doShift a) (doShift b) spd w
-    PutBlock    bm  hp wl  ps' 
+    PutBlock    bl wl  ps' 
-                            -> placeBlock (map doShift ps') hp wl bm w
+                            -> placeBlock (map doShift ps') bl wl w
-    PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
+    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
     PutWall     qs  wl      -> (0,placeWallPoly (map doShift qs) wl w)
     PutShape    sh          -> placeShape sh p rot w
     PutNothing              -> (0,w)

src/Dodge/Placement/PlaceSpot/Block.hs

@@ -20,15 +20,14 @@ import qualified Data.IntSet as IS
 addBlock 
     :: [Point2]     -- ^ Block polygon
     -> Wall         -- ^ Base Pane
-    -> Int          -- ^ First layer of health
+    -> Block
-    -> BlockMaterial
     -> World 
     -> World
-addBlock (p:ps) wl hp bm w = w
+addBlock (p:ps) wl bl w = w
     & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
     & walls  %~ IM.union panes
-    & blocks %~ IM.insert blid Block 
+    & blocks %~ IM.insert blid bl 
-        {_blID = blid,_blWallIDs = IS.fromList is, _blHP = hp, _blShadows=[], _blMaterial = bm
+        {_blID = blid,_blWallIDs = IS.fromList is, _blShadows=[]
             , _blFootprint = p:ps, _blPos = centroid (p:ps), _blDraw = const mempty
             , _blDeath = makeBlockDebris}
   where 
@@ -51,26 +50,25 @@ addBlock (p:ps) wl hp bm w = w
         (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
         wlid  = _wlID wl
         ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
-addBlock _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
+addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
-placeBlock :: [Point2] -> Int -> Wall -> BlockMaterial -> World -> (Int,World)
+placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
-placeBlock poly hp wl bm w 
+placeBlock poly bl wl w 
     = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
   where 
     pairs = loopPairs poly
-    wWithBlock = addBlock poly wl hp bm w
+    wWithBlock = addBlock poly wl bl w
 
 {- | Splits a line into many four cornered blocks. -}
 placeLineBlock 
     :: Wall     -- ^ Base pane
-    -> BlockMaterial
     -> Float    -- ^ Block width
     -> Float    -- ^ Block depth
     -> Point2   -- ^ Start point (symmetric)
     -> Point2   -- ^ End point (symmetric)
     -> World 
     -> (Int, World)
-placeLineBlock basePane bm blockWidth depth a b gw = ( 0 
+placeLineBlock basePane blockWidth depth a b gw = ( 0 
     , removePathsCrossing a b (foldr insertWall (insertBlocks gw) listWalls)
     )
   where 
@@ -86,7 +84,7 @@ placeLineBlock basePane bm blockWidth depth a b gw = ( 0
     blid = IM.newKey $ _blocks gw
     insertBlock (i,p) = over blocks $ IM.insert (i+blid) Block 
         { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i
-        , _blHP = 1000, _blShadows = shadowsAt i, _blMaterial = bm
+        , _blHP = 1000, _blShadows = shadowsAt i
         , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise)
         , _blPos = p, _blDraw = const mempty , _blDeath = makeBlockDebris}
     insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs

src/Dodge/Room/Pillar.hs

@@ -1,4 +1,5 @@
 module Dodge.Room.Pillar where
+import Dodge.Default.Block
 import Dodge.Placement.Instance.LightSource
 import Dodge.Data
 import Dodge.Cleat
@@ -29,10 +30,10 @@ blockPillar w' h' = ps0jPushPS (aline tl tr)
     tr = V2 w h
     br = V2 w (-h)
     bl = V2 (-w) (-h)
-    aline = PutLineBlock baseBlockPane StoneBlock 9 9
+    aline = PutLineBlock baseBlockPane 9 9
 
 smallPillar :: PSType
-smallPillar = PutBlock StoneBlock 500 baseBlockPane $ reverse $ square 5
+smallPillar = PutBlock defaultBlock 500 baseBlockPane $ reverse $ square 5
 
 crossPillar :: Float -> Float -> Placement
 crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))

src/Dodge/Room/RoadBlock.hs

@@ -1,6 +1,7 @@
 {- Connecting rooms designed with a pass-through technique in mind.  -}
 module Dodge.Room.RoadBlock where
 import Dodge.Default.Wall
+import Dodge.Default.Block
 import Dodge.Cleat
 import Dodge.Data
 import Dodge.RoomLink
@@ -67,7 +68,7 @@ blockedCorridor :: RandomGen g => State g (Tree Room)
 blockedCorridor = longBlockedCorridor 0
 
 dirtPoly :: [Point2] -> PSType
-dirtPoly = PutBlock DirtBlock 1 defaultDirtWall . reverse
+dirtPoly = PutBlock defaultDirtBlock defaultDirtWall . reverse
 
 -- | A single corridor with a destructible block blocking it.
 blockedCorridorCloseBlocks :: RandomGen g => State g Room