Cleanup

src/Dodge/Data/Universe.hs

@@ -69,17 +69,17 @@ data OptionScreenFlag = NormalOptions | GameOverOptions | SplashOptions
     | LoadingScreen
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
-data PositionedMenuOption
+data EscapeMenuOption
-    = BottomMenuOption { _pmoMenuOption :: MenuOption }
+    = BottomEscapeMenuOption { _emoMenuOption :: MenuOption }
-    | TopMenuOption { _pmoMenuOption :: MenuOption }
+    | TopEscapeMenuOption { _emoMenuOption :: MenuOption }
-    | NoPositionedMenuOption
+    | 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

src/Dodge/DisplayInventory.hs

@@ -186,16 +186,15 @@ updateSection ::
     SelectionSection a
 updateSection sis mcsel availablelines ss =
     ss
-        { _ssItems = sis
+        & ssItems .~ sis
-        , _ssCursor = scurs
+        & ssCursor .~ scurs
-        , _ssOffset = offset
+        & ssOffset .~ offset
-        , _ssShownItems = shownitems
+        & 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

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
+pauseMenu =
-  where
+    initializeOptionMenu "PAUSED" pauseMenuOptions $
-    pmo = TopMenuOption $ Toggle unpause (const (MODString "CONTINUE"))
+        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 =
+gameplayMenuOptions = [makeBoolOption gameplay_rotate_to_wall "ROTATE TO WALL"]
-    [ 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")
     , ("<rmb>", "AIM")
     , ("<rmb>&<lmb>", "SHOOT/USE/EQUIP SELECTED")
-    , ("<lmb>", "USE EQUIPPED")
+--    , ("<lmb>", "USE EQUIPPED")
     , ("<wheelscroll>", "SELECT ITEM")
     , ("<space>", "PICKUP ITEM")
-    , ("m", "DISPLAY MAP")
     , ("f", "DROP ITEM")
+    , ("q|e|0-9", "USE EQUIPMENT")
     , ("c", "COMBINE ITEMS")
     , ("x", "EXAMINE ITEMS")
+    , ("m", "DISPLAY MAP")
     , ("c|<esc>", "PAUSE AND DISPLAY MENU")
-    , ("q|e", "ROTATE CAMERA")
     , ("<F1>", "USE NORMAL CAMERA")
     , ("<F2>", "PAUSE AND FLOAT CAMERA")
---    , ("<F3>", "PAUSE AND PAN CAMERA")
     , ("<F5>", "QUICKSAVE")
     , ("<F9>", "QUICKLOAD")
     ]

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

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
+    NoEscapeMenuOption -> map (menuOptionToSelectionItem u maxOptionLength) ops
-    TopMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops)
+    TopEscapeMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (mo : ops)
-    BottomMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (ops ++ [mo])
+    BottomEscapeMenuOption mo -> map (menuOptionToSelectionItem u maxOptionLength) (ops ++ [mo])
   where
     offset = fromMaybe 0 $ u ^? uvScreenLayers . _head . scOffset
     ops

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

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
+        . textJustifyRight
-        . leftPad 5 ' '
         . show
         . (^?! cWorld . lWorld . creatures . ix cid . crHP)
 

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
+    InputScreen{} -> doInputScreenInput (sl ^. scInput)
-    screen -> optionScreenUpdate screen
+    _ -> 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 :: EscapeMenuOption -> Universe -> Universe
-optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
+optionScreenDefaultEffect f u =
-    Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
+    fromMaybe
-    _ -> u
+        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))
+    guard $
+        (mmoving || (_scDisplayTime screen <= 1))
             && isselectable yi
             && yi >= 0
             && yi < ymax
     --      && x > xl && x < xr
     return $ u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yi
+  where
     --    | x > xl && x < xr
     --        && ylower == yupper
     --        && (mmoving || (_scDisplayTime screen <= 1)) -- slight hack
     --        && isselectable =
     --        u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
     --    | otherwise = u
-  where
+
     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
+--    V2 _ y = u ^. uvWorld . input . mousePos
-    cfig = u ^. uvConfig
+--    cfig = u ^. uvConfig
-    hh = halfHeight cfig
+--    hh = halfHeight cfig
-    hw = halfWidth 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

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
+textVMirror :: String -> Picture
-{-# INLINE vMirrorText #-}
+{-# INLINE textVMirror #-}
-vMirrorText = translate 0 200 . scale 1 (-1) . text
+textVMirror = translate 0 200 . scale 1 (-1) . text
 
 drawText :: Float -> String -> [Verx]
 {-# INLINE drawText #-}