Migrate LDTs to DTs

src/Dodge/DoubleTree.hs

@@ -1,10 +1,11 @@
+{-# 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
-import Dodge.Data.DoubleTree
 
 singleDT :: a -> DTree a
 singleDT x = DT x [] []
@@ -15,6 +16,25 @@ 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 (\(t) -> (dtPropagate' z f t)) l)
@@ -265,6 +285,22 @@ locUp (LocLDT c@RightwardLDT{} t) =
 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) =
+    Just $
+        LocDT
+            (_cdtUp c)
+            (DT (_cdtParent c) (_cdtCloseLeft c ++ (( t) : _cdtCloseRight c)) (_cdtFarRight c))
+locUp' (LocDT c@RightwardDT{} t) =
+    Just $
+        LocDT
+            (_cdtUp c)
+            (DT (_cdtParent c) (_cdtFarLeft c) (_cdtCloseLeft c ++ (( t) : _cdtCloseRight c)))
+
+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