pituicat/src/Types/Subsystems.hs

112 lines
2.8 KiB
Haskell

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Types.Subsystems where
import Affection
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
}
deriving (Eq, Show)
instance Message TranslatorMessage where
msgTime (TranslatorMessage _ t) = t
data Action
= 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