tracer/src/Types/UserData.hs

225 lines
5.8 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
2022-08-04 16:13:53 +00:00
import Control.Monad.Trans.Resource
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
2020-05-04 23:12:53 +00:00
{ state :: MVar State
2018-05-27 14:03:31 +00:00
, subsystems :: Subsystems
2020-05-04 23:12:53 +00:00
, assetIcons :: MVar (M.Map IconId Image)
, assetImages :: MVar (M.Map ImgId Image)
, assetFonts :: MVar (M.Map FontId T.Text)
, assetAnimations :: MVar (M.Map AnimId Animation)
2020-05-04 23:23:40 +00:00
, controls :: MVar Controller
2020-05-04 23:12:53 +00:00
, translation :: MVar Translation
2018-05-27 14:03:31 +00:00
, nano :: Context
2020-05-04 23:12:53 +00:00
, uuid :: MVar [UUID]
2022-08-04 16:13:53 +00:00
, worldState :: MVar (SystemState Entity (AffectionState AffectionData ResIO))
2020-05-04 23:12:53 +00:00
, stateData :: MVar StateData
2018-08-10 06:58:26 +00:00
, stateMVar :: MVar
2022-08-04 16:13:53 +00:00
( SystemState Entity (AffectionState AffectionData ResIO)
2018-08-10 06:58:26 +00:00
, StateData
)
2018-07-19 02:51:07 +00:00
, stateProgress :: MVar (Float, T.Text)
2020-05-04 23:23:40 +00:00
, threadContext :: MVar (Maybe SDL.GLContext)
, window :: MVar (Maybe SDL.Window)
2020-05-04 23:12:53 +00:00
, joyCache :: MVar [JoystickMessage]
, joyUUID :: MVar UUID
2020-05-05 08:26:16 +00:00
, doNextStep :: MVar Bool
2018-02-07 00:18:16 +00:00
}
2019-02-11 09:49:23 +00:00
data Controller
2019-02-11 15:11:27 +00:00
= NoController
2019-02-11 09:49:23 +00:00
| Keyboard
2019-02-11 15:11:27 +00:00
| Joystick SDL.Joystick
2019-02-11 09:49:23 +00:00
deriving (Eq, Show)
2018-02-07 00:18:16 +00:00
data State
= Load
2018-10-12 12:26:06 +00:00
| Menu SubMenu
2018-06-28 19:07:58 +00:00
| Main SubMain
2018-10-12 19:40:16 +00:00
deriving (Eq, Show)
2018-02-07 00:18:16 +00:00
2018-06-28 19:07:58 +00:00
data SubMain
= WorldMap
| MindMap
2018-10-12 19:40:16 +00:00
deriving (Eq, Show)
2018-06-28 19:07:58 +00:00
2018-10-12 12:26:06 +00:00
data SubMenu
= Connect
2019-02-11 23:11:53 +00:00
| Adjust Action Controller
2018-10-12 19:40:16 +00:00
deriving (Eq, Show)
2018-10-12 12:26:06 +00:00
2019-02-11 23:11:53 +00:00
defaultJoyTranslation :: M.Map JoypadAction Action
defaultJoyTranslation = M.fromList
[ (ButtonAction 0 SDL.JoyButtonPressed, ActActivate)
, (ButtonAction 7 SDL.JoyButtonPressed, ActSwitchMap)
, (AxisAction 1 AxisNegative, ActUp 1)
, (AxisAction 1 AxisPositive, ActDown 1)
, (AxisAction 0 AxisNegative, ActLeft 1)
, (AxisAction 0 AxisPositive, ActRight 1)
2018-10-08 21:36:52 +00:00
]
2019-02-11 23:11:53 +00:00
defaultKbdTranslation :: M.Map SDL.Keycode Action
defaultKbdTranslation = M.fromList
[ (SDL.KeycodeSpace, ActActivate)
, (SDL.KeycodeF1, ActSwitchMap)
, (SDL.KeycodeW, ActUp 1)
, (SDL.KeycodeS, ActDown 1)
, (SDL.KeycodeA, ActLeft 1)
, (SDL.KeycodeD, ActRight 1)
]
data Translation
= JoyTranslation (M.Map JoypadAction Action)
| KbdTranslation (M.Map SDL.Keycode Action)
| NoTranslation
deriving (Show, Eq)
2018-10-08 21:36:52 +00:00
data Action
2019-02-11 23:11:53 +00:00
= ActActivate
| ActSwitchMap
| ActUp Double
| ActDown Double
| ActLeft Double
| ActRight Double
2018-10-12 12:26:06 +00:00
deriving (Show, Eq)
2018-10-08 21:36:52 +00:00
2019-02-11 23:11:53 +00:00
data JoypadAction
2018-10-12 12:26:06 +00:00
= ButtonAction Word8 SDL.JoyButtonState
2019-02-11 23:11:53 +00:00
| AxisAction Word8 AxisAlign
2018-10-12 12:26:06 +00:00
-- | HatAction Word SDL.JoyHatPosition
2018-10-08 21:36:52 +00:00
deriving (Show, Eq, Ord)
data AxisAlign
= AxisPositive
| AxisNegative
| AxisNeutral
deriving (Show, Eq, Ord)
2018-02-07 00:18:16 +00:00
data Subsystems = Subsystems
2018-10-08 21:36:52 +00:00
{ subWindow :: SubWindow
, subMouse :: SubMouse
, subkeyboard :: SubKeyboard
, subJoypad :: SubJoypad
, subTranslator :: SubTranslator
}
data ActionMessage = ActionMessage
{ amAction :: Action
, amTime :: Double
2018-02-07 00:18:16 +00:00
}
2018-10-08 21:36:52 +00:00
deriving (Eq, Show)
instance Message ActionMessage where
2018-10-12 12:26:06 +00:00
msgTime (ActionMessage _ t) = t
2018-02-07 00:18:16 +00:00
2020-05-04 22:52:24 +00:00
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection())])
newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype SubJoypad = SubJoypad (TVar [(UUID, JoystickMessage -> Affection ())])
newtype SubTranslator = SubTranslator (TVar [(UUID, ActionMessage -> Affection ())])
2018-02-07 00:18:16 +00:00
2020-05-04 22:52:24 +00:00
instance Participant SubWindow where
type Mesg SubWindow = 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
2020-05-04 22:52:24 +00:00
instance SDLSubsystem SubWindow where
2018-02-07 00:18:16 +00:00
consumeSDLEvents = consumeSDLWindowEvents
2020-05-04 22:52:24 +00:00
instance Participant SubMouse where
type Mesg SubMouse = 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
2020-05-04 22:52:24 +00:00
instance SDLSubsystem SubMouse where
2018-02-07 00:18:16 +00:00
consumeSDLEvents = consumeSDLMouseEvents
2020-05-04 22:52:24 +00:00
instance Participant SubKeyboard where
type Mesg SubKeyboard = 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
2020-05-04 22:52:24 +00:00
instance SDLSubsystem SubKeyboard where
2018-06-23 22:42:39 +00:00
consumeSDLEvents = consumeSDLKeyboardEvents
2020-05-04 22:52:24 +00:00
instance Participant SubJoypad where
type Mesg SubJoypad = JoystickMessage
2018-10-08 16:54:23 +00:00
partSubscribers (SubJoypad t) = generalSubscribers t
partSubscribe (SubJoypad t) = generalSubscribe t
partUnSubscribe (SubJoypad t) = generalUnSubscribe t
2020-05-04 22:52:24 +00:00
instance SDLSubsystem SubJoypad where
2018-10-08 16:54:23 +00:00
consumeSDLEvents = consumeSDLJoystickEvents
2020-05-04 22:52:24 +00:00
instance Participant SubTranslator where
type Mesg SubTranslator = ActionMessage
2018-10-08 21:36:52 +00:00
partSubscribers (SubTranslator t) = generalSubscribers t
partSubscribe (SubTranslator t) = generalSubscribe t
partUnSubscribe (SubTranslator t) = generalUnSubscribe t
2018-02-07 00:18:16 +00:00
generalSubscribers
2020-05-04 22:52:24 +00:00
:: TVar [(UUID, msg -> Affection ())]
-> Affection [(msg -> Affection ())]
2018-02-07 00:18:16 +00:00
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
2020-05-04 22:52:24 +00:00
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection ())
-> Affection UUID
2018-02-07 00:18:16 +00:00
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
2020-05-04 22:52:24 +00:00
:: TVar [(UUID, msg -> Affection ())]
2018-02-07 00:18:16 +00:00
-> UUID
2020-05-04 22:52:24 +00:00
-> Affection ()
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