diff --git a/Algorithms/RangeSearch/QuadTree.hs b/Algorithms/RangeSearch/QuadTree.hs index c0bac9f..0351fec 100644 --- a/Algorithms/RangeSearch/QuadTree.hs +++ b/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" diff --git a/CG2.cabal b/CG2.cabal index 894f85e..94a59e3 100644 --- a/CG2.cabal +++ b/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: diff --git a/GUI/Gtk.hs b/GUI/Gtk.hs index 2f36da0..8e49e79 100644 --- a/GUI/Gtk.hs +++ b/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. -showPathWidget :: MyGUI +-- depending on the context and may also pop up the tree window. +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 - (CairoOptions fps - (Dims (fromIntegral daW) (fromIntegral daH)) - SVG False) - (diagS (def{ - t = scaleVal, - dX = xD', - dY = yD', - alg = alg', - gd = gd', - ct = ct', - pQt = pE'}) - mesh) + let (s, r) = renderDiag daW daH diagS xD' yD' + let (_, r') = renderDiag daTW daTH diagTreeS xD' yD' + renderWithDrawable dw r + renderWithDrawable dwT r' + if null fps then return () else s diff --git a/GUI/gtk2.glade b/GUI/gtk2.glade index 716ca9f..7cb19df 100644 --- a/GUI/gtk2.glade +++ b/GUI/gtk2.glade @@ -867,4 +867,16 @@ Show quad tree squares + + 800 + 500 + False + dialog + + + True + False + + + diff --git a/Graphics/Diagram/Gtk.hs b/Graphics/Diagram/Gtk.hs index 89be33c..14b74e5 100644 --- a/Graphics/Diagram/Gtk.hs +++ b/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 diff --git a/Graphics/Diagram/Plotter.hs b/Graphics/Diagram/Plotter.hs index e1d40d1..15821bf 100644 --- a/Graphics/Diagram/Plotter.hs +++ b/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