Fix build and freeze

We had to add NoFace/NoEdge/NoVert constructors to our half-edge
data structures, because using "Maybe HeEdge a" as the result value
of 'indirectToDirect' causes an infinite recursion, since the whole
data structure (which is cyclic and infinite) has to be evaluated
in order to know which constructor to use.

Unfortunately this makes the code quite hard to read.

TODO: add pseudo-code

.gitignore

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

Algebra/Polygon.hs

@@ -10,9 +10,9 @@ import MyPrelude
 
 -- |Split a polygon by a given segment which must be vertices of the
 -- polygon (returns empty array otherwise).
-splitPoly :: [P2]
-          -> (P2, P2)
-          -> [[P2]]
+splitPoly :: [P2 Double]
+          -> (P2 Double, P2 Double)
+          -> [[P2 Double]]
 splitPoly pts (a, b)
   | elem a pts && elem b pts =
     [b : takeWhile (/= b) shiftedPoly, a : dropWhile (/= b) shiftedPoly]
@@ -22,7 +22,7 @@ splitPoly pts (a, b)
 
 
 -- |Get all edges of a polygon.
-polySegments :: [P2] -> [(P2, P2)]
+polySegments :: [P2 Double] -> [(P2 Double, P2 Double)]
 polySegments p@(x':_:_:_) = go p ++ [(last p, x')]
   where
     go (x:y:xs) = (x, y) : go (y:xs)
@@ -33,30 +33,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] -> (P2, P2) -> Bool
+isInsidePoly :: [P2 Double] -> (P2 Double, P2 Double) -> 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 -> P2 -> [P2] -> Bool
+adjacent :: P2 Double -> P2 Double -> [P2 Double] -> Bool
 adjacent u v = any (\x -> x == (u, v) || x == (v, u)) . polySegments
 
 
 -- |Check whether the polygon is a triangle polygon.
-isTrianglePoly :: [P2] -> Bool
+isTrianglePoly :: [P2 Double] -> Bool
 isTrianglePoly [_, _, _] = True
 isTrianglePoly _         = False
 
 
 -- |Get all triangle polygons.
-triangleOnly :: [[P2]] -> [[P2]]
+triangleOnly :: [[P2 Double]] -> [[P2 Double]]
 triangleOnly = filter isTrianglePoly
 
 
 -- |Get all non-triangle polygons.
-nonTriangleOnly :: [[P2]] -> [[P2]]
+nonTriangleOnly :: [[P2 Double]] -> [[P2 Double]]
 nonTriangleOnly = filter (not . isTrianglePoly)

Algebra/Vector.hs

@@ -8,7 +8,6 @@ import Control.Arrow ((***))
 import Data.List (sortBy)
 import Diagrams.Coordinates
 import Diagrams.TwoD.Types
-import Graphics.Gloss.Geometry.Line
 import GHC.Float
 import MyPrelude
 
@@ -30,8 +29,8 @@ 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     -- ^ Coordinate
-        -> Bool   -- ^ result
+        -> P2 Double  -- ^ Coordinate
+        -> Bool       -- ^ result
 inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
   = x >= min xmin xmax
     && x <= max xmin xmax
@@ -40,7 +39,7 @@ inRange ((xmin, ymin), (xmax, ymax)) (coords -> x :& y)
 
 
 -- |Get the angle between two vectors.
-getAngle :: R2 -> R2 -> Double
+getAngle :: V2 Double -> V2 Double -> Double
 getAngle a b =
   acos
     . flip (/) (vecLength a * vecLength b)
@@ -49,64 +48,50 @@ getAngle a b =
 
 
 -- |Get the length of a vector.
-vecLength :: R2 -> Double
+vecLength :: V2 Double -> Double
 vecLength v = sqrt (x^(2 :: Int) + y^(2 :: Int))
   where
     (x, y) = unr2 v
 
 
 -- |Compute the scalar product of two vectors.
-scalarProd :: R2 -> R2 -> Double
-scalarProd (R2 a1 a2) (R2 b1 b2) = a1 * b1 + a2 * b2
+scalarProd :: V2 Double -> V2 Double -> Double
+scalarProd (V2 a1 a2) (V2 b1 b2) = a1 * b1 + a2 * b2
 
 
 -- |Multiply a scalar with a vector.
-scalarMul :: Double -> R2 -> R2
-scalarMul d (R2 a b) = R2 (a * d) (b * d)
+scalarMul :: Double -> V2 Double -> V2 Double
+scalarMul d (V2 a b) = V2 (a * d) (b * d)
 
 
 -- |Construct a vector that points to a point from the origin.
-pt2Vec :: P2 -> R2
+pt2Vec :: P2 Double -> V2 Double
 pt2Vec = r2 . unp2
 
 
 -- |Give the point which is at the coordinates the vector
 -- points to from the origin.
-vec2Pt :: R2 -> P2
+vec2Pt :: V2 Double -> P2 Double
 vec2Pt = p2 . unr2
 
 
 -- |Construct a vector between two points.
-vp2 :: P2  -- ^ vector origin
-    -> P2  -- ^ vector points here
-    -> R2
+vp2 :: P2 Double  -- ^ vector origin
+    -> P2 Double  -- ^ vector points here
+    -> V2 Double
 vp2 a b = pt2Vec b - pt2Vec a
 
 
 -- |Computes the determinant of 3 points.
-det :: P2 -> P2 -> P2 -> Double
+det :: P2 Double -> P2 Double -> P2 Double -> 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' :: (P2, P2) -- ^ first segment
-              -> (P2, P2) -- ^ second segment
-              -> Maybe P2
-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, P2) -> (P2, P2) -> Maybe P2
-intersectSeg'' (a, b) (c, d) = case intersectSeg' (a, b) (c, d) of
+intersectSeg :: (P2 Double, P2 Double) -> (P2 Double, P2 Double) -> Maybe (P2 Double)
+intersectSeg (a, b) (c, d) = case intersectSegSeg a b c d of
   Just x  -> if x `notElem` [a,b,c,d] then Just a else Nothing
   Nothing -> Nothing
 
@@ -115,7 +100,7 @@ intersectSeg'' (a, b) (c, d) = case intersectSeg' (a, b) (c, d) of
 -- * clock-wise
 -- * counter-clock-wise
 -- * collinear
-getOrient :: P2 -> P2 -> P2 -> Alignment
+getOrient :: P2 Double -> P2 Double -> P2 Double -> Alignment
 getOrient a b c = case compare (det a b c) 0 of
   LT -> CW
   GT -> CCW
@@ -125,7 +110,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 -> P2 -> P2 -> Bool
+notcw :: P2 Double -> P2 Double -> P2 Double -> Bool
 notcw a b c = case getOrient a b c of
   CW -> False
   _  -> True
@@ -134,22 +119,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 -> P2 -> P2 -> Bool
+cw :: P2 Double -> P2 Double -> P2 Double -> Bool
 cw a b c = not . notcw a b $ c
 
 
 -- |Sort X and Y coordinates lexicographically.
-sortedXY :: [P2] -> [P2]
+sortedXY :: [P2 Double] -> [P2 Double]
 sortedXY = fmap p2 . sortLex . fmap unp2
 
 
 -- |Sort Y and X coordinates lexicographically.
-sortedYX :: [P2] -> [P2]
+sortedYX :: [P2 Double] -> [P2 Double]
 sortedYX = fmap p2 . sortLexSwapped . fmap unp2
 
 
 -- |Sort all points according to their X-coordinates only.
-sortedX :: [P2] -> [P2]
+sortedX :: [P2 Double] -> [P2 Double]
 sortedX xs =
   fmap p2
   . sortBy (\(a1, _) (a2, _) -> compare a1 a2)
@@ -157,7 +142,7 @@ sortedX xs =
 
 
 -- |Sort all points according to their Y-coordinates only.
-sortedY :: [P2] -> [P2]
+sortedY :: [P2 Double] -> [P2 Double]
 sortedY xs =
   fmap p2
   . sortBy (\(_, b1) (_, b2) -> compare b1 b2)
@@ -165,25 +150,125 @@ sortedY xs =
 
 
 -- |Apply a function on the coordinates of a point.
-onPT :: ((Double, Double) -> (Double, Double)) -> P2 -> P2
+onPT :: ((Double, Double) -> (Double, Double)) -> P2 Double -> P2 Double
 onPT f = p2 . f . unp2
 
 
 -- |Compare the y-coordinate of two points.
-ptCmpY :: P2 -> P2 -> Ordering
+ptCmpY :: P2 Double -> P2 Double -> Ordering
 ptCmpY (coords -> _ :& y1) (coords -> _ :& y2) =
   compare y1 y2
 
 
 -- |Compare the x-coordinate of two points.
-ptCmpX :: P2 -> P2 -> Ordering
+ptCmpX :: P2 Double -> P2 Double -> Ordering
 ptCmpX (coords -> x1 :& _) (coords -> x2 :& _) =
   compare x1 x2
 
 
-posInfPT :: P2
+posInfPT :: P2 Double
 posInfPT = p2 (read "Infinity", read "Infinity")
 
 
-negInfPT :: P2
+negInfPT :: P2 Double
 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

Algorithms/GrahamScan.hs

@@ -75,18 +75,18 @@ ys = []
 return [(100, 100), (400, 200)]
 =========================================================
 --}
-grahamCH :: [P2] -> [P2]
+grahamCH :: [P2 Double] -> [P2 Double]
 grahamCH vs = grahamUCH vs ++ (tailInit . grahamLCH $ vs)
 
 
 -- |Get the lower part of the convex hull.
-grahamLCH :: [P2] -> [P2]
+grahamLCH :: [P2 Double] -> [P2 Double]
 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] -> [P2]
+grahamUCH :: [P2 Double] -> [P2 Double]
 grahamUCH vs = uncurry (\x y -> last . scanH x $ y)
                        (first reverse . splitAt 3 . reverse . sortedXY $ vs)
 
@@ -96,9 +96,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]   -- ^ the first 3 starting points in reversed order
-      -> [P2]   -- ^ the rest of the points
-      -> [[P2]] -- ^ all convex hull points iterations for the half
+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 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 +112,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] -> [P2] -> [[P2]]
+grahamCHSteps :: Int -> [P2 Double] -> [P2 Double] -> [[P2 Double]]
 grahamCHSteps c xs' ys' = take c . scanH xs' $ ys'
 
 
 -- |Get all iterations of the upper hull of the graham scan algorithm.
-grahamUHSteps :: [P2] -> [[P2]]
+grahamUHSteps :: [P2 Double] -> [[P2 Double]]
 grahamUHSteps vs =
   (++) [getLastX 2 . sortedXY $ vs]
   . rmdups
@@ -128,7 +128,7 @@ grahamUHSteps vs =
 
 
 -- |Get all iterations of the lower hull of the graham scan algorithm.
-grahamLHSteps :: [P2] -> [[P2]]
+grahamLHSteps :: [P2 Double] -> [[P2 Double]]
 grahamLHSteps vs =
   (++) [take 2 . sortedXY $ vs]
   . rmdups

Algorithms/KDTree.hs

@@ -42,9 +42,9 @@ instance Not Direction where
 
 
 -- |Construct a kd-tree from a list of points in O(n log n).
-kdTree :: [P2]      -- ^ list of points to construct the kd-tree from
+kdTree :: [P2 Double]      -- ^ list of points to construct the kd-tree from
        -> Direction -- ^ initial direction of the root-node
-       -> KDTree P2 -- ^ resulting kd-tree
+       -> KDTree (P2 Double) -- ^ 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                           -- ^ the pivot to partition against
-           -> (P2 -> P2 -> Ordering)       -- ^ ptCmpY or ptCmpX
-           -> ([P2], [P2])                 -- ^ both lists (X, Y) or (Y, X)
-           -> (([P2], [P2]), ([P2], [P2])) -- ^ ((x1, x2), (y1, y2)) or
+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
                                            --   ((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], [P2])                 -- ^ both lists (X, Y)
-           -> (([P2], [P2]), ([P2], [P2])) -- ^ ((x1, x2), (y1, y2))
+partitionY :: ([P2 Double], [P2 Double])                 -- ^ both lists (X, Y)
+           -> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((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], [P2])                 -- ^ both lists (X, Y)
-           -> (([P2], [P2]), ([P2], [P2])) -- ^ ((x1, x2), (y1, y2))
+partitionX :: ([P2 Double], [P2 Double])                 -- ^ both lists (X, Y)
+           -> (([P2 Double], [P2 Double]), ([P2 Double], [P2 Double])) -- ^ ((x1, x2), (y1, y2))
 partitionX (xs, ys) = (\(x, y) -> (y, x))
                       . partition' (fromJust . pivot $ xs) ptCmpX $ (ys, xs)
 
@@ -100,9 +100,9 @@ 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                            -- ^ tree to search in
+rangeSearch :: KDTree (P2 Double)                            -- ^ tree to search in
             -> ((Double, Double), (Double, Double)) -- ^ square describing the range
-            -> ([P2], Tree String)
+            -> ([P2 Double], Tree String)
 rangeSearch kd' sq' = (goPt kd' sq', goTree kd' sq' True)
   where
     -- either y1 or x1 depending on the orientation
@@ -112,7 +112,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)) -> [P2]
+    goPt :: KDTree (P2 Double) -> ((Double, Double), (Double, Double)) -> [P2 Double]
     goPt KTNil _ = []
     goPt (KTNode ln pt dir rn) sq =
       [pt | inRange sq pt]
@@ -124,7 +124,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)) -> Bool -> Tree String
+    goTree :: KDTree (P2 Double) -> ((Double, Double), (Double, Double)) -> Bool -> Tree String
     goTree KTNil _ _ = Node "nil" []
     goTree (KTNode ln pt dir rn) sq vis
       | ln == KTNil && rn == KTNil = Node treeText []
@@ -181,7 +181,7 @@ getDirection _                  = Nothing
 
 
 -- |Convert a kd-tree to a rose tree, for pretty printing.
-kdTreeToRoseTree :: KDTree P2 -> Tree String
+kdTreeToRoseTree :: KDTree (P2 Double) -> Tree String
 kdTreeToRoseTree (KTNil) = Node "nil" []
 kdTreeToRoseTree (KTNode ln val _ rn) =
   Node (show . unp2 $ val) [kdTreeToRoseTree ln, kdTreeToRoseTree rn]

Algorithms/PolygonIntersection.hs

@@ -18,14 +18,14 @@ import           QueueEx
 -- successor are saved for convenience.
 data PolyPT =
   PolyA {
-    id'   :: P2
-    , pre :: P2
-    , suc :: P2
+    id'   :: P2 Double
+    , pre :: P2 Double
+    , suc :: P2 Double
     }
   | PolyB {
-    id'   :: P2
-    , pre :: P2
-    , suc :: P2
+    id'   :: P2 Double
+    , pre :: P2 Double
+    , suc :: P2 Double
     }
   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] -> [P2]
+sortLexPoly :: [P2 Double] -> [P2 Double]
 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 -> P2 -> P2 -> PolyPT) -- ^ PolyA or PolyB function
-             -> [P2]                       -- ^ polygon points
+mkPolyPTList :: (P2 Double -> P2 Double -> P2 Double -> PolyPT) -- ^ PolyA or PolyB function
+             -> [P2 Double]                       -- ^ 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], [P2]) -> [PolyPT]
+sortLexPolys :: ([P2 Double], [P2 Double]) -> [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 . Q.popFront $ pA) pB)
+        = Q.pushFront (go (maybeShift . snd . fromJust . 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 . Q.popFront $ pB))
+      | otherwise = Q.pushFront (go pA (maybeShift . snd . fromJust . 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]
+intersectionPoints :: [PolyPT] -> [P2 Double]
 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, P2)], [(P2, P2)])
+    scanLine :: [PolyPT] -> ([(P2 Double, P2 Double)], [(P2 Double, P2 Double)])
     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, P2)], [(P2, P2)]) -> [P2]
+    segIntersections :: ([(P2 Double, P2 Double)], [(P2 Double, P2 Double)]) -> [P2 Double]
     segIntersections (a@(_:_), b@(_:_)) =
       catMaybes
-      . fmap (\[x, y] -> intersectSeg' x y)
+      . fmap (\[(x1, y1), (x2, y2)] -> intersectSegSeg x1 y1 x2 y2)
       $ combinations a b
     segIntersections _ = []
 

Algorithms/PolygonTriangulation.hs

@@ -19,12 +19,12 @@ data VCategory = VStart
 
 
 -- |Classify all vertices on a polygon into five categories (see VCategory).
-classifyList :: [P2] -> [(P2, VCategory)]
+classifyList :: [P2 Double] -> [(P2 Double, 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] -> [(P2, VCategory)]
+    go :: [P2 Double] -> [(P2 Double, VCategory)]
     go (x':y':z':xs) = classify x' y' z' : go (y':z':xs)
     go _          = []
 classifyList _ = []
@@ -32,10 +32,10 @@ classifyList _ = []
 
 -- |Classify a vertex on a polygon given it's next and previous vertex
 -- into five categories (see VCategory).
-classify :: P2  -- ^ prev vertex
-         -> P2  -- ^ classify this one
-         -> P2  -- ^ next vertex
-         -> (P2, VCategory)
+classify :: P2 Double  -- ^ prev vertex
+         -> P2 Double  -- ^ classify this one
+         -> P2 Double  -- ^ next vertex
+         -> (P2 Double, VCategory)
 classify prev v next
   | isVStart prev v next = (v, VStart)
   | isVSplit prev v next = (v, VSplit)
@@ -46,9 +46,9 @@ classify prev v next
 
 -- |Whether the vertex, given it's next and previous vertex,
 -- is a start vertex.
-isVStart :: P2  -- ^ previous vertex
-         -> P2  -- ^ vertice to check
-         -> P2  -- ^ next vertex
+isVStart :: P2 Double  -- ^ previous vertex
+         -> P2 Double  -- ^ vertice to check
+         -> P2 Double  -- ^ next vertex
          -> Bool
 isVStart prev v next =
   ptCmpY next v == LT && ptCmpY prev v == LT && cw next v prev
@@ -56,9 +56,9 @@ isVStart prev v next =
 
 -- |Whether the vertex, given it's next and previous vertex,
 -- is a split vertex.
-isVSplit :: P2  -- ^ previous vertex
-         -> P2  -- ^ vertice to check
-         -> P2  -- ^ next vertex
+isVSplit :: P2 Double  -- ^ previous vertex
+         -> P2 Double  -- ^ vertice to check
+         -> P2 Double  -- ^ next vertex
          -> Bool
 isVSplit prev v next =
   ptCmpY prev v == LT && ptCmpY next v == LT && cw prev v next
@@ -66,9 +66,9 @@ isVSplit prev v next =
 
 -- |Whether the vertex, given it's next and previous vertex,
 -- is an end vertex.
-isVEnd :: P2  -- ^ previous vertex
-       -> P2  -- ^ vertice to check
-       -> P2  -- ^ next vertex
+isVEnd :: P2 Double  -- ^ previous vertex
+       -> P2 Double  -- ^ vertice to check
+       -> P2 Double  -- ^ next vertex
        -> Bool
 isVEnd prev v next =
   ptCmpY prev v == GT && ptCmpY next v == GT && cw next v prev
@@ -76,9 +76,9 @@ isVEnd prev v next =
 
 -- |Whether the vertex, given it's next and previous vertex,
 -- is a merge vertex.
-isVMerge :: P2  -- ^ previous vertex
-         -> P2  -- ^ vertice to check
-         -> P2  -- ^ next vertex
+isVMerge :: P2 Double  -- ^ previous vertex
+         -> P2 Double  -- ^ vertice to check
+         -> P2 Double  -- ^ next vertex
          -> Bool
 isVMerge prev v next =
   ptCmpY next v == GT && ptCmpY prev v == GT && cw prev v next
@@ -86,9 +86,9 @@ isVMerge prev v next =
 
 -- |Whether the vertex, given it's next and previous vertex,
 -- is a regular vertex.
-isVRegular :: P2  -- ^ previous vertex
-           -> P2  -- ^ vertice to check
-           -> P2  -- ^ next vertex
+isVRegular :: P2 Double  -- ^ previous vertex
+           -> P2 Double  -- ^ vertice to check
+           -> P2 Double  -- ^ next vertex
            -> Bool
 isVRegular prev v next =
      (not . isVStart prev v $ next)
@@ -99,7 +99,7 @@ isVRegular prev v next =
 
 
 -- |A polygon P is y-monotone, if it has no split and merge vertices.
-isYmonotone :: [P2] -> Bool
+isYmonotone :: [P2 Double] -> Bool
 isYmonotone poly =
   not
   . any (\x -> x == VSplit || x == VMerge)
@@ -108,12 +108,12 @@ isYmonotone poly =
 
 
 -- |Partition P into y-monotone pieces.
-monotonePartitioning :: [P2] -> [[P2]]
+monotonePartitioning :: [P2 Double] -> [[P2 Double]]
 monotonePartitioning pts
   | isYmonotone pts = [pts]
   | otherwise = go (monotoneDiagonals pts) pts
   where
-    go :: [(P2, P2)] -> [P2] -> [[P2]]
+    go :: [(P2 Double, P2 Double)] -> [P2 Double] -> [[P2 Double]]
     go (x:xs) pts'@(_:_)
       | isYmonotone a && isYmonotone b = [a, b]
       | isYmonotone b = b : go xs a
@@ -125,37 +125,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] -> [(P2, P2)]
+monotoneDiagonals :: [P2 Double] -> [(P2 Double, P2 Double)]
 monotoneDiagonals pts = catMaybes . go $ classifyList pts
   where
-    go :: [(P2, VCategory)] -> [Maybe (P2, P2)]
+    go :: [(P2 Double, VCategory)] -> [Maybe (P2 Double, P2 Double)]
     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] -- all points above/below the current point
-           -> P2   -- current point
-           -> Maybe (P2, P2)
+    getSeg :: [P2 Double] -- all points above/below the current point
+           -> P2 Double   -- current point
+           -> Maybe (P2 Double, P2 Double)
     getSeg [] _ = Nothing
     getSeg (z:zs) pt
       | isInsidePoly pts (z, pt) = Just (z, pt)
       | otherwise = getSeg zs pt
-    aboveS :: P2 -> [P2]
+    aboveS :: P2 Double -> [P2 Double]
     aboveS pt = tail . dropWhile (/= pt) $ sortedYX pts
-    belowS :: P2 -> [P2]
+    belowS :: P2 Double -> [P2 Double]
     belowS pt = reverse . takeWhile (/= pt) $ sortedYX pts
 
 
 -- |Triangulate a y-monotone polygon.
-triangulate :: [P2] -> [[P2]]
+triangulate :: [P2 Double] -> [[P2 Double]]
 triangulate pts =
   go pts . A.first reverse . splitAt 3 . reverse . sortedYX $ pts
   where
-    go :: [P2]          -- current polygon
-       -> ([P2], [P2])  -- (stack of visited vertices, rest)
+    go :: [P2 Double]          -- current polygon
+       -> ([P2 Double], [P2 Double])  -- (stack of visited vertices, rest)
                         --  sorted by Y-coordinate
-       -> [[P2]]
+       -> [[P2 Double]]
     go xs (p@[_, _], r:rs) = go xs (r:p, rs)
     go xs (p@(u:vi:vi1:ys), rs)
       -- case 1 and 3

Algorithms/QuadTree.hs

@@ -80,9 +80,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]                                 -- ^ the points to divide
+quadTree :: [P2 Double]                                 -- ^ the points to divide
          -> ((Double, Double), (Double, Double)) -- ^ the initial square around the points
-         -> QuadTree P2                          -- ^ the quad tree
+         -> QuadTree (P2 Double)                          -- ^ the quad tree
 quadTree []   _ = TNil
 quadTree [pt] _ = TLeaf pt
 quadTree pts sq = TNode (quadTree nWPT . nwSq $ sq) (quadTree nEPT . neSq $ sq)
@@ -97,7 +97,7 @@ 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                            -- ^ the quad tree
+                -> QuadTree (P2 Double)                            -- ^ the quad tree
                 -> [((Double, Double), (Double, Double))] -- ^ all squares of the quad tree
 quadTreeSquares sq (TNil)              = [sq]
 quadTreeSquares sq (TLeaf _)           = [sq]
@@ -203,7 +203,7 @@ lookupByNeighbors :: [Orient] -> QTZipper a -> Maybe (QTZipper a)
 lookupByNeighbors = flip (foldlM (flip findNeighbor))
 
 
-quadTreeToRoseTree :: QTZipper P2 -> Tree String
+quadTreeToRoseTree :: QTZipper (P2 Double) -> Tree String
 quadTreeToRoseTree z' = go (rootNode z')
   where
     go z = case z of

CG2.cabal

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

GUI/Gtk.hs

@@ -14,10 +14,11 @@ import Diagrams.Backend.Cairo.Internal
 import Graphics.Diagram.Core (DiagProp(..))
 import Graphics.Diagram.Gtk
 import Graphics.UI.Gtk
-import Graphics.UI.Gtk.Glade
+import Graphics.UI.Gtk.Builder
 import MyPrelude
 import System.Directory
 import System.FilePath.Posix
+import System.Glib.UTFString
 import Text.Read
 
 
@@ -63,9 +64,9 @@ data MyGUI = MkMyGUI {
   -- |Path entry widget for the quad tree.
   quadPathEntry :: Entry,
   -- |Horizontal box containing the path entry widget.
-  vbox7 :: Box,
+  vbox7 :: Graphics.UI.Gtk.Box,
   -- |Horizontal box containing the Rang search entry widgets.
-  vbox10 :: Box,
+  vbox10 :: Graphics.UI.Gtk.Box,
   -- |Range entry widget for lower x bound
   rangeXminEntry :: Entry,
   -- |Range entry widget for upper x bound
@@ -77,42 +78,38 @@ 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
-  Just xml   <- xmlNew gladeFile
+  builder <- builderNew
+  builderAddFromFile builder "GUI/gtk2.xml"
 
   MkMyGUI
-    <$> 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"
+    <$> 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"
 
 
 -- |Main entry point for the GTK GUI routines.
@@ -158,23 +155,23 @@ makeGUI startFile = do
   -- hotkeys
   _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
-    "q"       <- eventKeyName
+    "q"       <- fmap glibToString eventKeyName
     liftIO mainQuit
   _ <- treeWin mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
-    "q"       <- eventKeyName
+    "q"       <- fmap glibToString eventKeyName
     liftIO (widgetHide $ treeWin mygui)
   _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
-    "s"       <- eventKeyName
+    "s"       <- fmap glibToString eventKeyName
     liftIO $ saveDiag mygui
   _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
-    "d"       <- eventKeyName
+    "d"       <- fmap glibToString eventKeyName
     liftIO $ drawDiag mygui
   _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
     [Control] <- eventModifier
-    "a"       <- eventKeyName
+    "a"       <- fmap glibToString eventKeyName
     liftIO $ widgetShowAll (aboutDialog mygui)
 
   -- draw widgets and start main loop
@@ -299,9 +296,9 @@ saveAndDrawDiag fp fps mygui =
         renderDiag winWidth winHeight buildDiag =
           renderDia Cairo
             (CairoOptions fps
-               (Dims (fromIntegral winWidth) (fromIntegral winHeight))
+               (mkSizeSpec2D (Just $ fromIntegral winWidth) (Just $ fromIntegral winHeight))
                SVG False)
-            (buildDiag (def{
+            (buildDiag (MyPrelude.def{
                 dotSize       = scaleVal,
                 xDimension    = fromMaybe (0, 500) xDim,
                 yDimension    = fromMaybe (0, 500) yDim,

GUI/gtk2.xml

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

Graphics/Diagram/AlgoDiags.hs

@@ -1,4 +1,7 @@
 {-# OPTIONS_HADDOCK ignore-exports #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
 
 module Graphics.Diagram.AlgoDiags where
 
@@ -123,9 +126,9 @@ 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
+        kdLines :: KDTree (P2 Double)
                 -> ((Double, Double), (Double, Double)) -- ^ square
-                -> [(P2, P2)]
+                -> [(P2 Double, P2 Double)]
         kdLines (KTNode ln pt Horizontal rn) ((xmin, ymin), (xmax, ymax)) =
           (\(x, _) -> [(p2 (x, ymin), p2 (x, ymax))])
             (unp2 pt)
@@ -180,7 +183,7 @@ kdTreeDiag = Diag f
 
 
 -- |Get the quad tree corresponding to the given points and diagram properties.
-qt :: [P2] -> DiagProp -> QuadTree P2
+qt :: [P2 Double] -> DiagProp -> QuadTree (P2 Double)
 qt vt p = quadTree vt (diagDimSquare p)
 
 
@@ -194,7 +197,7 @@ quadPathSquare = Diag f
       (getSquare (stringToQuads (quadPath p)) (qt (mconcat vts) p, []))
       where
         getSquare :: [Either Quad Orient]
-                  -> QTZipper P2
+                  -> QTZipper (P2 Double)
                   -> ((Double, Double), (Double, Double))
         getSquare [] z = getSquareByZipper (diagDimSquare p) z
         getSquare (q:qs) z = case q of
@@ -212,7 +215,7 @@ gifQuadPath = GifDiag f
       <$> getSquares (stringToQuads (quadPath p)) (qt vt p, [])
       where
         getSquares :: [Either Quad Orient]
-                   -> QTZipper P2
+                   -> QTZipper (P2 Double)
                    -> [((Double, Double), (Double, Double))]
         getSquares [] z = [getSquareByZipper (diagDimSquare p) z]
         getSquares (q:qs) z = case q of
@@ -233,12 +236,12 @@ treePretty = Diag f
                       . quadPath
                       $ p)
       where
-        getCurQT :: [Either Quad Orient] -> QTZipper P2 -> QTZipper P2
+        getCurQT :: [Either Quad Orient] -> QTZipper (P2 Double) -> QTZipper (P2 Double)
         getCurQT [] z = z
         getCurQT (q:qs) z = case q of
           Right x -> getCurQT qs (fromMaybe z (findNeighbor x z))
           Left x  -> getCurQT qs (fromMaybe z (goQuad x z))
-        prettyRoseTree :: Tree String -> Diagram Cairo R2
+        prettyRoseTree :: Tree String -> Diagram Cairo
         prettyRoseTree tree =
         -- HACK: in order to give specific nodes a specific color
           renderTree (\n -> case head n of

Graphics/Diagram/Core.hs

@@ -15,18 +15,18 @@ data Diag =
   Diag
   {
     mkDiag :: DiagProp
-           -> [[P2]]
-           -> Diagram Cairo R2
+           -> [[P2 Double]]
+           -> Diagram Cairo
   }
   | GifDiag
   {
     mkGifDiag :: DiagProp
               -> Colour Double
-              -> ([P2] -> [[P2]])
-              -> [P2]
-              -> [Diagram Cairo R2]
+              -> ([P2 Double] -> [[P2 Double]])
+              -> [P2 Double]
+              -> [Diagram Cairo]
   }
-  | EmptyDiag (Diagram Cairo R2)
+  | EmptyDiag (Diagram Cairo)
 
 
 -- |Holds the properties for a Diagram, like thickness of 2d points etc.
@@ -57,23 +57,24 @@ instance Def DiagProp where
   def = diagDefaultProp
 
 
-instance Monoid Diag where
-  mempty = EmptyDiag mempty
-  mappend d1@(Diag {}) d2@(Diag {}) = Diag g
+instance Semigroup Diag where
+  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
+  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
+  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
+  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
+  (EmptyDiag _) <> g = g
+  g <> (EmptyDiag _) = g
 
+instance Monoid Diag where
+  mempty = EmptyDiag mempty
   mconcat = foldr mappend mempty
 
 
@@ -134,7 +135,7 @@ maybeDiag b d
   | otherwise = mempty
 
 
-filterValidPT :: DiagProp -> [P2] -> [P2]
+filterValidPT :: DiagProp -> [P2 Double] -> [P2 Double]
 filterValidPT =
   filter
   . inRange
@@ -146,21 +147,21 @@ diagDimSquare p = dimToSquare (xDimension p) $ yDimension p
 
 
 -- |Draw a list of points.
-drawP :: [P2]              -- ^ the points to draw
+drawP :: [P2 Double]              -- ^ the points to draw
       -> Double            -- ^ dot size
-      -> Diagram Cairo R2  -- ^ the resulting diagram
+      -> Diagram Cairo     -- ^ the resulting diagram
 drawP [] _  = mempty
 drawP vt ds =
   position (zip vt (repeat dot))
   where
-    dot = circle ds :: Diagram Cairo R2
+    dot = circle ds :: Diagram Cairo
 
 
 -- |Create a rectangle around a diagonal line, which has sw
 -- as startpoint and nw as endpoint.
 rectByDiagonal :: (Double, Double)  -- ^ sw point
                -> (Double, Double)  -- ^ nw point
-               -> Diagram Cairo R2
+               -> Diagram Cairo
 rectByDiagonal (xmin, ymin) (xmax, ymax) =
   fromVertices [p2 (xmin, ymin)
                 , p2 (xmax, ymin)
@@ -172,7 +173,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 -> Diagram Cairo R2
+pointToTextCoord :: P2 Double -> Diagram Cairo
 pointToTextCoord pt =
   text ("(" ++ (show . trim') x ++ ", " ++ (show . trim') y ++ ")") # scale 10
   where

Graphics/Diagram/Gif.hs

@@ -2,7 +2,7 @@
 
 module Graphics.Diagram.Gif where
 
-import Algebra.Vector(PT)
+import Algebra.Vector
 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 -> [PT] -> [(Diagram Cairo R2, GifDelay)]
+gifDiag :: DiagProp -> [P2 Double] -> [(Diagram Cairo, 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 R2, GifDelay)]
+gifDiagS :: DiagProp -> B.ByteString -> [(Diagram Cairo, GifDelay)]
 gifDiagS p = gifDiag p . filterValidPT p . meshToArr

Graphics/Diagram/Gtk.hs

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

Graphics/Diagram/Plotter.hs

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

Graphics/HalfEdge.hs

@@ -0,0 +1,242 @@
+{-# 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
+

Parser/Meshparser.hs

@@ -1,6 +1,6 @@
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
-module Parser.Meshparser (meshToArr, facesToArr) where
+module Parser.Meshparser (meshToArr, facesToArr, parseObj) where
 
 import Control.Applicative
 import Data.Attoparsec.ByteString.Char8
@@ -9,19 +9,14 @@ import qualified Data.ByteString.Char8 as B
 import Diagrams.TwoD.Types
 
 
--- |Convert a text String with multiple vertices and faces into
--- a list of vertices, ordered by the faces specification.
-facesToArr :: B.ByteString -> [[P2]]
-facesToArr str = fmap (fmap (\y -> meshToArr str !! (fromIntegral y - 1)))
-                      (faces str)
-  where
-    faces = rights . fmap (parseOnly parseFace) . B.lines
+facesToArr :: B.ByteString -> [[Int]]
+facesToArr = 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]         -- ^ the resulting vertice table
+          -> [P2 Double]         -- ^ the resulting vertice table
 meshToArr =
   fmap p2
     . rights
@@ -37,5 +32,14 @@ parseVertice =
     <*> (many' space *> double)
 
 
-parseFace :: Parser [Integer]
+parseFace :: Parser [Int]
 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

QueueEx.hs

@@ -3,21 +3,20 @@ 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  = (\(b, nq) -> Q.pushBack nq (fromJust b)) <$> Q.popFront
+shiftQueueLeft  = (\(Just (b, nq)) -> Q.pushBack nq b) <$> Q.popFront
 
 
 -- |Shift a queue to the right, such as:
 -- [1, 2, 3] -> [3, 1, 2]
 shiftQueueRight :: BankersDequeue a -> BankersDequeue a
-shiftQueueRight = (\(b, nq) -> Q.pushFront nq (fromJust b)) <$> Q.popBack
+shiftQueueRight = (\(Just (b, nq)) -> Q.pushFront nq b) <$> Q.popBack
 
 
 -- |Convert a Queue back to a list.
 queueToList :: BankersDequeue a -> [a]
-queueToList q = Q.takeFront (Q.length q) q
+queueToList q = Q.takeFront (length q) q

Test/Vector.hs

@@ -21,19 +21,19 @@ newtype PosRoundDouble = PosRoundDouble { getPRD :: Double }
   deriving (Eq, Ord, Show, Read)
 
 
-newtype RoundR2 = RoundR2 { getRR2 :: R2 }
+newtype RoundR2 = RoundR2 { getRR2 :: V2 Double }
   deriving (Eq, Ord, Show, Read)
 
 
-newtype PosRoundR2 = PosRoundR2 { getPRR2 :: R2 }
+newtype PosRoundR2 = PosRoundR2 { getPRR2 :: V2 Double }
   deriving (Eq, Ord, Show, Read)
 
 
-newtype RoundP2 = RoundP2 { getRP2 :: P2 }
+newtype RoundP2 = RoundP2 { getRP2 :: P2 Double }
   deriving (Eq, Ord, Show, Read)
 
 
-newtype PosRoundP2 = PosRoundP2 { getPRP2 :: P2 }
+newtype PosRoundP2 = PosRoundP2 { getPRP2 :: P2 Double }
   deriving (Eq, Ord, Show, Read)
 
 
@@ -72,11 +72,11 @@ instance Arbitrary PosRoundP2 where
                 <*> (arbitrary :: Gen PosRoundDouble)
 
 
-instance Arbitrary R2 where
+instance Arbitrary (V2 Double) where
   arbitrary = curry r2 <$> arbitrary <*> arbitrary
 
 
-instance Arbitrary P2 where
+instance Arbitrary (P2 Double) where
   arbitrary = curry p2 <$> arbitrary <*> arbitrary
 
 
@@ -126,51 +126,51 @@ inRangeProp6 sq@((x1, y1), (x2, y2)) (Positive a) (Positive b) =
 
 
 -- apply id function on the point
-onPTProp1 :: P2 -> Bool
+onPTProp1 :: P2 Double -> Bool
 onPTProp1 pt = onPT id pt == pt
 
 
 -- add a random value to the point coordinates
-onPTProp2 :: P2 -> Positive R2 -> Bool
-onPTProp2 pt (Positive (R2 rx ry))
+onPTProp2 :: P2 Double -> Positive (V2 Double) -> Bool
+onPTProp2 pt (Positive (V2 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 R2 -> Positive R2 -> Bool
-getAngleProp1 (Positive (R2 x1 _)) (Positive (R2 x2 _))
-  = getAngle (R2 x1 0) (R2 x2 0) == 0
+getAngleProp1 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
+getAngleProp1 (Positive (V2 x1 _)) (Positive (V2 x2 _))
+  = getAngle (V2 x1 0) (V2 x2 0) == 0
 
 
 -- angle between two vectors both on the y-axis must be 0
-getAngleProp2 :: Positive R2 -> Positive R2 -> Bool
-getAngleProp2 (Positive (R2 _ y1)) (Positive (R2 _ y2))
-  = getAngle (R2 0 y1) (R2 0 y2) == 0
+getAngleProp2 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
+getAngleProp2 (Positive (V2 _ y1)) (Positive (V2 _ y2))
+  = getAngle (V2 0 y1) (V2 0 y2) == 0
 
 
 -- angle between two vectors both on the x-axis but with opposite direction
 -- must be pi
-getAngleProp3 :: Positive R2 -> Positive R2 -> Bool
-getAngleProp3 (Positive (R2 x1 _)) (Positive (R2 x2 _))
-  = getAngle (R2 (negate x1) 0) (R2 x2 0) == 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
 
 
 -- angle between two vectors both on the y-axis but with opposite direction
 -- must be pi
-getAngleProp4 :: Positive R2 -> Positive R2 -> Bool
-getAngleProp4 (Positive (R2 _ y1)) (Positive (R2 _ y2))
-  = getAngle (R2 0 (negate y1)) (R2 0 y2) == 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
 
 
 -- angle between vector in x-axis direction and y-axis direction must be
 -- p/2
-getAngleProp5 :: Positive R2 -> Positive R2 -> Bool
-getAngleProp5 (Positive (R2 x1 _)) (Positive (R2 _ y2))
-  = getAngle (R2 x1 0) (R2 0 y2) == pi / 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
 
 
 -- commutative
-getAngleProp6 :: Positive R2 -> Positive R2 -> Bool
+getAngleProp6 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
 getAngleProp6 (Positive v1) (Positive v2)
   = getAngle v1 v2 == getAngle v2 v1
 
@@ -183,7 +183,7 @@ getAngleProp7 (PosRoundR2 v)
 
 
 -- commutative
-scalarProdProp1 :: R2 -> R2 -> Bool
+scalarProdProp1 :: (V2 Double) -> (V2 Double) -> 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 R2 -> Positive R2 -> Bool
-scalarProdProp5 (Positive (R2 x1 _)) (Positive (R2 _ y2))
-  = scalarProd (R2 x1 0) (R2 0 y2) == 0
+scalarProdProp5 :: Positive (V2 Double) -> Positive (V2 Double) -> Bool
+scalarProdProp5 (Positive (V2 x1 _)) (Positive (V2 _ y2))
+  = scalarProd (V2 x1 0) (V2 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 -> R2 -> Bool
+vecLengthProp1 :: PosRoundDouble -> (V2 Double) -> Bool
 vecLengthProp1 (PosRoundDouble r) v
   = abs (vecLength v * r - vecLength (scalarMul r v)) < 0.0001
 
 
 -- convert to vector and back again
-pt2VecProp1 :: P2 -> Bool
+pt2VecProp1 :: P2 Double -> Bool
 pt2VecProp1 pt = (vec2Pt . pt2Vec $ pt) == pt
 
 
 -- unbox coordinates and check if equal
-pt2VecProp2 :: P2 -> Bool
+pt2VecProp2 :: P2 Double -> Bool
 pt2VecProp2 pt = (unr2 . pt2Vec $ pt) == unp2 pt
 
 
 -- convert to point and back again
-vec2PtProp1 :: R2 -> Bool
+vec2PtProp1 :: V2 Double -> Bool
 vec2PtProp1 v = (pt2Vec . vec2Pt $ v) == v
 
 
 -- unbox coordinates and check if equal
-vec2PtProp2 :: R2 -> Bool
+vec2PtProp2 :: V2 Double -> Bool
 vec2PtProp2 v = (unp2 . vec2Pt $ v) == unr2 v
 
 
 -- vector from a to b must not be the same as b to a
-vp2Prop1 :: P2 -> P2 -> Bool
+vp2Prop1 :: P2 Double -> P2 Double -> 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 -> P2 -> Bool
+vp2Prop2 :: P2 Double -> P2 Double -> Bool
 vp2Prop2 p1' p2'
   | p1' == origin && p2' == origin = True
-  | otherwise = vp2 p1' p2' == (\(R2 x y) -> negate x ^& negate y)
+  | otherwise = vp2 p1' p2' == (\(V2 x y) -> negate x ^& negate y)
                                  (vp2 p2' p1')
                 &&
-                vp2 p2' p1' == (\(R2 x y) -> negate x ^& negate y)
+                vp2 p2' p1' == (\(V2 x y) -> negate x ^& negate y)
                                  (vp2 p1' p2')
 
 
 -- determinant of the 3 same points is always 0
-detProp1 :: P2 -> Bool
+detProp1 :: P2 Double -> Bool
 detProp1 pt' = det pt' pt' pt' == 0

cabal.project

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

cabal.project.freeze

@@ -0,0 +1,169 @@
+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