tracer/src/NPC.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module NPC where

import Affection as A

import qualified Data.Matrix as M
import Data.Ecstasy as E
import Data.Maybe (fromMaybe, fromJust)
import Data.List (find)

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

import Linear

import System.Random

-- internal imports

import Util

import Types

import Object

placeNPCs
  :: M.Matrix (Maybe ImgId)
  -> M.Matrix TileState
  -> [ReachPoint]
  -> Int
  -> IO [V2 Double]
placeNPCs imgmat tilemat rp count =
  doPlace 1 []
  where
    doPlace :: Int -> [V2 Double] -> IO [V2 Double]
    doPlace nr acc =
      if nr <= count
      then do
        r <- randomRIO (1, M.nrows imgmat)
        c <- randomRIO (1, M.ncols imgmat)
        if null (maybe [] collisionObstacle $ imgmat M.! (r, c)) &&
          tilemat M.! (r, c) == Hall
        then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
        else do
          i <- randomRIO (0, length nonexits - 1)
          doPlace
            (nr + 1)
            ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)
      else
        return acc
    nonexits =
      filter
        (\p ->
          pointType p /= RoomExit
          )
        rp

updateNPCs
  :: M.Matrix (Maybe ImgId)
  -> [ReachPoint]
  -> Double
  -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
updateNPCs imgmat rp dt = do
  posbounds <- efor allEnts $ do
    with pos
    with obstacle
    pos' <- query pos
    bnds <- query obstacle
    return (pos', bnds)
  npcs <- efor allEnts $ do
    with npcMoveState
    with vel
    with pos
    with rot
    with anim
    pos' <- query pos
    rot' <- query rot
    let mdir = 
          (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp)
    e <- queryEnt
    return (e, pos', rot', mdir)
  mapM_ (\(e, pos', rot', mdir) -> do
    accessibles <- getObjects pos'
    moent <- runQueryT e $ do
      npcState' <- query npcMoveState
      case npcState' of
        NPCStanding ttl future -> do
          let nttl = ttl - dt
          if nttl > 0
          then
            return $ (Nothing, unchanged
              { npcMoveState = Set $ NPCStanding nttl future
              , vel      = Set $ V2 0 0
              })
          else do
            mpath <- liftIO $ tryTakeMVar future
            case mpath of
              Just path ->
                return $ (Nothing, unchanged
                  { npcMoveState = Set $ NPCWalking path
                  })
              Nothing ->
                return $ (Nothing, unchanged
                  { npcMoveState = 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 $ (Nothing, unchanged
                { npcMoveState = Set $ NPCWalking (tail path)
                })
            else
              return $ (Nothing, unchanged
                { vel = Set $ (* 2) <$> signorm (itarget - pos')
                })
          else do
            future <- liftIO $ newEmptyMVar
            stat <- query anim
            rot' <- query rot
            pos' <- query pos
            _ <- liftIO $ forkIO $
              getPath (fmap floor pos') future rp imgmat posbounds
            let mdir = 
                  (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp)
            -- ttl <- liftIO $ randomRIO (5, 30)
            -- return $ (Nothing, unchanged
            --   { npcMoveState = Set $ NPCStanding ttl future
            --   , vel      = Set $ V2 0 0
            --   , rot      = Set $ fromMaybe rot' mdir
            --   , anim     = Set stat
            --     { asId = (asId stat)
            --       { aiDirection = fromMaybe rot' mdir
            --       }
            --     }
            --   })
            case accessibles of
              [] -> do
                ttl <- liftIO $ randomRIO (5, 30)
                return $ (Nothing, unchanged
                  { npcMoveState = Set $ NPCStanding ttl future
                  , vel      = Set $ V2 0 0
                  , rot      = Set $ fromMaybe rot' mdir
                  , anim     = Set stat
                    { asId = (asId stat)
                      { aiDirection = fromMaybe rot' mdir
                      }
                    }
                  })
              objects -> do
                liftIO $ logIO Debug ("applicable objects: " ++ show objects)
                rind <- liftIO $ randomRIO (0, length objects - 1)
                npcent <- queryEnt
                let (oent, _, _) = objects !! rind
                return (Just (oent, npcent), unchanged
                  { rot      = Set $ fromMaybe rot' mdir
                  , anim     = Set stat
                    { asId = (asId stat)
                      { aiDirection = fromMaybe rot' mdir
                      }
                    }
                  })
    (\(_, ent) ->
      setEntity e ent
      ) (fromJust moent)
    maybe (return()) (\(oent, npcent) -> do
      Just (t, s) <- runQueryT oent $ do
        with objType
        with objState
        otyp <- query objType
        ostat <- query objState
        return (otyp, ostat)
      setEntity oent =<< objectTransition t s False oent
      Just (nt, ns) <- runQueryT oent $ do
        with objType
        with objState
        otyp <- query objType
        ostat <- query objState
        return (otyp, ostat)
      Just npc <- runQueryT npcent $ do
        let ttl = actionTime nt ns
        future <- liftIO $ newEmptyMVar
        _ <- liftIO $ forkIO $
          getPath (fmap floor pos') future rp imgmat posbounds
        return unchanged
          { npcMoveState = Set $ NPCStanding ttl future
          , vel = Set $ V2 0 0
          }
      setEntity npcent npc
      ) (fromJust (fst <$> moent))
    ) npcs

getObjects npos = do
  candidates <- efor allEnts $ do
    with pos
    with objType
    with objState
    with objAccess
    pos' <- query pos
    oacc <- query objAccess
    ent <- queryEnt
    return (ent, pos', oacc)
  return $ filter (\(_, p, (delta, _)) ->
    fmap floor p + delta == fmap floor npos
    ) candidates

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