hasufell/cga
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

GUI/DIAG: allow visualizing the rangeSearch and the tree

Browse Source
This commit is contained in:
hasufell 2014-11-29 23:45:53 +01:00
parent fd4f135efa
commit 543b08df2c
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
6 changed files with 370 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
Algorithms/KDTree/KDTree.hs
View File

@ -4,6 +4,7 @@ module Algorithms.KDTree.KDTree where
import Algebra.VectorTypes import Algebra.VectorTypes
import Algebra.Vector import Algebra.Vector
import Data.Maybe (fromJust, catMaybes) import Data.Maybe (fromJust, catMaybes)
import Data.Tree
import Diagrams.TwoD.Types import Diagrams.TwoD.Types
import MyPrelude (pivot,if',Not, not') import MyPrelude (pivot,if',Not, not')
import Safe import Safe
@ -81,17 +82,47 @@ partitionX (xs, ys) = (\(x, y) -> (y, x))
. partition' (fromJust . pivot $ xs) $ (ys, xs) . partition' (fromJust . pivot $ xs) $ (ys, xs)
-- |Execute a range search in O(log n). -- |Execute a range search in O(log n). It returns a tuple
rangeSearch :: KDTree PT -> Square -> [PT] -- of the points found in the range and also gives back a pretty
rangeSearch KTNil _ = [] -- rose tree suitable for printing.
rangeSearch (KTNode ln pt Vertical rn) sq@(_, (y1, y2)) = rangeSearch :: KDTree PT -> Square -> ([PT], Tree String)
[pt | inRange sq pt] rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
++ (if y1 < (snd . unp2 $ pt) then rangeSearch ln sq else []) where
++ (if (snd . unp2 $ pt) < y2 then rangeSearch rn sq else []) -- either y1 or x1 depending on the orientation
rangeSearch (KTNode ln pt Horizontal rn) sq@((x1, x2), _) = p1' dir ((x1, _), (y1, _)) = if' (dir == Vertical) y1 x1
[pt | inRange sq pt] -- either y2 or x2 depending on the orientation
++ (if x1 < (fst . unp2 $ pt) then rangeSearch ln sq else []) p2' dir ((_, x2), (_, y2)) = if' (dir == Vertical) y2 x2
++ (if (fst . unp2 $ pt) < x2 then rangeSearch rn sq else []) -- 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 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]

63
GUI/Gtk.hs
View File

@ -6,6 +6,7 @@ import Control.Applicative
import Control.Monad(unless) import Control.Monad(unless)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.Maybe
import Diagrams.Prelude import Diagrams.Prelude
import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.Internal import Diagrams.Backend.Cairo.Internal
@ -61,7 +62,17 @@ data MyGUI = MkMyGUI {
-- |Path entry widget for the quad tree. -- |Path entry widget for the quad tree.
quadPathEntry :: Entry, quadPathEntry :: Entry,
-- |Horizontal box containing the path entry widget. -- |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 castToCheckButton "coordcheckbutton"
<*> xmlGetWidget xml castToEntry "path" <*> xmlGetWidget xml castToEntry "path"
<*> xmlGetWidget xml castToBox "vbox7" <*> 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. -- |Main entry point for the GTK GUI routines.
@ -164,6 +180,7 @@ makeGUI startFile = do
widgetShowAll (rootWin mygui) widgetShowAll (rootWin mygui)
widgetShowAll (treeWin mygui) widgetShowAll (treeWin mygui)
widgetHide (vbox7 mygui) widgetHide (vbox7 mygui)
widgetHide (vbox10 mygui)
widgetHide (treeWin mygui) widgetHide (treeWin mygui)
mainGUI mainGUI
@ -193,6 +210,13 @@ onAlgoBoxChange mygui = do
else do else do
widgetHide (vbox7 mygui) widgetHide (vbox7 mygui)
widgetHide (treeWin mygui) widgetHide (treeWin mygui)
if item == 5
then do
widgetShow (vbox10 mygui)
widgetShow (treeWin mygui)
else do
widgetHide (vbox10 mygui)
widgetHide (treeWin mygui)
return () return ()
@ -251,6 +275,10 @@ saveAndDrawDiag fp fps mygui =
gridActive <- toggleButtonGetActive (gridCheckBox mygui) gridActive <- toggleButtonGetActive (gridCheckBox mygui)
coordTextActive <- toggleButtonGetActive (coordCheckBox mygui) coordTextActive <- toggleButtonGetActive (coordCheckBox mygui)
quadPathEntry' <- entryGetText (quadPathEntry mygui) quadPathEntry' <- entryGetText (quadPathEntry mygui)
rxminEntryText <- entryGetText (rangeXminEntry mygui)
rxmaxEntryText <- entryGetText (rangeXmaxEntry mygui)
ryminEntryText <- entryGetText (rangeYminEntry mygui)
rymaxEntryText <- entryGetText (rangeYmaxEntry mygui)
let let
xDim = (,) <$> xDim = (,) <$>
@ -259,31 +287,36 @@ saveAndDrawDiag fp fps mygui =
yDim = (,) <$> yDim = (,) <$>
readMaybe yminEntryText <*> readMaybe yminEntryText <*>
readMaybe ymaxEntryText :: Maybe (Double, Double) 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 renderDia Cairo
(CairoOptions fps (CairoOptions fps
(Dims (fromIntegral winWidth) (fromIntegral winHeight)) (Dims (fromIntegral winWidth) (fromIntegral winHeight))
SVG False) SVG False)
(buildDiag (def{ (buildDiag (def{
dotSize = scaleVal, dotSize = scaleVal,
xDimension = xDim', xDimension = fromMaybe (0, 500) xDim,
yDimension = yDim', yDimension = fromMaybe (0, 500) yDim,
algo = algoActive, algo = algoActive,
haveGrid = gridActive, haveGrid = gridActive,
showCoordText = coordTextActive, showCoordText = coordTextActive,
quadPath = quadPathEntry'}) quadPath = quadPathEntry',
rangeSquare = (fromMaybe (0, 500) rxDim,
fromMaybe (0, 500) ryDim)
})
mesh) mesh)
(s, r) = renderDiag daW daH diagS
(_, r') = renderDiag daTW daTH diagTreeS
case (xDim, yDim) of renderWithDrawable mainDrawWindow r
(Just xDim', Just yDim') -> do renderWithDrawable treeDrawWindow r'
let (s, r) = renderDiag daW daH diagS xDim' yDim'
let (_, r') = renderDiag daTW daTH diagTreeS xDim' yDim'
renderWithDrawable mainDrawWindow r unless (null fps) s
renderWithDrawable treeDrawWindow r' return 0
unless (null fps) s
return 0
_ -> return 1
else return 2 else return 2

208
GUI/gtk2.glade
View File

@ -848,6 +848,212 @@ Public License instead of this License.
<property name="position">6</property> <property name="position">6</property>
</packing> </packing>
</child> </child>
<child>
<widget class="GtkVBox" id="vbox10">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkHBox" id="hbox7">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkLabel" id="label11">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">Range search</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="padding">5</property>
<property name="position">0</property>
</packing>
</child>
<child>
<widget class="GtkVBox" id="vbox11">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkLabel" id="label7">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">X min</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<widget class="GtkEntry" id="rxMin">
<property name="width_request">5</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="invisible_char">●</property>
<property name="primary_icon_activatable">False</property>
<property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
<child>
<widget class="GtkVBox" id="vbox12">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkLabel" id="label8">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">X max</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<widget class="GtkEntry" id="rxMax">
<property name="width_request">5</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="invisible_char">●</property>
<property name="primary_icon_activatable">False</property>
<property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child>
<child>
<widget class="GtkVBox" id="vbox13">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkLabel" id="label9">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">Y min</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<widget class="GtkEntry" id="ryMin">
<property name="width_request">5</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="invisible_char">●</property>
<property name="primary_icon_activatable">False</property>
<property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">3</property>
</packing>
</child>
<child>
<widget class="GtkVBox" id="vbox14">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<widget class="GtkLabel" id="label10">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">Y max</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<widget class="GtkEntry" id="ryMax">
<property name="width_request">5</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="invisible_char">●</property>
<property name="primary_icon_activatable">False</property>
<property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
</widget>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">4</property>
</packing>
</child>
</widget>
<packing>
<property name="expand">False</property>
<property name="fill">False</property>
<property name="position">0</property>
</packing>
</child>
<child>
<widget class="GtkHSeparator" id="hseparator4">
<property name="visible">True</property>
<property name="can_focus">False</property>
</widget>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
</widget>
<packing>
<property name="expand">False</property>
<property name="fill">False</property>
<property name="position">7</property>
</packing>
</child>
<child> <child>
<widget class="GtkComboBox" id="comboalgo"> <widget class="GtkComboBox" id="comboalgo">
<property name="visible">True</property> <property name="visible">True</property>
@ -862,7 +1068,7 @@ Show kd tree squares</property>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
<property name="position">7</property> <property name="position">8</property>
</packing> </packing>
</child> </child>
</widget> </widget>

6
Graphics/Diagram/Gtk.hs
View File

@ -24,7 +24,7 @@ diag p obj@(Object _)
coordPoints, polyLines, plotterBG]) coordPoints, polyLines, plotterBG])
p obj p obj
| algo p == 5 = | algo p == 5 =
mkDiag (mconcat [kdSquares, coordPointsText, mkDiag (mconcat [kdRange, kdSquares, coordPointsText,
coordPoints, plotterBG]) coordPoints, plotterBG])
p obj p obj
| otherwise = mempty | otherwise = mempty
@ -60,4 +60,8 @@ diagTreeS p mesh
. filterValidPT p . filterValidPT p
. meshToArr . meshToArr
$ mesh) $ mesh)
| algo p == 5 = mkDiag kdTreeDiag p (Object
. filterValidPT p
. meshToArr
$ mesh)
| otherwise = mempty | otherwise = mempty

64
Graphics/Diagram/Plotter.hs
View File

@ -16,6 +16,7 @@ import Diagrams.TwoD.Layout.Tree
import Graphics.Diagram.Types import Graphics.Diagram.Types
import Parser.PathParser import Parser.PathParser
import qualified Debug.Trace as D
-- |Creates a Diagram that shows the coordinates from the points -- |Creates a Diagram that shows the coordinates from the points
-- as dots. The points and thickness of the dots can be controlled -- as dots. The points and thickness of the dots can be controlled
@ -23,13 +24,20 @@ import Parser.PathParser
coordPoints :: Diag coordPoints :: Diag
coordPoints = Diag cp coordPoints = Diag cp
where where
cp p (Object vt) = drawP vt p cp p (Object vt) = drawP vt (dotSize p) black
cp p (Objects vts) = drawP (concat vts) p cp p (Objects vts) = drawP (concat vts) (dotSize p) black
drawP [] _ = mempty
drawP vt p =
position (zip vt (repeat dot)) -- |Draw a list of points.
where drawP :: [PT] -- ^ the points to draw
dot = (circle $ dotSize p :: Diagram Cairo R2) # fc black -> 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 -- |Creates a Diagram from a point that shows the coordinates
@ -182,7 +190,7 @@ squares = Diag f
-- |Draw the squares of the kd-tree. -- |Draw the squares of the kd-tree.
kdSquares:: Diag kdSquares :: Diag
kdSquares = Diag f kdSquares = Diag f
where where
f _ (Object []) = mempty f _ (Object []) = mempty
@ -212,6 +220,46 @@ kdSquares = Diag f
f _ _ = mempty 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. -- |Get the quad tree corresponding to the given points and diagram properties.
qt :: [PT] -> DiagProp -> QuadTree PT qt :: [PT] -> DiagProp -> QuadTree PT
qt vt p = quadTree vt (xDimension p, yDimension p) qt vt p = quadTree vt (xDimension p, yDimension p)

7
Graphics/Diagram/Types.hs
View File

@ -55,7 +55,9 @@ data DiagProp = MkProp {
-- |Square size used to show the grid and x/y-axis. -- |Square size used to show the grid and x/y-axis.
squareSize :: Double, squareSize :: Double,
-- |The path to a quad in the quad tree. -- |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. -- |The default properties of the Diagram.
diagDefaultProp :: DiagProp 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. -- |Extract the lower bound of the x-axis dimension.