Highlight moused-over inventory items

2024-10-16 22:14:11 +01:00
parent cf0873d73b
commit d256bc0443
9 changed files with 214 additions and 148 deletions
@@ -22,7 +22,7 @@ data HUDElement
 data SubInventory
    = NoSubInventory
        { _nsSelected :: Maybe (Int,Int) 
-        , _nsMouseOver :: Maybe Int
+        , _nsMouseOver :: Maybe (Int,Int)
        }
    | ExamineInventory
    | CombineInventory { _ciSections :: SelectionSections CombinableItem }
@@ -161,7 +161,7 @@ defaultHUD =
 defaultDisplayInventory :: HUDElement
 defaultDisplayInventory =
    DisplayInventory
-        { _subInventory = NoSubInventory {_nsSelected = Just (0,2), _nsMouseOver = Just 3}
+        { _subInventory = NoSubInventory {_nsSelected = Just (0,2), _nsMouseOver = Just (0,3)}
        , _diSections = defaultInvSections
        }

@@ -5,6 +5,7 @@ module Dodge.Render.HUD (
    selNumPos, -- this shoud probably be pushed back here
 ) where

+import Dodge.SelectionSections
 import Control.Lens
 import Control.Monad
 import qualified Data.Map.Strict as M
@@ -58,9 +59,13 @@ drawHP cfig =

 drawInventory :: SelectionSections () -> World -> Configuration -> Picture
 drawInventory sss w cfig =
-    drawSelectionSections sss (invDisplayParams w) cfig
+    drawSelectionSections sss ldp cfig
        <> iextra
+        <> translateScreenPos cfig (ldp ^. ldpPos)
+            (drawDIMouseOver w)
+        <> drawDISelections w cfig
  where
+    ldp = invDisplayParams w
    iextra = fromMaybe mempty $ do
        inv <- w ^? cWorld . lWorld . creatures . ix 0 . crInv
        let x = case invAdj inv of
@@ -68,6 +73,23 @@ drawInventory sss w cfig =
                Right y -> y
        return $ inventoryExtra sss cfig w x

+drawDIMouseOver :: World -> Picture
+drawDIMouseOver w = fromMaybe mempty $ do
+    (_,i) <- w ^? hud . hudElement . subInventory . nsMouseOver . _Just
+    sss <- w ^? hud . hudElement . diSections
+    let idp = invDisplayParams w
+    return . color (withAlpha 0.5 white) $ selSecDrawCursorAt (0,i) 10 idp sss
+
+drawDISelections :: World -> Configuration -> Picture
+drawDISelections w cfig = fromMaybe mempty $ do
+    (i,j) <- w ^? hud . hudElement . subInventory . nsSelected . _Just
+    sss <- w ^? hud . hudElement . diSections
+    let idp = invDisplayParams w
+    tp <- selNumPos cfig idp sss 0 i
+    bp <- selNumPos cfig idp sss 0 j
+    return . color red $ line [tp,bp]
+
+
 drawSubInventory :: SubInventory -> Configuration -> World -> Picture
 drawSubInventory subinv cfig w = case subinv of
    LockedInventory -> mempty -- topInvCursor col cursPos cfig w
@@ -344,5 +366,8 @@ selNumPos cfig ldp sss i j = do
    s = _ldpScale ldp
    ygap = _ldpVerticalGap ldp

+
+
+
 selSecSelCol :: Int -> Int -> SelectionSections a -> Maybe Color
 selSecSelCol i j sss = sss ^? sssSections . ix i . ssItems . ix j . siColor
@@ -2,8 +2,6 @@ module Dodge.Render.ShapePicture (
    worldSPic,
 ) where

-import Dodge.Render.HUD
-import Dodge.ListDisplayParams
 import qualified Data.Map.Strict as M
 import Control.Lens
 import Control.Monad (guard)
@@ -40,8 +38,6 @@ worldSPic cfig u =
        <> foldup mcSPic (filtOn _mcPos _machines)
        <> aimDelaySweep w
        <> drawMouseSelection w
-        <> drawDISelections w cfig
-        <> drawDIMouseOver w cfig
  where
    w = _uvWorld u
    foldup = foldMap'
@@ -57,22 +53,6 @@ drawMouseSelection w = fromMaybe mempty $ do
    return $ noShape $ color (withAlpha 0.5 white) 
        $ setLayer FixedCoordLayer $ polygon $ reverse $ rectVV p (w ^. input . mousePos)

-drawDIMouseOver :: World -> Configuration -> SPic
-drawDIMouseOver w cfig = fromMaybe mempty $ do
-    i <- w ^? hud . hudElement . subInventory . nsMouseOver . _Just
-    sss <- w ^? hud . hudElement . diSections
-    let idp = invDisplayParams w
-    return . noShape . setLayer FixedCoordLayer . color white $ selSecDrawCursorAt (0,i) 10 idp sss
-
-drawDISelections :: World -> Configuration -> SPic
-drawDISelections w cfig = fromMaybe mempty $ do
-    (i,j) <- w ^? hud . hudElement . subInventory . nsSelected . _Just
-    sss <- w ^? hud . hudElement . diSections
-    let idp = invDisplayParams w
-    tp <- selNumPos cfig idp sss 0 i
-    bp <- selNumPos cfig idp sss 0 j
-    return . noShape . setLayer FixedCoordLayer . color red $ line [tp,bp]
-
 aimDelaySweep :: World -> SPic
 aimDelaySweep w = fromMaybe mempty $ do
    cr <- w ^? cWorld . lWorld . creatures . ix 0
@@ -157,8 +137,6 @@ extraPics cfig u =
        <> foldMap drawBul (_bullets lw)
        <> foldMap drawBlip (_radarBlips lw)
        <> _flares lw
-        --        <> foldMap (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams lw)
-        --        <> foldMap (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams lw)
        <> foldMap (dbArg (drawLightSource . _lsPict)) (_lightSources lw)
        <> testPic cfig w
        <> foldMap ppDraw (_pressPlates lw)
@@ -6,8 +6,13 @@ module Dodge.SelectionSections (
    setFirstPosSelectionSections,
    selSecYint,
    selSecSelSize,
+    inverseSelNumPos,
 ) where

+import qualified Control.Foldl as L
+import Dodge.ScreenPos
+import Geometry.Data
+import Dodge.Data.Config
 import Control.Applicative
 import Control.Lens
 import qualified Data.IntMap.Strict as IM
@@ -124,6 +129,12 @@ ssLookupGE' i sss = do
 selSecSelSize :: Int -> Int -> SelectionSections a -> Maybe Int
 selSecSelSize i j sss = fmap length $ sss ^? sssSections . ix i . ssItems . ix j . siPictures

+-- need to check that the vertical gap is correctly put in here
+posSelSecYint :: Configuration -> ListDisplayParams -> Point2 -> Int
+posSelSecYint cfig ldp (V2 _ y) = floor $ (y0 - y) / (20 / ldp ^. ldpScale + ldp ^. ldpVerticalGap)
+  where
+    V2 _ y0 = screenPosAbs cfig (ldp ^. ldpPos)
+
 selSecYint :: Int -> Int -> SelectionSections a -> Maybe Int
 selSecYint i j sss = do
    ss <- sss ^? sssSections . ix i
@@ -136,5 +147,37 @@ selSecYint i j sss = do
  where
    secpos = sum . fmap (length . _ssShownItems) . fst $ IM.split i $ sss ^. sssSections

+-- it is annoying that Control.Foldl doesn't seem to allow for scans to be done
+-- at the same time as folds
+inverseSelSecYint :: Int -> SelectionSections a -> Maybe (Int,Int)
+inverseSelSecYint yint sss = do 
+    ((i,ss),othersss) <- IM.minViewWithKey (_sssSections sss)
+    let l = length $ _ssShownItems ss
+    if l <= yint
+        then inverseSelSecYint (yint - l) (sss & sssSections .~ othersss)
+        else do
+            let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
+            j <- L.fold (L.findIndex (\x -> x - _ssOffset ss > yint)) ls
+            return (i,j)
+--
+--    ss <- sss ^? sssSections . ix i
+--    return . (secpos +)
+--        . subtract (ss ^. ssOffset)
+--        . sum
+--        . fmap _siHeight
+--        . fst
+--        $ IM.split j (ss ^. ssItems)
+--  where
+--    secpos = sum . fmap (length . _ssShownItems) . fst $ IM.split i $ sss ^. sssSections
+
+inverseSelNumPos ::
+    Configuration ->
+    ListDisplayParams ->
+    SelectionSections a ->
+    Point2 ->
+    Maybe (Int,Int)
+inverseSelNumPos cfig ldp sss pos = --Just (0,posSelSecYint cfig ldp pos)
+    inverseSelSecYint (posSelSecYint cfig ldp pos) sss
+
 --getIthPos :: Int -> IM.IntMap (SelectionItem a) -> Int
 --getIthPos i sm = sum . fmap _siHeight . fst $ IM.split i sm
@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.TestString where

+import qualified Control.Foldl as L
 import Dodge.DoubleTree
 import Dodge.Data.DoubleTree
 import Dodge.Item.Grammar
@@ -20,7 +21,11 @@ import Dodge.Data.Universe
 import qualified IntMapHelp as IM

 testStringInit :: Universe -> [String]
-testStringInit _ = []
+testStringInit u = [
+    show $ u ^? uvWorld . hud . hudElement . subInventory . nsMouseOver . _Just]
+    <> map show (IM.elems (L.postscan (L.premap _siHeight L.sum)
+        $ fromMaybe mempty $ u ^? uvWorld . hud . hudElement . diSections . sssSections . ix 0 . ssItems)
+        )
 --testStringInit u = [maybe mempty show $ u ^? uvWorld . cWorld . lWorld . projectiles . ix 0 . prjUpdates . ix 3 . pjuControllerID]
 --testStringInit u = (topTestPart u
 --    <>) $ map showh $ 
@@ -6,6 +6,8 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where

+import Dodge.ListDisplayParams
+import Dodge.SelectionSections
 import Data.Monoid
 import NewInt
 import Control.Monad
@@ -232,7 +234,7 @@ scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of

 -- | The update step.
 functionalUpdate :: Universe -> Universe
-functionalUpdate w =
+functionalUpdate u =
    checkEndGame
        . over uvWorld (cWorld . lWorld . lClock +~ 1)
        . over uvWorld updateDistortions
@@ -276,11 +278,12 @@ functionalUpdate w =
        . over uvWorld updateRBList
        . over uvWorld updateCloseObjects
        . over uvWorld updateWheelEvents
+        . over uvWorld (updateMouseOverInventory (u ^. uvConfig))
        . over uvWorld zoneClouds
        . over uvWorld zoneCreatures
        -- . over uvWorld updateInventorySelectionList
        . set (uvWorld . cWorld . lWorld . flares) []
-        $ over uvWorld updatePastWorlds w
+        $ over uvWorld updatePastWorlds u

 checkTermDist :: World -> World
 checkTermDist w = fromMaybe w $ do
@@ -290,6 +293,14 @@ checkTermDist w = fromMaybe w $ do
    guard $ dist btpos (_crPos $ you w) > 40
    return (w & hud . hudElement . subInventory .~ NoSubInventory Nothing Nothing)

+updateMouseOverInventory :: Configuration -> World -> World
+updateMouseOverInventory cfig w = fromMaybe w $ do
+    sss <- w ^? hud . hudElement . diSections
+    guard $ w ^. input . mouseMoving
+    let x = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
+    return $ w & hud . hudElement . subInventory . nsMouseOver .~ x
+  where
+    ldp = invDisplayParams w

 updateWheelEvents :: World -> World
 updateWheelEvents w