From abb3ad3cd3ef9e7fb5a3e4768364f648751f5b2e Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 15 Mar 2019 01:41:18 +0100 Subject: [PATCH] doors are now opened by NPCs and the player, not automatically. --- shell.nix | 4 +- src/MainGame/WorldMap.hs | 25 ++--- src/NPC.hs | 224 +++++++++++++++++++++++++-------------- src/Object.hs | 8 +- src/Object/Computer.hs | 9 +- src/Object/Copier.hs | 7 +- src/Object/Door.hs | 79 +++++++------- src/Types/NPCState.hs | 4 +- src/Types/ObjClass.hs | 3 +- tracer-game.cabal | 1 + 10 files changed, 214 insertions(+), 150 deletions(-) diff --git a/shell.nix b/shell.nix index 0551a44..25e9da8 100644 --- a/shell.nix +++ b/shell.nix @@ -232,7 +232,7 @@ let f = { mkDerivation, algebraic-graphs, base , bytestring, containers, ecstasy, JuicyPixels, JuicyPixels-extra - , matrix, mtl, OpenGL, random, stdenv, stm + , matrix, mtl, OpenGL, random, stdenv, stm, split , text, unordered-containers, vector, pkgconfig }: mkDerivation { @@ -244,7 +244,7 @@ let executableHaskellDepends = [ aff algebraic-graphs astar base bytestring containers ecstasy JuicyPixels JuicyPixels-extra linear matrix mtl nano OpenGL - random sdl stm text unordered-containers vector pkgconfig + random sdl stm split text unordered-containers vector pkgconfig ]; enableExecutableProfiling = true; enableLibraryProfiling = true; diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 36b6f55..81af42a 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -253,7 +253,7 @@ loadMapFork ud ad future progress = do , vel = Just (V2 0 0) , velFact = Just fact , rot = Just SE - , npcMoveState = Just (NPCWalking [pointCoord cpr]) + , npcMoveState = Just (NPCWalking [[pointCoord cpr]]) , npcWorkplace = Just cpr , npcActionState = Just ASWork , npcStats = Just stats @@ -853,16 +853,16 @@ updateMap dt = do Nothing -> Keep } return ent - allRelEnts <- efor allEnts $ do - with pos - with rot - with clearanceLvl - without objType - pos' <- query pos - rot' <- query rot - clvl <- query clearanceLvl - entn <- queryEnt - return (entn, pos', rot', clvl) + -- allRelEnts <- efor allEnts $ do + -- with pos + -- with rot + -- with clearanceLvl + -- without objType + -- pos' <- query pos + -- rot' <- query rot + -- clvl <- query clearanceLvl + -- entn <- queryEnt + -- return (entn, pos', rot', clvl) tses <- efor allEnts $ do with objType with objState @@ -871,10 +871,11 @@ updateMap dt = do e <- queryEnt return (t, s, e) mapM_ (\(t, s, e) -> - objectAction allRelEnts dt t s e + objectAction dt t s e ) tses (nws2, _) <- yieldSystemT nws $ updateNPCs (imgMat $ stateData ud) + (mapMat $ stateData ud) nws (Prelude.filter (\p -> pointType p /= RoomExit) diff --git a/src/NPC.hs b/src/NPC.hs index 7d13f17..54bd45f 100644 --- a/src/NPC.hs +++ b/src/NPC.hs @@ -8,6 +8,7 @@ import qualified Data.Matrix as M import Data.Ecstasy as E import Data.Maybe import Data.List (find) +import Data.List.Split (splitWhen) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans (lift) @@ -42,11 +43,12 @@ getPosBounds = do updateNPCs :: M.Matrix (Maybe ImgId) + -> M.Matrix TileState -> SystemState Entity (AffectionState (AffectionData UserData) IO) -> [ReachPoint] -> Double -> SystemT Entity (AffectionState (AffectionData UserData) IO) () -updateNPCs imgmat ws rrp dt = do +updateNPCs imgmat tsmat ws rrp dt = do updateStats dt posbounds <- getPosBounds moent <- catMaybes <$> eover allEnts (do @@ -62,6 +64,7 @@ updateNPCs imgmat ws rrp dt = do pos' <- query pos rot' <- query rot lvl <- query clearanceLvl + stat <- query anim npcState' <- query npcMoveState let rp = filter ((lvl >=) . pointClearance) rrp case npcState' of @@ -102,77 +105,46 @@ updateNPCs imgmat ws rrp dt = do }) NPCWalking path -> if not (null path) - then do - let itarget = fmap (+ 0.5) (fromIntegral <$> head path) :: V2 Double - if distance pos' itarget < 1.5 * dt - then - return (Nothing, unchanged - { npcMoveState = Set $ NPCWalking (tail path) - }) - else - return (Nothing, unchanged - { vel = Set $ (* 2) <$> signorm (itarget - pos') - }) + 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: " ++ 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 <$> 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 - future <- liftIO $ newEmptyMVar - stat <- query anim - as <- query npcActionState - targetRPs <- case as of - ASWork -> - let fltrd = filter (\p -> pointType p == Copier) rp - in - ((fltrd ++) . replicate (5 * length fltrd)) <$> - 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 + standStill imgmat tsmat pos' rot' ws posbounds rp + ) + mapM_ (\(oent, npcent, mfuture) -> do mts <- efor (anEnt oent) $ do with objType with objState @@ -205,11 +177,85 @@ updateNPCs imgmat ws rrp dt = do let ttl = case head mntns of Just (nt, ns) -> actionTime nt ns Nothing -> 1 - return unchanged - { npcMoveState = Set $ NPCStanding ttl future - } + 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)] + -> [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 = filter (\p -> pointType p == Copier) rp + in + ((fltrd ++) . replicate (5 * length fltrd)) <$> + 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 tsmat 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, 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) () @@ -271,12 +317,13 @@ getObject npos = do getPath :: V2 Int - -> MVar [V2 Int] + -> MVar [[V2 Int]] -> [ReachPoint] -> M.Matrix (Maybe ImgId) + -> M.Matrix TileState -> [(V2 Double, Boundaries Double)] -> IO () -getPath pos' mvar rp imgmat posbounds = do +getPath pos' mvar rp imgmat tsmat posbounds = do let seekRP = filter (\p -> pointType p /= RoomExit) rp ntargeti <- randomRIO (0, length seekRP - 1) let ntarget = pointCoord (seekRP !! ntargeti) @@ -287,19 +334,36 @@ getPath pos' mvar rp imgmat posbounds = 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 + Just p -> putMVar mvar (chewPath tsmat p) getPathTo :: V2 Int - -> MVar [V2 Int] + -> MVar [[V2 Int]] -> V2 Int -> M.Matrix (Maybe ImgId) + -> M.Matrix TileState -> [(V2 Double, Boundaries Double)] -> IO () -getPathTo pos' mvar target imgmat posbounds = do +getPathTo pos' mvar target imgmat tsmat 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 + 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 diff --git a/src/Object.hs b/src/Object.hs index 43159dc..98d7633 100644 --- a/src/Object.hs +++ b/src/Object.hs @@ -21,13 +21,13 @@ import Object.Copier import Object.Door instance ObjectAction ObjType ObjState where - objectAction relEnts dt t@ObjCopier s ent = copierObjectAction relEnts dt t s ent + objectAction dt t@ObjCopier s ent = copierObjectAction dt t s ent - objectAction relEnts dt t@ObjComputer s ent = computerObjectAction relEnts dt t s ent + objectAction dt t@ObjComputer s ent = computerObjectAction dt t s ent - objectAction relEnts dt t@ObjDoor s ent = doorObjectAction relEnts dt t s ent + objectAction dt t@ObjDoor s ent = doorObjectAction dt t s ent - objectAction _ _ _ _ _ = return () + objectAction _ _ _ _ = return () objectTransition t@ObjCopier s pa ent aent = copierObjectTransition t s pa ent aent diff --git a/src/Object/Computer.hs b/src/Object/Computer.hs index 2f06637..0557bdf 100644 --- a/src/Object/Computer.hs +++ b/src/Object/Computer.hs @@ -22,13 +22,12 @@ import Object.ActionTime computerObjectAction :: (Monad m, MonadIO m) - => [(Ent, V2 Double, Direction, Word)] - -> Double + => Double -> ObjType -> ObjState -> Ent -> SystemT Entity m () -computerObjectAction _ dt t@ObjComputer s@"on" ent = do +computerObjectAction dt t@ObjComputer s@"on" ent = do pent <- efor (anEnt ent) $ do with objUsedBy query objUsedBy @@ -66,7 +65,7 @@ computerObjectAction _ dt t@ObjComputer s@"on" ent = do (\tpa -> setEntity ent =<< computerObjectTransition t s tpa ent Nothing) (head trans) -computerObjectAction _ dt t@ObjComputer s@"hack" ent = do +computerObjectAction dt t@ObjComputer s@"hack" ent = do aent <- efor (anEnt ent) $ do with objUsedBy query objUsedBy @@ -101,7 +100,7 @@ computerObjectAction _ dt t@ObjComputer s@"hack" ent = do (\tpa -> setEntity ent =<< computerObjectTransition t s tpa ent Nothing) (head trans) -computerObjectAction _ _ _ _ _ = return () +computerObjectAction _ _ _ _ = return () computerObjectTransition :: (Monad m, MonadIO m) diff --git a/src/Object/Copier.hs b/src/Object/Copier.hs index 36aaaed..279fca6 100644 --- a/src/Object/Copier.hs +++ b/src/Object/Copier.hs @@ -19,13 +19,12 @@ import Types copierObjectAction :: (Monad m, MonadIO m, ActionTime ObjType ObjState) - => [(Ent, V2 Double, Direction, Word)] - -> Double + => Double -> ObjType -> ObjState -> Ent -> SystemT Entity m () -copierObjectAction _ dt t@ObjCopier s@"copying" ent = do +copierObjectAction dt t@ObjCopier s@"copying" ent = do emap (anEnt ent) $ do mtime <- queryMaybe objStateTime case mtime of @@ -46,7 +45,7 @@ copierObjectAction _ dt t@ObjCopier s@"copying" ent = do Just ttl -> return (ttl < 0) when (head trans) (setEntity ent =<< copierObjectTransition t s False ent Nothing) -copierObjectAction _ _ _ _ _ = return () +copierObjectAction _ _ _ _ = return () copierObjectTransition :: (Eq a, IsString a, MonadIO m) diff --git a/src/Object/Door.hs b/src/Object/Door.hs index 0eee01d..899484d 100644 --- a/src/Object/Door.hs +++ b/src/Object/Door.hs @@ -19,7 +19,7 @@ import Types import Object.ActionTime -doorObjectAction _ dt t@ObjDoor s@"open" ent = do +doorObjectAction dt t@ObjDoor s@"open" ent = do emap (anEnt ent) $ do mtime <- queryMaybe objStateTime case mtime of @@ -36,49 +36,50 @@ doorObjectAction _ dt t@ObjDoor s@"open" ent = do Just ttl -> return (ttl < 0) when (head trans) (setEntity ent =<< doorObjectTransition t s False ent Nothing) -doorObjectAction allRelEnts dt t@ObjDoor s@"shut" ent = do - permEnts <- efor (anEnt ent) $ do - pos' <- query pos - rot' <- query rot - clvl <- query clearanceLvl - let posEnts = filter - (\(_, b, _, _) -> - (fmap floor b `elem` deltaCoords || fmap floor b == floorPos) && - distance b pos' < 0.75) - allRelEnts - floorPos = fmap floor pos' - deltas = case rot' of - NW -> - [ V2 (-1) 0 - , V2 1 0 - ] - NE -> - [ V2 0 (-1) - , V2 0 1 - ] - acceptedRots = case rot' of - NW -> [NW, SE] - NE -> [NE, SW] - deltaCoords = map (floorPos +) deltas - predicate (_, _, c, d) = c `elem` acceptedRots && d >= clvl - ret = filter predicate posEnts - return ret - mapM_ - (\(e, _, _, _) -> setEntity ent =<< doorObjectTransition t s False ent (Just e)) - (head permEnts) +-- doorObjectAction allRelEnts dt t@ObjDoor s@"shut" ent = do +-- permEnts <- efor (anEnt ent) $ do +-- pos' <- query pos +-- rot' <- query rot +-- clvl <- query clearanceLvl +-- let posEnts = filter +-- (\(_, b, _, _) -> +-- (fmap floor b `elem` deltaCoords || fmap floor b == floorPos) && +-- distance b pos' < 0.75) +-- allRelEnts +-- floorPos = fmap floor pos' +-- deltas = case rot' of +-- NW -> +-- [ V2 (-1) 0 +-- , V2 1 0 +-- ] +-- NE -> +-- [ V2 0 (-1) +-- , V2 0 1 +-- ] +-- acceptedRots = case rot' of +-- NW -> [NW, SE] +-- NE -> [NE, SW] +-- deltaCoords = map (floorPos +) deltas +-- predicate (_, _, c, d) = c `elem` acceptedRots && d >= clvl +-- ret = filter predicate posEnts +-- return ret +-- mapM_ +-- (\(e, _, _, _) -> setEntity ent =<< doorObjectTransition t s False ent (Just e)) +-- (head permEnts) -doorObjectAction _ _ _ _ _ = return () +doorObjectAction _ _ _ _ = return () -doorObjectTransition t@ObjDoor s@"shut" _ ent (Just aent) = do +doorObjectTransition t@ObjDoor s _ ent (Just aent) = do [clearance] <- efor (anEnt aent) (query clearanceLvl) e <- efor (anEnt ent) $ do dir <- query rot oclear <- query clearanceLvl - liftIO $ A.logIO A.Verbose (show aent ++ " is attempting to open door " ++ show ent) - liftIO $ A.logIO A.Verbose ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance) + mttl <- queryMaybe objStateTime + liftIO $ A.logIO A.Debug (show aent ++ " is attempting to open door " ++ show ent) + liftIO $ A.logIO A.Debug ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance) if clearance >= oclear then do - liftIO $ A.logIO A.Verbose ("door " ++ show oclear ++ " opens") + liftIO $ A.logIO A.Debug ("door " ++ show oclear ++ " opens") let nstat = AnimState (AnimId AnimDoor0 "open" dir) 0 @@ -86,8 +87,9 @@ doorObjectTransition t@ObjDoor s@"shut" _ ent (Just aent) = do return unchanged { objState = Set "open" , objStateTime = Set (actionTime t ("open" :: String)) - , objUsedBy = Set aent - , anim = Set nstat + , anim = if fromMaybe True (fmap (0 >) mttl) + then Set nstat + else Keep , obstacle = Unset } else @@ -108,7 +110,6 @@ doorObjectTransition ObjDoor "open" _ ent Nothing = do { anim = Set nstat , objState = Set "shut" , objStateTime = Unset - , objUsedBy = Unset , obstacle = Set $ case orientation of NW -> Boundaries (4/9, 0) (5/9, 1) NE -> Boundaries (0, 4/9) (1, 5/9) diff --git a/src/Types/NPCState.hs b/src/Types/NPCState.hs index 314b1fb..4cdb642 100644 --- a/src/Types/NPCState.hs +++ b/src/Types/NPCState.hs @@ -5,11 +5,11 @@ import Linear (V2) data NPCMoveState = NPCWalking - { npcWalkPath :: [V2 Int] + { npcWalkPath :: [[V2 Int]] } | NPCStanding { npcStandTime :: Double - , npcFuturePath :: MVar [V2 Int] + , npcFuturePath :: MVar [[V2 Int]] } data NPCActionState diff --git a/src/Types/ObjClass.hs b/src/Types/ObjClass.hs index 4e22c56..b4ead37 100644 --- a/src/Types/ObjClass.hs +++ b/src/Types/ObjClass.hs @@ -13,8 +13,7 @@ import Types.Direction class ObjectAction otype ostate where objectAction - :: [(Ent, V2 Double, Direction, Word)] - -> Double + :: Double -> otype -> ostate -> Ent diff --git a/tracer-game.cabal b/tracer-game.cabal index c766bcc..13156a4 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -79,6 +79,7 @@ executable tracer-game , algebraic-graphs , mtl , parallel + , split hs-source-dirs: src ghc-options: -Wall -threaded default-language: Haskell2010