Move main to allow for new executables

src/Loop.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 {- |
 Module      : Loop
 Description : Simple game loop
@@ -6,15 +7,18 @@ This module sets up an SDL window which may be updated using a simple game loop.
 -}
 module Loop
     ( setupLoop
+    , setupMiniLoop
     ) 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
@@ -99,3 +103,60 @@ winConfig x y = defaultWindow
     , windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
     , 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