diff --git a/affection.cabal b/affection.cabal index db5ea25..5aea7e6 100644 --- a/affection.cabal +++ b/affection.cabal @@ -77,14 +77,19 @@ executable example00 else buildable: False --- executable example01 --- hs-source-dirs: examples --- main-is: example01.hs --- ghc-options: -threaded -Wall --- default-language: Haskell2010 --- default-extensions: OverloadedStrings --- if flag(examples) --- build-depends: base --- , affection --- else --- buildable: False +executable example01 + hs-source-dirs: examples + main-is: example01.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 diff --git a/examples/example01.hs b/examples/example01.hs index b0050b5..35606e3 100644 --- a/examples/example01.hs +++ b/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 $ - 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 + , 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 ()