From bd16ad2a2a1f1830805cd2068c6d8d3fa93490c2 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 5 Mar 2021 20:24:12 +0100 Subject: [PATCH] Reorganise block module --- src/Dodge/Block.hs | 104 ----------------------------------------- src/Dodge/Data.hs | 12 +---- src/Dodge/LevelGen.hs | 47 +++++++------------ src/Dodge/Rendering.hs | 7 ++- src/Dodge/Update.hs | 2 +- 5 files changed, 23 insertions(+), 149 deletions(-) delete mode 100644 src/Dodge/Block.hs diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs deleted file mode 100644 index fb48bad5d..000000000 --- a/src/Dodge/Block.hs +++ /dev/null @@ -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) - diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 789cdf425..7e38db3b1 100644 --- a/src/Dodge/Data.hs +++ b/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)) diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index d940d49ee..7bb0846a9 100644 --- a/src/Dodge/LevelGen.hs +++ b/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 diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index c798cb6f9..9b582ae0e 100644 --- a/src/Dodge/Rendering.hs +++ b/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 _ = True + wallCastsShadow wl = case wl ^? wlCastShadow of + Just b -> b + Nothing -> True +--(AutoDoor {_wlCastShadow = b}) = b +-- wallCastsShadow _ = True wallsForGloom' :: World -> [(Point2,Point2)] wallsForGloom' w = map (wallPairBack . _wlLine) $ filter (not . _wlIsSeeThrough) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 12bd715eb..fbfcfb0cb 100644 --- a/src/Dodge/Update.hs +++ b/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