From 4d7f8fb3546db995ed7eb097a0d68be61217f8ab Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 31 Oct 2016 23:47:16 +0100 Subject: [PATCH] working types, but no working implementation --- affection.cabal | 2 ++ src/Affection.hs | 69 ++++++++++++++++++++++++----------- src/Affection/Types.hs | 81 +++++++++++++++++++++++++++++++++++++++++- 3 files changed, 131 insertions(+), 21 deletions(-) diff --git a/affection.cabal b/affection.cabal index e177d91..1155bd4 100644 --- a/affection.cabal +++ b/affection.cabal @@ -55,6 +55,8 @@ library , linear , mtl , gegl + , monad-loops + , timeit -- , sdl2-image executable example00 diff --git a/src/Affection.hs b/src/Affection.hs index 0ea48b9..b09b42c 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE RecordWildCards #-} module Affection - ( withAllAffection + ( withAffection , withWindow , withDefaultWindow , delaySec @@ -7,34 +8,62 @@ module Affection , module Affection.Types ) where -import SDL -import Data.Text -import GEGL +import qualified SDL +import qualified GEGL as G + +import qualified Data.Text as T +import Data.Maybe + +import System.TimeIt (timeItT) + +import Control.Monad.Loops +import Control.Monad.State +import Control.Monad.Reader +import Control.Concurrent.MVar import Affection.Render -import Affection.Types +import Affection.Types as Types -withAllAffection :: IO () -> IO () -withAllAffection ops = do - initializeAll - ops - quit +withAffection :: AffectionConfig us -> IO () +withAffection conf@AffectionConfig{..} = do + case initComponents of + All -> + SDL.initializeAll + Only is -> + SDL.initialize is + execTime <- newMVar 0 + window <- SDL.createWindow windowTitle windowConfig + surface <- SDL.getWindowSurface window + let initContainer = AffectionData conf False userData window surface + state <- newMVar initContainer + (res, nState) <- runStateT ( + whileM_ (do + current <- get + return $ Types.quitEvent current + ) + $ do + lastTime <- liftIO $ fromMaybe 0 <$> tryReadMVar execTime + (dTime, _) <- liftIO $ timeItT <$> drawLoop + (uTime, _) <- liftIO $ timeItT <$> updateLoop lastTime + liftIO $ putMVar execTime $ lastTime + dTime + uTime + ) initContainer + SDL.quit -withWindow :: Monad m => Text -> WindowConfig -> RendererConfig -> RenderT m a -> IO () +withWindow :: Monad m => T.Text -> WindowConfig -> SDL.RendererConfig -> RenderT m a -> IO () withWindow title wconf rconf ops = do - window <- createWindow title wconf + window <- SDL.createWindow title wconf -- I don't need a renderer here, i need a surface - renderer <- createRenderer window (-1) rconf - surface <- getWindowSurface window - gegl_init + renderer <- SDL.createRenderer window (-1) rconf + surface <- SDL.getWindowSurface window + G.gegl_init -- I think I need some AffectionT or someting similar here and not a RenderT -- from SDL. inRender renderer $ ops - gegl_exit - destroyWindow window + G.gegl_exit + SDL.destroyWindow window -withDefaultWindow :: Monad m => Text -> (RenderT m a) -> IO () -withDefaultWindow title ops = withWindow title defaultWindow defaultRenderer ops +withDefaultWindow :: Monad m => T.Text -> (RenderT m a) -> IO () +withDefaultWindow title ops = withWindow title defaultWindow SDL.defaultRenderer ops delaySec :: Int -> IO () -delaySec dur = delay (fromIntegral $ dur * 1000) +delaySec dur = SDL.delay (fromIntegral $ dur * 1000) diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 4807ab4..44eebc2 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -1,7 +1,86 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module Affection.Types - ( RGBA(..) + ( AffectionData(..) + , AffectionConfig(..) + -- , AffectionState(..) + -- , AffectionDraw(..) + -- , Draw(..) + , AffectionStateInner(..) + -- , AffectionDrawInner(..) + , InitComponents(..) + -- , Loop(..) + , RGBA(..) + , SDL.WindowConfig(..) + , SDL.defaultWindow ) where +import qualified SDL.Init as SDL +import qualified SDL.Video as SDL +import qualified Data.Text as T + +import Control.Monad.IO.Class +import Control.Monad.State +import Control.Monad.Reader + +import Control.Concurrent.MVar + +-- | Configuration for the aplication. needed at startup. +data AffectionConfig us = AffectionConfig + { initComponents :: InitComponents -- ^ SDL components to initialize at startup + , windowTitle :: T.Text -- ^ Window title + , windowConfig :: SDL.WindowConfig -- ^ Window configuration + , drawLoop :: AffectionState (AffectionData us) IO (IO ()) -- ^ Some function. Type to be determined. + , updateLoop :: Double -> AffectionState us IO (IO ()) -- ^ Another function. Type to be determined + , userData :: us + } + +-- | Main type for defining the look, feel and action of the whole application. +data AffectionData us = AffectionData + { affectionConfig :: AffectionConfig us -- ^ Application configuration. + , quitEvent :: Bool -- ^ Loop breaker. + , userState :: us -- ^ State data provided by user + , drawWindow :: SDL.Window -- ^ SDL window + , drawSurface :: SDL.Surface -- ^ SDL surface + } + +-- -- | Data and surfaces for drawing. +-- data AffectionDraw dd = AffectionDraw +-- } + +-- | Components to initialize in SDL. +data InitComponents + = All + | Only [SDL.InitFlag] + +-- | Inner 'StateT' monad for the update state +type AffectionStateInner us m a = StateT (AffectionData us) m a + +-- | Affection's state monad +newtype AffectionState us m a = AffectionState + { runState :: AffectionStateInner us m a } + deriving (Functor, Applicative, Monad, MonadIO) + +-- -- | Inner 'StateT' monad of Affection +-- type AffectionInner us od a = StateT (AffectionState us od) IO a +-- +-- -- | Affection state monad +-- newtype Affection us od a = Affection +-- { runAffection :: AffectionInner us od a } +-- deriving (Functor, Applicative, Monad, MonadState (AffectionState us od)) +-- +-- -- | Inner drawing monad of Affection. +-- type AffectionDrawInner ds a = ReaderT (Draw ds) a +-- +-- -- | Affectiondrawinf reader monad. +-- newtype AffectionDraw ds a = AffectionDraw +-- { runDraw :: (ds -> a) } +-- deriving (Functor, Applicative, Monad, MonadReader ds) +-- +-- -- | Loop state monad to hold elapsed time per frame +-- newtype Loop f a = Loop +-- { runLoop :: f -> (a, f) } +-- deriving (Functor, Applicative, Monad, MonadState (Loop f)) + data RGBA = RGBA { r :: Int , g :: Int