tracer/src/Init.hs

{-# 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 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])
  return UserData
    { state           = Load
    , subsystems      = subs
    , assetImages     = M.empty
    , assetAnimations = M.empty
    , assetFonts      = M.empty
    , assetIcons      = M.empty
    , nano            = nvg
    , uuid            = []
    , stateData       = None
    , threadContext   = Nothing
    , joystick        = Nothing
    , translation     = defaultTranslation
    , joyCache        = []
    }

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) ->
        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: " ++ fp ++ " " ++ show i)
              exitFailure
            Just resimg -> return (i, resimg)
          ) (zip [0..] ids)
        ) rids
      return $ concat ret