reworking interactions

shell.nix

@@ -134,7 +134,7 @@ let
 
   f = { mkDerivation, astar, base, containers, linear
       , matrix, OpenGL, random, stdenv, stm, text, unordered-containers
-      , vector, JuicyPixels, JuicyPixels-extra, bytestring
+      , vector, JuicyPixels, JuicyPixels-extra, bytestring, mtl
       }:
       mkDerivation {
         pname = "tracer-game";
@@ -146,7 +146,7 @@ let
         executableHaskellDepends = [
           affectionNeko astar base containers ecstasyNeko linear matrix nanovgNeko
           OpenGL random sdl2Nek0 stm text unordered-containers vector JuicyPixels
-          JuicyPixels-extra bytestring agNek0
+          JuicyPixels-extra bytestring agNek0 mtl
         ];
         license = stdenv.lib.licenses.gpl3;
       };

src/Init.hs

@@ -33,7 +33,7 @@ init = do
     <*> (Mouse <$> newTVarIO [])
     <*> (Keyboard <$> newTVarIO [])
   _ <- glewInit
-  (ws, _) <- yieldSystemT (0, defStorage) (return ())
+  -- (ws, _) <- yieldSystemT (0, defStorage) (return ())
   nvg <- createGL3 (S.fromList [NanoVG.Debug, Antialias, StencilStrokes])
   return UserData
     { state           = Load
@@ -43,7 +43,7 @@ init = do
     , assetFonts      = M.empty
     , nano            = nvg
     , uuid            = []
-    , worldState      = ws
+    -- , worldState      = ws
     , stateData       = None
     , threadContext   = Nothing
     }

src/Load.hs

@@ -51,11 +51,14 @@ loadLoad = do
     }
 
 loadFork
-  :: (SystemState Entity IO)
+  :: SystemState Entity (AffectionState (AffectionData UserData) IO)
   -> SDL.Window
   -> SDL.GLContext
   -> Context
-  -> MVar (SystemState Entity IO, StateData)
+  -> MVar
+    ( SystemState Entity (AffectionState (AffectionData UserData) IO)
+    , StateData
+    )
   -> MVar (Float, T.Text)
   -> IO ()
 loadFork ws win glc nvg future progress = do

src/Main.hs

@@ -3,6 +3,8 @@ module Main where
 
 import Affection as A
 
+import Data.Ecstasy
+
 import qualified SDL
 
 import NanoVG hiding (V2(..), V3(..))
@@ -55,9 +57,11 @@ pre = do
   let Subsystems w m k = subsystems ud
   _ <- partSubscribe w (fitViewport (1280/720))
   _ <- partSubscribe w exitOnWindowClose
+  (ws, _) <- yieldSystemT (0, defStorage) (return ())
   putAffection ud
     { threadContext = Just threadCtx
     , window     = Just (drawWindow ad)
+    , worldState = ws
     }
 
 update :: Double -> Affection UserData ()

src/MainGame/MindMap.hs

@@ -25,7 +25,7 @@ import Util (direction)
 updateMind :: Double -> Affection UserData ()
 updateMind dt = do
  ud <- getAffection
- (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
+ (nws, _) <- yieldSystemT (worldState ud) $ do
    emap allEnts $ do
      with anim
      with mmpos
@@ -149,7 +149,7 @@ drawMind = do
   ud <- getAffection
   let ctx = nano ud
   dt <- getDelta
-  (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
+  (_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do
     pc <- fmap head $ efor allEnts $ do
       with player
       with mmpos

src/MainGame/WorldMap.hs

@@ -12,6 +12,7 @@ import NanoVG hiding (V2(..))
 
 import Control.Monad (when, void)
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.State.Strict (evalStateT)
 import Control.Concurrent.MVar
 import Control.Concurrent (forkIO)
 
@@ -43,13 +44,14 @@ import Animation
 loadMap :: Affection UserData ()
 loadMap = do
   ud <- getAffection
+  ad <- get
   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
+  _ <- liftIO $ forkIO $ loadMapFork ud ad future progress
   putAffection ud
     { stateData = None
     , uuid = [uu1, uu2, uu3]
@@ -74,10 +76,11 @@ changeMaps _ = return ()
 
 loadMapFork
   :: UserData
-  -> MVar (SystemState Entity IO, StateData)
+  -> AffectionData UserData
+  -> MVar (SystemState Entity (AffectionState (AffectionData UserData) IO), StateData)
   -> MVar (Float, T.Text)
   -> IO ()
-loadMapFork ud future progress = do
+loadMapFork ud ad future progress = do
   let loadSteps = 20
       fc = FloorConfig
         (10, 10)
@@ -107,7 +110,7 @@ loadMapFork ud future progress = do
   _ <- liftIO $ swapMVar progress (15 / loadSteps, "Unfolding and Converting MindMap to images")
   let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
   _ <- liftIO $ swapMVar progress (16 / loadSteps, "Creating WorldState")
-  (nws, _) <- yieldSystemT (worldState ud) $ do
+  (nws, _) <- evalStateT (runState (yieldSystemT (worldState ud) $ do
     let pmmpos = (+ 0.5) . (fromIntegral :: Int -> Double) . floor <$> mmPos
           (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph))
         delta = (0, 0) :
@@ -139,6 +142,7 @@ loadMapFork ud future progress = do
         , anim      = Just $ AnimState (AnimId "copier" "open" N) 0 0
         , objAccess = Just $ (V2 1 0, NW)
         , objType   = Just ObjCopier
+        , objState  = Just "idle"
         }
       ) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers)
     void $ liftIO $ swapMVar progress (18 / loadSteps, "Registering computers into WorldState")
@@ -189,6 +193,7 @@ loadMapFork ud future progress = do
         }
       ) npcposs
     void $ liftIO $ swapMVar progress (20 / loadSteps, "Handing over")
+    )) ad
   putMVar future (nws, MainData
       { mapMat = mat
       , imgMat = M.fromList (nrows inter) (ncols inter) $
@@ -207,7 +212,7 @@ mouseToPlayer mv2 = do
   (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
   let dr = (ry / sin (atan (1/2)) / 2) + rx
       dc = rx - (ry / sin (atan (1/2)) / 2)
-  (nws, _) <- liftIO $ yieldSystemT (worldState ud) $
+  (nws, _) <- yieldSystemT (worldState ud) $
     emap allEnts $ do
       with player
       pure $ unchanged
@@ -223,7 +228,7 @@ movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
   mouseToPlayer m
 movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
   ud <- getAffection
-  (nws, _) <- liftIO $ yieldSystemT (worldState ud) $
+  (nws, _) <- yieldSystemT (worldState ud) $
     emap allEnts $ do
       with player
       pure $ unchanged
@@ -237,10 +242,11 @@ movePlayer _ = return ()
 playerInteract :: MouseMessage -> Affection UserData ()
 playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
   ud <- getAffection
+  ad <- get
   (V2 rx ry) <- liftIO $ (* V2 640 360) <$> relativizeMouseCoords m
   let dr = ((ry / 32) / sin (atan 0.5) / 2) + (rx / 64)
       dc = (rx / 64) - ((ry / 32) / sin (atan 0.5) / 2)
-  (nws, relEnts) <- liftIO $ yieldSystemT (worldState ud) $ do
+  (nws, relEnts) <- yieldSystemT (worldState ud) $ do
     emap allEnts $ do
       with player
       with rot
@@ -259,23 +265,28 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
     mrelEnts <- efor allEnts $ do
       with pos
       with objAccess
+      with objType
+      with objState
       (rel, dir) <- query objAccess
       pos' <- query pos
       otype <- query objType
+      ostate <- query objState
       ent <- queryEnt
       if (fmap floor ppos == fmap floor pos' ||
         fmap floor ppos == fmap floor pos' + rel) &&
         fmap floor (ppos + V2 dr dc) == fmap floor pos' &&
         pdir == dir
-      then return $ Just (otype, ent)
+      then return $ Just (otype, ostate, ent)
       else return Nothing
-    return (catMaybes mrelEnts)
+    let relEnts = catMaybes mrelEnts
     liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts)
     -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
+    mapM_ (\(t, s, e) ->
+      setEntity e =<< objectTransition t s e
+      ) relEnts
   putAffection ud
     { worldState = nws
     }
-  mapM_ (uncurry objectAction) relEnts
 playerInteract _ = return ()
 
 drawMap :: Affection UserData ()
@@ -288,7 +299,7 @@ drawMap = do
       drawLoadScreen ud progress
     _ -> do
       dt <- getDelta
-      (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
+      (_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do
         pc <- fmap head $ efor allEnts $ do
           with player
           with pos
@@ -454,7 +465,7 @@ updateMap dt = do
       , stateData = mendat
       }
   else do
-    (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
+    (nws, _) <- yieldSystemT (worldState ud) $ do
       emap allEnts $ do
         with anim
         stat <- query anim
@@ -641,6 +652,16 @@ updateMap dt = do
           (reachPoints $ stateData ud)
           )
         dt
+      tses <- efor allEnts $ do
+          with objType
+          with objState
+          t <- query objType
+          s <- query objState
+          e <- queryEnt
+          return (t, s, e)
+      mapM_ (\(t, s, e) ->
+        objectAction dt t s e
+        ) tses
     putAffection ud
       { worldState = nws
       }

src/Object.hs

@@ -1,28 +1,95 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Object where
 
 import Affection
 
+import Control.Monad (when)
+
 import Data.Ecstasy
 
 import Types
 
-instance ObjectAction UserData ObjType where
-  objectAction ObjCopier ent = do
-    ud <- getAffection
-    (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
+instance ObjectAction ObjType ObjState where
+  -- objectAction ObjCopier "idle" ent = do
+  --   ud <- getAffection
+  --   (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
+  --     emap (anEnt ent) $ do
+  --       with anim
+  --       mtime <- queryMaybe objStateTime
+  --       case mtime of
+  --         Nothing -> do
+  --           liftIO $ logIO Debug "copying!"
+  --           let nstat = AnimState
+  --                 (AnimId "copier" "copy" N)
+  --                 0
+  --                 0
+  --           return unchanged
+  --             { anim = Set nstat
+  --             , objStateTime = Set 5
+  --             , objState = "copying"
+  --             }
+  --         Just ttl -> do
+  --           dt <- getDelta
+  --           return unchanged
+  --             { objStateTime = Set (ttl - dt)
+  --             }
+  --   putAffection ud
+  --     { worldState = nws
+  --     }
+
+  objectAction dt t@ObjCopier s@"copying" ent = do
     emap (anEnt ent) $ do
-        with anim
-        liftIO $ logIO Debug "copying!"
+      mtime <- queryMaybe objStateTime
+      case mtime of
+        Nothing -> do
+          liftIO $ logIO Debug ("Copier " ++ show ent ++ ": copying!")
+          return unchanged
+            { objStateTime = Set (actionTime t s)
+            , objState = Set "copying"
+            }
+        Just ttl -> do
+          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 trans (setEntity ent =<< objectTransition t s ent)
+
+  objectAction _ _ _ _ = return ()
+
+  objectTransition ObjCopier "idle" ent = do
+    [e] <- efor (anEnt ent) $ do
         let nstat = AnimState
               (AnimId "copier" "copy" N)
               0
               0
         return unchanged
-          { anim = Set nstat
-          }
-    putAffection ud
-      { worldState = nws
+          { objState = Set "copying"
+          , anim     = Set nstat
           }
+    return e
 
-  objectAction _ _ = return ()
+  objectTransition ObjCopier "copying" ent = do
+    [e] <- efor (anEnt ent) $ do
+        let nstat = AnimState
+              (AnimId "copier" "open" N)
+              0
+              0
+        return unchanged
+          { anim         = Set nstat
+          , objState     = Set "idle"
+          , objStateTime = Unset
+          }
+    return e
+
+  objectTransition _ _ _ = return unchanged
+
+instance ActionTime ObjType ObjState where
+  actionTime ObjCopier "copying" = 5
+
+  actionTime o s = error (show o ++ ": " ++ s ++ ": has not time")

src/Types.hs

@@ -15,3 +15,6 @@ import Types.MindMap as T
 import Types.Drawable as T
 import Types.Collidible as T
 import Types.ObjType as T
+import Types.ObjClass as T
+import Types.Entity as T
+import Types.NPCState as T

src/Types/Entity.hs

@@ -0,0 +1,30 @@
+module Types.Entity where
+
+import Data.Ecstasy
+
+import Linear (V2)
+
+import Types.Direction
+import Types.Map
+import Types.NPCState
+import Types.Animation
+import Types.ObjType
+
+data Entity f = Entity
+  { pos           :: Component f 'Field (V2 Double)
+  , mmpos         :: Component f 'Field (V2 Double)
+  , gridPos       :: Component f 'Field (V2 Int)
+  , vel           :: Component f 'Field (V2 Double)
+  , mmvel         :: Component f 'Field (V2 Double)
+  , velFact       :: Component f 'Field Double
+  , rot           :: Component f 'Field Direction
+  , obstacle      :: Component f 'Field (Boundaries Double)
+  , player        :: Component f 'Unique ()
+  , npcMoveState  :: Component f 'Field NPCMoveState
+  , anim          :: Component f 'Field AnimState
+  , objAccess     :: Component f 'Field ((V2 Int), Direction)
+  , objType       :: Component f 'Field ObjType
+  , objState      :: Component f 'Field ObjState
+  , objStateTime  :: Component f 'Field Double
+  }
+  deriving (Generic)

src/Types/NPCState.hs

@@ -0,0 +1,13 @@
+module Types.NPCState where
+
+import Control.Concurrent.MVar (MVar)
+import Linear (V2)
+
+data NPCMoveState
+  = NPCWalking
+    { npcWalkPath :: [V2 Int]
+    }
+  | NPCStanding
+    { npcStandTime  :: Double
+    , npcFuturePath :: MVar [V2 Int]
+    }

src/Types/ObjClass.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Types.ObjClass where
+
+import Affection
+
+import Data.Ecstasy
+
+import Types.Entity
+import Types.UserData
+
+class ObjectAction otype ostate where
+  objectAction
+    :: Double
+    -> otype
+    -> ostate
+    -> Ent
+    -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
+
+  objectTransition
+    :: otype
+    -> ostate
+    -> Ent
+    -> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf)
+
+class ActionTime otype ostate where
+  actionTime :: otype -> ostate -> Double

src/Types/ObjType.hs

@@ -11,7 +11,12 @@ data ObjType
   | ObjToilet
   deriving (Show, Eq, Ord, Enum)
 
-class ObjectAction us t where
-  objectAction :: t -> Ent -> Affection us ()
+type ObjState = String
 
-  objectUpdate :: t -> Ent -> Affection us ()
+-- class ObjectAction us otype ostate where
+--   objectAction :: otype -> ostate -> Ent -> Affection us ()
+-- 
+--   objectTransition :: otype -> ostate -> Ent -> Affection us Entity
+-- 
+-- class ActionTime otype ostate where
+--   actionTime :: otype -> ostate -> Double

src/Types/UserData.hs

@@ -24,6 +24,8 @@ import Types.FontId
 import Types.Direction
 import Types.Animation
 import Types.ObjType
+import Types.Entity
+import Types.NPCState
 
 data UserData = UserData
   { state           :: State
@@ -33,9 +35,12 @@ data UserData = UserData
   , assetAnimations :: M.Map AnimId Animation
   , nano            :: Context
   , uuid            :: [UUID]
-  , worldState      :: SystemState Entity IO
+  , worldState      :: SystemState Entity (AffectionState (AffectionData UserData) IO)
   , stateData       :: StateData
-  , stateMVar       :: MVar (SystemState Entity IO, StateData)
+  , stateMVar       :: MVar
+    ( SystemState Entity (AffectionState (AffectionData UserData) IO)
+    , StateData
+    )
   , stateProgress   :: MVar (Float, T.Text)
   , threadContext   :: Maybe SDL.GLContext
   , window          :: Maybe SDL.Window
@@ -49,31 +54,33 @@ data SubMain
   = WorldMap
   | MindMap
 
-data Entity f = Entity
-  { pos           :: Component f 'Field (V2 Double)
-  , mmpos         :: Component f 'Field (V2 Double)
-  , gridPos       :: Component f 'Field (V2 Int)
-  , vel           :: Component f 'Field (V2 Double)
-  , mmvel         :: Component f 'Field (V2 Double)
-  , velFact       :: Component f 'Field Double
-  , rot           :: Component f 'Field Direction
-  , obstacle      :: Component f 'Field (Boundaries Double)
-  , player        :: Component f 'Unique ()
-  , npcMoveState  :: Component f 'Field NPCMoveState
-  , anim          :: Component f 'Field AnimState
-  , objAccess     :: Component f 'Field ((V2 Int), Direction)
-  , objType       :: Component f 'Field ObjType
-  }
-  deriving (Generic)
-
-data NPCMoveState
-  = NPCWalking
-    { npcWalkPath :: [V2 Int]
-    }
-  | NPCStanding
-    { npcStandTime  :: Double
-    , npcFuturePath :: MVar [V2 Int]
-    }
+-- data Entity f = Entity
+--   { pos           :: Component f 'Field (V2 Double)
+--   , mmpos         :: Component f 'Field (V2 Double)
+--   , gridPos       :: Component f 'Field (V2 Int)
+--   , vel           :: Component f 'Field (V2 Double)
+--   , mmvel         :: Component f 'Field (V2 Double)
+--   , velFact       :: Component f 'Field Double
+--   , rot           :: Component f 'Field Direction
+--   , obstacle      :: Component f 'Field (Boundaries Double)
+--   , player        :: Component f 'Unique ()
+--   , npcMoveState  :: Component f 'Field NPCMoveState
+--   , anim          :: Component f 'Field AnimState
+--   , objAccess     :: Component f 'Field ((V2 Int), Direction)
+--   , objType       :: Component f 'Field ObjType
+--   , objState      :: Component f 'Field ObjState
+--   , objStateTime  :: Component f 'Field Double
+--   }
+--   deriving (Generic)
+-- 
+-- data NPCMoveState
+--   = NPCWalking
+--     { npcWalkPath :: [V2 Int]
+--     }
+--   | NPCStanding
+--     { npcStandTime  :: Double
+--     , npcFuturePath :: MVar [V2 Int]
+--     }
 
 data Subsystems = Subsystems
   { subWindow   :: Window

tracer-game.cabal

@@ -31,6 +31,9 @@ executable tracer-game
                      , Types.Drawable
                      , Types.Collidible
                      , Types.ObjType
+                     , Types.ObjClass
+                     , Types.Entity
+                     , Types.NPCState
                      , Animation
                      , StateMachine
                      , Floorplan
@@ -67,6 +70,7 @@ executable tracer-game
                      , JuicyPixels-extra
                      , bytestring
                      , algebraic-graphs
+                     , mtl
   hs-source-dirs:      src
   ghc-options:         -Wall -threaded
   default-language:    Haskell2010