Use function on location to determine laser orientation

src/Dodge/Data/DoubleTree.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 --{-# LANGUAGE StrictData #-}
@@ -79,9 +80,52 @@ instance Bifunctor LDTree where
             (map (bimap f (first f)) l)
             (map (bimap f (first f)) r)
 
+
+data ContextDT a
+    = TopDT
+    | LeftwardDT
+        { _cdtUp :: ContextDT a
+        , _cdtCloseLeft :: [DoubleTree a]
+        , _cdtParent :: a
+        , _cdtCloseRight :: [DoubleTree a]
+        , _cdtFarRight :: [DoubleTree a]
+        }
+    | RightwardDT
+        { _cdtUp :: ContextDT a
+        , _cdtFarLeft :: [ DoubleTree a]
+        , _cdtCloseLeft :: [DoubleTree a]
+        , _cdtParent :: a
+        , _cdtCloseRight :: [DoubleTree a]
+        }
+
+data LocationDT b a = LocDT
+    { _locDtContext :: ContextDT a
+    , _locDT :: DoubleTree a
+    }
+
 makeLenses ''DoubleTree
 makeLenses ''LDTree
 makeLenses ''LocationLDT
 makeLenses ''ContextLDT
+
+instance Functor (LocationLDT b) where
+    fmap f (LocLDT c t) = LocLDT (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)
+
 --deriveJSON defaultOptions ''DoubleTree
 --deriveJSON defaultOptions ''LabelDoubleTree