tracer/src/NPC.hs

module NPC where

import Affection as A

import qualified Data.Matrix as M
import Data.Map.Strict as Map hiding (filter, null)
import Data.Ecstasy as E
import Data.Maybe (fromMaybe)
import Data.List (find)

import Control.Monad.IO.Class (MonadIO(..))
import Control.Concurrent.MVar
import Control.Concurrent (forkOS)

import Linear

import System.Random

import NanoVG hiding (V2(..))

-- internal imports

import Navigation
import Util

import Types

-- drawNPCs
--   :: Map ImgId Image
--   -> Context
--   -> UserData
--   -> [(V2 Double, Direction)]
--   -> Double
--   -> Double
--   -> Int
--   -> Int
--   -> Maybe ImgId
--   -> IO ()
-- drawNPCs ai ctx ud npcposrots prow pcol row col img = do
--   let fnpcposrots = filter
--         (\((V2 nr nc, dir)) ->
--           let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
--               y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
--           in  ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
--             (realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) &&
--             ((all (\m -> prow > (fromIntegral (floor prow :: Int)) + m) minrs &&
--             all (\m -> pcol < (fromIntegral (floor pcol :: Int)) + m) mincs) ||
--             (all (\m -> prow > (fromIntegral (floor prow :: Int)) + m) minrs &&
--             all (\m -> pcol < (fromIntegral (floor pcol :: Int)) + m) maxcs)) &&
--             (floor nr == row && floor nc == col)
--           )
--         npcposrots
--   mapM_
--     (\((V2 nr nc, dir)) -> do
--       let x = realToFrac $ 640 + ((nc - pcol) + (nr - prow)) * 32
--           y = realToFrac $ 360 + ((nr - prow) - (nc - pcol)) * 16
--       beginPath ctx
--       paint <- imagePattern ctx (x - 32) (y - 58) 64 74 0
--         (ai Map.! (dirToImgId dir)) 1
--       rect ctx (x - realToFrac (tileWidth / 2)) (y - 58)
--         (realToFrac tileWidth) 74
--       fillPaint ctx paint
--       -- circle ctx x y 5
--       -- closePath ctx
--       -- fillColor ctx (rgba 255 0 0 255)
--       fill ctx
--       )
--     fnpcposrots
--   where
--     tileWidth = 64 :: Double
--     tileHeight = 32 :: Double
--     mb = imgObstacle img
--     minrs = Prelude.map (fst . matmin) mb
--     maxrs = Prelude.map (fst . matmax) mb
--     mincs = Prelude.map (snd . matmin) mb
--     maxcs = Prelude.map (snd . matmax) mb

placeNPCs
  :: M.Matrix (Maybe ImgId)
  -> M.Matrix TileState
  -> [ReachPoint]
  -> [Graph]
  -> Int
  -> Affection UserData [V2 Double]
placeNPCs imgmat tilemat rp gr count =
  doPlace 1 []
  where
    doPlace :: Int -> [V2 Double] -> Affection UserData [V2 Double]
    doPlace nr acc = do
      if nr <= count
      then do
        r <- liftIO $ randomRIO (1, M.nrows imgmat)
        c <- liftIO $ randomRIO (1, M.ncols imgmat)
        if null (imgObstacle $ imgmat M.! (r, c)) &&
          tilemat M.! (r, c) == Hall
        then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
        else do
          i <- liftIO $ randomRIO (0, length nonexits - 1)
          doPlace
            (nr + 1)
            ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)
      else
        return acc
    applRooms row col =
      (filter (\r -> graphIsRoom r && inBounds (V2 row col) (bounds r)) gr)
    nonexits =
      filter
        (\p ->
          pointType p /= RoomExit
          )
        rp

updateNPCs
  :: MonadIO m
  => M.Matrix (Maybe ImgId)
  -> [ReachPoint]
  -> Double
  -> SystemT Entity m ()
updateNPCs imgmat rp dt =
  emap allEnts $ do
    with npcState
    with vel
    with pos
    with rot
    with anim
    npcState' <- query npcState
    case npcState' of
      NPCStanding ttl future -> do
        let nttl = ttl - dt
        if nttl > 0
        then
          return $ unchanged
            { npcState = Set $ NPCStanding nttl future
            , vel      = Set $ V2 0 0
            }
        else do
          mpath <- liftIO $ tryTakeMVar future
          case mpath of
            Just path ->
              return $ unchanged
                { npcState = Set $ NPCWalking path
                }
            Nothing ->
              return $ unchanged
                { npcState = Set $ NPCStanding 1 future
                }
      NPCWalking path -> do
        pos' <- query pos
        if not (null path)
        then do
          let itarget = V2 0.5 0.5 + (fromIntegral <$> head path) :: V2 Double
          if distance pos' itarget < 0.1
          then
            return $ unchanged
              { npcState = Set $ NPCWalking (tail path)
              }
          else
            return $ unchanged
              { vel = Set $ (* 2) <$> signorm (itarget - pos')
              }
        else do
          ttl <- liftIO $ randomRIO (5, 30)
          future <- liftIO $ newEmptyMVar
          rot' <- query rot
          state <- query anim
          let mdir = 
                (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp)
          -- _ <- liftIO $ forkOS $ getPath (fmap floor pos') future rp imgmat
          _ <- liftIO $ getPath (fmap floor pos') future rp imgmat
          return $ unchanged
            { npcState = Set $ NPCStanding ttl future
            , vel      = Set $ V2 0 0
            , rot      = Set $ fromMaybe rot' mdir
            , anim     = Set state
              { asId = (asId state)
                { aiDirection = fromMaybe rot' mdir
                }
              }
            }


getPath
  :: V2 Int
  -> MVar [V2 Int]
  -> [ReachPoint]
  -> M.Matrix (Maybe ImgId)
  -> IO ()
getPath pos' mvar rp imgmat = do
  let seekRP = filter (\p -> pointType p /= RoomExit) rp
  ntargeti <- randomRIO (0, length seekRP - 1)
  let ntarget = pointCoord (seekRP !! ntargeti)
      path = astarAppl imgmat ntarget pos'
  logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
  case path of
    Nothing -> getPath pos' mvar rp imgmat
    Just p  -> putMVar mvar p