more loading screens, but breaking things...

This commit is contained in:
nek0 2018-06-09 01:17:03 +02:00
parent fd8d5d81f0
commit ee62010d7f
13 changed files with 290 additions and 129 deletions

View file

@ -5,6 +5,7 @@ import qualified Data.Matrix as M
import Data.Maybe
import Control.Monad (foldM)
import Control.Concurrent.MVar
import System.Random
@ -12,17 +13,30 @@ import Types.Map
import Debug.Trace
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState, [Graph])
buildHallFloorIO fc = do
buildHallFloorIO
:: FloorConfig
-> MVar Float
-> Float
-> IO (Matrix TileState, [Graph])
buildHallFloorIO fc progress increment = do
rand <- newStdGen
modifyMVar_ progress (return . (+ increment))
let empty = emptyFloor fc
(g1, withElv) = buildElevator fc (placeHalls rand fc empty)
(g2, withIW) = buildInnerWalls g1 withElv
withOW = buildOuterWalls withIW
closed = closeOffices withOW
doorgraph = buildDoorsGraph closed
modifyMVar_ progress (return . (+ increment))
let (g1, withElv) = buildElevator fc (placeHalls rand fc empty)
modifyMVar_ progress (return . (+ increment))
let (g2, withIW) = buildInnerWalls g1 withElv
modifyMVar_ progress (return . (+ increment))
let withOW = buildOuterWalls withIW
modifyMVar_ progress (return . (+ increment))
let closed = closeOffices withOW
modifyMVar_ progress (return . (+ increment))
let doorgraph = buildDoorsGraph closed
modifyMVar_ progress (return . (+ increment))
doors <- buildDoors closed doorgraph
modifyMVar_ progress (return . (+ increment))
let (_, facils) = buildFacilities g2 fc doors
modifyMVar_ progress (return . (+ increment))
return (facils, doorgraph)
emptyFloor :: FloorConfig -> Matrix TileState

View file

@ -41,107 +41,26 @@ import Debug.Trace
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
load :: IO UserData
load = do
init :: IO UserData
init = do
subs <- Subsystems
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
_ <- glewInit
nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
(ws, _) <- yieldSystemT (0, defStorage) (return ())
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
mmisctable1 <- createImage nvg (FileName "assets/misc/table1.png") 0
mmisctable2 <- createImage nvg (FileName "assets/misc/table2.png") 0
mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
let mimgs = [ mwallasc, mwalldesc,
mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
mmiscbox1,
mmisctable1, mmisctable2, mmisctable3, mmisctable4, mmisctableC
]
when (any isNothing mimgs) $ do
logIO Error "Failed to load image assets"
exitFailure
-- playerImgs <- loadPlayerSprite "assets/intruder.png" 64 74 nvg
-- (zipWith (\a b -> (a, [b])) [0..] $ [ImgIntrE .. ImgIntrN] ++ [ImgIntrNE])
let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
directions = [E .. N] ++ [NE]
standIds = map (AnimId 0 "standing") directions
walkIds = map (AnimId 0 "walking") directions
standConfigs = map
(\i -> AnimationConfig (0, i * 74) (64, 74) 1 0 APLoop)
[0 .. length standIds - 1]
walkConfigs = map
(\i -> AnimationConfig (64, i * 74) (64, 74) 6 1.5 APLoop)
[0 .. length walkIds - 1]
playerStanding <- loadAnimationSprites "assets/intruder.png" nvg
(zip standIds standConfigs)
playerWalking <- loadAnimationSprites "assets/intruder.png" nvg
(zip walkIds walkConfigs)
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
return UserData
{ state = Menu
{ state = Load
, subsystems = subs
, assetImages = M.fromList imgs
, assetAnimations = M.fromList
(playerStanding ++ playerWalking)
, assetFonts = M.fromList
[ (FontBedstead, "bedstead")
]
, assetImages = M.empty
, assetAnimations = M.empty
, assetFonts = M.empty
, nano = nvg
, uuid = []
, worldState = ws
, stateData = None
}
loadAnimationSprites
:: FilePath -- Path to Sprite map
-> Context -- NanoVG context
-> [(AnimId, AnimationConfig)]
-> IO [(AnimId, Animation)]
loadAnimationSprites fp nvg idconfs = do
eimg <- readImage fp
case eimg of
Left err -> do
logIO Error err
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
mapM
(\(id, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
let crs = map
(\i -> crop (xoffs + (i * w)) yoffs w h img)
[0 .. (count - 1)]
mresimgs <- mapM
(\cr ->
createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr))
crs
imgs <- if any isNothing mresimgs
then do
logIO Error ("failed to load: " ++ fp ++ " " ++ show id)
exitFailure
else
return $ catMaybes mresimgs
return $
( id
, Animation dur imgs pb
)
) idconfs
loadPlayerSprite
:: FilePath -- Path to spritemap
-> Int -- width of single sprite

143
src/Load.hs Normal file
View file

@ -0,0 +1,143 @@
module Load where
import Affection as A
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Monad (when)
import qualified Data.Map as M
import Data.Ecstasy
import Data.Maybe
import System.Exit (exitFailure)
import NanoVG hiding (V2(..))
-- internal imports
import Types
import Test
import Util
loadLoad :: Affection UserData ()
loadLoad = do
ud <- getAffection
progress <- liftIO $ newMVar 0
future <- liftIO $ newEmptyMVar
_ <- liftIO $ forkIO $ loadFork (worldState ud) (nano ud) future progress
putAffection ud
{ stateMVar = future
, stateProgress = progress
, state = Load
}
loadFork
:: (SystemState Entity IO)
-> Context
-> MVar (SystemState Entity IO, StateData)
-> MVar Float
-> IO ()
loadFork ws nvg future progress = do
let stateSteps = 20
increment = 1 / stateSteps
_ <- createFont nvg "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf")
modifyMVar_ progress (return . (+ increment))
mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
modifyMVar_ progress (return . (+ increment))
mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
modifyMVar_ progress (return . (+ increment))
mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
modifyMVar_ progress (return . (+ increment))
mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
modifyMVar_ progress (return . (+ increment))
mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
modifyMVar_ progress (return . (+ increment))
mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
modifyMVar_ progress (return . (+ increment))
mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
modifyMVar_ progress (return . (+ increment))
mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
modifyMVar_ progress (return . (+ increment))
mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
modifyMVar_ progress (return . (+ increment))
mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
modifyMVar_ progress (return . (+ increment))
mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
modifyMVar_ progress (return . (+ increment))
mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
modifyMVar_ progress (return . (+ increment))
mmisctable1 <- createImage nvg (FileName "assets/misc/table1.png") 0
modifyMVar_ progress (return . (+ increment))
mmisctable2 <- createImage nvg (FileName "assets/misc/table2.png") 0
modifyMVar_ progress (return . (+ increment))
mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
modifyMVar_ progress (return . (+ increment))
mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
modifyMVar_ progress (return . (+ increment))
mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
modifyMVar_ progress (return . (+ increment))
let mimgs = [ mwallasc, mwalldesc,
mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
mmiscbox1,
mmisctable1, mmisctable2, mmisctable3, mmisctable4, mmisctableC
]
when (any isNothing mimgs) $ do
liftIO $logIO Error "Failed to load image assets"
exitFailure
-- playerImgs <- loadPlayerSprite "assets/intruder.png" 64 74 nvg
-- (zipWith (\a b -> (a, [b])) [0..] $ [ImgIntrE .. ImgIntrN] ++ [ImgIntrNE])
let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
directions = [E .. N] ++ [NE]
standIds = map (AnimId 0 "standing") directions
walkIds = map (AnimId 0 "walking") directions
standConfigs = map
(\i -> AnimationConfig (0, i * 74) (64, 74) 1 0 APLoop)
[0 .. length standIds - 1]
walkConfigs = map
(\i -> AnimationConfig (64, i * 74) (64, 74) 6 1.5 APLoop)
[0 .. length walkIds - 1]
playerStanding <- loadAnimationSprites "assets/intruder.png" nvg
(zip standIds standConfigs)
liftIO $modifyMVar_ progress (return . (+ increment))
playerWalking <- loadAnimationSprites "assets/intruder.png" nvg
(zip walkIds walkConfigs)
modifyMVar_ progress (return . (+ increment))
putMVar future
( ws
, LoadData
{ loadAssetImages = M.fromList imgs
, loadAssetAnims = M.fromList
(playerStanding ++ playerWalking)
, loadAssetFonts = M.fromList
[ (FontBedstead, "bedstead")
]
}
)
drawLoad :: Affection UserData ()
drawLoad = do
ud <- getAffection
let ctx = nano ud
progress <- liftIO $ readMVar (stateProgress ud)
liftIO $ drawLoadScreen ud progress
updateLoad :: Double -> Affection UserData ()
updateLoad _ = do
ud <- getAffection
mwsld <- liftIO $ tryTakeMVar (stateMVar ud)
case mwsld of
Just (_, ld) -> do
liftIO $ logIO A.Debug "loaded assets, entering menu"
putAffection ud
{ assetImages = loadAssetImages ld
, assetAnimations = loadAssetAnims ld
, assetFonts = loadAssetFonts ld
, state = Menu
, stateData = None
}
loadMap
Nothing -> do
return ()

View file

@ -27,11 +27,11 @@ main = do
}
}
, canvasSize = Nothing
, preLoop = pre >> smLoad Menu
, preLoop = pre >> smLoad Load
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, loadState = load
, loadState = Init.init
, cleanUp = const (return ())
, initScreenMode = SDL.Windowed
}

View file

@ -6,15 +6,22 @@ import Affection
import Types
import Load
import Test
instance StateMachine State UserData where
smLoad Menu = loadMap
smLoad Load = loadLoad
smUpdate Menu = updateMap
smUpdate Load = updateLoad
smDraw Menu = drawMap
smDraw Load = drawLoad
smEvent _ evs = do
Subsystems w m <- subsystems <$> getAffection
_ <- consumeSDLEvents w =<< consumeSDLEvents m evs

View file

@ -39,29 +39,29 @@ loadMap = do
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
progress <- liftIO $ newMVar 0
_ <- liftIO $ forkIO $ loadMapFork ud future progress
putAffection ud
{ stateData = None
, uuid = [uu]
, menuMVar = future
, stateMVar = future
, stateProgress = progress
}
loadMapFork :: UserData -> MVar (SystemState Entity IO, StateData) -> IO ()
loadMapFork ud future = do
let fc = FloorConfig
loadMapFork
:: UserData
-> MVar (SystemState Entity IO, StateData)
-> MVar Float
-> IO ()
loadMapFork ud future progress = do
let loadSteps = 16
fc = FloorConfig
(10, 10)
[]
(50, 50)
(mat, gr) <- buildHallFloorIO fc
_ <- liftIO $ swapMVar progress (1 / loadSteps)
(mat, gr) <- buildHallFloorIO fc progress (1 / loadSteps)
_ <- liftIO $ swapMVar progress (11 / loadSteps)
let imgmat = convertTileToImg mat
exits = Prelude.foldl
(\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty
@ -70,10 +70,13 @@ loadMapFork ud future = do
)
[]
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
_ <- liftIO $ swapMVar progress (12 / loadSteps)
(inter, rps) <- placeInteriorIO mat imgmat exits gr
_ <- liftIO $ swapMVar progress (13 / loadSteps)
logIO A.Debug ("number of reachpoints: " ++ show (length rps))
let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
_ <- liftIO $ swapMVar progress (14 / loadSteps)
A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
(nws, _) <- yieldSystemT (worldState ud) $ do
void $ createEntity $ newEntity
@ -83,6 +86,7 @@ loadMapFork ud future = do
, rot = Just SE
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
}
void $ liftIO $ swapMVar progress (15 / loadSteps)
void $ mapM_ (\npcpos@(V2 nr nc) -> do
fact <- liftIO $ randomRIO (0.5, 1.5)
future <- liftIO newEmptyMVar
@ -96,6 +100,7 @@ loadMapFork ud future = do
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
}
) npcposs
void $ liftIO $ swapMVar progress (16 / loadSteps)
putMVar future (nws, MenuData
{ mapMat = mat
, imgMat = M.fromList (nrows inter) (ncols inter) $
@ -145,13 +150,8 @@ drawMap = do
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)
progress <- readMVar (stateProgress ud)
drawLoadScreen ud progress
_ -> do
dt <- getDelta
(_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
@ -295,10 +295,11 @@ drawTile ud ctx posanims pr pc row col img =
updateMap :: Double -> Affection UserData ()
updateMap dt = do
ud <- getAffection
isFut <- liftIO $ isEmptyMVar (menuMVar ud)
isFut <- liftIO $ isEmptyMVar (stateMVar ud)
if not isFut && stateData ud == None
then do
Just (nws, mendat) <- liftIO $ tryTakeMVar (menuMVar ud)
liftIO $ logIO A.Debug "Loaded game data"
Just (nws, mendat) <- liftIO $ tryTakeMVar (stateMVar ud)
putAffection ud
{ worldState = nws
, stateData = mendat

View file

@ -7,6 +7,7 @@ import Types.Map as T
import Types.Interior as T
import Types.ReachPoint as T
import Types.ImgId as T
import Types.FontId as T
import Types.Direction as T
import Types.StateData as T
import Types.Animation as T

View file

@ -16,17 +16,19 @@ data AnimState = AnimState
, asCurrentFrame :: Int
, asElapsedTime :: Double
}
deriving (Show)
deriving (Show, Eq)
data AnimPlayback
= APLoop
| APOnce
deriving (Show, Eq)
data Animation = Animation
{ animDuration :: Double
, animSprites :: [Image]
, animPlay :: AnimPlayback
}
deriving (Show, Eq)
data AnimationConfig = AnimationConfig
{ animConfOffset :: (Int, Int)
@ -35,3 +37,4 @@ data AnimationConfig = AnimationConfig
, animConfDuration :: Double
, animConfPlay :: AnimPlayback
}
deriving (Show, Eq)

5
src/Types/FontId.hs Normal file
View file

@ -0,0 +1,5 @@
module Types.FontId where
data FontId
= FontBedstead
deriving (Show, Eq, Ord, Enum)

View file

@ -1,13 +1,24 @@
module Types.StateData where
import Data.Matrix
import Data.Map
import Data.Text
import NanoVG
import Types.ReachPoint
import Types.Map
import Types.ImgId
import Types.FontId
import Types.Animation
data StateData
= None
| LoadData
{ loadAssetImages :: Map ImgId Image
, loadAssetAnims :: Map AnimId Animation
, loadAssetFonts :: Map FontId Text
}
| MenuData
{ mapMat :: Matrix TileState
, initCoords :: (Int, Int)

View file

@ -19,6 +19,7 @@ import Control.Concurrent.MVar
import Types.Map
import Types.StateData
import Types.ImgId
import Types.FontId
import Types.Direction
import Types.Animation
@ -32,17 +33,15 @@ data UserData = UserData
, uuid :: [UUID]
, worldState :: SystemState Entity IO
, stateData :: StateData
, menuMVar :: MVar (SystemState Entity IO, StateData)
, stateMVar :: MVar (SystemState Entity IO, StateData)
, stateProgress :: MVar Float
}
data State
= Menu
= Load
| Menu
| Test
data FontId
= FontBedstead
deriving (Show, Eq, Ord, Enum)
data Entity f = Entity
{ pos :: Component f 'Field (V2 Double)
, gridPos :: Component f 'Field (V2 Int)

View file

@ -4,14 +4,25 @@ import Affection as A
import Data.Matrix as M
import qualified Data.HashSet as HS
import qualified Data.Set as S
import qualified Data.Map as Map
import Data.ByteString.Lazy (toStrict)
import Data.Graph.AStar
import Data.Maybe (fromMaybe)
import Data.Maybe
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import System.Exit (exitFailure)
import Linear
import NanoVG hiding (V2(..))
import NanoVG.Internal.Image (ImageFlags(..))
import Codec.Picture as CP
import Codec.Picture.Extra
-- internal imports
import Types
@ -161,3 +172,48 @@ naviGraph imgmat (V2 r c) =
[]
[(-1, -1), (-1, 1), (1, -1), (1, 1)]
in HS.fromList (list1 ++ list2)
drawLoadScreen :: UserData -> Float -> IO ()
drawLoadScreen ud progress = do
let ctx = nano ud
-- fontSize ctx 100
-- fontFace ctx (assetFonts ud Map.! FontBedstead)
-- textAlign ctx (S.fromList [AlignCenter, AlignTop])
fillColor ctx (rgb 255 128 0)
rect ctx
(640 - 640 * realToFrac progress) 450 (1280 * realToFrac progress) 20
fill ctx
loadAnimationSprites
:: FilePath -- Path to Sprite map
-> Context -- NanoVG context
-> [(AnimId, AnimationConfig)]
-> IO [(AnimId, Animation)]
loadAnimationSprites fp nvg idconfs = do
eimg <- readImage fp
case eimg of
Left err -> do
logIO Error err
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
mapM
(\(id, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
let crs = map
(\i -> crop (xoffs + (i * w)) yoffs w h img)
[0 .. (count - 1)]
mresimgs <- mapM
(\cr ->
createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr))
crs
imgs <- if any isNothing mresimgs
then do
logIO Error ("failed to load: " ++ fp ++ " " ++ show id)
exitFailure
else
return $ catMaybes mresimgs
return $
( id
, Animation dur imgs pb
)
) idconfs

View file

@ -24,12 +24,14 @@ executable tracer-game
, Types.ReachPoint
, Types.Direction
, Types.ImgId
, Types.FontId
, Types.StateData
, Types.Animation
, StateMachine
, Floorplan
, Interior
, Init
, Load
, Test
, Navigation
, NPC