From 13b12f01a8a41d7d6c0a8efd7da03695fbe83792 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 17 Mar 2026 15:37:15 +0000 Subject: [PATCH] Delete location double trees --- src/Dodge/Data/DoubleTree.hs | 80 ------------- src/Dodge/DoubleTree.hs | 220 +---------------------------------- src/Dodge/HeldUse.hs | 2 +- src/Dodge/TestString.hs | 14 --- src/Dodge/WorldEffect.hs | 1 - 5 files changed, 2 insertions(+), 315 deletions(-) diff --git a/src/Dodge/Data/DoubleTree.hs b/src/Dodge/Data/DoubleTree.hs index eabb9c3dd..a663611f4 100644 --- a/src/Dodge/Data/DoubleTree.hs +++ b/src/Dodge/Data/DoubleTree.hs @@ -5,11 +5,6 @@ module Dodge.Data.DoubleTree where import Control.Lens ---import Data.Aeson ---import Data.Aeson.TH -import Data.Bifunctor - ---import qualified Data.Map.Strict as M data DoubleTreeNodeType = DTRootNode @@ -18,67 +13,15 @@ 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 DTree a = DT {_dtValue :: a, _dtLeft :: [DTree a], _dtRight :: [DTree a]} deriving (Eq, Ord, Show, Read) -data LDTree b a = LDT -- LabelDoubleTree - { _ldtValue :: a - , _ldtLeft :: [(b, LDTree b a)] - , _ldtRight :: [(b, LDTree b a)] - } - deriving (Eq, Ord, Show, Read) - ----- I am not sure about the double use of records here ---data ContextLDT b a --- = TopLDT --- | LeftwardLDT --- { _cldtUp :: ContextLDT b a --- , _cldtCloseLeft :: [(b, LDTree b a)] --- , _cldtParent :: a --- , _cldtLink :: b --- , _cldtCloseRight :: [(b, LDTree b a)] --- , _cldtFarRight :: [(b, LDTree b a)] --- } --- | RightwardLDT --- { _cldtUp :: ContextLDT b a --- , _cldtFarLeft :: [(b, LDTree b a)] --- , _cldtCloseLeft :: [(b, LDTree b a)] --- , _cldtParent :: a --- , _cldtLink :: b --- , _cldtCloseRight :: [(b, LDTree b a)] --- } - ---data LocationLDT b a = LocLDT --- { _locLdtContext :: ContextLDT b a --- , _locLDT :: LDTree b a --- } - instance Functor DTree where fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r) instance Foldable DTree where foldMap f (DT x l r) = foldMap (foldMap f) l <> f x <> foldMap (foldMap f) r -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 LDTree where - second = fmap - first f (LDT x l r) = - LDT - x - (map (bimap f (first f)) l) - (map (bimap f (first f)) r) - - data ContextDT a = TopDT | LeftwardDT @@ -102,35 +45,12 @@ data LocationDT a = LocDT } makeLenses ''DTree ---makeLenses ''LDTree ---makeLenses ''LocationLDT ---makeLenses ''ContextLDT makeLenses ''LocationDT makeLenses ''ContextDT ---instance Functor (LocationLDT b) where --- fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t) - instance Functor LocationDT where fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t) ---instance Functor (ContextLDT b) where --- fmap f = \case --- TopLDT -> TopLDT --- LeftwardLDT u cl p l cr fr -> LeftwardLDT --- (fmap f u) --- (fmap (fmap (fmap f)) cl) --- (f p) --- l --- (fmap (fmap (fmap f)) cr) --- (fmap (fmap (fmap f)) fr) --- RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u) --- (fmap (fmap (fmap f)) fl) --- (fmap (fmap (fmap f)) cl) --- (f p) --- l --- (fmap (fmap (fmap f)) cr) - instance Functor ContextDT where fmap f = \case TopDT -> TopDT diff --git a/src/Dodge/DoubleTree.hs b/src/Dodge/DoubleTree.hs index 4be3ec3c2..d1de598a8 100644 --- a/src/Dodge/DoubleTree.hs +++ b/src/Dodge/DoubleTree.hs @@ -1,40 +1,13 @@ -{-# LANGUAGE LambdaCase #-} module Dodge.DoubleTree where import Dodge.Data.DoubleTree import Control.Lens -import Data.Bifunctor import qualified Data.IntMap.Strict as IM import Data.Monoid singleDT :: a -> DTree a singleDT x = DT x [] [] -singleLDT :: a -> LDTree b a -singleLDT x = LDT x [] [] - -ldtToDT :: LDTree b a -> DTree a -ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r) - ---locLDTToLocDT :: LocationLDT b a -> LocationDT a ---locLDTToLocDT (LocLDT con t) = LocDT (conLDTToConDT con) (ldtToDT t) - ---conLDTToConDT :: ContextLDT b a -> ContextDT a ---conLDTToConDT = \case --- TopLDT -> TopDT --- LeftwardLDT u cl p _ cr fr -> LeftwardDT --- (conLDTToConDT u) --- (map (ldtToDT . snd) cl) --- p --- (map (ldtToDT . snd) cr) --- (map (ldtToDT . snd) fr) --- RightwardLDT u fl cl p _ cr -> RightwardDT --- (conLDTToConDT u) --- (map (ldtToDT . snd) fl) --- (map (ldtToDT . snd) cl) --- p --- (map (ldtToDT . snd) cr) - dtStartPropagate :: (a -> c) -> (c -> a -> c) -> DTree a -> DTree c dtStartPropagate g f (DT x l r) = DT z (fmap (dtPropagate' f z) l) @@ -49,80 +22,6 @@ dtPropagate' f x (DT y l r) = DT z where z = f x y -ldtStartPropagate :: (a -> c) -> (c -> b -> a -> c) -> LDTree b a -> LDTree b c -ldtStartPropagate g f (LDT x l r) = LDT z - (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) l) - (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) r) - where - z = g x - - -ldtPropagate' :: c -> b -> (c -> b -> a -> c) -> LDTree b a -> LDTree b c -ldtPropagate' x i f (LDT y l r) = LDT z - (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) l) - (fmap (\(j,t) -> (j,ldtPropagate' z j f t)) r) - where - z = f x i y - --- 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 -> - 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. --- The value is updated according a "left" or "right" function (lf or rf), --- that acts on the parent value, the link, and the child value. --- For each node, the updated value is used to update a final value (of type d). -ldtPropagateFold :: - (c -> a -> b -> a -> c) -> - (c -> a -> b -> a -> c) -> - (c -> a -> d -> d) -> - c -> - LDTree b a -> - d -> - d -ldtPropagateFold lf rf up x (LDT v l r) = - alaf Endo foldMap (\(s, y) -> ldtPropagateFold lf rf up (rf x v s (_ldtValue y)) y) r - . alaf Endo foldMap (\(s, y) -> ldtPropagateFold lf rf up (lf x v s (_ldtValue y)) y) l - . up x v - --- Propgates a value (of type c) down the branches of the LDT. --- The value is updated according a "left" or "right" function (lf or rf), --- that acts on the parent value, the link, and the child value. --- 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 -> LDTree b a -> d -> d) -> - c -> - LDTree b a -> - d -> - d -ldtPropagateFoldTree lf rf up x t@(LDT v l r) = - alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (rf x v s (_ldtValue y)) y) r - . alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (lf x v s (_ldtValue y)) y) l - . up x t - -ildtPropagate :: - (Int -> c -> b -> c) -> - (Int -> c -> b -> c) -> - c -> - 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 :: 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) - -- 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 @@ -216,36 +115,6 @@ dtToAdjRootParentEither root par f (DT x l r) = do where g = f . _dtValue -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 :: LDTree b a -> [(a, Int, LabelDoubleTreeNodeType b)] -ldtToIndentList = ldtIL LDTRootNode - -ldtIL :: LabelDoubleTreeNodeType b -> LDTree 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 _ _ [] = [] @@ -260,31 +129,6 @@ prettyDT f (DT x l r) = concatMap (map ('/' :) . prettyDT f) r ++ (f x : concatMap (map ('\\' :) . prettyDT f) l) -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 :: LDTree b a -> LocationLDT b a ---ldtToLoc = LocLDT TopLDT - ----- should probably do tests for these ---locUp :: LocationLDT b a -> Maybe (LocationLDT b a) ---locUp (LocLDT TopLDT _) = Nothing ---locUp (LocLDT c@LeftwardLDT{} t) = --- Just $ --- LocLDT --- (_cldtUp c) --- (LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)) (_cldtFarRight c)) ---locUp (LocLDT c@RightwardLDT{} t) = --- Just $ --- LocLDT --- (_cldtUp c) --- (LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c))) - ---locToTop :: LocationLDT b a -> LocationLDT b a ---locToTop loc = maybe loc locToTop $ locUp loc - locUp' :: LocationDT a -> Maybe (LocationDT a) locUp' (LocDT TopDT _) = Nothing locUp' (LocDT c@LeftwardDT{} t) = @@ -301,30 +145,12 @@ locUp' (LocDT c@RightwardDT{} t) = locToTop :: LocationDT a -> LocationDT a locToTop loc = maybe loc locToTop $ locUp' loc ---locToTop = fix $ \x -> fromMaybe x $ locUp x - ---locLeftmost :: LocationLDT b a -> LocationLDT b a ---locLeftmost loc = maybe loc locLeftmost $ alaf First foldMap Just $ locGoLeft loc - ---locRightmost :: LocationLDT b a -> LocationLDT b a ---locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight loc - locDTLeftmost :: LocationDT a -> LocationDT a locDTLeftmost loc = maybe loc locDTLeftmost $ alaf First foldMap Just $ locDTGoLeft loc locDTRightmost :: LocationDT a -> LocationDT a locDTRightmost loc = maybe loc locDTRightmost $ alaf Last foldMap Just $ locDTGoRight loc ----- should probably do tests for these ---locGoLeft :: LocationLDT b a -> [LocationLDT b a] ---locGoLeft (LocLDT c (LDT v l r)) = --- [LocLDT (LeftwardLDT c closel v link closer r) t | (closel, (link, t), closer) <- locGoHelp id l] - ----- should probably do tests for these ---locGoRight :: LocationLDT b a -> [LocationLDT b a] ---locGoRight (LocLDT c (LDT v l r)) = --- [LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r] - -- should probably do tests for these locDTGoLeft :: LocationDT a -> [LocationDT a] locDTGoLeft (LocDT c (DT v l r)) = @@ -351,56 +177,12 @@ locDTGoHelp f = go [] go cleft (y : ys) = (cleft, f y, ys) : go (cleft <> [y]) ys go _ [] = [] ----- Propgates a value (of type c) down the branches of the ContextLDT. ----- The value is updated according a "left" or "right" function (lf or rf), ----- that acts on the parent value, the link, and the child value. ----- For each context node, the updated value is used to update a final value (of type d). ---cldtPropagateFold :: --- (c -> a -> b -> a -> c) -> --- (c -> a -> b -> a -> c) -> --- (c -> LocationLDT b a -> d -> d) -> --- c -> --- LocationLDT b a -> --- d -> --- d ---cldtPropagateFold lf rf up x loc = --- alaf --- Endo --- foldMap --- ( \(LocLDT con' t') -> --- cldtPropagateFold --- lf --- rf --- up --- (lf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) --- (LocLDT con' t') --- ) --- (locGoLeft loc) --- . alaf --- Endo --- foldMap --- ( \(LocLDT con' t') -> --- cldtPropagateFold --- lf --- rf --- up --- (rf x (_cldtParent con') (_cldtLink con') (_ldtValue t')) --- (LocLDT con' t') --- ) --- (locGoRight loc) --- . up x loc - ---reduceLocLDT :: Monoid m => (LocationLDT b a -> m) -> LocationLDT b a -> m ---reduceLocLDT f x = --- foldMap (reduceLocLDT f) (locGoLeft x) <> f x --- <> foldMap (reduceLocLDT f) (locGoRight x) - reduceLocDT :: Monoid m => (LocationDT a -> m) -> LocationDT a -> m reduceLocDT f x = foldMap (reduceLocDT f) (locDTGoLeft x) <> f x <> foldMap (reduceLocDT f) (locDTGoRight x) --- Propgates a value (of type c) down the branches of the ContextLDT. +-- Propgates a value (of type c) down the branches of the ContextDT. -- The value is updated according a "left" or "right" function (lf or rf), -- that acts on the parent value and the child value. -- For each context node, the updated value is used to update a final value (of type d). diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index dc606fbe2..1dfea2b0f 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -1393,7 +1393,7 @@ dropInventoryPath i ip loc cr = fromMaybe id $ do -- guard $ (i + j) `IM.member` (cr ^. crInv) -- return $ dropItem cr (i + j) w -- RELITEM -> fromMaybe w $ do --- j <- loc ^? locLDT . ldtValue . _1 . itLocation . ilInvID +-- j <- loc ^? locDT . dtValue . _1 . itLocation . ilInvID -- guard $ (i + j) `IM.member` (cr ^. crInv) -- return $ dropItem cr (i + j) w diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index 644108b84..9fc99689e 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -61,20 +61,6 @@ showManObj (SelCloseItem x) = "CloseItem " ++ show x showManObj SortCloseButton = "SortCloseButton" showManObj (SelCloseButton x) = "CloseButton " ++ show x - ---testStringInit u = fromMaybe mempty $ do --- inv <- fmap invLDT $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv --- invitm <- inv ^? ix 1 --- return $ concatMap (prettyLDT (\(x,_,_,_) -> take 5 (show $ x ^. itType . iyBase))) [invitm] - ---testStringInit u = maybe [] invTree (u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crInv) --- [fromMaybe "" $ do --- cr <- u ^? uvWorld . cWorld . lWorld . creatures . ix 0 --- i <- cr ^? crManipulation . manObject . inInventory . ispItem --- fmap (show . canAttachTargeting) (cr ^? crInv . ix i) --- ] - - showTimeFlow :: TimeFlowStatus -> String showTimeFlow tfs = case tfs of RespawnDelay i -> "Respawndelay"++show i diff --git a/src/Dodge/WorldEffect.hs b/src/Dodge/WorldEffect.hs index 8bf86cb5e..fa13d54e6 100644 --- a/src/Dodge/WorldEffect.hs +++ b/src/Dodge/WorldEffect.hs @@ -59,7 +59,6 @@ doWdWd = \case UseInvItem invid pt -> \w -> fromMaybe w (useItem invid pt w) WdWdBurstFireRepetition cid invid -> \w -> fromMaybe w $ do cr <- w ^? cWorld . lWorld . creatures . ix cid - --itree <- allInvLocs (cr ^. crInv) ^? ix invid . _2 . locLDT loc <- invIndents (fmap (\k -> w ^?! cWorld . lWorld . items . ix k) $ cr ^. crInv) ^? ix (_unNInt invid) . _2 return $ heldEffectMuzzles loc cr w