diff --git a/affection.cabal b/affection.cabal index 1ec0293..8b3959c 100644 --- a/affection.cabal +++ b/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 diff --git a/examples/example04.hs b/examples/example04.hs index a720487..dcd1335 100644 --- a/examples/example04.hs +++ b/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 () diff --git a/examples/example04/panorama.jpg b/examples/example04/panorama.jpg new file mode 100644 index 0000000..9ed5014 Binary files /dev/null and b/examples/example04/panorama.jpg differ