Implement simple indenting in selection menu

This commit is contained in:
2024-09-12 18:14:52 +01:00
parent 4dedba8d30
commit e69abf1715
8 changed files with 226 additions and 217 deletions
+15
View File
@@ -17,9 +17,24 @@ data DoubleTreeNodeType
| DTMidBelowNode
| DTBottomNode
-- for each child, records the link type to the father node
data LabelDoubleTreeNodeType a
= LDTRootNode
| LDTTopNode a
| LDTMidAboveNode a
| LDTMidBelowNode a
| LDTBottomNode a
data DoubleTree a = DT {_dtValue :: a,_dtLeft :: [DoubleTree a],_dtRight :: [DoubleTree a]}
deriving (Eq,Ord,Show,Read)
--data FLatLabelDoubleTreeNode b a = FLDT
-- {_fldtValue :: a
-- ,_fldtType ::
-- ,_fldtIndentation :: Int
-- ,_fldtID :: Int
-- ,_fldtChildren =
data LabelDoubleTree b a = LDT {_ldtValue :: a, _ldtLeft :: [(b,LabelDoubleTree b a)]
,_ldtRight :: [(b,LabelDoubleTree b a)]}
deriving (Eq,Ord,Show,Read)
+3 -8
View File
@@ -9,10 +9,9 @@ module Dodge.DisplayInventory (
updateCombinePositioning,
) where
import Dodge.Data.DoubleTree
import Control.Monad
import qualified Data.IntMap.Strict as IM
import qualified Data.IntMap.Merge.Strict as MIM
--import qualified Data.IntMap.Merge.Strict as MIM
import Data.Maybe
import Dodge.Base.You
import Dodge.Combine
@@ -116,9 +115,8 @@ updateDisplaySections w cfig sss =
map closeObjectToSelectionItem (w ^. hud . closeObjects)
--invitems' = MIM.merge MIM.dropMissing MIM.dropMissing (MIM.zipWithMatched $ const addindent) indents $ IM.mapWithKey (invSelectionItem cr) inv
invitems' = IM.mapWithKey (invSelectionItem cr) inv
addindent x y = y & siPictures %~ map (x ++)
cr = you w
inv = _crInv (you w)
inv = invIndentIM $ _crInv (you w)
--indents = indentInv inv
--inv = indentInv $ _crInv (you w)
nfreeslots = crNumFreeSlots cr
@@ -150,7 +148,7 @@ updateInventorySectionItems w =
where
f olditems = fromMaybe olditems $ do
cr <- w ^? cWorld . lWorld . creatures . ix 0
invitms <- IM.mapWithKey (invSelectionItem cr) <$> cr ^? crInv
invitms <- IM.mapWithKey (invSelectionItem' cr) <$> cr ^? crInv
return $ case w ^? hud . hudElement . diSections . sssExtra . sssFilters . ix (-1) . _Just of
Just str -> IM.filter (plainRegex str) invitms
_ -> invitms
@@ -250,9 +248,6 @@ updateSection sis mcsel availablelines ss =
h (_, str) = translate (fromIntegral (_ssIndent ss) * 100) 0 str
theindent = replicate (_ssIndent ss) ' '
displaySelectionSection :: SelectionSection a -> Picture
displaySelectionSection ss = undefined
listSelectionColorPicture :: Foldable t => t (SelectionItem a) -> [(Color,Picture)]
listSelectionColorPicture = foldMap f
where
+36
View File
@@ -2,6 +2,9 @@ module Dodge.DoubleTree where
import Dodge.Data.DoubleTree
ldtToDT :: LabelDoubleTree b a -> DoubleTree a
ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
-- conceptually, in a tree growing from left to right,
-- bottom -> top is equated with left -> right.
-- this does not match with thinking of a list as top -> bottom, so take care
@@ -15,6 +18,30 @@ dtIL nt (DT x l r) = map doindent (concat (headMap (dtIL DTBottomNode) (dtIL DTM
where
doindent (a,b,c) = (a,b+1,c)
ldtToIndentList :: LabelDoubleTree b a -> [(a,Int,LabelDoubleTreeNodeType b)]
ldtToIndentList = ldtIL LDTRootNode
ldtIL :: LabelDoubleTreeNodeType b -> LabelDoubleTree b a -> [(a,Int,LabelDoubleTreeNodeType b)]
ldtIL nt (LDT x l r) = map doindent
(concat
(headMap
(\(lab,c) -> ldtIL (LDTBottomNode lab) c)
(\(lab,c) -> ldtIL (LDTMidBelowNode lab) c)
l
)
)
++ [(x,0,nt)]
++ map doindent
(concat
(lastMap
(\(lab,c) -> ldtIL (LDTTopNode lab) c)
(\(lab,c) -> ldtIL (LDTMidAboveNode lab) c)
r
)
)
where
doindent (a,b,c) = (a,b+1,c)
headMap :: (a -> b) -> (a -> b) -> [a] -> [b]
headMap f g (x:xs) = f x : map g xs
headMap _ _ [] = []
@@ -24,3 +51,12 @@ lastMap _ _ [] = []
lastMap f _ (x:[]) = [f x]
lastMap f g (x:xs) = g x : lastMap f g xs
prettyDT :: (a -> String) -> DoubleTree a -> [String]
prettyDT f (DT x l r) = concatMap (map ('/':) . prettyDT f) r
++ (f x : concatMap (map ('\\':) . prettyDT f) l)
prettyLDT :: (a -> String) -> LabelDoubleTree b a -> [String]
prettyLDT f (LDT x l r) = concatMap (map ('/':) . prettyLDT f . snd) r
++ (f x : concatMap (map ('\\':) . prettyLDT f . snd) l)
+21 -2
View File
@@ -1,5 +1,6 @@
module Dodge.Inventory.SelectionList (
invSelectionItem,
invSelectionItem',
closeObjectToSelectionItem,
) where
@@ -13,8 +14,8 @@ import Dodge.Item.InventoryColor
import LensHelp
import Picture.Base
invSelectionItem :: Creature -> Int -> Item -> SelectionItem ()
invSelectionItem cr i it =
invSelectionItem' :: Creature -> Int -> Item -> SelectionItem ()
invSelectionItem' cr i it =
SelectionItem
{ _siPictures = pics & ix 0 %~ (++ anyequippos ++ anyhotkey)
, _siHeight = itSlotsTaken it
@@ -31,6 +32,24 @@ invSelectionItem cr i it =
UndroppableIdentified -> itemDisplay cr it
_ -> itemDisplay cr it
invSelectionItem :: Creature -> Int -> (Item,Int,a) -> SelectionItem ()
invSelectionItem cr i (it,indent,_) =
SelectionItem
{ _siPictures = pics & ix 0 %~ (++ anyequippos ++ anyhotkey)
, _siHeight = itSlotsTaken it
, _siIsSelectable = True
, _siColor = col
, _siOffX = indent
, _siPayload = ()
}
where
anyhotkey = maybe [] ((' ':) .hotkeyToString) (cr ^? crInvHotkeys . ix i)
anyequippos = maybe [] (rightPad 8 ' ' . (' ':) . eqPosText) (cr ^? crInvEquipped . ix i)
col = itemInvColor it
pics = case _itCurseStatus it of
UndroppableIdentified -> itemDisplay cr it
_ -> itemDisplay cr it
hotkeyToString :: Hotkey -> String
hotkeyToString x = case x of
HotkeyQ -> "[Q]"
+79 -80
View File
@@ -14,28 +14,20 @@ import qualified Data.IntMap.Strict as IM
import Control.Lens
import Dodge.DoubleTree
type PCI = (ComposedItem, [ComposedItem], [ComposedItem])
type PCI' = (Item,ComposedItem,[ComposedItem], [ComposedItem])
type PCI'' = (Item,ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,ComposedItem)])
type ComposedItemStructure
= (Item,ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,ComposedItem)])
type CIL = (ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,ComposedItem)])
cisToItem :: ComposedItemStructure -> Item
cisToItem (x,_,_,_) = x
singleDT :: a -> DoubleTree a
singleDT x = DT x [] []
singleLDT :: a -> LabelDoubleTree b a
singleLDT x = LDT x [] []
baseComposedItem :: ItemBaseType -> PCI
baseComposedItem ibt = case ibt of
HELD BURSTRIFLE -> (WeaponCI, [BulletAmmoCI], [])
AMMOMAG TINMAG -> (BulletAmmoCI, [AmmoModifierCI], [])
AMMOMAG DRUMMAG -> (BulletAmmoCI, [AmmoModifierCI], [])
ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI, [], [])
_ -> (UncomposableCI, [], [])
baseComposedItem' :: ItemBaseType -> CIL
baseComposedItem' ibt = case ibt of
HELD BURSTRIFLE -> (WeaponCI, [(AmmoInLink,BulletAmmoCI)], [])
@@ -44,31 +36,24 @@ baseComposedItem' ibt = case ibt of
ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI, [], [])
_ -> (UncomposableCI, [], [])
basePCI :: Item -> PCI''
basePCI itm = let (a,b,c) = baseComposedItem' (itm ^. itType . iyBase)
baseCIS :: Item -> ComposedItemStructure
baseCIS itm = let (a,b,c) = baseComposedItem' (itm ^. itType . iyBase)
in (itm, a, b, c)
baseCI :: Item -> PCI'
baseCI itm = let (a,b,c) = baseComposedItem (itm ^. itType . iyBase)
in (itm, a, b, c)
combineMaybe :: (a -> a -> Maybe b) -> (a -> a -> b -> a) -> a -> a -> Maybe a
combineMaybe t f x y = fmap (f x y) (t x y)
type LDTTest a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe b
type LDTCombine a b = LabelDoubleTree b a -> LabelDoubleTree b a -> b -> LabelDoubleTree b a
type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
-- the following imposes a strict ordering on the possible attachments
leftIsParentCombine :: LDTComb PCI'' ComposeLinkType
leftIsParentCombine :: LDTComb ComposedItemStructure ComposeLinkType
leftIsParentCombine (LDT (itm,p,lc,rc) lt rt) t'@(LDT (_,p',_,_) _ _) = do
let f (_,x) = p' == x
(_,ys) = break f rc
(linktype,_) <- safeHead ys
return $ LDT (itm,p,lc,tail ys) lt (rt ++ [(linktype,t')])
rightIsParentCombine :: LDTComb PCI'' ComposeLinkType
rightIsParentCombine :: LDTComb ComposedItemStructure ComposeLinkType
rightIsParentCombine t'@(LDT (_,p',_,_) _ _) (LDT (itm,p,lc,rc) lt rt) = do
let f (_,x) = p' == x
(_,ys) = break f lc
@@ -86,19 +71,6 @@ leftRightCombine f f' t1 t2 = f t1 t2
return $ Just $ LDT x ((lab,tx):tail ls) rs
checktop t t' = f' t t'
joinItems :: DoubleTree PCI' -> DoubleTree PCI' -> Maybe (DoubleTree PCI')
joinItems t@(DT (itm,px,lc',rc') ls' rs') s@(DT (_,py,_,_) _ _)
| py `elem` rc' = Just (DT (itm,px,lc', delete py rc') ls' (rs' ++ [s]))
| otherwise = checkdepth t s
where
checkdepth a a'@(DT b ls rs) = fromMaybe (checktop a a') $ do
c <- safeHead ls
d <- checkdepth a c
return $ Just $ DT b (d:tail ls) rs
checktop a@(DT (_,pa,_,_) _ _) (DT (itm2,pb,lc,rc) ls rs)
| pa `elem` lc = Just (DT (itm2,pb, delete pa lc,rc) (a:ls) rs)
| otherwise = Nothing
joinItemsInList :: (a -> a -> Maybe a) -> [a] -> [a]
joinItemsInList f xs = snd $ h (xs,[])
where
@@ -108,52 +80,79 @@ joinItemsInList f xs = snd $ h (xs,[])
Nothing -> h (ys, (y:z:zs))
Just w -> h ((w:ys),zs)
indentDoubleTreeWith :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
indentDoubleTreeWith f g h (DT x l r) = DT x
(headMap (iDTL f g h) (iDTboth f g h) l)
(lastMap (iDTR f g h) (iDTboth f g h) r)
iDTL :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
iDTL fspace fline flink (DT x l r) = DT (flink x)
(map (fmap fspace . indentDoubleTreeWith fspace fline flink) l)
(map (fmap fline . indentDoubleTreeWith fspace fline flink) r)
iDTR :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
iDTR fspace fline flink (DT x l r) = DT (flink x)
(map (fmap fline . indentDoubleTreeWith fspace fline flink) l)
(map (fmap fspace . indentDoubleTreeWith fspace fline flink) r)
iDTboth :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
iDTboth fspace fline flink (DT x l r) = DT (flink x)
(map (fmap fline . indentDoubleTreeWith fspace fline flink) l)
(map (fmap fline . indentDoubleTreeWith fspace fline flink) r)
flattenDT :: DoubleTree a -> [a]
flattenDT (DT x l r) = concatMap flattenDT l ++ (x : concatMap flattenDT r)
prettyDT :: (a -> String) -> DoubleTree a -> [String]
prettyDT f (DT x l r) = concatMap (map ('/':) . prettyDT f) r
++ (f x : concatMap (map ('\\':) . prettyDT f) l)
prettyLDT :: (a -> String) -> LabelDoubleTree b a -> [String]
prettyLDT f (LDT x l r) = concatMap (map ('/':) . prettyLDT f . snd) r
++ (f x : concatMap (map ('\\':) . prettyLDT f . snd) l)
invTree :: IM.IntMap Item -> [String]
invTree = concatMap (prettyDT (\(itm,_,_,_) -> show (_itType itm))) .
joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
--indentInv :: IM.IntMap Item -> IM.IntMap String
--indentInv = IM.fromList . zip [0..] .
-- reverse . concatMap (flattenDT .indentDoubleTreeWith (' ':) ('|':) ('+':) . fmap (const "")) .
-- joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
--invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType PCI'']
invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType PCI'']
invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItemStructure]
invLDT = joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems .
fmap (singleLDT . basePCI)
fmap (singleLDT . baseCIS)
invIndentIM' :: IM.IntMap Item -> IM.IntMap (Item,Int, ())
invIndentIM' = fmap (\x -> (x,0,()))
invIndentIM :: IM.IntMap Item -> IM.IntMap (Item,Int, LabelDoubleTreeNodeType ComposeLinkType )
invIndentIM = IM.fromAscList . zip [0..] . reverse . map (over _1 cisToItem) . concatMap ldtToIndentList . invLDT
--indentInv :: IM.IntMap Item -> [String]
--indentInv = concat . fmap (flattenDT . indentDoubleTreeWith (' ':) ('|':) ('+':) . fmap const "")
-- . joinItemsInList joinItems
-- . IM.toList . fmap (singleDT . baseComposedItem)
--
--type PCI = (ComposedItem, [ComposedItem], [ComposedItem])
--
--type PCI' = (Item,ComposedItem,[ComposedItem], [ComposedItem])
--baseComposedItem :: ItemBaseType -> PCI
--baseComposedItem ibt = case ibt of
-- HELD BURSTRIFLE -> (WeaponCI, [BulletAmmoCI], [])
-- AMMOMAG TINMAG -> (BulletAmmoCI, [AmmoModifierCI], [])
-- AMMOMAG DRUMMAG -> (BulletAmmoCI, [AmmoModifierCI], [])
-- ATTACH BULLETSYNTHESIZER -> (AmmoModifierCI, [], [])
-- _ -> (UncomposableCI, [], [])
--
--baseCI :: Item -> PCI'
--baseCI itm = let (a,b,c) = baseComposedItem (itm ^. itType . iyBase)
-- in (itm, a, b, c)
--
--joinItems :: DoubleTree PCI' -> DoubleTree PCI' -> Maybe (DoubleTree PCI')
--joinItems t@(DT (itm,px,lc',rc') ls' rs') s@(DT (_,py,_,_) _ _)
-- | py `elem` rc' = Just (DT (itm,px,lc', delete py rc') ls' (rs' ++ [s]))
-- | otherwise = checkdepth t s
-- where
-- checkdepth a a'@(DT b ls rs) = fromMaybe (checktop a a') $ do
-- c <- safeHead ls
-- d <- checkdepth a c
-- return $ Just $ DT b (d:tail ls) rs
-- checktop a@(DT (_,pa,_,_) _ _) (DT (itm2,pb,lc,rc) ls rs)
-- | pa `elem` lc = Just (DT (itm2,pb, delete pa lc,rc) (a:ls) rs)
-- | otherwise = Nothing
--
--invTree :: IM.IntMap Item -> [String]
--invTree = concatMap (prettyDT (\(itm,_,_,_) -> show (_itType itm))) .
-- joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
--indentInv :: IM.IntMap Item -> IM.IntMap String
--indentInv = IM.fromList . zip [0..] .
-- reverse . concatMap (flattenDT .indentDoubleTreeWith (' ':) ('|':) ('+':) . fmap (const "")) .
-- joinItemsInList joinItems . IM.elems . fmap (singleDT . baseCI)
--
--indentDoubleTreeWith :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
--indentDoubleTreeWith f g h (DT x l r) = DT x
-- (headMap (iDTL f g h) (iDTboth f g h) l)
-- (lastMap (iDTR f g h) (iDTboth f g h) r)
--
--iDTL :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
--iDTL fspace fline flink (DT x l r) = DT (flink x)
-- (map (fmap fspace . indentDoubleTreeWith fspace fline flink) l)
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) r)
--
--iDTR :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
--iDTR fspace fline flink (DT x l r) = DT (flink x)
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) l)
-- (map (fmap fspace . indentDoubleTreeWith fspace fline flink) r)
--
--iDTboth :: (a -> a) -> (a -> a) -> (a -> a) -> DoubleTree a -> DoubleTree a
--iDTboth fspace fline flink (DT x l r) = DT (flink x)
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) l)
-- (map (fmap fline . indentDoubleTreeWith fspace fline flink) r)
--combineMaybe :: (a -> a -> Maybe b) -> (a -> a -> b -> a) -> a -> a -> Maybe a
--combineMaybe t f x y = fmap (f x y) (t x y)
-4
View File
@@ -12,7 +12,6 @@ module Dodge.Render.List (
listCursorChooseBorderScale,
) where
import Dodge.Data.DoubleTree
import Dodge.SelectionSections
import Data.Maybe
import Dodge.Base.Window
@@ -76,9 +75,6 @@ getLDPWidth ldps = case _ldpWidth ldps of
drawListYoff :: Int -> [Picture] -> Picture
drawListYoff = drawListYgapScaleYoff 0 1
drawTreeYgapScaleYoff :: Float -> Float -> Int -> DoubleTree [Picture] -> Picture
drawTreeYgapScaleYoff ygap s i = undefined
drawListYgapScaleYoff :: Float -> Float -> Int -> [Picture] -> Picture
drawListYgapScaleYoff ygap s i = mconcat . zipWith (drawListElement ygap s 0) [i ..]