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 Control.Monad (join)

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

import System.Exit (exitFailure)

import Linear hiding (E(..), translation)

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 =
      zipWith
        (\i ls -> zipWith (convertTile i) [1..] ls)
        [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
        Kitc
          | any
            (\(rr, cc) -> M.safeGet (irow + rr) (icol + cc) mat == Just Door)
            [(1, 0), (-1, 0), (0, 1), (0, -1)] ->
            Just ImgEmpty
          | otherwise ->
            Nothing
        Toil
          | 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 Double, Boundaries Double)]
  -> V2 Int
  -> V2 Int
  -> Maybe [V2 Int]
astarAppl imgmat animBounds target = aStar
  (naviGraph imgmat animBounds)
  (\a b -> distance
    (fmap (fromIntegral :: Int -> Double) a)
    (fmap (fromIntegral :: Int -> Double) b)
    )
  (distance (fmap fromIntegral target) . fmap fromIntegral)
  (== target)

naviGraph
  :: Matrix (Maybe ImgId)
  -> [(V2 Double, Boundaries Double)]
  -> V2 Int
  -> HS.HashSet (V2 Int)
naviGraph imgmat animBounds (V2 r c) =
  let list1 =
        foldl
          (\acc (rr, cc) ->
            if null
              (maybe [] collisionObstacle
                (join $ M.safeGet (r + rr) (c + cc) imgmat)
              ++
              map snd (filter
                (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
                animBounds))
            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
                (join $ M.safeGet (r + rr) (c + cc) imgmat)
              ++
              map snd (filter (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
                animBounds))
              && all null
              (map
              (\(oor, ooc) -> (maybe [] collisionObstacle
                (join $ M.safeGet (r + oor) (c + ooc) imgmat)) ++
                map snd (filter
                  (\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc)
                  animBounds))
              [(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

rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny
  where
    nx   = x * cos (dtor deg) + y * sin (dtor deg)
    ny   = x * sin (dtor deg) - y * cos (dtor deg)

dtor :: (Num a, Floating a) => a -> a
dtor = (pi / 180 *)

cacheJoypad :: JoystickMessage -> Affection UserData ()
cacheJoypad msg = do
  ud <- getAffection
  putAffection ud
    { joyCache = msg : joyCache ud
    }

emitActionMessage :: JoystickMessage -> Affection UserData ()
emitActionMessage (MsgJoystickAxis time _ axis val) = do
  ud <- getAffection
  let Subsystems _ _ _ _ t = subsystems ud
  case (translation ud) Map.!? (AxisAction axis) of
    Just (UpDown s)    -> partEmit t (ActionMessage (UpDown (s * fromIntegral val)) time)
    Just (LeftRight s) -> partEmit t (ActionMessage (LeftRight (s * fromIntegral val)) time)
    _                  -> return ()
emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
  ud <- getAffection
  let Subsystems _ _ _ _ t = subsystems ud
  case (translation ud) Map.!? (ButtonAction but SDL.JoyButtonPressed) of
    Just act -> partEmit t (ActionMessage act time)
    _        -> return ()
emitActionMessage _ = return ()

fullClean :: Affection UserData ()
fullClean = do
  ud <- getAffection
  let Subsystems w m k j t = subsystems ud
      toClean              = uuid ud
  mapM_ (\u -> do
    partUnSubscribe w u
    partUnSubscribe m u
    partUnSubscribe k u
    partUnSubscribe j u
    partUnSubscribe t u
    ) toClean
  putAffection ud
    { uuid = []
    }