Move debug flags to config, various perf improvements

appDodge/Main.hs

@@ -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
+    when (_debug_seconds_frame $ _config w) $ void $ renderFoldable
-                (_pictureShaders $ _renderData preData)
+        (_pictureShaders $ _renderData preData)
-                (setDepth (-1)
+        (setDepth (-1)
-                    . translate (-0.5) (-0.8) . scale 0.0005 0.0005
+            . translate (-0.5) (-0.8) . scale 0.0005 0.0005
-                    . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
+            . 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

src/Dodge/Base.hs

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

src/Dodge/Config/Data.hs

@@ -1,23 +1,10 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StrictData #-}
-module Dodge.Config.Data (
+module Dodge.Config.Data 
-      Configuration (..)
+    where
-    , defaultConfig
-    , volume_master
-    , volume_sound
-    , volume_music
-    , wall_textured
-    , cloud_shadows
-    , resolution_factor
-    , windowX
-    , windowY
-    , rotate_to_wall
-    , show_sound
-    ) 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
     }

src/Dodge/Creature/Picture.hs

@@ -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 

src/Dodge/Data.hs

@@ -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) 

src/Dodge/Debug/Flag/Data.hs

@@ -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

src/Dodge/Debug/Terminal.hs

@@ -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

src/Dodge/Default/World.hs

@@ -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
         }

src/Dodge/Initialisation.hs

@@ -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']

src/Dodge/Layout.hs

@@ -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

src/Dodge/LevelGen/Block.hs

@@ -22,9 +22,10 @@ import Data.Function
 import System.Random
 
 updateBlocks :: World -> World
-updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes 
+updateBlocks w 
-                    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls)
+    = (\w' -> seq (_wallsZone w') w') 
-                 degradeBlocks 
+    $ 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

src/Dodge/Menu.hs

@@ -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"

src/Dodge/Room.hs

@@ -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

src/Dodge/SoundLogic.hs

@@ -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)
 

src/Dodge/Update.hs

@@ -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
+        $ updateClouds
-        $ updateSoundQueue
         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)
+    | otherwise = over creatures
-                        $ over (creatures . ix id2 . crPos) (-.- overlap2) w
+        ( over (ix id1 . crPos) (+.+ overlap1)
+        . over (ix id2 . crPos) (-.- overlap2)
+        ) w
   where 
     id1  = _crID c1
     id2  = _crID c2

src/Dodge/WallCreatureCollisions.hs

@@ -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 %~
+    | otherwise = c & crPos %~ pushOutFromWalls rad ls 
---        collideCorners rad wallPoints
-         collideWalls rad p1 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 = 
+pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of
-    fromMaybe p
+    Nothing -> p1
-    . listToMaybe
+    Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall rad p2)) wls
-    . sortBy (compare `on` dist p)
+    -- possible improvement: choose between the closer of p2 and "p3" to p1
-    $ mapMaybe (pushOutFromWall rad p) 
-    wls
 
 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 :: World -> Creature -> Creature
-pushOutFromCorners w cr = cr & crPos .~ newPos
+--pushOutFromCorners w cr = cr & crPos .~ newPos
-  where
+--  where
-    newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
+--    newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
-    ls  = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w
+--    ls  = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w
 
-collideCorners :: Float -> [Point2] -> Point2 -> Point2
+--collideCorners :: Float -> [Point2] -> Point2 -> Point2
-collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps
+--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))
 
+---- 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))

src/Loop.hs

@@ -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'
+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'
+doLoop
-    :: Window   -- ^ The SDL window.
+    :: 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
+            doLoop spf 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
         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