298 lines
9.1 KiB
Haskell
298 lines
9.1 KiB
Haskell
{-# 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.Monad.Trans (lift)
|
|
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 UserData) IO)
|
|
[(V2 Double, Boundaries Double)]
|
|
getPosBounds = do
|
|
efor allEnts $ do
|
|
with pos
|
|
with obstacle
|
|
pos' <- query pos
|
|
bnds <- query obstacle
|
|
return (pos', bnds)
|
|
|
|
updateNPCs
|
|
:: M.Matrix (Maybe ImgId)
|
|
-> SystemState Entity (AffectionState (AffectionData UserData) IO)
|
|
-> [ReachPoint]
|
|
-> Double
|
|
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
|
|
updateNPCs imgmat ws rp dt = do
|
|
updateStats dt
|
|
posbounds <- getPosBounds
|
|
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 -> (: filter (\p -> pointType p == Copier) rp)
|
|
<$> 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
|
|
let mdir =
|
|
pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
|
|
(_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
|
|
liftIO $ logIO A.Verbose ("accessibles: " ++ 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, 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
|
|
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
|
|
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
|
|
|
|
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: " ++ show candidates)
|
|
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 -> do
|
|
logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show ntarget)
|
|
putMVar mvar []
|
|
-- 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)
|
|
Just p -> putMVar mvar p
|