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,146 +130,162 @@ 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
-  putAffection ud
+  case stateData ud of
-    { stateData = MenuData
+    MenuData _ _ _ ->
-      (velocity $ stateData ud)
+      putAffection ud
-      (rotation $ stateData ud)
+        { stateData = MenuData
-      (max 0 ((activate $ stateData ud) - dt))
+          (velocity $ stateData ud)
-    }
+          (rotation $ stateData ud)
+          (max 0 ((activate $ stateData ud) - dt))
+        }
+    _ -> return ()
 
 drawMenu :: Affection UserData ()
 drawMenu = do
   ud <- getAffection
-  liftIO $ do
+  case stateData ud of
-    let ctx = nano ud
+    MenuData _ _ _ ->
-        controller = joystick ud
+      liftIO $ do
-    save ctx
+        let ctx = nano ud
-    beginPath ctx
+            controller = joystick ud
-    paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
-      if isNothing controller
-      then IconContrBlue
-      else IconContrGreen
-      ) 1
-    rect ctx 600 620 80 80
-    fillPaint ctx paint
-    fill ctx
-    when (isJust controller) $ do
-      let V2 vx vy = velocity $ stateData ud
-      beginPath ctx
-      roundedRect ctx 140 110 1000 500 25
-      strokeWidth ctx 5
-      fillColor ctx (rgba 255 255 255 64)
-      strokeColor ctx (rgb 255 255 255)
-      stroke ctx
-      fill ctx
-      mapM_ (\deg -> do
-        let V2 px py = fmap realToFrac $
-              V2 360 360 - V2 50 50 + fmap realToFrac rot
-            rot@(V2 rx ry) = fmap (fromIntegral . floor) $
-              V2 0 120 `rotVec` deg :: V2 Int
         save ctx
-        translate ctx (px + 50) (py + 50)
-        rotate ctx (dtor deg)
-        translate ctx (-50) (-50)
-        case deg of
-          0 -> do
-            when (vy < 0) $ do
-              beginPath ctx
-              fillColor ctx (rgb 255 128 0)
-              roundedRect ctx 0 0 100 100 10
-              closePath ctx
-              fill ctx
-            case state ud of
-              Menu (Adjust (UpDown _)) -> do
-                beginPath ctx
-                fillColor ctx (rgb 0 255 0)
-                roundedRect ctx 0 0 100 100 10
-                closePath ctx
-                fill ctx
-              _ ->
-                return ()
-          90 -> do
-            when (vx > 0) $ do
-              beginPath ctx
-              fillColor ctx (rgb 255 128 0)
-              roundedRect ctx 0 0 100 100 10
-              closePath ctx
-              fill ctx
-            case state ud of
-              Menu (Adjust (LeftRight _)) -> do
-                beginPath ctx
-                fillColor ctx (rgb 0 255 0)
-                roundedRect ctx 0 0 100 100 10
-                closePath ctx
-                fill ctx
-              _ ->
-                return ()
-          180 -> do
-            when (vy > 0) $ do
-              beginPath ctx
-              fillColor ctx (rgb 255 128 0)
-              roundedRect ctx 0 0 100 100 10
-              closePath ctx
-              fill ctx
-            case state ud of
-              Menu (Adjust (UpDown _)) -> do
-                beginPath ctx
-                fillColor ctx (rgb 0 255 0)
-                roundedRect ctx 0 0 100 100 10
-                closePath ctx
-                fill ctx
-              _ ->
-                return ()
-          270 -> do
-            when (vx < 0) $ do
-              beginPath ctx
-              fillColor ctx (rgb 255 128 0)
-              roundedRect ctx 0 0 100 100 10
-              closePath ctx
-              fill ctx
-            case state ud of
-              Menu (Adjust (LeftRight _)) -> do
-                beginPath ctx
-                fillColor ctx (rgb 0 255 0)
-                roundedRect ctx 0 0 100 100 10
-                closePath ctx
-                fill ctx
-              _ ->
-                return ()
         beginPath ctx
-        paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
+        paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.!
-        rect ctx 0 0 100 100
+          if isNothing controller
+          then IconContrBlue
+          else IconContrGreen
+          ) 1
+        rect ctx 600 620 80 80
         fillPaint ctx paint
-        closePath ctx
         fill ctx
-        restore ctx
+        when (isJust controller) $ do
-        ) [0, 90, 180, 270]
+          let V2 vx vy = velocity $ stateData ud
-      beginPath ctx
-      when (activate (stateData ud) > 0) $ do
-        fillColor ctx (rgb 255 128 0)
-        roundedRect ctx 650 160 150 50 10
-        fill ctx
-      case state ud of
-        Menu (Adjust Activate) -> do
           beginPath ctx
-          fillColor ctx (rgb 0 255 0)
+          roundedRect ctx 140 110 1000 500 25
-          roundedRect ctx 650 160 150 50 10
+          strokeWidth ctx 5
-          closePath ctx
+          fillColor ctx (rgba 255 255 255 64)
+          strokeColor ctx (rgb 255 255 255)
+          stroke ctx
           fill ctx
-        _ ->
+          mapM_ (\deg -> do
-          return ()
+            let V2 px py = fmap realToFrac $
-      roundedRect ctx 650 160 150 50 10
+                  V2 360 360 - V2 50 50 + fmap realToFrac rot
-      strokeWidth ctx 2
+                rot@(V2 rx ry) = fmap (fromIntegral . floor) $
-      stroke ctx
+                  V2 0 120 `rotVec` deg :: V2 Int
-      fontSize ctx 25
+            save ctx
-      fontFace ctx "bedstead"
+            translate ctx (px + 50) (py + 50)
-      textAlign ctx (S.fromList [AlignCenter, AlignTop])
+            rotate ctx (dtor deg)
-      fillColor ctx (rgba 255 255 255 255)
+            translate ctx (-50) (-50)
-      textBox ctx 650 175 150 "Activate"
+            case deg of
-      closePath ctx
+              0 -> do
-    restore ctx
+                when (vy < 0) $ do
+                  beginPath ctx
+                  fillColor ctx (rgb 255 128 0)
+                  roundedRect ctx 0 0 100 100 10
+                  closePath ctx
+                  fill ctx
+                case state ud of
+                  Menu (Adjust (UpDown _)) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  _ ->
+                    return ()
+              90 -> do
+                when (vx > 0) $ do
+                  beginPath ctx
+                  fillColor ctx (rgb 255 128 0)
+                  roundedRect ctx 0 0 100 100 10
+                  closePath ctx
+                  fill ctx
+                case state ud of
+                  Menu (Adjust (LeftRight _)) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  _ ->
+                    return ()
+              180 -> do
+                when (vy > 0) $ do
+                  beginPath ctx
+                  fillColor ctx (rgb 255 128 0)
+                  roundedRect ctx 0 0 100 100 10
+                  closePath ctx
+                  fill ctx
+                case state ud of
+                  Menu (Adjust (UpDown _)) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  _ ->
+                    return ()
+              270 -> do
+                when (vx < 0) $ do
+                  beginPath ctx
+                  fillColor ctx (rgb 255 128 0)
+                  roundedRect ctx 0 0 100 100 10
+                  closePath ctx
+                  fill ctx
+                case state ud of
+                  Menu (Adjust (LeftRight _)) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  _ ->
+                    return ()
+            beginPath ctx
+            paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1
+            rect ctx 0 0 100 100
+            fillPaint ctx paint
+            closePath ctx
+            fill ctx
+            restore ctx
+            ) [0, 90, 180, 270]
+          beginPath ctx
+          when (activate (stateData ud) > 0) $ do
+            fillColor ctx (rgb 255 128 0)
+            roundedRect ctx 650 160 150 50 10
+            fill ctx
+          case state ud of
+            Menu (Adjust Activate) -> do
+              beginPath ctx
+              fillColor ctx (rgb 0 255 0)
+              roundedRect ctx 650 160 150 50 10
+              closePath ctx
+              fill ctx
+            _ ->
+              return ()
+          roundedRect ctx 650 160 150 50 10
+          strokeWidth ctx 2
+          stroke ctx
+          fontSize ctx 25
+          fontFace ctx "bedstead"
+          textAlign ctx (S.fromList [AlignCenter, AlignTop])
+          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