doors are now opened by NPCs and the player, not automatically.

2019-03-15 01:41:18 +01:00 · 2019-03-15 01:41:18 +01:00 · abb3ad3cd3
commit abb3ad3cd3
parent 0fcd4a10b2
10 changed files with 214 additions and 150 deletions
--- 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;
--- 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)
--- 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
--- 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
--- 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)
--- 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)
--- 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)
--- 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
--- 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
--- 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