starting work on new example

affection.cabal

@@ -77,14 +77,19 @@ executable example00
   else
     buildable:       False
 
--- executable example01
+executable example01
---   hs-source-dirs:    examples
+  hs-source-dirs:    examples
---   main-is:           example01.hs
+  main-is:           example01.hs
---   ghc-options:       -threaded -Wall
+  ghc-options:       -threaded -Wall
---   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
---   else
+                     , sdl2
---     buildable:       False
+                     , gegl
+                     , babl
+                     , containers
+                     , mtl
+  else
+    buildable:       False

examples/example01.hs

@@ -1,9 +1,164 @@
+{-# LANGUAGE RecordWildCards #-}
+
 import Affection
+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
+
+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 $
+main = do
-  withDefaultWindow "test" $ do
+  conf <- return $ AffectionConfig
-    changeColor $ RGBA 255 255 255 255
+    { initComponents = All
-    clear
+    , windowTitle    = "Affection: example00"
-    present
+    , windowConfig   = SDL.defaultWindow
-    liftIO $ delaySec 2
+    , drawLoop       = draw
+    , updateLoop     = update
+    , loadState      = load
+    , cleanUp        = clean
+    }
+  withAffection conf
+
+data UserData = UserData
+  { nodeGraph   :: M.Map String G.GeglNode
+  , foreground  :: G.GeglBuffer
+  , elapsedTime :: 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
+    [ 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"
+  over <- G.gegl_node_new_child root G.defaultOverOperation
+  traceM "over"
+  buffer <- G.gegl_buffer_new (G.GeglRectangle 0 0 20 20) =<<
+    B.babl_format (B.PixelFormat B.RGBA B.CFfloat)
+  bufsrc <- G.gegl_node_new_child root $ G.bufferSourceOperation
+    [ G.Property "buffer" $ G.PropertyBuffer buffer
+    ]
+  traceM "buffer-source"
+  G.gegl_node_link checkerboard over
+  G.gegl_node_connect_to bufsrc "output" over "aux"
+  traceM "connections made"
+  myMap <- return $ M.fromList
+    [ ("root"        , root)
+    , ("over"        , over)
+    , ("background"  , checkerboard)
+    , ("foreground"  , bufsrc)
+    ]
+  let roi = G.GeglRectangle 0 0 20 20
+  G.iterateOver
+    buffer
+    roi
+    (B.PixelFormat B.RGBA B.CFfloat)
+    G.GeglAccessReadWrite
+    G.GeglAbyssNone
+    (\(G.Pixel px py pc) ->
+      let dsqr = (((10 - px) ^ 2) + ((10 - py) ^ 2))
+          (G.CVfloat (CFloat pr), G.CVfloat (CFloat pg), G.CVfloat (CFloat pb), G.CVfloat (CFloat pa)) = pc
+          dist = (sqrt (fromIntegral dsqr :: Float))
+      in if dsqr < 100
+        then
+          if dist < fromIntegral 9
+            then
+              G.Pixel px py
+                ( G.CVfloat $ CFloat 0
+                , G.CVfloat $ CFloat 0
+                , G.CVfloat $ CFloat 0
+                , G.CVfloat $ CFloat $ if pa < 1 then 1 else pa
+                )
+            else
+              let alpha = fromIntegral 10 - dist
+                  dst_a = pa
+                  a = alpha + dst_a * (1 - alpha)
+                  a_term = dst_a * (1 - alpha)
+                  red = 0 * alpha + pr * a_term
+                  gre = 0 * alpha + pg * a_term
+                  blu = 0 * alpha + pb * a_term
+              in
+                G.Pixel px py
+                  ( G.CVfloat $ CFloat $ red / a
+                  , G.CVfloat $ CFloat $ gre / a
+                  , G.CVfloat $ CFloat $ blu / a
+                  , G.CVfloat $ CFloat $ if pa < alpha then alpha else pa
+                  )
+      else
+        G.Pixel px py pc
+    )
+  traceM "loading complete"
+  return $ UserData
+    { nodeGraph = myMap
+    , foreground = buffer
+    , elapsedTime = 0
+    }
+
+draw :: AffectionState (AffectionData UserData) IO ()
+draw = do
+  traceM "drawing"
+  AffectionData{..} <- get
+  let UserData{..} = userState
+  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.RGBA B.CFu8)
+  SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface
+  let (w, h) = (fromIntegral rw, fromIntegral rh)
+  liftIO $ G.gegl_node_blit
+    (nodeGraph M.! "over" :: 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"
+  -- liftIO $ delaySec 5
+  ad@AffectionData{..} <- get
+  let ud@UserData{..} = userState
+  traceM $ show elapsedTime
+  if elapsedTime < 5
+  then do
+    fg <- liftIO $ G.gegl_buffer_get_extent foreground
+    _ <- liftIO $ G.gegl_buffer_set_extent foreground $ fg
+      { G.rectangleX = G.rectangleX fg + 1
+      , G.rectangleY = G.rectangleY fg + 1
+      }
+    put $ ad
+      { userState = ud
+        { elapsedTime = elapsedTime + sec
+        }
+      }
+  else
+    put $ ad
+      { quitEvent = True
+      }
+
+clean :: UserData -> IO ()
+clean _ = return ()