tracer/src/Init.hs

95 lines
2.9 KiB
Haskell
Raw Normal View History

2018-02-07 00:18:16 +00:00
{-# LANGUAGE ForeignFunctionInterface #-}
module Init where
import Affection as A
import NanoVG hiding (V2(..), V3(..))
2018-05-20 22:40:40 +00:00
import NanoVG.Internal.Image (ImageFlags(..))
2018-02-07 00:18:16 +00:00
2018-05-20 22:40:40 +00:00
import Codec.Picture as CP
import Codec.Picture.Extra
2018-02-07 00:18:16 +00:00
import Control.Concurrent.STM
2020-05-04 23:23:40 +00:00
import Control.Concurrent.MVar
2018-02-07 00:18:16 +00:00
2019-10-28 17:20:34 +00:00
import Data.String
2018-02-07 00:18:16 +00:00
import qualified Data.Set as S
import qualified Data.Map.Strict as M
2018-05-20 22:40:40 +00:00
import Data.ByteString.Lazy (toStrict)
2018-02-25 09:30:13 +00:00
import System.Exit (exitFailure)
2018-02-07 00:18:16 +00:00
import Foreign.C.Types (CInt(..))
import Types
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
init :: IO UserData
init = do
2018-02-07 00:18:16 +00:00
subs <- Subsystems
2018-10-08 16:54:23 +00:00
<$> (SubWindow <$> newTVarIO [])
<*> (SubMouse <$> newTVarIO [])
<*> (SubKeyboard <$> newTVarIO [])
<*> (SubJoypad <$> newTVarIO [])
2018-10-08 21:36:52 +00:00
<*> (SubTranslator <$> newTVarIO [])
2018-06-07 22:29:46 +00:00
_ <- glewInit
nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
2020-05-04 23:23:40 +00:00
UserData
2020-05-05 08:26:16 +00:00
<$> 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
2018-05-20 22:40:40 +00:00
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
2019-10-28 17:20:34 +00:00
logIO Error (fromString err)
2018-05-20 22:40:40 +00:00
exitFailure
Right dimg -> do
let img = convertRGBA8 dimg
2018-07-03 14:19:27 +00:00
ret <- mapM (\(row, ids) ->
mapM (\(num, i) -> do
2018-05-20 22:40:40 +00:00
let cr = crop (num * w) (row * h) w h img
2018-05-30 14:20:58 +00:00
mresimg <-
2022-02-18 20:34:02 +00:00
createImageMem nvg (S.singleton ImagePremultiplied) (toStrict $ encodePng cr)
2018-05-20 22:40:40 +00:00
case mresimg of
Nothing -> do
2019-10-28 17:20:34 +00:00
logIO
Error
("Failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
2018-05-20 22:40:40 +00:00
exitFailure
2018-07-03 14:19:27 +00:00
Just resimg -> return (i, resimg)
2018-05-20 22:40:40 +00:00
) (zip [0..] ids)
) rids
return $ concat ret