Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/loop
This commit is contained in:
Ross
+43
-47
@@ -5,14 +5,11 @@ 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.Config.Update
|
||||
import Dodge.LoadSound
|
||||
import Picture
|
||||
import Picture.Render
|
||||
@@ -22,27 +19,58 @@ import Preload
|
||||
import Sound.Data
|
||||
import Music
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Lens
|
||||
import Foreign (Word32)
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Lens
|
||||
import Foreign (Word32)
|
||||
import Control.Monad (when,void)
|
||||
|
||||
import System.Random
|
||||
import qualified Data.Map as M
|
||||
import Graphics.Rendering.OpenGL hiding (color, rotate, scale,
|
||||
translate)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.IntMap as IM
|
||||
import qualified Data.IntMap as IM
|
||||
import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate)
|
||||
import qualified SDL
|
||||
import qualified SDL.Mixer as Mix
|
||||
|
||||
doPreload' :: IO (PreloadData a)
|
||||
doPreload' = do
|
||||
main :: IO ()
|
||||
main = do
|
||||
(sizex,sizey) <- loadConfig
|
||||
keyConfig <- loadKeyConfig
|
||||
dodgeConfig <- loadDodgeConfig
|
||||
setupLoop
|
||||
(sizex,sizey)
|
||||
(SDL.cursorVisible $= False >> doPreload' dodgeConfig >>= resizeSpareFBO sizex sizey)
|
||||
(\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
|
||||
(fmap (setWindowSize sizex sizey keyConfig . (config .~ dodgeConfig)) firstWorld)
|
||||
doSideEffects
|
||||
handleEvent
|
||||
(Just . update)
|
||||
|
||||
doSideEffects :: PreloadData SoundOrigin -> World -> IO (PreloadData SoundOrigin)
|
||||
doSideEffects preData w = do
|
||||
startTicks <- SDL.ticks
|
||||
updateDodgeConfig w
|
||||
void $ doDrawing (_renderData preData) w
|
||||
playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
|
||||
newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
|
||||
|
||||
endTicks <- SDL.ticks
|
||||
let lastFrameTicks = _frameTimer preData
|
||||
when (_debugMode w) $ void $ renderFoldable
|
||||
(_renderData preData)
|
||||
(picToLTree Nothing . setLayer 1 . setDepth (-1)
|
||||
. translate (-0.5) (-0.8) . scale 0.0005 0.0005
|
||||
. text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
|
||||
)
|
||||
foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
|
||||
& frameTimer .~ endTicks)) (_doneSideEffects w)
|
||||
|
||||
doPreload' :: Dodge.LoadConfig.Configuration -> IO (PreloadData a)
|
||||
doPreload' config = do
|
||||
lChunks <- loadSounds
|
||||
lMusic <- loadMusic
|
||||
let sData = SoundData {_loadedChunks = lChunks, _playingSounds = M.empty}
|
||||
mData = MusicData {_loadedMusic = lMusic}
|
||||
Mix.playMusic Mix.Forever (lMusic IM.! 0)
|
||||
setVolume config
|
||||
rData <- preloadRender
|
||||
return $ PreloadData
|
||||
{ _renderData = rData
|
||||
@@ -51,38 +79,6 @@ doPreload' = do
|
||||
, _frameTimer = 0
|
||||
}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
(sizex,sizey) <- loadConfig
|
||||
keyConfig <- loadKeyConfig
|
||||
setupLoop
|
||||
(sizex,sizey)
|
||||
(SDL.cursorVisible $= False >> doPreload' >>= resizeSpareFBO sizex sizey)
|
||||
(\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x)
|
||||
(fmap (setWindowSize sizex sizey keyConfig) firstWorld)
|
||||
( \preData w -> do
|
||||
startTicks <- SDL.ticks
|
||||
void $ doDrawing (_renderData preData) w
|
||||
playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
|
||||
newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
|
||||
|
||||
endTicks <- SDL.ticks
|
||||
let lastFrameTicks = _frameTimer preData
|
||||
when (_debugMode w) $ void $ renderFoldable
|
||||
(_renderData preData)
|
||||
(picToLTree Nothing . setLayer 1 . setDepth (-1)
|
||||
. translate (-0.5) (-0.8) . scale 0.0005 0.0005
|
||||
. text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
|
||||
)
|
||||
|
||||
|
||||
return $ preData & soundData . playingSounds .~ newPlayingSounds
|
||||
& frameTimer .~ endTicks
|
||||
)
|
||||
(flip $ menuEvents handleEvent)
|
||||
(Just . update)
|
||||
Mix.closeAudio
|
||||
|
||||
checkForGlErrors :: IO ()
|
||||
checkForGlErrors = do
|
||||
errs <- errors
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
+1
-1
@@ -770,7 +770,7 @@ levLayer HPtLayer = 73
|
||||
levLayer ShadowLayer = 75
|
||||
levLayer LabelLayer = 80
|
||||
levLayer InvLayer = 85
|
||||
levLayer MenuLayer = 90
|
||||
levLayer MenuDepth = 90
|
||||
|
||||
{- | Transform coordinates from world position to normalised screen coordinates.
|
||||
-}
|
||||
|
||||
@@ -0,0 +1,39 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.Config.Data (
|
||||
Configuration (..)
|
||||
, defaultConfig
|
||||
, volume_master
|
||||
, volume_sound
|
||||
, volume_music
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Foreign.C.Types
|
||||
import GHC.Generics
|
||||
import qualified GHC.Int
|
||||
import qualified SDL
|
||||
import System.Directory
|
||||
import Control.Lens
|
||||
|
||||
data Configuration = Configuration
|
||||
{ _volume_master :: Float
|
||||
, _volume_sound :: Float
|
||||
, _volume_music :: Float
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
makeLenses ''Configuration
|
||||
|
||||
instance ToJSON Configuration where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON Configuration
|
||||
|
||||
defaultConfig = Configuration
|
||||
{ _volume_master = 1
|
||||
, _volume_sound = 1
|
||||
, _volume_music = 1
|
||||
}
|
||||
|
||||
@@ -0,0 +1,25 @@
|
||||
{-|
|
||||
IO actions that apply config side effects and save configuration settings to disk.
|
||||
-}
|
||||
module Dodge.Config.Update
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Config.Data
|
||||
import Sound
|
||||
|
||||
import Data.Aeson (encodeFile)
|
||||
import Control.Monad (when)
|
||||
|
||||
updateDodgeConfig :: World -> IO ()
|
||||
updateDodgeConfig w = case _menuLayers w of
|
||||
(ConfigSaveScreen : _) -> do
|
||||
putStrLn "Saving config to data/dodge.config.json"
|
||||
encodeFile "data/dodge.config.json" cfig
|
||||
_ -> when (_configNeedsUpdate w) (setVolume cfig)
|
||||
where
|
||||
cfig = _config w
|
||||
|
||||
setVolume :: Configuration -> IO ()
|
||||
setVolume cfig = do
|
||||
setSoundVolume ( _volume_master cfig * _volume_sound cfig)
|
||||
setMusicVolume ( _volume_master cfig * _volume_music cfig)
|
||||
@@ -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
|
||||
|
||||
|
||||
+13
-11
@@ -3,11 +3,15 @@
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.Data
|
||||
( module Dodge.Data
|
||||
, module Dodge.Data.Menu
|
||||
, Point2 (..)
|
||||
, Sound (..)
|
||||
, soundTime
|
||||
)
|
||||
where
|
||||
import Dodge.Data.Menu
|
||||
import Preload.Data
|
||||
|
||||
import Picture.Data
|
||||
import Geometry.Data
|
||||
import Sound.Data
|
||||
@@ -23,7 +27,8 @@ import SDL (Scancode, MouseButton)
|
||||
import Graphics.Rendering.OpenGL (PrimitiveMode (..),GLfloat,Program,VertexArrayObject,BufferObject)
|
||||
import Codec.Picture (Image,PixelRGBA8)
|
||||
import qualified Data.DList as DL
|
||||
import Dodge.LoadConfig
|
||||
import Dodge.Config.Data
|
||||
import Dodge.LoadConfig.KeyConfig
|
||||
|
||||
import Data.Int (Int16)
|
||||
|
||||
@@ -62,7 +67,7 @@ data World = World
|
||||
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
|
||||
, _pathInc :: ~(M.Map Point2 [Point2])
|
||||
, _storedLevel :: Maybe World
|
||||
, _menuState :: MenuState
|
||||
, _menuLayers :: [MenuLayer]
|
||||
, _worldState :: M.Map WorldState Bool
|
||||
, _windowX :: !Float
|
||||
, _windowY :: !Float
|
||||
@@ -78,7 +83,11 @@ data World = World
|
||||
, _keyConfig :: KeyConfigSDL
|
||||
, _varMovementSpeedModifier :: Float
|
||||
, _varMovementStrafeSpeedModifier :: Float
|
||||
, _debugMode :: Bool
|
||||
, _debugMode :: Bool
|
||||
, _config :: Configuration
|
||||
, _configNeedsUpdate :: Bool
|
||||
, _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
|
||||
, _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
|
||||
}
|
||||
|
||||
data Corpse = Corpse
|
||||
@@ -96,7 +105,7 @@ data Layer
|
||||
| FlItLayer
|
||||
| LabelLayer
|
||||
| InvLayer
|
||||
| MenuLayer
|
||||
| MenuDepth
|
||||
| PressPlateLayer
|
||||
| CorpseLayer
|
||||
| UPtLayer
|
||||
@@ -242,13 +251,6 @@ data Faction
|
||||
data WorldState = DoorNumOpen Int | CrNumAlive Int
|
||||
deriving (Eq,Ord)
|
||||
|
||||
data MenuState
|
||||
= LevelMenu Int
|
||||
| PauseMenu
|
||||
| GameOverMenu
|
||||
| InGame
|
||||
deriving (Eq,Ord)
|
||||
|
||||
data Button = Button
|
||||
{ _btPict :: Picture
|
||||
, _btPos :: Point2
|
||||
|
||||
@@ -0,0 +1,12 @@
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.Data.Menu
|
||||
where
|
||||
data MenuLayer
|
||||
= LevelMenu Int
|
||||
| PauseMenu
|
||||
| GameOverMenu
|
||||
| OptionMenu
|
||||
| ConfigSaveScreen
|
||||
| ControlList
|
||||
deriving (Eq,Ord)
|
||||
|
||||
+13
-10
@@ -1,28 +1,28 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{- |
|
||||
Module : Dodge.Default
|
||||
Description : Instances of data structures
|
||||
|
||||
This module contains prototypical data structures.
|
||||
-}
|
||||
module Dodge.Default where
|
||||
|
||||
import Dodge.Item.Weapon.Recock
|
||||
|
||||
import Dodge.Data
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.Base
|
||||
|
||||
import Dodge.LoadConfig
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import System.Random
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Graph.Inductive.Graph hiding ((&))
|
||||
import Data.List
|
||||
|
||||
import Dodge.LoadConfig
|
||||
|
||||
-- defalt datatypes / prototypes {{{
|
||||
defaultWall = Wall { _wlLine = [(0,0),(50,0)]
|
||||
, _wlID = 0
|
||||
, _wlColor = greyN 0.6
|
||||
@@ -210,7 +210,7 @@ defaultWorld = World
|
||||
, _corpses = IM.empty
|
||||
, _decorations = IM.empty
|
||||
, _storedLevel = Nothing
|
||||
, _menuState = LevelMenu 1
|
||||
, _menuLayers = [LevelMenu 1]
|
||||
, _worldState = M.empty
|
||||
, _clickMousePos = (0,0)
|
||||
, _pathGraph = Data.Graph.Inductive.Graph.empty
|
||||
@@ -234,10 +234,13 @@ defaultWorld = World
|
||||
, _keyConfig = defaultKeyConfigSDL
|
||||
, _varMovementSpeedModifier = 3
|
||||
, _varMovementStrafeSpeedModifier = 3
|
||||
, _debugMode = False
|
||||
, _debugMode = True
|
||||
, _config = defaultConfig
|
||||
, _configNeedsUpdate = False
|
||||
, _sideEffects = []
|
||||
, _doneSideEffects = []
|
||||
}
|
||||
youLight =
|
||||
-- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) )
|
||||
TLS { _tlsPos = (0,0)
|
||||
,_tlsRad = 300
|
||||
,_tlsIntensity = 0.1
|
||||
|
||||
+35
-28
@@ -1,12 +1,28 @@
|
||||
module Dodge.Event where
|
||||
import Dodge.Event.Keyboard
|
||||
{- |
|
||||
Module : Dodge.Event
|
||||
Description : Direct event handling
|
||||
|
||||
Deals with direct events.
|
||||
This includes individual key or 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".
|
||||
-}
|
||||
module Dodge.Event
|
||||
( handleEvent
|
||||
) where
|
||||
import Dodge.Event.Keyboard
|
||||
import Dodge.Event.Menu
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.CreatureAction
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.Inventory
|
||||
import Geometry
|
||||
import Preload.Update
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Data.Char
|
||||
@@ -15,16 +31,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,16 +59,20 @@ 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 _menuLayers w of
|
||||
[] -> 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)
|
||||
. set windowY (fromIntegral y)
|
||||
where V2 x y = windowSizeChangedEventSize sev
|
||||
handleResizeEvent sev = Just
|
||||
. set windowX (fromIntegral x)
|
||||
. set windowY (fromIntegral y)
|
||||
. over sideEffects ( resizeSpareFBO (fromIntegral x) (fromIntegral y) : )
|
||||
where
|
||||
V2 x y = windowSizeChangedEventSize sev
|
||||
|
||||
handlePressedMouseButton :: MouseButton -> World -> Maybe World
|
||||
handlePressedMouseButton but w
|
||||
@@ -113,12 +129,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
|
||||
|
||||
|
||||
+35
-24
@@ -1,3 +1,6 @@
|
||||
{- |
|
||||
Deals with keyboard events.
|
||||
-}
|
||||
module Dodge.Event.Keyboard
|
||||
( handleKeyboardEvent
|
||||
)
|
||||
@@ -12,6 +15,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
|
||||
@@ -20,6 +24,11 @@ import Control.Lens
|
||||
|
||||
import Picture
|
||||
|
||||
{- | Handles keyboard press and release.
|
||||
On release, remove scancode from the 'Set' of pressed keys.
|
||||
On press, adds the scancode, and perhaps applies a direct effect:
|
||||
see 'handlePressedKeyInGame'.
|
||||
-}
|
||||
handleKeyboardEvent :: KeyboardEventData -> World -> Maybe World
|
||||
handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of
|
||||
Released -> Just $ w & keys %~ S.delete kcode
|
||||
@@ -30,33 +39,35 @@ 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
|
||||
| scode == rotateCameraPlusKey (_keyConfig w) = Just $ w & cameraRot +~ 0.01
|
||||
| scode == rotateCameraMinusKey (_keyConfig w) = Just $ w & cameraRot -~ 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
|
||||
| _menuLayers w == []
|
||||
= handlePressedKeyInGame scode w
|
||||
| otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
|
||||
handlePressedKey _ _ w = Just w
|
||||
|
||||
debugKey :: Scancode -> World -> Maybe World
|
||||
debugKey scancode w
|
||||
| scancode == ScancodeF7 = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w - 1}
|
||||
| scancode == ScancodeF8 = Just $ w {_varMovementSpeedModifier = _varMovementSpeedModifier w + 1}
|
||||
| scancode == ScancodeF5 = Just $ dropLight w
|
||||
| scancode == ScancodeF6 = Just $ dropLight' w
|
||||
| scancode == ScancodeF7 = Just $ w & varMovementSpeedModifier -~ 1
|
||||
| scancode == ScancodeF8 = Just $ w & varMovementSpeedModifier +~ 1
|
||||
| scancode == ScancodeF5 = Just $ dropLight w
|
||||
| scancode == ScancodeF6 = Just $ dropLight' w
|
||||
debugKey _ w = Just w
|
||||
|
||||
spaceAction :: World -> World
|
||||
@@ -66,14 +77,14 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of
|
||||
Nothing -> w
|
||||
|
||||
pauseGame :: World -> World
|
||||
pauseGame w = w {_menuState = PauseMenu}
|
||||
pauseGame w = w {_menuLayers = [PauseMenu]}
|
||||
|
||||
toggleMap w = w & carteDisplay %~ not
|
||||
escapeMap w = w & carteDisplay .~ False
|
||||
|
||||
dropLight :: World -> World
|
||||
dropLight w = placeLS ls dec pos 0
|
||||
-- $ over creatures IM.insert i (lamp)
|
||||
-- $ over creatures IM.insert i (lamp)
|
||||
$ w
|
||||
--case yourItem w of
|
||||
--NoItem -> w
|
||||
@@ -90,4 +101,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,66 @@
|
||||
module Dodge.Event.Menu
|
||||
( handlePressedKeyInMenu
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Rooms
|
||||
import Dodge.Floor
|
||||
import Dodge.Initialisation
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.LoadConfig
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as S
|
||||
import Control.Lens
|
||||
import SDL
|
||||
|
||||
handlePressedKeyInMenu :: MenuLayer -> Scancode -> World -> Maybe World
|
||||
handlePressedKeyInMenu mState scode w = case mState of
|
||||
LevelMenu _ -> case scode of
|
||||
ScancodeEscape -> Nothing
|
||||
ScancodeO -> goToOptionMenu w
|
||||
ScancodeC -> goToControls w
|
||||
_ -> startLevel w
|
||||
PauseMenu -> case scode of
|
||||
ScancodeEscape -> Nothing
|
||||
ScancodeR -> return $ fromMaybe w $ _storedLevel w
|
||||
ScancodeN -> Just $ putSound $ generateLevel 1
|
||||
$ initialWorld {_randGen = _randGen w}
|
||||
ScancodeO -> goToOptionMenu w
|
||||
ScancodeC -> goToControls w
|
||||
_ -> unpause w
|
||||
GameOverMenu -> case scode of
|
||||
ScancodeEscape -> Nothing
|
||||
ScancodeR -> Just $ fromMaybe w $ _storedLevel w
|
||||
ScancodeN -> Just $ putSound $ generateLevel 1
|
||||
$ initialWorld
|
||||
{_randGen = _randGen w}
|
||||
ScancodeO -> goToOptionMenu w
|
||||
ScancodeC -> goToControls w
|
||||
_ -> Just w
|
||||
OptionMenu -> case scode of
|
||||
ScancodeY -> Just $ w & config . volume_master %~ dec
|
||||
ScancodeU -> Just $ w & config . volume_master %~ inc
|
||||
ScancodeH -> Just $ w & config . volume_sound %~ dec
|
||||
ScancodeJ -> Just $ w & config . volume_sound %~ inc
|
||||
ScancodeN -> Just $ w & config . volume_music %~ dec
|
||||
ScancodeM -> Just $ w & config . volume_music %~ inc
|
||||
_ -> Just $ w & menuLayers %~ ([ConfigSaveScreen , ConfigSaveScreen] ++) . tail
|
||||
& configNeedsUpdate .~ False
|
||||
ControlList -> Just $ w & menuLayers %~ tail
|
||||
_ -> Just w
|
||||
where
|
||||
unpause w' = Just . resumeSound $
|
||||
w' {_menuLayers = []}
|
||||
startLevel = unpause . storeLevel
|
||||
putSound = id -- set loadedSounds (_loadedSounds w)
|
||||
dec x = max 0 (x - 0.1)
|
||||
inc x = min 1 (x + 0.1)
|
||||
goToOptionMenu w = Just $ w & menuLayers %~ (OptionMenu :)
|
||||
& configNeedsUpdate .~ True
|
||||
goToControls w = Just $ w & menuLayers %~ (ControlList :)
|
||||
|
||||
storeLevel :: World -> World
|
||||
storeLevel w = case _storedLevel w of
|
||||
Nothing -> w & storedLevel ?~ w
|
||||
_ -> w
|
||||
@@ -47,7 +47,7 @@ initialWorld = defaultWorld
|
||||
, _sounds = M.empty
|
||||
, _decorations = IM.empty
|
||||
, _storedLevel = Nothing
|
||||
, _menuState = LevelMenu 1
|
||||
, _menuLayers = [LevelMenu 1]
|
||||
, _worldState = M.empty
|
||||
, _windowX = 800
|
||||
, _windowY = 600
|
||||
|
||||
+20
-141
@@ -1,152 +1,31 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
module Dodge.LoadConfig
|
||||
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
|
||||
(
|
||||
loadDodgeConfig
|
||||
, module Dodge.LoadConfig.KeyConfig
|
||||
, module Dodge.Config.Data
|
||||
) where
|
||||
import Dodge.LoadConfig.KeyConfig
|
||||
import Dodge.Config.Data
|
||||
import Dodge.Config.Update
|
||||
|
||||
import Data.Aeson
|
||||
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"
|
||||
loadDodgeConfig :: IO Configuration
|
||||
loadDodgeConfig = do
|
||||
fExists <- doesFileExist "data/dodge.config.json"
|
||||
if fExists
|
||||
then do
|
||||
mayConfig <- decodeFileStrict "keys.json"
|
||||
print mayConfig
|
||||
mayConfig <- decodeFileStrict "data/dodge.config.json"
|
||||
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
|
||||
}
|
||||
Just config -> setVolume config >> return config
|
||||
Nothing -> do
|
||||
putStrLn "invalid keys.json, loading default config"
|
||||
-- This is duplicated but not sure how to reduce
|
||||
return defaultKeyConfigSDL
|
||||
putStrLn "invalid data/dodge.config.json, loading default config"
|
||||
return defaultConfig
|
||||
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
|
||||
putStrLn "No data/data/dodge.config.json found, loading defaults"
|
||||
return defaultConfig
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -3,52 +3,78 @@ module Dodge.Render.MenuScreen
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.LoadConfig
|
||||
import Dodge.Base (halfWidth,halfHeight)
|
||||
|
||||
import Picture
|
||||
|
||||
menuScreen :: World -> Picture
|
||||
menuScreen w = case _menuState w of
|
||||
InGame -> blank
|
||||
LevelMenu x ->
|
||||
pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
tst (-100) 100 0.4 ("LEVEL "++show x)
|
||||
,controlsList
|
||||
]
|
||||
PauseMenu -> pictures
|
||||
[--color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
tst (-100) 100 0.4 "PAUSED"
|
||||
,tst (-100) 50 0.2 "n - new level"
|
||||
,tst (-100) 0 0.2 "r - restart"
|
||||
, controlsList
|
||||
]
|
||||
GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "GAME OVER"
|
||||
,tst (-100) 50 0.2 "n - new level"
|
||||
,tst (-100) 0 0.2 "r - restart"
|
||||
,controlsList
|
||||
]
|
||||
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
menuScreen w = case _menuLayers w of
|
||||
[] -> blank
|
||||
(LevelMenu x:_) -> pictures
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 ("LEVEL "++show x)
|
||||
]
|
||||
(PauseMenu:_) -> pictures
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "PAUSED"
|
||||
,tst (-100) 50 0.2 "n - new level"
|
||||
,tst (-100) 0 0.2 "r - restart"
|
||||
,tst (-100) (-50) 0.2 "o - options"
|
||||
,tst (-100) (-100) 0.2 "c - controls"
|
||||
]
|
||||
(GameOverMenu:_) -> pictures
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "GAME OVER"
|
||||
,tst (-100) 50 0.2 "n - new level"
|
||||
,tst (-100) 0 0.2 "r - restart"
|
||||
,tst (-100) (-50) 0.2 "o - options"
|
||||
,tst (-100) (-100) 0.2 "c - controls"
|
||||
]
|
||||
(OptionMenu : _) -> pictures
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "OPTIONS"
|
||||
,tst (-180) 50 0.2 $ "y - master volume + u : " ++ mavol
|
||||
,tst (-180) 0 0.2 $ "h - sound volume + j : " ++ snvol
|
||||
,tst (-180) (-50) 0.2 $ "n - music volume + m : " ++ muvol
|
||||
]
|
||||
(ControlList : _) -> pictures
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "CONTROLS"
|
||||
,controlsList
|
||||
]
|
||||
(ConfigSaveScreen : _) -> pictures
|
||||
[color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "OPTIONS"
|
||||
,tst (-180) 50 0.2 $ "y - master volume + u : " ++ mavol
|
||||
,tst (-180) 0 0.2 $ "h - sound volume + j : " ++ snvol
|
||||
,tst (-180) (-50) 0.2 $ "n - music volume + m : " ++ muvol
|
||||
]
|
||||
_ -> blank
|
||||
where
|
||||
tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
mavol = f $ _volume_master $ _config w
|
||||
snvol = f $ _volume_sound $ _config w
|
||||
muvol = f $ _volume_music $ _config w
|
||||
f x = show $ round $ 10 * x
|
||||
|
||||
controlsList = pictures [tst (-250) (-130) 0.15 "controls:"
|
||||
,tst (-150) (-130) 0.15 "wasd"
|
||||
,tst 0 (-130) 0.15 "movement"
|
||||
,tst (-150) (-160) 0.15 "[rmb]"
|
||||
,tst 0 (-160) 0.15 "aim"
|
||||
,tst (-150) (-190) 0.15 "[rmb+lmb]"
|
||||
,tst 0 (-190) 0.15 "shoot or use item"
|
||||
,tst (-150) (-220) 0.15 "[wheelscroll]"
|
||||
,tst 0 (-220) 0.15 "select item"
|
||||
,tst (-150) (-250) 0.15 "[space]"
|
||||
,tst 0 (-250) 0.15 "pickup item"
|
||||
,tst (-150) (-280) 0.15 "f"
|
||||
,tst 0 (-280) 0.15 "drop item"
|
||||
,tst (-150) (-310) 0.15 "cp[esc]"
|
||||
,tst 0 (-310) 0.15 "pause"
|
||||
,tst (-150) (-340) 0.15 "qe[lmb]"
|
||||
,tst 0 (-340) 0.15 "rotate camera"
|
||||
]
|
||||
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
controlsList = pictures $ concat $ zipWith butAndEff
|
||||
[("wasd", "movement")
|
||||
,("[rmb]", "aim")
|
||||
,("[rmb+lmb]", "shoot or use item")
|
||||
,("[wheelscroll]" , "select item" )
|
||||
,("[space]" , "pickup item" )
|
||||
,("m" , "display map" )
|
||||
,("f" , "drop item" )
|
||||
,("c[esc]" , "pause" )
|
||||
,("qe" , "rotate camera")
|
||||
]
|
||||
[60,30..]
|
||||
where
|
||||
butAndEff (btext,etext) y =
|
||||
[translate (-250) y $ scale 0.15 0.15 $ color white $ text btext
|
||||
,translate 0 y $ scale 0.15 0.15 $ color white $ text etext
|
||||
]
|
||||
|
||||
screenBox w = [ (halfWidth w, halfHeight w)
|
||||
, (-halfWidth w, halfHeight w)
|
||||
|
||||
@@ -29,7 +29,7 @@ worldPictures w = pictures $ concat
|
||||
fixedCoordPictures :: World -> Picture
|
||||
fixedCoordPictures w = pictures
|
||||
[ hudDrawings w
|
||||
, scaler . onLayer MenuLayer $ menuScreen w
|
||||
, scaler . onLayer MenuDepth $ menuScreen w
|
||||
, customMouseCursor w
|
||||
]
|
||||
where
|
||||
|
||||
@@ -65,7 +65,7 @@ resumeSound :: World -> World
|
||||
resumeSound w = w
|
||||
|
||||
{-| Add a sound to the queue for playback.
|
||||
Consider replacing with 'soundOncePos'.
|
||||
Consider replacing instances with 'soundOncePos'.
|
||||
-}
|
||||
soundOnce :: Int -> World -> World
|
||||
soundOnce i = over soundQueue ((:) (i,0))
|
||||
|
||||
+31
-29
@@ -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,17 +21,24 @@ 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
|
||||
|
||||
update = update' . pushSideEffects
|
||||
|
||||
-- }}}
|
||||
pushSideEffects :: World -> World
|
||||
pushSideEffects w = w
|
||||
& sideEffects .~ []
|
||||
& doneSideEffects .~ _sideEffects w
|
||||
|
||||
update :: World -> World
|
||||
update w
|
||||
| _menuState w /= InGame = w
|
||||
| otherwise =
|
||||
let w1 = updateParticles' . updateProjectiles
|
||||
{- | The update step.
|
||||
If '_menuLayers' is not empty, or the saving screen, this is the identity.
|
||||
In such menus, the only way to change the world is using event handling.
|
||||
-}
|
||||
update' :: World -> World
|
||||
update' w = case _menuLayers w of
|
||||
(ConfigSaveScreen : ls) -> w & menuLayers .~ ls
|
||||
(_ : _) -> w
|
||||
[] -> let w1 = updateParticles' . updateProjectiles
|
||||
. updateLightSources
|
||||
. zoneClouds
|
||||
. updateClouds
|
||||
@@ -35,7 +46,6 @@ update w
|
||||
. updateBlocks -- . zoning
|
||||
. updateSeenWalls
|
||||
. updateSoundQueue
|
||||
-- . updateUsingInput
|
||||
$ updateCloseObjects w
|
||||
in checkEndGame . ppEvents
|
||||
. updateCamera
|
||||
@@ -45,22 +55,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 +75,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
|
||||
@@ -107,7 +109,7 @@ setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
|
||||
where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
|
||||
|
||||
checkEndGame :: World -> World
|
||||
checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuState = GameOverMenu}
|
||||
checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
|
||||
| otherwise = w
|
||||
|
||||
updateClouds :: World -> World
|
||||
|
||||
+3
-3
@@ -1,4 +1,4 @@
|
||||
{-|
|
||||
{- |
|
||||
Module : Loop
|
||||
Description : Minimal game loop
|
||||
|
||||
@@ -7,14 +7,14 @@ This module sets up an SDL window which may be updated using a simple game loop.
|
||||
module Loop
|
||||
( setupLoop
|
||||
) where
|
||||
import SDL
|
||||
import qualified Data.Text as T
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import Control.Monad
|
||||
import System.Mem
|
||||
import Foreign.C
|
||||
import SDL
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import Control.Lens ((.~),(&),(+~))
|
||||
|
||||
|
||||
+5
-2
@@ -6,15 +6,18 @@ module Preload
|
||||
where
|
||||
import Preload.Data
|
||||
import Preload.Update
|
||||
|
||||
import Picture.Preload
|
||||
import Sound.Data
|
||||
import Control.Lens
|
||||
|
||||
import Control.Lens
|
||||
import GHC.Word (Word32)
|
||||
import qualified SDL.Mixer as Mix
|
||||
|
||||
|
||||
cleanUpPreload :: PreloadData a -> IO ()
|
||||
cleanUpPreload pd = do
|
||||
cleanUpRenderPreload $ _renderData pd
|
||||
cleanUpSoundPreload $ _soundData pd
|
||||
|
||||
cleanUpSoundPreload :: SoundData a -> IO ()
|
||||
cleanUpSoundPreload sd = Mix.closeAudio
|
||||
|
||||
+26
-7
@@ -14,6 +14,9 @@ module Sound (
|
||||
, playPositionalSoundQueue
|
||||
-- * Complex Playback
|
||||
, playAndUpdate
|
||||
-- * Volume Control
|
||||
, setSoundVolume
|
||||
, setMusicVolume
|
||||
) where
|
||||
import Sound.Data
|
||||
|
||||
@@ -32,17 +35,18 @@ then sounds in the merged Map are updated.
|
||||
The Map of updated sound specifications is returned.
|
||||
|
||||
New sounds with the same keys as
|
||||
already playing sounds are merged in the following manner:
|
||||
already playing sounds are merged as follows:
|
||||
|
||||
* the '_soundChannel' is set to the old value
|
||||
* if the old '_soundStatus' was 'FadingOut', it is replaced with the new status (allowing playback to be restarted using 'ToStart')
|
||||
* all other fields are set to the new value.
|
||||
* '_soundChannel' is set to the old value
|
||||
* if the old '_soundStatus' was 'FadingOut', it set to the new value (can restart playback with 'ToStart')
|
||||
* other fields are set to the new value.
|
||||
|
||||
In the update:
|
||||
|
||||
1. sounds with a value 'ToStart' commence playing
|
||||
2. timers are decremented and any fading status is set
|
||||
3. sounds that have stopped playing are removed from the map.
|
||||
1. commence playing sounds with 'ToStart' status
|
||||
2. decrement timers, set any fading status
|
||||
3. apply 'Just' sound position effects, set value to 'Nothing'
|
||||
4. remove sounds that have stopped playing from the map.
|
||||
-}
|
||||
playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound)
|
||||
playAndUpdate sData newSounds
|
||||
@@ -148,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))
|
||||
|
||||
|
||||
@@ -32,5 +32,3 @@ data Sound = Sound
|
||||
makeLenses ''SoundData
|
||||
makeLenses ''Sound
|
||||
|
||||
cleanUpSoundPreload :: SoundData a -> IO ()
|
||||
cleanUpSoundPreload sd = Mix.closeAudio
|
||||
|
||||
Reference in New Issue
Block a user