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

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 .. ImgIntrNE])
  let imgs = zipWith (\a b -> (a, fromJust b)) [ImgWallAsc ..] mimgs
  return UserData
    { state       = Menu
    , subsystems  = subs
    , assetImages = M.fromList
      (imgs ++ playerImgs)
    , assetFonts  = M.fromList
      [ (FontBedstead, "bedstead")
      ]
    , nano        = nvg
    , uuid        = []
    , worldState  = ws
    , stateData   = None
    }

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