--{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {- | Module : Dodge.Update Description : Simulation update -} module Dodge.Update (updateUniverse) where import Dodge.Damage import RandomHelp import Dodge.Data.CrWlID import Dodge.ListDisplayParams import Color import Control.Applicative import Control.Monad import Data.List import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import Dodge.Base import Dodge.Bullet import Dodge.CrGroupUpdate import Dodge.Creature.Update import Dodge.Data.Universe import Dodge.Debug import Dodge.DisplayInventory import Dodge.Distortion import Dodge.DrWdWd import Dodge.EnergyBall import Dodge.Flame import Dodge.Inventory import Dodge.Laser.Update import Dodge.LinearShockwave.Update import Dodge.Machine.Update import Dodge.Menu import Dodge.ModificationEffect import Dodge.PosEvent import Dodge.PressPlate import Dodge.Projectile.Update import Dodge.Prop.Update import Dodge.RadarBlip import Dodge.RadarSweep import Dodge.ScreenPos import Dodge.ScrollValue import Dodge.SelectionSections import Dodge.Shockwave.Update import Dodge.SmoothScroll import Dodge.SoundLogic import Dodge.Spark import Dodge.Terminal.Type import Dodge.TmTm import Dodge.TractorBeam.Update import Dodge.Update.Camera import Dodge.Update.Cloud import Dodge.Update.Input.InGame import Dodge.Update.Input.ScreenLayer import Dodge.Update.Scroll import Dodge.Update.WallDamage import Dodge.WallCreatureCollisions import Dodge.WorldEffect import Dodge.Zoning.Cloud import Dodge.Zoning.Creature import Geometry import qualified IntMapHelp as IM import LensHelp import NewInt import SDL import Sound.Data import StrictHelp updateUniverse :: Universe -> Universe updateUniverse u = updateUniverseLast . updateUniverseMid . debugEvents . updateMouseContext cfig . updateUniverseFirst $ u where cfig = u ^. uvConfig updateUniverseFirst :: Universe -> Universe updateUniverseFirst u = u & uvWorld . input . clickWorldPos %~ M.union (setClickWorldPos u) & uvWorld . input . smoothScrollAmount %~ calcSmoothScroll (u ^. uvWorld . input . scrollAmount) & over (uvWorld . input) updateScrollTestValue & updateDebugMessageOffset & over (uvWorld . cWorld . cClock) (+ 1) updateDebugMessageOffset :: Universe -> Universe updateDebugMessageOffset u | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) = u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount)) | otherwise = u setClickWorldPos :: Universe -> M.Map MouseButton Point2 setClickWorldPos u = fmap (const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos))) (M.filter (== 0) $ u ^. uvWorld . input . mouseButtons) -- the ordering of updating here may be important updateWorldEventFlags :: Universe -> Universe updateWorldEventFlags u = (uvWorld . worldEventFlags .~ mempty) -- for now update inventory positioning every tick -- the question is how often to update the close objects section, and if -- this can be done independently of the other sections $ foldr updateWorldEventFlag (updateInventoryPositioning u) (u ^. uvWorld . worldEventFlags) updateWorldEventFlag :: WorldEventFlag -> Universe -> Universe updateWorldEventFlag wef = case wef of InventoryChange -> id -- updateInventoryPositioning -- for now update inventory positioning every tick CombineInventoryChange -> updateCombinePositioning maybeOpenConsole :: Universe -> Universe maybeOpenConsole u = case u ^. uvWorld . input . pressedKeys . at ScancodeSemicolon of Just InitialPress -> u & uvScreenLayers %~ openConsole _ -> u openConsole :: [ScreenLayer] -> [ScreenLayer] openConsole = \case xs@(InputScreen{} : _) -> xs xs -> InputScreen mempty "Enter command" : xs updateUniverseLast :: Universe -> Universe updateUniverseLast u = u & over (uvWorld . input . textInput) (const mempty) & maybeOpenConsole & advanceScrollAmount & updateWorldEventFlags & uvWorld . input . pressedKeys . each %~ f & uvWorld . input . mouseMoving .~ False & uvWorld . input . mouseButtons . each +~ 1 & uvWorld . input . mouseButtonsReleased . each +~ 1 & uvWorld . input . heldPos %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons)) & uvWorld . input . heldWorldPos %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons)) where mp = u ^. uvWorld . input . mousePos mwp = screenToWorldPos (u ^. uvWorld . wCam) mp f LongPress = LongPress f _ = ShortPress {- For most menus the only way to change the world is using event handling. -} updateUniverseMid :: Universe -> Universe updateUniverseMid u = case _uvScreenLayers u of (OptionScreen{_scOptionFlag = LoadingScreen} : _) -> u -- (sl@OptionScreen{_scOptionFlag = GameOverOptions} : _) -> u & updateUseInputOnScreen sl (sl : _) -> u & uvWorld . unpauseClock .~ 0 & updateUseInputOnScreen sl [] -> (uvWorld . unpauseClock +~ 1) . timeFlowUpdate . updateUseInputInGame . over uvWorld (updateMouseInGame (u ^. uvConfig)) $ over uvWorld (updateCamera (u ^. uvConfig)) u timeFlowUpdate :: Universe -> Universe timeFlowUpdate u = case u ^. uvWorld . timeFlow of NormalTimeFlow -> functionalUpdate u ItemScrollTimeFlow smoothing _ _ _ -> over uvWorld (doItemTimeScroll smoothing) u CameraScrollTimeFlow smoothing _ _ | SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) -> over uvWorld (doTimeScroll smoothing) u CameraScrollTimeFlow{} -> u RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow DeathTime{} -> u PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u pauseTime :: NewInt ItmInt -> World -> World --pauseTime itmloc w pauseTime _ w -- | justPressedButtonLeft || outofcharge = w & timeFlow .~ NormalTimeFlow | justPressedButtonLeft = w & timeFlow .~ NormalTimeFlow | otherwise = w -- & pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix (_unNInt itmloc)) . itUse . leftConsumption . wpCharge -~ 1 where justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just 0 -- outofcharge = maybe True (== 0) charge -- charge = w ^? pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix (_unNInt itmloc)) . itUse . leftConsumption . wpCharge doItemTimeScroll :: Int -> World -> World doItemTimeScroll smoothing w = case w ^? input . mouseButtons . ix ButtonLeft of Just 0 -> w & timeFlow .~ NormalTimeFlow _ -> doTimeScroll smoothing w doTimeScroll :: Int -> World -> World doTimeScroll smoothing w = case w ^. input . scrollAmount of x | x > 1 -> w & scrollTimeBack & timeFlow . scrollSmoothing .~ 20 x | x > 0 -> w & scrollTimeBack & timeFlow . scrollSmoothing %~ max 0 x | x < (-1) -> w & scrollTimeForward & timeFlow . scrollSmoothing .~ negate 20 x | x < 0 -> w & scrollTimeForward & timeFlow . scrollSmoothing %~ min 0 _ | smoothing > 0 -> scrollTimeBack w & timeFlow . scrollSmoothing -~ 1 _ | smoothing < 0 -> scrollTimeForward w & timeFlow . scrollSmoothing +~ 1 _ -> w scrollTimeBack :: World -> World scrollTimeBack w = case w ^? pastWorlds . _head of Nothing -> w Just lw -> case w ^?! timeFlow . reverseAmount of x | x > 0 -> w & pastWorlds %~ tail & timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld) & timeFlow . reverseAmount -~ 1 & cWorld . lWorld .~ lw & mupdateitem x _ -> w where --mupdateitem x = fromMaybe id $ do mupdateitem _ = fromMaybe id $ do --i <- w ^? timeFlow . scrollItemID . unNInt _ <- w ^? timeFlow . scrollItemID . unNInt -- let pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse return id -- (pointituse . leftConsumption . wpCharge .~ (x -1)) -- . (pointituse . leftHammer .~ HammerDown) scrollTimeForward :: World -> World scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of Nothing -> w Just lw -> w & timeFlow . futureWorlds %~ tail & pastWorlds .:~ (w ^. cWorld . lWorld) & cWorld . lWorld .~ lw & timeFlow . reverseAmount .~ ramount & mupdateitem where ramount = (w ^?! timeFlow . reverseAmount) + 1 mupdateitem = fromMaybe id $ do --i <- w ^? timeFlow . scrollItemID . unNInt _ <- w ^? timeFlow . scrollItemID . unNInt return id -- pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount -- | The update step. functionalUpdate :: Universe -> Universe functionalUpdate u = checkEndGame . over (uvWorld . cWorld . lWorld) updateMagnets . over uvWorld (cWorld . lWorld . lClock +~ 1) . over uvWorld updateDistortions . over uvWorld updateCreatureSoundPositions . over uvWorld ppEvents . colCrsWalls . over uvWorld simpleCrSprings . over uvWorld (updateIMl (_doors . _lWorld . _cWorld) (doDrWdWd . _drMech)) . over uvWorld doWorldEvents . over uvWorld updateDelayedEvents . over uvWorld (updateIMl (_modifications . _lWorld . _cWorld) (doModificationEffect . _mdUpdate)) . over uvWorld updateSparks . over uvWorld updateRadarSweeps . over uvWorld updatePosEvents . over uvWorld updateFlames . over uvWorld updateShockwaves . over uvWorld updateEnergyBalls . over uvWorld updateBullets . over uvWorld updateRadarBlips -- . over uvWorld updateBeams . over uvWorld updateLasers . over uvWorld updateTeslaArcs . over uvWorld updateTractorBeams . over uvWorld (updateIMl' (_linearShockwaves . _lWorld . _cWorld) updateLinearShockwave) . over uvWorld (updateIMl' (_props . _lWorld . _cWorld) updateProp) . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile) . over uvWorld updateClouds . over uvWorld updateGusts . over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) tmUpdate) -- . updateIMl _machines mcChooseUpdate . over uvWorld (updateIMl' (_machines . _lWorld . _cWorld) updateMachine) . over uvWorld (updateIMl' (_creatures . _lWorld . _cWorld) updateCreature) -- creatures should be updated early so that crOldPos is set before any position change . over (uvWorld . cWorld . lWorld . creatures) (fmap setOldPos) . over uvWorld updateCreatureGroups . over uvWorld updateWallDamages -- . over uvWorld updateSeenWalls . over uvWorld checkTermDist . over uvWorld updateRBList . over uvWorld updateCloseObjects . over uvWorld updateWheelEvents -- . over uvWorld (updateMouseInventorySelection (u ^. uvConfig)) . over uvWorld zoneClouds . over uvWorld zoneCreatures -- . over uvWorld updateInventorySelectionList . set (uvWorld . cWorld . lWorld . flares) [] . set (uvWorld . cWorld . lWorld . lights) [] . updateAimPos $ over uvWorld updatePastWorlds u updateAimPos :: Universe -> Universe updateAimPos u = u & uvWorld . cWorld . lWorld . lAimPos .~ mouseWorldPos' (u ^. uvWorld . input) (u ^. uvWorld . wCam) updateMagnets :: LWorld -> LWorld updateMagnets lw = lw & oldMagnets .~ (lw ^. magnets) & magnets .~ mempty checkTermDist :: World -> World checkTermDist w = fromMaybe w $ do tmid <- w ^? hud . hudElement . subInventory . termID btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos guard $ dist btpos (_crPos $ you w) > 40 return $ w & hud . hudElement . subInventory .~ NoSubInventory updateMouseContext :: Configuration -> Universe -> Universe updateMouseContext cfig u = case u ^? uvScreenLayers . ix 0 of Just screen -> u & uvWorld . input . mouseContext .~ getMenuMouseContext screen u Nothing -> updateMouseContextGame cfig u updateMouseContextGame :: Configuration -> Universe -> Universe updateMouseContextGame cfig u = case u ^. uvWorld . input . mouseContext of OverInvDrag i _ _ _ -> u & uvWorld . input . mouseContext .~ invdrag i OverInvDragSelect{} -> u _ -> u & uvWorld . input . mouseContext .~ fromMaybe aimcontext (isrotatedrag <|> overinv <|> overcomb <|> overterm) where w = u ^. uvWorld isrotatedrag = do t1 <- w ^. input . mouseButtons . at ButtonLeft t2 <- w ^. input . mouseButtons . at ButtonRight guard $ t1 > t2 return MouseGameRotate aimcontext -- | Just t1 <- w ^. input . mouseButtons . at ButtonLeft -- , Just t2 <- w ^. input . mouseButtons . at ButtonRight -- , t1 > t2 = MouseGameRotate | ButtonRight `M.member` (w ^. input . mouseButtons) = MouseAiming | otherwise = MouseInGame mpos = w ^. input . mousePos invdrag i' = fromMaybe (OverInvDrag i' Nothing Nothing Nothing) $ do sss <- w ^? hud . hudElement . diSections let yint = posSelSecYint cfig invDP (mpos ^. _y) (i, j) <- inverseSelNumPos cfig invDP sss mpos let above = inverseSelSecYint (yint - 1) sss bneath = inverseSelSecYint (yint + 1) sss return $ OverInvDrag i' (Just (i, j)) above bneath overinv = do sss <- w ^? hud . hudElement . diSections selpos@(i, j) <- inverseSelNumPos cfig invDP sss mpos case w ^? hud . hudElement . subInventory . ciSelection of Just _ | i == 0 -> return $ OverCombFiltInv selpos Just _ -> Nothing _ -> do guard $ ButtonRight `M.notMember` (w ^. input . mouseButtons) guard =<< sss ^? ix i . ssItems . ix j . siIsSelectable return $ OverInvSelect selpos overcomb = do sss <- w ^? hud . hudElement . subInventory . ciSections (xl, xr, _) <- w ^? hud . hudElement . subInventory . ciSelection . _Just let msel = (xl, xr) let mpossel = inverseSelNumPos cfig secondColumnParams sss (w ^. input . mousePos) return $ case mpossel of Nothing -> OverCombEscape Just (-1, i) | (-1, i) == msel -> OverCombFilter Just x | x == msel -> OverCombCombine x Just x -> OverCombSelect x overterm = do tmid <- w ^? hud . hudElement . subInventory . termID tm <- w ^? cWorld . lWorld . terminals . ix tmid return $ if isOverTerminalScreen cfig tm mpos then fromMaybe NoMouseContext $ do let s = tm ^. tmInput . tiText guard $ not (null s) && _tmStatus tm == TerminalReady return $ OverTerminalReturn tmid else OverTerminalEscape getMenuMouseContext :: ScreenLayer -> Universe -> MouseContext getMenuMouseContext screen u = case screen ^. scOptions of [] -> NoMouseContext _ -> fromMaybe MouseMenuCursor $ do ymax <- length <$> screen ^? scSelectionList yi <- ldpVerticalSelection (u ^. uvConfig) menuDisplayParams (u ^. uvWorld . input . mousePos) guard (yi >= 0 && yi < ymax) return $ case u ^? uvScreenLayers . _head . scSelectionList . ix yi . siIsSelectable of Just True -> MouseMenuClick yi _ -> NoMouseContext isOverTerminalScreen :: Configuration -> Terminal -> Point2 -> Bool isOverTerminalScreen cfig tm (V2 x y) = x <= xmax && x >= xmin - 5 && y <= ymax + 5 && y >= ymin where ldp = secondColumnParams V2 xmin ymax = screenPosAbs cfig (ldp ^. ldpPos) tsize = fromIntegral $ getMaxLinesTM (tm ^. tmType) + 1 s = 5 + tsize * (20 * ldp ^. ldpScale + ldp ^. ldpVerticalGap) ymin = ymax - s xmax = xmin + 555 -- HACK drawSelectionListBackground updateWheelEvents :: World -> World updateWheelEvents w | 0 <- w ^. input . scrollAmount = w | yi <- w ^. input . scrollAmount = updateWheelEvent yi w advanceScrollAmount :: Universe -> Universe advanceScrollAmount = (uvWorld . input . scrollAmount .~ 0) . (uvWorld . input . smoothScrollAmount %~ advanceSmoothScroll) updatePastWorlds :: World -> World updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :)) doWorldEvents :: World -> World doWorldEvents w = foldl' (flip doWdWd) (w & cWorld . lWorld . worldEvents .~ []) (w ^. cWorld . lWorld . worldEvents) updateLasers :: World -> World updateLasers w = w' & cWorld . lWorld . flares <>~ concat ls where (w', ls) = mapAccumR updateLaser (w & cWorld . lWorld . lasers .~ []) (w ^. cWorld . lWorld . lasers) zoneClouds :: World -> World zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds) displayTerminalLineString :: TerminalLineString -> World -> (String, Color) displayTerminalLineString (TerminalLineConst str col) = const (str, col) tmUpdate :: Terminal -> World -> World tmUpdate tm w = case w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines . ix 0 of Nothing -> w Just tl | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1 Just (TerminalLineDisplay _ f) -> w & pointTermParams %~ ( (tmFutureLines %~ tail) . (tmDisplayedLines .:~ displayTerminalLineString f w) ) Just (TerminalLineEffect _ eff) -> w & pointTermParams . tmFutureLines %~ tail & doTmWdWd eff tm Just (TerminalLineTerminalEffect _ eff) -> w & pointTermParams . tmFutureLines %~ tail & pointTermParams %~ doTmTm eff where pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm) setOldPos :: Creature -> Creature setOldPos cr = cr & crOldPos .~ _crPos cr & crOldDir .~ _crDir cr -- hack --updateRandGen :: World -> World --updateRandGen = randGen %~ (snd . (uniform :: StdGen -> (Int,StdGen))) --doRewind :: World -> World --doRewind w = case w ^. cwTime . maybeWorld of -- Just' cw -> -- w & cWorld .~ cw -- & timeFlow .~ RewindingLastFrame -- Nothing' -> w & timeFlow .~ NormalTimeFlow zoneCreatures :: World -> World zoneCreatures w = w & crZoning .~ foldl' zoneCreature mempty (w ^. cWorld . lWorld . creatures) updateCreatureSoundPositions :: World -> World updateCreatureSoundPositions w = M.foldlWithKey' insertSound w . M.mapMaybeWithKey updateSound $ _playingSounds w where insertSound w' k s = w' & toPlaySounds %~ M.insertWith (const id) k s updateSound (CrMouth cid) s = case w ^? cWorld . lWorld . creatures . ix cid . crPos of Just p -> Just s{_soundPos = p, _soundAngDist = Just (soundAngle p w, 0)} Nothing -> Just s{_soundTime = Just 0} updateSound _ _ = Nothing --updateIMr :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World --updateIMr fim fup w = foldr (dbArg fup) w (fim w) updateIMl :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w --updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w) updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w --updateIMl' fim fup w = foldl' (flip fup) w (fim w) updateCreatureGroups :: World -> World updateCreatureGroups w = w & cWorld . lWorld . creatureGroups %~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp) updateObjMapMaybe :: (([a] -> Identity [a]) -> LWorld -> Identity LWorld) -> (a -> Maybe a) -> World -> World updateObjMapMaybe p f = cWorld . lWorld . p %~ mapMaybe f updateObjCatMaybes :: ALens' LWorld [a] -> (World -> a -> (World, Maybe a)) -> World -> World updateObjCatMaybes p f w = w' & cWorld . lWorld . p #~ catMaybes newxs where (w', newxs) = mapAccumR f w $ w ^# cWorld . lWorld . p updateDistortions :: World -> World updateDistortions = updateObjMapMaybe distortions updateDistortion updateRadarBlips :: World -> World updateRadarBlips = updateObjMapMaybe radarBlips updateRadarBlip -- if changing, make sure that bullets can still spawn new bullets updateBullets :: World -> World updateBullets w = w' & cWorld . lWorld . bullets <>~ catMaybes ps where (w', ps) = mapAccumR updateBullet (w & cWorld . lWorld . bullets .~ []) $ w ^. cWorld . lWorld . bullets updateTeslaArcs :: World -> World updateTeslaArcs = updateObjCatMaybes teslaArcs updateTeslaArc updateTeslaArc :: World -> TeslaArc -> (World, Maybe TeslaArc) updateTeslaArc w pt | _taTimer pt == 2 = ( makesparks $ foldl' (flip damthings) w thearc , Just $ pt & taTimer -~ 1 ) | _taTimer pt >= 0 = (w, Just $ pt & taTimer -~ 1) | otherwise = (w, Nothing) where thearc = _taArcSteps pt makeaspark = randSpark ELECTRICAL (state (randomR (3, 6))) (brightX 100 1.5 <$> takeOne [white, azure, blue, cyan]) rdir lp makesparks = makeaspark . makeaspark . makeaspark rp x = randPeakedParam 2 (x - 0.7) x (x + 0.7) (lp, rdir) | ArcStep lp' ld' (CrID crid) <- last thearc , Just cr <- w ^? cWorld . lWorld . creatures . ix crid = (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld', rp $ ld' + pi) | ArcStep lp' ld' (WlID wlid) <- last thearc , Just wl <- w ^? cWorld . lWorld . walls . ix wlid = ( lp' -.- 2 *.* unitVectorAtAngle ld' , randWallReflect ld' wl ) | ArcStep lp' ld' _ <- last thearc = (lp', rp ld') damthings (ArcStep p dir crwl) = damageCrWlID (thedamage p dir) crwl thedamage p dir = Damage ELECTRICAL 50 (p -.- q) p (p +.+ q) NoDamageEffect where q = 5 *.* unitVectorAtAngle dir randWallReflect :: RandomGen g => Float -> Wall -> State g Float randWallReflect a wl = randPeaked a1 outa a2 where (x, y) = _wlLine wl outa = reflectAngle a x y a1 = nearestAngleRep outa $ argV (x - y) a2 = if a1 < outa then a1 + pi else a1 - pi updateTractorBeams :: World -> World updateTractorBeams = updateObjCatMaybes tractorBeams updateTractorBeam updateShockwaves :: World -> World updateShockwaves = updateObjCatMaybes shockwaves updateShockwave updateFlames :: World -> World updateFlames = updateObjCatMaybes flames updateFlame updateEnergyBalls :: World -> World updateEnergyBalls = updateObjCatMaybes energyBalls updateEnergyBall updateRadarSweeps :: World -> World updateRadarSweeps = updateObjCatMaybes radarSweeps updateRadarSweep updateSparks :: World -> World updateSparks = updateObjCatMaybes sparks updateSpark updatePosEvents :: World -> World updatePosEvents = updateObjCatMaybes posEvents updatePosEvent updateClouds :: World -> World updateClouds = updateObjCatMaybes clouds updateCloud --updateBeams :: World -> World --updateBeams w = -- w -- & cWorld . lWorld . newBeams .~ WorldBeams [] [] [] [] -- & cWorld . lWorld . beams .~ thebeams -- & combineBeams thebeams -- where -- thebeams = w ^. cWorld . lWorld . newBeams --combineBeams :: WorldBeams -> World -> World --combineBeams wbeams w = -- w'' -- & cWorld . lWorld . beams . positronBeams .~ pbeams -- & cWorld . lWorld . beams . electronBeams .~ ebeams -- where -- (w', pbeams) = mapAccumR (combineBeamBeams (_electronBeams wbeams)) w $ _positronBeams wbeams -- (w'', ebeams) = mapAccumR (combineBeamBeams (_positronBeams wbeams)) w' $ _electronBeams wbeams --combineBeamBeams :: [Beam] -> World -> Beam -> (World, Beam) --combineBeamBeams bms w bm = case intersectBeamBeams bm bms of -- (ps, Nothing) -> (w, bm & bmFirstPoints .~ ps) -- (ps, Just a) -> (doBeamCombine (_beamCombine (_bmType bm)) a w, bm & bmFirstPoints .~ ps) ---- intersect a beam with a list of beams. ---- returns the (reversed) travel of the beam up to maybe an intersection point --intersectBeamBeams :: -- Beam -> -- [Beam] -> -- ([Point2], Maybe (Point2, (Point2, Point2, Beam), (Point2, Point2, Beam))) --intersectBeamBeams bm bms = f [] $ _bmPoints bm -- where -- f ps (x : y : ys) = case intersectSegBeams x y bms of -- Just (z, a) -> (z : x : ps, Just (z, (x, y, bm), a)) -- Nothing -> f (x : ps) (y : ys) -- f ps [x] = (x : ps, Nothing) -- f _ _ = error "made an empty beam" -- --intersectSegBeams :: Point2 -> Point2 -> [Beam] -> Maybe (Point2, (Point2, Point2, Beam)) --intersectSegBeams sp ep (bm : bms) = case intersectSegBeam sp ep bm of -- Nothing -> intersectSegBeams sp ep bms -- --Just a@(z,_) -> maybe (Just a) Just $ intersectSegBeams sp z bms -- Just a@(z, _) -> intersectSegBeams sp z bms <|> Just a --intersectSegBeams _ _ _ = Nothing -- --intersectSegBeam :: Point2 -> Point2 -> Beam -> Maybe (Point2, (Point2, Point2, Beam)) --intersectSegBeam sp ep bm = case intersectSegSegs' sp ep (_bmPoints bm) of -- Nothing -> Nothing -- Just (z, x, y) -> Just (z, (x, y, bm)) --intersectSegSegs' :: Point2 -> Point2 -> [Point2] -> Maybe (Point2, Point2, Point2) --intersectSegSegs' sp ep (x : y : ys) = case intersectSegSeg sp ep x y of -- --Just z -> maybe (Just (z,x,y)) Just $ intersectSegSegs' sp z (y:ys) -- Just z -> intersectSegSegs' sp z (y : ys) <|> Just (z, x, y) -- Nothing -> intersectSegSegs' sp ep (y : ys) --intersectSegSegs' _ _ _ = Nothing --intersectSegSegs :: Point2 -> Point2 -> [Point2] -> Maybe Point2 --intersectSegSegs sp ep (x:y:ys) = case intersectSegSeg sp ep x y of -- Just z -> maybe (Just z) Just $ intersectSegSegs sp z (y:ys) -- Nothing -> intersectSegSegs sp ep (y:ys) --intersectSegSegs _ _ _ = Nothing -- --intersectSegSegss :: Point2 -> Point2 -> [[Point2]] -> Maybe Point2 --intersectSegSegss sp ep (as:ass) = case intersectSegSegs sp ep as of -- Just z -> maybe (Just z) Just $ intersectSegSegss sp z ass -- Nothing -> intersectSegSegss sp ep ass --intersectSegSegss _ _ _ = Nothing -- --intersectSegsSegss :: [Point2] -> [[Point2]] -> Maybe Point2 --intersectSegsSegss (x:y:ys) ass = maybe -- (intersectSegsSegss (y:ys) ass) -- Just -- (intersectSegSegss x y ass) --intersectSegsSegss _ _ = Nothing ppEvents :: World -> World ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ w ^. cWorld . lWorld . pressPlates --updateSeenWalls :: World -> World --updateSeenWalls w = alaf Endo foldMap (markWallSeen . _wlID . snd) (allVisibleWalls w) w --markWallSeen :: Int -> World -> World --markWallSeen i = cWorld . seenWalls . at i ?~ () --markWallSeen :: World -> Int -> World --markWallSeen w i = w & cWorld . seenWalls . at i ?~ () --markWallSeen !w !i = w & cWorld . lWorld . walls %~ IM.adjust markSeen i -- in the past there might have been a space leak, which the following was meant -- to fix --markWallSeen !w !i = w & cWorld . lWorld . walls .~ IM.adjust markSeen i (w ^. cWorld . lWorld . walls) --markSeen :: Wall -> Wall --{-# INLINE markSeen #-} --markSeen wl = wl{_wlSeen = True} checkEndGame :: Universe -> Universe checkEndGame uv = case w ^? timeFlow . deathDelay of Just x | x < 0 -> uv & uvScreenLayers .~ [gameOverMenu uv] Just _ -> uv & uvWorld . timeFlow . deathDelay -~ 1 _ | _crHP (you w) < 1 -> uv & uvWorld . timeFlow .~ DeathTime 50 _ -> uv where w = _uvWorld uv updateGusts :: World -> World updateGusts w = w & cWorld . lWorld . gusts %~ IM.mapMaybe (mvGust w) mvGust :: World -> Gust -> Maybe Gust mvGust _ gu | _guTime gu < 0 = Nothing | otherwise = Just $ gu & guPos .+.+~ _guVel gu & guTime -~ 1 cloudEffect :: Cloud -> World -> World cloudEffect cl = case _clType cl of GasCloud -> cloudPoisonDamage cl SmokeCloud -> id updateCloud :: World -> Cloud -> (World, Maybe Cloud) updateCloud w c | _clTimer c < 1 = (w, Nothing) | otherwise = ( cloudEffect 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) (clsNearPoint oldPos2 w) oldPos@(V3 _ _ opz) = _clPos c oldPos2 = stripZ oldPos newPos@(V3 _ _ npz) = oldPos +.+.+ newVel newPos2 = stripZ newPos hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl -- allowing clouds at/above height 75 causes graphical glitches 22.05.23 finalVel = addZ nvz $ maybe newVel2 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 $ w ^. cWorld . lWorld . creatures -- note that this may in rare cases not push creatures away from each other crSpring :: Creature -> World -> World crSpring c w = foldl' (flip $ crCrSpring c) w cs where cs = crsNearPoint (_crPos c) w crCrSpring :: Creature -> Creature -> World -> World crCrSpring c1 c2 | id1 == id2 = id | vec == V2 0 0 = id | diff >= comRad = id | otherwise = cWorld . lWorld . creatures %~ ( over (ix id1 . crPos) (+.+ overlap1) . over (ix id2 . crPos) (-.- overlap2) ) 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 updateDelayedEvents :: World -> World updateDelayedEvents w = let (neww, newde) = mapAccumR f w (w ^. cWorld . lWorld . delayedEvents) in neww & cWorld . lWorld . delayedEvents .~ catMaybes newde where f w' (i, g) | i <= 0 = (w' & cWorld . lWorld . worldEvents .:~ g, Nothing) | otherwise = (w', Just (i -1, g))