From 543b08df2c3a12a0f383561c96999889d9a9c69c Mon Sep 17 00:00:00 2001 From: hasufell Date: Sat, 29 Nov 2014 23:45:53 +0100 Subject: [PATCH] GUI/DIAG: allow visualizing the rangeSearch and the tree --- Algorithms/KDTree/KDTree.hs | 60 +++++++++-- GUI/Gtk.hs | 63 ++++++++--- GUI/gtk2.glade | 208 +++++++++++++++++++++++++++++++++++- Graphics/Diagram/Gtk.hs | 6 +- Graphics/Diagram/Plotter.hs | 64 +++++++++-- Graphics/Diagram/Types.hs | 7 +- 6 files changed, 370 insertions(+), 38 deletions(-) diff --git a/Algorithms/KDTree/KDTree.hs b/Algorithms/KDTree/KDTree.hs index 254db92..b8483a1 100644 --- a/Algorithms/KDTree/KDTree.hs +++ b/Algorithms/KDTree/KDTree.hs @@ -4,6 +4,7 @@ module Algorithms.KDTree.KDTree where import Algebra.VectorTypes import Algebra.Vector import Data.Maybe (fromJust, catMaybes) +import Data.Tree import Diagrams.TwoD.Types import MyPrelude (pivot,if',Not, not') import Safe @@ -81,17 +82,47 @@ partitionX (xs, ys) = (\(x, y) -> (y, x)) . partition' (fromJust . pivot $ xs) $ (ys, xs) --- |Execute a range search in O(log n). -rangeSearch :: KDTree PT -> Square -> [PT] -rangeSearch KTNil _ = [] -rangeSearch (KTNode ln pt Vertical rn) sq@(_, (y1, y2)) = - [pt | inRange sq pt] - ++ (if y1 < (snd . unp2 $ pt) then rangeSearch ln sq else []) - ++ (if (snd . unp2 $ pt) < y2 then rangeSearch rn sq else []) -rangeSearch (KTNode ln pt Horizontal rn) sq@((x1, x2), _) = - [pt | inRange sq pt] - ++ (if x1 < (fst . unp2 $ pt) then rangeSearch ln sq else []) - ++ (if (fst . unp2 $ pt) < x2 then rangeSearch rn sq else []) +-- |Execute a range search in O(log n). It returns a tuple +-- of the points found in the range and also gives back a pretty +-- rose tree suitable for printing. +rangeSearch :: KDTree PT -> Square -> ([PT], Tree String) +rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True) + where + -- either y1 or x1 depending on the orientation + p1' dir ((x1, _), (y1, _)) = if' (dir == Vertical) y1 x1 + -- either y2 or x2 depending on the orientation + p2' dir ((_, x2), (_, y2)) = if' (dir == Vertical) y2 x2 + -- either the second or first of the tuple, depending on the orientation + cur' dir = if' (dir == Vertical) snd fst + -- All points in the range. + goPt :: KDTree PT -> Square -> [PT] + goPt KTNil _ = [] + goPt (KTNode ln pt dir rn) sq = + [pt | inRange sq pt] + ++ (if' (p1' dir sq < (cur' dir . unp2 $ pt)) + (goPt ln sq) + [] + ) + ++ (if' ((cur' dir . unp2 $ pt) < p2' dir sq) + (goPt rn sq) + []) + where + -- A pretty rose tree suitable for printing. + goTree :: KDTree PT -> Square -> Bool -> Tree String + goTree KTNil _ _ = Node "nil" [] + goTree (KTNode ln pt dir rn) sq vis = + Node treeText + [if' (p1' dir sq < (cur' dir . unp2 $ pt)) + (goTree ln sq vis) + (goTree ln sq False) + , if' ((cur' dir . unp2 $ pt) < p2' dir sq) + (goTree rn sq vis) + (goTree rn sq False)] + where + treeText + | vis && inRange sq pt = "** " ++ (show . unp2 $ pt) + | vis = "* " ++ (show . unp2 $ pt) + | otherwise = show . unp2 $ pt @@ -130,3 +161,10 @@ getDirection (KTNode _ _ dir _) = Just dir getDirection _ = Nothing +-- |Convert a kd-tree to a rose tree, for pretty printing. +kdTreeToRoseTree :: KDTree PT -> Tree String +kdTreeToRoseTree (KTNil) = Node "nil" [] +kdTreeToRoseTree (KTNode ln val _ rn) = + Node (show . unp2 $ val) [kdTreeToRoseTree ln, kdTreeToRoseTree rn] + + diff --git a/GUI/Gtk.hs b/GUI/Gtk.hs index 0262241..d867f33 100644 --- a/GUI/Gtk.hs +++ b/GUI/Gtk.hs @@ -6,6 +6,7 @@ import Control.Applicative import Control.Monad(unless) import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as B +import Data.Maybe import Diagrams.Prelude import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo.Internal @@ -61,7 +62,17 @@ data MyGUI = MkMyGUI { -- |Path entry widget for the quad tree. quadPathEntry :: Entry, -- |Horizontal box containing the path entry widget. - vbox7 :: Box + vbox7 :: Box, + -- |Horizontal box containing the Rang search entry widgets. + vbox10 :: Box, + -- |Range entry widget for lower x bound + rangeXminEntry :: Entry, + -- |Range entry widget for upper x bound + rangeXmaxEntry :: Entry, + -- |Range entry widget for lower y bound + rangeYminEntry :: Entry, + -- |Range entry widget for upper y bound + rangeYmaxEntry :: Entry } @@ -96,6 +107,11 @@ makeMyGladeGUI = do <*> xmlGetWidget xml castToCheckButton "coordcheckbutton" <*> xmlGetWidget xml castToEntry "path" <*> xmlGetWidget xml castToBox "vbox7" + <*> xmlGetWidget xml castToBox "vbox10" + <*> xmlGetWidget xml castToEntry "rxMin" + <*> xmlGetWidget xml castToEntry "rxMax" + <*> xmlGetWidget xml castToEntry "ryMin" + <*> xmlGetWidget xml castToEntry "ryMax" -- |Main entry point for the GTK GUI routines. @@ -164,6 +180,7 @@ makeGUI startFile = do widgetShowAll (rootWin mygui) widgetShowAll (treeWin mygui) widgetHide (vbox7 mygui) + widgetHide (vbox10 mygui) widgetHide (treeWin mygui) mainGUI @@ -193,6 +210,13 @@ onAlgoBoxChange mygui = do else do widgetHide (vbox7 mygui) widgetHide (treeWin mygui) + if item == 5 + then do + widgetShow (vbox10 mygui) + widgetShow (treeWin mygui) + else do + widgetHide (vbox10 mygui) + widgetHide (treeWin mygui) return () @@ -251,6 +275,10 @@ saveAndDrawDiag fp fps mygui = gridActive <- toggleButtonGetActive (gridCheckBox mygui) coordTextActive <- toggleButtonGetActive (coordCheckBox mygui) quadPathEntry' <- entryGetText (quadPathEntry mygui) + rxminEntryText <- entryGetText (rangeXminEntry mygui) + rxmaxEntryText <- entryGetText (rangeXmaxEntry mygui) + ryminEntryText <- entryGetText (rangeYminEntry mygui) + rymaxEntryText <- entryGetText (rangeYmaxEntry mygui) let xDim = (,) <$> @@ -259,31 +287,36 @@ saveAndDrawDiag fp fps mygui = yDim = (,) <$> readMaybe yminEntryText <*> readMaybe ymaxEntryText :: Maybe (Double, Double) - renderDiag winWidth winHeight buildDiag xDim' yDim' = + rxDim = (,) <$> + readMaybe rxminEntryText <*> + readMaybe rxmaxEntryText :: Maybe (Double, Double) + ryDim = (,) <$> + readMaybe ryminEntryText <*> + readMaybe rymaxEntryText :: Maybe (Double, Double) + renderDiag winWidth winHeight buildDiag = renderDia Cairo (CairoOptions fps (Dims (fromIntegral winWidth) (fromIntegral winHeight)) SVG False) (buildDiag (def{ dotSize = scaleVal, - xDimension = xDim', - yDimension = yDim', + xDimension = fromMaybe (0, 500) xDim, + yDimension = fromMaybe (0, 500) yDim, algo = algoActive, haveGrid = gridActive, showCoordText = coordTextActive, - quadPath = quadPathEntry'}) + quadPath = quadPathEntry', + rangeSquare = (fromMaybe (0, 500) rxDim, + fromMaybe (0, 500) ryDim) + }) mesh) + (s, r) = renderDiag daW daH diagS + (_, r') = renderDiag daTW daTH diagTreeS - case (xDim, yDim) of - (Just xDim', Just yDim') -> do - let (s, r) = renderDiag daW daH diagS xDim' yDim' - let (_, r') = renderDiag daTW daTH diagTreeS xDim' yDim' + renderWithDrawable mainDrawWindow r + renderWithDrawable treeDrawWindow r' - renderWithDrawable mainDrawWindow r - renderWithDrawable treeDrawWindow r' - - unless (null fps) s - return 0 - _ -> return 1 + unless (null fps) s + return 0 else return 2 diff --git a/GUI/gtk2.glade b/GUI/gtk2.glade index f28ff42..9e4b5e1 100644 --- a/GUI/gtk2.glade +++ b/GUI/gtk2.glade @@ -848,6 +848,212 @@ Public License instead of this License. 6 + + + True + False + + + True + False + + + True + False + Range search + + + True + True + 5 + 0 + + + + + True + False + + + True + False + X min + + + True + True + 0 + + + + + 5 + True + True + ● + False + False + True + True + + + True + True + 1 + + + + + True + True + 1 + + + + + True + False + + + True + False + X max + + + True + True + 0 + + + + + 5 + True + True + ● + False + False + True + True + + + True + True + 1 + + + + + True + True + 2 + + + + + True + False + + + True + False + Y min + + + True + True + 0 + + + + + 5 + True + True + ● + False + False + True + True + + + True + True + 1 + + + + + True + True + 3 + + + + + True + False + + + True + False + Y max + + + True + True + 0 + + + + + 5 + True + True + ● + False + False + True + True + + + True + True + 1 + + + + + True + True + 4 + + + + + False + False + 0 + + + + + True + False + + + False + True + 1 + + + + + False + False + 7 + + True @@ -862,7 +1068,7 @@ Show kd tree squares False False - 7 + 8 diff --git a/Graphics/Diagram/Gtk.hs b/Graphics/Diagram/Gtk.hs index c692809..f87af39 100644 --- a/Graphics/Diagram/Gtk.hs +++ b/Graphics/Diagram/Gtk.hs @@ -24,7 +24,7 @@ diag p obj@(Object _) coordPoints, polyLines, plotterBG]) p obj | algo p == 5 = - mkDiag (mconcat [kdSquares, coordPointsText, + mkDiag (mconcat [kdRange, kdSquares, coordPointsText, coordPoints, plotterBG]) p obj | otherwise = mempty @@ -60,4 +60,8 @@ diagTreeS p mesh . filterValidPT p . meshToArr $ mesh) + | algo p == 5 = mkDiag kdTreeDiag p (Object + . filterValidPT p + . meshToArr + $ mesh) | otherwise = mempty diff --git a/Graphics/Diagram/Plotter.hs b/Graphics/Diagram/Plotter.hs index 32c3f60..c346763 100644 --- a/Graphics/Diagram/Plotter.hs +++ b/Graphics/Diagram/Plotter.hs @@ -16,6 +16,7 @@ import Diagrams.TwoD.Layout.Tree import Graphics.Diagram.Types import Parser.PathParser +import qualified Debug.Trace as D -- |Creates a Diagram that shows the coordinates from the points -- as dots. The points and thickness of the dots can be controlled @@ -23,13 +24,20 @@ import Parser.PathParser coordPoints :: Diag coordPoints = Diag cp where - cp p (Object vt) = drawP vt p - cp p (Objects vts) = drawP (concat vts) p - drawP [] _ = mempty - drawP vt p = - position (zip vt (repeat dot)) - where - dot = (circle $ dotSize p :: Diagram Cairo R2) # fc black + cp p (Object vt) = drawP vt (dotSize p) black + cp p (Objects vts) = drawP (concat vts) (dotSize p) black + + +-- |Draw a list of points. +drawP :: [PT] -- ^ the points to draw + -> Double -- ^ dot size + -> Colour Double -- ^ fc and lc + -> Diagram Cairo R2 -- ^ the resulting diagram +drawP [] _ _ = mempty +drawP vt ds col = + position (zip vt (repeat dot)) + where + dot = (circle ds :: Diagram Cairo R2) # fc col # lc col -- |Creates a Diagram from a point that shows the coordinates @@ -182,7 +190,7 @@ squares = Diag f -- |Draw the squares of the kd-tree. -kdSquares:: Diag +kdSquares :: Diag kdSquares = Diag f where f _ (Object []) = mempty @@ -212,6 +220,46 @@ kdSquares = Diag f f _ _ = mempty +-- |Draw the range rectangle and highlight the points inside that range. +kdRange :: Diag +kdRange = Diag f + where + f _ (Object []) = mempty + f p (Object vt) = + (\((xmin, xmax), (ymin, ymax)) -> rect (xmax - xmin) (ymax - ymin) + # moveTo (p2 ((xmax + xmin) / 2, (ymax + ymin) / 2)) + # lc red) + (rangeSquare p) + <> drawP ptsInRange (dotSize p) red + where + ptsInRange = fst . rangeSearch (kdTree vt Vertical) $ rangeSquare p + f _ _ = mempty + + +-- |The kd-tree visualized as binary tree. +kdTreeDiag :: Diag +kdTreeDiag = Diag f + where + f _ (Object []) = mempty + f p (Object vt) = + renderTree (\n -> case n of + '*':'*':_ -> (text n # fontSizeL 5.0) + <> rect 50.0 20.0 # fc green + '*':_ -> (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) roseTree) + # scale 2 # alignT # bg white + where + roseTree = snd + . rangeSearch (kdTree vt Vertical) + $ rangeSquare p + + f _ _ = mempty + + -- |Get the quad tree corresponding to the given points and diagram properties. qt :: [PT] -> DiagProp -> QuadTree PT qt vt p = quadTree vt (xDimension p, yDimension p) diff --git a/Graphics/Diagram/Types.hs b/Graphics/Diagram/Types.hs index 3c5bf9b..1880e2b 100644 --- a/Graphics/Diagram/Types.hs +++ b/Graphics/Diagram/Types.hs @@ -55,7 +55,9 @@ data DiagProp = MkProp { -- |Square size used to show the grid and x/y-axis. squareSize :: Double, -- |The path to a quad in the quad tree. - quadPath :: String + quadPath :: String, + -- |The square for the kd-tree range search. + rangeSquare :: Square } @@ -85,7 +87,8 @@ instance Monoid Diag where -- |The default properties of the Diagram. diagDefaultProp :: DiagProp -diagDefaultProp = MkProp 2 (0,500) (0,500) 0 False False 50 "" +diagDefaultProp = MkProp 2 (0,500) (0,500) + 0 False False 50 "" ((0,500),(0,500)) -- |Extract the lower bound of the x-axis dimension.