Linting, haddocking
This commit is contained in:
@@ -1,68 +1,87 @@
|
||||
{-
|
||||
Creation of doors that open when creatures approach them.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.LevelGen.AutoDoor
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
|
||||
import Dodge.Creature.Property
|
||||
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
import Control.Lens
|
||||
import Control.DeepSeq (deepseq)
|
||||
|
||||
addAutoDoor :: Point2 -> Point2 -> World -> World
|
||||
addAutoDoor
|
||||
:: Point2 -- ^ Left point
|
||||
-> Point2 -- ^ Right point (though the two points should be symmetric)
|
||||
-> World
|
||||
-> World
|
||||
addAutoDoor a b = over walls (autoDoorAt a b)
|
||||
|
||||
autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
autoDoorAt
|
||||
:: Point2 -- ^ Left point
|
||||
-> Point2 -- ^ Right point (though the two points should be symmetric)
|
||||
-> IM.IntMap Wall
|
||||
-> IM.IntMap Wall
|
||||
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
|
||||
where i = newKey wls
|
||||
is = [i..]
|
||||
where
|
||||
i = newKey wls
|
||||
is = [i..]
|
||||
|
||||
mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
|
||||
mkAutoDoor
|
||||
:: Point2 -- ^ Left point
|
||||
-> Point2 -- ^ Right point (though the two points should be symmetric)
|
||||
-> [Int] -- ^ Wall ids
|
||||
-> [Wall]
|
||||
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
|
||||
xs
|
||||
(lDoorClosed ++ rDoorClosed)
|
||||
(map shiftL lDoorClosed ++ map shiftR rDoorClosed)
|
||||
where lDoorClosed = [ [pld,hwd]
|
||||
, [hwd,hwu]
|
||||
, [hwu,plu]
|
||||
]
|
||||
rDoorClosed = [ [pru,hwu]
|
||||
, [hwu,hwd]
|
||||
, [hwd,prd]
|
||||
]
|
||||
norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
||||
hw = 0.5 *.* (pl +.+ pr)
|
||||
parallel = 0.5 *.* (pl -.- pr)
|
||||
plu = pl +.+ norm
|
||||
pld = pl -.- norm
|
||||
pru = pr +.+ norm
|
||||
prd = pr -.- norm
|
||||
hwu = hw +.+ norm
|
||||
hwd = hw -.- norm
|
||||
shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
|
||||
shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
|
||||
where
|
||||
lDoorClosed = [ [pld,hwd]
|
||||
, [hwd,hwu]
|
||||
, [hwu,plu]
|
||||
]
|
||||
rDoorClosed = [ [pru,hwu]
|
||||
, [hwu,hwd]
|
||||
, [hwd,prd]
|
||||
]
|
||||
norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
||||
hw = 0.5 *.* (pl +.+ pr)
|
||||
parallel = 0.5 *.* (pl -.- pr)
|
||||
plu = pl +.+ norm
|
||||
pld = pl -.- norm
|
||||
pru = pr +.+ norm
|
||||
prd = pr -.- norm
|
||||
hwu = hw +.+ norm
|
||||
hwd = hw -.- norm
|
||||
shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
|
||||
shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
|
||||
|
||||
addSound (x:xs) = f x : xs
|
||||
f wl = over doorMech g wl
|
||||
g dm w | dist wp pld > 1 && dist wp hwd > 1
|
||||
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
|
||||
| otherwise = dm w
|
||||
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
|
||||
addSound (x:xs) = f x : xs
|
||||
f wl = over doorMech g wl
|
||||
g dm w | dist wp pld > 2 && dist wp hwd > 2
|
||||
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
|
||||
| otherwise = dm w
|
||||
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
|
||||
|
||||
autoDoorPane :: (Point2,Point2) -> Int -> [Point2] -> [Point2] -> Wall
|
||||
autoDoorPane
|
||||
:: (Point2,Point2) -- ^ Trigger line
|
||||
-> Int -- ^ Wall id
|
||||
-> [Point2] -- ^ Closed position
|
||||
-> [Point2] -- ^ Open position
|
||||
-> Wall
|
||||
autoDoorPane (trigx,trigy) n closedPos openPos = Door
|
||||
{ _wlLine = closedPos
|
||||
, _wlID = n
|
||||
, _doorMech = dm
|
||||
, _wlColor = dim $ yellow
|
||||
, _wlColor = dim yellow
|
||||
, _wlSeen = False
|
||||
, _wlIsSeeThrough = False
|
||||
, _doorPathable = True
|
||||
@@ -70,22 +89,18 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
|
||||
where
|
||||
a = closedPos !! 0
|
||||
b = closedPos !! 1
|
||||
dm w | any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
|
||||
-- crsNearLine 40 trigL w
|
||||
= flip (foldr changeZonedWall) zoneps
|
||||
$ over walls (IM.adjust openDoor n) w
|
||||
| otherwise = flip (foldr changeZonedWall') zoneps
|
||||
$ over walls (IM.adjust closeDoor n) w
|
||||
dm w
|
||||
| any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
|
||||
= flip (foldr changeZonedWall) zoneps $ over walls (IM.adjust openDoor n) w
|
||||
| otherwise
|
||||
= flip (foldr changeZonedWall') zoneps $ over walls (IM.adjust closeDoor n) w
|
||||
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
|
||||
moveToward :: [Point2] -> Wall -> Wall
|
||||
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
|
||||
in deepseq newPs $ w {_wlLine = newPs}
|
||||
--deepseq ps $ w & wlLine %~ zipWith mvP ps
|
||||
openDoor = moveToward openPos
|
||||
in deepseq newPs $ w {_wlLine = newPs}
|
||||
openDoor = moveToward openPos
|
||||
closeDoor = moveToward closedPos
|
||||
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
|
||||
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
|
||||
changeZonedWall (!x,!y)
|
||||
= over wallsZone $ adjustIMZone openDoor x y n
|
||||
changeZonedWall' (!x,!y)
|
||||
= over wallsZone $ adjustIMZone closeDoor x y n
|
||||
changeZonedWall (!x,!y) = over wallsZone $ adjustIMZone openDoor x y n
|
||||
changeZonedWall' (!x,!y) = over wallsZone $ adjustIMZone closeDoor x y n
|
||||
|
||||
+95
-114
@@ -1,149 +1,130 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-
|
||||
Creation, update and descruction of destructible walls.
|
||||
-}
|
||||
module Dodge.LevelGen.Block where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
|
||||
import Dodge.WorldEvent.Sound
|
||||
|
||||
import Dodge.LevelGen.Pathing
|
||||
|
||||
import Geometry
|
||||
import Picture.Data
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Control.Monad.State
|
||||
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
|
||||
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)
|
||||
(_blShadows bl)
|
||||
$ w
|
||||
where
|
||||
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
|
||||
f bl = hitSound' bl
|
||||
pos = _wlLine bl !! 0
|
||||
hitSound bl | _wlIsSeeThrough bl = mkSoundBreakGlass pos
|
||||
| otherwise = soundMultiFrom sos soundid 25 0
|
||||
hitSound' bl | _wlIsSeeThrough bl = mkSoundSplinterGlass pos
|
||||
| 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)
|
||||
& walls . ix bid . blVisible %~ \_ -> True
|
||||
Nothing -> w
|
||||
killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
|
||||
where
|
||||
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
|
||||
f bl = hitSound' bl
|
||||
pos = _wlLine bl !! 0
|
||||
hitSound bl
|
||||
| _wlIsSeeThrough bl = mkSoundBreakGlass pos
|
||||
| otherwise = soundMultiFrom sos soundid 25 0
|
||||
hitSound' bl
|
||||
| _wlIsSeeThrough bl = mkSoundSplinterGlass pos
|
||||
| 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 %~ 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 _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 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
|
||||
{-
|
||||
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 <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps))
|
||||
xs <- replicateM (length ps) $ 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
|
||||
shrinkPolygon
|
||||
:: RandomGen g
|
||||
=> Float -- ^ Shrink parameter
|
||||
-> [Point2]
|
||||
-> State g [Point2]
|
||||
shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
|
||||
|
||||
addBlockNoShadow :: [Point2] -> Int -> Color -> Bool -> [Int] -> Bool -> World -> World
|
||||
addBlockNoShadow (p:ps) hp col isSeeThrough degradability hasAllShadows 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
|
||||
where
|
||||
shadowList | hasAllShadows = repeat True
|
||||
| otherwise = concat $ repeat [False,True]
|
||||
lines = zip (p:ps) (ps ++ [p])
|
||||
i = newKey $ _walls w
|
||||
is = [i.. i + length lines-1]
|
||||
blocks = IM.fromList $ zip is
|
||||
$ zipWith3 (\j (a,b) bool
|
||||
-> Block { _wlLine = [a,b]
|
||||
, _wlID = j
|
||||
-- , _wlColor = greyN 0.5
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _blIDs = is
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = isSeeThrough
|
||||
, _blVisible = True
|
||||
, _blShadows = []
|
||||
, _blDegrades = degradability
|
||||
}
|
||||
) is lines shadowList
|
||||
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)
|
||||
|
||||
addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
|
||||
addBlock
|
||||
:: [Point2] -- ^ Block polygon
|
||||
-> Int -- ^ First layer of health
|
||||
-> Color
|
||||
-> Bool -- ^ Is the block see through?
|
||||
-> [Int] -- ^ Extra layers of health
|
||||
-> World
|
||||
-> World
|
||||
addBlock (p:ps) hp col isSeeThrough degradability w
|
||||
| hp <= 0 && degradability == [] = w
|
||||
| hp <= 0 && null 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
|
||||
, _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)
|
||||
| otherwise = w
|
||||
& wallsZone %~ flip (IM.foldr wallInZone) panes
|
||||
& walls %~ IM.union panes
|
||||
where
|
||||
lines = zip (p:ps) (ps ++ [p])
|
||||
i = newKey $ _walls w
|
||||
is = [i.. i + length lines-1]
|
||||
panes = IM.fromList $ zip is
|
||||
$ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
|
||||
, _wlID = j
|
||||
, _wlColor = col
|
||||
, _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)
|
||||
|
||||
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 = addBlockNoShadow (p:ps) i c b is False 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])
|
||||
|
||||
Reference in New Issue
Block a user