Refactor event handling. Allow mouse movement in menus
This commit is contained in:
+1
-5
@@ -5,13 +5,9 @@ import LoadConfig
|
||||
import Dodge.Default
|
||||
import Dodge.Data
|
||||
import Dodge.Initialisation
|
||||
import Dodge.Rooms
|
||||
import Dodge.Layout
|
||||
import Dodge.Update
|
||||
import Dodge.Event
|
||||
import Dodge.Render
|
||||
import Dodge.Menu
|
||||
import Dodge.Floor
|
||||
import Dodge.LoadConfig
|
||||
import Dodge.LoadSound
|
||||
import Picture
|
||||
@@ -76,7 +72,7 @@ main = do
|
||||
return $ preData & soundData . playingSounds .~ newPlayingSounds
|
||||
& frameTimer .~ endTicks
|
||||
)
|
||||
(flip $ menuEvents handleEvent)
|
||||
handleEvent
|
||||
(Just . update)
|
||||
Mix.closeAudio
|
||||
|
||||
|
||||
@@ -1,11 +1,9 @@
|
||||
module Dodge.AIs where
|
||||
-- imports {{{
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Path
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.CreatureAction
|
||||
import Dodge.Event
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.WorldEvent
|
||||
|
||||
|
||||
@@ -5,7 +5,6 @@ import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.CreatureAction
|
||||
import Dodge.Update.UsingInput
|
||||
import Dodge.Event
|
||||
import Dodge.CreatureState
|
||||
import Dodge.LoadConfig
|
||||
|
||||
@@ -90,3 +89,12 @@ 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)
|
||||
|
||||
mouseActionsCr :: S.Set SDL.MouseButton -> Creature -> Creature
|
||||
mouseActionsCr keys cr
|
||||
| rbPressed
|
||||
= set ( crState . stance . posture) Aiming cr
|
||||
| otherwise
|
||||
= set ( crState . stance . posture) AtEase cr
|
||||
where lbPressed = SDL.ButtonLeft `S.member` keys
|
||||
rbPressed = SDL.ButtonRight `S.member` keys
|
||||
|
||||
|
||||
@@ -237,7 +237,6 @@ defaultWorld = World
|
||||
, _debugMode = True
|
||||
}
|
||||
youLight =
|
||||
-- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) )
|
||||
TLS { _tlsPos = (0,0)
|
||||
,_tlsRad = 300
|
||||
,_tlsIntensity = 0.1
|
||||
|
||||
+27
-25
@@ -1,6 +1,20 @@
|
||||
module Dodge.Event where
|
||||
import Dodge.Event.Keyboard
|
||||
module Dodge.Event
|
||||
{- |
|
||||
Module : Dodge.Event
|
||||
Description : Direct event handling
|
||||
|
||||
Deals with direct events.
|
||||
This includes individual key/mouse presses, but /not/ continuous held down input.
|
||||
We cannot handle multiple keys held down at once here,
|
||||
(eg left mouse button + right mouse button)
|
||||
because these are separate events.
|
||||
Instead we store the events in a set, and deal with the combinations in
|
||||
"Dodge.Update".
|
||||
-}
|
||||
( handleEvent
|
||||
) where
|
||||
import Dodge.Event.Keyboard
|
||||
import Dodge.Event.Menu
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.CreatureAction
|
||||
@@ -15,16 +29,12 @@ import Data.Function (on)
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import SDL
|
||||
-- Deals with direct events
|
||||
-- This includes individual key/mouse presses, but /not/ continuous held down input
|
||||
-- We cannot handle multiple keys held down at once here,
|
||||
-- (eg left mouse button + right mouse button)
|
||||
-- because these are separate events
|
||||
-- Instead we store the events in a set, and deal with the combinations in
|
||||
-- Update
|
||||
|
||||
handleEvent :: Event -> World -> Maybe World
|
||||
handleEvent e = case eventPayload e of
|
||||
handleEvent :: World -> Event -> Maybe World
|
||||
handleEvent = flip handleEvent'
|
||||
|
||||
handleEvent' :: Event -> World -> Maybe World
|
||||
handleEvent' e = case eventPayload e of
|
||||
KeyboardEvent kev -> handleKeyboardEvent kev
|
||||
MouseMotionEvent mmev -> handleMouseMotionEvent mmev
|
||||
MouseButtonEvent mbev -> handleMouseButtonEvent mbev
|
||||
@@ -47,11 +57,12 @@ handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of
|
||||
where but = mouseButtonEventButton mbev
|
||||
|
||||
handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World
|
||||
handleMouseWheelEvent mwev =
|
||||
case mouseWheelEventPos mwev of
|
||||
V2 x y | y > 0 -> Just . wheelUpEvent
|
||||
| y < 0 -> Just . wheelDownEvent
|
||||
| otherwise -> Just
|
||||
handleMouseWheelEvent mwev w = case _menuState w of
|
||||
InGame -> case mouseWheelEventPos mwev of
|
||||
V2 x y | y > 0 -> Just (wheelUpEvent w)
|
||||
| y < 0 -> Just (wheelDownEvent w)
|
||||
| otherwise -> Just w
|
||||
_ -> Just w
|
||||
|
||||
handleResizeEvent :: WindowSizeChangedEventData -> World -> Maybe World
|
||||
handleResizeEvent sev = Just . set windowX (fromIntegral x)
|
||||
@@ -113,12 +124,3 @@ before y (x:z:ys) | y == z = x
|
||||
after y (x:z:ys) | y == x = z
|
||||
| otherwise = after y (z:ys)
|
||||
|
||||
mouseActionsCr :: S.Set MouseButton -> Creature -> Creature
|
||||
mouseActionsCr keys cr
|
||||
| rbPressed
|
||||
= set ( crState . stance . posture) Aiming cr
|
||||
| otherwise
|
||||
= set ( crState . stance . posture) AtEase cr
|
||||
where lbPressed = ButtonLeft `S.member` keys
|
||||
rbPressed = ButtonRight `S.member` keys
|
||||
|
||||
|
||||
+23
-18
@@ -12,6 +12,7 @@ import Dodge.LevelGen
|
||||
import Dodge.Creature.Inanimate
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Dodge.Event.Test
|
||||
import Dodge.Event.Menu
|
||||
|
||||
import SDL
|
||||
import Data.Maybe
|
||||
@@ -30,25 +31,28 @@ handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of
|
||||
where
|
||||
kcode = (keysymScancode . keyboardEventKeysym) kev
|
||||
|
||||
handlePressedKeyInGame :: Scancode -> World -> Maybe World
|
||||
handlePressedKeyInGame scode w
|
||||
| scode == escapeKey (_keyConfig w) = Nothing
|
||||
| scode == pauseKey (_keyConfig w) = Just $ pauseGame $ escapeMap w
|
||||
| scode == dropItemKey (_keyConfig w) = Just $ dropItem w
|
||||
| scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w
|
||||
| scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ reloadWeapon (_yourID w) w
|
||||
| scode == testEventKey (_keyConfig w) = Just $ testEvent w
|
||||
| scode == spaceActionKey (_keyConfig w) = Just $ spaceAction w
|
||||
-- Rotation seems to be duplicated here and in Camera.hs ? why
|
||||
| scode == rotateCameraPlusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w + 0.01}
|
||||
| scode == rotateCameraMinusKey (_keyConfig w) = Just $ w {_cameraRot = _cameraRot w - 0.01}
|
||||
| scode == ScancodeF11 = Just $ w {_debugMode = not $ _debugMode w}
|
||||
| _debugMode w = debugKey scode w
|
||||
handlePressedKeyInGame _ w = Just w
|
||||
|
||||
handlePressedKey :: Bool -> Scancode -> World -> Maybe World
|
||||
handlePressedKey True _ w = 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}
|
||||
| scancode == ScancodeF11 = Just $ w {_debugMode = not $ _debugMode w}
|
||||
| _debugMode w = debugKey scancode w
|
||||
-- | _debugMode w && scancode == ScancodeF7 = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w - 1}
|
||||
-- | _debugMode w && scancode == ScancodeF8 = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w + 1}
|
||||
-- | _debugMode w && scancode == ScancodeF5 = Just $ dropLight w
|
||||
-- | _debugMode w && scancode == ScancodeF6 = Just $ dropLight' w
|
||||
handlePressedKey _ scode w
|
||||
| _menuState w == InGame
|
||||
= handlePressedKeyInGame scode w
|
||||
| otherwise = handlePressedKeyInMenu (_menuState w) scode w
|
||||
handlePressedKey _ _ w = Just w
|
||||
|
||||
debugKey :: Scancode -> World -> Maybe World
|
||||
@@ -59,6 +63,7 @@ debugKey scancode w
|
||||
| scancode == ScancodeF6 = Just $ dropLight' w
|
||||
debugKey _ w = Just w
|
||||
|
||||
|
||||
spaceAction :: World -> World
|
||||
spaceAction w = case listToMaybe $ _closeActiveObjects w of
|
||||
Just (Left flit) -> pickUpItem' flit w
|
||||
@@ -90,4 +95,4 @@ dropLight w = placeLS ls dec pos 0
|
||||
dropLight' :: World -> World
|
||||
dropLight' w = placeCr lamp pos 0 w
|
||||
where
|
||||
pos = _crPos(you w)
|
||||
pos = _crPos(you w)
|
||||
|
||||
@@ -0,0 +1,45 @@
|
||||
module Dodge.Event.Menu
|
||||
( handlePressedKeyInMenu
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Rooms
|
||||
import Dodge.Floor
|
||||
import Dodge.Initialisation
|
||||
import Dodge.SoundLogic
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import SDL
|
||||
|
||||
handlePressedKeyInMenu :: MenuState -> Scancode -> World -> Maybe World
|
||||
handlePressedKeyInMenu mState scode w = case mState of
|
||||
LevelMenu _ -> case scode of
|
||||
ScancodeEscape -> Nothing
|
||||
_ -> startLevel w
|
||||
PauseMenu -> case scode of
|
||||
ScancodeEscape -> Nothing
|
||||
ScancodeR -> return $ fromMaybe w $ _storedLevel w
|
||||
ScancodeN -> Just $ putSound $ generateLevel 1
|
||||
$ initialWorld {_randGen = _randGen w}
|
||||
_ -> unpause w
|
||||
GameOverMenu -> case scode of
|
||||
ScancodeEscape -> Nothing
|
||||
ScancodeR -> Just $ fromMaybe w $ _storedLevel w
|
||||
ScancodeN -> Just $ putSound $ generateLevel 1
|
||||
$ initialWorld
|
||||
{_randGen = _randGen w}
|
||||
_ -> Just w
|
||||
where
|
||||
unpause w' = Just . resumeSound $
|
||||
w' {_menuState = InGame}
|
||||
startLevel = unpause . storeLevel
|
||||
putSound = id -- set loadedSounds (_loadedSounds w)
|
||||
|
||||
storeLevel :: World -> World
|
||||
storeLevel w = case _storedLevel w of
|
||||
Nothing -> w & storedLevel ?~ w
|
||||
_ -> w
|
||||
+24
-135
@@ -1,152 +1,41 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Dodge.LoadConfig
|
||||
where
|
||||
( module Dodge.LoadConfig.KeyConfig
|
||||
) where
|
||||
import Dodge.LoadConfig.KeyConfig
|
||||
|
||||
import Data.Aeson
|
||||
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 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
|
||||
data Configuration = Configuration
|
||||
{ volume_master :: Int
|
||||
, volume_sound :: Int
|
||||
, volume_music :: 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
|
||||
instance ToJSON Configuration 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
|
||||
}
|
||||
instance FromJSON Configuration
|
||||
|
||||
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
|
||||
loadConfig :: IO Configuration
|
||||
loadConfig = do
|
||||
mayConfig <- decodeFileStrict "data/dodge.config.json"
|
||||
case mayConfig of
|
||||
Just config -> return config
|
||||
Nothing -> do
|
||||
putStrLn "invalid data/dodge.config.json, loading default config"
|
||||
return defaultConfiguration
|
||||
|
||||
getSdlScancode :: Int -> SDL.Scancode
|
||||
getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode
|
||||
defaultConfiguration = Configuration
|
||||
{ volume_master = 128
|
||||
, volume_sound = 128
|
||||
, volume_music = 128
|
||||
}
|
||||
|
||||
|
||||
@@ -0,0 +1,152 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Dodge.LoadConfig.KeyConfig
|
||||
where
|
||||
import Data.Aeson
|
||||
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 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
|
||||
@@ -1,104 +0,0 @@
|
||||
module Dodge.Menu where
|
||||
-- imports {{{
|
||||
import Dodge.Data
|
||||
import Dodge.Rooms
|
||||
import Dodge.Floor
|
||||
import Dodge.Initialisation
|
||||
import Dodge.SoundLogic
|
||||
|
||||
import Data.Tree
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
|
||||
|
||||
import System.Exit
|
||||
import System.Random
|
||||
|
||||
--import Graphics.Gloss.Interface.IO.Game
|
||||
import SDL
|
||||
-- }}}
|
||||
|
||||
keyPressedDown :: Event -> Maybe Scancode
|
||||
keyPressedDown e = case eventPayload e of
|
||||
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 ScancodeEscape -> Nothing
|
||||
Just _ -> startLevel w >>= f e
|
||||
_ -> Just w
|
||||
PauseMenu -> case keyPressedDown e of
|
||||
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 ScancodeEscape -> Nothing
|
||||
Just ScancodeR -> Just $ fromMaybe w $ _storedLevel w
|
||||
Just ScancodeN -> Just $ putSound $ generateLevel 1
|
||||
$ initialWorld
|
||||
{_randGen = _randGen w}
|
||||
_ -> return w
|
||||
_ -> f e w
|
||||
where unpause w' = Just $ resumeSound $
|
||||
w' {_menuState = InGame,_keys = S.empty}
|
||||
startLevel = unpause . storeLevel
|
||||
putSound = id -- set loadedSounds (_loadedSounds w)
|
||||
|
||||
|
||||
--- menuCheckKeyEvents :: (Event -> World -> IO World) -> Event -> World -> IO World
|
||||
--- menuCheckKeyEvents f e w = case _menuState w of
|
||||
--- LevelMenu _ -> case e of
|
||||
--- (EventKey (SpecialKey KeyEsc) Down _ _)
|
||||
--- -> exitSuccess
|
||||
--- (EventKey _ Down _ _) -> startLevel w >>= f e
|
||||
--- _ -> return w
|
||||
--- PauseMenu -> case e of
|
||||
--- (EventKey (SpecialKey KeyEsc) Down _ _)
|
||||
--- -> exitSuccess
|
||||
--- (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
|
||||
--- (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1
|
||||
--- $ initialWorld
|
||||
--- {_randGen = _randGen w}
|
||||
--- -- (EventKey (Char 'c') Down _ _) -> unpaused
|
||||
--- -- (EventKey (Char 'p') Down _ _) -> unpaused
|
||||
--- -- (EventKey (SpecialKey KeySpace) Down _ _) -> unpaused
|
||||
--- (EventKey _ Down _ _) -> unpause w >>= f e
|
||||
--- _ -> return w
|
||||
--- GameOverMenu -> case e of
|
||||
--- (EventKey (SpecialKey KeyEsc) Down _ _)
|
||||
--- -> exitSuccess
|
||||
--- (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
|
||||
--- (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1
|
||||
--- $ initialWorld
|
||||
--- {_randGen = _randGen w}
|
||||
--- -- (EventKey (Char 'c') Down _ _) -> unpaused
|
||||
--- _ -> return w
|
||||
--- _ -> f e w
|
||||
--- where unpause w' = do Mix.resume (-1)
|
||||
--- return w' {_menuState = InGame,_keys = S.empty}
|
||||
--- startLevel = unpause . storeLevel
|
||||
--- putSound = set loadedSounds (_loadedSounds w)
|
||||
--- -- there might be a better way to pass the loaded sounds around
|
||||
|
||||
updateRandGen :: World -> World
|
||||
updateRandGen = over randGen (fst . split)
|
||||
|
||||
menuCheckUpdate :: (Float -> World -> IO World) -> Float -> World -> IO World
|
||||
menuCheckUpdate f t w = case _menuState w of
|
||||
InGame -> f t w
|
||||
_ -> return w
|
||||
|
||||
storeLevel :: World -> World
|
||||
storeLevel w = case _storedLevel w of
|
||||
Nothing -> set storedLevel (Just w) w
|
||||
_ -> w
|
||||
|
||||
+20
-26
@@ -1,5 +1,10 @@
|
||||
module Dodge.Update where
|
||||
-- imports {{{
|
||||
{- |
|
||||
Module : Dodge.Update
|
||||
Description : Simulation update
|
||||
-}
|
||||
module Dodge.Update
|
||||
( update
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.WallCreatureCollisions
|
||||
@@ -8,7 +13,6 @@ import Dodge.Update.Camera
|
||||
import Dodge.Update.UsingInput
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.Inventory
|
||||
|
||||
import Geometry
|
||||
|
||||
import Data.List
|
||||
@@ -17,12 +21,11 @@ import Data.Function
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Control.Lens
|
||||
|
||||
|
||||
-- }}}
|
||||
|
||||
{- | The update step.
|
||||
If the '_menuState' is not 'InGame', this is the identity.
|
||||
This means that the only way to change the world is using event handling.
|
||||
-}
|
||||
update :: World -> World
|
||||
update w
|
||||
| _menuState w /= InGame = w
|
||||
@@ -35,7 +38,6 @@ update w
|
||||
. updateBlocks -- . zoning
|
||||
. updateSeenWalls
|
||||
. updateSoundQueue
|
||||
-- . updateUsingInput
|
||||
$ updateCloseObjects w
|
||||
in checkEndGame . ppEvents
|
||||
. updateCamera
|
||||
@@ -45,22 +47,15 @@ update w
|
||||
. wallEvents
|
||||
. set worldEvents id
|
||||
$ _worldEvents w1 w1
|
||||
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
|
||||
-- w
|
||||
-- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
|
||||
-- = insertIMInZone x y wlid wl
|
||||
-- | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
|
||||
-- where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
|
||||
-- wlid = _wlID wl
|
||||
-- ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
|
||||
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
|
||||
creatureInZone cr = insertIMInZone x y cid cr
|
||||
where (x,y) = zoneOfPoint $ _crPos cr
|
||||
cid = _crID cr
|
||||
zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
|
||||
cloudInZone cr = insertIMInZone x y cid cr
|
||||
where (x,y) = zoneOfPoint $ _clPos cr
|
||||
cid = _clID cr
|
||||
where
|
||||
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
|
||||
creatureInZone cr = insertIMInZone x y cid cr
|
||||
where (x,y) = zoneOfPoint $ _crPos cr
|
||||
cid = _crID cr
|
||||
zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
|
||||
cloudInZone cr = insertIMInZone x y cid cr
|
||||
where (x,y) = zoneOfPoint $ _clPos cr
|
||||
cid = _clID cr
|
||||
|
||||
updateSoundQueue = set soundQueue []
|
||||
. set sounds M.empty
|
||||
@@ -72,7 +67,6 @@ updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
|
||||
|
||||
updateParticles' :: World -> World
|
||||
updateParticles' w =
|
||||
--set particles' [] w
|
||||
set particles' (catMaybes ps) w'
|
||||
where
|
||||
(w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
|
||||
|
||||
@@ -14,6 +14,9 @@ module Sound (
|
||||
, playPositionalSoundQueue
|
||||
-- * Complex Playback
|
||||
, playAndUpdate
|
||||
-- * Volume Control
|
||||
, setSoundVolume
|
||||
, setMusicVolume
|
||||
) where
|
||||
import Sound.Data
|
||||
|
||||
@@ -149,3 +152,18 @@ setChannelPos :: Int16 -> Mix.Channel -> MaybeT IO Mix.Channel
|
||||
setChannelPos a i = do
|
||||
liftIO $ Mix.effectPosition i a 0
|
||||
return i
|
||||
|
||||
|
||||
-----------------------------------------------------------------
|
||||
{- | Set the volume for all sound channels.
|
||||
Behind the scenes, scales a float [0,1] to an Int [0..128].
|
||||
-}
|
||||
setSoundVolume :: Float -> IO ()
|
||||
setSoundVolume x = Mix.setVolume (round (x * 128)) Mix.AllChannels
|
||||
|
||||
{- | Set the music volume.
|
||||
Behind the scenes, scales a float [0,1] to an Int [0..128].
|
||||
-}
|
||||
setMusicVolume :: Float -> IO ()
|
||||
setMusicVolume x = Mix.setMusicVolume (round (x * 128))
|
||||
|
||||
|
||||
Reference in New Issue
Block a user