affection/examples/example02/Types.hs

78 lines
1.9 KiB
Haskell

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types where
import Affection
import Data.Matrix as M
import NanoVG
import Control.Concurrent.STM
import Control.Concurrent.MVar
data UserData = UserData
{ lifeMat :: MVar (Matrix Word)
, foodMat :: MVar (Matrix Word)
, timeMat :: MVar (Matrix Word)
, subsystems :: Subsystems
, nano :: Context
, doNextStep :: MVar Bool
}
data Subsystems = Subsystems
{ subWindow :: Types.Window
, subKeyboard :: Types.Keyboard
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
instance Participant Types.Window where
type Mesg Types.Window = WindowMessage
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Window t) = generalSubscribe t
partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Types.Window where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard where
type Mesg Keyboard = KeyboardMessage
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Keyboard t) = generalSubscribe t
partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard where
consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection ())
-> Affection UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> UUID
-> Affection ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p