affection/examples/example00.hs

129 lines
3.6 KiB
Haskell
Raw Normal View History

2016-11-04 15:06:16 +00:00
{-# LANGUAGE RecordWildCards #-}
2017-12-15 16:48:12 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
2016-11-04 15:06:16 +00:00
2016-05-29 16:01:23 +00:00
import Affection
2016-11-04 15:06:16 +00:00
import qualified SDL
2017-12-13 14:19:53 +00:00
import Control.Concurrent.STM
2017-12-15 16:48:12 +00:00
import Control.Monad.IO.Class (liftIO)
2016-12-26 13:06:51 +00:00
2017-12-13 14:19:53 +00:00
data StateData = StateData
{ sdSubs :: Subsystems
}
2016-11-04 15:06:16 +00:00
2017-12-13 14:19:53 +00:00
data Subsystems = Subsystems
2017-12-15 16:48:12 +00:00
{ subWindow :: Window
, subMouse :: Mouse
, subKeyboard :: Keyboard
2017-12-13 14:19:53 +00:00
}
2016-05-29 16:01:23 +00:00
2017-12-15 16:48:12 +00:00
data Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
data Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
data Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
instance Participant Window WindowMessage StateData where
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO $ t
return $ map snd subTups
partSubscribe (Window t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Window t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Window StateData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse MouseMessage StateData where
partSubscribers (Mouse t) = do
subTups <- liftIO $ readTVarIO $ t
return $ map snd subTups
partSubscribe (Mouse t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Mouse t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Mouse StateData where
consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard KeyboardMessage StateData where
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO $ t
return $ map snd subTups
partSubscribe (Keyboard t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
partUnSubscribe (Keyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents
2016-05-29 16:01:23 +00:00
main :: IO ()
2016-11-04 15:06:16 +00:00
main = do
2017-12-13 14:19:53 +00:00
logIO Debug "Starting"
let conf = AffectionConfig
{ initComponents = All
, windowTitle = "affection: example00"
, windowConfig = SDL.defaultWindow
2017-12-15 16:48:12 +00:00
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
2017-12-13 14:19:53 +00:00
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
2016-11-04 15:06:16 +00:00
withAffection conf
2017-12-13 14:19:53 +00:00
load :: IO StateData
2017-03-23 03:27:57 +00:00
load = do
2017-12-13 14:19:53 +00:00
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
return $ StateData $ Subsystems
2017-12-15 16:48:12 +00:00
(Window empty1)
(Mouse empty2)
(Keyboard empty3)
2017-12-13 14:19:53 +00:00
pre :: Affection StateData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
return ()
2016-11-04 15:06:16 +00:00
2017-12-13 14:19:53 +00:00
exitOnQ :: KeyboardMessage -> Affection StateData ()
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeQ -> quit
otherwise -> return ()
2016-11-04 15:06:16 +00:00
2017-12-13 14:19:53 +00:00
handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
(Subsystems a b c) <- sdSubs <$> getAffection
_ <- consumeSDLEvents a es
_ <- consumeSDLEvents b es
_ <- consumeSDLEvents c es
return ()
2017-12-13 14:19:53 +00:00
update _ = return ()
2017-12-13 14:19:53 +00:00
draw = return ()
2016-11-13 12:46:23 +00:00
clean _ = return ()