affection/examples/example01/Types.hs

79 lines
2.0 KiB
Haskell

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types where
import Affection
import Data.Matrix as M
import NanoVG
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data UserData = UserData
{ lifeMat :: Matrix Word
, foodMat :: Matrix Word
, timeMat :: Matrix Word
, subsystems :: Subsystems
, nano :: Context
, lastUpdate :: Int
}
data Subsystems = Subsystems
{ subWindow :: Types.Window
, subKeyboard :: Types.Keyboard
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Types.Window UserData where
type Mesg Types.Window UserData = 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 UserData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard UserData where
type Mesg Keyboard UserData = 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 UserData where
consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> (msg -> Affection UserData ())
-> Affection UserData UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> UUID
-> Affection UserData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p