tracer/src/NPC.hs

306 lines
9.4 KiB
Haskell
Raw Normal View History

2018-08-10 12:09:07 +00:00
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
2018-04-14 09:18:37 +00:00
module NPC where
import Affection as A
import qualified Data.Matrix as M
import Data.Ecstasy as E
2018-08-10 23:12:07 +00:00
import Data.Maybe
import Data.List (find)
2018-04-14 09:18:37 +00:00
2018-04-14 16:43:05 +00:00
import Control.Monad.IO.Class (MonadIO(..))
2018-09-12 22:51:22 +00:00
import Control.Monad.Trans (lift)
import Control.Concurrent.MVar
2018-06-23 22:43:09 +00:00
import Control.Concurrent (forkIO)
2018-04-14 16:43:05 +00:00
2018-04-14 09:18:37 +00:00
import Linear
import System.Random
-- internal imports
2018-04-14 11:34:28 +00:00
import Util
import Types
2018-04-14 09:18:37 +00:00
2018-08-18 03:01:52 +00:00
import Object ()
2018-08-10 12:09:07 +00:00
2018-09-12 22:51:22 +00:00
getPosBounds
:: SystemT
Entity
(AffectionState (AffectionData UserData) IO)
[(V2 Double, Boundaries Double)]
getPosBounds = do
efor allEnts $ do
with pos
with obstacle
without ignoreObstacle
2018-09-12 22:51:22 +00:00
pos' <- query pos
bnds <- query obstacle
return (pos', bnds)
2018-04-14 16:43:05 +00:00
updateNPCs
2018-08-10 12:09:07 +00:00
:: M.Matrix (Maybe ImgId)
2018-09-12 22:51:22 +00:00
-> SystemState Entity (AffectionState (AffectionData UserData) IO)
2018-04-14 16:43:05 +00:00
-> [ReachPoint]
-> Double
2018-08-10 12:09:07 +00:00
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
updateNPCs imgmat ws rrp dt = do
2018-09-07 21:39:53 +00:00
updateStats dt
2018-09-12 22:51:22 +00:00
posbounds <- getPosBounds
2018-09-02 08:44:33 +00:00
moent <- catMaybes <$> eover allEnts (do
2018-04-14 16:43:05 +00:00
with pos
2018-08-10 23:12:07 +00:00
with npcMoveState
2018-09-08 12:05:07 +00:00
with npcActionState
with npcWorkplace
with npcStats
2019-02-14 21:31:00 +00:00
with clearanceLvl
2018-08-10 23:12:07 +00:00
with vel
with rot
with anim
2018-08-10 12:09:07 +00:00
pos' <- query pos
rot' <- query rot
2019-02-14 21:31:00 +00:00
lvl <- query clearanceLvl
2018-08-10 23:12:07 +00:00
npcState' <- query npcMoveState
let rp = filter ((lvl >=) . pointClearance) rrp
2018-08-10 23:12:07 +00:00
case npcState' of
NPCStanding ttl future -> do
let nttl = ttl - dt
if nttl > 0
then
2018-09-02 08:44:33 +00:00
return (Nothing, unchanged
2018-08-10 23:12:07 +00:00
{ npcMoveState = Set $ NPCStanding nttl future
2018-09-12 22:51:22 +00:00
-- , vel = Set $ V2 0 0
2018-08-10 23:12:07 +00:00
})
else do
mpath <- liftIO $ tryTakeMVar future
2018-09-08 12:05:07 +00:00
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
2018-08-10 23:12:07 +00:00
case mpath of
Just path ->
2018-09-02 08:44:33 +00:00
return (Nothing, unchanged
2018-08-10 23:12:07 +00:00
{ npcMoveState = Set $ NPCWalking path
2018-09-08 12:05:07 +00:00
, npcStats = Set nstats
2018-08-10 12:09:07 +00:00
})
2018-08-10 23:12:07 +00:00
Nothing ->
2018-09-02 08:44:33 +00:00
return (Nothing, unchanged
2018-08-10 23:12:07 +00:00
{ npcMoveState = Set $ NPCStanding 1 future
2018-08-10 12:09:07 +00:00
})
2018-09-02 08:44:33 +00:00
NPCWalking path ->
2018-08-10 23:12:07 +00:00
if not (null path)
then do
2018-09-08 12:05:07 +00:00
let itarget = fmap (+ 0.5) (fromIntegral <$> head path) :: V2 Double
2019-02-13 11:09:41 +00:00
if distance pos' itarget < 1.5 * dt
2018-08-10 23:12:07 +00:00
then
2018-09-02 08:44:33 +00:00
return (Nothing, unchanged
2018-08-10 23:12:07 +00:00
{ npcMoveState = Set $ NPCWalking (tail path)
})
else
2018-09-02 08:44:33 +00:00
return (Nothing, unchanged
2018-08-10 23:12:07 +00:00
{ vel = Set $ (* 2) <$> signorm (itarget - pos')
})
else do
future <- liftIO $ newEmptyMVar
stat <- query anim
2018-09-08 12:05:07 +00:00
as <- query npcActionState
targetRPs <- case as of
2019-02-13 23:20:26 +00:00
ASWork ->
let fltrd = filter (\p -> pointType p == Copier) rp
in
((fltrd ++) . replicate (5 * length fltrd)) <$>
query npcWorkplace
2018-09-08 12:05:07 +00:00
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
2018-08-10 23:12:07 +00:00
_ <- liftIO $ forkIO $
2018-09-08 12:05:07 +00:00
getPath (fmap floor pos') future targetRPs imgmat posbounds
2018-08-10 23:12:07 +00:00
let mdir =
2018-09-02 08:44:33 +00:00
pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
2018-09-12 22:51:22 +00:00
(_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles)
2018-08-10 23:12:07 +00:00
case accessibles of
[] -> do
ttl <- liftIO $ randomRIO (5, 30)
2018-09-02 08:44:33 +00:00
return (Nothing, unchanged
2018-08-10 23:12:07 +00:00
{ 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
2018-08-10 12:09:07 +00:00
}
2018-08-10 23:12:07 +00:00
}
})
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
2018-08-10 12:09:07 +00:00
}
2018-08-10 23:12:07 +00:00
}
, vel = Set $ V2 0 0
}))
mapM_ (\(oent, npcent, future) -> do
2019-01-06 02:52:43 +00:00
mts <- efor (anEnt oent) $ do
2018-08-10 23:12:07 +00:00
with objType
with objState
2018-09-12 22:51:22 +00:00
moub <- queryMaybe objUsedBy
2018-08-10 23:12:07 +00:00
otyp <- query objType
ostat <- query objState
2018-09-12 22:51:22 +00:00
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)
)
2019-01-06 02:52:43 +00:00
(head mts)
mntns <- efor (anEnt oent) $ do
2018-08-10 23:12:07 +00:00
with objType
with objState
2018-09-12 22:51:22 +00:00
moub <- queryMaybe objUsedBy
2018-08-10 23:12:07 +00:00
otyp <- query objType
ostat <- query objState
2018-09-12 22:51:22 +00:00
case moub of
Nothing -> return $ Just (otyp, ostat)
Just uent -> if uent == npcent
then return $ Just (otyp, ostat)
else return Nothing
2018-08-10 23:12:07 +00:00
emap (anEnt npcent) $ do
2019-01-06 02:52:43 +00:00
let ttl = case head mntns of
2018-09-12 22:51:22 +00:00
Just (nt, ns) -> actionTime nt ns
Nothing -> 1
2018-08-10 23:12:07 +00:00
return unchanged
{ npcMoveState = Set $ NPCStanding ttl future
}
) moent
2018-09-07 21:39:53 +00:00
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
2018-09-08 19:40:05 +00:00
{ statAttention =
2018-09-07 21:39:53 +00:00
if as == ASWork
2019-02-13 23:20:26 +00:00
then max 0 (conc - 0.05 * dt)
else min 1 (conc + 0.1 * dt)
2018-09-07 21:39:53 +00:00
, statBladder =
if food > 0 || drin > 0
2019-03-07 00:33:51 +00:00
then min 1 (blad + 0.01 * dt)
2018-09-07 21:39:53 +00:00
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
2018-09-08 19:40:05 +00:00
| statAttention nstat == 0 = ASRandWalk
2018-09-07 21:39:53 +00:00
| statThirst nstat == 0 = ASDrink
2019-02-13 23:20:26 +00:00
| statHunger nstat == 0 = ASEat -- TODO: Let them eat
2018-09-08 19:40:05 +00:00
| statAttention nstat > statAttention ostat &&
statAttention nstat > 0.75 = ASWork
2018-09-07 21:39:53 +00:00
| statBladder nstat > 0.9 = ASToilet
| otherwise = as
2018-09-12 22:51:22 +00:00
getObject
:: (MonadIO m, RealFrac a1)
=> V2 a1
2019-02-16 19:38:00 +00:00
-> SystemT Entity m [(Ent, V2 Double, [(V2 Int, Direction)])]
2018-09-12 22:51:22 +00:00
getObject npos = do
2018-08-10 12:09:07 +00:00
candidates <- efor allEnts $ do
with pos
with objType
with objState
with objAccess
pos' <- query pos
oacc <- query objAccess
ent <- queryEnt
return (ent, pos', oacc)
2018-09-12 22:51:22 +00:00
liftIO $ logIO A.Verbose ("candidates: " ++ show candidates)
return $
2019-02-16 19:38:00 +00:00
filter (\(_, p, deltaors) ->
any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors
2018-09-12 22:51:22 +00:00
) candidates
getPath
:: V2 Int
-> MVar [V2 Int]
-> [ReachPoint]
-> M.Matrix (Maybe ImgId)
2018-07-21 19:10:32 +00:00
-> [(V2 Double, Boundaries Double)]
-> IO ()
2018-07-21 19:10:32 +00:00
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)
2018-07-21 19:10:32 +00:00
path = astarAppl imgmat posbounds ntarget pos'
logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
case path of
2018-09-12 22:51:22 +00:00
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
2018-09-07 17:49:16 +00:00
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