tracer/src/Load.hs

144 lines
5.2 KiB
Haskell

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 ()