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
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
  updateStats dt
  posbounds <- efor allEnts $ do
    with pos
    with obstacle
    pos' <- query pos
    bnds <- query obstacle
    return (pos', bnds)
  npcposs <- efor allEnts $ do
    with pos
    with npcMoveState
    with vel
    with rot
    with anim
    pos' <- query pos
    e <- queryEnt
    return (e, pos')
  eaccess <- getObjects npcposs
  moent <- catMaybes <$> eover allEnts (do
    with pos
    with npcMoveState
    with npcActionState
    with npcWorkplace
    with npcStats
    with vel
    with rot
    with anim
    pos' <- query pos
    rot' <- query rot
    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
          as <- query npcActionState
          stats <- query npcStats
          let nstats = case as of
                ASDrink  -> stats
                  { statThirst = 0
                  , statDrink  = 1
                  }
                ASEat    -> stats
                  { statHunger = 0
                  , statFood   = 1
                  }
                ASToilet -> stats
                  { statBladder = 0
                  }
                _ -> stats
          case mpath of
            Just path ->
              return (Nothing, unchanged
                { npcMoveState = Set $ NPCWalking path
                , npcStats     = Set nstats
                })
            Nothing ->
              return (Nothing, unchanged
                { npcMoveState = Set $ NPCStanding 1 future
                })
      NPCWalking path ->
        if not (null path)
        then do
          let itarget = fmap (+ 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
          as <- query npcActionState
          targetRPs <- case as of
            ASWork     -> (: []) <$> query npcWorkplace
            ASToilet   -> do
              let seekRP = filter (\p -> pointType p == Toilet) rp
              if null seekRP
              then return $ filter (\p -> pointType p == Elevator) rp
              else return seekRP
            ASDrink    -> do
              let seekRP = filter (\p -> pointType p == Drink) rp
              if null seekRP
              then return $ filter (\p -> pointType p == Elevator) rp
              else return seekRP
            ASEat      -> do
              let seekRP = filter (\p -> pointType p == Eat) rp
              if null seekRP
              then return $ filter (\p -> pointType p == Elevator) rp
              else return seekRP
            ASRandWalk ->
              return $ filter (\p -> pointType p /= RoomExit) rp
          _ <- liftIO $ forkIO $
            getPath (fmap floor pos') future targetRPs imgmat posbounds
          e <- queryEnt
          let mdir = 
                pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
              accessibles = fromMaybe [] $ lookup e eaccess
          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
              rind <- liftIO $ randomRIO (0, length objects - 1)
              npcent <- queryEnt
              let (oent, _, _) = objects !! rind
              return (Just (oent, npcent, future), unchanged
                { rot      = Set $ fromMaybe rot' mdir
                , anim     = Set stat
                  { asId = (asId stat)
                    { aiDirection = fromMaybe rot' mdir
                    }
                  }
                , vel = Set $ V2 0 0
                }))
  mapM_ (\(oent, npcent, future) -> 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)
    emap (anEnt npcent) $ do
      let ttl = actionTime nt ns
      return unchanged
        { npcMoveState = Set $ NPCStanding ttl future
        }
    ) moent

updateStats
  :: Double
  -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
updateStats dt =
  emap allEnts $ do
    with npcStats
    with npcActionState
    stat <- query npcStats
    as <- query npcActionState
    let nstat = doUpdate stat as
    return unchanged
      { npcStats = Set nstat
      , npcActionState = Set $ doCompare stat nstat as
      }
  where
    doUpdate stat@(NPCStats conc blad thir hung food drin) as =
      stat
        { statAttention =
          if as == ASWork
          then max 0 (conc - 0.2 * dt)
          else min 1 (conc + 0.075 * dt)
        , statBladder       =
          if food > 0 || drin > 0
          then min 1 (blad + 0.3 * dt)
          else blad
        , statThirst        = min 1 (if drin > 0 then thir else thir + 0.2 * dt)
        , statHunger        = min 1 (if food > 0 then hung else hung + 0.1 * dt)
        , statFood          = max 0 (food - 0.1 * dt)
        , statDrink         = max 0 (drin - 0.2 * dt)
        }
    doCompare ostat nstat as
      | statAttention nstat == 0 = ASRandWalk
      | statThirst nstat == 0 = ASDrink
      | statHunger nstat == 0 = ASDrink -- TODO: Let them eat
      | statAttention nstat > statAttention ostat &&
        statAttention nstat > 0.75 = ASWork
      | statBladder nstat > 0.9 = ASToilet
      | otherwise = as

getObjects
  :: (Monad m, Traversable t, RealFrac a1)
  => t (a2, V2 a1)
  -> SystemT Entity m (t (a2, [(Ent, V2 Double, (V2 Int, Direction))]))
getObjects npcposs = 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)
  mapM (\(e, npos) ->
    return
      ( e
      , filter (\(_, p, (delta, _)) ->
        fmap floor p + delta == fmap floor npos
        ) candidates
      )
    ) npcposs

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

getPathTo
  :: V2 Int
  -> MVar [V2 Int]
  -> V2 Int
  -> M.Matrix (Maybe ImgId)
  -> [(V2 Double, Boundaries Double)]
  -> IO ()
getPathTo pos' mvar target imgmat posbounds = do
  let path = astarAppl imgmat posbounds target pos'
  logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show target)
  case path of
    Nothing -> do
      logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target)
      putMVar mvar [pos']
    Just p  -> putMVar mvar p