Work on inventory selection list

2022-12-25 19:00:19 +00:00
parent b01a9f89e6
commit 2ae7f2bbc1
5 changed files with 74 additions and 65 deletions
@@ -5,13 +5,15 @@

 module Dodge.Data.HUD where

+--import Dodge.Data.SelectionList
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
 import Geometry.Data

 data HUDElement
-    = DisplayInventory {_subInventory :: SubInventory}
+    = DisplayInventory 
+        { _subInventory :: SubInventory}
    | DisplayCarte
    deriving (Eq, Ord, Show, Read) --Generic, Flat)

@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.Data.SelectionList where
@@ -6,6 +8,8 @@ import Picture.Data
 import Control.Lens
 import Data.Set (Set)
 import Dodge.Data.CardinalPoint
+import Data.Aeson
+import Data.Aeson.TH

 data ListDisplayParams = ListDisplayParams
    { _ldpPosX :: Float
@@ -43,3 +47,4 @@ data SelectionItem a = SelectionItem
 makeLenses ''ListDisplayParams
 makeLenses ''SelectionList
 makeLenses ''SelectionItem
+deriveJSON defaultOptions ''SelectionItem
@@ -8,7 +8,6 @@ module Dodge.Inventory (
    selNumPos,
    selNumTextPos,
    selNumCol,
-    selNumSlots,
    selNumMidHeight,
    augmentedInvSizes,
    rmInvItem,
@@ -23,6 +22,7 @@ module Dodge.Inventory (
    crNumFreeSlots,
    crInvSize,
    selectedCloseObject,
+    invDimColor,
 ) where

 import Color
@@ -96,13 +96,16 @@ rmSelectedInvItem :: Int -> World -> World
 rmSelectedInvItem cid w = rmInvItem cid (crSel (w ^?! cWorld . lWorld . creatures . ix cid)) w

 augmentedInvSizes :: World -> IM.IntMap Int
-augmentedInvSizes = bimapAugmentInv itSlotsTaken closeObjectSize
+augmentedInvSizes = trimapAugmentInv itSlotsTaken 1 closeObjectSize

-bimapAugmentInv :: (Item -> a) -> (Either FloorItem Button -> a) -> World -> IM.IntMap a
-bimapAugmentInv f g w =
+trimapAugmentInv :: (Item -> a) -> a -> (Either FloorItem Button -> a) -> World -> IM.IntMap a
+trimapAugmentInv f x g w =
+    IM.insert n x $
    IM.union
        (f <$> yourInv w)
-        (IM.fromAscList $ zip [length (yourInv w) ..] $ map g $ w ^. cWorld . lWorld . closeObjects)
+        (IM.fromAscList $ zip [n + 1 ..] $ map g $ w ^. cWorld . lWorld . closeObjects)
+  where
+    n = length $ yourInv w

 invSelSize :: Int -> World -> Int
 invSelSize i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i
@@ -117,15 +120,12 @@ closeObjectCol e = case e of
    Left flit -> _itInvColor $ _flIt flit
    Right _ -> yellow

-selNumSlots :: Int -> World -> Int
-selNumSlots i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i
-
 selNumPos :: Int -> World -> Int
 selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w))
  where
-    splitgap
-        | i < length (yourInv w) = 0
-        | otherwise = 1
+    splitgap = 0
+--        | i < length (yourInv w) = 0
+--        | otherwise = 1

 selNumTextPos :: Configuration -> World -> Int -> Point2
 selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20))
@@ -140,18 +140,22 @@ selNumMidHeight cfig w i = V2 (150 - hw) (hh + bump - (20 * fromIntegral ipos +
    hh = halfHeight cfig
    hw = halfWidth cfig
    ipos = selNumPos i w
-    bump = negate $ 10 * fromIntegral (selNumSlots i w)
+    bump = negate $ 10 * fromIntegral (invSelSize i w)

 selNumCol :: Int -> World -> Color
-selNumCol i w = fromMaybe white $ bimapAugmentInv _itInvColor closeObjectCol w IM.!? i
+selNumCol i w = fromMaybe white $ trimapAugmentInv _itInvColor invDimColor closeObjectCol w IM.!? i
+
+invDimColor :: Color
+invDimColor = greyN 0.7

 invSelPos :: World -> Int
 invSelPos w = splitgap + (foldl' (+) 0 . fst $ IM.split invsel (augmentedInvSizes w))
  where
    invsel = yourInvSel w
-    splitgap
-        | invsel < length (yourInv w) = 0
-        | otherwise = 1
+    splitgap = 0
+--    splitgap
+--        | invsel < length (yourInv w) = 0
+--        | otherwise = 1

 updateTerminal :: World -> World
 updateTerminal = checkTermDist
@@ -172,7 +176,8 @@ updateCloseObjects w =
        & cWorld . lWorld . creatures . ix 0 . crInvSel . iselPos %~ updateinvsel
  where
    updateinvsel curinvsel
-        | length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w) - 1
+        -- | length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w) - 1
+        | length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w)
        | otherwise = curinvsel
    filt = filter $ \obj -> dist ypos (closeObjPos obj) < 40 && hasButtonLOS ypos (closeObjPos obj) w
    ypos = _crPos $ you w
@@ -371,7 +376,7 @@ changeAugInvSel i w
            & cWorld . lWorld . creatures . ix 0 . crInvSel . iselPos %~ (`mod` n) . subtract i
            & cWorld . lWorld . creatures . ix 0 . crInvSel . iselAction .~ NoInvSelAction
  where
-    n = length (yourInv w) + length (w ^. cWorld . lWorld . closeObjects)
+    n = length (yourInv w) + length (w ^. cWorld . lWorld . closeObjects) + 1

 bestCloseObjectIndex :: World -> Maybe Int
 bestCloseObjectIndex w = findIndex f $ w ^. cWorld . lWorld . closeObjects
@@ -382,7 +387,7 @@ bestCloseObjectIndex w = findIndex f $ w ^. cWorld . lWorld . closeObjects

 selectedCloseObject :: World -> Maybe (Int, Either FloorItem Button)
 selectedCloseObject w
-    | invsel >= length inv = selectNthCloseObject w (invsel - length inv)
+    | invsel >= (length inv + 1) = selectNthCloseObject w (invsel - (length inv + 1))
    | otherwise = selectNthCloseObject w =<< bestCloseObjectIndex w
  where
    invsel = crSel cr
@@ -85,7 +85,7 @@ subInvSelectionList = SelectionList

 inventorySelectionList :: World -> [SelectionItem ()]
 inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
-    ++ [SelectionItem displayFreeSlots 1 False (length thetext) white 0 ()]
+    ++ [SelectionItem displayFreeSlots 1 True (length thetext) invDimColor 2 ()]
            ++ map (closeObjectToSelectionItem nfreeslots) (w ^. cWorld . lWorld . closeObjects)
  where
    cr = you w
@@ -312,7 +312,7 @@ topCursorTypeWidth ::
    Int ->
    Picture
 topCursorTypeWidth ctype width cfig w i =
-    ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (selNumSlots i w)
+    ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (invSelSize i w)

 determineInvSelCursorWidth :: World -> Int
 determineInvSelCursorWidth w = case _rbOptions w of
@@ -355,8 +355,6 @@ invHead cfig s =
        . scale 0.4 0.4
        $ text s

-invDimColor :: Color
-invDimColor = greyN 0.7

 closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem ()
 closeObjectToSelectionItem n e = SelectionItem
@@ -6,22 +6,19 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where

--import Dodge.Menu.Option
-import Dodge.Menu.Option
-import Dodge.SelectionList
-import Dodge.Data.SelectionList
-import Dodge.InputFocus
 import Color
 import Control.Applicative
 import Data.List
 import qualified Data.Map.Strict as M
 import Data.Maybe
+import qualified Data.Text as T
 import Dodge.Base
 import Dodge.Beam
 import Dodge.Bullet
 import Dodge.CrGroupUpdate
 import Dodge.Creature.Update
 import Dodge.CullBox
+import Dodge.Data.SelectionList
 import Dodge.Data.Universe
 import Dodge.Distortion
 import Dodge.DrWdWd
@@ -29,6 +26,7 @@ import Dodge.EnergyBall
 import Dodge.Flame
 import Dodge.Flare
 import Dodge.Hammer
+import Dodge.InputFocus
 import Dodge.Inventory
 import Dodge.Item.Location
 import Dodge.Laser.Update
@@ -37,6 +35,7 @@ import Dodge.LinearShockwave.Update
 import Dodge.Machine.Update
 import Dodge.Magnet.Update
 import Dodge.Menu
+import Dodge.Menu.Option
 import Dodge.ModificationEffect
 import Dodge.PosEvent
 import Dodge.PressPlate
@@ -44,6 +43,7 @@ import Dodge.Projectile.Update
 import Dodge.Prop.Update
 import Dodge.RadarBlip
 import Dodge.RadarSweep
+import Dodge.SelectionList
 import Dodge.Shockwave.Update
 import Dodge.SoundLogic
 import Dodge.Spark
@@ -62,12 +62,9 @@ import Dodge.Zoning.Creature
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
--import MaybeHelp
 import SDL
 import Sound.Data
 import StrictHelp
-import qualified Data.Text as T
--import ListHelp

 updateUniverse :: Universe -> Universe
 updateUniverse u =
@@ -95,23 +92,27 @@ gotoTerminal w = case _uvScreenLayers w of

 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
+    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
+        && 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 
+    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
@@ -130,27 +131,30 @@ setSelectionListRestriction' cfig screen = fromMaybe screen $ do
 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
--    Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
+    Just screen@OptionScreen{_scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps} ->
+        optionScreenUpdate screen mop flag ldps sellist u
    _ -> case u ^? uvWorld . cWorld . lWorld . hud . hudElement . subInventory of
        Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid 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 = 
+optionScreenUpdate ::
+    ScreenLayer ->
+    PositionedMenuOption ->
+    OptionScreenFlag ->
+    ListDisplayParams ->
+    SelectionList (Universe -> Universe) ->
+    Universe ->
+    Universe
+optionScreenUpdate screen mop _ ldps sl u =
    refreshOptionsSelectionList
-    . optionScreenDefEff mop
-    . mouseClickOptionsList screen
-    . mouseOverSelectionList ldps sl
-    . menuWheelEvents
-    . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig)
-    $ u
+        . optionScreenDefEff mop
+        . mouseClickOptionsList screen
+        . mouseOverSelectionList ldps sl
+        . menuWheelEvents
+        . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig)
+        $ u
  where
    cfig = u ^. uvConfig

@@ -291,12 +295,7 @@ functionalUpdate w =
        . over uvWorld updateWheelEvents
        $ over uvWorld updatePastWorlds w

--menuWheelEvents :: Universe -> Universe
--menuWheelEvents u = u & uvScreenLayers . _head . scSelectionList . slSelPos . _Just %~ (\y' -> (y' - y) `mod` ymax)
--  where
--    ymax = max 1 $ maybe 1 length (u ^? uvScreenLayers . _head . scSelectionList . slItems)
--    y = u ^. uvWorld . input . scrollAmount
-
+-- this can probably be unified with updateWheelEvents
 menuWheelEvents :: Universe -> Universe
 menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
  where
@@ -306,13 +305,13 @@ menuWheelEvents u = foldr ($) u (replicate (abs y) (menuWheelStep (signum y)))
 menuWheelStep :: Int -> Universe -> Universe
 menuWheelStep i u = fromMaybe u $ do
    sl <- u ^? uvScreenLayers . _head . scSelectionList
-    selpos <- sl ^? slSelPos . _Just 
+    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 
+        then Just newu
        else Just $ menuWheelStep i newu

 updateWheelEvents :: World -> World