diff --git a/examples/example00.hs b/examples/example00.hs deleted file mode 100644 index c9090b8..0000000 --- a/examples/example00.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -import Affection -import qualified SDL - -import Control.Concurrent.STM -import Control.Monad.IO.Class (liftIO) - -newtype StateData = StateData - { sdSubs :: Subsystems - } - -data Subsystems = Subsystems - { subWindow :: Window - , subMouse :: Mouse - , subKeyboard :: Keyboard - } - -newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) -newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) -newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) - -generalSubscribe - :: TVar [(UUID, msg -> Affection StateData ())] - -> (msg -> Affection StateData()) - -> Affection StateData UUID -generalSubscribe t funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return uuid - -instance Participant Window StateData where - type Mesg Window StateData = WindowMessage - - partSubscribers (Window t) = do - subTups <- liftIO $ readTVarIO t - return $ map snd subTups - - partSubscribe (Window t) = generalSubscribe t - - partUnSubscribe (Window t) uuid = - liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) - -instance SDLSubsystem Window StateData where - consumeSDLEvents = consumeSDLWindowEvents - -instance Participant Mouse StateData where - type Mesg Mouse StateData = MouseMessage - - partSubscribers (Mouse t) = do - subTups <- liftIO $ readTVarIO t - return $ map snd subTups - - partSubscribe (Mouse t) = generalSubscribe t - - partUnSubscribe (Mouse t) uuid = - liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) - -instance SDLSubsystem Mouse StateData where - consumeSDLEvents = consumeSDLMouseEvents - -instance Participant Keyboard StateData where - type Mesg Keyboard StateData = KeyboardMessage - - partSubscribers (Keyboard t) = do - subTups <- liftIO $ readTVarIO t - return $ map snd subTups - - partSubscribe (Keyboard t) = generalSubscribe t - - partUnSubscribe (Keyboard t) uuid = - liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) - -instance SDLSubsystem Keyboard StateData where - consumeSDLEvents = consumeSDLKeyboardEvents - -main :: IO () -main = do - logIO Debug "Starting" - let conf = AffectionConfig - { initComponents = All - , windowTitle = "affection: example00" - , windowConfig = SDL.defaultWindow - { SDL.windowOpenGL = Just SDL.defaultOpenGL - { SDL.glProfile = SDL.Core SDL.Normal 3 3 - } - } - , initScreenMode = SDL.Windowed - , canvasSize = Nothing - , loadState = load - , preLoop = pre - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , cleanUp = clean - } - withAffection conf - -load :: IO StateData -load = do - empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())]) - empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) - empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) - return $ StateData $ Subsystems - (Window empty1) - (Mouse empty2) - (Keyboard empty3) - -pre :: Affection StateData () -pre = do - sd <- getAffection - _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ - _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose - return () - -exitOnQ :: KeyboardMessage -> Affection StateData () -exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = - case SDL.keysymKeycode sym of - SDL.KeycodeQ -> do - liftIO $ logIO Debug "Yo dog I heard..." - quit - _ -> return () - -exitOnWindowClose :: WindowMessage -> Affection StateData () -exitOnWindowClose wm = - case wm of - MsgWindowClose _ _ -> do - liftIO $ logIO Debug "I heard another one..." - quit - _ -> return () - -handle :: [SDL.EventPayload] -> Affection StateData () -handle es = do - (Subsystems a b c) <- sdSubs <$> getAffection - _ <- consumeSDLEvents a es - _ <- consumeSDLEvents b es - _ <- consumeSDLEvents c es - return () - -update _ = return () - -draw = return () - -clean _ = return () diff --git a/examples/example01.hs b/examples/example01.hs deleted file mode 100644 index 3380349..0000000 --- a/examples/example01.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# 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 Control.Monad (when) - -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 - , preLoop = return () - , eventLoop = const $ return () - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - , canvasSize = Nothing - } - withAffection conf - -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - , foreground :: G.GeglBuffer - -- , lastTick :: Double - } - -load :: IO UserData -load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ 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 (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-source" - nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] - traceM "nop" - crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - props $ do - prop "width" (800::Double) - prop "height" (600.0::Double) - G.gegl_node_link_many [checkerboard, over, crop, sink] - G.gegl_node_connect_to nop "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , checkerboard) - , ("sink" , sink) - , ("nop" , nop) - ] - let roi = G.GeglRectangle 0 0 20 20 - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - , foreground = buffer - -- , lastTick = 0 - } - -draw :: Affection UserData () -draw = do - traceM "drawing" - UserData{..} <- getAffection - drawRect (nodeGraph M.! "nop") (G.RGB 1 0 0) Fill (G.GeglRectangle 10 10 500 500) foreground - process $ nodeGraph M.! "sink" - render Nothing Nothing - -update :: Double -> Affection UserData () -update dt = do - traceM "updating" - ud <- getAffection - -- let last = lastTick ud - -- tick <- getTick - -- putAffection $ ud { lastTick = tick } - traceM $ (show $ 1 / dt) ++ " FPS" - elapsed <- getElapsedTime - when (elapsed > 20) $ - quit - -clean :: UserData -> IO () -clean _ = return () diff --git a/examples/example02.1.hs b/examples/example02.1.hs deleted file mode 100644 index 2f2c48c..0000000 --- a/examples/example02.1.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# 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 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 - , canvasSize = Nothing - } - withAffection conf - -data UserData = UserData - -- { nodeGraph :: M.Map String G.GeglNode - -- , foreground :: G.GeglBuffer - -- , lastTick :: Double - -- } - { coordinates :: (Double, Double) - , lastTick :: Double - } - -load :: IO UserData -load = do - -- traceM "loading" - -- root <- G.gegl_node_new - -- traceM "new root node" - -- checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - -- props $ do - -- prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - -- prop "color2" $ 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 (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" - -- rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $ - -- props $ do - -- prop "x" (0::Double) - -- prop "y" (0::Double) - -- prop "width" (20::Double) - -- prop "height" (20::Double) - -- prop "color" $ G.RGBA 1 0 0 0.5 - -- 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 [checkerboard, over, crop, sink] - -- _ <- G.gegl_node_connect_to rect "output" over "aux" - -- traceM "connections made" - -- myMap <- return $ M.fromList - -- [ ("root" , root) - -- , ("over" , over) - -- , ("background" , checkerboard) - -- , ("sink" , sink) - -- , ("rect" , rect) - -- , ("crop" , crop) - -- ] - -- traceM "loading complete" - -- return $ UserData - -- { nodeGraph = myMap - -- , foreground = buffer - -- , lastTick = 0 - -- } - return $ UserData - { coordinates = (400, 300) - , lastTick = 0 - } - --- drawInit :: Affection UserData () --- drawInit = do --- UserData{..} <- getAffection --- present (GeglRectangle 0 0 800 600) foreground True - -draw :: Affection UserData () -draw = do - UserData{..} <- getAffection - traceM "loading" - root <- liftIO $ G.gegl_node_new - traceM "new root node" - checkerboard <- liftIO $ G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- liftIO $ G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - buffer <- liftIO $ G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 800 600) =<< - B.babl_format (B.PixelFormat B.RGBA B.CFfloat) - sink <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:copy-buffer" $ - props $ - prop "buffer" buffer - traceM "buffer-sink" - rect <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $ - props $ do - prop "x" $ fst coordinates - prop "y" $ snd coordinates - prop "width" (20::Double) - prop "height" (20::Double) - prop "color" $ G.RGBA 1 0 0 0.5 - traceM "rect" - crop <- liftIO $ G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - props $ do - prop "width" (800::Double) - prop "height" (600::Double) - liftIO $ G.gegl_node_link_many [checkerboard, over, crop, sink] - _ <- liftIO $ G.gegl_node_connect_to rect "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , checkerboard) - , ("sink" , sink) - , ("rect" , rect) - , ("crop" , crop) - ] - traceM "loading complete" - process (myMap M.! "sink") - present (GeglRectangle 0 0 800 600) buffer True - render Nothing Nothing - -update :: Double -> Affection UserData () -update dt = do - traceM "updating" - - tick <- getElapsedTime - ud <- getAffection - putAffection $ ud { lastTick = tick } - - return () - traceM $ (show $ 1 / dt) ++ " FPS" - -handle (SDL.MouseMotionEvent dat) = do - let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat - ud <- getAffection - putAffection ud - { coordinates = (fromIntegral (x - 10), fromIntegral (y - 10)) - } - -- liftIO $ G.gegl_node_set (nodeGraph ud M.! "rect") $ G.Operation "" $ - -- props $ do - -- prop "x" (fromIntegral (x - 10) :: Double) - -- prop "y" $ (fromIntegral (y - 10) :: Double) - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean _ = return () diff --git a/examples/example02.hs b/examples/example02.hs deleted file mode 100644 index 1fe808c..0000000 --- a/examples/example02.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# 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 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 - , canvasSize = Nothing - } - 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 :: IO UserData -load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ 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 (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" (0::Double) - prop "y" (0::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 [checkerboard, 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) - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , checkerboard) - , ("sink" , sink) - , ("rect" , rect) - , ("crop" , crop) - ] - traceM "loading complete" - actorMap <- return $ M.fromList - [ ("rect", rectActor) - ] - 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 - render Nothing Nothing - -update :: Double -> Affection UserData () -update dt = 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.MouseMotionEvent dat) = do - let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat - ud <- getAffection - - nmap <- return $ M.adjust - (updateProperties $ props $ do - prop "x" (fromIntegral (x - 10) :: Double) - prop "y" (fromIntegral (y - 10) :: Double) - ) - "rect" - (actors ud) - putAffection ud - { actors = nmap - , updateActors = (actors ud M.! "rect") : [] - } - -- liftIO $ G.gegl_node_set (nodeGraph ud M.! "rect") $ G.Operation "" $ - -- props $ do - -- prop "x" (fromIntegral (x - 10) :: Double) - -- prop "y" $ (fromIntegral (y - 10) :: Double) - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean _ = return () diff --git a/examples/example03.hs b/examples/example03.hs deleted file mode 100644 index 120b6ee..0000000 --- a/examples/example03.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} - -import Affection -import qualified SDL -import qualified GEGL as G -import qualified BABL as B - -import qualified Data.Map.Strict as M - -import Control.Monad (when) - -import Foreign.C.Types - -import System.Random (randomRIO) - -import Debug.Trace - -main :: IO () -main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = drawInit - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - , canvasSize = Nothing - } - withAffection conf - -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - , foreground :: G.GeglBuffer - , partsys :: ParticleSystem - } - -load :: IO UserData -load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - rect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" $ - props $ do - prop "x" (0 :: Double) - prop "y" (0 :: Double) - prop "width" (800 :: Double) - prop "height" (600 :: Double) - prop "color" $ G.RGB 0 0 0 - traceM "rect" - traceM "checkerboard" - 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" - [G.Property "buffer" $ G.PropertyBuffer buffer - ] - traceM "buffer-sink" - 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 "width" $ G.PropertyDouble 800 - , G.Property "height" $ G.PropertyDouble 600 - ] - traceM "crop" - G.gegl_node_link_many [rect, over, crop, sink] - G.gegl_node_connect_to nop "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("sink" , sink) - , ("nop" , nop) - , ("crop" , crop) - ] - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - , foreground = buffer - , partsys = ParticleSystem (ParticleStorage Nothing []) nop buffer - } - -drawInit :: Affection UserData () -drawInit = return () --- drawInit = do --- UserData{..} <- getAffection --- present (GeglRectangle 0 0 800 600) foreground True - -draw :: Affection UserData () -draw = do - traceM "drawing" - UserData{..} <- getAffection - drawParticleSystem partsys partDraw - process $ nodeGraph M.! "sink" - present - (G.GeglRectangle 0 0 800 600) - foreground - True - render Nothing Nothing - -update :: Double -> Affection UserData () -update dt = do - traceM "updating" - ad <- get - ud <- getAffection - delta <- getDelta - traceM $ (show $ 1 / delta) ++ " FPS" - ud2 <- getAffection - !nps <- updateParticleSystem (partsys ud2) delta partUpd - putAffection $ ud2 { partsys = nps } - -handle (SDL.MouseMotionEvent dat) = - when (SDL.ButtonLeft `elem` SDL.mouseMotionEventState dat) - $ do - ad <- get - ud <- getAffection - let (SDL.P (SDL.V2 x y)) = SDL.mouseMotionEventPos dat - vx <- liftIO $ randomRIO (-20, 20) - vy <- liftIO $ randomRIO (-20, 20) - life <- liftIO $ randomRIO (1, 5) - r <- liftIO $ randomRIO (0,1) - g <- liftIO $ randomRIO (0,1) - b <- liftIO $ randomRIO (0,1) - tempRoot <- liftIO $ G.gegl_node_new - tempOver <- liftIO $ G.gegl_node_new_child tempRoot - G.defaultOverOperation - tempRect <- liftIO $ G.gegl_node_new_child tempRoot $ G.Operation - "gegl:rectangle" - [ G.Property "x" $ G.PropertyDouble $ fromIntegral x - 10 - , G.Property "y" $ G.PropertyDouble $ fromIntegral y - 10 - , G.Property "width" $ G.PropertyDouble 20 - , G.Property "height" $ G.PropertyDouble 20 - , G.Property "color" $ G.PropertyColor $ (G.RGBA r g b 0.5) - ] - liftIO $ G.gegl_node_connect_to tempRect "output" tempOver "aux" - -- traceM $ "position is: " ++ show x ++ " " ++ show y - -- traceM $ "velocity is: " ++ show vx ++ " " ++ show vy - ips <- insertParticle (partsys ud) $ - Particle - { particleTimeToLive = life - , particleCreation = elapsedTime ad - , particlePosition = (fromIntegral x, fromIntegral y) - , particleRotation = Rad 0 - , particleVelocity = (vx, vy) - , particlePitchRate = Rad 0 - , particleRootNode = tempRoot - , particleNodeGraph = M.fromList - [ ("root", tempRoot) - , ("over", tempOver) - , ("rect", tempRect) - ] - , particleStackCont = tempOver - , particleDrawFlange = tempOver - } - putAffection $ ud - { partsys = ips - } - -- when (not $ null $ psParts $ partsys ud) $ - -- liftIO $ G.gegl_node_link - -- tempOver - -- (particleStackCont $ head $ psParts $ partsys ud) - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean ud = do - G.gegl_node_drop (nodeGraph ud M.! "root") - -partUpd :: Double -> Particle -> Affection UserData Particle -partUpd sec p = do - let !newX = (fst $ particlePosition p) + sec * (fromIntegral $ fst $ particleVelocity p) - !newY = (snd $ particlePosition p) + sec * (fromIntegral $ snd $ particleVelocity p) - liftIO $ G.gegl_node_set (particleNodeGraph p M.! "rect") $ G.Operation "gegl:rectangle" - [ G.Property "x" $ G.PropertyDouble $ newX - 10 - , G.Property "y" $ G.PropertyDouble $ newY - 10 - ] - let !np = p {particlePosition = (newX, newY)} - return np - -partDraw :: G.GeglBuffer -> G.GeglNode -> Particle -> Affection UserData () -partDraw _ _ _ = return () --- partDraw buf node Particle{..} = do --- present --- (G.GeglRectangle (floor $ fst particlePosition - 10) (floor $ snd particlePosition - 10) 20 20) --- buf --- False --- -- ud <- getAffection --- -- drawRect' --- -- particleDrawFlange --- -- (G.RGBA 1 0 0 0.5) --- -- (Fill) --- -- (G.GeglRectangle ((floor $ fst particlePosition) - 10) ((floor $ snd particlePosition) -10) 20 20) --- -- buf diff --git a/examples/example04.hs b/examples/example04.hs deleted file mode 100644 index 9c926f9..0000000 --- a/examples/example04.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# 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 Foreign.C.Types - -import Debug.Trace - -main :: IO () -main = do - conf <- return AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , canvasSize = Just (3289, 600) - , 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 - , updateActors :: [Actor String] - , keysDown :: [SDL.Keycode] - , cameraX :: Double - } - -load :: 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 3289 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" (3289 :: 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 - , updateActors = [] - , keysDown = [] - , cameraX = 0 - } - -drawInit :: Affection UserData () -drawInit = do - ad <- get - ud <- getAffection - process (nodeGraph ud M.! "sink") - present (GeglRectangle (round $ cameraX ud) 0 800 600) (foreground ud) True - render Nothing Nothing - -draw :: Affection UserData () -draw = do - ud@UserData{..} <- getAffection - MP.mapM_ applyProperties updateActors - putAffection ud - { updateActors = [] - } - process (nodeGraph M.! "sink") - present (GeglRectangle (round cameraX) 0 800 600) foreground True - render - (Just $ G.GeglRectangle (round cameraX) 0 800 600) - Nothing - -update :: Double -> Affection UserData () -update dt = do - traceM "updating" - - ud <- getAffection - - traceM $ show (1 / dt) ++ " FPS" - -- traceM $ show $ keysDown ud - - mapM_ (\code -> do - let vel = 400 -- velocity in Pixels per second - leg = vel * dt - (G.PropertyDouble xpos) <- - return $ apValue $ fromJust $ L.find (\a -> "x" == apName a) $ - actorProperties $ actors ud M.! "rect" - nmap <- return $ M.adjust - (updateProperties $ props $ prop "x" $ xpos + - case code of - SDL.KeycodeLeft -> - if xpos - leg > 0 - then (- leg) - else 0 - SDL.KeycodeRight -> - if xpos + leg < 3269 - then leg - else 0 - _ -> 0 - ) - "rect" - (actors ud) - let { - offset | xpos - cameraX ud > 750 && cameraX ud + leg < 2489 && code == SDL.KeycodeRight = - leg - | xpos - cameraX ud < 50 && cameraX ud - leg > 0 && code == SDL.KeycodeLeft = - (-leg) - | otherwise = 0 - } - putAffection ud - { actors = nmap - , updateActors = (nmap M.! "rect") : updateActors ud - , cameraX = cameraX ud + offset - } - ) (keysDown ud) - -handle :: SDL.EventPayload -> Affection UserData () -handle (SDL.KeyboardEvent dat) = - when (not (SDL.keyboardEventRepeat dat)) $ do - ud <- getAffection - if (SDL.keyboardEventKeyMotion dat == SDL.Pressed) - then - putAffection ud - { keysDown = - SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud - } - else - putAffection ud - { keysDown = - delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown 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 deleted file mode 100644 index 9ed5014..0000000 Binary files a/examples/example04/panorama.jpg and /dev/null differ diff --git a/examples/example05.1.hs b/examples/example05.1.hs deleted file mode 100644 index 2758c28..0000000 --- a/examples/example05.1.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE RecordWildCards, BangPatterns #-} - -import Affection -import qualified SDL -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M -import qualified Data.Matrix as X -import Data.List as L -import Data.Maybe (fromJust, catMaybes) --- import Data.Vector as V -import System.Random (randomRIO) -import Control.Monad as CM (when, unless, foldM) -import qualified Control.Monad.Parallel as MP -import Control.Parallel.Strategies -import Foreign.C.Types -import Foreign.Marshal.Utils - -import Debug.Trace - -dimension :: Int -dimension = 60 - -resolution :: Int -resolution = 600 - -main :: IO () -main = do - conf <- return AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - { windowInitialSize = SDL.V2 - (CInt $ fromIntegral resolution) - (CInt $ fromIntegral resolution) - } - , canvasSize = Nothing - , preLoop = loadList - , eventLoop = handle - , updateLoop = Main.update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } - withAffection conf - -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - , foreground :: G.GeglBuffer - , keysDown :: [SDL.Keycode] - , liveIndices :: [(Int, Int)] - , indices :: [(Int, Int)] - -- , cells :: [((Int, Int), Actor String)] - -- , updateActors :: [Actor String] - } - -load :: IO UserData -load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - let bgProps = props $ do - prop "x" (0 :: Double) - prop "y" (0 :: Double) - prop "width" (fromIntegral resolution :: Double) - prop "height" (fromIntegral resolution :: Double) - prop "color" $ G.RGB 0 0 0 - bg <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" bgProps - traceM "background" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 resolution resolution) =<< - 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" - crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - props $ do - prop "width" (fromIntegral resolution :: Double) - prop "height" (fromIntegral resolution :: Double) - G.gegl_node_link_many [bg, over, crop, sink] - nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] - _ <- G.gegl_node_connect_to nop "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , bg) - , ("sink" , sink) - , ("nop" , nop) - , ("crop" , crop) - ] - traceM "building matrix" - let !emptyMatrix = X.matrix dimension dimension (const False) - !indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]] - -- traceM "building cells" - -- cells <- foldM (\acc index@(row, col) -> do - -- tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation - -- let !scale = (fromIntegral resolution) / (fromIntegral dimension) - -- tempProps = - -- props $ do - -- prop "x" (((fromIntegral col) - 1) * scale :: Double) - -- prop "y" (((fromIntegral row) - 1) * scale :: Double) - -- prop "width" (scale :: Double) - -- prop "height" (scale :: Double) - -- prop "color" $ G.RGB 1 1 1 - -- tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" - -- tempProps - -- G.gegl_node_connect_to tempRect "output" tempOver "aux" - -- let tempMap = M.fromList - -- [ ("over", tempOver) - -- , ("rect", tempRect) - -- ] - -- tempAProps = - -- map (\p -> ActorProperty - -- { apName = G.propertyName p - -- , apValue = G.propertyValue p - -- , apMapping = Just "rect" - -- }) tempProps - -- traceIO $ show index - -- return $ (index, Actor - -- { actorProperties = tempAProps - -- , actorNodes = tempMap - -- }) : acc - -- ) - -- ([] :: [((Int, Int), Actor String)]) - -- indices - -- :: IO [((Int, Int), Actor String)] - traceM "loading complete" - return UserData - { nodeGraph = myMap - , foreground = buffer - , keysDown = [] - , indices = indices - , liveIndices = [] - -- , cells = cells - -- , updateActors = [] - } - -loadList :: Affection UserData () -loadList = do - ud@UserData{..} <- getAffection - init <- foldM (\acc coord -> do - trig <- liftIO $ randomRIO (True, False) - if trig then return (coord : acc) else return acc - ) [] indices - putAffection ud - { liveIndices = init - } - -getNeighbors :: (Int, Int) -> Affection UserData [(Int, Int)] -getNeighbors (row, col) = - do - UserData{..} <- getAffection - mapM (\(pr, pc) -> - return (overflow(row + pr), overflow(col + pc)) - ) lcs - where - overflow x - | x < 1 = dimension - | x > dimension = 1 - | otherwise = x - -lcs :: [(Int, Int)] -lcs = - [ (-1, -1) - , (-1, 0) - , (-1, 1) - , (0, -1) - -- , (0, 0) - , (0, 1) - , (1, -1) - , (1, 0) - , (1, 1) - ] - -draw :: Affection UserData () -draw = do - traceM "drawing" - ad <- get - ud@UserData{..} <- getAffection - SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 0 0 0 255) - SDL.clear (windowRenderer ad) - SDL.rendererDrawColor (windowRenderer ad) SDL.$= (SDL.V4 255 255 255 255) - MP.mapM_ (\(row, col) -> - let scale = floor (fromIntegral resolution / fromIntegral dimension) - in - SDL.fillRect - (windowRenderer ad) - (Just ( SDL.Rectangle - (SDL.P (SDL.V2 - (CInt $ fromIntegral $ (col - 1) * scale) - (CInt $ fromIntegral $ (row - 1) * scale) - )) - (SDL.V2 - (CInt $ fromIntegral $ scale) - (CInt $ fromIntegral $ scale) - ) - )) - ) liveIndices - -- render Nothing Nothing - -- let livingActors = catMaybes $ parMap rpar (\i -> lookup i cells) liveIndices - -- unless (null livingActors) $ do - -- liftIO $ G.gegl_node_link_many $ - -- parMap rpar (\a -> (actorNodes a) M.! "over") livingActors - -- _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over") - -- (nodeGraph M.! "nop") - -- return () - -- process (nodeGraph M.! "sink") - -- present (G.GeglRectangle 0 0 resolution resolution) foreground True - -- render - -- Nothing - -- Nothing - -- _ <- liftIO $ MP.mapM - -- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input" - -- ) livingActors - -- putAffection ud - -- { updateActors = [] - -- } - -update :: Double -> Affection UserData () -update dt = do - traceM "updating" - - ud <- getAffection - elapsed <- getElapsedTime - - traceM $ show (1 / dt) ++ " FPS" - traceM $ show $ keysDown ud - - relevant <- getRelevant (liveIndices ud) - - new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do - neighs <- - foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$> - getNeighbors coord - let ret - | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = - Just coord - | neighs == 3 = - Just coord - | otherwise = - Nothing - return ret - ) relevant - - ud2 <- getAffection - putAffection ud2 - { liveIndices = new - } - - mapM_ (\code -> - when (code == SDL.KeycodeR) loadList - ) (keysDown ud) - -getRelevant :: [(Int, Int)] -> Affection UserData [(Int, Int)] -getRelevant ls = - getRelevant' ls - where - getRelevant' xs = foldM (\acc x -> do - neighs <- getNeighbors x - let slice = (x : neighs) - rels = foldl (\a y -> - if y `elem` acc then a else y : a - ) [] slice - return (acc ++ rels) - ) [] xs - -handle :: SDL.EventPayload -> Affection UserData () -handle (SDL.KeyboardEvent dat) = - when (not (SDL.keyboardEventRepeat dat)) $ do - ud <- getAffection - if (SDL.keyboardEventKeyMotion dat == SDL.Pressed) - then - putAffection ud - { keysDown = - SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud - } - else - putAffection ud - { keysDown = - delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown ud) - } - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean _ = return () diff --git a/examples/example05.hs b/examples/example05.hs deleted file mode 100644 index 9985d73..0000000 --- a/examples/example05.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE RecordWildCards, BangPatterns #-} - -import Affection -import qualified SDL -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Matrix as X -import Data.List as L -import Data.Foldable (foldrM, foldlM) -import Data.Maybe (fromJust, catMaybes) --- import Data.Vector as V -import System.Random (randomRIO) -import Control.Monad as CM (when, unless) -import qualified Control.Monad.Parallel as MP -import Control.Parallel.Strategies -import Foreign.C.Types -import Foreign.Marshal.Utils - -import Debug.Trace - -dimension :: Int -dimension = 60 - -resolution :: Int -resolution = 600 - -main :: IO () -main = do - conf <- return AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - { windowInitialSize = SDL.V2 - (CInt $ fromIntegral resolution) - (CInt $ fromIntegral resolution) - } - , canvasSize = Nothing - , initScreenMode = SDL.Windowed - , preLoop = loadList - , eventLoop = handle - , updateLoop = Main.update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } - withAffection conf - -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - , foreground :: G.GeglBuffer - , keysDown :: [SDL.Keycode] - , liveIndices :: HS.HashSet (Int, Int) - , indices :: [(Int, Int)] - , cells :: HM.HashMap (Int, Int) (Actor String) - , updateActors :: [Actor String] - } - -load :: IO UserData -load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - let bgProps = props $ do - prop "x" (0 :: Double) - prop "y" (0 :: Double) - prop "width" (fromIntegral resolution :: Double) - prop "height" (fromIntegral resolution :: Double) - prop "color" $ G.RGB 0 0 0 - bg <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" bgProps - traceM "background" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - buffer <- G.gegl_buffer_new (Just $ G.GeglRectangle 0 0 resolution resolution) =<< - 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" - crop <- G.gegl_node_new_child root $ G.Operation "gegl:crop" $ - props $ do - prop "width" (fromIntegral resolution :: Double) - prop "height" (fromIntegral resolution :: Double) - G.gegl_node_link_many [bg, over, crop, sink] - nop <- G.gegl_node_new_child root $ G.Operation "gegl:nop" [] - _ <- G.gegl_node_connect_to nop "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("background" , bg) - , ("sink" , sink) - , ("nop" , nop) - , ("crop" , crop) - ] - traceM "building matrix" - let !emptyMatrix = X.matrix dimension dimension (const False) - !indices = [(row, col) | row <- [1..dimension], col <- [1..dimension]] - traceM "building cells" - cells <- foldrM (\index@(row, col) acc -> do - tempOver <- G.gegl_node_new_child root $ G.defaultOverOperation - let !scale = (fromIntegral resolution) / (fromIntegral dimension) - tempProps = - props $ do - prop "x" (((fromIntegral col) - 1) * scale :: Double) - prop "y" (((fromIntegral row) - 1) * scale :: Double) - prop "width" (scale :: Double) - prop "height" (scale :: Double) - prop "color" $ G.RGB 1 1 1 - tempRect <- G.gegl_node_new_child root $ G.Operation "gegl:rectangle" - tempProps - G.gegl_node_connect_to tempRect "output" tempOver "aux" - let tempMap = M.fromList - [ ("over", tempOver) - , ("rect", tempRect) - ] - tempAProps = - map (\p -> ActorProperty - { apName = G.propertyName p - , apValue = G.propertyValue p - , apMapping = Just ("rect", "color") - }) tempProps - traceIO $ show index - return $ HM.insert index Actor - { actorProperties = tempAProps - , actorNodes = tempMap - } - acc - ) - HM.empty - indices - traceM "loading complete" - return UserData - { nodeGraph = myMap - , foreground = buffer - , keysDown = [] - , indices = indices - , liveIndices = HS.empty - , cells = cells - , updateActors = [] - } - -loadList :: Affection UserData () -loadList = do - ud@UserData{..} <- getAffection - -- init <- foldrM (\coord acc -> do - init <- foldlM (\acc coord -> do - trig <- liftIO $ randomRIO (True, False) - if trig then return (HS.insert coord acc) else return acc - ) HS.empty indices - putAffection ud - { liveIndices = init - } - -getNeighbors :: (Int, Int) -> [(Int, Int)] -getNeighbors (row, col) = - map (\(pr, pc) -> (overflow(row + pr), overflow(col + pc))) lcs - where - overflow x - | x < 1 = dimension - | x > dimension = 1 - | otherwise = x - -lcs :: [(Int, Int)] -lcs = - [ (-1, -1) - , (-1, 0) - , (-1, 1) - , (0, -1) - -- , (0, 0) - , (0, 1) - , (1, -1) - , (1, 0) - , (1, 1) - ] - -draw :: Affection UserData () -draw = do - traceM "drawing" - ud@UserData{..} <- getAffection - let livingActors = parMap rpar (cells HM.!) $ HS.toList liveIndices - unless (null livingActors) $ do - liftIO $ G.gegl_node_link_many $ - parMap rpar (\a -> (actorNodes a) M.! "over") livingActors - _ <- liftIO $ G.gegl_node_link ((actorNodes $ last livingActors) M.! "over") - (nodeGraph M.! "nop") - return () - process (nodeGraph M.! "sink") - present (G.GeglRectangle 0 0 resolution resolution) foreground True - render - Nothing - Nothing - -- _ <- liftIO $ MP.mapM - -- (\a -> G.gegl_node_disconnect (actorNodes a M.! "over") "input" - -- ) livingActors - putAffection ud - { updateActors = [] - } - -update :: Double -> Affection UserData () -update dt = do - traceM "updating" - - ud <- getAffection - elapsed <- getElapsedTime - - traceM $ show (1 / dt) ++ " FPS" - traceM $ show $ keysDown ud - - relevant <- getRelevant (liveIndices ud) - - -- let new = HS.fromList $ catMaybes $ parMap rpar (\coord@(row, col) -> - -- let neighs = - -- foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 $ - -- getNeighbors coord - -- ret - -- | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = - -- Just coord - -- | neighs == 3 = - -- Just coord - -- | otherwise = - -- Nothing - -- in ret - -- ) (HS.toList relevant) - - new <- foldrM (\coord@(row, col) acc -> do - -- new <- foldlM (\acc coord@(row, col) -> do - let !neighs = sum $ - map (\n -> if n `elem` liveIndices ud then 1 else 0)$ - getNeighbors coord - ret - | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = - HS.insert coord acc - | neighs == 3 = - HS.insert coord acc - | otherwise = - acc - return ret - ) HS.empty relevant - - -- new <- catMaybes <$> MP.mapM (\coord@(row, col) -> do - -- neighs <- - -- foldl (\acc n -> if n `elem` liveIndices ud then acc + 1 else acc) 0 <$> - -- getNeighbors coord - -- let ret - -- | coord `elem` liveIndices ud && (neighs == 2 || neighs == 3) = - -- Just coord - -- | neighs == 3 = - -- Just coord - -- | otherwise = - -- Nothing - -- return ret - -- ) relevant - - ud2 <- getAffection - putAffection ud2 - { liveIndices = new - } - - mapM_ (\code -> - when (code == SDL.KeycodeR) loadList - ) (keysDown ud) - -getRelevant :: HS.HashSet (Int, Int) -> Affection UserData (HS.HashSet (Int, Int)) -getRelevant ls = do - getRelevant' ls - where - getRelevant' xs = foldlM (\acc x -> - let neighs = getNeighbors x - slice = (x : neighs) - rels = foldr (\y a -> - -- rels = foldl (\a y -> - if y `elem` acc then a else HS.insert y a - ) HS.empty slice - in return (acc `HS.union` rels) - ) HS.empty xs - -handle :: SDL.EventPayload -> Affection UserData () -handle (SDL.KeyboardEvent dat) = - when (not (SDL.keyboardEventRepeat dat)) $ do - ud <- getAffection - if (SDL.keyboardEventKeyMotion dat == SDL.Pressed) - then - putAffection ud - { keysDown = - SDL.keysymKeycode (SDL.keyboardEventKeysym dat) : keysDown ud - } - else - putAffection ud - { keysDown = - delete (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) (keysDown ud) - } - -handle (SDL.WindowClosedEvent _) = do - traceM "seeya!" - quit - -handle _ = - return () - -clean :: UserData -> IO () -clean _ = return () - -parHSMap f = (`using` parTraversable rpar) . HM.map f - --- catHSMaybe = --- foldr (\x acc -> --- case x of --- Just a -> a `HS.insert` acc --- Nothing -> acc --- ) HS.empty