From f50bd1afe8fafcf9a40d804e007e57ec9580bb03 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 4 Nov 2016 16:06:16 +0100 Subject: [PATCH] get first example somewhat working --- affection.cabal | 5 +++ examples/example00.hs | 89 ++++++++++++++++++++++++++++++++++++++---- src/Affection.hs | 23 ++++++----- src/Affection/Types.hs | 22 +++++++---- 4 files changed, 115 insertions(+), 24 deletions(-) diff --git a/affection.cabal b/affection.cabal index 4fbe4c3..c65c64c 100644 --- a/affection.cabal +++ b/affection.cabal @@ -68,6 +68,11 @@ executable example00 if flag(examples) build-depends: base , affection + , sdl2 + , gegl + , babl + , containers + , mtl else buildable: False diff --git a/examples/example00.hs b/examples/example00.hs index 3d67ac1..f4a78ce 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,10 +1,85 @@ +{-# LANGUAGE RecordWildCards #-} + import Affection -import Affection.Render +import qualified SDL +import qualified SDL.Raw as Raw +import qualified GEGL as G +import qualified BABL as B +import qualified Data.Map.Strict as M + +import Foreign.Storable (peek) +import Foreign.C.Types (CInt(..)) + +import Debug.Trace + +-- main :: IO () +-- main = withAllAffection $ +-- withDefaultWindow "test" $ do +-- changeColor $ RGBA 255 255 255 255 +-- clear +-- present +-- liftIO $ delaySec 2 main :: IO () -main = withAllAffection $ - withDefaultWindow "test" $ do - changeColor $ RGBA 255 255 255 255 - clear - present - liftIO $ delaySec 2 +main = do + conf <- return $ AffectionConfig + { initComponents = All + , windowTitle = "Affection: example00" + , windowConfig = SDL.defaultWindow + , drawLoop = draw + , updateLoop = update + , loadState = load + } + withAffection conf + +type UserData = M.Map String G.GeglNode + +load :: SDL.Surface -> IO UserData +load _ = do + traceM "loading" + root <- G.gegl_node_new + traceM "new root node" + checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation + [ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1 + , G.Property "color2" $ G.PropertyColor $ G.RGBA 0.6 0.6 0.6 1 + ] + traceM "checkerboard" + myMap <- return $ M.fromList + [ ("root" , root) + , ("checkerboard", checkerboard) + ] + traceM "loading complete" + return myMap + +draw :: AffectionState (AffectionData UserData) IO () +draw = do + traceM "drawing" + AffectionData{..} <- get + liftIO $ SDL.lockSurface drawSurface + pixels <- liftIO $ SDL.surfacePixels drawSurface + let SDL.Surface rawSurfacePtr _ = drawSurface + rawSurface <- liftIO $ peek rawSurfacePtr + pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface + format <- liftIO $ (B.babl_format $ B.PixelFormat B.R'G'B'A B.CFu8) + SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface + let (w, h) = (fromIntegral rw, fromIntegral rh) + liftIO $ G.gegl_node_blit + (userState M.! "checkerboard" :: G.GeglNode) + 1 + (G.GeglRectangle 0 0 w h) + format + pixels + (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w) + [G.GeglBlitDefault] + liftIO $ SDL.unlockSurface drawSurface + liftIO $ SDL.updateWindowSurface drawWindow + +update :: Double -> AffectionState (AffectionData UserData) IO () +update sec = do + traceM "updating" + -- traceM $ show sec + -- liftIO $ delaySec 5 + -- ud@AffectionData{..} <- get + -- put $ ud + -- { quitEvent = True + -- } diff --git a/src/Affection.hs b/src/Affection.hs index ce4aad1..756ef9c 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -4,6 +4,8 @@ module Affection , withWindow , withDefaultWindow , delaySec + , get + , put , module Affection.Render , module Types ) where @@ -31,30 +33,33 @@ withAffection conf@AffectionConfig{..} = do SDL.initializeAll Only is -> SDL.initialize is + G.gegl_init execTime <- newMVar =<< getTime Monotonic window <- SDL.createWindow windowTitle windowConfig surface <- SDL.getWindowSurface window - initContainer <- return $ AffectionData - { affectionConfig = conf - , quitEvent = False - , userState = userData + initContainer <- return . (\x -> AffectionData + -- { affectionConfig = conf + { quitEvent = False + , userState = x , drawWindow = window , drawSurface = surface - } - state <- newMVar initContainer + }) =<< loadState surface (res, nState) <- runStateT ( Types.runState $ whileM_ (do current <- get - return $ Types.quitEvent current + return $ not $ Types.quitEvent current ) - $ do + (do now <- liftIO $ getTime Monotonic lastTime <- liftIO $ fromMaybe now <$> tryReadMVar execTime drawLoop updateLoop $ (fromIntegral $ toNanoSecs $ diffTimeSpec lastTime now) / (fromIntegral 10 ^ 9) - liftIO $ putMVar execTime $ now + _ <- liftIO $ swapMVar execTime $ now + return () + ) ) initContainer + G.gegl_exit SDL.quit withWindow :: Monad m => T.Text -> WindowConfig -> SDL.RendererConfig -> RenderT m a -> IO () diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 3cf0e65..eca0baf 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -26,18 +26,24 @@ 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 (AffectionData us) IO (IO ()) -- ^ main update function. Takes nanoseconds as input. - , userData :: us + { initComponents :: InitComponents + -- ^ SDL components to initialize at startup + , windowTitle :: T.Text + -- ^ Window title + , windowConfig :: SDL.WindowConfig + -- ^ Window configuration + , drawLoop :: AffectionState (AffectionData us) IO () + -- ^ Function for updating graphics. + , updateLoop :: Double -> AffectionState (AffectionData us) IO () + -- ^ Main update function. Takes fractions of a second as input. + , loadState :: SDL.Surface -> IO us + -- ^ Provide your own load function to create this data. } -- | 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. + -- { 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