{-# 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 = 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 :: Affection UserData () 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 $ drawRect foreground (G.RGB 1 0 0) (Line 2) (G.GeglRectangle 10 10 500 500) 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 ()