tracer/src/Init.hs
2020-05-05 01:23:40 +02:00

94 lines
2.4 KiB
Haskell

{-# LANGUAGE ForeignFunctionInterface #-}
module Init where
import Affection as A
import NanoVG hiding (V2(..), V3(..))
import NanoVG.Internal.Image (ImageFlags(..))
import Codec.Picture as CP
import Codec.Picture.Extra
import Control.Concurrent.STM
import Control.Concurrent.MVar
import Data.String
import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.ByteString.Lazy (toStrict)
import System.Exit (exitFailure)
import Foreign.C.Types (CInt(..))
import Types
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
init :: IO UserData
init = do
subs <- Subsystems
<$> (SubWindow <$> newTVarIO [])
<*> (SubMouse <$> newTVarIO [])
<*> (SubKeyboard <$> newTVarIO [])
<*> (SubJoypad <$> newTVarIO [])
<*> (SubTranslator <$> newTVarIO [])
_ <- glewInit
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
UserData
<$> newMVar Load
<*> pure subs
<*> newMVar M.empty
<*> newMVar M.empty
<*> newMVar M.empty
<*> newMVar M.empty
<*> newMVar NoController
<*> newMVar NoTranslation
<*> pure nvg
<*> newMVar []
<*> newEmptyMVar
<*> newMVar None
<*> newEmptyMVar
<*> newMVar (0, "foobar!")
<*> newMVar Nothing
<*> newMVar Nothing
<*> newMVar []
<*> newEmptyMVar
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 (fromString err)
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
ret <- mapM (\(row, ids) ->
mapM (\(num, i) -> 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: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure
Just resimg -> return (i, resimg)
) (zip [0..] ids)
) rids
return $ concat ret