From 5f238a65d0b5ab1e9f5bc016842a64648e801dda Mon Sep 17 00:00:00 2001 From: justin Date: Wed, 10 May 2023 20:32:26 +0100 Subject: [PATCH] Cleanup --- src/Dodge/Data/Universe.hs | 12 ++--- src/Dodge/DisplayInventory.hs | 15 +++---- src/Dodge/Menu.hs | 61 +++++++++++-------------- src/Dodge/Menu/Loading.hs | 2 +- src/Dodge/Menu/Option.hs | 14 +++--- src/Dodge/Menu/OptionType.hs | 1 + src/Dodge/Render/HUD.hs | 5 +-- src/Dodge/Update/Input/ScreenLayer.hs | 65 +++++++++++++++------------ src/Picture/Base.hs | 13 ++++-- 9 files changed, 96 insertions(+), 92 deletions(-) diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs index 54aba9447..8e870144b 100644 --- a/src/Dodge/Data/Universe.hs +++ b/src/Dodge/Data/Universe.hs @@ -69,17 +69,17 @@ data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions | LoadingScreen deriving (Eq, Ord, Show, Read) --Generic, Flat) -data PositionedMenuOption - = BottomMenuOption { _pmoMenuOption :: MenuOption } - | TopMenuOption { _pmoMenuOption :: MenuOption } - | NoPositionedMenuOption +data EscapeMenuOption + = BottomEscapeMenuOption { _emoMenuOption :: MenuOption } + | TopEscapeMenuOption { _emoMenuOption :: MenuOption } + | NoEscapeMenuOption data ScreenLayer = OptionScreen { _scTitle :: String , _scOptions :: [MenuOption] , _scOffset :: Int - , _scPositionedMenuOption :: PositionedMenuOption + , _scPositionedMenuOption :: EscapeMenuOption , _scOptionFlag :: OptionScreenFlag , _scSelectionList :: SelectionList (Universe -> Universe,Universe->Universe) , _scAvailableLines :: Int @@ -114,6 +114,6 @@ makeLenses ''ScreenLayer makeLenses ''SideEffect makeLenses ''MenuOptionDisplay makeLenses ''MenuOption -makeLenses ''PositionedMenuOption +makeLenses ''EscapeMenuOption makeLenses ''DebugItem makeLenses ''DebugInfo diff --git a/src/Dodge/DisplayInventory.hs b/src/Dodge/DisplayInventory.hs index c5ef74d70..672074f3a 100644 --- a/src/Dodge/DisplayInventory.hs +++ b/src/Dodge/DisplayInventory.hs @@ -186,16 +186,15 @@ updateSection :: SelectionSection a updateSection sis mcsel availablelines ss = ss - { _ssItems = sis - , _ssCursor = scurs - , _ssOffset = offset - , _ssShownItems = shownitems - } + & ssItems .~ sis + & ssCursor .~ scurs + & ssOffset .~ offset + & ssShownItems .~ shownitems where oldoffset = ss ^. ssOffset scurs = do csel <- mcsel - (_, si) <- IM.lookupGE csel sis -- this is not right + (_, si) <- IM.lookupGE csel sis -- this is not right? let cpos = sum (fmap (length . _siPictures) . fst . IM.split csel $ sis) csize = length $ _siPictures si ccolor = _siColor si @@ -238,7 +237,7 @@ updateSection sis mcsel availablelines ss = | length shownstrings > availablelines = tweakfirst (take (availablelines - 1) shownstrings) -- ++ [xtra ">>>"] - ++ [translate 0 100 . color moredowncolor . vMirrorText $ theindent ++ replicate 15 '^'] + ++ [translate 0 100 . color moredowncolor . textVMirror $ theindent ++ replicate 15 '^'] | otherwise = tweakfirst shownstrings moredowncolor = fromMaybe white $ allstrings ^? ix (offset + availablelines - 1) . _1 allstrings :: [(Color, String)] @@ -246,7 +245,7 @@ updateSection sis mcsel availablelines ss = shownstrings = drop offset allstrings h (col, str) = color col . text $ theindent ++ str theindent = replicate (_ssIndent ss) ' ' - xtra str = color white . text $ theindent ++ str ++ " MORE " ++ _ssDescriptor ss + --xtra str = color white . text $ theindent ++ str ++ " MORE " ++ _ssDescriptor ss g si = map (_siColor si,) $ _siPictures si enterCombineInv :: Configuration -> World -> World diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 0265d79a5..d4a8200a2 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -4,11 +4,9 @@ module Dodge.Menu ( splashMenu, ) where -import qualified Data.Aeson.Encode.Pretty as AEP import Control.Monad +import qualified Data.Aeson.Encode.Pretty as AEP import Data.ByteString.Lazy.Char8 (unpack) ---import SDL - import Data.Maybe import Dodge.Concurrent import Dodge.Config.Update @@ -16,19 +14,19 @@ import Dodge.Data.Universe import Dodge.Menu.Option import Dodge.Menu.OptionType import Dodge.Menu.PushPop -import Preload.Update import Dodge.Save import Dodge.SoundLogic import Dodge.StartNewGame import LensHelp import MaybeHelp import Padding +import Preload.Update import System.Clipboard import Text.Read splashMenu :: Universe -> ScreenLayer splashMenu u = - initializeOptionMenu "GAME TITLE" splashMenuOptions NoPositionedMenuOption u + initializeOptionMenu "GAME TITLE" splashMenuOptions NoEscapeMenuOption u & scOptionFlag .~ SplashOptions splashMenuOptions :: [MenuOption] @@ -53,9 +51,9 @@ splashMenuOptions = | otherwise = MODString str pauseMenu :: Universe -> ScreenLayer -pauseMenu = initializeOptionMenu "PAUSED" pauseMenuOptions pmo - where - pmo = TopMenuOption $ Toggle unpause (const (MODString "CONTINUE")) +pauseMenu = + initializeOptionMenu "PAUSED" pauseMenuOptions $ + TopEscapeMenuOption $ Toggle unpause (const (MODString "CONTINUE")) pauseMenuOptions :: [MenuOption] pauseMenuOptions = @@ -130,27 +128,11 @@ debugMenuOptions = g bd Nothing = (show bd, "False") g bd _ = (show bd, "True") --- zipWith ($) --- [ makeBoolOption debug_seconds_frame "SHOW SECONDS/FRAME" --- , makeBoolOption debug_noclip "NOCLIP" --- , makeBoolOption debug_cr_status "SHOW CREATURE STATUS" --- , makeBoolOption debug_cr_awareness "SHOW CREATURE AWARENESS" --- , makeBoolOption debug_view_boundaries "SHOW VIEW BOUNDARIES" --- , makeBoolOption debug_pathing "SHOW PATHING" --- , makeBoolOption debug_show_sound "SHOW VISUAL SOUNDS" --- , makeBoolOption debug_mouse_position "SHOW MOUSE POSITION" --- , makeBoolOption debug_walls "SHOW WALL INFO" --- , makeBoolOption debug_remove_LOS "REMOVE LOS" --- , makeBoolOption debug_cull_more_lights "CULL MORE LIGHTS" --- ] --- $ map Scancode [4 ..] gameplayMenu :: Universe -> ScreenLayer gameplayMenu = titleOptionsMenu "OPTIONS:GAMEPLAY" gameplayMenuOptions gameplayMenuOptions :: [MenuOption] -gameplayMenuOptions = - [ makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL" - ] +gameplayMenuOptions = [makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL"] soundMenu :: Universe -> ScreenLayer soundMenu = titleOptionsMenu "OPTIONS:VOLUME" soundMenuOptions @@ -183,9 +165,13 @@ graphicsMenu = titleOptionsMenu "OPTIONS:GRAPHICS" graphicsMenuOptions graphicsMenuOptions :: [MenuOption] graphicsMenuOptions = [ makeEnumOption graphics_world_resolution "World resolution" (uvIOEffects .~ updatePreload) - , makeEnumOption graphics_downsize_resolution "Downsize resolution" + , makeEnumOption + graphics_downsize_resolution + "Downsize resolution" (uvIOEffects .~ updatePreload) - , makeEnumOption graphics_distortion_resolution "Distortion resolution" + , makeEnumOption + graphics_distortion_resolution + "Distortion resolution" (uvIOEffects .~ updatePreload) , makeEnumOption graphics_shadow_rendering "SHADOW RENDERING" id , makeEnumOption graphics_shadow_size "SHADOW DETAIL" id @@ -197,43 +183,48 @@ graphicsMenuOptions = gameOverMenu :: Universe -> ScreenLayer gameOverMenu u = - initializeOptionMenu "GAME OVER" pauseMenuOptions NoPositionedMenuOption u + initializeOptionMenu "GAME OVER" pauseMenuOptions NoEscapeMenuOption u & scOptionFlag .~ GameOverOptions --charToScode :: Char -> Scancode --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum unpause :: Universe -> Universe -unpause w = over uvWorld resumeSound $ w & uvScreenLayers .~ [] +unpause = over uvWorld resumeSound . set uvScreenLayers [] -- note that this won't update after it is first loaded displayConfig :: Universe -> ScreenLayer displayConfig u = titleOptionsNoWrite "CONFIG" (map (Toggle id . const . MODString) $ listConfig u) u listConfig :: Universe -> [String] -listConfig u = lines $ unpack $ AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) $ u ^. uvConfig +listConfig = + lines + . unpack + . AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) + . _uvConfig displayControls :: Universe -> ScreenLayer --displayControls = const $ ColumnsScreen "CONTROLS" listControls -displayControls = titleOptionsNoWrite "CONTROLS" $ map (Toggle id . const . uncurry MODStringOption) listControls +displayControls = + titleOptionsNoWrite "CONTROLS" $ + map (Toggle id . const . uncurry MODStringOption) listControls listControls :: [(String, String)] listControls = [ ("w|a|s|d", "MOVEMENT") , ("", "AIM") , ("&", "SHOOT/USE/EQUIP SELECTED") - , ("", "USE EQUIPPED") +-- , ("", "USE EQUIPPED") , ("", "SELECT ITEM") , ("", "PICKUP ITEM") - , ("m", "DISPLAY MAP") , ("f", "DROP ITEM") + , ("q|e|0-9", "USE EQUIPMENT") , ("c", "COMBINE ITEMS") , ("x", "EXAMINE ITEMS") + , ("m", "DISPLAY MAP") , ("c|", "PAUSE AND DISPLAY MENU") - , ("q|e", "ROTATE CAMERA") , ("", "USE NORMAL CAMERA") , ("", "PAUSE AND FLOAT CAMERA") --- , ("", "PAUSE AND PAN CAMERA") , ("", "QUICKSAVE") , ("", "QUICKLOAD") ] diff --git a/src/Dodge/Menu/Loading.hs b/src/Dodge/Menu/Loading.hs index 2892bd542..b67fa4de9 100644 --- a/src/Dodge/Menu/Loading.hs +++ b/src/Dodge/Menu/Loading.hs @@ -9,7 +9,7 @@ loadingScreen str = OptionScreen { _scTitle = str , _scOptions = [] , _scOffset = 0 - , _scPositionedMenuOption = NoPositionedMenuOption + , _scPositionedMenuOption = NoEscapeMenuOption , _scOptionFlag = LoadingScreen , _scSelectionList = defaultSelectionList , _scAvailableLines = 0 diff --git a/src/Dodge/Menu/Option.hs b/src/Dodge/Menu/Option.hs index b226dd906..57ab3ca57 100644 --- a/src/Dodge/Menu/Option.hs +++ b/src/Dodge/Menu/Option.hs @@ -11,7 +11,7 @@ import LensHelp import Padding import Picture.Base -initializeOptionMenu :: String -> [MenuOption] -> PositionedMenuOption -> Universe -> ScreenLayer +initializeOptionMenu :: String -> [MenuOption] -> EscapeMenuOption -> Universe -> ScreenLayer initializeOptionMenu title ops pmo u = OptionScreen { _scTitle = title @@ -29,7 +29,7 @@ initializeOptionMenu title ops pmo u = initializeOptionMenuBO :: String -> [MenuOption] -> String -> (Universe -> Universe) -> Universe -> ScreenLayer initializeOptionMenuBO title ops str eff = initializeOptionMenu title ops pmo where - pmo = BottomMenuOption $ (Toggle eff . const . MODString) str + pmo = BottomEscapeMenuOption $ (Toggle eff . const . MODString) str refreshOptionsSelectionList :: Universe -> Universe refreshOptionsSelectionList u = u & uvScreenLayers . ix 0 %~ f @@ -48,7 +48,7 @@ makeOptionsSelectionList :: Maybe Int -> Universe -> [MenuOption] -> - PositionedMenuOption -> + EscapeMenuOption -> SelectionList (Universe -> Universe, Universe -> Universe) makeOptionsSelectionList maxlines mselpos u mos pmo = defaultSelectionList @@ -60,12 +60,12 @@ optionsToSelections :: Int -> Universe -> [MenuOption] -> - PositionedMenuOption -> + EscapeMenuOption -> [SelectionItem (Universe -> Universe, Universe -> Universe)] optionsToSelections maxlines u allops pmo = case pmo of - NoPositionedMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops - TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops) - BottomMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (ops ++ [mo]) + NoEscapeMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops + TopEscapeMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops) + BottomEscapeMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (ops ++ [mo]) where offset = fromMaybe 0 $ u ^? uvScreenLayers . _head . scOffset ops diff --git a/src/Dodge/Menu/OptionType.hs b/src/Dodge/Menu/OptionType.hs index abe32b805..34c3f1042 100644 --- a/src/Dodge/Menu/OptionType.hs +++ b/src/Dodge/Menu/OptionType.hs @@ -16,6 +16,7 @@ makeEnumOption lns str sideeff = (\u -> sideeff (u & uvConfig . lns #%~ cycleDownEnum)) (\u -> MODStringOption str (show (u ^# uvConfig . lns))) +makeSubmenuOption :: (Universe -> ScreenLayer) -> MenuOptionDisplay -> MenuOption makeSubmenuOption submenu t = Toggle (pushScreen submenu) (const t) cycleEnum :: (Eq a, Enum a, Bounded a) => a -> a diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 23f1918b4..14aba7f5d 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -361,10 +361,9 @@ openCursorAt wth col xoff yoff yint w = displayHP :: Int -> Configuration -> World -> Picture displayHP cid cfig = - translate (halfWidth cfig -80) (halfHeight cfig -20) + translate (halfWidth cfig) (halfHeight cfig -40) . scale 0.2 0.2 - . text - . leftPad 5 ' ' + . textJustifyRight . show . (^?! cWorld . lWorld . creatures . ix cid . crHP) diff --git a/src/Dodge/Update/Input/ScreenLayer.hs b/src/Dodge/Update/Input/ScreenLayer.hs index 1d1642cb1..e1cb3907d 100644 --- a/src/Dodge/Update/Input/ScreenLayer.hs +++ b/src/Dodge/Update/Input/ScreenLayer.hs @@ -2,12 +2,10 @@ module Dodge.Update.Input.ScreenLayer ( updateUseInputOnScreen, ) where -import Linear -import Dodge.Data.ScreenPos import Control.Monad import qualified Data.Map.Strict as M import Data.Maybe -import Dodge.Base.Window +import Dodge.Data.ScreenPos import Dodge.Data.Universe import Dodge.Debug.Terminal import Dodge.Menu.Option @@ -15,25 +13,26 @@ import Dodge.SelectionList import Dodge.Update.Input.Text import Geometry import LensHelp +import Linear import SDL updateUseInputOnScreen :: ScreenLayer -> Universe -> Universe updateUseInputOnScreen sl = case sl of - InputScreen thetext _ -> doInputScreenInput thetext - screen -> optionScreenUpdate screen + InputScreen{} -> doInputScreenInput (sl ^. scInput) + _ -> optionScreenUpdate sl doInputScreenInput :: String -> Universe -> Universe doInputScreenInput s u = u & doTextInputOver (uvScreenLayers . _head . scInput) & checkEndStatus where - pkeys = u ^. uvWorld . input . pressedKeys + ispressed = (`M.member` (u ^. uvWorld . input . pressedKeys)) checkEndStatus - | ScancodeReturn `M.member` pkeys = + | ispressed ScancodeReturn = (uvScreenLayers %~ tail) . applyTerminalString (words s) . (uvWorld . worldEventFlags . at InventoryChange ?~ ()) - | ScancodeEscape `M.member` pkeys = uvScreenLayers %~ tail + | ispressed ScancodeEscape = uvScreenLayers %~ tail | otherwise = id optionScreenUpdate :: @@ -53,10 +52,16 @@ optionScreenUpdate screen u = mop = _scPositionedMenuOption screen ldps = _scListDisplayParams screen -optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe -optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of - Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u - _ -> u +optionScreenDefaultEffect :: EscapeMenuOption -> Universe -> Universe +optionScreenDefaultEffect f u = + fromMaybe + id + ( do + ptype <- u ^. uvWorld . input . pressedKeys . at ScancodeEscape + guard $ ptype == InitialPress + f ^? emoMenuOption . moEff + ) + u -- ouch this is not good mouseClickOptionsList :: ScreenLayer -> Universe -> Universe @@ -81,36 +86,40 @@ mouseOverSelectionList :: Universe mouseOverSelectionList ldps screen u = fromMaybe u $ do yi <- ldpVerticalSelection (u ^. uvConfig) ldps (u ^. uvWorld . input . mousePos) - guard $ (mmoving || (_scDisplayTime screen <= 1)) - && isselectable yi - && yi >= 0 - && yi < ymax --- && x > xl && x < xr + guard $ + (mmoving || (_scDisplayTime screen <= 1)) + && isselectable yi + && yi >= 0 + && yi < ymax + -- && x > xl && x < xr return $ u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yi --- | x > xl && x < xr --- && ylower == yupper --- && (mmoving || (_scDisplayTime screen <= 1)) -- slight hack --- && isselectable = --- u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper --- | otherwise = u where + -- | x > xl && x < xr + -- && ylower == yupper + -- && (mmoving || (_scDisplayTime screen <= 1)) -- slight hack + -- && isselectable = + -- u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper + -- | otherwise = u + sl = _scSelectionList screen isselectable yi = fromMaybe False $ u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yi . siIsSelectable ymax = maybe 0 length $ sl ^? slItems mmoving = u ^. uvWorld . input . mouseMoving + -- ylower = ceiling $ (hh - (75 + y + _ldpPosY ldps)) / 50 -- yupper = floor $ (hh - (15 + y + _ldpPosY ldps)) / 50 -- xl = _ldpPosX ldps - hw -- xr = xl + _ldpScale ldps * 26 * 9 - V2 _ y = u ^. uvWorld . input . mousePos - cfig = u ^. uvConfig - hh = halfHeight cfig - hw = halfWidth cfig +-- V2 _ y = u ^. uvWorld . input . mousePos +-- cfig = u ^. uvConfig +-- hh = halfHeight cfig +-- hw = halfWidth cfig ldpVerticalSelection :: Configuration -> ListDisplayParams -> Point2 -> Maybe Int -ldpVerticalSelection cfig ldp (V2 _ y) | yupper == ylower = Just yupper +ldpVerticalSelection cfig ldp (V2 _ y) + | yupper == ylower = Just yupper | otherwise = Nothing where winy = cfig ^. windowY diff --git a/src/Picture/Base.hs b/src/Picture/Base.hs index 8e78d570d..86f6ecd17 100644 --- a/src/Picture/Base.hs +++ b/src/Picture/Base.hs @@ -25,6 +25,8 @@ module Picture.Base ( line, lineCol, text, + textJustifyRight, + textVMirror, drawText, centerText, stackText, @@ -45,7 +47,6 @@ module Picture.Base ( mirrorxz, overPos, picMap, - vMirrorText, ) where import Color @@ -200,15 +201,19 @@ stackText :: [String] -> Picture {-# INLINE stackText #-} stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..] +textJustifyRight :: String -> Picture +{-# INLINE textJustifyRight #-} +textJustifyRight str = translate ((-100) * fromIntegral (length str)) 0 $ text str + text :: String -> Picture {-# INLINE text #-} --text = translate (-50) (-100) . drawText (-10) text = drawText 0 --text = drawText (-10) -vMirrorText :: String -> Picture -{-# INLINE vMirrorText #-} -vMirrorText = translate 0 200 . scale 1 (-1) . text +textVMirror :: String -> Picture +{-# INLINE textVMirror #-} +textVMirror = translate 0 200 . scale 1 (-1) . text drawText :: Float -> String -> [Verx] {-# INLINE drawText #-}