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

Compare commits

base: hasufell:master
Branches Tags
hasufell:master
hasufell:halfedge
hasufell:test_objs
..
compare: hasufell:halfedge
Branches Tags
hasufell:master
hasufell:halfedge
hasufell:test_objs

20 Commits
master ... halfedge

Author SHA1 Message Date
hasufell
7fe3aa8458
Port to diagrams >1.3 2015-05-21 01:39:34 +02:00
hasufell
e9786df1e2
Update .gitignore 2015-05-21 01:37:42 +02:00
hasufell
9f5938da97
HALFEDGE: add Show instance to indirect data structures 2015-02-10 04:17:31 +01:00
hasufell
fbb0d2963c
CABAL: cleanup dependencies 2015-02-10 04:17:04 +01:00
hasufell
6a6870b1d3
HALFEDGE: improve pseudo-code 2015-02-10 04:10:14 +01:00
hasufell
c2ffde8712
HALFEDGE: fix module doc 2015-02-09 18:46:39 +01:00
hasufell
38a1e4d7fb
HALFEDGE: improve readability 2015-02-09 18:36:43 +01:00
hasufell
84d2e38d55
HALFEDGE: add pseudo-code for 'indirectToDirect' 2015-02-09 18:29:40 +01:00
hasufell
d845cc0691
HALFEDGE: make 'indirectToDirect' a safe function 
We had to add NoFace/NoEdge/NoVert constructors to our half-edge
data structures, because using "Maybe HeEdge a" as the result value
of 'indirectToDirect' causes an infinite recursion, since the whole
data structure (which is cyclic and infinite) has to be evaluated
in order to know which constructor to use.

Unfortunately this makes the code quite hard to read.

TODO: add pseudo-code
 2015-02-09 17:58:33 +01:00
hasufell
57476d2986
HALFEDGE: use Data.IntMap instead of Array 2015-02-09 16:14:01 +01:00
hasufell
d37624f2d1
HALFEDGE: optimize buildHeEdgeFromStr 
It's faster this way than using buildHeEdge.
 2015-02-09 16:12:19 +01:00
hasufell
c04ba4f803
HALFEDGE: fix haddock comment 2015-02-04 02:02:58 +01:00
hasufell
97f72dc58d
Update .gitignore 2015-02-04 00:56:32 +01:00
hasufell
351e47fa48
Add test obj for HalfEdge data structure 2015-02-04 00:55:53 +01:00
hasufell
b5ecd16a2e
Revert "Remove almost all 'type' usage to make types more transparent" 
This reverts commit 5120a44d0f.

Conflicts:
	Parser/Meshparser.hs
 2015-02-04 00:51:03 +01:00
hasufell
d6174a975c
CABAL: more lax dependencies 2015-02-04 00:47:46 +01:00
hasufell
c94a92739d
HALFEDGE: initial implementation for half-edge data structures 
See http://www.flipcode.com/archives/The_Half-Edge_Data_Structure.shtml
 2015-02-04 00:47:46 +01:00
hasufell
44fee35926
PARSER: improve function names 2015-02-04 00:47:46 +01:00
hasufell
a33b451740
PARSER: improve modularity 2015-02-04 00:46:48 +01:00
hasufell
df4a4c2a27
PARSER: export the whole module 2015-02-04 00:46:47 +01:00
23 changed files with 420 additions and 677 deletions
Show Stats Expand all files Collapse all files

2
.gitignore vendored
View File

@ -18,5 +18,3 @@ cabal.sandbox.config
_darcs/ _darcs/
.liquid/ .liquid/
.stack-work/

21
Algebra/Polygon.hs
View File

@ -4,15 +4,14 @@ module Algebra.Polygon where
import Algebra.Vector import Algebra.Vector
import Data.Maybe import Data.Maybe
import Diagrams.TwoD.Types
import MyPrelude import MyPrelude
-- |Split a polygon by a given segment which must be vertices of the -- |Split a polygon by a given segment which must be vertices of the
-- polygon (returns empty array otherwise). -- polygon (returns empty array otherwise).
splitPoly :: [P2 Double] splitPoly :: [PT]
-> (P2 Double, P2 Double) -> Segment
-> [[P2 Double]] -> [[PT]]
splitPoly pts (a, b) splitPoly pts (a, b)
| elem a pts && elem b pts = | elem a pts && elem b pts =
[b : takeWhile (/= b) shiftedPoly, a : dropWhile (/= b) shiftedPoly] [b : takeWhile (/= b) shiftedPoly, a : dropWhile (/= b) shiftedPoly]
@ -22,7 +21,7 @@ splitPoly pts (a, b)
-- |Get all edges of a polygon. -- |Get all edges of a polygon.
polySegments :: [P2 Double] -> [(P2 Double, P2 Double)] polySegments :: [PT] -> [Segment]
polySegments p@(x':_:_:_) = go p ++ [(last p, x')] polySegments p@(x':_:_:_) = go p ++ [(last p, x')]
where where
go (x:y:xs) = (x, y) : go (y:xs) go (x:y:xs) = (x, y) : go (y:xs)
@ -33,30 +32,30 @@ polySegments _ = []
-- |Check whether the given segment is inside the polygon. -- |Check whether the given segment is inside the polygon.
-- This doesn't check for segments that are completely outside -- This doesn't check for segments that are completely outside
-- of the polygon yet. -- of the polygon yet.
isInsidePoly :: [P2 Double] -> (P2 Double, P2 Double) -> Bool isInsidePoly :: [PT] -> Segment -> Bool
isInsidePoly pts seg = isInsidePoly pts seg =
null null
. catMaybes . catMaybes
. fmap (intersectSeg seg) . fmap (intersectSeg'' seg)
$ polySegments pts $ polySegments pts
-- |Check whether two points are adjacent vertices of a polygon. -- |Check whether two points are adjacent vertices of a polygon.
adjacent :: P2 Double -> P2 Double -> [P2 Double] -> Bool adjacent :: PT -> PT -> [PT] -> Bool
adjacent u v = any (\x -> x == (u, v) || x == (v, u)) . polySegments adjacent u v = any (\x -> x == (u, v) || x == (v, u)) . polySegments
-- |Check whether the polygon is a triangle polygon. -- |Check whether the polygon is a triangle polygon.
isTrianglePoly :: [P2 Double] -> Bool isTrianglePoly :: [PT] -> Bool
isTrianglePoly [_, _, _] = True isTrianglePoly [_, _, _] = True
isTrianglePoly _ = False isTrianglePoly _ = False
-- |Get all triangle polygons. -- |Get all triangle polygons.
triangleOnly :: [[P2 Double]] -> [[P2 Double]] triangleOnly :: [[PT]] -> [[PT]]
triangleOnly = filter isTrianglePoly triangleOnly = filter isTrianglePoly
-- |Get all non-triangle polygons. -- |Get all non-triangle polygons.
nonTriangleOnly :: [[P2 Double]] -> [[P2 Double]] nonTriangleOnly :: [[PT]] -> [[PT]]
nonTriangleOnly = filter (not . isTrianglePoly) nonTriangleOnly = filter (not . isTrianglePoly)

176
Algebra/Vector.hs
View File

@ -8,10 +8,18 @@ import Control.Arrow ((***))
import Data.List (sortBy) import Data.List (sortBy)
import Diagrams.Coordinates import Diagrams.Coordinates
import Diagrams.TwoD.Types import Diagrams.TwoD.Types
import Graphics.Gloss.Geometry.Line
import GHC.Float import GHC.Float
import MyPrelude import MyPrelude
type Vec = V2 Double
type PT = P2 Double
type Coord = (Double, Double)
type Segment = (PT, PT)
type Square = (Coord, Coord)
data Alignment = CW data Alignment = CW
| CCW | CCW
| CL | CL
@ -23,14 +31,14 @@ data Alignment = CW
-- ((xmin, ymin), (xmax, ymax)) -- ((xmin, ymin), (xmax, ymax))
dimToSquare :: (Double, Double) -- ^ x dimension dimToSquare :: (Double, Double) -- ^ x dimension
-> (Double, Double) -- ^ y dimension -> (Double, Double) -- ^ y dimension
-> ((Double, Double), (Double, Double)) -- ^ square describing those dimensions -> Square -- ^ square describing those dimensions
dimToSquare (x1, x2) (y1, y2) = ((x1, y1), (x2, y2)) dimToSquare (x1, x2) (y1, y2) = ((x1, y1), (x2, y2))
-- |Checks whether the Point is in a given Square. -- |Checks whether the Point is in a given Square.
inRange :: ((Double, Double), (Double, Double)) -- ^ the square: ((xmin, ymin), (xmax, ymax)) inRange :: Square -- ^ the square: ((xmin, ymin), (xmax, ymax))
-> P2 Double -- ^ Coordinate -> PT -- ^ Coordinate
-> Bool -- ^ result -> Bool -- ^ result
inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y) inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
= x >= min xmin xmax = x >= min xmin xmax
&& x <= max xmin xmax && x <= max xmin xmax
@ -39,7 +47,7 @@ inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
-- |Get the angle between two vectors. -- |Get the angle between two vectors.
getAngle :: V2 Double -> V2 Double -> Double getAngle :: Vec -> Vec -> Double
getAngle a b = getAngle a b =
acos acos
. flip (/) (vecLength a * vecLength b) . flip (/) (vecLength a * vecLength b)
@ -48,50 +56,62 @@ getAngle a b =
-- |Get the length of a vector. -- |Get the length of a vector.
vecLength :: V2 Double -> Double vecLength :: Vec -> Double
vecLength v = sqrt (x^(2 :: Int) + y^(2 :: Int)) vecLength v = sqrt (x^(2 :: Int) + y^(2 :: Int))
where where
(x, y) = unr2 v (x, y) = unr2 v
-- |Compute the scalar product of two vectors. -- |Compute the scalar product of two vectors.
scalarProd :: V2 Double -> V2 Double -> Double scalarProd :: Vec -> Vec -> Double
scalarProd (V2 a1 a2) (V2 b1 b2) = a1 * b1 + a2 * b2 scalarProd (V2 a1 a2) (V2 b1 b2) = a1 * b1 + a2 * b2
-- |Multiply a scalar with a vector. -- |Multiply a scalar with a vector.
scalarMul :: Double -> V2 Double -> V2 Double scalarMul :: Double -> Vec -> Vec
scalarMul d (V2 a b) = V2 (a * d) (b * d) scalarMul d (V2 a b) = V2 (a * d) (b * d)
-- |Construct a vector that points to a point from the origin. -- |Construct a vector that points to a point from the origin.
pt2Vec :: P2 Double -> V2 Double pt2Vec :: PT -> Vec
pt2Vec = r2 . unp2 pt2Vec = r2 . unp2
-- |Give the point which is at the coordinates the vector -- |Give the point which is at the coordinates the vector
-- points to from the origin. -- points to from the origin.
vec2Pt :: V2 Double -> P2 Double vec2Pt :: Vec -> PT
vec2Pt = p2 . unr2 vec2Pt = p2 . unr2
-- |Construct a vector between two points. -- |Construct a vector between two points.
vp2 :: P2 Double -- ^ vector origin vp2 :: PT -- ^ vector origin
-> P2 Double -- ^ vector points here -> PT -- ^ vector points here
-> V2 Double -> Vec
vp2 a b = pt2Vec b - pt2Vec a vp2 a b = pt2Vec b - pt2Vec a
-- |Computes the determinant of 3 points. -- |Computes the determinant of 3 points.
det :: P2 Double -> P2 Double -> P2 Double -> Double det :: PT -> PT -> PT -> Double
det (coords -> ax :& ay) (coords -> bx :& by) (coords -> cx :& cy) = det (coords -> ax :& ay) (coords -> bx :& by) (coords -> cx :& cy) =
(bx - ax) * (cy - ay) - (by - ay) * (cx - ax) (bx - ax) * (cy - ay) - (by - ay) * (cx - ax)
-- |Get the point where two lines intesect, if any.
intersectSeg' :: Segment -> Segment -> Maybe PT
intersectSeg' (a, b) (c, d) =
glossToPt <$> intersectSegSeg (ptToGloss a)
(ptToGloss b)
(ptToGloss c)
(ptToGloss d)
where
ptToGloss = (double2Float *** double2Float) <$> unp2
glossToPt = p2 . (float2Double *** float2Double)
-- |Get the point where two lines intesect, if any. Excludes the -- |Get the point where two lines intesect, if any. Excludes the
-- case of end-points intersecting. -- case of end-points intersecting.
intersectSeg :: (P2 Double, P2 Double) -> (P2 Double, P2 Double) -> Maybe (P2 Double) intersectSeg'' :: Segment -> Segment -> Maybe PT
intersectSeg (a, b) (c, d) = case intersectSegSeg a b c d of intersectSeg'' (a, b) (c, d) = case intersectSeg' (a, b) (c, d) of
Just x -> if x `notElem` [a,b,c,d] then Just a else Nothing Just x -> if x `notElem` [a,b,c,d] then Just a else Nothing
Nothing -> Nothing Nothing -> Nothing
@ -100,7 +120,7 @@ intersectSeg (a, b) (c, d) = case intersectSegSeg a b c d of
-- * clock-wise -- * clock-wise
-- * counter-clock-wise -- * counter-clock-wise
-- * collinear -- * collinear
getOrient :: P2 Double -> P2 Double -> P2 Double -> Alignment getOrient :: PT -> PT -> PT -> Alignment
getOrient a b c = case compare (det a b c) 0 of getOrient a b c = case compare (det a b c) 0 of
LT -> CW LT -> CW
GT -> CCW GT -> CCW
@ -110,7 +130,7 @@ getOrient a b c = case compare (det a b c) 0 of
--- |Checks if 3 points a,b,c do not build a clockwise triangle by --- |Checks if 3 points a,b,c do not build a clockwise triangle by
--- connecting a-b-c. This is done by computing the determinant and --- connecting a-b-c. This is done by computing the determinant and
--- checking the algebraic sign. --- checking the algebraic sign.
notcw :: P2 Double -> P2 Double -> P2 Double -> Bool notcw :: PT -> PT -> PT -> Bool
notcw a b c = case getOrient a b c of notcw a b c = case getOrient a b c of
CW -> False CW -> False
_ -> True _ -> True
@ -119,22 +139,22 @@ notcw a b c = case getOrient a b c of
--- |Checks if 3 points a,b,c do build a clockwise triangle by --- |Checks if 3 points a,b,c do build a clockwise triangle by
--- connecting a-b-c. This is done by computing the determinant and --- connecting a-b-c. This is done by computing the determinant and
--- checking the algebraic sign. --- checking the algebraic sign.
cw :: P2 Double -> P2 Double -> P2 Double -> Bool cw :: PT -> PT -> PT -> Bool
cw a b c = not . notcw a b $ c cw a b c = not . notcw a b $ c
-- |Sort X and Y coordinates lexicographically. -- |Sort X and Y coordinates lexicographically.
sortedXY :: [P2 Double] -> [P2 Double] sortedXY :: [PT] -> [PT]
sortedXY = fmap p2 . sortLex . fmap unp2 sortedXY = fmap p2 . sortLex . fmap unp2
-- |Sort Y and X coordinates lexicographically. -- |Sort Y and X coordinates lexicographically.
sortedYX :: [P2 Double] -> [P2 Double] sortedYX :: [PT] -> [PT]
sortedYX = fmap p2 . sortLexSwapped . fmap unp2 sortedYX = fmap p2 . sortLexSwapped . fmap unp2
-- |Sort all points according to their X-coordinates only. -- |Sort all points according to their X-coordinates only.
sortedX :: [P2 Double] -> [P2 Double] sortedX :: [PT] -> [PT]
sortedX xs = sortedX xs =
fmap p2 fmap p2
. sortBy (\(a1, _) (a2, _) -> compare a1 a2) . sortBy (\(a1, _) (a2, _) -> compare a1 a2)
@ -142,7 +162,7 @@ sortedX xs =
-- |Sort all points according to their Y-coordinates only. -- |Sort all points according to their Y-coordinates only.
sortedY :: [P2 Double] -> [P2 Double] sortedY :: [PT] -> [PT]
sortedY xs = sortedY xs =
fmap p2 fmap p2
. sortBy (\(_, b1) (_, b2) -> compare b1 b2) . sortBy (\(_, b1) (_, b2) -> compare b1 b2)
@ -150,125 +170,25 @@ sortedY xs =
-- |Apply a function on the coordinates of a point. -- |Apply a function on the coordinates of a point.
onPT :: ((Double, Double) -> (Double, Double)) -> P2 Double -> P2 Double onPT :: (Coord -> Coord) -> PT -> PT
onPT f = p2 . f . unp2 onPT f = p2 . f . unp2
-- |Compare the y-coordinate of two points. -- |Compare the y-coordinate of two points.
ptCmpY :: P2 Double -> P2 Double -> Ordering ptCmpY :: PT -> PT -> Ordering
ptCmpY (coords -> _ :& y1) (coords -> _ :& y2) = ptCmpY (coords -> _ :& y1) (coords -> _ :& y2) =
compare y1 y2 compare y1 y2
-- |Compare the x-coordinate of two points. -- |Compare the x-coordinate of two points.
ptCmpX :: P2 Double -> P2 Double -> Ordering ptCmpX :: PT -> PT -> Ordering
ptCmpX (coords -> x1 :& _) (coords -> x2 :& _) = ptCmpX (coords -> x1 :& _) (coords -> x2 :& _) =
compare x1 x2 compare x1 x2
posInfPT :: P2 Double posInfPT :: PT
posInfPT = p2 (read "Infinity", read "Infinity") posInfPT = p2 (read "Infinity", read "Infinity")
negInfPT :: P2 Double negInfPT :: PT
negInfPT = p2 (negate . read $ "Infinity", negate . read $ "Infinity") negInfPT = p2 (negate . read $ "Infinity", negate . read $ "Infinity")
-- | Given an infinite line which intersects P1 and P2,
-- let P4 be the point on the line that is closest to P3.
--
-- Return an indication of where on the line P4 is relative to P1 and P2.
--
-- @
-- if P4 == P1 then 0
-- if P4 == P2 then 1
-- if P4 is halfway between P1 and P2 then 0.5
-- @
--
-- @
-- |
-- P1
-- |
-- P4 +---- P3
-- |
-- P2
-- |
-- @
--
{-# INLINE closestPointOnLineParam #-}
closestPointOnLineParam
:: P2 Double -- ^ `P1`
-> P2 Double -- ^ `P2`
-> P2 Double -- ^ `P3`
-> Double
closestPointOnLineParam p1 p2 p3
= pt2Vec (p3 - p1) `scalarProd` pt2Vec (p2 - p1)
/ pt2Vec (p2 - p1) `scalarProd` pt2Vec (p2 - p1)
-- | Given four points specifying two lines, get the point where the two lines
-- cross, if any. Note that the lines extend off to infinity, so the
-- intersection point might not line between either of the two pairs of points.
--
-- @
-- \\ /
-- P1 P4
-- \\ /
-- +
-- / \\
-- P3 P2
-- / \\
-- @
--
intersectLineLine
:: P2 Double -- ^ `P1`
-> P2 Double -- ^ `P2`
-> P2 Double -- ^ `P3`
-> P2 Double -- ^ `P4`
-> Maybe (P2 Double)
intersectLineLine (coords -> x1 :& y1)
(coords -> x2 :& y2)
(coords -> x3 :& y3)
(coords -> x4 :& y4)
= let dx12 = x1 - x2
dx34 = x3 - x4
dy12 = y1 - y2
dy34 = y3 - y4
den = dx12 * dy34 - dy12 * dx34
in if den == 0
then Nothing
else let
det12 = x1*y2 - y1*x2
det34 = x3*y4 - y3*x4
numx = det12 * dx34 - dx12 * det34
numy = det12 * dy34 - dy12 * det34
in Just $ p2 (numx / den, numy / den)
-- | Get the point where a segment @P1-P2@ crosses another segement @P3-P4@,
-- if any.
intersectSegSeg
:: P2 Double -- ^ `P1`
-> P2 Double -- ^ `P2`
-> P2 Double -- ^ `P3`
-> P2 Double -- ^ `P4`
-> Maybe (P2 Double)
intersectSegSeg p1 p2 p3 p4
-- TODO: merge closest point checks with intersection, reuse subterms.
| Just p0 <- intersectLineLine p1 p2 p3 p4
, t12 <- closestPointOnLineParam p1 p2 p0
, t23 <- closestPointOnLineParam p3 p4 p0
, t12 >= 0 && t12 <= 1
, t23 >= 0 && t23 <= 1
= Just p0
| otherwise
= Nothing

19
Algorithms/GrahamScan.hs
View File

@ -3,7 +3,6 @@
module Algorithms.GrahamScan where module Algorithms.GrahamScan where
import Algebra.Vector import Algebra.Vector
import Diagrams.TwoD.Types
import MyPrelude import MyPrelude
@ -75,18 +74,18 @@ ys = []
return [(100, 100), (400, 200)] return [(100, 100), (400, 200)]
========================================================= =========================================================
--} --}
grahamCH :: [P2 Double] -> [P2 Double] grahamCH :: [PT] -> [PT]
grahamCH vs = grahamUCH vs ++ (tailInit . grahamLCH $ vs) grahamCH vs = grahamUCH vs ++ (tailInit . grahamLCH $ vs)
-- |Get the lower part of the convex hull. -- |Get the lower part of the convex hull.
grahamLCH :: [P2 Double] -> [P2 Double] grahamLCH :: [PT] -> [PT]
grahamLCH vs = uncurry (\x y -> last . scanH x $ y) grahamLCH vs = uncurry (\x y -> last . scanH x $ y)
(first reverse . splitAt 3 . sortedXY $ vs) (first reverse . splitAt 3 . sortedXY $ vs)
-- |Get the upper part of the convex hull. -- |Get the upper part of the convex hull.
grahamUCH :: [P2 Double] -> [P2 Double] grahamUCH :: [PT] -> [PT]
grahamUCH vs = uncurry (\x y -> last . scanH x $ y) grahamUCH vs = uncurry (\x y -> last . scanH x $ y)
(first reverse . splitAt 3 . reverse . sortedXY $ vs) (first reverse . splitAt 3 . reverse . sortedXY $ vs)
@ -96,9 +95,9 @@ grahamUCH vs = uncurry (\x y -> last . scanH x $ y)
-- If it's the upper or lower half depends on the input. -- If it's the upper or lower half depends on the input.
-- Also, the first list is expected to be reversed since we only care -- Also, the first list is expected to be reversed since we only care
-- about the last 3 elements and want to stay efficient. -- about the last 3 elements and want to stay efficient.
scanH :: [P2 Double] -- ^ the first 3 starting points in reversed order scanH :: [PT] -- ^ the first 3 starting points in reversed order
-> [P2 Double] -- ^ the rest of the points -> [PT] -- ^ the rest of the points
-> [[P2 Double]] -- ^ all convex hull points iterations for the half -> [[PT]] -- ^ all convex hull points iterations for the half
scanH hs@(x:y:z:xs) (r':rs') scanH hs@(x:y:z:xs) (r':rs')
| notcw z y x = hs : scanH (r':hs) rs' | notcw z y x = hs : scanH (r':hs) rs'
| otherwise = hs : scanH (x:z:xs) (r':rs') | otherwise = hs : scanH (x:z:xs) (r':rs')
@ -112,12 +111,12 @@ scanH hs _ = [hs]
-- |Compute all steps of the graham scan algorithm to allow -- |Compute all steps of the graham scan algorithm to allow
-- visualizing it. -- visualizing it.
-- Whether the upper or lower hull is computed depends on the input. -- Whether the upper or lower hull is computed depends on the input.
grahamCHSteps :: Int -> [P2 Double] -> [P2 Double] -> [[P2 Double]] grahamCHSteps :: Int -> [PT] -> [PT] -> [[PT]]
grahamCHSteps c xs' ys' = take c . scanH xs' $ ys' grahamCHSteps c xs' ys' = take c . scanH xs' $ ys'
-- |Get all iterations of the upper hull of the graham scan algorithm. -- |Get all iterations of the upper hull of the graham scan algorithm.
grahamUHSteps :: [P2 Double] -> [[P2 Double]] grahamUHSteps :: [PT] -> [[PT]]
grahamUHSteps vs = grahamUHSteps vs =
(++) [getLastX 2 . sortedXY $ vs] (++) [getLastX 2 . sortedXY $ vs]
. rmdups . rmdups
@ -128,7 +127,7 @@ grahamUHSteps vs =
-- |Get all iterations of the lower hull of the graham scan algorithm. -- |Get all iterations of the lower hull of the graham scan algorithm.
grahamLHSteps :: [P2 Double] -> [[P2 Double]] grahamLHSteps :: [PT] -> [[PT]]
grahamLHSteps vs = grahamLHSteps vs =
(++) [take 2 . sortedXY $ vs] (++) [take 2 . sortedXY $ vs]
. rmdups . rmdups

30
Algorithms/KDTree.hs
View File

@ -42,9 +42,9 @@ instance Not Direction where
-- |Construct a kd-tree from a list of points in O(n log n). -- |Construct a kd-tree from a list of points in O(n log n).
kdTree :: [P2 Double] -- ^ list of points to construct the kd-tree from kdTree :: [PT] -- ^ list of points to construct the kd-tree from
-> Direction -- ^ initial direction of the root-node -> Direction -- ^ initial direction of the root-node
-> KDTree (P2 Double) -- ^ resulting kd-tree -> KDTree PT -- ^ resulting kd-tree
kdTree xs' = go (sortedX xs') (sortedY xs') kdTree xs' = go (sortedX xs') (sortedY xs')
where where
go [] _ _ = KTNil go [] _ _ = KTNil
@ -67,10 +67,10 @@ kdTree xs' = go (sortedX xs') (sortedY xs')
-- If you want to partition against the pivot of X, then you pass -- If you want to partition against the pivot of X, then you pass
-- partition' (pivot xs) (ys, xs) -- partition' (pivot xs) (ys, xs)
-- and get ((y1, y2), (x1, x2)). -- and get ((y1, y2), (x1, x2)).
partition' :: P2 Double -- ^ the pivot to partition against partition' :: PT -- ^ the pivot to partition against
-> (P2 Double -> P2 Double -> Ordering) -- ^ ptCmpY or ptCmpX -> (PT -> PT -> Ordering) -- ^ ptCmpY or ptCmpX
-> ([P2 Double], [P2 Double]) -- ^ both lists (X, Y) or (Y, X) -> ([PT], [PT]) -- ^ both lists (X, Y) or (Y, X)
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2)) or -> (([PT], [PT]), ([PT], [PT])) -- ^ ((x1, x2), (y1, y2)) or
-- ((y1, y2), (x1, x2)) -- ((y1, y2), (x1, x2))
partition' piv cmp' (xs, ys) = ((x1, x2), (y1, y2)) partition' piv cmp' (xs, ys) = ((x1, x2), (y1, y2))
where where
@ -83,16 +83,16 @@ partition' piv cmp' (xs, ys) = ((x1, x2), (y1, y2))
-- |Partition two sorted lists of points X and Y against the pivot of -- |Partition two sorted lists of points X and Y against the pivot of
-- Y. This function is unsafe as it does not check if there is a valid -- Y. This function is unsafe as it does not check if there is a valid
-- pivot. -- pivot.
partitionY :: ([P2 Double], [P2 Double]) -- ^ both lists (X, Y) partitionY :: ([PT], [PT]) -- ^ both lists (X, Y)
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2)) -> (([PT], [PT]), ([PT], [PT])) -- ^ ((x1, x2), (y1, y2))
partitionY (xs, ys) = partition' (fromJust . pivot $ ys) ptCmpY (xs, ys) partitionY (xs, ys) = partition' (fromJust . pivot $ ys) ptCmpY (xs, ys)
-- |Partition two sorted lists of points X and Y against the pivot of -- |Partition two sorted lists of points X and Y against the pivot of
-- X. This function is unsafe as it does not check if there is a valid -- X. This function is unsafe as it does not check if there is a valid
-- pivot. -- pivot.
partitionX :: ([P2 Double], [P2 Double]) -- ^ both lists (X, Y) partitionX :: ([PT], [PT]) -- ^ both lists (X, Y)
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2)) -> (([PT], [PT]), ([PT], [PT])) -- ^ ((x1, x2), (y1, y2))
partitionX (xs, ys) = (\(x, y) -> (y, x)) partitionX (xs, ys) = (\(x, y) -> (y, x))
. partition' (fromJust . pivot $ xs) ptCmpX $ (ys, xs) . partition' (fromJust . pivot $ xs) ptCmpX $ (ys, xs)
@ -100,9 +100,7 @@ partitionX (xs, ys) = (\(x, y) -> (y, x))
-- |Execute a range search in O(log n). It returns a tuple -- |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 -- of the points found in the range and also gives back a pretty
-- rose tree suitable for printing. -- rose tree suitable for printing.
rangeSearch :: KDTree (P2 Double) -- ^ tree to search in rangeSearch :: KDTree PT -> Square -> ([PT], Tree String)
-> ((Double, Double), (Double, Double)) -- ^ square describing the range
-> ([P2 Double], Tree String)
rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True) rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
where where
-- either y1 or x1 depending on the orientation -- either y1 or x1 depending on the orientation
@ -112,7 +110,7 @@ rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
-- either the second or first of the tuple, depending on the orientation -- either the second or first of the tuple, depending on the orientation
cur' dir = if' (dir == Vertical) snd fst cur' dir = if' (dir == Vertical) snd fst
-- All points in the range. -- All points in the range.
goPt :: KDTree (P2 Double) -> ((Double, Double), (Double, Double)) -> [P2 Double] goPt :: KDTree PT -> Square -> [PT]
goPt KTNil _ = [] goPt KTNil _ = []
goPt (KTNode ln pt dir rn) sq = goPt (KTNode ln pt dir rn) sq =
[pt | inRange sq pt] [pt | inRange sq pt]
@ -124,7 +122,7 @@ rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
(goPt rn sq) (goPt rn sq)
[]) [])
-- A pretty rose tree suitable for printing. -- A pretty rose tree suitable for printing.
goTree :: KDTree (P2 Double) -> ((Double, Double), (Double, Double)) -> Bool -> Tree String goTree :: KDTree PT -> Square -> Bool -> Tree String
goTree KTNil _ _ = Node "nil" [] goTree KTNil _ _ = Node "nil" []
goTree (KTNode ln pt dir rn) sq vis goTree (KTNode ln pt dir rn) sq vis
| ln == KTNil && rn == KTNil = Node treeText [] | ln == KTNil && rn == KTNil = Node treeText []
@ -181,7 +179,7 @@ getDirection _ = Nothing
-- |Convert a kd-tree to a rose tree, for pretty printing. -- |Convert a kd-tree to a rose tree, for pretty printing.
kdTreeToRoseTree :: KDTree (P2 Double) -> Tree String kdTreeToRoseTree :: KDTree PT -> Tree String
kdTreeToRoseTree (KTNil) = Node "nil" [] kdTreeToRoseTree (KTNil) = Node "nil" []
kdTreeToRoseTree (KTNode ln val _ rn) = kdTreeToRoseTree (KTNode ln val _ rn) =
Node (show . unp2 $ val) [kdTreeToRoseTree ln, kdTreeToRoseTree rn] Node (show . unp2 $ val) [kdTreeToRoseTree ln, kdTreeToRoseTree rn]

32
Algorithms/PolygonIntersection.hs
View File

@ -18,14 +18,14 @@ import QueueEx
-- successor are saved for convenience. -- successor are saved for convenience.
data PolyPT = data PolyPT =
PolyA { PolyA {
id' :: P2 Double id' :: PT
, pre :: P2 Double , pre :: PT
, suc :: P2 Double , suc :: PT
} }
| PolyB { | PolyB {
id' :: P2 Double id' :: PT
, pre :: P2 Double , pre :: PT
, suc :: P2 Double , suc :: PT
} }
deriving (Show, Eq) deriving (Show, Eq)
@ -42,7 +42,7 @@ isPolyB = not . isPolyA
-- |Shift a list of sorted convex hull points of a polygon so that -- |Shift a list of sorted convex hull points of a polygon so that
-- the first element in the list is the one with the highest y-coordinate. -- the first element in the list is the one with the highest y-coordinate.
-- This is done in O(n). -- This is done in O(n).
sortLexPoly :: [P2 Double] -> [P2 Double] sortLexPoly :: [PT] -> [PT]
sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps) sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps)
where where
yMax = foldl1 (\x y -> if ptCmpY x y == GT then x else y) yMax = foldl1 (\x y -> if ptCmpY x y == GT then x else y)
@ -50,8 +50,8 @@ sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps)
-- |Make a PolyPT list out of a regular list of points, so -- |Make a PolyPT list out of a regular list of points, so
-- the predecessor and successors are all saved. -- the predecessor and successors are all saved.
mkPolyPTList :: (P2 Double -> P2 Double -> P2 Double -> PolyPT) -- ^ PolyA or PolyB function mkPolyPTList :: (PT -> PT -> PT -> PolyPT) -- ^ PolyA or PolyB function
-> [P2 Double] -- ^ polygon points -> [PT] -- ^ polygon points
-> [PolyPT] -> [PolyPT]
mkPolyPTList f' pts@(x':y':_:_) = mkPolyPTList f' pts@(x':y':_:_) =
f' x' (last pts) y' : go f' pts f' x' (last pts) y' : go f' pts
@ -64,7 +64,7 @@ mkPolyPTList _ _ = []
-- |Sort the points of two polygons according to their y-coordinates, -- |Sort the points of two polygons according to their y-coordinates,
-- while saving the origin of that point. This is done in O(n). -- while saving the origin of that point. This is done in O(n).
sortLexPolys :: ([P2 Double], [P2 Double]) -> [PolyPT] sortLexPolys :: ([PT], [PT]) -> [PolyPT]
sortLexPolys (pA'@(_:_), pB'@(_:_)) = sortLexPolys (pA'@(_:_), pB'@(_:_)) =
queueToList $ go (Q.fromList . mkPolyPTList PolyA . sortLexPoly $ pA') queueToList $ go (Q.fromList . mkPolyPTList PolyA . sortLexPoly $ pA')
(Q.fromList . mkPolyPTList PolyB . sortLexPoly $ pB') (Q.fromList . mkPolyPTList PolyB . sortLexPoly $ pB')
@ -84,11 +84,11 @@ sortLexPolys (pA'@(_:_), pB'@(_:_)) =
-- queue and traverse the rest. -- queue and traverse the rest.
| ptCmpY (fromMaybe negInfPT (id' <$> Q.first pA)) | ptCmpY (fromMaybe negInfPT (id' <$> Q.first pA))
(fromMaybe negInfPT (id' <$> Q.first pB)) == GT (fromMaybe negInfPT (id' <$> Q.first pB)) == GT
= Q.pushFront (go (maybeShift . snd . fromJust . Q.popFront $ pA) pB) = Q.pushFront (go (maybeShift . snd . Q.popFront $ pA) pB)
(fromJust . Q.first $ pA) (fromJust . Q.first $ pA)
-- Same as above, except that the current point of polygon B -- Same as above, except that the current point of polygon B
-- is higher. -- is higher.
| otherwise = Q.pushFront (go pA (maybeShift . snd . fromJust . Q.popFront $ pB)) | otherwise = Q.pushFront (go pA (maybeShift . snd . Q.popFront $ pB))
(fromJust . Q.first $ pB) (fromJust . Q.first $ pB)
-- Compare the first and the last element of the queue according -- Compare the first and the last element of the queue according
@ -104,7 +104,7 @@ sortLexPolys _ = []
-- |Get all points that intersect between both polygons. This is done -- |Get all points that intersect between both polygons. This is done
-- in O(n). -- in O(n).
intersectionPoints :: [PolyPT] -> [P2 Double] intersectionPoints :: [PolyPT] -> [PT]
intersectionPoints xs' = rmdups . go $ xs' intersectionPoints xs' = rmdups . go $ xs'
where where
go [] = [] go [] = []
@ -113,7 +113,7 @@ intersectionPoints xs' = rmdups . go $ xs'
-- Get the scan line or in other words the -- Get the scan line or in other words the
-- Segment pairs we are going to check for intersection. -- Segment pairs we are going to check for intersection.
scanLine :: [PolyPT] -> ([(P2 Double, P2 Double)], [(P2 Double, P2 Double)]) scanLine :: [PolyPT] -> ([Segment], [Segment])
scanLine sp@(_:_) = (,) (getSegment isPolyA) (getSegment isPolyB) scanLine sp@(_:_) = (,) (getSegment isPolyA) (getSegment isPolyB)
where where
getSegment f = fromMaybe [] getSegment f = fromMaybe []
@ -124,10 +124,10 @@ intersectionPoints xs' = rmdups . go $ xs'
-- Gets the actual intersections between the segments of -- Gets the actual intersections between the segments of
-- both polygons we currently examine. This is done in O(1) -- both polygons we currently examine. This is done in O(1)
-- since we have max 4 segments. -- since we have max 4 segments.
segIntersections :: ([(P2 Double, P2 Double)], [(P2 Double, P2 Double)]) -> [P2 Double] segIntersections :: ([Segment], [Segment]) -> [PT]
segIntersections (a@(_:_), b@(_:_)) = segIntersections (a@(_:_), b@(_:_)) =
catMaybes catMaybes
. fmap (\[(x1, y1), (x2, y2)] -> intersectSegSeg x1 y1 x2 y2) . fmap (\[x, y] -> intersectSeg' x y)
$ combinations a b $ combinations a b
segIntersections _ = [] segIntersections _ = []

71
Algorithms/PolygonTriangulation.hs
View File

@ -6,7 +6,6 @@ import Algebra.Polygon
import Algebra.Vector import Algebra.Vector
import qualified Control.Arrow as A import qualified Control.Arrow as A
import Data.Maybe import Data.Maybe
import Diagrams.TwoD.Types
import Safe import Safe
@ -19,12 +18,12 @@ data VCategory = VStart
-- |Classify all vertices on a polygon into five categories (see VCategory). -- |Classify all vertices on a polygon into five categories (see VCategory).
classifyList :: [P2 Double] -> [(P2 Double, VCategory)] classifyList :: [PT] -> [(PT, VCategory)]
classifyList p@(x:y:_:_) = classifyList p@(x:y:_:_) =
-- need to handle the first and last element separately -- need to handle the first and last element separately
[classify (last p) x y] ++ go p ++ [classify (last . init $ p) (last p) x] [classify (last p) x y] ++ go p ++ [classify (last . init $ p) (last p) x]
where where
go :: [P2 Double] -> [(P2 Double, VCategory)] go :: [PT] -> [(PT, VCategory)]
go (x':y':z':xs) = classify x' y' z' : go (y':z':xs) go (x':y':z':xs) = classify x' y' z' : go (y':z':xs)
go _ = [] go _ = []
classifyList _ = [] classifyList _ = []
@ -32,10 +31,10 @@ classifyList _ = []
-- |Classify a vertex on a polygon given it's next and previous vertex -- |Classify a vertex on a polygon given it's next and previous vertex
-- into five categories (see VCategory). -- into five categories (see VCategory).
classify :: P2 Double -- ^ prev vertex classify :: PT -- ^ prev vertex
-> P2 Double -- ^ classify this one -> PT -- ^ classify this one
-> P2 Double -- ^ next vertex -> PT -- ^ next vertex
-> (P2 Double, VCategory) -> (PT, VCategory)
classify prev v next classify prev v next
| isVStart prev v next = (v, VStart) | isVStart prev v next = (v, VStart)
| isVSplit prev v next = (v, VSplit) | isVSplit prev v next = (v, VSplit)
@ -46,9 +45,9 @@ classify prev v next
-- |Whether the vertex, given it's next and previous vertex, -- |Whether the vertex, given it's next and previous vertex,
-- is a start vertex. -- is a start vertex.
isVStart :: P2 Double -- ^ previous vertex isVStart :: PT -- ^ previous vertex
-> P2 Double -- ^ vertice to check -> PT -- ^ vertice to check
-> P2 Double -- ^ next vertex -> PT -- ^ next vertex
-> Bool -> Bool
isVStart prev v next = isVStart prev v next =
ptCmpY next v == LT && ptCmpY prev v == LT && cw next v prev ptCmpY next v == LT && ptCmpY prev v == LT && cw next v prev
@ -56,9 +55,9 @@ isVStart prev v next =
-- |Whether the vertex, given it's next and previous vertex, -- |Whether the vertex, given it's next and previous vertex,
-- is a split vertex. -- is a split vertex.
isVSplit :: P2 Double -- ^ previous vertex isVSplit :: PT -- ^ previous vertex
-> P2 Double -- ^ vertice to check -> PT -- ^ vertice to check
-> P2 Double -- ^ next vertex -> PT -- ^ next vertex
-> Bool -> Bool
isVSplit prev v next = isVSplit prev v next =
ptCmpY prev v == LT && ptCmpY next v == LT && cw prev v next ptCmpY prev v == LT && ptCmpY next v == LT && cw prev v next
@ -66,9 +65,9 @@ isVSplit prev v next =
-- |Whether the vertex, given it's next and previous vertex, -- |Whether the vertex, given it's next and previous vertex,
-- is an end vertex. -- is an end vertex.
isVEnd :: P2 Double -- ^ previous vertex isVEnd :: PT -- ^ previous vertex
-> P2 Double -- ^ vertice to check -> PT -- ^ vertice to check
-> P2 Double -- ^ next vertex -> PT -- ^ next vertex
-> Bool -> Bool
isVEnd prev v next = isVEnd prev v next =
ptCmpY prev v == GT && ptCmpY next v == GT && cw next v prev ptCmpY prev v == GT && ptCmpY next v == GT && cw next v prev
@ -76,9 +75,9 @@ isVEnd prev v next =
-- |Whether the vertex, given it's next and previous vertex, -- |Whether the vertex, given it's next and previous vertex,
-- is a merge vertex. -- is a merge vertex.
isVMerge :: P2 Double -- ^ previous vertex isVMerge :: PT -- ^ previous vertex
-> P2 Double -- ^ vertice to check -> PT -- ^ vertice to check
-> P2 Double -- ^ next vertex -> PT -- ^ next vertex
-> Bool -> Bool
isVMerge prev v next = isVMerge prev v next =
ptCmpY next v == GT && ptCmpY prev v == GT && cw prev v next ptCmpY next v == GT && ptCmpY prev v == GT && cw prev v next
@ -86,9 +85,9 @@ isVMerge prev v next =
-- |Whether the vertex, given it's next and previous vertex, -- |Whether the vertex, given it's next and previous vertex,
-- is a regular vertex. -- is a regular vertex.
isVRegular :: P2 Double -- ^ previous vertex isVRegular :: PT -- ^ previous vertex
-> P2 Double -- ^ vertice to check -> PT -- ^ vertice to check
-> P2 Double -- ^ next vertex -> PT -- ^ next vertex
-> Bool -> Bool
isVRegular prev v next = isVRegular prev v next =
(not . isVStart prev v $ next) (not . isVStart prev v $ next)
@ -99,7 +98,7 @@ isVRegular prev v next =
-- |A polygon P is y-monotone, if it has no split and merge vertices. -- |A polygon P is y-monotone, if it has no split and merge vertices.
isYmonotone :: [P2 Double] -> Bool isYmonotone :: [PT] -> Bool
isYmonotone poly = isYmonotone poly =
not not
. any (\x -> x == VSplit || x == VMerge) . any (\x -> x == VSplit || x == VMerge)
@ -108,12 +107,12 @@ isYmonotone poly =
-- |Partition P into y-monotone pieces. -- |Partition P into y-monotone pieces.
monotonePartitioning :: [P2 Double] -> [[P2 Double]] monotonePartitioning :: [PT] -> [[PT]]
monotonePartitioning pts monotonePartitioning pts
| isYmonotone pts = [pts] | isYmonotone pts = [pts]
| otherwise = go (monotoneDiagonals pts) pts | otherwise = go (monotoneDiagonals pts) pts
where where
go :: [(P2 Double, P2 Double)] -> [P2 Double] -> [[P2 Double]] go :: [Segment] -> [PT] -> [[PT]]
go (x:xs) pts'@(_:_) go (x:xs) pts'@(_:_)
| isYmonotone a && isYmonotone b = [a, b] | isYmonotone a && isYmonotone b = [a, b]
| isYmonotone b = b : go xs a | isYmonotone b = b : go xs a
@ -125,37 +124,37 @@ monotonePartitioning pts
-- |Try to eliminate the merge and split vertices by computing the -- |Try to eliminate the merge and split vertices by computing the
-- diagonals we have to use for splitting the polygon. -- diagonals we have to use for splitting the polygon.
monotoneDiagonals :: [P2 Double] -> [(P2 Double, P2 Double)] monotoneDiagonals :: [PT] -> [Segment]
monotoneDiagonals pts = catMaybes . go $ classifyList pts monotoneDiagonals pts = catMaybes . go $ classifyList pts
where where
go :: [(P2 Double, VCategory)] -> [Maybe (P2 Double, P2 Double)] go :: [(PT, VCategory)] -> [Maybe Segment]
go (x:xs) = case snd x of go (x:xs) = case snd x of
VMerge -> getSeg (belowS . fst $ x) (fst x) : go xs VMerge -> getSeg (belowS . fst $ x) (fst x) : go xs
VSplit -> getSeg (aboveS . fst $ x) (fst x) : go xs VSplit -> getSeg (aboveS . fst $ x) (fst x) : go xs
_ -> [] ++ go xs _ -> [] ++ go xs
go [] = [] go [] = []
getSeg :: [P2 Double] -- all points above/below the current point getSeg :: [PT] -- all points above/below the current point
-> P2 Double -- current point -> PT -- current point
-> Maybe (P2 Double, P2 Double) -> Maybe Segment
getSeg [] _ = Nothing getSeg [] _ = Nothing
getSeg (z:zs) pt getSeg (z:zs) pt
| isInsidePoly pts (z, pt) = Just (z, pt) | isInsidePoly pts (z, pt) = Just (z, pt)
| otherwise = getSeg zs pt | otherwise = getSeg zs pt
aboveS :: P2 Double -> [P2 Double] aboveS :: PT -> [PT]
aboveS pt = tail . dropWhile (/= pt) $ sortedYX pts aboveS pt = tail . dropWhile (/= pt) $ sortedYX pts
belowS :: P2 Double -> [P2 Double] belowS :: PT -> [PT]
belowS pt = reverse . takeWhile (/= pt) $ sortedYX pts belowS pt = reverse . takeWhile (/= pt) $ sortedYX pts
-- |Triangulate a y-monotone polygon. -- |Triangulate a y-monotone polygon.
triangulate :: [P2 Double] -> [[P2 Double]] triangulate :: [PT] -> [[PT]]
triangulate pts = triangulate pts =
go pts . A.first reverse . splitAt 3 . reverse . sortedYX $ pts go pts . A.first reverse . splitAt 3 . reverse . sortedYX $ pts
where where
go :: [P2 Double] -- current polygon go :: [PT] -- current polygon
-> ([P2 Double], [P2 Double]) -- (stack of visited vertices, rest) -> ([PT], [PT]) -- (stack of visited vertices, rest)
-- sorted by Y-coordinate -- sorted by Y-coordinate
-> [[P2 Double]] -> [[PT]]
go xs (p@[_, _], r:rs) = go xs (r:p, rs) go xs (p@[_, _], r:rs) = go xs (r:p, rs)
go xs (p@(u:vi:vi1:ys), rs) go xs (p@(u:vi:vi1:ys), rs)
-- case 1 and 3 -- case 1 and 3

21
Algorithms/QuadTree.hs
View File

@ -56,8 +56,7 @@ data Orient = North | South | East | West
-- |Get a sub-square of the current square, e.g. nw, ne, sw or se. -- |Get a sub-square of the current square, e.g. nw, ne, sw or se.
nwSq, neSq, swSq, seSq :: ((Double, Double), (Double, Double)) -- ^ current square nwSq, neSq, swSq, seSq :: Square -> Square
-> ((Double, Double), (Double, Double)) -- ^ sub-square
nwSq ((xl, yl), (xu, yu)) = (,) (xl, (yl + yu) / 2) ((xl + xu) / 2, yu) nwSq ((xl, yl), (xu, yu)) = (,) (xl, (yl + yu) / 2) ((xl + xu) / 2, yu)
neSq ((xl, yl), (xu, yu)) = (,) ((xl + xu) / 2, (yl + yu) / 2) (xu, yu) neSq ((xl, yl), (xu, yu)) = (,) ((xl + xu) / 2, (yl + yu) / 2) (xu, yu)
swSq ((xl, yl), (xu, yu)) = (,) (xl, yl) ((xl + xu) / 2, (yl + yu) / 2) swSq ((xl, yl), (xu, yu)) = (,) (xl, yl) ((xl + xu) / 2, (yl + yu) / 2)
@ -80,9 +79,9 @@ isSEchild _ = False
-- |Builds a quadtree of a list of points which recursively divides up 2D -- |Builds a quadtree of a list of points which recursively divides up 2D
-- space into quadrants, so that every leaf-quadrant stores either zero or one -- space into quadrants, so that every leaf-quadrant stores either zero or one
-- point. -- point.
quadTree :: [P2 Double] -- ^ the points to divide quadTree :: [PT] -- ^ the points to divide
-> ((Double, Double), (Double, Double)) -- ^ the initial square around the points -> Square -- ^ the initial square around the points
-> QuadTree (P2 Double) -- ^ the quad tree -> QuadTree PT -- ^ the quad tree
quadTree [] _ = TNil quadTree [] _ = TNil
quadTree [pt] _ = TLeaf pt quadTree [pt] _ = TLeaf pt
quadTree pts sq = TNode (quadTree nWPT . nwSq $ sq) (quadTree nEPT . neSq $ sq) quadTree pts sq = TNode (quadTree nWPT . nwSq $ sq) (quadTree nEPT . neSq $ sq)
@ -96,9 +95,9 @@ quadTree pts sq = TNode (quadTree nWPT . nwSq $ sq) (quadTree nEPT . neSq $ sq)
-- |Get all squares of a quad tree. -- |Get all squares of a quad tree.
quadTreeSquares :: ((Double, Double), (Double, Double)) -- ^ the initial square around the points quadTreeSquares :: Square -- ^ the initial square around the points
-> QuadTree (P2 Double) -- ^ the quad tree -> QuadTree PT -- ^ the quad tree
-> [((Double, Double), (Double, Double))] -- ^ all squares of the quad tree -> [Square] -- ^ all squares of the quad tree
quadTreeSquares sq (TNil) = [sq] quadTreeSquares sq (TNil) = [sq]
quadTreeSquares sq (TLeaf _) = [sq] quadTreeSquares sq (TLeaf _) = [sq]
quadTreeSquares sq (TNode nw ne sw se) = quadTreeSquares sq (TNode nw ne sw se) =
@ -108,9 +107,7 @@ quadTreeSquares sq (TNode nw ne sw se) =
-- |Get the current square of the zipper, relative to the given top -- |Get the current square of the zipper, relative to the given top
-- square. -- square.
getSquareByZipper :: ((Double, Double), (Double, Double)) -- ^ top square getSquareByZipper :: Square -> QTZipper a -> Square
-> QTZipper a
-> ((Double, Double), (Double, Double)) -- ^ current square
getSquareByZipper sq z = go sq (reverse . snd $ z) getSquareByZipper sq z = go sq (reverse . snd $ z)
where where
go sq' [] = sq' go sq' [] = sq'
@ -203,7 +200,7 @@ lookupByNeighbors :: [Orient] -> QTZipper a -> Maybe (QTZipper a)
lookupByNeighbors = flip (foldlM (flip findNeighbor)) lookupByNeighbors = flip (foldlM (flip findNeighbor))
quadTreeToRoseTree :: QTZipper (P2 Double) -> Tree String quadTreeToRoseTree :: QTZipper PT -> Tree String
quadTreeToRoseTree z' = go (rootNode z') quadTreeToRoseTree z' = go (rootNode z')
where where
go z = case z of go z = case z of

13
CG2.cabal
View File

@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/ -- see http://haskell.org/cabal/users-guide/
-- The name of the package. -- The name of the package.
name: CG2 name: CGA
-- The package version. See the Haskell package versioning policy (PVP) -- The package version. See the Haskell package versioning policy (PVP)
-- for standards guiding when and how versions should be incremented. -- for standards guiding when and how versions should be incremented.
@ -80,13 +80,14 @@ executable Gtk
base >=4.6, base >=4.6,
bytestring >= 0.10.4.0, bytestring >= 0.10.4.0,
containers >= 0.5.0.0, containers >= 0.5.0.0,
dequeue >= 0.1.12, dequeue >= 0.1.5,
diagrams-lib >=1.3, diagrams-lib >=1.3,
diagrams-cairo >=1.3, diagrams-cairo >=1.3,
diagrams-contrib >= 1.3.0.0, diagrams-contrib >= 1.3.0.0,
directory >=1.2, directory >=1.2,
filepath >= 1.3.0.2, filepath >= 1.3.0.2,
glib >=0.13, glade >=0.12,
gloss >= 1.2.0.1,
gtk >=0.12, gtk >=0.12,
safe >= 0.3.8, safe >= 0.3.8,
transformers >=0.4 transformers >=0.4
@ -129,10 +130,11 @@ executable Gif
base >=4.6, base >=4.6,
bytestring >= 0.10.4.0, bytestring >= 0.10.4.0,
containers >= 0.5.0.0, containers >= 0.5.0.0,
dequeue >= 0.1.12, dequeue >= 0.1.5,
diagrams-lib >=1.3, diagrams-lib >=1.3,
diagrams-cairo >=1.3, diagrams-cairo >=1.3,
diagrams-contrib >= 1.3.0.0, diagrams-contrib >= 1.3.0.0,
gloss >= 1.2.0.1,
JuicyPixels >= 3.1.7.1, JuicyPixels >= 3.1.7.1,
safe >= 0.3.8, safe >= 0.3.8,
transformers >=0.4 transformers >=0.4
@ -177,11 +179,10 @@ executable Test
base >=4.6, base >=4.6,
bytestring >= 0.10.4.0, bytestring >= 0.10.4.0,
containers >= 0.5.0.0, containers >= 0.5.0.0,
dequeue >= 0.1.12,
diagrams-lib >=1.3, diagrams-lib >=1.3,
diagrams-cairo >=1.3, diagrams-cairo >=1.3,
diagrams-contrib >= 1.3.0.0, diagrams-contrib >= 1.3.0.0,
JuicyPixels >= 3.1.7.1, gloss >= 1.2.0.1,
QuickCheck >= 2.4.2, QuickCheck >= 2.4.2,
safe >= 0.3.8 safe >= 0.3.8

69
GUI/Gtk.hs
View File

@ -14,11 +14,10 @@ import Diagrams.Backend.Cairo.Internal
import Graphics.Diagram.Core (DiagProp(..)) import Graphics.Diagram.Core (DiagProp(..))
import Graphics.Diagram.Gtk import Graphics.Diagram.Gtk
import Graphics.UI.Gtk import Graphics.UI.Gtk
import Graphics.UI.Gtk.Builder import Graphics.UI.Gtk.Glade
import MyPrelude import MyPrelude
import System.Directory import System.Directory
import System.FilePath.Posix import System.FilePath.Posix
import System.Glib.UTFString
import Text.Read import Text.Read
@ -78,38 +77,42 @@ data MyGUI = MkMyGUI {
} }
-- |The glade file to load the UI from.
gladeFile :: FilePath
gladeFile = "GUI/gtk2.glade"
-- |Loads the glade file and creates the MyGUI object. -- |Loads the glade file and creates the MyGUI object.
makeMyGladeGUI :: IO MyGUI makeMyGladeGUI :: IO MyGUI
makeMyGladeGUI = do makeMyGladeGUI = do
-- load glade file -- load glade file
builder <- builderNew Just xml <- xmlNew gladeFile
builderAddFromFile builder "GUI/gtk2.xml"
MkMyGUI MkMyGUI
<$> builderGetObject builder castToWindow "window1" <$> xmlGetWidget xml castToWindow "window1"
<*> builderGetObject builder castToWindow "window2" <*> xmlGetWidget xml castToWindow "window2"
<*> builderGetObject builder castToButton "drawButton" <*> xmlGetWidget xml castToButton "drawButton"
<*> builderGetObject builder castToButton "saveButton" <*> xmlGetWidget xml castToButton "saveButton"
<*> builderGetObject builder castToButton "quitButton" <*> xmlGetWidget xml castToButton "quitButton"
<*> builderGetObject builder castToFileChooserButton "filechooserButton" <*> xmlGetWidget xml castToFileChooserButton "filechooserButton"
<*> builderGetObject builder castToDrawingArea "drawingarea" <*> xmlGetWidget xml castToDrawingArea "drawingarea"
<*> builderGetObject builder castToDrawingArea "treedrawingarea" <*> xmlGetWidget xml castToDrawingArea "treedrawingarea"
<*> builderGetObject builder castToHScale "hscale" <*> xmlGetWidget xml castToHScale "hscale"
<*> builderGetObject builder castToEntry "xlD" <*> xmlGetWidget xml castToEntry "xlD"
<*> builderGetObject builder castToEntry "xuD" <*> xmlGetWidget xml castToEntry "xuD"
<*> builderGetObject builder castToEntry "ylD" <*> xmlGetWidget xml castToEntry "ylD"
<*> builderGetObject builder castToEntry "yuD" <*> xmlGetWidget xml castToEntry "yuD"
<*> builderGetObject builder castToAboutDialog "aboutdialog" <*> xmlGetWidget xml castToAboutDialog "aboutdialog"
<*> builderGetObject builder castToComboBox "comboalgo" <*> xmlGetWidget xml castToComboBox "comboalgo"
<*> builderGetObject builder castToCheckButton "gridcheckbutton" <*> xmlGetWidget xml castToCheckButton "gridcheckbutton"
<*> builderGetObject builder castToCheckButton "coordcheckbutton" <*> xmlGetWidget xml castToCheckButton "coordcheckbutton"
<*> builderGetObject builder castToEntry "path" <*> xmlGetWidget xml castToEntry "path"
<*> builderGetObject builder castToBox "vbox7" <*> xmlGetWidget xml castToBox "vbox7"
<*> builderGetObject builder castToBox "vbox10" <*> xmlGetWidget xml castToBox "vbox10"
<*> builderGetObject builder castToEntry "rxMin" <*> xmlGetWidget xml castToEntry "rxMin"
<*> builderGetObject builder castToEntry "rxMax" <*> xmlGetWidget xml castToEntry "rxMax"
<*> builderGetObject builder castToEntry "ryMin" <*> xmlGetWidget xml castToEntry "ryMin"
<*> builderGetObject builder castToEntry "ryMax" <*> xmlGetWidget xml castToEntry "ryMax"
-- |Main entry point for the GTK GUI routines. -- |Main entry point for the GTK GUI routines.
@ -155,23 +158,23 @@ makeGUI startFile = do
-- hotkeys -- hotkeys
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"q" <- fmap glibToString eventKeyName "q" <- eventKeyName
liftIO mainQuit liftIO mainQuit
_ <- treeWin mygui `on` keyPressEvent $ tryEvent $ do _ <- treeWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"q" <- fmap glibToString eventKeyName "q" <- eventKeyName
liftIO (widgetHide $ treeWin mygui) liftIO (widgetHide $ treeWin mygui)
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"s" <- fmap glibToString eventKeyName "s" <- eventKeyName
liftIO $ saveDiag mygui liftIO $ saveDiag mygui
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"d" <- fmap glibToString eventKeyName "d" <- eventKeyName
liftIO $ drawDiag mygui liftIO $ drawDiag mygui
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"a" <- fmap glibToString eventKeyName "a" <- eventKeyName
liftIO $ widgetShowAll (aboutDialog mygui) liftIO $ widgetShowAll (aboutDialog mygui)
-- draw widgets and start main loop -- draw widgets and start main loop

271
GUI/gtk2.xml → GUI/gtk2.glade
View File

@ -1,8 +1,8 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<interface> <glade-interface>
<requires lib="gtk+" version="2.24"/> <!-- interface-requires gtk+ 2.24 -->
<!-- interface-naming-policy project-wide --> <!-- interface-naming-policy project-wide -->
<object class="GtkAboutDialog" id="aboutdialog"> <widget class="GtkAboutDialog" id="aboutdialog">
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="border_width">5</property> <property name="border_width">5</property>
<property name="type_hint">dialog</property> <property name="type_hint">dialog</property>
@ -353,16 +353,16 @@ Public License instead of this License.
</property> </property>
<property name="authors">Julian Ospald &lt;hasufell@hasufell.de&gt;</property> <property name="authors">Julian Ospald &lt;hasufell@hasufell.de&gt;</property>
<child internal-child="vbox"> <child internal-child="vbox">
<object class="GtkVBox" id="dialog-vbox1"> <widget class="GtkVBox" id="dialog-vbox1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="spacing">2</property> <property name="spacing">2</property>
<child internal-child="action_area"> <child internal-child="action_area">
<object class="GtkHButtonBox" id="dialog-action_area1"> <widget class="GtkHButtonBox" id="dialog-action_area1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="layout_style">end</property> <property name="layout_style">end</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -372,16 +372,10 @@ Public License instead of this License.
<child> <child>
<placeholder/> <placeholder/>
</child> </child>
</object> </widget>
</child> </child>
</object> </widget>
<object class="GtkAdjustment" id="adjustment1"> <widget class="GtkWindow" id="window1">
<property name="lower">0.10000000000000001</property>
<property name="upper">10</property>
<property name="step_increment">1</property>
<property name="page_increment">10</property>
</object>
<object class="GtkWindow" id="window1">
<property name="width_request">600</property> <property name="width_request">600</property>
<property name="height_request">750</property> <property name="height_request">750</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
@ -389,15 +383,15 @@ Public License instead of this License.
<property name="window_position">mouse</property> <property name="window_position">mouse</property>
<property name="type_hint">dialog</property> <property name="type_hint">dialog</property>
<child> <child>
<object class="GtkVBox" id="vbox1"> <widget class="GtkVBox" id="vbox1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkFileChooserButton" id="filechooserButton"> <widget class="GtkFileChooserButton" id="filechooserButton">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="create_folders">False</property> <property name="create_folders">False</property>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -405,12 +399,12 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkDrawingArea" id="drawingarea"> <widget class="GtkDrawingArea" id="drawingarea">
<property name="width_request">600</property> <property name="width_request">600</property>
<property name="height_request">600</property> <property name="height_request">600</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -418,16 +412,16 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHBox" id="hbox1"> <widget class="GtkHBox" id="hbox1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkButton" id="drawButton"> <widget class="GtkButton" id="drawButton">
<property name="label" translatable="yes">Draw</property> <property name="label" translatable="yes">Draw</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="receives_default">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -435,12 +429,12 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="saveButton"> <widget class="GtkButton" id="saveButton">
<property name="label" translatable="yes">Save</property> <property name="label" translatable="yes">Save</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="receives_default">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -448,19 +442,19 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="quitButton"> <widget class="GtkButton" id="quitButton">
<property name="label" translatable="yes">Quit</property> <property name="label" translatable="yes">Quit</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="receives_default">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">2</property> <property name="position">2</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -468,10 +462,10 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHSeparator" id="hseparator2"> <widget class="GtkHSeparator" id="hseparator2">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -480,23 +474,23 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHBox" id="hbox2"> <widget class="GtkHBox" id="hbox2">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkHBox" id="hbox3"> <widget class="GtkHBox" id="hbox3">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkVBox" id="vbox2"> <widget class="GtkVBox" id="vbox2">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label1"> <widget class="GtkLabel" id="label1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">X min</property> <property name="label" translatable="yes">X min</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -504,7 +498,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="xlD"> <widget class="GtkEntry" id="xlD">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -515,14 +509,14 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -530,15 +524,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox3"> <widget class="GtkVBox" id="vbox3">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label2"> <widget class="GtkLabel" id="label2">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">X max</property> <property name="label" translatable="yes">X max</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -546,7 +540,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="xuD"> <widget class="GtkEntry" id="xuD">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -557,21 +551,21 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -579,19 +573,19 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHBox" id="hbox4"> <widget class="GtkHBox" id="hbox4">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkVBox" id="vbox4"> <widget class="GtkVBox" id="vbox4">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label3"> <widget class="GtkLabel" id="label3">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">Y min</property> <property name="label" translatable="yes">Y min</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -599,7 +593,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="ylD"> <widget class="GtkEntry" id="ylD">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -610,14 +604,14 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -625,15 +619,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox5"> <widget class="GtkVBox" id="vbox5">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label4"> <widget class="GtkLabel" id="label4">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">Y max</property> <property name="label" translatable="yes">Y max</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -641,7 +635,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="yuD"> <widget class="GtkEntry" id="yuD">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -652,21 +646,21 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -674,15 +668,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox6"> <widget class="GtkVBox" id="vbox6">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label5"> <widget class="GtkLabel" id="label5">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">point thickness</property> <property name="label" translatable="yes">point thickness</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -690,21 +684,20 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHScale" id="hscale"> <widget class="GtkHScale" id="hscale">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="adjustment">adjustment1</property> <property name="adjustment">2 0.10000000000000001 10 0.5 0.5 0</property>
<property name="fill_level">999999999999999</property>
<property name="round_digits">1</property> <property name="round_digits">1</property>
<property name="value_pos">left</property> <property name="value_pos">left</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -712,15 +705,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox8"> <widget class="GtkVBox" id="vbox8">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label6"> <widget class="GtkLabel" id="label6">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">options</property> <property name="label" translatable="yes">options</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -728,17 +721,17 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHBox" id="hbox6"> <widget class="GtkHBox" id="hbox6">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkCheckButton" id="gridcheckbutton"> <widget class="GtkCheckButton" id="gridcheckbutton">
<property name="label" translatable="yes">grid</property> <property name="label" translatable="yes">grid</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">False</property> <property name="receives_default">False</property>
<property name="draw_indicator">True</property> <property name="draw_indicator">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -746,34 +739,34 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkCheckButton" id="coordcheckbutton"> <widget class="GtkCheckButton" id="coordcheckbutton">
<property name="label" translatable="yes">coord</property> <property name="label" translatable="yes">coord</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">False</property> <property name="receives_default">False</property>
<property name="draw_indicator">True</property> <property name="draw_indicator">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<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">3</property> <property name="position">3</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -781,10 +774,10 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHSeparator" id="hseparator1"> <widget class="GtkHSeparator" id="hseparator1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -793,19 +786,19 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox7"> <widget class="GtkVBox" id="vbox7">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkHBox" id="hbox5"> <widget class="GtkHBox" id="hbox5">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="pathlabel"> <widget class="GtkLabel" id="pathlabel">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">QuadTree Path</property> <property name="label" translatable="yes">QuadTree Path</property>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -814,7 +807,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="path"> <widget class="GtkEntry" id="path">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="invisible_char">●</property> <property name="invisible_char">●</property>
@ -822,14 +815,14 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -837,10 +830,10 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHSeparator" id="hseparator3"> <widget class="GtkHSeparator" id="hseparator3">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -848,7 +841,7 @@ Public License instead of this License.
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -856,19 +849,19 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox10"> <widget class="GtkVBox" id="vbox10">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkHBox" id="hbox7"> <widget class="GtkHBox" id="hbox7">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label11"> <widget class="GtkLabel" id="label11">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">Range search</property> <property name="label" translatable="yes">Range search</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -877,15 +870,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox11"> <widget class="GtkVBox" id="vbox11">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label7"> <widget class="GtkLabel" id="label7">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">X min</property> <property name="label" translatable="yes">X min</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -893,7 +886,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="rxMin"> <widget class="GtkEntry" id="rxMin">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -902,14 +895,14 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -917,15 +910,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox12"> <widget class="GtkVBox" id="vbox12">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label8"> <widget class="GtkLabel" id="label8">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">X max</property> <property name="label" translatable="yes">X max</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -933,7 +926,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="rxMax"> <widget class="GtkEntry" id="rxMax">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -942,14 +935,14 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -957,15 +950,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox13"> <widget class="GtkVBox" id="vbox13">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label9"> <widget class="GtkLabel" id="label9">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">Y min</property> <property name="label" translatable="yes">Y min</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -973,7 +966,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="ryMin"> <widget class="GtkEntry" id="ryMin">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -982,14 +975,14 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -997,15 +990,15 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkVBox" id="vbox14"> <widget class="GtkVBox" id="vbox14">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkLabel" id="label10"> <widget class="GtkLabel" id="label10">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="label" translatable="yes">Y max</property> <property name="label" translatable="yes">Y max</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
@ -1013,7 +1006,7 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkEntry" id="ryMax"> <widget class="GtkEntry" id="ryMax">
<property name="width_request">5</property> <property name="width_request">5</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
@ -1022,21 +1015,21 @@ Public License instead of this License.
<property name="secondary_icon_activatable">False</property> <property name="secondary_icon_activatable">False</property>
<property name="primary_icon_sensitive">True</property> <property name="primary_icon_sensitive">True</property>
<property name="secondary_icon_sensitive">True</property> <property name="secondary_icon_sensitive">True</property>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">4</property> <property name="position">4</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -1044,17 +1037,17 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkHSeparator" id="hseparator4"> <widget class="GtkHSeparator" id="hseparator4">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </widget>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">False</property> <property name="fill">False</property>
@ -1062,39 +1055,37 @@ Public License instead of this License.
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkComboBoxText" id="comboalgo"> <widget class="GtkComboBox" id="comboalgo">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<items> <property name="items" translatable="yes">Show points
<item>Show points</item> Show convex hull
<item>Show convex hull</item> Show polygons
<item>Show polygons</item> Show polygons intersection
<item>Show polygons intersection</item> Show quad tree squares
<item>Show quad tree squares</item> Show kd tree squares
<item>Show kd tree squares</item> Polygon Triangulation</property>
<item>Polygon Triangulation</item> </widget>
</items>
</object>
<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">8</property> <property name="position">8</property>
</packing> </packing>
</child> </child>
</object> </widget>
</child> </child>
</object> </widget>
<object class="GtkWindow" id="window2"> <widget class="GtkWindow" id="window2">
<property name="width_request">800</property> <property name="width_request">800</property>
<property name="height_request">500</property> <property name="height_request">500</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="title" translatable="yes">Tree</property> <property name="title" translatable="yes">Tree</property>
<property name="type_hint">dialog</property> <property name="type_hint">dialog</property>
<child> <child>
<object class="GtkDrawingArea" id="treedrawingarea"> <widget class="GtkDrawingArea" id="treedrawingarea">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
</object> </widget>
</child> </child>
</object> </widget>
</interface> </glade-interface>

20
Graphics/Diagram/AlgoDiags.hs
View File

@ -1,10 +1,8 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Graphics.Diagram.AlgoDiags where module Graphics.Diagram.AlgoDiags where
import Algebra.Vector(PT,Square)
import Algorithms.GrahamScan import Algorithms.GrahamScan
import Algorithms.QuadTree import Algorithms.QuadTree
import Algorithms.KDTree import Algorithms.KDTree
@ -126,9 +124,7 @@ kdSquares = Diag f
where where
-- Gets all lines that make up the kdSquares. Every line is -- Gets all lines that make up the kdSquares. Every line is
-- described by two points, start and end respectively. -- described by two points, start and end respectively.
kdLines :: KDTree (P2 Double) kdLines :: KDTree PT -> Square -> [(PT, PT)]
-> ((Double, Double), (Double, Double)) -- ^ square
-> [(P2 Double, P2 Double)]
kdLines (KTNode ln pt Horizontal rn) ((xmin, ymin), (xmax, ymax)) = kdLines (KTNode ln pt Horizontal rn) ((xmin, ymin), (xmax, ymax)) =
(\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))]) (\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))])
(unp2 pt) (unp2 pt)
@ -183,7 +179,7 @@ kdTreeDiag = Diag f
-- |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 :: [P2 Double] -> DiagProp -> QuadTree (P2 Double) qt :: [PT] -> DiagProp -> QuadTree PT
qt vt p = quadTree vt (diagDimSquare p) qt vt p = quadTree vt (diagDimSquare p)
@ -196,9 +192,7 @@ quadPathSquare = Diag f
(uncurry rectByDiagonal # lw thin # lc red) (uncurry rectByDiagonal # lw thin # lc red)
(getSquare (stringToQuads (quadPath p)) (qt (mconcat vts) p, [])) (getSquare (stringToQuads (quadPath p)) (qt (mconcat vts) p, []))
where where
getSquare :: [Either Quad Orient] getSquare :: [Either Quad Orient] -> QTZipper PT -> Square
-> QTZipper (P2 Double)
-> ((Double, Double), (Double, Double))
getSquare [] z = getSquareByZipper (diagDimSquare p) z getSquare [] z = getSquareByZipper (diagDimSquare p) z
getSquare (q:qs) z = case q of getSquare (q:qs) z = case q of
Right x -> getSquare qs (fromMaybe z (findNeighbor x z)) Right x -> getSquare qs (fromMaybe z (findNeighbor x z))
@ -214,9 +208,7 @@ gifQuadPath = GifDiag f
(uncurry rectByDiagonal # lw thick # lc col) (uncurry rectByDiagonal # lw thick # lc col)
<$> getSquares (stringToQuads (quadPath p)) (qt vt p, []) <$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
where where
getSquares :: [Either Quad Orient] getSquares :: [Either Quad Orient] -> QTZipper PT -> [Square]
-> QTZipper (P2 Double)
-> [((Double, Double), (Double, Double))]
getSquares [] z = [getSquareByZipper (diagDimSquare p) z] getSquares [] z = [getSquareByZipper (diagDimSquare p) z]
getSquares (q:qs) z = case q of getSquares (q:qs) z = case q of
Right x -> getSquareByZipper (diagDimSquare p) z : Right x -> getSquareByZipper (diagDimSquare p) z :
@ -236,7 +228,7 @@ treePretty = Diag f
. quadPath . quadPath
$ p) $ p)
where where
getCurQT :: [Either Quad Orient] -> QTZipper (P2 Double) -> QTZipper (P2 Double) getCurQT :: [Either Quad Orient] -> QTZipper PT -> QTZipper PT
getCurQT [] z = z getCurQT [] z = z
getCurQT (q:qs) z = case q of getCurQT (q:qs) z = case q of
Right x -> getCurQT qs (fromMaybe z (findNeighbor x z)) Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))

47
Graphics/Diagram/Core.hs
View File

@ -15,15 +15,15 @@ data Diag =
Diag Diag
{ {
mkDiag :: DiagProp mkDiag :: DiagProp
-> [[P2 Double]] -> [[PT]]
-> Diagram Cairo -> Diagram Cairo
} }
| GifDiag | GifDiag
{ {
mkGifDiag :: DiagProp mkGifDiag :: DiagProp
-> Colour Double -> Colour Double
-> ([P2 Double] -> [[P2 Double]]) -> ([PT] -> [[PT]])
-> [P2 Double] -> [PT]
-> [Diagram Cairo] -> [Diagram Cairo]
} }
| EmptyDiag (Diagram Cairo) | EmptyDiag (Diagram Cairo)
@ -49,7 +49,7 @@ data DiagProp = MkProp {
-- |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. -- |The square for the kd-tree range search.
rangeSquare :: ((Double, Double), (Double, Double)) rangeSquare :: Square
} }
@ -57,24 +57,23 @@ instance Def DiagProp where
def = diagDefaultProp def = diagDefaultProp
instance Semigroup Diag where
d1@(Diag {}) <> d2@(Diag {}) = Diag g
where
g p obj = mkDiag d1 p obj <> mkDiag d2 p obj
d1@(GifDiag {}) <> d2@(Diag {}) = GifDiag g
where
g p col f vt = mkGifDiag d1 p col f vt ++ [mkDiag d2 p [vt]]
d1@(Diag {}) <> d2@(GifDiag {}) = GifDiag g
where
g p col f vt = mkDiag d2 p [vt] : mkGifDiag d1 p col f vt
d1@(GifDiag {}) <> d2@(GifDiag {}) = GifDiag g
where
g p col f vt = mkGifDiag d1 p col f vt ++ mkGifDiag d2 p col f vt
(EmptyDiag _) <> g = g
g <> (EmptyDiag _) = g
instance Monoid Diag where instance Monoid Diag where
mempty = EmptyDiag mempty mempty = EmptyDiag mempty
mappend d1@(Diag {}) d2@(Diag {}) = Diag g
where
g p obj = mkDiag d1 p obj <> mkDiag d2 p obj
mappend d1@(GifDiag {}) d2@(Diag {}) = GifDiag g
where
g p col f vt = mkGifDiag d1 p col f vt ++ [mkDiag d2 p [vt]]
mappend d1@(Diag {}) d2@(GifDiag {}) = GifDiag g
where
g p col f vt = mkDiag d2 p [vt] : mkGifDiag d1 p col f vt
mappend d1@(GifDiag {}) d2@(GifDiag {}) = GifDiag g
where
g p col f vt = mkGifDiag d1 p col f vt ++ mkGifDiag d2 p col f vt
mappend (EmptyDiag _) g = g
mappend g (EmptyDiag _) = g
mconcat = foldr mappend mempty mconcat = foldr mappend mempty
@ -135,19 +134,19 @@ maybeDiag b d
| otherwise = mempty | otherwise = mempty
filterValidPT :: DiagProp -> [P2 Double] -> [P2 Double] filterValidPT :: DiagProp -> [PT] -> [PT]
filterValidPT = filterValidPT =
filter filter
. inRange . inRange
. diagDimSquare . diagDimSquare
diagDimSquare :: DiagProp -> ((Double, Double), (Double, Double)) diagDimSquare :: DiagProp -> Square
diagDimSquare p = dimToSquare (xDimension p) $ yDimension p diagDimSquare p = dimToSquare (xDimension p) $ yDimension p
-- |Draw a list of points. -- |Draw a list of points.
drawP :: [P2 Double] -- ^ the points to draw drawP :: [PT] -- ^ the points to draw
-> Double -- ^ dot size -> Double -- ^ dot size
-> Diagram Cairo -- ^ the resulting diagram -> Diagram Cairo -- ^ the resulting diagram
drawP [] _ = mempty drawP [] _ = mempty
@ -173,7 +172,7 @@ rectByDiagonal (xmin, ymin) (xmax, ymax) =
-- |Creates a Diagram from a point that shows the coordinates -- |Creates a Diagram from a point that shows the coordinates
-- in text format, such as "(1.0, 2.0)". -- in text format, such as "(1.0, 2.0)".
pointToTextCoord :: P2 Double -> Diagram Cairo pointToTextCoord :: PT -> Diagram Cairo
pointToTextCoord pt = pointToTextCoord pt =
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10 text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
where where

6
Graphics/Diagram/Gif.hs
View File

@ -2,7 +2,7 @@
module Graphics.Diagram.Gif where module Graphics.Diagram.Gif where
import Algebra.Vector 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
@ -16,7 +16,7 @@ import Parser.Meshparser
-- |Return a list of tuples used by 'gifMain' to generate an animated gif. -- |Return a list of tuples used by 'gifMain' to generate an animated gif.
gifDiag :: DiagProp -> [P2 Double] -> [(Diagram Cairo, GifDelay)] gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo, GifDelay)]
gifDiag p xs = gifDiag p xs =
fmap ((\x -> (x, 50)) . (<> nonChDiag)) fmap ((\x -> (x, 50)) . (<> nonChDiag))
(upperHullList (upperHullList
@ -36,4 +36,4 @@ gifDiag p xs =
-- |Same as gifDiag, except that it takes a string containing the -- |Same as gifDiag, except that it takes a string containing the
-- mesh file content instead of the the points. -- mesh file content instead of the the points.
gifDiagS :: DiagProp -> B.ByteString -> [(Diagram Cairo, GifDelay)] gifDiagS :: DiagProp -> B.ByteString -> [(Diagram Cairo, GifDelay)]
gifDiagS p = gifDiag p . filterValidPT p . meshToArr gifDiagS p = gifDiag p . filterValidPT p . meshVertices

12
Graphics/Diagram/Gtk.hs
View File

@ -2,7 +2,7 @@
module Graphics.Diagram.Gtk where module Graphics.Diagram.Gtk where
import Algebra.Vector import Algebra.Vector(PT)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Data.List(find) import Data.List(find)
import Diagrams.Backend.Cairo import Diagrams.Backend.Cairo
@ -46,7 +46,7 @@ diagTreAlgos =
-- |Create the Diagram from the points. -- |Create the Diagram from the points.
diag :: DiagProp -> [DiagAlgo] -> [[P2 Double]] -> Diagram Cairo diag :: DiagProp -> [DiagAlgo] -> [[PT]] -> Diagram Cairo
diag p das vts = maybe mempty (\x -> mkDiag x p vts) diag p das vts = maybe mempty (\x -> mkDiag x p vts)
$ mconcat $ mconcat
-- get the actual [Diag] array -- get the actual [Diag] array
@ -62,8 +62,8 @@ diagS :: DiagProp -> B.ByteString -> Diagram Cairo
diagS p mesh = diagS p mesh =
diag p diagAlgos diag p diagAlgos
. fmap (filterValidPT p) . fmap (filterValidPT p)
. (\x -> if null x then [meshToArr mesh] else x) . (\x -> if null x then [meshVertices mesh] else x)
. parseObj . meshFaceVertices
$ mesh $ mesh
@ -73,7 +73,7 @@ diagTreeS :: DiagProp -> B.ByteString -> Diagram Cairo
diagTreeS p mesh = diagTreeS p mesh =
diag p diagTreAlgos diag p diagTreAlgos
. fmap (filterValidPT p) . fmap (filterValidPT p)
. (\x -> if null x then [meshToArr mesh] else x) . (\x -> if null x then [meshVertices mesh] else x)
. parseObj . meshFaceVertices
$ mesh $ mesh

2
Graphics/Diagram/Plotter.hs
View File

@ -1,6 +1,4 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Graphics.Diagram.Plotter where module Graphics.Diagram.Plotter where

7
Graphics/HalfEdge.hs
View File

@ -29,7 +29,6 @@ import Control.Monad
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import qualified Data.IntMap.Lazy as Map import qualified Data.IntMap.Lazy as Map
import Data.Maybe import Data.Maybe
import Diagrams.TwoD.Types
import Parser.Meshparser import Parser.Meshparser
import Safe import Safe
@ -232,10 +231,10 @@ buildHeEdge pts fs
-- |Build the HeEdge data structure from the .obj mesh file contents. -- |Build the HeEdge data structure from the .obj mesh file contents.
buildHeEdgeFromStr :: B.ByteString -- ^ contents of an .obj mesh file buildHeEdgeFromStr :: B.ByteString -- ^ contents of an .obj mesh file
-> HeEdge (P2 Double) -> HeEdge PT
buildHeEdgeFromStr bmesh = buildHeEdgeFromStr bmesh =
let pts = meshToArr bmesh let pts = meshVertices bmesh
faces' = indirectHeFaces . facesToArr $ bmesh faces' = indirectHeFaces . meshFaces $ bmesh
edges = indirectHeEdges faces' edges = indirectHeEdges faces'
verts = indirectHeVerts edges verts = indirectHeVerts edges
in indirectToDirect pts edges faces' verts in indirectToDirect pts edges faces' verts

32
Parser/Meshparser.hs
View File

@ -1,7 +1,8 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module Parser.Meshparser (meshToArr, facesToArr, parseObj) where module Parser.Meshparser where
import Algebra.Vector(PT)
import Control.Applicative import Control.Applicative
import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.ByteString.Char8
import Data.Either import Data.Either
@ -9,16 +10,19 @@ import qualified Data.ByteString.Char8 as B
import Diagrams.TwoD.Types import Diagrams.TwoD.Types
facesToArr :: B.ByteString -> [[Int]] -- |Convert a text String with multiple vertices and faces into
facesToArr = rights . fmap (parseOnly parseFace) . B.lines -- a list of vertices, ordered by the faces specification.
meshFaceVertices :: B.ByteString -> [[PT]]
meshFaceVertices str = fmap (fmap (\y -> meshVertices str !! (y - 1)))
(meshFaces str)
-- |Convert a text String with multiple vertices into -- |Convert a text String with multiple vertices into
-- an array of float tuples. -- an array of float tuples.
meshToArr :: B.ByteString -- ^ the string to convert meshVertices :: B.ByteString -- ^ the string to convert
-> [P2 Double] -- ^ the resulting vertice table -> [PT] -- ^ the resulting vertice table
meshToArr = meshVertices
fmap p2 = fmap p2
. rights . rights
. fmap (parseOnly parseVertice) . fmap (parseOnly parseVertice)
. B.lines . B.lines
@ -32,14 +36,12 @@ parseVertice =
<*> (many' space *> double) <*> (many' space *> double)
parseFace :: Parser [Int] parseFace :: (Integral a) => Parser [a]
parseFace = char 'f' *> many1' (many' space *> decimal) parseFace = char 'f' *> many1' (many' space *> decimal)
-- |Convert a text String with multiple vertices and faces into meshFaces :: B.ByteString -> [[Int]]
-- a list of vertices, ordered by the faces specification. meshFaces
parseObj :: B.ByteString -> [[P2 Double]] = rights
parseObj str = fmap (fmap (\y -> meshToArr str !! (fromIntegral y - 1))) . fmap (parseOnly parseFace)
(faces str) . B.lines
where
faces = rights . fmap (parseOnly parseFace) . B.lines

7
QueueEx.hs
View File

@ -3,20 +3,21 @@ module QueueEx where
import Control.Applicative import Control.Applicative
import Data.Dequeue (BankersDequeue) import Data.Dequeue (BankersDequeue)
import qualified Data.Dequeue as Q import qualified Data.Dequeue as Q
import Data.Maybe
-- |Shift a queue to the left, such as: -- |Shift a queue to the left, such as:
-- [1, 2, 3] -> [2, 3, 1] -- [1, 2, 3] -> [2, 3, 1]
shiftQueueLeft :: BankersDequeue a -> BankersDequeue a shiftQueueLeft :: BankersDequeue a -> BankersDequeue a
shiftQueueLeft = (\(Just (b, nq)) -> Q.pushBack nq b) <$> Q.popFront shiftQueueLeft = (\(b, nq) -> Q.pushBack nq (fromJust b)) <$> Q.popFront
-- |Shift a queue to the right, such as: -- |Shift a queue to the right, such as:
-- [1, 2, 3] -> [3, 1, 2] -- [1, 2, 3] -> [3, 1, 2]
shiftQueueRight :: BankersDequeue a -> BankersDequeue a shiftQueueRight :: BankersDequeue a -> BankersDequeue a
shiftQueueRight = (\(Just (b, nq)) -> Q.pushFront nq b) <$> Q.popBack shiftQueueRight = (\(b, nq) -> Q.pushFront nq (fromJust b)) <$> Q.popBack
-- |Convert a Queue back to a list. -- |Convert a Queue back to a list.
queueToList :: BankersDequeue a -> [a] queueToList :: BankersDequeue a -> [a]
queueToList q = Q.takeFront (length q) q queueToList q = Q.takeFront (Q.length q) q

48
Test/Vector.hs
View File

@ -82,40 +82,40 @@ instance Arbitrary (P2 Double) where
-- the point describing the lower left corner of the square -- the point describing the lower left corner of the square
-- must be part of the square -- must be part of the square
inRangeProp1 :: ((Double, Double), (Double, Double)) -> Bool inRangeProp1 :: Square -> Bool
inRangeProp1 sq@((x1, y1), _) = inRangeProp1 sq@((x1, y1), _) =
inRange sq (p2 (x1, y1)) inRange sq (p2 (x1, y1))
-- the point describing the upper right corner of the square -- the point describing the upper right corner of the square
-- must be part of the square -- must be part of the square
inRangeProp2 :: ((Double, Double), (Double, Double)) -> Bool inRangeProp2 :: Square -> Bool
inRangeProp2 sq@(_, (x2, y2)) = inRangeProp2 sq@(_, (x2, y2)) =
inRange sq (p2 (x2, y2)) inRange sq (p2 (x2, y2))
-- the point describing the upper left corner of the square -- the point describing the upper left corner of the square
-- must be part of the square -- must be part of the square
inRangeProp3 :: ((Double, Double), (Double, Double)) -> Bool inRangeProp3 :: Square -> Bool
inRangeProp3 sq@((x1, _), (_, y2)) = inRangeProp3 sq@((x1, _), (_, y2)) =
inRange sq (p2 (x1, y2)) inRange sq (p2 (x1, y2))
-- the point describing the lower right corner of the square -- the point describing the lower right corner of the square
-- must be part of the square -- must be part of the square
inRangeProp4 :: ((Double, Double), (Double, Double)) -> Bool inRangeProp4 :: Square -> Bool
inRangeProp4 sq@((_, y1), (x2, _)) = inRangeProp4 sq@((_, y1), (x2, _)) =
inRange sq (p2 (x2, y1)) inRange sq (p2 (x2, y1))
-- generating random points within the square -- generating random points within the square
inRangeProp5 :: ((Double, Double), (Double, Double)) -> Positive Double -> Positive Double -> Bool inRangeProp5 :: Square -> Positive Double -> Positive Double -> Bool
inRangeProp5 sq@((x1, y1), (x2, y2)) (Positive a) (Positive b) = inRangeProp5 sq@((x1, y1), (x2, y2)) (Positive a) (Positive b) =
inRange sq (p2 (x1 + ((x2 - x1) / (a + 1)), y1 + ((y2 - y1) / (b + 1)))) inRange sq (p2 (x1 + ((x2 - x1) / (a + 1)), y1 + ((y2 - y1) / (b + 1))))
-- generating random points outside of the square -- generating random points outside of the square
inRangeProp6 :: ((Double, Double), (Double, Double)) -> Positive Double -> Positive Double -> Bool inRangeProp6 :: Square -> Positive Double -> Positive Double -> Bool
inRangeProp6 sq@((x1, y1), (x2, y2)) (Positive a) (Positive b) = inRangeProp6 sq@((x1, y1), (x2, y2)) (Positive a) (Positive b) =
(not . inRange sq $ p2 (max x1 x2 + (a + 1), max y1 y2 + (b + 1))) (not . inRange sq $ p2 (max x1 x2 + (a + 1), max y1 y2 + (b + 1)))
&& (not . inRange sq $ p2 (max x1 x2 + (a + 1), max y1 y2 - (b + 1))) && (not . inRange sq $ p2 (max x1 x2 + (a + 1), max y1 y2 - (b + 1)))
@ -126,51 +126,51 @@ inRangeProp6 sq@((x1, y1), (x2, y2)) (Positive a) (Positive b) =
-- apply id function on the point -- apply id function on the point
onPTProp1 :: P2 Double -> Bool onPTProp1 :: PT -> Bool
onPTProp1 pt = onPT id pt == pt onPTProp1 pt = onPT id pt == pt
-- add a random value to the point coordinates -- add a random value to the point coordinates
onPTProp2 :: P2 Double -> Positive (V2 Double) -> Bool onPTProp2 :: PT -> Positive (V2 Double) -> Bool
onPTProp2 pt (Positive (V2 rx ry)) onPTProp2 pt (Positive (V2 rx ry))
= onPT (\(x, y) -> (x + rx, y + ry)) pt /= pt = onPT (\(x, y) -> (x + rx, y + ry)) pt /= pt
-- angle between two vectors both on the x-axis must be 0 -- angle between two vectors both on the x-axis must be 0
getAngleProp1 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool getAngleProp1 :: Positive Vec -> Positive Vec -> Bool
getAngleProp1 (Positive (V2 x1 _)) (Positive (V2 x2 _)) getAngleProp1 (Positive (V2 x1 _)) (Positive (V2 x2 _))
= getAngle (V2 x1 0) (V2 x2 0) == 0 = getAngle (V2 x1 0) (V2 x2 0) == 0
-- angle between two vectors both on the y-axis must be 0 -- angle between two vectors both on the y-axis must be 0
getAngleProp2 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool getAngleProp2 :: Positive Vec -> Positive Vec -> Bool
getAngleProp2 (Positive (V2 _ y1)) (Positive (V2 _ y2)) getAngleProp2 (Positive (V2 _ y1)) (Positive (V2 _ y2))
= getAngle (V2 0 y1) (V2 0 y2) == 0 = getAngle (V2 0 y1) (V2 0 y2) == 0
-- angle between two vectors both on the x-axis but with opposite direction -- angle between two vectors both on the x-axis but with opposite direction
-- must be pi -- must be pi
getAngleProp3 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool getAngleProp3 :: Positive Vec -> Positive Vec -> Bool
getAngleProp3 (Positive (V2 x1 _)) (Positive (V2 x2 _)) getAngleProp3 (Positive (V2 x1 _)) (Positive (V2 x2 _))
= getAngle (V2 (negate x1) 0) (V2 x2 0) == pi = getAngle (V2 (negate x1) 0) (V2 x2 0) == pi
-- angle between two vectors both on the y-axis but with opposite direction -- angle between two vectors both on the y-axis but with opposite direction
-- must be pi -- must be pi
getAngleProp4 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool getAngleProp4 :: Positive Vec -> Positive Vec -> Bool
getAngleProp4 (Positive (V2 _ y1)) (Positive (V2 _ y2)) getAngleProp4 (Positive (V2 _ y1)) (Positive (V2 _ y2))
= getAngle (V2 0 (negate y1)) (V2 0 y2) == pi = getAngle (V2 0 (negate y1)) (V2 0 y2) == pi
-- angle between vector in x-axis direction and y-axis direction must be -- angle between vector in x-axis direction and y-axis direction must be
-- p/2 -- p/2
getAngleProp5 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool getAngleProp5 :: Positive Vec -> Positive Vec -> Bool
getAngleProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2)) getAngleProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2))
= getAngle (V2 x1 0) (V2 0 y2) == pi / 2 = getAngle (V2 x1 0) (V2 0 y2) == pi / 2
-- commutative -- commutative
getAngleProp6 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool getAngleProp6 :: Positive Vec -> Positive Vec -> Bool
getAngleProp6 (Positive v1) (Positive v2) getAngleProp6 (Positive v1) (Positive v2)
= getAngle v1 v2 == getAngle v2 v1 = getAngle v1 v2 == getAngle v2 v1
@ -183,7 +183,7 @@ getAngleProp7 (PosRoundR2 v)
-- commutative -- commutative
scalarProdProp1 :: (V2 Double) -> (V2 Double) -> Bool scalarProdProp1 :: Vec -> Vec -> Bool
scalarProdProp1 v1 v2 = v1 `scalarProd` v2 == v2 `scalarProd` v1 scalarProdProp1 v1 v2 = v1 `scalarProd` v2 == v2 `scalarProd` v1
@ -212,7 +212,7 @@ scalarProdProp4 (RoundDouble s1) (RoundDouble s2) (RoundR2 v1) (RoundR2 v2)
-- orthogonal -- orthogonal
scalarProdProp5 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool scalarProdProp5 :: Positive Vec -> Positive Vec -> Bool
scalarProdProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2)) scalarProdProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2))
= scalarProd (V2 x1 0) (V2 0 y2) == 0 = scalarProd (V2 x1 0) (V2 0 y2) == 0
@ -226,40 +226,40 @@ dimToSquareProp1 (x1, x2) (y1, y2) =
-- multiply scalar with result of vecLength or with the vector itself... -- multiply scalar with result of vecLength or with the vector itself...
-- both results must be the same. We can't check against 0 -- both results must be the same. We can't check against 0
-- because of sqrt in vecLength. -- because of sqrt in vecLength.
vecLengthProp1 :: PosRoundDouble -> (V2 Double) -> Bool vecLengthProp1 :: PosRoundDouble -> Vec -> Bool
vecLengthProp1 (PosRoundDouble r) v vecLengthProp1 (PosRoundDouble r) v
= abs (vecLength v * r - vecLength (scalarMul r v)) < 0.0001 = abs (vecLength v * r - vecLength (scalarMul r v)) < 0.0001
-- convert to vector and back again -- convert to vector and back again
pt2VecProp1 :: P2 Double -> Bool pt2VecProp1 :: PT -> Bool
pt2VecProp1 pt = (vec2Pt . pt2Vec $ pt) == pt pt2VecProp1 pt = (vec2Pt . pt2Vec $ pt) == pt
-- unbox coordinates and check if equal -- unbox coordinates and check if equal
pt2VecProp2 :: P2 Double -> Bool pt2VecProp2 :: PT -> Bool
pt2VecProp2 pt = (unr2 . pt2Vec $ pt) == unp2 pt pt2VecProp2 pt = (unr2 . pt2Vec $ pt) == unp2 pt
-- convert to point and back again -- convert to point and back again
vec2PtProp1 :: V2 Double -> Bool vec2PtProp1 :: Vec -> Bool
vec2PtProp1 v = (pt2Vec . vec2Pt $ v) == v vec2PtProp1 v = (pt2Vec . vec2Pt $ v) == v
-- unbox coordinates and check if equal -- unbox coordinates and check if equal
vec2PtProp2 :: V2 Double -> Bool vec2PtProp2 :: Vec -> Bool
vec2PtProp2 v = (unp2 . vec2Pt $ v) == unr2 v vec2PtProp2 v = (unp2 . vec2Pt $ v) == unr2 v
-- vector from a to b must not be the same as b to a -- vector from a to b must not be the same as b to a
vp2Prop1 :: P2 Double -> P2 Double -> Bool vp2Prop1 :: PT -> PT -> Bool
vp2Prop1 p1' p2' vp2Prop1 p1' p2'
| p1' == origin && p2' == origin = True | p1' == origin && p2' == origin = True
| otherwise = vp2 p1' p2' /= vp2 p2' p1' | otherwise = vp2 p1' p2' /= vp2 p2' p1'
-- negating vector from a to be must be the same as vector b to a -- negating vector from a to be must be the same as vector b to a
vp2Prop2 :: P2 Double -> P2 Double -> Bool vp2Prop2 :: PT -> PT -> Bool
vp2Prop2 p1' p2' vp2Prop2 p1' p2'
| p1' == origin && p2' == origin = True | p1' == origin && p2' == origin = True
| otherwise = vp2 p1' p2' == (\(V2 x y) -> negate x ^& negate y) | otherwise = vp2 p1' p2' == (\(V2 x y) -> negate x ^& negate y)
@ -270,5 +270,5 @@ vp2Prop2 p1' p2'
-- determinant of the 3 same points is always 0 -- determinant of the 3 same points is always 0
detProp1 :: P2 Double -> Bool detProp1 :: PT -> Bool
detProp1 pt' = det pt' pt' pt' == 0 detProp1 pt' = det pt' pt' pt' == 0

3
cabal.project
View File

@ -1,3 +0,0 @@
with-compiler: ghc-8.6.5
packages: *.cabal

169
cabal.project.freeze
View File

@ -1,169 +0,0 @@
constraints: any.Boolean ==0.2.4,
any.Cabal ==2.4.0.1,
any.JuicyPixels ==3.3.4,
JuicyPixels -mmap,
any.MemoTrie ==0.6.10,
MemoTrie -examples,
any.MonadRandom ==0.5.1.1,
any.NumInstances ==1.4,
any.QuickCheck ==2.13.2,
QuickCheck +templatehaskell,
any.StateVar ==1.2,
any.active ==0.2.0.14,
any.adjunctions ==4.4,
any.alex ==3.2.5,
alex +small_base,
any.ansi-terminal ==0.10.2,
ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.3.0,
any.async ==2.2.2,
async -bench,
any.attoparsec ==0.13.2.3,
attoparsec -developer,
any.base ==4.12.0.0,
any.base-orphans ==0.8.1,
any.bifunctors ==5.5.6,
bifunctors +semigroups +tagged,
any.binary ==0.8.6.0,
any.binary-orphans ==1.0.1,
any.bytes ==0.16,
bytes +test-doctests,
any.bytestring ==0.10.8.2,
any.cabal-doctest ==1.0.8,
any.cairo ==0.13.6.1,
cairo +cairo_pdf +cairo_ps +cairo_svg,
any.call-stack ==0.2.0,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.circle-packing ==0.1.0.6,
any.colour ==2.3.5,
any.comonad ==5.0.6,
comonad +containers +distributive +test-doctests,
any.constraints ==0.11.2,
any.containers ==0.6.0.1,
any.contravariant ==1.5.2,
contravariant +semigroups +statevar +tagged,
any.cubicbezier ==0.6.0.6,
cubicbezier -debug,
any.data-default ==0.7.1.1,
any.data-default-class ==0.1.2.0,
any.data-default-instances-containers ==0.0.1,
any.data-default-instances-dlist ==0.0.1,
any.data-default-instances-old-locale ==0.0.1,
any.deepseq ==1.4.4.0,
any.dequeue ==0.1.12,
any.diagrams-cairo ==1.4.1,
any.diagrams-contrib ==1.4.4,
any.diagrams-core ==1.4.2,
any.diagrams-lib ==1.4.3,
any.diagrams-solve ==0.1.1,
any.directory ==1.3.3.0,
any.distributive ==0.6.1,
distributive +semigroups +tagged,
any.dlist ==0.8.0.7,
any.dual-tree ==0.2.2.1,
any.enclosed-exceptions ==1.0.3,
any.exceptions ==0.10.3,
any.fast-math ==1.0.2,
any.filepath ==1.4.2.1,
any.fingertree ==0.1.4.2,
any.force-layout ==0.4.0.6,
any.free ==5.1.3,
any.fsnotify ==0.3.0.1,
any.ghc-boot-th ==8.6.5,
any.ghc-prim ==0.5.3,
any.gio ==0.13.6.1,
any.glib ==0.13.7.1,
glib +closure_signals,
any.groups ==0.4.1.0,
any.gtk ==0.15.3,
gtk +deprecated +fmode-binary +have-gio -have-quartz-gtk,
any.gtk2hs-buildtools ==0.13.5.4,
gtk2hs-buildtools +closuresignals,
any.happy ==1.19.12,
happy +small_base,
any.hashable ==1.2.7.0,
hashable -examples +integer-gmp +sse2 -sse41,
any.hashtables ==1.2.3.4,
hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks,
any.hinotify ==0.4,
any.integer-gmp ==1.0.2.0,
any.integer-logarithms ==1.0.3,
integer-logarithms -check-bounds +integer-gmp,
any.integration ==0.2.1,
any.intervals ==0.9,
intervals -herbie +test-doctests,
any.invariant ==0.5.3,
any.kan-extensions ==5.2,
any.lens ==4.17.1,
lens -benchmark-uniplate -dump-splices +inlining -j -old-inline-pragmas -safe +test-doctests +test-hunit +test-properties +test-templates +trustworthy,
any.lifted-async ==0.10.0.4,
any.lifted-base ==0.2.3.12,
any.linear ==1.20.9,
linear -herbie +template-haskell,
any.matrices ==0.5.0,
any.mfsolve ==0.3.2.0,
any.microlens ==0.4.11.2,
any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.2,
any.monad-control ==1.0.2.3,
any.monoid-extras ==0.5.1,
any.mtl ==2.2.2,
any.mtl-compat ==0.2.2,
mtl-compat -two-point-one -two-point-two,
any.newtype-generics ==0.5.4,
any.old-locale ==1.0.0.7,
any.optparse-applicative ==0.14.3.0,
any.pango ==0.13.6.1,
pango +new-exception,
any.parallel ==3.2.2.0,
any.parsec ==3.1.13.0,
any.pretty ==1.1.3.6,
any.primitive ==0.7.0.0,
any.process ==1.6.5.0,
any.profunctors ==5.5.1,
any.random ==1.1,
any.reflection ==2.1.5,
reflection -slow +template-haskell,
any.rts ==1.0,
any.safe ==0.3.17,
any.scientific ==0.3.6.2,
scientific -bytestring-builder -integer-simple,
any.semigroupoids ==5.3.4,
semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
any.semigroups ==0.19.1,
semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
any.shelly ==1.9.0,
shelly -build-examples -lifted,
any.split ==0.2.3.3,
any.splitmix ==0.0.3,
splitmix -optimised-mixer +random,
any.statestack ==0.2.0.5,
any.stm ==2.5.0.0,
any.tagged ==0.8.6,
tagged +deepseq +transformers,
any.template-haskell ==2.14.0.0,
any.text ==1.2.3.1,
any.th-abstraction ==0.3.1.0,
any.time ==1.8.0.2,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
transformers-base +orphaninstances,
any.transformers-compat ==0.6.5,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.type-equality ==1,
any.unix ==2.7.2.2,
any.unix-compat ==0.5.2,
unix-compat -old-time,
any.unordered-containers ==0.2.10.0,
unordered-containers -debug,
any.utf8-string ==1.0.1.1,
any.vector ==0.12.0.3,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-space ==0.16,
any.void ==0.7.3,
void -safe,
any.zlib ==0.6.2.1,
zlib -non-blocking-ffi -pkg-config

19
test_objs/testcube_trans.obj Normal file
View File

@ -0,0 +1,19 @@
v 9.0 10.0
v 11.0 10.0
v 9.0 11.0
v 11.0 11.0
v 9.0 11.0
v 11.0 11.0
v 9.0 10.0
v 11.0 10.0
f 1 2 4 3
f 3 4 6 5
f 5 6 8 7
f 7 8 2 1
f 2 8 6 4
f 7 1 3 5
cstype bezier
deg 3
curv 1 2 3 4
end