Start adding filters to selection lists

src/Dodge/Combine.hs

@@ -8,6 +8,7 @@ module Dodge.Combine (
     enterCombineInv,
 ) where
 
+import qualified Data.Text as T
 import qualified Data.IntSet as IS
 import Control.Lens
 import Control.Monad
@@ -92,7 +93,11 @@ toggleCombineInv w = case w ^. hud . hudElement of
     _ -> w & enterCombineInv
 
 enterCombineInv :: World -> World
-enterCombineInv w = w & hud . hudElement . subInventory .~ CombineInventory mi
+enterCombineInv w = w & hud . hudElement . subInventory .~ CombineInventory 
+    { _subInvSel = mi
+    , _subInvRegex = T.pack ""
+    , _subInvRegexInput = False
+    }
   where
     mi = 0 <$ listToMaybe (combineItemListYou w)
 

src/Dodge/Data/HUD.hs

@@ -10,6 +10,7 @@ import Dodge.Data.Button
 import Dodge.Data.FloorItem
 import Control.Lens
 import Geometry.Data
+import qualified Data.Text as T
 
 data HUDElement
     = DisplayInventory 
@@ -21,7 +22,8 @@ data HUDElement
 data SubInventory
     = NoSubInventory
     | ExamineInventory {_subInvSel :: Maybe Int}
-    | CombineInventory {_subInvSel :: Maybe Int}
+    | CombineInventory {_subInvSel :: Maybe Int, _subInvRegex :: T.Text 
+        , _subInvRegexInput :: Bool}
     | LockedInventory
     | DisplayTerminal {_termID :: Int}
     deriving (Eq, Ord, Show, Read) --Generic, Flat)

src/Dodge/Data/SelectionList.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE StrictData #-}
 module Dodge.Data.SelectionList where
 import Color
-import Picture.Data
 import Control.Lens
 import Dodge.Data.CardinalPoint
 --import Data.Aeson
@@ -24,6 +23,8 @@ data SelectionList a = SelectionList
     { _slItems :: [SelectionItem a]
     , _slSelPos :: Maybe Int
     , _slLength :: Int
+    , _slRegex  :: String
+    , _slRegexInput :: Bool
     }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
@@ -35,7 +36,7 @@ data CursorType = NoCursor
     | BorderCursor [CardinalPoint]
 
 data SelectionItem a = SelectionItem
-    { _siPictures :: [Picture]
+    { _siPictures :: [String]
     , _siHeight :: Int
     , _siIsSelectable :: Bool
     , _siWidth  :: Int
@@ -43,6 +44,9 @@ data SelectionItem a = SelectionItem
     , _siOffX   :: Int
     , _siPayload :: a
     }
+    | SelectionFilter
+    { _siPictures :: [String]
+    }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
     
 makeLenses ''ListDisplayParams

src/Dodge/Inventory.hs

@@ -194,8 +194,8 @@ updateRBList w
             w
                 & rbOptions
                     .~ EquipOptions
-                        { _opEquip = (equipSiteToPositions esite)
+                        { _opEquip = equipSiteToPositions esite
-                        , _opSel = (chooseEquipmentPosition cr (equipSiteToPositions esite))
+                        , _opSel = chooseEquipmentPosition cr (equipSiteToPositions esite)
                         , _opItemID = itid
                         , _opAllocateEquipment = DoNotMoveEquipment
                         , _opActivateEquipment = NoChangeActivateEquipment

src/Dodge/Inventory/SelectionList.hs

@@ -19,7 +19,7 @@ makeInventorySelectionList w = defaultSelectionList
 
 inventorySelectionList :: World -> [SelectionItem ()]
 inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
-    ++ [SelectionItem displayFreeSlots 1 True (length thetext) invDimColor 2 ()]
+    ++ [SelectionItem [thetext] 1 True (length thetext) invDimColor 2 ()]
             ++ map (closeObjectToSelectionItem nfreeslots) (w ^. hud . closeObjects)
   where
     cr = you w
@@ -29,7 +29,6 @@ inventorySelectionList w = map (invSelectionItem cr) (IM.toList inv)
         0 -> "  INVENTORY FULL"
         1 -> "  +1 FREE SLOT"
         x -> "  +" ++ show x ++ " FREE SLOTS"
-    displayFreeSlots = [color invDimColor $ text thetext]
 
 inventoryCursorPos :: World -> Maybe Int
 inventoryCursorPos w = case w ^? hud . hudElement . subInventory of
@@ -48,10 +47,10 @@ invSelectionItem cr (i,it) = SelectionItem
     }
   where
     col = _itInvColor it
-    pics = take (itSlotsTaken it) . (++ replicate 10 (color col $ text "*")) $ case _itCurseStatus it of
+    pics = take (itSlotsTaken it) . (++ replicate 10 "*") $ case _itCurseStatus it of
-        UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
+        UndroppableIdentified -> itemDisplay it
-        _ | crSel cr == i -> map (color col . text) (selectedItemDisplay cr it)
+        _ | crSel cr == i -> selectedItemDisplay cr it
-        _ -> map (color col . text) (itemDisplay it)
+        _ -> itemDisplay it
 
 closeObjectToSelectionItem :: Int -> Either FloorItem Button -> SelectionItem ()
 closeObjectToSelectionItem n e = SelectionItem
@@ -66,16 +65,13 @@ closeObjectToSelectionItem n e = SelectionItem
   where
     (pics,col) = closeObjectToTextPictures' n e
 
-closeObjectToTextPictures' :: Int -> Either FloorItem Button -> ([Picture],Color)
+closeObjectToTextPictures' :: Int -> Either FloorItem Button -> ([String],Color)
 closeObjectToTextPictures' nfreeslots e = case e of
     Left flit -> let it = _flIt flit 
-        in (map (applycolor it . textindent) $ itemDisplay it, thecol it)
+        in (map textindent $ itemDisplay it, thecol it)
-    Right bt -> ([color yellow $ textindent $ _btText bt], yellow)
+    Right bt -> ([textindent $ _btText bt], yellow)
   where
-    textindent = text . (replicate clObjIntIn ' ' ++)
+    textindent = (replicate clObjIntIn ' ' ++)
-    applycolor it
-        | nfreeslots >= itSlotsTaken it = color $ _itInvColor it
-        | otherwise = color invDimColor
     thecol it
         | nfreeslots >= itSlotsTaken it = _itInvColor it
         | otherwise = invDimColor

src/Dodge/Item/Draw/SPic.hs

@@ -247,7 +247,7 @@ addBullets :: Item -> Shape
 addBullets itm = fromMaybe mempty $ do
     x <- itm ^? itUse . heldConsumption . laLoaded
     hit <- itm ^? itType . iyBase . ibtHeld
-    ps <- fmap (take x) $ (ammoPosition itm hit) ^? amPosDirs
+    ps <- fmap (take x) $ ammoPosition itm hit ^? amPosDirs
     return $ foldMap (uncurry (drawBullet itm)) ps
 
 drawBullet :: Item -> Point3 -> Q.Quaternion Float -> Shape

src/Dodge/Menu.hs

@@ -12,7 +12,6 @@ import Data.ByteString.Lazy.Char8 (unpack)
 import Data.Maybe
 import Dodge.Concurrent
 import Dodge.Config.Update
-import Dodge.Data.SelectionList
 import Dodge.Data.Universe
 import Dodge.Menu.Option
 import Dodge.Menu.OptionType
@@ -24,7 +23,6 @@ import Dodge.StartNewGame
 import LensHelp
 import MaybeHelp
 import Padding
-import ShortShow
 import System.Clipboard
 import Text.Read
 
@@ -36,8 +34,6 @@ splashMenu u =
 splashMenuOptions :: [MenuOption]
 splashMenuOptions =
     [ Toggle (loadSaveSlot (SaveSlotNum 0)) displaycontinue
-    , Toggle id (\u -> MODString $ show $ u ^? uvScreenLayers . _head . scSelectionList . slSelPos . _Just)
-    , Toggle id (\u -> MODString $ shortShow $ u ^. uvWorld . input . mousePos)
     , Toggle (startNewGameInSlot 0) (opText "NEW WITH RANDOM SEED")
     , Toggle reloadLevelStart (displaywhenseed "NEW WITH LAST SEED")
     , Toggle (pushScreen $ seedStartMenu "START FROM SEED") (opText "NEW WITH SPECIFIC SEED")

src/Dodge/Menu/Loading.hs

@@ -10,7 +10,7 @@ loadingScreen str = OptionScreen
     , _scOffset = 0
     , _scPositionedMenuOption = NoPositionedMenuOption
     , _scOptionFlag = LoadingScreen
-    , _scSelectionList = SelectionList [] Nothing 0
+    , _scSelectionList = SelectionList [] Nothing 0 "" False
     , _scAvailableLines = 0
     , _scListDisplayParams = optionListDisplayParams
     }

src/Dodge/Menu/Option.hs

@@ -66,6 +66,8 @@ makeOptionsSelectionList maxlines mselpos u mos pmo =
         { _slItems = optionsToSelections maxlines u mos pmo
         , _slSelPos = mselpos
         , _slLength = length $ optionsToSelections maxlines u mos pmo
+        , _slRegex = ""
+        , _slRegexInput = False
         }
 
 optionsToSelections :: Int -> Universe -> [MenuOption] -> PositionedMenuOption -> [SelectionItem (Universe -> Universe)]
@@ -101,7 +103,7 @@ cycleOptions u = fromMaybe u $ do
 colStrToSelItem :: (Color, String) -> SelectionItem (Universe -> Universe)
 colStrToSelItem (col, str) =
     SelectionItem
-        { _siPictures = [color col $ text str]
+        { _siPictures = [str]
         , _siHeight = 1
         , _siIsSelectable = True
         , _siWidth = length str
@@ -118,11 +120,11 @@ optionValueOffset u mo = case _moString mo u of
 menuOptionToSelectionItem :: Universe -> Int -> MenuOption -> SelectionItem (Universe -> Universe)
 menuOptionToSelectionItem w padAmount mo =
     SelectionItem
-        { _siPictures = [color thecol $ text optionText]
+        { _siPictures = [optionText]
         , _siHeight = 1
         , _siIsSelectable = isselectable
         , _siWidth = length optionText
-        , _siColor = white
+        , _siColor = thecol
         , _siOffX = 0
         , _siPayload = f
         }

src/Dodge/Render/HUD.hs

@@ -66,6 +66,8 @@ defaultSubInvSelectionList =
         { _slItems = []
         , _slSelPos = Nothing
         , _slLength = 15
+        , _slRegex = ""
+        , _slRegexInput = False
         }
 
 invDisplayParams :: World -> ListDisplayParams
@@ -91,11 +93,11 @@ drawSubInventory subinv cfig w = case subinv of
     NoSubInventory -> drawNoSubInventory cfig w
     ExamineInventory mtweaki -> drawExamineInventory cfig mtweaki w
     DisplayTerminal tid -> displayTerminal tid cfig (w ^. cWorld . lWorld)
-    CombineInventory mi ->
+    CombineInventory mi regex x ->
         titledSub
             cfig
-            "COMBINE"
+            ("COMBINE")
-            (combineListSelection w mi)
+            (combineListSelection w mi (T.unpack regex) x)
             <> combineInventoryExtra mi cfig w
 
 titledSub :: Configuration -> String -> SelectionList a -> Picture
@@ -115,7 +117,7 @@ drawExamineInventory cfig mtweaki w =
     itm = yourItem w
     f str =
         SelectionItem
-            { _siPictures = [text str]
+            { _siPictures = [str]
             , _siHeight = 1
             , _siIsSelectable = True
             , _siWidth = length str
@@ -238,8 +240,8 @@ displayTerminal tid cfig w = fromMaybe mempty $ do
             , drawSelectionList secondColumnParams cfig (thesellist tm)
             ]
   where
-    toselitm (str, col) = SelectionItem [color col $ text str] 1 True (length str) col 0 ()
+    toselitm (str, col) = SelectionItem [str] 1 True (length str) col 0 ()
-    thesellist tm = SelectionList (thelist tm) Nothing (length (thelist tm))
+    thesellist tm = SelectionList (thelist tm) Nothing (length (thelist tm)) "" False
     thelist tm =
         map toselitm . displayTermInput tm
             . reverse
@@ -331,15 +333,17 @@ determineInvSelCursorWidth w = case _rbOptions w of
             47
         | otherwise -> topInvW
 
-combineListSelection :: World -> Maybe Int -> SelectionList ()
+combineListSelection :: World -> Maybe Int -> String -> Bool -> SelectionList ()
-combineListSelection w mi =
+combineListSelection w mi regex x =
     defaultSubInvSelectionList
         & slItems .~ combineListSelectionItems w
         & slSelPos .~ mi
+        & slRegex .~ regex
+        & slRegexInput .~ x
 
 combineListSelectionItems :: World -> [SelectionItem ()]
 combineListSelectionItems w = case combineListSelectionItems' w of
-    [] -> [SelectionItem [text thetext] 1 False (length thetext) white 0 ()]
+    [] -> [SelectionItem [thetext] 1 False (length thetext) white 0 ()]
     xs -> xs
   where
     thetext = "NO POSSIBLE COMBINATIONS"
@@ -449,7 +453,7 @@ drawMapWall cfig thehud wl = color c . polygon $ map (cartePosToScreen cfig theh
 mainListCursor :: Color -> Int -> Configuration -> Picture
 mainListCursor c = openCursorAt 120 c 5 0
 
-picsToSelectable :: Int -> [Picture] -> SelectionItem ()
+picsToSelectable :: Int -> [String] -> SelectionItem ()
 picsToSelectable wdth pics =
     SelectionItem
         { _siPictures = pics
@@ -462,17 +466,15 @@ picsToSelectable wdth pics =
         }
 
 textSelItems :: [String] -> [SelectionItem ()]
-textSelItems = map (picsToSelectable 15 . (: []) . text)
+textSelItems = map (picsToSelectable 15 . (: []))
 
-itemText :: Item -> [Picture]
+itemText :: Item -> [String]
 {-# INLINE itemText #-}
 itemText it = f $ case _itCurseStatus it of
-    UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
+    UndroppableIdentified -> itemDisplay it
-    --        <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90)))
+    _ -> itemDisplay it
-    _ -> map (color thecolor . text) (itemDisplay it)
   where
-    thecolor = _itInvColor it
+    f = take (itSlotsTaken it) . (++ replicate 10 "*")
-    f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
 
 openCursorAt ::
     -- | Width

src/Dodge/Render/List.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.List where
 
 --import Data.Foldable
+import Regex
 import Data.Maybe
 import Dodge.Base.WinScale
 import Dodge.Base.Window
@@ -25,7 +26,16 @@ drawSelectionList ldps cfig sl =
         <> drawSelectionCursor ldps cfig sl
 
 makeSelectionListPictures :: SelectionList a -> [Picture]
-makeSelectionListPictures sl = concatMap _siPictures $ _slItems sl
+makeSelectionListPictures sl = regex ++ concatMap f theitems
+  where
+    theitems = case sl ^. slRegex of
+        "" -> _slItems sl
+        str -> filter (doregex str) (_slItems sl)
+    doregex str = regexList str . _siPictures
+    regex = case sl ^. slRegex of
+        "" | not (sl ^. slRegexInput) -> []
+        str -> [text $ "SEARCH: " ++ str]
+    f si = map (color (_siColor si) . text) $ _siPictures si
         --case sl ^. slSizeRestriction of
 --    SelectionSizeRestriction {} -> concatMap (_siPictures . fst) $ _slShownItems sl
 --    _ -> concatMap _siPictures $ _slItems sl
@@ -47,7 +57,16 @@ drawCursorAt ldps cfig mi lis = fromMaybe mempty $ do
         _ -> 1
 
 drawSelectionCursor :: ListDisplayParams -> Configuration -> SelectionList a -> Picture
-drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (sl ^. slSelPos) (sl ^. slItems)
+drawSelectionCursor ldps cfig sl = drawCursorAt ldps cfig (f $ sl ^. slSelPos) (g $ sl ^. slItems)
+  where
+    -- the following is quite hacky
+    f = case sl ^. slRegex of
+        "" | not (sl ^. slRegexInput) -> id
+        _ -> fmap (+1)
+    g (x:xs) = case sl ^. slRegex of
+        "" | not (sl ^. slRegexInput) -> (x:xs)
+        _ -> ((x & siHeight .~ 1) : x : xs)
+    g _ = []
 
 -- given a list of pictures that are each the size of a "text" call, displays them as
 -- a list on the screen

src/Dodge/SelectionList.hs

@@ -2,6 +2,7 @@ module Dodge.SelectionList where
 
 --import Color
 --import Dodge.WindowLayout
+import Regex
 import Dodge.Data.Universe
 import LensHelp
 --import Data.Maybe
@@ -19,5 +20,13 @@ defaultSelectionList = SelectionList
     {_slItems = []
     , _slSelPos = Nothing
     , _slLength = 0
+    , _slRegex = ""
+    , _slRegexInput = False
     }
 
+getShownItems :: SelectionList a -> [SelectionItem a]
+getShownItems sl = case sl ^. slRegex of
+        "" -> _slItems sl
+        str ->  SelectionFilter ["FILTER: "++str] : filter (doregex str) (_slItems sl)
+  where
+    doregex str = regexList str . _siPictures

src/Dodge/Update.hs

@@ -139,6 +139,7 @@ updateUseInput u = case u ^? uvScreenLayers . _head of
         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 _ _ True) -> doSubInvRegexInput u
         _ -> M.foldlWithKey' updateKeyInGame u pkeys
   where
     pkeys = u ^. uvWorld . input . pressedKeys

src/Dodge/Update/Input.hs

@@ -2,6 +2,7 @@ module Dodge.Update.Input (
     updateKeyInGame,
     updateKeysInTerminal,
     doInputScreenInput,
+    doSubInvRegexInput,
 ) where
 
 import qualified Data.Map.Strict as M
@@ -22,20 +23,13 @@ import Dodge.WorldPos
 import LensHelp
 import SDL
 
-doInputScreenInput :: T.Text -> Universe -> Universe
+doTextInputOver :: ASetter' Universe T.Text -> Universe -> Universe
-doInputScreenInput s u =
+doTextInputOver p u = u & p %~ (`T.append` T.toUpper thetext)
-    u & uvScreenLayers . _head . scInput %~ (`T.append` T.toUpper thetext)
     & checkBackspace
-        & checkEndStatus
   where
     thetext = u ^. uvWorld . input . textInput
     checkBackspace 
-        | backspaceInputted u = uvScreenLayers . _head . scInput %~ doBackspace
+        | backspaceInputted u = p %~ doBackspace
-        | otherwise = id
-    pkeys = u ^. uvWorld . input . pressedKeys
-    checkEndStatus
-        | ScancodeReturn `M.member` pkeys = (uvScreenLayers %~ tail) . applyTerminalString (words $ T.unpack s)
-        | ScancodeEscape `M.member` pkeys = uvScreenLayers %~ tail
         | otherwise = id
     
 doBackspace :: T.Text -> T.Text
@@ -49,17 +43,35 @@ backspaceInputted u = case u ^. uvWorld . input . pressedKeys . at ScancodeBacks
     Just LongPress -> True
     _ -> False
 
+doSubInvRegexInput :: Universe -> Universe
+doSubInvRegexInput u = u
+    & doTextInputOver (uvWorld . hud . hudElement . subInventory . subInvRegex)
+    & checkEndStatus
+  where
+    pkeys = u ^. uvWorld . input . pressedKeys
+    checkEndStatus
+        | any ( (== Just InitialPress) . (`M.lookup` pkeys)) [ScancodeReturn,ScancodeEscape,ScancodeSlash] 
+            = uvWorld . hud . hudElement . subInventory . subInvRegexInput .~ False
+        | otherwise = id
+
+doInputScreenInput :: T.Text -> Universe -> Universe
+doInputScreenInput s u =
+    u & doTextInputOver (uvScreenLayers . _head . scInput)
+        & checkEndStatus
+  where
+    pkeys = u ^. uvWorld . input . pressedKeys
+    checkEndStatus
+        | ScancodeReturn `M.member` pkeys = (uvScreenLayers %~ tail) 
+            . applyTerminalString (words $ T.unpack s)
+        | ScancodeEscape `M.member` pkeys = uvScreenLayers %~ tail
+        | otherwise = id
+
 updateKeysInTerminal :: Int -> Universe -> Universe
 updateKeysInTerminal tmid u =
-    u & tmpoint %~ (`T.append` T.toUpper thetext)
+    u & doTextInputOver tmpoint 
-        & checkBackspace
         & checkEndStatus
   where
     tmpoint = uvWorld . cWorld . lWorld . terminals . ix tmid . tmInput . tiText
-    thetext = u ^. uvWorld . input . textInput
-    checkBackspace
-        | backspaceInputted u = tmpoint %~ doBackspace
-        | otherwise = id
     pkeys = u ^. uvWorld . input . pressedKeys
     checkEndStatus
         | pkeys ^. at ScancodeReturn == Just InitialPress =
@@ -79,6 +91,10 @@ updateKeyInGame uv sc InitialPress = case sc of
     ScancodeT -> over uvWorld testEvent uv
     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 -> set (uvWorld . hud . hudElement . subInventory . subInvRegexInput) True uv
+    -- in fact the whole logic should probably be rethought, oh well
     _ -> uv
 updateKeyInGame uv sc LongPress = case sc of
     ScancodeF -> over uvWorld youDropItem uv

src/Dodge/Update/UsingInput.hs

@@ -30,9 +30,11 @@ pressedMBEffects subinv pkeys w = case subinv of
         | ButtonLeft `M.member` pkeys && w ^?! input . hammers . ix SubInvHam /= HammerUp ->
             w & input . hammers . ix SubInvHam .~ HammerDown
         | otherwise -> pressedMBEffectsNoInventory pkeys w
-    CombineInventory mi
+    CombineInventory mi _ False
         | pkeys ^? ix ButtonLeft == Just False ->
             maybeexitcombine (maybe id doCombine mi w) & input . hammers . ix SubInvHam .~ HammerDown
+    CombineInventory _ _ True | pkeys ^? ix ButtonLeft == Just False 
+        -> w & hud . hudElement . subInventory . subInvRegexInput .~ False
     DisplayTerminal tmid
         | pkeys ^? ix ButtonLeft == Just False && inTermFocus w ->
             doTerminalEffectLB (w ^?! cWorld . lWorld . terminals . ix tmid) w

src/Regex.hs

@@ -0,0 +1,8 @@
+module Regex where
+import Data.List
+
+regexIn :: String -> String -> Bool
+regexIn = isInfixOf
+
+regexList :: String -> [String] -> Bool
+regexList x = any (isInfixOf x)