tracer/src/Types/UserData.hs

139 lines
3.7 KiB
Haskell
Raw Normal View History

2018-02-07 00:18:16 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types.UserData where
import Affection
import Control.Concurrent.STM
import qualified SDL
2018-02-07 00:18:16 +00:00
import NanoVG hiding (V2(..), V3(..))
import qualified Data.Map.Strict as M
2018-03-01 22:33:08 +00:00
import qualified Data.Text as T
2018-02-07 00:18:16 +00:00
import Data.Ecstasy
import Control.Concurrent.MVar
import Types.StateData
import Types.ImgId
import Types.FontId
import Types.Animation
2018-08-10 06:58:26 +00:00
import Types.Entity
2018-02-07 00:18:16 +00:00
data UserData = UserData
2018-05-27 14:03:31 +00:00
{ state :: State
, subsystems :: Subsystems
, assetImages :: M.Map ImgId Image
, assetFonts :: M.Map FontId T.Text
, assetAnimations :: M.Map AnimId Animation
, nano :: Context
, uuid :: [UUID]
2018-08-10 06:58:26 +00:00
, worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO)
2018-05-27 14:03:31 +00:00
, stateData :: StateData
2018-08-10 06:58:26 +00:00
, stateMVar :: MVar
( SystemState Entity (AffectionState (AffectionData UserData) IO)
, StateData
)
2018-07-19 02:51:07 +00:00
, stateProgress :: MVar (Float, T.Text)
, threadContext :: Maybe SDL.GLContext
, window :: Maybe SDL.Window
2018-02-07 00:18:16 +00:00
}
data State
= Load
2018-06-28 19:07:58 +00:00
| Main SubMain
2018-09-24 22:13:09 +00:00
deriving (Eq)
2018-02-07 00:18:16 +00:00
2018-06-28 19:07:58 +00:00
data SubMain
= WorldMap
| MindMap
2018-09-24 22:13:09 +00:00
deriving (Eq)
2018-06-28 19:07:58 +00:00
2018-02-07 00:18:16 +00:00
data Subsystems = Subsystems
2018-10-08 16:54:23 +00:00
{ subWindow :: SubWindow
, subMouse :: SubMouse
, subkeyboard :: SubKeyboard
, subJoypad :: SubJoypad
2018-02-07 00:18:16 +00:00
}
2018-10-08 16:54:23 +00:00
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
newtype SubJoypad = SubJoypad (TVar [(UUID, JoystickMessage -> Affection UserData ())])
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
instance Participant SubWindow UserData where
type Mesg SubWindow UserData = WindowMessage
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
partSubscribers (SubWindow t) = generalSubscribers t
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
partSubscribe (SubWindow t) = generalSubscribe t
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
partUnSubscribe (SubWindow t) = generalUnSubscribe t
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
instance SDLSubsystem SubWindow UserData where
2018-02-07 00:18:16 +00:00
consumeSDLEvents = consumeSDLWindowEvents
2018-10-08 16:54:23 +00:00
instance Participant SubMouse UserData where
type Mesg SubMouse UserData = MouseMessage
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
partSubscribers (SubMouse t) = generalSubscribers t
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
partSubscribe (SubMouse t) = generalSubscribe t
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
partUnSubscribe (SubMouse t) = generalUnSubscribe t
2018-02-07 00:18:16 +00:00
2018-10-08 16:54:23 +00:00
instance SDLSubsystem SubMouse UserData where
2018-02-07 00:18:16 +00:00
consumeSDLEvents = consumeSDLMouseEvents
2018-10-08 16:54:23 +00:00
instance Participant SubKeyboard UserData where
type Mesg SubKeyboard UserData = KeyboardMessage
2018-06-23 22:42:39 +00:00
2018-10-08 16:54:23 +00:00
partSubscribers (SubKeyboard t) = generalSubscribers t
2018-06-23 22:42:39 +00:00
2018-10-08 16:54:23 +00:00
partSubscribe (SubKeyboard t) = generalSubscribe t
2018-06-23 22:42:39 +00:00
2018-10-08 16:54:23 +00:00
partUnSubscribe (SubKeyboard t) = generalUnSubscribe t
2018-06-23 22:42:39 +00:00
2018-10-08 16:54:23 +00:00
instance SDLSubsystem SubKeyboard UserData where
2018-06-23 22:42:39 +00:00
consumeSDLEvents = consumeSDLKeyboardEvents
2018-10-08 16:54:23 +00:00
instance Participant SubJoypad UserData where
type Mesg SubJoypad UserData = JoystickMessage
partSubscribers (SubJoypad t) = generalSubscribers t
partSubscribe (SubJoypad t) = generalSubscribe t
partUnSubscribe (SubJoypad t) = generalUnSubscribe t
instance SDLSubsystem SubJoypad UserData where
consumeSDLEvents = consumeSDLJoystickEvents
2018-02-07 00:18:16 +00:00
generalSubscribers
:: TVar [(UUID, msg -> Affection UserData ())]
-> Affection UserData [(msg -> Affection UserData ())]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> (msg -> Affection UserData ())
-> Affection UserData UUID
generalSubscribe t funct = do
2018-02-18 02:11:41 +00:00
uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu
2018-02-07 00:18:16 +00:00
generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> UUID
-> Affection UserData ()
2018-02-18 02:11:41 +00:00
generalUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
2018-02-07 00:18:16 +00:00
where
filterMsg (u, _) p = u /= p