Implement zipper for attachment trees

src/Dodge/DoubleTree.hs

@@ -15,7 +15,7 @@ singleLDT x = LDT x [] []
 ldtToDT :: LabelDoubleTree b a -> DoubleTree a
 ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
 
--- propogate two functions down the links of an LDT tree
+-- 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 
@@ -110,7 +110,7 @@ dtToLRAdj f (DT x l r) = IM.insert i (Nothing,map g l , map g r)
 
 -- returns an adjacency map with oldest ancestor and direct parent if they exist
 -- and any left and right children
--- allows to propogate failure in the index discovery
+-- allows to propagate failure in the index discovery
 dtToLRAdjEither :: (a -> Either String Int) -> DoubleTree a 
     -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
 dtToLRAdjEither f (DT x l r) = do
@@ -184,4 +184,61 @@ prettyLDT :: (a -> String) -> LabelDoubleTree 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 = 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
+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]
+
+-- this seems like it might be very inefficient for large lists
+-- difference lists?
+locGoHelp :: (a -> b) -> [a] -> [([a],b,[a])]
+locGoHelp f = go []
+  where
+    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