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 Data.String

import Control.Monad

import Control.Concurrent.MVar

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
                (M.unsafeGet (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
                (M.unsafeGet (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
  fonts <- readMVar (assetFonts ud)
  fontFace ctx (fonts 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 (fromString 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: " <>
                  fromString fp <>
                  " " <>
                  fromString (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 :: UserData -> JoystickMessage -> Affection ()
cacheJoypad ud msg = do
  joy <- liftIO $ readMVar (joyCache ud)
  void $ liftIO $ swapMVar (joyCache ud) (msg : joy)

emitJoyActionMessage :: UserData -> JoystickMessage -> Affection ()
emitJoyActionMessage ud message = do
  trans <- liftIO $ readMVar (translation ud)
  case message of
    MsgJoystickAxis time _ axis val -> do
      case trans of
        JoyTranslation tmap -> do
          let Subsystems _ _ _ _ t = subsystems ud
              vnormal = fromIntegral val / 32768
              sigvnormal = abs vnormal
              align
                | signum vnormal >= 0 = AxisPositive
                | signum vnormal < 0 = AxisNegative
          case tmap Map.!? (AxisAction axis align) of
            Just (ActUp _)    -> partEmit t (ActionMessage (ActUp sigvnormal) time)
            Just (ActDown _)  -> partEmit t (ActionMessage (ActDown sigvnormal) time)
            Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
            Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
            _              -> return ()
        _ -> return ()
    MsgJoystickButton time _ but SDL.JoyButtonPressed -> do
      let Subsystems _ _ _ _ t = subsystems ud
      case trans of
        JoyTranslation tmap -> do
          case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
            Just act -> partEmit t (ActionMessage act time)
            _        -> return ()
        _ -> return ()
    _ -> return ()

emitKbdActionMessage :: UserData -> KeyboardMessage -> Affection ()
emitKbdActionMessage ud (MsgKeyboardEvent time _ press False sym) = do
  let Subsystems _ _ _ _ t = subsystems ud
      val = if press == SDL.Pressed then 1 else 0
  trans <- liftIO $ readMVar (translation ud)
  case trans of
    KbdTranslation tmap -> do
      case tmap Map.!? SDL.keysymKeycode sym of
        Just (ActUp _)    -> partEmit t (ActionMessage (ActUp val) time)
        Just (ActDown _)  -> partEmit t (ActionMessage (ActDown val) time)
        Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft val) time)
        Just (ActRight _) -> partEmit t (ActionMessage (ActRight val) time)
        Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
        _        -> return ()
    _ -> return ()
emitKbdActionMessage _ _ = return ()

fullClean :: UserData -> Affection ()
fullClean ud = do
  let Subsystems w m k j t = subsystems ud
  toClean <- liftIO $ readMVar $ uuid ud
  mapM_ (\u -> do
    partUnSubscribe w u
    partUnSubscribe m u
    partUnSubscribe k u
    partUnSubscribe j u
    partUnSubscribe t u
    ) toClean
  void $ liftIO $ swapMVar (uuid ud) []