{-# 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