{-# 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.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 without ignoreObstacle pos' <- query pos bnds <- query obstacle return (pos', bnds) updateNPCs :: M.Matrix (Maybe ImgId) -> M.Matrix TileState -> SystemState Entity (AffectionState (AffectionData UserData) IO) -> V.Vector ReachPoint -> Double -> SystemT Entity (AffectionState (AffectionData UserData) IO) () 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 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.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