rebase keyconfig changes

.gitignore

@@ -3,3 +3,4 @@
 *.swp
 loop.cabal
 *.lock
+keys.json

app/Main.hs

@@ -36,17 +36,20 @@ import qualified SDL
 import qualified SDL.Mixer as Mix
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 
+import LoadConfig
+
 cursorVis :: Bool -> IO ()
 cursorVis b = SDL.cursorVisible $= b
 
 main :: IO ()
 main = do
     (sizex,sizey) <- loadConfig
+    keyConfig <- loadKeyConfig
     setupLoop 
         (sizex,sizey)
         (cursorVis False >> doPreload >>= resizeSpareFBO sizex sizey)
         (\x -> cursorVis True >> cleanUpPreload x)
-        (fmap (setWindowSize sizex sizey) firstWorld)
+        (fmap (setWindowSize sizex sizey keyConfig) firstWorld)
         ( \preData w -> do
                       startTicks <- SDL.ticks
                       clear [ColorBuffer,DepthBuffer]
@@ -82,6 +85,7 @@ checkForGlErrors = do
     errs <- errors
     when (length errs > 0) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
 
-setWindowSize :: Int -> Int -> World -> World
+setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
-setWindowSize x y w = w & windowX .~ fromIntegral x
+setWindowSize x y z w = w & windowX .~ fromIntegral x
                         & windowY .~ fromIntegral y
+                        & keyConfig .~ z

src/Dodge/AIs.hs

@@ -39,6 +39,8 @@ import qualified Data.Map as M
 
 import Foreign.ForeignPtr
 import Control.Concurrent
+
+import LoadConfig
 ---}
 
 factionIs :: Faction -> Creature -> Bool
@@ -225,9 +227,9 @@ spawnerAI spawn w (f,g) cr =
 
 placeCrFaction :: Creature -> Faction -> Point2 -> Point2 -> Float -> World -> World
 placeCrFaction cr fact p op rot w = over creatures addCr w
-    where addCr crs = IM.insert (newKey crs) 
+    where addCr crs = IM.insert (Dodge.Base.newKey crs) 
                                 ( set (crState . faction) fact  
-                                  $ cr {_crPos = p,_crOldPos = op,_crDir = rot,_crID = newKey crs}
+                                  $ cr {_crPos = p,_crOldPos = op,_crDir = rot,_crID = Dodge.Base.newKey crs}
                                 ) 
                                 crs
 
@@ -1923,7 +1925,7 @@ wasdWithAiming w speed aimSpeed i cr
         = -- stopSoundFrom (CrSound i) $ 
             over ( crDir) (flip fromMaybe dir) 
                         cr
-    where (mov',dir') = wasdComp $ view keys w
+    where (mov',dir') = wasdComp (view keys w) w
           (mov,dir)   = (rotateV (_cameraRot w) mov',fmap (_cameraRot w +) dir')
           isMoving    = mov' /= (0,0)
           isAiming    = (_posture $ _stance $ _crState cr) == Aiming
@@ -1935,15 +1937,21 @@ wasdWithAiming w speed aimSpeed i cr
                 _                 -> normalizeAngle $ argV (_mousePos w) + _cameraRot w
 
 
-wasdM :: SDL.Scancode -> Point2
+wasdM :: World -> SDL.Scancode -> Point2
-wasdM SDL.ScancodeW = (0,1)
+wasdM w scancode 
-wasdM SDL.ScancodeS = (0,-1)
+ | scancode == moveUpKey (_keyConfig w) = (0,1)
-wasdM SDL.ScancodeD = (1,0)
+ | scancode == moveDownKey (_keyConfig w) = (0,-1)
-wasdM SDL.ScancodeA = (-1,0)
+ | scancode == moveRightKey (_keyConfig w) = (1,0)
-wasdM _          = (0,0)
+ | scancode == moveLeftKey (_keyConfig w) = (-1,0)
+wasdM _ _          = (0,0)
+--wasdM SDL.ScancodeW = (0,1)
+--wasdM SDL.ScancodeS = (0,-1)
+--wasdM SDL.ScancodeD = (1,0)
+--wasdM SDL.ScancodeA = (-1,0)
+--wasdM _          = (0,0)
 
-wasdComp :: S.Set SDL.Scancode -> (Point2,Maybe Float)
+wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float)
-wasdComp ks = f $ foldr ( (+.+) . wasdM ) (0,0) ks
+wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks
     where f (0,0) = ((0,0), Nothing)
           f p     = (errorNormalizeV 46 p, Just $ argV p)
 

src/Dodge/Data.hs

@@ -33,6 +33,8 @@ import Codec.Picture (Image,PixelRGBA8)
 
 import qualified Data.DList as DL
 
+import LoadConfig
+
 --}}}
 -- datatypes {{{
 data World = World 
@@ -85,6 +87,7 @@ data World = World
     , _closeActiveObjects   :: [Either FloorItem Button]
     , _seenLocations        :: IM.IntMap (World -> Point2,String)
     , _selLocation          :: Int
+    , _keyConfig            :: KeyConfigSDL
     } 
 
 data Corpse = Corpse

src/Dodge/Default.hs

@@ -20,6 +20,8 @@ import qualified Data.Set as S
 import Data.Graph.Inductive.Graph hiding ((&))
 import Data.List
 
+import LoadConfig
+
 -- defalt datatypes / prototypes {{{
 defaultWall = Wall { _wlLine = [(0,0),(50,0)]
                    , _wlID = 0
@@ -229,6 +231,7 @@ defaultWorld = World
         ,(1, (const (0,0) , "START POSITION"))
         ]
     , _selLocation = 0
+    , _keyConfig = defaultKeyConfigSDL
     }
 youLight = 
 --    LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) 

src/Dodge/Event/Keyboard.hs

@@ -9,6 +9,7 @@ import SDL
 import Data.Maybe
 import qualified Data.Set as S
 import Control.Lens
+import LoadConfig
 
 handleKeyboardEvent :: KeyboardEventData -> World -> Maybe World
 handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of
@@ -22,18 +23,19 @@ handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of
 
 handlePressedKey :: Bool -> Scancode -> World -> Maybe World
 handlePressedKey True _       w = Just w
-handlePressedKey _    keycode w = case keycode of
+handlePressedKey _    scancode w 
-    ScancodeEscape  -> Nothing
+    |  scancode == escapeKey (_keyConfig w) = Nothing
-    ScancodeC       -> Just $ pauseGame $ escapeMap w
+    |  scancode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w
-    ScancodeF       -> Just $ dropItem w
+    |  scancode == dropItemKey (_keyConfig w) = Just $ dropItem w
-    ScancodeM       -> Just $ toggleMap w
+    |  scancode == toggleMapKey (_keyConfig w) = Just $ toggleMap w
-    ScancodeP       -> Just $ pauseGame $ escapeMap w
+    |  scancode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ reloadWeapon (_yourID w) w
-    ScancodeR       -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w
+    |  scancode == testEventKey (_keyConfig w) = Just $ testEvent w
-    ScancodeT       -> Just $ testEvent w
+    |  scancode == spaceActionKey (_keyConfig w) = Just $ spaceAction w
-    ScancodeSpace   -> Just $ spaceAction w
+    -- Rotation seems to be duplicated here and in Camera.hs ? why
-    ScancodeQ       -> Just $ w & cameraRot +~ 0.01
+    |  scancode == rotateCameraPlusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w + 0.01}
-    ScancodeE       -> Just $ w & cameraRot -~ 0.01
+    |  scancode == rotateCameraMinusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w - 0.01}
-    _               -> Just w
+handlePressedKey _ _ w = Just w
+
 
 spaceAction :: World -> World
 spaceAction w = case listToMaybe $ _closeActiveObjects w of
@@ -48,20 +50,4 @@ pauseGame :: World -> World
 pauseGame w = w {_menuState = PauseMenu}
 
 toggleMap w = w & carteDisplay %~ not
-escapeMap w = w & carteDisplay .~ False
+escapeMap w = w & carteDisplay .~ False
-
--- Basic key remapping for a dvorak key layout
-keyremap :: Keycode -> Keycode 
-keyremap KeycodeComma = KeycodeW
-keyremap KeycodeA = KeycodeA
-keyremap KeycodeE = KeycodeD
-keyremap KeycodeO = KeycodeS
-keyremap KeycodeSlash = KeycodeQ
-keyremap KeycodePeriod = KeycodeE
-keyremap KeycodeP = KeycodeR
-keyremap KeycodeU = KeycodeF
-keyremap k = k
-
-keyremapDefault :: Keycode -> Keycode 
-keyremapDefault k = k
-

src/Dodge/Menu.hs

@@ -22,28 +22,28 @@ import System.Random
 import SDL
 -- }}}
 
-keyPressedDown :: Event -> Maybe Keycode
+keyPressedDown :: Event -> Maybe Scancode
 keyPressedDown e = case eventPayload e of
-    KeyboardEvent (KeyboardEventData _ Pressed False keysym) -> Just $ keysymKeycode keysym
+    KeyboardEvent (KeyboardEventData _ Pressed False keysym) -> Just $ keysymScancode keysym
     _ -> Nothing
 
 menuEvents :: (Event -> World -> Maybe World) -> Event -> World -> Maybe World
 menuEvents f e w = case _menuState w of
     LevelMenu _ -> case keyPressedDown e of
-            Just KeycodeEscape -> Nothing
+            Just ScancodeEscape -> Nothing
             Just _             -> startLevel w >>= f e
             _                  -> Just w
     PauseMenu -> case keyPressedDown e of
-            Just KeycodeEscape -> Nothing
+            Just ScancodeEscape -> Nothing
-            Just KeycodeR      -> return $ fromMaybe w $ _storedLevel w
+            Just ScancodeR      -> return $ fromMaybe w $ _storedLevel w
-            Just KeycodeN      -> Just $ putSound $ generateLevel 1 
+            Just ScancodeN      -> Just $ putSound $ generateLevel 1 
                                            $ initialWorld {_randGen = _randGen w}
             Just _             -> unpause w >>= f e
             _                  -> Just w
     GameOverMenu -> case keyPressedDown e of
-            Just KeycodeEscape -> Nothing
+            Just ScancodeEscape -> Nothing
-            Just KeycodeR      -> Just $ fromMaybe w $ _storedLevel w
+            Just ScancodeR      -> Just $ fromMaybe w $ _storedLevel w
-            Just KeycodeN      -> Just $ putSound $ generateLevel 1 
+            Just ScancodeN      -> Just $ putSound $ generateLevel 1 
                                                             $ initialWorld
                                                                 {_randGen = _randGen w}
             _                              -> return w

src/Dodge/Update/Camera.hs

@@ -14,6 +14,8 @@ import qualified Data.IntMap.Strict as IM
 
 import qualified SDL as SDL
 
+import LoadConfig
+
 updateCamera :: World -> World
 updateCamera = rotCam . moveCamera . updateAimTime . updateScopeZoom
 
@@ -98,23 +100,23 @@ zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just .
 rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . autoZoomCam
 
 rotateCameraL :: World -> World
-rotateCameraL w | SDL.ScancodeQ `S.member` _keys w
+rotateCameraL w | rotateCameraPlusKey (_keyConfig w) `S.member` _keys w
                     = w & cameraRot +~ 0.015
                         & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
                                 . itAttachment . _Just . scopePos %~ rotateV 0.015
                 | otherwise = w
 rotateCameraR :: World -> World
-rotateCameraR w | SDL.ScancodeE `S.member` _keys w
+rotateCameraR w | rotateCameraMinusKey (_keyConfig w) `S.member` _keys w
                     = w & cameraRot -~ 0.015
                         & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
                                 . itAttachment . _Just . scopePos %~ rotateV (-0.015)
                 | otherwise = w
 zoomCamIn :: World -> World
-zoomCamIn w | SDL.ScancodeJ `S.member` _keys w
+zoomCamIn w | zoomInKey (_keyConfig w) `S.member` _keys w
                     = w {_cameraZoom = _cameraZoom w + 0.01}
             | otherwise = w
 zoomCamOut :: World -> World
-zoomCamOut w | SDL.ScancodeK `S.member` _keys w
+zoomCamOut w | zoomOutKey (_keyConfig w) `S.member` _keys w
                     = w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
              | otherwise = w
 

src/LoadConfig.hs

@@ -1,24 +1,165 @@
 {-# LANGUAGE DeriveGeneric #-}
-module LoadConfig
+{-# LANGUAGE OverloadedStrings #-}
-    where
+
+module LoadConfig where
+
 import Data.Aeson
-import GHC.Generics
 import Foreign.C.Types
+import GHC.Generics
+import qualified GHC.Int
+import qualified SDL
+import SDL.Internal.Numbered as SDL.Internal.Numbered
 
 data Configuration = Configuration
-    { windowxsize :: Int
+  { windowxsize :: Int,
-    , windowysize :: Int
+    windowysize :: Int
-    } deriving (Generic, Show)
+  }
+  deriving (Generic, Show)
 
 instance ToJSON Configuration where
-    toEncoding = genericToEncoding defaultOptions
+  toEncoding = genericToEncoding defaultOptions
+
 instance FromJSON Configuration
 
-loadConfig :: IO (Int,Int)
+loadConfig :: IO (Int, Int)
 loadConfig = do
-    mayConfig <- decodeFileStrict "config.json"
+  mayConfig <- decodeFileStrict "config.json"
-    case mayConfig of
+  case mayConfig of
-        Just config -> return (windowxsize config,windowysize config)
+    Just config -> return (windowxsize config, windowysize config)
-        Nothing     -> do
+    Nothing -> do
-                        putStrLn "invalid config.json, loading default config"
+      putStrLn "invalid config.json, loading default config"
-                        return (800,600)
+      return (800, 600)
+
+data KeyConfig = KeyConfig
+  { moveUpBinding :: Int,
+    moveDownBinding :: Int,
+    moveLeftBinding :: Int,
+    moveRightBinding :: Int,
+    pauseBinding :: Int,
+    escapeBinding :: Int,
+    dropItemBinding :: Int,
+    toggleMapBinding :: Int,
+    reloadBinding :: Int,
+    testEventBinding :: Int,
+    spaceActionBinding :: Int,
+    rotateCameraPlusBinding :: Int,
+    rotateCameraMinusBinding :: Int,
+    zoomInBinding :: Int,
+    zoomOutBinding :: Int,
+    newBinding :: Int
+  }
+  deriving (Generic, Show)
+
+data KeyConfigSDL = KeyConfigSDL
+  { moveUpKey :: SDL.Scancode,
+    moveDownKey :: SDL.Scancode,
+    moveLeftKey :: SDL.Scancode,
+    moveRightKey :: SDL.Scancode,
+    pauseKey :: SDL.Scancode,
+    escapeKey :: SDL.Scancode,
+    dropItemKey :: SDL.Scancode,
+    toggleMapKey :: SDL.Scancode,
+    reloadKey :: SDL.Scancode,
+    testEventKey :: SDL.Scancode,
+    spaceActionKey :: SDL.Scancode,
+    rotateCameraPlusKey :: SDL.Scancode,
+    rotateCameraMinusKey :: SDL.Scancode,
+    zoomInKey :: SDL.Scancode,
+    zoomOutKey :: SDL.Scancode,
+    newKey :: SDL.Scancode 
+  }
+  deriving (Generic, Show)
+
+defaultKeyConfigSDL =
+  KeyConfigSDL
+    { moveUpKey = SDL.ScancodeW,
+      moveDownKey = SDL.ScancodeS,
+      moveLeftKey = SDL.ScancodeA,
+      moveRightKey = SDL.ScancodeD,
+      pauseKey = SDL.ScancodeP,
+      escapeKey = SDL.ScancodeEscape,
+      dropItemKey = SDL.ScancodeF,
+      toggleMapKey = SDL.ScancodeM,
+      reloadKey = SDL.ScancodeR,
+      testEventKey = SDL.ScancodeT,
+      spaceActionKey = SDL.ScancodeSpace,
+      rotateCameraPlusKey = SDL.ScancodeQ,
+      rotateCameraMinusKey = SDL.ScancodeE,
+      zoomInKey = SDL.ScancodeJ,
+      zoomOutKey = SDL.ScancodeK,
+      newKey = SDL.ScancodeN
+    }
+
+instance ToJSON KeyConfig where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON KeyConfig where
+  parseJSON = withObject "KeyConfig" $ \o -> do
+    moveUpBinding <- o .:? "moveUp" .!= 119
+    moveDownBinding <- o .:? "moveDown" .!= 115
+    moveLeftBinding <- o .:? "moveLeft" .!= 97
+    moveRightBinding <- o .:? "moveRight" .!= 100
+    pauseBinding <- o .:? "pause" .!= 112
+    escapeBinding <- o .:? "escape" .!= 27
+    dropItemBinding <- o .:? "dropItem" .!= 102
+    toggleMapBinding <- o .:? "toggleMap" .!= 109
+    reloadBinding <- o .:? "reload" .!= 114
+    testEventBinding <- o .:? "testEvent" .!= 116
+    spaceActionBinding <- o .:? "spaceAction" .!= 32
+    rotateCameraPlusBinding <- o .:? "rotateCameraPlus" .!= 113
+    rotateCameraMinusBinding <- o .:? "rotateCameraMinus" .!= 101
+    zoomInBinding <- o .:? "zoomIn" .!= 106
+    zoomOutBinding <- o .:? "zoomOut" .!= 107
+    newBinding <- o .:? "new" .!= 110
+    return
+      KeyConfig
+        { moveUpBinding = moveUpBinding,
+          moveDownBinding = moveDownBinding,
+          moveLeftBinding = moveLeftBinding,
+          moveRightBinding = moveRightBinding,
+          pauseBinding = pauseBinding,
+          escapeBinding = escapeBinding,
+          dropItemBinding = dropItemBinding,
+          toggleMapBinding = toggleMapBinding,
+          reloadBinding = reloadBinding,
+          testEventBinding = testEventBinding,
+          spaceActionBinding = spaceActionBinding,
+          rotateCameraPlusBinding = rotateCameraPlusBinding,
+          rotateCameraMinusBinding = rotateCameraMinusBinding,
+          zoomInBinding = zoomInBinding,
+          zoomOutBinding = zoomOutBinding,
+          newBinding = newBinding
+        }
+
+loadKeyConfig :: IO KeyConfigSDL
+loadKeyConfig = do
+  mayConfig <- decodeFileStrict "keys.json"
+  print mayConfig
+  case mayConfig of
+    Just config ->
+      return
+        KeyConfigSDL
+          { moveUpKey = getSdlScancode $ moveUpBinding config,
+            moveDownKey = getSdlScancode $ moveDownBinding config,
+            moveLeftKey = getSdlScancode $ moveLeftBinding config,
+            moveRightKey = getSdlScancode $ moveRightBinding config,
+            pauseKey = getSdlScancode $ pauseBinding config,
+            escapeKey = getSdlScancode $ escapeBinding config,
+            dropItemKey = getSdlScancode $ dropItemBinding config,
+            toggleMapKey = getSdlScancode $ toggleMapBinding config,
+            reloadKey = getSdlScancode $ reloadBinding config,
+            testEventKey = getSdlScancode $ testEventBinding config,
+            spaceActionKey = getSdlScancode $ spaceActionBinding config,
+            rotateCameraPlusKey = getSdlScancode $ rotateCameraPlusBinding config,
+            rotateCameraMinusKey = getSdlScancode $ rotateCameraMinusBinding config,
+            zoomInKey = getSdlScancode $ zoomInBinding config,
+            zoomOutKey = getSdlScancode $ zoomOutBinding config,
+            newKey = getSdlScancode $ newBinding config
+          }
+    Nothing -> do
+      putStrLn "invalid keys.json, loading default config"
+      -- This is duplicated but not sure how to reduce
+      return defaultKeyConfigSDL
+
+getSdlScancode :: Int -> SDL.Scancode
+getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode