justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup, split CWorld into separate file

Browse Source
This commit is contained in:
justin
2022-07-26 21:19:12 +01:00
parent c2707719fb
commit 6554d219dc
27 changed files with 1049 additions and 911 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+1 -1
View File
@@ -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
src/Dodge/Button/Event.hs
+3 -3
View File
@@ -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\\")
src/Dodge/Creature.hs
+7 -42
View File
@@ -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
src/Dodge/Creature/Action.hs
+104 -96
View File
@@ -1,55 +1,45 @@
--{-# 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
performActions w cr =
cr
& crActionPlan . apImpulse .~ concat iss
& crActionPlan . apAction .~ catMaybes mayas
where
@@ -66,7 +56,8 @@ 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)
tpos
| canSee' = _crPos (_creatures (_cWorld w) IM.! tcid)
| otherwise = p
performPathTo :: Creature -> World -> Point2 -> OutAction
@@ -74,13 +65,14 @@ performPathTo cr w p
| dist cpos p <= _crRad cr = ([], Nothing)
| isWalkable cpos p w = ([MvTurnToward p, MvForward, RandomTurn jit], Just (PathTo p))
| otherwise = case pointTowardsImpulse p cpos w of
Just q -> ([MvTurnToward q
Just q ->
(
[ MvTurnToward q
, MvForward
, RandomTurn jit
-- ,ArbitraryImpulseEffect . const
-- $ debugPicture .~ drawPathList cpos p w
]
, Just (PathTo p))
, Just (PathTo p)
)
_ -> ([], Nothing)
where
cpos = _crPos cr
@@ -98,7 +90,7 @@ 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)
@@ -152,12 +144,13 @@ performAction cr w ac = case ac of
(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
-- | 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
@@ -172,9 +165,10 @@ blinkActionFail cr w = w
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
blinkAction cr w =
w
& soundMultiFrom [TeleSound 0, TeleSound 1] p3 teleS Nothing
& cWorld . distortions .++~ distortionBulge
& cWorld . creatures . ix cid . crPos .~ p3
@@ -194,21 +188,24 @@ blinkAction cr w = w
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
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
| 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
| otherwise =
w
& blinkActionFail cr
& cWorld . creatures . ix cid . crState . csDamage .:~
Damage ENTERREMENT 10000 mwp mwp mwp NoDamageEffect
& 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
@@ -222,11 +219,12 @@ unsafeBlinkAction cr w
mwp = mouseWorldPos w
cpos = _crPos cr
blinkShockwave
:: Int -- ^ Blinking creature ID.
-> Point2
-> World
-> World
blinkShockwave ::
-- | Blinking creature ID.
Int ->
Point2 ->
World ->
World
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan
setMinInvSize :: Int -> Creature -> World -> World
@@ -234,14 +232,17 @@ 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 )
organiseInvKeys cid w =
w & cWorld . creatures . ix cid
%~ ( (crInvSel . iselPos .~ newSelKey)
. (crInv .~ newInv)
. ( crInvSel . iselAction .~ NoInvSelAction) )
. (crInvSel . iselAction .~ NoInvSelAction)
)
where
cr = _creatures (_cWorld w) IM.! cid
pairs = IM.toList (_crInv cr)
@@ -249,17 +250,20 @@ organiseInvKeys cid w = w & cWorld . creatures . ix cid %~
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
@@ -270,30 +274,33 @@ 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
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
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
| not (crOnWall cr1 w) =
Just $
w
& soundMultiFrom [TeleSound 0, TeleSound 1] cpos teleS Nothing
& cWorld . distortions .:~ distortionBulge
& cWorld . creatures . ix cid %~
( (crRad .~ 10 * x)
& cWorld . creatures . ix cid
%~ ( (crRad .~ 10 * x)
. (crMvType . mvSpeed .~ yourDefaultSpeed * x)
. (crStance . strideLength .~ ceiling (fromIntegral yourDefaultStrideLength * x))
)
@@ -311,7 +318,8 @@ sizeSelf x cr w
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
src/Dodge/Creature/Impulse/UseItem.hs
+3 -2
View File
@@ -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
src/Dodge/Data.hs
+5 -113
View File
@@ -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
src/Dodge/Data/ActionPlan.hs
+38 -14
View File
@@ -1,17 +1,18 @@
{-# 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
@@ -21,16 +22,22 @@ data ActionPlan
, _apGoal :: [Goal]
}
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON ActionPlan where
toEncoding = genericToEncoding defaultOptions
instance FromJSON ActionPlan
data RandImpulse
= RandImpulseList [Impulse]
| RandImpulseCircMove Float
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON RandImpulse where
toEncoding = genericToEncoding defaultOptions
instance FromJSON RandImpulse
data Impulse
= Move Point2
| MoveForward Float
@@ -64,14 +71,22 @@ data Impulse
}
| ImpulseNothing
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
@@ -88,10 +103,10 @@ data Action
| TurnToPoint
{ _turnToPoint :: Point2
}
-- | PickupItem
| -- | PickupItem
-- {_pickupItemID :: Int
-- }
| ImpulsesList
ImpulsesList
{ _impulsesListList :: [[Impulse]]
}
| DoImpulses
@@ -131,10 +146,10 @@ data Action
{ _doActionThenFirst :: Action
, _doActionThenSecond :: Action
}
-- | DoGuardActions
| -- | DoGuardActions
-- {_doGuardActionsList :: [( (World, Creature) -> Bool, Action, Maybe Action)]
-- }
| DoReplicate
DoReplicate
{ _doReplicateTimes :: Int
, _doReplicateAction :: Action
}
@@ -162,15 +177,18 @@ data Action
}
| ArbitraryAction
{_arbitraryAction :: CrWdAc}
| DoImpulsesAlongside
-- ^ Repeatedly perform impulses alongside a main action until the main action terminates
| -- | Repeatedly perform impulses alongside a main action until the main action terminates
DoImpulsesAlongside
{ _sideImpulses :: [Impulse]
, _mainAction :: Action
}
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON Action where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Action
data Strategy
= Flank Int
| Ambush Int
@@ -188,17 +206,23 @@ data Strategy
| Flee
| MeleeStrike
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)
instance ToJSON Goal where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Goal
makeLenses ''ActionPlan
makeLenses ''Impulse
makeLenses ''Action
src/Dodge/Data/CWorld.hs
+159
View File
@@ -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
src/Dodge/Data/Creature.hs
+6 -3
View File
@@ -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
src/Dodge/Creature/Memory/Data.hs → src/Dodge/Data/Creature/Memory.hs
+1 -1
View File
@@ -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
src/Dodge/Creature/Perception/Data.hs → src/Dodge/Data/Creature/Perception.hs
+1 -1
View File
@@ -1,7 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Creature.Perception.Data
module Dodge.Data.Creature.Perception
( Perception (..)
, Vigilance (..)
, Attention (..)
src/Dodge/Creature/Stance/Data.hs → src/Dodge/Data/Creature/Stance.hs
+1 -1
View File
@@ -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
src/Dodge/Data/Item/HeldUse.hs
+17
View File
@@ -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
src/Dodge/Data/WorldEffect.hs
+10
View File
@@ -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
src/Dodge/Default/World.hs
+8 -8
View File
@@ -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]
src/Dodge/Event.hs
+3 -3
View File
@@ -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
src/Dodge/Event/Keyboard.hs
+4 -4
View File
@@ -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
src/Dodge/HeldUse.hs
+31 -3
View File
@@ -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
src/Dodge/Inventory.hs
+19 -19
View File
@@ -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)
src/Dodge/ItEffect.hs
-1
View File
@@ -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
src/Dodge/Item/Weapon/BulletGun/Cane.hs
+49 -64
View File
@@ -1,25 +1,28 @@
module Dodge.Item.Weapon.BulletGun.Cane
( volleyGun
, repeater
, rifle
, autoRifle
, burstRifle
, miniGunX
module Dodge.Item.Weapon.BulletGun.Cane (
volleyGun,
repeater,
rifle,
autoRifle,
burstRifle,
miniGunX,
) where
import Dodge.Reloading.Action
import Dodge.Data
import Dodge.Default.Weapon
import Dodge.Default
import Dodge.Reloading.Action
import Geometry
import LensHelp
defaultBangCane :: Item
defaultBangCane = defaultBulletWeapon
& itParams .~ BulletShooter
defaultBangCane =
defaultBulletWeapon
& itParams
.~ BulletShooter
{ _muzVel = 0.8
, _rifling = 0.9
, _bore = 2
, _gunBarrels = SingleBarrel
, _gunBarrels =
SingleBarrel
{ _brlInaccuracy = 0.01
}
, _recoil = 50
@@ -36,8 +39,10 @@ defaultBangCane = defaultBulletWeapon
& itType . iyBase .~ error "undefined bangCane baseitemtype"
& itConsumption . laMax .~ 1
& itConsumption . laCycle .~ [loadPartialInsert 10 1]
volleyGun :: Int -> Item
volleyGun i = defaultBangCane
volleyGun i =
defaultBangCane
& itUse . useDelay . rateMax .~ 6
& itUse . useMods .~ VolleyGunMod
& itUse . useAim . aimWeight .~ 6
@@ -47,115 +52,95 @@ volleyGun i = defaultBangCane
& itUse . useAim . aimHandlePos .~ 5
& itUse . useAim . aimMuzPos .~ 15
& itConsumption . laMax .~ i
& itParams .~ BulletShooter
& itParams
.~ BulletShooter
{ _muzVel = 0.8
, _rifling = 0.9
, _bore = 2
, _gunBarrels = SingleBarrel
, _gunBarrels =
SingleBarrel
{ _brlInaccuracy = 0.01
}
, _recoil = 50
, _torqueAfter = 0.1
, _randomOffset = 0
}
& itParams . gunBarrels .~ MultiBarrel
& 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
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
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
autoRifle =
repeater
& itType . iyBase .~ HELD AUTORIFLE
& itUse . useMods .~ AutoRifleMod
& itType . iyModules . at ModAutoMag ?~ EMPTYMODULE
-- & itUse . useDelay . rateMax .~ 6
burstRifle :: Item
burstRifle = repeater
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
-- ]
miniGunUse :: Int -> ItemUse
miniGunUse i = defaultrUse
miniGunUse i =
defaultrUse
& rUse .~ HeldUseAmmoParams
& useDelay .~ NoDelay
& useMods .~ MiniGunMod i
miniGunX :: Int -> Item
miniGunX i = defaultAutoGun
{ _itConsumption = defaultBulletLoadable
miniGunX i =
defaultAutoGun
{ _itConsumption =
defaultBulletLoadable
{ _laMax = 1500
, _laLoaded = 1500
}
& laCycle .~ [loadEject 40, loadInsert 40, loadPrime 40]
, _itUse = miniGunUse i
, _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
, -- , _itFloorPict = miniGunPictItem
_itParams =
BulletShooter
{ _muzVel = 1
, _rifling = 0.9
, _bore = 2
, _gunBarrels = MultiBarrel
, _gunBarrels =
MultiBarrel
{ _brlSpread = RotatingBarrels 0.01
, _brlNum = i
, _brlInaccuracy = 0
src/Dodge/Item/Weapon/TriggerType.hs
+6 -6
View File
@@ -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'
src/Dodge/Render/HUD.hs
+3 -3
View File
@@ -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
src/Dodge/Render/ShapePicture.hs
+6 -6
View File
@@ -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
src/Dodge/Update.hs
+116 -80
View File
@@ -1,63 +1,64 @@
{-# LANGUAGE BangPatterns #-}
{- |
Module : Dodge.Update
Description : Simulation update
-}
module Dodge.Update (updateUniverse) where
import Dodge.Magnet.Update
import Dodge.TmTm
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
@@ -65,18 +66,22 @@ 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
(OptionScreen{_scOptionFlag = GameOverOptions} : _) ->
u & uvWorld
%~ (
--updateParticles
(cWorld . radarBlips .~ [])
-- . updateIMl _props _pjUpdate
. updateLightSources
. updateClouds )
. updateClouds
)
(_ : _) -> u
[] -> functionalUpdate u
{- | The update step. -}
-- | The update step.
functionalUpdate :: Universe -> Universe
functionalUpdate w = checkEndGame
functionalUpdate w =
checkEndGame
-- . updateRandGen
. over uvWorld (mouseButtons . each .~ True) -- to determine if the mouse button is held
. over uvWorld (cWorld . worldClock +~ 1)
@@ -131,35 +136,40 @@ functionalUpdate w = checkEndGame
$ 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'
updateLasers w =
w'
& cWorld . lasers .~ []
& cWorld . lasersToDraw .~ ls
where
(w', ls) = mapAccumR updateLaser w (_lasers (_cWorld w))
zoneClouds :: World -> World
zoneClouds w = 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
(Just False, Nothing) -> w & lLine . _1 .~ mwp
(Just True, Nothing) -> w & lLine . _2 .~ mwp
(Nothing, _) -> w
(Just False,_) -> w & cWorld . rLine . _1 .~ mwp
(Just True ,_) -> w & cWorld . rLine . _2 .~ mwp
(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
@@ -175,21 +185,25 @@ 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 )
Just (TerminalLineDisplay _ f) ->
w & pointTermParams
%~ ( (tmFutureLines %~ tail)
. (tmDisplayedLines .:~ displayTerminalLineString f w)
)
Just (TerminalLineEffect _ eff) -> w
Just (TerminalLineEffect _ eff) ->
w
& pointTermParams . tmFutureLines %~ tail
& doTmWdWd eff tm
Just (TerminalLineTerminalEffect _ eff) -> w
Just (TerminalLineTerminalEffect _ eff) ->
w
& pointTermParams . tmFutureLines %~ tail
& pointTermParams %~ doTmTm eff
where
pointTermParams = cWorld . terminals . ix (_tmID tm)
setOldPos :: Creature -> Creature
setOldPos cr = cr
setOldPos cr =
cr
& crOldPos .~ _crPos cr
& crOldDir .~ _crDir cr
@@ -199,18 +213,23 @@ 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
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
updateCreatureSoundPositions w =
M.foldlWithKey' insertSound w
. M.mapMaybeWithKey updateSound
$ _playingSounds w
where
@@ -229,8 +248,9 @@ 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
@@ -256,7 +276,6 @@ updateTractorBeams w = w' & cWorld . tractorBeams .~ catMaybes newtas
where
(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'
@@ -277,6 +296,7 @@ updateEnergyBalls :: World -> World
updateEnergyBalls w = w' & cWorld . energyBalls .~ catMaybes newebs
where
(w', newebs) = mapAccumR moveEnergyBall w $ _energyBalls (_cWorld w)
updateRadarSweeps :: World -> World
updateRadarSweeps w = w' & cWorld . radarSweeps .~ catMaybes newradarSweeps
where
@@ -286,19 +306,20 @@ updateSparks :: World -> World
updateSparks w = w' & cWorld . sparks .~ catMaybes newsparks
where
(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)
{- Apply internal particle updates, delete 'Nothing's. -}
--updateParticles :: World -> World
--updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w'
-- where
-- (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
updateBeams :: World -> World
updateBeams w = w
updateBeams w =
w
& cWorld . newBeams .~ WorldBeams [] [] [] []
& cWorld . beams .~ thebeams
& combineBeams thebeams
@@ -306,7 +327,8 @@ updateBeams w = w
thebeams = _newBeams (_cWorld w)
combineBeams :: WorldBeams -> World -> World
combineBeams wbeams w = w''
combineBeams wbeams w =
w''
& cWorld . beams . positronBeams .~ pbeams
& cWorld . beams . electronBeams .~ ebeams
where
@@ -320,8 +342,10 @@ combineBeamBeams bms w bm = case intersectBeamBeams bm bms of
-- 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
@@ -370,7 +394,8 @@ intersectSegSegs' _ _ _ = Nothing
updateInstantBullets :: World -> World
updateInstantBullets w = case _instantBullets (_cWorld w) of
[] -> w
ps -> let (w',ps') = mapAccumR updateBullet (w & cWorld . instantBullets.~[]) ps
ps ->
let (w', ps') = mapAccumR updateBullet (w & cWorld . instantBullets .~ []) ps
in updateInstantBullets $ w' & cWorld . bullets .++~ catMaybes ps'
--updateInstantParticles :: World -> World
@@ -399,6 +424,7 @@ 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
-- = w' { _walls = IM.adjust mw i $ _walls w' }
@@ -412,7 +438,9 @@ markSeen wl = wl {_wlSeen = True}
checkEndGame :: Universe -> Universe
checkEndGame uv = case _deathDelay (_cWorld w) of
Just x | x < 0 -> uv & menuLayers .~ [gameOverMenu]
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
@@ -426,9 +454,12 @@ updateGusts w = w & cWorld . gusts %~ IM.mapMaybe (mvGust w)
mvGust :: World -> Gust -> Maybe Gust
mvGust _ gu
| _guTime gu < 0 = Nothing
| otherwise = Just $ gu
| otherwise =
Just $
gu
& guPos .+.+~ _guVel gu
& guTime -~ 1
updateClouds :: World -> World
updateClouds w = w' & cWorld . clouds .~ catMaybes mclouds
where
@@ -443,7 +474,10 @@ cloudEffect cl = case _clType cl of
updateCloud :: World -> Cloud -> (World, Maybe Cloud)
updateCloud w c
| _clTimer c < 1 = (w, Nothing)
| otherwise = (cloudEffect c w, Just $ c
| otherwise =
( cloudEffect c w
, Just $
c
& clPos .~ finalPos
& clVel .~ finalVel
& clTimer -~ 1
@@ -485,8 +519,9 @@ crCrSpring c1 c2
| id1 == id2 = id
| vec == V2 0 0 = id
| diff >= comRad = id
| otherwise = cWorld . creatures %~
( over (ix id1 . crPos) (+.+ overlap1)
| otherwise =
cWorld . creatures
%~ ( over (ix id1 . crPos) (+.+ overlap1)
. over (ix id2 . crPos) (-.- overlap2)
)
where
@@ -500,7 +535,8 @@ crCrSpring c1 c2
massT = _crMass c1 + _crMass c2
updateDelayedEvents :: World -> World
updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents (_cWorld w))
updateDelayedEvents w =
let (neww, newde) = mapAccumR f w (_delayedEvents (_cWorld w))
in neww & cWorld . delayedEvents .~ catMaybes newde
where
f w' (i, g)
src/Dodge/Update/UsingInput.hs
+2 -2
View File
@@ -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
src/Dodge/WorldEffect.hs
+37 -26
View File
@@ -1,43 +1,58 @@
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)
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
TerminalOff ->
tm
& tmFutureLines .~ doTerminalBootProgram (_tmBootProgram tm) tm w
& tmStatus .~ TerminalBusy
@@ -48,9 +63,6 @@ torqueCr x cid 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,9 +74,9 @@ doLineEffectsInstant tm = foldr f
TerminalLineEffect _ eff -> doTmWdWd eff tm w
_ -> w
lineOutputTerminal :: [TerminalLine] -> Terminal
lineOutputTerminal tls = defaultTerminal
lineOutputTerminal tls =
defaultTerminal
{ _tmDisplayedLines = []
, _tmFutureLines = []
, _tmMaxLines = 14
@@ -77,10 +89,12 @@ lineOutputTerminal tls = defaultTerminal
}
doDeathTriggers :: Terminal -> World -> World
doDeathTriggers tm w = w
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
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