loading screen

This commit is contained in:
nek0 2018-06-08 00:29:46 +02:00
parent c6d4cae284
commit fd8d5d81f0
7 changed files with 321 additions and 283 deletions

View file

@ -79,7 +79,7 @@ let
f = { mkDerivation, astar, base, containers, linear f = { mkDerivation, astar, base, containers, linear
, matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers , matrix, OpenGL, random, sdl2, stdenv, stm, text, unordered-containers
, vector, JuicyPixels, JuicyPixels-extra, bytestring , vector, JuicyPixels, JuicyPixels-extra, bytestring, monad-loops
}: }:
mkDerivation { mkDerivation {
pname = "tracer-game"; pname = "tracer-game";

View file

@ -43,11 +43,13 @@ foreign import ccall unsafe "glewInit"
load :: IO UserData load :: IO UserData
load = do load = do
_ <- glewInit
nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
subs <- Subsystems subs <- Subsystems
<$> (Window <$> newTVarIO []) <$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO []) <*> (Mouse <$> newTVarIO [])
_ <- glewInit
nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0 mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0 mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
@ -66,8 +68,6 @@ load = do
mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0 mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0 mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0 mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
let mimgs = [ mwallasc, mwalldesc, let mimgs = [ mwallasc, mwalldesc,
mwallcornern, mwallcornere, mwallcorners, mwallcornerw, mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross, mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,

View file

@ -81,21 +81,21 @@ placeNPCs
-> [ReachPoint] -> [ReachPoint]
-> [Graph] -> [Graph]
-> Int -> Int
-> Affection UserData [V2 Double] -> IO [V2 Double]
placeNPCs imgmat tilemat rp gr count = placeNPCs imgmat tilemat rp gr count =
doPlace 1 [] doPlace 1 []
where where
doPlace :: Int -> [V2 Double] -> Affection UserData [V2 Double] doPlace :: Int -> [V2 Double] -> IO [V2 Double]
doPlace nr acc = do doPlace nr acc = do
if nr <= count if nr <= count
then do then do
r <- liftIO $ randomRIO (1, M.nrows imgmat) r <- randomRIO (1, M.nrows imgmat)
c <- liftIO $ randomRIO (1, M.ncols imgmat) c <- randomRIO (1, M.ncols imgmat)
if null (imgObstacle $ imgmat M.! (r, c)) && if null (imgObstacle $ imgmat M.! (r, c)) &&
tilemat M.! (r, c) == Hall tilemat M.! (r, c) == Hall
then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc) then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
else do else do
i <- liftIO $ randomRIO (0, length nonexits - 1) i <- randomRIO (0, length nonexits - 1)
doPlace doPlace
(nr + 1) (nr + 1)
((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc) ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)

View file

@ -8,7 +8,7 @@ import NanoVG hiding (V2(..))
import Control.Monad (when, void) import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (forkOS) import Control.Concurrent (forkIO)
import Data.Map.Strict as Map import Data.Map.Strict as Map
import qualified Data.Set as S import qualified Data.Set as S
@ -35,12 +35,33 @@ import NPC
loadMap :: Affection UserData () loadMap :: Affection UserData ()
loadMap = do loadMap = do
ud <- getAffection ud <- getAffection
let (Subsystems _ m) = subsystems ud
ctx = nano ud
uu <- partSubscribe m movePlayer
future <- liftIO $ newEmptyMVar
_ <- liftIO $ forkIO $ loadMapFork ud future
-- liftIO $ whileM_ (isJust <$> tryTakeMVar future) $ do
-- beginFrame (nano ud) 1280 720 1
-- fontSize ctx 100
-- fontFace ctx (assetFonts ud Map.! FontBedstead)
-- textAlign ctx (S.fromList [AlignCenter,AlignTop])
-- fillColor ctx (rgb 255 128 0)
-- textBox ctx 0 300 1280 ("Loading")
-- endFrame (nano ud)
-- (nws, mendat) <- liftIO $ takeMVar future
putAffection ud
{ stateData = None
, uuid = [uu]
, menuMVar = future
}
loadMapFork :: UserData -> MVar (SystemState Entity IO, StateData) -> IO ()
loadMapFork ud future = do
let fc = FloorConfig let fc = FloorConfig
(10, 10) (10, 10)
[] []
(50, 50) (50, 50)
(Subsystems _ m) = subsystems ud (mat, gr) <- buildHallFloorIO fc
(mat, gr) <- liftIO $ buildHallFloorIO fc
let imgmat = convertTileToImg mat let imgmat = convertTileToImg mat
exits = Prelude.foldl exits = Prelude.foldl
(\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
@ -49,12 +70,12 @@ loadMap = do
) )
[] []
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
(inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr (inter, rps) <- placeInteriorIO mat imgmat exits gr
liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps)) logIO A.Debug ("number of reachpoints: " ++ show (length rps))
let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex) npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (V2 10.5 10.5) { pos = Just (V2 10.5 10.5)
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
@ -65,7 +86,7 @@ loadMap = do
void $ mapM_ (\npcpos@(V2 nr nc) -> do void $ mapM_ (\npcpos@(V2 nr nc) -> do
fact <- liftIO $ randomRIO (0.5, 1.5) fact <- liftIO $ randomRIO (0.5, 1.5)
future <- liftIO newEmptyMVar future <- liftIO newEmptyMVar
_ <- liftIO $ forkOS $ getPath (fmap floor npcpos) future nnex inter _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future nnex inter
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5)) { pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
@ -75,10 +96,7 @@ loadMap = do
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
} }
) npcposs ) npcposs
uu <- partSubscribe m movePlayer putMVar future (nws, MenuData
putAffection ud
{ worldState = nws
, stateData = MenuData
{ mapMat = mat { mapMat = mat
, imgMat = M.fromList (nrows inter) (ncols inter) $ , imgMat = M.fromList (nrows inter) (ncols inter) $
Prelude.map Prelude.map
@ -86,9 +104,7 @@ loadMap = do
(M.toList inter) (M.toList inter)
, initCoords = (0, 500) , initCoords = (0, 500)
, reachPoints = rps , reachPoints = rps
} })
, uuid = [uu]
}
mouseToPlayer :: V2 Int32 -> Affection UserData () mouseToPlayer :: V2 Int32 -> Affection UserData ()
mouseToPlayer mv2 = do mouseToPlayer mv2 = do
@ -126,6 +142,17 @@ movePlayer _ = return ()
drawMap :: Affection UserData () drawMap :: Affection UserData ()
drawMap = do drawMap = do
ud <- getAffection ud <- getAffection
let ctx = nano ud
case stateData ud of
None -> liftIO $ do
beginFrame (nano ud) 1280 720 1
fontSize ctx 100
fontFace ctx (assetFonts ud Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0)
textBox ctx 0 300 1280 ("Loading")
endFrame (nano ud)
_ -> do
dt <- getDelta dt <- getDelta
(_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
pc <- fmap head $ efor allEnts $ do pc <- fmap head $ efor allEnts $ do
@ -141,7 +168,6 @@ drawMap = do
return (pc, posanims) return (pc, posanims)
let V2 pr pc = playerPos let V2 pr pc = playerPos
mat = imgMat (stateData ud) mat = imgMat (stateData ud)
ctx = nano ud
cols = fromIntegral (ncols mat) cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat) rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double tileWidth = 64 :: Double
@ -268,11 +294,22 @@ drawTile ud ctx posanims pr pc row col img =
updateMap :: Double -> Affection UserData () updateMap :: Double -> Affection UserData ()
updateMap dt = do updateMap dt = do
ud <- getAffection
isFut <- liftIO $ isEmptyMVar (menuMVar ud)
if not isFut && stateData ud == None
then do
Just (nws, mendat) <- liftIO $ tryTakeMVar (menuMVar ud)
putAffection ud
{ worldState = nws
, stateData = mendat
}
else do
let direction :: V2 Double -> Direction -> Direction let direction :: V2 Double -> Direction -> Direction
direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0 direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
then then
let xuu = let xuu =
acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel')) / pi * 180 acos ((vel' `dot` V2 0 1) /
sqrt (vel' `dot` vel')) / pi * 180
xu = if vr < 0 then 360 - xuu else xuu xu = if vr < 0 then 360 - xuu else xuu
d d
| xu < 22.5 = NE | xu < 22.5 = NE
@ -287,7 +324,6 @@ updateMap dt = do
| otherwise = NE | otherwise = NE
in d in d
else rot' else rot'
ud <- getAffection
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
emap allEnts $ do emap allEnts $ do
with anim with anim

View file

@ -8,7 +8,7 @@ data ReachPoint = ReachPoint
, pointCoord :: V2 Int , pointCoord :: V2 Int
, pointDir :: Direction , pointDir :: Direction
} }
deriving (Show) deriving (Eq, Show)
data PointType data PointType
= RoomExit = RoomExit

View file

@ -14,3 +14,4 @@ data StateData
, imgMat :: Matrix (Maybe ImgId) , imgMat :: Matrix (Maybe ImgId)
, reachPoints :: [ReachPoint] , reachPoints :: [ReachPoint]
} }
deriving (Eq)

View file

@ -32,6 +32,7 @@ data UserData = UserData
, uuid :: [UUID] , uuid :: [UUID]
, worldState :: SystemState Entity IO , worldState :: SystemState Entity IO
, stateData :: StateData , stateData :: StateData
, menuMVar :: MVar (SystemState Entity IO, StateData)
} }
data State data State