Move towards selection section inventory management

src/Dodge/Data/SelectionList.hs

@@ -30,19 +30,14 @@ data SelectionList a = SelectionList
     }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
-data Regex = NoRegex
-    | Regex 
-        { _regString :: String
-        , _regInput :: Bool
-        }
-
 data SelectionSections a = SelectionSections
     { _sssSections :: IntMap (SelectionSection a)
     , _sssSelPos :: Maybe Int
     }
 
 data SectionCursor = SectionCursor
-    { _scurPos :: Int
+    { _scurSel :: Int
+    , _scurPos :: Int
     , _scurSize :: Int
     , _scurColor :: Color
     }
@@ -50,6 +45,7 @@ data SectionCursor = SectionCursor
 data SelectionSection a = SelectionSection
     { _ssItems :: IntMap (SelectionItem a)
     , _ssCursor :: Maybe SectionCursor
+    , _ssRegex :: Regex
 --    , _ssSelPos :: Maybe Int
 --    , _ssSelSize :: Maybe Int
 --    , _ssSelColor :: Maybe Color
@@ -61,11 +57,10 @@ data SelectionSection a = SelectionSection
     , _ssDescriptor :: String
     }
     
-data SMRegex = NoSMRegex
+
-    | SMRegex
+data Regex = UnavailableRegex
-        { _smrString :: String
+    | EmptyRegex
-        , _smrInput :: Bool
+    | Regex {_regexString :: String}
-        }
   deriving (Show)
 
 data SelectionIntMap a = SelectionIntMap
@@ -115,6 +110,5 @@ makeLenses ''SelectionSection
 makeLenses ''SelectionSections
 makeLenses ''SectionCursor
 makeLenses ''Regex
-makeLenses ''SMRegex
 --deriveJSON defaultOptions ''SelectionItem
 --deriveJSON defaultOptions ''SelectionList

src/Dodge/DisplayInventory.hs

@@ -4,6 +4,7 @@ module Dodge.DisplayInventory
     , defaultDisplaySections
     ) where
 
+import Regex
 import Data.Maybe
 import Picture.Base
 import Dodge.Render.HUD
@@ -66,11 +67,27 @@ updateSections allavailablelines (i,j) ((k,(x,y)):xs) = IM.insert k ss
         | otherwise = updateSection Nothing y availablelines x
     availablelines = allavailablelines - sum (map (_ssMinSize . fst . snd) xs)
 
+defaultSS :: SelectionSection ()
+defaultSS = SelectionSection 
+    { _ssItems = mempty 
+    , _ssCursor = Nothing 
+    , _ssRegex = EmptyRegex
+    , _ssMinSize = 5 
+    , _ssOffset = 0 
+    , _ssShownItems = [] 
+    , _ssIndent = 0 
+    , _ssDescriptor = ""
+    }
+
+
 defaultCOSection :: SelectionSection ()
-defaultCOSection = SelectionSection mempty Nothing 5 0 [] 2 "CLOSE OBJECTS"
+defaultCOSection = defaultSS 
+    & ssIndent .~ 2 
+    & ssDescriptor .~ "CLOSE OBJECTS"
 
 defaultInvSection :: SelectionSection ()
-defaultInvSection = SelectionSection mempty Nothing 5 0 [] 0 "INVENTORY ITEMS"
+defaultInvSection = defaultSS
+    & ssDescriptor .~ "INVENTORY ITEMS"
 
 updateSection 
     :: Maybe Int
@@ -78,16 +95,24 @@ updateSection
     -> Int 
     -> SelectionSection a
     -> SelectionSection a
-updateSection mspos sis availablelines ss = ss
+updateSection mspos sis' availablelines ss = ss
     { _ssItems = sis
     , _ssCursor = scurs
     , _ssOffset = offset
---    , _ssRegex = ""
---    , _ssRegexInput = False
     , _ssMinSize = 5
     , _ssShownItems = shownitems
     }
   where
+    sis = case _ssRegex ss of
+        Regex str -> IM.insert (-1) (f str) $ IM.filter (regexList str . _siPictures) sis'
+        _ -> sis'
+    f str = SelectionRegex
+        { _siPictures = ["FILTER: " ++ str]
+        , _siHeight = 1
+        , _siIsSelectable = True
+        , _siColor = white
+        , _siOffX = 0
+        }
     oldoffset = ss ^. ssOffset
     scurs = do
         csel <- mspos
@@ -95,7 +120,7 @@ updateSection mspos sis availablelines ss = ss
         let cpos = sum (fmap (length . _siPictures) . fst . IM.split csel $ sis)
             csize = length $ _siPictures si
             ccolor = _siColor si
-        return $ SectionCursor (cpos - offset) csize ccolor
+        return $ SectionCursor csel (cpos - offset) csize ccolor
     mcpos = do
         csel <- mspos
         return . sum $ fmap (length . _siPictures) . fst . IM.split csel $ sis
@@ -136,15 +161,9 @@ updateSection mspos sis availablelines ss = ss
         return . length $ _siPictures si
 
 yousec :: SelectionSection ()
-yousec = SelectionSection
+yousec = defaultSS
-    { _ssItems = mempty
+    & ssCursor ?~ SectionCursor 0 0 1 invDimColor
-    , _ssCursor = Just $ SectionCursor 0 1 invDimColor
+    & ssRegex .~ UnavailableRegex
-    , _ssOffset = 0
+    & ssIndent .~ 2
-    , _ssIndent = 2
+    & ssMinSize .~ 1
---    , _ssRegex = ""
+    & ssDescriptor .~ "YOUR STATUS"
---    , _ssRegexInput = False
-    , _ssMinSize = 1
---    , _ssOffset = 0
-    , _ssShownItems = mempty
-    , _ssDescriptor = "YOUR STATUS"
-    }

src/Dodge/Inventory.hs

@@ -25,6 +25,7 @@ module Dodge.Inventory (
     trimapAugmentInv,
 ) where
 
+import Dodge.Data.SelectionList
 import Color
 import qualified Data.Map.Strict as M
 import Data.Maybe
@@ -353,27 +354,136 @@ changeAugInvSel :: Int -> World -> World
 changeAugInvSel yi w
     | yi == 0 = w
     | otherwise =
-        w & cWorld . lWorld . creatures . ix 0 . crInvSel . isel %~ f
+        w & hud . hudElement . diSections %~ scrollSelectionSections yi
-  where
+            & setInvPosFromSS
-    f = fromAugSelPos w . (`mod` (ninv + nclose + 1)) . subtract yi . toAugSelPos w
-    ninv = length (yourInv w)
-    nclose = length (w ^. hud . closeObjects)
 
-toAugSelPos :: World -> ManipulatedObject -> Int
+setInvPosFromSS :: World -> World
-toAugSelPos w mo = case mo of
+setInvPosFromSS w = w
-    SelItem i _ -> i
+    & cWorld . lWorld . creatures . ix 0 . crInvSel . isel .~ thesel
-    SelNothing -> ninv   
-    SelCloseObject i -> ninv + i + 1
   where
-    ninv = length (yourInv w)
+    thesel = fromMaybe SelNothing $ do
+        sss <- w ^? hud . hudElement . diSections
+        i <- sss ^? sssSelPos . _Just
+        j <- sss ^? sssSections . ix i . ssCursor . _Just . scurSel
+        case i of
+            0 -> Just $ SelItem j NoInvSelAction
+            2 -> Just $ SelCloseObject j
+            _ -> Just SelNothing
             
-fromAugSelPos :: World -> Int -> ManipulatedObject
+--changeAugInvSel :: Int -> World -> World
-fromAugSelPos w i
+--changeAugInvSel yi w
-    | i > ninv = SelCloseObject (i - ninv - 1)
+--    | yi == 0 = w
-    | i == ninv = SelNothing
+--    | otherwise =
-    | otherwise = SelItem i NoInvSelAction
+--        w & cWorld . lWorld . creatures . ix 0 . crInvSel . isel %~ f
-  where
+--  where
-    ninv = length (yourInv w)
+--    f = fromAugSelPos w . (`mod` (ninv + nclose + 1)) . subtract yi . toAugSelPos w
+--    ninv = length (yourInv w)
+--    nclose = length (w ^. hud . closeObjects)
+
+firstPosSelectionSections :: SelectionSections a -> SelectionSections a
+firstPosSelectionSections sss = fromMaybe sss $ do
+    (i,j,si) <- ssLookupMin sss
+    return $ sss
+        & sssSelPos ?~ i
+        & sssSections . ix i . ssCursor ?~ SectionCursor j j (_siHeight si) (_siColor si)
+
+scrollSelectionSections :: Int -> SelectionSections a -> SelectionSections a
+scrollSelectionSections yi sss
+    | yi == 0 = sss
+    | yi  > 0 = foldr ($) sss $ replicate yi scrollUpSelectionSections
+    | otherwise = foldr ($) sss $ replicate (negate yi) scrollDownSelectionSections
+
+scrollUpSelectionSections :: SelectionSections a -> SelectionSections a
+scrollUpSelectionSections sss = fromMaybe (firstPosSelectionSections sss) $ do
+    i <- sss ^? sssSelPos . _Just
+    j <- sss ^? sssSections . ix i . ssCursor . _Just . scurSel
+    (i',j',si) <- ssLookupUp i j sss
+    return $ sss & sssSelPos ?~ i'
+        & sssSections . ix i' . ssCursor ?~ SectionCursor j' j' (_siHeight si) (_siColor si)
+
+scrollDownSelectionSections :: SelectionSections a -> SelectionSections a
+scrollDownSelectionSections sss = fromMaybe (firstPosSelectionSections sss) $ do
+    i <- sss ^? sssSelPos . _Just
+    j <- sss ^? sssSections . ix i . ssCursor . _Just . scurSel
+    (i',j',si) <- ssLookupDown i j sss
+    return $ sss & sssSelPos ?~ i'
+        & sssSections . ix i' . ssCursor ?~ SectionCursor j' j' (_siHeight si) (_siColor si)
+
+ssLookupMax :: SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupMax sss = do
+    (i,_) <- IM.lookupMax (sss ^. sssSections)
+    ssLookupLE' i sss
+
+ssLookupUp :: Int -> Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupUp i j sss = case ssLookupLT i j sss of
+    Nothing -> ssLookupMax sss
+    x -> x
+
+ssLookupDown :: Int -> Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupDown i j sss = case ssLookupGT i j sss of
+    Nothing -> ssLookupMin sss
+    x -> x
+    
+ssLookupLT :: Int -> Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupLT i j sss = fromMaybe (ssLookupLT' i sss) $ do
+    ss <- sss ^? sssSections . ix i
+    (j',si) <- IM.lookupLT j (ss ^. ssItems)
+    return $ Just (i,j',si)
+
+ssLookupLT' :: Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupLT' i sss = do
+    (i',ss) <- IM.lookupLT i (sss ^. sssSections)
+    case IM.lookupMax (ss ^. ssItems) of
+        Just (j',si) -> return (i',j',si)
+        Nothing -> ssLookupLT' i' sss
+
+ssLookupLE' :: Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupLE' i sss = do
+    (i',ss) <- IM.lookupLE i (sss ^. sssSections)
+    case IM.lookupMax (ss ^. ssItems) of
+        Just (j',si) -> return (i',j',si)
+        Nothing -> ssLookupLT' i' sss
+
+ssLookupMin :: SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupMin sss = do
+    (i,_) <- IM.lookupMin (sss ^. sssSections)
+    ssLookupGE' i sss
+
+ssLookupGT :: Int -> Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupGT i j sss = fromMaybe (ssLookupGT' i sss) $ do
+    ss <- sss ^? sssSections . ix i
+    (j',si) <- IM.lookupGT j (ss ^. ssItems)
+    return $ Just (i,j',si)
+
+ssLookupGT' :: Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupGT' i sss = do
+    (i',ss) <- IM.lookupGT i (sss ^. sssSections)
+    case IM.lookupMin (ss ^. ssItems) of
+        Just (j',si) -> return (i',j',si)
+        Nothing -> ssLookupGT' i' sss
+
+ssLookupGE' :: Int -> SelectionSections a -> Maybe (Int,Int,SelectionItem a)
+ssLookupGE' i sss = do
+    (i',ss) <- IM.lookupGE i (sss ^. sssSections)
+    case IM.lookupMin (ss ^. ssItems) of
+        Just (j',si) -> return (i',j',si)
+        Nothing -> ssLookupGT' i' sss
+
+--toAugSelPos :: World -> ManipulatedObject -> Int
+--toAugSelPos w mo = case mo of
+--    SelItem i _ -> i
+--    SelNothing -> ninv   
+--    SelCloseObject i -> ninv + i + 1
+--  where
+--    ninv = length (yourInv w)
+--
+--fromAugSelPos :: World -> Int -> ManipulatedObject
+--fromAugSelPos w i
+--    | i > ninv = SelCloseObject (i - ninv - 1)
+--    | i == ninv = SelNothing
+--    | otherwise = SelItem i NoInvSelAction
+--  where
+--    ninv = length (yourInv w)
 
 bestCloseObjectIndex :: World -> Maybe Int
 bestCloseObjectIndex w = findIndex f $ w ^. hud . closeObjects

src/Dodge/Update.hs

@@ -145,8 +145,10 @@ updateUseInput u = case u ^? uvScreenLayers . _head of
         Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) -> updateKeysInTerminal tmid u
         Just (CombineInventory sm)
             | inregex sm -> doSubInvRegexInput u
+        _ | ininvregex -> doInvRegexInput u
         _ -> M.foldlWithKey' updateKeyInGame u pkeys
   where
+    ininvregex = False
     inregex sm = fromMaybe False $ do
         i <- sm ^? smSelPos . _Just
         si <- sm ^? smShownItems . ix i

src/Dodge/Update/Input.hs

@@ -3,8 +3,11 @@ module Dodge.Update.Input (
     updateKeysInTerminal,
     doInputScreenInput,
     doSubInvRegexInput,
+    doInvRegexInput,
 ) where
 
+import Color
+import Data.Maybe
 import Dodge.DisplayInventory
 import SelectionIntMap
 import qualified Data.Map.Strict as M
@@ -25,6 +28,15 @@ import Dodge.WorldPos
 import LensHelp
 import SDL
 
+doTextInputOver' :: Universe -> ASetter' a String -> a -> a
+doTextInputOver' u p x = x & p %~ (++ map toUpper thetext)
+    & checkBackspace
+  where
+    thetext = u ^. uvWorld . input . textInput
+    checkBackspace 
+        | backspaceInputted u = p %~ doBackspace
+        | otherwise = id
+
 doTextInputOver :: ASetter' Universe String -> Universe -> Universe
 doTextInputOver p u = u & p %~ (++ map toUpper thetext)
     & checkBackspace
@@ -63,6 +75,28 @@ doSubInvRegexInput u
       && ScancodeBackspace `M.lookup` pkeys == Just InitialPress
     pkeys = u ^. uvWorld . input . pressedKeys
 
+doInvRegexInput :: Universe -> Universe
+doInvRegexInput u
+    | backspacetonothing
+            = u & uvWorld . hud . hudElement . diSections %~ overSection
+                ( ssRegex .~ EmptyRegex )
+--                . initialSelPos )
+--                & uvWorld . hud . hudElement . diSections %~ setShownIntMap
+    | endkeys || endmouse = u
+--            = u & uvWorld . hud . hudElement . diSections %~ initialSelPos
+    | otherwise = u & uvWorld . hud . hudElement . diSections %~ 
+        overSection (doTextInputOver' u (ssRegex . regexString))
+--    | otherwise = u & doTextInputOver (uvWorld . hud . hudElement . subInventory . subInvMap . smRegex . _Just)
+--        & uvWorld . hud . hudElement . subInventory . subInvMap %~ setShownIntMap
+  where
+    endkeys = any 
+        ( (== Just InitialPress) . (`M.lookup` pkeys)) 
+        [ScancodeReturn,ScancodeEscape,ScancodeSlash]
+    endmouse = Just True == (u ^? uvWorld . input . mouseButtons . ix ButtonLeft)
+    backspacetonothing = u ^? uvWorld . hud . hudElement . subInventory . subInvMap . smRegex . _Just == Just ""
+      && ScancodeBackspace `M.lookup` pkeys == Just InitialPress
+    pkeys = u ^. uvWorld . input . pressedKeys
+
 doInputScreenInput :: String -> Universe -> Universe
 doInputScreenInput s u =
     u & doTextInputOver (uvScreenLayers . _head . scInput)
@@ -101,29 +135,53 @@ updateKeyInGame uv sc InitialPress = case sc of
     ScancodeX -> uv & uvWorld %~ toggleTweakInv
     ScancodeC -> over uvWorld toggleCombineInv uv
     -- the following should be put in a more sensible place
-    --ScancodeSlash -> set (uvWorld . hud . hudElement . subInventory . subInvRegexInput) True uv
+    ScancodeSlash -> uv & uvWorld . hud . hudElement %~ updateEnterRegex
-    ScancodeSlash -> uv
+    ScancodeBackspace -> uv & uvWorld . hud . hudElement %~ updateBackspaceRegex
-        & uvWorld . hud . hudElement . subInventory . subInvMap . smRegex %~ enterregex
-        & uvWorld . hud . hudElement . subInventory . subInvMap . smSelPos ?~ 0 
-        & uvWorld . hud . hudElement . subInventory . subInvMap %~ setShownIntMap
-    ScancodeBackspace -> uv
-        & uvWorld . hud . hudElement . subInventory . subInvMap . smRegex %~ enternonzeroregex
-        & uvWorld . hud . hudElement . subInventory . subInvMap . smSelPos ?~ 0 
-        & uvWorld . hud . hudElement . subInventory . subInvMap %~ setShownIntMap
         
     -- in fact the whole logic should probably be rethought, oh well
     _ -> uv
-  where
-    enterregex Nothing = Just ""
-    enterregex (Just str)  = Just str
-    enternonzeroregex (Just (x:xs)) = Just (init (x:xs))
-    enternonzeroregex smr = smr
 updateKeyInGame uv sc LongPress = case sc of
     ScancodeF -> over uvWorld youDropItem uv
     ScancodeSpace -> over uvWorld spaceAction uv
     _ -> uv
 updateKeyInGame uv _ _ = uv
 
+updateBackspaceRegex :: HUDElement -> HUDElement
+updateBackspaceRegex di = case di ^?  subInventory of
+    Just NoSubInventory -> di & diSections %~ overSection 
+            ( (ssRegex %~ backssregex)
+            . (ssCursor .~ Just (SectionCursor (-1) 0 1 white))
+            )
+    Just CombineInventory {} -> di
+        & subInventory . subInvMap . smRegex %~ enternonzeroregex
+        & subInventory . subInvMap . smSelPos ?~ 0 
+        & subInventory . subInvMap %~ setShownIntMap
+    _ -> di
+  where
+    enternonzeroregex (Just (x:xs)) = Just (init (x:xs))
+    enternonzeroregex smr = smr
+    backssregex (Regex (x:xs)) = Regex (init (x:xs))
+    backssregex x = x
+
+updateEnterRegex :: HUDElement -> HUDElement
+updateEnterRegex di = case di ^?  subInventory of
+    Just NoSubInventory -> di & diSections %~ overSection (ssRegex %~ enterssregex)
+    Just CombineInventory {} -> di
+        & subInventory . subInvMap . smRegex %~ enterregex
+        & subInventory . subInvMap . smSelPos ?~ 0 
+        & subInventory . subInvMap %~ setShownIntMap
+    _ -> di
+  where
+    enterssregex EmptyRegex = Regex ""
+    enterssregex x = x
+    enterregex Nothing = Just ""
+    enterregex (Just str)  = Just str
+
+overSection :: (SelectionSection a -> SelectionSection a) -> SelectionSections a -> SelectionSections a
+overSection f sss = fromMaybe sss $ do
+    i <- sss ^? sssSelPos . _Just
+    return $ sss & sssSections . ix i %~ f
+
 pauseGame :: Universe -> Universe
 pauseGame u = u & uvScreenLayers .~ [pauseMenu u]
 

src/SelectionIntMap.hs

@@ -26,9 +26,12 @@ setShownIntMap sm = case sm ^. smRegex of
 initialSelPos :: SelectionIntMap a -> SelectionIntMap a
 initialSelPos sm = sm & smSelPos .~ mi
   where
-    mi = fst <$> ifind t (sm ^. smShownItems)
+    mi = case sm ^? smShownItems . ix 0 of
-    t _ SelectionRegex{} = False
+        Nothing -> Nothing
-    t _ si = _siIsSelectable si
+        Just SelectionRegex {} -> case sm ^? smShownItems . ix 1 of
+            Nothing -> Just 0
+            Just _ -> Just 1
+        _ -> Just 0
 
 -- assumes that at least one item is selectable!
 -- also assumes that the integer is 1 or -1