Work on inventory selection list

src/Dodge/Data/HUD.hs

@@ -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)
 

src/Dodge/Data/SelectionList.hs

@@ -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

src/Dodge/Inventory.hs

@@ -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
+trimapAugmentInv :: (Item -> a) -> a -> (Either FloorItem Button -> a) -> World -> IM.IntMap a
-bimapAugmentInv f g w =
+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
+    splitgap = 0
-        | i < length (yourInv w) = 0
+--        | i < length (yourInv w) = 0
-        | otherwise = 1
+--        | 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
+    splitgap = 0
-        | invsel < length (yourInv w) = 0
+--    splitgap
-        | otherwise = 1
+--        | 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

src/Dodge/Render/HUD.hs

@@ -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

src/Dodge/Update.hs

@@ -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
+    sl <- screen ^? scSelectionList
-  Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
+    Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
-    Just False -> fromMaybe u $ do
+        Just False -> fromMaybe u $ do
-        i <- sl ^. slSelPos
+            i <- sl ^. slSelPos
-        f <- sl ^? slItems . ix i . siPayload
+            f <- sl ^? slItems . ix i . siPayload
-        return $ f u
+            return $ f u
-    _ -> 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 
+    isselectable =
-        $ u ^? uvScreenLayers . _head . scSelectionList . slItems . ix yupper . siIsSelectable
+        fromMaybe False $
-    ymax = maybe 0 length $ sl ^? slItems 
+            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}
+    Just screen@OptionScreen{_scPositionedMenuOption = mop, _scOptionFlag = flag, _scSelectionList = sellist, _scListDisplayParams = ldps} ->
-        -> optionScreenUpdate screen mop flag ldps sellist u
+        optionScreenUpdate screen mop flag ldps sellist u
---    Just ColumnsScreen{} -> u & uvScreenLayers %~ tail
     _ -> 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
+optionScreenUpdate ::
-    -> ListDisplayParams
+    ScreenLayer ->
-    -> SelectionList (Universe -> Universe)
+    PositionedMenuOption ->
-    -> Universe -> Universe
+    OptionScreenFlag ->
-optionScreenUpdate screen mop _ ldps sl u = 
+    ListDisplayParams ->
+    SelectionList (Universe -> Universe) ->
+    Universe ->
+    Universe
+optionScreenUpdate screen mop _ ldps sl u =
     refreshOptionsSelectionList
-    . optionScreenDefEff mop
+        . optionScreenDefEff mop
-    . mouseClickOptionsList screen
+        . mouseClickOptionsList screen
-    . mouseOverSelectionList ldps sl
+        . mouseOverSelectionList ldps sl
-    . menuWheelEvents
+        . menuWheelEvents
-    . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig)
+        . over (uvScreenLayers . _head) (setSelectionListRestriction' cfig)
-    $ u
+        $ u
   where
     cfig = u ^. uvConfig
 
@@ -291,12 +295,7 @@ functionalUpdate w =
         . over uvWorld updateWheelEvents
         $ over uvWorld updatePastWorlds w
 
---menuWheelEvents :: Universe -> Universe
+-- this can probably be unified with updateWheelEvents
---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
-
 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