tracer/src/NPC.hs

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 Data.List.Split (splitWhen)
import qualified Data.Vector as V
import Data.String

import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Resource (ResIO)
import Control.Concurrent.MVar
import Control.Concurrent (forkIO)

import Linear

import System.Random

-- internal imports

import Util

import Types

import Object ()

getPosBounds
  :: SystemT
    Entity
    (AffectionState AffectionData ResIO)
    [(V2 Double, Boundaries Double)]
getPosBounds = do
  efor allEnts $ do
    with pos
    with obstacle
    without ignoreObstacle
    pos' <- query pos
    bnds <- query obstacle
    return (pos', bnds)

updateNPCs
  :: M.Matrix (Maybe ImgId)
  -> M.Matrix TileState
  -> SystemState Entity (AffectionState AffectionData ResIO)
  -> V.Vector ReachPoint
  -> Double
  -> SystemT Entity (AffectionState AffectionData ResIO) ()
updateNPCs imgmat tsmat ws rrp dt = do
  updateStats dt
  posbounds <- getPosBounds
  moent <- catMaybes <$> eover allEnts (do
    with pos
    with npcMoveState
    with npcActionState
    with npcWorkplace
    with npcStats
    with clearanceLvl
    with vel
    with rot
    with anim
    pos' <- query pos
    rot' <- query rot
    lvl  <- query clearanceLvl
    stat <- query anim
    npcState' <- query npcMoveState
    let rp = V.filter ((lvl >=) . pointClearance) rrp
    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
          case head path of
            [] -> if null (tail path)
              then standStill imgmat tsmat pos' rot' ws posbounds rp
              else do
                (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
                liftIO $ logIO
                  A.Verbose
                  ("accessibles: " <> fromString (show accessibles))
                case accessibles of
                  [] -> error ("unknown reason to stop at " ++ show pos')
                  objects -> do
                    rind <- liftIO $ randomRIO (0, length objects - 1)
                    npcent <- queryEnt
                    let (oent, _, _) = objects !! rind
                        mdir = 
                          pointDir <$> V.find (\a -> pointCoord a == fmap floor pos') rp
                    return (Just (oent, npcent, Nothing), unchanged
                      { rot      = Set $ fromMaybe rot' mdir
                      , anim     = Set stat
                        { asId = (asId stat)
                          { aiDirection = fromMaybe rot' mdir
                          }
                        }
                      , vel = Set $ V2 0 0
                      , npcMoveState = Set $ NPCWalking (tail path)
                      })
            ppath -> do
              let itarget = fmap (+ 0.5) (fromIntegral <$> head ppath) :: V2 Double
              if distance pos' itarget < 1.5 * dt
              then
                return (Nothing, unchanged
                  { npcMoveState = Set $ NPCWalking (tail ppath : tail path)
                  })
              else
                return (Nothing, unchanged
                  { vel = Set $ (* 2) <$> signorm (itarget - pos')
                  })
        else do
          standStill imgmat tsmat pos' rot' ws posbounds rp
    )
  mapM_ (\(oent, npcent, mfuture) -> do
    mts <- efor (anEnt oent) $ do
      with objType
      with objState
      moub <- queryMaybe objUsedBy
      otyp <- query objType
      ostat <- query objState
      case moub of
        Nothing -> return $ Just (otyp, ostat)
        Just uent -> if uent == npcent
          then return $ Just (otyp, ostat)
          else return Nothing
    maybe
      (return ())
      (\(t, s) -> 
        setEntity oent =<< objectTransition t s False oent (Just npcent)
      )
      (head mts)
    mntns <- efor (anEnt oent) $ do
      with objType
      with objState
      moub <- queryMaybe objUsedBy
      otyp <- query objType
      ostat <- query objState
      case moub of
        Nothing -> return $ Just (otyp, ostat)
        Just uent -> if uent == npcent
          then return $ Just (otyp, ostat)
          else return Nothing
    emap (anEnt npcent) $ do
      let ttl = case head mntns of
            Just (nt, ns) -> actionTime nt ns
            Nothing       -> 1
      maybe
        (return unchanged)
        (\future -> return unchanged
          { npcMoveState = Set $ NPCStanding ttl future
          }
          )
        mfuture
    ) moent

standStill
  :: (MonadIO m, RealFrac a1)
  => M.Matrix (Maybe ImgId)
  -> M.Matrix TileState
  -> V2 a1
  -> Direction
  -> SystemState Entity m
  -> [(V2 Double, Boundaries Double)]
  -> V.Vector ReachPoint
  -> QueryT Entity m (Maybe (Ent, Ent, Maybe (MVar [[V2 Int]])), Entity 'SetterOf)
standStill imgmat tsmat pos' rot' ws posbounds rp = do
  future <- liftIO $ newEmptyMVar
  stat <- query anim
  as <- query npcActionState
  targetRPs <- case as of
    ASWork     ->
      let fltrd = V.filter (\p -> pointType p == Copier) rp
      in
        (V.foldl V.snoc fltrd . V.replicate (5 * V.length fltrd)) <$>
          query npcWorkplace
    ASToilet   -> do
      let seekRP = V.filter (\p -> pointType p == Toilet) rp
      if V.null seekRP
      then return $ V.filter (\p -> pointType p == Elevator) rp
      else return seekRP
    ASDrink    -> do
      let seekRP = V.filter (\p -> pointType p == Drink) rp
      if V.null seekRP
      then return $ V.filter (\p -> pointType p == Elevator) rp
      else return seekRP
    ASEat      -> do
      let seekRP = V.filter (\p -> pointType p == Eat) rp
      if V.null seekRP
      then return $ V.filter (\p -> pointType p == Elevator) rp
      else return seekRP
    ASRandWalk ->
      return $ V.filter (\p -> pointType p /= RoomExit) rp
  _ <- liftIO $ forkIO $
    getPath (fmap floor pos') future targetRPs imgmat tsmat posbounds
  let mdir = 
        pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
  (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
  liftIO $ logIO A.Verbose ("accessibles: " <> fromString (show accessibles))
  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, Just future), unchanged
        { rot      = Set $ fromMaybe rot' mdir
        , anim     = Set stat
          { asId = (asId stat)
            { aiDirection = fromMaybe rot' mdir
            }
          }
        , vel = Set $ V2 0 0
        })

updateStats
  :: Double
  -> SystemT Entity (AffectionState AffectionData ResIO) ()
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.05 * dt)
          else min 1 (conc + 0.1 * dt)
        , statBladder       =
          if food > 0 || drin > 0
          then min 1 (blad + 0.01 * 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 = ASEat -- TODO: Let them eat
      | statAttention nstat > statAttention ostat &&
        statAttention nstat > 0.75 = ASWork
      | statBladder nstat > 0.9 = ASToilet
      | otherwise = as

getObject
  :: (MonadIO m, RealFrac a1)
  => V2 a1
  -> SystemT Entity m [(Ent, V2 Double, [(V2 Int, Direction)])]
getObject 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)
  liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates))
  return $
    filter (\(_, p, deltaors) ->
      any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors
    ) candidates

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

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

simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int]
simplifyPath [] a = [a]
simplifyPath acc@[_] a = a : acc
simplifyPath (b:c:bs) a
  | ((signorm $ fmap fromIntegral a) - (signorm $ fmap fromIntegral b)) `dot`
    ((signorm $ fmap fromIntegral b) - (signorm $ fmap fromIntegral c)) == (1 :: Double)
    = a : c : bs
  | otherwise
    = a : b : c : bs

chunkPath :: M.Matrix TileState -> [V2 Int] -> [[V2 Int]]
chunkPath tsmat = splitWhen (\(V2 r c) -> tsmat M.! (r, c) == Door)

chewPath :: M.Matrix TileState -> [V2 Int] -> [[V2 Int]]
chewPath tsmat = map (reverse . foldl simplifyPath []) . chunkPath tsmat