tracer/src/Init.hs

92 lines
2.2 KiB
Haskell

{-# LANGUAGE ForeignFunctionInterface #-}
module Init where
import Affection as A
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import NanoVG hiding (V2(..), V3(..))
import NanoVG.Internal.Image (ImageFlags(..))
import Linear hiding (E(..))
import Codec.Picture as CP
import Codec.Picture.Extra
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Ecstasy
import Data.Maybe
import Data.ByteString.Lazy (toStrict)
import System.Exit (exitFailure)
import Foreign.C.Types (CInt(..))
import Types
import Floorplan
import Debug.Trace
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
init :: IO UserData
init = do
subs <- Subsystems
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
_ <- glewInit
(ws, _) <- yieldSystemT (0, defStorage) (return ())
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
return UserData
{ state = Load
, subsystems = subs
, assetImages = M.empty
, assetAnimations = M.empty
, assetFonts = M.empty
, nano = nvg
, uuid = []
, worldState = ws
, stateData = None
}
loadPlayerSprite
:: FilePath -- Path to spritemap
-> Int -- width of single sprite
-> Int -- height of single sprite
-> Context -- Nanovg context
-> [(Int, [ImgId])] -- [(picture row, Image IDs)]
-> IO [(ImgId, NanoVG.Image)]
loadPlayerSprite fp w h nvg rids = do
eimg <- readImage fp
case eimg of
Left err -> do
logIO Error err
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
ret <- mapM (\(row, ids) -> do
mapM (\(num, id) -> do
let cr = crop (num * w) (row * h) w h img
mresimg <-
createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr)
case mresimg of
Nothing -> do
logIO Error ("Failed to load: " ++ fp ++ " " ++ show id)
exitFailure
Just resimg -> return (id, resimg)
) (zip [0..] ids)
) rids
return $ concat ret