1063 lines
40 KiB
Haskell
1063 lines
40 KiB
Haskell
{-# 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 (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 . _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 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
|
|
|
|
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
|
|
|
|
-- should possibly limit how big this can get
|
|
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 =
|
|
--cWorld . lWorld . creatures %~ (rolap c1 c2 . rolap' c2 c1)
|
|
cWorld . lWorld . creatures %~ (rolap . rolap')
|
|
| SlimeCrit{} <- c2 ^. crType = id
|
|
-- cWorld . lWorld . creatures %~ ( rolap c1 c2 . rolap' c2 c1)
|
|
| 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
|
|
suckx = min 1 (2 * (1 - distance xy1 xy2 / (r1 + r2)))
|
|
rolap = ix id1 . crPos . _xy +~ (2*m2 / (m1+m2)) *^ normalize (xy2 - xy1)
|
|
rolap' = ix id2 . crPos . _xy +~ (suckx * 1.5*m1 / (m1+m2)) *^ normalize (xy1 - xy2)
|
|
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) * crMass (_crType c) * 0.5 / massT) *^ signorm vec
|
|
massT = crMass (_crType c1) + crMass (_crType c2)
|
|
m1 = crMass $ c1 ^. crType
|
|
m2 = crMass $ c2 ^. crType
|
|
|
|
fuseSlimes :: Creature -> Creature -> World -> World
|
|
fuseSlimes c1 c2 = (cWorld . lWorld . creatures . ix i1 .~ c)
|
|
. (cWorld . lWorld . creatures . at i2 .~ Nothing)
|
|
where
|
|
i1 = c1 ^. crID
|
|
i2 = c2 ^. crID
|
|
c = c1 & crType . slimeRad .~ r
|
|
& crType . slimeCompression .~ V2 r 0
|
|
& crPos . _xy .~ (r1/(r1+r2)) *^ xy1 + (r2/(r1+r2)) *^ xy2
|
|
xy1 = c1 ^. crPos . _xy
|
|
xy2 = c2 ^. crPos . _xy
|
|
r1 = c1 ^?! crType . slimeRad
|
|
r2 = c2 ^?! crType . slimeRad
|
|
r = sqrt (r1*r1 + r2*r2)
|
|
|
|
|
|
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))
|