145 lines
5.3 KiB
Haskell
145 lines
5.3 KiB
Haskell
{- | Creation, update and destruction of destructible walls. -}
|
|
module Dodge.LevelGen.Block where
|
|
import Dodge.Data
|
|
import Dodge.Data.SoundOrigin
|
|
import Dodge.Base
|
|
import Dodge.Zone
|
|
import Dodge.SoundLogic
|
|
import Dodge.SoundLogic.LoadSound
|
|
import Dodge.WorldEvent.Sound
|
|
import Dodge.LevelGen.Pathing
|
|
import Dodge.RandomHelp
|
|
import Geometry
|
|
import qualified IntMapHelp as IM
|
|
import Color
|
|
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import System.Random
|
|
|
|
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
|
|
|
|
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)
|
|
|
|
shrinkPolygon
|
|
:: RandomGen g
|
|
=> Float -- ^ Shrink parameter
|
|
-> [Point2]
|
|
-> State g [Point2]
|
|
shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
|
|
|
|
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 && null degradability = w
|
|
| hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
|
|
| otherwise = w
|
|
& wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
|
|
& walls %~ IM.union panes
|
|
where
|
|
lns = zip (p:ps) (ps ++ [p])
|
|
i = IM.newKey $ _walls w
|
|
is = [i.. i + length lns-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 lns
|
|
wallInZone wl
|
|
| uncurry dist (_wlLine wl) <= 2*zoneSize
|
|
= insertIMInZone x y wlid wl
|
|
| otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl)) ips
|
|
where
|
|
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
|
|
wlid = _wlID wl
|
|
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
|
|
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"
|
|
|