justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Merge branch 'keyconfig2'

Browse Source
This commit is contained in:
jgk
2021-03-26 20:07:39 +01:00
parent 2f583d8a8a ca949a9d2b
commit fb1d7571e7
10 changed files with 227 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.gitignore
+1
View File
@@ -3,3 +3,4 @@
*.swp
loop.cabal
*.lock
keys.json
app/Main.hs
+7 -3
View File
@@ -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 x y w = w & windowX .~ fromIntegral x
setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
setWindowSize x y z w = w & windowX .~ fromIntegral x
& windowY .~ fromIntegral y
& keyConfig .~ z
package.yaml
+1
View File
@@ -45,6 +45,7 @@ dependencies:
- foldl
- linear
- aeson
- directory
library:
source-dirs: src
src/Dodge/AIs.hs
+19 -11
View File
@@ -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 SDL.ScancodeW = (0,1)
wasdM SDL.ScancodeS = (0,-1)
wasdM SDL.ScancodeD = (1,0)
wasdM SDL.ScancodeA = (-1,0)
wasdM _ = (0,0)
wasdM :: World -> SDL.Scancode -> Point2
wasdM w scancode
| scancode == moveUpKey (_keyConfig w) = (0,1)
| scancode == moveDownKey (_keyConfig w) = (0,-1)
| scancode == moveRightKey (_keyConfig w) = (1,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 ks = f $ foldr ( (+.+) . wasdM ) (0,0) ks
wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float)
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
+3
View File
@@ -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
+3
View File
@@ -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
+15 -29
View File
@@ -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
ScancodeEscape -> Nothing
ScancodeC -> Just $ pauseGame $ escapeMap w
ScancodeF -> Just $ dropItem w
ScancodeM -> Just $ toggleMap w
ScancodeP -> Just $ pauseGame $ escapeMap w
ScancodeR -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w
ScancodeT -> Just $ testEvent w
ScancodeSpace -> Just $ spaceAction w
ScancodeQ -> Just $ w & cameraRot +~ 0.01
ScancodeE -> Just $ w & cameraRot -~ 0.01
_ -> Just w
handlePressedKey _ scancode w
| scancode == escapeKey (_keyConfig w) = Nothing
| scancode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w
| scancode == dropItemKey (_keyConfig w) = Just $ dropItem w
| scancode == toggleMapKey (_keyConfig w) = Just $ toggleMap w
| scancode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ reloadWeapon (_yourID w) w
| scancode == testEventKey (_keyConfig w) = Just $ testEvent w
| scancode == spaceActionKey (_keyConfig w) = Just $ spaceAction w
-- Rotation seems to be duplicated here and in Camera.hs ? why
| scancode == rotateCameraPlusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w + 0.01}
| scancode == rotateCameraMinusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w - 0.01}
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
-- 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
escapeMap w = w & carteDisplay .~ False
src/Dodge/Menu.hs
+9 -9
View File
@@ -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 KeycodeR -> return $ fromMaybe w $ _storedLevel w
Just KeycodeN -> Just $ putSound $ generateLevel 1
Just ScancodeEscape -> Nothing
Just ScancodeR -> return $ fromMaybe w $ _storedLevel w
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 KeycodeR -> Just $ fromMaybe w $ _storedLevel w
Just KeycodeN -> Just $ putSound $ generateLevel 1
Just ScancodeEscape -> Nothing
Just ScancodeR -> Just $ fromMaybe w $ _storedLevel w
Just ScancodeN -> Just $ putSound $ generateLevel 1
$ initialWorld
{_randGen = _randGen w}
_ -> return w
src/Dodge/Update/Camera.hs
+6 -4
View File
@@ -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
+163 -14
View File
@@ -1,24 +1,173 @@
{-# LANGUAGE DeriveGeneric #-}
module LoadConfig
where
{-# LANGUAGE OverloadedStrings #-}
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
import System.Directory
data Configuration = Configuration
{ windowxsize :: Int
, windowysize :: Int
} deriving (Generic, Show)
{ windowxsize :: Int,
windowysize :: Int
}
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"
case mayConfig of
Just config -> return (windowxsize config,windowysize config)
Nothing -> do
putStrLn "invalid config.json, loading default config"
return (800,600)
mayConfig <- decodeFileStrict "config.json"
case mayConfig of
Just config -> return (windowxsize config, windowysize config)
Nothing -> do
putStrLn "invalid config.json, loading default config"
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
fExists <- doesFileExist "keys.json"
if fExists
then 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
else do
putStrLn "No keys.json found, loading default config"
return defaultKeyConfigSDL
getSdlScancode :: Int -> SDL.Scancode
getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode