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