justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Start adding filters to selection lists

Browse Source
This commit is contained in:
justin
2023-01-15 11:55:32 +00:00
parent 6f1162f7b9
commit 64b1c2761e
16 changed files with 128 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Combine.hs
+6 -1
View File
@@ -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
+3 -1
View File
@@ -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
+6 -2
View File
@@ -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
+2 -2
View File
@@ -194,8 +194,8 @@ updateRBList w
w
& rbOptions
.~ EquipOptions
{ _opEquip = (equipSiteToPositions esite)
, _opSel = (chooseEquipmentPosition cr (equipSiteToPositions esite))
{ _opEquip = equipSiteToPositions esite
, _opSel = chooseEquipmentPosition cr (equipSiteToPositions esite)
, _opItemID = itid
, _opAllocateEquipment = DoNotMoveEquipment
, _opActivateEquipment = NoChangeActivateEquipment
src/Dodge/Inventory/SelectionList.hs
+9 -13
View File
@@ -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
UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
_ | crSel cr == i -> map (color col . text) (selectedItemDisplay cr it)
_ -> map (color col . text) (itemDisplay it)
pics = take (itSlotsTaken it) . (++ replicate 10 "*") $ case _itCurseStatus it of
UndroppableIdentified -> itemDisplay it
_ | crSel cr == i -> selectedItemDisplay cr 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)
Right bt -> ([color yellow $ textindent $ _btText bt], yellow)
in (map textindent $ itemDisplay it, thecol it)
Right bt -> ([textindent $ _btText bt], yellow)
where
textindent = text . (replicate clObjIntIn ' ' ++)
applycolor it
| nfreeslots >= itSlotsTaken it = color $ _itInvColor it
| otherwise = color invDimColor
textindent = (replicate clObjIntIn ' ' ++)
thecol it
| nfreeslots >= itSlotsTaken it = _itInvColor it
| otherwise = invDimColor
src/Dodge/Item/Draw/SPic.hs
+1 -1
View File
@@ -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
-4
View File
@@ -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
+1 -1
View File
@@ -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
+5 -3
View File
@@ -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
+19 -17
View File
@@ -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"
(combineListSelection w mi)
("COMBINE")
(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 ()
thesellist tm = SelectionList (thelist tm) Nothing (length (thelist tm))
toselitm (str, col) = SelectionItem [str] 1 True (length str) col 0 ()
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 w mi =
combineListSelection :: World -> Maybe Int -> String -> Bool -> SelectionList ()
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)
-- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90)))
_ -> map (color thecolor . text) (itemDisplay it)
UndroppableIdentified -> itemDisplay it
_ -> itemDisplay it
where
thecolor = _itInvColor it
f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
f = take (itSlotsTaken it) . (++ replicate 10 "*")
openCursorAt ::
-- | Width
src/Dodge/Render/List.hs
+21 -2
View File
@@ -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
+9
View File
@@ -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
+1
View File
@@ -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
+34 -18
View File
@@ -2,6 +2,7 @@ module Dodge.Update.Input (
updateKeyInGame,
updateKeysInTerminal,
doInputScreenInput,
doSubInvRegexInput,
) where
import qualified Data.Map.Strict as M
@@ -22,22 +23,15 @@ import Dodge.WorldPos
import LensHelp
import SDL
doInputScreenInput :: T.Text -> Universe -> Universe
doInputScreenInput s u =
u & uvScreenLayers . _head . scInput %~ (`T.append` T.toUpper thetext)
& checkBackspace
& checkEndStatus
doTextInputOver :: ASetter' Universe T.Text -> Universe -> Universe
doTextInputOver p u = u & p %~ (`T.append` T.toUpper thetext)
& checkBackspace
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
doBackspace t = case T.unsnoc t of
Nothing -> t
@@ -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)
& checkBackspace
u & doTextInputOver tmpoint
& 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
+3 -1
View File
@@ -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
+8
View File
@@ -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)