Move debug flags to config, various perf improvements

2021-09-24 13:25:24 +01:00
parent 899cf6ef81
commit 7da1a8bc45
17 changed files with 112 additions and 265 deletions
@@ -11,7 +11,6 @@ import Dodge.Config.KeyConfig
 import Dodge.Config.Load
 import Dodge.Config.Update
 import Dodge.SoundLogic.LoadSound
-import Dodge.Debug.Flag.Data
 import Picture
 import Render
 import Preload.Render
@@ -33,11 +32,13 @@ import qualified SDL
 import qualified SDL.Mixer                 as Mix
 --import qualified Control.Monad.Parallel as MP
 import Control.Parallel
+import qualified Data.Map.Strict as M

 main :: IO ()
 main = do
    (sizex,sizey) <- loadConfig
-    setupLoop'
+    setupLoop
+        20
        (sizex,sizey)
        theCleanup
        (firstWorldLoad (sizex,sizey))
@@ -68,21 +69,22 @@ updateRenderSplit w = do
 doSideEffects :: World -> IO World
 doSideEffects w = do
    let preData = _preloadData w
-    newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_sounds w)
+    newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_toPlaySounds w)
    w' <- _sideEffects w w
    
    endTicks <- SDL.ticks
    let lastFrameTicks = _frameTimer preData
    
-    when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
-                (_pictureShaders $ _renderData preData)
-                (setDepth (-1)
-                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005
-                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
-                )
+    when (_debug_seconds_frame $ _config w) $ void $ renderFoldable
+        (_pictureShaders $ _renderData preData)
+        (setDepth (-1)
+            . translate (-0.5) (-0.8) . scale 0.0005 0.0005
+            . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
+        )
    return $ w' & preloadData . frameTimer .~ endTicks
        & playingSounds .~ newPlayingSounds
-        & sideEffects .~ return
+        & toPlaySounds  .~ M.empty
+        & sideEffects   .~ return

 doPreload :: IO PreloadData
 doPreload = do
@@ -281,13 +281,13 @@ collideCircWalls'' p1 p2 rad ws

 -- | Looks for first collision of a point with a list of lines.
 -- If found, gives point and normal of wall.
-collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2)
-collidePointLines p1 p2 ws 
-    = safeMinimumOn f
-    $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) 
-        . _wlLine') ws
-  where 
-    f (a,_) = magV (p1 -.- a)
+--collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2)
+--collidePointLines p1 p2 ws 
+--    = safeMinimumOn f
+--    $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) 
+--        . _wlLine') ws
+--  where 
+--    f (a,_) = magV (p1 -.- a)

 -- | Looks for first collision of a point with walls.
 -- If found, gives point and normal of wall.
@@ -1,23 +1,10 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StrictData #-}
-module Dodge.Config.Data (
-      Configuration (..)
-    , defaultConfig
-    , volume_master
-    , volume_sound
-    , volume_music
-    , wall_textured
-    , cloud_shadows
-    , resolution_factor
-    , windowX
-    , windowY
-    , rotate_to_wall
-    , show_sound
-    ) where
+module Dodge.Config.Data 
+    where
 import Data.Aeson
 import GHC.Generics
--import System.Directory
 import Control.Lens
 data Configuration = Configuration
    { _volume_master        :: Float
@@ -30,6 +17,9 @@ data Configuration = Configuration
    , _windowY              :: Float
    , _rotate_to_wall       :: Bool
    , _show_sound           :: Bool
+    , _debug_seconds_frame  :: Bool
+    , _debug_noclip         :: Bool
+    , _debug_cr_status      :: Bool
    }
  deriving (Generic, Show)
 makeLenses ''Configuration
@@ -51,4 +41,7 @@ defaultConfig = Configuration
    , _windowY              = 600
    , _rotate_to_wall       = True
    , _show_sound           = False
+    , _debug_seconds_frame  = True
+    , _debug_noclip         = False
+    , _debug_cr_status      = False
    }
@@ -9,6 +9,7 @@ module Dodge.Creature.Picture
    , picAtCrPosNoRot
    ) where
 import Dodge.Data
+import Dodge.Config.Data
 --import Dodge.Data.DamageType
 --import Dodge.Base
 --import Dodge.Creature.Stance.Data
@@ -65,6 +66,8 @@ basicCrShape col cr = tr $ mconcat

 creatureDisplayText :: World -> Creature -> Picture
 creatureDisplayText w cr 
+  | not (_debug_cr_status $ _config w) = []
+  | otherwise
    = setLayer 4 
    . setDepth 50 
    . translate x y 
@@ -13,7 +13,6 @@ import Dodge.Creature.State.Data
 import Dodge.Creature.Stance.Data
 import Dodge.Creature.Perception.Data
 import Dodge.Creature.Memory.Data
-import Dodge.Debug.Flag.Data
 import Dodge.Data.SoundOrigin
 import Dodge.Data.DamageType
 import Dodge.Zone.Data
@@ -71,7 +70,7 @@ data World = World
    , _worldEvents          :: World -> World
    , _pressPlates          :: IM.IntMap PressPlate
    , _buttons              :: IM.IntMap Button
-    , _sounds               :: M.Map SoundOrigin Sound
+    , _toPlaySounds         :: M.Map SoundOrigin Sound
    , _playingSounds        :: M.Map SoundOrigin Sound
    , _decorations          :: IM.IntMap Picture
    , _foregroundShape      :: Shape
@@ -97,7 +96,6 @@ data World = World
    , _keyConfig            :: KeyConfigSDL
    , _config               :: Configuration
    , _sideEffects          :: World -> IO World
-    , _debugFlags           :: DebugFlags
    , _inventoryMode        :: InventoryMode
    , _lClickHammer         :: HammerPosition
    , _radDistortion        :: [(Point2,Point2,Point2,Float)]
@@ -504,11 +502,6 @@ data Projectile
        }
 data Either3 a b c = E3x1 a | E3x2 b | E3x3 c

-data Wall' = Wall'
-    { _wlLine' :: (Point2,Point2)
-    , _wlColor' :: Color
-    }
-
 data Wall 
    = Wall 
        { _wlLine :: (Point2,Point2) 
@@ -1,10 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE StrictData #-}
-module Dodge.Debug.Flag.Data
-    where
-import Control.Lens
-data DebugFlags = DebugFlags
-    { _noClip :: Bool
-    , _displaySecondsPerFrame :: Bool
-    }
-makeLenses ''DebugFlags
@@ -1,10 +1,10 @@
 module Dodge.Debug.Terminal
    where
 import Dodge.Data
-import Dodge.Debug.Flag.Data
+import Dodge.Config.Data

 import Control.Lens

 applyTerminalString :: String -> World -> World
-applyTerminalString "NOCLIP" w = w & debugFlags . noClip %~ not
+applyTerminalString "NOCLIP" w = w & config . debug_noclip %~ not
 applyTerminalString _ w = w
@@ -3,7 +3,6 @@ module Dodge.Default.World
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone.Data
-import Dodge.Debug.Flag.Data
 import Dodge.Config.Data
 import Dodge.Config.KeyConfig
 import Dodge.Item.Data
@@ -48,7 +47,7 @@ defaultWorld = World
    , _worldEvents = id
    , _pressPlates = IM.empty
    , _buttons = IM.empty
-    , _sounds = M.empty
+    , _toPlaySounds = M.empty
    , _playingSounds = M.empty
    , _corpses = Zone IM.empty
    , _decorations = IM.empty
@@ -76,7 +75,6 @@ defaultWorld = World
    , _keyConfig = defaultKeyConfigSDL
    , _config       = defaultConfig
    , _sideEffects  = return
-    , _debugFlags = defaultDebugFlags
    , _inventoryMode = TopInventory
    , _lClickHammer = HammerUp
    , _foregroundShape = mempty
@@ -86,17 +84,11 @@ defaultWorld = World
    , _frameClock = 0
    , _worldBounds = defaultBounds
    }
-defaultDebugFlags :: DebugFlags
-defaultDebugFlags = DebugFlags
-    { _noClip = False
-    , _displaySecondsPerFrame = True
-    }
 youLight :: TempLightSource
 youLight = 
    TLS { _tlsPos = V3 0 0 0
        ,_tlsRad = 300
        ,_tlsIntensity = 0.1
-        --,_tlsUpdate = \w _ -> (w, Nothing)
        ,_tlsUpdate = \w _ -> Just (youLight {_tlsPos = f $ _crPos (you w)})
        ,_tlsTime = 0
        }
@@ -54,7 +54,7 @@ initialWorld = defaultWorld
        . foldr ((.) . makeStartCloudAt) id [V3 x y 5 | x <- [-5,-3..5] , y <- [-5,-3..5]]
    , _pressPlates = IM.empty
    , _buttons = IM.empty
-    , _sounds = M.empty
+    , _toPlaySounds = M.empty
    , _decorations = IM.empty
    , _storedLevel = Nothing
    , _menuLayers = [TerminalScreen 300 rezText']
@@ -95,12 +95,6 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
    insertPoint  pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
    --pinc = M.fromList $ pairsToIncidence pairGraph

-wallToWall :: Wall -> IM.IntMap (IM.IntMap [Wall']) -> IM.IntMap (IM.IntMap [Wall'])
-wallToWall wl wls = foldl' (flip f) wls is
-  where
-    is = uncurry zoneOfLine (_wlLine wl)
-    wl' = Wall' {_wlLine' = _wlLine wl, _wlColor' = _wlColor wl}
-    f (x,y) = insertInZoneWith x y (++) [wl']

 updateWallZoning :: World -> World
 updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w
@@ -22,9 +22,10 @@ import Data.Function
 import System.Random

 updateBlocks :: World -> World
-updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes 
-                    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls)
-                 degradeBlocks 
+updateBlocks w 
+    = (\w' -> seq (_wallsZone w') w') 
+    $ flip (foldr removeFromZone) deadPanes 
+    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks 
 where  
    degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
    removeFromZone :: Wall -> World -> World
@@ -33,13 +33,30 @@ optionsOptions =
    [ Toggle ScancodeV (pushScreen soundMenu)    (const "VOLUME")
    , Toggle ScancodeG (pushScreen graphicsMenu) (const "GRAPHICS")
    , Toggle ScancodeP (pushScreen gameplayOptionsMenu) (const "GAMEPLAY")
+    , Toggle ScancodeD (pushScreen debugOptionsMenu) (const "DEBUG OPTIONS")
+    ]
+debugOptionsMenu :: ScreenLayer
+debugOptionsMenu  = OptionScreen
+    { _scTitle = const "OPTIONS:GAMEPLAY"
+    , _scOptions = debugMenuOptions
+    , _scDefaultEff = popScreen . writeConfig
+    , _scOptionFlag = NormalOptions
+    }
+debugMenuOptions :: [MenuOption]
+debugMenuOptions =
+    [ Toggle 
+        ScancodeF 
+        (Just . (config . debug_seconds_frame %~ not))
+        (\w -> "SHOW SECONDS/FRAME:" ++ show (_debug_seconds_frame $ _config w))
+    , Toggle 
+        ScancodeC 
+        (Just . (config . debug_noclip %~ not))
+        (\w -> "NOCLIP:" ++ show (_debug_noclip $ _config w))
+    , Toggle 
+        ScancodeS 
+        (Just . (config . debug_cr_status %~ not))
+        (\w -> "SHOW CREATURE STATUS:" ++ show (_debug_cr_status $ _config w))
    ]
--levelMenuOptions :: [MenuOption]
--levelMenuOptions =
--    [  InvisibleToggle ScancodeEscape (const Nothing)
--    ,  InvisibleToggle ScancodeO      (pushScreen optionMenu)
--    ,  InvisibleToggle ScancodeC      (pushScreen displayControls)
--    ]
 gameplayOptionsMenu :: ScreenLayer
 gameplayOptionsMenu  = OptionScreen
    { _scTitle = const "OPTIONS:GAMEPLAY"
@@ -479,7 +479,7 @@ pistolerRoom = do
    aa <- state $ randomR (0,2*pi)
    ab <- state $ randomR (0,2*pi)
    ac <- state $ randomR (0,2*pi)
-    let plmnts = [sPS (ps !! 0) aa $ PutCrit pistolCrit
+    let plmnts = [sPS (head ps) aa $ PutCrit pistolCrit
                 ,sPS (ps !! 1) ab $ PutCrit pistolCrit
                 ,sPS (ps !! 2) ac $ PutCrit pistolCrit
                 ,sPS (V2 (w/2) (h-50)) 0 putLamp
@@ -48,7 +48,7 @@ soundWithStatus
    -> Maybe Int    -- ^ Frames to play sound for, Nothing for until finished
    -> World 
    -> World
-soundWithStatus status so pos sType mtime w = over sounds (M.insertWith f so sound) w
+soundWithStatus status so pos sType mtime w = over toPlaySounds (M.insertWith f so sound) w
  where 
    sound = Sound 
        { _soundChunkID     = sType
@@ -86,7 +86,7 @@ soundFromGeneral
    -> Maybe Int    -- ^ Frames to play sound for, Nothing for until finished
    -> World 
    -> World
-soundFromGeneral so fpos sType mtime w = over sounds (M.insertWith f so sound) w
+soundFromGeneral so fpos sType mtime w = over toPlaySounds (M.insertWith f so sound) w
  where 
    sound = Sound 
        { _soundChunkID     = sType
@@ -126,7 +126,7 @@ soundMultiFrom
    -> World
 soundMultiFrom [] _ _ _ w = w
 soundMultiFrom [so] pos sType mtime w
-    = over sounds (M.insert so sound) w
+    = over toPlaySounds (M.insert so sound) w
  where 
    sound = Sound 
        { _soundChunkID     = sType
@@ -140,7 +140,7 @@ soundMultiFrom [so] pos sType mtime w
    a = soundAngle pos w
 soundMultiFrom (so:sos) pos sType mtime w
    | so `M.member` _playingSounds w = soundMultiFrom sos pos sType mtime w
-    | otherwise = over sounds (M.insert so sound) w
+    | otherwise = over toPlaySounds (M.insert so sound) w
  where 
    sound = Sound 
        { _soundChunkID     = sType
@@ -154,5 +154,5 @@ soundMultiFrom (so:sos) pos sType mtime w
    a = soundAngle pos w
 {- | Sets '_soundTime' to 0.  -}
 stopSoundFrom :: SoundOrigin -> World -> World
-stopSoundFrom so = over (sounds . ix so . soundTime) (fmap $ min 0)
+stopSoundFrom so = over (playingSounds . ix so . soundTime) (fmap $ min 0)

@@ -30,7 +30,6 @@ import Data.Maybe
 import Data.Function
 import qualified Data.Set as S
 import qualified Data.IntMap.Lazy as IM
-import qualified Data.Map as M
 import Control.Lens
 import Data.Monoid
 import System.Random
@@ -50,8 +49,7 @@ functionalUpdate w = case _menuLayers w of
    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> updateParticles 
        . updateProjectiles 
        . updateLightSources
-        . updateClouds
-        $ updateSoundQueue
+        $ updateClouds
        w
    (_ : _) -> w
    []  -> checkEndGame 
@@ -75,9 +73,9 @@ functionalUpdate w = case _menuLayers w of
        . updateCreatureGroups
        . updateBlocks
        . updateSeenWalls 
-        . updateSoundQueue
        $ updateCloseObjects w
  where 
+    --updatedLightSources = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
    zoneCreatures = set (creaturesZone . znObjects) 
        (IM.foldl' (flip creatureInZone) IM.empty (_creatures w))
    creatureInZone cr = insertIMInZone x y cid cr
@@ -119,9 +117,6 @@ updateTriggers w
  where
    cr = _creatures w IM.! 0 & crPos .~ V2 0 0

-updateSoundQueue :: World -> World
-updateSoundQueue = set sounds M.empty
-
 updateLightSources :: World -> World
 updateLightSources w = set tempLightSources tlss w
  where 
@@ -156,7 +151,7 @@ ppEvents :: World -> World
 ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w

 updateSeenWalls :: World -> World
-updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate
+updateSeenWalls w = foldr markSeen w wallsToUpdate
  where 
    vPos = _cameraViewFrom w
    wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
@@ -229,10 +224,10 @@ clClSpringVel a v b
    radDist = (_clRad a + _clRad b) / 2

 simpleCrSprings :: World -> World
-simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
+simpleCrSprings w = IM.foldr crSpring w $ _creatures w

 crSpring :: Creature -> World -> World
-crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
+crSpring c w = IM.foldr (crCrSpring c) w cs
  where 
    cs = creaturesNearPoint (_crPos c) w

@@ -241,8 +236,10 @@ crCrSpring c1 c2 w
    | id1 == id2 = w
    | vec == V2 0 0 = w
    | diff >= comRad = w
-    | otherwise = over (creatures . ix id1 . crPos) (+.+ overlap1)
-                        $ over (creatures . ix id2 . crPos) (-.- overlap2) w
+    | otherwise = over creatures
+        ( over (ix id1 . crPos) (+.+ overlap1)
+        . over (ix id2 . crPos) (-.- overlap2)
+        ) w
  where 
    id1  = _crID c1
    id2  = _crID c2
@@ -1,14 +1,16 @@
 {- | Deals with moving creature wall collisions.  -}
-module Dodge.WallCreatureCollisions where
+module Dodge.WallCreatureCollisions 
+    ( colCrsWalls
+    ) where
 import Dodge.Data
 import Dodge.Data.DamageType
 import Dodge.Creature.State.Data
-import Dodge.Debug.Flag.Data
 import Dodge.Zone
 import Dodge.Base
+import Dodge.Config.Data
 import Geometry

-import Data.List
+import Data.Monoid
 import Data.Maybe
 import Data.Function
 import Control.Lens
@@ -21,9 +23,7 @@ colCrWall :: World -> Creature -> Creature
 colCrWall w c 
    | noclipIsOn && _crID c == 0 = c -- for noclip
    | p1 == p2  = pushOrCrush ls c
-    | otherwise = c & crPos %~
--        collideCorners rad wallPoints
-         collideWalls rad p1 ls 
+    | otherwise = c & crPos %~ pushOutFromWalls rad ls 
        . flip (collidePointWalls p1) wls  -- check push throughs
  where 
    rad = _crRad c + wallBuffer
@@ -32,7 +32,7 @@ colCrWall w c
    ls  = IM.elems $ _wlLine <$> wallsNearPoint p2 w
    wls = wallsNearPoint p2 w
    --wallPoints = map fst ls
-    noclipIsOn = _noClip $ _debugFlags w
+    noclipIsOn = _debug_noclip $ _config w

 -- the amount to push creatures out from walls, extra to their radius
 wallBuffer :: Float
@@ -41,23 +41,11 @@ wallBuffer = 0
 -- the following tests whether or not a point is on a wall, and if so pushes it
 -- out from the wall
 -- this is then repeated if the point ends up on a new wall
-collideWalls :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2
-collideWalls rad cp1 wls cp2 = case (listToMaybe . mapMaybe (pushOutFromWall rad cp2)) wls of
-    Nothing -> cp2
-    Just cp3 -> case (listToMaybe . reverse . mapMaybe (pushOutFromWall rad cp3)) wls of
-        Nothing -> cp3
--        Just cp4 -> 0.5 *.* (cp4 +.+ cp1)
-        Just _ -> cp1
-
-- pushes a point out from a list of walls
-- if multiple new points occur, chooses the one closest to the orignal point
 pushOutFromWalls :: Float -> [(Point2,Point2)] -> Point2 -> Point2
-pushOutFromWalls rad wls p = 
-    fromMaybe p
-    . listToMaybe
-    . sortBy (compare `on` dist p)
-    $ mapMaybe (pushOutFromWall rad p) 
-    wls
+pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of
+    Nothing -> p1
+    Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall rad p2)) wls
+    -- possible improvement: choose between the closer of p2 and "p3" to p1

 pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature
 pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
@@ -80,18 +68,17 @@ pushOutFromWall rad cp2 (wp1,wp2)
    newP = errorClosestPointOnLine 5 wp1' wp2' cp2
    isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad

-pushOutFromCorners :: World -> Creature -> Creature
-pushOutFromCorners w cr = cr & crPos .~ newPos
-  where
-    newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
-    ls  = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w
+--pushOutFromCorners :: World -> Creature -> Creature
+--pushOutFromCorners w cr = cr & crPos .~ newPos
+--  where
+--    newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
+--    ls  = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w

-collideCorners :: Float -> [Point2] -> Point2 -> Point2
-collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps
-
-- collide circles with points (outer corners)
-intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
-intersectCirclePoint rad p cCen 
-    | dist cCen p > rad = cCen
-    | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
+--collideCorners :: Float -> [Point2] -> Point2 -> Point2
+--collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps

+---- collide circles with points (outer corners)
+--intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
+--intersectCirclePoint rad p cCen 
+--    | dist cCen p > rad = cCen
+--    | otherwise         = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
@@ -7,64 +7,27 @@ This module sets up an SDL window which may be updated using a simple game loop.
 -}
 module Loop
    ( setupLoop
-    , setupMiniLoop
-    , setupLoop'
    ) where
 import qualified Data.Text as T
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
-import Control.Monad.Trans.Maybe
 import System.Mem
 --import Foreign.C
 import SDL
 import qualified Graphics.Rendering.OpenGL as GL
-import qualified Data.Vector.Fusion.Stream.Monadic as VS
--import Control.Lens ((.~),(&),(+~))
+
 -- | Create a game loop with an SDL window.
 setupLoop
-    :: (Int,Int)            -- ^ The window size.
-    -> IO params            -- ^ Initial parameters.
-    -> (params -> IO ())    -- ^ Function for cleaning up parameters, applied when exiting loop.
-    -> IO world             -- ^ Initial simulation state.
-    -> (params -> world -> IO params)   -- ^ Parameter update, called once per frame. Allows for side effects such as rendering.
-    -> (world -> Event -> Maybe world)
-                            -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
-    -> (world -> Maybe world)
-                            -- ^ Simulation update, once per frame. 'Nothing' exits the loop.
-    -> IO ()
-setupLoop 
-    (xSize,ySize)
-    initParams 
-    paramCleanup 
-    ioStartWorld 
-    sideEffects 
-    eventFn 
-    worldFn = do 
-        startWorld <- ioStartWorld
-        initializeAll
-        bracket 
-            (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize)) 
-            destroyWindow 
-            $ \window -> bracket 
-                (glCreateContext window) 
-                ( \con -> GL.finish >> glDeleteContext con)
-                $ \_   -> bracket 
-                    initParams 
-                    paramCleanup 
-                    $ doLoop window startWorld sideEffects eventFn worldFn
-
-
-- | Create a game loop with an SDL window.
-setupLoop'
-    :: (Int,Int)            -- ^ The window size.
+    :: Int                  -- ^ Target seconds per frame
+    -> (Int,Int)            -- ^ The window size.
    -> (world -> IO ())    -- ^ Function for cleaning up parameters, applied when exiting loop.
    -> IO world             -- ^ Initial simulation state.
    -> (world -> IO world)   -- ^ update, called once per frame. Allows for side effects such as rendering.
    -> (world -> Event -> Maybe world)
                            -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
    -> IO ()
-setupLoop' (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do 
+setupLoop spf (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do 
    initializeAll
    bracket 
        (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize)) 
@@ -75,15 +38,17 @@ setupLoop' (xSize,ySize) paramCleanup ioStartWorld sideEffects eventFn = do
            $ \_   -> bracket 
                ioStartWorld
                paramCleanup 
-                $ doLoop' window sideEffects eventFn
+                $ doLoop spf window sideEffects eventFn
 -- | The internal loop.
-doLoop'
-    :: Window   -- ^ The SDL window.
+doLoop
+    :: Int      -- ^ target msec per frame
+    -> Window   -- ^ The SDL window.
    -> (world -> IO world) -- ^ simulation update. 
    -> (world -> Event -> Maybe world) -- ^ SDL Event handling.
    -> world    -- ^ Current simulation state.
    -> IO ()
-doLoop' 
+doLoop 
+    spf
    window 
    worldSideEffects 
    eventFn 
@@ -99,42 +64,10 @@ doLoop'
            performGC
            endTicks <- ticks -- it might be better to use System.Clock (monotonic)

-            let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
+            let theDelay = max 0 (spf + fromIntegral startTicks - fromIntegral endTicks)
            threadDelay (theDelay * 1000 )

-            doLoop' window worldSideEffects eventFn updatedWorld
-        Nothing -> return ()
-- | The internal loop.
-doLoop 
-    :: Window   -- ^ The SDL window.
-    -> world    -- ^ Current simulation state.
-    -> (params -> world -> IO params) -- ^ Parameter update. 
-    -> (world -> Event -> Maybe world) -- ^ SDL Event handling.
-    -> (world -> Maybe world) -- ^ Simulation update
-    -> params -- ^ Current parameters.
-    -> IO ()
-doLoop 
-    window 
-    startWorld
-    worldSideEffects 
-    eventFn 
-    worldUpdate 
-    startParams 
-  = do
-    startTicks <- ticks
-    newParams <- worldSideEffects startParams startWorld
-    glSwapWindow window
-    events <- pollEvents
-    maybeUpdatedWorld <- foldM (applyEventIO eventFn) (Just startWorld) events
-    case maybeUpdatedWorld >>= worldUpdate of
-        Just updatedWorld -> do 
-            performGC
-            endTicks <- ticks -- it might be better to use System.Clock (monotonic)
-
-            let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
-            threadDelay (theDelay * 1000 )
-
-            doLoop window updatedWorld worldSideEffects eventFn worldUpdate newParams
+            doLoop spf window worldSideEffects eventFn updatedWorld
        Nothing -> return ()
 -- | Handle quit events in a manner to exit the loop. Other events handled as
 -- determined by the custom function, although resize events also change the viewport.
@@ -156,59 +89,4 @@ winConfig x y = defaultWindow
    , windowResizable =True
    }

-setupMiniLoop
-    :: (Int,Int)            -- ^ The window size.
-    -> IO world             -- ^ Initial simulation state.
-    -> (world -> IO ())      -- ^ Function for cleaning up parameters, applied when exiting loop.
-    -> (world -> Event -> MaybeT IO world)
-                            -- ^ Event handling
-    -> (world -> MaybeT IO world)
-                            -- ^ Simulation update
-    -> IO ()
-setupMiniLoop (xsize,ysize) initWorld cleanup eventUpdate simUpdate = do
-    bracket     
-        (createWindow (T.pack "Mini Loop") (winConfig xsize ysize))
-        destroyWindow
-        $ \window -> bracket
-            (glCreateContext window)
-            (\con -> GL.finish >> glDeleteContext con)
-            $ \_ -> bracket
-                initWorld
-                cleanup
-                (doMiniLoop window eventUpdate simUpdate)

-doMiniLoop 
-    :: Window
-    -> (world -> Event -> MaybeT IO world)
-    -> (world -> MaybeT IO world)
-    -> world
-    -> IO ()
-doMiniLoop window eventUpdate simUpdate startWorld = do
-    startTicks <- ticks
-    glSwapWindow window
-    mayWorld <- runMaybeT $ foldEventsT (plungeMaybe eventUpdate) startWorld >>= simUpdate
-    case mayWorld of
-        Just w -> do 
-            performGC
-            endTicks <- ticks -- it might be better to use System.Clock (monotonic)
-
-            let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks)
-            threadDelay (theDelay * 1000 )
-
-            doMiniLoop window eventUpdate simUpdate w
-        Nothing -> return ()
-
-plungeMaybe :: (a -> b -> MaybeT IO a) -> Maybe a -> b -> IO (Maybe a)
-plungeMaybe f a b = runMaybeT $ MaybeT (pure a) >>= flip f b
-
-foldEventsT :: (Maybe world -> Event -> IO (Maybe world)) -> world -> MaybeT IO world
-foldEventsT f w = MaybeT $ foldEvents f w
-
-foldEvents :: (Maybe world -> Event -> IO (Maybe world)) -> world -> IO (Maybe world)
-foldEvents f w = VS.foldlM' f (Just w) streamEvents
-
-streamEvents :: VS.Stream IO Event
-streamEvents = VS.unfoldrM pollEventSeed ()
-
-pollEventSeed :: () -> IO (Maybe (Event,()))
-pollEventSeed _ = fmap (fmap (,())) pollEvent