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:test_objs
Branches Tags
hasufell:master
hasufell:halfedge
hasufell:test_objs

1 Commits
master ... test_objs

Author SHA1 Message Date
hasufell e2c3ab3fe6 Add test objs 2015-01-18 19:28:46 +01:00
24 changed files with 488 additions and 974 deletions
Show Stats Expand all files Collapse all files

9
.gitignore vendored
View File

@ -11,12 +11,3 @@ dist/
# cabal
.cabal-sandbox/
cabal.sandbox.config
# profiling
*.prof
_darcs/
.liquid/
.stack-work/

21
Algebra/Polygon.hs
View File

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

180
Algebra/Vector.hs
View File

@ -8,10 +8,18 @@ import Control.Arrow ((***))
import Data.List (sortBy)
import Diagrams.Coordinates
import Diagrams.TwoD.Types
import Graphics.Gloss.Geometry.Line
import GHC.Float
import MyPrelude
type Vec = R2
type PT = P2
type Coord = (Double, Double)
type Segment = (PT, PT)
type Square = (Coord, Coord)
data Alignment = CW
| CCW
| CL
@ -23,14 +31,14 @@ data Alignment = CW
-- ((xmin, ymin), (xmax, ymax))
dimToSquare :: (Double, Double) -- ^ x 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))
-- |Checks whether the Point is in a given Square.
inRange :: ((Double, Double), (Double, Double)) -- ^ the square: ((xmin, ymin), (xmax, ymax))
-> P2 Double -- ^ Coordinate
-> Bool -- ^ result
inRange :: Square -- ^ the square: ((xmin, ymin), (xmax, ymax))
-> PT -- ^ Coordinate
-> Bool -- ^ result
inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
= x >= min xmin xmax
&& x <= max xmin xmax
@ -39,7 +47,7 @@ inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
-- |Get the angle between two vectors.
getAngle :: V2 Double -> V2 Double -> Double
getAngle :: Vec -> Vec -> Double
getAngle a b =
acos
. flip (/) (vecLength a * vecLength b)
@ -48,50 +56,62 @@ getAngle a b =
-- |Get the length of a vector.
vecLength :: V2 Double -> Double
vecLength :: Vec -> Double
vecLength v = sqrt (x^(2 :: Int) + y^(2 :: Int))
where
(x, y) = unr2 v
-- |Compute the scalar product of two vectors.
scalarProd :: V2 Double -> V2 Double -> Double
scalarProd (V2 a1 a2) (V2 b1 b2) = a1 * b1 + a2 * b2
scalarProd :: Vec -> Vec -> Double
scalarProd (R2 a1 a2) (R2 b1 b2) = a1 * b1 + a2 * b2
-- |Multiply a scalar with a vector.
scalarMul :: Double -> V2 Double -> V2 Double
scalarMul d (V2 a b) = V2 (a * d) (b * d)
scalarMul :: Double -> Vec -> Vec
scalarMul d (R2 a b) = R2 (a * d) (b * d)
-- |Construct a vector that points to a point from the origin.
pt2Vec :: P2 Double -> V2 Double
pt2Vec :: PT -> Vec
pt2Vec = r2 . unp2
-- |Give the point which is at the coordinates the vector
-- points to from the origin.
vec2Pt :: V2 Double -> P2 Double
vec2Pt :: Vec -> PT
vec2Pt = p2 . unr2
-- |Construct a vector between two points.
vp2 :: P2 Double -- ^ vector origin
-> P2 Double -- ^ vector points here
-> V2 Double
vp2 :: PT -- ^ vector origin
-> PT -- ^ vector points here
-> Vec
vp2 a b = pt2Vec b - pt2Vec a
-- |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) =
(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
-- case of end-points intersecting.
intersectSeg :: (P2 Double, P2 Double) -> (P2 Double, P2 Double) -> Maybe (P2 Double)
intersectSeg (a, b) (c, d) = case intersectSegSeg a b c d of
intersectSeg'' :: Segment -> Segment -> Maybe PT
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
Nothing -> Nothing
@ -100,7 +120,7 @@ intersectSeg (a, b) (c, d) = case intersectSegSeg a b c d of
-- * clock-wise
-- * counter-clock-wise
-- * 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
LT -> CW
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
--- connecting a-b-c. This is done by computing the determinant and
--- 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
CW -> False
_ -> 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
--- connecting a-b-c. This is done by computing the determinant and
--- 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
-- |Sort X and Y coordinates lexicographically.
sortedXY :: [P2 Double] -> [P2 Double]
sortedXY :: [PT] -> [PT]
sortedXY = fmap p2 . sortLex . fmap unp2
-- |Sort Y and X coordinates lexicographically.
sortedYX :: [P2 Double] -> [P2 Double]
sortedYX :: [PT] -> [PT]
sortedYX = fmap p2 . sortLexSwapped . fmap unp2
-- |Sort all points according to their X-coordinates only.
sortedX :: [P2 Double] -> [P2 Double]
sortedX :: [PT] -> [PT]
sortedX xs =
fmap p2
. sortBy (\(a1, _) (a2, _) -> compare a1 a2)
@ -142,7 +162,7 @@ sortedX xs =
-- |Sort all points according to their Y-coordinates only.
sortedY :: [P2 Double] -> [P2 Double]
sortedY :: [PT] -> [PT]
sortedY xs =
fmap p2
. sortBy (\(_, b1) (_, b2) -> compare b1 b2)
@ -150,125 +170,25 @@ sortedY xs =
-- |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
-- |Compare the y-coordinate of two points.
ptCmpY :: P2 Double -> P2 Double -> Ordering
ptCmpY :: PT -> PT -> Ordering
ptCmpY (coords -> _ :& y1) (coords -> _ :& y2) =
compare y1 y2
-- |Compare the x-coordinate of two points.
ptCmpX :: P2 Double -> P2 Double -> Ordering
ptCmpX :: PT -> PT -> Ordering
ptCmpX (coords -> x1 :& _) (coords -> x2 :& _) =
compare x1 x2
posInfPT :: P2 Double
posInfPT :: PT
posInfPT = p2 (read "Infinity", read "Infinity")
negInfPT :: P2 Double
negInfPT :: PT
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
import Algebra.Vector
import Diagrams.TwoD.Types
import MyPrelude
@ -75,18 +74,18 @@ ys = []
return [(100, 100), (400, 200)]
=========================================================
--}
grahamCH :: [P2 Double] -> [P2 Double]
grahamCH :: [PT] -> [PT]
grahamCH vs = grahamUCH vs ++ (tailInit . grahamLCH $ vs)
-- |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)
(first reverse . splitAt 3 . sortedXY $ vs)
-- |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)
(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.
-- Also, the first list is expected to be reversed since we only care
-- about the last 3 elements and want to stay efficient.
scanH :: [P2 Double] -- ^ the first 3 starting points in reversed order
-> [P2 Double] -- ^ the rest of the points
-> [[P2 Double]] -- ^ all convex hull points iterations for the half
scanH :: [PT] -- ^ the first 3 starting points in reversed order
-> [PT] -- ^ the rest of the points
-> [[PT]] -- ^ all convex hull points iterations for the half
scanH hs@(x:y:z:xs) (r':rs')
| notcw z y x = hs : scanH (r':hs) 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
-- visualizing it.
-- 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'
-- |Get all iterations of the upper hull of the graham scan algorithm.
grahamUHSteps :: [P2 Double] -> [[P2 Double]]
grahamUHSteps :: [PT] -> [[PT]]
grahamUHSteps vs =
(++) [getLastX 2 . sortedXY $ vs]
. rmdups
@ -128,7 +127,7 @@ grahamUHSteps vs =
-- |Get all iterations of the lower hull of the graham scan algorithm.
grahamLHSteps :: [P2 Double] -> [[P2 Double]]
grahamLHSteps :: [PT] -> [[PT]]
grahamLHSteps vs =
(++) [take 2 . sortedXY $ vs]
. 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).
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
-> KDTree (P2 Double) -- ^ resulting kd-tree
-> KDTree PT -- ^ resulting kd-tree
kdTree xs' = go (sortedX xs') (sortedY xs')
where
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
-- partition' (pivot xs) (ys, xs)
-- and get ((y1, y2), (x1, x2)).
partition' :: P2 Double -- ^ the pivot to partition against
-> (P2 Double -> P2 Double -> Ordering) -- ^ ptCmpY or ptCmpX
-> ([P2 Double], [P2 Double]) -- ^ both lists (X, Y) or (Y, X)
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2)) or
partition' :: PT -- ^ the pivot to partition against
-> (PT -> PT -> Ordering) -- ^ ptCmpY or ptCmpX
-> ([PT], [PT]) -- ^ both lists (X, Y) or (Y, X)
-> (([PT], [PT]), ([PT], [PT])) -- ^ ((x1, x2), (y1, y2)) or
-- ((y1, y2), (x1, x2))
partition' piv cmp' (xs, ys) = ((x1, x2), (y1, y2))
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
-- Y. This function is unsafe as it does not check if there is a valid
-- pivot.
partitionY :: ([P2 Double], [P2 Double]) -- ^ both lists (X, Y)
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2))
partitionY :: ([PT], [PT]) -- ^ both lists (X, Y)
-> (([PT], [PT]), ([PT], [PT])) -- ^ ((x1, x2), (y1, y2))
partitionY (xs, ys) = partition' (fromJust . pivot $ ys) ptCmpY (xs, ys)
-- |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
-- pivot.
partitionX :: ([P2 Double], [P2 Double]) -- ^ both lists (X, Y)
-> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2))
partitionX :: ([PT], [PT]) -- ^ both lists (X, Y)
-> (([PT], [PT]), ([PT], [PT])) -- ^ ((x1, x2), (y1, y2))
partitionX (xs, ys) = (\(x, y) -> (y, x))
. 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
-- of the points found in the range and also gives back a pretty
-- rose tree suitable for printing.
rangeSearch :: KDTree (P2 Double) -- ^ tree to search in
-> ((Double, Double), (Double, Double)) -- ^ square describing the range
-> ([P2 Double], Tree String)
rangeSearch :: KDTree PT -> Square -> ([PT], Tree String)
rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
where
-- either y1 or x1 depending on the orientation
@ -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
cur' dir = if' (dir == Vertical) snd fst
-- All points in the range.
goPt :: KDTree (P2 Double) -> ((Double, Double), (Double, Double)) -> [P2 Double]
goPt :: KDTree PT -> Square -> [PT]
goPt KTNil _ = []
goPt (KTNode ln pt dir rn) sq =
[pt | inRange sq pt]
@ -124,7 +122,7 @@ rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
(goPt rn sq)
[])
-- 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 (KTNode ln pt dir rn) sq vis
| ln == KTNil && rn == KTNil = Node treeText []
@ -181,7 +179,7 @@ getDirection _ = Nothing
-- |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 (KTNode ln val _ rn) =
Node (show . unp2 $ val) [kdTreeToRoseTree ln, kdTreeToRoseTree rn]

44
Algorithms/PolygonIntersection.hs
View File

@ -18,14 +18,14 @@ import QueueEx
-- successor are saved for convenience.
data PolyPT =
PolyA {
id' :: P2 Double
, pre :: P2 Double
, suc :: P2 Double
id' :: PT
, pre :: PT
, suc :: PT
}
| PolyB {
id' :: P2 Double
, pre :: P2 Double
, suc :: P2 Double
id' :: PT
, pre :: PT
, suc :: PT
}
deriving (Show, Eq)
@ -42,7 +42,7 @@ isPolyB = not . isPolyA
-- |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.
-- This is done in O(n).
sortLexPoly :: [P2 Double] -> [P2 Double]
sortLexPoly :: [PT] -> [PT]
sortLexPoly ps = maybe [] (`shiftM` ps) (elemIndex (yMax ps) ps)
where
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
-- the predecessor and successors are all saved.
mkPolyPTList :: (P2 Double -> P2 Double -> P2 Double -> PolyPT) -- ^ PolyA or PolyB function
-> [P2 Double] -- ^ polygon points
mkPolyPTList :: (PT -> PT -> PT -> PolyPT) -- ^ PolyA or PolyB function
-> [PT] -- ^ polygon points
-> [PolyPT]
mkPolyPTList f' pts@(x':y':_:_) =
f' x' (last pts) y' : go f' pts
@ -64,7 +64,7 @@ mkPolyPTList _ _ = []
-- |Sort the points of two polygons according to their y-coordinates,
-- 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'@(_:_)) =
queueToList $ go (Q.fromList . mkPolyPTList PolyA . sortLexPoly $ pA')
(Q.fromList . mkPolyPTList PolyB . sortLexPoly $ pB')
@ -84,11 +84,11 @@ sortLexPolys (pA'@(_:_), pB'@(_:_)) =
-- queue and traverse the rest.
| ptCmpY (fromMaybe negInfPT (id' <$> Q.first pA))
(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)
-- Same as above, except that the current point of polygon B
-- 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)
-- 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
-- in O(n).
intersectionPoints :: [PolyPT] -> [P2 Double]
intersectionPoints :: [PolyPT] -> [PT]
intersectionPoints xs' = rmdups . go $ xs'
where
go [] = []
@ -113,7 +113,7 @@ intersectionPoints xs' = rmdups . go $ xs'
-- Get the scan line or in other words the
-- 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)
where
getSegment f = fromMaybe []
@ -124,10 +124,10 @@ intersectionPoints xs' = rmdups . go $ xs'
-- Gets the actual intersections between the segments of
-- both polygons we currently examine. This is done in O(1)
-- since we have max 4 segments.
segIntersections :: ([(P2 Double, P2 Double)], [(P2 Double, P2 Double)]) -> [P2 Double]
segIntersections :: ([Segment], [Segment]) -> [PT]
segIntersections (a@(_:_), b@(_:_)) =
catMaybes
. fmap (\[(x1, y1), (x2, y2)] -> intersectSegSeg x1 y1 x2 y2)
. fmap (\[x, y] -> intersectSeg' x y)
$ combinations a b
segIntersections _ = []
@ -136,3 +136,15 @@ intersectionPoints xs' = rmdups . go $ xs'
combinations :: [a] -> [a] -> [[a]]
combinations xs ys = concat . fmap (\y -> fmap (\x -> [y, x]) xs) $ ys
testArr :: ([PT], [PT])
testArr = ([p2 (200.0, 500.0),
p2 (0.0, 200.0),
p2 (200.0, 100.0),
p2 (400.0, 300.0)],
[p2 (350.0, 450.0),
p2 (275.0, 225.0),
p2 (350.0, 50.0),
p2 (500.0, 0.0),
p2 (450.0, 400.0)])

71
Algorithms/PolygonTriangulation.hs
View File

@ -6,7 +6,6 @@ import Algebra.Polygon
import Algebra.Vector
import qualified Control.Arrow as A
import Data.Maybe
import Diagrams.TwoD.Types
import Safe
@ -19,12 +18,12 @@ data VCategory = VStart
-- |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:_:_) =
-- need to handle the first and last element separately
[classify (last p) x y] ++ go p ++ [classify (last . init $ p) (last p) x]
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 _ = []
classifyList _ = []
@ -32,10 +31,10 @@ classifyList _ = []
-- |Classify a vertex on a polygon given it's next and previous vertex
-- into five categories (see VCategory).
classify :: P2 Double -- ^ prev vertex
-> P2 Double -- ^ classify this one
-> P2 Double -- ^ next vertex
-> (P2 Double, VCategory)
classify :: PT -- ^ prev vertex
-> PT -- ^ classify this one
-> PT -- ^ next vertex
-> (PT, VCategory)
classify prev v next
| isVStart prev v next = (v, VStart)
| isVSplit prev v next = (v, VSplit)
@ -46,9 +45,9 @@ classify prev v next
-- |Whether the vertex, given it's next and previous vertex,
-- is a start vertex.
isVStart :: P2 Double -- ^ previous vertex
-> P2 Double -- ^ vertice to check
-> P2 Double -- ^ next vertex
isVStart :: PT -- ^ previous vertex
-> PT -- ^ vertice to check
-> PT -- ^ next vertex
-> Bool
isVStart prev v next =
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,
-- is a split vertex.
isVSplit :: P2 Double -- ^ previous vertex
-> P2 Double -- ^ vertice to check
-> P2 Double -- ^ next vertex
isVSplit :: PT -- ^ previous vertex
-> PT -- ^ vertice to check
-> PT -- ^ next vertex
-> Bool
isVSplit 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,
-- is an end vertex.
isVEnd :: P2 Double -- ^ previous vertex
-> P2 Double -- ^ vertice to check
-> P2 Double -- ^ next vertex
isVEnd :: PT -- ^ previous vertex
-> PT -- ^ vertice to check
-> PT -- ^ next vertex
-> Bool
isVEnd prev v next =
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,
-- is a merge vertex.
isVMerge :: P2 Double -- ^ previous vertex
-> P2 Double -- ^ vertice to check
-> P2 Double -- ^ next vertex
isVMerge :: PT -- ^ previous vertex
-> PT -- ^ vertice to check
-> PT -- ^ next vertex
-> Bool
isVMerge 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,
-- is a regular vertex.
isVRegular :: P2 Double -- ^ previous vertex
-> P2 Double -- ^ vertice to check
-> P2 Double -- ^ next vertex
isVRegular :: PT -- ^ previous vertex
-> PT -- ^ vertice to check
-> PT -- ^ next vertex
-> Bool
isVRegular 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.
isYmonotone :: [P2 Double] -> Bool
isYmonotone :: [PT] -> Bool
isYmonotone poly =
not
. any (\x -> x == VSplit || x == VMerge)
@ -108,12 +107,12 @@ isYmonotone poly =
-- |Partition P into y-monotone pieces.
monotonePartitioning :: [P2 Double] -> [[P2 Double]]
monotonePartitioning :: [PT] -> [[PT]]
monotonePartitioning pts
| isYmonotone pts = [pts]
| otherwise = go (monotoneDiagonals pts) pts
where
go :: [(P2 Double, P2 Double)] -> [P2 Double] -> [[P2 Double]]
go :: [Segment] -> [PT] -> [[PT]]
go (x:xs) pts'@(_:_)
| isYmonotone a && isYmonotone b = [a, b]
| isYmonotone b = b : go xs a
@ -125,37 +124,37 @@ monotonePartitioning pts
-- |Try to eliminate the merge and split vertices by computing the
-- 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
where
go :: [(P2 Double, VCategory)] -> [Maybe (P2 Double, P2 Double)]
go :: [(PT, VCategory)] -> [Maybe Segment]
go (x:xs) = case snd x of
VMerge -> getSeg (belowS . fst $ x) (fst x) : go xs
VSplit -> getSeg (aboveS . fst $ x) (fst x) : go xs
_ -> [] ++ go xs
go [] = []
getSeg :: [P2 Double] -- all points above/below the current point
-> P2 Double -- current point
-> Maybe (P2 Double, P2 Double)
getSeg :: [PT] -- all points above/below the current point
-> PT -- current point
-> Maybe Segment
getSeg [] _ = Nothing
getSeg (z:zs) pt
| isInsidePoly pts (z, pt) = Just (z, pt)
| otherwise = getSeg zs pt
aboveS :: P2 Double -> [P2 Double]
aboveS :: PT -> [PT]
aboveS pt = tail . dropWhile (/= pt) $ sortedYX pts
belowS :: P2 Double -> [P2 Double]
belowS :: PT -> [PT]
belowS pt = reverse . takeWhile (/= pt) $ sortedYX pts
-- |Triangulate a y-monotone polygon.
triangulate :: [P2 Double] -> [[P2 Double]]
triangulate :: [PT] -> [[PT]]
triangulate pts =
go pts . A.first reverse . splitAt 3 . reverse . sortedYX $ pts
where
go :: [P2 Double] -- current polygon
-> ([P2 Double], [P2 Double]) -- (stack of visited vertices, rest)
go :: [PT] -- current polygon
-> ([PT], [PT]) -- (stack of visited vertices, rest)
-- sorted by Y-coordinate
-> [[P2 Double]]
-> [[PT]]
go xs (p@[_, _], r:rs) = go xs (r:p, rs)
go xs (p@(u:vi:vi1:ys), rs)
-- 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.
nwSq, neSq, swSq, seSq :: ((Double, Double), (Double, Double)) -- ^ current square
-> ((Double, Double), (Double, Double)) -- ^ sub-square
nwSq, neSq, swSq, seSq :: Square -> Square
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)
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
-- space into quadrants, so that every leaf-quadrant stores either zero or one
-- point.
quadTree :: [P2 Double] -- ^ the points to divide
-> ((Double, Double), (Double, Double)) -- ^ the initial square around the points
-> QuadTree (P2 Double) -- ^ the quad tree
quadTree :: [PT] -- ^ the points to divide
-> Square -- ^ the initial square around the points
-> QuadTree PT -- ^ the quad tree
quadTree [] _ = TNil
quadTree [pt] _ = TLeaf pt
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.
quadTreeSquares :: ((Double, Double), (Double, Double)) -- ^ the initial square around the points
-> QuadTree (P2 Double) -- ^ the quad tree
-> [((Double, Double), (Double, Double))] -- ^ all squares of the quad tree
quadTreeSquares :: Square -- ^ the initial square around the points
-> QuadTree PT -- ^ the quad tree
-> [Square] -- ^ all squares of the quad tree
quadTreeSquares sq (TNil) = [sq]
quadTreeSquares sq (TLeaf _) = [sq]
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
-- square.
getSquareByZipper :: ((Double, Double), (Double, Double)) -- ^ top square
-> QTZipper a
-> ((Double, Double), (Double, Double)) -- ^ current square
getSquareByZipper :: Square -> QTZipper a -> Square
getSquareByZipper sq z = go sq (reverse . snd $ z)
where
go sq' [] = sq'
@ -203,7 +200,7 @@ lookupByNeighbors :: [Orient] -> QTZipper a -> Maybe (QTZipper a)
lookupByNeighbors = flip (foldlM (flip findNeighbor))
quadTreeToRoseTree :: QTZipper (P2 Double) -> Tree String
quadTreeToRoseTree :: QTZipper PT -> Tree String
quadTreeToRoseTree z' = go (rootNode z')
where
go z = case z of

54
CG2.cabal
View File

@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
-- The name of the package.
name: CG2
name: CGA
-- The package version. See the Haskell package versioning policy (PVP)
-- for standards guiding when and how versions should be incremented.
@ -65,7 +65,6 @@ executable Gtk
Graphics.Diagram.Core
Graphics.Diagram.Gtk
Graphics.Diagram.Plotter
Graphics.HalfEdge
GUI.Gtk
MyPrelude
Parser.Meshparser
@ -77,19 +76,21 @@ executable Gtk
-- Other library packages from which modules are imported.
build-depends: attoparsec >= 0.12.1.1,
base >=4.6,
base >=4.6 && <4.8,
bytestring >= 0.10.4.0,
containers >= 0.5.0.0,
dequeue >= 0.1.12,
diagrams-lib >=1.3,
diagrams-cairo >=1.3,
diagrams-contrib >= 1.3.0.0,
directory >=1.2,
dequeue >= 0.1.5,
diagrams-lib >=1.2 && <1.3,
diagrams-cairo >=1.2 && <1.3,
diagrams-contrib >= 1.1.2.1,
directory >=1.2 && <1.3,
filepath >= 1.3.0.2,
glib >=0.13,
gtk >=0.12,
glade >=0.12 && <0.13,
gloss >= 1.2.0.1,
gtk >=0.12 && <0.13,
multiset-comb >= 0.2.1,
safe >= 0.3.8,
transformers >=0.4
transformers >=0.4 && <0.5
-- Directories containing source files.
-- hs-source-dirs:
@ -114,7 +115,6 @@ executable Gif
Graphics.Diagram.Core
Graphics.Diagram.Gif
Graphics.Diagram.Plotter
Graphics.HalfEdge
MyPrelude
Parser.Meshparser
Parser.PathParser
@ -126,16 +126,18 @@ executable Gif
-- Other library packages from which modules are imported.
build-depends: attoparsec >= 0.12.1.1,
base >=4.6,
base >=4.6 && <4.8,
bytestring >= 0.10.4.0,
containers >= 0.5.0.0,
dequeue >= 0.1.12,
diagrams-lib >=1.3,
diagrams-cairo >=1.3,
diagrams-contrib >= 1.3.0.0,
dequeue >= 0.1.5,
diagrams-lib >=1.2 && <1.3,
diagrams-cairo >=1.2 && <1.3,
diagrams-contrib >= 1.1.2.1,
gloss >= 1.2.0.1,
JuicyPixels >= 3.1.7.1,
safe >= 0.3.8,
transformers >=0.4
multiset-comb >= 0.2.1,
transformers >=0.4 && <0.5,
safe >= 0.3.8
-- Directories containing source files.
-- hs-source-dirs:
@ -160,7 +162,6 @@ executable Test
Graphics.Diagram.Core
Graphics.Diagram.Gif
Graphics.Diagram.Plotter
Graphics.HalfEdge
MyPrelude
Parser.Meshparser
Parser.PathParser
@ -174,15 +175,18 @@ executable Test
-- Other library packages from which modules are imported.
build-depends: attoparsec >= 0.12.1.1,
base >=4.6,
base >=4.6 && <4.8,
bytestring >= 0.10.4.0,
containers >= 0.5.0.0,
dequeue >= 0.1.12,
diagrams-lib >=1.3,
diagrams-cairo >=1.3,
diagrams-contrib >= 1.3.0.0,
dequeue >= 0.1.5,
diagrams-lib >=1.2 && <1.3,
diagrams-cairo >=1.2 && <1.3,
diagrams-contrib >= 1.1.2.1,
gloss >= 1.2.0.1,
JuicyPixels >= 3.1.7.1,
multiset-comb >= 0.2.1,
QuickCheck >= 2.4.2,
transformers >=0.4 && <0.5,
safe >= 0.3.8
-- Directories containing source files.

77
GUI/Gtk.hs
View File

@ -14,11 +14,10 @@ import Diagrams.Backend.Cairo.Internal
import Graphics.Diagram.Core (DiagProp(..))
import Graphics.Diagram.Gtk
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Builder
import Graphics.UI.Gtk.Glade
import MyPrelude
import System.Directory
import System.FilePath.Posix
import System.Glib.UTFString
import Text.Read
@ -64,9 +63,9 @@ data MyGUI = MkMyGUI {
-- |Path entry widget for the quad tree.
quadPathEntry :: Entry,
-- |Horizontal box containing the path entry widget.
vbox7 :: Graphics.UI.Gtk.Box,
vbox7 :: Box,
-- |Horizontal box containing the Rang search entry widgets.
vbox10 :: Graphics.UI.Gtk.Box,
vbox10 :: Box,
-- |Range entry widget for lower x bound
rangeXminEntry :: Entry,
-- |Range entry widget for upper x bound
@ -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.
makeMyGladeGUI :: IO MyGUI
makeMyGladeGUI = do
-- load glade file
builder <- builderNew
builderAddFromFile builder "GUI/gtk2.xml"
Just xml <- xmlNew gladeFile
MkMyGUI
<$> builderGetObject builder castToWindow "window1"
<*> builderGetObject builder castToWindow "window2"
<*> builderGetObject builder castToButton "drawButton"
<*> builderGetObject builder castToButton "saveButton"
<*> builderGetObject builder castToButton "quitButton"
<*> builderGetObject builder castToFileChooserButton "filechooserButton"
<*> builderGetObject builder castToDrawingArea "drawingarea"
<*> builderGetObject builder castToDrawingArea "treedrawingarea"
<*> builderGetObject builder castToHScale "hscale"
<*> builderGetObject builder castToEntry "xlD"
<*> builderGetObject builder castToEntry "xuD"
<*> builderGetObject builder castToEntry "ylD"
<*> builderGetObject builder castToEntry "yuD"
<*> builderGetObject builder castToAboutDialog "aboutdialog"
<*> builderGetObject builder castToComboBox "comboalgo"
<*> builderGetObject builder castToCheckButton "gridcheckbutton"
<*> builderGetObject builder castToCheckButton "coordcheckbutton"
<*> builderGetObject builder castToEntry "path"
<*> builderGetObject builder castToBox "vbox7"
<*> builderGetObject builder castToBox "vbox10"
<*> builderGetObject builder castToEntry "rxMin"
<*> builderGetObject builder castToEntry "rxMax"
<*> builderGetObject builder castToEntry "ryMin"
<*> builderGetObject builder castToEntry "ryMax"
<$> xmlGetWidget xml castToWindow "window1"
<*> xmlGetWidget xml castToWindow "window2"
<*> xmlGetWidget xml castToButton "drawButton"
<*> xmlGetWidget xml castToButton "saveButton"
<*> xmlGetWidget xml castToButton "quitButton"
<*> xmlGetWidget xml castToFileChooserButton "filechooserButton"
<*> xmlGetWidget xml castToDrawingArea "drawingarea"
<*> xmlGetWidget xml castToDrawingArea "treedrawingarea"
<*> xmlGetWidget xml castToHScale "hscale"
<*> xmlGetWidget xml castToEntry "xlD"
<*> xmlGetWidget xml castToEntry "xuD"
<*> xmlGetWidget xml castToEntry "ylD"
<*> xmlGetWidget xml castToEntry "yuD"
<*> xmlGetWidget xml castToAboutDialog "aboutdialog"
<*> xmlGetWidget xml castToComboBox "comboalgo"
<*> xmlGetWidget xml castToCheckButton "gridcheckbutton"
<*> xmlGetWidget xml castToCheckButton "coordcheckbutton"
<*> xmlGetWidget xml castToEntry "path"
<*> xmlGetWidget xml castToBox "vbox7"
<*> xmlGetWidget xml castToBox "vbox10"
<*> xmlGetWidget xml castToEntry "rxMin"
<*> xmlGetWidget xml castToEntry "rxMax"
<*> xmlGetWidget xml castToEntry "ryMin"
<*> xmlGetWidget xml castToEntry "ryMax"
-- |Main entry point for the GTK GUI routines.
@ -155,23 +158,23 @@ makeGUI startFile = do
-- hotkeys
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
"q" <- eventKeyName
liftIO mainQuit
_ <- treeWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
"q" <- eventKeyName
liftIO (widgetHide $ treeWin mygui)
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"s" <- fmap glibToString eventKeyName
"s" <- eventKeyName
liftIO $ saveDiag mygui
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"d" <- fmap glibToString eventKeyName
"d" <- eventKeyName
liftIO $ drawDiag mygui
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"a" <- fmap glibToString eventKeyName
"a" <- eventKeyName
liftIO $ widgetShowAll (aboutDialog mygui)
-- draw widgets and start main loop
@ -296,9 +299,9 @@ saveAndDrawDiag fp fps mygui =
renderDiag winWidth winHeight buildDiag =
renderDia Cairo
(CairoOptions fps
(mkSizeSpec2D (Just $ fromIntegral winWidth) (Just $ fromIntegral winHeight))
(Dims (fromIntegral winWidth) (fromIntegral winHeight))
SVG False)
(buildDiag (MyPrelude.def{
(buildDiag (def{
dotSize = scaleVal,
xDimension = fromMaybe (0, 500) xDim,
yDimension = fromMaybe (0, 500) yDim,

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

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

22
Graphics/Diagram/AlgoDiags.hs
View File

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

59
Graphics/Diagram/Core.hs
View File

@ -15,18 +15,18 @@ data Diag =
Diag
{
mkDiag :: DiagProp
-> [[P2 Double]]
-> Diagram Cairo
-> [[PT]]
-> Diagram Cairo R2
}
| GifDiag
{
mkGifDiag :: DiagProp
-> Colour Double
-> ([P2 Double] -> [[P2 Double]])
-> [P2 Double]
-> [Diagram Cairo]
-> ([PT] -> [[PT]])
-> [PT]
-> [Diagram Cairo R2]
}
| EmptyDiag (Diagram Cairo)
| EmptyDiag (Diagram Cairo R2)
-- |Holds the properties for a Diagram, like thickness of 2d points etc.
@ -49,7 +49,7 @@ data DiagProp = MkProp {
-- |The path to a quad in the quad tree.
quadPath :: String,
-- |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
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
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
@ -135,33 +134,33 @@ maybeDiag b d
| otherwise = mempty
filterValidPT :: DiagProp -> [P2 Double] -> [P2 Double]
filterValidPT :: DiagProp -> [PT] -> [PT]
filterValidPT =
filter
. inRange
. diagDimSquare
diagDimSquare :: DiagProp -> ((Double, Double), (Double, Double))
diagDimSquare :: DiagProp -> Square
diagDimSquare p = dimToSquare (xDimension p) $ yDimension p
-- |Draw a list of points.
drawP :: [P2 Double] -- ^ the points to draw
drawP :: [PT] -- ^ the points to draw
-> Double -- ^ dot size
-> Diagram Cairo -- ^ the resulting diagram
-> Diagram Cairo R2 -- ^ the resulting diagram
drawP [] _ = mempty
drawP vt ds =
position (zip vt (repeat dot))
where
dot = circle ds :: Diagram Cairo
dot = circle ds :: Diagram Cairo R2
-- |Create a rectangle around a diagonal line, which has sw
-- as startpoint and nw as endpoint.
rectByDiagonal :: (Double, Double) -- ^ sw point
-> (Double, Double) -- ^ nw point
-> Diagram Cairo
-> Diagram Cairo R2
rectByDiagonal (xmin, ymin) (xmax, ymax) =
fromVertices [p2 (xmin, ymin)
, p2 (xmax, ymin)
@ -173,7 +172,7 @@ rectByDiagonal (xmin, ymin) (xmax, ymax) =
-- |Creates a Diagram from a point that shows the coordinates
-- in text format, such as "(1.0, 2.0)".
pointToTextCoord :: P2 Double -> Diagram Cairo
pointToTextCoord :: PT -> Diagram Cairo R2
pointToTextCoord pt =
text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
where

6
Graphics/Diagram/Gif.hs
View File

@ -2,7 +2,7 @@
module Graphics.Diagram.Gif where
import Algebra.Vector
import Algebra.Vector(PT)
import Algorithms.GrahamScan
import Codec.Picture.Gif
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.
gifDiag :: DiagProp -> [P2 Double] -> [(Diagram Cairo, GifDelay)]
gifDiag :: DiagProp -> [PT] -> [(Diagram Cairo R2, GifDelay)]
gifDiag p xs =
fmap ((\x -> (x, 50)) . (<> nonChDiag))
(upperHullList
@ -35,5 +35,5 @@ gifDiag p xs =
-- |Same as gifDiag, except that it takes a string containing the
-- mesh file content instead of the the points.
gifDiagS :: DiagProp -> B.ByteString -> [(Diagram Cairo, GifDelay)]
gifDiagS :: DiagProp -> B.ByteString -> [(Diagram Cairo R2, GifDelay)]
gifDiagS p = gifDiag p . filterValidPT p . meshToArr

12
Graphics/Diagram/Gtk.hs
View File

@ -2,7 +2,7 @@
module Graphics.Diagram.Gtk where
import Algebra.Vector
import Algebra.Vector(PT)
import qualified Data.ByteString.Char8 as B
import Data.List(find)
import Diagrams.Backend.Cairo
@ -46,7 +46,7 @@ diagTreAlgos =
-- |Create the Diagram from the points.
diag :: DiagProp -> [DiagAlgo] -> [[P2 Double]] -> Diagram Cairo
diag :: DiagProp -> [DiagAlgo] -> [[PT]] -> Diagram Cairo R2
diag p das vts = maybe mempty (\x -> mkDiag x p vts)
$ mconcat
-- get the actual [Diag] array
@ -58,22 +58,22 @@ diag p das vts = maybe mempty (\x -> mkDiag x p vts)
-- |Create the Diagram from a String which is supposed to be the contents
-- of an obj file.
diagS :: DiagProp -> B.ByteString -> Diagram Cairo
diagS :: DiagProp -> B.ByteString -> Diagram Cairo R2
diagS p mesh =
diag p diagAlgos
. fmap (filterValidPT p)
. (\x -> if null x then [meshToArr mesh] else x)
. parseObj
. facesToArr
$ mesh
-- |Create the tree diagram from a String which is supposed to be the contents
-- of an obj file.
diagTreeS :: DiagProp -> B.ByteString -> Diagram Cairo
diagTreeS :: DiagProp -> B.ByteString -> Diagram Cairo R2
diagTreeS p mesh =
diag p diagTreAlgos
. fmap (filterValidPT p)
. (\x -> if null x then [meshToArr mesh] else x)
. parseObj
. facesToArr
$ mesh

2
Graphics/Diagram/Plotter.hs
View File

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

242
Graphics/HalfEdge.hs
View File

@ -1,242 +0,0 @@
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides methods to build a cyclic half-edge data structure
-- from an already parsed obj mesh file. As such, it depends on details
-- of the parsed data.
--
-- In particular, 'indirectHeFaces', 'indirectHeVerts' and 'indirectToDirect'
-- assume specific structure of some input lists. Check their respective
-- documentation.
--
-- As the data structure has a lot of cross-references and the knots are
-- not really known at compile-time, we have to use helper data structures
-- such as lists and maps under the hood and tie the knots through
-- index lookups.
--
-- For an explanation of the abstract concept of the half-edge data structure,
-- check <http://www.flipcode.com/archives/The_Half-Edge_Data_Structure.shtml>
module Graphics.HalfEdge (
HeVert(..)
, HeFace(..)
, HeEdge(..)
, buildHeEdge
, buildHeEdgeFromStr
) where
import Algebra.Vector
import Control.Applicative
import Control.Monad
import qualified Data.ByteString.Char8 as B
import qualified Data.IntMap.Lazy as Map
import Data.Maybe
import Diagrams.TwoD.Types
import Parser.Meshparser
import Safe
-- |The vertex data structure for the half-edge.
data HeVert a = HeVert {
vcoord :: a -- the coordinates of the vertex
, emedge :: HeEdge a -- one of the half-edges emanating from the vertex
} | NoVert
-- |The face data structure for the half-edge.
data HeFace a = HeFace {
bordedge :: HeEdge a -- one of the half-edges bordering the face
} | NoFace
-- |The actual half-edge data structure.
data HeEdge a = HeEdge {
startvert :: HeVert a -- start-vertex of the half-edge
, oppedge :: HeEdge a -- oppositely oriented adjacent half-edge
, edgeface :: HeFace a -- face the half-edge borders
, nextedge :: HeEdge a -- next half-edge around the face
} | NoEdge
-- This is a helper data structure of half-edge edges
-- for tying the knots in 'indirectToDirect'.
data IndirectHeEdge = IndirectHeEdge {
edgeindex :: Int -- edge index
, svindex :: Int -- index of start-vertice
, nvindex :: Int -- index of next-vertice
, indexf :: Int -- index of face
, offsetedge :: Int -- offset to get the next edge
} deriving (Show)
-- This is a helper data structure of half-edge vertices
-- for tying the knots in 'indirectToDirect'.
data IndirectHeVert = IndirectHeVert {
emedgeindex :: Int -- emanating edge index (starts at 1)
, edgelist :: [Int] -- index of edge that points to this vertice
} deriving (Show)
-- This is a helper data structure of half-edge faces
-- for tying the knots in 'indirectToDirect'.
data IndirectHeFace =
IndirectHeFace (Int, [Int]) -- (faceIndex, [verticeindex])
deriving (Show)
-- |Construct the indirect data structure for half-edge faces.
-- This function assumes that the input faces are parsed exactly like so:
--
-- @
-- f 1 3 4 5
-- f 4 6 1 3
-- @
--
-- becomes
--
-- > [[1,3,4,5],[4,6,1,3]]
indirectHeFaces :: [[Int]] -- ^ list of faces with their respective
-- list of vertice-indices
-> [IndirectHeFace]
indirectHeFaces = fmap IndirectHeFace . zip [0..]
-- |Construct the indirect data structure for half-edge edges.
indirectHeEdges :: [IndirectHeFace] -> [IndirectHeEdge]
indirectHeEdges = concat . fmap indirectHeEdge
where
indirectHeEdge :: IndirectHeFace -> [IndirectHeEdge]
indirectHeEdge (IndirectHeFace (_, [])) = []
indirectHeEdge p@(IndirectHeFace (_, pv@(v:_))) = go p 0
where
go (IndirectHeFace (_, [])) _
= []
-- connect last to first element
go (IndirectHeFace (fi, [vlast])) ei
= [IndirectHeEdge ei vlast v fi (negate $ length pv - 1)]
-- regular non-last element
go (IndirectHeFace (fi, vfirst:vnext:vrest)) ei
= (:) (IndirectHeEdge ei vfirst vnext fi 1)
(go (IndirectHeFace (fi, vnext:vrest)) (ei + 1))
-- |Construct the indirect data structure for half-edge vertices.
-- It is assumed that the list of points is indexed in order of their
-- appearance in the obj mesh file.
indirectHeVerts :: [IndirectHeEdge] -- ^ list of indirect edges
-> Map.IntMap IndirectHeVert -- ^ output map, starts at index 1
indirectHeVerts hes' = go hes' Map.empty 0
where
go [] map' _ = map'
go (IndirectHeEdge _ _ nv _ offset:hes) map' i
= go hes
(Map.alter updateMap nv map')
(i + 1)
where
updateMap (Just (IndirectHeVert _ xs))
= Just (IndirectHeVert (i + offset) (i:xs))
updateMap Nothing
= Just (IndirectHeVert (i + offset) [i])
-- |Tie the knots!
-- It is assumed that the list of points is indexed in order of their
-- appearance in the obj mesh file.
--
-- pseudo-code:
--
-- @
-- indirectToDirect :: [a] -- parsed vertices, e.g. 2d points (Double, Double)
-- -> [IndirectHeEdge]
-- -> [IndirectHeFace]
-- -> [IndirectHeVert]
-- -> HeEdge a
-- indirectToDirect points edges faces vertices
-- = thisEdge (head edges)
-- where
-- thisEdge edge
-- = HeEdge (thisVert (vertices !! svindex edge) $ svindex edge)
-- (thisOppEdge (svindex edge) $ indexf edge)
-- (thisFace $ faces !! indexf edge)
-- (thisEdge $ edges !! (edgeindex edge + offsetedge edge))
-- thisFace face = HeFace $ thisEdge (edges !! (head . snd $ face))
-- thisVert vertice coordindex
-- = HeVert (points !! (coordindex - 1))
-- (thisEdge $ points !! (emedgeindex vertice - 1))
-- thisOppEdge startverticeindex faceindex
-- = case headMay
-- . filter ((/=) faceindex . indexf)
-- . fmap (edges !!)
-- . edgelist -- getter
-- $ vertices !! startverticeindex
-- of Just x -> thisEdge x
-- Nothing -> NoEdge
-- @
indirectToDirect :: [a] -- ^ list of points
-> [IndirectHeEdge]
-> [IndirectHeFace]
-> Map.IntMap IndirectHeVert -- ^ assumed to start at index 1
-> HeEdge a
indirectToDirect pts pe@(e:_) fs vertmap
= thisEdge e
where
thisEdge (IndirectHeEdge ei sv _ fi off)
= case (fs `atMay` fi, pe `atMay` (ei + off), Map.lookup sv vertmap) of
(Just face,
Just edge,
Just vert) -> HeEdge (thisVert vert sv)
(getOppEdge sv fi)
(thisFace face)
(thisEdge edge)
_ -> NoEdge
thisFace (IndirectHeFace (_, vi:_))
= case pe `atMay` vi of
Just edge -> HeFace (thisEdge edge)
Nothing -> NoFace
thisFace (IndirectHeFace _) = NoFace
thisVert (IndirectHeVert eedg _) coordi
= case (pts `atMay` (coordi - 1), pe `atMay` (eedg - 1)) of
(Just vert, Just edge) -> HeVert vert $ thisEdge edge
_ -> NoVert
getOppEdge sv fi
= case join
$ headMay
. filter ((/=) fi . indexf)
. catMaybes
. fmap (pe `atMay`)
. edgelist
<$> Map.lookup sv vertmap
of Just x -> thisEdge x
Nothing -> NoEdge
indirectToDirect _ _ _ _ = NoEdge
-- |Build the half-edge data structure from a list of points
-- and from a list of faces.
-- The points are assumed to have been parsed in order of their appearance
-- in the .obj mesh file, so that the indices match.
-- The faces are assumed to have been parsed in order of their appearance
-- in the .obj mesh file as follows:
--
-- @
-- f 1 3 4 5
-- f 4 6 1 3
-- @
--
-- becomes
--
-- > [[1,3,4,5],[4,6,1,3]]
buildHeEdge :: [a] -> [[Int]] -> Maybe (HeEdge a)
buildHeEdge [] _ = Nothing
buildHeEdge _ [] = Nothing
buildHeEdge pts fs
= let faces' = indirectHeFaces fs
edges' = indirectHeEdges faces'
verts' = indirectHeVerts edges'
in Just $ indirectToDirect pts edges' faces' verts'
-- |Build the HeEdge data structure from the .obj mesh file contents.
buildHeEdgeFromStr :: B.ByteString -- ^ contents of an .obj mesh file
-> HeEdge (P2 Double)
buildHeEdgeFromStr bmesh =
let pts = meshToArr bmesh
faces' = indirectHeFaces . facesToArr $ bmesh
edges = indirectHeEdges faces'
verts = indirectHeVerts edges
in indirectToDirect pts edges faces' verts

25
Parser/Meshparser.hs
View File

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

7
QueueEx.hs
View File

@ -3,20 +3,21 @@ module QueueEx where
import Control.Applicative
import Data.Dequeue (BankersDequeue)
import qualified Data.Dequeue as Q
import Data.Maybe
-- |Shift a queue to the left, such as:
-- [1, 2, 3] -> [2, 3, 1]
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:
-- [1, 2, 3] -> [3, 1, 2]
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.
queueToList :: BankersDequeue a -> [a]
queueToList q = Q.takeFront (length q) q
queueToList q = Q.takeFront (Q.length q) q

90
Test/Vector.hs
View File

@ -21,19 +21,19 @@ newtype PosRoundDouble = PosRoundDouble { getPRD :: Double }
deriving (Eq, Ord, Show, Read)
newtype RoundR2 = RoundR2 { getRR2 :: V2 Double }
newtype RoundR2 = RoundR2 { getRR2 :: R2 }
deriving (Eq, Ord, Show, Read)
newtype PosRoundR2 = PosRoundR2 { getPRR2 :: V2 Double }
newtype PosRoundR2 = PosRoundR2 { getPRR2 :: R2 }
deriving (Eq, Ord, Show, Read)
newtype RoundP2 = RoundP2 { getRP2 :: P2 Double }
newtype RoundP2 = RoundP2 { getRP2 :: P2 }
deriving (Eq, Ord, Show, Read)
newtype PosRoundP2 = PosRoundP2 { getPRP2 :: P2 Double }
newtype PosRoundP2 = PosRoundP2 { getPRP2 :: P2 }
deriving (Eq, Ord, Show, Read)
@ -72,50 +72,50 @@ instance Arbitrary PosRoundP2 where
<*> (arbitrary :: Gen PosRoundDouble)
instance Arbitrary (V2 Double) where
instance Arbitrary R2 where
arbitrary = curry r2 <$> arbitrary <*> arbitrary
instance Arbitrary (P2 Double) where
instance Arbitrary P2 where
arbitrary = curry p2 <$> arbitrary <*> arbitrary
-- the point describing the lower left corner of the square
-- must be part of the square
inRangeProp1 :: ((Double, Double), (Double, Double)) -> Bool
inRangeProp1 :: Square -> Bool
inRangeProp1 sq@((x1, y1), _) =
inRange sq (p2 (x1, y1))
-- the point describing the upper right corner of the square
-- must be part of the square
inRangeProp2 :: ((Double, Double), (Double, Double)) -> Bool
inRangeProp2 :: Square -> Bool
inRangeProp2 sq@(_, (x2, y2)) =
inRange sq (p2 (x2, y2))
-- the point describing the upper left corner of the square
-- must be part of the square
inRangeProp3 :: ((Double, Double), (Double, Double)) -> Bool
inRangeProp3 :: Square -> Bool
inRangeProp3 sq@((x1, _), (_, y2)) =
inRange sq (p2 (x1, y2))
-- the point describing the lower right corner of the square
-- must be part of the square
inRangeProp4 :: ((Double, Double), (Double, Double)) -> Bool
inRangeProp4 :: Square -> Bool
inRangeProp4 sq@((_, y1), (x2, _)) =
inRange sq (p2 (x2, y1))
-- 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) =
inRange sq (p2 (x1 + ((x2 - x1) / (a + 1)), y1 + ((y2 - y1) / (b + 1))))
-- 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) =
(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
onPTProp1 :: P2 Double -> Bool
onPTProp1 :: PT -> Bool
onPTProp1 pt = onPT id pt == pt
-- add a random value to the point coordinates
onPTProp2 :: P2 Double -> Positive (V2 Double) -> Bool
onPTProp2 pt (Positive (V2 rx ry))
onPTProp2 :: PT -> Positive R2 -> Bool
onPTProp2 pt (Positive (R2 rx ry))
= onPT (\(x, y) -> (x + rx, y + ry)) pt /= pt
-- angle between two vectors both on the x-axis must be 0
getAngleProp1 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
getAngleProp1 (Positive (V2 x1 _)) (Positive (V2 x2 _))
= getAngle (V2 x1 0) (V2 x2 0) == 0
getAngleProp1 :: Positive Vec -> Positive Vec -> Bool
getAngleProp1 (Positive (R2 x1 _)) (Positive (R2 x2 _))
= getAngle (R2 x1 0) (R2 x2 0) == 0
-- angle between two vectors both on the y-axis must be 0
getAngleProp2 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
getAngleProp2 (Positive (V2 _ y1)) (Positive (V2 _ y2))
= getAngle (V2 0 y1) (V2 0 y2) == 0
getAngleProp2 :: Positive Vec -> Positive Vec -> Bool
getAngleProp2 (Positive (R2 _ y1)) (Positive (R2 _ y2))
= getAngle (R2 0 y1) (R2 0 y2) == 0
-- angle between two vectors both on the x-axis but with opposite direction
-- must be pi
getAngleProp3 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
getAngleProp3 (Positive (V2 x1 _)) (Positive (V2 x2 _))
= getAngle (V2 (negate x1) 0) (V2 x2 0) == pi
getAngleProp3 :: Positive Vec -> Positive Vec -> Bool
getAngleProp3 (Positive (R2 x1 _)) (Positive (R2 x2 _))
= getAngle (R2 (negate x1) 0) (R2 x2 0) == pi
-- angle between two vectors both on the y-axis but with opposite direction
-- must be pi
getAngleProp4 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
getAngleProp4 (Positive (V2 _ y1)) (Positive (V2 _ y2))
= getAngle (V2 0 (negate y1)) (V2 0 y2) == pi
getAngleProp4 :: Positive Vec -> Positive Vec -> Bool
getAngleProp4 (Positive (R2 _ y1)) (Positive (R2 _ y2))
= getAngle (R2 0 (negate y1)) (R2 0 y2) == pi
-- angle between vector in x-axis direction and y-axis direction must be
-- p/2
getAngleProp5 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
getAngleProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2))
= getAngle (V2 x1 0) (V2 0 y2) == pi / 2
getAngleProp5 :: Positive Vec -> Positive Vec -> Bool
getAngleProp5 (Positive (R2 x1 _)) (Positive (R2 _ y2))
= getAngle (R2 x1 0) (R2 0 y2) == pi / 2
-- commutative
getAngleProp6 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
getAngleProp6 :: Positive Vec -> Positive Vec -> Bool
getAngleProp6 (Positive v1) (Positive v2)
= getAngle v1 v2 == getAngle v2 v1
@ -183,7 +183,7 @@ getAngleProp7 (PosRoundR2 v)
-- commutative
scalarProdProp1 :: (V2 Double) -> (V2 Double) -> Bool
scalarProdProp1 :: Vec -> Vec -> Bool
scalarProdProp1 v1 v2 = v1 `scalarProd` v2 == v2 `scalarProd` v1
@ -212,9 +212,9 @@ scalarProdProp4 (RoundDouble s1) (RoundDouble s2) (RoundR2 v1) (RoundR2 v2)
-- orthogonal
scalarProdProp5 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
scalarProdProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2))
= scalarProd (V2 x1 0) (V2 0 y2) == 0
scalarProdProp5 :: Positive Vec -> Positive Vec -> Bool
scalarProdProp5 (Positive (R2 x1 _)) (Positive (R2 _ y2))
= scalarProd (R2 x1 0) (R2 0 y2) == 0
-- this is almost the same as the function definition
@ -226,49 +226,49 @@ dimToSquareProp1 (x1, x2) (y1, y2) =
-- multiply scalar with result of vecLength or with the vector itself...
-- both results must be the same. We can't check against 0
-- because of sqrt in vecLength.
vecLengthProp1 :: PosRoundDouble -> (V2 Double) -> Bool
vecLengthProp1 :: PosRoundDouble -> Vec -> Bool
vecLengthProp1 (PosRoundDouble r) v
= abs (vecLength v * r - vecLength (scalarMul r v)) < 0.0001
-- convert to vector and back again
pt2VecProp1 :: P2 Double -> Bool
pt2VecProp1 :: PT -> Bool
pt2VecProp1 pt = (vec2Pt . pt2Vec $ pt) == pt
-- unbox coordinates and check if equal
pt2VecProp2 :: P2 Double -> Bool
pt2VecProp2 :: PT -> Bool
pt2VecProp2 pt = (unr2 . pt2Vec $ pt) == unp2 pt
-- convert to point and back again
vec2PtProp1 :: V2 Double -> Bool
vec2PtProp1 :: Vec -> Bool
vec2PtProp1 v = (pt2Vec . vec2Pt $ v) == v
-- unbox coordinates and check if equal
vec2PtProp2 :: V2 Double -> Bool
vec2PtProp2 :: Vec -> Bool
vec2PtProp2 v = (unp2 . vec2Pt $ v) == unr2 v
-- 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'
| p1' == origin && p2' == origin = True
| otherwise = vp2 p1' p2' /= vp2 p2' p1'
-- 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'
| p1' == origin && p2' == origin = True
| otherwise = vp2 p1' p2' == (\(V2 x y) -> negate x ^& negate y)
| otherwise = vp2 p1' p2' == (\(R2 x y) -> negate x ^& negate y)
(vp2 p2' p1')
&&
vp2 p2' p1' == (\(V2 x y) -> negate x ^& negate y)
vp2 p2' p1' == (\(R2 x y) -> negate x ^& negate y)
(vp2 p1' p2')
-- determinant of the 3 same points is always 0
detProp1 :: P2 Double -> Bool
detProp1 :: PT -> Bool
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

11
test_objs/UB5_T1_CCW.obj Normal file
View File

@ -0,0 +1,11 @@
v 150.0 450.0
v 75.0 300.0
v 50.0 100.0
v 125.0 200.0
v 350.0 50.0
v 400.0 225.0
v 350.0 175.0
v 325.0 425.0
v 300.0 350.0
f 1 2 3 4 5 6 7 8 9

17
test_objs/UB5_T2_CCW.obj Normal file
View File

@ -0,0 +1,17 @@
v 150.0 500.0
v 100.0 400.0
v 125.0 300.0
v 100.0 125.0
v 125.0 75.0
v 200.0 50.0
v 275.0 200.0
v 350.0 150.0
v 425.0 225.0
v 475.0 175.0
v 500.0 375.0
v 450.0 350.0
v 400.0 450.0
v 300.0 425.0
f 1 2 3 4 5 6 7 8 9 10 11 12 13 14