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 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