removing old examples

This commit is contained in:
nek0 2017-12-28 16:56:25 +01:00
parent 11bb7b69e5
commit 59b60f58c3
9 changed files with 0 additions and 1610 deletions

View file

@ -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 ()

View file

@ -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 ()

View file

@ -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 ()

View file

@ -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 ()

View file

@ -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

View file

@ -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 ()

Binary file not shown.

Before

Width:  |  Height:  |  Size: 400 KiB

View file

@ -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 ()

View file

@ -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