Partially implement separate blocks

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.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"
-