Partially implement separate blocks

src/Dodge/Base/Collide.hs

@@ -141,7 +141,7 @@ collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
 collidePointFire p1 p2 ws 
     = safeMinimumOn (dist p1) 
     . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine ) 
-    $ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws
+    $ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? wlBlockID))) ws
 {- | Checks to see whether someone can fire bullets effectively between two points. 
  - Not sure if this needs vision as well, need to make this uniform. -}
 collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
@@ -149,7 +149,7 @@ collidePointFireVision p1 p2 ws
     = any ( isJust . uncurry (intersectSegSeg p1 p2) . _wlLine) 
     $ IM.filter notBlockWindow ws
   where 
-    notBlockWindow wl = case wl ^? blHP of
+    notBlockWindow wl = case wl ^? wlBlockID of
         Just _  -> not $ _wlIsSeeThrough wl
         Nothing -> True
 
@@ -180,7 +180,7 @@ pathToPointFireable :: Int -> Point2 -> World -> Bool
 pathToPointFireable i p w 
     = not 
     . pointHitsWalls (_crPos $ _creatures w IM.! i) p
-    $ IM.filter (isNothing . (^? blHP) ) $ wallsAlongLine p1 p w
+    $ IM.filter (isNothing . (^? wlBlockID) ) $ wallsAlongLine p1 p w
   where 
     p1 = _crPos (_creatures w IM.! i)
 

src/Dodge/Data.hs

@@ -568,13 +568,14 @@ data Wall
         , _wlColor :: Color
         , _wlSeen :: Bool
         , _blIDs :: [Int]
-        , _blHP :: Int
+        --, _blHP :: Int
         , _wlIsSeeThrough :: Bool
         , _blVisible :: Bool
-        , _blDegrades :: [Int]
+        --, _blDegrades :: [Int]
         , _blShadows :: [Int]
         , _wlDraw :: Bool
         , _wlRotateTo :: Bool
+        , _wlBlockID :: Int
         }
 data ForceField = FF 
     { _ffLine :: [Point2] , _ffID :: Int 

src/Dodge/Default/Wall.hs

@@ -22,13 +22,12 @@ defaultBlock = Block
     , _wlColor = greyN 0.5
     , _wlSeen = False
     , _blIDs = []
-    , _blHP = 5
     , _wlIsSeeThrough = False
     , _blVisible = True
     , _blShadows = []
-    , _blDegrades = [20,20]
     , _wlDraw = True
     , _wlRotateTo = True
+    , _wlBlockID = 0
     }
 
 {- Indestructible see-through wall.  -}

src/Dodge/Floor.hs

@@ -35,6 +35,7 @@ initialRoomTree = do
         t = treeFromTrunk 
             [[StartRoom]
             ,[Corridor]
+            ,[SpecificRoom roomCCrits]
             ,[Corridor]
             ,[AirlockAno]
             ,[Corridor]
@@ -78,7 +79,7 @@ initialRoomTree = do
                 ]
              ]
             ,[Corridor]
-            ,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
+--            ,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
             ,[Corridor]
             ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
             ] 

src/Dodge/Initialisation.hs

@@ -23,10 +23,8 @@ import System.Random
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
---import Data.Maybe
 --import Control.Lens
---import Data.List (partition)
+--import Data.Maybe
---import Data.List (sortOn)
 
 firstWorld :: IO World
 firstWorld = do
@@ -58,8 +56,23 @@ initialWorld = defaultWorld
     , _decorations = IM.empty
     , _menuLayers = [TerminalScreen 300 rezText']
     }
+
+zonedBlockWalls :: World -> [String]
+zonedBlockWalls = concatMap f . IM.toList . _znObjects . _wallsZone
+  where
+    f (x,ys) = map (show x ++) $ map g $ IM.toList ys
+    g (y,zs) = show y
+
 testStringInit :: World -> [String]
-testStringInit _ = []
+--testStringInit w = map (show . _blWallIDs) . IM.elems $ _blocks w
+testStringInit w = (map (f w) . filter g . IM.elems $ _walls w)
+--    ++ zonedBlockWalls w
+  where
+    g Block{} = True
+    g _ = False
+    f w' wl = show (_wlID wl) ++ " : " ++ show blid ++ show (_blWallIDs $ (_blocks w') IM.! blid)
+      where
+        blid = _wlBlockID wl
 --testStringInit = mapMaybe f . IM.elems . flattenIMIMIM . _znObjects . _wallsZone
 --  where
 --    f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr

src/Dodge/LevelGen.hs

@@ -39,6 +39,8 @@ shiftPSBy (pos,rot) ps = ps
     & psPos %~ shiftPointBy (pos,rot)
     & psRot %~ (+ rot)
 
+-- the Int here allows for passing parameters down to other placements:
+-- button ids, etc
 placeSpotID :: PlacementSpot -> World -> (Int, World)
 placeSpotID ps w = case _psType ps of
     PutProp prop -> placeProp prop p rot w

src/Dodge/LevelGen/Block.hs

@@ -1,96 +1,100 @@
 {- | Creation, update and destruction of destructible walls.  -}
-module Dodge.LevelGen.Block where
+module Dodge.LevelGen.Block 
+    ( putBlock
+    )
+    where
 import Dodge.Data
-import Dodge.Data.SoundOrigin
+--import Dodge.Data.SoundOrigin
 import Dodge.Base
 import Dodge.Zone
-import Dodge.SoundLogic
+--import Dodge.SoundLogic
-import Dodge.SoundLogic.LoadSound
+--import Dodge.SoundLogic.LoadSound
-import Dodge.WorldEvent.Sound
+--import Dodge.WorldEvent.Sound
 import Dodge.LevelGen.Pathing
-import Dodge.RandomHelp
+--import Dodge.RandomHelp
 import Geometry
 import qualified IntMapHelp as IM
 import Color
 
 import Control.Lens
-import Control.Monad.State
+--import Control.Monad.State
 import Data.List
-import Data.Maybe
+--import Data.Maybe
-import Data.Function
+--import Data.Function
-import System.Random
+--import System.Random
+
+--updateBlocks :: World -> World
+--updateBlocks w 
+--    = w --(\w' -> seq (_wallsZone w') w') 
+--    $ flip (foldl' $ flip removeFromZone) deadPanes 
+--    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks 
+-- where  
+--    --degradeBlocks = deadBlocks `seq` foldl' (flip killBlock) w deadBlocks
+--    removeFromZone :: Wall -> World -> World
+--    removeFromZone bl = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID bl))
+--      where 
+--        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine bl)
+--    deadPanes w' = filter (blockIsDead w') (IM.elems $ _walls w)
+--    --deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
+--    blockIsDead w' wl = case IM.lookup (_wlBlockID wl) $ _blocks w of 
+--        Just x  -> x <= 0
+--        Nothing -> False
 
-updateBlocks :: World -> World
-updateBlocks w 
-    = (\w' -> seq (_wallsZone w') w') 
-    $ flip (foldl' $ flip removeFromZone) deadPanes 
-    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks 
- where  
-    degradeBlocks = deadBlocks `seq` foldl' (flip killBlock) w deadBlocks
-    removeFromZone :: Wall -> World -> World
-    removeFromZone bl = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID bl))
-      where 
-        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine bl)
-    deadPanes = filter blockIsDead (IM.elems $ _walls w)
-    deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
-    blockIsDead wl = case wl ^? blHP of 
-        Just x  -> x <= 0
-        Nothing -> False
 {- | Destroy a block.
 Plays destruction sound and sets to be displayed other walls that were shadowed by this wall. -}
-killBlock :: Wall -> World -> World
+--killBlock :: Wall -> World -> World
-killBlock bl w =  f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
+--killBlock bl w =  f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
-  where
+--  where
-    f :: Wall -> World -> World
+--    f :: Wall -> World -> World
-    f bl'
+--    f bl'
-        | isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl
+--        | isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl
-        | otherwise = hitSound' bl'
+--        | otherwise = hitSound' bl'
-    pos = fst $ _wlLine bl
+--    pos = fst $ _wlLine bl
-    breakHitSound bl' 
+--    breakHitSound bl' 
-        | _wlIsSeeThrough bl' = mkSoundBreakGlass pos
+--        | _wlIsSeeThrough bl' = mkSoundBreakGlass pos
-        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
+--        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
-    hitSound' bl' 
+--    hitSound' bl' 
-        | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
+--        | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
-        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
+--        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
-    sos = [BlockDegradeSound 0,BlockDegradeSound 1]
+--    sos = [BlockDegradeSound 0,BlockDegradeSound 1]
-    impactSound = evalState (takeOne [impact1S,impact2S,impact3S,impact4S]) $ _randGen w
+--    impactSound = evalState (takeOne [impact1S,impact2S,impact3S,impact4S]) $ _randGen w
-    unshadow :: Int -> World -> World
+--    unshadow :: Int -> World -> World
-    unshadow bid w' = case w' ^? walls . ix bid of 
+--    unshadow bid w' = case w' ^? walls . ix bid of 
-        Just b -> 
+--        Just b -> 
-            let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
+--            let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
-            in w & wallsZone . znObjects . ix x . ix y . ix bid . blVisible %~ const True
+--            in w & wallsZone . znObjects . ix x . ix y . ix bid . blVisible %~ const True
-                 & walls . ix bid . blVisible %~ const True
+--                 & walls . ix bid . blVisible %~ const True
-        Nothing -> w
+--        Nothing -> w
 
-degradeBlock :: Wall -> World -> World
+--degradeBlock :: Wall -> World -> World
-degradeBlock bl w = 
+--degradeBlock bl w = 
-    let blid = _wlID bl
+--    let blid = _wlID bl
-        bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
+--        bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
-        ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _wlLine) bls
+--        ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _wlLine) bls
-        (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
+--        (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
-        (x:xs) = _blDegrades bl
+--        (x:xs) = _blDegrades bl
-    in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
+--    in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
 
 {-
 This does not have clear behaviour in my mind, and should probably be replaced with something more obvious...
  -}
-pushPointTowardsBy 
+--pushPointTowardsBy 
-    :: RandomGen g 
+--    :: RandomGen g 
-    => Float 
+--    => Float 
-    -> Point2 
+--    -> Point2 
-    -> [Point2] 
+--    -> [Point2] 
-    -> State g Point2
+--    -> State g Point2
-pushPointTowardsBy x p ps = do
+--pushPointTowardsBy x p ps = do
-    xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
+--    xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
-    let toAdd p' y = y *.* (p' -.- p)
+--    let toAdd p' y = y *.* (p' -.- p)
-    return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)
+--    return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)
 
-shrinkPolygon 
+--shrinkPolygon 
-    :: RandomGen g 
+--    :: RandomGen g 
-    => Float        -- ^ Shrink parameter
+--    => Float        -- ^ Shrink parameter
-    -> [Point2] 
+--    -> [Point2] 
-    -> State g [Point2]
+--    -> State g [Point2]
-shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
+--shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
 
 addBlock 
     :: [Point2]     -- ^ Block polygon
@@ -119,13 +123,12 @@ addBlock (p:ps) hp col isSeeThrough hps w
             , _wlColor = col
             , _wlSeen = False
             , _blIDs = is
-            , _blHP = hp
             , _wlIsSeeThrough = isSeeThrough
             , _blVisible = True
             , _blShadows = []
-            , _blDegrades = hps
             , _wlDraw = True
             , _wlRotateTo = True
+            , _wlBlockID = blid
             }
         ) is lns
     wallInZone wl 
@@ -138,11 +141,10 @@ addBlock (p:ps) hp col isSeeThrough hps w
         ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
 addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
         
--- TODO add block list to world
+---- TODO add block list to world
 putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World)
 putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
   where 
     pairs = zip (p:ps) (ps ++ [p])
     wWithBlock = addBlock (p:ps) i c b is w
 putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon"
-

src/Dodge/LevelGen/LineBlock.hs

@@ -1,12 +1,10 @@
 {- | Splits a line into many four cornered blocks. -}
 module Dodge.LevelGen.LineBlock
     ( putLineBlock
-    )
+    ) where
-    where
 import Dodge.Data
 import Dodge.Base
 import Dodge.LevelGen.Pathing
---import Picture
 import Geometry
 import qualified IntMapHelp as IM
 
@@ -22,7 +20,7 @@ putLineBlock
     -> (Int, World)
 putLineBlock basePane blockWidth depth a b w 
     = (,) 0 
-    $ removePathsCrossing a b $ foldr insertBlock w listBlocks
+    $ removePathsCrossing a b $ foldr insertBlock (insertBlocks' w) listBlocks
   where 
     d = dist a b
     rot = argV (b -.- a)
@@ -40,6 +38,9 @@ putLineBlock basePane blockWidth depth a b w
     cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
     linesAt p = makeLoopPairs $ cornersAt p
     k = IM.newKey $ _walls w
+    blid = IM.newKey $ _blocks w
+    insertBlock' i = over blocks $ IM.insert (i+blid) Block' {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows' = []}
+    insertBlocks' = flip (foldr insertBlock') is
     ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
     visibilityAt i 
         | i == 0             = [ True,True,False,True]
@@ -53,6 +54,7 @@ putLineBlock basePane blockWidth depth a b w
     makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
     makePane i visStatus k' ps = basePane 
         {_wlID = k'
+        ,_wlBlockID = i + blid
         ,_wlLine = ps
         ,_blIDs = ksAtI i
         ,_blShadows = shadowsAt i
@@ -61,4 +63,3 @@ putLineBlock basePane blockWidth depth a b w
     listBlocks = concat $ zipWith makeBlockAt blockCenPs is
     insertBlock :: Wall -> World -> World
     insertBlock wl = over walls $ IM.insert (_wlID wl) wl
-

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -6,10 +6,9 @@ module Dodge.Particle.Bullet.HitEffect
 import Dodge.Data
 import Dodge.Data.DamageType
 import Dodge.Data.SoundOrigin
---import Dodge.Base
+import Dodge.WorldEvent.DamageBlock
 import Dodge.WorldEvent
 import Dodge.Particle.Bullet.Spawn
-import Dodge.WorldEvent.DamageBlock
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 import Dodge.RandomHelp
@@ -190,6 +189,7 @@ bulConWall'
 bulConWall' _ p wl = damageBlocksBy 1 wl . 
     over worldEvents ( makeShockwaveAt [] p 15 4 1 white . ) 
 
+
 hvBulHitWall' 
     :: Particle 
     -> Point2   -- ^ Impact point

src/Dodge/Room.hs

@@ -53,7 +53,8 @@ roomC x y = defaultRoom
     { _rmPolys = [rectNSWE y 0 0 x]
     , _rmLinks = lnks
     , _rmPath  = pth
-    , _rmPS    = [windowLine (V2 (x/2) 0) (V2 (x/2) (y-60))
+    --, _rmPS    = [windowLine (V2 (x/2) 0) (V2 (x/2) (y-60))
+    , _rmPS    = [windowLine (V2 (x/2) 10) (V2 (x/2) (20))
                  ]
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     }

src/Dodge/Room/Placement.hs

@@ -97,11 +97,9 @@ baseBlockPane = defaultBlock
     , _wlColor = greyN 0.5
     , _wlSeen = False
     , _blIDs = []
-    , _blHP = 5
     , _wlIsSeeThrough = False
     , _blVisible = True
     , _blShadows = []
-    , _blDegrades = [20,20]
     , _wlDraw = True
     }
 baseWindowPane :: Wall
@@ -111,11 +109,9 @@ baseWindowPane = defaultBlock
     , _wlColor = withAlpha 0.2 cyan
     , _wlSeen = False
     , _blIDs = []
-    , _blHP = 1
     , _wlIsSeeThrough = True
     , _blVisible = True
     , _blShadows = []
-    , _blDegrades = [5,5]
     , _wlDraw = True
     }
 {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}

src/Dodge/Update.hs

@@ -11,7 +11,7 @@ import Dodge.Config.Data
 import Dodge.Base
 import Dodge.Zone
 import Dodge.WallCreatureCollisions
-import Dodge.LevelGen.Block
+--import Dodge.LevelGen.Block
 import Dodge.Update.Camera
 import Dodge.SoundLogic
 import Dodge.Inventory
@@ -80,6 +80,23 @@ functionalUpdate w = case _menuLayers w of
       where 
         (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
 
+updateBlocks :: World -> World
+updateBlocks w = foldr f w $ _blocks w
+  where
+    f bl w' 
+        | head (_blHPs bl) < 1 = w'
+            & blocks %~ IM.delete (_blID bl)
+            & walls  %~ removeIDs (_blWallIDs bl)
+--            & flip (foldr removeFromZone) (_blWallIDs bl)
+        | otherwise = w'
+    removeIDs is wls = foldr IM.delete wls is
+    --removeFromZone wlid w' = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID wl)) w'
+    removeFromZone wlid w' = over (wallsZone . znObjects . ix x . ix y . ix (_wlID wl)) setCol w'
+      where
+        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
+        wl = _walls w' IM.! wlid
+        setCol = wlColor .~ V4 1 1 0 1
+
 -- | Note the explict use of record syntax. Using lens creates a space leak.
 resetWorldEvents :: World -> World
 resetWorldEvents w = w {_worldEvents = id}

src/Dodge/WorldEvent/DamageBlock.hs

@@ -1,16 +1,13 @@
 module Dodge.WorldEvent.DamageBlock
-    ( damageBlocksBy
-    )
     where
 import Dodge.Data
 
-import Data.Maybe
 import Control.Lens
-{- | Given a wall, if it is a damageable block
- - then damage it and connecting walls by a certain amount.  -}
-damageBlocksBy :: Int -> Wall -> World -> World
-{-# INLINE damageBlocksBy #-}
-damageBlocksBy x wall w
-        | isJust (wall ^? blHP) = foldr (\j -> walls . ix j . blHP -~ x) w (_blIDs wall)
-        | otherwise = w
 
+damageBlocksBy :: Int -> Wall -> World -> World
+damageBlocksBy x wl = case wl ^? wlBlockID of
+    Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
+    Nothing   -> id
+  where
+    reduceHeadBy y (z:zs) = z - y : zs
+    reduceHeadBy _ [] = []

src/Dodge/WorldEvent/HitEffect.hs

@@ -65,7 +65,7 @@ penWalls crEff wlEff ffEff pt hitThings w = case hitThings of
         []              -> (              w, mvPt)
         ((p,E3x1 cr):_)  -> (crEff pt p cr w, destroyAt p)
         ((p,E3x3 ff):_)  -> (ffEff pt p ff w, destroyAt p)
-        ((p,E3x2 wl):hs) | isJust (wl ^? blHP) 
+        ((p,E3x2 wl):hs) | isJust (wl ^? wlBlockID) 
                                      -> first (wlEff pt p wl) $ penWalls crEff wlEff ffEff pt hs w
         ((p,E3x2 wl):_)  | otherwise -> (wlEff pt p wl w, destroyAt p)
   where 

src/Dodge/WorldEvent/Shockwave.hs

@@ -5,8 +5,8 @@ module Dodge.WorldEvent.Shockwave
   where
 import Dodge.Data
 import Dodge.Data.DamageType
-import Dodge.WorldEvent.DamageBlock
 import Dodge.Creature.State.Data
+import Dodge.WorldEvent.DamageBlock
 import Dodge.Base
 import Dodge.Zone
 import Dodge.Picture.Layer