Add source files, commit before reverting pictures to lists
This commit is contained in:
@@ -0,0 +1,190 @@
|
||||
module Dodge.Update where
|
||||
-- imports {{{
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.WallCreatureCollisions
|
||||
import Dodge.Block
|
||||
import Dodge.Camera
|
||||
import Dodge.SoundLogic
|
||||
|
||||
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 = let w1 = updateParticles' $ updateParticles
|
||||
$ updateLightSources
|
||||
$ zoneClouds
|
||||
$ updateClouds
|
||||
$ updateSmoke
|
||||
$ updateCreatures
|
||||
$ updateBlocks -- $ zoning
|
||||
$ updateSeenWalls
|
||||
w
|
||||
w2 = -- updateWeaponCounters $
|
||||
simpleCrSprings
|
||||
$ zoneCreatures $ wallEvents
|
||||
$ set worldEvents id $ _worldEvents w1
|
||||
w1
|
||||
w3 = updateCamera
|
||||
$ updateAfterParticles'
|
||||
$ 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
|
||||
|
||||
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
|
||||
|
||||
updateAfterParticles' :: World -> World
|
||||
updateAfterParticles' w = set afterParticles' (catMaybes ps) w'
|
||||
where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _afterParticles' 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
|
||||
AutoDoor {} -> 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 _ = []
|
||||
|
||||
Reference in New Issue
Block a user