working types, but no working implementation

This commit is contained in:
nek0 2016-10-31 23:47:16 +01:00
parent c49f41673c
commit 4d7f8fb354
3 changed files with 131 additions and 21 deletions

View file

@ -55,6 +55,8 @@ library
, linear , linear
, mtl , mtl
, gegl , gegl
, monad-loops
, timeit
-- , sdl2-image -- , sdl2-image
executable example00 executable example00

View file

@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-}
module Affection module Affection
( withAllAffection ( withAffection
, withWindow , withWindow
, withDefaultWindow , withDefaultWindow
, delaySec , delaySec
@ -7,34 +8,62 @@ module Affection
, module Affection.Types , module Affection.Types
) where ) where
import SDL import qualified SDL
import Data.Text import qualified GEGL as G
import GEGL
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.Render
import Affection.Types import Affection.Types as Types
withAllAffection :: IO () -> IO () withAffection :: AffectionConfig us -> IO ()
withAllAffection ops = do withAffection conf@AffectionConfig{..} = do
initializeAll case initComponents of
ops All ->
quit 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 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 -- I don't need a renderer here, i need a surface
renderer <- createRenderer window (-1) rconf renderer <- SDL.createRenderer window (-1) rconf
surface <- getWindowSurface window surface <- SDL.getWindowSurface window
gegl_init G.gegl_init
-- I think I need some AffectionT or someting similar here and not a RenderT -- I think I need some AffectionT or someting similar here and not a RenderT
-- from SDL. -- from SDL.
inRender renderer $ ops inRender renderer $ ops
gegl_exit G.gegl_exit
destroyWindow window SDL.destroyWindow window
withDefaultWindow :: Monad m => Text -> (RenderT m a) -> IO () withDefaultWindow :: Monad m => T.Text -> (RenderT m a) -> IO ()
withDefaultWindow title ops = withWindow title defaultWindow defaultRenderer ops withDefaultWindow title ops = withWindow title defaultWindow SDL.defaultRenderer ops
delaySec :: Int -> IO () delaySec :: Int -> IO ()
delaySec dur = delay (fromIntegral $ dur * 1000) delaySec dur = SDL.delay (fromIntegral $ dur * 1000)

View file

@ -1,7 +1,86 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-}
module Affection.Types module Affection.Types
( RGBA(..) ( AffectionData(..)
, AffectionConfig(..)
-- , AffectionState(..)
-- , AffectionDraw(..)
-- , Draw(..)
, AffectionStateInner(..)
-- , AffectionDrawInner(..)
, InitComponents(..)
-- , Loop(..)
, RGBA(..)
, SDL.WindowConfig(..)
, SDL.defaultWindow
) where ) 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 data RGBA = RGBA
{ r :: Int { r :: Int
, g :: Int , g :: Int