2018-02-07 00:18:16 +00:00
|
|
|
{-# 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
|
2018-03-01 22:33:08 +00:00
|
|
|
import qualified Data.Text as T
|
2018-02-17 01:36:06 +00:00
|
|
|
import Data.Matrix
|
2018-02-07 00:18:16 +00:00
|
|
|
import Data.Ecstasy
|
|
|
|
|
2018-02-17 01:36:06 +00:00
|
|
|
import Types.Map
|
|
|
|
|
2018-02-07 00:18:16 +00:00
|
|
|
data UserData = UserData
|
|
|
|
{ state :: State
|
|
|
|
, subsystems :: Subsystems
|
|
|
|
, assetImages :: M.Map ImgId Image
|
2018-03-01 22:33:08 +00:00
|
|
|
, assetFonts :: M.Map FontId T.Text
|
2018-02-07 00:18:16 +00:00
|
|
|
, nano :: Context
|
|
|
|
, uuid :: [UUID]
|
2018-02-24 14:33:46 +00:00
|
|
|
, worldState :: SystemState Entity
|
2018-02-17 01:36:06 +00:00
|
|
|
, stateData :: StateData
|
2018-02-07 00:18:16 +00:00
|
|
|
}
|
|
|
|
|
|
|
|
data State
|
|
|
|
= Menu
|
|
|
|
| Test
|
|
|
|
|
2018-02-17 01:36:06 +00:00
|
|
|
data StateData
|
|
|
|
= None
|
|
|
|
| MenuData
|
|
|
|
{ mapMat :: Matrix TileState
|
2018-02-23 12:07:24 +00:00
|
|
|
, initCoords :: (Int, Int)
|
2018-03-02 01:10:35 +00:00
|
|
|
, imgMat :: Matrix (Maybe ImgId)
|
2018-02-17 01:36:06 +00:00
|
|
|
}
|
|
|
|
|
2018-02-07 00:18:16 +00:00
|
|
|
data ImgId
|
2018-03-31 21:22:10 +00:00
|
|
|
= ImgEmpty -- TODO: Find better solution thatn empty image.
|
|
|
|
| ImgWallAsc
|
2018-02-27 19:35:08 +00:00
|
|
|
| ImgWallDesc
|
|
|
|
| ImgWallCornerN
|
|
|
|
| ImgWallCornerE
|
|
|
|
| ImgWallCornerS
|
|
|
|
| ImgWallCornerW
|
|
|
|
| ImgWallTNE
|
|
|
|
| ImgWallTSE
|
|
|
|
| ImgWallTSW
|
|
|
|
| ImgWallTNW
|
|
|
|
| ImgWallCross
|
2018-03-03 16:03:17 +00:00
|
|
|
| ImgMiscBox1
|
2018-03-31 21:22:10 +00:00
|
|
|
| ImgMiscTable1
|
|
|
|
| ImgMiscTable2
|
|
|
|
| ImgMiscTableCorner
|
2018-02-27 19:35:08 +00:00
|
|
|
deriving (Show, Eq, Ord, Enum)
|
2018-02-07 00:18:16 +00:00
|
|
|
|
2018-03-03 16:03:17 +00:00
|
|
|
isWall :: ImgId -> Bool
|
|
|
|
isWall ImgMiscBox1 = False
|
2018-03-31 21:22:10 +00:00
|
|
|
isWall ImgMiscTable1 = False
|
|
|
|
isWall ImgMiscTable2 = False
|
|
|
|
isWall ImgMiscTableCorner = False
|
2018-03-03 16:03:17 +00:00
|
|
|
isWall _ = True
|
2018-03-04 21:24:30 +00:00
|
|
|
|
2018-03-05 20:11:38 +00:00
|
|
|
imgObstacle :: Maybe ImgId -> [(Boundaries Double)]
|
|
|
|
imgObstacle (Just ImgMiscBox1) = [Boundaries (0.2, 0.34) (0.8, 1)]
|
2018-03-08 19:19:53 +00:00
|
|
|
imgObstacle (Just ImgWallAsc) = [Boundaries (0.34, 0) (0.66, 1)]
|
|
|
|
imgObstacle (Just ImgWallDesc) = [Boundaries (0, 0.34) (1, 0.66)]
|
2018-03-05 20:11:38 +00:00
|
|
|
imgObstacle (Just ImgWallCornerN) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0, 0.34) (0.66, 0.66)
|
|
|
|
, Boundaries (0.34, 0.34) (0.66, 1)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallCornerE) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0.34, 0.34) (1, 0.66)
|
|
|
|
, Boundaries (0.34, 0.34) (0.66, 1)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallCornerS) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0.34, 0.34) (1, 0.66)
|
|
|
|
, Boundaries (0.34, 0) (0.66, 0.66)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallCornerW) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0, 0.34) (0.66, 0.66)
|
|
|
|
, Boundaries (0.34, 0) (0.66, 0.66)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallTNE) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0, 0.34) (1, 0.66)
|
|
|
|
, Boundaries (0.34, 0.34) (0.66, 1)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallTSW) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0, 0.34) (1, 0.66)
|
|
|
|
, Boundaries (0.34, 0) (0.66, 0.66)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallTSE) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0.34, 0) (0.66, 1)
|
|
|
|
, Boundaries (0.34, 0.34) (1, 0.66)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallTNW) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0.34, 0) (0.66, 1)
|
|
|
|
, Boundaries (0, 0.34) (0.66, 0.66)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
|
|
|
imgObstacle (Just ImgWallCross) =
|
2018-03-08 19:19:53 +00:00
|
|
|
[ Boundaries (0.34, 0) (0.66, 1)
|
|
|
|
, Boundaries (0, 0.34) (1, 0.66)
|
2018-03-05 20:11:38 +00:00
|
|
|
]
|
2018-03-31 21:22:10 +00:00
|
|
|
imgObstacle (Just ImgMiscTable1) =
|
|
|
|
[ Boundaries (0, 0.34) (1, 1)
|
|
|
|
]
|
|
|
|
imgObstacle (Just ImgMiscTable2) =
|
|
|
|
[ Boundaries (0, 0) (0.63, 1)
|
|
|
|
]
|
|
|
|
imgObstacle (Just ImgMiscTableCorner) =
|
|
|
|
[ Boundaries (0, 0) (0.63, 1)
|
|
|
|
, Boundaries (0, 0.34) (1, 1)
|
|
|
|
]
|
2018-03-05 20:11:38 +00:00
|
|
|
imgObstacle _ = []
|
2018-03-03 16:03:17 +00:00
|
|
|
|
2018-03-01 22:33:08 +00:00
|
|
|
data FontId
|
|
|
|
= FontBedstead
|
|
|
|
deriving (Show, Eq, Ord, Enum)
|
|
|
|
|
2018-02-07 00:18:16 +00:00
|
|
|
data Direction
|
|
|
|
= N
|
|
|
|
| W
|
|
|
|
| S
|
|
|
|
| E
|
|
|
|
| NW
|
|
|
|
| SW
|
|
|
|
| NE
|
|
|
|
| SE
|
|
|
|
|
|
|
|
data Entity f = Entity
|
2018-03-03 16:03:17 +00:00
|
|
|
{ pos :: Component f 'Field (V2 Double)
|
|
|
|
, gridPos :: Component f 'Field (V2 Int)
|
|
|
|
, vel :: Component f 'Field (V2 Double)
|
|
|
|
, rot :: Component f 'Field Direction
|
|
|
|
, obstacle :: Component f 'Field (Boundaries Double)
|
|
|
|
, player :: Component f 'Unique Bool
|
2018-02-07 00:18:16 +00:00
|
|
|
}
|
|
|
|
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
|
2018-02-18 02:11:41 +00:00
|
|
|
uu <- genUUID
|
|
|
|
liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
|
|
|
|
return uu
|
2018-02-07 00:18:16 +00:00
|
|
|
|
|
|
|
generalUnSubscribe
|
|
|
|
:: TVar [(UUID, msg -> Affection UserData ())]
|
|
|
|
-> UUID
|
|
|
|
-> Affection UserData ()
|
2018-02-18 02:11:41 +00:00
|
|
|
generalUnSubscribe t uu =
|
|
|
|
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
|
2018-02-07 00:18:16 +00:00
|
|
|
where
|
|
|
|
filterMsg (u, _) p = u /= p
|