121 lines
2.9 KiB
Haskell
121 lines
2.9 KiB
Haskell
{-# 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
|
|
, tmKeyMotion :: 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
|