From b337fbdab9e75476a66ba05265da9ccdd326c7bf Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 23 May 2021 16:24:11 +0200 Subject: [PATCH] Add basic prompt --- app/Main.hs | 3 +- src/Dodge/Data.hs | 3 +- src/Dodge/Data/Menu.hs | 1 + src/Dodge/Debug/Flag.hs | 3 ++ src/Dodge/Debug/Flag/Data.hs | 10 +++++++ src/Dodge/Debug/Terminal.hs | 10 +++++++ src/Dodge/Default.hs | 8 ++++- src/Dodge/Event/Keyboard.hs | 45 ++++++++++++++++------------- src/Dodge/Event/Menu.hs | 15 ++++++++++ src/Dodge/Layout.hs | 6 ++-- src/Dodge/Render/MenuScreen.hs | 1 + src/Dodge/WallCreatureCollisions.hs | 4 ++- 12 files changed, 82 insertions(+), 27 deletions(-) create mode 100644 src/Dodge/Debug/Flag.hs create mode 100644 src/Dodge/Debug/Flag/Data.hs create mode 100644 src/Dodge/Debug/Terminal.hs diff --git a/app/Main.hs b/app/Main.hs index 2f81610bf..ffffb40e7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,6 +11,7 @@ import Dodge.Config.KeyConfig import Dodge.Config.Load import Dodge.Config.Update import Dodge.LoadSound +import Dodge.Debug.Flag.Data import Picture import Picture.Render import Picture.Preload @@ -52,7 +53,7 @@ doSideEffects preData w = do endTicks <- SDL.ticks let lastFrameTicks = _frameTimer preData - when (_debugMode w) $ void $ renderFoldable + when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable (_renderData preData) (picToLTree Nothing . setLayer 1 . setDepth (-1) . translate (-0.5) (-0.8) . scale 0.0005 0.0005 diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 1058dc203..a4b2d690a 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -18,6 +18,7 @@ module Dodge.Data import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data import Dodge.Creature.AlertLevel.Data +import Dodge.Debug.Flag.Data import Dodge.Data.Menu import Dodge.Data.SoundOrigin import Dodge.Data.DamageType @@ -91,10 +92,10 @@ data World = World , _seenLocations :: IM.IntMap (World -> Point2,String) , _selLocation :: Int , _keyConfig :: KeyConfigSDL - , _debugMode :: Bool , _config :: Configuration , _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] , _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] + , _debugFlags :: DebugFlags } data CrGroupParams = CrGroupParams { _crGroupParamID :: Int diff --git a/src/Dodge/Data/Menu.hs b/src/Dodge/Data/Menu.hs index e415f9e89..c5cb9898a 100644 --- a/src/Dodge/Data/Menu.hs +++ b/src/Dodge/Data/Menu.hs @@ -10,4 +10,5 @@ data MenuLayer | GraphicsOptionMenu | ControlList | WaitMessage String Int + | Terminal String deriving (Eq,Ord) diff --git a/src/Dodge/Debug/Flag.hs b/src/Dodge/Debug/Flag.hs new file mode 100644 index 000000000..68acc80a3 --- /dev/null +++ b/src/Dodge/Debug/Flag.hs @@ -0,0 +1,3 @@ +module Dodge.Debug.Flag + where + diff --git a/src/Dodge/Debug/Flag/Data.hs b/src/Dodge/Debug/Flag/Data.hs new file mode 100644 index 000000000..1e71a384b --- /dev/null +++ b/src/Dodge/Debug/Flag/Data.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} +module Dodge.Debug.Flag.Data + where +import Control.Lens +data DebugFlags = DebugFlags + { _noClip :: Bool + , _displaySecondsPerFrame :: Bool + } +makeLenses ''DebugFlags diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs new file mode 100644 index 000000000..25ec64ed7 --- /dev/null +++ b/src/Dodge/Debug/Terminal.hs @@ -0,0 +1,10 @@ +module Dodge.Debug.Terminal + where +import Dodge.Data +import Dodge.Debug.Flag.Data + +import Control.Lens + +applyTerminalString :: String -> World -> World +applyTerminalString "NOCLIP" w = w & debugFlags . noClip %~ not +applyTerminalString _ w = w diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 6ab25ddd0..9977b00bb 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -10,6 +10,7 @@ import Dodge.Data import Dodge.Creature.Stance.Data import Dodge.Creature.State.Data import Dodge.Creature.AlertLevel.Data +import Dodge.Debug.Flag.Data import Dodge.Data.Menu import Dodge.SoundLogic import Dodge.Base @@ -272,10 +273,15 @@ defaultWorld = World ] , _selLocation = 0 , _keyConfig = defaultKeyConfigSDL - , _debugMode = True , _config = defaultConfig , _sideEffects = [] , _doneSideEffects = [] + , _debugFlags = defaultDebugFlags + } +defaultDebugFlags :: DebugFlags +defaultDebugFlags = DebugFlags + { _noClip = False + , _displaySecondsPerFrame = True } youLight :: TempLightSource youLight = diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 6eab849b4..a35ef1867 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -37,32 +37,37 @@ 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 $ youDropItem w - | scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w - | scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ startReloadingWeapon (_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 _ ScancodeSemicolon w | not (inTerminal w) = Just $ gotoTerminal w handlePressedKey _ scode w | null (_menuLayers w) = handlePressedKeyInGame scode w | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w -debugKey :: Scancode -> World -> Maybe World -debugKey scancode w - | scancode == ScancodeF5 = Just $ dropLight w - | scancode == ScancodeF6 = Just $ dropLight' w -debugKey _ w = Just w +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 $ youDropItem w + | scode == toggleMapKey (_keyConfig w) = Just $ toggleMap w + | scode == reloadKey (_keyConfig w) = Just $ fromMaybe w $ startReloadingWeapon (_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 == ScancodeF5 = Just $ dropLight w + | scode == ScancodeF6 = Just $ dropLight' w +handlePressedKeyInGame _ w = Just w + + +inTerminal :: World -> Bool +inTerminal w = case _menuLayers w of + (Terminal _ : _) -> True + _ -> False +gotoTerminal :: World -> World +gotoTerminal w = case _menuLayers w of + (Terminal _ : _ ) -> w + _ -> w & menuLayers %~ (Terminal [] :) spaceAction :: World -> World spaceAction w = if _carteDisplay w diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 05604a3c5..7adc211b0 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -11,14 +11,21 @@ import Dodge.Config.Data import Dodge.Config.Update import Dodge.Layout import Preload.Update +import Dodge.Debug.Terminal import Data.Maybe --import qualified Data.Set as S import Control.Lens import SDL +import SDL.Internal.Numbered handlePressedKeyInMenu :: MenuLayer -> Scancode -> World -> Maybe World handlePressedKeyInMenu mState scode w = case mState of + Terminal s -> case scode of + ScancodeEscape -> popMenu w + ScancodeReturn -> popMenu $ applyTerminalString s w + ScancodeBackspace -> popMenu w >>= pushMenu (Terminal $ dropLast s) + _ -> popMenu w >>= pushMenu (Terminal $ s ++ [scodeToChar scode]) LevelMenu _ -> case scode of ScancodeEscape -> Nothing ScancodeO -> pushMenu OptionMenu w @@ -72,6 +79,12 @@ handlePressedKeyInMenu mState scode w = case mState of aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld & randGen .~ _randGen w & config .~ _config w + dropLast (x:xs) = init (x:xs) + dropLast _ = [] + +-- | hacky +scodeToChar :: Scancode -> Char +scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber updateFramebufferSize :: World -> World updateFramebufferSize w = w & sideEffects @@ -91,3 +104,5 @@ storeLevel :: World -> World storeLevel w = case _storedLevel w of Nothing -> w & storedLevel ?~ w _ -> w + + diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 7aa7977f0..204fffc8d 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -13,7 +13,7 @@ import Dodge.Default import Geometry import Dodge.Room.Link import qualified IntMapHelp as IM -import Dodge.Debug.LinkDecoration +--import Dodge.Debug.LinkDecoration import Control.Monad.State import Control.Lens @@ -27,8 +27,8 @@ import qualified Data.Map as M generateLevelFromRoomList :: State StdGen [Room] -> World -> World generateLevelFromRoomList gr w = updateWallZoning . placeSpots plmnts - . addRoomPolyDecorations rs - . addRoomLinkDecorations rs +-- . addRoomPolyDecorations rs +-- . addRoomLinkDecorations rs $ w { _walls = wallsFromRooms rs } where diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 470d1dd12..d948bf5fa 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -50,6 +50,7 @@ menuScreen cfig hw hh mLays = case mLays of ,controlsList ] (WaitMessage s _ : _) -> optionsList hw hh s [] + (Terminal s : _) -> optionsList hw hh "SCANCODE INPUT" ['>':s ++ "_"] _ -> blank where tst x y sc t = translate x y $ scale sc sc $ color white $ text t diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index c0c52ea26..93307ee2d 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -2,6 +2,7 @@ module Dodge.WallCreatureCollisions where import Dodge.Data import Dodge.Creature.State.Data +import Dodge.Debug.Flag.Data import Dodge.Base import Geometry @@ -16,7 +17,7 @@ colCrsWalls w = over creatures (fmap (colCrWall w)) w colCrWall :: World -> Creature -> Creature colCrWall w c - | _crID c == 0 = c -- for noclip + | noclipIsOn && _crID c == 0 = c -- for noclip | p1 == p2 = pushOrCrush ls c | otherwise = c & crPos %~ collideCorners rad wallPoints @@ -28,6 +29,7 @@ colCrWall w c p2 = _crPos c ls = IM.elems $ _wlLine <$> wallsNearPoint p2 w wallPoints = nub $ concatMap (\(x,y) -> [x,y]) ls + noclipIsOn = _noClip $ _debugFlags w -- colCrPushThrough :: World -> Creature -> Creature -- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr