keyboard controls finished

src/Init.hs

@@ -47,7 +47,7 @@ init = do
     , stateData       = None
     , threadContext   = Nothing
     , controls        = NoController
-    , translation     = defaultTranslation
+    , translation     = NoTranslation
     , joyCache        = []
     }
 

src/Load.hs

@@ -80,12 +80,12 @@ loadFork ws win glc nvg future progress = do
     ( p + increment
     , "Loading icon \"controller_green\""
     )))
-  mcontrblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
+  mkbdblue <- createImage nvg (FileName "assets/icons/keyboard_blue.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading icon \"keyboard_blue\""
     )))
-  mcontrgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
+  mkbdgreen <- createImage nvg (FileName "assets/icons/keyboard_green.png") 0
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Loading icon \"keyboard_green\""
@@ -267,7 +267,7 @@ loadFork ws win glc nvg future progress = do
     )))
   mcabinetCorner <- createImage nvg (FileName "assets/cabinet/cabinetCorner.png") 0
   let micons =
-        [ mcontrblue, mcontrgreen, marrow
+        [ mcontrblue, mcontrgreen, mkbdblue, mkbdgreen, marrow
         ]
   when (any isNothing micons) $ do
     liftIO $logIO Error "Failed to load icon assets"

src/MainGame/WorldMap.hs

@@ -46,19 +46,17 @@ loadMap = do
   ud <- getAffection
   ad <- get
   let (Subsystems _ m k j t) = subsystems ud
-  uu1 <- partSubscribe m movePlayer
+  uu0 <- partSubscribe k emitKbdActionMessage
-  uu2 <- partSubscribe k changeMaps
+  uu1 <- partSubscribe j emitJoyActionMessage
-  uu3 <- partSubscribe m playerInteract
+  uu2 <- partSubscribe t movePlayer2
-  uu4 <- partSubscribe j emitActionMessage
+  uu3 <- partSubscribe t playerInteract2
-  uu5 <- partSubscribe t movePlayer2
+  uu4 <- partSubscribe t changeMaps2
-  uu6 <- partSubscribe t playerInteract2
-  uu7 <- partSubscribe t changeMaps2
   future <- liftIO newEmptyMVar
   progress <- liftIO $ newMVar (0, "Ohai!")
   _ <- liftIO $ forkIO $ loadMapFork ud ad future progress
   putAffection ud
     { stateData = None
-    , uuid = [ uu1, uu2, uu3, uu4, uu5, uu6, uu7 ]
+    , uuid = [ uu0, uu1, uu2, uu3, uu4 ]
     , stateMVar = future
     , stateProgress = progress
     , state = Main WorldMap
@@ -67,20 +65,22 @@ loadMap = do
 changeMaps :: KeyboardMessage -> Affection UserData ()
 changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym)
   | SDL.keysymKeycode sym == SDL.KeycodeF1 = do
-    ud <- getAffection
+  ud <- getAffection
-    putAffection ud
+  case state ud of
-      { state = Main WorldMap
+    Main MindMap ->
-      }
+      putAffection ud
-  | SDL.keysymKeycode sym == SDL.KeycodeF2 = do
+        { state = Main WorldMap
-    ud <- getAffection
+        }
-    putAffection ud
+    Main WorldMap ->
-      { state = Main MindMap
+      putAffection ud
-      }
+        { state = Main MindMap
+        }
+    _ -> return ()
   | otherwise = return ()
 changeMaps _ = return ()
 
 changeMaps2 :: ActionMessage -> Affection UserData ()
-changeMaps2 (ActionMessage SwitchMap _) = do
+changeMaps2 (ActionMessage ActSwitchMap _) = do
   ud <- getAffection
   case state ud of
     Main MindMap ->
@@ -272,60 +272,116 @@ loadMapFork ud ad future progress = do
       , roomGraph = gr
       })
 
-mouseToPlayer :: V2 Int32 -> Affection UserData ()
+-- mouseToPlayer :: V2 Int32 -> Affection UserData ()
-mouseToPlayer mv2 = do
+-- mouseToPlayer mv2 = do
-  ud <- getAffection
+--   ud <- getAffection
-  (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
+--   (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
-  (nws, _) <- yieldSystemT (worldState ud) $
+--   (nws, _) <- yieldSystemT (worldState ud) $
-    emap allEnts $ do
+--     emap allEnts $ do
-      with player
+--       with player
-      return $ unchanged
+--       return $ unchanged
-        { xyvel = Set $ V2 rx ry
+--         { xyvel = Set $ V2 rx ry
-        }
+--         }
-  putAffection ud
+--   putAffection ud
-    { worldState = nws
+--     { worldState = nws
-    }
+--     }
+-- 
+-- movePlayer :: MouseMessage -> Affection UserData ()
+-- movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
+-- movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
+--   mouseToPlayer m
+-- movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
+--   ud <- getAffection
+--   (nws, _) <- yieldSystemT (worldState ud) $
+--     emap allEnts $ do
+--       with player
+--       return $ unchanged
+--         { xyvel = Set $ V2 0 0
+--         }
+--   putAffection ud
+--     { worldState = nws
+--     }
+-- movePlayer _ = return ()
 
-movePlayer :: MouseMessage -> Affection UserData ()
+movePlayerKbd :: KeyboardMessage -> Affection UserData ()
-movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m
+movePlayerKbd (MsgKeyboardEvent _ _ press False sym)
-movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
+  | SDL.keysymKeycode sym == SDL.KeycodeW = do
-  mouseToPlayer m
+    ud <- getAffection
-movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
+    (nws, _) <- yieldSystemT (worldState ud) $
-  ud <- getAffection
+      emap allEnts $ do
-  (nws, _) <- yieldSystemT (worldState ud) $
+        with player
-    emap allEnts $ do
+        (V2 vx _) <- query xyvel
-      with player
+        let ry = if (press == SDL.Pressed)
-      return $ unchanged
+              then 1
-        { xyvel = Set $ V2 0 0
+              else 0
-        }
+        return $ unchanged
-  putAffection ud
+          { xyvel = Set $ V2 vx ry
-    { worldState = nws
+          }
-    }
+    putAffection ud
-movePlayer _ = return ()
+      { worldState = nws
+      }
+  | SDL.keysymKeycode sym == SDL.KeycodeS = do
+    ud <- getAffection
+    (nws, _) <- yieldSystemT (worldState ud) $
+      emap allEnts $ do
+        with player
+        (V2 vx _) <- query xyvel
+        let ry = if (press == SDL.Pressed)
+              then -1
+              else 0
+        return $ unchanged
+          { xyvel = Set $ V2 vx ry
+          }
+    putAffection ud
+      { worldState = nws
+      }
+  | SDL.keysymKeycode sym == SDL.KeycodeA = do
+    ud <- getAffection
+    (nws, _) <- yieldSystemT (worldState ud) $
+      emap allEnts $ do
+        with player
+        (V2 _ vy) <- query xyvel
+        let rx = if (press == SDL.Pressed)
+              then -1
+              else 0
+        return $ unchanged
+          { xyvel = Set $ V2 rx vy
+          }
+    putAffection ud
+      { worldState = nws
+      }
+  | SDL.keysymKeycode sym == SDL.KeycodeD = do
+    ud <- getAffection
+    (nws, _) <- yieldSystemT (worldState ud) $
+      emap allEnts $ do
+        with player
+        (V2 _ vy) <- query xyvel
+        let rx = if (press == SDL.Pressed)
+              then 1
+              else 0
+        return $ unchanged
+          { xyvel = Set $ V2 rx vy
+          }
+    putAffection ud
+      { worldState = nws
+      }
+  | otherwise = return ()
+movePlayerKbd _ = return ()
 
 movePlayer2 :: ActionMessage -> Affection UserData ()
-movePlayer2 (ActionMessage (UpDown f) _) = do
+movePlayer2 (ActionMessage mov _) = do
   ud <- getAffection
   (nws, _) <- yieldSystemT (worldState ud) $
     emap allEnts $ do
       with player
-      V2 vx _ <- query xyvel
+      V2 vx vy <- query xyvel
-      let ry = fromIntegral f / if f < 0 then 32768 :: Double else 32767 :: Double
       return $ unchanged
-        { xyvel = Set $ V2 vx ry
+        { xyvel = Set $ case mov of
-        }
+          ActUp f -> V2 vx (-f)
-  putAffection ud
+          ActDown f -> V2 vx f
-    { worldState = nws
+          ActLeft f -> V2 (-f) vy
-    }
+          ActRight f -> V2 f vy
-movePlayer2 (ActionMessage (LeftRight f) _) = do
+          _          -> V2 vx vy
-  ud <- getAffection
-  (nws, _) <- yieldSystemT (worldState ud) $
-    emap allEnts $ do
-      with player
-      V2 _ vy <- query xyvel
-      let rx = fromIntegral f / if f < 0 then 32768 :: Double else 32767 :: Double
-      return $ unchanged
-        { xyvel = Set $ V2 rx vy
         }
   putAffection ud
     { worldState = nws
@@ -384,7 +440,7 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
 playerInteract _ = return ()
 
 playerInteract2 :: ActionMessage -> Affection UserData ()
-playerInteract2 (ActionMessage Activate _) = do
+playerInteract2 (ActionMessage ActActivate _) = do
   ud <- getAffection
   (nws, _) <- yieldSystemT (worldState ud) $ do
     pdata <- efor allEnts $ do

src/Menu/Adjust.hs

@@ -16,13 +16,13 @@ import Data.Maybe (fromJust, isJust)
 import Types
 import Util
 
-loadAdjust :: Action -> Affection UserData () -> Affection UserData ()
+loadAdjust :: Action -> Controller -> Affection UserData () -> Affection UserData ()
-loadAdjust sub switchBack = do
+loadAdjust sub contr switchBack = do
   ud <- getAffection
   let Subsystems w m k j t = subsystems ud
   uu1 <- partSubscribe j (joyListener switchBack)
   putAffection ud
-    { state = Menu (Adjust sub)
+    { state = Menu (Adjust sub contr)
     , uuid = [ uu1 ]
     }
 
@@ -30,38 +30,64 @@ joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
 joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
   ud <- getAffection
   liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis)
-  case state ud of
+  let trans = translation ud
-    Menu (Adjust (UpDown s)) -> do
+      align
-      let k = fst <$> find (\(_, v) -> v == UpDown 1 || v == UpDown (-1)) (M.assocs $ translation ud)
+        | val > 0 = AxisPositive
-      putAffection ud
+        | val < 0 = AxisNegative
-        { translation =
+        | otherwise = A.log A.Error "Can not assign neitral axis align" (error "*dies*")
-          M.insert (AxisAction $ fromIntegral axis) (UpDown (fromIntegral $ -signum val)) $
+  case trans of
-            if isJust k then M.delete (fromJust k) (translation ud) else translation ud
+    JoyTranslation tmap -> do
-        }
+      case state ud of
-    Menu (Adjust (LeftRight s)) -> do
+        Menu (Adjust (ActUp s) (Joystick _)) -> do
-      let k = fst <$> find (\(_, v) -> v == LeftRight 1 || v == LeftRight (-1)) (M.assocs $ translation ud)
+          let k = fst <$> find (\(_, v) -> v == ActUp 1) (M.assocs tmap)
-      putAffection ud
+          putAffection ud
-        { translation =
+            { translation = JoyTranslation $
-          M.insert (AxisAction $ fromIntegral axis) (LeftRight (fromIntegral $ signum val)) $
+              M.insert (AxisAction (fromIntegral axis) align) (ActUp 1) $
-            if isJust k then M.delete (fromJust k) (translation ud) else translation ud
+                if isJust k then M.delete (fromJust k) (tmap) else tmap
-        }
+            }
-  fullClean
+        Menu (Adjust (ActDown s) (Joystick _)) -> do
-  switchBack
+          let k = fst <$> find (\(_, v) -> v == ActDown 1) (M.assocs tmap)
+          putAffection ud
+            { translation = JoyTranslation $
+              M.insert (AxisAction (fromIntegral axis) align) (ActDown 1) $
+                if isJust k then M.delete (fromJust k) (tmap) else tmap
+            }
+        Menu (Adjust (ActLeft s) (Joystick _)) -> do
+          let k = fst <$> find (\(_, v) -> v == ActLeft 1) (M.assocs tmap)
+          putAffection ud
+            { translation = JoyTranslation $
+              M.insert (AxisAction (fromIntegral axis) align) (ActLeft 1) $
+                if isJust k then M.delete (fromJust k) (tmap) else tmap
+            }
+        Menu (Adjust (ActRight s) (Joystick _)) -> do
+          let k = fst <$> find (\(_, v) -> v == ActRight 1) (M.assocs tmap)
+          putAffection ud
+            { translation = JoyTranslation $
+              M.insert (AxisAction (fromIntegral axis) align) (ActRight 1) $
+                if isJust k then M.delete (fromJust k) (tmap) else tmap
+            }
+      fullClean
+      switchBack
+    _ -> return ()
 joyListener switchBack (MsgJoystickButton _ _ but SDL.JoyButtonPressed) = do
   ud <- getAffection
-  case state ud of
+  case translation ud of
-    Menu (Adjust (UpDown s)) -> return ()
+    JoyTranslation tmap -> do
-    Menu (Adjust (LeftRight s)) -> return ()
+      case state ud of
-    Menu (Adjust (act)) -> do
+        Menu (Adjust (ActUp _) (Joystick _)) -> return ()
-      let k = fst <$> find (\(_, v) -> v == act) (M.assocs $ translation ud)
+        Menu (Adjust (ActDown _) (Joystick _)) -> return ()
-      putAffection ud
+        Menu (Adjust (ActLeft _) (Joystick _)) -> return ()
-        { translation =
+        Menu (Adjust (ActRight _) (Joystick _)) -> return ()
-          M.insert (ButtonAction but SDL.JoyButtonPressed) act $
+        Menu (Adjust (act) (Joystick _)) -> do
-            if isJust k then M.delete (fromJust k) (translation ud) else translation ud
+          let k = fst <$> find (\(_, v) -> v == act) (M.assocs tmap)
-        }
+          putAffection ud
-    _ -> return ()
+            { translation = JoyTranslation $
-  fullClean
+              M.insert (ButtonAction but SDL.JoyButtonPressed) act $
-  switchBack
+                if isJust k then M.delete (fromJust k) tmap else tmap
+            }
+        _ -> return ()
+      fullClean
+      switchBack
 joyListener _ _ = return ()
 
 drawAdjust :: Affection UserData ()

src/Menu/Connect.hs

@@ -6,7 +6,7 @@ import qualified SDL hiding (V2)
 
 import NanoVG hiding (V2)
 
-import Linear hiding (rotate)
+import Linear hiding (rotate, translation)
 
 import qualified Data.Set as S
 import qualified Data.Map.Strict as M
@@ -29,12 +29,13 @@ loadMenu = do
   uu1 <- partSubscribe j joystickConnect
   uu2 <- partSubscribe j joystickDisconnect
   uu3 <- partSubscribe j emitJoyActionMessage
-  uu4 <- partSubscribe t handleActionMessages
+  uu4 <- partSubscribe k emitKbdActionMessage
-  uu5 <- partSubscribe m handleClicks
+  uu5 <- partSubscribe t handleActionMessages
+  uu6 <- partSubscribe m handleClicks
   -- uu6 <- partSubscribe k emitKbdActionMessage
   partUnSubscribe j (joyUUID ud)
   putAffection ud
-    { uuid      = [ uu1, uu2, uu3, uu4, uu5 ]
+    { uuid      = [ uu1, uu2, uu3, uu4, uu5, uu6 ]
     , state     = Menu Connect
     , stateData = MenuData (V2 0 0) S 0 0
     , joyCache  = []
@@ -51,6 +52,7 @@ joystickConnect msg = do
       liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident
       putAffection ud
         { controls = Joystick joy
+        , translation = JoyTranslation defaultJoyTranslation
         }
       ) mjoy
 
@@ -63,77 +65,104 @@ joystickDisconnect msg = do
       when (null njoys) $ do
         liftIO $ logIO A.Debug $ "Joystick disconnected"
         putAffection ud
-          { controls = None
+          { controls = NoController
+          , translation = NoTranslation
           }
     _ -> return ()
 
 handleActionMessages :: ActionMessage -> Affection UserData ()
-handleActionMessages (ActionMessage Activate _) = do
+handleActionMessages (ActionMessage ActActivate _) = do
   ud <- getAffection
   putAffection ud
     { stateData = (stateData ud)
       { activate = 0.5
       }
     }
-handleActionMessages (ActionMessage SwitchMap _) = do
+handleActionMessages (ActionMessage ActSwitchMap _) = do
   ud <- getAffection
   putAffection ud
     { stateData = (stateData ud)
       { switchMap = 0.5
       }
     }
-handleActionMessages (ActionMessage (UpDown f) _) = do
+handleActionMessages (ActionMessage (ActUp f) _) = do
   ud <- getAffection
   let V2 vx _ = velocity $ stateData ud
   putAffection ud
     { stateData = (stateData ud)
-      { velocity = (V2 vx (fromIntegral f / 32768))
+      { velocity = (V2 vx (-f))
       }
     }
-handleActionMessages (ActionMessage (LeftRight f) _) = do
+handleActionMessages (ActionMessage (ActDown f) _) = do
+  ud <- getAffection
+  let V2 vx _ = velocity $ stateData ud
+  putAffection ud
+    { stateData = (stateData ud)
+      { velocity = (V2 vx f)
+      }
+    }
+handleActionMessages (ActionMessage (ActLeft f) _) = do
   ud <- getAffection
   let V2 _ vy = velocity $ stateData ud
   putAffection ud
     { stateData = (stateData ud)
-      { velocity = (V2 (fromIntegral f / 32768) vy)
+      { velocity = (V2 (-f) vy)
+      }
+    }
+handleActionMessages (ActionMessage (ActRight f) _) = do
+  ud <- getAffection
+  let V2 _ vy = velocity $ stateData ud
+  putAffection ud
+    { stateData = (stateData ud)
+      { velocity = (V2 f vy)
       }
     }
 
 handleClicks :: MouseMessage -> Affection UserData ()
 handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do
   ud <- getAffection
+  rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
   case controls ud of
-    Joystick -> do
+    Joystick _ -> do
-      rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos)
+      when (arrowUp rels) adjustKbdUp
-      when (arrowUp rels || arrowDown rels) (adjustUpDown rels)
+      when (arrowDown rels) adjustKbdDown
-      when (arrowLeft rels || arrowRight rels) (adjustLeftRight rels)
+      when (arrowLeft rels) adjustKbdLeft
-      when (buttonActivate rels) (adjustActivate)
+      when (arrowRight rels) adjustKbdRight
-      when (buttonSwitchMap rels) (adjustSwitchMap)
+      when (buttonActivate rels) adjustKbdActivate
-      when (buttonPlay rels) (enterGame)
+      when (buttonSwitchMap rels) adjustKbdSwitchMap
-    _ -> return ()
+      when (buttonPlay rels) enterGame
+    NoController -> do
+      when (kbdIcon rels) $
+        putAffection ud
+          { controls = Keyboard
+          , translation = KbdTranslation defaultKbdTranslation
+          }
+    Keyboard -> do
+      when (kbdIcon rels) $
+        putAffection ud
+          { controls = NoController
+          , translation = NoTranslation
+          }
+      when (buttonPlay rels) enterGame
   where
-    adjustUpDown rels = do
+    adjustKbdUp = do
-      if arrowUp rels
-      then do
         fullClean
-        loadAdjust (UpDown 1) loadMenu
+        loadAdjust (ActUp 1) Keyboard loadMenu
-      else do
+    adjustKbdDown = do
         fullClean
-        loadAdjust (UpDown (-1)) loadMenu
+        loadAdjust (ActDown 1) Keyboard loadMenu
-    adjustLeftRight rels = do
+    adjustKbdLeft = do
-      if arrowLeft rels
-      then do
         fullClean
-        loadAdjust (LeftRight 1) loadMenu
+        loadAdjust (ActLeft 1) Keyboard loadMenu
-      else do
+    adjustKbdRight = do
         fullClean
-        loadAdjust (LeftRight (-1)) loadMenu
+        loadAdjust (ActRight 1) Keyboard loadMenu
-    adjustActivate = do
+    adjustKbdActivate = do
       fullClean
-      loadAdjust Activate loadMenu
+      loadAdjust ActActivate Keyboard loadMenu
-    adjustSwitchMap = do
+    adjustKbdSwitchMap = do
       fullClean
-      loadAdjust SwitchMap loadMenu
+      loadAdjust ActSwitchMap Keyboard loadMenu
     enterGame = do
       fullClean
       loadMap
@@ -151,6 +180,8 @@ handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py))
       rx > 650 / 1280 && rx < 800 / 1280 && ry > 220 / 720 && ry < 270 / 720
     buttonPlay (V2 rx ry) =
       rx > 650 / 1280 && rx < 800 / 1280 && ry > 560 / 720 && ry < 610 / 720
+    kbdIcon (V2 rx ry) =
+      rx > 650 / 1280 && rx < 730 / 1280 && ry > 620 / 720 && ry < 700 / 720
 handleClicks _ = return ()
 
 updateMenu :: Double -> Affection UserData ()
@@ -179,12 +210,12 @@ drawMenu = do
         beginPath ctx
         cpaint <- imagePattern ctx 550 620 80 80 0 (assetIcons ud M.!
           case controller of
-          Joystick -> IconContrGreen
+          Joystick _ -> IconContrGreen
-          _        -> IconContrBlue
+          _          -> IconContrBlue
           ) 1
-        rect ctx 600 620 80 80
+        rect ctx 550 620 80 80
         fillPaint ctx cpaint
-        endPath ctx
+        closePath ctx
         fill ctx
         beginPath ctx
         cpaint <- imagePattern ctx 650 620 80 80 0 (assetIcons ud M.!
@@ -192,9 +223,9 @@ drawMenu = do
           Keyboard -> IconKbdGreen
           _        -> IconKbdBlue
           ) 1
-        rect ctx 600 620 80 80
+        rect ctx 650 620 80 80
         fillPaint ctx cpaint
-        endPath ctx
+        closePath ctx
         fill ctx
         when (controller /= NoController) $ do
           let V2 vx vy = velocity $ stateData ud
@@ -223,7 +254,13 @@ drawMenu = do
                   closePath ctx
                   fill ctx
                 case state ud of
-                  Menu (Adjust (UpDown _)) -> do
+                  Menu (Adjust (ActUp _) _) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  Menu (Adjust (ActDown _) _) -> do
                     beginPath ctx
                     fillColor ctx (rgb 0 255 0)
                     roundedRect ctx 0 0 100 100 10
@@ -239,7 +276,13 @@ drawMenu = do
                   closePath ctx
                   fill ctx
                 case state ud of
-                  Menu (Adjust (LeftRight _)) -> do
+                  Menu (Adjust (ActLeft _) _) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  Menu (Adjust (ActRight _) _) -> do
                     beginPath ctx
                     fillColor ctx (rgb 0 255 0)
                     roundedRect ctx 0 0 100 100 10
@@ -255,7 +298,13 @@ drawMenu = do
                   closePath ctx
                   fill ctx
                 case state ud of
-                  Menu (Adjust (UpDown _)) -> do
+                  Menu (Adjust (ActUp _) _) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  Menu (Adjust (ActDown _) _) -> do
                     beginPath ctx
                     fillColor ctx (rgb 0 255 0)
                     roundedRect ctx 0 0 100 100 10
@@ -271,7 +320,13 @@ drawMenu = do
                   closePath ctx
                   fill ctx
                 case state ud of
-                  Menu (Adjust (LeftRight _)) -> do
+                  Menu (Adjust (ActLeft _) _) -> do
+                    beginPath ctx
+                    fillColor ctx (rgb 0 255 0)
+                    roundedRect ctx 0 0 100 100 10
+                    closePath ctx
+                    fill ctx
+                  Menu (Adjust (ActRight _) _) -> do
                     beginPath ctx
                     fillColor ctx (rgb 0 255 0)
                     roundedRect ctx 0 0 100 100 10
@@ -294,7 +349,7 @@ drawMenu = do
             fill ctx
             closePath ctx
           case state ud of
-            Menu (Adjust Activate) -> do
+            Menu (Adjust ActActivate _) -> do
               beginPath ctx
               fillColor ctx (rgb 0 255 0)
               roundedRect ctx 650 160 150 50 10
@@ -319,7 +374,7 @@ drawMenu = do
             fill ctx
             closePath ctx
           case state ud of
-            Menu (Adjust SwitchMap) -> do
+            Menu (Adjust ActSwitchMap _) -> do
               beginPath ctx
               fillColor ctx (rgb 0 255 0)
               roundedRect ctx 650 220 150 50 10

src/StateMachine.hs

@@ -21,13 +21,13 @@ instance StateMachine State UserData where
 
   smUpdate Load = updateLoad
   smUpdate (Menu Connect) = updateMenu
-  smUpdate (Menu (Adjust _)) = const (return ())
+  smUpdate (Menu (Adjust _ _)) = const (return ())
   smUpdate (Main WorldMap) = updateMap
   smUpdate (Main MindMap) = updateMind
 
   smDraw Load = drawLoad
   smDraw (Menu Connect) = drawMenu
-  smDraw (Menu (Adjust _)) = drawMenu >> drawAdjust
+  smDraw (Menu (Adjust _ _)) = drawMenu >> drawAdjust
   smDraw (Main WorldMap) = drawMap
   smDraw (Main MindMap) = drawMind
 

src/Types/UserData.hs

@@ -31,7 +31,7 @@ data UserData = UserData
   , assetFonts      :: M.Map FontId T.Text
   , assetAnimations :: M.Map AnimId Animation
   , controls        :: Controller -- Maybe SDL.Joystick
-  , translation     :: M.Map GamepadAction Action
+  , translation     :: Translation
   , nano            :: Context
   , uuid            :: [UUID]
   , worldState      :: SystemState Entity (AffectionState (AffectionData UserData) IO)
@@ -66,27 +66,47 @@ data SubMain
 
 data SubMenu
   = Connect
-  | Adjust Action
+  | Adjust Action Controller
   deriving (Eq, Show)
 
-defaultTranslation :: M.Map GamepadAction Action
+defaultJoyTranslation :: M.Map JoypadAction Action
-defaultTranslation = M.fromList
+defaultJoyTranslation = M.fromList
-  [ (ButtonAction 0 SDL.JoyButtonPressed, Activate)
+  [ (ButtonAction 0 SDL.JoyButtonPressed, ActActivate)
-  , (ButtonAction 7 SDL.JoyButtonPressed, SwitchMap)
+  , (ButtonAction 7 SDL.JoyButtonPressed, ActSwitchMap)
-  , (AxisAction 1, UpDown 1)
+  , (AxisAction 1 AxisNegative, ActUp 1)
-  , (AxisAction 0, LeftRight 1)
+  , (AxisAction 1 AxisPositive, ActDown 1)
+  , (AxisAction 0 AxisNegative, ActLeft 1)
+  , (AxisAction 0 AxisPositive, ActRight 1)
   ]
 
-data Action
+defaultKbdTranslation :: M.Map SDL.Keycode Action
-  = Activate
+defaultKbdTranslation = M.fromList
-  | SwitchMap
+  [ (SDL.KeycodeSpace, ActActivate)
-  | UpDown Int
+  , (SDL.KeycodeF1, ActSwitchMap)
-  | LeftRight Int
+  , (SDL.KeycodeW, ActUp 1)
+  , (SDL.KeycodeS, ActDown 1)
+  , (SDL.KeycodeA, ActLeft 1)
+  , (SDL.KeycodeD, ActRight 1)
+  ]
+
+data Translation
+  = JoyTranslation (M.Map JoypadAction Action)
+  | KbdTranslation (M.Map SDL.Keycode Action)
+  | NoTranslation
   deriving (Show, Eq)
 
-data GamepadAction
+data Action
+  = ActActivate
+  | ActSwitchMap
+  | ActUp Double
+  | ActDown Double
+  | ActLeft Double
+  | ActRight Double
+  deriving (Show, Eq)
+
+data JoypadAction
   = ButtonAction Word8 SDL.JoyButtonState
-  | AxisAction Word8
+  | AxisAction Word8 AxisAlign
   -- | HatAction Word SDL.JoyHatPosition
   deriving (Show, Eq, Ord)
 

src/Util.hs

@@ -11,7 +11,7 @@ import Data.Graph.AStar
 import Data.Maybe
 import qualified Data.Text as T
 
-import Control.Monad (join)
+import Control.Monad (join, when)
 
 import qualified SDL
 import qualified Graphics.Rendering.OpenGL as GL hiding (get)
@@ -307,18 +307,46 @@ cacheJoypad msg = do
 emitJoyActionMessage :: JoystickMessage -> Affection UserData ()
 emitJoyActionMessage (MsgJoystickAxis time _ axis val) = do
   ud <- getAffection
-  let Subsystems _ _ _ _ t = subsystems ud
+  case translation ud of
-  case (translation ud) Map.!? (AxisAction axis) of
+    JoyTranslation tmap -> do
-    Just (UpDown s)    -> partEmit t (ActionMessage (UpDown (s * fromIntegral val)) time)
+      let Subsystems _ _ _ _ t = subsystems ud
-    Just (LeftRight s) -> partEmit t (ActionMessage (LeftRight (s * fromIntegral val)) time)
+          vnormal = fromIntegral val / 32768
-    _                  -> return ()
+          sigvnormal = abs vnormal
-emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
+          align
+            | signum vnormal >= 0 = AxisPositive
+            | signum vnormal < 0 = AxisNegative
+      case tmap Map.!? (AxisAction axis align) of
+        Just (ActUp _)    -> partEmit t (ActionMessage (ActUp sigvnormal) time)
+        Just (ActDown _)  -> partEmit t (ActionMessage (ActDown sigvnormal) time)
+        Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft sigvnormal) time)
+        Just (ActRight _) -> partEmit t (ActionMessage (ActRight sigvnormal) time)
+        _              -> return ()
+    _ -> return ()
+emitJoyActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do
   ud <- getAffection
   let Subsystems _ _ _ _ t = subsystems ud
-  case (translation ud) Map.!? (ButtonAction but SDL.JoyButtonPressed) of
+  case (translation ud) of
-    Just act -> partEmit t (ActionMessage act time)
+    JoyTranslation tmap -> do
-    _        -> return ()
+      case tmap Map.!? (ButtonAction but SDL.JoyButtonPressed) of
-emitActionMessage _ = return ()
+        Just act -> partEmit t (ActionMessage act time)
+        _        -> return ()
+emitJoyActionMessage _ = return ()
+
+emitKbdActionMessage :: KeyboardMessage -> Affection UserData ()
+emitKbdActionMessage (MsgKeyboardEvent time _ press False sym) = do
+  ud <- getAffection
+  let Subsystems _ _ _ _ t = subsystems ud
+      val = if press == SDL.Pressed then 1 else 0
+  case (translation ud) of
+    KbdTranslation tmap -> do
+      case tmap Map.!? SDL.keysymKeycode sym of
+        Just (ActUp _)    -> partEmit t (ActionMessage (ActUp val) time)
+        Just (ActDown _)  -> partEmit t (ActionMessage (ActDown val) time)
+        Just (ActLeft _)  -> partEmit t (ActionMessage (ActLeft val) time)
+        Just (ActRight _) -> partEmit t (ActionMessage (ActRight val) time)
+        Just act -> when (press == SDL.Pressed) (partEmit t (ActionMessage act time))
+        _        -> return ()
+emitKbdActionMessage _ = return ()
 
 fullClean :: Affection UserData ()
 fullClean = do