Delete location double trees

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

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).

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
 

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

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