tracer/src/Types/UserData.hs

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

module Types.UserData where

import Affection

import Control.Concurrent.STM

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

import qualified Data.Map.Strict as M
import Data.Matrix
import Data.Ecstasy

import Types.Map

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

data State
  = Menu
  | Test

data StateData
  = None
  | MenuData
    { mapMat :: Matrix TileState
    , initCoords :: (Int, Int)
    }

data ImgId
  = ImgFloor

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

data Entity f = Entity
  { pos     :: Component f 'Field (V2 Double)
  , gridPos :: Component f 'Field (V2 Int)
  , vel     :: Component f 'Field (V2 Double)
  , 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
  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