78 lines
1.9 KiB
Haskell
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
|