Cleanup LabelDoubleTree -> LDTree
This commit is contained in:
+14
-100
@@ -27,35 +27,10 @@ import Dodge.DoubleTree
|
||||
import LensHelp
|
||||
import ListHelp
|
||||
|
||||
tryAttachItems ::
|
||||
LabelDoubleTree ItemLink CItem ->
|
||||
LabelDoubleTree ItemLink CItem ->
|
||||
Maybe (LabelDoubleTree ItemLink CItem)
|
||||
tryAttachItems :: LDTree ItemLink CItem -> LDTree ItemLink CItem ->
|
||||
Maybe (LDTree ItemLink CItem)
|
||||
tryAttachItems = leftRightCombine leftIsParentCombine rightIsParentCombine
|
||||
|
||||
useBreakL ::
|
||||
[(ItemStructuralFunction, ItemLink)] ->
|
||||
[(ItemStructuralFunction, ItemLink)] ->
|
||||
LinkTest
|
||||
useBreakL llist rlist = LTest ltest rtest
|
||||
where
|
||||
ltest ldt = do
|
||||
let xs =
|
||||
dropWhile
|
||||
((\s -> not $ S.member s (structureToPotentialFunction ldt)) . fst)
|
||||
llist
|
||||
(sf, linktype) <- safeHead xs
|
||||
return $ LUpdate linktype (set _3 (useBreakL (tail xs) rlist))
|
||||
(_2 .~ sf)
|
||||
rtest ldt = do
|
||||
let xs =
|
||||
dropWhile
|
||||
((\s -> not $ S.member s (structureToPotentialFunction ldt)) . fst)
|
||||
rlist
|
||||
(sf, linktype) <- safeHead xs
|
||||
return $ LUpdate linktype (set _3 (useBreakL llist (tail xs)))
|
||||
(_2 .~ sf)
|
||||
|
||||
itemToBreakLists ::
|
||||
Item ->
|
||||
ItemStructuralFunction ->
|
||||
@@ -173,9 +148,7 @@ itemToFunction itm = case itm ^. itType of
|
||||
CLICKER{} -> GadgetPlatformSF
|
||||
_ -> NoSF
|
||||
|
||||
structureToPotentialFunction ::
|
||||
LabelDoubleTree ItemLink CItem ->
|
||||
S.Set ItemStructuralFunction
|
||||
structureToPotentialFunction :: LDTree ItemLink CItem -> S.Set ItemStructuralFunction
|
||||
structureToPotentialFunction ldt = case ldt ^. ldtValue . _1 . itType of
|
||||
STICKYMOD -> S.singleton GrenadeHitEffectSF
|
||||
ATTACH GIMBAL -> S.singleton ProjectileStabiliserSF
|
||||
@@ -184,52 +157,9 @@ structureToPotentialFunction ldt = case ldt ^. ldtValue . _1 . itType of
|
||||
_ -> S.singleton (ldt ^. ldtValue . _2)
|
||||
|
||||
baseCI :: Item -> CItem
|
||||
baseCI itm = (itm, itemToFunction itm, itemBaseConnections itm)
|
||||
baseCI itm = (itm, itemToFunction itm)
|
||||
|
||||
itemBaseConnections :: Item -> LinkTest
|
||||
itemBaseConnections itm = case _itType itm of
|
||||
HELD LASER -> laserLinkTest itm
|
||||
CRAFT SPRING -> springLinkTest
|
||||
_ -> uncurry useBreakL $ itemToBreakLists itm (itemToFunction itm)
|
||||
|
||||
laserLinkTest :: Item -> LinkTest
|
||||
laserLinkTest itm = LTest (llleft itm) (llright itm)
|
||||
|
||||
llleft :: Item -> LabelDoubleTree ItemLink CItem -> Maybe LinkUpdate
|
||||
llleft itm =
|
||||
_tryLeftLink
|
||||
. uncurry useBreakL
|
||||
$ itemToBreakLists itm WeaponTargetingSF
|
||||
|
||||
llright :: Item -> LabelDoubleTree ItemLink CItem -> Maybe LinkUpdate
|
||||
llright itm pci = case pci ^. ldtValue . _1 . itType of
|
||||
CRAFT TRANSFORMER -> Just (toLasgunUpdate itm)
|
||||
_ -> _tryRightLink (uncurry useBreakL $ itemToBreakLists itm WeaponTargetingSF) pci
|
||||
|
||||
toLasgunUpdate :: Item -> LinkUpdate
|
||||
toLasgunUpdate itm =
|
||||
LUpdate
|
||||
FunctionChangeLink
|
||||
(\(par, _, _) -> (par, HeldPlatformSF, uncurry useBreakL $ itemToBreakLists itm HeldPlatformSF))
|
||||
(\(chi, _, up) -> (chi, FunctionChangeSF, up))
|
||||
|
||||
springLinkTest :: LinkTest
|
||||
springLinkTest = LTest (const Nothing) $
|
||||
\ci -> case ci ^. ldtValue . _1 . itType of
|
||||
CRAFT HARDWARE ->
|
||||
Just
|
||||
( LUpdate
|
||||
(FunctionChangeLink)
|
||||
(\(par, _, up) -> (par, MakeAutoSF, up))
|
||||
(\(chi, _, up) -> (chi, FunctionChangeSF, up))
|
||||
)
|
||||
_ -> Nothing
|
||||
|
||||
--itemLinkTestLeft :: Item -> PartiallyCItem -> Maybe LinkUpdate
|
||||
--itemLinkTestLeft itm = _tryLeftLink $
|
||||
-- uncurry useBreakL $ itemToBreakLists itm
|
||||
|
||||
type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
|
||||
type LDTComb a b = LDTree b a -> LDTree b a -> Maybe (LDTree b a)
|
||||
|
||||
leftIsParentCombine :: LDTComb CItem ItemLink
|
||||
leftIsParentCombine ltree rtree = do
|
||||
@@ -239,13 +169,6 @@ leftIsParentCombine ltree rtree = do
|
||||
return $
|
||||
ltree & ldtRight .:~ (linktype, rtree & ldtValue . _2 .~ sf)
|
||||
|
||||
leftIsParentCombine' :: LDTComb CItem ItemLink
|
||||
leftIsParentCombine' ltree rtree = do
|
||||
lu <- (ltree ^. ldtValue . _3 . tryRightLink) rtree --(rtree ^. ldtValue)
|
||||
return $
|
||||
ltree & ldtValue %~ (lu ^. luParentUpdate)
|
||||
& ldtRight %~ (++ [(lu ^. luLinkType, rtree & ldtValue %~ (lu ^. luChildUpdate))])
|
||||
|
||||
rightIsParentCombine :: LDTComb CItem ItemLink
|
||||
rightIsParentCombine ltree rtree = do
|
||||
let l = leftChildList rtree
|
||||
@@ -254,31 +177,24 @@ rightIsParentCombine ltree rtree = do
|
||||
return $
|
||||
rtree & ldtLeft .:~ (linktype, ltree & ldtValue . _2 .~ sf)
|
||||
|
||||
leftChildList :: LabelDoubleTree ItemLink CItem -> [(ItemStructuralFunction, ItemLink)]
|
||||
leftChildList :: LDTree ItemLink CItem -> [(ItemStructuralFunction, ItemLink)]
|
||||
leftChildList t = foldl' f l (reverse $ t ^.. ldtLeft . each . _1)
|
||||
where
|
||||
l = fst $ itemToBreakLists (t ^. ldtValue . _1) (t ^. ldtValue . _2)
|
||||
f x y = tail $ dropWhile ((/=y) . snd) x
|
||||
|
||||
rightChildList :: LabelDoubleTree ItemLink CItem -> [(ItemStructuralFunction, ItemLink)]
|
||||
rightChildList :: LDTree ItemLink CItem -> [(ItemStructuralFunction, ItemLink)]
|
||||
rightChildList t = foldl' f l (reverse $ t ^.. ldtRight . each . _1)
|
||||
where
|
||||
l = snd $ itemToBreakLists (t ^. ldtValue . _1) (t ^. ldtValue . _2)
|
||||
f x y = tail $ dropWhile ((/=y) . snd) x
|
||||
|
||||
rightIsParentCombine' :: LDTComb CItem ItemLink
|
||||
rightIsParentCombine' ltree rtree = do
|
||||
lu <- (rtree ^. ldtValue . _3 . tryLeftLink) ltree -- (ltree ^. ldtValue)
|
||||
return $
|
||||
rtree & ldtValue %~ (lu ^. luParentUpdate)
|
||||
& ldtLeft .:~ (lu ^. luLinkType, ltree & ldtValue %~ (lu ^. luChildUpdate))
|
||||
|
||||
leftRightCombine ::
|
||||
LDTComb a b ->
|
||||
LDTComb a b ->
|
||||
LabelDoubleTree b a ->
|
||||
LabelDoubleTree b a ->
|
||||
Maybe (LabelDoubleTree b a)
|
||||
LDTree b a ->
|
||||
LDTree b a ->
|
||||
Maybe (LDTree b a)
|
||||
leftRightCombine f f' t1 t2 = f t1 t2 <|> checkdepth t1 t2
|
||||
where
|
||||
checkdepth t t'@(LDT x ls rs) = fromMaybe (checktop t t') $ do
|
||||
@@ -297,7 +213,7 @@ joinItemsInList f xs = snd $ h (xs, [])
|
||||
Just w -> h (w : ys, zs)
|
||||
|
||||
-- this puts the first elements in the intmap at the end of the list
|
||||
invLDT :: IM.IntMap Item -> [LabelDoubleTree ItemLink CItem]
|
||||
invLDT :: IM.IntMap Item -> [LDTree ItemLink CItem]
|
||||
invLDT =
|
||||
joinItemsInList tryAttachItems . IM.elems
|
||||
. fmap (singleLDT . baseCI)
|
||||
@@ -321,18 +237,16 @@ invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int, Int), [Int], [Int])
|
||||
invAdj = IM.unions . map g . invLDT
|
||||
where
|
||||
g = dtToLRAdj getid . ldtToDT
|
||||
getid (itm, _, _) =
|
||||
getid (itm, _) =
|
||||
fromMaybe
|
||||
(error ("invAdj item " ++ show (_itID itm) ++ " location: " ++ show (itm ^? itLocation)))
|
||||
$ itm ^? itLocation . ilInvID
|
||||
|
||||
-- returns an intmap with trees for (only!) root items, indexed by inventory position
|
||||
invRootTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink CItem)
|
||||
invRootTrees :: IM.IntMap Item -> IM.IntMap (LDTree ItemLink CItem)
|
||||
invRootTrees = IM.fromDistinctAscList . reverse . map getid . invLDT
|
||||
where
|
||||
getid ::
|
||||
LabelDoubleTree ItemLink CItem ->
|
||||
(Int, LabelDoubleTree ItemLink CItem)
|
||||
getid :: LDTree ItemLink CItem -> (Int, LDTree ItemLink CItem)
|
||||
getid t = (t ^?! ldtValue . _1 . itLocation . ilInvID, t)
|
||||
|
||||
-- returns an intmap with indents and locations for all items
|
||||
|
||||
Reference in New Issue
Block a user