--{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {- | Module : Dodge.Update Description : Simulation update -} module Dodge.Update (updateUniverse) where 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.Cloud import Dodge.CrGroupUpdate import Dodge.Creature.Mass 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.DrWdWd import Dodge.EnergyBall import Dodge.Flame import Dodge.Inventory import Dodge.Item.Weapon.LaserPath import Dodge.Laser.Update import Dodge.LinearShockwave.Update import Dodge.ListDisplayParams import Dodge.Machine.Update --import Dodge.Menu import Dodge.ModificationEffect import Dodge.PressPlate import Dodge.Projectile.Update import Dodge.Prop.Moving 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.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 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 "Enter command" : xs updateUniverseLast :: Universe -> Universe updateUniverseLast u = u & over (uvWorld . input . textInput) (const 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)) where mp = u ^. uvWorld . input . mousePos mwp = screenToWorldPos (u ^. uvWorld . wCam) mp {- 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 RespawnDelay{} -> functionalUpdate 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) updateDoor) . 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 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' (_props . _lWorld . _cWorld) updateProp) . over uvWorld (updateIMl' (_projectiles . _lWorld . _cWorld) updateProjectile) . over uvWorld updateClouds . over uvWorld updateDusts . 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 zoneDusts . 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) updateDoor :: Door -> World -> World updateDoor dr = doDrWdWd (_drMech dr) dr 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 (_crPos $ you w) > 40 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 -> updateMouseContextGame cfig u updateMouseContextGame :: Config -> 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 | ButtonRight `M.member` (w ^. input . mouseButtons) = MouseAiming | otherwise = MouseInGame mpos = w ^. input . mousePos disss = w ^. hud . diSections invdrag i' = fromMaybe (OverInvDrag i' Nothing) $ do (i, j) <- inverseSelNumPos cfig invDP mpos disss return $ OverInvDrag i' (Just (i, j)) overinv = do selpos@(i, j) <- inverseSelNumPos cfig invDP mpos disss 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 secondColumnParams (w ^. input . mousePos) sss 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 return $ if isOverTerminalScreen cfig mpos then OverTerminal tmid (tm ^. tmStatus) else OutsideTerminal 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 :: Config -> Point2 -> Bool isOverTerminalScreen cfig (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 + 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) updatePulseLasers :: World -> World updatePulseLasers w = f w & cWorld . lWorld . pulseLasers .~ pzs where (Endo f, pzs) = foldMap updatePulseLaser (w ^. cWorld . lWorld . pulseLasers) updatePulseBall :: PulseBall -> World -> World updatePulseBall pb w | Just (_, ecrwl) <- thit = w & cWorld . lWorld . pulseBalls . at (pb ^. pbID) .~ Nothing & cWorld . lWorld %~ dodam ecrwl | pb ^. pbTimer <= 0 = w & cWorld . lWorld . pulseBalls . at (pb ^. pbID) .~ Nothing | otherwise = w & cWorld . lWorld . pulseBalls . ix (pb ^. pbID) . pbTimer -~ 1 & cWorld . lWorld . pulseBalls . ix (pb ^. pbID) . pbPos .~ 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 ^. pbVel) sp = pb ^. pbPos ep = sp + pb ^. pbVel thit = thingHit sp ep w pbFlicker :: PulseBall -> World -> World pbFlicker pt = cWorld . lWorld . lights .:~ LSParam (addZ 5 $ _pbPos pt) d (0.5 * xyzV4 chartreuse) where d = 4 * fromIntegral (10 + abs ((_pbTimer pt `mod` 20) - 10)) zoneClouds :: World -> World zoneClouds w = w & clZoning .~ foldl' (flip zoneCloud) mempty (w ^. cWorld . lWorld . clouds) 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) tmUpdate :: Terminal -> World -> World tmUpdate 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) . (tmDisplayedLines %~ take getMaxLinesTM . (map displayTerminalLineString tls ++)) -- . (tmDisplayedLines %~ (map displayTerminalLineString tls ++)) ) & doTmWdWd g tm where pointTermParams = cWorld . lWorld . terminals . ix (_tmID tm) setOldPos :: Creature -> Creature setOldPos cr = cr & crOldPos .~ _crPos cr --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 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 <>~ drawLaser cyan (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 (_pbID pb) . pbTimer .~ 0) . makeExplosionAt (_pbPos 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 <>~ drawLaser cyan (sp : ps) where (_, ps) = reflectLaserAlong 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 = updateObjCatMaybes clouds updateCloud 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 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 . respawnDelay of Just x | x < 0 -> uv -- & uvScreenLayers .~ [gameOverMenu uv] & uvWorld . timeFlow .~ NormalTimeFlow & uvWorld %~ respawn Just _ -> uv & uvWorld . timeFlow . respawnDelay -~ 1 _ | _crHP (you w) < 1 -> uv & uvWorld . timeFlow .~ RespawnDelay 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 _ -> 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.01 * vertVel) newVel2 = stripZ newVel vertVel = min 5 $ 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 (max 1 $ 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 .~ finalpos & dsVel .~ newvel & dsTimer -~ 1 where v@(V3 _ _ vz) = foldl' (dustSpringVel c) (_dsVel c) (dssNearPoint oldPos2 w) newvel = 0.95 * (maybe v (addZ vz . snd) hitWl - V3 0 0 0.05) oldPos = _dsPos c oldPos2 = stripZ oldPos newPos@(V3 _ _ npz) = oldPos + v newPos2 = stripZ newPos hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w finalpos = addZ (max 1 $ min 90 npz) $ maybe newPos2 fst 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 = 10 --radDist = (_clRad a + _clRad b) / 2 dustSpringVel :: Dust -> Point3 -> Dust -> Point3 dustSpringVel a v b | dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb) | otherwise = v where pa = _dsPos a pb = _dsPos b radDist = 10 simpleCrSprings :: World -> World simpleCrSprings w = IM.foldl' (flip crSpring) w $ IM.filter (\cr -> _crZ cr >= 0) $ 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 ^. crType) + crRad (c2 ^. crType) overlap1 = ((comRad - diff) * crMass (_crType c2) * 0.5 / massT) *.* errorNormalizeV 55 vec overlap2 = ((comRad - diff) * crMass (_crType c1) * 0.5 / massT) *.* errorNormalizeV 56 vec massT = crMass (_crType c1) + crMass (_crType 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))