on how not to do it

This commit is contained in:
nek0 2017-03-20 05:26:24 +01:00
parent 9744ebcf99
commit 33ca2220ea
2 changed files with 186 additions and 0 deletions

View file

@ -122,6 +122,23 @@ executable example02
else else
buildable: False buildable: False
executable example02.1
hs-source-dirs: examples
main-is: example02.1.hs
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
build-depends: base
, affection
, sdl2
, gegl
, babl
, containers
, mtl
else
buildable: False
executable example03 executable example03
hs-source-dirs: examples hs-source-dirs: examples
main-is: example03.hs main-is: example03.hs

169
examples/example02.1.hs Normal file
View file

@ -0,0 +1,169 @@
{-# LANGUAGE RecordWildCards #-}
import Affection
import qualified SDL
import qualified GEGL as G
import qualified BABL as B
import qualified Data.Map.Strict as M
import Debug.Trace
main :: IO ()
main = do
conf <- return $ AffectionConfig
{ initComponents = All
, windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow
, preLoop = return ()
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, loadState = load
, cleanUp = clean
}
withAffection conf
data UserData = UserData
-- { nodeGraph :: M.Map String G.GeglNode
-- , foreground :: G.GeglBuffer
-- , lastTick :: Double
-- }
{ coordinates :: (Double, Double)
, lastTick :: Double
}
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 $
-- props $ do
-- prop "color1" $ G.RGBA 0.4 0.4 0.4 1
-- prop "color2" $ G.RGBA 0.6 0.6 0.6 1
-- traceM "checkerboard"
-- over <- G.gegl_node_new_child root G.defaultOverOperation
-- traceM "over"
-- buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
-- B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
-- sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
-- props $
-- prop "buffer" buffer
-- traceM "buffer-sink"
-- rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $
-- props $ do
-- prop "x" (0::Double)
-- prop "y" (0::Double)
-- prop "width" (20::Double)
-- prop "height" (20::Double)
-- prop "color" $ G.RGBA 1 0 0 0.5
-- traceM "rect"
-- crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
-- props $ do
-- prop "width" (800::Double)
-- prop "height" (600::Double)
-- G.gegl_node_link_many [checkerboard, over, crop, sink]
-- _ <- G.gegl_node_connect_to rect "output" over "aux"
-- traceM "connections made"
-- myMap <- return $ M.fromList
-- [ ("root" , root)
-- , ("over" , over)
-- , ("background" , checkerboard)
-- , ("sink" , sink)
-- , ("rect" , rect)
-- , ("crop" , crop)
-- ]
-- traceM "loading complete"
-- return $ UserData
-- { nodeGraph = myMap
-- , foreground = buffer
-- , lastTick = 0
-- }
return $ UserData
{ coordinates = (400, 300)
, lastTick = 0
}
-- drawInit :: Affection UserData ()
-- drawInit = do
-- UserData{..} <- getAffection
-- present (GeglRectangle 0 0 800 600) foreground True
draw :: Affection UserData ()
draw = do
UserData{..} <- getAffection
traceM "loading"
root <- liftIO $ G.gegl_node_new
traceM "new root node"
checkerboard <- liftIO $ G.gegl_node_new_child root $ G.checkerboardOperation $
props $ do
prop "color1" $ G.RGBA 0.4 0.4 0.4 1
prop "color2" $ G.RGBA 0.6 0.6 0.6 1
traceM "checkerboard"
over <- liftIO $ G.gegl_node_new_child root G.defaultOverOperation
traceM "over"
buffer <- liftIO $ G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
sink <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
props $
prop "buffer" buffer
traceM "buffer-sink"
rect <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $
props $ do
prop "x" $ fst coordinates
prop "y" $ snd coordinates
prop "width" (20::Double)
prop "height" (20::Double)
prop "color" $ G.RGBA 1 0 0 0.5
traceM "rect"
crop <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:crop" $
props $ do
prop "width" (800::Double)
prop "height" (600::Double)
liftIO $ G.gegl_node_link_many [checkerboard, over, crop, sink]
_ <- liftIO $ G.gegl_node_connect_to rect "output" over "aux"
traceM "connections made"
myMap <- return $ M.fromList
[ ("root" , root)
, ("over" , over)
, ("background" , checkerboard)
, ("sink" , sink)
, ("rect" , rect)
, ("crop" , crop)
]
traceM "loading complete"
process (myMap M.! "sink")
present (GeglRectangle 0 0 800 600) buffer True
update :: Affection UserData ()
update = do
traceM "updating"
tick <- getElapsedTime
ud <- getAffection
putAffection $ ud { lastTick = tick }
let dt = tick - lastTick ud
return ()
traceM $ (show $ 1 / dt) ++ " FPS"
handle (SDL.MouseMotionEvent dat) = do
let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat
ud <- getAffection
putAffection ud
{ coordinates = (fromIntegral (x - 10), fromIntegral (y - 10))
}
-- liftIO $ G.gegl_node_set (nodeGraph ud M.! "rect") $ G.Operation "" $
-- props $ do
-- prop "x" (fromIntegral (x - 10) :: Double)
-- prop "y" $ (fromIntegral (y - 10) :: Double)
handle (SDL.WindowClosedEvent _) = do
traceM "seeya!"
quit
handle _ =
return ()
clean :: UserData -> IO ()
clean _ = return ()