made doors player interactable

src/Load.hs

@@ -453,22 +453,40 @@ loadFork ws win glc nvg future progress = do
       , AnimationConfig (64, 0) (64, 74) (0, 0) 1 0 APLoop
       )
     ]
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"neDoor0: open\""
+    )))
+  neDoor0open <- loadAnimationSprites "assets/doors/door_desc_0.png" nvg
+    [ ( AnimId AnimDoor0 "open" NE
+      , AnimationConfig (0, 0) (64, 74) (0, 74) 5 1 APOnce
+      )
+    ]
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading Animation \"neDoor0: shut\""
     )))
-  neDoor0shut <- loadAnimationSprites "assets/doors/door_asc_0.png" nvg
+  neDoor0shut <- loadAnimationSprites "assets/doors/door_desc_0.png" nvg
     [ ( AnimId AnimDoor0 "shut" NE
-      , AnimationConfig (0, 0) (64, 74) (0, 0) 1 0 APLoop
+      , AnimationConfig (0, 4*74) (64, 74) (0, -74) 5 1 APOnce
+      )
+    ]
+  modifyMVar_ progress (return . (\(p, _) ->
+    ( p + increment
+    , "Loading Animation \"nwDoor0: open\""
+    )))
+  nwDoor0open <- loadAnimationSprites "assets/doors/door_asc_0.png" nvg
+    [ ( AnimId AnimDoor0 "open" NW
+      , AnimationConfig (0, 0) (64, 74) (0, 74) 5 1 APOnce
       )
     ]
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading Animation \"nwDoor0: shut\""
     )))
-  nwDoor0shut <- loadAnimationSprites "assets/doors/door_desc_0.png" nvg
+  nwDoor0shut <- loadAnimationSprites "assets/doors/door_asc_0.png" nvg
     [ ( AnimId AnimDoor0 "shut" NW
-      , AnimationConfig (0, 0) (64, 74) (0, 0) 1 0 APLoop
+      , AnimationConfig (0, 4*74) (64, 74) (0, -74) 5 1 APOnce
       )
     ]
   modifyMVar_ progress (return . (\(p, _) ->
@@ -499,7 +517,9 @@ loadFork ws win glc nvg future progress = do
           toiletFree ++
           toiletOccupied ++
           neDoor0shut ++
-          nwDoor0shut
+          neDoor0open ++
+          nwDoor0shut ++
+          nwDoor0open
         )
       , loadAssetIcons  = M.fromList icons
       }

src/MainGame/WorldMap.hs

@@ -147,7 +147,7 @@ loadMapFork ud ad future progress = do
         { pos       = Just $ reachCoord - V2 1 0
         , obstacle  = Just $ Boundaries (10/36, 8/36) (28/36, 30/36)
         , anim      = Just $ AnimState (AnimId AnimCopier "open" N) 0 0
-        , objAccess = Just (V2 1 0, NW)
+        , objAccess = Just [(V2 1 0, NW)]
         , objType   = Just ObjCopier
         , objState  = Just "idle"
         }
@@ -167,7 +167,8 @@ loadMapFork ud ad future progress = do
       void $ createEntity $ newEntity
         { pos       = Just $ reachCoord - fmap fromIntegral access
         , anim      = Just $ AnimState (AnimId AnimComputer "off" dir) 0 0
-        , objAccess = Just (access, dir)
+        , rot       = Just dir
+        , objAccess = Just [(access, dir)]
         , objType   = Just ObjComputer
         , objState  = Just "off"
         }
@@ -183,7 +184,7 @@ loadMapFork ud ad future progress = do
         { pos       = Just $ reachCoord - V2 0 (-1)
         , obstacle  = Just $ Boundaries (0, 0) (1, 1)
         , anim      = Just $ AnimState (AnimId AnimToilet "free" N) 0 0
-        , objAccess = Just (V2 0 (-1), dir)
+        , objAccess = Just [(V2 0 (-1), dir)]
         , objType   = Just ObjToilet
         }
       ) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets)
@@ -218,6 +219,7 @@ loadMapFork ud ad future progress = do
       , mmvel         = Just (V2 0 0)
       , player        = Just ()
       , rot           = Just SE
+      , clearanceLvl  = Just 0
       , anim          = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0
       }
     liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers)
@@ -288,18 +290,31 @@ loadMapFork ud ad future progress = do
                 fromMaybe False (isWall <$> imgmat M.! (r, c)))
             deltas
           orientation
-            | head wall == V2 0 1 || head wall == V2 0 (-1) = NE
+            | head wall == V2 0 1 || head wall == V2 0 (-1) = NW
-            | head wall == V2 1 0 || head wall == V2 (-1) 0 = NW
+            | head wall == V2 1 0 || head wall == V2 (-1) 0 = NE
             | otherwise                                     = error ("strange wall: " ++ show wall)
       void $ createEntity $ newEntity
         { pos            = Just (fmap ((+ 0.5) . fromIntegral) coord)
         , clearanceLvl   = Just (maximum $ 0 : Prelude.map clearance (Prelude.map snd rooms))
-        , anim           = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 0
+        , anim           = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1
         , obstacle       = Just $ case orientation of
-          NE -> Boundaries (4/9, 0) (5/9, 1)
+          NW -> Boundaries (4/9, 0) (5/9, 1)
-          NW -> Boundaries (0, 4/9) (1, 5/9)
+          NE -> Boundaries (0, 4/9) (1, 5/9)
           _  -> error "strange orientation for door"
         , ignoreObstacle = Just ()
+        , rot            = Just orientation
+        , objAccess      = Just $ case orientation of
+          NW ->
+            [ ((V2 (-1) 0), SE)
+            , ((V2   1  0), NW)
+            ]
+          NE ->
+            [ ((V2 0    1), SW)
+            , ((V2 0 (-1)), NE)
+            ]
+          _  -> error "strange orientation for door"
+        , objType        = Just ObjDoor
+        , objState       = Just "shut"
         }
       ) doors
     liftIO $ modifyMVar_ progress (return . (\(p, _) ->
@@ -467,15 +482,15 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
       with objAccess
       with objType
       with objState
-      (rel, dir) <- query objAccess
+      reldirs <- query objAccess
       pos' <- query pos
       otype <- query objType
       ostate <- query objState
       ent <- queryEnt
-      if ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
+      if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
         (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
         (fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) &&
-        pdir == dir
+        pdir == dir) reldirs
       then return $ Just (otype, ostate, ent)
       else return Nothing
     let relEnts = catMaybes mrelEnts
@@ -507,14 +522,14 @@ playerInteract2 (ActionMessage ActActivate _) = do
       with objAccess
       with objType
       with objState
-      (rel, dir) <- query objAccess
+      reldirs <- query objAccess
       pos' <- query pos
       otype <- query objType
       ostate <- query objState
       ent <- queryEnt
-      if ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
+      if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
         (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
-        pdir == dir
+        pdir == dir) reldirs
       then return $ Just (otype, ostate, ent)
       else return Nothing
     let relEnts = catMaybes mrelEnts

src/NPC.hs

@@ -252,7 +252,7 @@ updateStats dt =
 getObject
   :: (MonadIO m, RealFrac a1)
   => V2 a1
-  -> SystemT Entity m [(Ent, V2 Double, (V2 Int, Direction))]
+  -> SystemT Entity m [(Ent, V2 Double, [(V2 Int, Direction)])]
 getObject npos = do
   candidates <- efor allEnts $ do
     with pos
@@ -265,8 +265,8 @@ getObject npos = do
     return (ent, pos', oacc)
   liftIO $ logIO A.Verbose ("candidates: " ++ show candidates)
   return $
-    filter (\(_, p, (delta, _)) ->
+    filter (\(_, p, deltaors) ->
-    fmap floor p + delta == fmap floor npos
+      any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors
     ) candidates
 
 getPath

src/Object.hs

@@ -18,12 +18,15 @@ import Types
 
 import Object.Computer
 import Object.Copier
+import Object.Door
 
 instance ObjectAction ObjType ObjState where
   objectAction dt t@ObjCopier s ent = copierObjectAction dt t s ent
 
   objectAction dt t@ObjComputer s ent = computerObjectAction dt t s ent
 
+  objectAction dt t@ObjDoor s ent = doorObjectAction dt t s ent
+
   objectAction _ _ _ _ = return ()
 
   objectTransition t@ObjCopier s pa ent aent =
@@ -32,12 +35,7 @@ instance ObjectAction ObjType ObjState where
   objectTransition t@ObjComputer s pa ent aent =
     computerObjectTransition t s pa ent aent
 
+  objectTransition t@ObjDoor s pa ent aent =
+    doorObjectTransition t s pa ent aent
+
   objectTransition _ _ _ _ _ = return unchanged
-
-instance ActionTime ObjType ObjState where
-  actionTime ObjCopier "copying" = 5
-  actionTime ObjComputer "off" = 0
-  actionTime ObjComputer "on" = 20
-  actionTime ObjComputer "hack" = 20
-
-  actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not a time") 0

src/Object/ActionTime.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Object.ActionTime where
+
+import Affection as A
+
+-- internal imports
+
+import Types
+
+instance ActionTime ObjType ObjState where
+  actionTime ObjCopier "copying" = 5
+  actionTime ObjComputer "off" = 0
+  actionTime ObjComputer "on" = 20
+  actionTime ObjComputer "hack" = 20
+  actionTime ObjComputer "hack" = 20
+  actionTime ObjDoor     "open" = 2
+
+  actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not a time") 0

src/Object/Computer.hs

@@ -7,15 +7,26 @@ module Object.Computer where
 import Affection as A
 
 import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO(..))
 
 import Data.Ecstasy
 import Data.Maybe
 
 import Linear
 
+-- internal imports
+
 import Types
 
+import Object.ActionTime
 
+computerObjectAction
+  :: (Monad m, MonadIO m)
+  => Double
+  -> ObjType
+  -> ObjState
+  -> Ent
+  -> SystemT Entity m ()
 computerObjectAction dt t@ObjComputer s@"on" ent = do
   pent <- efor (anEnt ent) $ do
     with objUsedBy
@@ -91,10 +102,18 @@ computerObjectAction dt t@ObjComputer s@"hack" ent = do
 
 computerObjectAction _ _ _ _ = return ()
 
+computerObjectTransition
+  :: (Monad m, MonadIO m)
+  => ObjType
+  -> ObjState
+  -> Bool
+  -> Ent
+  -> Maybe Ent
+  -> SystemT Entity m (Entity 'SetterOf)
 computerObjectTransition ObjComputer "off" pa ent (Just aent) = do
+  [dir] <- efor (anEnt aent) (query rot)
   e <- efor (anEnt ent) $ do
     solved <- queryMaybe objSolved
-    (_, dir) <- query objAccess
     if pa
     then if not (fromMaybe False solved)
       then do
@@ -134,7 +153,7 @@ computerObjectTransition ObjComputer "off" pa ent (Just aent) = do
 
 computerObjectTransition ObjComputer "on" _ ent _ = do
   e <- efor (anEnt ent) $ do
-    (_, dir) <- query objAccess
+    dir <- query rot
     let nstat = AnimState
           (AnimId AnimComputer "off" dir)
           0
@@ -152,7 +171,7 @@ computerObjectTransition ObjComputer "hack" pa ent _ =
   if pa
   then do
     e <- efor (anEnt ent) $ do
-      (_, dir) <- query objAccess
+      dir <- query rot
       let nstat = AnimState
             (AnimId AnimComputer "off" dir)
             0

src/Object/Door.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Object.Door where
+
+import Affection as A
+
+import Control.Monad (when)
+
+import Data.Ecstasy
+import Data.Maybe
+
+import Linear
+
+-- internal imports
+
+import Types
+
+import Object.ActionTime
+
+doorObjectAction dt t@ObjDoor s@"open" ent = do
+  emap (anEnt ent) $ do
+    mtime <- queryMaybe objStateTime
+    case mtime of
+      Nothing -> do
+        return unchanged
+      Just ttl ->
+        return unchanged
+          { objStateTime = Set (ttl - dt)
+          }
+  trans <- efor (anEnt ent) $ do
+    mttl <- queryMaybe objStateTime
+    case mttl of
+      Nothing -> return False
+      Just ttl -> return (ttl < 0)
+  when (head trans) (setEntity ent =<< doorObjectTransition t s False ent Nothing)
+
+doorObjectAction _ _ _ _ = return ()
+
+doorObjectTransition t@ObjDoor s@"shut" _ 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.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
+        let nstat = AnimState
+              (AnimId AnimDoor0 "open" dir)
+              0
+              0
+        return unchanged
+          { objState     = Set "open"
+          , objStateTime = Set (actionTime t ("open" :: String))
+          , objUsedBy    = Set aent
+          , anim         = Set nstat
+          , obstacle     = Unset
+          }
+      else
+        return unchanged
+  return (head e)
+
+doorObjectTransition ObjDoor "open" _ ent Nothing = do
+  e <- efor (anEnt ent) $ do
+    ttl <- query objStateTime
+    orientation <- query rot
+    if ttl < 0
+    then do
+      let nstat = AnimState
+            (AnimId AnimDoor0 "shut" orientation)
+            0
+            0
+      return unchanged
+        { 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)
+          _  -> error "strange orientation for door"
+        }
+    else return unchanged
+  return (head e)
+
+doorObjectTransition _ _ _ _ _ = return unchanged

src/Types/Entity.hs

@@ -29,7 +29,7 @@ data Entity f = Entity
   , npcStats           :: Component f 'Field NPCStats
   , clearanceLvl       :: Component f 'Field Word
   , anim               :: Component f 'Field AnimState
-  , objAccess          :: Component f 'Field ((V2 Int), Direction)
+  , objAccess          :: Component f 'Field [((V2 Int), Direction)]
   , objType            :: Component f 'Field ObjType
   , objState           :: Component f 'Field ObjState
   , objStateTime       :: Component f 'Field Double

tracer-game.cabal

@@ -49,8 +49,10 @@ executable tracer-game
                      , MindMap
                      , NPC
                      , Object
+                     , Object.ActionTime
                      , Object.Computer
                      , Object.Copier
+                     , Object.Door
                      , Util
   default-extensions:  OverloadedStrings
                      , DeriveGeneric