justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Reorganise block module

Browse Source
This commit is contained in:
jgk
2021-03-05 20:24:12 +01:00
parent fdca8a8760
commit bd16ad2a2a
5 changed files with 23 additions and 149 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block.hs
-104
View File
@@ -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
+1 -11
View File
@@ -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
+16 -31
View File
@@ -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
+5 -2
View File
@@ -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)
src/Dodge/Update.hs
+1 -1
View File
@@ -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