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 qualified Data.Text as T
import Data.Matrix
import Data.Ecstasy

import Control.Concurrent.MVar

import Types.Map
import Types.ReachPoint

data UserData = UserData
  { state       :: State
  , subsystems  :: Subsystems
  , assetImages :: M.Map ImgId Image
  , assetFonts  :: M.Map FontId T.Text
  , nano        :: Context
  , uuid        :: [UUID]
  , worldState  :: SystemState Entity IO
  , stateData   :: StateData
  }

data State
  = Menu
  | Test

data StateData
  = None
  | MenuData
    { mapMat      :: Matrix TileState
    , initCoords  :: (Int, Int)
    , imgMat      :: Matrix (Maybe ImgId)
    , reachPoints :: [ReachPoint]
    }

data ImgId
  = ImgEmpty -- TODO: Find better solution thatn empty image.
  | ImgWallAsc
  | ImgWallDesc
  | ImgWallCornerN
  | ImgWallCornerE
  | ImgWallCornerS
  | ImgWallCornerW
  | ImgWallTNE
  | ImgWallTSE
  | ImgWallTSW
  | ImgWallTNW
  | ImgWallCross
  | ImgMiscBox1
  | ImgMiscTable1
  | ImgMiscTable2
  | ImgMiscTable3
  | ImgMiscTable4
  | ImgMiscTableCorner
  | ImgIntrE
  | ImgIntrSE
  | ImgIntrS
  | ImgIntrSW
  | ImgIntrW
  | ImgIntrNW
  | ImgIntrN
  | ImgIntrNE
  deriving (Show, Eq, Ord, Enum)

isWall :: ImgId -> Bool
isWall ImgMiscBox1 = False
isWall ImgMiscTable1 = False
isWall ImgMiscTable2 = False
isWall ImgMiscTable3 = False
isWall ImgMiscTable4 = False
isWall ImgMiscTableCorner = False
isWall _ = True

imgObstacle :: Maybe ImgId -> [(Boundaries Double)]
imgObstacle (Just ImgMiscBox1) = [Boundaries (0.2, 0.34) (0.8, 1)]
imgObstacle (Just ImgWallAsc) = [Boundaries (0.34, 0) (0.66, 1)]
imgObstacle (Just ImgWallDesc) = [Boundaries (0, 0.34) (1, 0.66)]
imgObstacle (Just ImgWallCornerN) =
  [ Boundaries (0, 0.34) (0.66, 0.66)
  , Boundaries (0.34, 0.34) (0.66, 1)
  ]
imgObstacle (Just ImgWallCornerE) =
  [ Boundaries (0.34, 0.34) (1, 0.66)
  , Boundaries (0.34, 0.34) (0.66, 1)
  ]
imgObstacle (Just ImgWallCornerS) =
  [ Boundaries (0.34, 0.34) (1, 0.66)
  , Boundaries (0.34, 0) (0.66, 0.66)
  ]
imgObstacle (Just ImgWallCornerW) =
  [ Boundaries (0, 0.34) (0.66, 0.66)
  , Boundaries (0.34, 0) (0.66, 0.66)
  ]
imgObstacle (Just ImgWallTNE) =
  [ Boundaries (0, 0.34) (1, 0.66)
  , Boundaries (0.34, 0.34) (0.66, 1)
  ]
imgObstacle (Just ImgWallTSW) =
  [ Boundaries (0, 0.34) (1, 0.66)
  , Boundaries (0.34, 0) (0.66, 0.66)
  ]
imgObstacle (Just ImgWallTSE) =
  [ Boundaries (0.34, 0) (0.66, 1)
  , Boundaries (0.34, 0.34) (1, 0.66)
  ]
imgObstacle (Just ImgWallTNW) =
  [ Boundaries (0.34, 0) (0.66, 1)
  , Boundaries (0, 0.34) (0.66, 0.66)
  ]
imgObstacle (Just ImgWallCross) =
  [ Boundaries (0.34, 0) (0.66, 1)
  , Boundaries (0, 0.34) (1, 0.66)
  ]
imgObstacle (Just ImgMiscTable1) =
  [ Boundaries (0, 0.34) (1, 1)
  ]
imgObstacle (Just ImgMiscTable2) =
  [ Boundaries (0, 0) (0.63, 1)
  ]
imgObstacle (Just ImgMiscTable3) =
  [ Boundaries (0, 0) (1, 0.63)
  ]
imgObstacle (Just ImgMiscTable4) =
  [ Boundaries (0.34, 0) (1, 1)
  ]
imgObstacle (Just ImgMiscTableCorner) =
  [ Boundaries (0, 0) (0.63, 1)
  , Boundaries (0, 0.34) (1, 1)
  ]
imgObstacle _ = []

data FontId
  = FontBedstead
  deriving (Show, Eq, Ord, Enum)

data Direction
  = NE
  | E
  | SE
  | S
  | SW
  | W
  | NW
  | N
  deriving (Show, Eq, Ord, Enum)

dirToImgId :: Direction -> ImgId
dirToImgId E  = ImgIntrE
dirToImgId SE = ImgIntrSE
dirToImgId S  = ImgIntrS
dirToImgId SW = ImgIntrSW
dirToImgId W  = ImgIntrW
dirToImgId NW = ImgIntrNW
dirToImgId N  = ImgIntrN
dirToImgId NE = ImgIntrNE

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

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

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