> {-# LANGUAGE MultiWayIf, PatternGuards, TemplateHaskell, BangPatterns, CPP #-}

Removing overlap from bezier paths in haskell
=============================================

This literate programming document serves as both the description 
and code for the algorithm for removing overlap and
performing set operations on bezier paths.  It can be used both for
understanding the code, and for porting the used algorithm to other 
implementations.

**Note on porting**: Porting should be fairly straightforward. 
However some care must be taken with regards to lazyness.  Often
many variables inside the `where` statement aren't
evaluated in all guards, so it's important to evaluate only those
which appear in the guards.  This library uses copying instead of 
mutation, but for the most part mutation can be used as well.
It uses the `lens` library for modifying state.  The following translation
could be made to a mutable language: 

  * reading state:
    - `view field struct`: `struct.field`
    - `get`: `state` (implicit state, usually sweepstate)
    - `use field`: `state.field`

  * writing state:
    - `set field value struct`: `struct.field = value`
    - `field .= value`: `state.field = value` (typically sweepstate)

  * modifying state:
    - `over field fun struct`: `struct.field = fun (struct.field)`
    - `modify fun`: `state = fun state`
    - `modifying field fun`: `state.field = fun (state.field)`

Let's begin with declaring the module and library imports:

> module Geom2D.CubicBezier.Overlap
>        (boolPathOp, union, intersection, difference,
>         exclusion, FillRule (..))
>        where
> import Prelude
> import Geom2D
> import Geom2D.CubicBezier.Basic
> import Geom2D.CubicBezier.Intersection
> import Geom2D.CubicBezier.Numeric
> import Math.BernsteinPoly
> import Data.Foldable (traverse_)
> import Data.Functor ((<$>))
> import Data.List (sortBy, sort, intercalate, intersperse)
> import Control.Monad
> import Control.Monad.State.Strict
> import Lens.Micro
> import Lens.Micro.TH
> import Lens.Micro.Mtl
> import qualified Data.Map.Strict as M
> import qualified Data.Set as S 
> import Text.Printf
> import Data.Ratio
> import Data.Tuple
> import Data.IORef
> import Data.Maybe (isJust, isNothing, mapMaybe)

#ifdef DEBUG
> import System.IO.Unsafe (unsafePerformIO)
> import System.IO
> import Debug.Trace
#endif

The basic idea is to keep curves where one side is inside the filled
region, and the other side is outside, and discard the rest. 
Since that could be true only of a part of the curve, I also need to
split each curve when it intersects
another curve.  How to know which side is the inside, and which
side the outside?  There are two methods which are use the most: the
[*even-odd rule*](https://en.wikipedia.org/wiki/Even%E2%80%93odd_rule)
and the [*nonzero rule*](https://en.wikipedia.org/wiki/Nonzero-rule).
Instead of hardwiring it, I use higher-order functions to determine
when a turnratio is inside the region to be filled, and how the
turnratio changes with each curve.

Checking each pair of curves for intersections would work, but is
rather inefficient.  I only need to check for overlap when two curves
are adjacent.  Fortunately there exist a good method from
*computational geometry*, called the *sweep line algorithm*.  The 
idea is to sweep a vertical line over the input, starting from
leftmost point to the right (of course the opposite direction is also
possible), and to update the input dynamically.  I keep track of each
curve that intersects the sweepline by using a balanced tree of
curves.  When adding a new curve, it's only necessary to check for
intersections with the curve above and below.  Since searching on the
tree takes only `O(log n)` operations, this will save a lot of
computation.

The input is processed in horizontal order, and after splitting curves
the order must be preserved, so an ordered structure is needed.  The
standard map library from `Data.Map` is ideal, and has all the
operations needed.  This structure is called the *X-structure*,
since the data is ordered by X coordinate.:

> type XStruct = M.Map PointEvent [Curve]

I use `PointEvent` instead of just `Point`.  This way I can have a `Ord`
instance for the map, which must match the horizontal ordering.  A
newtype is ideal, since it has no extra cost, and allows me to define
a Ord instance for defining the relative order.  The value from the
map is a list, since there can be many curves starting from the same
point.

> newtype PointEvent = PointEvent DPoint
>
> instance Show PointEvent where
>    show :: PointEvent -> String
show (PointEvent (Point Double
px Double
py)) = forall r. PrintfType r => String -> r
printf String
"(%.5g, %.5g)" Double
px Double
py

When the x-coordinates are equal, use the y-coordinate to determine
the order.

> instance Eq PointEvent where
>   (PointEvent (Point Double
x1 Double
y1)) == :: PointEvent -> PointEvent -> Bool
== (PointEvent (Point Double
x2 Double
y2)) =
>     (Double
x1, Double
y1) forall a. Eq a => a -> a -> Bool
== (Double
x2, Double
y2)
>
> instance Ord PointEvent where
>   compare :: PointEvent -> PointEvent -> Ordering
compare (PointEvent (Point Double
x1 Double
y1)) (PointEvent (Point Double
x2 Double
y2)) =
>     forall a. Ord a => a -> a -> Ordering
compare (Double
x1, Double
y2) (Double
x2, Double
y1)

All curves are kept left to right, so I need to remember the
curve direction for the output:

The curves intersecting the sweepline are kept in another balanced
Tree, called the *Y-structure*.  *These curves are not allowed to
overlap*, except in the endpoints, and will be ordered vertically.
The `Curve` datatype defines the ordering of the curves,
and adds additional information.  The `turnRatio` field is the
turnRatio of the area to the left for a left to right curve, and to
the right for a right to left curve.  The `changeTurn` function
determines how the turnRatio will change from up to down.  This
together with a test for the *insideness* of a certain turnratio,
allows for more flexibility.  Using this, it is possible to generalize
this algorithm to boolean operations!

The curveRank parameter is used to memoize the order in the Ystruct.
This will avoid costly comparisons for tree rebalancing etc...

The FillRule datatype is used for the exported API:

> data FillRule = EvenOdd | NonZero

> data Curve = Curve {
>   Curve -> CubicBezier Double
_bezier :: !(CubicBezier Double),
>   Curve -> (Int, Int)
_turnRatio :: !(Int, Int),
>   Curve -> (Int, Int) -> (Int, Int)
_changeTurn :: !((Int, Int) -> (Int, Int)),
>   Curve -> Maybe (Ratio Integer)
_curveRank :: Maybe (Ratio Integer)}
>
> trOne :: (Int, Int)
> trOne :: (Int, Int)
trOne = (Int
0,Int
0)
>
> between :: Ratio Integer -> Ratio Integer -> Ratio Integer
> between :: Ratio Integer -> Ratio Integer -> Ratio Integer
between Ratio Integer
a Ratio Integer
b = Ratio Integer
a forall a. Num a => a -> a -> a
+(Ratio Integer
bforall a. Num a => a -> a -> a
-Ratio Integer
a)forall a. Fractional a => a -> a -> a
/Ratio Integer
2
> 
> makeLenses ''Curve
>
> instance Show Curve where
>   show :: Curve -> String
show (Curve (CubicBezier (Point Double
p0x Double
p0y) (Point Double
p1x Double
p1y)
>               (Point Double
p2x Double
p2y) (Point Double
p3x Double
p3y)) (Int
t1, Int
t2) (Int, Int) -> (Int, Int)
_ Maybe (Ratio Integer)
o) =
>     forall r. PrintfType r => String -> r
printf String
"Curve (%.5g, %.5g) (%.5g, %.5g) (%.5g, %.5g) (%.5g, %.5g) (%i,%i) %s" 
>     Double
p0x Double
p0y Double
p1x Double
p1y Double
p2x Double
p2y Double
p3x Double
p3y Int
t1 Int
t2 (forall a. Show a => a -> String
show Maybe (Ratio Integer)
o)
> 
> type YStruct = S.Set Curve

The total state for the algorithm consists of the X-structure, the
Y-structure, and the output found so far.  I use a trick to make
access to curves above and below the current pointevent more
convenient.  I use two sets to represent a focus point into the
Y-structure, where the left set are the elements less than the
pointEvent (above), and the right set the elements greater (below):

> data SweepState = SweepState {
>   SweepState -> Map PointEvent [CubicBezier Double]
_output :: !(M.Map PointEvent [CubicBezier Double]),
>   SweepState -> YStruct
_yStruct :: !YStruct,
>   SweepState -> Point Double
_focusPoint :: DPoint,
>   SweepState -> XStruct
_xStruct :: !XStruct}
>                   
> makeLenses ''SweepState

> singularC :: Point Double -> Curve
> singularC :: Point Double -> Curve
singularC Point Double
p = CubicBezier Double
-> (Int, Int)
-> ((Int, Int) -> (Int, Int))
-> Maybe (Ratio Integer)
-> Curve
Curve (forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point Double
p Point Double
p Point Double
p Point Double
p) (Int, Int)
trOne forall a. a -> a
id forall a. Maybe a
Nothing
>

Some functions for debugging:

> showCurve :: CubicBezier Double -> String
showCurve (CubicBezier Point Double
p0 Point Double
p1 Point Double
p2 Point Double
p3) =
>   Point Double -> String
showPt Point Double
p0 forall a. [a] -> [a] -> [a]
++ Point Double -> String
showPt Point Double
p1 forall a. [a] -> [a] -> [a]
++ Point Double -> String
showPt Point Double
p2 forall a. [a] -> [a] -> [a]
++ Point Double -> String
showPt Point Double
p3
>
> showPt :: DPoint -> String
> showPt :: Point Double -> String
showPt (Point Double
x Double
y) = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
x forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
y forall a. [a] -> [a] -> [a]
++ String
")"
>
#ifdef DEBUG
> type SweepStateM = StateT SweepState IO
>
> traceMessage :: String -> SweepStateM ()
> traceMessage msg = liftIO $ hPutStrLn stderr msg
>
> assert :: Bool -> String -> SweepStateM ()
> assert p msg = unless p $ liftIO $ hPutStrLn stderr $ "ASSERT " ++ msg
>
> assertTrace p msg e
>   | p = e
>   | otherwise = trace ("ASSERT " ++ msg) e
>
#else
> -- | output a trace of the algorithm when compiled with @-fdebug@.
> type SweepStateM  = State SweepState
>
> assertTrace :: p -> p -> p -> p
assertTrace p
_ p
_ p
e  = p
e
> 
> traceMessage :: p -> m ()
traceMessage p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
>
> assert :: Bool -> String -> SweepStateM ()
> assert :: Bool -> String -> SweepStateM ()
assert Bool
_ String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

> activate, deactivate :: [Curve] -> SweepStateM ()
> activate :: [Curve] -> SweepStateM ()
activate [Curve]
cs = 
>   forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"ACTIVATE " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CubicBezier Double -> String
showCurve forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier) [Curve]
cs
> 
> deactivate :: [Curve] -> SweepStateM ()
deactivate [Curve]
cs = 
>   forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"DEACTIVATE " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. CubicBezier Double -> String
showCurve forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier) [Curve]
cs


This handy helper function will pass the first curve above to the
given function, and if it doesn't return `Nothing`, remove it from the
state.  It does nothing when there is no curve above.

> withAbove :: (Curve -> Maybe a) -> SweepStateM (Maybe a)
> withAbove :: forall a. (Curve -> Maybe a) -> SweepStateM (Maybe a)
withAbove Curve -> Maybe a
f = do
>   Point Double
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState (Point Double)
focusPoint
>   YStruct
yStr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   let i :: Int
i = Curve -> YStruct -> Int
yStructIndex (Point Double -> Curve
singularC Point Double
p) YStruct
yStr
>   if Int
i forall a. Ord a => a -> a -> Bool
< Int
0
>     then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
>     else let c :: Curve
c = forall a. Int -> Set a -> a
S.elemAt Int
i YStruct
yStr
>          in case Curve -> Maybe a
f Curve
c of
>               Maybe a
Nothing ->
>                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
>               Just a
x -> do
>                 Int -> SweepStateM ()
yStructDel Int
i
>                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x

The same with the curve below.

> withBelow :: (Curve -> Maybe a) -> SweepStateM (Maybe a)
> withBelow :: forall a. (Curve -> Maybe a) -> SweepStateM (Maybe a)
withBelow Curve -> Maybe a
f = do
>   Point Double
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState (Point Double)
focusPoint
>   YStruct
yStr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   let i :: Int
i = Curve -> YStruct -> Int
yStructIndex (Point Double -> Curve
singularC Point Double
p) YStruct
yStr
>       s :: Int
s = forall a. Set a -> Int
S.size YStruct
yStr
>   if Int
i forall a. Ord a => a -> a -> Bool
>= Int
sforall a. Num a => a -> a -> a
-Int
1
>     then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
>     else let c :: Curve
c = forall a. Int -> Set a -> a
S.elemAt (Int
iforall a. Num a => a -> a -> a
+Int
1) YStruct
yStr
>          in case Curve -> Maybe a
f Curve
c of
>               Maybe a
Nothing ->
>                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
>               Just a
x -> do
>                 Int -> SweepStateM ()
yStructDel (Int
iforall a. Num a => a -> a -> a
+Int
1)
>                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x

`splitYStruct` changes the focus and returns and removes any curves which end in
the current pointEvent:

> splitYStruct :: DPoint -> SweepStateM [Curve]
> splitYStruct :: Point Double -> SweepStateM [Curve]
splitYStruct Point Double
p = do
>   YStruct
yStr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   Lens' SweepState (Point Double)
focusPoint forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Point Double
p
>   forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"CHANGEFOCUS " forall a. [a] -> [a] -> [a]
++ Point Double -> String
showPt Point Double
p
>   forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Remove curves ending at pointevent from Y structure" 
>   let lStr :: YStruct
lStr = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> (Set a, Set a)
S.split (Point Double -> Curve
singularC Point Double
p) YStruct
yStr
>       rightCurves :: [Curve]
rightCurves = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Curve
c -> forall a. CubicBezier a -> Point a
cubicC3 (Curve -> CubicBezier Double
_bezier Curve
c) forall a. Eq a => a -> a -> Bool
== Point Double
p) forall a b. (a -> b) -> a -> b
$
>                     forall a. Set a -> [a]
S.toDescList YStruct
lStr
>       nR :: Int
nR = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Curve]
rightCurves
>       i :: Int
i = forall a. Set a -> Int
S.size YStruct
lStr forall a. Num a => a -> a -> a
- Int
nR
>   forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
nR (Int -> SweepStateM ()
yStructDel Int
i)
>   forall (m :: * -> *) a. Monad m => a -> m a
return [Curve]
rightCurves
>

=== Some functions on the Sweep state:

Adding and removing curves from the X structure.

> insertX :: PointEvent -> [Curve] -> SweepStateM ()
> insertX :: PointEvent -> [Curve] -> SweepStateM ()
insertX PointEvent
p [Curve]
c =
>   forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SweepState XStruct
xStruct forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. [a] -> [a] -> [a]
(++) PointEvent
p [Curve]
c
>
> xStructAdd :: Curve -> SweepStateM ()
> xStructAdd :: Curve -> SweepStateM ()
xStructAdd Curve
c = do
>   forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"XSTRUCTADD " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c)
>   PointEvent -> [Curve] -> SweepStateM ()
insertX (Point Double -> PointEvent
PointEvent forall a b. (a -> b) -> a -> b
$ forall a. CubicBezier a -> Point a
cubicC0 forall a b. (a -> b) -> a -> b
$
>            forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c) [Curve
c]
>
> xStructRemove :: SweepStateM (PointEvent, [Curve])
> xStructRemove :: SweepStateM (PointEvent, [Curve])
xStructRemove = do
>   XStruct
str <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState XStruct
xStruct
>   forall (m :: * -> *) a. Monad m => a -> m a
return XStruct
str
>   (PointEvent
p, [Curve]
c) <- forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom Lens' SweepState XStruct
xStruct forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state forall k a. Map k a -> ((k, a), Map k a)
M.deleteFindMin
>   forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"XSTRUCTREM " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>              CubicBezier Double -> String
showCurve forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier) [Curve]
c
>   XStruct
str <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState XStruct
xStruct
>   forall (m :: * -> *) a. Monad m => a -> m a
return XStruct
str
>   forall (m :: * -> *) a. Monad m => a -> m a
return (PointEvent
p, [Curve]
c)
>
> yStructIndex :: Curve -> YStruct -> Int
> yStructIndex :: Curve -> YStruct -> Int
yStructIndex Curve
c YStruct
str = forall a. Set a -> Int
S.size (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> (Set a, Set a)
S.split Curve
c YStruct
str) forall a. Num a => a -> a -> a
- Int
1
>
> yStructDel :: Int -> SweepStateM ()
> yStructDel :: Int -> SweepStateM ()
yStructDel Int
i = do
>   YStruct
str <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"YSTRUCTREM " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier forall a b. (a -> b) -> a -> b
$ forall a. Int -> Set a -> a
S.elemAt Int
i YStruct
str)
>   Lens' SweepState YStruct
yStruct forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Int -> Set a -> Set a
S.deleteAt Int
i YStruct
str
>

Insert the curve into the Y structure.  First lookup the position of
the curve, then calculate the rank of the curve, using the surrounding
elements.  Insert the curve using the rank.  This will avoid repeating
expensive operations.

> 
> yStructAdd :: Curve -> SweepStateM ()
> yStructAdd :: Curve -> SweepStateM ()
yStructAdd Curve
c = do
>   YStruct
str <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"YSTRUCTADD " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c)
>   forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"YSTRUCT: " forall a. [a] -> [a] -> [a]
++
>       (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
"\n  " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (CubicBezier Double -> String
showCurve forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList YStruct
str)
>   Bool -> String -> SweepStateM ()
assert (forall a. Maybe a -> Bool
isNothing (Curve -> Maybe (Ratio Integer)
_curveRank Curve
c))
>     String
"CURVE ALREADY HAS A RANK IN THE YSTRUCT" 
>   Bool -> String -> SweepStateM ()
assert (Curve -> YStruct -> Bool
yStructConsistent Curve
c YStruct
str)
>    (String
"Y STRUCT NOT CONSISTENT WITH CURVE:" forall a. [a] -> [a] -> [a]
++
>    forall a. Show a => a -> String
show (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => a -> a -> Ordering
compare Curve
c) (forall a. Set a -> [a]
S.toAscList YStruct
str)) )
>   let i :: Int
i = Curve -> YStruct -> Int
yStructIndex Curve
c YStruct
str
>       s :: Int
s = forall a. Set a -> Int
S.size YStruct
str
>       newC :: Curve
newC 
>         | Int
s forall a. Eq a => a -> a -> Bool
== Int
0 = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Maybe (Ratio Integer))
curveRank (forall a. a -> Maybe a
Just Ratio Integer
0) Curve
c
>         | Int
i forall a. Ord a => a -> a -> Bool
>= Int
sforall a. Num a => a -> a -> a
-Int
1 = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Maybe (Ratio Integer))
curveRank ((forall a. Num a => a -> a -> a
+Ratio Integer
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Curve -> Maybe (Ratio Integer)
_curveRank (forall a. Int -> Set a -> a
S.elemAt (Int
sforall a. Num a => a -> a -> a
-Int
1) YStruct
str)) Curve
c
>         | Int
i forall a. Ord a => a -> a -> Bool
< Int
0 = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Maybe (Ratio Integer))
curveRank (forall a. Num a => a -> a -> a
subtract Ratio Integer
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Curve -> Maybe (Ratio Integer)
_curveRank (forall a. Int -> Set a -> a
S.elemAt Int
0 YStruct
str)) Curve
c
>         | Bool
otherwise = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Maybe (Ratio Integer))
curveRank (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Ratio Integer -> Ratio Integer -> Ratio Integer
between
>                                       (Curve -> Maybe (Ratio Integer)
_curveRank forall a b. (a -> b) -> a -> b
$ forall a. Int -> Set a -> a
S.elemAt Int
i YStruct
str)
>                                       (Curve -> Maybe (Ratio Integer)
_curveRank forall a b. (a -> b) -> a -> b
$ forall a. Int -> Set a -> a
S.elemAt (Int
iforall a. Num a => a -> a -> a
+Int
1) YStruct
str)) Curve
c
>   Bool -> String -> SweepStateM ()
assert (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
S.member Curve
c YStruct
str)
>     (String
"CURVE ALREADY IN YSTRUCT: " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c))
>   Bool -> String -> SweepStateM ()
assert (forall a. Set a -> Int
S.size YStruct
str forall a. Ord a => a -> a -> Bool
< forall a. Set a -> Int
S.size (forall a. Ord a => a -> Set a -> Set a
S.insert Curve
newC YStruct
str)) forall a b. (a -> b) -> a -> b
$
>     String
"CURVE NOT ADDED TO YSTRUCT" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Curve
newC 
>   Lens' SweepState YStruct
yStruct forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Ord a => a -> Set a -> Set a
S.insert Curve
newC YStruct
str
> 
> yStructConsistent :: Curve -> YStruct -> Bool
> yStructConsistent :: Curve -> YStruct -> Bool
yStructConsistent Curve
c YStruct
str =
>   forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> a -> Bool
> Curve
c) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Ord a => a -> a -> Bool
< Curve
c) forall a b. (a -> b) -> a -> b
$
>   forall a. Set a -> [a]
S.toAscList YStruct
str
>
> yStructOverlap :: Curve -> YStruct -> [String]
> yStructOverlap :: Curve -> YStruct -> [String]
yStructOverlap Curve
c YStruct
str =
>   forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Curve -> Maybe String
checkOverlap forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toAscList YStruct
str
>   where checkOverlap :: Curve -> Maybe String
checkOverlap Curve
c2 =
>           case Curve
-> Curve -> Double -> (Maybe (Curve, Curve), Maybe (Curve, Curve))
splitMaybe Curve
c Curve
c2 Double
1e-5 of
>             (Maybe (Curve, Curve)
Nothing, Maybe (Curve, Curve)
Nothing) -> forall a. Maybe a
Nothing
>             (Maybe (Curve, Curve), Maybe (Curve, Curve))
_ -> forall a. a -> Maybe a
Just (forall a. Show a => a -> String
show Curve
c2 forall a. [a] -> [a] -> [a]
++ String
"\n")

To compare curves vertically, take the the curve which starts the
rightmost, and see if it falls below or above the curve.  If the first
control points are coincident, test the last control points instead,
or the midpoint.  This works because if the first point is coincident
the curves shouldn't intersect except in the endpoints (see #splitAndOrder).
To lookup a single point, I use a singular bezier curve.

> instance Eq Curve where
>    Curve CubicBezier Double
_ (Int, Int)
_ (Int, Int) -> (Int, Int)
_ (Just Ratio Integer
o1) == :: Curve -> Curve -> Bool
== Curve CubicBezier Double
_ (Int, Int)
_ (Int, Int) -> (Int, Int)
_ (Just Ratio Integer
o2) = Ratio Integer
o1 forall a. Eq a => a -> a -> Bool
== Ratio Integer
o2
>    Curve CubicBezier Double
c1 (Int, Int)
t1 (Int, Int) -> (Int, Int)
ct1 Maybe (Ratio Integer)
_ == Curve CubicBezier Double
c2 (Int, Int)
t2 (Int, Int) -> (Int, Int)
ct2 Maybe (Ratio Integer)
_ =
>     CubicBezier Double
c1 forall a. Eq a => a -> a -> Bool
== CubicBezier Double
c2 Bool -> Bool -> Bool
&& (Int, Int)
t1 forall a. Eq a => a -> a -> Bool
== (Int, Int)
t2 Bool -> Bool -> Bool
&& (Int, Int) -> (Int, Int)
ct1 (Int, Int)
t1 forall a. Eq a => a -> a -> Bool
== (Int, Int) -> (Int, Int)
ct2 (Int, Int)
t2
>     
> instance Ord Curve where
>   compare :: Curve -> Curve -> Ordering
compare (Curve CubicBezier Double
_ (Int, Int)
_ (Int, Int) -> (Int, Int)
_ (Just Ratio Integer
o1)) (Curve CubicBezier Double
_ (Int, Int)
_ (Int, Int) -> (Int, Int)
_ (Just Ratio Integer
o2)) = forall a. Ord a => a -> a -> Ordering
compare Ratio Integer
o1 Ratio Integer
o2
>   compare (Curve c1 :: CubicBezier Double
c1@(CubicBezier Point Double
p0 Point Double
p1 Point Double
p2 Point Double
p3) (Int, Int)
tr1 (Int, Int) -> (Int, Int)
_ Maybe (Ratio Integer)
_)
>     (Curve c2 :: CubicBezier Double
c2@(CubicBezier Point Double
q0 Point Double
q1 Point Double
q2 Point Double
q3) (Int, Int)
tr2 (Int, Int) -> (Int, Int)
_ Maybe (Ratio Integer)
_)
>     | Point Double
p0 forall a. Eq a => a -> a -> Bool
== Point Double
q0 = if
>         | Point Double
p3 forall a. Eq a => a -> a -> Bool
== Point Double
q3 ->
>             -- compare the midpoint
>             case Point Double -> CubicBezier Double -> Ordering
compVert (forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
c1 Double
0.5) CubicBezier Double
c2 of
>              Ordering
LT -> Ordering
LT
>              Ordering
GT -> Ordering
GT
>              Ordering
EQ ->
>                -- otherwise arbitrary
>                forall a. Ord a => a -> a -> Ordering
compare ((Int, Int)
tr1, Point Double -> PointEvent
PointEvent Point Double
p1, Point Double -> PointEvent
PointEvent Point Double
p2)
>                ((Int, Int)
tr2, Point Double -> PointEvent
PointEvent Point Double
q1, Point Double -> PointEvent
PointEvent Point Double
q2)
>         | forall a. Point a -> a
pointX Point Double
p3 forall a. Ord a => a -> a -> Bool
< forall a. Point a -> a
pointX Point Double
q3 ->
>             case Point Double -> CubicBezier Double -> Ordering
compVert Point Double
p3 CubicBezier Double
c2 of
>             Ordering
LT -> Ordering
LT
>             Ordering
EQ -> Ordering
LT
>             Ordering
GT -> Ordering
GT
>         | Bool
otherwise ->
>             case Point Double -> CubicBezier Double -> Ordering
compVert Point Double
q3 CubicBezier Double
c1 of
>              Ordering
LT -> Ordering
GT
>              Ordering
EQ -> Ordering
GT
>              Ordering
GT -> Ordering
LT
>     | forall a. Point a -> a
pointX Point Double
p0 forall a. Ord a => a -> a -> Bool
< forall a. Point a -> a
pointX Point Double
q0 =
>       case Point Double -> CubicBezier Double -> Ordering
compVert Point Double
q0 CubicBezier Double
c1 of
>        Ordering
LT -> Ordering
GT
>        Ordering
EQ -> Ordering
LT
>        Ordering
GT -> Ordering
LT
>     | Bool
otherwise =
>       case Point Double -> CubicBezier Double -> Ordering
compVert Point Double
p0 CubicBezier Double
c2 of
>       Ordering
LT -> Ordering
LT
>       Ordering
EQ -> Ordering
GT
>       Ordering
GT -> Ordering
GT

Compare a point with a curve.  See if it falls below or above the hull
first.  Otherwise find the point on the curve with the same
X-coordinate by iterating.

> compVert :: DPoint -> CubicBezier Double -> Ordering
> compVert :: Point Double -> CubicBezier Double -> Ordering
compVert Point Double
p CubicBezier Double
c
>   | Point Double
p forall a. Eq a => a -> a -> Bool
== forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
c Bool -> Bool -> Bool
||
>     Point Double
p forall a. Eq a => a -> a -> Bool
== forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
c = Ordering
EQ
>   | Ordering
compH forall a. Eq a => a -> a -> Bool
/= Ordering
EQ = Ordering
compH
>   | Bool
otherwise = Point Double -> CubicBezier Double -> Ordering
comparePointCurve Point Double
p CubicBezier Double
c
>     where
>       compH :: Ordering
compH = Point Double -> CubicBezier Double -> Ordering
compareHull Point Double
p CubicBezier Double
c

=== Test if the point is above or below the curve {#comparePC}

> comparePointCurve :: Point Double -> CubicBezier Double -> Ordering
> comparePointCurve :: Point Double -> CubicBezier Double -> Ordering
comparePointCurve (Point Double
x1 Double
y1) c1 :: CubicBezier Double
c1@(CubicBezier Point Double
p0 Point Double
p1 Point Double
p2 Point Double
p3)
>   | forall a. Point a -> a
pointX Point Double
p0 forall a. Eq a => a -> a -> Bool
== Double
x1 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointX Point Double
p0 forall a. Eq a => a -> a -> Bool
== forall a. Point a -> a
pointX Point Double
p1 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointX Point Double
p0 forall a. Eq a => a -> a -> Bool
== forall a. Point a -> a
pointX Point Double
p2 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointX Point Double
p0 forall a. Eq a => a -> a -> Bool
== forall a. Point a -> a
pointX Point Double
p3 =
>     forall a. Ord a => a -> a -> Ordering
compare (forall a. Point a -> a
pointY Point Double
p0) Double
y1
>   | Bool
otherwise = forall a. Ord a => a -> a -> Ordering
compare Double
y2 Double
y1
>   where
>     t :: Double
t = CubicBezier Double -> Double -> Double -> Double
findX CubicBezier Double
c1 Double
x1 (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a
absforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Point a -> a
pointX) [Point Double
p0, Point Double
p1, Point Double
p2, Point Double
p3])forall a. Num a => a -> a -> a
*Double
1e-14)
>     y2 :: Double
y2 = forall a. Point a -> a
pointY forall a b. (a -> b) -> a -> b
$ forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
c1 Double
t

=== Comparing against the hull {#hull}

Compare a point against the convex hull of the bezier.  `EQ` means the
point is inside the hull, `LT` below and `GT` above.  I am currently
only testing against the control points, some testing needs to be done
to see what is faster.

> belowLine :: DPoint -> DPoint -> DPoint -> Bool
> belowLine :: Point Double -> Point Double -> Point Double -> Bool
belowLine (Point Double
px Double
py) (Point Double
lx Double
ly) (Point Double
rx Double
ry)
>   | Double
lx forall a. Eq a => a -> a -> Bool
== Double
rx = Bool
True
>   | (Double
px forall a. Ord a => a -> a -> Bool
>= Double
lx Bool -> Bool -> Bool
&& Double
px forall a. Ord a => a -> a -> Bool
<= Double
rx) Bool -> Bool -> Bool
||
>     (Double
px forall a. Ord a => a -> a -> Bool
<= Double
lx Bool -> Bool -> Bool
&& Double
px forall a. Ord a => a -> a -> Bool
>= Double
rx) = Double
py forall a. Ord a => a -> a -> Bool
< Double
midY
>   | Bool
otherwise = Bool
True
>   where midY :: Double
midY = Double
ly forall a. Num a => a -> a -> a
+ (Double
ryforall a. Num a => a -> a -> a
-Double
ly) forall a. Num a => a -> a -> a
* (Double
rxforall a. Num a => a -> a -> a
-Double
lx) forall a. Fractional a => a -> a -> a
/ (Double
pxforall a. Num a => a -> a -> a
-Double
lx)
> 
> aboveLine :: DPoint -> DPoint -> DPoint -> Bool
> aboveLine :: Point Double -> Point Double -> Point Double -> Bool
aboveLine (Point Double
px Double
py) (Point Double
lx Double
ly) (Point Double
rx Double
ry)
>   | Double
lx forall a. Eq a => a -> a -> Bool
== Double
rx = Bool
True
>   | (Double
px forall a. Ord a => a -> a -> Bool
>= Double
lx Bool -> Bool -> Bool
&& Double
px forall a. Ord a => a -> a -> Bool
<= Double
rx) Bool -> Bool -> Bool
||
>     (Double
px forall a. Ord a => a -> a -> Bool
<= Double
lx Bool -> Bool -> Bool
&& Double
px forall a. Ord a => a -> a -> Bool
>= Double
rx) = Double
py forall a. Ord a => a -> a -> Bool
> Double
midY
>   | Bool
otherwise = Bool
True
>   where midY :: Double
midY = Double
ly forall a. Num a => a -> a -> a
+ (Double
ryforall a. Num a => a -> a -> a
-Double
ly) forall a. Num a => a -> a -> a
* (Double
rxforall a. Num a => a -> a -> a
-Double
lx) forall a. Fractional a => a -> a -> a
/ (Double
pxforall a. Num a => a -> a -> a
-Double
lx)
> 
> compareHull :: DPoint -> CubicBezier Double -> Ordering
> compareHull :: Point Double -> CubicBezier Double -> Ordering
compareHull Point Double
p (CubicBezier Point Double
c0 Point Double
c1 Point Double
c2 Point Double
c3)
>   | forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
> forall a. Point a -> a
pointY Point Double
c0 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
> forall a. Point a -> a
pointY Point Double
c1 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
> forall a. Point a -> a
pointY Point Double
c2 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
> forall a. Point a -> a
pointY Point Double
c3 = Ordering
LT
>   | forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
< forall a. Point a -> a
pointY Point Double
c0 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
< forall a. Point a -> a
pointY Point Double
c1 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
< forall a. Point a -> a
pointY Point Double
c2 Bool -> Bool -> Bool
&&
>     forall a. Point a -> a
pointY Point Double
p forall a. Ord a => a -> a -> Bool
< forall a. Point a -> a
pointY Point Double
c3 = Ordering
GT
>   | Bool
otherwise = Ordering
EQ

Preprocessing
-------------

Since the algorithm assumes curves are increasing in the horizontal
direction they have to be preprocessed first.  I split each curve
where the tangent is vertical.  If the resulting subsegment is too
small however, I just adjust the control point to make the curve
vertical at the endpoint.

I also do snaprounding to prevent points closer than the tolerance.

> makeXStruct :: ((Int, Int) -> (Int, Int)) -> ((Int, Int) -> (Int, Int)) -> Double -> [CubicBezier Double] -> XStruct
> makeXStruct :: ((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> Double
-> [CubicBezier Double]
-> XStruct
makeXStruct (Int, Int) -> (Int, Int)
chTr (Int, Int) -> (Int, Int)
chTrBack Double
tol =
>   forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>   forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CubicBezier Double -> [(PointEvent, [Curve])]
toCurve forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>   forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Double -> CubicBezier Double -> [CubicBezier Double]
splitVert Double
tol)
>   where toCurve :: CubicBezier Double -> [(PointEvent, [Curve])]
toCurve c :: CubicBezier Double
c@(CubicBezier Point Double
p0 Point Double
_ Point Double
_ Point Double
p3) =
>           case forall a. Ord a => a -> a -> Ordering
compare (forall a. Point a -> a
pointX Point Double
p0) (forall a. Point a -> a
pointX Point Double
p3) of
>            Ordering
LT -> [(Point Double -> PointEvent
PointEvent Point Double
p0, [CubicBezier Double
-> (Int, Int)
-> ((Int, Int) -> (Int, Int))
-> Maybe (Ratio Integer)
-> Curve
Curve CubicBezier Double
c (Int, Int)
trOne (Int, Int) -> (Int, Int)
chTr forall a. Maybe a
Nothing])]
>            Ordering
GT -> [(Point Double -> PointEvent
PointEvent Point Double
p3, [CubicBezier Double
-> (Int, Int)
-> ((Int, Int) -> (Int, Int))
-> Maybe (Ratio Integer)
-> Curve
Curve (forall (b :: * -> *) a. (GenericBezier b, Unbox a) => b a -> b a
reorient CubicBezier Double
c) (Int, Int)
trOne (Int, Int) -> (Int, Int)
chTrBack forall a. Maybe a
Nothing]),
>                   (Point Double -> PointEvent
PointEvent Point Double
p0, [])]
>            -- vertical curve
>            Ordering
EQ | forall a. Point a -> a
pointY Point Double
p0 forall a. Ord a => a -> a -> Bool
> forall a. Point a -> a
pointY Point Double
p3 ->
>                 [(Point Double -> PointEvent
PointEvent Point Double
p0, [CubicBezier Double
-> (Int, Int)
-> ((Int, Int) -> (Int, Int))
-> Maybe (Ratio Integer)
-> Curve
Curve CubicBezier Double
c (Int, Int)
trOne (Int, Int) -> (Int, Int)
chTr forall a. Maybe a
Nothing])]
>               | Bool
otherwise ->
>                 [(Point Double -> PointEvent
PointEvent Point Double
p3, [CubicBezier Double
-> (Int, Int)
-> ((Int, Int) -> (Int, Int))
-> Maybe (Ratio Integer)
-> Curve
Curve (forall (b :: * -> *) a. (GenericBezier b, Unbox a) => b a -> b a
reorient CubicBezier Double
c) (Int, Int)
trOne (Int, Int) -> (Int, Int)
chTrBack forall a. Maybe a
Nothing]),
>                  (Point Double -> PointEvent
PointEvent Point Double
p0, [])]
>
> splitVert :: Double -> CubicBezier Double -> [CubicBezier Double]
> splitVert :: Double -> CubicBezier Double -> [CubicBezier Double]
splitVert Double
tol curve :: CubicBezier Double
curve@(CubicBezier Point Double
c0 Point Double
c1 Point Double
c2 Point Double
c3) = 
>   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a (b :: * -> *).
(Ord a, Unbox a, Fractional a, GenericBezier b) =>
b a -> [a] -> [b a]
splitBezierN forall a b. (a -> b) -> a -> b
$
>   (CubicBezier Double, [Double]) -> (CubicBezier Double, [Double])
adjustLast forall a b. (a -> b) -> a -> b
$
>   (CubicBezier Double, [Double]) -> (CubicBezier Double, [Double])
adjustFirst (CubicBezier Double
curve, [Double]
vert)
>   where vert :: [Double]
vert
>           | forall a. Point a -> a
pointX Point Double
c0 forall a. Eq a => a -> a -> Bool
== forall a. Point a -> a
pointX Point Double
c1 Bool -> Bool -> Bool
&&
>             forall a. Point a -> a
pointX Point Double
c0 forall a. Eq a => a -> a -> Bool
== forall a. Point a -> a
pointX Point Double
c2 Bool -> Bool -> Bool
&&
>             forall a. Point a -> a
pointX Point Double
c0 forall a. Eq a => a -> a -> Bool
== forall a. Point a -> a
pointX Point Double
c3 = []
>           | Bool
otherwise = 
>               forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ CubicBezier Double -> [Double]
bezierVert CubicBezier Double
curve
>         -- adjust control points to avoid small curve fragments
>         -- near the endpoints
>         adjustFirst :: (CubicBezier Double, [Double]) -> (CubicBezier Double, [Double])
adjustFirst (c :: CubicBezier Double
c@(CubicBezier Point Double
p0 Point Double
p1 Point Double
p2 Point Double
p3), Double
t:[Double]
ts)
>           | forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
p0 (forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
c Double
t) forall a. Ord a => a -> a -> Bool
< Double
tol =
>               (forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point Double
p0 (forall a. a -> a -> Point a
Point (forall a. Point a -> a
pointX Point Double
p0) (forall a. Point a -> a
pointY Point Double
p1)) Point Double
p2 Point Double
p3,
>                [Double]
ts)
>         adjustFirst (CubicBezier Double, [Double])
x = (CubicBezier Double, [Double])
x
>         adjustLast :: (CubicBezier Double, [Double]) -> (CubicBezier Double, [Double])
adjustLast (c :: CubicBezier Double
c@(CubicBezier Point Double
p0 Point Double
p1 Point Double
p2 Point Double
p3), ts :: [Double]
ts@(Double
_:[Double]
_))
>           | forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
p3 (forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
c forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [Double]
ts) forall a. Ord a => a -> a -> Bool
< Double
tol =
>               (forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point Double
p0 Point Double
p1 (forall a. a -> a -> Point a
Point (forall a. Point a -> a
pointX Point Double
p3) (forall a. Point a -> a
pointY Point Double
p2)) Point Double
p3,
>                forall a. [a] -> [a]
init [Double]
ts)
>         adjustLast (CubicBezier Double, [Double])
x = (CubicBezier Double, [Double])
x

main loop
---------

For the main loop, I remove the leftmost point from the
X-structure, and do the following steps:

  1. Split any curves which come near the current pointEvent.

  2. Send all curves to the left of the sweepline to the output, after
  filtering them based on the turning number.

  3. For each curve starting at the point, split if it intersects with
the curve above or the curve below.  Sort resulting curves vertically.
If there are no curves starting from point, test the curves above and
below instead.  Adjust the turnRatios for each curve.

  4. Insert the points in the Y structure.

  5. Loop until the X-structure is empty

> loopEvents :: ((Int, Int) -> Bool) -> Double -> SweepStateM ()
> loopEvents :: ((Int, Int) -> Bool) -> Double -> SweepStateM ()
loopEvents (Int, Int) -> Bool
isInside Double
tol = do
>   XStruct
xStr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState XStruct
xStruct
>   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
M.null XStruct
xStr) forall a b. (a -> b) -> a -> b
$ do
>       (PointEvent Point Double
p, [Curve]
curves) <- SweepStateM (PointEvent, [Curve])
xStructRemove
>       [Curve] -> SweepStateM ()
activate [Curve]
curves
>       
>       [Curve]
ending <- Point Double -> SweepStateM [Curve]
splitYStruct Point Double
p
>       [Curve] -> SweepStateM ()
activate [Curve]
ending
>
>       -- split near curves
>       forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Split curves near the focuspoint." 
>       ([Curve]
ending2, [Curve]
rightSubCurves) <- Point Double -> Double -> SweepStateM ([Curve], [Curve])
splitNearPoints Point Double
p Double
tol
>
>       [Curve] -> SweepStateM ()
activate [Curve]
ending2
>       [Curve] -> SweepStateM ()
activate [Curve]
rightSubCurves
>       forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Output curves"
>        
>       -- output curves to the left of the sweepline.
>       [Curve] -> SweepStateM ()
deactivate ([Curve]
ending forall a. [a] -> [a] -> [a]
++ [Curve]
ending2)
>       [Curve] -> ((Int, Int) -> Bool) -> SweepStateM ()
filterOutput ([Curve]
ending forall a. [a] -> [a] -> [a]
++ [Curve]
ending2) (Int, Int) -> Bool
isInside 
>       let allCurves :: [Curve]
allCurves = [Curve]
rightSubCurves forall a. [a] -> [a] -> [a]
++ [Curve]
curves
>       if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Curve]
allCurves
> 
>          -- split surrounding curves
>         then do
>              forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Split curves around pointevent."
>              Double -> SweepStateM ()
splitSurround Double
tol
>         else do
> 
>         -- sort curves
>         forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Sort curves."
>         
>         [Curve]
sorted <- Double -> [Curve] -> SweepStateM [Curve]
splitAndOrder Double
tol [Curve]
allCurves
>         [Curve] -> SweepStateM ()
deactivate [Curve]
allCurves
>         [Curve] -> SweepStateM ()
activate [Curve]
sorted
> 
>         -- split curve above
>         forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Split curve above sorted curves."
>         [Curve] -> SweepStateM ()
deactivate [Curve]
sorted
>         [Curve]
curves2 <- [Curve] -> Double -> SweepStateM [Curve]
splitAbove [Curve]
sorted Double
tol
>         [Curve] -> SweepStateM ()
activate [Curve]
curves2
> 
>         -- add curves to Y structure
>         forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Add curves to Y structure."
>         [Curve] -> SweepStateM ()
deactivate [Curve]
curves2
>         [Curve] -> Double -> SweepStateM ()
addMidCurves [Curve]
curves2 Double
tol
>
>       ((Int, Int) -> Bool) -> Double -> SweepStateM ()
loopEvents (Int, Int) -> Bool
isInside Double
tol


Send curves to output
---------------------

> outputPaths :: M.Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
> outputPaths :: Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputPaths Map PointEvent [CubicBezier Double]
m
>   | forall k a. Map k a -> Bool
M.null Map PointEvent [CubicBezier Double]
m = []
>   | Bool
otherwise = Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputNext Map PointEvent [CubicBezier Double]
m
>   where
>     lookupDelete :: Point Double -> Map PointEvent [a] -> Maybe (a, Map PointEvent [a])
lookupDelete Point Double
p Map PointEvent [a]
m =
>       case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Point Double -> PointEvent
PointEvent Point Double
p) Map PointEvent [a]
m of
>        Maybe [a]
Nothing -> forall a. Maybe a
Nothing
>        Just (a
x:[a]
xs) -> forall a. a -> Maybe a
Just (a
x, Map PointEvent [a]
m')
>          where m' :: Map PointEvent [a]
m' | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs = forall k a. Ord k => k -> Map k a -> Map k a
M.delete (Point Double -> PointEvent
PointEvent Point Double
p) Map PointEvent [a]
m
>                   | Bool
otherwise = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Point Double -> PointEvent
PointEvent Point Double
p) [a]
xs Map PointEvent [a]
m
>        Maybe [a]
_ -> forall a. HasCallStack => String -> a
error String
"outputPaths: empty list inside map."
>     outputNext :: Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputNext !Map PointEvent [CubicBezier Double]
m
>       | forall k a. Map k a -> Bool
M.null Map PointEvent [CubicBezier Double]
m = []
>       | Bool
otherwise = 
>         let ((PointEvent Point Double
p0, CubicBezier Double
c0:[CubicBezier Double]
cs), Map PointEvent [CubicBezier Double]
m0) =
>               forall k a. Map k a -> ((k, a), Map k a)
M.deleteFindMin Map PointEvent [CubicBezier Double]
m
>             m0' :: Map PointEvent [CubicBezier Double]
m0' | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CubicBezier Double]
cs = Map PointEvent [CubicBezier Double]
m0
>                 | Bool
otherwise = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Point Double -> PointEvent
PointEvent Point Double
p0) [CubicBezier Double]
cs Map PointEvent [CubicBezier Double]
m0
>         in Map PointEvent [CubicBezier Double]
-> CubicBezier Double
-> [CubicBezier Double]
-> Point Double
-> [ClosedPath Double]
go Map PointEvent [CubicBezier Double]
m0' CubicBezier Double
c0 [] Point Double
p0
>     go :: Map PointEvent [CubicBezier Double]
-> CubicBezier Double
-> [CubicBezier Double]
-> Point Double
-> [ClosedPath Double]
go !Map PointEvent [CubicBezier Double]
m !CubicBezier Double
next ![CubicBezier Double]
prev !Point Double
start
>       | Point Double
p forall a. Eq a => a -> a -> Bool
== Point Double
start =
>           [CubicBezier Double] -> ClosedPath Double
curvesToPath (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ CubicBezier Double
nextforall a. a -> [a] -> [a]
:[CubicBezier Double]
prev)forall a. a -> [a] -> [a]
:
>           Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputNext Map PointEvent [CubicBezier Double]
m
>       | Bool
otherwise =
>         case forall {a}.
Point Double -> Map PointEvent [a] -> Maybe (a, Map PointEvent [a])
lookupDelete Point Double
p Map PointEvent [CubicBezier Double]
m of
>          Maybe (CubicBezier Double, Map PointEvent [CubicBezier Double])
Nothing -> Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputNext Map PointEvent [CubicBezier Double]
m
>          Just (CubicBezier Double
x, Map PointEvent [CubicBezier Double]
m') -> Map PointEvent [CubicBezier Double]
-> CubicBezier Double
-> [CubicBezier Double]
-> Point Double
-> [ClosedPath Double]
go Map PointEvent [CubicBezier Double]
m' CubicBezier Double
x (CubicBezier Double
nextforall a. a -> [a] -> [a]
:[CubicBezier Double]
prev) Point Double
start
>       where p :: Point Double
p = forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
next
>
> curvesToPath :: [CubicBezier Double] -> ClosedPath Double
> curvesToPath :: [CubicBezier Double] -> ClosedPath Double
curvesToPath =
>   forall a. [(Point a, PathJoin a)] -> ClosedPath a
ClosedPath forall b c a. (b -> c) -> (a -> b) -> a -> c
.
>   forall a b. (a -> b) -> [a] -> [b]
map (\(CubicBezier Point Double
p0 Point Double
p1 Point Double
p2 Point Double
_) ->
>         (Point Double
p0, forall a. Point a -> Point a -> PathJoin a
JoinCurve Point Double
p1 Point Double
p2))

Filter and output the given curves.  The `isInside` function
determines the *insideness* of a give turnratio.  For example for the
nonzero-rule, this would be `(> 0)`.  This inserts the curve into the
output map.

> filterOutput :: [Curve] -> ((Int, Int) -> Bool) -> SweepStateM ()
> filterOutput :: [Curve] -> ((Int, Int) -> Bool) -> SweepStateM ()
filterOutput [Curve]
curves (Int, Int) -> Bool
isInside =
>   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((Int, Int) -> Bool) -> Curve -> SweepStateM ()
outputCurve (Int, Int) -> Bool
isInside)  [Curve]
curves
>
> outputCurve :: ((Int, Int) -> Bool) -> Curve -> SweepStateM ()
> outputCurve :: ((Int, Int) -> Bool) -> Curve -> SweepStateM ()
outputCurve (Int, Int) -> Bool
isInside (Curve CubicBezier Double
c (Int, Int)
tr (Int, Int) -> (Int, Int)
op Maybe (Ratio Integer)
_)
>   | (Int, Int) -> Bool
isInside ((Int, Int) -> (Int, Int)
op (Int, Int)
tr) forall a. Eq a => a -> a -> Bool
/= (Int, Int) -> Bool
isInside (Int, Int)
tr =
>       let c' :: CubicBezier Double
c' | (Int, Int) -> Bool
isInside (Int, Int)
tr = forall (b :: * -> *) a. (GenericBezier b, Unbox a) => b a -> b a
reorient CubicBezier Double
c
>              | Bool
otherwise = CubicBezier Double
c
>       in do forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"OUTPUT " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c
>             forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying Lens' SweepState (Map PointEvent [CubicBezier Double])
output (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. [a] -> [a] -> [a]
(++) (Point Double -> PointEvent
PointEvent forall a b. (a -> b) -> a -> b
$ forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
c') [CubicBezier Double
c'])
>   | Bool
otherwise =
>       forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"DISCARD " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c

Test for intersections and split: (#splitAndOrder)
--------------------------------------------------

Since the curves going out of the current pointEvent in the X-structure are
unordered, they need to be ordered first.  First they are ordered by
first derivative.  Since it's easier to compare two curves when they
don't overlap, remove overlap, and then sort again by comparing the
whole curve.

To do this, I implemented a monadic insertion sort.  First the curves are split
in the statemonad, then they are compared.

> splitAndOrder :: Double -> [Curve] -> SweepStateM [Curve]
> splitAndOrder :: Double -> [Curve] -> SweepStateM [Curve]
splitAndOrder Double
tol [Curve]
curves =
>   Double -> [Curve] -> SweepStateM [Curve]
sortSplit Double
tol forall a b. (a -> b) -> a -> b
$
>   forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Curve -> Curve -> Ordering
compDeriv [Curve]
curves
>
> compDeriv :: Curve -> Curve -> Ordering
> compDeriv :: Curve -> Curve -> Ordering
compDeriv (Curve (CubicBezier Point Double
p0 Point Double
p1 Point Double
_ Point Double
_) (Int, Int)
_ (Int, Int) -> (Int, Int)
_ Maybe (Ratio Integer)
_)
>   (Curve (CubicBezier Point Double
q0 Point Double
q1 Point Double
_ Point Double
_) (Int, Int)
_ (Int, Int) -> (Int, Int)
_ Maybe (Ratio Integer)
_) =
>   forall a. Ord a => a -> a -> Ordering
compare (forall {a}. (Eq a, Fractional a) => Point a -> a
slope (Point Double
q1forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
q0)) (forall {a}. (Eq a, Fractional a) => Point a -> a
slope (Point Double
p1forall v. AdditiveGroup v => v -> v -> v
^-^Point Double
p0)) 
>
> slope :: Point a -> a
slope (Point a
0 a
0) = a
0
> slope (Point a
x a
y) = a
yforall a. Fractional a => a -> a -> a
/a
x


Insertion sort, by splitting and comparing.  This should be efficient
enough, since ordering by derivative should mostly order the curves.

> sortSplit :: Double -> [Curve] -> SweepStateM [Curve]
> sortSplit :: Double -> [Curve] -> SweepStateM [Curve]
sortSplit Double
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
> sortSplit Double
tol (Curve
x:[Curve]
xs) =
>   Curve -> Double -> [Curve] -> SweepStateM [Curve]
insertM Curve
x Double
tol forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
>   Double -> [Curve] -> SweepStateM [Curve]
sortSplit Double
tol [Curve]
xs
>
> insertM :: Curve -> Double -> [Curve] -> SweepStateM [Curve]
> insertM :: Curve -> Double -> [Curve] -> SweepStateM [Curve]
insertM Curve
x Double
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return [Curve
x]
> insertM Curve
x Double
tol (Curve
y:[Curve]
ys) =
>   case Curve -> Curve -> Double -> Maybe (Curve, Maybe Curve)
curveOverlap Curve
x Curve
y Double
tol of
>    Just (Curve
c1, Maybe Curve
c2) -> do
>      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Curve -> SweepStateM ()
xStructAdd Maybe Curve
c2
>      Curve -> Double -> [Curve] -> SweepStateM [Curve]
insertM Curve
c1 Double
tol [Curve]
ys
>    Maybe (Curve, Maybe Curve)
Nothing -> do
>      (Curve
x', Curve
y') <- Curve -> Curve -> Double -> SweepStateM (Curve, Curve)
splitM Curve
x Curve
y Double
tol
>      if Curve
x' forall a. Ord a => a -> a -> Bool
< Curve
y'
>        then forall (m :: * -> *) a. Monad m => a -> m a
return (Curve
x'forall a. a -> [a] -> [a]
:Curve
y'forall a. a -> [a] -> [a]
:[Curve]
ys)
>        else (Curve
y'forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Curve -> Double -> [Curve] -> SweepStateM [Curve]
insertM Curve
x' Double
tol [Curve]
ys
>
> splitM :: Curve -> Curve -> Double -> SweepStateM (Curve, Curve)
> splitM :: Curve -> Curve -> Double -> SweepStateM (Curve, Curve)
splitM Curve
x Curve
y Double
tol =
>   case Curve
-> Curve -> Double -> (Maybe (Curve, Curve), Maybe (Curve, Curve))
splitMaybe Curve
x Curve
y Double
tol of
>   (Just (Curve
a, Curve
b), Just (Curve
c, Curve
d)) -> do
>     Curve -> SweepStateM ()
xStructAdd Curve
b
>     Curve -> SweepStateM ()
xStructAdd Curve
d
>     forall (m :: * -> *) a. Monad m => a -> m a
return (Curve
a, Curve
c)
>   (Maybe (Curve, Curve)
Nothing, Just (Curve
c, Curve
d)) -> do
>     Curve -> SweepStateM ()
xStructAdd Curve
d
>     forall (m :: * -> *) a. Monad m => a -> m a
return (Curve
x, Curve
c)
>   (Just (Curve
a, Curve
b), Maybe (Curve, Curve)
Nothing) -> do
>     Curve -> SweepStateM ()
xStructAdd Curve
b
>     forall (m :: * -> *) a. Monad m => a -> m a
return (Curve
a, Curve
y)
>   (Maybe (Curve, Curve)
Nothing, Maybe (Curve, Curve)
Nothing) ->
>     forall (m :: * -> *) a. Monad m => a -> m a
return (Curve
x, Curve
y)

Handle intersections of the first curve at point and the curve
above. Return the curves with updated turnratios.  Some care is needed
when one of the curves is intersected at the endpoints, in order not
to create singular curves.

> updateTurnRatio :: Curve -> Curve -> Curve
> updateTurnRatio :: Curve -> Curve -> Curve
updateTurnRatio (Curve CubicBezier Double
_ (Int, Int)
tr (Int, Int) -> (Int, Int)
chTr Maybe (Ratio Integer)
_) =
>   forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Int, Int)
turnRatio ((Int, Int) -> (Int, Int)
chTr (Int, Int)
tr)
>
> propagateTurnRatio :: Curve -> [Curve] -> [Curve]
> propagateTurnRatio :: Curve -> [Curve] -> [Curve]
propagateTurnRatio Curve
cAbove [Curve]
l =
>   forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Curve -> Curve -> Curve
updateTurnRatio Curve
cAbove [Curve]
l
>
> splitAbove :: [Curve] -> Double -> SweepStateM [Curve]
> splitAbove :: [Curve] -> Double -> SweepStateM [Curve]
splitAbove [] Double
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
> splitAbove (Curve
c:[Curve]
cs) Double
tol = do
>   YStruct
yStr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   Point Double
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState (Point Double)
focusPoint
>   let i :: Int
i = Curve -> YStruct -> Int
yStructIndex (Point Double -> Curve
singularC Point Double
p) YStruct
yStr
>   if Int
i forall a. Ord a => a -> a -> Bool
< Int
0
>     then let c' :: Curve
c' = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Int, Int)
turnRatio (Int, Int)
trOne Curve
c
>                 in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve
c'forall a. a -> [a] -> [a]
:Curve -> [Curve] -> [Curve]
propagateTurnRatio Curve
c' [Curve]
cs
>     else 
>       let cAbove :: Curve
cAbove = forall a. Int -> Set a -> a
S.elemAt Int
i YStruct
yStr
>       in case Curve
-> Curve -> Double -> (Maybe (Curve, Curve), Maybe (Curve, Curve))
splitMaybe Curve
c Curve
cAbove Double
tol of
>         (Maybe (Curve, Curve)
Nothing, Maybe (Curve, Curve)
Nothing) ->
>           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> [Curve] -> [Curve]
propagateTurnRatio Curve
cAbove forall a b. (a -> b) -> a -> b
$ Curve
cforall a. a -> [a] -> [a]
:[Curve]
cs
>         (Just (Curve
c1, Curve
c2), Maybe (Curve, Curve)
Nothing)
>           | forall a. CubicBezier a -> Point a
cubicC3 (Curve -> CubicBezier Double
_bezier Curve
c1) forall a. Eq a => a -> a -> Bool
== forall a. CubicBezier a -> Point a
cubicC0 (Curve -> CubicBezier Double
_bezier Curve
cAbove)
>             -> do
>               Curve -> SweepStateM ()
xStructAdd Curve
cAbove; Curve -> SweepStateM ()
xStructAdd Curve
c2
>               Int -> SweepStateM ()
yStructDel Int
i
>               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> [Curve] -> [Curve]
propagateTurnRatio Curve
cAbove forall a b. (a -> b) -> a -> b
$ Curve
c1forall a. a -> [a] -> [a]
:[Curve]
cs
>           | Bool
otherwise -> do
>               Curve -> SweepStateM ()
xStructAdd Curve
c2
>               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> [Curve] -> [Curve]
propagateTurnRatio Curve
cAbove forall a b. (a -> b) -> a -> b
$ Curve
c1forall a. a -> [a] -> [a]
:[Curve]
cs
>         (Maybe (Curve, Curve)
Nothing, Just (Curve
c3, Curve
c4)) -> do
>             Bool -> String -> SweepStateM ()
assert (forall a. CubicBezier a -> Point a
cubicC3 (Curve -> CubicBezier Double
_bezier Curve
c3) forall a. Eq a => a -> a -> Bool
/= forall a. CubicBezier a -> Point a
cubicC0 (Curve -> CubicBezier Double
_bezier Curve
c)) forall a b. (a -> b) -> a -> b
$
>               String
"curve intersecting pointevent: cAbove " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Curve
cAbove
>             Curve -> SweepStateM ()
xStructAdd Curve
c4
>             Int -> SweepStateM ()
yStructDel Int
i; Curve -> SweepStateM ()
yStructAdd Curve
c3
>             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> [Curve] -> [Curve]
propagateTurnRatio Curve
cAbove forall a b. (a -> b) -> a -> b
$ Curve
cforall a. a -> [a] -> [a]
:[Curve]
cs
>         (Just (Curve
c1, Curve
c2), Just (Curve
c3, Curve
c4)) -> do
>           Curve -> SweepStateM ()
xStructAdd Curve
c2; Curve -> SweepStateM ()
xStructAdd Curve
c4
>           Int -> SweepStateM ()
yStructDel Int
i; Curve -> SweepStateM ()
yStructAdd Curve
c3
>           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Curve -> [Curve] -> [Curve]
propagateTurnRatio Curve
cAbove forall a b. (a -> b) -> a -> b
$ Curve
c1forall a. a -> [a] -> [a]
:[Curve]
cs

Split curves near the point.  Return the curves starting from this point.

> splitNearPoints :: DPoint -> Double -> SweepStateM ([Curve], [Curve])
> splitNearPoints :: Point Double -> Double -> SweepStateM ([Curve], [Curve])
splitNearPoints Point Double
p Double
tol = do
>   [(Curve, Curve)]
curves1 <- ((Curve -> Maybe (Curve, Double))
 -> SweepStateM (Maybe (Curve, Double)))
-> Point Double -> Double -> SweepStateM [(Curve, Curve)]
splitNearDir forall a. (Curve -> Maybe a) -> SweepStateM (Maybe a)
withAbove Point Double
p Double
tol
>   [(Curve, Curve)]
curves2 <- ((Curve -> Maybe (Curve, Double))
 -> SweepStateM (Maybe (Curve, Double)))
-> Point Double -> Double -> SweepStateM [(Curve, Curve)]
splitNearDir forall a. (Curve -> Maybe a) -> SweepStateM (Maybe a)
withBelow Point Double
p Double
tol
>   forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Curve, Curve)]
curves1 forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Curve, Curve)]
curves2,
>           forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Curve, Curve)]
curves1 forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Curve, Curve)]
curves2)
>
> splitNearDir  :: ((Curve -> Maybe (Curve, Double))
>                   -> SweepStateM (Maybe (Curve, Double)))
>               -> DPoint -> Double
>               -> SweepStateM [(Curve, Curve)]
> splitNearDir :: ((Curve -> Maybe (Curve, Double))
 -> SweepStateM (Maybe (Curve, Double)))
-> Point Double -> Double -> SweepStateM [(Curve, Curve)]
splitNearDir (Curve -> Maybe (Curve, Double))
-> SweepStateM (Maybe (Curve, Double))
dir Point Double
p Double
tol = do
>   Maybe (Curve, Double)
mbSplit <- (Curve -> Maybe (Curve, Double))
-> SweepStateM (Maybe (Curve, Double))
dir forall a b. (a -> b) -> a -> b
$ \Curve
curve ->
>     (,) Curve
curve forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
>     Double -> Point Double -> CubicBezier Double -> Maybe Double
pointOnCurve Double
tol Point Double
p
>     (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
curve)
>   case Maybe (Curve, Double)
mbSplit of
>    Maybe (Curve, Double)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
>    Just (Curve
curve, Double
t) -> do
>      let (CubicBezier Double
c1, CubicBezier Double
c2) = forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
curve) Double
t
>          c1' :: Curve
c1' = Curve -> CubicBezier Double -> Curve
adjust Curve
curve forall a b. (a -> b) -> a -> b
$ forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC3 Point Double
p forall a b. (a -> b) -> a -> b
$
>                Double -> Double -> Double
snapRound Double
tol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CubicBezier Double
c1
>          c2' :: Curve
c2' = Curve -> CubicBezier Double -> Curve
adjust Curve
curve forall a b. (a -> b) -> a -> b
$ forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC0 Point Double
p forall a b. (a -> b) -> a -> b
$
>                Double -> Double -> Double
snapRound Double
tol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CubicBezier Double
c2
>      forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage forall a b. (a -> b) -> a -> b
$ String
"MSG Splitting curve " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
curve)
>      ((Curve
c1', Curve
c2')forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Curve -> Maybe (Curve, Double))
 -> SweepStateM (Maybe (Curve, Double)))
-> Point Double -> Double -> SweepStateM [(Curve, Curve)]
splitNearDir (Curve -> Maybe (Curve, Double))
-> SweepStateM (Maybe (Curve, Double))
dir Point Double
p Double
tol

Add the sorted curves starting at point to the Y-structure, and test
last curve with curve below.

> addMidCurves :: [Curve] -> Double -> SweepStateM ()
> addMidCurves :: [Curve] -> Double -> SweepStateM ()
addMidCurves [] Double
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
> addMidCurves [Curve
c] Double
tol =
>   Curve -> Double -> SweepStateM ()
splitBelow Curve
c Double
tol
> addMidCurves (Curve
c:[Curve]
cs) Double
tol = do
>   [Curve] -> Double -> SweepStateM ()
addMidCurves [Curve]
cs Double
tol
>   Curve -> SweepStateM ()
yStructAdd Curve
c 
>   
> splitBelow :: Curve -> Double -> SweepStateM ()
> splitBelow :: Curve -> Double -> SweepStateM ()
splitBelow Curve
c Double
tol = do
>   YStruct
yStr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   Point Double
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState (Point Double)
focusPoint
>   let i :: Int
i = Curve -> YStruct -> Int
yStructIndex (Point Double -> Curve
singularC Point Double
p) YStruct
yStr
>   if Int
i forall a. Ord a => a -> a -> Bool
>= forall a. Set a -> Int
S.size YStruct
yStrforall a. Num a => a -> a -> a
-Int
1
>     then Curve -> SweepStateM ()
yStructAdd Curve
c
>     else
>       let cBelow :: Curve
cBelow = forall a. Int -> Set a -> a
S.elemAt (Int
iforall a. Num a => a -> a -> a
+Int
1) YStruct
yStr
>       in case Curve
-> Curve -> Double -> (Maybe (Curve, Curve), Maybe (Curve, Curve))
splitMaybe Curve
c Curve
cBelow Double
tol of
>         (Maybe (Curve, Curve)
Nothing, Maybe (Curve, Curve)
Nothing) -> 
>           Curve -> SweepStateM ()
yStructAdd Curve
c
>         (Maybe (Curve, Curve)
Nothing, Just (Curve
c3, Curve
c4)) -> do
>           Bool -> String -> SweepStateM ()
assert (forall a. CubicBezier a -> Point a
cubicC3 (Curve -> CubicBezier Double
_bezier Curve
c3) forall a. Eq a => a -> a -> Bool
/= forall a. CubicBezier a -> Point a
cubicC0 (Curve -> CubicBezier Double
_bezier Curve
c)) forall a b. (a -> b) -> a -> b
$
>             String
"splitBelow: curve starting in future: c3 == " forall a. [a] -> [a] -> [a]
++
>              forall a. Show a => a -> String
show Curve
c3 forall a. [a] -> [a] -> [a]
++ String
" c == " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Curve
c
>           forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG Split lower curve only." 
>           Curve -> SweepStateM ()
xStructAdd Curve
c4
>           Int -> SweepStateM ()
yStructDel (Int
iforall a. Num a => a -> a -> a
+Int
1); Curve -> SweepStateM ()
yStructAdd Curve
c3; Curve -> SweepStateM ()
yStructAdd Curve
c
>         (Just (Curve
c1, Curve
c2), Maybe (Curve, Curve)
Nothing) -> do
>           forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG split curve above lower curve"
>           Bool -> String -> SweepStateM ()
assert (forall a. CubicBezier a -> Point a
cubicC3 (Curve -> CubicBezier Double
_bezier Curve
c1) forall a. Eq a => a -> a -> Bool
/= forall a. CubicBezier a -> Point a
cubicC0 (Curve -> CubicBezier Double
_bezier Curve
cBelow))
>             String
"SPLITBELOW: CURVE INTERSECTING POINTEVENT." 
>           Curve -> SweepStateM ()
xStructAdd Curve
c2
>           Curve -> SweepStateM ()
yStructAdd Curve
c1
>         (Just (Curve
c1, Curve
c2), Just (Curve
c3, Curve
c4)) -> do
>           forall {m :: * -> *} {p}. Monad m => p -> m ()
traceMessage String
"MSG split lower curve and curve above."
>           Curve -> SweepStateM ()
xStructAdd Curve
c2; Curve -> SweepStateM ()
xStructAdd Curve
c4
>           Int -> SweepStateM ()
yStructDel (Int
iforall a. Num a => a -> a -> a
+Int
1); Curve -> SweepStateM ()
yStructAdd Curve
c3; Curve -> SweepStateM ()
yStructAdd Curve
c1

If no curves start from the point, check if the surrounding
curves overlap.

> splitSurround :: Double -> SweepStateM ()
> splitSurround :: Double -> SweepStateM ()
splitSurround Double
tol = do
>   Point Double
p <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState (Point Double)
focusPoint
>   YStruct
yStr <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' SweepState YStruct
yStruct
>   let i :: Int
i = Curve -> YStruct -> Int
yStructIndex (Point Double -> Curve
singularC Point Double
p) YStruct
yStr
>       s :: Int
s = forall a. Set a -> Int
S.size YStruct
yStr
>   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
< Int
sforall a. Num a => a -> a -> a
-Int
1) forall a b. (a -> b) -> a -> b
$
>    case Curve
-> Curve -> Double -> (Maybe (Curve, Curve), Maybe (Curve, Curve))
splitMaybe (forall a. Int -> Set a -> a
S.elemAt Int
i YStruct
yStr) (forall a. Int -> Set a -> a
S.elemAt (Int
iforall a. Num a => a -> a -> a
+Int
1) YStruct
yStr) Double
tol of
>      (Just (Curve
c1, Curve
c2), Just (Curve
c3, Curve
c4)) -> do
>        Curve -> SweepStateM ()
xStructAdd Curve
c2; Curve -> SweepStateM ()
xStructAdd Curve
c4
>        Int -> SweepStateM ()
yStructDel Int
i; Int -> SweepStateM ()
yStructDel Int
i
>        Curve -> SweepStateM ()
yStructAdd Curve
c3; Curve -> SweepStateM ()
yStructAdd Curve
c1
>      (Just (Curve
c1, Curve
c2), Maybe (Curve, Curve)
Nothing) -> do
>        Curve -> SweepStateM ()
xStructAdd Curve
c2
>        Int -> SweepStateM ()
yStructDel Int
i; Curve -> SweepStateM ()
yStructAdd Curve
c1
>      (Maybe (Curve, Curve)
Nothing, Just (Curve
c1, Curve
c2)) -> do
>        Curve -> SweepStateM ()
xStructAdd Curve
c2
>        Int -> SweepStateM ()
yStructDel (Int
iforall a. Num a => a -> a -> a
+Int
1); Curve -> SweepStateM ()
yStructAdd Curve
c1
>      (Maybe (Curve, Curve)
Nothing, Maybe (Curve, Curve)
Nothing) ->
>        forall (m :: * -> *) a. Monad m => a -> m a
return ()


=== Find curve intersections

Test if both curves intersect.  Split one or both of the curves when
they intersect.  Also snapround each point, and make sure the point
of overlap is the same in both curves.

> splitMaybe :: Curve -> Curve -> Double ->
>               (Maybe (Curve, Curve),
>                Maybe (Curve, Curve))
> splitMaybe :: Curve
-> Curve -> Double -> (Maybe (Curve, Curve), Maybe (Curve, Curve))
splitMaybe Curve
c1 Curve
c2 Double
tol =
>   forall {p} {p} {p}. p -> p -> p -> p
assertTrace (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
errMsg) String
errMsg
>   (Curve -> (CubicBezier Double, CubicBezier Double) -> (Curve, Curve)
adjustSplit Curve
c1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> a
fst (Maybe (CubicBezier Double, CubicBezier Double),
 Maybe (CubicBezier Double, CubicBezier Double))
n,
>    Curve -> (CubicBezier Double, CubicBezier Double) -> (Curve, Curve)
adjustSplit Curve
c2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a, b) -> b
snd (Maybe (CubicBezier Double, CubicBezier Double),
 Maybe (CubicBezier Double, CubicBezier Double))
n)
>   where
>     errMsg :: String
errMsg = CubicBezier Double
-> CubicBezier Double
-> (Maybe (CubicBezier Double, CubicBezier Double),
    Maybe (CubicBezier Double, CubicBezier Double))
-> String
checkSplitCurve CubicBezier Double
b1 CubicBezier Double
b2 (Maybe (CubicBezier Double, CubicBezier Double),
 Maybe (CubicBezier Double, CubicBezier Double))
n
>     n :: (Maybe (CubicBezier Double, CubicBezier Double),
 Maybe (CubicBezier Double, CubicBezier Double))
n = CubicBezier Double
-> CubicBezier Double
-> Double
-> [(Double, Double)]
-> (Maybe (CubicBezier Double, CubicBezier Double),
    Maybe (CubicBezier Double, CubicBezier Double))
nextIntersection CubicBezier Double
b1 CubicBezier Double
b2 Double
tol forall a b. (a -> b) -> a -> b
$
>         CubicBezier Double
-> CubicBezier Double -> Double -> [(Double, Double)]
bezierIntersection CubicBezier Double
b1 CubicBezier Double
b2 Double
tol
>     b1 :: CubicBezier Double
b1 = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c1
>     b2 :: CubicBezier Double
b2 = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c2
>
> checkOverlap :: CubicBezier Double -> CubicBezier Double -> Bool
checkOverlap CubicBezier Double
c1 CubicBezier Double
c2 =
>   forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
/=Ordering
p) [Ordering]
ps
>   where x0 :: Double
x0 = forall a. Point a -> a
pointX forall a b. (a -> b) -> a -> b
$ forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
c2
>         x3 :: Double
x3 = forall a. Point a -> a
pointX forall a b. (a -> b) -> a -> b
$ forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
c2
>         t0 :: Double
t0 | forall a. Point a -> a
pointX (forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
c1) forall a. Ord a => a -> a -> Bool
>= Double
x0 = Double
0
>            | Bool
otherwise = CubicBezier Double -> Double -> Double -> Double
findX CubicBezier Double
c1 Double
x0 Double
1e-7
>         t1 :: Double
t1 | forall a. Point a -> a
pointX (forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
c1) forall a. Ord a => a -> a -> Bool
<= Double
x3 = Double
1
>            | Bool
otherwise = CubicBezier Double -> Double -> Double -> Double
findX CubicBezier Double
c1 Double
x3 Double
1e-7
>         comp :: Double -> Ordering
comp Double
t = let (Point Double
bx Double
by) = forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
c1 (Double
t0 forall a. Num a => a -> a -> a
+ (Double
t1forall a. Num a => a -> a -> a
-Double
t0)forall a. Num a => a -> a -> a
*Double
tforall a. Fractional a => a -> a -> a
/Double
10)
>                  in forall a. Ord a => a -> a -> Ordering
compare (forall a. Point a -> a
pointY (forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
c2 (CubicBezier Double -> Double -> Double -> Double
findX CubicBezier Double
c2 Double
bx Double
1e-7))) Double
by
>         (Ordering
p:[Ordering]
ps) = forall a b. (a -> b) -> [a] -> [b]
map Double -> Ordering
comp [Double
1..Double
9]
> 
> checkDirection :: CubicBezier Double -> CubicBezier Double -> CubicBezier Double -> String
> checkDirection :: CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 c :: CubicBezier Double
c@(CubicBezier Point Double
p1 Point Double
_ Point Double
_ Point Double
p2)
>   | Point Double -> PointEvent
PointEvent Point Double
p1 forall a. Ord a => a -> a -> Bool
< Point Double -> PointEvent
PointEvent Point Double
p2 = String
""
>   | Bool
otherwise = String
"Curve has wrong direction: " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c forall a. [a] -> [a] -> [a]
++
>       String
"after splitting " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c2
>   
> checkSplitCurve :: CubicBezier Double -> CubicBezier Double ->
>                    (Maybe (CubicBezier Double, CubicBezier Double),
>                     Maybe (CubicBezier Double, CubicBezier Double)) -> String
> checkSplitCurve :: CubicBezier Double
-> CubicBezier Double
-> (Maybe (CubicBezier Double, CubicBezier Double),
    Maybe (CubicBezier Double, CubicBezier Double))
-> String
checkSplitCurve CubicBezier Double
c1 CubicBezier Double
c2 (Maybe (CubicBezier Double, CubicBezier Double)
Nothing, Maybe (CubicBezier Double, CubicBezier Double)
Nothing) =
>   if CubicBezier Double -> CubicBezier Double -> Bool
checkOverlap CubicBezier Double
c1 CubicBezier Double
c2
>   then String
"Curves overlap: " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c2
>   else String
""
>
> checkSplitCurve CubicBezier Double
c1 CubicBezier Double
c2 (Just (CubicBezier Double
c3, CubicBezier Double
c4), Just (CubicBezier Double
c5, CubicBezier Double
c6)) =
>   CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c3 forall a. [a] -> [a] -> [a]
++ CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c4 forall a. [a] -> [a] -> [a]
++
>   CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c5 forall a. [a] -> [a] -> [a]
++ CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c6
>
> 
> checkSplitCurve CubicBezier Double
c1 CubicBezier Double
c2 (Just (CubicBezier Double
c3, CubicBezier Double
c4), Maybe (CubicBezier Double, CubicBezier Double)
Nothing) =
>   CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c3 forall a. [a] -> [a] -> [a]
++ CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c4 forall a. [a] -> [a] -> [a]
++
>   (if forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
c2 forall a. Eq a => a -> a -> Bool
== forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
c3 then String
"" else
>    String
"second curve doesn't split first curve: " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c2)
>
> checkSplitCurve CubicBezier Double
c1 CubicBezier Double
c2 (Maybe (CubicBezier Double, CubicBezier Double)
Nothing, Just (CubicBezier Double
c3, CubicBezier Double
c4)) =
>   CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c3 forall a. [a] -> [a] -> [a]
++ CubicBezier Double
-> CubicBezier Double -> CubicBezier Double -> String
checkDirection CubicBezier Double
c1 CubicBezier Double
c2 CubicBezier Double
c4 forall a. [a] -> [a] -> [a]
++
>   (if forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
c1 forall a. Eq a => a -> a -> Bool
== forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
c3 then String
"" else
>    String
"first curve doesn't split second curve: " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
c2)
>
> adjustSplit :: Curve -> (CubicBezier Double, CubicBezier Double) -> (Curve, Curve)
> adjustSplit :: Curve -> (CubicBezier Double, CubicBezier Double) -> (Curve, Curve)
adjustSplit Curve
curve (CubicBezier Double
b1, CubicBezier Double
b2) = (CubicBezier Double -> Curve
adjust1 CubicBezier Double
b1, CubicBezier Double -> Curve
adjust1 CubicBezier Double
b2)
>   where
>     adjust1 :: CubicBezier Double -> Curve
adjust1 CubicBezier Double
b = (if Point Double -> PointEvent
PointEvent (forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
b) forall a. Ord a => a -> a -> Bool
> Point Double -> PointEvent
PointEvent (forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b)
>                 then Curve -> Curve
revertCurve else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
>                forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Maybe (Ratio Integer))
curveRank forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (CubicBezier Double)
bezier CubicBezier Double
b Curve
curve
>
> revertCurve :: Curve -> Curve
> revertCurve :: Curve -> Curve
revertCurve (Curve CubicBezier Double
bez (Int, Int)
tr (Int, Int) -> (Int, Int)
chtr Maybe (Ratio Integer)
rank) =
>   CubicBezier Double
-> (Int, Int)
-> ((Int, Int) -> (Int, Int))
-> Maybe (Ratio Integer)
-> Curve
Curve (forall (b :: * -> *) a. (GenericBezier b, Unbox a) => b a -> b a
reorient CubicBezier Double
bez) (forall a b. (a, b) -> (b, a)
swap (Int, Int)
tr) (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> (Int, Int)
chtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> (b, a)
swap) Maybe (Ratio Integer)
rank
>
> adjust :: Curve -> CubicBezier Double -> Curve
> adjust :: Curve -> CubicBezier Double -> Curve
adjust Curve
curve CubicBezier Double
curve2 = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (Maybe (Ratio Integer))
curveRank forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' Curve (CubicBezier Double)
bezier CubicBezier Double
curve2 Curve
curve
>
> snapRoundBezier :: Double -> CubicBezier Double -> CubicBezier Double
> snapRoundBezier :: Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Double
snapRound Double
tol)
>

Given a list of intersection parameters, split at the next
intersection, but don't split at the first or last control point, or
when the two curves are (nearly) coincident.  Note that list of
intersections is read lazily, in order not to evaluate more
intersections that necessary.

> nextIntersection :: CubicBezier Double -> CubicBezier Double -> Double -> [(Double, Double)]
>                  -> (Maybe (CubicBezier Double, CubicBezier Double),
>                      Maybe (CubicBezier Double, CubicBezier Double))
> nextIntersection :: CubicBezier Double
-> CubicBezier Double
-> Double
-> [(Double, Double)]
-> (Maybe (CubicBezier Double, CubicBezier Double),
    Maybe (CubicBezier Double, CubicBezier Double))
nextIntersection CubicBezier Double
_ CubicBezier Double
_ Double
_ [] = (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
> nextIntersection b1 :: CubicBezier Double
b1@(CubicBezier Point Double
p0 Point Double
_ Point Double
_ Point Double
p3) b2 :: CubicBezier Double
b2@(CubicBezier Point Double
q0 Point Double
_ Point Double
_ Point Double
q3) Double
tol ((Double
t1, Double
t2): [(Double, Double)]
ts)
>   | Bool
atStart1 Bool -> Bool -> Bool
&& Bool
atStart2 =
>       CubicBezier Double
-> CubicBezier Double
-> Double
-> [(Double, Double)]
-> (Maybe (CubicBezier Double, CubicBezier Double),
    Maybe (CubicBezier Double, CubicBezier Double))
nextIntersection CubicBezier Double
b1 CubicBezier Double
b2 Double
tol [(Double, Double)]
ts
>   | CubicBezier Double -> CubicBezier Double -> Double -> Bool
bezierEqual CubicBezier Double
b1l CubicBezier Double
b2l Double
tol =
>       CubicBezier Double
-> CubicBezier Double
-> Double
-> [(Double, Double)]
-> (Maybe (CubicBezier Double, CubicBezier Double),
    Maybe (CubicBezier Double, CubicBezier Double))
nextIntersection CubicBezier Double
b1 CubicBezier Double
b2 Double
tol [(Double, Double)]
ts
>   | Bool
otherwise =
>       forall {p} {p} {p}. p -> p -> p -> p
assertTrace (forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
x1 Point Double
x2 forall a. Ord a => a -> a -> Bool
< Double
tol)
>       (String
"ASSERT: DISTANCE IS LARGER THAN TOLERANCE: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
t1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
t2 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
b1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ CubicBezier Double -> String
showCurve CubicBezier Double
b2)
>       (Maybe (CubicBezier Double, CubicBezier Double)
bs1, Maybe (CubicBezier Double, CubicBezier Double)
bs2)
>   where
>     bs1 :: Maybe (CubicBezier Double, CubicBezier Double)
bs1 | Bool
atStart1 Bool -> Bool -> Bool
|| Bool
atEnd1 = forall a. Maybe a
Nothing 
>         | Bool
otherwise = forall a. a -> Maybe a
Just (forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC3 Point Double
pMid2 forall a b. (a -> b) -> a -> b
$ Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol CubicBezier Double
b1l,
>                             forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC0 Point Double
pMid2 forall a b. (a -> b) -> a -> b
$ Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol CubicBezier Double
b1r)
>     bs2 :: Maybe (CubicBezier Double, CubicBezier Double)
bs2 | Bool
atStart2 Bool -> Bool -> Bool
|| Bool
atEnd2 = forall a. Maybe a
Nothing
>         | Bool
otherwise = forall a. a -> Maybe a
Just (forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC3 Point Double
pMid2 forall a b. (a -> b) -> a -> b
$ Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol CubicBezier Double
b2l,
>                             forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC0 Point Double
pMid2 forall a b. (a -> b) -> a -> b
$ Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol CubicBezier Double
b2r)
>     pMid :: Point Double
pMid | Bool
atStart1 = forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
b1
>          | Bool
atEnd1 = forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b1
>          | Bool
atStart2 = forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
b2
>          | Bool
atEnd2 = forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b2
>          | Bool
otherwise = Double -> Double -> Double
snapRound Double
tol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b1l

The intersection point can be in the past (if the curve is nearly vertical), so if that happens move the intersection point a tiny bit aside.  We may need to reorient the subcurve after the intersection point as well (see adjustSplit).

>     pMid2 :: Point Double
pMid2 | Point Double -> PointEvent
PointEvent Point Double
pMid forall a. Ord a => a -> a -> Bool
<= Point Double -> PointEvent
PointEvent (forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
b1) Bool -> Bool -> Bool
||
>             Point Double -> PointEvent
PointEvent Point Double
pMid forall a. Ord a => a -> a -> Bool
<= Point Double -> PointEvent
PointEvent (forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
b2) =
>             forall a. a -> a -> Point a
Point (forall a. Ord a => a -> a -> a
max (forall a. Point a -> a
pointX Point Double
x1) (forall a. Point a -> a
pointX Point Double
x2) forall a. Num a => a -> a -> a
+ Double
tol) (forall a. Point a -> a
pointY Point Double
pMid)
>           | Bool
otherwise = Point Double
pMid
>     x1 :: Point Double
x1 = forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
b1 Double
t1
>     x2 :: Point Double
x2 = forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
b2 Double
t2
>     atStart1 :: Bool
atStart1 = forall a. Floating a => Point a -> Point a -> a
vectorDistance (forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
b1) Point Double
x1 forall a. Ord a => a -> a -> Bool
< Double
tol
>     atStart2 :: Bool
atStart2 = forall a. Floating a => Point a -> Point a -> a
vectorDistance (forall a. CubicBezier a -> Point a
cubicC0 CubicBezier Double
b2) Point Double
x2 forall a. Ord a => a -> a -> Bool
< Double
tol
>     atEnd1 :: Bool
atEnd1 = forall a. Floating a => Point a -> Point a -> a
vectorDistance (forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b1) Point Double
x1 forall a. Ord a => a -> a -> Bool
< Double
tol
>     atEnd2 :: Bool
atEnd2 = forall a. Floating a => Point a -> Point a -> a
vectorDistance (forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b2) Point Double
x2 forall a. Ord a => a -> a -> Bool
< Double
tol
>     (CubicBezier Double
b1l, CubicBezier Double
b1r) = forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
b1 Double
t1
>     (CubicBezier Double
b2l, CubicBezier Double
b2r) = forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
b2 Double
t2
> 
> adjustC0 :: Point a -> CubicBezier a -> CubicBezier a
> adjustC0 :: forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC0 Point a
p (CubicBezier Point a
_ Point a
p1 Point a
p2 Point a
p3) = forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point a
p Point a
p1 Point a
p2 Point a
p3
>
> adjustC3 :: Point a -> CubicBezier a -> CubicBezier a
> adjustC3 :: forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC3 Point a
p (CubicBezier Point a
p0 Point a
p1 Point a
p2 Point a
_) = forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point a
p0 Point a
p1 Point a
p2 Point a
p

=== Check if curves overlap.

If the curves overlap, combine the overlapping part into one curve.
To compare the curves, I first split the longest curve so that the
velocities in the first control point match, then compare those curves
for equality.

> curveOverlap :: Curve -> Curve -> Double
>              -> Maybe (Curve, Maybe Curve)
> curveOverlap :: Curve -> Curve -> Double -> Maybe (Curve, Maybe Curve)
curveOverlap Curve
c1 Curve
c2 Double
tol
>   -- starting in the same point
>   | Point Double
p0 forall a. Eq a => a -> a -> Bool
/= Point Double
q0 = forall a. Maybe a
Nothing
>   | CubicBezier Double -> Double -> Bool
colinear (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c1) Double
tol = if
>       | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ CubicBezier Double -> Double -> Bool
colinear (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c2) Double
tol ->
>           forall a. Maybe a
Nothing
>       | forall a. Floating a => Point a -> Point a -> a
vectorDistance (Point Double
p3forall v. AdditiveGroup v => v -> v -> v
^-^Point Double
p0)
>         ((Point Double
q3forall v. AdditiveGroup v => v -> v -> v
^-^Point Double
q0) forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (Double
d1forall a. Fractional a => a -> a -> a
/Double
d2)) forall a. Ord a => a -> a -> Bool
> Double
tol ->
>           forall a. Maybe a
Nothing
>       | Point Double
p3 forall a. Eq a => a -> a -> Bool
== Point Double
q3 -> 
>           forall a. a -> Maybe a
Just (Curve -> Curve -> Curve
combineCurves Curve
c2 Curve
c1,
>                 forall a. Maybe a
Nothing)
>       | Double
d1 forall a. Ord a => a -> a -> Bool
> Double
d2 ->
>           forall a. a -> Maybe a
Just (Curve -> Curve -> Curve
combineCurves Curve
c2 Curve
c1,
>                 forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Curve -> CubicBezier Double -> Curve
adjust Curve
c1 forall a b. (a -> b) -> a -> b
$
>                 forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point Double
q3
>                 (Double -> Double -> Double
snapRound Double
tol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Num a => Point a -> Point a -> a -> Point a
interpolateVector Point Double
q3 Point Double
p3 (Double
1forall a. Fractional a => a -> a -> a
/Double
3))
>                 (Double -> Double -> Double
snapRound Double
tol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Num a => Point a -> Point a -> a -> Point a
interpolateVector Point Double
q3 Point Double
p3 (Double
2forall a. Fractional a => a -> a -> a
/Double
3))
>                 Point Double
p3)
>       | Bool
otherwise ->
>           forall a. a -> Maybe a
Just (Curve -> Curve -> Curve
combineCurves Curve
c1 Curve
c2,
>                 forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Curve -> CubicBezier Double -> Curve
adjust Curve
c2 forall a b. (a -> b) -> a -> b
$
>                 forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point Double
p3
>                 (Double -> Double -> Double
snapRound Double
tol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Num a => Point a -> Point a -> a -> Point a
interpolateVector Point Double
p3 Point Double
q3 (Double
1forall a. Fractional a => a -> a -> a
/Double
3))
>                 (Double -> Double -> Double
snapRound Double
tol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Num a => Point a -> Point a -> a -> Point a
interpolateVector Point Double
p3 Point Double
q3 (Double
2forall a. Fractional a => a -> a -> a
/Double
3))
>                 Point Double
q3)
>   -- equalize velocities, and compare           
>   | Double
v1 forall a. Eq a => a -> a -> Bool
== Double
0 Bool -> Bool -> Bool
||
>     Double
v2 forall a. Eq a => a -> a -> Bool
== Double
0 = forall a. Maybe a
Nothing
>   | Double
v1 forall a. Ord a => a -> a -> Bool
> Double
v2 = if CubicBezier Double -> CubicBezier Double -> Double -> Bool
bezierEqual CubicBezier Double
b2 CubicBezier Double
b1l Double
tol
>               then forall a. a -> Maybe a
Just (Curve -> Curve -> Curve
combineCurves Curve
c2 Curve
c1,
>                          if CubicBezier Double -> Double -> Bool
checkEmpty CubicBezier Double
b1r Double
tol
>                          then forall a. Maybe a
Nothing
>                          else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Curve -> CubicBezier Double -> Curve
adjust Curve
c1 forall a b. (a -> b) -> a -> b
$
>                               forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC0 (forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b2) forall a b. (a -> b) -> a -> b
$
>                               Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol CubicBezier Double
b1r)
>               else forall a. Maybe a
Nothing
>         
>   | Bool
otherwise =
>       if CubicBezier Double -> CubicBezier Double -> Double -> Bool
bezierEqual CubicBezier Double
b1 CubicBezier Double
b2l Double
tol
>               then forall a. a -> Maybe a
Just (Curve -> Curve -> Curve
combineCurves Curve
c1 Curve
c2,
>                          if CubicBezier Double -> Double -> Bool
checkEmpty CubicBezier Double
b2r Double
tol
>                          then forall a. Maybe a
Nothing
>                          else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Curve -> CubicBezier Double -> Curve
adjust Curve
c2 forall a b. (a -> b) -> a -> b
$
>                               forall a. Point a -> CubicBezier a -> CubicBezier a
adjustC0 (forall a. CubicBezier a -> Point a
cubicC3 CubicBezier Double
b1) forall a b. (a -> b) -> a -> b
$
>                               Double -> CubicBezier Double -> CubicBezier Double
snapRoundBezier Double
tol CubicBezier Double
b2r)
>               else forall a. Maybe a
Nothing
>   where
>     (CubicBezier Double
b1l, CubicBezier Double
b1r) = forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
b1 (Double
v2forall a. Fractional a => a -> a -> a
/Double
v1)
>     (CubicBezier Double
b2l, CubicBezier Double
b2r) = forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
b2 (Double
v1forall a. Fractional a => a -> a -> a
/Double
v2)
>     b1 :: CubicBezier Double
b1@(CubicBezier Point Double
p0 Point Double
p1 Point Double
_ Point Double
p3) = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c1
>     b2 :: CubicBezier Double
b2@(CubicBezier Point Double
q0 Point Double
q1 Point Double
_ Point Double
q3) = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve (CubicBezier Double)
bezier Curve
c2
>     d1 :: Double
d1 = forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
p0 Point Double
p3
>     d2 :: Double
d2 = forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
q0 Point Double
q3
>     v1 :: Double
v1 = forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
p0 Point Double
p1
>     v2 :: Double
v2 = forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
q0 Point Double
q1
>
> checkEmpty :: CubicBezier Double -> Double -> Bool
> checkEmpty :: CubicBezier Double -> Double -> Bool
checkEmpty (CubicBezier Point Double
p0 Point Double
p1 Point Double
p2 Point Double
p3) Double
tol = 
>   Point Double
p0 forall a. Eq a => a -> a -> Bool
== Point Double
p3 Bool -> Bool -> Bool
&&
>   forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
p0 Point Double
p1 forall a. Ord a => a -> a -> Bool
< Double
tol Bool -> Bool -> Bool
&&
>   forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
p0 Point Double
p2 forall a. Ord a => a -> a -> Bool
< Double
tol

Curves can be combined if they are equal, just by composing their
changeTurn functions.

> combineCurves :: Curve -> Curve -> Curve
> combineCurves :: Curve -> Curve -> Curve
combineCurves Curve
c1 Curve
c2 =
>   forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' Curve ((Int, Int) -> (Int, Int))
changeTurn (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Curve ((Int, Int) -> (Int, Int))
changeTurn Curve
c2 forall b c a. (b -> c) -> (a -> b) -> a -> c
.) Curve
c1

=== Snaprounding

> snapRound :: Double -> Double -> Double
> snapRound :: Double -> Double -> Double
snapRound Double
tol Double
v =
>   forall a. Num a => Integer -> a
fromInteger (forall a b. (RealFrac a, Integral b) => a -> b
round (Double
vforall a. Fractional a => a -> a -> a
/Double
tol)) forall a. Num a => a -> a -> a
* Double
tol

=== Test if the point is on the curve (within tolerance) {#oncurve}

> pointOnCurve :: Double -> DPoint -> CubicBezier Double -> Maybe Double
> pointOnCurve :: Double -> Point Double -> CubicBezier Double -> Maybe Double
pointOnCurve Double
tol Point Double
p CubicBezier Double
c1
>   | Double
t <- CubicBezier Double -> Point Double -> Double -> Double
closest CubicBezier Double
c1 Point Double
p Double
tol,
>     Point Double
p2 <- forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
c1 Double
t,
>     forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
p Point Double
p2 forall a. Ord a => a -> a -> Bool
< Double
tol = forall a. a -> Maybe a
Just Double
t
>   | Bool
otherwise = forall a. Maybe a
Nothing

=== Testing beziers for approximate equality {#eq}

If the control points of two bezier curves are within a distance `eps`
from each other, then both curves will all so be at least within
distance `eps` from each other.  This can be proven easily:
subtracting both curves gives the distance curve.  Since each control
point of this curve lies within a circle of radius `eps`, by the
convex hull property, the curve will also be inside the circle, so the
distances between each point will never exceed `eps`.

> bezierEqual :: CubicBezier Double -> CubicBezier Double -> Double -> Bool
> bezierEqual :: CubicBezier Double -> CubicBezier Double -> Double -> Bool
bezierEqual cb1 :: CubicBezier Double
cb1@(CubicBezier Point Double
a0 Point Double
a1 Point Double
a2 Point Double
a3) cb2 :: CubicBezier Double
cb2@(CubicBezier Point Double
b0 Point Double
b1 Point Double
b2 Point Double
b3) Double
tol
>   -- controlpoints equal within tol
>   | forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
a1 Point Double
b1 forall a. Ord a => a -> a -> Bool
< Double
tol Bool -> Bool -> Bool
&&
>     forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
a2 Point Double
b2 forall a. Ord a => a -> a -> Bool
< Double
tol Bool -> Bool -> Bool
&&
>     forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
a3 Point Double
b3 forall a. Ord a => a -> a -> Bool
< Double
tol Bool -> Bool -> Bool
&&
>     forall a. Floating a => Point a -> Point a -> a
vectorDistance Point Double
a0 Point Double
b0 forall a. Ord a => a -> a -> Bool
< Double
tol = Bool
True
>   -- compare if both are colinear and close together
>   | Double
dist forall a. Ord a => a -> a -> Bool
< Double
tol Bool -> Bool -> Bool
&&
>     CubicBezier Double -> Double -> Bool
colinear CubicBezier Double
cb1 ((Double
tolforall a. Num a => a -> a -> a
-Double
dist)forall a. Fractional a => a -> a -> a
/Double
2) Bool -> Bool -> Bool
&&
>     CubicBezier Double -> Double -> Bool
colinear CubicBezier Double
cb2 ((Double
tolforall a. Num a => a -> a -> a
-Double
dist)forall a. Fractional a => a -> a -> a
/Double
2) = Bool
True
>   | Bool
otherwise = Bool
False
>   where dist :: Double
dist = forall a. Ord a => a -> a -> a
max (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ Point Double -> Double
ld Point Double
b0) (forall a. Num a => a -> a
abs forall a b. (a -> b) -> a -> b
$ Point Double -> Double
ld Point Double
b3)
>         ld :: Point Double -> Double
ld = forall a. Floating a => Line a -> Point a -> a
lineDistance (forall a. Point a -> Point a -> Line a
Line Point Double
a0 Point Double
a3)

Higher level functions
----------------------

> fillFunction :: FillRule -> Int -> Bool
> fillFunction :: FillRule -> Int -> Bool
fillFunction FillRule
NonZero = (forall a. Eq a => a -> a -> Bool
/=Int
0)
> fillFunction FillRule
EvenOdd = forall a. Integral a => a -> Bool
odd
>
> newSweep :: XStruct -> SweepState
> newSweep :: XStruct -> SweepState
newSweep XStruct
xStr = Map PointEvent [CubicBezier Double]
-> YStruct -> Point Double -> XStruct -> SweepState
SweepState forall k a. Map k a
M.empty forall a. Set a
S.empty forall a. HasCallStack => a
undefined XStruct
xStr
>
> runSweep :: SweepState -> SweepStateM () -> SweepState
#if DEBUG
> runSweep sweep m = 
>   unsafePerformIO $ do
>   hPutStrLn stderr "XSTRUCTBEGIN" 
>   mapM_ (hPutStrLn stderr . showCurve) $ map (view bezier) $
>    concat $ M.elems $ view xStruct sweep
>   hPutStrLn stderr "XSTRUCTEND" 
>   execStateT m sweep
#else
> runSweep :: SweepState -> SweepStateM () -> SweepState
runSweep SweepState
sweep SweepStateM ()
m =
>   forall s a. State s a -> s -> s
execState SweepStateM ()
m SweepState
sweep
#endif

> -- | `O((n+m)*log(n+m))`, for `n` segments and `m` intersections.
> -- Union of paths, removing overlap and rounding to the given
> -- tolerance.
> union :: [ClosedPath Double] -- ^ Paths
>          -> FillRule         -- ^ input fillrule
>          -> Double           -- ^ Tolerance
>          -> [ClosedPath Double]
> union :: [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
union [ClosedPath Double]
p FillRule
fill Double
tol =
>   Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputPaths forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SweepState (Map PointEvent [CubicBezier Double])
output forall a b. (a -> b) -> a -> b
$ SweepState -> SweepStateM () -> SweepState
runSweep SweepState
sweep forall a b. (a -> b) -> a -> b
$ 
>   ((Int, Int) -> Bool) -> Double -> SweepStateM ()
loopEvents (FillRule -> Int -> Bool
fillFunction FillRule
fill forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Double
tol
>   where
>     sweep :: SweepState
sweep = XStruct -> SweepState
newSweep XStruct
xStr
>     xStr :: XStruct
xStr = ((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> Double
-> [CubicBezier Double]
-> XStruct
makeXStruct (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
subtract Int
1) (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall a. Num a => a -> a -> a
+Int
1)) Double
tol forall a b. (a -> b) -> a -> b
$
>            forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Fractional a => ClosedPath a -> [CubicBezier a]
closedPathCurves [ClosedPath Double]
p
>
> union' :: [CubicBezier Double] -> FillRule -> Double -> [ClosedPath Double]
union' [CubicBezier Double]
p FillRule
fill Double
tol =
>   Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputPaths forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SweepState (Map PointEvent [CubicBezier Double])
output forall a b. (a -> b) -> a -> b
$ SweepState -> SweepStateM () -> SweepState
runSweep SweepState
sweep forall a b. (a -> b) -> a -> b
$ 
>   ((Int, Int) -> Bool) -> Double -> SweepStateM ()
loopEvents (FillRule -> Int -> Bool
fillFunction FillRule
fill forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Double
tol
>   where
>     sweep :: SweepState
sweep = XStruct -> SweepState
newSweep XStruct
xStr
>     xStr :: XStruct
xStr = ((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> Double
-> [CubicBezier Double]
-> XStruct
makeXStruct (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field1 s t a b => Lens s t a b
_1 forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
subtract Int
1) (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall a. Num a => a -> a -> a
+Int
1)) Double
tol [CubicBezier Double]
p
>
> 
> -- | `O((n+m)*log(n+m))`, for `n` segments and `m` intersections.
> -- Combine paths using the given boolean operation
> boolPathOp :: (Bool -> Bool -> Bool) -- ^ operation
>           -> [ClosedPath Double]     -- ^ first path (merged with union)
>           -> [ClosedPath Double]     -- ^ second path (merged with union)
>           -> FillRule                -- ^ input fillrule
>           -> Double                  -- ^ tolerance 
>           -> [ClosedPath Double]
> boolPathOp :: (Bool -> Bool -> Bool)
-> [ClosedPath Double]
-> [ClosedPath Double]
-> FillRule
-> Double
-> [ClosedPath Double]
boolPathOp Bool -> Bool -> Bool
op [ClosedPath Double]
p1 [ClosedPath Double]
p2 FillRule
fill Double
tol =
>   Map PointEvent [CubicBezier Double] -> [ClosedPath Double]
outputPaths forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SweepState (Map PointEvent [CubicBezier Double])
output forall a b. (a -> b) -> a -> b
$ SweepState -> SweepStateM () -> SweepState
runSweep SweepState
sweep forall a b. (a -> b) -> a -> b
$
>   ((Int, Int) -> Bool) -> Double -> SweepStateM ()
loopEvents (Int, Int) -> Bool
isInside Double
tol
>   where
>     isInside :: (Int, Int) -> Bool
isInside (Int
a, Int
b) = FillRule -> Int -> Bool
fillFunction FillRule
fill Int
a Bool -> Bool -> Bool
`op`
>                       FillRule -> Int -> Bool
fillFunction FillRule
fill Int
b
>     sweep :: SweepState
sweep = XStruct -> SweepState
newSweep XStruct
xStr
>
>     xStr :: XStruct
xStr = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith forall a. [a] -> [a] -> [a]
(++)
>            (((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> Double
-> [CubicBezier Double]
-> XStruct
makeXStruct 
>             (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall a. Num a => a -> a -> a
subtract Int
1))
>             (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field1 s t a b => Lens s t a b
_1 (forall a. Num a => a -> a -> a
+Int
1)) Double
tol forall a b. (a -> b) -> a -> b
$
>             forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Fractional a => ClosedPath a -> [CubicBezier a]
closedPathCurves [ClosedPath Double]
p1)
>            (((Int, Int) -> (Int, Int))
-> ((Int, Int) -> (Int, Int))
-> Double
-> [CubicBezier Double]
-> XStruct
makeXStruct
>             (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field2 s t a b => Lens s t a b
_2 (forall a. Num a => a -> a -> a
subtract Int
1))
>             (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field2 s t a b => Lens s t a b
_2 (forall a. Num a => a -> a -> a
+Int
1)) Double
tol forall a b. (a -> b) -> a -> b
$
>             forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Fractional a => ClosedPath a -> [CubicBezier a]
closedPathCurves [ClosedPath Double]
p2)
>
> intersection, difference, exclusion ::
>   [ClosedPath Double] -> [ClosedPath Double] ->
>   FillRule -> Double -> [ClosedPath Double]
>
> -- | path intersection  
> intersection :: [ClosedPath Double]
-> [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
intersection = (Bool -> Bool -> Bool)
-> [ClosedPath Double]
-> [ClosedPath Double]
-> FillRule
-> Double
-> [ClosedPath Double]
boolPathOp Bool -> Bool -> Bool
(&&)
>
> -- | path difference
> difference :: [ClosedPath Double]
-> [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
difference = (Bool -> Bool -> Bool)
-> [ClosedPath Double]
-> [ClosedPath Double]
-> FillRule
-> Double
-> [ClosedPath Double]
boolPathOp (\Bool
a Bool
b -> Bool
a Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
b)
>
> -- | path exclusion
> exclusion :: [ClosedPath Double]
-> [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
exclusion = (Bool -> Bool -> Bool)
-> [ClosedPath Double]
-> [ClosedPath Double]
-> FillRule
-> Double
-> [ClosedPath Double]
boolPathOp (\Bool
a Bool
b -> if Bool
a then Bool -> Bool
not Bool
b else Bool
b)
>

handy for debugging: 

>
> -- mkBezier (a, b) (c, d) (e, f) (g, h) = CubicBezier (Point a b) (Point c d) (Point e f) (Point g h)
> --x =