105 lines
5.0 KiB
Haskell
105 lines
5.0 KiB
Haskell
{-# 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)
|
|
|