Add frame clock

appDodge/Main.hs

@@ -63,6 +63,7 @@ doSideEffects w = do
     void $ doDrawing (_renderData preData) w
     playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
     newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_sounds w)
+    w' <- _sideEffects w w
     
     endTicks <- SDL.ticks
     let lastFrameTicks = _frameTimer preData
@@ -73,9 +74,9 @@ doSideEffects w = do
                     . translate (-0.5) (-0.8) . scale 0.0005 0.0005
                     . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
                 )
-    newpdata <- foldr (=<<) (return (preData & frameTimer .~ endTicks)) (_doneSideEffects w)
+    return $ w' & preloadData . frameTimer .~ endTicks
-    return $ w & preloadData .~ newpdata
         & playingSounds .~ newPlayingSounds
+        & sideEffects .~ return
 
 doPreload :: IO PreloadData
 doPreload = do

src/Dodge/Clock.hs

@@ -0,0 +1,14 @@
+module Dodge.Clock
+    ( clockCycle
+    )
+    where
+import Dodge.Data
+
+import qualified Data.Vector as V
+clockCycle :: Int -> V.Vector a -> World -> a
+{-# INLINABLE clockCycle #-}
+clockCycle tPeriod xs w = xs V.! i 
+  where
+    l = V.length xs
+    t = _frameClock w `mod` (l * tPeriod)
+    i = t `div` tPeriod

src/Dodge/Config/Update.hs

@@ -14,20 +14,25 @@ import Data.Aeson (encodeFile)
 {- |
 Write the current world configuration to disk as a json file.
  -}
-saveConfig :: Configuration -> PreloadData -> IO PreloadData
+saveConfig :: Configuration -> (a -> IO a) -> a -> IO a
-saveConfig cfig d = do
+saveConfig cfig f x = do
     putStrLn "Saving config to data/dodge.config.json"
     encodeFile "data/dodge.config.json" cfig
-    return d
+    f x
 
 {- |
 Apply the volume settings from the world configuration to the running game.
  -}
-setVol :: Configuration -> PreloadData -> IO PreloadData
+setVol :: Configuration -> IO ()
-setVol cfig d = do
+setVol cfig = do
     setSoundVolume ( _volume_master cfig * _volume_sound cfig)
     setMusicVolume ( _volume_master cfig * _volume_music cfig)
-    return d
+
+setVol' :: Configuration -> (a -> IO a) -> a -> IO a
+setVol' cfig f a = do
+    setVol cfig 
+    f a
+
 
 {- |
 Apply /all/ of the values in the world configuration to the running game.
@@ -37,7 +42,8 @@ applyWorldConfig
     -> PreloadData
     -> IO PreloadData
 applyWorldConfig cfig pdata = do
-    setVol cfig pdata >>= pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y
+    setVol cfig 
+    pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y pdata
   where
     x = round $ _windowX cfig
     y = round $ _windowY cfig

src/Dodge/Creature/Action.hs

@@ -69,6 +69,16 @@ performPathTo cr w p
     cpos = _crPos cr
     jit = _mvTurnJit $ _crMvType cr
 
+performTurnToA :: Creature -> Point2 -> OutAction
+performTurnToA cr p
+    | angleVV cdirv dirv < 0.1 = ([], Nothing)
+    | otherwise = ([MvTurnToward p,RandomTurn jit] , Just (TurnToA p))
+  where
+    cpos = _crPos cr
+    cdirv = unitVectorAtAngle (_crDir cr)
+    dirv = p -.- cpos
+    jit = _mvTurnJit $ _crMvType cr
+
 {- | Performing an action means that a creature has some impulses for a frame, and
  updates or deletes the action itself. 
 -- doAction -}
@@ -108,13 +118,14 @@ performAction cr w ac = case ac of
         in (concat imps, Just . DoActions $ catMaybes newAcs)
     StartSentinelPost -> ([AddGoal $ SentinelAt (_crPos cr) (_crDir cr)], Nothing)
     PathTo p -> performPathTo cr w p
-    LeadTarget p -> case cr ^? crTarget . _Just of
+    TurnToA p -> performTurnToA cr p
+    LeadTarget p -> case cr ^? crIntention . targetCr . _Just of
         Just tcr -> ([TurnTo (_crPos tcr +.+ rotateV (_crDir tcr) p)], Nothing)
         _        -> ([], Nothing)
-    UseTarget f -> performAction cr w $ f $ cr ^? crTarget . _Just
+    UseTarget f -> performAction cr w $ f $ cr ^? crIntention . targetCr . _Just
     UseSelf f   -> performAction cr w $ f cr
     UseAheadPos f -> performAction cr w (f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr)))
-    UseMvTargetPos f -> performAction cr w $ f $ _crMvTarget cr
+    UseMvTargetPos f -> performAction cr w $ f $ _mvToPoint $ _crIntention cr
     ArbitraryAction f -> performAction cr w (f cr w)
     DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of
         (imp, Just nxtac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp nxtac)

src/Dodge/Creature/ArmourChase.hs

@@ -26,7 +26,7 @@ armourChaseCrit = defaultCreature
         doStrategyActionsR >=>
         performActionsR >=>
         targetYouWhenCognizantR  >=>
-        setTargetMv (pure . _crTarget) >=> -- should be able to remove this?
+        setTargetMv (pure . _targetCr . _crIntention) >=> -- should be able to remove this?
         flockACCR >=>
         perceptionUpdate [0] >=>
         goToTarget >=>

src/Dodge/Creature/Boid.hs

@@ -171,7 +171,7 @@ swarmUsingCenter
     -> World
     -> Creature
     -> Creature
-swarmUsingCenter updT upd w cr = case _crTarget cr of
+swarmUsingCenter updT upd w cr = case _targetCr $ _crIntention cr of
     Nothing -> upd cenp cr
     Just tcr -> updT tcr cenp cr
   where
@@ -184,7 +184,7 @@ flockChaseTarget
     -> World
     -> Creature
     -> Creature
-flockChaseTarget updT upd w cr = case _crTarget cr of
+flockChaseTarget updT upd w cr = case _targetCr $ _crIntention cr of
     Nothing -> upd crs cr
     Just tcr -> updT tcr crs cr
   where
@@ -210,7 +210,7 @@ flockToPointUsing
     -> (Point2 -> Creature -> Creature -> [Impulse])
     -> Creature
     -> Reader World Creature
-flockToPointUsing pf mvf cr = reader $ \w -> case _crTarget cr of
+flockToPointUsing pf mvf cr = reader $ \w -> case _targetCr $ _crIntention cr of
     Nothing -> cr
     Just tcr -> cr & crActionPlan . crImpulse .~ mvf ptarg cr tcr
       where

src/Dodge/Creature/ChaseCrit.hs

@@ -38,6 +38,7 @@ chaseCrit = defaultCreature
         doStrategyActionsR >=>
         performActionsR >=>
         overrideMeleeCloseTargetR >=>
+        setViewPos >=>
         setMvPos >=>
 --        setTargetMv (pure . _crTarget) >=>
         goToTarget >=>

src/Dodge/Creature/Impulse.hs

@@ -62,10 +62,10 @@ followImpulse cr w imp = case imp of
     AddGoal gl -> (id, cr & crActionPlan . crGoal %~ (gl :) )
     ArbitraryImpulseFunction f -> (id, f w cr)
     ArbitraryImpulse f -> followImpulse cr w (f cr w) 
-    ImpulseUseTargetCID f -> case cr ^? crTarget . _Just of
+    ImpulseUseTargetCID f -> case cr ^? crIntention . targetCr . _Just of
         Just tcr -> followImpulse cr w (f $ _crID tcr)
         _ -> (id,cr)
-    ImpulseUseTarget f -> case cr ^? crTarget . _Just of
+    ImpulseUseTarget f -> case cr ^? crIntention . targetCr . _Just of
         Just tcr -> followImpulse cr w (f tcr)
         _ -> (id,cr)
     ImpulseUseAheadPos f -> followImpulse cr w (f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr)))

src/Dodge/Creature/Intention.hs

@@ -0,0 +1,2 @@
+module Dodge.Creature.Intention
+    where

src/Dodge/Creature/Memory/Data.hs

@@ -6,7 +6,7 @@ import Geometry.Data
 
 import Control.Lens
 
-data MemoryState = MemoryState
+newtype MemoryState = MemoryState
     { _soundsToInvestigate :: [Point2]
     }
 

src/Dodge/Creature/Perception.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Creature.Perception
     ( perceptionUpdate
     , newSounds
@@ -96,7 +96,7 @@ newSounds = mapMaybe f . M.elems . _playingSounds
 
 rememberSounds :: Creature -> Reader World Creature
 rememberSounds cr = do
-    sList <- fmap newSounds ask
+    sList <- asks newSounds
     return $ cr & crMemory . soundsToInvestigate .~ map fst (filter (soundIsClose cr) sList)
 --    return $ cr & crMemory . soundsToInvestigate .~ [V2 0 0]
 

src/Dodge/Creature/Perception/Data.hs

@@ -35,7 +35,7 @@ data Vision = Eyes
     { _viFOV  :: Float -> Float
     , _viDist :: Float -> Float
     }
-data Audition = Ears
+newtype Audition = Ears
     { _auDist :: Float -> Float
     }
 

src/Dodge/Creature/Picture.hs

@@ -10,14 +10,15 @@ module Dodge.Creature.Picture
 import Dodge.Data
 --import Dodge.Base
 --import Dodge.Creature.Stance.Data
---import Dodge.Creature.Perception.Data
+import Dodge.Creature.Perception.Data
 import Dodge.Creature.State.Data
 import Dodge.Creature.Stance.Data
-import Dodge.Creature.Memory.Data
+--import Dodge.Creature.Memory.Data
 import Dodge.Creature.Test
 --import Dodge.Creature.AlertLevel.Data
 --import Dodge.Picture.Layer
 import Dodge.Item.Data
+import Dodge.Clock
 import Picture
 import Geometry
 --import Geometry.Vector3D
@@ -25,6 +26,7 @@ import Geometry
 import Control.Lens
 import Data.List
 import qualified Data.IntMap.Strict as IM
+import qualified Data.Vector as V
 basicCrPict 
     :: Color    -- ^ Creature color
     -> Creature 
@@ -56,26 +58,38 @@ creatureDisplayText w cr
     . color white 
     . rotate a 
     . scale theScale theScale 
-    $ text $ creatureDisplayString cr
+    . text 
+    $ clockCycle 50 (V.fromList [crDisplayAwake, crDisplayAlert]) w cr
   where
     campos = _cameraViewFrom w
-    theScale = 0.2 / _cameraZoom w
+    theScale = 0.15 / _cameraZoom w
     cpos = _crPos cr
     v = cpos -.- campos
     a = argV v - 0.5 * pi
     (V2 x y) = campos +.+ v +.+ _crRad cr *.* normalizeV v
 
-creatureDisplayString :: Creature -> String
+
-creatureDisplayString cr = show . take 1 . _soundsToInvestigate $ _crMemory cr
+crDisplayAlert :: Creature -> String
---    | isAsleep = "Z"
+crDisplayAlert cr
---    | isSuspicious = "?"
+    | isSuspicious = "?"
---    | otherwise = ""
+    | isCognizant  = "!"
---  where
+    | otherwise    = "."
---    isAsleep = _crAwakeLevel (_crPerception cr) == Asleep
+  where
---    imAwarenesses = _crAwarenessLevel (_crPerception cr)
+    imAwarenesses = _crAwarenessLevel (_crPerception cr)
---    isSuspicious = any f imAwarenesses && not (null imAwarenesses)
+    isSuspicious = any f imAwarenesses && not (null imAwarenesses)
---    f (Suspicious _) = True
+    isCognizant  = any g imAwarenesses && not (null imAwarenesses)
---    f _ = False
+    f (Suspicious _) = True
+    f _ = False
+    g (Cognizant _) = True
+    g _ = False
+
+crDisplayAwake :: Creature -> String
+crDisplayAwake cr = case _crAwakeLevel (_crPerception cr) of
+    Comatose    -> "-"
+    Asleep      -> "Z"
+    Lethargic   -> "L"
+    Vigilant    -> "V"
+    Overstrung  -> "O"
 damageMod :: Creature -> Picture -> Picture
 damageMod cr pic = piercingMod $ bluntScale pic
   where

src/Dodge/Creature/ReaderUpdate.hs

@@ -10,6 +10,7 @@ module Dodge.Creature.ReaderUpdate
     , goToTarget
     , flockACCR
     , setMvPos
+    , setViewPos
     )
     where
 import Dodge.Data
@@ -19,6 +20,7 @@ import Dodge.Creature.Test
 import Dodge.Creature.Volition
 import Dodge.Creature.Perception.Data
 import Dodge.Base
+import Dodge.Base.Collide
 import Geometry
 import FoldableHelp
 
@@ -31,7 +33,7 @@ import Data.Maybe
 overrideMeleeCloseTargetR 
     :: Creature 
     -> Reader World Creature
-overrideMeleeCloseTargetR cr = return $ maybe cr (tryMeleeAttack cr) (_crTarget cr)
+overrideMeleeCloseTargetR cr = return $ maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr)
 
 tryMeleeAttack :: Creature -> Creature -> Creature
 tryMeleeAttack cr tcr
@@ -45,11 +47,17 @@ tryMeleeAttack cr tcr
     cpos = _crPos cr
 
 setMvPos :: Creature -> Reader World Creature
-setMvPos cr = pure $ cr & crMvTarget .~ mpos
+setMvPos cr = pure $ cr & crIntention . mvToPoint .~ mpos
   where
-    mpos = (_crPos <$> _crTarget cr) 
+    int = _crIntention cr
-                <|> _crMvTarget cr 
+    mpos = (_crPos <$> _targetCr int) 
-                <|> listToMaybe (_soundsToInvestigate $ _crMemory cr)
+        <|> _mvToPoint int 
+--        <|> listToMaybe (_soundsToInvestigate $ _crMemory cr)
+
+setViewPos :: Creature -> Reader World Creature
+setViewPos cr = pure $ cr & crIntention . viewPoint %~ (<|> mpos)
+  where
+    mpos = listToMaybe (_soundsToInvestigate $ _crMemory cr)
 
 setTargetMv
     :: (Creature -> Reader World (Maybe Creature))    -- ^ Function for determining target
@@ -59,10 +67,10 @@ setTargetMv targFunc cr = do
     targ <- targFunc cr
     case targ of
         Nothing -> pure cr
-        Just crTarg -> pure $ cr & crMvTarget .~ Just (_crPos crTarg)
+        Just crTarg -> pure $ cr & crIntention . mvToPoint ?~ _crPos crTarg
 flockACCR :: Creature -> Reader World Creature
 flockACCR cr = do
-    case cr ^? crTarget . _Just of
+    case cr ^? crIntention . targetCr . _Just of
         Nothing -> pure cr
         Just tcr -> do
             w <- ask
@@ -81,13 +89,29 @@ flockACCR cr = do
                         horShift = if isLHS tpos cpos (_crPos acr)
                             then r *.* horDir
                             else negate r *.* horDir
-                    pure $ cr & crMvTarget .~ Just (tpos +.+ horShift)
+                    pure $ cr & crIntention . mvToPoint ?~ tpos +.+ horShift
 
 goToTarget :: Creature -> Reader World Creature
 goToTarget cr = do
-    case cr ^? crMvTarget . _Just of
+    case cr ^? crIntention . mvToPoint . _Just of
         Just p -> pure $ cr & crActionPlan . crAction .~ [PathTo p]
-        _ -> pure cr
+        _ -> viewTarget cr
+
+viewTarget :: Creature -> Reader World Creature
+viewTarget cr = do
+    w <- ask
+    case cr ^? crIntention . viewPoint . _Just of
+        Just p | hasLOSIndirect p (_crPos cr) w -> pure $ cr'
+                    & crActionPlan . crAction %~ replaceNullWith (TurnToA p)
+                    & crIntention . viewPoint .~ Nothing
+               | otherwise -> pure $ cr' & crActionPlan . crAction %~ replaceNullWith (PathTo p)
+        Nothing -> pure $ cr & crPerception . crAwakeLevel .~ Lethargic
+  where
+    cr' = cr & crPerception . crAwakeLevel .~ Vigilant
+
+replaceNullWith :: a -> [a] -> [a]
+replaceNullWith x [] = [x]
+replaceNullWith _ xs = xs
     
 doStrategyActionsR
     :: Creature
@@ -138,5 +162,5 @@ listGuard (_,z) _ = z
 
 targetYouWhenCognizantR :: Creature -> Reader World Creature
 targetYouWhenCognizantR cr = reader $ \w -> case cr ^? crPerception . crAwarenessLevel . ix 0 of
-    Just (Cognizant _)  -> cr {_crTarget = Just $! _creatures w IM.! 0}
+    Just (Cognizant _)  -> cr & crIntention . targetCr ?~ _creatures w IM.! 0
-    _                   -> cr & crTarget .~ Nothing
+    _                   -> cr & crIntention . targetCr .~ Nothing

src/Dodge/Creature/SentinelAI.hs

@@ -40,7 +40,7 @@ sentinelAI = sentinelExtraWatchUpdate
     >=> reloadOverrideR
   where
     advanceShoot = DoImpulses [UseItem, MoveForward 3]
-    tcid cr = _crID <$> _crTarget cr
+    tcid cr = _crID <$> _targetCr (_crIntention cr)
     lostest (w,cr) = maybe False (\cid -> canSee (_crID cr) cid w) (tcid cr)
 
 sentinelFireType

src/Dodge/Creature/SetTarget.hs

@@ -14,6 +14,6 @@ targetYouWhenCognizant
     -> Creature
     -> Creature
 targetYouWhenCognizant w cr = case cr ^? crPerception . crAwarenessLevel . ix 0 of
-    Just (Cognizant _)  -> cr & crTarget ?~ _creatures w IM.! 0
+    Just (Cognizant _)  -> cr & crIntention . targetCr ?~ _creatures w IM.! 0
-    _                   -> cr & crTarget .~ Nothing
+    _                   -> cr & crIntention . targetCr .~ Nothing
 

src/Dodge/Creature/Test.hs

@@ -56,28 +56,28 @@ crIsAimingR :: Creature -> Reader World Bool
 crIsAimingR cr = return $ _posture (_crStance cr) == Aiming
 
 crHasTarget :: (World,Creature) -> Bool
-crHasTarget (_,cr) = isJust $ cr ^? crTarget . _Just
+crHasTarget (_,cr) = isJust $ cr ^? crIntention . targetCr . _Just
 
 crHasTargetR :: Creature -> Reader World Bool
-crHasTargetR cr = return $ isJust $ cr ^? crTarget . _Just
+crHasTargetR cr = return $ isJust $ cr ^? crIntention . targetCr . _Just
 
 crHasTargetLOS :: (World,Creature) -> Bool
-crHasTargetLOS (w,cr) = case cr ^? crTarget . _Just of
+crHasTargetLOS (w,cr) = case cr ^? crIntention . targetCr . _Just of
     Just i -> crCanSeeCr i (w,cr) 
     Nothing -> False
 
 crHasTargetLOSR :: Creature -> Reader World Bool
-crHasTargetLOSR cr = reader $ \w -> case cr ^? crTarget . _Just of
+crHasTargetLOSR cr = reader $ \w -> case cr ^? crIntention . targetCr . _Just of
     Just i -> crCanSeeCr i (w,cr) 
     Nothing -> False
 
 crSafeDistFromTarg :: Float -> (World,Creature) -> Bool
-crSafeDistFromTarg d (_,cr) = case cr ^? crTarget . _Just of
+crSafeDistFromTarg d (_,cr) = case cr ^? crIntention . targetCr . _Just of
     Just tcr -> dist (_crPos cr) (_crPos tcr) > d
     Nothing -> True
 
 crSafeDistFromTargR :: Float -> Creature -> Reader World Bool
-crSafeDistFromTargR d cr = return $ case cr ^? crTarget . _Just of
+crSafeDistFromTargR d cr = return $ case cr ^? crIntention . targetCr . _Just of
     Just tcr -> dist (_crPos cr) (_crPos tcr) > d
     Nothing -> True
 

src/Dodge/Data.hs

@@ -103,14 +103,14 @@ data World = World
     , _selLocation          :: Int
     , _keyConfig            :: KeyConfigSDL
     , _config               :: Configuration
-    , _sideEffects          :: [PreloadData -> IO PreloadData]
+    , _sideEffects          :: World -> IO World
-    , _doneSideEffects      :: [PreloadData -> IO PreloadData]
     , _debugFlags           :: DebugFlags
     , _inventoryMode        :: InventoryMode
     , _lClickHammer         :: HammerPosition
     , _radDistortion        :: [(Point2,Point2,Point2,Float)]
     , _gameRooms            :: [GameRoom]
     , _preloadData          :: PreloadData
+    , _frameClock           :: Int
     }
 data OptionScreenFlag = NormalOptions | GameOverOptions
 data ScreenLayer
@@ -221,10 +221,15 @@ data Creature = Creature
     , _crMemory         :: MemoryState
     , _crFaction        :: Faction
     , _crGroup          :: CrGroup
-    , _crTarget         :: Maybe Creature
+    , _crIntention      :: Intention
-    , _crMvTarget       :: Maybe Point2
     , _crMvType         :: CrMvType
     }
+data Intention = Intention
+    { _targetCr     :: Maybe Creature
+    , _mvToPoint    :: Maybe Point2
+    , _viewPoint    :: Maybe Point2
+    }
+
 data CrMvType 
     = NoMvType
     | ChaseMvType
@@ -580,7 +585,7 @@ data Impulse
     | DropItem
 --    | PickupNearby Int
 --    | UseWorldObject Int
-    | Bark -- placeholder for various communication types
+--    | Bark -- placeholder for various communication types
 --    | UseIntrinsicAbility
     | Melee Int
     | ChangePosture Posture
@@ -612,6 +617,9 @@ data Action
     | PathTo 
         {_pathToPoint   :: Point2
         }
+    | TurnToA
+        {_turnToAPoint :: Point2
+        }
 --    | PickupItem 
 --        {_pickupItemID :: Int
 --        }
@@ -737,6 +745,7 @@ makeLenses ''Impulse
 makeLenses ''Action
 makeLenses ''CrGroupParams
 makeLenses ''CrMvType 
+makeLenses ''Intention
 numColor :: Int -> Color
 numColor 0  = toV4 (1,0,0,1) 
 numColor 1  = toV4 (0,1,0,1) 

src/Dodge/Default.hs

@@ -54,8 +54,7 @@ defaultCreature = Creature
     , _crMemory     = defaultCreatureMemory
     , _crMeleeCooldown = 0
     , _crFaction = NoFaction
-    , _crTarget  = Nothing
+    , _crIntention = defaultIntention
-    , _crMvTarget= Nothing
     , _crGroup   = LoneWolf
     , _crMvType  = defaultAimMvType
     }
@@ -86,6 +85,12 @@ defaultAudition :: Audition
 defaultAudition = Ears
     { _auDist = \x -> x * x
     }
+defaultIntention :: Intention
+defaultIntention = Intention
+    { _targetCr     = Nothing
+    , _mvToPoint    = Nothing
+    , _viewPoint    = Nothing
+    }
 defaultChaseMvType :: CrMvType
 defaultChaseMvType = ChaseMvType
     { _mvSpeed = 3

src/Dodge/Default/World.hs

@@ -76,8 +76,7 @@ defaultWorld = World
     , _selLocation = 0
     , _keyConfig = defaultKeyConfigSDL
     , _config       = defaultConfig
-    , _sideEffects          = []
+    , _sideEffects  = return
-    , _doneSideEffects      = []
     , _debugFlags = defaultDebugFlags
     , _inventoryMode = TopInventory
     , _lClickHammer = HammerUp
@@ -86,6 +85,7 @@ defaultWorld = World
     , _radDistortion = []
     , _gameRooms = []
     , _preloadData = DummyPdata -- hack TODO remove this
+    , _frameClock = 0
     }
 defaultDebugFlags :: DebugFlags
 defaultDebugFlags = DebugFlags

src/Dodge/Event.hs

@@ -65,9 +65,13 @@ handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
 handleResizeEvent sev w = Just 
     . set (config . windowX) (fromIntegral x)
     . set (config . windowY) (fromIntegral y)
-    $ over sideEffects (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : )
+    $ over sideEffects up
     w
   where 
+    up :: (World -> IO World) -> World -> IO World
+    up f w' = do
+        pdata <- pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y (_preloadData w')
+        f $ w' & preloadData .~ pdata
     x = fromIntegral x'
     y = fromIntegral y'
     V2 x' y' = windowSizeChangedEventSize sev

src/Dodge/Initialisation.hs

@@ -9,7 +9,7 @@ import Dodge.Story
 import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms
-import Dodge.Creature.Perception
+--import Dodge.Creature.Perception
 import Geometry.Data
 --import Dodge.GameRoom
 --import Geometry
@@ -53,8 +53,8 @@ initialWorld = defaultWorld
     , _worldState = M.empty
     }
 testStringInit :: World -> [String]
---testStringInit _ = []
+testStringInit _ = []
-testStringInit w = [show . length $ newSounds w]
+--testStringInit w = [show . length $ newSounds w]
 --testStringInit w = (show . _crPos $ _creatures w IM.! 0) 
 --    : (map show . _grBound . last $ sortOn _grName grs) 
 --    ++ closeRooms

src/Dodge/Menu.hs

@@ -53,7 +53,8 @@ soundMenuOptions =
   where
     dec x = max 0 (x - 0.1)
     inc x = min 1 (x + 0.1)
-    sw w = w & sideEffects %~ (setVol (_config w) : )
+    --sw w = w & sideEffects %~ (setVol (_config w) : )
+    sw w = w & sideEffects %~ setVol' (_config w)
     master g    = Just . (config . volume_master %~ g)
     soundEffs g = Just . (config . volume_sound %~ g)
     music g     = Just . (config . volume_music %~ g)
@@ -70,7 +71,7 @@ popScreen :: World -> Maybe World
 popScreen = Just . (menuLayers %~ tail)
 
 writeConfig :: World -> World
-writeConfig w = w & sideEffects %~ (saveConfig (_config w) :)
+writeConfig w = w & sideEffects %~ saveConfig (_config w)
 
 graphicsMenu :: ScreenLayer
 graphicsMenu = OptionScreen
@@ -138,11 +139,14 @@ charToScode :: Char -> Scancode
 charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
 
 updateFramebufferSize :: World -> World
-updateFramebufferSize w = w & sideEffects 
+updateFramebufferSize w = w & sideEffects %~ up
-    %~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : )
   where 
     (x,y) = (round $ getWindowX w, round $ getWindowY w)
     divRes = w ^. config . resolution_factor
+    up :: (World -> IO World) -> World -> IO World
+    up f w' = do
+        pdata <- pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y (_preloadData w')
+        f $ w' & preloadData .~ pdata
     
 levelMenu :: Int -> ScreenLayer
 levelMenu x = OptionScreen

src/Dodge/Room/Path.hs

@@ -22,9 +22,7 @@ createPathGrid rm = rm
     { _rmPath = linksAndPath (_rmLinks rm) filterGrid }
   where
     filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid
-    grid = case shiftedGrid <$> minx <*> maxx <*> miny <*> maxy of
+    grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy
-        Nothing -> []
-        Just xs -> xs
     outerWalls = foldr cutPoly [] $ _rmPolys rm
     outerPoints = map fst outerWalls
     (minx, maxx, miny, maxy) = L.fold theFold outerPoints

src/Dodge/Update.hs

@@ -35,12 +35,8 @@ import System.Random
 --import Data.Bifunctor
 
 update :: World -> World
-update = functionalUpdate . pushSideEffects
+update = (frameClock +~ 1) . functionalUpdate
 
-pushSideEffects :: World -> World
-pushSideEffects w = w 
-    & sideEffects .~ []
-    & doneSideEffects .~ _sideEffects w
 {- | 
  The update step.
 For most menus the only way to change the world is using event handling.  -}

src/Sound/Data.hs

@@ -3,7 +3,7 @@ module Sound.Data
     where
 import qualified SDL.Mixer as Mix
 import qualified Data.IntMap.Strict as IM
-import qualified Data.Map.Strict as M
+--import qualified Data.Map.Strict as M
 import Control.Lens
 import Geometry.Data
 import Data.Word (Word8)
@@ -16,7 +16,7 @@ data SoundStatus
     | ToStart
   deriving (Eq,Ord,Show)
 
-data SoundData = SoundData
+newtype SoundData = SoundData
     {_loadedChunks :: IM.IntMap Mix.Chunk
     }
 data Sound = Sound 

src/Tile.hs

@@ -36,7 +36,7 @@ makeTileFromPoly poly z = Tile
     { _tilePoly = poly
     , _tileZero = c
     --, _tileXY   = c +.+ xdir +.+ vNormal xdir
-    , _tileX  = c +.+ (normalizeV $ (poly !! 1) -.- c)
+    , _tileX  = c +.+ normalizeV ((poly !! 1) -.- c)
     , _tileZ = z
     }
   where