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.Map
import Types.StateData
import Types.ImgId
import Types.FontId
import Types.Direction
import Types.Animation
import Types.ObjType

data UserData = UserData
  { state           :: State
  , subsystems      :: Subsystems
  , assetImages     :: M.Map ImgId Image
  , assetFonts      :: M.Map FontId T.Text
  , assetAnimations :: M.Map AnimId Animation
  , nano            :: Context
  , uuid            :: [UUID]
  , worldState      :: SystemState Entity IO
  , stateData       :: StateData
  , stateMVar       :: MVar (SystemState Entity IO, StateData)
  , stateProgress   :: MVar (Float, T.Text)
  , threadContext   :: Maybe SDL.GLContext
  , window          :: Maybe SDL.Window
  }

data State
  = Load
  | Main SubMain

data SubMain
  = WorldMap
  | MindMap

data Entity f = Entity
  { pos           :: Component f 'Field (V2 Double)
  , mmpos         :: Component f 'Field (V2 Double)
  , gridPos       :: Component f 'Field (V2 Int)
  , vel           :: Component f 'Field (V2 Double)
  , mmvel         :: Component f 'Field (V2 Double)
  , velFact       :: Component f 'Field Double
  , rot           :: Component f 'Field Direction
  , obstacle      :: Component f 'Field (Boundaries Double)
  , player        :: Component f 'Unique ()
  , npcMoveState  :: Component f 'Field NPCMoveState
  , anim          :: Component f 'Field AnimState
  , objAccess     :: Component f 'Field ((V2 Int), Direction)
  , objType       :: Component f 'Field ObjType
  }
  deriving (Generic)

data NPCMoveState
  = NPCWalking
    { npcWalkPath :: [V2 Int]
    }
  | NPCStanding
    { npcStandTime  :: Double
    , npcFuturePath :: MVar [V2 Int]
    }

data Subsystems = Subsystems
  { subWindow   :: Window
  , subMouse    :: Mouse
  , subkeyboard :: Keyboard
  }

newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])

instance Participant Window UserData where
  type Mesg Window UserData = WindowMessage

  partSubscribers (Window t) = generalSubscribers t

  partSubscribe (Window t) = generalSubscribe t

  partUnSubscribe (Window t) = generalUnSubscribe t

instance SDLSubsystem Window UserData where
  consumeSDLEvents = consumeSDLWindowEvents

instance Participant Mouse UserData where
  type Mesg Mouse UserData = MouseMessage

  partSubscribers (Mouse t) = generalSubscribers t

  partSubscribe (Mouse t) = generalSubscribe t

  partUnSubscribe (Mouse t) = generalUnSubscribe t

instance SDLSubsystem Mouse UserData where
  consumeSDLEvents = consumeSDLMouseEvents

instance Participant Keyboard UserData where
  type Mesg Keyboard UserData = KeyboardMessage

  partSubscribers (Keyboard t) = generalSubscribers t

  partSubscribe (Keyboard t) = generalSubscribe t

  partUnSubscribe (Keyboard t) = generalUnSubscribe t

instance SDLSubsystem Keyboard UserData where
  consumeSDLEvents = consumeSDLKeyboardEvents

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