removing old examples
This commit is contained in:
nek0
parent
11bb7b69e5
commit
59b60f58c3
9 changed files with 0 additions and 1610 deletions
|
|
@ -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 ()
|
|
||||||
|
|
@ -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 ()
|
|
||||||
|
|
@ -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 ()
|
|
||||||
|
|
@ -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 ()
|
|
||||||
|
|
@ -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
|
|
||||||
|
|
@ -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 |
|
|
@ -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 ()
|
|
||||||
|
|
@ -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
|
|
||||||
Loading…
Reference in a new issue