Restructure Graphics/Diagram subdir, rename modules
This commit is contained in:
parent
3c1a34e4af
commit
a7774b69a4
@ -59,9 +59,10 @@ executable Gtk
|
|||||||
Algorithms.PolygonIntersection
|
Algorithms.PolygonIntersection
|
||||||
Algorithms.QuadTree
|
Algorithms.QuadTree
|
||||||
Algorithms.KDTree
|
Algorithms.KDTree
|
||||||
|
Graphics.Diagram.AlgoDiags
|
||||||
|
Graphics.Diagram.Core
|
||||||
Graphics.Diagram.Gtk
|
Graphics.Diagram.Gtk
|
||||||
Graphics.Diagram.Plotter
|
Graphics.Diagram.Plotter
|
||||||
Graphics.Diagram.Types
|
|
||||||
GUI.Gtk
|
GUI.Gtk
|
||||||
MyPrelude
|
MyPrelude
|
||||||
Parser.Meshparser
|
Parser.Meshparser
|
||||||
@ -106,9 +107,10 @@ executable Gif
|
|||||||
Algorithms.PolygonIntersection
|
Algorithms.PolygonIntersection
|
||||||
Algorithms.QuadTree
|
Algorithms.QuadTree
|
||||||
Algorithms.KDTree
|
Algorithms.KDTree
|
||||||
|
Graphics.Diagram.AlgoDiags
|
||||||
|
Graphics.Diagram.Core
|
||||||
Graphics.Diagram.Gif
|
Graphics.Diagram.Gif
|
||||||
Graphics.Diagram.Plotter
|
Graphics.Diagram.Plotter
|
||||||
Graphics.Diagram.Types
|
|
||||||
MyPrelude
|
MyPrelude
|
||||||
Parser.Meshparser
|
Parser.Meshparser
|
||||||
Parser.PathParser
|
Parser.PathParser
|
||||||
|
|||||||
@ -10,8 +10,8 @@ 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
|
||||||
|
import Graphics.Diagram.Core (DiagProp(..))
|
||||||
import Graphics.Diagram.Gtk
|
import Graphics.Diagram.Gtk
|
||||||
import Graphics.Diagram.Types
|
|
||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk
|
||||||
import Graphics.UI.Gtk.Glade
|
import Graphics.UI.Gtk.Glade
|
||||||
import MyPrelude
|
import MyPrelude
|
||||||
|
|||||||
257
Graphics/Diagram/AlgoDiags.hs
Normal file
257
Graphics/Diagram/AlgoDiags.hs
Normal file
@ -0,0 +1,257 @@
|
|||||||
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||||
|
|
||||||
|
module Graphics.Diagram.AlgoDiags where
|
||||||
|
|
||||||
|
import Algebra.Vector(PT,Square)
|
||||||
|
import Algorithms.GrahamScan
|
||||||
|
import Algorithms.QuadTree
|
||||||
|
import Algorithms.KDTree
|
||||||
|
import Algorithms.PolygonIntersection
|
||||||
|
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.Core
|
||||||
|
import Parser.PathParser
|
||||||
|
|
||||||
|
|
||||||
|
-- |Draw the lines of the polygon.
|
||||||
|
polyLines :: Diag
|
||||||
|
polyLines = Diag pp
|
||||||
|
where
|
||||||
|
pp _ (Objects []) = mempty
|
||||||
|
pp _ (Objects (x:y:_)) =
|
||||||
|
strokePoly x <> strokePoly y
|
||||||
|
where
|
||||||
|
strokePoly x' = (strokeTrail . fromVertices $ x' ++ [head x'])
|
||||||
|
# moveTo (head x') # lc black
|
||||||
|
pp _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Show the intersection points of two polygons as red dots.
|
||||||
|
polyIntersection :: Diag
|
||||||
|
polyIntersection = Diag pi'
|
||||||
|
where
|
||||||
|
pi' p (Objects (x:y:_)) = drawP vtpi (dotSize p) # fc red # lc red
|
||||||
|
where
|
||||||
|
vtpi = intersectionPoints . sortLexPolys $ (sortLexPoly x, sortLexPoly y)
|
||||||
|
pi' _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Show the coordinate text of the intersection points of two polygons.
|
||||||
|
polyIntersectionText :: Diag
|
||||||
|
polyIntersectionText = Diag pit'
|
||||||
|
where
|
||||||
|
pit' p (Objects (x:y:_))
|
||||||
|
| showCoordText p = position . zip vtpi $ (pointToTextCoord # fc red <$> vtpi)
|
||||||
|
# translate (r2 (0, 10))
|
||||||
|
| otherwise = mempty
|
||||||
|
where
|
||||||
|
vtpi = intersectionPoints
|
||||||
|
. sortLexPolys
|
||||||
|
$ (sortLexPoly x,
|
||||||
|
sortLexPoly y)
|
||||||
|
pit' _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create a diagram which shows the points of the convex hull.
|
||||||
|
convexHP :: Diag
|
||||||
|
convexHP = Diag chp
|
||||||
|
where
|
||||||
|
chp p (Object vt) = drawP (grahamCH vt) (dotSize p) # fc red # lc red
|
||||||
|
chp _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Show coordinates as text above the convex hull points.
|
||||||
|
convexHPText :: Diag
|
||||||
|
convexHPText = Diag chpt
|
||||||
|
where
|
||||||
|
chpt p (Object vt)
|
||||||
|
| showCoordText p =
|
||||||
|
position $ zip vtchf (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
|
||||||
|
| otherwise = mempty
|
||||||
|
where
|
||||||
|
vtchf = grahamCH vt
|
||||||
|
chpt _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create a diagram which shows the lines along the convex hull
|
||||||
|
-- points.
|
||||||
|
convexHLs :: Diag
|
||||||
|
convexHLs = Diag chl
|
||||||
|
where
|
||||||
|
chl _ (Object []) = mempty
|
||||||
|
chl _ (Object vt) =
|
||||||
|
(strokeTrail . fromVertices . flip (++) [head $ grahamCH vt] . grahamCH $ vt)
|
||||||
|
# moveTo (head $ grahamCH vt) # lc red
|
||||||
|
chl _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create list of diagrama which describe the lines along points of a half
|
||||||
|
-- convex hull, for each iteration of the algorithm. Which half is chosen
|
||||||
|
-- depends on the input.
|
||||||
|
convexHStepsLs :: Diag
|
||||||
|
convexHStepsLs = GifDiag chs
|
||||||
|
where
|
||||||
|
chs _ col f vt = fmap mkChDiag (f vt)
|
||||||
|
where
|
||||||
|
mkChDiag vt' = (strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create a diagram that shows all squares of the RangeSearch algorithm
|
||||||
|
-- from the quad tree.
|
||||||
|
squares :: Diag
|
||||||
|
squares = Diag f
|
||||||
|
where
|
||||||
|
f _ (Object []) = mempty
|
||||||
|
f p (Object vt) =
|
||||||
|
mconcat
|
||||||
|
$ (uncurry rectByDiagonal # lw ultraThin)
|
||||||
|
<$>
|
||||||
|
(quadTreeSquares (xDimension p, yDimension p)
|
||||||
|
. quadTree vt
|
||||||
|
$ (xDimension p, yDimension p))
|
||||||
|
f _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Draw the squares of the kd-tree.
|
||||||
|
kdSquares :: Diag
|
||||||
|
kdSquares = Diag f
|
||||||
|
where
|
||||||
|
f _ (Object []) = mempty
|
||||||
|
f p (Object vt) =
|
||||||
|
mconcat
|
||||||
|
. fmap (uncurry (~~))
|
||||||
|
$ kdLines (kdTree vt Horizontal) (xDimension p, yDimension p)
|
||||||
|
where
|
||||||
|
-- Gets all lines that make up the kdSquares. Every line is
|
||||||
|
-- described by two points, start and end respectively.
|
||||||
|
kdLines :: KDTree PT -> Square -> [(PT, PT)]
|
||||||
|
kdLines (KTNode ln pt Horizontal rn) ((xmin, xmax), (ymin, ymax)) =
|
||||||
|
(\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))])
|
||||||
|
(unp2 pt)
|
||||||
|
++ kdLines ln ((xmin, x'), (ymin, ymax))
|
||||||
|
++ kdLines rn ((x', xmax), (ymin, ymax))
|
||||||
|
where
|
||||||
|
(x', _) = unp2 pt
|
||||||
|
kdLines (KTNode ln pt Vertical rn) ((xmin, xmax), (ymin, ymax)) =
|
||||||
|
(\(_, y) -> [(p2 (xmin, y), p2 (xmax, y))])
|
||||||
|
(unp2 pt)
|
||||||
|
++ kdLines ln ((xmin, xmax), (ymin, y'))
|
||||||
|
++ kdLines rn ((xmin, xmax), (y', ymax))
|
||||||
|
where
|
||||||
|
(_, y') = unp2 pt
|
||||||
|
kdLines _ _ = []
|
||||||
|
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) =
|
||||||
|
(uncurry rectByDiagonal # lc red) (rangeSquare p)
|
||||||
|
<> drawP ptsInRange (dotSize p) # fc red # lc 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) =
|
||||||
|
-- HACK: in order to give specific nodes a specific color
|
||||||
|
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)
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create a diagram that shows a single square of the RangeSearch algorithm
|
||||||
|
-- from the quad tree in red, according to the given path in quadPath.
|
||||||
|
quadPathSquare :: Diag
|
||||||
|
quadPathSquare = Diag f
|
||||||
|
where
|
||||||
|
f _ (Object []) = mempty
|
||||||
|
f p (Object vt) =
|
||||||
|
(uncurry rectByDiagonal # lw thin # lc red)
|
||||||
|
(getSquare (stringToQuads (quadPath p)) (qt vt p, []))
|
||||||
|
where
|
||||||
|
getSquare :: [Either Quad Orient] -> QTZipper PT -> Square
|
||||||
|
getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z
|
||||||
|
getSquare (q:qs) z = case q of
|
||||||
|
Right x -> getSquare qs (fromMaybe z (findNeighbor x z))
|
||||||
|
Left x -> getSquare qs (fromMaybe z (goQuad x z))
|
||||||
|
f _ _ = mempty
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create a list of diagrams that show the walk along the given path
|
||||||
|
-- through the quad tree.
|
||||||
|
gifQuadPath :: Diag
|
||||||
|
gifQuadPath = GifDiag f
|
||||||
|
where
|
||||||
|
f p col _ vt =
|
||||||
|
(uncurry rectByDiagonal # lw thick # lc col)
|
||||||
|
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
|
||||||
|
where
|
||||||
|
getSquares :: [Either Quad Orient] -> QTZipper PT -> [Square]
|
||||||
|
getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
|
||||||
|
getSquares (q:qs) z = case q of
|
||||||
|
Right x -> getSquareByZipper (xDimension p, yDimension p) z :
|
||||||
|
getSquares qs (fromMaybe z (findNeighbor x z))
|
||||||
|
Left x -> getSquareByZipper (xDimension p, yDimension p) z :
|
||||||
|
getSquares qs (fromMaybe z (goQuad x z))
|
||||||
|
|
||||||
|
|
||||||
|
-- |A diagram that shows the full Quad Tree with nodes.
|
||||||
|
treePretty :: Diag
|
||||||
|
treePretty = Diag f
|
||||||
|
where
|
||||||
|
f _ (Object []) = mempty
|
||||||
|
f p (Object vt) =
|
||||||
|
prettyRoseTree (quadTreeToRoseTree
|
||||||
|
. flip getCurQT (qt vt p, [])
|
||||||
|
. stringToQuads
|
||||||
|
. quadPath
|
||||||
|
$ p)
|
||||||
|
where
|
||||||
|
getCurQT :: [Either Quad Orient] -> QTZipper PT -> QTZipper 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 tree =
|
||||||
|
-- HACK: in order to give specific nodes a specific color
|
||||||
|
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) tree)
|
||||||
|
# scale 2 # alignT # bg white
|
||||||
|
f _ _ = mempty
|
||||||
@ -1,6 +1,6 @@
|
|||||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||||
|
|
||||||
module Graphics.Diagram.Types where
|
module Graphics.Diagram.Core where
|
||||||
|
|
||||||
import Algebra.Vector
|
import Algebra.Vector
|
||||||
import Diagrams.Backend.Cairo
|
import Diagrams.Backend.Cairo
|
||||||
@ -8,9 +8,6 @@ import Diagrams.Prelude
|
|||||||
import MyPrelude
|
import MyPrelude
|
||||||
|
|
||||||
|
|
||||||
type MeshString = String
|
|
||||||
|
|
||||||
|
|
||||||
-- |Represents a Cairo Diagram. This allows us to create multiple
|
-- |Represents a Cairo Diagram. This allows us to create multiple
|
||||||
-- diagrams with different algorithms but based on the same
|
-- diagrams with different algorithms but based on the same
|
||||||
-- coordinates and common properties.
|
-- coordinates and common properties.
|
||||||
@ -143,3 +140,36 @@ maybeDiag b d
|
|||||||
|
|
||||||
filterValidPT :: DiagProp -> [PT] -> [PT]
|
filterValidPT :: DiagProp -> [PT] -> [PT]
|
||||||
filterValidPT p = filter (inRange (xDimension p, yDimension p))
|
filterValidPT p = filter (inRange (xDimension p, yDimension p))
|
||||||
|
|
||||||
|
|
||||||
|
-- |Draw a list of points.
|
||||||
|
drawP :: [PT] -- ^ the points to draw
|
||||||
|
-> Double -- ^ dot size
|
||||||
|
-> Diagram Cairo R2 -- ^ the resulting diagram
|
||||||
|
drawP [] _ = mempty
|
||||||
|
drawP vt ds =
|
||||||
|
position (zip vt (repeat dot))
|
||||||
|
where
|
||||||
|
dot = circle ds :: Diagram Cairo R2
|
||||||
|
|
||||||
|
|
||||||
|
-- |Create a rectangle around a diagonal line, which has sw
|
||||||
|
-- as startpoint and nw as endpoint.
|
||||||
|
rectByDiagonal :: (Double, Double) -- ^ sw point
|
||||||
|
-> (Double, Double) -- ^ nw point
|
||||||
|
-> Diagram Cairo R2
|
||||||
|
rectByDiagonal (xmin, xmax) (ymin, ymax) =
|
||||||
|
rect (xmax - xmin) (ymax - ymin)
|
||||||
|
# moveTo (p2 ((xmax + xmin) / 2, (ymax + ymin) / 2))
|
||||||
|
|
||||||
|
|
||||||
|
-- |Creates a Diagram from a point that shows the coordinates
|
||||||
|
-- in text format, such as "(1.0, 2.0)".
|
||||||
|
pointToTextCoord :: PT -> Diagram Cairo R2
|
||||||
|
pointToTextCoord pt =
|
||||||
|
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
|
||||||
|
where
|
||||||
|
trim' :: Double -> Double
|
||||||
|
trim' x' = fromInteger . round $ x' * (10^(2 :: Int)) /
|
||||||
|
(10.0^^(2 :: Int))
|
||||||
|
(x, y) = unp2 pt
|
||||||
@ -2,14 +2,16 @@
|
|||||||
|
|
||||||
module Graphics.Diagram.Gif where
|
module Graphics.Diagram.Gif where
|
||||||
|
|
||||||
|
import Algebra.Vector(PT)
|
||||||
import Algorithms.GrahamScan
|
import Algorithms.GrahamScan
|
||||||
import Codec.Picture.Gif
|
import Codec.Picture.Gif
|
||||||
import qualified Data.ByteString.Char8 as B
|
import qualified Data.ByteString.Char8 as B
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Diagrams.Backend.Cairo
|
import Diagrams.Backend.Cairo
|
||||||
import Diagrams.Prelude hiding ((<>))
|
import Diagrams.Prelude hiding ((<>))
|
||||||
|
import Graphics.Diagram.AlgoDiags
|
||||||
|
import Graphics.Diagram.Core
|
||||||
import Graphics.Diagram.Plotter
|
import Graphics.Diagram.Plotter
|
||||||
import Graphics.Diagram.Types
|
|
||||||
import Parser.Meshparser
|
import Parser.Meshparser
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -6,8 +6,9 @@ import qualified Data.ByteString.Char8 as B
|
|||||||
import Data.List(find)
|
import Data.List(find)
|
||||||
import Diagrams.Backend.Cairo
|
import Diagrams.Backend.Cairo
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude
|
||||||
|
import Graphics.Diagram.AlgoDiags
|
||||||
|
import Graphics.Diagram.Core
|
||||||
import Graphics.Diagram.Plotter
|
import Graphics.Diagram.Plotter
|
||||||
import Graphics.Diagram.Types
|
|
||||||
import Parser.Meshparser
|
import Parser.Meshparser
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -2,40 +2,10 @@
|
|||||||
|
|
||||||
module Graphics.Diagram.Plotter where
|
module Graphics.Diagram.Plotter where
|
||||||
|
|
||||||
import Algebra.Vector(PT,Square)
|
|
||||||
import Algorithms.GrahamScan
|
|
||||||
import Algorithms.QuadTree
|
|
||||||
import Algorithms.KDTree
|
|
||||||
import Algorithms.PolygonIntersection
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
import Data.Tree
|
|
||||||
import Diagrams.Backend.Cairo
|
import Diagrams.Backend.Cairo
|
||||||
import Diagrams.Prelude hiding ((<>))
|
import Diagrams.Prelude hiding ((<>))
|
||||||
import Diagrams.TwoD.Layout.Tree
|
import Graphics.Diagram.Core
|
||||||
import Graphics.Diagram.Types
|
|
||||||
import Parser.PathParser
|
|
||||||
|
|
||||||
|
|
||||||
-- |Draw a list of points.
|
|
||||||
drawP :: [PT] -- ^ the points to draw
|
|
||||||
-> Double -- ^ dot size
|
|
||||||
-> Diagram Cairo R2 -- ^ the resulting diagram
|
|
||||||
drawP [] _ = mempty
|
|
||||||
drawP vt ds =
|
|
||||||
position (zip vt (repeat dot))
|
|
||||||
where
|
|
||||||
dot = circle ds :: Diagram Cairo R2
|
|
||||||
|
|
||||||
|
|
||||||
-- |Create a rectangle around a diagonal line, which has sw
|
|
||||||
-- as startpoint and nw as endpoint.
|
|
||||||
rectByDiagonal :: (Double, Double) -- ^ sw point
|
|
||||||
-> (Double, Double) -- ^ nw point
|
|
||||||
-> Diagram Cairo R2
|
|
||||||
rectByDiagonal (xmin, xmax) (ymin, ymax) =
|
|
||||||
rect (xmax - xmin) (ymax - ymin)
|
|
||||||
# moveTo (p2 ((xmax + xmin) / 2, (ymax + ymin) / 2))
|
|
||||||
|
|
||||||
|
|
||||||
-- |Creates a Diagram that shows the coordinates from the points
|
-- |Creates a Diagram that shows the coordinates from the points
|
||||||
@ -48,18 +18,6 @@ coordPoints = Diag cp
|
|||||||
cp p (Objects vts) = drawP (concat vts) (dotSize p) # fc black # lc black
|
cp p (Objects vts) = drawP (concat vts) (dotSize p) # fc black # lc black
|
||||||
|
|
||||||
|
|
||||||
-- |Creates a Diagram from a point that shows the coordinates
|
|
||||||
-- in text format, such as "(1.0, 2.0)".
|
|
||||||
pointToTextCoord :: PT -> Diagram Cairo R2
|
|
||||||
pointToTextCoord pt =
|
|
||||||
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
|
|
||||||
where
|
|
||||||
trim' :: Double -> Double
|
|
||||||
trim' x' = fromInteger . round $ x' * (10^(2 :: Int)) /
|
|
||||||
(10.0^^(2 :: Int))
|
|
||||||
(x, y) = unp2 pt
|
|
||||||
|
|
||||||
|
|
||||||
-- |Show coordinates as text above all points.
|
-- |Show coordinates as text above all points.
|
||||||
coordPointsText :: Diag
|
coordPointsText :: Diag
|
||||||
coordPointsText = Diag cpt
|
coordPointsText = Diag cpt
|
||||||
@ -73,246 +31,6 @@ coordPointsText = Diag cpt
|
|||||||
| otherwise = mempty
|
| otherwise = mempty
|
||||||
|
|
||||||
|
|
||||||
-- |Draw the lines of the polygon.
|
|
||||||
polyLines :: Diag
|
|
||||||
polyLines = Diag pp
|
|
||||||
where
|
|
||||||
pp _ (Objects []) = mempty
|
|
||||||
pp _ (Objects (x:y:_)) =
|
|
||||||
strokePoly x <> strokePoly y
|
|
||||||
where
|
|
||||||
strokePoly x' = (strokeTrail . fromVertices $ x' ++ [head x'])
|
|
||||||
# moveTo (head x') # lc black
|
|
||||||
pp _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Show the intersection points of two polygons as red dots.
|
|
||||||
polyIntersection :: Diag
|
|
||||||
polyIntersection = Diag pi'
|
|
||||||
where
|
|
||||||
pi' p (Objects (x:y:_)) = drawP vtpi (dotSize p) # fc red # lc red
|
|
||||||
where
|
|
||||||
vtpi = intersectionPoints . sortLexPolys $ (sortLexPoly x, sortLexPoly y)
|
|
||||||
pi' _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Show the coordinate text of the intersection points of two polygons.
|
|
||||||
polyIntersectionText :: Diag
|
|
||||||
polyIntersectionText = Diag pit'
|
|
||||||
where
|
|
||||||
pit' p (Objects (x:y:_))
|
|
||||||
| showCoordText p = position . zip vtpi $ (pointToTextCoord # fc red <$> vtpi)
|
|
||||||
# translate (r2 (0, 10))
|
|
||||||
| otherwise = mempty
|
|
||||||
where
|
|
||||||
vtpi = intersectionPoints
|
|
||||||
. sortLexPolys
|
|
||||||
$ (sortLexPoly x,
|
|
||||||
sortLexPoly y)
|
|
||||||
pit' _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Create a diagram which shows the points of the convex hull.
|
|
||||||
convexHP :: Diag
|
|
||||||
convexHP = Diag chp
|
|
||||||
where
|
|
||||||
chp p (Object vt) = drawP (grahamCH vt) (dotSize p) # fc red # lc red
|
|
||||||
chp _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Show coordinates as text above the convex hull points.
|
|
||||||
convexHPText :: Diag
|
|
||||||
convexHPText = Diag chpt
|
|
||||||
where
|
|
||||||
chpt p (Object vt)
|
|
||||||
| showCoordText p =
|
|
||||||
position $ zip vtchf (pointToTextCoord <$> vtchf) # translate (r2 (0, 10))
|
|
||||||
| otherwise = mempty
|
|
||||||
where
|
|
||||||
vtchf = grahamCH vt
|
|
||||||
chpt _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Create a diagram which shows the lines along the convex hull
|
|
||||||
-- points.
|
|
||||||
convexHLs :: Diag
|
|
||||||
convexHLs = Diag chl
|
|
||||||
where
|
|
||||||
chl _ (Object []) = mempty
|
|
||||||
chl _ (Object vt) =
|
|
||||||
(strokeTrail . fromVertices . flip (++) [head $ grahamCH vt] . grahamCH $ vt)
|
|
||||||
# moveTo (head $ grahamCH vt) # lc red
|
|
||||||
chl _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Create list of diagrama which describe the lines along points of a half
|
|
||||||
-- convex hull, for each iteration of the algorithm. Which half is chosen
|
|
||||||
-- depends on the input.
|
|
||||||
convexHStepsLs :: Diag
|
|
||||||
convexHStepsLs = GifDiag chs
|
|
||||||
where
|
|
||||||
chs _ col f vt = fmap mkChDiag (f vt)
|
|
||||||
where
|
|
||||||
mkChDiag vt' = (strokeTrail . fromVertices $ vt') # moveTo (head vt') # lc col
|
|
||||||
|
|
||||||
|
|
||||||
-- |Create a diagram that shows all squares of the RangeSearch algorithm
|
|
||||||
-- from the quad tree.
|
|
||||||
squares :: Diag
|
|
||||||
squares = Diag f
|
|
||||||
where
|
|
||||||
f _ (Object []) = mempty
|
|
||||||
f p (Object vt) =
|
|
||||||
mconcat
|
|
||||||
$ (uncurry rectByDiagonal # lw ultraThin)
|
|
||||||
<$>
|
|
||||||
(quadTreeSquares (xDimension p, yDimension p)
|
|
||||||
. quadTree vt
|
|
||||||
$ (xDimension p, yDimension p))
|
|
||||||
f _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Draw the squares of the kd-tree.
|
|
||||||
kdSquares :: Diag
|
|
||||||
kdSquares = Diag f
|
|
||||||
where
|
|
||||||
f _ (Object []) = mempty
|
|
||||||
f p (Object vt) =
|
|
||||||
mconcat
|
|
||||||
. fmap (uncurry (~~))
|
|
||||||
$ kdLines (kdTree vt Horizontal) (xDimension p, yDimension p)
|
|
||||||
where
|
|
||||||
-- Gets all lines that make up the kdSquares. Every line is
|
|
||||||
-- described by two points, start and end respectively.
|
|
||||||
kdLines :: KDTree PT -> Square -> [(PT, PT)]
|
|
||||||
kdLines (KTNode ln pt Horizontal rn) ((xmin, xmax), (ymin, ymax)) =
|
|
||||||
(\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))])
|
|
||||||
(unp2 pt)
|
|
||||||
++ kdLines ln ((xmin, x'), (ymin, ymax))
|
|
||||||
++ kdLines rn ((x', xmax), (ymin, ymax))
|
|
||||||
where
|
|
||||||
(x', _) = unp2 pt
|
|
||||||
kdLines (KTNode ln pt Vertical rn) ((xmin, xmax), (ymin, ymax)) =
|
|
||||||
(\(_, y) -> [(p2 (xmin, y), p2 (xmax, y))])
|
|
||||||
(unp2 pt)
|
|
||||||
++ kdLines ln ((xmin, xmax), (ymin, y'))
|
|
||||||
++ kdLines rn ((xmin, xmax), (y', ymax))
|
|
||||||
where
|
|
||||||
(_, y') = unp2 pt
|
|
||||||
kdLines _ _ = []
|
|
||||||
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) =
|
|
||||||
(uncurry rectByDiagonal # lc red) (rangeSquare p)
|
|
||||||
<> drawP ptsInRange (dotSize p) # fc red # lc 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) =
|
|
||||||
-- HACK: in order to give specific nodes a specific color
|
|
||||||
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)
|
|
||||||
|
|
||||||
|
|
||||||
-- |Create a diagram that shows a single square of the RangeSearch algorithm
|
|
||||||
-- from the quad tree in red, according to the given path in quadPath.
|
|
||||||
quadPathSquare :: Diag
|
|
||||||
quadPathSquare = Diag f
|
|
||||||
where
|
|
||||||
f _ (Object []) = mempty
|
|
||||||
f p (Object vt) =
|
|
||||||
(uncurry rectByDiagonal # lw thin # lc red)
|
|
||||||
(getSquare (stringToQuads (quadPath p)) (qt vt p, []))
|
|
||||||
where
|
|
||||||
getSquare :: [Either Quad Orient] -> QTZipper PT -> Square
|
|
||||||
getSquare [] z = getSquareByZipper (xDimension p, yDimension p) z
|
|
||||||
getSquare (q:qs) z = case q of
|
|
||||||
Right x -> getSquare qs (fromMaybe z (findNeighbor x z))
|
|
||||||
Left x -> getSquare qs (fromMaybe z (goQuad x z))
|
|
||||||
f _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Create a list of diagrams that show the walk along the given path
|
|
||||||
-- through the quad tree.
|
|
||||||
gifQuadPath :: Diag
|
|
||||||
gifQuadPath = GifDiag f
|
|
||||||
where
|
|
||||||
f p col _ vt =
|
|
||||||
(uncurry rectByDiagonal # lw thick # lc col)
|
|
||||||
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
|
|
||||||
where
|
|
||||||
getSquares :: [Either Quad Orient] -> QTZipper PT -> [Square]
|
|
||||||
getSquares [] z = [getSquareByZipper (xDimension p, yDimension p) z]
|
|
||||||
getSquares (q:qs) z = case q of
|
|
||||||
Right x -> getSquareByZipper (xDimension p, yDimension p) z :
|
|
||||||
getSquares qs (fromMaybe z (findNeighbor x z))
|
|
||||||
Left x -> getSquareByZipper (xDimension p, yDimension p) z :
|
|
||||||
getSquares qs (fromMaybe z (goQuad x z))
|
|
||||||
|
|
||||||
|
|
||||||
-- |A diagram that shows the full Quad Tree with nodes.
|
|
||||||
treePretty :: Diag
|
|
||||||
treePretty = Diag f
|
|
||||||
where
|
|
||||||
f _ (Object []) = mempty
|
|
||||||
f p (Object vt) =
|
|
||||||
prettyRoseTree (quadTreeToRoseTree
|
|
||||||
. flip getCurQT (qt vt p, [])
|
|
||||||
. stringToQuads
|
|
||||||
. quadPath
|
|
||||||
$ p)
|
|
||||||
where
|
|
||||||
getCurQT :: [Either Quad Orient] -> QTZipper PT -> QTZipper 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 tree =
|
|
||||||
-- HACK: in order to give specific nodes a specific color
|
|
||||||
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) tree)
|
|
||||||
# scale 2 # alignT # bg white
|
|
||||||
f _ _ = mempty
|
|
||||||
|
|
||||||
|
|
||||||
-- |Creates a Diagram that shows an XAxis which is bound
|
-- |Creates a Diagram that shows an XAxis which is bound
|
||||||
-- by the dimensions given in xDimension from DiagProp.
|
-- by the dimensions given in xDimension from DiagProp.
|
||||||
xAxis :: Diag
|
xAxis :: Diag
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user