tracer/src/NPC.hs

400 lines
12 KiB
Haskell
Raw Normal View History

2018-08-10 12:09:07 +00:00
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
2019-10-20 08:53:53 +00:00
{-# LANGUAGE ScopedTypeVariables #-}
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)
import Data.List.Split (splitWhen)
2019-10-20 08:53:53 +00:00
import qualified Data.Vector as V
2019-10-28 17:20:34 +00:00
import Data.String
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)
2022-08-04 16:13:53 +00:00
import Control.Monad.Trans.Resource (ResIO)
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
2022-08-04 16:13:53 +00:00
(AffectionState AffectionData ResIO)
2018-09-12 22:51:22 +00:00
[(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)
-> M.Matrix TileState
2022-08-04 16:13:53 +00:00
-> SystemState Entity (AffectionState AffectionData ResIO)
2019-10-20 08:53:53 +00:00
-> V.Vector ReachPoint
2018-04-14 16:43:05 +00:00
-> Double
2022-08-04 16:13:53 +00:00
-> SystemT Entity (AffectionState AffectionData ResIO) ()
updateNPCs imgmat tsmat 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
stat <- query anim
2018-08-10 23:12:07 +00:00
npcState' <- query npcMoveState
2019-10-20 08:53:53 +00:00
let rp = V.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
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')
2019-10-28 17:20:34 +00:00
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 =
2019-10-20 08:53:53 +00:00
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')
})
2018-08-10 23:12:07 +00:00
else do
standStill imgmat tsmat pos' rot' ws posbounds rp
)
mapM_ (\(oent, npcent, mfuture) -> 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
maybe
(return unchanged)
(\future -> return unchanged
{ npcMoveState = Set $ NPCStanding ttl future
}
)
mfuture
2018-08-10 23:12:07 +00:00
) moent
standStill
:: (MonadIO m, RealFrac a1)
=> M.Matrix (Maybe ImgId)
-> M.Matrix TileState
-> V2 a1
-> Direction
-> SystemState Entity m
-> [(V2 Double, Boundaries Double)]
2019-10-20 08:53:53 +00:00
-> 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 ->
2019-10-20 08:53:53 +00:00
let fltrd = V.filter (\p -> pointType p == Copier) rp
in
2019-10-20 08:53:53 +00:00
(V.foldl V.snoc fltrd . V.replicate (5 * V.length fltrd)) <$>
query npcWorkplace
ASToilet -> do
2019-10-20 08:53:53 +00:00
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
2019-10-20 08:53:53 +00:00
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
2019-10-20 08:53:53 +00:00
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 ->
2019-10-20 08:53:53 +00:00
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')
2019-10-28 17:20:34 +00:00
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
})
2018-09-07 21:39:53 +00:00
updateStats
:: Double
2022-08-04 16:13:53 +00:00
-> SystemT Entity (AffectionState AffectionData ResIO) ()
2018-09-07 21:39:53 +00:00
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)
2019-10-28 17:20:34 +00:00
liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates))
2018-09-12 22:51:22 +00:00
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]]
2019-10-20 08:53:53 +00:00
-> V.Vector ReachPoint
-> M.Matrix (Maybe ImgId)
-> M.Matrix TileState
2018-07-21 19:10:32 +00:00
-> [(V2 Double, Boundaries Double)]
-> IO ()
getPath pos' mvar rp imgmat tsmat posbounds = do
2019-10-20 08:53:53 +00:00
let seekRP = V.filter (\p -> pointType p /= RoomExit) rp
ntargeti <- randomRIO (0, V.length seekRP - 1)
let ntarget = pointCoord (seekRP V.! ntargeti)
2018-07-21 19:10:32 +00:00
path = astarAppl imgmat posbounds ntarget pos'
2019-10-28 17:20:34 +00:00
logIO
A.Verbose
("seeking path from " <>
fromString (show pos') <>
" to " <>
fromString (show ntarget)
)
case path of
2018-09-12 22:51:22 +00:00
Nothing -> do
2019-10-28 17:20:34 +00:00
logIO
A.Error
("No path from " <>
fromString (show pos') <>
" to " <>
fromString ( show ntarget)
)
2018-09-12 22:51:22 +00:00
putMVar mvar []
-- getPath pos' mvar rp imgmat posbounds
Just p -> putMVar mvar (chewPath tsmat p)
2018-09-07 17:49:16 +00:00
getPathTo
:: V2 Int
-> MVar [[V2 Int]]
2018-09-07 17:49:16 +00:00
-> V2 Int
-> M.Matrix (Maybe ImgId)
-> M.Matrix TileState
2018-09-07 17:49:16 +00:00
-> [(V2 Double, Boundaries Double)]
-> IO ()
getPathTo pos' mvar target imgmat tsmat posbounds = do
2018-09-07 17:49:16 +00:00
let path = astarAppl imgmat posbounds target pos'
2019-10-28 17:20:34 +00:00
logIO
A.Verbose
("seeking path from " <>
fromString (show pos') <>
" to " <>
fromString (show target)
)
2018-09-07 17:49:16 +00:00
case path of
Nothing -> do
2019-10-28 17:20:34 +00:00
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