Refactor world events

src/Dodge/Data.hs

@@ -223,8 +223,8 @@ data World = World
     , _randGen          :: StdGen
     , _modifications    :: IM.IntMap Modification
     , _yourID           :: Int
-    , _worldEvents      :: World -> World
+    , _worldEvents      :: [WorldEffect]
-    , _delayedEvents    :: [(Int,World -> World)]
+    , _delayedEvents    :: [(Int,WorldEffect)]
     , _pressPlates      :: IM.IntMap PressPlate
     , _buttons          :: IM.IntMap Button
     , _toPlaySounds     :: M.Map SoundOrigin Sound
@@ -241,7 +241,7 @@ data World = World
     , _tempLightSources :: [TempLightSource]
     , _closeObjects     :: [Either FloorItem Button]
     , _rbOptions        :: RightButtonOptions
-    , _seenLocations    :: IM.IntMap (World -> Point2,String)
+    , _seenLocations    :: IM.IntMap (WdP2,String)
     , _selLocation      :: Int
     , _sideEffects      :: Universe -> IO Universe
     , _distortions      :: [Distortion]
@@ -272,6 +272,7 @@ data WorldHammer
 newtype GenParams = GenParams
     { _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape)
     }
+  deriving (Eq,Ord,Show,Read)
 data DecorationShape = PLUS | SQUARE | CIRCLE | THREELINES
   deriving (Eq,Ord,Enum,Show,Read)
 
@@ -279,12 +280,13 @@ data TimeFlowStatus
     = RewindingNow
     | RewindingLastFrame
     | NormalTimeFlow
-  deriving (Eq,Ord)
+  deriving (Eq,Ord,Show,Read)
 
 data SaveSlot = QuicksaveSlot | LevelStartSlot
-  deriving (Eq,Ord)
+  deriving (Eq,Ord,Show,Read)
 
 data OptionScreenFlag = NormalOptions | GameOverOptions
+  deriving (Eq,Ord,Show,Read)
 data ScreenLayer
     = OptionScreen
         { _scTitle   :: Universe -> String

src/Dodge/Data/WorldEffect.hs

@@ -1,8 +1,16 @@
 module Dodge.Data.WorldEffect where
+import Sound.Data
 import Geometry.Data
+import Dodge.Data.SoundOrigin
 
 data WorldEffect = NoWorldEffect
     | SetTrigger Bool Int 
     | WorldEffects [WorldEffect]
     | SetLSCol Point3 Int
     | AccessTerminal (Maybe Int)
+    | UnlockInv Int
+    | SoundStart SoundOrigin Point2 SoundID (Maybe Int)
+    | MakeStartCloudAt Point3
+    | TorqueCr Float Int
+data WdP2 = WdP2Const Point2
+    | WdYouPos

src/Dodge/Default/World.hs

@@ -2,12 +2,8 @@ module Dodge.Default.World where
 import Dodge.Data
 import Dodge.Zone.Size
 import Dodge.Zone.Object
-import Dodge.Base
 import Geometry.Vector3D
 import Geometry.Zone
---import Dodge.Config.KeyConfig
---import Dodge.Menu
---import Picture
 import Geometry.Data
 import Geometry.Polygon
 
@@ -67,7 +63,7 @@ defaultWorld = World
     , _randGen = mkStdGen 2
     , _mousePos = V2 0 0
     , _yourID = 0
-    , _worldEvents = id
+    , _worldEvents = []
     , _delayedEvents = []
     , _pressPlates = IM.empty
     , _buttons = IM.empty
@@ -93,8 +89,8 @@ defaultWorld = World
     , _closeObjects     = []
     , _rbOptions        = NoRightButtonOptions
     , _seenLocations        = IM.fromList 
-        [(0, (_crPos . you, "CURRENT POSITION"))
+        [(0, (WdYouPos, "CURRENT POSITION"))
-        ,(1, (const (V2 0 0) , "START POSITION"))
+        ,(1, (WdP2Const (V2 0 0) , "START POSITION"))
         ]
     , _selLocation = 0
     --, _keyConfig = defaultKeyConfigSDL

src/Dodge/Event/Keyboard.hs

@@ -4,6 +4,7 @@ module Dodge.Event.Keyboard
     , handleTextInput
     , guardDisconnectedID
     ) where
+import Dodge.WorldPos
 import Dodge.Button.Event
 import Dodge.Terminal
 import Dodge.InputFocus
@@ -134,7 +135,7 @@ spaceAction w = case _hudElement $ _hud w of
     DisplayInventory DisplayTerminal {} -> w & hud . hudElement .~ DisplayInventory NoSubInventory
     _ -> w & hud . hudElement .~ DisplayInventory NoSubInventory
   where
-    theLoc = fst (_seenLocations w IM.! _selLocation w) w
+    theLoc = doWorldPos (fst (_seenLocations w IM.! _selLocation w)) w
 --    updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail
 
 pauseGame :: World -> World

src/Dodge/HeldUse.hs

@@ -238,7 +238,7 @@ useMod hm = case hm of
     BurstRifleMod ->
         [ ammoHammerCheck
         , useTimeCheck
-        , sideEffectOnFrame 7 (torqueSideEffect 0.2)
+        , 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
         , withSoundStart tap3S

src/Dodge/Initialisation.hs

@@ -6,8 +6,6 @@ import Dodge.Default.World
 --import Dodge.Save
 import Dodge.Data
 import Dodge.Creature
---import Dodge.Story
-import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
 import Geometry.Data
 
@@ -30,8 +28,8 @@ initialWorld = defaultWorld
     , _mousePos = V2 0 0
     , _yourID = 0
     , _sideEffects = return
-    , _worldEvents = soundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing 
+    , _worldEvents = SoundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing 
-        . foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-4..5] , y <- [-5,-4..5]]
+        : [MakeStartCloudAt (V3 x y 5) | x <- [-5,-4..5] , y <- [-5,-4..5]]
     , _pressPlates = IM.empty
     , _buttons = IM.empty
     , _toPlaySounds = M.empty

src/Dodge/Item/Weapon/TriggerType.hs

@@ -94,7 +94,7 @@ type ChainEffect
     -> World
 
 lockInvFor :: Int -> ChainEffect
-lockInvFor i f it cr = f it cr . (delayedEvents .:~ (i, unlockInv (_crID cr)))
+lockInvFor i f it cr = f it cr . (delayedEvents .:~ (i, UnlockInv (_crID cr)))
     . lockInv (_crID cr)
 
 trigDoAlso'
@@ -543,14 +543,10 @@ spreadLoaded eff item cr w = foldr f w dirs
     numBulLoaded = _laLoaded $ _itConsumption item
 
 sideEffectOnFrame :: Int 
-    -> (Item -> Creature -> World -> World)
+    -> (Item -> Creature -> WorldEffect)
     -> ChainEffect
 sideEffectOnFrame i sf f it cr w = f it cr w
-    & delayedEvents .:~ (i, f')
+    & delayedEvents .:~ (i, sf it cr)
-  where
-    f' w' = fromMaybe w' $ do
-        cr' <- w' ^? creatures . ix (_crID cr)
-        return $ sf it cr' w'
 
 torqueSideEffect :: Float -> Item -> Creature -> World -> World
 torqueSideEffect torque _ cr w
@@ -562,12 +558,13 @@ torqueSideEffect torque _ cr w
 
 -- pump the updated creature into the chain in later frames
 repeatOnFrames :: [Int] -> ChainEffect
-repeatOnFrames is f it cr w = f it cr w
+repeatOnFrames = const id
-    & delayedEvents .++~ (is <&> (, f'))
+--repeatOnFrames is f it cr w = f it cr w
-  where
+--    & delayedEvents .++~ (is <&> (, f'))
-    f' w' = fromMaybe w' $ do
+--  where
-        cr' <- w' ^? creatures . ix (_crID cr)
+--    f' w' = fromMaybe w' $ do
-        return $ f it cr' w'
+--        cr' <- w' ^? creatures . ix (_crID cr)
+--        return $ f it cr' w'
 
 duplicateLoaded :: ChainEffect
 duplicateLoaded eff it cr w = foldr f w [1..numBul]

src/Dodge/Render/HUD.hs

@@ -2,6 +2,7 @@
 module Dodge.Render.HUD
     ( hudDrawings
     ) where
+import Dodge.WorldPos
 import Dodge.Data
 import Dodge.Tweak.Show
 import Dodge.Item.Display
@@ -310,7 +311,7 @@ drawCarte cfig w = pictures $
   where
     iPos = _selLocation w
     locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
-    locPoss = map (cartePosToScreen cfig w . ($ w) . fst) . IM.elems . _seenLocations $ w
+    locPoss = map (cartePosToScreen cfig w . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations $ w
     locTexts = map fst locs
 
 displayListEndCoords :: Configuration -> [String] -> [Point2]

src/Dodge/Update.hs

@@ -4,6 +4,7 @@ Module      : Dodge.Update
 Description : Simulation update
 -}
 module Dodge.Update ( updateUniverse ) where
+import Dodge.WorldEffect
 import Dodge.Data
 import Dodge.Beam
 import Dodge.LightSource.Update
@@ -47,7 +48,7 @@ import SDL
 updateUniverse :: Universe -> Universe
 updateUniverse u = case _menuLayers u of
     (WaitScreen s i : _) 
-        | i < 1     -> u & over uvWorld (dbArg _worldEvents)
+        | i < 1     -> u & over uvWorld doWorldEvents
         | otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
     (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
         ( updateParticles 
@@ -75,9 +76,8 @@ functionalUpdate w = over uvWorld checkEndGame
     . over uvWorld (simpleCrSprings                         )        
     . over uvWorld (zoneCreatures                           )
     . over uvWorld (updateIMl _doors _drMech                )
+    . over uvWorld doWorldEvents
     . over uvWorld (updateDelayedEvents                     )
-    . over uvWorld (resetWorldEvents                        )
-    . over uvWorld (dbArg _worldEvents                      )
     . over uvWorld (updateIMl _modifications _mdUpdate      )
     . over uvWorld (updateSparks                            )
     . over uvWorld (updateRadarSweeps                       )
@@ -110,6 +110,9 @@ functionalUpdate w = over uvWorld checkEndGame
     . updateBounds  -- where should this go? next to update camera?
     $ over uvWorld updateCloseObjects w
 
+doWorldEvents :: World -> World
+doWorldEvents w = foldr doWorldEffect (w & worldEvents .~ []) (_worldEvents w)
+
 zoneClouds :: World -> World
 zoneClouds w = w 
     & clZoning . znObjects .~ mempty
@@ -194,10 +197,6 @@ updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
 updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
 updateIMl' fim fup w = foldl' (flip fup) w (fim w)
 
--- | Note the explict use of record syntax. Using lens created a space leak.
-resetWorldEvents :: World -> World
-resetWorldEvents w = w {_worldEvents = id}
-
 updateCreatureGroups :: World -> World
 updateCreatureGroups w = w & creatureGroups %~ 
     IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp)
@@ -457,5 +456,5 @@ updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w)
     in neww & delayedEvents .~ catMaybes newde
   where
     f w' (i,g) 
-        | i <= 0    = (g w', Nothing)
+        | i <= 0    = (w' & worldEvents .:~ g, Nothing)
         | otherwise = (w', Just (i-1,g))

src/Dodge/WorldEffect.hs

@@ -1,7 +1,11 @@
 module Dodge.WorldEffect where
+import Dodge.SoundLogic
+import Dodge.WorldEvent.Cloud
 import Dodge.Data
+import Dodge.Inventory.Lock
 import Dodge.Placement.Instance.Terminal
 
+import System.Random
 import Control.Lens
 
 doWorldEffect :: WorldEffect -> World -> World
@@ -11,3 +15,14 @@ doWorldEffect we = case we of
     SetLSCol col lsid -> lightSources . ix lsid . lsParam . lsCol .~ col
     AccessTerminal mtmid -> accessTerminal mtmid
     WorldEffects wes -> \w -> foldr doWorldEffect 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
+
+torqueCr :: Float -> Int -> World -> World
+torqueCr x cid w
+    | cid == 0  = set randGen g $ over cameraRot (+rot) w
+    | otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) w
+  where 
+    (rot, g) = randomR (-x,x) $ _randGen w

src/Dodge/WorldPos.hs

@@ -0,0 +1,9 @@
+module Dodge.WorldPos where
+import Dodge.Data
+import Dodge.Base.You
+import Geometry
+
+doWorldPos :: WdP2 -> World -> Point2
+doWorldPos wp2 = case wp2 of
+    WdP2Const p -> const p
+    WdYouPos -> _crPos . you

src/Dodge/Zoning.hs

@@ -0,0 +1,2 @@
+module Dodge.Zoning where
+

src/Dodge/Zoning/Base.hs

@@ -0,0 +1,20 @@
+module Dodge.Zoning.Base where
+
+--zoneOfCirc :: Float -> Point2 -> Float -> [Int2]
+--zoneOfCirc zsize p r = zoneOfRect' x (p +.+ V2 r r) (p -.- V2 r r)
+--
+--zoneOfRect' :: Float -> Point2 -> Point2 -> [Int2]
+--zoneOfRect' s sp ep = [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
+--  where
+--    V2 sx sy = zoneOfPoint s sp
+--    V2 ex ey = zoneOfPoint s ep
+--
+--zoneOfPoint :: Float -> Point2 -> Int2
+--{-# INLINE zoneOfPoint #-}
+--zoneOfPoint s = fmap (divTo s)
+--
+--zoneExtract :: Monoid m => Int2 -> IM.IntMap (IM.IntMap m) -> m
+--zoneExtract (x,y) = ix x . ix y
+--
+--zonesExtract :: Monoid m => [Int2] -> IM.IntMap (IM.IntMap m) -> m
+--zonesExtract xs = fold (flip zoneExtract xs)

src/Dodge/Zoning/Creature.hs

@@ -0,0 +1,7 @@
+module Dodge.Zoning.Creature where
+
+--zoneOfCr :: Creature -> [Int2]
+--zoneOfCr cr = zoneOfCirc crZoneSize (_crPos cr) (_crRad cr)
+
+--crsInZones :: [Int2] -> CrZoning -> IS.IntSet
+--crsInZones is