Add source files, commit before reverting pictures to lists

2021-02-15 00:07:55 +01:00
parent c6bcfacc7a
commit 8447844bcd
41 changed files with 13677 additions and 35 deletions
@@ -0,0 +1,120 @@
+module Loop
+    ( setupLoop
+--    , withExits
+    ) where
+import SDL
+import qualified Data.Text as T
+import Control.Concurrent
+import Control.Exception
+import qualified Graphics.Rendering.OpenGL as GL
+import Control.Monad
+import System.Mem
+import Foreign.C
+import Geometry
+
+winConfig x y = defaultWindow 
+    { windowGraphicsContext
+        = OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
+                                       , glColorPrecision = V4 8 8 8 8
+                                       } 
+                        )
+    , windowInitialSize = V2 x y
+    , windowResizable =True
+    }
+
+setupLoop :: String
+        -> CInt
+        -> CInt
+        -> IO setupParams
+        -> (setupParams -> IO ())
+        -> world
+        -> (setupParams -> world -> IO ())
+        -> (world -> Event -> Maybe world)
+        -> (world -> Maybe world)
+        -> IO ()
+setupLoop wName xSize ySize 
+            customInit initCleanup startWorld sideEffects eventFn worldFn = do 
+    initializeAll
+    bracket (createWindow (T.pack wName) (winConfig xSize ySize)) destroyWindow
+        (\window -> 
+            do bracket (glCreateContext window) (\con -> GL.finish >> glDeleteContext con)
+                 (\_ -> bracket customInit initCleanup $ \setup -> do --  setup <- customInit
+--                            swapInterval $= ImmediateUpdates
+                            GL.blend $= GL.Enabled
+                            GL.blendEquation $= GL.FuncAdd
+                            GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha)
+                            GL.clearColor $= GL.Color4 0 0.5 0 0
+                            doLoop setup window startWorld
+                                   sideEffects eventFn worldFn
+                 )
+        )
+
+
+--doLoop :: setupParams -> Window -> WorldView world0
+--            -> (setupParams -> WorldView world0 -> IO ()) 
+--            -> (world0 -> Event -> Maybe world0) 
+--            -> (world0 -> Maybe world0) 
+--            -> IO ()
+doLoop setup window startWorld
+        worldSideEffects 
+        eventFn 
+        worldUpdate 
+  = do
+    startLoopTicks <- ticks
+    events <- pollEvents
+    --let-- maybeUpdatedWorld :: Maybe (WorldView world0)
+    --    maybeUpdatedWorld = applyEvents eventFn startWorld events worldUpdate
+    maybeUpdatedWorld <- applyEventsIO eventFn startWorld events
+    case maybeUpdatedWorld >>= worldUpdate of
+        Just updatedWorld -> do 
+            GL.clear [GL.ColorBuffer,GL.DepthBuffer]
+            worldSideEffects setup updatedWorld
+            glSwapWindow window
+            --GL.flush
+            performGC
+            endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic)
+            let delay = max 0 (10 + fromIntegral startLoopTicks - fromIntegral endLoopTicks)
+            threadDelay (delay * 1000)
+            doLoop setup window updatedWorld worldSideEffects eventFn worldUpdate
+        Nothing -> return ()
+
+applyEvents :: (world0 -> Event -> Maybe world0)
+                -> world0 
+                -> [Event]
+                -> (world0 -> Maybe world0)
+                -> Maybe world0
+applyEvents eventFn startWorld events worldUpdate = 
+    case foldM (applyH eventFn) startWorld events of
+        Just w -> fmap (\w' -> w') $ worldUpdate w
+        Nothing -> Nothing
+    where
+        applyH :: (world0 -> Event -> Maybe world0) -> world0 -> Event -> Maybe world0
+        applyH f w e 
+            = case eventPayload e of
+                QuitEvent -> Nothing
+                WindowClosedEvent _ -> Nothing
+                _ -> f w e
+
+-- applyResizeExits :: (world -> Event -> Maybe world) -> (world -> Event -> Maybe world)
+-- applyResizeExits f w e 
+--     = case eventPayload e of
+--         QuitEvent -> Nothing
+--         WindowClosedEvent _ -> Nothing
+--         WindowSizeChangedEvent
+--          (WindowSizeChangedEventData {windowSizeChangedEventWindow = V2 x y})
+--             -> GL.viewport
+--         _   -> f w e
+applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
+applyEventIO fn mw e = case eventPayload e of
+    QuitEvent -> return Nothing
+    WindowClosedEvent _ -> return Nothing
+    WindowSizeChangedEvent
+     (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
+        -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
+    _   -> return $ mw >>= flip fn e
+
+applyEventsIO :: (world0 -> Event -> Maybe world0)
+                -> world0 
+                -> [Event]
+                -> IO (Maybe world0)
+applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es