Reorganise update-input-gamestate structure

2023-02-23 11:47:05 +00:00
parent fc0fd5fa37
commit d513914886
3 changed files with 397 additions and 0 deletions
@@ -0,0 +1,115 @@
+module Dodge.Update.Input.ScreenLayer (
+    updateUseInputOnScreen,
+) where
+
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import Dodge.Base.Window
+import Dodge.Data.Universe
+import Dodge.Debug.Terminal
+import Dodge.Menu.Option
+import Dodge.SelectionList
+import Dodge.Update.Input.Text
+import Geometry
+import LensHelp
+import SDL
+
+updateUseInputOnScreen :: ScreenLayer -> Universe -> Universe
+updateUseInputOnScreen sl = case sl of
+    InputScreen thetext _ -> doInputScreenInput thetext
+    screen@OptionScreen{_scPositionedMenuOption = mop, _scSelectionList = sellist, _scListDisplayParams = ldps} ->
+        optionScreenUpdate screen mop ldps sellist
+
+doInputScreenInput :: String -> Universe -> Universe
+doInputScreenInput s u =
+    u & doTextInputOver (uvScreenLayers . _head . scInput)
+        & checkEndStatus
+  where
+    pkeys = u ^. uvWorld . input . pressedKeys
+    checkEndStatus
+        | ScancodeReturn `M.member` pkeys =
+            (uvScreenLayers %~ tail)
+                . applyTerminalString (words s)
+                . (uvWorld . worldEventFlags . at InventoryChange ?~ ())
+        | ScancodeEscape `M.member` pkeys = uvScreenLayers %~ tail
+        | otherwise = id
+
+optionScreenUpdate ::
+    ScreenLayer ->
+    PositionedMenuOption ->
+    ListDisplayParams ->
+    SelectionList (Universe -> Universe) ->
+    Universe ->
+    Universe
+optionScreenUpdate screen mop ldps sl u =
+    refreshOptionsSelectionList
+        . optionScreenDefaultEffect mop
+        . mouseClickOptionsList screen
+        . mouseOverSelectionList ldps sl
+        . menuWheelEvents
+        . over (uvScreenLayers . _head) (setSelectionListRestriction (u ^. uvConfig))
+        $ u
+
+optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe
+optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
+    Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
+    _ -> u
+
+mouseClickOptionsList :: ScreenLayer -> Universe -> Universe
+mouseClickOptionsList screen u = fromMaybe u $ do
+    sl <- screen ^? scSelectionList
+    Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
+        Just False -> fromMaybe u $ do
+            i <- sl ^. slSelPos
+            f <- sl ^? slItems . ix i . siPayload
+            return $ f u
+        _ -> u
+
+mouseOverSelectionList :: ListDisplayParams -> SelectionList (Universe -> Universe) -> Universe -> Universe
+mouseOverSelectionList ldps sl u
+    | x > xl && x < xr
+        && ylower == yupper
+        && mmoving
+        && ylower >= 0
+        && ylower < ymax
+        && isselectable =
+        u & uvScreenLayers . _head . scSelectionList . slSelPos ?~ yupper
+    | otherwise = u
+  where
+    isselectable =
+        fromMaybe False $
+            u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . 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 * 15 * 9
+    xr = xl + _ldpScale ldps * 26 * 9
+    V2 x y = u ^. uvWorld . input . mousePos
+    cfig = u ^. uvConfig
+    hh = halfHeight cfig
+    hw = halfWidth cfig
+
+menuWheelEvents :: Universe -> Universe
+menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
+  where
+    y = u ^. uvWorld . input . scrollAmount
+
+-- you probably want i to be 1 or -1
+menuWheelStep :: Int -> Universe -> Universe
+menuWheelStep i u = fromMaybe u $ do
+    sl <- u ^? uvScreenLayers . _head . scSelectionList
+    selpos <- sl ^? slSelPos . _Just
+    ymax <- fmap length (sl ^? slItems)
+    let newpos = (selpos - i) `mod` ymax
+    itm <- sl ^? slItems . ix newpos
+    let newu = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ const newpos
+    if _siIsSelectable itm
+        then Just newu
+        else Just $ menuWheelStep i newu
+
+setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
+setSelectionListRestriction cfig screen = fromMaybe screen $ do
+    ldps <- screen ^? scListDisplayParams
+    return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)