more loading screens, but breaking things...

src/Floorplan.hs

@@ -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

src/Init.hs

@@ -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

src/Load.hs

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

src/Main.hs

@@ -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
         }

src/StateMachine.hs

@@ -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

src/Test.hs

@@ -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

src/Types.hs

@@ -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

src/Types/Animation.hs

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

src/Types/FontId.hs

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

src/Types/StateData.hs

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

src/Types/UserData.hs

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

src/Util.hs

@@ -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

tracer-game.cabal

@@ -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