diff --git a/examples/basic/Main.hs b/examples/basic/Main.hs index c6a2bf4..0302e05 100644 --- a/examples/basic/Main.hs +++ b/examples/basic/Main.hs @@ -1,6 +1,8 @@ module Main where +import Control.Monad.RWS (void, tell) import Polar +import Polar.System.Renderer import Polar.System.Renderer.OpenGL_3_2 hello :: System @@ -8,6 +10,10 @@ hello = defaultSystem "Hello" & startup .~ logWrite NOTICE "Hello!" & shutdown .~ logWrite NOTICE "Goodbye... :(" +prim :: System +prim = defaultSystem "Primitive Submitter" + & startup .~ tell [SysCoreAction (void $ submitPrimitive ())] + main :: IO () main = run $ defaultEngine - & systems .~ [hello, renderer] + & systems .~ [hello, prim, renderer] diff --git a/polar-engine.cabal b/polar-engine.cabal index 17c69ba..68ef2ec 100644 --- a/polar-engine.cabal +++ b/polar-engine.cabal @@ -21,11 +21,13 @@ library Polar.Log, Polar.Exit, Polar.Storage, + Polar.Unique, Polar.Core.Config, Polar.Core.File, Polar.Core.Run, Polar.Sys.Run, Polar.Logic.Run, + Polar.System.Renderer, Polar.System.Renderer.OpenGL_3_2, Polar.Shader.Compiler.GLSL150, Polar.Types, @@ -49,7 +51,7 @@ library test-suite example-basic type: exitcode-stdio-1.0 main-is: Main.hs - build-depends: base >=4.8 && <5.0, polar-engine + build-depends: base >=4.8 && <5.0, mtl >=2.2, polar-engine default-language: Haskell2010 hs-source-dirs: examples/basic ghc-options: -W diff --git a/src/Polar/System/Renderer.hs b/src/Polar/System/Renderer.hs new file mode 100644 index 0000000..8f9281d --- /dev/null +++ b/src/Polar/System/Renderer.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} + +{-| + Module : Polar.System.Renderer + Copyright : (c) 2016 David Farrell + License : Apache-2.0 + Stability : unstable + Portability : non-portable (GHC extensions) + + Generic renderer utility functions. +-} + +module Polar.System.Renderer +( submitPrimitive, readRendererMsg +) where + +import Data.Hashable +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan +import GHC.Generics +import Polar.Storage +import Polar.Unique + +data RendererKey = RendererKey deriving Generic +instance Hashable RendererKey + +submitPrimitive :: (MonadIO m, StorePolar m) => () -> m Integer +submitPrimitive x = do + uid <- unique + chan <- mRetrieveKeyed RendererKey >>= \case + Nothing -> do + c <- liftIO (atomically newTChan) + storeKeyed RendererKey c + pure c + Just c -> pure c + liftIO $ atomically (writeTChan chan (uid, x)) + pure uid + +readRendererMsg :: (MonadIO m, StorePolar m) => m (Maybe (Integer, ())) +readRendererMsg = do + mRetrieveKeyed RendererKey >>= \case + Nothing -> pure Nothing + Just chan -> liftIO $ atomically (tryReadTChan chan) diff --git a/src/Polar/System/Renderer/OpenGL_3_2.hs b/src/Polar/System/Renderer/OpenGL_3_2.hs index 3f9cd52..385618c 100644 --- a/src/Polar/System/Renderer/OpenGL_3_2.hs +++ b/src/Polar/System/Renderer/OpenGL_3_2.hs @@ -29,6 +29,7 @@ import Polar.Types import Polar.Log import Polar.Exit import Polar.Storage +import Polar.System.Renderer import Polar.Shader (compile) import Polar.Shader.Types import Polar.Shader.Compiler.GLSL150 (GLSL150(..)) @@ -77,6 +78,9 @@ tickF = do render :: GLFW.Window -> Core () render win = do gl (GL.clear [GL.ColorBuffer, GL.DepthBuffer]) + readRendererMsg >>= \case + Nothing -> pure () + Just m -> logWrite TRACE ("Received renderer message: " ++ show m) traverse_ renderOne =<< retrieveAll liftIO (GLFW.swapBuffers win) liftIO GLFW.pollEvents diff --git a/src/Polar/Unique.hs b/src/Polar/Unique.hs new file mode 100644 index 0000000..f5681b5 --- /dev/null +++ b/src/Polar/Unique.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} + +{-| + Module : Polar.Unique + Copyright : (c) 2016 David Farrell + License : Apache-2.0 + Stability : unstable + Portability : non-portable (GHC extensions) + + Functions for generating unique values. +-} + +module Polar.Unique (unique) where + +import Data.Typeable +import Data.Hashable +import GHC.Generics +import Polar.Storage + +data UniqueKey = UniqueKey deriving Generic +instance Hashable UniqueKey + +unique :: (StorePolar m, Enum a, Typeable a) => m a +unique = do + x <- maybe (toEnum 0) succ <$> mRetrieveKeyed UniqueKey + storeKeyed UniqueKey x + pure x