tracer/src/Types/UserData.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

module Types.UserData where

import Affection

import qualified SDL

import Control.Concurrent.STM

import NanoVG hiding (V2(..), V3(..))

import qualified Data.Map.Strict as M
import Data.Text (Text(..))
import Data.Ecstasy

import Linear

data UserData = UserData
  { state       :: State
  , subsystems  :: Subsystems
  , assetImages :: M.Map ImgId Image
  , nano        :: Context
  , uuid        :: [UUID]
  , world       :: Entity 'WorldOf
  }

data State
  = Menu
  | Test

data ImgId
  = ImgFloor

data Direction
  = N
  | W
  | S
  | E
  | NW
  | SW
  | NE
  | SE

data Entity f = Entity
  { pos    :: Component f 'Field (V2 Float)
  , vel    :: Component f 'Field (V2 Float)
  , rot    :: Component f 'Field Direction
  , player :: Component f 'Unique Bool
  }
  deriving (Generic)

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

newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> 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

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
  uuid <- genUUID
  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
  return uuid

generalUnSubscribe
  :: TVar [(UUID, msg -> Affection UserData ())]
  -> UUID
  -> Affection UserData ()
generalUnSubscribe t uuid =
  liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
  where
    filterMsg (u, _) p = u /= p