{-# 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 -- state <*> pure subs -- subsystems <*> newMVar M.empty -- assetIcons <*> newMVar M.empty -- assetImages <*> newMVar M.empty -- assetFonts <*> newMVar M.empty -- assetAnimations <*> newMVar NoController -- controls <*> newMVar NoTranslation -- translation <*> pure nvg -- nano <*> newMVar [] -- uuid <*> newEmptyMVar -- worldState <- <*> newMVar None -- stateData <*> newEmptyMVar -- stateMVar <- <*> newEmptyMVar -- stateProgress <- <*> newMVar Nothing -- threadContext <*> newMVar Nothing -- window <*> newMVar [] -- joyCache <*> newEmptyMVar -- joyUUID <- <*> newMVar True -- doNextStep 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 (S.singleton 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