tracer/src/Types/UserData.hs

{-# 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 Control.Monad.Trans.Resource

import Types.StateData
import Types.ImgId
import Types.FontId
import Types.Animation
import Types.Entity

data UserData = UserData
  { state           :: MVar State
  , subsystems      :: Subsystems
  , 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)
  , controls        :: MVar Controller
  , translation     :: MVar Translation
  , nano            :: Context
  , uuid            :: MVar [UUID]
  , worldState      :: MVar (SystemState Entity (AffectionState AffectionData ResIO))
  , stateData       :: MVar StateData
  , stateMVar       :: MVar
    ( SystemState Entity (AffectionState AffectionData ResIO)
    , StateData
    )
  , stateProgress   :: MVar (Float, T.Text)
  , threadContext   :: MVar (Maybe SDL.GLContext)
  , window          :: MVar (Maybe SDL.Window)
  , joyCache        :: MVar [JoystickMessage]
  , joyUUID         :: MVar UUID
  , doNextStep      :: MVar Bool
  }

data Controller
  = NoController
  | Keyboard
  | Joystick SDL.Joystick
  deriving (Eq, Show)

data State
  = Load
  | Menu SubMenu
  | Main SubMain
  deriving (Eq, Show)

data SubMain
  = WorldMap
  | MindMap
  deriving (Eq, Show)

data SubMenu
  = Connect
  | Adjust Action Controller
  deriving (Eq, Show)

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)
  ]

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)

data Action
  = ActActivate
  | ActSwitchMap
  | ActUp Double
  | ActDown Double
  | ActLeft Double
  | ActRight Double
  deriving (Show, Eq)

data JoypadAction
  = ButtonAction Word8 SDL.JoyButtonState
  | AxisAction Word8 AxisAlign
  -- | 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())])
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 ())])

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 SubJoypad where
  type Mesg SubJoypad = JoystickMessage

  partSubscribers (SubJoypad t) = generalSubscribers t

  partSubscribe (SubJoypad t) = generalSubscribe t

  partUnSubscribe (SubJoypad t) = generalUnSubscribe t

instance SDLSubsystem SubJoypad where
  consumeSDLEvents = consumeSDLJoystickEvents

instance Participant SubTranslator where
  type Mesg SubTranslator = ActionMessage

  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