get first example somewhat working

This commit is contained in:
nek0 2016-11-04 16:06:16 +01:00
parent 6ff8df056b
commit f50bd1afe8
4 changed files with 115 additions and 24 deletions

View file

@ -68,6 +68,11 @@ executable example00
if flag(examples)
build-depends: base
, affection
, sdl2
, gegl
, babl
, containers
, mtl
else
buildable: False

View file

@ -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
-- }

View file

@ -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 ()

View file

@ -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