example04 (side scrolling example) finished

affection.cabal

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

examples/example04.hs

@@ -4,117 +4,230 @@ import Affection
 import qualified SDL
 import qualified GEGL as G
 import qualified BABL as B
-import qualified BABL.FFI.Format as B
 import qualified Data.Map.Strict as M
-
-import Foreign.C.Types
-import Foreign.Ptr (castPtr, nullPtr)
-import Foreign.Marshal.Utils (new)
-
-import System.Random (randomRIO)
-
-import Control.Monad (unless)
+import Data.List as L
+import Data.Maybe (fromJust)
+import Control.Monad (when)
+import qualified Control.Monad.Parallel as MP
 
 import Debug.Trace
 
 main :: IO ()
 main = do
-  conf <- return $ AffectionConfig
+  conf <- return AffectionConfig
     { initComponents = All
     , windowTitle    = "Affection: example00"
     , windowConfig   = SDL.defaultWindow
     , preLoop        = return ()
-    , drawLoop       = draw
+    , eventLoop      = handle
     , updateLoop     = update
+    , drawLoop       = draw
     , loadState      = load
     , cleanUp        = clean
     }
   withAffection conf
 
 data UserData = UserData
-  { nodeGraph   :: M.Map String G.GeglNode
-  , coordinates :: Maybe (Int, Int)
+  { nodeGraph    :: M.Map String G.GeglNode
+  , actors       :: M.Map String (Actor String)
+  , foreground   :: G.GeglBuffer
+  , lastTick     :: Double
+  , updateActors :: [Actor String]
   }
 
 load :: SDL.Surface -> IO UserData
-load surface = do
+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"
+  let bgProps = props $ prop "path" ("examples/example04/panorama.jpg" :: String)
+  bg <- G.gegl_node_new_child root $ G.Operation "gegl:jpg-load" bgProps
+  bgScaleProps <- return $  props $ do
+    prop "y" (600 :: Double)
+    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
   traceM "over"
-  nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" []
-  traceM "nop"
-  crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop"
-    [ G.Property "x" $ G.PropertyDouble 0
-    , G.Property "y" $ G.PropertyDouble 0
-    , G.Property "width" $ G.PropertyDouble 800
-    , G.Property "height" $ G.PropertyDouble 600
-    ]
-  traceM "crop"
-  format <- B.babl_format $ B.PixelFormat B.RGBA B.CFu8
-  pixels <- liftIO $ new =<< SDL.surfacePixels surface
-  sink <- G.gegl_node_new_child root $ G.Operation "gegl:buffer-sink"
-    [ G.Property "buffer" $ G.PropertyPointer $ castPtr $ pixels
-    , G.Property "format" $ G.PropertyPointer $ nullPtr
-    ]
-  traceM "sink"
-  G.gegl_node_link_many [checkerboard, over, crop, sink]
-  diw <- G.gegl_node_connect_to nop "output" over "aux"
-  unless diw (error "connect failed")
+  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"
+  rectProps <- return $ props $ do
+    prop "x" (50 :: Double)
+    prop "y" (290 :: Double)
+    prop "width" (20::Double)
+    prop "height" (20::Double)
+    prop "color" $ G.RGBA 1 0 0 0.5
+  rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" rectProps
+  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 [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"
   myMap <- return $ M.fromList
     [ ("root"        , root)
     , ("over"        , over)
-    , ("background"  , checkerboard)
-    , ("nop"         , nop)
-    , ("crop"        , crop)
+    , ("background"  , bg)
     , ("sink"        , sink)
+    , ("rect"        , rect)
+    , ("crop"        , crop)
     ]
   traceM "loading complete"
-  return $ UserData
-    { nodeGraph = myMap
-    , coordinates = Nothing
+  actorMap <- return $ M.fromList
+    [ ("rect", rectActor)
+    , ("background", bgActor)
+    ]
+  return UserData
+    { nodeGraph    = myMap
+    , actors       = actorMap
+    , foreground   = buffer
+    , lastTick     = 0
+    , updateActors = []
     }
 
-update :: Double -> AffectionState (AffectionData UserData) IO ()
-update sec = do
-  traceM "updating"
-  ad <- get
-  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
+-- drawInit :: Affection UserData ()
+-- drawInit = do
+--   UserData{..} <- getAffection
+--   present (GeglRectangle 0 0 800 600) foreground True
 
 draw :: Affection UserData ()
 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
-  liftIO $ SDL.lockSurface $ drawSurface ad
-  liftIO $ G.gegl_node_process (nodeGraph ud M.! "sink")
-  liftIO $ SDL.unlockSurface $ drawSurface ad
+  putAffection $ ud { lastTick = tick }
+
+  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 _ = return ()