From dd5a747559e19a95542da165b30adc8acea16f84 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 27 Jun 2025 08:55:00 +0100 Subject: [PATCH] Cleanup LabelDoubleTree -> LDTree --- src/Dodge/Creature/Impulse/UseItem.hs | 2 +- src/Dodge/Creature/State.hs | 6 +- src/Dodge/Data/ComposedItem.hs | 20 +---- src/Dodge/Data/DoubleTree.hs | 33 +++----- src/Dodge/DoubleTree.hs | 26 +++--- src/Dodge/HeldUse.hs | 57 ++++++------- src/Dodge/Item/AimStance.hs | 2 +- src/Dodge/Item/Draw.hs | 2 +- src/Dodge/Item/Draw/SPic.hs | 8 +- src/Dodge/Item/Grammar.hs | 114 ++++---------------------- tags | 49 ++++++----- 11 files changed, 101 insertions(+), 218 deletions(-) diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index eec8a5866..0648c28c4 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -80,7 +80,7 @@ structureUseAtLoc = \case MapperSF -> True _ -> False -activateDetonator :: LabelDoubleTree ItemLink CItem -> World -> World +activateDetonator :: LDTree ItemLink CItem -> World -> World activateDetonator det = fromMaybe id $ do pjid <- det ^? ldtValue . _1 . itUse . uaParams . apProjectiles . ix 0 return $ cWorld . lWorld . projectiles . ix pjid . pjTimer .~ 0 diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 1d0065229..9d7f0a948 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -279,7 +279,7 @@ updateHeldRootItem cr = fromMaybe id $ do itmtree <- invRootTrees (_crInv cr) ^? ix invid return $ updateAttachedItems itmtree cr -updateAttachedItems :: LabelDoubleTree ItemLink CItem -> Creature -> World -> World +updateAttachedItems :: LDTree ItemLink CItem -> Creature -> World -> World updateAttachedItems itmtree cr = cldtPropagateFold chainLinkOrientation @@ -326,7 +326,7 @@ drawARHUD (LocLDT con _) w = fromMaybe w $ do shineTargetLaser :: Creature -> - LabelDoubleTree ItemLink CItem -> + LDTree ItemLink CItem -> (Point3, Q.Quaternion Float) -> World -> World @@ -367,7 +367,7 @@ shineTargetLaser cr itmtree (p, q) w = fromMaybe (w & pointittarg . itTgPos .~ N shineTorch :: Creature -> - LabelDoubleTree ItemLink CItem -> + LDTree ItemLink CItem -> (Point3, Q.Quaternion Float) -> World -> World diff --git a/src/Dodge/Data/ComposedItem.hs b/src/Dodge/Data/ComposedItem.hs index 97ebbfd64..d24638f82 100644 --- a/src/Dodge/Data/ComposedItem.hs +++ b/src/Dodge/Data/ComposedItem.hs @@ -6,7 +6,6 @@ module Dodge.Data.ComposedItem where import Dodge.Data.AmmoType -import Dodge.Data.DoubleTree import Control.Lens import Dodge.Data.Item @@ -63,23 +62,6 @@ data ItemStructuralFunction | MapperSF deriving (Eq, Ord, Show, Read) -type CItem = (Item, ItemStructuralFunction, LinkTest) - --- this should possibly use a full item structure tree rather than a --- CItem as arguments -data LinkTest = LTest - { _tryLeftLink :: LabelDoubleTree ItemLink CItem -> Maybe LinkUpdate - , _tryRightLink :: LabelDoubleTree ItemLink CItem -> Maybe LinkUpdate - } - -data LinkUpdate = LUpdate - { _luLinkType :: ItemLink - , _luParentUpdate :: CItem -> CItem - , _luChildUpdate :: CItem -> CItem - } +type CItem = (Item, ItemStructuralFunction) makeLenses ''ItemLink -makeLenses ''LinkTest -makeLenses ''LinkUpdate ---deriveJSON defaultOptions ''ItemStructuralFunction ---deriveJSON defaultOptions ''ComposeLinkType diff --git a/src/Dodge/Data/DoubleTree.hs b/src/Dodge/Data/DoubleTree.hs index e2bf71698..10b171add 100644 --- a/src/Dodge/Data/DoubleTree.hs +++ b/src/Dodge/Data/DoubleTree.hs @@ -30,17 +30,10 @@ data LabelDoubleTreeNodeType 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 +data LDTree b a = LDT -- LabelDoubleTree { _ldtValue :: a - , _ldtLeft :: [(b, LabelDoubleTree b a)] - , _ldtRight :: [(b, LabelDoubleTree b a)] + , _ldtLeft :: [(b, LDTree b a)] + , _ldtRight :: [(b, LDTree b a)] } deriving (Eq, Ord, Show, Read) @@ -49,24 +42,24 @@ data ContextLDT b a = TopLDT | LeftwardLDT { _cldtUp :: ContextLDT b a - , _cldtCloseLeft :: [(b, LabelDoubleTree b a)] + , _cldtCloseLeft :: [(b, LDTree b a)] , _cldtParent :: a , _cldtLink :: b - , _cldtCloseRight :: [(b, LabelDoubleTree b a)] - , _cldtFarRight :: [(b, LabelDoubleTree b a)] + , _cldtCloseRight :: [(b, LDTree b a)] + , _cldtFarRight :: [(b, LDTree b a)] } | RightwardLDT { _cldtUp :: ContextLDT b a - , _cldtFarLeft :: [(b, LabelDoubleTree b a)] - , _cldtCloseLeft :: [(b, LabelDoubleTree b a)] + , _cldtFarLeft :: [(b, LDTree b a)] + , _cldtCloseLeft :: [(b, LDTree b a)] , _cldtParent :: a , _cldtLink :: b - , _cldtCloseRight :: [(b, LabelDoubleTree b a)] + , _cldtCloseRight :: [(b, LDTree b a)] } data LocationLDT b a = LocLDT { _locLdtContext :: ContextLDT b a - , _locLDT :: LabelDoubleTree b a + , _locLDT :: LDTree b a } instance Functor DoubleTree where @@ -75,10 +68,10 @@ instance Functor DoubleTree where instance Foldable DoubleTree where foldMap f (DT x l r) = foldMap (foldMap f) l <> f x <> foldMap (foldMap f) r -instance Functor (LabelDoubleTree b) where +instance Functor (LDTree b) where fmap f (LDT x l r) = LDT (f x) (fmap (second $ fmap f) l) (fmap (second $ fmap f) r) -instance Bifunctor LabelDoubleTree where +instance Bifunctor LDTree where second = fmap first f (LDT x l r) = LDT @@ -87,7 +80,7 @@ instance Bifunctor LabelDoubleTree where (map (bimap f (first f)) r) makeLenses ''DoubleTree -makeLenses ''LabelDoubleTree +makeLenses ''LDTree makeLenses ''LocationLDT makeLenses ''ContextLDT --deriveJSON defaultOptions ''DoubleTree diff --git a/src/Dodge/DoubleTree.hs b/src/Dodge/DoubleTree.hs index 05bc06b22..3b05603c4 100644 --- a/src/Dodge/DoubleTree.hs +++ b/src/Dodge/DoubleTree.hs @@ -9,17 +9,17 @@ import Data.Monoid singleDT :: a -> DoubleTree a singleDT x = DT x [] [] -singleLDT :: a -> LabelDoubleTree b a +singleLDT :: a -> LDTree b a singleLDT x = LDT x [] [] -ldtToDT :: LabelDoubleTree b a -> DoubleTree a +ldtToDT :: LDTree b a -> DoubleTree a ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r) -- propagate two functions down the links of an LDT tree -- which function is chosen depends on whether it is a left or right branch ldtPropagate :: (c -> b -> c) -> (c -> b -> c) -> c - -> LabelDoubleTree b a -> LabelDoubleTree c a + -> LDTree b a -> LDTree c a ldtPropagate lf rf = ildtPropagate (const lf) (const rf) -- Propgates a value (of type c) down the branches of the LDT. @@ -30,7 +30,7 @@ ldtPropagateFold :: (c -> a -> b -> a -> c) -> (c -> a -> b -> a -> c) -> (c -> a -> d -> d) -> c - -> LabelDoubleTree b a + -> LDTree b a -> d -> d ldtPropagateFold lf rf up x (LDT v l r) = @@ -44,9 +44,9 @@ ldtPropagateFold lf rf up x (LDT v l r) = -- For each node-tree, the updated value is used to update a final value (of type d). ldtPropagateFoldTree :: (c -> a -> b -> a -> c) -> (c -> a -> b -> a -> c) - -> (c -> LabelDoubleTree b a -> d -> d) + -> (c -> LDTree b a -> d -> d) -> c - -> LabelDoubleTree b a + -> LDTree b a -> d -> d ldtPropagateFoldTree lf rf up x t@(LDT v l r) = @@ -56,12 +56,12 @@ ldtPropagateFoldTree lf rf up x t@(LDT v l r) = ildtPropagate :: (Int -> c -> b -> c) -> (Int -> c -> b -> c) -> c - -> LabelDoubleTree b a -> LabelDoubleTree c a + -> LDTree b a -> LDTree c a ildtPropagate lf rf x (LDT v l r) = LDT v (imap (go lf x) l) (imap (go rf x) r) where go f y i (z,t) = (f i y z, ildtPropagate lf rf (f i y z) t) -ldtPropagateIndices :: LabelDoubleTree b a -> LabelDoubleTree b (a, [Either Int Int]) +ldtPropagateIndices :: LDTree b a -> LDTree b (a, [Either Int Int]) ldtPropagateIndices (LDT x l r) = LDT (x,[]) (imap (f Left) l) (imap (f Right) r) where f e i (y,t) = (y, second (e i:) <$> ldtPropagateIndices t) @@ -140,13 +140,13 @@ dtToAdjRootParentEither root par f (DT x l r) = do where g = f . _dtValue -ldtToIM :: (a -> Int) -> LabelDoubleTree b a -> IM.IntMap (LabelDoubleTree b a) +ldtToIM :: (a -> Int) -> LDTree b a -> IM.IntMap (LDTree b a) ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $ l <> r -ldtToIndentList :: LabelDoubleTree b a -> [(a,Int,LabelDoubleTreeNodeType b)] +ldtToIndentList :: LDTree b a -> [(a,Int,LabelDoubleTreeNodeType b)] ldtToIndentList = ldtIL LDTRootNode -ldtIL :: LabelDoubleTreeNodeType b -> LabelDoubleTree b a -> [(a,Int,LabelDoubleTreeNodeType b)] +ldtIL :: LabelDoubleTreeNodeType b -> LDTree b a -> [(a,Int,LabelDoubleTreeNodeType b)] ldtIL nt (LDT x l r) = map doindent (concat (headMap @@ -180,11 +180,11 @@ 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 :: (a -> String) -> LDTree b a -> [String] prettyLDT f (LDT x l r) = concatMap (map ('/':) . prettyLDT f . snd) r ++ (f x : concatMap (map ('\\':) . prettyLDT f . snd) l) -ldtToLoc :: LabelDoubleTree b a -> LocationLDT b a +ldtToLoc :: LDTree b a -> LocationLDT b a ldtToLoc = LocLDT TopLDT -- should probably do tests for these diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 5908bad57..cf7ad3e32 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -60,23 +60,23 @@ gadgetEffect pt loc useInventoryPath pt i x loc | otherwise = const id -heldEffect :: PressType -> LabelDoubleTree ItemLink Item -> Creature -> World -> World +heldEffect :: PressType -> LDTree ItemLink Item -> Creature -> World -> World heldEffect = useTimeCheck . hammerCheck heldEffectMuzzles -heldEffectNoHammerCheck :: LabelDoubleTree ItemLink Item -> Creature -> World -> World +heldEffectNoHammerCheck :: LDTree ItemLink Item -> Creature -> World -> World heldEffectNoHammerCheck = useTimeCheck heldEffectMuzzles type ChainEffect = - (LabelDoubleTree ItemLink Item -> Creature -> World -> World) -> - LabelDoubleTree ItemLink Item -> + (LDTree ItemLink Item -> Creature -> World -> World) -> + LDTree ItemLink Item -> Creature -> World -> World hammerCheck :: - (LabelDoubleTree ItemLink Item -> Creature -> World -> World) -> + (LDTree ItemLink Item -> Creature -> World -> World) -> PressType -> - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> Creature -> World -> World @@ -142,7 +142,7 @@ useTimeCheck f item cr w = case useDelay $ item ^. ldtValue of -- will have problems elsewhere also itRef = item ^?! ldtValue . itLocation . ilInvID -heldEffectMuzzles :: LabelDoubleTree ItemLink Item -> Creature -> World -> World +heldEffectMuzzles :: LDTree ItemLink Item -> Creature -> World -> World heldEffectMuzzles t cr w = setusetime . doHeldUseEffect t cr . uncurry (applyCME (_ldtValue t) cr) @@ -336,7 +336,7 @@ vgunMuzzles i = -- <*> ZipList [0 .. i -1] ) -doHeldUseEffect :: LabelDoubleTree ItemLink Item -> Creature -> World -> World +doHeldUseEffect :: LDTree ItemLink Item -> Creature -> World -> World doHeldUseEffect t cr w = case t ^. ldtValue . itType of HELD (VOLLEYGUN j) -> case itm ^? itParams . unfiredBarrels of Just [_] -> fromMaybe w $ do @@ -677,9 +677,9 @@ heldTorqueAmount = \case -- (Muzzle,Int,Int) = (muzzle, amountloaded, id of mag taken from) loadMuzzle :: - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> Muzzle -> - (LabelDoubleTree ItemLink Item, Maybe (Muzzle, Int, LabelDoubleTree ItemLink Item)) + (LDTree ItemLink Item, Maybe (Muzzle, Int, LDTree ItemLink Item)) loadMuzzle t@(LDT _ l _) mz = fromMaybe (t, Nothing) $ do -- guard $ mz ^? mzFrame == t ^? ldtValue . itUse . heldFrame let as = _mzAmmoSlot mz @@ -697,7 +697,7 @@ loadMuzzle t@(LDT _ l _) mz = fromMaybe (t, Nothing) $ do , Just (mz, usedammo, mag) ) -makeMuzzleFlare :: Muzzle -> LabelDoubleTree ItemLink Item -> Creature -> World -> World +makeMuzzleFlare :: Muzzle -> LDTree ItemLink Item -> Creature -> World -> World makeMuzzleFlare mz itmtree cr = case mz ^. mzFlareType of NoFlare -> id BasicFlare -> basicMuzFlare pos dir @@ -746,13 +746,13 @@ flareCircleAt col alphax tranv = ) -- previous phaseV parameters: 0.2, 1, 5 -getLaserPhaseV :: LabelDoubleTree ItemLink Item -> Float +getLaserPhaseV :: LDTree ItemLink Item -> Float getLaserPhaseV = const 1 -getLaserDamage :: LabelDoubleTree ItemLink Item -> LaserType +getLaserDamage :: LDTree ItemLink Item -> LaserType getLaserDamage = const (DamageLaser 11) -getLaserColor :: LabelDoubleTree ItemLink Item -> Color +getLaserColor :: LDTree ItemLink Item -> Color getLaserColor = const yellow basicMuzFlare :: Point2 -> Float -> World -> World @@ -767,10 +767,10 @@ isAmmoIntLink i (AmmoInLink j _) = i == j isAmmoIntLink _ _ = False useLoadedAmmo :: - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> Creature -> (Bool, World) -> - Maybe (Muzzle, Int, LabelDoubleTree ItemLink Item) -> + Maybe (Muzzle, Int, LDTree ItemLink Item) -> (Bool, World) useLoadedAmmo _ _ (cme, w) Nothing = (cme, w) useLoadedAmmo itmtree cr (_, w) (Just (mz, x, magtree)) = (,) True $ @@ -808,7 +808,7 @@ useLoadedAmmo itmtree cr (_, w) (Just (mz, x, magtree)) = (,) True $ getAttachedSFLink :: ItemStructuralFunction -> - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> Maybe (NewInt ItmInt) getAttachedSFLink sf = (^? ldtRight . folding (lookup (SFLink sf)) . ldtValue . itID) @@ -869,7 +869,7 @@ tractorBeamAt pos outpos dir power = d = unitVectorAtAngle dir * power creatureShootLaser :: - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> Creature -> Muzzle -> World -> @@ -925,7 +925,7 @@ removeAmmoFromMag x mid cr = fromMaybe id $ do . _Just -~ x -getBulletType :: LabelDoubleTree ItemLink Item -> Maybe Bullet +getBulletType :: LDTree ItemLink Item -> Maybe Bullet getBulletType magtree = --magtree ^? ldtValue . itConsumables . magParams . ampBullet (magtree ^? ldtValue >>= magAmmoParams >>= (^? ampBullet)) @@ -979,9 +979,9 @@ magAmmoParams itm = case itm ^. itType of -- _ -> 0 shootBullet :: - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> Creature -> - (Muzzle, Int, LabelDoubleTree ItemLink Item) -> + (Muzzle, Int, LDTree ItemLink Item) -> World -> World shootBullet itmtree cr (mz, x, magtree) w = fromMaybe w $ do @@ -1265,10 +1265,7 @@ shootTeslaArc itm cr mz w = pos = _crPos cr + rotateV (_crDir cr) moff dir = _crDir cr + mrot -determineProjectileTracking :: - LabelDoubleTree ItemLink Item -> - LabelDoubleTree ItemLink Item -> - RocketHoming +determineProjectileTracking :: LDTree ItemLink Item -> LDTree ItemLink Item -> RocketHoming determineProjectileTracking magtree itmtree = fromMaybe NoHoming $ finddronecontrols <|> findexternaltracking @@ -1283,8 +1280,8 @@ determineProjectileTracking magtree itmtree = return $ HomeUsingTargeting (targetingtree ^. ldtValue . itID) createProjectileR :: - LabelDoubleTree ItemLink Item -> - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> + LDTree ItemLink Item -> Muzzle -> Creature -> World -> @@ -1302,7 +1299,7 @@ createProjectileR itmtree magtree = | isJust $ lookup SmokeReducerLink (magtree ^. ldtLeft) = Just ReducedRocketSmoke | otherwise = Nothing -getPJStabiliser :: LabelDoubleTree ItemLink Item -> Maybe PJStabiliser +getPJStabiliser :: LDTree ItemLink Item -> Maybe PJStabiliser getPJStabiliser ldt = case lookup ProjectileStabiliserLink (ldt ^. ldtRight) of Just ldt' -> case ldt' ^? ldtValue . itType . ibtAttach of Just GIMBAL -> Just StabOrthReduce @@ -1310,7 +1307,7 @@ getPJStabiliser ldt = case lookup ProjectileStabiliserLink (ldt ^. ldtRight) of _ -> Nothing _ -> Nothing -getGrenadeHitEffect :: LabelDoubleTree ItemLink Item -> GrenadeHitEffect +getGrenadeHitEffect :: LDTree ItemLink Item -> GrenadeHitEffect getGrenadeHitEffect t = case lookup GrenadeHitEffectLink (t ^. ldtRight) of Just ldt' -> case ldt' ^? ldtValue . itType of Just STICKYMOD -> GStick @@ -1319,7 +1316,7 @@ getGrenadeHitEffect t = case lookup GrenadeHitEffectLink (t ^. ldtRight) of createProjectile :: ProjectileType -> - LabelDoubleTree ItemLink Item -> + LDTree ItemLink Item -> Maybe PJStabiliser -> Muzzle -> Creature -> diff --git a/src/Dodge/Item/AimStance.hs b/src/Dodge/Item/AimStance.hs index 158924086..b0ab53a9e 100644 --- a/src/Dodge/Item/AimStance.hs +++ b/src/Dodge/Item/AimStance.hs @@ -10,7 +10,7 @@ import Dodge.Data.AimStance --aStance :: LocationLDT ItemLink CItem -> AimStance --aStance loc = case loc ^. locLDT . ldtValue . _1 . itType of -- -aimStance :: LabelDoubleTree ItemLink CItem -> AimStance +aimStance :: LDTree ItemLink CItem -> AimStance aimStance ldt = itemBaseStance $ ldt ^. ldtValue . _1 diff --git a/src/Dodge/Item/Draw.hs b/src/Dodge/Item/Draw.hs index 79f615cba..7d0374a75 100644 --- a/src/Dodge/Item/Draw.hs +++ b/src/Dodge/Item/Draw.hs @@ -15,7 +15,7 @@ import Dodge.Item.Draw.SPic import Dodge.Item.HeldOffset import ShapePicture -itemEquipPict :: Creature -> LabelDoubleTree ItemLink CItem -> SPic +itemEquipPict :: Creature -> LDTree ItemLink CItem -> SPic itemEquipPict cr itmtree | Just i <- itm ^? itLocation . ilInvID , Just esite <- cr ^? crInv . ix i . itLocation . ilEquipSite . _Just diff --git a/src/Dodge/Item/Draw/SPic.hs b/src/Dodge/Item/Draw/SPic.hs index 81040c553..0988197f5 100644 --- a/src/Dodge/Item/Draw/SPic.hs +++ b/src/Dodge/Item/Draw/SPic.hs @@ -21,12 +21,10 @@ import Picture import Shape import ShapePicture -itemTreeSPic :: LabelDoubleTree ItemLink CItem -> SPic -itemTreeSPic (LDT (itm,_,_) l r) = - itemSPic itm - <> foldMap (itemRotTreeSPic itm) (l <> r) +itemTreeSPic :: LDTree ItemLink CItem -> SPic +itemTreeSPic (LDT (itm,_) l r) = itemSPic itm <> foldMap (itemRotTreeSPic itm) (l <> r) -itemRotTreeSPic :: Item -> (ItemLink, LabelDoubleTree ItemLink CItem) -> SPic +itemRotTreeSPic :: Item -> (ItemLink, LDTree ItemLink CItem) -> SPic itemRotTreeSPic par (il, t) = translateSP p . overPosSP (Q.rotate q) $ itemTreeSPic t where (p, q) = orientAttachment par il itm diff --git a/src/Dodge/Item/Grammar.hs b/src/Dodge/Item/Grammar.hs index 754380ca6..ebafaed23 100644 --- a/src/Dodge/Item/Grammar.hs +++ b/src/Dodge/Item/Grammar.hs @@ -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 diff --git a/tags b/tags index 0bea4aa38..11586e2e9 100644 --- a/tags +++ b/tags @@ -978,7 +978,7 @@ Kill src/Dodge/Data/ActionPlan.hs 198;" C LASER src/Dodge/Data/Item/Combine.hs 168;" C LDT src/Dodge/Data/DoubleTree.hs 40;" C LDTBottomNode src/Dodge/Data/DoubleTree.hs 28;" C -LDTComb src/Dodge/Item/Grammar.hs 230;" t +LDTComb src/Dodge/Item/Grammar.hs 233;" t LDTMidAboveNode src/Dodge/Data/DoubleTree.hs 26;" C LDTMidBelowNode src/Dodge/Data/DoubleTree.hs 27;" C LDTRootNode src/Dodge/Data/DoubleTree.hs 24;" C @@ -3352,7 +3352,7 @@ airlockDoor src/Dodge/Room/Airlock.hs 51;" f airlockDoubleDoor src/Dodge/Room/Airlock.hs 54;" f airlockSimple src/Dodge/Room/Airlock.hs 66;" f airlockZ src/Dodge/Room/Airlock.hs 91;" f -allInvLocs src/Dodge/Item/Grammar.hs 323;" f +allInvLocs src/Dodge/Item/Grammar.hs 326;" f allVisibleWalls src/Dodge/Base/Collide.hs 132;" f alongSegBy src/Geometry.hs 40;" f alteRifle src/Dodge/Item/Held/Cane.hs 22;" f @@ -3453,7 +3453,7 @@ barrel src/Dodge/Creature/Inanimate.hs 17;" f barrelShape src/Dodge/Render/ShapePicture.hs 46;" f baseAMRShape src/Dodge/Item/Draw/SPic.hs 407;" f baseBlockPane src/Dodge/Placement/Instance/Wall.hs 86;" f -baseCI src/Dodge/Item/Grammar.hs 184;" f +baseCI src/Dodge/Item/Grammar.hs 186;" f baseCaneShape src/Dodge/Item/Draw/SPic.hs 313;" f baseDebris src/Dodge/Block/Debris.hs 122;" f baseFloorTileSize src/Tile.hs 45;" f @@ -4305,8 +4305,8 @@ extTrigLitPos src/Dodge/Placement/Instance/Button.hs 84;" f extendAway src/Dodge/Placement/Instance/LightSource.hs 200;" f extendConeToScreenEdge src/Dodge/Debug/Picture.hs 82;" f extraPics src/Dodge/Render/ShapePicture.hs 73;" f -extraWeaponLinks src/Dodge/Item/Grammar.hs 117;" f -extraWeaponLinksBelow src/Dodge/Item/Grammar.hs 126;" f +extraWeaponLinks src/Dodge/Item/Grammar.hs 119;" f +extraWeaponLinksBelow src/Dodge/Item/Grammar.hs 128;" f extractRoomPos src/Dodge/RoomPos.hs 6;" f faceEdges src/Polyhedra.hs 65;" f facesToVF src/Polyhedra/Geodesic.hs 69;" f @@ -4425,11 +4425,11 @@ geometryTests test/Spec.hs 17;" f geometryUnitTests test/Spec.hs 22;" f geqConstr src/SameConstr.hs 21;" f getAimZoom src/Dodge/Update/Camera.hs 135;" f -getAmmoLinks src/Dodge/Item/Grammar.hs 133;" f +getAmmoLinks src/Dodge/Item/Grammar.hs 135;" f getArguments src/Dodge/Update/Scroll.hs 178;" f getArguments' src/Dodge/Update/Scroll.hs 166;" f getAttachedSFLink src/Dodge/HeldUse.hs 809;" f -getAutoSpringLinks src/Dodge/Item/Grammar.hs 112;" f +getAutoSpringLinks src/Dodge/Item/Grammar.hs 114;" f getAvailableListLines src/Dodge/SelectionList.hs 10;" f getBulHitDams src/Dodge/Bullet.hs 171;" f getBulletType src/Dodge/HeldUse.hs 928;" f @@ -4646,16 +4646,16 @@ interweave src/Justify.hs 17;" f introScan src/Dodge/Item/Scope.hs 57;" f introScanValue src/Dodge/Inventory/SelectionList.hs 79;" f intsToPos src/Dodge/Room/Modify/Girder.hs 160;" f -invAdj src/Dodge/Item/Grammar.hs 304;" f +invAdj src/Dodge/Item/Grammar.hs 307;" f invCursorParams src/Dodge/ListDisplayParams.hs 36;" f invDP src/Dodge/ListDisplayParams.hs 30;" f invDimColor src/Dodge/DisplayInventory.hs 192;" f invHead src/Dodge/Render/HUD.hs 405;" f invItemLocUpdate src/Dodge/Creature/State.hs 154;" f -invLDT src/Dodge/Item/Grammar.hs 284;" f +invLDT src/Dodge/Item/Grammar.hs 287;" f invRootItemEffs src/Dodge/Creature/State.hs 147;" f -invRootMap src/Dodge/Item/Grammar.hs 293;" f -invRootTrees src/Dodge/Item/Grammar.hs 314;" f +invRootMap src/Dodge/Item/Grammar.hs 296;" f +invRootTrees src/Dodge/Item/Grammar.hs 317;" f invSelectionItem src/Dodge/Inventory/SelectionList.hs 32;" f invSetSelection src/Dodge/Inventory.hs 185;" f invSetSelectionPos src/Dodge/Inventory.hs 193;" f @@ -4703,7 +4703,7 @@ itEffectOnPickup src/Dodge/Item/BackgroundEffect.hs 64;" f itInvHeight src/Dodge/Item/InvSize.hs 11;" f itUseCondition src/Dodge/ItemUseCondition.hs 6;" f itemAmmoSlots src/Dodge/Item/AmmoSlots.hs 12;" f -itemBaseConnections src/Dodge/Item/Grammar.hs 187;" f +itemBaseConnections src/Dodge/Item/Grammar.hs 190;" f itemBaseName src/Dodge/Item/Display.hs 59;" f itemBaseStance src/Dodge/Item/AimStance.hs 17;" f itemBlips src/Dodge/RadarSweep.hs 93;" f @@ -4735,7 +4735,7 @@ itemScrollValue src/Dodge/Inventory/SelectionList.hs 147;" f itemSidePush src/Dodge/HeldUse.hs 432;" f itemString src/Dodge/Item/Display.hs 55;" f itemToBreakLists src/Dodge/Item/Grammar.hs 59;" f -itemToFunction src/Dodge/Item/Grammar.hs 139;" f +itemToFunction src/Dodge/Item/Grammar.hs 141;" f itemTreeSPic src/Dodge/Item/Draw/SPic.hs 24;" f itemTriggerType src/Dodge/BaseTriggerType.hs 12;" f itemWeight src/Dodge/Creature/Statistics.hs 66;" f @@ -4747,7 +4747,7 @@ itmSpaceInfo src/Dodge/Item/Info.hs 25;" f itmUsageInfo src/Dodge/Item/Info.hs 230;" f jShape src/Dodge/Placement/Instance/LightSource.hs 85;" f jaggedShape src/Dodge/Block/Debris.hs 191;" f -joinItemsInList src/Dodge/Item/Grammar.hs 274;" f +joinItemsInList src/Dodge/Item/Grammar.hs 277;" f joystick src/Dodge/Item/Scope.hs 149;" f jps0' src/Dodge/LevelGen/PlacementHelper.hs 60;" f jps0PushPS src/Dodge/LevelGen/PlacementHelper.hs 63;" f @@ -4781,7 +4781,7 @@ lasTunnel src/Dodge/Room/LasTurret.hs 126;" f lasTunnelRunPast src/Dodge/Room/LasTurret.hs 167;" f lasTurret src/Dodge/Placement/Instance/Turret.hs 38;" f laser src/Dodge/Item/Held/BatteryGuns.hs 41;" f -laserLinkTest src/Dodge/Item/Grammar.hs 193;" f +laserLinkTest src/Dodge/Item/Grammar.hs 196;" f lastMap src/Dodge/DoubleTree.hs 174;" f launcherCrit src/Dodge/Creature/LauncherCrit.hs 12;" f layoutLevelFromSeed src/Dodge/LevelGen.hs 47;" f @@ -4796,11 +4796,10 @@ ldtToIM src/Dodge/DoubleTree.hs 143;" f ldtToIndentList src/Dodge/DoubleTree.hs 146;" f ldtToLoc src/Dodge/DoubleTree.hs 187;" f left src/DoubleStack.hs 16;" f -leftChildList src/Dodge/Item/Grammar.hs 250;" f +leftChildList src/Dodge/Item/Grammar.hs 251;" f leftIsParentCombine src/Dodge/Item/Grammar.hs 235;" f -leftIsParentCombine' src/Dodge/Item/Grammar.hs 232;" f leftPad src/Padding.hs 15;" f -leftRightCombine src/Dodge/Item/Grammar.hs 260;" f +leftRightCombine src/Dodge/Item/Grammar.hs 263;" f legsSPic src/Dodge/Item/Draw/SPic.hs 477;" f liShape src/Dodge/Placement/Instance/LightSource.hs 98;" f light src/Color.hs 104;" f @@ -4828,8 +4827,8 @@ listCursorChooseBorderScale src/Dodge/Render/List.hs 135;" f listGuard src/Dodge/Creature/ReaderUpdate.hs 190;" f listSelectionColorPicture src/Dodge/DisplayInventory.hs 308;" f litCorridor90 src/Dodge/Room/RoadBlock.hs 26;" f -llleft src/Dodge/Item/Grammar.hs 196;" f -llright src/Dodge/Item/Grammar.hs 202;" f +llleft src/Dodge/Item/Grammar.hs 199;" f +llright src/Dodge/Item/Grammar.hs 205;" f lmt src/MatrixHelper.hs 43;" f lnkBothAnd src/Dodge/Room/Procedural.hs 121;" f lnkMidPosInvSelsCol src/Dodge/Render/HUD.hs 394;" f @@ -5537,8 +5536,8 @@ rezText' src/Dodge/Story.hs 17;" f rhombus src/Polyhedra.hs 72;" f rifle src/Dodge/Item/Held/Cane.hs 19;" f right src/DoubleStack.hs 16;" f -rightIsParentCombine src/Dodge/Item/Grammar.hs 242;" f -rightIsParentCombine' src/Dodge/Item/Grammar.hs 253;" f +rightChildList src/Dodge/Item/Grammar.hs 257;" f +rightIsParentCombine src/Dodge/Item/Grammar.hs 243;" f rightPad src/Padding.hs 19;" f rightPadNoSquash src/Padding.hs 23;" f rlPosDir src/Dodge/RoomLink.hs 94;" f @@ -5886,7 +5885,7 @@ spreadCenter src/Dodge/Base.hs 187;" f spreadFromCenter src/Dodge/Base.hs 176;" f spreadGunCrit src/Dodge/Creature/SpreadGunCrit.hs 12;" f spreadOut src/Dodge/Creature/Boid.hs 158;" f -springLinkTest src/Dodge/Item/Grammar.hs 214;" f +springLinkTest src/Dodge/Item/Grammar.hs 217;" f sps src/Dodge/LevelGen/PlacementHelper.hs 30;" f sps0 src/Dodge/LevelGen/PlacementHelper.hs 42;" f square src/Geometry/Polygon.hs 46;" f @@ -5943,7 +5942,7 @@ strideRot src/Dodge/Item/HeldOffset.hs 78;" f stringToList src/Picture/Base.hs 313;" f stringToListGrad src/Picture/Text.hs 12;" f stripZ src/Geometry/Vector3D.hs 97;" f -structureToPotentialFunction src/Dodge/Item/Grammar.hs 174;" f +structureToPotentialFunction src/Dodge/Item/Grammar.hs 176;" f structureUseAtLoc src/Dodge/Creature/Impulse/UseItem.hs 75;" f subInvX src/Dodge/ListDisplayParams.hs 48;" f subMap src/TreeHelp.hs 118;" f @@ -6056,7 +6055,7 @@ toClosestMultiple src/HelpNum.hs 3;" f toColor8 src/Color.hs 148;" f toFloatVAs src/Shader/Compile.hs 211;" f toLabel src/Dodge/Cleat.hs 16;" f -toLasgunUpdate src/Dodge/Item/Grammar.hs 207;" f +toLasgunUpdate src/Dodge/Item/Grammar.hs 210;" f toMultiset src/Multiset.hs 64;" f toOnward src/Dodge/Tree/Compose.hs 101;" f toTopLeft src/Dodge/Render/List.hs 219;" f