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

View file

@ -41,107 +41,26 @@ import Debug.Trace
foreign import ccall unsafe "glewInit" foreign import ccall unsafe "glewInit"
glewInit :: IO CInt glewInit :: IO CInt
load :: IO UserData init :: IO UserData
load = do init = do
subs <- Subsystems subs <- Subsystems
<$> (Window <$> newTVarIO []) <$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO []) <*> (Mouse <$> newTVarIO [])
_ <- glewInit _ <- 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 nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
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)
return UserData return UserData
{ state = Menu { state = Load
, subsystems = subs , subsystems = subs
, assetImages = M.fromList imgs , assetImages = M.empty
, assetAnimations = M.fromList , assetAnimations = M.empty
(playerStanding ++ playerWalking) , assetFonts = M.empty
, assetFonts = M.fromList
[ (FontBedstead, "bedstead")
]
, nano = nvg , nano = nvg
, uuid = [] , uuid = []
, worldState = ws , worldState = ws
, stateData = None , 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 loadPlayerSprite
:: FilePath -- Path to spritemap :: FilePath -- Path to spritemap
-> Int -- width of single sprite -> 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 , canvasSize = Nothing
, preLoop = pre >> smLoad Menu , preLoop = pre >> smLoad Load
, eventLoop = handle , eventLoop = handle
, updateLoop = update , updateLoop = update
, drawLoop = draw , drawLoop = draw
, loadState = load , loadState = Init.init
, cleanUp = const (return ()) , cleanUp = const (return ())
, initScreenMode = SDL.Windowed , initScreenMode = SDL.Windowed
} }

View file

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

View file

@ -39,29 +39,29 @@ loadMap = do
ctx = nano ud ctx = nano ud
uu <- partSubscribe m movePlayer uu <- partSubscribe m movePlayer
future <- liftIO $ newEmptyMVar future <- liftIO $ newEmptyMVar
_ <- liftIO $ forkIO $ loadMapFork ud future progress <- liftIO $ newMVar 0
-- liftIO $ whileM_ (isJust <$> tryTakeMVar future) $ do _ <- liftIO $ forkIO $ loadMapFork ud future progress
-- 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 putAffection ud
{ stateData = None { stateData = None
, uuid = [uu] , uuid = [uu]
, menuMVar = future , stateMVar = future
, stateProgress = progress
} }
loadMapFork :: UserData -> MVar (SystemState Entity IO, StateData) -> IO () loadMapFork
loadMapFork ud future = do :: UserData
let fc = FloorConfig -> MVar (SystemState Entity IO, StateData)
-> MVar Float
-> IO ()
loadMapFork ud future progress = do
let loadSteps = 16
fc = FloorConfig
(10, 10) (10, 10)
[] []
(50, 50) (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 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
@ -70,10 +70,13 @@ loadMapFork ud future = do
) )
[] []
((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat])
_ <- liftIO $ swapMVar progress (12 / loadSteps)
(inter, rps) <- placeInteriorIO mat imgmat exits gr (inter, rps) <- placeInteriorIO mat imgmat exits gr
_ <- liftIO $ swapMVar progress (13 / loadSteps)
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 $ swapMVar progress (14 / loadSteps)
A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
(nws, _) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
void $ createEntity $ newEntity void $ createEntity $ newEntity
@ -83,6 +86,7 @@ loadMapFork ud future = do
, rot = Just SE , rot = Just SE
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
} }
void $ liftIO $ swapMVar progress (15 / loadSteps)
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
@ -96,6 +100,7 @@ loadMapFork ud future = do
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
} }
) npcposs ) npcposs
void $ liftIO $ swapMVar progress (16 / loadSteps)
putMVar future (nws, MenuData putMVar future (nws, MenuData
{ mapMat = mat { mapMat = mat
, imgMat = M.fromList (nrows inter) (ncols inter) $ , imgMat = M.fromList (nrows inter) (ncols inter) $
@ -145,13 +150,8 @@ drawMap = do
let ctx = nano ud let ctx = nano ud
case stateData ud of case stateData ud of
None -> liftIO $ do None -> liftIO $ do
beginFrame (nano ud) 1280 720 1 progress <- readMVar (stateProgress ud)
fontSize ctx 100 drawLoadScreen ud progress
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 _ -> do
dt <- getDelta dt <- getDelta
(_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do (_, (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 :: Double -> Affection UserData ()
updateMap dt = do updateMap dt = do
ud <- getAffection ud <- getAffection
isFut <- liftIO $ isEmptyMVar (menuMVar ud) isFut <- liftIO $ isEmptyMVar (stateMVar ud)
if not isFut && stateData ud == None if not isFut && stateData ud == None
then do 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 putAffection ud
{ worldState = nws { worldState = nws
, stateData = mendat , stateData = mendat

View file

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

View file

@ -16,17 +16,19 @@ data AnimState = AnimState
, asCurrentFrame :: Int , asCurrentFrame :: Int
, asElapsedTime :: Double , asElapsedTime :: Double
} }
deriving (Show) deriving (Show, Eq)
data AnimPlayback data AnimPlayback
= APLoop = APLoop
| APOnce | APOnce
deriving (Show, Eq)
data Animation = Animation data Animation = Animation
{ animDuration :: Double { animDuration :: Double
, animSprites :: [Image] , animSprites :: [Image]
, animPlay :: AnimPlayback , animPlay :: AnimPlayback
} }
deriving (Show, Eq)
data AnimationConfig = AnimationConfig data AnimationConfig = AnimationConfig
{ animConfOffset :: (Int, Int) { animConfOffset :: (Int, Int)
@ -35,3 +37,4 @@ data AnimationConfig = AnimationConfig
, animConfDuration :: Double , animConfDuration :: Double
, animConfPlay :: AnimPlayback , 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 module Types.StateData where
import Data.Matrix import Data.Matrix
import Data.Map
import Data.Text
import NanoVG
import Types.ReachPoint import Types.ReachPoint
import Types.Map import Types.Map
import Types.ImgId import Types.ImgId
import Types.FontId
import Types.Animation
data StateData data StateData
= None = None
| LoadData
{ loadAssetImages :: Map ImgId Image
, loadAssetAnims :: Map AnimId Animation
, loadAssetFonts :: Map FontId Text
}
| MenuData | MenuData
{ mapMat :: Matrix TileState { mapMat :: Matrix TileState
, initCoords :: (Int, Int) , initCoords :: (Int, Int)

View file

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

View file

@ -4,14 +4,25 @@ import Affection as A
import Data.Matrix as M import Data.Matrix as M
import qualified Data.HashSet as HS 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.Graph.AStar
import Data.Maybe (fromMaybe) import Data.Maybe
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get) import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import System.Exit (exitFailure)
import Linear import Linear
import NanoVG hiding (V2(..))
import NanoVG.Internal.Image (ImageFlags(..))
import Codec.Picture as CP
import Codec.Picture.Extra
-- internal imports -- internal imports
import Types import Types
@ -161,3 +172,48 @@ naviGraph imgmat (V2 r c) =
[] []
[(-1, -1), (-1, 1), (1, -1), (1, 1)] [(-1, -1), (-1, 1), (1, -1), (1, 1)]
in HS.fromList (list1 ++ list2) 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.ReachPoint
, Types.Direction , Types.Direction
, Types.ImgId , Types.ImgId
, Types.FontId
, Types.StateData , Types.StateData
, Types.Animation , Types.Animation
, StateMachine , StateMachine
, Floorplan , Floorplan
, Interior , Interior
, Init , Init
, Load
, Test , Test
, Navigation , Navigation
, NPC , NPC