Comment out LDTs

2026-03-17 15:31:24 +00:00
parent 4cacb45252
commit 96c2fb00e1
3 changed files with 132 additions and 131 deletions
@@ -36,30 +36,30 @@ data LDTree b a = LDT -- LabelDoubleTree
    }
    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)]
-        }
+---- 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
-    }
+--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)
@@ -102,34 +102,34 @@ data LocationDT a = LocDT
    }

 makeLenses ''DTree
-makeLenses ''LDTree
-makeLenses ''LocationLDT
-makeLenses ''ContextLDT
+--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 (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 (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
@@ -16,24 +16,24 @@ 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)
+--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)
+--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 
@@ -265,22 +265,22 @@ 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
+--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)))
+---- 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
@@ -303,11 +303,11 @@ 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
+--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
+--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
@@ -315,15 +315,15 @@ locDTLeftmost loc = maybe loc locDTLeftmost $ alaf First foldMap Just $ locDTGoL
 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
+--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
+--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]
@@ -351,49 +351,49 @@ 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
+---- 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)
+--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 =
@@ -256,7 +256,8 @@ heldItemMuzzles loc = \case
    BLUNDERBUSS -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet 12]
    GRAPECANNON i -> [Muzzle (V2 30 0) 0 0.5 magupto15 BasicFlare MuzzleShootBullet (12 + 4 * fromIntegral i)]
    LED -> dbwMuzzles & ix 0 . mzPos .~ V2 10 0
-    FLAMETHROWER | Just PumpSF <- loc ^? locDT. dtRight . ix 0 . dtValue ._2 
+            -- don't care where the pump is, but possibly should know this
+    FLAMETHROWER | any (\dt -> Just PumpSF == dt ^? dtValue . _2) (loc ^. locDT . dtRight)
            -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 2 8
    FLAMETHROWER -> flameMuzzles
    FLAMESPITTER -> flameMuzzles & ix 0 . mzEffect . nzPressure .~ UniRandFloat 3 4