312 lines
9.8 KiB
Haskell
312 lines
9.8 KiB
Haskell
{- |
|
|
Module : Dodge.Update
|
|
Description : Simulation update
|
|
-}
|
|
module Dodge.Update
|
|
( update
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Menu
|
|
import Dodge.Config.Data
|
|
import Dodge.Base
|
|
import Dodge.Zone
|
|
import Dodge.WallCreatureCollisions
|
|
import Dodge.Update.Camera
|
|
import Dodge.SoundLogic
|
|
import Dodge.Inventory
|
|
import Dodge.WorldEvent.Sound
|
|
import Dodge.Wall.Delete
|
|
import Geometry
|
|
import Geometry.ConvexPoly
|
|
import Geometry.Vector3D
|
|
|
|
import SDL (MouseButton (..))
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Function
|
|
import qualified Data.Set as S
|
|
import qualified Data.IntSet as IS
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Control.Lens
|
|
import Data.Monoid
|
|
import System.Random
|
|
|
|
update :: World -> World
|
|
update = (frameClock +~ 1) . functionalUpdate
|
|
|
|
{- |
|
|
The update step.
|
|
For most menus the only way to change the world is using event handling. -}
|
|
functionalUpdate :: World -> World
|
|
functionalUpdate w = case _menuLayers w of
|
|
(TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls)
|
|
(WaitScreen s i : _)
|
|
| i < 1 -> w & dbArg _worldEvents
|
|
| otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
|
|
(OptionScreen {_scOptionFlag = GameOverOptions} : _) -> updateParticles
|
|
. updateProjectiles
|
|
. updateLightSources
|
|
$ updateClouds
|
|
w
|
|
(_ : _) -> w
|
|
[] -> checkEndGame
|
|
. updateRadialDistortions
|
|
. ppEvents
|
|
. updateCamera
|
|
. colCrsWalls
|
|
. ifConfigWallRotate
|
|
. simpleCrSprings
|
|
. zoneCreatures
|
|
. updateDoors
|
|
. resetWorldEvents
|
|
. dbArg _worldEvents
|
|
. updateParticles
|
|
. updateProjectiles
|
|
. updateLightSources
|
|
. updateClouds
|
|
. zoneClouds
|
|
. updateMachines
|
|
. updateCreatures
|
|
. updateCreatureGroups
|
|
. updateBlocks
|
|
. updateSeenWalls
|
|
$ updateCloseObjects w
|
|
where
|
|
--updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
|
|
zoneCreatures = set (creaturesZone . znObjects)
|
|
(IM.foldl' (flip creatureInZone) IM.empty (_creatures w))
|
|
creatureInZone cr = insertIMInZone x y cid cr
|
|
where
|
|
(x,y) = crZoneOfPoint $ _crPos cr
|
|
cid = _crID cr
|
|
zoneClouds = set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
|
|
cloudInZone cl = insertInZoneWith x y (++) [cl]
|
|
where
|
|
(x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
|
|
|
|
splinterBlock :: Block -> World -> World
|
|
splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
|
|
& blocks . ix (_blID bl) . blHPs %~ tail
|
|
& theSoundEffect cen
|
|
where
|
|
wls = map (_walls w IM.!) (IS.toList $ _blWallIDs bl)
|
|
ps = map (fst . _wlLine) wls
|
|
cen = centroid ps
|
|
theSoundEffect
|
|
| _wlOpacity (head wls) == SeeThrough = mkSoundSplinterGlass
|
|
| otherwise = mkSoundSplinterBlock
|
|
|
|
unshadowBlock :: Int -> World -> World
|
|
unshadowBlock wlid w = case w ^? walls . ix wlid of
|
|
Just wl -> w
|
|
& walls . ix wlid . wlDraw .~ True
|
|
& wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
|
|
where
|
|
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
|
|
Nothing -> w
|
|
|
|
updateBlocks :: World -> World
|
|
updateBlocks w = foldr f w $ _blocks w
|
|
where
|
|
f bl w' = case _blHPs bl of
|
|
(x:_:_) | x < 1 -> splinterBlock bl w'
|
|
[x] | x < 1 -> destroyBlock bl w'
|
|
_ -> w'
|
|
|
|
destroyBlock :: Block -> World -> World
|
|
destroyBlock bl w = w
|
|
& deleteWallIDs wlids
|
|
& blocks %~ IM.delete (_blID bl)
|
|
& mkSoundBreakGlass pos
|
|
where
|
|
wlids = _blWallIDs bl
|
|
pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
|
|
|
|
-- | Note the explict use of record syntax. Using lens created a space leak.
|
|
resetWorldEvents :: World -> World
|
|
resetWorldEvents w = w {_worldEvents = id}
|
|
|
|
updateCreatureGroups :: World -> World
|
|
updateCreatureGroups w = w & creatureGroups %~
|
|
IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp)
|
|
|
|
updateRadialDistortions :: World -> World
|
|
updateRadialDistortions = radDistortion %~ mapMaybe decreaseBulge
|
|
|
|
decreaseBulge
|
|
:: (Point2,Point2,Point2,Float)
|
|
-> Maybe (Point2,Point2,Point2,Float)
|
|
decreaseBulge (a,b,c,v)
|
|
| v > 1 = Just (a,b,c,max 1 (v - 0.05) )
|
|
| v < 1 = Just (a,b,c,min 1 (v + 0.05) )
|
|
| otherwise = Nothing
|
|
|
|
updateLightSources :: World -> World
|
|
updateLightSources w = over tempLightSources f w
|
|
where
|
|
f = mapMaybe (\b -> _tlsUpdate b w b)
|
|
|
|
updateProjectiles :: World -> World
|
|
updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props w
|
|
|
|
{- Apply internal particle updates, delete 'Nothing's. -}
|
|
updateParticles :: World -> World
|
|
updateParticles w = set particles (catMaybes ps) w'
|
|
where
|
|
(w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
|
|
|
|
updateMachines :: World -> World
|
|
updateMachines w = foldr f w (_machines w)
|
|
where
|
|
f mc = _mcUpdate mc mc
|
|
|
|
-- Note that this updates the randgen
|
|
updateCreatures :: World -> World
|
|
updateCreatures w = appEndo f $ w
|
|
& creatures .~ IM.mapMaybe id m
|
|
& randGen .~ newg
|
|
where
|
|
((f,newg),m) = mapAccumR crUp (Endo id,_randGen w) (_creatures w)
|
|
crUp (f',g) cr = ((f' <> f'',g'), cr')
|
|
where
|
|
(f'',cr') = _crUpdate cr cr (w & randGen .~ g)
|
|
(_,g') = genWord8 g
|
|
|
|
updateDoors :: World -> World
|
|
updateDoors w = IM.foldl' (\w' dr -> _drMech dr dr w') w (_doors w)
|
|
|
|
ppEvents :: World -> World
|
|
ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w
|
|
|
|
updateSeenWalls :: World -> World
|
|
updateSeenWalls w = foldl' markWallSeen w wallsToUpdate
|
|
where
|
|
vPos = _cameraViewFrom w
|
|
wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
|
|
$ nRays 20
|
|
|
|
markWallSeen :: World -> Wall -> World
|
|
markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w }
|
|
where
|
|
mw wl' = wl' {_wlSeen = True}
|
|
|
|
checkEndGame :: World -> World
|
|
checkEndGame w
|
|
| _crHP (you w) < 1 = haltSound $ w {_menuLayers = [gameOverMenu]}
|
|
| otherwise = w
|
|
|
|
updateClouds :: World -> World
|
|
updateClouds w = w' & clouds .~ catMaybes mclouds
|
|
where
|
|
(w',mclouds) = mapAccumR updateCloud w (_clouds w)
|
|
|
|
updateCloud :: World -> Cloud -> (World,Maybe Cloud)
|
|
updateCloud w c
|
|
| _clTimer c < 1 = (w, Nothing)
|
|
| otherwise = (_clEffect c c w, Just $ c
|
|
& clPos .~ finalPos
|
|
& clVel .~ finalVel
|
|
& clTimer -~ 1
|
|
)
|
|
where
|
|
newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ V3 0 0 (0.001 * vertVel)
|
|
newVel2 = stripZ newVel
|
|
vertVel = _clAlt c - opz
|
|
springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos2 w)
|
|
oldPos@(V3 _ _ opz) = _clPos c
|
|
oldPos2 = stripZ oldPos
|
|
newPos@(V3 _ _ npz) = oldPos +.+.+ newVel
|
|
newPos2 = stripZ newPos
|
|
-- the following only tests for the first collision with a wall
|
|
hitWl = collidePointAnyWallsReflect oldPos2 newPos2 $ wallsNearPoint newPos2 w
|
|
finalPos = addZ npz $ maybe newPos2 fst hitWl
|
|
finalVel = addZ nvz $ maybe newVel2 snd hitWl
|
|
|
|
--updateCloud :: World -> Cloud -> Maybe Cloud
|
|
--updateCloud w c
|
|
-- | _clTimer c < 1 = Nothing
|
|
-- | otherwise = Just $ c
|
|
-- & clPos .~ finalPos
|
|
-- & clVel .~ finalVel
|
|
-- & clTimer -~ 1
|
|
-- where
|
|
-- newVel = 0.95 *.* springVels
|
|
-- springVels = foldl' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w)
|
|
-- oldPos = _clPos c
|
|
-- newPos = oldPos +.+ newVel
|
|
-- hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
|
|
-- finalPos = maybe newPos fst hitWl
|
|
-- finalVel = maybe newVel snd hitWl
|
|
|
|
clClSpringVel :: Cloud -> Point3 -> Cloud -> Point3
|
|
clClSpringVel a v b
|
|
| dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb)
|
|
| otherwise = v
|
|
where
|
|
pa = _clPos a
|
|
pb = _clPos b
|
|
radDist = (_clRad a + _clRad b) / 2
|
|
|
|
simpleCrSprings :: World -> World
|
|
simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
|
|
|
|
crSpring :: Creature -> World -> World
|
|
crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
|
|
where
|
|
cs = creaturesNearPoint (_crPos c) w
|
|
|
|
crCrSpring :: Creature -> Creature -> World -> World
|
|
crCrSpring c1 c2 w
|
|
| id1 == id2 = w
|
|
| vec == V2 0 0 = w
|
|
| diff >= comRad = w
|
|
| otherwise = over creatures
|
|
( over (ix id1 . crPos) (+.+ overlap1)
|
|
. over (ix id2 . crPos) (-.- overlap2)
|
|
) 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
|
|
|
|
ifConfigWallRotate :: World -> World
|
|
ifConfigWallRotate w
|
|
| _rotate_to_wall (_config w) && not (ButtonRight `S.member` _mouseButtons w)
|
|
= rotateToOverlappingWall w
|
|
| otherwise = w
|
|
|
|
rotateToOverlappingWall :: World -> World
|
|
rotateToOverlappingWall w = case theWall of
|
|
Nothing -> w
|
|
Just wl -> rotateUsing ( (argV . uncurry (-.-) $ _wlLine wl) - camrot)
|
|
where
|
|
camrot = _cameraRot w
|
|
rotateUsing a
|
|
| b - b' > 0.01 = w & cameraRot +~ 0.01
|
|
| b - b' < negate 0.01 = w & cameraRot -~ 0.01
|
|
| otherwise = w
|
|
where
|
|
b = a * (2 / pi)
|
|
b' = fromIntegral (round b :: Int)
|
|
cr = you w
|
|
p = _crPos cr
|
|
theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
|
|
|
|
{- Finds the visible walls from a point to another point. -}
|
|
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
|
|
visibleWalls p1 p2 ws
|
|
= takeUntil theTest
|
|
. map snd
|
|
. sortOn (dist p1 . fromJust . fst)
|
|
. filter (isJust . fst)
|
|
. map f
|
|
$ IM.elems ws
|
|
where
|
|
f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl)
|
|
theTest wl = _wlOpacity wl /= Opaque
|