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 Data.Text as T

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

import System.Exit (exitFailure)

import Linear hiding (E(..))

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 = aStar
  (naviGraph imgmat)
  (\a b -> distance
    (fmap (fromIntegral :: Int -> Double) a)
    (fmap (fromIntegral :: Int -> Double) b)
    )
  (\a -> distance (fmap fromIntegral target) (fmap fromIntegral a))
  (== target)

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

drawLoadScreen :: UserData -> (Float, T.Text) -> IO ()
drawLoadScreen ud (progress, msg) = 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
  fontSize ctx 25
  textBox ctx 0 500 1280 msg
  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
        (\(i, (AnimationConfig (xoffs, yoffs) (w, h) (sx, sy) count dur pb)) -> do
          let crs = map
                (\iid -> crop (xoffs + (iid * sx)) (yoffs + (iid * sy)) 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 i)
              exitFailure
            else
              return $ catMaybes mresimgs
          return $
            ( i
            , Animation dur imgs pb
            )
          ) idconfs

direction :: V2 Double -> Maybe Direction
direction vel'@(V2 vr _) = if sqrt (vel' `dot` vel') > 0
  then
    let xuu =
          acos ((vel' `dot` V2 0 1) /
            sqrt (vel' `dot` vel')) / pi * 180
        xu = if vr < 0 then 360 - xuu else xuu
        d
          |               xu < 22.5  = NE
          | xu > 22.5  && xu < 67.5  = E
          | xu > 67.5  && xu < 112.5 = SE
          | xu > 112.5 && xu < 157.5 = S
          | xu > 157.5 && xu < 202.5 = SW
          | xu > 202.5 && xu < 247.5 = W
          | xu > 247.5 && xu < 292.5 = NW
          | xu > 292.5 && xu < 337.5 = N
          | xu > 337.5               = NE
          | otherwise                = NE
    in Just d
  else Nothing