{-# LANGUAGE RecordWildCards #-} import Affection import qualified SDL import qualified GEGL as G import qualified BABL as B import qualified Data.Map.Strict as M 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 { initComponents = All , windowTitle = "Affection: example00" , windowConfig = SDL.defaultWindow , preLoop = return () , eventLoop = handle , updateLoop = update , drawLoop = draw , loadState = load , cleanUp = clean } withAffection conf data UserData = UserData { 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 _ = do traceM "loading" root <- G.gegl_node_new traceM "new root node" 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" 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" , bg) , ("sink" , sink) , ("rect" , rect) , ("crop" , crop) ] traceM "loading complete" actorMap <- return $ M.fromList [ ("rect", rectActor) , ("background", bgActor) ] return UserData { nodeGraph = myMap , actors = actorMap , foreground = buffer , lastTick = 0 , updateActors = [] } -- drawInit :: Affection UserData () -- drawInit = do -- UserData{..} <- getAffection -- present (GeglRectangle 0 0 800 600) foreground True draw :: Affection UserData () draw = do 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 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 - 20 SDL.KeycodeRight -> xpos + 20 _ -> 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 + 20 else bgPos SDL.KeycodeRight -> bgPos _ -> bgPos else case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of SDL.KeycodeLeft -> bgPos SDL.KeycodeRight -> if bgPos >= -2489 then bgPos - 20 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 - 20 SDL.KeycodeRight -> if xpos < 40 then xpos + 20 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 ()