first interactable object ever: a copier

src/Load.hs

@@ -227,7 +227,7 @@ loadFork ws win glc nvg future progress = do
     )))
   copierCopy <- loadAnimationSprites "assets/misc/copier.png" nvg $
     [ ( AnimId "copier" "copy" N
-      , AnimationConfig (64, 0) (64, 74) (64, 0) 4 0.5 APOnce
+      , AnimationConfig (64, 0) (64, 74) (64, 0) 4 1 APLoop
       )
     ]
   modifyMVar_ progress (return . (\(p, _) ->

src/MainGame/WorldMap.hs

@@ -37,6 +37,7 @@ import Types
 import Floorplan
 import MindMap
 import NPC
+import Object
 
 loadMap :: Affection UserData ()
 loadMap = do
@@ -44,12 +45,13 @@ loadMap = do
   let (Subsystems _ m k) = subsystems ud
   uu1 <- partSubscribe m movePlayer
   uu2 <- partSubscribe k changeMaps
+  uu3 <- partSubscribe m playerInteract
   future <- liftIO newEmptyMVar
   progress <- liftIO $ newMVar (0, "Ohai!")
   _ <- liftIO $ forkIO $ loadMapFork ud future progress
   putAffection ud
     { stateData = None
-    , uuid = [uu1, uu2]
+    , uuid = [uu1, uu2, uu3]
     , stateMVar = future
     , stateProgress = progress
     }
@@ -133,8 +135,9 @@ loadMapFork ud future progress = do
       void $ createEntity $ newEntity
         { pos       = Just $ reachCoord - V2 1 0
         , obstacle  = Just $ Boundaries (10/36, 8/36) (28/36, 30/36)
-        , anim      = Just $ AnimState (AnimId "copier" "closed" N) 0 0
-        , objAccess = Just $ V2 1 0
+        , anim      = Just $ AnimState (AnimId "copier" "open" N) 0 0
+        , objAccess = Just $ (V2 1 0, NW)
+        , objType   = Just ObjCopier
         }
       ) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers)
     void $ liftIO $ swapMVar progress (18 / loadSteps, "Registering NPCs into WorldState")
@@ -204,6 +207,48 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
     }
 movePlayer _ = return ()
 
+playerInteract :: MouseMessage -> Affection UserData ()
+playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
+  ud <- getAffection
+  (nws, relEnts) <- liftIO $ yieldSystemT (worldState ud) $ do
+    emap allEnts $ do
+      with player
+      with rot
+      rot' <- query rot
+      (V2 rx ry) <- liftIO $ relativizeMouseCoords m
+      let dr = (ry / sin (atan 0.5) / 2) + rx
+          dc = rx - (ry / sin (atan 0.5) / 2)
+          ndir = direction (V2 dr dc)
+      return $ unchanged
+        { rot = Set $ fromMaybe rot' ndir
+        }
+    [(ppos, pdir)] <- efor allEnts $ do
+      with player
+      with pos
+      with rot
+      pos' <- query pos
+      rot' <- query rot
+      return (pos', rot')
+    mrelEnts <- efor allEnts $ do
+      with pos
+      with objAccess
+      (rel, dir) <- query objAccess
+      pos' <- query pos
+      otype <- query objType
+      ent <- queryEnt
+      if (fmap floor ppos == fmap floor pos' ||
+        fmap floor ppos == fmap floor pos' + rel) &&
+        pdir == dir
+      then return $ Just (otype, ent)
+      else return Nothing
+    return (catMaybes mrelEnts)
+  liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
+  putAffection ud
+    { worldState = nws
+    }
+  mapM_ (uncurry objectAction) relEnts
+playerInteract _ = return ()
+
 drawMap :: Affection UserData ()
 drawMap = do
   ud <- getAffection
@@ -337,9 +382,9 @@ drawTile ud ctx posanims pr pc row col img =
     tileWidth = 64 :: Double
     tileHeight = 32 :: Double
     sorted = sortOn (\(V2 sr sc, _, mbnds) -> case mbnds of
-      Just (Boundaries (minr, minc) (maxr, maxc)) -> maxr * 10 + (1 - minc)
-      _ -> (sr - (fromIntegral ((floor sr) :: Int))) * 10 +
-        (1 - (sc - (fromIntegral ((floor sc) :: Int))))
+      Just (Boundaries (minr, minc) (maxr, maxc)) -> maxr + (1 - maxc) * 10
+      _ -> (sr - (fromIntegral ((floor sr) :: Int))) +
+        (1 - (sc - (fromIntegral ((floor sc) :: Int)))) * 10
       ) posanims
     -- sorted = posanims
     minrs = Prelude.map (fst . matmin) mb
@@ -380,7 +425,6 @@ updateMap dt = do
     (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
       emap allEnts $ do
         with anim
-        with pos
         stat <- query anim
         let an = assetAnimations ud Map.! asId stat
             ntime = asElapsedTime stat + dt

src/Object.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Object where
+
+import Affection
+
+import Data.Ecstasy
+
+import Types
+
+instance ObjectAction UserData ObjType where
+  objectAction ObjCopier ent = do
+    ud <- getAffection
+    (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
+      emap (anEnt ent) $ do
+        with anim
+        liftIO $ logIO Debug "copying!"
+        let nstat = AnimState
+              (AnimId "copier" "copy" N)
+              0
+              0
+        return unchanged
+          { anim = Set nstat
+          }
+    putAffection ud
+      { worldState = nws
+      }

src/Types.hs

@@ -14,3 +14,4 @@ import Types.Animation as T
 import Types.MindMap as T
 import Types.Drawable as T
 import Types.Collidible as T
+import Types.ObjType as T

src/Types/ObjType.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Types.ObjType where
+
+import Affection
+
+import Data.Ecstasy (Ent)
+
+data ObjType
+  = ObjCopier
+  deriving (Show, Eq, Ord, Enum)
+
+class ObjectAction us t where
+  objectAction :: t -> Ent -> Affection us ()

src/Types/UserData.hs

@@ -23,6 +23,7 @@ import Types.ImgId
 import Types.FontId
 import Types.Direction
 import Types.Animation
+import Types.ObjType
 
 data UserData = UserData
   { state           :: State
@@ -60,7 +61,8 @@ data Entity f = Entity
   , player        :: Component f 'Unique ()
   , npcMoveState  :: Component f 'Field NPCMoveState
   , anim          :: Component f 'Field AnimState
-  , objAccess     :: Component f 'Field (V2 Int)
+  , objAccess     :: Component f 'Field ((V2 Int), Direction)
+  , objType       :: Component f 'Field ObjType
   }
   deriving (Generic)
 

src/Util.hs

@@ -174,12 +174,19 @@ naviGraph imgmat animBounds (V2 r c) =
       list2 =
         foldl
           (\acc (rr, cc) ->
-            if null (maybe [] collisionObstacle
-              (fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat))
+            if null
+              ((maybe [] collisionObstacle
+                (fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat)) ++
+                (map snd $ filter
+                  (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
+                  animBounds))
               && all null
               (map
-              (\(oor, ooc) -> maybe [] collisionObstacle
-                (fromMaybe Nothing $ M.safeGet (r + oor) (c + ooc) imgmat))
+              (\(oor, ooc) -> (maybe [] collisionObstacle
+                (fromMaybe Nothing $ M.safeGet (r + oor) (c + ooc) imgmat)) ++
+                (map snd $ filter
+                  (\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc)
+                  animBounds))
               [(0, cc), (rr, 0)])
             then V2 (r + rr) (c + cc): acc
             else acc