start laying out types

This commit is contained in:
nek0 2020-09-21 04:26:45 +02:00
parent 2bff7b942f
commit f5353c5de2
2 changed files with 147 additions and 0 deletions

58
src/Types/Application.hs Normal file
View file

@ -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

89
src/Types/Subsystems.hs Normal file
View file

@ -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