Shuffle functions

2023-02-19 11:57:45 +00:00
parent 2b0b54f1cd
commit 9109841658
3 changed files with 105 additions and 95 deletions
@@ -20,7 +20,7 @@ import qualified SDL
 yourControl :: Creature -> World -> World
 yourControl cr w
    | inputFocus w = w
-    | intopinv = w & cWorld . lWorld . creatures . ix (_crID cr)
+    | not intopinv = w & cWorld . lWorld . creatures . ix (_crID cr)
                %~ wasdWithAiming w (_mvSpeed $ _crMvType cr)    
    | otherwise =
        w
@@ -96,86 +96,10 @@ gotoTerminal w = case _uvScreenLayers w of
    (InputScreen{} : _) -> w
    _ -> w & uvScreenLayers .:~ InputScreen mempty "Enter command"

-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

-setSelectionListRestriction :: Configuration -> ScreenLayer -> ScreenLayer
-setSelectionListRestriction cfig screen = fromMaybe screen $ do
-    ldps <- screen ^? scListDisplayParams
-    return $ screen & scAvailableLines %~ const (getAvailableListLines ldps cfig)

-updateUseInput :: Universe -> Universe
-updateUseInput u = case u ^? uvScreenLayers . _head of
-    Just (InputScreen thetext _) -> doInputScreenInput thetext u
-    Just screen@OptionScreen{_scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps} ->
-        optionScreenUpdate screen mop flag ldps sellist u
-    _ -> case u ^? uvWorld . hud . hudElement . subInventory of
-        Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u
-        Just (CombineInventory _ _ _)
-            | inSubInvRegex (u ^. uvWorld) -> doSubInvRegexInput u
-        -- _ | inInvRegex (u ^. uvWorld) -> doInvRegexInput u
-        _ | inInvRegex (u ^. uvWorld) -> doRegexInput (-1) invRegex invRegex u
-        _ | inCloseRegex (u ^. uvWorld) -> doRegexInput 2 closeRegex closeRegex u
-        _ -> M.foldlWithKey' updateKeyInGame u pkeys
-  where
-    pkeys = u ^. uvWorld . input . pressedKeys

-optionScreenUpdate ::
-    ScreenLayer ->
-    PositionedMenuOption ->
-    OptionScreenFlag ->
-    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 cfig)
-        $ u
-  where
-    cfig = u ^. uvConfig
-
-optionScreenDefaultEffect :: PositionedMenuOption -> Universe -> Universe
-optionScreenDefaultEffect f u = case u ^. uvWorld . input . pressedKeys . at ScancodeEscape of
-    Just InitialPress -> fromMaybe id (f ^? pmoMenuOption . moEff) u
-    _ -> u

 updateUniverseLast :: Universe -> Universe
 updateUniverseLast =
@@ -323,23 +247,6 @@ functionalUpdate w =
 --    & cWorld . lWorld . hud . hudElement . augmentedInventory .~ makeInventorySelectionList w

 -- this can probably be unified with updateWheelEvents
-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

 --updateWheelEvents :: World -> World
 --updateWheelEvents w = foldr ($) w (replicate (abs y) (updateWheelEvent (signum y)))
@@ -4,8 +4,13 @@ module Dodge.Update.Input (
    doInputScreenInput,
    doSubInvRegexInput,
    doRegexInput,
+    updateUseInput,
 ) where

+import Dodge.SelectionList
+import Dodge.Base.Window
+import Dodge.Menu.Option
+import Dodge.InputFocus
 import Dodge.SelectionSections
 import Dodge.Default.World
 import Data.Char
@@ -29,7 +34,22 @@ import Dodge.Terminal.LeftButton
 import Dodge.WorldPos
 import LensHelp
 import SDL
--import SelectionIntMap
+
+updateUseInput :: Universe -> Universe
+updateUseInput u = case u ^? uvScreenLayers . _head of
+    Just (InputScreen thetext _) -> doInputScreenInput thetext u
+    Just screen@OptionScreen{_scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps} ->
+        optionScreenUpdate screen mop flag ldps sellist u
+    _ -> case u ^? uvWorld . hud . hudElement . subInventory of
+        Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u
+        Just (CombineInventory _ _ _)
+            | inSubInvRegex (u ^. uvWorld) -> doSubInvRegexInput u
+        -- _ | inInvRegex (u ^. uvWorld) -> doInvRegexInput u
+        _ | inInvRegex (u ^. uvWorld) -> doRegexInput (-1) invRegex invRegex u
+        _ | inCloseRegex (u ^. uvWorld) -> doRegexInput 2 closeRegex closeRegex u
+        _ -> M.foldlWithKey' updateKeyInGame u pkeys
+  where
+    pkeys = u ^. uvWorld . input . pressedKeys

 doTextInputOver :: ASetter' Universe String -> Universe -> Universe
 doTextInputOver p u =
@@ -268,3 +288,86 @@ toggleTweakInv w = case w ^? hud . hudElement . subInventory of
  where
    thepointer = hud . hudElement . subInventory
    mi = 0 <$ (yourItem w >>= (^? itTweaks . tweakParams . ix 0))
+
+optionScreenUpdate ::
+    ScreenLayer ->
+    PositionedMenuOption ->
+    OptionScreenFlag ->
+    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 cfig)
+        $ u
+  where
+    cfig = u ^. uvConfig
+
+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)