tracer/src/Init.hs

{-# LANGUAGE ForeignFunctionInterface #-}

module Init where

import Affection as A

import SDL (($=))
import qualified SDL

import qualified Graphics.Rendering.OpenGL as GL

import NanoVG hiding (V2(..), V3(..))
import NanoVG.Internal.Image (ImageFlags(..))

import Linear hiding (E(..))

import Codec.Picture as CP
import Codec.Picture.Extra

import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)

import Control.Concurrent.STM

import qualified Data.Set as S
import qualified Data.Map.Strict as M
import Data.Ecstasy
import Data.Maybe
import Data.ByteString.Lazy (toStrict)

import System.Exit (exitFailure)

import Foreign.C.Types (CInt(..))

import Types

import Floorplan

import Debug.Trace

foreign import ccall unsafe "glewInit"
  glewInit :: IO CInt

load :: IO UserData
load = do
  _ <- glewInit
  nvg <- createGL3 (S.fromList [Antialias, StencilStrokes])
  subs <- Subsystems
    <$> (Window <$> newTVarIO [])
    <*> (Mouse <$> newTVarIO [])
  (ws, _) <- yieldSystemT (0, defStorage) (return ())
  mwallasc <- createImage nvg (FileName "assets/walls/wall_asc.png") 0
  mwalldesc <- createImage nvg (FileName "assets/walls/wall_desc.png") 0
  mwallcornern <- createImage nvg (FileName "assets/walls/wall_corner_n.png") 0
  mwallcornere <- createImage nvg (FileName "assets/walls/wall_corner_e.png") 0
  mwallcorners <- createImage nvg (FileName "assets/walls/wall_corner_s.png") 0
  mwallcornerw <- createImage nvg (FileName "assets/walls/wall_corner_w.png") 0
  mwalltne <- createImage nvg (FileName "assets/walls/wall_t_ne.png") 0
  mwalltse <- createImage nvg (FileName "assets/walls/wall_t_se.png") 0
  mwalltsw <- createImage nvg (FileName "assets/walls/wall_t_sw.png") 0
  mwalltnw <- createImage nvg (FileName "assets/walls/wall_t_nw.png") 0
  mwallcross <- createImage nvg (FileName "assets/walls/wall_cross.png") 0
  mmiscbox1 <- createImage nvg (FileName "assets/misc/box1.png") 0
  mmisctable1 <- createImage nvg (FileName "assets/misc/table1.png") 0
  mmisctable2 <- createImage nvg (FileName "assets/misc/table2.png") 0
  mmisctable3 <- createImage nvg (FileName "assets/misc/table3.png") 0
  mmisctable4 <- createImage nvg (FileName "assets/misc/table4.png") 0
  mmisctableC <- createImage nvg (FileName "assets/misc/tableCorner.png") 0
  _ <- createFont nvg "bedstead"
    (FileName "assets/font/Bedstead-Semicondensed.ttf")
  let mimgs = [ mwallasc, mwalldesc,
        mwallcornern, mwallcornere, mwallcorners, mwallcornerw,
        mwalltne, mwalltse, mwalltsw, mwalltnw, mwallcross,
        mmiscbox1,
        mmisctable1, mmisctable2, mmisctable3, mmisctable4, mmisctableC
        ]
  when (any isNothing mimgs) $ do
    logIO Error "Failed to load image assets"
    exitFailure
  -- playerImgs <- loadPlayerSprite "assets/intruder.png" 64 74 nvg
  --   (zipWith (\a b -> (a, [b])) [0..] $ [ImgIntrE .. ImgIntrN] ++ [ImgIntrNE])
  let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
      directions = [E .. N] ++ [NE]
      standIds = map (AnimId 0 "standing") directions
      walkIds = map (AnimId 0 "walking") directions
      standConfigs = map
        (\i -> AnimationConfig (0, i * 74) (64, 74) 1 0 APLoop)
        [0 .. length standIds - 1]
      walkConfigs = map
        (\i -> AnimationConfig (64, i * 74) (64, 74) 6 1.5 APLoop)
        [0 .. length walkIds - 1]
  playerStanding <- loadAnimationSprites "assets/intruder.png" nvg
    (zip standIds standConfigs)
  playerWalking <- loadAnimationSprites "assets/intruder.png" nvg
    (zip walkIds walkConfigs)
  return UserData
    { state           = Menu
    , subsystems      = subs
    , assetImages     = M.fromList imgs
    , assetAnimations = M.fromList
      (playerStanding ++ playerWalking)
    , assetFonts      = M.fromList
      [ (FontBedstead, "bedstead")
      ]
    , nano            = nvg
    , uuid            = []
    , worldState      = ws
    , stateData       = None
    }

loadAnimationSprites
  :: FilePath   -- Path to Sprite map
  -> Context    -- NanoVG context
  -> [(AnimId, AnimationConfig)]
  -> IO [(AnimId, Animation)]
loadAnimationSprites fp nvg idconfs = do
  eimg <- readImage fp
  case eimg of
    Left err -> do
      logIO Error err
      exitFailure
    Right dimg -> do
      let img = convertRGBA8 dimg
      mapM
        (\(id, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
          let crs = map
                (\i -> crop (xoffs + (i * w)) yoffs w h img)
                [0 .. (count - 1)]
          mresimgs <- mapM
            (\cr ->
              createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr))
            crs
          imgs <- if any isNothing mresimgs
            then do
              logIO Error ("failed to load: " ++ fp ++ " " ++ show id)
              exitFailure
            else
              return $ catMaybes mresimgs
          return $
            ( id
            , Animation dur imgs pb
            )
          ) idconfs

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) -> do
        mapM (\(num, id) -> 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 id)
              exitFailure
            Just resimg -> return (id, resimg)
          ) (zip [0..] ids)
        ) rids
      return $ concat ret