Merge branch 'master' of http://git.xkjq.uk:30000/justin/dodge

.gitignore

@@ -1,3 +1,5 @@
 .stack-work/
 *~
 *.swp
+loop.cabal
+*.lock

src/Dodge/AIs.hs

@@ -1874,7 +1874,7 @@ yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,
 yourControl w (f,g) cr = ( (mouseActionsWorld (_mouseButtons w) . f, g)
                          , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
                          )
-    where strafeSpeed = 3 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
+    where strafeSpeed = 8 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
           speed = 3 * equipFactor
           equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0
 
@@ -1932,6 +1932,7 @@ wasdWithAiming w speed aimSpeed i cr
                                             *.* rotateV (_cameraRot w) (_mousePos w)
                 _                 -> normalizeAngle $ argV (_mousePos w) + _cameraRot w
 
+
 wasdM :: SDL.Keycode -> Point2
 wasdM SDL.KeycodeW = (0,1)
 wasdM SDL.KeycodeS = (0,-1)

src/Dodge/Data.hs

@@ -86,6 +86,7 @@ data World = World
                 , _lightSources :: !(IM.IntMap LightSource)
                 , _tempLightSources :: ![TempLightSource]
                 , _closeActiveObjects :: [Either FloorItem Button]
+                , _remap :: Keycode -> Keycode
                 } --deriving (Show)
 
 type Drawing = Picture

src/Dodge/KeyEvents.hs

@@ -39,12 +39,26 @@ handleKeyEvent w kev = case keyboardEventKeyMotion kev of
     Released -> Just $ over keys (S.delete $ getKeycode kev) w
     _  -> handlePressedKeyEvent (addKey (getKeycode kev) w) (keyboardEventRepeat kev) (getKeycode kev)
     where getKeycode :: KeyboardEventData -> Keycode
-          getKeycode = keysymKeycode . keyboardEventKeysym
+          getKeycode = _remap w . keysymKeycode . keyboardEventKeysym
 
 addKey :: Keycode -> World -> World
 addKey k = over keys $ S.insert k
 
-handlePressedKeyEvent :: World -> Bool -> Keycode -> Maybe World
+-- 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
+
 handlePressedKeyEvent w True _ = Just w
 handlePressedKeyEvent w _    keycode
     = case keycode of
@@ -58,6 +72,8 @@ handlePressedKeyEvent w _    keycode
         KeycodeSpace  -> Just $ spaceAction w
         KeycodeQ      -> Just $ w {_cameraRot = _cameraRot w + 0.01}
         KeycodeE      -> Just $ w {_cameraRot = _cameraRot w - 0.01}
+        KeycodeF1      -> Just $ w {_remap = keyremap}
+        KeycodeF2      -> Just $ w {_remap = keyremapDefault}
         _ -> Just w
 
 handleMouseMotionEvent :: World -> MouseMotionEventData -> Maybe World

src/Dodge/Prototypes.hs

@@ -19,6 +19,7 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Graph.Inductive.Graph hiding ((&))
 import Data.List
+import Dodge.KeyEvents (keyremapDefault)
 
 -- defalt datatypes / prototypes {{{
 basicWall = Wall { _wlLine = [(0,0),(50,0)]
@@ -175,6 +176,7 @@ basicPP = PressPlate
     , _ppText = "Pressure plate"
     }
 -- }}}
+
 basicWorld = World
     { _keys = S.empty
     , _mouseButtons = S.empty
@@ -223,6 +225,7 @@ basicWorld = World
     , _lightSources = IM.empty
     , _tempLightSources = [youLight]
     , _closeActiveObjects = []
+    , _remap = keyremapDefault
     }
 youLight = 
 --    LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) ) 

src/Shader.hs

@@ -215,6 +215,7 @@ compileAndCheckShader str (shaderType,sourceCode) = do
         putStrLn $ str ++ ": Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
     return theShader
 
+resetShaderUniforms :: [(Program, [UniformLocation])] -> IO ()
 resetShaderUniforms = setShaderUniforms 0 1 (0,0) (2,2)
 {-# INLINE resetShaderUniforms #-}