194 lines
8.2 KiB
Haskell
194 lines
8.2 KiB
Haskell
module Dodge.Update where
|
|
-- imports {{{
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.WallCreatureCollisions
|
|
import Dodge.LevelGen.Block
|
|
import Dodge.Update.Camera
|
|
import Dodge.SoundLogic
|
|
import Dodge.Inventory
|
|
|
|
import Geometry
|
|
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import qualified Data.Set as S
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.Map as M
|
|
|
|
import Control.Lens
|
|
|
|
|
|
-- }}}
|
|
|
|
update :: World -> World
|
|
update w
|
|
| _menuState w /= InGame = w
|
|
| otherwise =
|
|
let w1 = updateParticles' $ updateParticles
|
|
$ updateLightSources
|
|
$ zoneClouds
|
|
$ updateClouds
|
|
$ updateSmoke
|
|
$ updateCreatures
|
|
$ updateBlocks -- $ zoning
|
|
$ updateSeenWalls
|
|
$ updateSoundQueue
|
|
$ updateCloseObjects
|
|
w
|
|
w2 = -- updateWeaponCounters $
|
|
simpleCrSprings
|
|
$ zoneCreatures $ wallEvents
|
|
$ set worldEvents id $ _worldEvents w1
|
|
w1
|
|
w3 = updateCamera
|
|
$ colCrsWalls
|
|
w2
|
|
in checkEndGame $ ppEvents w3
|
|
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
|
|
-- w
|
|
-- 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)
|
|
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
|
|
creatureInZone cr = insertIMInZone x y cid cr
|
|
where (x,y) = zoneOfPoint $ _crPos cr
|
|
cid = _crID cr
|
|
zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
|
|
cloudInZone cr = insertIMInZone x y cid cr
|
|
where (x,y) = zoneOfPoint $ _clPos cr
|
|
cid = _clID cr
|
|
|
|
updateSoundQueue = set soundQueue []
|
|
. set sounds M.empty
|
|
|
|
updateLightSources w = set tempLightSources (catMaybes tlss) w'
|
|
where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
|
|
|
|
updateParticles w = IM.foldr' _ptUpdate w $ _particles w
|
|
|
|
updateSmoke :: World -> World
|
|
updateSmoke w = w & smoke %~ mapMaybe (\s -> _smUpdate s s)
|
|
|
|
updateParticles' :: World -> World
|
|
updateParticles' w = set particles' (catMaybes ps) w'
|
|
where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
|
|
|
|
updateCreatures :: World -> World
|
|
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
|
|
where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
|
|
|
|
|
|
wallEvents :: World -> World
|
|
wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of
|
|
Door {} -> True
|
|
BlockAutoDoor {} -> True
|
|
_ -> False) ( _walls w))
|
|
|
|
ppEvents :: World -> World
|
|
ppEvents w = IM.foldr' (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
|
|
|
|
updateSeenWalls :: World -> World
|
|
updateSeenWalls w = foldr markSeen w wallsToUpdate
|
|
where yPos = _crPos $ _creatures w IM.! 0
|
|
wallsToUpdate = map _wlID $ IM.elems $ wallsNearPoint yPos w
|
|
-- wallsToUpdate = concatMap (\p -> collidePointFindWalls yPos (yPos +.+p) $ wallsAlongLine yPos (yPos +.+ p) w)
|
|
-- $ nRays 60
|
|
markSeen i = set (walls . ix i . wlSeen) True
|
|
|
|
setTestStringIO :: IO World -> IO World
|
|
setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
|
|
where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
|
|
-- w --do numC <- Mix.numChannelsPlaying
|
|
-- w' <- w
|
|
-- let ycr = _creatures w' IM.! 0
|
|
-- let st = _stance $ _crState ycr
|
|
-- let vel = magV $ _crPos ycr -.- _crOldPos ycr
|
|
-- let (x,y) = zoneOfPoint $ _crPos ycr
|
|
-- --fmap (set testString $ show (map _wlLine $ IM.elems $ _wallsZone w' IM.! x IM.! y)) w
|
|
-- fmap (set testString $ show $ last $ show $ pairsToIncidence' $ _pathGraph' w') w
|
|
|
|
-- update logic: creature old position set, creatures perform actions including movement,
|
|
-- creatures collided with each other, camera updated, particles updated, creatures
|
|
-- collided with walls
|
|
|
|
|
|
checkEndGame :: World -> World
|
|
checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuState = GameOverMenu}
|
|
| otherwise = w
|
|
|
|
updateClouds :: World -> World
|
|
updateClouds w = IM.foldr' updateCloud w $ _clouds w
|
|
|
|
updateCloud :: Cloud -> World -> World
|
|
updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
|
|
| otherwise = moveCloud c w
|
|
|
|
moveCloud :: Cloud -> World -> World
|
|
moveCloud c w = _clEffect c c . theUpdate $ w
|
|
where newVel = 0.99 *.* springVels
|
|
springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w)
|
|
oldPos = _clPos c
|
|
newPos = oldPos +.+ newVel
|
|
hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
|
|
finalPos = fromMaybe newPos (fmap fst hitWl)
|
|
finalVel = fromMaybe newVel (fmap snd hitWl)
|
|
theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
|
|
& clouds . ix (_clID c) . clVel .~ finalVel
|
|
& clouds . ix (_clID c) . clPos .~ finalPos
|
|
|
|
clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2
|
|
clClSpringVel a w b v
|
|
| ida == idb = v
|
|
| dist pa pb < 5 = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb))
|
|
| otherwise = v
|
|
where ida = _clID a
|
|
idb = _clID b
|
|
pa = _clPos a
|
|
pb = _clPos b
|
|
|
|
simpleCrSprings :: World -> World
|
|
simpleCrSprings w = IM.foldr' crSpring w $ _creatures w
|
|
|
|
crSpring :: Creature -> World -> World
|
|
crSpring c w = IM.foldr' (crCrSpring c) w $ cs
|
|
where cs = creaturesNearPoint (_crPos c) w
|
|
|
|
crCrSpring :: Creature -> Creature -> World -> World
|
|
crCrSpring c1 c2 w
|
|
| id1 == id2 = w
|
|
| vec == (0,0) = w
|
|
| diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
|
|
$ over (creatures . ix id2 . crPos) (-.- overlap2) w
|
|
| otherwise = w
|
|
where id1 = _crID c1
|
|
id2 = _crID c2
|
|
vec = _crPos c1 -.- _crPos c2
|
|
diff = magV $ vec
|
|
comRad = _crRad c1 + _crRad c2
|
|
overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
|
|
overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
|
|
massT = _crMass c1 + _crMass c2
|
|
|
|
collidePointFindWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Int
|
|
collidePointFindWall p1 p2 ws = fmap fst $ listToMaybe $ sortBy f
|
|
$ IM.toList
|
|
$ IM.mapMaybe ((\(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
|
|
where f (_,a) (_,b) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
|
|
|
|
collidePointFindWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
|
|
collidePointFindWalls p1 p2 ws
|
|
-- = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fst . fromJust)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
|
|
= map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fromJust . fst)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
|
|
where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
|
|
g (_,wl) = _wlIsSeeThrough wl
|
|
takeWhileAnd h xs = let (ys,zs) = span h xs
|
|
in ys ++ tf zs
|
|
where tf (x:_) = [x]
|
|
tf _ = []
|
|
|