{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} module Dodge.Update (updateUniverse) where import Dodge.Data.CardinalPoint import Dodge.Data.ScreenPos import Bound import Color import Control.Applicative import Control.Monad import Data.Foldable import Data.Function (on) import Data.List import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as S import Dodge.Base import Dodge.Bullet import Dodge.Cloud import Dodge.CrGroupUpdate import Dodge.Creature.Mass import Dodge.Creature.MoveType import Dodge.Creature.Radius import Dodge.Creature.Update import Dodge.Damage import Dodge.Data.CrWlID import Dodge.Data.Object import Dodge.Data.Universe import Dodge.Debug import Dodge.DisplayInventory import Dodge.Distortion import Dodge.Door import Dodge.DoubleTree import Dodge.EnergyBall import Dodge.Flame import Dodge.HeldUse import Dodge.Inventory import Dodge.Item.Grammar import Dodge.Item.Weapon.LaserPath import Dodge.Laser.Update import Dodge.LinearShockwave.Update import Dodge.ListDisplayParams import Dodge.Machine.Update import Dodge.ModificationEffect import Dodge.Projectile.Update import Dodge.Prop.Moving import Dodge.RadarBlip import Dodge.RadarSweep import Dodge.Render.List import Dodge.ScrollValue import Dodge.SelectionSections import Dodge.Shockwave.Update import Dodge.SmoothScroll import Dodge.SoundLogic import Dodge.Spark import Dodge.SpawnAt import Dodge.Terminal.Type 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.WorldEvent.Explosion import Dodge.WorldEvent.ThingsHit import Dodge.Zoning.Cloud import Dodge.Zoning.Creature import Dodge.Zoning.Wall import Geometry import qualified IntMapHelp as IM import LensHelp import NewInt import RandomHelp 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 0 -> u & uvScreenLayers %~ openConsole _ -> u openConsole :: [ScreenLayer] -> [ScreenLayer] openConsole = \case xs@(InputScreen{} : _) -> xs xs -> InputScreen mempty : xs updateUniverseLast :: Universe -> Universe updateUniverseLast u = u & uvWorld . input . textInput .~ mempty & maybeOpenConsole & advanceScrollAmount & updateWorldEventFlags & uvWorld . input . pressedKeys . each +~ 1 & 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)) & uvIOEffects %~ doMouseWarping u where mp = u ^. uvWorld . input . mousePos mwp = screenToWorldPos (u ^. uvWorld . wCam) mp doMouseWarping :: p -> a -> a doMouseWarping _ = id --doMouseWarping :: Universe -> (Universe -> IO Universe) -> (Universe -> IO Universe) --doMouseWarping u f u' -- | Just x <- u ^? uvWorld . input . mouseContext . mcoRotateDist -- = SDL.warpMouse WarpCurrentFocus (P p) >> f (u' & uvWorld . input . mousePos .~ nmp) -- | otherwise = f u' -- where -- cfig = u' ^. uvConfig -- nmp = V2 -- (fromIntegral x - 0.5 * windowXFloat cfig) -- (0.5 * windowYFloat cfig - fromIntegral y) -- p@(V2 x y) = (cwin + (msp & each %~ round)) & each %~ fromIntegral -- cwin :: V2 Int -- cwin = ((getWindowSize _gr_world_res (u' ^. uvConfig))) -- mwp = mouseWorldPosW (u' ^. uvWorld) -- msp = u' ^. uvWorld . input . mousePos & _y %~ negate -- cc = u' ^. uvWorld . wCam . camCenter -- d = dist mwp cc {- For most menus the only way to change the world is using event handling. -} updateUniverseMid :: Universe -> Universe updateUniverseMid u = case _uvScreenLayers u of (sl : _) -> u & uvWorld . unpauseClock .~ 0 & updateUseInputOnScreen sl [] -> (uvWorld . unpauseClock +~ 1) . (uvWorld . cWorld . highlightItems %~ IM.mapMaybe minusone) -- . (uvWorld . cWorld . highlightItems . filteredBy . non 0 -~ 1) . timeFlowUpdate . updateUseInputInGame $ over uvWorld (updateMouseInGame (u ^. uvConfig) . updateCamera (u ^. uvConfig)) u where minusone x | x > 0 = Just $ x - 1 | otherwise = Nothing 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 RespawnDelay{} -> functionalUpdate u PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u PauseTimeMessage{} -> u pauseTime :: NewInt ItmInt -> World -> World 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 _ = fromMaybe id $ do _ <- w ^? timeFlow . scrollItemID . unNInt return id 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 _ <- w ^? timeFlow . scrollItemID . unNInt return id -- | The update step. functionalUpdate :: Universe -> Universe functionalUpdate = checkEndGame . over (uvWorld . cWorld . lWorld) updateMagnets . over uvWorld (cWorld . lWorld . lClock +~ 1) . over uvWorld updateDistortions . over uvWorld updateCreatureSoundPositions . over uvWorld updateCreatureStrides . over uvWorld pushYouOutFromWalls . colCrsWalls . over uvWorld simpleCrSprings . over uvWorld updateDoors . over uvWorld doWorldEvents . over uvWorld updateDelayedEvents . over uvWorld ( updateIMl (_modifications . _lWorld . _cWorld) (doModificationEffect . _mdUpdate) ) . over uvWorld updateSparks . over uvWorld updateRadarSweeps . over uvWorld updateFlames . over uvWorld updateShockwaves . over uvWorld updateBullets . over uvWorld updatePlasmaBalls . over uvWorld updateDebris . over uvWorld updateEnergyBalls -- energybs can be created by bullets, -- so should probably be updated before bullets . over uvWorld updateRadarBlips -- . over uvWorld updateBeams . over uvWorld updateLasers . over uvWorld (updateIMl' (_pulseBalls . _lWorld . _cWorld) updatePulseBall) . over uvWorld updatePulseLasers . over uvWorld updateTeslaArcs . over uvWorld updateTractorBeams . over uvWorld (updateIMl' (_linearShockwaves . _lWorld . _cWorld) updateLinearShockwave) . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile) . over uvWorld updateClouds . over uvWorld updateGasses . over uvWorld updateDusts . over uvWorld updateGusts . over uvWorld (updateIMl' (_terminals . _lWorld . _cWorld) updateTerminal) . 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 -- can potentially be combined in some way with update doors so that only one pathing update needs to be done... . over uvWorld checkTermDist . over uvWorld updateRBList . over uvWorld updateCloseObjects . over uvWorld updateWheelEvents -- . over uvWorld (updateMouseInventorySelection (u ^. uvConfig)) . over uvWorld zoneClouds . over uvWorld zoneDusts . over uvWorld zoneCreatures -- . over uvWorld updateInventorySelectionList . set (uvWorld . cWorld . lWorld . flares) [] . set (uvWorld . cWorld . lWorld . lights) [] . set (uvWorld . cWorld . lWorld . tempSPic) mempty . updateAimPos . over uvWorld updatePastWorlds -- it might be possible to do this without storing stuff such as the temporary lights/flares etc pushYouOutFromWalls :: World -> World pushYouOutFromWalls w = w & cWorld . lWorld . creatures . ix 0 %~ muzzleWallCheck w -- rotate creature as well? behaviour on ledges? muzzleWallCheck :: World -> Creature -> Creature muzzleWallCheck w cr = fromMaybe cr $ do invid <- cr ^? crManipulation . manObject . imRootSelectedItem . unNInt loc <- invIndents ((\k -> w ^?! cWorld . lWorld . items . ix k) <$> _crInv cr) ^? ix invid . _2 let ps = reduceLocDT f loc ^.. each . _1 . _xy cp = cr ^. crPos . _xy r <- boundPointsRect (cp : ps) let wls = uncurry wlsNearRect r w & IM.elems & filter (not . _wlTouchThrough) vs = mapMaybe (g cp wls) ps return $ if null vs then cr else let (v,wl) = minimumBy (compare `on` norm . fst) vs v' = signorm (vNormal (uncurry (-) (wl ^. wlLine))) x = dotV v' v in cr & crPos . _xy +~ min 1 x *^ v' where f loc = map (muzzlePos loc cr) (itemMuzzles loc) g cp wls p = case collidePoint cp p wls of (ep, Just wl) -> Just (ep - p, wl) _ -> Nothing updateCreatureStrides :: World -> World updateCreatureStrides w = foldl' updateCreatureStride w (w ^. cWorld . lWorld . creatures) updateCreatureStride :: World -> Creature -> World updateCreatureStride w cr | Walking <- cr ^. crStance . carriage , CrabCrit {} <- cr ^. crType = w & f footPin1S (g 10) (cr ^?! crType . lFootPos) lFootPos & f footPin2S (g (-10)) (cr ^?! crType . rFootPos) rFootPos | Walking <- cr ^. crStance . carriage , isJust $ cr ^? crType . strideAmount = w & tocr . crType . strideAmount +~ d | otherwise = w where tocr = cWorld . lWorld . creatures . ix cid cid = cr ^. crID f sn p q fp | distance p q > 10 = (tocr . crType . fp .~ (p - 9 *^ signorm (q - p))) . soundStart (CrFootSound cid 0) (p - 9 *^ signorm (q - p)) sn Nothing | otherwise = id g x = cr ^. crPos . _xy + x *^ vNormal (unitVectorAtAngle (cr ^. crDir)) s = 2 * fromMaybe 1 (crMvType cr ^? mvSpeed) -- d = min s . norm $ cr ^. crPos - cr ^. crOldPos d = max 0 . min s $ dotV (cr ^. crPos . _xy - cr ^. crOldPos . _xy) (unitVectorAtAngle (cr ^. crMvDir)) updateAimPos :: Universe -> Universe updateAimPos u = u & uvWorld . cWorld . lWorld . lAimPos .~ mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam) updateDoors :: World -> World updateDoors w = uncurry updateEdgesWall $ foldrM updateDoor w (w ^. cWorld . lWorld . doors) updateMagnets :: LWorld -> LWorld updateMagnets lw = lw & oldMagnets .~ (lw ^. magnets) & magnets .~ mempty checkTermDist :: World -> World checkTermDist w = fromMaybe w $ do tmid <- w ^? hud . subInventory . termID btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos guard $ dist btpos (you w ^. crPos . _xy) > closeItemDist return $ w & hud . subInventory .~ NoSubInventory updateMouseContext :: Config -> Universe -> Universe updateMouseContext cfig u = case u ^? uvScreenLayers . ix 0 of Just screen -> u & uvWorld . input . mouseContext .~ getMenuMouseContext screen u Nothing -> u & uvWorld . input . mouseContext %~ updateMouseContextGame cfig u updateMouseContextGame :: Config -> Universe -> MouseContext -> MouseContext updateMouseContextGame cfig u = \case OverInvDrag i _ -> OverInvDrag i (inverseSelNumPos cfig invDP mpos disss ^? _Just . nonInf) x@OverInvDragSelect{} -> x MouseGameRotate x | ButtonRight `M.member` (w ^. input . mouseButtons) -> MouseGameRotate x OverTerminalBar p | ButtonLeft `M.member` (w ^. input . mouseButtons) -> OverTerminalBar p _ -> fromMaybe aimcontext (overterm <|> overinv <|> overcomb) where w = u ^. uvWorld aimcontext | ButtonRight `M.member` (w ^. input . mouseButtons) = MouseAiming | Display_debug `S.member` (cfig ^. debug_booleans) = getDebugMouseOver u | otherwise = MouseInGame mpos = w ^. input . mousePos disss = w ^. hud . diSections overinv = do selpos@(i, j) <- inverseSelNumPos cfig invDP mpos disss ^? _Just . nonInf case w ^? hud . subInventory . ciSelection of Just _ | i == 0 -> return $ OverCombFiltInv selpos Just _ -> Nothing _ -> do guard $ ButtonRight `M.notMember` (w ^. input . mouseButtons) guard =<< disss ^? ix i . ssItems . ix j . siIsSelectable return $ OverInvSelect selpos overcomb = do sss <- w ^? hud . subInventory . ciSections Sel xl xr _ <- w ^? hud . subInventory . ciSelection . _Just let msel = (xl, xr) let mpossel = inverseSelNumPos cfig secondColumnLDP (w ^. input . mousePos) sss ^? _Just . nonInf 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 . subInventory . termID tm <- w ^? cWorld . lWorld . terminals . ix tmid xy <- ldpRect cfig (w ^. tmLDP) return $ tmScreenMousePos w xy mpos tmid (tm ^. tmStatus) tmScreenMousePos :: World -> (Point2,Point2) -> Point2 -> Int -> TerminalStatus -> MouseContext tmScreenMousePos w (V2 xmin ymax, V2 xmax ymin) (V2 x y) tmid ts | xtest && y <= ymax && y >= ymin = OverTerminal tmid ts | xtest && y <= ymax + 20 && y >= ymax = OverTerminalBar (w ^. tmLDP . ldpPos . spPixelOff - V2 x y) | otherwise = OutsideTerminal where xtest = x <= xmax && x >= xmin getDebugMouseOver :: Universe -> MouseContext getDebugMouseOver u = fromMaybe MouseInGame $ do guard $ x > 0 && x < 100 (db, j) <- m ^? ix i return $ OverDebug db j where f (a, as) = (a,) <$> [0 .. length as - 1] m = foldMap f . M.toList $ u ^. uvDebug i = floor (y / 20) y = halfHeight (u ^. uvConfig) - y' V2 x y' = u ^. uvWorld . input . mousePos getMenuMouseContext :: ScreenLayer -> Universe -> MouseContext getMenuMouseContext screen u = case screen ^. scOptions of [] -> NoMouseContext _ -> fromMaybe (MouseMenu Nothing) $ do yi <- ldpSelection (u ^. uvConfig) menuLDP (u ^. uvWorld . input . mousePos) t <- screen ^? scSelectionList . ix yi . siIsSelectable return $ if t then MouseMenu (Just yi) else NoMouseContext updateWheelEvents :: World -> World updateWheelEvents w = case w ^. input . scrollAmount of 0 -> w yi -> 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) updatePulseLasers :: World -> World updatePulseLasers w = f w & cWorld . lWorld . pulseLasers .~ pzs where (Endo f, pzs) = foldMap updatePulseLaser (w ^. cWorld . lWorld . pulseLasers) updatePlasmaBall :: World -> PlasmaBall -> (World, Maybe PlasmaBall) updatePlasmaBall w pb | Just (_, ecrwl) <- thit = ( w & cWorld . lWorld %~ dodam ecrwl , Nothing ) | norm (pb ^. pbVel) <= 0 = (w, Nothing) | otherwise = ( w -- flicker? , Just $ pb & pbPos .~ ep ) where dodam = \case Left cr -> creatures . ix (_crID cr) . crDamage .:~ thedam Right wl -> wallDamages . at (_wlID wl) . non mempty .:~ thedam thedam = Lasering 100 ep (pb ^. pbVel) sp = pb ^. pbPos ep = sp + pb ^. pbVel thit = thingHit sp ep w updatePulseBall :: PulseBall -> World -> World updatePulseBall pb w | Just (_, ecrwl) <- thit = w & cWorld . lWorld . pulseBalls . at (pb ^. pzbID) .~ Nothing & cWorld . lWorld %~ dodam ecrwl | pb ^. pzbTimer <= 0 = w & cWorld . lWorld . pulseBalls . at (pb ^. pzbID) .~ Nothing | otherwise = w & cWorld . lWorld . pulseBalls . ix (pb ^. pzbID) . pzbTimer -~ 1 & cWorld . lWorld . pulseBalls . ix (pb ^. pzbID) . pzbPos .~ ep & pbFlicker pb where dodam = \case Left cr -> creatures . ix (_crID cr) . crDamage .:~ thedam Right wl -> wallDamages . at (_wlID wl) . non mempty .:~ thedam thedam = Lasering 100 ep (pb ^. pzbVel) sp = pb ^. pzbPos ep = sp + pb ^. pzbVel thit = listToMaybe $ thingsHitZ 20 sp ep w pbFlicker :: PulseBall -> World -> World pbFlicker pt = cWorld . lWorld . lights .:~ LSParam (addZ 5 $ _pzbPos pt) d (0.5 * xyzV4 chartreuse) where d = 4 * fromIntegral (10 + abs ((_pzbTimer pt `mod` 20) - 10)) zoneClouds :: World -> World zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds) & gasZoning .~ foldl' (flip zoneGas) mempty (w ^. cWorld . lWorld . gasses) zoneDusts :: World -> World zoneDusts w = w & dsZoning .~ foldl' (flip zoneDust) mempty (w ^. cWorld . lWorld . dusts) displayTerminalLineString :: TerminalLineString -> (String, Color) displayTerminalLineString (TerminalLineConst str col) = (str, col) updateTerminal :: Terminal -> World -> World updateTerminal tm w = fromMaybe w $ do guard $ tm ^. tmStatus == TerminalLineRead tl <- w ^? cWorld . lWorld . terminals . ix (_tmID tm) . tmFutureLines . ix 0 return $ case tl of _ | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1 (TLine _ tls g) -> w & pointTermParams . tmFutureLines %~ tail & pointTermParams . tmDisplayedLines %~ take getMaxLinesTM . (map displayTerminalLineString tls ++) & doTmWdWd g tm where pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm) setOldPos :: Creature -> Creature setOldPos cr = cr & crOldPos .~ _crPos cr & crOldOldPos .~ cr ^. crOldPos --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 (IM.filter zonableCreature $ w ^. cWorld . lWorld . creatures) zonableCreature :: Creature -> Bool zonableCreature cr = case cr ^. crHP of HP{} -> True CrIsCorpse{} -> True CrDestroyed{} -> False 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 . _xy 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' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World updateIMl' fim fup w = alaf Endo foldMap fup (fim w) 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 updatePlasmaBalls :: World -> World updatePlasmaBalls w = w' & cWorld . lWorld . plasmaBalls <>~ catMaybes ps where (w', ps) = mapAccumR updatePlasmaBall (w & cWorld . lWorld . plasmaBalls .~ []) $ w ^. cWorld . lWorld . plasmaBalls updateDebris :: World -> World updateDebris w = w' & cWorld . lWorld . debris <>~ catMaybes xs where (w', xs) = mapAccumR updateDebrisChunk (w & cWorld . lWorld . debris .~ []) $ w ^. cWorld . lWorld . debris 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 ElectricSpark (state (randomR (3, 6))) 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 ^. crType) + 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 _ _ crwl) = damageCrWlID [Electrical 50] crwl updatePulseLaser :: PulseLaser -> (Endo World, [PulseLaser]) updatePulseLaser pz = case pz ^. pzTimer of i | i <= 0 -> (Endo id, []) 5 -> (Endo f, [pz & pzTimer -~ 1]) _ -> (Endo g, [pz & pzTimer -~ 1]) where f w = dodam thHit w & cWorld . lWorld . flares <>~ drawPulseLaser (sp : ps) where (thHit, ps) = reflectPulseLaserAlong phasev sp xp w dodam thit = case thit of ((p, OCreature cr) : _) -> cWorld . lWorld . creatures . ix (_crID cr) . crDamage .:~ Lasering (pz ^. pzDamage) p (xp - sp) ((p, OWall wl) : _) -> cWorld . lWorld . wallDamages . at (_wlID wl) . non mempty .:~ Lasering (pz ^. pzDamage) p (xp - sp) ((_, OPulseBall pb) : xs) -> dodam xs . (cWorld . lWorld . pulseBalls . ix (_pzbID pb) . pzbTimer .~ 0) . makeExplosionAt (_pzbPos pb `v2z` 20) 0 _ -> id phasev = _pzPhaseV pz sp = _pzPos pz dir = _pzDir pz xp = sp +.+ 800 *.* unitVectorAtAngle dir g w = w & cWorld . lWorld . flares <>~ drawPulseLaser (sp : ps) where (_, ps) = reflectPulseLaserAlong phasev sp xp w 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 updateClouds :: World -> World updateClouds w = updateObjMapMaybe clouds (updateCloud w) w updateGasses :: World -> World updateGasses = updateObjCatMaybes gasses updateGas updateDusts :: World -> World updateDusts w = updateObjMapMaybe dusts (updateDust w) w --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 --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 . respawnDelay of Just x | x < 0 -> uv -- & uvScreenLayers .~ [gameOverMenu uv] & uvWorld . timeFlow .~ NormalTimeFlow & uvWorld %~ respawn Just _ -> uv & uvWorld . timeFlow . respawnDelay -~ 1 _ | null (you w ^? crHP . _HP) -> uv & uvWorld . timeFlow .~ RespawnDelay 100 _ -> 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 gasEffect :: Gas -> World -> World gasEffect cl = case _gsType cl of PoisonGas -> cloudPoisonDamage cl updateCloud :: World -> Cloud -> Maybe Cloud updateCloud w c | _clTimer c < 1 = Nothing | otherwise = Just $ c & clPos .~ finalPos & clVel .~ finalVel & clTimer -~ 1 where newVel@(V3 _ _ nvz) = (0.95 *^ (springVels + c ^. clVel)) + V3 0 0 (0.01 * vertVel) newVel2 = stripZ newVel vertVel = min 5 $ clAlt c - opz springVels = sum $ map (radiusSpring 10 oldPos . _clPos) (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 90 npz) $ maybe newPos2 fst hitWl finalVel = addZ nvz $ maybe newVel2 snd hitWl updateGas :: World -> Gas -> (World, Maybe Gas) updateGas w c | _gsTimer c < 1 = (w, Nothing) | otherwise = ( gasEffect c w , Just $ c & gsPos .~ finalPos & gsVel .~ finalVel & gsTimer -~ 1 ) where newVel@(V3 _ _ nvz) = (0.95 *^ springVels) + V3 0 0 (0.01 * vertVel) newVel2 = stripZ newVel vertVel = min 5 $ 20 - opz springVels = c ^. gsPos + alaf Sum foldMap (radiusSpring 10 oldPos . _gsPos) (gassesNearPoint oldPos2 w) oldPos@(V3 _ _ opz) = _gsPos c oldPos2 = stripZ oldPos newPos@(V3 _ _ npz) = oldPos + newVel newPos2 = stripZ newPos hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w finalPos = addZ (min 90 npz) $ maybe newPos2 fst hitWl finalVel = addZ nvz $ maybe newVel2 snd hitWl updateDust :: World -> Dust -> Maybe Dust updateDust w c | _dsTimer c < 1 = Nothing | otherwise = Just $ c & dsPos +~ newvel & dsPos . _z %~ max 1 & dsVel .~ newvel & dsTimer -~ 1 where v@(V3 _ _ vz) = c ^. dsVel + alaf Sum foldMap (radiusSpring 10 oldPos . _dsPos) (dssNearPoint oldPos2 w) newvel = 0.95 * (maybe v (addZ vz . snd) hitWl - V3 0 0 0.05) oldPos = _dsPos c oldPos2 = stripZ oldPos newPos = oldPos + v newPos2 = stripZ newPos hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w radiusSpring :: Float -> Point3 -> Point3 -> Point3 radiusSpring r a b | dist3 a b < r = 0.1 *^ normalizeV3 (a - b) | otherwise = 0 simpleCrSprings :: World -> World simpleCrSprings w = IM.foldl' (flip crSpring) w $ IM.filter canSpring $ 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 = IM.foldl' (flip $ crCrSpring c) w . IM.filter canSpring $ crsNearCirc (c ^. crPos . _xy) (crRad $ c ^. crType) w canSpring :: Creature -> Bool canSpring cr = cr ^. crPos . _z >= 0 && case cr ^. crHP of HP{} -> True CrIsCorpse{} -> True CrDestroyed{} -> False crCrSpring :: Creature -> Creature -> World -> World crCrSpring c1 c2 | id1 == id2 = id | vec == V2 0 0 = id | diff >= comRad = id | diffheight = id | SlimeCrit{} <- c1 ^. crType , SlimeCrit{} <- c2 ^. crType , id2 > id1 , distance xy1 xy2 < abs (r1 - r2) + 1 = fuseSlimes c1 c2 | SlimeCrit{} <- c1 ^. crType , slimeFood c2 , distance xy1 xy2 < r1 - (r2 + 5) = feedSlime c1 c2 | Just t <- c1 ^? crType . slimeSplitTimer , slimeFood c2 , t <= 0 = slimeSuck c1 c2 | SlimeCrit{} <- c1 ^. crType = id | SlimeCrit{} <- c2 ^. crType = id | otherwise = cWorld . lWorld . creatures %~ ( olap c1 c2 . olap' c2 c1) where z c = c ^. crPos . _z h c = fmap (+ z c) (crHeight c) diffheight = fromMaybe True $ do h1 <- h c1 h2 <- h c2 return $ z c1 > h2 || z c2 > h1 olap a b = ix (a ^. crID) . crPos . _xy +~ overlap b olap' a b = ix (a ^. crID) . crPos . _xy -~ overlap b id1 = _crID c1 id2 = _crID c2 xy1 = c1 ^. crPos . _xy xy2 = c2 ^. crPos . _xy vec = c1 ^. crPos . _xy - c2 ^. crPos . _xy diff = magV vec r1 = crRad (c1 ^. crType) r2 = crRad (c2 ^. crType) comRad = crRad (c1 ^. crType) + crRad (c2 ^. crType) overlap c = ((comRad - diff) * cmass c * 0.5 / massT) *^ signorm vec massT = cmass c1 + cmass c2 cmass c = case c ^. crStance . carriage of Falling {} -> crMass (c ^. crType) * 10 _ -> crMass (c ^. crType) slimeSuck :: Creature -> Creature -> World -> World slimeSuck c1 c2 = cWorld . lWorld . creatures %~ (rolap . rolap') where suckx = (min 1 $ 2 * (1 - distance xy1 xy2 / (r1 + r2))) ^ (2:: Int) rolap = ix id1 . crPos . _xy +~ f (suckx * 1.5 * m2 / (m1+m2)) *^ normalize (xy2 - xy1) rolap' = ix id2 . crPos . _xy +~ f (suckx * 1.5*m1 / (m1+m2)) *^ normalize (xy1 - xy2) f = min (distance xy1 xy2/2) id1 = _crID c1 id2 = _crID c2 xy1 = c1 ^. crPos . _xy xy2 = c2 ^. crPos . _xy r1 = crRad (c1 ^. crType) r2 = crRad (c2 ^. crType) m1 = crMass $ c1 ^. crType m2 = crMass $ c2 ^. crType slimeFood :: Creature -> Bool slimeFood cr = case cr ^. crType of Avatar{} -> True ChaseCrit{} -> True CrabCrit {} -> True _ -> False feedSlime :: Creature -> Creature -> World -> World feedSlime s c w = fromMaybe w $ do ch <- crHeight c return $ if min 10 r1 + s ^?! crType . slimeEngulfProgress < max 15 (ch + 2) then w & cWorld.lWorld.creatures.ix (s^.crID).crType.slimeEngulfProgress%~ (min r1.(+0.7)) & slimeSuck s c else w & cWorld . lWorld . creatures . ix (c ^. crID) . crHP .~ CrDestroyed Swallowed & cWorld . lWorld . creatures . ix (s ^. crID) %~ f & slimeEatSound (s ^. crID) (s ^. crPos . _xy) where f cr = cr & crType . slimeRad .~ r & crType . slimeRadWobble +~ r - r1 & crType . slimeCompression %~ ((r/r1) *^) r1 = s ^?! crType . slimeRad r2 = c ^. crType . to crRad r = sqrt (r1*r1 + r2*r2) fuseSlimes :: Creature -> Creature -> World -> World fuseSlimes c1 c2 = (cWorld . lWorld . creatures . ix mini .~ c) . (cWorld . lWorld . creatures . at maxi .~ Nothing) . slimeEatSound i1 (c ^. crPos . _xy) where c' | c1 ^?! crType . slimeRad > c2 ^?! crType . slimeRad = c1 | otherwise = c2 mini = min i1 i2 maxi = max i1 i2 i1 = c1 ^. crID i2 = c2 ^. crID c = c' & crType . slimeRad .~ r & crType . slimeRadWobble +~ r - max r1 r2 & crType . slimeCompression %~ ((r/max r1 r2) *^) & crID .~ mini r1 = c1 ^?! crType . slimeRad r2 = c2 ^?! crType . slimeRad r = sqrt (r1*r1 + r2*r2) slimeEatSound :: Int -> Point2 -> World -> World slimeEatSound i p w = w & soundStart (CrSound i) p s Nothing & randGen .~ g where (s,g) = runState (takeOne [slurp1S,slurp2S,slurp3S,slurp4S,slurp5S]) (w ^. randGen) 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))