tracer/src/Types/UserData.hs
2018-10-12 21:40:16 +02:00

195 lines
5.1 KiB
Haskell

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types.UserData where
import Affection
import Control.Concurrent.STM
import qualified SDL
import NanoVG hiding (V2(..), V3(..))
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Ecstasy
import Control.Concurrent.MVar
import Types.StateData
import Types.ImgId
import Types.FontId
import Types.Animation
import Types.Entity
data UserData = UserData
{ state :: State
, subsystems :: Subsystems
, assetIcons :: M.Map IconId Image
, assetImages :: M.Map ImgId Image
, assetFonts :: M.Map FontId T.Text
, assetAnimations :: M.Map AnimId Animation
, joystick :: Maybe SDL.Joystick
, translation :: M.Map GamepadAction Action
, nano :: Context
, uuid :: [UUID]
, worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO)
, stateData :: StateData
, stateMVar :: MVar
( SystemState Entity (AffectionState (AffectionData UserData) IO)
, StateData
)
, stateProgress :: MVar (Float, T.Text)
, threadContext :: Maybe SDL.GLContext
, window :: Maybe SDL.Window
, joyCache :: [JoystickMessage]
, joyUUID :: UUID
}
data State
= Load
| Menu SubMenu
| Main SubMain
deriving (Eq, Show)
data SubMain
= WorldMap
| MindMap
deriving (Eq, Show)
data SubMenu
= Connect
| Adjust Action
deriving (Eq, Show)
defaultTranslation :: M.Map GamepadAction Action
defaultTranslation = M.fromList
[ (ButtonAction 0 SDL.JoyButtonPressed, Activate)
, (AxisAction 1, UpDown 1)
, (AxisAction 0, LeftRight 1)
]
data Action
= Activate
| UpDown Int
| LeftRight Int
deriving (Show, Eq)
data GamepadAction
= ButtonAction Word8 SDL.JoyButtonState
| AxisAction Word8
-- | HatAction Word SDL.JoyHatPosition
deriving (Show, Eq, Ord)
data AxisAlign
= AxisPositive
| AxisNegative
| AxisNeutral
deriving (Show, Eq, Ord)
data Subsystems = Subsystems
{ subWindow :: SubWindow
, subMouse :: SubMouse
, subkeyboard :: SubKeyboard
, subJoypad :: SubJoypad
, subTranslator :: SubTranslator
}
data ActionMessage = ActionMessage
{ amAction :: Action
, amTime :: Double
}
deriving (Eq, Show)
instance Message ActionMessage where
msgTime (ActionMessage _ t) = t
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 ())])
newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection UserData ())])
instance Participant SubWindow UserData where
type Mesg SubWindow UserData = WindowMessage
partSubscribers (SubWindow t) = generalSubscribers t
partSubscribe (SubWindow t) = generalSubscribe t
partUnSubscribe (SubWindow t) = generalUnSubscribe t
instance SDLSubsystem SubWindow UserData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant SubMouse UserData where
type Mesg SubMouse UserData = MouseMessage
partSubscribers (SubMouse t) = generalSubscribers t
partSubscribe (SubMouse t) = generalSubscribe t
partUnSubscribe (SubMouse t) = generalUnSubscribe t
instance SDLSubsystem SubMouse UserData where
consumeSDLEvents = consumeSDLMouseEvents
instance Participant SubKeyboard UserData where
type Mesg SubKeyboard UserData = KeyboardMessage
partSubscribers (SubKeyboard t) = generalSubscribers t
partSubscribe (SubKeyboard t) = generalSubscribe t
partUnSubscribe (SubKeyboard t) = generalUnSubscribe t
instance SDLSubsystem SubKeyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents
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
instance Participant SubTranslator UserData where
type Mesg SubTranslator UserData = ActionMessage
partSubscribers (SubTranslator t) = generalSubscribers t
partSubscribe (SubTranslator t) = generalSubscribe t
partUnSubscribe (SubTranslator t) = generalUnSubscribe t
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
uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu
generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> UUID
-> Affection UserData ()
generalUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
where
filterMsg (u, _) p = u /= p