Implement simple indenting in selection menu
This commit is contained in:
+79
-80
@@ -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)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user