tracer/src/NPC.hs

220 lines
6.1 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(..))
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-04-14 11:34:28 +00:00
placeNPCs
:: M.Matrix (Maybe ImgId)
2018-04-14 16:43:05 +00:00
-> M.Matrix TileState
2018-04-14 11:34:28 +00:00
-> [ReachPoint]
-> Int
2018-06-07 22:29:46 +00:00
-> IO [V2 Double]
2018-07-03 14:19:27 +00:00
placeNPCs imgmat tilemat rp count =
2018-04-14 09:18:37 +00:00
doPlace 1 []
where
2018-06-07 22:29:46 +00:00
doPlace :: Int -> [V2 Double] -> IO [V2 Double]
2018-07-03 14:19:27 +00:00
doPlace nr acc =
2018-04-14 09:18:37 +00:00
if nr <= count
then do
2018-06-07 22:29:46 +00:00
r <- randomRIO (1, M.nrows imgmat)
c <- randomRIO (1, M.ncols imgmat)
if null (maybe [] collisionObstacle $ imgmat M.! (r, c)) &&
2018-04-14 16:43:05 +00:00
tilemat M.! (r, c) == Hall
2018-04-14 09:18:37 +00:00
then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc)
2018-04-14 16:43:05 +00:00
else do
2018-06-07 22:29:46 +00:00
i <- randomRIO (0, length nonexits - 1)
2018-04-14 16:43:05 +00:00
doPlace
(nr + 1)
((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)
2018-04-14 09:18:37 +00:00
else
return acc
2018-04-14 16:43:05 +00:00
nonexits =
filter
(\p ->
pointType p /= RoomExit
)
rp
updateNPCs
2018-08-10 12:09:07 +00:00
:: M.Matrix (Maybe ImgId)
2018-04-14 16:43:05 +00:00
-> [ReachPoint]
-> Double
2018-08-10 12:09:07 +00:00
-> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
2018-08-18 03:01:52 +00:00
updateNPCs imgmat rp dt = do
2018-07-21 19:10:32 +00:00
posbounds <- efor allEnts $ do
with pos
with obstacle
pos' <- query pos
bnds <- query obstacle
return (pos', bnds)
2018-08-10 23:12:07 +00:00
npcposs <- efor allEnts $ do
with pos
2018-06-23 22:43:09 +00:00
with npcMoveState
2018-04-14 16:43:05 +00:00
with vel
2018-08-10 23:12:07 +00:00
with rot
with anim
pos' <- query pos
e <- queryEnt
return (e, pos')
eaccess <- getObjects npcposs
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
with vel
with rot
with anim
2018-08-10 12:09:07 +00:00
pos' <- query pos
rot' <- query rot
2018-08-10 23:12:07 +00:00
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
case mpath of
Just path ->
2018-08-10 12:09:07 +00:00
return $ (Nothing, unchanged
2018-08-10 23:12:07 +00:00
{ npcMoveState = Set $ NPCWalking path
2018-08-10 12:09:07 +00:00
})
2018-08-10 23:12:07 +00:00
Nothing ->
2018-08-10 12:09:07 +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-08-10 23:12:07 +00:00
NPCWalking path -> do
if not (null path)
then do
let itarget = V2 0.5 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
_ <- liftIO $ forkIO $
getPath (fmap floor pos') future rp 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
2018-08-10 12:09:07 +00:00
}
2018-08-10 23:12:07 +00:00
}
})
objects -> do
liftIO $ logIO Debug ("applicable objects: " ++ show objects)
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
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
2018-08-18 03:01:52 +00:00
getObjects
:: (Monad m, Traversable t, RealFrac a1)
=> t (a2, V2 a1)
-> SystemT Entity m (t (a2, [(Ent, V2 Double, (V2 Int, Direction))]))
2018-08-10 23:12:07 +00:00
getObjects npcposs = 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-08-18 03:01:52 +00:00
mapM (\(e, npos) ->
2018-08-10 23:12:07 +00:00
return
( e
, filter (\(_, p, (delta, _)) ->
2018-08-18 03:01:52 +00:00
fmap floor p + delta == fmap floor npos
2018-08-10 23:12:07 +00:00
) candidates
)
) npcposs
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-07-21 19:10:32 +00:00
Nothing -> getPath pos' mvar rp imgmat posbounds
Just p -> putMVar mvar p