Reorganise block module

src/Dodge/Block.hs

@@ -1,104 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-module Dodge.Block where
-import Dodge.Data
-import Dodge.Base
-import Dodge.SoundLogic
-
-import Geometry
-import Picture.Data
-
-import Control.Lens
-
-import Data.List
-
-import Data.Function
-import qualified Data.IntMap.Strict as IM
-import System.Random
-import Control.Monad.State
-
-updateBlocks :: World -> World
-updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes 
-                    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls)
-                 degradeBlocks 
---                    w                
-   where  degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
-          removeFromZone :: Wall -> World -> World
-          removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
-            where (x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1)
-          deadPanes = filter blockIsDead (IM.elems $ _walls w)
-          deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
-          blockIsDead wl = case wl ^? blHP of Just x  -> x <= 0
-                                              Nothing -> False
-
-killBlock :: Wall -> World -> World
-killBlock bl w =  f bl .
-                  flip (foldr unshadow)
---                  flip (foldr (\i -> set (walls . ix i . blVisible) (True)))
-                         (_blShadows bl)
-                        $ w
-    where
-        f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
-        f bl          = hitSound' bl
-        hitSound bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+8) 25 0 
-                    | otherwise = soundMultiFrom sos soundid 25 0 
-        hitSound' bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+4) 25 0 
-                     | otherwise = soundMultiFrom sos soundid 25 0 
-        sos = [BlockDegradeSound 0,BlockDegradeSound 1]
-        (soundid,_) = randomR (29,32) $ _randGen w
-        unshadow :: Int -> World -> World
-        unshadow bid w = case w ^? walls . ix bid of 
-                            Just b  -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
-                                       in  w & wallsZone . ix x . ix y . ix bid . blVisible %~ \_ -> 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 _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
-
-pushPointTowardsBy :: RandomGen g => Float -> Point2 -> [Point2] -> State g Point2
-pushPointTowardsBy x p ps = do
-    xs <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps))
-    let toAdd p' y = y *.* (p' -.- p)
-    return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
-
-shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2]
-shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps
-
-
-addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
-addBlock (p:ps) hp col isSeeThrough degradability w 
-    | hp <= 0 && degradability == [] = w
-    | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
-    | otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
-      $ over walls (IM.union blocks) w
---addBlock (p:p':ps) w = over walls (IM.insert i b) w
-    where 
-        lines = zip (p:ps) (ps ++ [p])
-        i = newKey $ _walls w
-        is = [i.. i + length lines-1]
-        blocks = IM.fromList $ zip is 
-                  $ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
-                                               , _wlID = j
-                                            --   , _wlColor = greyN 0.5
-                                               , _wlColor = col
-                                               , _wlDraw = Nothing
-                                               , _wlSeen = False
-                                               , _blIDs = is
-                                               , _blHP = hp
-                                               , _wlIsSeeThrough = isSeeThrough
-                                               , _blVisible = True
-                                               , _blShadows = []
-                                               , _blDegrades = degradability
-                                               }
-                             ) is lines
-        wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
-                          = insertIMInZone x y wlid wl
-                      | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
-          where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
-                wlid  = _wlID wl
-                ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
-        

src/Dodge/Data.hs

@@ -577,6 +577,7 @@ data Wall
         , _blVisible :: Bool
         , _blShadows :: [Int]
         , _blDegrades :: [Int]
+        , _wlCastShadow :: Bool
         }
     | MultiBlock
         { _wlLine :: [Point2]
@@ -587,17 +588,6 @@ data Wall
         , _subWalls :: [Wall]
         }
 
-data Block' = Block'
-    { _blPoly  :: [Point2]
-    , _blLines :: [[Point2]]
-    , _blColor :: Color
-    , _blSeen  :: Bool
-    , _blHP'   :: [Int]
-    , _blVisible' :: Bool
-    , _blShadows' :: [Int]
-    , _blID :: Int
-    }
-
 data ForceField = FF { _ffLine :: [Point2] , _ffID :: Int 
                      , _ffColor :: Color
                      , _ffDeflect :: Maybe (StdGen -> Point2 -> ForceField -> (Point2,StdGen))

src/Dodge/LevelGen.hs

@@ -13,7 +13,7 @@ import Dodge.Data
 import Dodge.Base
 import Dodge.SoundLogic
 import Dodge.Prototypes
-import Dodge.Block
+import Dodge.LevelGen.Block
 
 import Dodge.LevelGen.StaticWalls
 
@@ -303,6 +303,11 @@ removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
           insertPoint  pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
           newGraph = pairsToGraph dist pg'
 
+putBlockWallPart :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
+putBlockWallPart (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
+    where pairs = zip (p:ps) (ps ++ [p])
+          wWithBlock = addBlock (p:ps) i c b is w
+
 putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
 putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
     where pairs = zip (p:ps) (ps ++ [p])
@@ -338,50 +343,29 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
                            | otherwise = False
                 isRightmost | i == numPoints = True
                             | otherwise = False
-                l = Block 
+                l = baseBlock 
                         { _wlLine = [bl,tl]
                         , _wlID = k0
-                        , _wlColor = winCol
-                        , _wlDraw = Nothing
-                        , _wlSeen = False
-                        , _blIDs = ksAtN i
-                        , _blHP = hp
-                        , _wlIsSeeThrough = True
-                        --, _blVisible = False
                         , _blVisible = isLeftmost
-                        , _blShadows = shadows
-                        , _blDegrades = degradeHP
                         }
-                t = Block 
+                t = baseBlock 
                         { _wlLine = [tl,tr]
                         , _wlID = k1
-                        , _wlColor = winCol
-                        , _wlDraw = Nothing
-                        , _wlSeen = False
-                        , _blIDs = ksAtN i
-                        , _blHP = hp
-                        , _wlIsSeeThrough = True
                         , _blVisible = seen
-                        , _blShadows = shadows
-                        , _blDegrades = degradeHP
                         }
-                r = Block 
+                r = baseBlock 
                         { _wlLine = [tr,br]
                         , _wlID = k2
-                        , _wlColor = winCol
-                        , _wlDraw = Nothing
-                        , _wlSeen = False
-                        , _blIDs = ksAtN i
-                        , _blHP = hp
-                        , _wlIsSeeThrough = True
-                        --, _blVisible = False
                         , _blVisible = isRightmost
-                        , _blShadows = shadows
-                        , _blDegrades = degradeHP
                         }
-                b = Block 
+                b = baseBlock 
                         { _wlLine = [br,bl]
                         , _wlID = k3
+                        , _blVisible = seen
+                        }
+                baseBlock = Block
+                        { _wlLine = []
+                        , _wlID = 0
                         , _wlColor = winCol
                         , _wlDraw = Nothing
                         , _wlSeen = False
@@ -391,6 +375,7 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
                         , _blVisible = seen
                         , _blShadows = shadows
                         , _blDegrades = degradeHP
+                        , _wlCastShadow = False
                         }
                 f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
             in  over walls f w

src/Dodge/Rendering.hs

@@ -568,8 +568,11 @@ wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
                         $ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
     where linePairs (x:y:z:w:_) = (x,y,z,w)
           linePairs (x:y:_) = (x,y,x,y)
-          wallCastsShadow (AutoDoor {_wlCastShadow = b}) = b
+          wallCastsShadow wl = case wl ^? wlCastShadow of
-          wallCastsShadow _ = True
+                                Just b  -> b
+                                Nothing -> True
+--(AutoDoor {_wlCastShadow = b}) = b
+--          wallCastsShadow _ = True
 
 wallsForGloom' :: World -> [(Point2,Point2)]
 wallsForGloom' w = map (wallPairBack . _wlLine) $ filter (not . _wlIsSeeThrough) 

src/Dodge/Update.hs

@@ -3,7 +3,7 @@ module Dodge.Update where
 import Dodge.Data
 import Dodge.Base
 import Dodge.WallCreatureCollisions
-import Dodge.Block
+import Dodge.LevelGen.Block
 import Dodge.Camera
 import Dodge.SoundLogic