tracer/src/Util.hs

module Util where

import Affection as A

import Data.Matrix as M
import qualified Data.HashSet as HS
import qualified Data.Set as S
import qualified Data.Map as Map
import Data.ByteString.Lazy (toStrict)
import Data.Graph.AStar
import Data.Maybe

import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)

import System.Exit (exitFailure)

import Linear

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

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

-- internal imports

import Types

convertTileToImg :: Matrix TileState -> Matrix (Maybe ImgId)
convertTileToImg mat = fromLists conversion
  where
    conversion =
      map (\(i, ls) -> map (uncurry $ convertTile i) (zip [1..] ls))
        (zip [1..] (toLists mat))
    convertTile irow icol tile =
      case tile of
        Wall -> Just (case neighWalls irow icol mat of
          4 ->
            ImgWallCross
          3
            | M.safeGet (irow + 1) icol mat /= Just Wall &&
              M.safeGet (irow + 1) icol mat /= Just Door ->
              ImgWallTNW
            | M.safeGet irow (icol + 1) mat /= Just Wall &&
              M.safeGet irow (icol + 1) mat /= Just Door ->
              ImgWallTSW
            | M.safeGet (irow - 1) icol mat /= Just Wall &&
              M.safeGet (irow - 1) icol mat /= Just Door ->
              ImgWallTSE
            | otherwise ->
              ImgWallTNE
          2
            | (M.safeGet (irow + 1) icol mat == Just Wall ||
              M.safeGet (irow + 1) icol mat == Just Door) &&
              (M.safeGet (irow - 1) icol mat == Just Wall ||
              M.safeGet (irow - 1) icol mat == Just Door) ->
                ImgWallDesc
            | (M.safeGet irow (icol + 1) mat == Just Wall ||
              M.safeGet irow (icol + 1) mat == Just Door) &&
              (M.safeGet irow (icol - 1) mat == Just Wall ||
              M.safeGet irow (icol - 1) mat == Just Door) ->
                ImgWallAsc
            | (M.safeGet (irow - 1) icol mat == Just Wall ||
              M.safeGet (irow - 1) icol mat == Just Door) &&
              (M.safeGet irow (icol - 1) mat == Just Wall ||
              M.safeGet irow (icol - 1) mat == Just Door) ->
                ImgWallCornerW
            | (M.safeGet irow (icol - 1) mat == Just Wall ||
              M.safeGet irow (icol - 1) mat == Just Door) &&
              (M.safeGet (irow + 1) icol mat == Just Wall ||
              M.safeGet (irow + 1) icol mat == Just Door) ->
                ImgWallCornerS
            | (M.safeGet (irow + 1) icol mat == Just Wall ||
              M.safeGet (irow + 1) icol mat == Just Door) &&
              (M.safeGet irow (icol + 1) mat == Just Wall ||
              M.safeGet irow (icol + 1) mat == Just Door) ->
                ImgWallCornerE
            | otherwise ->
                ImgWallCornerN
          1
            | M.safeGet (irow - 1) icol mat == Just Wall ||
              M.safeGet (irow - 1) icol mat == Just Door ->
              ImgWallDesc
            | M.safeGet (irow + 1) icol mat == Just Wall ||
              M.safeGet (irow + 1) icol mat == Just Door ->
              ImgWallDesc
            | M.safeGet irow (icol + 1) mat == Just Wall ||
              M.safeGet irow (icol + 1) mat == Just Door ->
              ImgWallAsc
            | otherwise ->
              ImgWallAsc
          0 ->
            ImgWallCross
          _ ->
            error "unexpected number if neighbouring walls"
          )
        Offi
          | any
            (\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door)
            [(1, 0), (-1, 0), (0, 1), (0, -1)] ->
            Just ImgEmpty
          | otherwise ->
            Nothing
        _ ->
          Nothing

neighWalls :: Int -> Int -> Matrix TileState -> Int
neighWalls row col mat =
  Prelude.foldl (\acc (ir, ic) ->
    if M.safeGet (row + ir) (col + ic) mat == Just Wall ||
       M.safeGet (row + ir) (col + ic) mat == Just Door
    then acc + 1
    else acc
    )
    0
    [ (0, -1)
    , (-1, 0)
    , (0, 1)
    , (1, 0)
    ]

relativizeMouseCoords :: V2 Int32 -> IO (V2 Double)
relativizeMouseCoords (V2 ix iy) = do
  (GL.Position vx vy, GL.Size vw vh) <- SDL.get GL.viewport
  let rx = ix - vx
      ry = iy - vy
      hx = fromIntegral vw / 2
      hy = fromIntegral vh / 2
      dx = fromIntegral rx - hx
      dy = fromIntegral ry - hy
  return $ V2 (dx / hx) (dy / hy)

inBounds :: V2 Int -> Boundaries Int -> Bool
inBounds (V2 r c) (Boundaries (minr, minc) (maxr, maxc)) =
  (r >= minr && r <= maxr) && (c >= minc && c <= maxc)

astarAppl :: Matrix (Maybe ImgId) -> V2 Int -> V2 Int -> Maybe [V2 Int]
astarAppl imgmat target start = aStar
  (naviGraph imgmat)
  (\a b -> distance (fmap fromIntegral a) (fmap fromIntegral b))
  (\a -> distance (fmap fromIntegral target) (fmap fromIntegral a))
  (== target)
  start

naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int)
naviGraph imgmat (V2 r c) =
  let list1 =
        foldl
          (\acc (or, oc) ->
            if null
              (fromMaybe [] $
              imgObstacle <$> M.safeGet (r + or) (c + oc) imgmat)
            then V2 (r + or) (c + oc): acc
            else acc
            )
          []
          [(0, 1), (0, -1), (1, 0), (-1, 0)]
      list2 =
        foldl
          (\acc (or, oc) ->
            if null (fromMaybe [] $
              imgObstacle <$> M.safeGet (r + or) (c + oc) imgmat)
              && all null
              (map
              (\(oor, ooc) -> fromMaybe [] $
                imgObstacle <$> M.safeGet (r + oor) (c + ooc) imgmat)
              [(0, oc), (or, 0)])
            then V2 (r + or) (c + oc): acc
            else acc
            )
          []
          [(-1, -1), (-1, 1), (1, -1), (1, 1)]
  in  HS.fromList (list1 ++ list2)

drawLoadScreen :: UserData -> Float -> IO ()
drawLoadScreen ud progress = do
  let ctx = nano ud
  save ctx
  fillColor ctx (rgb 255 128 0)
  fontSize ctx 100
  fontFace ctx (assetFonts ud Map.! FontBedstead)
  textAlign ctx (S.fromList [AlignCenter, AlignTop])
  textBox ctx 0 300 1280 "Loading"
  beginPath ctx
  rect ctx
    (640 - 640 * realToFrac progress) 450 (1280 * realToFrac progress) 20
  closePath ctx
  fill ctx
  restore ctx

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