{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} module Types.Subsystems where import Affection import qualified SDL import Control.Concurrent.STM data Subsystems = Subsystems { subWindow :: SubWindow , subMouse :: SubMouse , subKeyboard :: SubKeyboard , subTranslator :: SubTranslator } newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())]) newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())]) newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())]) data TranslatorMessage = TranslatorMessage { tmAction :: Action , tmTime :: Double , tmKeyMotiuon :: SDL.InputMotion } deriving (Eq, Show) instance Message TranslatorMessage where msgTime (TranslatorMessage _ t _) = t data Action = MoveUp | MoveDown | MoveLeft | MoveRight | Jump | JumpDown | Activate | ReleasePowerup1 | ReleasePowerup2 | ReleasePowerup3 | Spit | Pause deriving (Enum, Eq, Show) instance Participant SubWindow where type Mesg SubWindow = WindowMessage partSubscribers (SubWindow t) = generalSubscribers t partSubscribe (SubWindow t) = generalSubscribe t partUnSubscribe (SubWindow t) = generalUnSubscribe t instance SDLSubsystem SubWindow where consumeSDLEvents = consumeSDLWindowEvents instance Participant SubMouse where type Mesg SubMouse = MouseMessage partSubscribers (SubMouse t) = generalSubscribers t partSubscribe (SubMouse t) = generalSubscribe t partUnSubscribe (SubMouse t) = generalUnSubscribe t instance SDLSubsystem SubMouse where consumeSDLEvents = consumeSDLMouseEvents instance Participant SubKeyboard where type Mesg SubKeyboard = KeyboardMessage partSubscribers (SubKeyboard t) = generalSubscribers t partSubscribe (SubKeyboard t) = generalSubscribe t partUnSubscribe (SubKeyboard t) = generalUnSubscribe t instance SDLSubsystem SubKeyboard where consumeSDLEvents = consumeSDLKeyboardEvents instance Participant SubTranslator where type Mesg SubTranslator = TranslatorMessage partSubscribers (SubTranslator t) = generalSubscribers t partSubscribe (SubTranslator t) = generalSubscribe t partUnSubscribe (SubTranslator t) = generalUnSubscribe t generalSubscribers :: TVar [(UUID, msg -> Affection ())] -> Affection [(msg -> Affection ())] generalSubscribers t = do subTups <- liftIO $ readTVarIO t return $ map snd subTups generalSubscribe :: TVar [(UUID, msg -> Affection ())] -> (msg -> Affection ()) -> Affection UUID generalSubscribe t funct = do uu <- genUUID liftIO $ atomically $ modifyTVar' t ((uu, funct) :) return uu generalUnSubscribe :: TVar [(UUID, msg -> Affection ())] -> UUID -> Affection () generalUnSubscribe t uu = liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) where filterMsg (u, _) p = u /= p