Implement visualizing the quad tree in a separate window

This window creation still sucks a bit, we should realize it
without actually showing it.

Algorithms/RangeSearch/QuadTree.hs

@@ -8,6 +8,7 @@ module Algorithms.RangeSearch.QuadTree
     lookupByPath',
     getSquareByZipper,
     rootNode,
+    quadTreeToRoseTree,
     Orient(North,East,West,South),
     Quad(NW,NE,SW,SE),
     QuadTree,
@@ -19,6 +20,7 @@ import Algebra.Vector
 import Data.Foldable (foldlM)
 import Data.List (partition)
 import Data.Maybe (fromJust)
+import Data.Tree
 import Diagrams.TwoD.Types
 
 
@@ -200,3 +202,19 @@ lookupByNeighbors :: [Orient] -> Zipper a -> Maybe (Zipper a)
 lookupByNeighbors = flip (foldlM (flip findNeighbor))
 
 
+quadTreeToRoseTree :: Zipper PT -> Tree String
+quadTreeToRoseTree z = case z of
+  (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
+    printOrigin
+      | isNWchild z = "NW"
+      | isNEchild z = "NE"
+      | isSWchild z = "SW"
+      | isSEchild z = "SE"
+      | otherwise   = "root"

CG2.cabal

@@ -60,7 +60,7 @@ executable Gtk
   -- other-extensions:
 
   -- Other library packages from which modules are imported.
-  build-depends:       base >=4.6 && <4.8, diagrams-lib >=1.2 && <1.3, diagrams-cairo >=1.2 && <1.3, transformers >=0.4 && <0.5, glade >=0.12 && <0.13, gtk >=0.12 && <0.13, directory >=1.2 && <1.3, dequeue >= 0.1.5, multiset-comb >= 0.2.1, gloss >= 1.2.0.1, safe >= 0.3.8
+  build-depends:       base >=4.6 && <4.8, diagrams-lib >=1.2 && <1.3, diagrams-cairo >=1.2 && <1.3, transformers >=0.4 && <0.5, glade >=0.12 && <0.13, gtk >=0.12 && <0.13, directory >=1.2 && <1.3, dequeue >= 0.1.5, multiset-comb >= 0.2.1, gloss >= 1.2.0.1, safe >= 0.3.8, containers >= 0.5.0.0, diagrams-contrib >= 1.1.2.1
 
   -- Directories containing source files.
   -- hs-source-dirs:
@@ -80,7 +80,7 @@ executable Gif
   -- other-extensions:
 
   -- Other library packages from which modules are imported.
-  build-depends:       base >=4.6 && <4.8, diagrams-lib >=1.2 && <1.3, diagrams-cairo >=1.2 && <1.3, transformers >=0.4 && <0.5, JuicyPixels >= 3.1.7.1, dequeue >= 0.1.5, multiset-comb >= 0.2.1, gloss >= 1.2.0.1, safe >= 0.3.8
+  build-depends:       base >=4.6 && <4.8, diagrams-lib >=1.2 && <1.3, diagrams-cairo >=1.2 && <1.3, transformers >=0.4 && <0.5, JuicyPixels >= 3.1.7.1, dequeue >= 0.1.5, multiset-comb >= 0.2.1, gloss >= 1.2.0.1, safe >= 0.3.8, containers >= 0.5.0.0, diagrams-contrib >= 1.1.2.1
 
   -- Directories containing source files.
   -- hs-source-dirs:

GUI/Gtk.hs

@@ -25,6 +25,8 @@ import Text.Read
 data MyGUI = MkMyGUI {
   -- |main Window
   win :: Window,
+  -- |Tree Window
+  winT :: Window,
   -- |delete Button
   dB  :: Button,
   -- |save Button
@@ -35,6 +37,8 @@ data MyGUI = MkMyGUI {
   fB  :: FileChooserButton,
   -- |drawing area
   da  :: DrawingArea,
+  -- |drawing area for the tree
+  daT :: DrawingArea,
   -- |scaler for point thickness
   hs  :: HScale,
   -- |entry widget for lower x bound
@@ -54,7 +58,7 @@ data MyGUI = MkMyGUI {
   -- |coord check button
   cC  :: CheckButton,
   -- |Path entry widget for the quad tree.
-  pE :: Entry,
+  pE  :: Entry,
   -- |Horizontal box containing the path entry widget.
   vbox7 :: Box
 }
@@ -73,12 +77,14 @@ makeMyGladeGUI = do
 
   MkMyGUI
     <$> xmlGetWidget xml castToWindow "window1"
+    <*> xmlGetWidget xml castToWindow "window2"
     <*> xmlGetWidget xml castToButton "drawButton"
     <*> xmlGetWidget xml castToButton "saveButton"
     <*> xmlGetWidget xml castToButton "quitButton"
     <*> xmlGetWidget xml castToFileChooserButton
           "filechooserButton"
     <*> xmlGetWidget xml castToDrawingArea "drawingarea"
+    <*> xmlGetWidget xml castToDrawingArea "treedrawingarea"
     <*> xmlGetWidget xml castToHScale "hscale"
     <*> xmlGetWidget xml castToEntry "xlD"
     <*> xmlGetWidget xml castToEntry "xuD"
@@ -124,8 +130,10 @@ makeGUI startFile = do
   -- have to redraw for window overlapping and resizing on expose
   _ <- onExpose (da mygui) (\_ -> drawDiag mygui >>=
                              (\_ -> return True))
+  _ <- onExpose (daT mygui) (\_ -> drawDiag mygui >>=
+                             (\_ -> return True))
   _ <- on (cB mygui) changed (drawDiag mygui)
-  _ <- on (cB mygui) changed (showPathWidget mygui)
+  _ <- on (cB mygui) changed (onPathWidgetChange mygui)
   _ <- on (gC mygui) toggled (drawDiag mygui)
   _ <- on (cC mygui) toggled (drawDiag mygui)
 
@@ -134,6 +142,10 @@ makeGUI startFile = do
     [Control] <- eventModifier
     "q"       <- eventKeyName
     liftIO mainQuit
+  _ <- winT mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "q"       <- eventKeyName
+    liftIO (widgetHide $ winT mygui)
   _ <- win mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
     "s"       <- eventKeyName
@@ -149,7 +161,9 @@ makeGUI startFile = do
 
   -- draw widgets and start main loop
   widgetShowAll (win mygui)
+  widgetShowAll (winT mygui)
   widgetHide (vbox7 mygui)
+  widgetHide (winT mygui)
   mainGUI
 
 
@@ -166,12 +180,16 @@ showErrorDialog str = do
 
 
 -- |May hide or show the widget that holds the quad tree path entry,
--- depending on the context.
+-- depending on the context and may also pop up the tree window.
-showPathWidget :: MyGUI
+onPathWidgetChange :: MyGUI
                -> IO ()
-showPathWidget mygui = do
+onPathWidgetChange mygui = do
   item <- comboBoxGetActive (cB mygui)
-  if item == 4 then widgetShow (vbox7 mygui) else widgetHide (vbox7 mygui)
+  if item == 4
+    then do
+      widgetShow (vbox7 mygui)
+      widgetShow (winT mygui)
+    else widgetHide (vbox7 mygui)
   return ()
 
 
@@ -217,6 +235,7 @@ saveAndDrawDiag fp fps mygui =
     then do
       mesh       <- readFile fp
       dw         <- widgetGetDrawWindow (da mygui)
+      dwT        <- widgetGetDrawWindow (daT mygui)
       adjustment <- rangeGetAdjustment (hs mygui)
       scaleVal   <- adjustmentGetValue adjustment
       xlD'       <- entryGetText (xl mygui)
@@ -225,6 +244,7 @@ saveAndDrawDiag fp fps mygui =
       yuD'       <- entryGetText (yu mygui)
       alg'       <- comboBoxGetActive (cB mygui)
       (daW, daH) <- widgetGetSize (da mygui)
+      (daTW, daTH) <- widgetGetSize (daT mygui)
       gd'        <- toggleButtonGetActive (gC mygui)
       ct'        <- toggleButtonGetActive (cC mygui)
       pE'        <- entryGetText (pE mygui)
@@ -236,23 +256,29 @@ saveAndDrawDiag fp fps mygui =
         yD = (,)         <$>
           readMaybe ylD' <*>
           readMaybe yuD' :: Maybe (Double, Double)
+        renderDiag winWidth winHeight buildDiag xD' yD' =
+          renderDia Cairo
+            (CairoOptions fps
+               (Dims (fromIntegral winWidth) (fromIntegral winHeight))
+               SVG False)
+            (buildDiag (def{
+                t   = scaleVal,
+                dX  = xD',
+                dY  = yD',
+                alg = alg',
+                gd  = gd',
+                ct  = ct',
+                pQt = pE'})
+              mesh)
 
       case (xD, yD) of
         (Just xD', Just yD') -> do
-          let (s, r) = renderDia Cairo
+          let (s, r)  = renderDiag daW daH diagS xD' yD'
-                (CairoOptions fps
+          let (_, r') = renderDiag daTW daTH diagTreeS xD' yD'
-                   (Dims (fromIntegral daW) (fromIntegral daH))
+
-                   SVG False)
-                (diagS (def{
-                    t   = scaleVal,
-                    dX  = xD',
-                    dY  = yD',
-                    alg = alg',
-                    gd  = gd',
-                    ct  = ct',
-                    pQt = pE'})
-                  mesh)
           renderWithDrawable dw r
+          renderWithDrawable dwT r'
+
           if null fps
             then return ()
             else s

GUI/gtk2.glade

@@ -867,4 +867,16 @@ Show quad tree squares</property>
       </widget>
     </child>
   </widget>
+  <widget class="GtkWindow" id="window2">
+    <property name="width_request">800</property>
+    <property name="height_request">500</property>
+    <property name="can_focus">False</property>
+    <property name="type_hint">dialog</property>
+    <child>
+      <widget class="GtkDrawingArea" id="treedrawingarea">
+        <property name="visible">True</property>
+        <property name="can_focus">False</property>
+      </widget>
+    </child>
+  </widget>
 </glade-interface>

Graphics/Diagram/Gtk.hs

@@ -40,3 +40,11 @@ diagS :: DiagProp -> MeshString -> Diagram Cairo R2
 diagS p mesh
   | alg p == 2 || alg p == 3 = diag p. Objects . facesToArr $ mesh
   | otherwise = (diag p . Object . meshToArr $ mesh) # bg white
+
+
+-- |Create the tree diagram from a String which is supposed to be the contents
+-- of an obj file.
+diagTreeS :: DiagProp -> MeshString -> Diagram Cairo R2
+diagTreeS p mesh
+  | alg p == 4 = mkDiag treePretty p (Object . meshToArr  $mesh)
+  | otherwise  = mempty

Graphics/Diagram/Plotter.hs

@@ -8,8 +8,10 @@ import Algorithms.RangeSearch.QuadTree
 import Algorithms.PolygonIntersection.Core
 import Data.Maybe
 import Data.Monoid
+import Data.Tree
 import Diagrams.Backend.Cairo
 import Diagrams.Prelude hiding ((<>))
+import Diagrams.TwoD.Layout.Tree
 import Graphics.Diagram.Types
 import Graphics.Gloss.Data.Extent
 import Parser.PathParser
@@ -231,6 +233,23 @@ gifQuadPath = GifDiag f
         vtf = filterValidPT p vt
 
 
+-- |A diagram that shows the full Quad Tree with nodes.
+treePretty :: Diag
+treePretty = Diag f
+  where
+    f p (Object []) = mempty
+    f p (Object vt) = prettyRoseTree (quadTreeToRoseTree (qt, []))
+      where
+        qt = quadTree (filterValidPT p vt) (dX p, dY p)
+        prettyRoseTree :: Tree String -> Diagram Cairo R2
+        prettyRoseTree t =
+          renderTree (\n -> (text n # fontSizeL 5.0)
+                        <> rect 50.0 20.0 # fc white)
+                     (~~)
+                     (symmLayout' (with & slHSep .~ 60 & slVSep .~ 40) t)
+          # scale 2 # alignT # bg white
+
+
 -- |Creates a Diagram that shows an XAxis which is bound
 -- by the dimensions given in xD from DiagProp.
 xAxis :: Diag