example04 (side scrolling example) finished

This commit is contained in:
nek0 2017-03-21 18:01:58 +01:00
parent efbfe14fe8
commit 22877d239b
3 changed files with 204 additions and 90 deletions

View file

@ -158,20 +158,21 @@ executable example03
else else
buildable: False buildable: False
-- executable example04 executable example04
-- hs-source-dirs: examples hs-source-dirs: examples
-- main-is: example04.hs main-is: example04.hs
-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts
-- default-language: Haskell2010 default-language: Haskell2010
-- default-extensions: OverloadedStrings default-extensions: OverloadedStrings
-- if flag(examples) if flag(examples)
-- build-depends: base build-depends: base
-- , affection , affection
-- , sdl2 , sdl2
-- , gegl , gegl
-- , babl , babl
-- , containers , containers
-- , mtl , mtl
-- , random , random
-- else , monad-parallel
-- buildable: False else
buildable: False

View file

@ -4,117 +4,230 @@ import Affection
import qualified SDL import qualified SDL
import qualified GEGL as G import qualified GEGL as G
import qualified BABL as B import qualified BABL as B
import qualified BABL.FFI.Format as B
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.List as L
import Foreign.C.Types import Data.Maybe (fromJust)
import Foreign.Ptr (castPtr, nullPtr) import Control.Monad (when)
import Foreign.Marshal.Utils (new) import qualified Control.Monad.Parallel as MP
import System.Random (randomRIO)
import Control.Monad (unless)
import Debug.Trace import Debug.Trace
main :: IO () main :: IO ()
main = do main = do
conf <- return $ AffectionConfig conf <- return AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Affection: example00" , windowTitle = "Affection: example00"
, windowConfig = SDL.defaultWindow , windowConfig = SDL.defaultWindow
, preLoop = return () , preLoop = return ()
, drawLoop = draw , eventLoop = handle
, updateLoop = update , updateLoop = update
, drawLoop = draw
, loadState = load , loadState = load
, cleanUp = clean , cleanUp = clean
} }
withAffection conf withAffection conf
data UserData = UserData data UserData = UserData
{ nodeGraph :: M.Map String G.GeglNode { nodeGraph :: M.Map String G.GeglNode
, coordinates :: Maybe (Int, Int) , actors :: M.Map String (Actor String)
, foreground :: G.GeglBuffer
, lastTick :: Double
, updateActors :: [Actor String]
} }
load :: SDL.Surface -> IO UserData load :: SDL.Surface -> IO UserData
load surface = do load _ = do
traceM "loading" traceM "loading"
root <- G.gegl_node_new root <- G.gegl_node_new
traceM "new root node" traceM "new root node"
checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation let bgProps = props $ prop "path" ("examples/example04/panorama.jpg" :: String)
[ G.Property "color1" $ G.PropertyColor $ G.RGBA 0.4 0.4 0.4 1 bg <- G.gegl_node_new_child root $ G.Operation "gegl:jpg-load" bgProps
, G.Property "color2" $ G.PropertyColor $ G.RGBA 0.6 0.6 0.6 1 bgScaleProps <- return $ props $ do
] prop "y" (600 :: Double)
traceM "checkerboard" prop "sampler" (fromEnum G.GeglSamplerCubic)
bgScale <- G.gegl_node_new_child root $
G.Operation "gegl:scale-size-keepaspect" bgScaleProps
bgTransProps <- return $ props $ do
prop "x" (0 :: Double)
prop "y" (0 :: Double)
prop "sampler" (fromEnum G.GeglSamplerCubic)
bgTrans <- G.gegl_node_new_child root $ G.Operation "gegl:translate" bgTransProps
traceM "background"
over <- G.gegl_node_new_child root G.defaultOverOperation over <- G.gegl_node_new_child root G.defaultOverOperation
traceM "over" traceM "over"
nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<<
traceM "nop" B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" sink <- G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $
[ G.Property "x" $ G.PropertyDouble 0 props $
, G.Property "y" $ G.PropertyDouble 0 prop "buffer" buffer
, G.Property "width" $ G.PropertyDouble 800 traceM "buffer-sink"
, G.Property "height" $ G.PropertyDouble 600 rectProps <- return $ props $ do
] prop "x" (50 :: Double)
traceM "crop" prop "y" (290 :: Double)
format <- B.babl_format $ B.PixelFormat B.RGBA B.CFu8 prop "width" (20::Double)
pixels <- liftIO $ new =<< SDL.surfacePixels surface prop "height" (20::Double)
sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink" prop "color" $ G.RGBA 1 0 0 0.5
[ G.Property "buffer" $ G.PropertyPointer $ castPtr $ pixels rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" rectProps
, G.Property "format" $ G.PropertyPointer $ nullPtr traceM "rect"
] crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $
traceM "sink" props $ do
G.gegl_node_link_many [checkerboard, over, crop, sink] prop "width" (800::Double)
diw <- G.gegl_node_connect_to nop "output" over "aux" prop "height" (600::Double)
unless diw (error "connect failed") G.gegl_node_link_many [bg, bgTrans, bgScale, over, crop, sink]
_ <- G.gegl_node_connect_to rect "output" over "aux"
rectActor <- return $ Actor (map
(\p -> ActorProperty
(G.propertyName p)
(G.propertyValue p)
(Just "rect")
)rectProps
) (M.singleton "rect" rect)
bgActor <- return $ Actor (map
(\p -> ActorProperty
(G.propertyName p)
(G.propertyValue p)
(Just "bg")
)bgProps ++
map (\p -> ActorProperty
(G.propertyName p)
(G.propertyValue p)
(Just "scale")
) bgScaleProps ++
map (\p -> ActorProperty
(G.propertyName p)
(G.propertyValue p)
(Just "trans")
) bgTransProps
) (M.fromList
[ ("bg", bg)
, ("trans", bgTrans)
, ("scale", bgScale)
])
traceM "connections made" traceM "connections made"
myMap <- return $ M.fromList myMap <- return $ M.fromList
[ ("root" , root) [ ("root" , root)
, ("over" , over) , ("over" , over)
, ("background" , checkerboard) , ("background" , bg)
, ("nop" , nop)
, ("crop" , crop)
, ("sink" , sink) , ("sink" , sink)
, ("rect" , rect)
, ("crop" , crop)
] ]
traceM "loading complete" traceM "loading complete"
return $ UserData actorMap <- return $ M.fromList
{ nodeGraph = myMap [ ("rect", rectActor)
, coordinates = Nothing , ("background", bgActor)
]
return UserData
{ nodeGraph = myMap
, actors = actorMap
, foreground = buffer
, lastTick = 0
, updateActors = []
} }
update :: Double -> AffectionState (AffectionData UserData) IO () -- drawInit :: Affection UserData ()
update sec = do -- drawInit = do
traceM "updating" -- UserData{..} <- getAffection
ad <- get -- present (GeglRectangle 0 0 800 600) foreground True
ud <- getAffection
traceM $ (show $ 1 / sec) ++ " FPS"
ev <- liftIO $ SDL.pollEvents
mapM_ (\e ->
case SDL.eventPayload e of
SDL.MouseButtonEvent dat -> do
let (SDL.P (SDL.V2 x y)) = SDL.mouseButtonEventPos dat
drawRect
(nodeGraph ud M.! "nop")
(G.RGBA 1 0 0 0.5)
Fill
(G.GeglRectangle (fromIntegral x - 10) (fromIntegral y - 10) 20 20)
traceM $ "drewn a rectangle at " ++ show x ++ " " ++ show y
SDL.WindowClosedEvent _ -> do
traceM "seeya!"
put $ ad
{ quitEvent = True
}
_ ->
return ()
) ev
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
ad <- get ud@UserData{..} <- getAffection
MP.mapM_ applyProperties updateActors
putAffection ud
{ updateActors = []
}
process (nodeGraph M.! "sink")
present (GeglRectangle 0 0 800 600) foreground True
update :: Affection UserData ()
update = do
traceM "updating"
tick <- getElapsedTime
ud <- getAffection ud <- getAffection
liftIO $ SDL.lockSurface $ drawSurface ad putAffection $ ud { lastTick = tick }
liftIO $ G.gegl_node_process (nodeGraph ud M.! "sink")
liftIO $ SDL.unlockSurface $ drawSurface ad let dt = tick - lastTick ud
return ()
traceM $ show (1 / dt) ++ " FPS"
handle :: SDL.EventPayload -> Affection UserData ()
handle (SDL.KeyboardEvent dat) =
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
ud <- getAffection
(G.PropertyDouble xpos) <-
return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
actorProperties $ actors ud M.! "rect"
if xpos >= 40 && xpos <= 760
then do
nmap <- return $ M.adjust
(updateProperties $ props $ prop "x" $
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft -> xpos - 5
SDL.KeycodeRight -> xpos + 5
_ -> xpos
)
"rect"
(actors ud)
putAffection ud
{ actors = nmap
, updateActors = (nmap M.! "rect") : updateActors ud
}
else do
(G.PropertyDouble bgPos) <-
return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $
actorProperties $ actors ud M.! "background"
nmap <- return $ M.adjust
(updateProperties $ props $ prop "x" $
if xpos < 40
then
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft ->
if bgPos <= 0 then bgPos + 5 else bgPos
SDL.KeycodeRight ->
bgPos
_ -> bgPos
else
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft ->
bgPos
SDL.KeycodeRight ->
if True {- TODO: CHANGE-} then bgPos - 5 else bgPos
_ -> bgPos
)
"background"
(actors ud)
nmap2 <- return $ M.adjust
(updateProperties $ props $ prop "x" $
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft ->
if xpos < 40
then
xpos
else
xpos - 5
SDL.KeycodeRight ->
if xpos < 40
then
xpos + 5
else
xpos
_ -> xpos
)
"rect"
nmap
putAffection ud
{ actors = nmap2
, updateActors = (nmap2 M.! "background") : (nmap2 M.! "rect") : updateActors ud
}
handle (SDL.WindowClosedEvent _) = do
traceM "seeya!"
quit
handle _ =
return ()
clean :: UserData -> IO () clean :: UserData -> IO ()
clean _ = return () clean _ = return ()

Binary file not shown.

After

Width:  |  Height:  |  Size: 400 KiB