Partially implement separate blocks

2021-10-26 22:53:49 +01:00
parent d136fd910c
commit 12d43f9cf0
15 changed files with 145 additions and 115 deletions
@@ -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)

@@ -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 
@@ -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.  -}
@@ -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]]
            ] 
@@ -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.List (sortOn)
+--import Data.Maybe

 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
@@ -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
@@ -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.LoadSound
-import Dodge.WorldEvent.Sound
+--import Dodge.SoundLogic
+--import Dodge.SoundLogic.LoadSound
+--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.Function
-import System.Random
+--import Data.Maybe
+--import Data.Function
+--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 bl w =  f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
-  where
-    f :: Wall -> World -> World
-    f bl'
-        | isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl
-        | otherwise = hitSound' bl'
-    pos = fst $ _wlLine bl
-    breakHitSound bl' 
-        | _wlIsSeeThrough bl' = mkSoundBreakGlass pos
-        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
-    hitSound' bl' 
-        | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
-        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
-    sos = [BlockDegradeSound 0,BlockDegradeSound 1]
-    impactSound = evalState (takeOne [impact1S,impact2S,impact3S,impact4S]) $ _randGen w
-    unshadow :: Int -> World -> World
-    unshadow bid w' = case w' ^? walls . ix bid of 
-        Just b -> 
-            let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
-            in w & wallsZone . znObjects . ix x . ix y . ix bid . blVisible %~ const True
-                 & walls . ix bid . blVisible %~ const True
-        Nothing -> w
+--killBlock :: Wall -> World -> World
+--killBlock bl w =  f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
+--  where
+--    f :: Wall -> World -> World
+--    f bl'
+--        | isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl
+--        | otherwise = hitSound' bl'
+--    pos = fst $ _wlLine bl
+--    breakHitSound bl' 
+--        | _wlIsSeeThrough bl' = mkSoundBreakGlass pos
+--        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
+--    hitSound' bl' 
+--        | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
+--        | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
+--    sos = [BlockDegradeSound 0,BlockDegradeSound 1]
+--    impactSound = evalState (takeOne [impact1S,impact2S,impact3S,impact4S]) $ _randGen w
+--    unshadow :: Int -> World -> World
+--    unshadow bid w' = case w' ^? walls . ix bid of 
+--        Just b -> 
+--            let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
+--            in w & wallsZone . znObjects . ix x . ix y . ix bid . blVisible %~ const True
+--                 & walls . ix bid . blVisible %~ const True
+--        Nothing -> w

-degradeBlock :: Wall -> World -> World
-degradeBlock bl w = 
-    let blid = _wlID bl
-        bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
-        ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _wlLine) bls
-        (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
-        (x:xs) = _blDegrades bl
-    in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
+--degradeBlock :: Wall -> World -> World
+--degradeBlock bl w = 
+--    let blid = _wlID bl
+--        bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
+--        ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _wlLine) bls
+--        (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
+--        (x:xs) = _blDegrades bl
+--    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 
-    :: RandomGen g 
-    => Float 
-    -> Point2 
-    -> [Point2] 
-    -> State g Point2
-pushPointTowardsBy x p ps = do
-    xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
-    let toAdd p' y = y *.* (p' -.- p)
-    return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)
+--pushPointTowardsBy 
+--    :: RandomGen g 
+--    => Float 
+--    -> Point2 
+--    -> [Point2] 
+--    -> State g Point2
+--pushPointTowardsBy x p ps = do
+--    xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
+--    let toAdd p' y = y *.* (p' -.- p)
+--    return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)

-shrinkPolygon 
-    :: RandomGen g 
-    => Float        -- ^ Shrink parameter
-    -> [Point2] 
-    -> State g [Point2]
-shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
+--shrinkPolygon 
+--    :: RandomGen g 
+--    => Float        -- ^ Shrink parameter
+--    -> [Point2] 
+--    -> State g [Point2]
+--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"
-
@@ -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,12 +38,15 @@ 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]
        | i == numBlocks - 1 = [False,True, True,True]
        | otherwise          = [False,True,False,True]
-    shadowsAt i 
+    shadowsAt i
        | i == 0             = ksAtI 1
        | i == numBlocks - 1 = ksAtI $ numBlocks - 2
        | otherwise          = ksAtI (i-1) ++ ksAtI (i+1)
@@ -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
-
@@ -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
@@ -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)]
    }
@@ -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.  -}
@@ -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}
@@ -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 _ [] = []
@@ -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 
@@ -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