DIAG: make the current node in the tree red

Algorithms/QuadTree/QuadTree.hs

@@ -203,15 +203,20 @@ lookupByNeighbors = flip (foldlM (flip findNeighbor))
 
 
 quadTreeToRoseTree :: Zipper PT -> Tree String
-quadTreeToRoseTree z = case z of
+quadTreeToRoseTree z' = go (rootNode z')
-  (TNil, _)    -> Node printOrigin []
-  (TLeaf a, _) -> Node (printOrigin ++ "\n" ++ (show . unp2 $ a)) []
-  _            -> Node printOrigin
-                    [quadTreeToRoseTree (fromJust . goNW $ z)
-                    , quadTreeToRoseTree (fromJust . goNE $ z)
-                    , quadTreeToRoseTree (fromJust . goSW $ z)
-                    , quadTreeToRoseTree (fromJust . goSE $ z)]
   where
+    go z = case z of
+      (TNil, _)    -> Node markAndPrintOrigin []
+      (TLeaf a, _) -> Node (markAndPrintOrigin ++ "\n" ++ (show . unp2 $ a)) []
+      _            -> Node markAndPrintOrigin
+                        [go (fromJust . goNW $ z)
+                        , go (fromJust . goNE $ z)
+                        , go (fromJust . goSW $ z)
+                        , go (fromJust . goSE $ z)]
+      where
+        markAndPrintOrigin
+          | z' == z   = "* " ++ printOrigin
+          | otherwise = printOrigin
         printOrigin
           | isNWchild z = "NW"
           | isNEchild z = "NE"

Graphics/Diagram/Plotter.hs

@@ -238,12 +238,23 @@ treePretty :: Diag
 treePretty = Diag f
   where
     f p (Object []) = mempty
-    f p (Object vt) = prettyRoseTree (quadTreeToRoseTree (qt, []))
+    f p (Object vt) =
+      prettyRoseTree (quadTreeToRoseTree . flip getCurQT (qt, []) . stringToQuads . pQt $ p)
       where
         qt = quadTree (filterValidPT p vt) (dX p, dY p)
+        getCurQT :: [Either Quad Orient] -> Zipper PT -> Zipper PT
+        getCurQT [] z = z
+        getCurQT (q:qs) z = case q of
+          Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))
+          Left x  -> getCurQT qs (fromMaybe z (goQuad x z))
         prettyRoseTree :: Tree String -> Diagram Cairo R2
         prettyRoseTree t =
-          renderTree (\n -> (text n # fontSizeL 5.0)
+          renderTree (\n -> case head n of
+                        '*' ->
+                          (text n # fontSizeL 5.0)
+                            <> rect 50.0 20.0 # fc red
+                        _   ->
+                          (text n # fontSizeL 5.0)
                             <> rect 50.0 20.0 # fc white)
                      (~~)
                      (symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) t)