start laying out types
This commit is contained in:
parent
2bff7b942f
commit
f5353c5de2
|
@ -0,0 +1,58 @@
|
||||||
|
module Types.Application where
|
||||||
|
|
||||||
|
import Affection
|
||||||
|
|
||||||
|
import qualified SDL
|
||||||
|
|
||||||
|
import Control.Concurrent.STM.TMVar
|
||||||
|
|
||||||
|
import qualified Data.Map.Strict as M
|
||||||
|
|
||||||
|
-- internal imports
|
||||||
|
|
||||||
|
import Types.Subsystems
|
||||||
|
|
||||||
|
data GameData = GameData
|
||||||
|
{ gameState :: TVar State
|
||||||
|
, gameCurrentLevel :: Tvar Level
|
||||||
|
, gameSubsystems :: Subsystems
|
||||||
|
, gameActionTranslation :: TVar ActionTranslation
|
||||||
|
, gameEnded :: TVar Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
data State
|
||||||
|
= Running
|
||||||
|
| Paused
|
||||||
|
deriving (Enum, Eq, Show)
|
||||||
|
|
||||||
|
data Level
|
||||||
|
= MainMenu
|
||||||
|
| DNAMenu
|
||||||
|
| Sewer01
|
||||||
|
| Sewer02
|
||||||
|
| Sewer03
|
||||||
|
| Sewer04
|
||||||
|
| Alley01
|
||||||
|
| Alley02
|
||||||
|
| Alley03
|
||||||
|
| Alley04
|
||||||
|
| Lab01
|
||||||
|
| Lab02
|
||||||
|
| Lab03
|
||||||
|
| Lab04
|
||||||
|
| Highway01
|
||||||
|
| Highway02
|
||||||
|
| Highway03
|
||||||
|
| Highway04
|
||||||
|
| Complex01
|
||||||
|
| Complex02
|
||||||
|
| Complex03
|
||||||
|
| Complex04
|
||||||
|
| Base01
|
||||||
|
| Base01
|
||||||
|
| Base01
|
||||||
|
| Base01
|
||||||
|
| Test
|
||||||
|
deriving (Enum, Eq, Show)
|
||||||
|
|
||||||
|
type ActionTranslation = M.Map SDL.Keycode Action
|
|
@ -0,0 +1,89 @@
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE MutliParamTypeClasses #-}
|
||||||
|
module Types.Subsystems where
|
||||||
|
|
||||||
|
import Affection
|
||||||
|
|
||||||
|
import Control.Concurrent.STM.TVar
|
||||||
|
|
||||||
|
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 ())])
|
||||||
|
|
||||||
|
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
|
Loading…
Reference in New Issue