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
import Types.Entity
import Types.NPCState

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

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
--   , objState      :: Component f 'Field ObjState
--   , objStateTime  :: Component f 'Field Double
--   }
--   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