implemented controller input for game

src/MainGame/WorldMap.hs

@@ -45,18 +45,22 @@ loadMap :: Affection UserData ()
 loadMap = do
   ud <- getAffection
   ad <- get
-  let (Subsystems _ m k _ _) = subsystems ud
+  let (Subsystems _ m k j t) = subsystems ud
   uu1 <- partSubscribe m movePlayer
   uu2 <- partSubscribe k changeMaps
   uu3 <- partSubscribe m playerInteract
+  uu4 <- partSubscribe j emitActionMessage
+  uu5 <- partSubscribe t movePlayer2
+  uu6 <- partSubscribe t playerInteract2
   future <- liftIO newEmptyMVar
   progress <- liftIO $ newMVar (0, "Ohai!")
   _ <- liftIO $ forkIO $ loadMapFork ud ad future progress
   putAffection ud
     { stateData = None
-    , uuid = [uu1, uu2, uu3]
+    , uuid = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
     , stateMVar = future
     , stateProgress = progress
+    , state = Main WorldMap
     }
 
 changeMaps :: KeyboardMessage -> Affection UserData ()
@@ -190,6 +194,7 @@ loadMapFork ud ad future progress = do
       { pos           = Just (V2 10.5 10.5)
       , mmpos         = mmmpos
       , vel           = Just (V2 0 0)
+      , xyvel         = Just (V2 0 0)
       , mmvel         = Just (V2 0 0)
       , player        = Just ()
       , rot           = Just SE
@@ -266,7 +271,7 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
   (nws, _) <- yieldSystemT (worldState ud) $
     emap allEnts $ do
       with player
-      pure $ unchanged
+      return $ unchanged
         { vel = Set $ V2 0 0
         }
   putAffection ud
@@ -274,6 +279,35 @@ movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
     }
 movePlayer _ = return ()
 
+movePlayer2 :: ActionMessage -> Affection UserData ()
+movePlayer2 (ActionMessage (UpDown f) _) = do
+  ud <- getAffection
+  (nws, _) <- yieldSystemT (worldState ud) $
+    emap allEnts $ do
+      with player
+      V2 vx _ <- query xyvel
+      let ry = fromIntegral f / 32768 :: Double
+      return $ unchanged
+        { xyvel = Set $ V2 vx ry
+        }
+  putAffection ud
+    { worldState = nws
+    }
+movePlayer2 (ActionMessage (LeftRight f) _) = do
+  ud <- getAffection
+  (nws, _) <- yieldSystemT (worldState ud) $
+    emap allEnts $ do
+      with player
+      V2 _ vy <- query xyvel
+      let rx = fromIntegral f / 32768 :: Double
+      return $ unchanged
+        { xyvel = Set $ V2 rx vy
+        }
+  putAffection ud
+    { worldState = nws
+    }
+movePlayer2 _ = return ()
+
 playerInteract :: MouseMessage -> Affection UserData ()
 playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
   ud <- getAffection
@@ -324,6 +358,44 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
     }
 playerInteract _ = return ()
 
+playerInteract2 :: ActionMessage -> Affection UserData ()
+playerInteract2 (ActionMessage Activate _) = do
+  ud <- getAffection
+  (nws, _) <- yieldSystemT (worldState ud) $ do
+    [(ppos, pdir, pent)] <- efor allEnts $ do
+      with player
+      with pos
+      with rot
+      pos' <- query pos
+      rot' <- query rot
+      ent <- queryEnt
+      return (pos', rot', ent)
+    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 :: V2 Int) == (fmap floor pos' :: V2 Int) ||
+        (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
+        pdir == dir
+      then return $ Just (otype, ostate, ent)
+      else return Nothing
+    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 True e (Just pent)
+      ) relEnts
+  putAffection ud
+    { worldState = nws
+    }
+playerInteract2 _ = return ()
+
 drawMap :: Affection UserData ()
 drawMap = do
   ud <- getAffection
@@ -529,6 +601,7 @@ updateMap dt = do
         putAffection ud
           { worldState = nws
           , stateData = mendat
+          , state = Main WorldMap
           }
         updateMap 0.1
         updateMap 0.1
@@ -538,6 +611,16 @@ updateMap dt = do
       Nothing -> return ()
   else do
     (nws, _) <- yieldSystemT (worldState ud) $ do
+      emap allEnts $ do
+        with player
+        with xyvel
+        with vel
+        V2 rx ry <- query xyvel
+        let dr = (ry / sin (atan (1/2)) / 2) + rx
+            dc = rx - (ry / sin (atan (1/2)) / 2)
+        return $ unchanged
+          { vel = Set $ 2 * V2 dr dc
+          }
       emap allEnts $ do
         with anim
         stat <- query anim

src/Menu/Connect.hs

@@ -19,6 +19,7 @@ import Control.Monad
 import Types
 import Util
 import Menu.Adjust
+import MainGame.WorldMap
 
 loadMenu :: Affection UserData ()
 loadMenu = do
@@ -95,6 +96,7 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
   when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
   when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
   when (buttonActivate rels) (adjustActivate)
+  when (buttonPlay rels) (enterGame)
   where
     adjustUpDown rels = do
       if arrowUp rels
@@ -115,6 +117,9 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
     adjustActivate = do
       fullClean
       loadAdjust Activate loadMenu
+    enterGame = do
+      fullClean
+      loadMap
     arrowUp (V2 rx ry) =
       rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720
     arrowDown (V2 rx ry) =
@@ -125,21 +130,28 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
       rx > 430 / 1280 && rx < 530 / 1280 && ry > 310 / 720 && ry < 410 / 720
     buttonActivate (V2 rx ry) =
       rx > 650 / 1280 && rx < 800 / 1280 && ry > 160 / 720 && ry < 210 / 720
+    buttonPlay (V2 rx ry) =
+      rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
 handleClicks _ = return ()
 
 updateMenu :: Double -> Affection UserData ()
 updateMenu dt = do
   ud <- getAffection
+  case stateData ud of
+    MenuData _ _ _ ->
       putAffection ud
         { stateData = MenuData
           (velocity $ stateData ud)
           (rotation $ stateData ud)
           (max 0 ((activate $ stateData ud) - dt))
         }
+    _ -> return ()
 
 drawMenu :: Affection UserData ()
 drawMenu = do
   ud <- getAffection
+  case stateData ud of
+    MenuData _ _ _ ->
       liftIO $ do
         let ctx = nano ud
             controller = joystick ud
@@ -267,4 +279,13 @@ drawMenu = do
           fillColor ctx (rgba 255 255 255 255)
           textBox ctx 650 175 150 "Activate"
           closePath ctx
+          roundedRect ctx 650 560 150 50 10
+          strokeWidth ctx 5
+          stroke ctx
+          fontSize ctx 25
+          fontFace ctx "bedstead"
+          textAlign ctx (S.fromList [AlignCenter, AlignTop])
+          fillColor ctx (rgba 255 255 255 255)
+          textBox ctx 650 575 150 "Play"
         restore ctx
+    _ -> return ()

src/Types/Entity.hs

@@ -16,6 +16,7 @@ data Entity f = Entity
   , mmpos              :: Component f 'Field (V2 Double)
   , gridPos            :: Component f 'Field (V2 Int)
   , vel                :: Component f 'Field (V2 Double)
+  , xyvel              :: Component f 'Field (V2 Double)
   , mmvel              :: Component f 'Field (V2 Double)
   , velFact            :: Component f 'Field Double
   , rot                :: Component f 'Field Direction