From 6554d219dc42a09cac777ba1e7db5944ce1de1e4 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 26 Jul 2022 21:19:12 +0100 Subject: [PATCH] Cleanup, split CWorld into separate file --- appDodge/Main.hs | 2 +- src/Dodge/Button/Event.hs | 6 +- src/Dodge/Creature.hs | 49 +- src/Dodge/Creature/Action.hs | 348 ++++++------ src/Dodge/Creature/Impulse/UseItem.hs | 5 +- src/Dodge/Data.hs | 118 +---- src/Dodge/Data/ActionPlan.hs | 192 ++++--- src/Dodge/Data/CWorld.hs | 159 ++++++ src/Dodge/Data/Creature.hs | 9 +- .../Data.hs => Data/Creature/Memory.hs} | 2 +- .../Data.hs => Data/Creature/Perception.hs} | 2 +- .../Data.hs => Data/Creature/Stance.hs} | 2 +- src/Dodge/Data/Item/HeldUse.hs | 17 + src/Dodge/Data/WorldEffect.hs | 10 + src/Dodge/Default/World.hs | 16 +- src/Dodge/Event.hs | 6 +- src/Dodge/Event/Keyboard.hs | 8 +- src/Dodge/HeldUse.hs | 34 +- src/Dodge/Inventory.hs | 38 +- src/Dodge/ItEffect.hs | 1 - src/Dodge/Item/Weapon/BulletGun/Cane.hs | 301 +++++------ src/Dodge/Item/Weapon/TriggerType.hs | 12 +- src/Dodge/Render/HUD.hs | 6 +- src/Dodge/Render/ShapePicture.hs | 12 +- src/Dodge/Update.hs | 498 ++++++++++-------- src/Dodge/Update/UsingInput.hs | 4 +- src/Dodge/WorldEffect.hs | 103 ++-- 27 files changed, 1049 insertions(+), 911 deletions(-) create mode 100644 src/Dodge/Data/CWorld.hs rename src/Dodge/{Creature/Memory/Data.hs => Data/Creature/Memory.hs} (92%) rename src/Dodge/{Creature/Perception/Data.hs => Data/Creature/Perception.hs} (98%) rename src/Dodge/{Creature/Stance/Data.hs => Data/Creature/Stance.hs} (97%) diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 389fdce8a..cb8c7d0ca 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -97,7 +97,7 @@ updateRenderSplit u = do playSoundUnlessRewinding :: Universe -> IO (M.Map SoundOrigin Sound) playSoundUnlessRewinding u - | _timeFlow (_cWorld w) == RewindingNow = return M.empty + | _timeFlow w == RewindingNow = return M.empty | otherwise = playSoundAndUpdate (_soundData $ _preloadData u) (_playingSounds w) (_toPlaySounds w) where w = _uvWorld u diff --git a/src/Dodge/Button/Event.hs b/src/Dodge/Button/Event.hs index d4b1171fa..5e3253705 100644 --- a/src/Dodge/Button/Event.hs +++ b/src/Dodge/Button/Event.hs @@ -8,7 +8,7 @@ import Control.Lens doButtonEvent :: ButtonEvent -> Button -> World -> World doButtonEvent be = case be of ButtonDoNothing -> const id - ButtonPress newstate newevent thesound f -> \b -> doWorldEffect f + ButtonPress newstate newevent thesound f -> \b -> doWdWd f . set (cWorld . buttons . ix (_btID b) . btState) newstate . set (cWorld . buttons . ix (_btID b) . btEvent) newevent . soundStart (LeverSound 0) (_btPos b) thesound Nothing @@ -18,9 +18,9 @@ doButtonEvent be = case be of flipSwitch :: WdWd -> WdWd -> Button -> World -> World flipSwitch oneff offeff bt - | _btState bt == BtOff = doWorldEffect oneff . dosound + | _btState bt == BtOff = doWdWd oneff . dosound . over (cWorld . buttons . ix (_btID bt)) turnon - | otherwise = doWorldEffect offeff . dosound + | otherwise = doWdWd offeff . dosound . over (cWorld . buttons . ix (_btID bt)) turnoff where turnon = (btState .~ BtOn ) . (btText .~ "SWITCH\\") diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 6046ed5ef..8cc864109 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -128,7 +128,6 @@ inventoryX c = case c of [ blinkGun , unsafeBlinkGun , autoDetector WALLDETECTOR - -- , effectGun "GIBBER" addCrGibs ] 'E' -> [ makeTypeCraftNum 3 PIPE @@ -176,8 +175,7 @@ inventoryX c = case c of [ lasGun , lasGun , dualBeam - , -- , lasWidePulse - makeTypeCraftNum 10 TRANSFORMER + , makeTypeCraftNum 10 TRANSFORMER ] 'K' -> [ autoRifle @@ -216,27 +214,11 @@ testInventory = , makeTypeCraft INCENDIARYMODULE , makeTypeCraft STATICMODULE , makeTypeCraft CONCUSSMODULE - , -- , bounceModule - -- , medkit 50 & itConsumption . itAmount .~ 3 - teleportModule - , -- , makeTypeCraftNum 1 LIGHTER - -- , makeTypeCraftNum 15 TUBE - -- , makeTypeCraftNum 9 TRANSFORMER - -- , makeTypeCraftNum 5 CREATURESENSOR - -- , makeTypeCraftNum 9 PRISM - -- , makeTypeCraftNum 3 DRUM - -- , makeTypeCraftNum 3 PUMP - -- , makeTypeCraftNum 3 BATTERY - -- , makeTypeCraftNum 1 MAGNET - -- , makeTypeCraftNum 1 TRANSMITTER - makeTypeCraftNum 10 HARDWARE + , teleportModule + , makeTypeCraftNum 10 HARDWARE , makeTypeCraftNum 3 SPRING , makeTypeCraftNum 10 CAN - , -- , makeTypeCraftNum 3 TIN - makeTypeCraftNum 3 PLANK - -- , makeTypeCraftNum 1 MOTOR - -- , makeTypeCraftNum 5 MICROCHIP - -- , makeTypeCraftNum 5 AIUNIT + , makeTypeCraftNum 3 PLANK ] stackedInventory :: IM.IntMap Item @@ -244,8 +226,7 @@ stackedInventory = IM.fromList $ zip [0 ..] - [ --sonicGun - burstRifle + [ burstRifle , pipe , rewindGun , tractorGun @@ -254,28 +235,12 @@ stackedInventory = , teslaGun , blinkGun , miniGunX 3 - , -- ,multGun - boosterGun + , boosterGun , remoteLauncher , flatShield - , -- ,grenade - spawnGun (lamp 5) + , spawnGun (lamp 5) , lasGun , flameThrower , poisonSprayer , launcher - -- ,droneLauncher - --,lasGun - --,grenade - --,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher - --,longGun - --,hvAutoGun - --,teslaGun - --,latchkey 0 - --,miniGun - --,medkit 50 - --,bezierGun ] - ---smokeGenGun :: Item ---smokeGenGun = effectGun "smoke" $ const spawnSmokeAtCursor diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index e3142826a..3e5b8f304 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -1,61 +1,51 @@ --{-# LANGUAGE TupleSections #-} -{- | Actions performed by creatures within the world - -} -module Dodge.Creature.Action - ( performActions - , stripNoItems - , setMinInvSize - , dropUnselected - , dropExcept - , dropItem --- , startReloadingWeapon - , blinkAction - , blinkActionFail - , unsafeBlinkAction - , sizeSelf --- , crAutoReload - , copyInvItemToFloor - , youDropItem - , pickUpItem - , pickUpItemID - ) - where -import Dodge.FloatFunction -import Dodge.Inventory.Add -import Dodge.CreatureEffect ---import Dodge.ShortShow -import Dodge.Path -import Dodge.Default -import Dodge.WallCreatureCollisions -import Dodge.Creature.Stance.Data -import Dodge.WorldEvent.Shockwave -import Dodge.Data -import Dodge.Base ---import Dodge.Zone -import Dodge.SoundLogic ---import Dodge.WorldEvent -import Dodge.Inventory -import Dodge.FloorItem ---import Dodge.LightSources -import Geometry -import Picture -import qualified IntMapHelp as IM -import LensHelp ---import Control.Monad ---import Control.Applicative -import Data.Maybe +-- | Actions performed by creatures within the world +module Dodge.Creature.Action ( + performActions, + stripNoItems, + setMinInvSize, + dropUnselected, + dropExcept, + dropItem, + blinkAction, + blinkActionFail, + unsafeBlinkAction, + sizeSelf, + copyInvItemToFloor, + youDropItem, + pickUpItem, + pickUpItemID, +) where import Data.Bifunctor import Data.List (findIndex) ---import qualified Data.Map as M +import Data.Maybe +import Dodge.Base +import Dodge.CreatureEffect +import Dodge.Data +import Dodge.Default +import Dodge.FloatFunction +import Dodge.FloorItem +import Dodge.Inventory +import Dodge.Inventory.Add +import Dodge.Path +import Dodge.SoundLogic +import Dodge.WallCreatureCollisions +import Dodge.WorldEvent.Shockwave +import Geometry +import qualified IntMapHelp as IM +import LensHelp +import Picture + performActions :: World -> Creature -> Creature -performActions w cr = cr - & crActionPlan . apImpulse .~ concat iss - & crActionPlan . apAction .~ catMaybes mayas +performActions w cr = + cr + & crActionPlan . apImpulse .~ concat iss + & crActionPlan . apAction .~ catMaybes mayas where (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . apAction -type OutAction = ( [Impulse] , Maybe Action ) +type OutAction = ([Impulse], Maybe Action) performAimAt :: Creature -> World -> Int -> Point2 -> OutAction performAimAt cr w tcid p = ([TurnToward tpos aimSp], Just $ AimAt tcid tpos) @@ -66,22 +56,24 @@ performAimAt cr w tcid p = ([TurnToward tpos aimSp], Just $ AimAt tcid tpos) aimSp = case cr ^? crMvType . mvAimSpeed of Just f -> doFloatFloat f $ safeAngleVV (unitVectorAtAngle cdir) (tpos - cpos) Nothing -> error "creature without aiming type" - tpos | canSee' = _crPos (_creatures (_cWorld w) IM.! tcid) - | otherwise = p + tpos + | canSee' = _crPos (_creatures (_cWorld w) IM.! tcid) + | otherwise = p performPathTo :: Creature -> World -> Point2 -> OutAction performPathTo cr w p | dist cpos p <= _crRad cr = ([], Nothing) - | isWalkable cpos p w = ([MvTurnToward p,MvForward,RandomTurn jit] , Just (PathTo p)) + | isWalkable cpos p w = ([MvTurnToward p, MvForward, RandomTurn jit], Just (PathTo p)) | otherwise = case pointTowardsImpulse p cpos w of - Just q -> ([MvTurnToward q - ,MvForward - ,RandomTurn jit --- ,ArbitraryImpulseEffect . const --- $ debugPicture .~ drawPathList cpos p w - ] - , Just (PathTo p)) - _ -> ([],Nothing) + Just q -> + ( + [ MvTurnToward q + , MvForward + , RandomTurn jit + ] + , Just (PathTo p) + ) + _ -> ([], Nothing) where cpos = _crPos cr jit = _mvTurnJit $ _crMvType cr @@ -89,7 +81,7 @@ performPathTo cr w p performTurnToA :: Creature -> Point2 -> OutAction performTurnToA cr p | angleVV cdirv dirv < 0.1 = ([], Nothing) - | otherwise = ([MvTurnToward p,RandomTurn jit] , Just (TurnToPoint p)) + | otherwise = ([MvTurnToward p, RandomTurn jit], Just (TurnToPoint p)) where cpos = _crPos cr cdirv = unitVectorAtAngle (_crDir cr) @@ -98,29 +90,29 @@ performTurnToA cr p {- | Performing an action means that a creature has some impulses for a frame, and updates or deletes the action itself. --- doAction -} +-} performAction :: Creature -> World -> Action -> OutAction performAction cr w ac = case ac of - ActionNothing -> ([],Nothing) + ActionNothing -> ([], Nothing) LabelAction str subAc -> second (fmap (LabelAction str)) $ performAction cr w subAc AimAt tcid p -> performAimAt cr w tcid p - WaitThen 0 newAc -> ([] , Just newAc) - WaitThen t newAc -> ([] , Just (WaitThen (t-1) newAc)) - ImpulsesList (xs:xss) -> (xs, Just $ ImpulsesList xss) - ImpulsesList _ -> ([], Nothing) + WaitThen 0 newAc -> ([], Just newAc) + WaitThen t newAc -> ([], Just (WaitThen (t -1) newAc)) + ImpulsesList (xs : xss) -> (xs, Just $ ImpulsesList xss) + ImpulsesList _ -> ([], Nothing) DoImpulses imps -> (imps, Nothing) DoActionThen fsta afta -> case performAction cr w fsta of - (imps , Just nxta) -> (imps, Just (DoActionThen nxta afta)) - (imps , Nothing ) -> (imps, Just afta) + (imps, Just nxta) -> (imps, Just (DoActionThen nxta afta)) + (imps, Nothing) -> (imps, Just afta) DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act DoActionWhilePartial partAc f resetAc | doWdCrBl f w cr -> case performAction cr w partAc of (imps, Just nxta) -> (imps, Just $ DoActionWhilePartial nxta f resetAc) - (imps, Nothing) -> (imps, Just $ DoActionWhilePartial resetAc f resetAc) + (imps, Nothing) -> (imps, Just $ DoActionWhilePartial resetAc f resetAc) | otherwise -> performAction cr w partAc DoActionIf f ifa | doWdCrBl f w cr -> performAction cr w ifa - | otherwise -> ([],Nothing) + | otherwise -> ([], Nothing) DoActionIfElse ifa f elsea | doWdCrBl f w cr -> performAction cr w ifa | otherwise -> performAction cr w elsea @@ -128,190 +120,206 @@ performAction cr w ac = case ac of | doWdCrBl f w cr -> (fst $ performAction cr w repa, Just $ DoActionWhileInterrupt repa f afta) | otherwise -> performAction cr w afta DoActions [] -> ([], Nothing) - DoActions acs -> + DoActions acs -> let (imps, newAcs) = unzip $ map (performAction cr w) acs - in (concat imps, Just . DoActions $ catMaybes newAcs) + in (concat imps, Just . DoActions $ catMaybes newAcs) StartSentinelPost -> ([AddGoal $ SentinelAt (_crPos cr) (_crDir cr)], Nothing) PathTo p -> performPathTo cr w p TurnToPoint p -> performTurnToA cr p LeadTarget p -> case cr ^? crIntention . targetCr . _Just of Just tcr -> ([TurnTo (_crPos tcr +.+ rotateV (_crDir tcr) p)], Nothing) - _ -> ([], Nothing) + _ -> ([], Nothing) UseTarget f -> performAction cr w $ doMCrAc f $ cr ^? crIntention . targetCr . _Just - UseSelf f -> performAction cr w $ doCrAc f cr + UseSelf f -> performAction cr w $ doCrAc f cr UseAheadPos f -> performAction cr w (doP2Ac f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr))) UseMvTargetPos f -> performAction cr w $ doMP2Ac f $ _mvToPoint $ _crIntention cr ArbitraryAction f -> performAction cr w (doCrWdAc f cr w) DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of (imp, Just nxtac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp nxtac) - (imp, _) -> (sideImp ++ imp, Nothing) + (imp, _) -> (sideImp ++ imp, Nothing) DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac - DoReplicatePartial _ 0 pac -> performAction cr w pac + DoReplicatePartial _ 0 pac -> performAction cr w pac DoReplicatePartial startac t partac -> case performAction cr w partac of - (imps , Just nextac) -> (imps, Just $ DoReplicatePartial startac t nextac) - (imps , _) -> (imps, Just $ DoReplicatePartial startac (t-1) startac) - NoAction -> ([],Nothing) + (imps, Just nextac) -> (imps, Just $ DoReplicatePartial startac t nextac) + (imps, _) -> (imps, Just $ DoReplicatePartial startac (t -1) startac) + NoAction -> ([], Nothing) -{- | Like a blink action, but no ingoing distortion -} -blinkActionFail - :: Creature - -> World - -> World -blinkActionFail cr w = w - & soundMultiFrom [TeleSound 0,TeleSound 1] p3 teleS Nothing - & cWorld . distortions .:~ distortionBulge - & cWorld . creatures . ix cid . crPos .~ p3 - & inverseShockwaveAt cpos 40 2 2 +-- | Like a blink action, but no ingoing distortion +blinkActionFail :: + Creature -> + World -> + World +blinkActionFail cr w = + w + & soundMultiFrom [TeleSound 0, TeleSound 1] p3 teleS Nothing + & cWorld . distortions .:~ distortionBulge + & cWorld . creatures . ix cid . crPos .~ p3 + & inverseShockwaveAt cpos 40 2 2 where distR = 120 distortionBulge = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9 - cid = _crID cr + cid = _crID cr p1 = mouseWorldPos w cpos = _crPos cr p2 = bouncePoint (const True) 1 cpos p1 w - r = 1.5 * _crRad cr + r = 1.5 * _crRad cr p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 -{- | Teleport a creature to the mouse position -} +-- | Teleport a creature to the mouse position blinkAction :: Creature -> World -> World -blinkAction cr w = w - & soundMultiFrom [TeleSound 0,TeleSound 1] p3 teleS Nothing - & cWorld . distortions .++~ distortionBulge - & cWorld . creatures . ix cid . crPos .~ p3 - & blinkShockwave cid p3 - & inverseShockwaveAt cpos 40 2 2 +blinkAction cr w = + w + & soundMultiFrom [TeleSound 0, TeleSound 1] p3 teleS Nothing + & cWorld . distortions .++~ distortionBulge + & cWorld . creatures . ix cid . crPos .~ p3 + & blinkShockwave cid p3 + & inverseShockwaveAt cpos 40 2 2 where distR = 120 - distortionBulge = - [RadialDistortion p3 (p3 +.+ V2 distR 0) (p3 +.+ V2 0 distR) 0.1 - ,RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9 + distortionBulge = + [ RadialDistortion p3 (p3 +.+ V2 distR 0) (p3 +.+ V2 0 distR) 0.1 + , RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9 ] - cid = _crID cr + cid = _crID cr p1 = mouseWorldPos w cpos = _crPos cr p2 = bouncePoint (const True) 1 cpos p1 w - r = 1.5 * _crRad cr + r = 1.5 * _crRad cr p3 = maybe p1 (mvPointTowardAtSpeed r cpos . fst) p2 {- | Teleport a creature to the mouse position. -Can go through walls, if ending up in wall does big damage. -} -unsafeBlinkAction - :: Creature - -> World - -> World -unsafeBlinkAction cr w - | success = soundMultiFrom [TeleSound 0,TeleSound 1] mwp teleS Nothing - . (cWorld . distortions .++~ distortionBulge) - . set (cWorld . creatures . ix cid . crPos) mwp - . blinkShockwave cid mwp - $ inverseShockwaveAt cpos 40 2 2 w - | otherwise = w - & blinkActionFail cr - & cWorld . creatures . ix cid . crState . csDamage .:~ - Damage ENTERREMENT 10000 mwp mwp mwp NoDamageEffect +Can go through walls, if ending up in wall does big damage. +-} +unsafeBlinkAction :: + Creature -> + World -> + World +unsafeBlinkAction cr w + | success = + soundMultiFrom [TeleSound 0, TeleSound 1] mwp teleS Nothing + . (cWorld . distortions .++~ distortionBulge) + . set (cWorld . creatures . ix cid . crPos) mwp + . blinkShockwave cid mwp + $ inverseShockwaveAt cpos 40 2 2 w + | otherwise = + w + & blinkActionFail cr + & cWorld . creatures . ix cid . crState . csDamage + .:~ Damage ENTERREMENT 10000 mwp mwp mwp NoDamageEffect where success = fromMaybe True $ do wl <- snd $ collidePointWallsFilterStream (const True) mwp cpos w return (isLHS mwp `uncurry` _wlLine wl) distR = 120 - distortionBulge = - [RadialDistortion mwp (mwp +.+ V2 distR 0) (mwp +.+ V2 0 distR) 0.1 - ,RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9 + distortionBulge = + [ RadialDistortion mwp (mwp +.+ V2 distR 0) (mwp +.+ V2 0 distR) 0.1 + , RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) 1.9 ] - cid = _crID cr + cid = _crID cr mwp = mouseWorldPos w cpos = _crPos cr -blinkShockwave - :: Int -- ^ Blinking creature ID. - -> Point2 - -> World - -> World -blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan +blinkShockwave :: + -- | Blinking creature ID. + Int -> + Point2 -> + World -> + World +blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan setMinInvSize :: Int -> Creature -> World -> World setMinInvSize n cr = cWorld . creatures . ix (_crID cr) . crInvCapacity .~ n -- maybe this should be removed... stripNoItems :: Creature -> World -> World -stripNoItems cr = organiseInvKeys (_crID cr) . - ( cWorld . creatures . ix (_crID cr) . crInv %~ IM.mapMaybe Just ) +stripNoItems cr = + organiseInvKeys (_crID cr) + . (cWorld . creatures . ix (_crID cr) . crInv %~ IM.mapMaybe Just) organiseInvKeys :: Int -> World -> World -organiseInvKeys cid w = w & cWorld . creatures . ix cid %~ - ( ( crInvSel . iselPos .~ newSelKey ) - . ( crInv .~ newInv ) - . ( crInvSel . iselAction .~ NoInvSelAction) ) +organiseInvKeys cid w = + w & cWorld . creatures . ix cid + %~ ( (crInvSel . iselPos .~ newSelKey) + . (crInv .~ newInv) + . (crInvSel . iselAction .~ NoInvSelAction) + ) where - cr = _creatures (_cWorld w) IM.! cid + cr = _creatures (_cWorld w) IM.! cid pairs = IM.toList (_crInv cr) - newSelKey = fromMaybe 0 $ findIndex ( (== crSel cr) . fst) pairs - newInv = IM.fromAscList $ zip [0..] $ map snd pairs + newSelKey = fromMaybe 0 $ findIndex ((== crSel cr) . fst) pairs + newInv = IM.fromAscList $ zip [0 ..] $ map snd pairs dropUnselected :: Creature -> World -> World -dropUnselected cr w = foldr (dropItem cr) w . IM.keys - $ crSel cr `IM.delete` _crInv cr +dropUnselected cr w = + foldr (dropItem cr) w . IM.keys $ + crSel cr `IM.delete` _crInv cr dropExcept :: Creature -> Int -> World -> World -dropExcept cr invid w = foldr (dropItem cr) w . IM.keys - $ invid `IM.delete` _crInv cr +dropExcept cr invid w = + foldr (dropItem cr) w . IM.keys $ + invid `IM.delete` _crInv cr dropItem :: Creature -> Int -> World -> World dropItem cr invid = rmInvItem cid invid . copyInvItemToFloor cr invid -- . mayberemoveequip where cid = _crID cr + -- the following should be done in rmInvItem -- mayberemoveequip = case _crLeftInvSel cr of -- Just i | i == invid -> creatures . ix cid . crLeftInvSel .~ Nothing -- _ -> id youDropItem :: World -> World -youDropItem w +youDropItem w | _crInvLock (you w) = w | otherwise = youDropItem' w -{- | Get your creature to drop the item under the cursor. -} +-- | Get your creature to drop the item under the cursor. youDropItem' :: World -> World youDropItem' w = case yourItem w ^? _Just . itCurseStatus of - Just Uncursed -> w - & dropItem cr (crSel cr) - & soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing + Just Uncursed -> + w + & dropItem cr (crSel cr) + & soundStart (CrSound (_crID cr)) (_crPos cr) whiteNoiseFadeOutS Nothing _ -> w where cr = you w -{- | Copy an inventory item to the floor. -} +-- | Copy an inventory item to the floor. copyInvItemToFloor :: Creature -> Int -> World -> World -copyInvItemToFloor cr i = copyItemToFloor (_crPos cr) - $ _crInv cr IM.! i - & itIsHeld .~ False +copyInvItemToFloor cr i = + copyItemToFloor (_crPos cr) $ + _crInv cr IM.! i + & itIsHeld .~ False sizeSelf :: Float -> Creature -> World -> Maybe World -sizeSelf x cr w - -- | _crPos cr1 == _crPos cr2 = Just $ w - | not (crOnWall cr1 w) = Just $ w - & soundMultiFrom [TeleSound 0,TeleSound 1] cpos teleS Nothing - & cWorld . distortions .:~ distortionBulge - & cWorld . creatures . ix cid %~ - ( (crRad .~ 10 * x) - . (crMvType . mvSpeed .~ yourDefaultSpeed * x) - . (crStance . strideLength .~ ceiling (fromIntegral yourDefaultStrideLength * x)) - ) +sizeSelf x cr w + | not (crOnWall cr1 w) = + Just $ + w + & soundMultiFrom [TeleSound 0, TeleSound 1] cpos teleS Nothing + & cWorld . distortions .:~ distortionBulge + & cWorld . creatures . ix cid + %~ ( (crRad .~ 10 * x) + . (crMvType . mvSpeed .~ yourDefaultSpeed * x) + . (crStance . strideLength .~ ceiling (fromIntegral yourDefaultStrideLength * x)) + ) | otherwise = Nothing where - cr1 = colCrWall w (cr {_crRad = 10* x}) + cr1 = colCrWall w (cr{_crRad = 10 * x}) distR = 120 - distortionBulge - | _crRad cr < 10*x = raddist 1.9 - | otherwise = raddist 0.1 + distortionBulge + | _crRad cr < 10 * x = raddist 1.9 + | otherwise = raddist 0.1 raddist = RadialDistortion cpos (cpos +.+ V2 distR 0) (cpos +.+ V2 0 distR) - cid = _crID cr + cid = _crID cr cpos = _crPos cr pickUpItemID :: Int -> Int -> World -> World pickUpItemID cid flid w = pickUpItem cid (_floorItems (_cWorld w) IM.! flid) w -{- | Pick up a specific item. -} +-- | Pick up a specific item. pickUpItem :: Int -> FloorItem -> World -> World -pickUpItem cid flit w = maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing . snd) - $ tryPutItemInInv cid flit w +pickUpItem cid flit w = + maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing . snd) $ + tryPutItemInInv cid flit w diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index 494d90a0a..98166d6dd 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -1,6 +1,7 @@ module Dodge.Creature.Impulse.UseItem ( useItem , useLeftItem + , itemEffect ) where import Dodge.Data import Dodge.Luse @@ -41,8 +42,8 @@ itemEffect cr it w = case it ^? itUse of HammerUp -> f w _ -> w & setuhamdown setuhamdown = cWorld . creatures . ix (_crID cr) . crHammerPosition .~ HammerDown - doequipmentchange = setuhamdown $ hammerTest (toggleEquipmentAt (_rbOptions (_cWorld w)) (crSel cr) cr - . activateEquipmentAt (_rbOptions (_cWorld w)) cr) + doequipmentchange = setuhamdown $ hammerTest (toggleEquipmentAt (_rbOptions w) (crSel cr) cr + . activateEquipmentAt (_rbOptions w) cr) tryReload :: Creature -> Item -> World -> (World -> World) -> World -> World tryReload cr it w f diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 72be02208..338487016 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -58,9 +58,6 @@ module Dodge.Data ( module Dodge.Distortion.Data, module Dodge.Data.Damage, module Dodge.Data.SoundOrigin, - module Dodge.Creature.Stance.Data, - module Dodge.Creature.Perception.Data, - module Dodge.Creature.Memory.Data, module Dodge.Config.Data, module MaybeHelp, module Dodge.Data.ItemAmount, @@ -83,14 +80,14 @@ module Dodge.Data ( module Dodge.Data.GenParams, module Dodge.Data.Terminal, module Dodge.Data.FloorItem, + module Dodge.Data.CWorld, ) where +import Dodge.Data.CWorld import Color import Control.Lens import Control.Monad.State import Data.Aeson -import Data.Graph.Inductive -import qualified Data.IntSet as IS import qualified Data.Map.Strict as M import Data.Preload import qualified Data.Set as S @@ -99,9 +96,6 @@ import Data.Tile import Dodge.Combine.Data import Dodge.Config.Data import Dodge.Config.KeyConfig -import Dodge.Creature.Memory.Data -import Dodge.Creature.Perception.Data -import Dodge.Creature.Stance.Data import Dodge.Data.ActionPlan import Dodge.Data.Ammo import Dodge.Data.ArcStep @@ -163,10 +157,8 @@ import Dodge.Data.Wall import Dodge.Data.WorldEffect import Dodge.Data.Zoning import Dodge.Distortion.Data -import Dodge.GameRoom import Dodge.RoomCluster.Data import GHC.Generics -import Geometry.ConvexPoly import Geometry.Data import qualified IntMapHelp as IM import MaybeHelp @@ -176,8 +168,6 @@ import Sound.Data import Streaming import System.Random -type CRUpdate = Creature -> World -> (World -> World, Maybe Creature) - type CRUpdate' = Creature -> World -> (World -> World, Creature) data Universe = Universe @@ -206,100 +196,16 @@ data World = World , _keys :: S.Set Scancode , _mouseButtons :: M.Map MouseButton Bool , _hammers :: M.Map WorldHammer HammerPosition - } - -data CWorld = CWorld - { _cameraCenter :: Point2 - , _cameraRot :: Float - , _cameraZoom :: Float -- smaller values zoom out - , _itemZoom :: Float - , _defaultZoom :: Float - , _cameraViewFrom :: Point2 - , _viewDistance :: Float - , _boundBox :: [Point2] - , _boundDist :: (Float, Float, Float, Float) -- NSEW, S and W negative - , _creatures :: IM.IntMap Creature - , _crZoning :: IM.IntMap (IM.IntMap IS.IntSet) --Zoning IM.IntMap Creature - , _creatureGroups :: IM.IntMap CrGroupParams - , _itemPositions :: IM.IntMap ItemPos - , _clouds :: [Cloud] - , _clZoning :: IM.IntMap (IM.IntMap [Cloud]) --Zoning IM.IntMap Creature - , _gusts :: IM.IntMap Gust - , _gsZoning :: IM.IntMap (IM.IntMap IS.IntSet) - , _props :: IM.IntMap Prop - , _projectiles :: IM.IntMap Proj - , _instantBullets :: [Bullet] - , _bullets :: [Bullet] - , _radarSweeps :: [RadarSweep] - , _energyBalls :: [EnergyBall] - , _posEvents :: [PosEvent] - , _flames :: [Flame] - , _sparks :: [Spark] - , _radarBlips :: [RadarBlip] - , _flares :: [Flare] - , _newBeams :: WorldBeams - , _beams :: WorldBeams - , _teslaArcs :: [TeslaArc] - , _shockwaves :: [Shockwave] - , _lasers :: [LaserStart] - , _lasersToDraw :: [Laser] - , _linearShockwaves :: IM.IntMap LinearShockwave - , _tractorBeams :: [TractorBeam] - , _walls :: IM.IntMap Wall - , _wallDamages :: IM.IntMap [Damage] - , _doors :: IM.IntMap Door - , _machines :: IM.IntMap Machine - , _terminals :: IM.IntMap Terminal - , _magnets :: IM.IntMap Magnet - , _blocks :: IM.IntMap Block - , _coordinates :: IM.IntMap Point2 - , _triggers :: IM.IntMap Bool - , _wlZoning :: IM.IntMap (IM.IntMap IS.IntSet) -- Zoning IM.IntMap Wall - , _floorItems :: IM.IntMap FloorItem - , _floorTiles :: [(Point3, Point3)] - , _modifications :: IM.IntMap Modification - , _yourID :: Int - , _worldEvents :: [WdWd] - , _delayedEvents :: [(Int, WdWd)] - , _pressPlates :: IM.IntMap PressPlate - , _buttons :: IM.IntMap Button - , _decorations :: IM.IntMap Picture - , _foregroundShapes :: IM.IntMap ForegroundShape - , _corpses :: IM.IntMap Corpse - , _clickMousePos :: Point2 - , _pathGraph :: Gr Point2 PathEdge - , _pnZoning :: IM.IntMap (IM.IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature - , _peZoning :: IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) --Zoning IM.IntMap Creature - , _hud :: HUD - , _lightSources :: IM.IntMap LightSource - , _tempLightSources :: [TempLightSource] - , _closeObjects :: [Either FloorItem Button] - , _rbOptions :: RightButtonOptions - , _seenLocations :: IM.IntMap (WdP2, String) - , _selLocation :: Int - , _distortions :: [Distortion] - , _worldBounds :: Bounds - , _gameRooms :: [GameRoom] -- consider using an IntMap - , _roomClipping :: [ConvexPoly] - , _maybeWorld :: Maybe' CWorld - , _rewindWorlds :: [CWorld] - , _timeFlow :: TimeFlowStatus - , _worldClock :: Int - , _backspaceTimer :: Int - , _genParams :: GenParams - , _deathDelay :: Maybe Int , _testFloat :: Float , _lLine :: (Point2, Point2) , _rLine :: (Point2, Point2) , _lSelect :: Point2 , _rSelect :: Point2 + , _backspaceTimer :: Int + , _timeFlow :: TimeFlowStatus + , _rbOptions :: RightButtonOptions } - deriving (Eq, Show, Read, Generic) -instance ToJSON CWorld where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON CWorld instance ToJSON MouseButton where toEncoding = genericToEncoding defaultOptions @@ -397,18 +303,6 @@ data MenuOption data IntID a = IntID Int a -data WorldBeams = WorldBeams - { _blockingBeams :: [Beam] - , _lightBeams :: [Beam] - , _positronBeams :: [Beam] - , _electronBeams :: [Beam] - } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON WorldBeams where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON WorldBeams type HitEffect' = Flame -> @@ -531,9 +425,7 @@ makeLenses ''World --makeLenses ''Particle makeLenses ''Universe makeLenses ''ScreenLayer -makeLenses ''WorldBeams makeLenses ''GenWorld -makeLenses ''CWorld ----- ROOM LENSES diff --git a/src/Dodge/Data/ActionPlan.hs b/src/Dodge/Data/ActionPlan.hs index b583bb4be..050ba1eb8 100644 --- a/src/Dodge/Data/ActionPlan.hs +++ b/src/Dodge/Data/ActionPlan.hs @@ -1,36 +1,43 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} --{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE DeriveGeneric #-} + module Dodge.Data.ActionPlan where -import GHC.Generics -import Data.Aeson -import Dodge.Creature.Stance.Data -import Dodge.Data.CreatureEffect ---import Dodge.ShortShow + import Control.Lens +import Data.Aeson +import Dodge.Data.Creature.Stance +import Dodge.Data.CreatureEffect +import GHC.Generics import Geometry.Data import Sound.Data ---import GHC.Generics + data ActionPlan = Inanimate | ActionPlan - {_apImpulse :: [Impulse] - ,_apAction :: [Action] - ,_apStrategy :: Strategy - ,_apGoal :: [Goal] + { _apImpulse :: [Impulse] + , _apAction :: [Action] + , _apStrategy :: Strategy + , _apGoal :: [Goal] } - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON ActionPlan where toEncoding = genericToEncoding defaultOptions + instance FromJSON ActionPlan -data RandImpulse + +data RandImpulse = RandImpulseList [Impulse] | RandImpulseCircMove Float - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON RandImpulse where + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON RandImpulse where toEncoding = genericToEncoding defaultOptions -instance FromJSON RandImpulse + +instance FromJSON RandImpulse + data Impulse = Move Point2 | MoveForward Float @@ -50,127 +57,138 @@ data Impulse | MakeSound SoundID | ChangeStrategy Strategy | AddGoal Goal - | ArbitraryImpulseFunction WdCrCr - | ArbitraryImpulse CrWdImp - | ArbitraryImpulseEffect CrWdWd + | ArbitraryImpulseFunction WdCrCr + | ArbitraryImpulse CrWdImp + | ArbitraryImpulseEffect CrWdWd | ImpulseUseTargetCID - {_impulseUseTargetCID :: IntImp + { _impulseUseTargetCID :: IntImp } | ImpulseUseTarget - {_impulseUseTarget :: CrImp + { _impulseUseTarget :: CrImp } | ImpulseUseAheadPos - {_impulseUseAheadPos :: P2Imp + { _impulseUseAheadPos :: P2Imp } | ImpulseNothing - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON Impulse where toEncoding = genericToEncoding defaultOptions + instance FromJSON Impulse + infixr 9 `WaitThen` + infixr 9 `DoActionThen` + infixr 9 `DoActionWhile` + infixr 9 `DoReplicate` + infixr 9 `DoImpulsesAlongside` + data Action = LabelAction - {_actLabel :: String - ,_actAction :: Action + { _actLabel :: String + , _actAction :: Action } | ActionNothing | AimAt - {_targetID :: Int - ,_targetSeenAt :: Point2 + { _targetID :: Int + , _targetSeenAt :: Point2 } - | PathTo - {_pathToPoint :: Point2 + | PathTo + { _pathToPoint :: Point2 } | TurnToPoint - {_turnToPoint :: Point2 + { _turnToPoint :: Point2 } --- | PickupItem --- {_pickupItemID :: Int --- } - | ImpulsesList - {_impulsesListList :: [[Impulse]] + | -- | PickupItem + -- {_pickupItemID :: Int + -- } + ImpulsesList + { _impulsesListList :: [[Impulse]] } - | DoImpulses - {_doImpulsesList :: [Impulse] + | DoImpulses + { _doImpulsesList :: [Impulse] } - | WaitThen - {_waitThenTimer :: Int - ,_waitThenAction :: Action + | WaitThen + { _waitThenTimer :: Int + , _waitThenAction :: Action } - | DoActionWhile - {_doActionWhileCondition :: WdCrBl - ,_doActionWhileAction :: Action + | DoActionWhile + { _doActionWhileCondition :: WdCrBl + , _doActionWhileAction :: Action } | DoActionWhilePartial - {_doActionWhilePartial :: Action - ,_doActionWhileCondition :: WdCrBl - ,_doActionWhileAction :: Action + { _doActionWhilePartial :: Action + , _doActionWhileCondition :: WdCrBl + , _doActionWhileAction :: Action } | DoActionIf - {_doActionIfCondition :: WdCrBl - ,_doActionIfAction :: Action + { _doActionIfCondition :: WdCrBl + , _doActionIfAction :: Action } - | DoActionIfElse - {_doActionIfElseIfAction :: Action - ,_doActionIfElseCondition :: WdCrBl - ,_doActionIfElseElseAction :: Action + | DoActionIfElse + { _doActionIfElseIfAction :: Action + , _doActionIfElseCondition :: WdCrBl + , _doActionIfElseElseAction :: Action } - | DoActionWhileInterrupt - {_doActionWhileThenDo :: Action - ,_doActionWhileThenCondition :: WdCrBl - ,_doActionWhileThenThen :: Action + | DoActionWhileInterrupt + { _doActionWhileThenDo :: Action + , _doActionWhileThenCondition :: WdCrBl + , _doActionWhileThenThen :: Action } - | DoActions - {_doActionsList :: [Action] + | DoActions + { _doActionsList :: [Action] } - | DoActionThen - {_doActionThenFirst :: Action - ,_doActionThenSecond :: Action + | DoActionThen + { _doActionThenFirst :: Action + , _doActionThenSecond :: Action } --- | DoGuardActions --- {_doGuardActionsList :: [( (World, Creature) -> Bool, Action, Maybe Action)] --- } - | DoReplicate - {_doReplicateTimes :: Int - ,_doReplicateAction :: Action + | -- | DoGuardActions + -- {_doGuardActionsList :: [( (World, Creature) -> Bool, Action, Maybe Action)] + -- } + DoReplicate + { _doReplicateTimes :: Int + , _doReplicateAction :: Action } | DoReplicatePartial - {_partialAction :: Action - ,_doReplicateTimes :: Int - ,_doReplicateAction :: Action + { _partialAction :: Action + , _doReplicateTimes :: Int + , _doReplicateAction :: Action } | LeadTarget - {_leadTargetBy :: Point2 + { _leadTargetBy :: Point2 } | NoAction | StartSentinelPost | UseTarget - {_useTarget :: MCrAc + { _useTarget :: MCrAc } | UseSelf - {_useSelf :: CrAc + { _useSelf :: CrAc } | UseAheadPos - {_useAheadPos :: P2Ac + { _useAheadPos :: P2Ac } | UseMvTargetPos - {_useMvTargetPos :: MP2Ac + { _useMvTargetPos :: MP2Ac } | ArbitraryAction - { _arbitraryAction :: CrWdAc } - | DoImpulsesAlongside - -- ^ Repeatedly perform impulses alongside a main action until the main action terminates - {_sideImpulses :: [Impulse] - ,_mainAction :: Action + {_arbitraryAction :: CrWdAc} + | -- | Repeatedly perform impulses alongside a main action until the main action terminates + DoImpulsesAlongside + { _sideImpulses :: [Impulse] + , _mainAction :: Action } - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON Action where toEncoding = genericToEncoding defaultOptions + instance FromJSON Action + data Strategy = Flank Int | Ambush Int @@ -187,18 +205,24 @@ data Strategy | Reload | Flee | MeleeStrike - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON Strategy where toEncoding = genericToEncoding defaultOptions + instance FromJSON Strategy + data Goal = LiveLongAndProsper | Kill Int | SentinelAt Point2 Float - deriving (Eq,Ord,Show,Read,Generic) + deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON Goal where toEncoding = genericToEncoding defaultOptions + instance FromJSON Goal + makeLenses ''ActionPlan makeLenses ''Impulse makeLenses ''Action diff --git a/src/Dodge/Data/CWorld.hs b/src/Dodge/Data/CWorld.hs new file mode 100644 index 000000000..0461ff1e8 --- /dev/null +++ b/src/Dodge/Data/CWorld.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.CWorld where + +import Control.Lens +import Data.Aeson +import Data.Graph.Inductive +import qualified Data.IntSet as IS +import Dodge.Data.Beam +import Dodge.Data.Block +import Dodge.Data.Bounds +import Dodge.Data.Bullet +import Dodge.Data.Button +import Dodge.Data.Cloud +import Dodge.Data.Corpse +import Dodge.Data.CrGroupParams +import Dodge.Data.Creature +import Dodge.Data.Damage +import Dodge.Data.Door +import Dodge.Data.EnergyBall +import Dodge.Data.Flame +import Dodge.Data.Flare +import Dodge.Data.FloorItem +import Dodge.Data.ForegroundShape +import Dodge.Data.GenParams +import Dodge.Data.Gust +import Dodge.Data.HUD +import Dodge.Data.Item +import Dodge.Data.Laser +import Dodge.Data.LightSource +import Dodge.Data.LinearShockwave +import Dodge.Data.Machine +import Dodge.Data.Magnet +import Dodge.Data.Modification +import Dodge.Data.PathGraph +import Dodge.Data.PosEvent +import Dodge.Data.PressPlate +import Dodge.Data.Projectile +import Dodge.Data.Prop +import Dodge.Data.RadarBlip +import Dodge.Data.RadarSweep +import Dodge.Data.Shockwave +import Dodge.Data.Spark +import Dodge.Data.Terminal +import Dodge.Data.TeslaArc +import Dodge.Data.TractorBeam +import Dodge.Data.Wall +import Dodge.Data.WorldEffect +import Dodge.Distortion.Data +import Dodge.GameRoom +import GHC.Generics +import Geometry.ConvexPoly +import Geometry.Data +import qualified IntMapHelp as IM +import MaybeHelp +import Picture.Data + +data CWorld = CWorld + { _cameraCenter :: Point2 + , _cameraRot :: Float + , _cameraZoom :: Float -- smaller values zoom out + , _itemZoom :: Float + , _defaultZoom :: Float + , _cameraViewFrom :: Point2 + , _viewDistance :: Float + , _boundBox :: [Point2] + , _boundDist :: (Float, Float, Float, Float) -- NSEW, S and W negative + , _creatures :: IM.IntMap Creature + , _crZoning :: IM.IntMap (IM.IntMap IS.IntSet) + , _creatureGroups :: IM.IntMap CrGroupParams + , _itemPositions :: IM.IntMap ItemPos + , _clouds :: [Cloud] + , _clZoning :: IM.IntMap (IM.IntMap [Cloud]) + , _gusts :: IM.IntMap Gust + , _gsZoning :: IM.IntMap (IM.IntMap IS.IntSet) + , _props :: IM.IntMap Prop + , _projectiles :: IM.IntMap Proj + , _instantBullets :: [Bullet] + , _bullets :: [Bullet] + , _radarSweeps :: [RadarSweep] + , _energyBalls :: [EnergyBall] + , _posEvents :: [PosEvent] + , _flames :: [Flame] + , _sparks :: [Spark] + , _radarBlips :: [RadarBlip] + , _flares :: [Flare] + , _newBeams :: WorldBeams + , _beams :: WorldBeams + , _teslaArcs :: [TeslaArc] + , _shockwaves :: [Shockwave] + , _lasers :: [LaserStart] + , _lasersToDraw :: [Laser] + , _linearShockwaves :: IM.IntMap LinearShockwave + , _tractorBeams :: [TractorBeam] + , _walls :: IM.IntMap Wall + , _wallDamages :: IM.IntMap [Damage] + , _doors :: IM.IntMap Door + , _machines :: IM.IntMap Machine + , _terminals :: IM.IntMap Terminal + , _magnets :: IM.IntMap Magnet + , _blocks :: IM.IntMap Block + , _coordinates :: IM.IntMap Point2 + , _triggers :: IM.IntMap Bool + , _wlZoning :: IM.IntMap (IM.IntMap IS.IntSet) -- Zoning IM.IntMap Wall + , _floorItems :: IM.IntMap FloorItem + , _floorTiles :: [(Point3, Point3)] + , _modifications :: IM.IntMap Modification + , _yourID :: Int + , _worldEvents :: [WdWd] + , _delayedEvents :: [(Int, WdWd)] + , _pressPlates :: IM.IntMap PressPlate + , _buttons :: IM.IntMap Button + , _decorations :: IM.IntMap Picture + , _foregroundShapes :: IM.IntMap ForegroundShape + , _corpses :: IM.IntMap Corpse + , _clickMousePos :: Point2 + , _pathGraph :: Gr Point2 PathEdge + , _pnZoning :: IM.IntMap (IM.IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature + , _peZoning :: IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) --Zoning IM.IntMap Creature + , _hud :: HUD + , _lightSources :: IM.IntMap LightSource + , _tempLightSources :: [TempLightSource] + , _closeObjects :: [Either FloorItem Button] + , _seenLocations :: IM.IntMap (WdP2, String) + , _selLocation :: Int + , _distortions :: [Distortion] + , _worldBounds :: Bounds + , _gameRooms :: [GameRoom] -- consider using an IntMap + , _roomClipping :: [ConvexPoly] + , _maybeWorld :: Maybe' CWorld + , _rewindWorlds :: [CWorld] + , _worldClock :: Int + , _genParams :: GenParams + , _deathDelay :: Maybe Int + } + deriving (Eq, Show, Read, Generic) + +instance ToJSON CWorld where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON CWorld + +data WorldBeams = WorldBeams + { _blockingBeams :: [Beam] + , _lightBeams :: [Beam] + , _positronBeams :: [Beam] + , _electronBeams :: [Beam] + } + deriving (Eq, Ord, Show, Read, Generic) + +instance ToJSON WorldBeams where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON WorldBeams + +makeLenses ''CWorld +makeLenses ''WorldBeams diff --git a/src/Dodge/Data/Creature.hs b/src/Dodge/Data/Creature.hs index 1ac0d40dd..5ec07cb10 100644 --- a/src/Dodge/Data/Creature.hs +++ b/src/Dodge/Data/Creature.hs @@ -5,6 +5,9 @@ module Dodge.Data.Creature ( module Dodge.Data.Creature , module Dodge.Data.Creature.Misc , module Dodge.Data.Creature.State + , module Dodge.Data.Creature.Perception + , module Dodge.Data.Creature.Memory + , module Dodge.Data.Creature.Stance ) where import GHC.Generics import Data.Aeson @@ -15,9 +18,9 @@ import Dodge.Data.LoadAction import Dodge.Data.Material import Dodge.Data.ActionPlan import Dodge.Data.Hammer -import Dodge.Creature.Perception.Data -import Dodge.Creature.Memory.Data -import Dodge.Creature.Stance.Data +import Dodge.Data.Creature.Perception +import Dodge.Data.Creature.Memory +import Dodge.Data.Creature.Stance import Geometry.Data import qualified IntMapHelp as IM import qualified Data.Map.Strict as M diff --git a/src/Dodge/Creature/Memory/Data.hs b/src/Dodge/Data/Creature/Memory.hs similarity index 92% rename from src/Dodge/Creature/Memory/Data.hs rename to src/Dodge/Data/Creature/Memory.hs index b42833b9d..fa4d0045b 100644 --- a/src/Dodge/Creature/Memory/Data.hs +++ b/src/Dodge/Data/Creature/Memory.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Creature.Memory.Data +module Dodge.Data.Creature.Memory where import GHC.Generics import Data.Aeson diff --git a/src/Dodge/Creature/Perception/Data.hs b/src/Dodge/Data/Creature/Perception.hs similarity index 98% rename from src/Dodge/Creature/Perception/Data.hs rename to src/Dodge/Data/Creature/Perception.hs index cbbf484d9..44bbfeca7 100644 --- a/src/Dodge/Creature/Perception/Data.hs +++ b/src/Dodge/Data/Creature/Perception.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Creature.Perception.Data +module Dodge.Data.Creature.Perception ( Perception (..) , Vigilance (..) , Attention (..) diff --git a/src/Dodge/Creature/Stance/Data.hs b/src/Dodge/Data/Creature/Stance.hs similarity index 97% rename from src/Dodge/Creature/Stance/Data.hs rename to src/Dodge/Data/Creature/Stance.hs index c1b7d9526..302720b08 100644 --- a/src/Dodge/Creature/Stance/Data.hs +++ b/src/Dodge/Data/Creature/Stance.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Creature.Stance.Data +module Dodge.Data.Creature.Stance where import GHC.Generics import Data.Aeson diff --git a/src/Dodge/Data/Item/HeldUse.hs b/src/Dodge/Data/Item/HeldUse.hs index 077012cc5..f820e1214 100644 --- a/src/Dodge/Data/Item/HeldUse.hs +++ b/src/Dodge/Data/Item/HeldUse.hs @@ -25,16 +25,22 @@ data HeldUse | HeldForceField | HeldShatter deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON HeldUse where toEncoding = genericToEncoding defaultOptions + instance FromJSON HeldUse + data Cuse = CDoNothing | CHeal Int deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON Cuse where toEncoding = genericToEncoding defaultOptions + instance FromJSON Cuse + data Euse = EDoNothing | EDetector Detector @@ -45,9 +51,12 @@ data Euse | EonWristShield | EoffWristShield deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON Euse where toEncoding = genericToEncoding defaultOptions + instance FromJSON Euse + data Luse = LDoNothing | LRewind @@ -56,13 +65,17 @@ data Luse | LUnsafeBlink | LBoost deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON Luse where toEncoding = genericToEncoding defaultOptions + instance FromJSON Luse + data HeldMod = HeldModNothing | PoisonSprayerMod | FlameSpitterMod + | FlameSpitterRepeatMod | FlameThrowerMod | LauncherMod | TeslaMod @@ -88,11 +101,15 @@ data HeldMod | AutoPistolMod | MachinePistolMod | BurstRifleMod + | BurstRifleRepeatMod | MiniGunMod Int | SmgMod | RevolverXMod + | RevolverXRepeatMod | BangConeMod deriving (Eq, Ord, Show, Read, Generic) + instance ToJSON HeldMod where toEncoding = genericToEncoding defaultOptions + instance FromJSON HeldMod diff --git a/src/Dodge/Data/WorldEffect.hs b/src/Dodge/Data/WorldEffect.hs index e1b64afa3..d0044645c 100644 --- a/src/Dodge/Data/WorldEffect.hs +++ b/src/Dodge/Data/WorldEffect.hs @@ -3,12 +3,20 @@ {-# LANGUAGE StrictData #-} {-# LANGUAGE DeriveGeneric #-} module Dodge.Data.WorldEffect where +import Dodge.Data.Item import Data.Aeson import GHC.Generics import Dodge.Data.CreatureEffect import Sound.Data import Geometry.Data import Dodge.Data.SoundOrigin +data ItCrWdWd = ItCrWdId + | ItCrWdItemEffect + deriving (Eq,Ord,Show,Read,Generic) +instance ToJSON ItCrWdWd where + toEncoding = genericToEncoding defaultOptions +instance FromJSON ItCrWdWd + data WdWd = NoWorldEffect | SetTrigger Bool Int | WorldEffects [WdWd] @@ -19,6 +27,8 @@ data WdWd = NoWorldEffect | MakeStartCloudAt Point3 | TorqueCr Float Int | WdWdNegateTrig Int + | WdWdFromItixCrixWdWd Int Int ItCrWdWd + | WdWdFromItCrixWdWd Item Int ItCrWdWd deriving (Eq,Ord,Show,Read,Generic) instance ToJSON WdWd where toEncoding = genericToEncoding defaultOptions diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 34d0ac1ea..07889e5a0 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -19,6 +19,14 @@ defaultWorld = World , _mouseButtons = mempty , _mousePos = V2 0 0 , _hammers = defaultWorldHammers + , _testFloat = 0 + , _lLine = (0,0) + , _rLine = (0,0) + , _lSelect = 0 + , _rSelect = 0 + , _backspaceTimer = 0 + , _timeFlow = NormalTimeFlow + , _rbOptions = NoRightButtonOptions } defaultCWorld :: CWorld @@ -95,7 +103,6 @@ defaultCWorld = CWorld , _lightSources = IM.empty , _tempLightSources = [] , _closeObjects = [] - , _rbOptions = NoRightButtonOptions , _seenLocations = IM.fromList [(0, (WdYouPos, "CURRENT POSITION")) ,(1, (WdP2Const (V2 0 0) , "START POSITION")) @@ -109,19 +116,12 @@ defaultCWorld = CWorld , _worldBounds = defaultBounds , _maybeWorld = Nothing' , _rewindWorlds = [] - , _timeFlow = NormalTimeFlow - , _backspaceTimer = 0 , _genParams = GenParams M.empty -- , _genPlacements = IM.empty -- , _genRooms = IM.empty , _deathDelay = Nothing - , _testFloat = 0 , _boundBox = square 100 , _boundDist = (100,-100,100,-100) - , _lLine = (0,0) - , _rLine = (0,0) - , _lSelect = 0 - , _rSelect = 0 } defaultWorldHammers :: M.Map WorldHammer HammerPosition defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound] diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 8d341e7af..afdd63e0c 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -97,7 +97,7 @@ wheelEvent y w = case _hudElement $ _hud (_cWorld w) of -- functions that modify the inventory should be centralised so that -- this lock can be sensibly applied, perhaps | _crInvLock (_creatures (_cWorld w) IM.! _yourID (_cWorld w)) -> w - | rbDown -> case (yourItem w ^? _Just . itUse . heldScroll,_rbOptions (_cWorld w)) of + | rbDown -> case (yourItem w ^? _Just . itUse . heldScroll,_rbOptions w) of (_,EquipOptions{}) -> scrollRBOption y w (Nothing,_) -> closeObjScrollDir y w (Just f,_) -> w & cWorld . creatures . ix 0 . crInv . ix (crSel $ you w) %~ doHeldScroll f y (you w) @@ -159,8 +159,8 @@ nullCommand = TerminalCommand scrollRBOption :: Float -> World -> World scrollRBOption y w - | y < 0 = w & cWorld . rbOptions . opSel %~ (min (length (_opEquip (_rbOptions (_cWorld w)))-1) . (+1)) - | y > 0 = w & cWorld . rbOptions . opSel %~ (max 0 . subtract 1) + | y < 0 = w & rbOptions . opSel %~ (min (length (_opEquip (_rbOptions w))-1) . (+1)) + | y > 0 = w & rbOptions . opSel %~ (max 0 . subtract 1) | otherwise = w moveTweakSel :: Int -> World -> World diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 648803faa..055dd3e7f 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -68,9 +68,9 @@ handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe) handlePressedKey True ScancodeBackspace u - | _backspaceTimer (_cWorld $ _uvWorld u) <= 0 = handlePressedKey False ScancodeBackspace u - <&> _Just . uvWorld . cWorld . backspaceTimer .~ 0 - | otherwise = return $ Just $ u & uvWorld . cWorld . backspaceTimer -~ 1 + | _backspaceTimer (_uvWorld u) <= 0 = handlePressedKey False ScancodeBackspace u + <&> _Just . uvWorld . backspaceTimer .~ 0 + | otherwise = return $ Just $ u & uvWorld . backspaceTimer -~ 1 handlePressedKey True _ u = return $ Just u handlePressedKey _ scode u = case scode of ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u) @@ -107,7 +107,7 @@ handlePressedKeyTerminal tmid scode w = case scode of ScancodeReturn -> w & terminalReturnEffect (w ^?! cWorld . terminals . ix tmid) ScancodeBackspace -> w & cWorld . terminals . ix tmid . tmInput . tiText %~ doBackspace - & cWorld . backspaceTimer .~ 5 + & backspaceTimer .~ 5 _ -> w where doBackspace t = case T.unsnoc t of diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index de8932838..6fb61142e 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -35,7 +35,14 @@ useMod hm = case hm of [ ammoCheckI , useTimeCheck , lockInvFor 10 - , repeatOnFrames [1..9] + , repeatOnFrames [1..9] FlameSpitterRepeatMod + , withRandomItemParams f + , useAmmoAmount 1 + , withSidePushI 5 + , withSidePushAfterI 20 + ] + FlameSpitterRepeatMod -> + [ ammoCheckI , withRandomItemParams f , useAmmoAmount 1 , withSidePushI 5 @@ -239,7 +246,16 @@ useMod hm = case hm of , useTimeCheck , sideEffectOnFrame 7 (\_ cr -> TorqueCr 0.2 (_crID cr)) --(torqueSideEffect 0.2) , lockInvFor 7 - , \f' it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [3,6]) f' it + , repeatOnFrames [3,6] BurstRifleRepeatMod + , withSoundStart tap3S + , useAmmoAmount 1 + , applyInaccuracy + , withMuzFlareI + , withRecoil + ] + BurstRifleRepeatMod -> + [ ammoCheckI + , sideEffectOnFrame 7 (\_ cr -> TorqueCr 0.2 (_crID cr)) --(torqueSideEffect 0.2) , withSoundStart tap3S , useAmmoAmount 1 , applyInaccuracy @@ -278,7 +294,19 @@ useMod hm = case hm of -- rather than locking the inventory, a better solution may be to check -- that the weapon is still in your hands in the repeated frames , lockInvFor 10 - , \f' it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [2,4,6,8,10]) f' it + , repeatOnFrames [2,4,6,8,10] RevolverXRepeatMod + , withSoundStart tap3S + , useAmmoUpTo 1 + , applyInaccuracy + , withMuzFlareI +-- , spreadLoaded + , withTorqueAfter + , withRecoil + ] + RevolverXRepeatMod -> + [ ammoCheckI + -- rather than locking the inventory, a better solution may be to check + -- that the weapon is still in your hands in the repeated frames , withSoundStart tap3S , useAmmoUpTo 1 , applyInaccuracy diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index f8de6415f..a1ea65fc1 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -185,17 +185,17 @@ updateCloseObjects w = w updateRBList :: World -> World updateRBList w - | w ^? cWorld . rbOptions . opCurInvPos == Just curinvid + | w ^? rbOptions . opCurInvPos == Just curinvid = w & setEquipAllocation & setEquipActivation | otherwise = case cr ^? crInv . ix curinvid . itUse . eqEq . eqSite of Just esite -> w - & cWorld . rbOptions .~ EquipOptions (equipSiteToPositions esite) + & rbOptions .~ EquipOptions (equipSiteToPositions esite) (chooseEquipmentPosition cr (equipSiteToPositions esite)) curinvid DoNotMoveEquipment NoChangeActivateEquipment & setEquipAllocation & setEquipActivation - Nothing -> w & cWorld . rbOptions .~ NoRightButtonOptions + Nothing -> w & rbOptions .~ NoRightButtonOptions -- | otherwise = w & rbOptions .~ NoRightButtonOptions where curinvid = crSel cr @@ -212,53 +212,53 @@ chooseFreeSite cr = fromMaybe 0 . findIndex hasnoequipment hasnoequipment ep = isNothing $ cr ^? crEquipment . ix ep setEquipAllocation :: World -> World -setEquipAllocation w = case _rbOptions (_cWorld w) of +setEquipAllocation w = case _rbOptions w of EquipOptions {_opEquip = es,_opSel=i} -> case you w ^? crInvEquipped . ix (crSel (you w)) of Just epos | es !! i == epos - -> w & cWorld . rbOptions . opAllocateEquipment .~ RemoveEquipment + -> w & rbOptions . opAllocateEquipment .~ RemoveEquipment {_allocOldPos = epos} Just epos | isJust (you w ^? crEquipment . ix (es !! i)) - -> w & cWorld . rbOptions . opAllocateEquipment .~ SwapEquipment + -> w & rbOptions . opAllocateEquipment .~ SwapEquipment {_allocOldPos = epos ,_allocNewPos = es !! i ,_allocSwapID = _crEquipment (you w) M.! (es !! i) } - Just epos -> w & cWorld . rbOptions . opAllocateEquipment .~ MoveEquipment + Just epos -> w & rbOptions . opAllocateEquipment .~ MoveEquipment {_allocOldPos = epos ,_allocNewPos = es !! i } Nothing | isJust (you w ^? crEquipment . ix (es !! i)) - -> w & cWorld . rbOptions . opAllocateEquipment .~ ReplaceEquipment + -> w & rbOptions . opAllocateEquipment .~ ReplaceEquipment {_allocNewPos = es !! i ,_allocRemoveID = _crEquipment (you w) M.! (es !! i) } - Nothing -> w & cWorld . rbOptions . opAllocateEquipment .~ PutOnEquipment + Nothing -> w & rbOptions . opAllocateEquipment .~ PutOnEquipment {_allocNewPos = es !! i} _ -> w -- where -- curpos = invSelPos w setEquipActivation :: World -> World -setEquipActivation w = case w ^? cWorld . rbOptions . opAllocateEquipment of +setEquipActivation w = case w ^? rbOptions . opAllocateEquipment of Just DoNotMoveEquipment -> w Just RemoveEquipment { } -> case _crLeftInvSel (you w) of - Just i | i == invsel -> w & cWorld . rbOptions . opActivateEquipment .~ DeactivateEquipment + Just i | i == invsel -> w & rbOptions . opActivateEquipment .~ DeactivateEquipment {_deactivateEquipment = i} - _ -> w & cWorld . rbOptions . opActivateEquipment .~ NoChangeActivateEquipment + _ -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment Just rbos -> case _crLeftInvSel (you w) of - Just i | i == invsel -> w & cWorld . rbOptions . opActivateEquipment .~ NoChangeActivateEquipment - Just i | invselcanactivate -> w & cWorld . rbOptions . opActivateEquipment .~ ActivateDeactivateEquipment + Just i | i == invsel -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment + Just i | invselcanactivate -> w & rbOptions . opActivateEquipment .~ ActivateDeactivateEquipment {_activateEquipment = invsel,_deactivateEquipment = i} Just i | Just i == rbos ^? allocRemoveID - -> w & cWorld . rbOptions . opActivateEquipment .~ DeactivateEquipment i - Just _ -> w & cWorld . rbOptions . opActivateEquipment .~ NoChangeActivateEquipment - Nothing | invselcanactivate -> w & cWorld . rbOptions . opActivateEquipment .~ ActivateEquipment + -> w & rbOptions . opActivateEquipment .~ DeactivateEquipment i + Just _ -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment + Nothing | invselcanactivate -> w & rbOptions . opActivateEquipment .~ ActivateEquipment {_activateEquipment = invsel} - Nothing -> w & cWorld . rbOptions . opActivateEquipment .~ NoChangeActivateEquipment - Nothing -> w & cWorld . rbOptions . opActivateEquipment .~ NoChangeActivateEquipment + Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment + Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment where invsel = crSel (you w) invselcanactivate = isJust (you w ^? crInv . ix invsel . itUse . lUse) diff --git a/src/Dodge/ItEffect.hs b/src/Dodge/ItEffect.hs index 74fe5ee02..49922e851 100644 --- a/src/Dodge/ItEffect.hs +++ b/src/Dodge/ItEffect.hs @@ -39,7 +39,6 @@ rewindEffect itm cr w maxcharge = _wpMaxCharge . _itConsumption $ itm cw = _cWorld w & rewindWorlds .~ [] - & timeFlow .~ NormalTimeFlow resetAttachmentEffect :: Item -> Creature -> World -> World resetAttachmentEffect itm cr w diff --git a/src/Dodge/Item/Weapon/BulletGun/Cane.hs b/src/Dodge/Item/Weapon/BulletGun/Cane.hs index 68af7cf5a..7a2f8dfb3 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Cane.hs +++ b/src/Dodge/Item/Weapon/BulletGun/Cane.hs @@ -1,173 +1,158 @@ -module Dodge.Item.Weapon.BulletGun.Cane - ( volleyGun - , repeater - , rifle - , autoRifle - , burstRifle - , miniGunX - ) where -import Dodge.Reloading.Action +module Dodge.Item.Weapon.BulletGun.Cane ( + volleyGun, + repeater, + rifle, + autoRifle, + burstRifle, + miniGunX, +) where + import Dodge.Data -import Dodge.Default.Weapon import Dodge.Default +import Dodge.Reloading.Action import Geometry import LensHelp defaultBangCane :: Item -defaultBangCane = defaultBulletWeapon - & itParams .~ BulletShooter - { _muzVel = 0.8 - , _rifling = 0.9 - , _bore = 2 - , _gunBarrels = SingleBarrel - { _brlInaccuracy = 0.01 - } - , _recoil = 50 - , _torqueAfter = 0.1 - , _randomOffset = 0 - } - & itDimension . dimRad .~ 8 - & itDimension . dimCenter .~ V3 5 0 0 - & itUse . useDelay . rateMax .~ 6 - & itUse . useMods .~ BangCaneMod - & itUse . useAim . aimStance .~ OneHand - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 15 - & itType . iyBase .~ error "undefined bangCane baseitemtype" - & itConsumption . laMax .~ 1 - & itConsumption . laCycle .~ [loadPartialInsert 10 1] -volleyGun :: Int -> Item -volleyGun i = defaultBangCane - & itUse . useDelay . rateMax .~ 6 - & itUse . useMods .~ VolleyGunMod - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ TwoHandFlat - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 15 - & itConsumption . laMax .~ i - & itParams .~ BulletShooter - { _muzVel = 0.8 - , _rifling = 0.9 - , _bore = 2 - , _gunBarrels = SingleBarrel - { _brlInaccuracy = 0.01 - } - , _recoil = 50 - , _torqueAfter = 0.1 - , _randomOffset = 0 - } - & itParams . gunBarrels .~ MultiBarrel - {_brlSpread = AlignedBarrels - ,_brlNum = i - ,_brlInaccuracy = 0.1 - } - & itParams . torqueAfter .~ 0.48 + 0.2 * fromIntegral i - & itType . iyBase .~ HELD (VOLLEYGUN i) -rifle :: Item -rifle = defaultBangCane - & itUse . useAim . aimStance .~ TwoHandTwist - & itType . iyBase .~ HELD RIFLE - & itConsumption . laMax .~ 1 - & itConsumption . laCycle .~ [loadEject 5, loadInsert 5 ,loadPrime 5] - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 --- & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 2} - & itType . iyModules . at ModHeldAttach ?~ EMPTYMODULE -repeater :: Item -repeater = rifle - & itType . iyModules . at ModRifleMag ?~ EMPTYMODULE - & itType . iyBase .~ HELD REPEATER - & itConsumption . laCycle .~ [loadEject 20, loadInsert 20 ,loadPrime 20] - & itConsumption . laMax .~ 15 +defaultBangCane = + defaultBulletWeapon + & itParams + .~ BulletShooter + { _muzVel = 0.8 + , _rifling = 0.9 + , _bore = 2 + , _gunBarrels = + SingleBarrel + { _brlInaccuracy = 0.01 + } + , _recoil = 50 + , _torqueAfter = 0.1 + , _randomOffset = 0 + } + & itDimension . dimRad .~ 8 + & itDimension . dimCenter .~ V3 5 0 0 + & itUse . useDelay . rateMax .~ 6 + & itUse . useMods .~ BangCaneMod + & itUse . useAim . aimStance .~ OneHand + & itUse . useAim . aimHandlePos .~ 5 + & itUse . useAim . aimMuzPos .~ 15 + & itType . iyBase .~ error "undefined bangCane baseitemtype" + & itConsumption . laMax .~ 1 + & itConsumption . laCycle .~ [loadPartialInsert 10 1] +volleyGun :: Int -> Item +volleyGun i = + defaultBangCane + & itUse . useDelay . rateMax .~ 6 + & itUse . useMods .~ VolleyGunMod + & itUse . useAim . aimWeight .~ 6 + & itUse . useAim . aimRange .~ 1 + & itUse . useAim . aimStance .~ TwoHandFlat + & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} + & itUse . useAim . aimHandlePos .~ 5 + & itUse . useAim . aimMuzPos .~ 15 + & itConsumption . laMax .~ i + & itParams + .~ BulletShooter + { _muzVel = 0.8 + , _rifling = 0.9 + , _bore = 2 + , _gunBarrels = + SingleBarrel + { _brlInaccuracy = 0.01 + } + , _recoil = 50 + , _torqueAfter = 0.1 + , _randomOffset = 0 + } + & itParams . gunBarrels + .~ MultiBarrel + { _brlSpread = AlignedBarrels + , _brlNum = i + , _brlInaccuracy = 0.1 + } + & itParams . torqueAfter .~ 0.48 + 0.2 * fromIntegral i + & itType . iyBase .~ HELD (VOLLEYGUN i) + +rifle :: Item +rifle = + defaultBangCane + & itUse . useAim . aimStance .~ TwoHandTwist + & itType . iyBase .~ HELD RIFLE + & itConsumption . laMax .~ 1 + & itConsumption . laCycle .~ [loadEject 5, loadInsert 5, loadPrime 5] + & itUse . useAim . aimWeight .~ 6 + & itUse . useAim . aimRange .~ 1 + & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomFac = 2} + & itType . iyModules . at ModHeldAttach ?~ EMPTYMODULE + +repeater :: Item +repeater = + rifle + & itType . iyModules . at ModRifleMag ?~ EMPTYMODULE + & itType . iyBase .~ HELD REPEATER + & itConsumption . laCycle .~ [loadEject 20, loadInsert 20, loadPrime 20] + & itConsumption . laMax .~ 15 autoRifle :: Item -autoRifle = repeater - & itType . iyBase .~ HELD AUTORIFLE - & itUse . useMods .~ AutoRifleMod - & itType . iyModules . at ModAutoMag ?~ EMPTYMODULE +autoRifle = + repeater + & itType . iyBase .~ HELD AUTORIFLE + & itUse . useMods .~ AutoRifleMod + & itType . iyModules . at ModAutoMag ?~ EMPTYMODULE + -- & itUse . useDelay . rateMax .~ 6 burstRifle :: Item -burstRifle = repeater - & itType . iyBase .~ HELD BURSTRIFLE - & itParams . gunBarrels . brlInaccuracy .~ 0.05 - & itUse . useDelay . rateMax .~ 18 - & itUse . useMods .~ BurstRifleMod ---fastBurstRifle :: Item ---fastBurstRifle = repeater --- & itType . iyBase .~ FASTBURSTRIFLE --- & itParams . gunBarrels . brlInaccuracy .~ 0.06 --- & itUse . useDelay . rateMax .~ 18 --- & itUse . useMods .~ --- [ ammoHammerCheck --- , useTimeCheck --- , sideEffectOnFrame 9 (torqueSideEffect 0.4) --- , lockInvFor 9 --- , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [2,4,6,8]) f it --- , withSoundStart tap3S --- , useAmmoAmount 1 --- , applyInaccuracy --- , withMuzFlareI --- , withRecoil --- ] ---completeBurstRifle :: Item ---completeBurstRifle = repeater --- & itType . iyBase .~ COMPLETEBURSTRIFLE --- & itType . iyModules . at ModRifleMag .~ Nothing --- & itParams . gunBarrels . brlInaccuracy .~ 0.1 --- & itUse . useDelay . rateMax .~ 28 --- & itUse . useMods .~ --- [ ammoHammerCheck --- , useTimeCheck --- , sideEffectOnFrame 15 (torqueSideEffect 0.8) --- , lockInvFor 15 --- , \f it -> repeatOnFrames (take (_laLoaded (_itConsumption it) - 1) [1..14]) f it --- , withSoundStart tap3S --- , useAmmoAmount 1 --- , applyInaccuracy --- , withMuzFlareI --- , withRecoil --- ] +burstRifle = + repeater + & itType . iyBase .~ HELD BURSTRIFLE + & itParams . gunBarrels . brlInaccuracy .~ 0.05 + & itUse . useDelay . rateMax .~ 18 + & itUse . useMods .~ BurstRifleMod + miniGunUse :: Int -> ItemUse -miniGunUse i = defaultrUse - & rUse .~ HeldUseAmmoParams - & useDelay .~ NoDelay - & useMods .~ MiniGunMod i +miniGunUse i = + defaultrUse + & rUse .~ HeldUseAmmoParams + & useDelay .~ NoDelay + & useMods .~ MiniGunMod i miniGunX :: Int -> Item -miniGunX i = defaultAutoGun - { _itConsumption = defaultBulletLoadable - { _laMax = 1500 - , _laLoaded = 1500 +miniGunX i = + defaultAutoGun + { _itConsumption = + defaultBulletLoadable + { _laMax = 1500 + , _laLoaded = 1500 + } + & laCycle .~ [loadEject 40, loadInsert 40, loadPrime 40] + , _itUse = + miniGunUse i + & useDelay .~ WarmUpNoDelay{_warmTime = 0, _warmMax = 100} + & useAim . aimWeight .~ 6 + & useAim . aimRange .~ 1 + & useAim . aimStance .~ TwoHandTwist + & useAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} + , -- , _itFloorPict = miniGunPictItem + _itParams = + BulletShooter + { _muzVel = 1 + , _rifling = 0.9 + , _bore = 2 + , _gunBarrels = + MultiBarrel + { _brlSpread = RotatingBarrels 0.01 + , _brlNum = i + , _brlInaccuracy = 0 + } + , _recoil = 10 + , _torqueAfter = 0 + , _randomOffset = 10 + } + , _itInvSize = 4 } - & laCycle .~ [loadEject 40, loadInsert 40 ,loadPrime 40] - , _itUse = miniGunUse i - & useDelay .~ WarmUpNoDelay {_warmTime = 0,_warmMax = 100} - & useAim . aimWeight .~ 6 - & useAim . aimRange .~ 1 - & useAim . aimStance .~ TwoHandTwist - & useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} --- , _itFloorPict = miniGunPictItem - , _itParams = BulletShooter - { _muzVel = 1 - , _rifling = 0.9 - , _bore = 2 - , _gunBarrels = MultiBarrel - {_brlSpread = RotatingBarrels 0.01 - ,_brlNum = i - ,_brlInaccuracy = 0 - } - , _recoil = 10 - , _torqueAfter = 0 - , _randomOffset = 10 - } - , _itInvSize = 4 - } - & itDimension . dimRad .~ 20 - & itDimension . dimCenter .~ V3 5 0 0 - & itDimension . dimAttachPos .~ V3 5 (-5) 0 - & itType . iyBase .~ HELD (MINIGUNX i) - & itUse . useAim . aimMuzPos .~ 40 + & itDimension . dimRad .~ 20 + & itDimension . dimCenter .~ V3 5 0 0 + & itDimension . dimAttachPos .~ V3 5 (-5) 0 + & itType . iyBase .~ HELD (MINIGUNX i) + & itUse . useAim . aimMuzPos .~ 40 diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 2dfe25267..5d4bf2da8 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -1,4 +1,4 @@ ---{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} {- | Weapon effects when pulling the trigger. -} module Dodge.Item.Weapon.TriggerType @@ -558,12 +558,12 @@ torqueSideEffect torque _ cr w (rot, g) = randomR (-torque,torque) $ _randGen w -- pump the updated creature into the chain in later frames -repeatOnFrames :: [Int] -> ChainEffect -repeatOnFrames = const id ---repeatOnFrames is f it cr w = f it cr w --- & delayedEvents .++~ (is <&> (, f')) +repeatOnFrames :: [Int] -> HeldMod -> ChainEffect +--repeatOnFrames is hm f it cr w = f it cr w +repeatOnFrames is hm f it cr w = f it cr $ w + & cWorld . delayedEvents .++~ (is <&> (, WdWdFromItCrixWdWd (it & itUse . useMods .~ hm) (_crID cr) ItCrWdItemEffect)) -- where --- f' w' = fromMaybe w' $ do +-- f' = fromMaybe w' $ do -- cr' <- w' ^? creatures . ix (_crID cr) -- return $ f it cr' w' diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index ca673f842..5a5951bd4 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -141,7 +141,7 @@ subInventoryDisplay subinv cfig w = case subinv of equipcursors = IM.foldMapWithKey (f yellow) (_crInvEquipped cr) f col invid epos = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos rboptions = if ButtonRight `M.member` _mouseButtons w - then drawRBOptions cfig w (_rbOptions (_cWorld w)) + then drawRBOptions cfig w (_rbOptions w) else mempty itmInfo :: Maybe Item -> [String] @@ -187,7 +187,7 @@ drawRBOptions cfig w EquipOptions{_opEquip = es,_opSel=i, _opAllocateEquipment=a where midtext str = listTextPictureAt 252 0 cfig curpos (text str) extratext str = listTextPictureAt 432 0 cfig curpos (text (str ++ deactivatetext)) - deactivatetext = case w ^? cWorld . rbOptions . opActivateEquipment . deactivateEquipment of + deactivatetext = case w ^? rbOptions . opActivateEquipment . deactivateEquipment of Just k -> " DEACTIVATES " ++ show (_iyBase $ _itType (_crInv (you w) IM.! k)) Nothing -> "" curpos = invSelPos w @@ -255,7 +255,7 @@ topCursorTypeWidth ctype width cfig w i = ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (selNumSlots i w) determineInvSelCursorWidth :: World -> Int -determineInvSelCursorWidth w = case _rbOptions (_cWorld w) of +determineInvSelCursorWidth w = case _rbOptions w of NoRightButtonOptions -> topInvW EquipOptions {} -> if ButtonRight `M.member` _mouseButtons w then 47 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 11689ab05..4023b0d20 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -207,22 +207,22 @@ drawPathBetween w = setLayer DebugLayer where nodepos = (`getNodePos` w) nodelist = makePathBetween sp ep w - sp = _lSelect (_cWorld w) - ep = _rSelect (_cWorld w) + sp = _lSelect w + ep = _rSelect w drawNodesNearSelect :: World -> Picture drawNodesNearSelect w = setLayer DebugLayer $ runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp)) <> color green (drawCross sp) where - sp = _lSelect (_cWorld w) + sp = _lSelect w drawInspectWalls :: World -> Picture drawInspectWalls w = foldMap (drawInspectWall w) $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $ IM.elems $ _walls (_cWorld w) where - (a,b) = _lLine (_cWorld w) + (a,b) = _lLine w drawInspectWall :: World -> Wall -> Picture drawInspectWall w wl = setLayer DebugLayer @@ -252,8 +252,8 @@ drawWorldSelect w = setLayer DebugLayer $ color cyan (line [a,b]) <> color magenta (line [c,d]) where - (a,b) = _lLine (_cWorld w) - (c,d) = _rLine (_cWorld w) + (a,b) = _lLine w + (c,d) = _rLine w drawFarWallDetect :: World -> Picture drawFarWallDetect w = setLayer DebugLayer diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 70798ee19..1a9ddce84 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -1,165 +1,175 @@ {-# LANGUAGE BangPatterns #-} + {- | Module : Dodge.Update Description : Simulation update -} -module Dodge.Update ( updateUniverse ) where -import Dodge.Magnet.Update -import Dodge.TmTm +module Dodge.Update (updateUniverse) where + import Color -import Dodge.DrWdWd -import Dodge.TractorBeam.Update -import Dodge.Prop.Update -import Dodge.LinearShockwave.Update -import Dodge.Shockwave.Update -import Dodge.Tesla.Arc -import Dodge.Laser.Update -import Dodge.PressPlate -import Dodge.ModificationEffect -import Dodge.CrGroupUpdate -import Dodge.Zoning.Cloud -import Dodge.Zoning.Creature -import Dodge.WorldEffect -import Dodge.Data +--import Dodge.Zone + +import Control.Applicative +import Data.List +import qualified Data.Map.Strict as M +import Data.Maybe +import Dodge.Base import Dodge.Beam -import Dodge.LightSource.Update -import Dodge.Projectile.Update +import Dodge.Bullet +import Dodge.CrGroupUpdate import Dodge.Creature.Update -import Dodge.RadarSweep -import Dodge.PosEvent -import Dodge.Spark +import Dodge.CullBox +import Dodge.Data +import Dodge.Distortion +import Dodge.DrWdWd import Dodge.EnergyBall import Dodge.Flame -import Dodge.Bullet -import Dodge.Update.Cloud -import Dodge.Machine.Update -import Dodge.RadarBlip import Dodge.Flare -import Dodge.Menu -import Dodge.CullBox -import Dodge.Distortion -import Dodge.SoundLogic -import Dodge.Update.WallDamage -import Dodge.Base ---import Dodge.Zone import Dodge.Hammer -import Dodge.WallCreatureCollisions -import Dodge.Update.Camera import Dodge.Inventory -import Sound.Data +import Dodge.Laser.Update +import Dodge.LightSource.Update +import Dodge.LinearShockwave.Update +import Dodge.Machine.Update +import Dodge.Magnet.Update +import Dodge.Menu +import Dodge.ModificationEffect +import Dodge.PosEvent +import Dodge.PressPlate +import Dodge.Projectile.Update +import Dodge.Prop.Update +import Dodge.RadarBlip +import Dodge.RadarSweep +import Dodge.Shockwave.Update +import Dodge.SoundLogic +import Dodge.Spark +import Dodge.Tesla.Arc +import Dodge.TmTm +import Dodge.TractorBeam.Update +import Dodge.Update.Camera +import Dodge.Update.Cloud +import Dodge.Update.WallDamage +import Dodge.WallCreatureCollisions +import Dodge.WorldEffect +import Dodge.Zoning.Cloud +import Dodge.Zoning.Creature import Geometry -import LensHelp -import FoldableHelp - -import Data.List -import Data.Maybe import qualified IntMapHelp as IM -import qualified Data.Map.Strict as M -import Control.Applicative +import LensHelp --import qualified Streaming.Prelude as S import SDL +import Sound.Data {- For most menus the only way to change the world is using event handling. -} updateUniverse :: Universe -> Universe updateUniverse u = case _menuLayers u of - (WaitScreen s i : _) - | i < 1 -> u & over uvWorld doWorldEvents - | otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail ) - (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~ - ( --updateParticles - (cWorld . radarBlips .~ []) --- . updateIMl _props _pjUpdate - . updateLightSources - . updateClouds ) + (WaitScreen s i : _) + | i < 1 -> u & over uvWorld doWorldEvents + | otherwise -> u & menuLayers %~ ((WaitScreen s (i -1) :) . tail) + (OptionScreen{_scOptionFlag = GameOverOptions} : _) -> + u & uvWorld + %~ ( + --updateParticles + (cWorld . radarBlips .~ []) + -- . updateIMl _props _pjUpdate + . updateLightSources + . updateClouds + ) (_ : _) -> u - [] -> functionalUpdate u + [] -> functionalUpdate u -{- | The update step. -} +-- | The update step. functionalUpdate :: Universe -> Universe -functionalUpdate w = checkEndGame --- . updateRandGen - . over uvWorld (mouseButtons . each .~ True) -- to determine if the mouse button is held - . over uvWorld (cWorld . worldClock +~ 1) - . over uvWorld updateWorldSelect - . over uvWorld doRewind - . over uvWorld (hammers . each %~ moveHammerUp) - . over uvWorld updateDistortions - . over uvWorld updateCreatureSoundPositions - . over uvWorld ppEvents - . updateCamera - . colCrsWalls - . over uvWorld simpleCrSprings - . over uvWorld zoneCreatures - . over uvWorld (updateIMl (_doors . _cWorld) (doDrWdWd . _drMech) ) - . over uvWorld doWorldEvents - . over uvWorld updateDelayedEvents - . over uvWorld (updateIMl (_modifications. _cWorld) (doModificationEffect . _mdUpdate) ) - . over uvWorld updateSparks - . over uvWorld updateRadarSweeps - . over uvWorld updatePosEvents - . over uvWorld updateFlames - . over uvWorld updateShockwaves - . over uvWorld updateEnergyBalls --- . over uvWorld updateParticles - . over uvWorld updateBullets - . over uvWorld updateRadarBlips - . over uvWorld updateFlares - . over uvWorld updateBeams - . over uvWorld updateLasers - . over uvWorld updateTeslaArcs - . over uvWorld updateTractorBeams - . over uvWorld (updateIMl' (_linearShockwaves . _cWorld) updateLinearShockwave) - . over uvWorld (updateIMl' (_props . _cWorld) updateProp ) - . over uvWorld (updateIMl' (_projectiles . _cWorld) updateProjectile) - . over uvWorld updateLightSources - . over uvWorld updateClouds - . over uvWorld updateGusts - . over uvWorld zoneClouds - . over uvWorld (updateMIM (cWorld . magnets) (doMagnetUpdate . _mgUpdate) ) - . over uvWorld (updateIMl' (_terminals . _cWorld) tmUpdate ) --- . updateIMl _machines mcChooseUpdate - . over uvWorld (updateIMl' (_machines . _cWorld) updateMachine ) - . over uvWorld (updateIMl' (_creatures . _cWorld) updateCreature ) +functionalUpdate w = + checkEndGame + -- . updateRandGen + . over uvWorld (mouseButtons . each .~ True) -- to determine if the mouse button is held + . over uvWorld (cWorld . worldClock +~ 1) + . over uvWorld updateWorldSelect + . over uvWorld doRewind + . over uvWorld (hammers . each %~ moveHammerUp) + . over uvWorld updateDistortions + . over uvWorld updateCreatureSoundPositions + . over uvWorld ppEvents + . updateCamera + . colCrsWalls + . over uvWorld simpleCrSprings + . over uvWorld zoneCreatures + . over uvWorld (updateIMl (_doors . _cWorld) (doDrWdWd . _drMech)) + . over uvWorld doWorldEvents + . over uvWorld updateDelayedEvents + . over uvWorld (updateIMl (_modifications . _cWorld) (doModificationEffect . _mdUpdate)) + . over uvWorld updateSparks + . over uvWorld updateRadarSweeps + . over uvWorld updatePosEvents + . over uvWorld updateFlames + . over uvWorld updateShockwaves + . over uvWorld updateEnergyBalls + -- . over uvWorld updateParticles + . over uvWorld updateBullets + . over uvWorld updateRadarBlips + . over uvWorld updateFlares + . over uvWorld updateBeams + . over uvWorld updateLasers + . over uvWorld updateTeslaArcs + . over uvWorld updateTractorBeams + . over uvWorld (updateIMl' (_linearShockwaves . _cWorld) updateLinearShockwave) + . over uvWorld (updateIMl' (_props . _cWorld) updateProp) + . over uvWorld (updateIMl' (_projectiles . _cWorld) updateProjectile) + . over uvWorld updateLightSources + . over uvWorld updateClouds + . over uvWorld updateGusts + . over uvWorld zoneClouds + . over uvWorld (updateMIM (cWorld . magnets) (doMagnetUpdate . _mgUpdate)) + . over uvWorld (updateIMl' (_terminals . _cWorld) tmUpdate) + -- . updateIMl _machines mcChooseUpdate + . over uvWorld (updateIMl' (_machines . _cWorld) updateMachine) + . over uvWorld (updateIMl' (_creatures . _cWorld) updateCreature) -- creatures should be updated early so that crOldPos is set before any position change - . over (uvWorld . cWorld . creatures) (fmap setOldPos) - . over uvWorld updateCreatureGroups - . over uvWorld updateWallDamages - . over uvWorld updateSeenWalls - . over uvWorld updateTerminal - . over uvWorld updateRBList - . updateBounds -- where should this go? next to update camera? - $ over uvWorld updateCloseObjects w + . over (uvWorld . cWorld . creatures) (fmap setOldPos) + . over uvWorld updateCreatureGroups + . over uvWorld updateWallDamages + . over uvWorld updateSeenWalls + . over uvWorld updateTerminal + . over uvWorld updateRBList + . updateBounds -- where should this go? next to update camera? + $ over uvWorld updateCloseObjects w doWorldEvents :: World -> World -doWorldEvents w = foldr doWorldEffect (w & cWorld . worldEvents .~ []) (_worldEvents (_cWorld w)) +doWorldEvents w = foldr doWdWd (w & cWorld . worldEvents .~ []) (_worldEvents (_cWorld w)) updateLasers :: World -> World -updateLasers w = w' - & cWorld . lasers .~ [] - & cWorld . lasersToDraw .~ ls +updateLasers w = + w' + & cWorld . lasers .~ [] + & cWorld . lasersToDraw .~ ls where - (w',ls) = mapAccumR updateLaser w (_lasers (_cWorld w)) + (w', ls) = mapAccumR updateLaser w (_lasers (_cWorld w)) zoneClouds :: World -> World -zoneClouds w = w - & cWorld . clZoning .~ mempty - & cWorld . clZoning %~ \zn -> - foldl' (flip zoneCloud) zn (_clouds (_cWorld w)) - --runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w)) +zoneClouds w = + w + & cWorld . clZoning .~ mempty + & cWorld . clZoning %~ \zn -> + foldl' (flip zoneCloud) zn (_clouds (_cWorld w)) + +--runIdentity (S.fold_ (flip $ updateZoning (:)) (zn & znObjects .~ mempty) id (_clouds w)) updateWorldSelect :: World -> World updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mouseButtons . ix ButtonRight) of - (Nothing ,Nothing) -> w - (Just False,Nothing) -> w & cWorld . lLine . _1 .~ mwp - (Just True ,Nothing) -> w & cWorld . lLine . _2 .~ mwp - (Nothing ,_) -> w - (Just False,_) -> w & cWorld . rLine . _1 .~ mwp - (Just True ,_) -> w & cWorld . rLine . _2 .~ mwp + (Nothing, Nothing) -> w + (Just False, Nothing) -> w & lLine . _1 .~ mwp + (Just True, Nothing) -> w & lLine . _2 .~ mwp + (Nothing, _) -> w + (Just False, _) -> w & rLine . _1 .~ mwp + (Just True, _) -> w & rLine . _2 .~ mwp where mwp = mouseWorldPos w - f | ButtonLeft `M.member` _mouseButtons w = cWorld . lSelect .~ mwp + f + | ButtonLeft `M.member` _mouseButtons w = lSelect .~ mwp | otherwise = id - g | ButtonRight `M.member` _mouseButtons w = cWorld . rSelect .~ mwp + g + | ButtonRight `M.member` _mouseButtons w = rSelect .~ mwp | otherwise = id --mcChooseUpdate :: Machine -> Machine -> World -> World @@ -167,31 +177,35 @@ updateWorldSelect w = f . g $ case (w ^? mouseButtons . ix ButtonLeft, w ^? mous -- | _mcHP mc > 0 = _mcUpdate mc mc' -- | otherwise = destroyMachine mc -displayTerminalLineString :: TerminalLineString -> World -> (String,Color) +displayTerminalLineString :: TerminalLineString -> World -> (String, Color) displayTerminalLineString tls = case tls of - TerminalLineConst str col -> const (str,col) + TerminalLineConst str col -> const (str, col) tmUpdate :: Terminal -> World -> World tmUpdate tm w = case w ^? cWorld . terminals . ix (_tmID tm) . tmFutureLines . ix 0 of Nothing -> w Just tl | _tlPause tl > 0 -> w & pointTermParams . tmFutureLines . ix 0 . tlPause -~ 1 - Just (TerminalLineDisplay _ f) -> w & pointTermParams %~ - ( ( tmFutureLines %~ tail ) - . ( tmDisplayedLines .:~ displayTerminalLineString f w ) - ) - Just (TerminalLineEffect _ eff) -> w - & pointTermParams . tmFutureLines %~ tail - & doTmWdWd eff tm - Just (TerminalLineTerminalEffect _ eff) -> w - & pointTermParams . tmFutureLines %~ tail - & pointTermParams %~ doTmTm eff + Just (TerminalLineDisplay _ f) -> + w & pointTermParams + %~ ( (tmFutureLines %~ tail) + . (tmDisplayedLines .:~ displayTerminalLineString f w) + ) + Just (TerminalLineEffect _ eff) -> + w + & pointTermParams . tmFutureLines %~ tail + & doTmWdWd eff tm + Just (TerminalLineTerminalEffect _ eff) -> + w + & pointTermParams . tmFutureLines %~ tail + & pointTermParams %~ doTmTm eff where pointTermParams = cWorld . terminals . ix (_tmID tm) setOldPos :: Creature -> Creature -setOldPos cr = cr - & crOldPos .~ _crPos cr - & crOldDir .~ _crDir cr +setOldPos cr = + cr + & crOldPos .~ _crPos cr + & crOldDir .~ _crDir cr -- hack --updateRandGen :: World -> World @@ -199,25 +213,30 @@ setOldPos cr = cr doRewind :: World -> World doRewind w = case _maybeWorld (_cWorld w) of - Just' cw -> w & cWorld .~ (cw & timeFlow .~ RewindingLastFrame) - Nothing' -> w & cWorld . timeFlow .~ NormalTimeFlow + Just' cw -> + w & cWorld .~ cw + & timeFlow .~ RewindingLastFrame + Nothing' -> w & timeFlow .~ NormalTimeFlow zoneCreatures :: World -> World -zoneCreatures w = w - & cWorld . crZoning .~ mempty - & cWorld . crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures (_cWorld w)) --- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr)) +zoneCreatures w = + w + & cWorld . crZoning .~ mempty + & cWorld . crZoning %~ \zn -> foldl' (flip zoneCreature) zn (_creatures (_cWorld w)) + +-- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr)) -- zn (_creatures w) updateCreatureSoundPositions :: World -> World -updateCreatureSoundPositions w = M.foldlWithKey' insertSound w - . M.mapMaybeWithKey updateSound - $ _playingSounds w +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 . creatures . ix cid . crPos of - Just p -> Just s {_soundPos = p, _soundAngDist = Just (soundAngle p w,0)} - Nothing -> Just s {_soundTime = Just 0} + 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 @@ -229,15 +248,16 @@ updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World updateIMl' fim fup w = foldl' (flip fup) w (fim w) updateCreatureGroups :: World -> World -updateCreatureGroups w = w & cWorld . creatureGroups %~ - IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp) +updateCreatureGroups w = + w & cWorld . creatureGroups + %~ IM.mapMaybe (\cgp -> doCrGroupUpdate (_crGroupUpdate cgp) w cgp) updateDistortions :: World -> World updateDistortions = cWorld . distortions %~ mapMaybe updateDistortion updateLightSources :: World -> World updateLightSources = cWorld . tempLightSources %~ f - where + where f = mapMaybe (\b -> updateTempLightSource (_tlsUpdate b) b) updateRadarBlips :: World -> World @@ -249,104 +269,108 @@ updateFlares = cWorld . flares %~ mapMaybe updateFlare updateTeslaArcs :: World -> World updateTeslaArcs w = w' & cWorld . teslaArcs .~ catMaybes newtas where - (w',newtas) = mapAccumR moveTeslaArc w $ _teslaArcs (_cWorld w) + (w', newtas) = mapAccumR moveTeslaArc w $ _teslaArcs (_cWorld w) updateTractorBeams :: World -> World updateTractorBeams w = w' & cWorld . tractorBeams .~ catMaybes newtas where - (w',newtas) = mapAccumR updateTractorBeam w $ _tractorBeams (_cWorld w) - + (w', newtas) = mapAccumR updateTractorBeam w $ _tractorBeams (_cWorld w) {- Apply internal particle updates, delete 'Nothing's. -} updateBullets :: World -> World updateBullets w = updateInstantBullets $ set (cWorld . bullets) (catMaybes ps) w' - where - (w',ps) = mapAccumR updateBullet w $ _bullets (_cWorld w) + where + (w', ps) = mapAccumR updateBullet w $ _bullets (_cWorld w) updateShockwaves :: World -> World updateShockwaves w = w' & cWorld . shockwaves .~ catMaybes newflames where - (w',newflames) = mapAccumR updateShockwave w $ _shockwaves (_cWorld w) + (w', newflames) = mapAccumR updateShockwave w $ _shockwaves (_cWorld w) updateFlames :: World -> World updateFlames w = w' & cWorld . flames .~ catMaybes newflames where - (w',newflames) = mapAccumR moveFlame w $ _flames (_cWorld w) + (w', newflames) = mapAccumR moveFlame w $ _flames (_cWorld w) updateEnergyBalls :: World -> World updateEnergyBalls w = w' & cWorld . energyBalls .~ catMaybes newebs where - (w',newebs) = mapAccumR moveEnergyBall w $ _energyBalls (_cWorld w) + (w', newebs) = mapAccumR moveEnergyBall w $ _energyBalls (_cWorld w) + updateRadarSweeps :: World -> World updateRadarSweeps w = w' & cWorld . radarSweeps .~ catMaybes newradarSweeps where - (w',newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps (_cWorld w) + (w', newradarSweeps) = mapAccumR updateRadarSweep w $ _radarSweeps (_cWorld w) updateSparks :: World -> World updateSparks w = w' & cWorld . sparks .~ catMaybes newsparks where - (w',newsparks) = mapAccumR moveSpark w $ _sparks (_cWorld w) + (w', newsparks) = mapAccumR moveSpark w $ _sparks (_cWorld w) + updatePosEvents :: World -> World updatePosEvents w = w' & cWorld . posEvents .~ catMaybes newposEvents where - (w',newposEvents) = mapAccumR updatePosEvent w $ _posEvents (_cWorld w) - + (w', newposEvents) = mapAccumR updatePosEvent w $ _posEvents (_cWorld w) {- Apply internal particle updates, delete 'Nothing's. -} --updateParticles :: World -> World --updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w' --- where +-- where -- (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w updateBeams :: World -> World -updateBeams w = w - & cWorld . newBeams .~ WorldBeams [] [] [] [] - & cWorld . beams .~ thebeams - & combineBeams thebeams +updateBeams w = + w + & cWorld . newBeams .~ WorldBeams [] [] [] [] + & cWorld . beams .~ thebeams + & combineBeams thebeams where thebeams = _newBeams (_cWorld w) combineBeams :: WorldBeams -> World -> World -combineBeams wbeams w = w'' - & cWorld . beams . positronBeams .~ pbeams - & cWorld . beams . electronBeams .~ ebeams +combineBeams wbeams w = + w'' + & cWorld . beams . positronBeams .~ pbeams + & cWorld . beams . electronBeams .~ ebeams where - (w',pbeams) = mapAccumR (combineBeamBeams (_electronBeams wbeams)) w $ _positronBeams wbeams - (w'',ebeams) = mapAccumR (combineBeamBeams (_positronBeams wbeams)) w' $ _electronBeams wbeams + (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 :: [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) + (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 :: + 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 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 +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 + Just a@(z, _) -> intersectSegBeams sp z bms <|> Just a intersectSegBeams _ _ _ = Nothing -intersectSegBeam :: Point2 -> Point2 -> Beam -> Maybe (Point2,(Point2,Point2,Beam)) +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)) + 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 +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) + 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 @@ -362,7 +386,7 @@ intersectSegSegs' _ _ _ = Nothing --intersectSegSegss _ _ _ = Nothing -- --intersectSegsSegss :: [Point2] -> [[Point2]] -> Maybe Point2 ---intersectSegsSegss (x:y:ys) ass = maybe +--intersectSegsSegss (x:y:ys) ass = maybe -- (intersectSegsSegss (y:ys) ass) -- Just -- (intersectSegSegss x y ass) @@ -370,8 +394,9 @@ intersectSegSegs' _ _ _ = Nothing updateInstantBullets :: World -> World updateInstantBullets w = case _instantBullets (_cWorld w) of [] -> w - ps -> let (w',ps') = mapAccumR updateBullet (w & cWorld . instantBullets.~[]) ps - in updateInstantBullets $ w' & cWorld . bullets .++~ catMaybes ps' + ps -> + let (w', ps') = mapAccumR updateBullet (w & cWorld . instantBullets .~ []) ps + in updateInstantBullets $ w' & cWorld . bullets .++~ catMaybes ps' --updateInstantParticles :: World -> World --updateInstantParticles w = case _instantParticles w of @@ -384,7 +409,7 @@ updateMIM f up = f %~ IM.mapMaybe (dbArg up) -- Note that this updates the randgen --updateCreatures :: World -> World ---updateCreatures w = appEndo f $ w +--updateCreatures w = appEndo f $ w -- & creatures .~ IM.mapMaybe id m -- & randGen .~ newg -- where @@ -399,8 +424,9 @@ ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ _p updateSeenWalls :: World -> World updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w) --- where --- f w' !i -- = w' & walls . ix i . wlSeen .~ True + +-- where +-- f w' !i -- = w' & walls . ix i . wlSeen .~ True -- = w' { _walls = IM.adjust mw i $ _walls w' } -- mw wl = wl {_wlSeen = True} @@ -408,12 +434,14 @@ markWallSeen :: World -> Int -> World markWallSeen !w !i = w & cWorld . walls .~ IM.adjust markSeen i (_walls (_cWorld w)) markSeen :: Wall -> Wall -markSeen wl = wl {_wlSeen = True} +markSeen wl = wl{_wlSeen = True} checkEndGame :: Universe -> Universe checkEndGame uv = case _deathDelay (_cWorld w) of - Just x | x < 0 -> uv & menuLayers .~ [gameOverMenu] - & uvWorld . cWorld . deathDelay .~ Nothing + Just x + | x < 0 -> + uv & menuLayers .~ [gameOverMenu] + & uvWorld . cWorld . deathDelay .~ Nothing Just _ -> uv & uvWorld . cWorld . deathDelay . _Just -~ 1 _ | _crHP (you w) < 1 -> uv & uvWorld . cWorld . deathDelay ?~ 50 _ -> uv @@ -426,27 +454,33 @@ updateGusts w = w & cWorld . gusts %~ IM.mapMaybe (mvGust w) mvGust :: World -> Gust -> Maybe Gust mvGust _ gu | _guTime gu < 0 = Nothing - | otherwise = Just $ gu - & guPos .+.+~ _guVel gu - & guTime -~ 1 + | otherwise = + Just $ + gu + & guPos .+.+~ _guVel gu + & guTime -~ 1 + updateClouds :: World -> World updateClouds w = w' & cWorld . clouds .~ catMaybes mclouds where --- cls = _clouds w - (w',mclouds) = mapAccumR updateCloud w (_clouds (_cWorld w)) + -- cls = _clouds w + (w', mclouds) = mapAccumR updateCloud w (_clouds (_cWorld w)) cloudEffect :: Cloud -> World -> World cloudEffect cl = case _clType cl of GasCloud -> cloudPoisonDamage cl SmokeCloud -> id -updateCloud :: World -> Cloud -> (World,Maybe Cloud) +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 + | otherwise = + ( cloudEffect c w + , Just $ + c + & clPos .~ finalPos + & clVel .~ finalVel + & clTimer -~ 1 ) where newVel@(V3 _ _ nvz) = (0.95 *.*.* springVels) +.+.+ V3 0 0 (0.001 * vertVel) @@ -459,14 +493,14 @@ updateCloud w c newPos2 = stripZ newPos hitWl = bouncePoint (const True) 1 oldPos2 newPos2 w finalPos = addZ (min 74 npz) $ maybe newPos2 fst hitWl - -- allowing clouds at/above height 75 causes graphical glitches 22.05.23 + -- allowing clouds at/above height 75 causes graphical glitches 22.05.23 finalVel = addZ nvz $ maybe newVel2 snd hitWl clClSpringVel :: Cloud -> Point3 -> Cloud -> Point3 clClSpringVel a v b | dist3 pa pb < radDist = v +.+.+ 0.1 *.*.* normalizeV3 (pa -.-.- pb) | otherwise = v - where + where pa = _clPos a pb = _clPos b radDist = (_clRad a + _clRad b) / 2 @@ -477,32 +511,34 @@ simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures (_cWorld w) -- 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 + where cs = crsNearPoint (_crPos c) w crCrSpring :: Creature -> Creature -> World -> World crCrSpring c1 c2 - | id1 == id2 = id + | id1 == id2 = id | vec == V2 0 0 = id | diff >= comRad = id - | otherwise = cWorld . creatures %~ - ( over (ix id1 . crPos) (+.+ overlap1) - . over (ix id2 . crPos) (-.- overlap2) - ) - where - id1 = _crID c1 - id2 = _crID c2 - vec = _crPos c1 -.- _crPos c2 + | otherwise = + cWorld . creatures + %~ ( over (ix id1 . crPos) (+.+ overlap1) + . over (ix id2 . crPos) (-.- overlap2) + ) + where + id1 = _crID c1 + id2 = _crID c2 + vec = _crPos c1 -.- _crPos c2 diff = magV vec - comRad = _crRad c1 + _crRad c2 + comRad = _crRad c1 + _crRad c2 overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec - massT = _crMass c1 + _crMass c2 + massT = _crMass c1 + _crMass c2 updateDelayedEvents :: World -> World -updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents (_cWorld w)) - in neww & cWorld . delayedEvents .~ catMaybes newde +updateDelayedEvents w = + let (neww, newde) = mapAccumR f w (_delayedEvents (_cWorld w)) + in neww & cWorld . delayedEvents .~ catMaybes newde where - f w' (i,g) - | i <= 0 = (w' & cWorld . worldEvents .:~ g, Nothing) - | otherwise = (w', Just (i-1,g)) + f w' (i, g) + | i <= 0 = (w' & cWorld . worldEvents .:~ g, Nothing) + | otherwise = (w', Just (i -1, g)) diff --git a/src/Dodge/Update/UsingInput.hs b/src/Dodge/Update/UsingInput.hs index 52c6dac3a..9e6da8949 100644 --- a/src/Dodge/Update/UsingInput.hs +++ b/src/Dodge/Update/UsingInput.hs @@ -53,10 +53,10 @@ updatePressedButtons' :: M.Map MouseButton Bool -> World -> World updatePressedButtons' pkeys w | isDown ButtonLeft && isDown ButtonRight && inTopInv = useItem (you w) w & hammers . ix DoubleMouseHam .~ HammerDown - | isDown ButtonLeft && (inTopInv || _timeFlow (_cWorld w) == RewindingLastFrame) + | isDown ButtonLeft && (inTopInv || _timeFlow w == RewindingLastFrame) && w ^?! hammers . ix DoubleMouseHam == HammerUp = useLeftItem (_yourID (_cWorld w)) w - | isDown ButtonLeft && (inTopInv || _timeFlow (_cWorld w) == RewindingLastFrame) + | isDown ButtonLeft && (inTopInv || _timeFlow w == RewindingLastFrame) = w & hammers . ix DoubleMouseHam .~ HammerDown | isDown ButtonRight && inTopInv = w | isDown ButtonMiddle diff --git a/src/Dodge/WorldEffect.hs b/src/Dodge/WorldEffect.hs index d838ea8c8..d28345c1b 100644 --- a/src/Dodge/WorldEffect.hs +++ b/src/Dodge/WorldEffect.hs @@ -1,55 +1,67 @@ module Dodge.WorldEffect where -import Dodge.Terminal -import Dodge.SoundLogic -import Dodge.WorldEvent.Cloud -import Dodge.Data -import Dodge.Inventory.Lock -import Dodge.Default -import LensHelp -import Data.Maybe import Data.Foldable import qualified Data.Map.Strict as M +import Data.Maybe +import Dodge.Creature.Impulse.UseItem +import Dodge.Data +import Dodge.Default +import Dodge.Inventory.Lock +import Dodge.Item.Location +import Dodge.SoundLogic +import Dodge.Terminal +import Dodge.WorldEvent.Cloud import qualified IntMapHelp as IM - +import LensHelp import System.Random -doWorldEffect :: WdWd -> World -> World -doWorldEffect we = case we of +doWdWd :: WdWd -> World -> World +doWdWd we = case we of NoWorldEffect -> id SetTrigger bool tid -> cWorld . triggers . ix tid .~ bool SetLSCol col lsid -> cWorld . lightSources . ix lsid . lsParam . lsCol .~ col AccessTerminal mtmid -> accessTerminal mtmid - WorldEffects wes -> \w -> foldr doWorldEffect w wes + WorldEffects wes -> \w -> foldr doWdWd w wes UnlockInv cid -> unlockInv cid MakeStartCloudAt p -> makeStartCloudAt p TorqueCr x cid -> torqueCr x cid SoundStart so p sid mi -> soundStart so p sid mi WdWdNegateTrig trid -> cWorld . triggers . ix trid %~ not + WdWdFromItixCrixWdWd itid crid f -> \w -> fromMaybe w $ do + cr <- w ^? cWorld . creatures . ix crid + it <- getItem itid w + return $ doItCrWdWd f it cr w + WdWdFromItCrixWdWd it crid f -> \w -> fromMaybe w $ do + cr <- w ^? cWorld . creatures . ix crid + return $ doItCrWdWd f it cr w + +doItCrWdWd :: ItCrWdWd -> Item -> Creature -> World -> World +doItCrWdWd icww = case icww of + ItCrWdId -> \_ _ -> id + ItCrWdItemEffect -> flip itemEffect accessTerminal :: Maybe Int -> World -> World accessTerminal mtmid w = case mtmid of Nothing -> w - Just tmid -> w & cWorld . hud . hudElement .~ DisplayInventory (DisplayTerminal tmid) - & cWorld . terminals . ix tmid . tmInput . tiFocus .~ True - & cWorld . terminals . ix tmid %~ tryToBoot + Just tmid -> + w & cWorld . hud . hudElement .~ DisplayInventory (DisplayTerminal tmid) + & cWorld . terminals . ix tmid . tmInput . tiFocus .~ True + & cWorld . terminals . ix tmid %~ tryToBoot where tryToBoot tm = case _tmStatus tm of TerminalReady -> tm TerminalBusy -> tm - TerminalOff -> tm - & tmFutureLines .~ doTerminalBootProgram (_tmBootProgram tm) tm w - & tmStatus .~ TerminalBusy + TerminalOff -> + tm + & tmFutureLines .~ doTerminalBootProgram (_tmBootProgram tm) tm w + & tmStatus .~ TerminalBusy torqueCr :: Float -> Int -> World -> World torqueCr x cid w - | cid == 0 = set randGen g $ over (cWorld . cameraRot) (+rot) w - | otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+rot) w - where - (rot, g) = randomR (-x,x) $ _randGen w - - - + | cid == 0 = set randGen g $ over (cWorld . cameraRot) (+ rot) w + | otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) w + where + (rot, g) = randomR (- x, x) $ _randGen w doCommandInstant :: String -> Terminal -> World -> World doCommandInstant arg tm w = doLineEffectsInstant tm w $ commandFutureLines arg tm w @@ -62,25 +74,27 @@ doLineEffectsInstant tm = foldr f TerminalLineEffect _ eff -> doTmWdWd eff tm w _ -> w - lineOutputTerminal :: [TerminalLine] -> Terminal -lineOutputTerminal tls = defaultTerminal - {_tmDisplayedLines = [] - ,_tmFutureLines = [] - ,_tmMaxLines = 14 - ,_tmTitle = "TERMINAL" - ,_tmInput = defaultTerminalInput - ,_tmScrollCommands = [quitCommand] - ,_tmWriteCommands = [helpCommand,commandsCommand] - ,_tmBootProgram = TerminalBootLines $ connectionBlurbLines tls - , _tmDeathEffect = TmWdWdDoDeathTriggers - } +lineOutputTerminal tls = + defaultTerminal + { _tmDisplayedLines = [] + , _tmFutureLines = [] + , _tmMaxLines = 14 + , _tmTitle = "TERMINAL" + , _tmInput = defaultTerminalInput + , _tmScrollCommands = [quitCommand] + , _tmWriteCommands = [helpCommand, commandsCommand] + , _tmBootProgram = TerminalBootLines $ connectionBlurbLines tls + , _tmDeathEffect = TmWdWdDoDeathTriggers + } doDeathTriggers :: Terminal -> World -> World -doDeathTriggers tm w = w - & cWorld . triggers %~ flip (foldl' $ flip doDeathToggle) xs +doDeathTriggers tm w = + w + & cWorld . triggers %~ flip (foldl' $ flip doDeathToggle) xs where xs = M.elems $ _tmToggles tm + doDeathToggle :: TerminalToggle -> IM.IntMap Bool -> IM.IntMap Bool doDeathToggle (TerminalToggle trid f) = ix trid %~ doBlBl f @@ -90,20 +104,17 @@ doBlBl bb = case bb of BlConst bl -> const bl BlId -> id - doTerminalBootProgram :: TerminalBootProgram -> Terminal -> World -> [TerminalLine] doTerminalBootProgram tbp = case tbp of TerminalBootMempty -> \_ _ -> [] TerminalBootLines ls -> \_ _ -> ls - - doTmWdWd :: TmWdWd -> Terminal -> World -> World doTmWdWd tmwdwd = case tmwdwd of TmWdId -> const id TmWdWdDisconnectTerminal -> disconnectTerminal - TmWdWdTermSound sid -> \tm w -> let tpos = fromMaybe 0 $ w ^? cWorld . buttons . ix (_tmButtonID tm) . btPos - in soundStart TerminalSound tpos sid Nothing w + TmWdWdTermSound sid -> \tm w -> + let tpos = fromMaybe 0 $ w ^? cWorld . buttons . ix (_tmButtonID tm) . btPos + in soundStart TerminalSound tpos sid Nothing w TmWdWdDoDeathTriggers -> doDeathTriggers - TmWdWdfromWdWd f -> \_ -> doWorldEffect f - + TmWdWdfromWdWd f -> \_ -> doWdWd f