{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Geom2D.CubicBezier.Stroke
       (penCircle, pathToPen, penStrokeOpen, penStrokeClosed, Pen,
        bezierOffset)
       where
import Geom2D
import Geom2D.CubicBezier
import Data.Monoid


data Pen a = PenEllipse (Transform a) (Transform a) (Transform a)
           | PenPath [PenSegment a]

data PenSegment a = PenCorner !(Point a) !(Point a)
                  | PenCurve !(Point a) !(CubicBezier a)

-- | A circular pen with unit radius.
penCircle :: (Floating a) => Pen a
penCircle :: forall a. Floating a => Pen a
penCircle = forall a. Transform a -> Transform a -> Transform a -> Pen a
PenEllipse forall a. Num a => Transform a
idTrans forall s. Floating s => Transform s
rotate90L forall s. Floating s => Transform s
rotate90R
{-# SPECIALIZE penCircle :: Pen Double #-}

-- | Create a pen from a path.  For predictable results the path
-- should be convex.
pathToPen :: (Floating a) => ClosedPath a -> Pen a
pathToPen :: forall a. Floating a => ClosedPath a -> Pen a
pathToPen (ClosedPath []) = forall a. [PenSegment a] -> Pen a
PenPath []
pathToPen (ClosedPath [(Point a, PathJoin a)]
nodes) =
  forall a. [PenSegment a] -> Pen a
PenPath forall a b. (a -> b) -> a -> b
$ forall a. Num a => [(Point a, PathJoin a)] -> [PenSegment a]
pathToPen' forall a b. (a -> b) -> a -> b
$ [(Point a, PathJoin a)]
nodes forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
2 [(Point a, PathJoin a)]
nodes

pathToPen' :: Num a => [(Point a, PathJoin a)] -> [PenSegment a]
pathToPen' :: forall a. Num a => [(Point a, PathJoin a)] -> [PenSegment a]
pathToPen' []     = []
pathToPen' [(Point a, PathJoin a)
_]    = []
pathToPen' [(Point a, PathJoin a)
_, (Point a, PathJoin a)
_] = []
pathToPen' ((Point a
p, PathJoin a
JoinLine):tl :: [(Point a, PathJoin a)]
tl@((Point a
q, PathJoin a
JoinLine):[(Point a, PathJoin a)]
_)) =
  forall a. Point a -> Point a -> PenSegment a
PenCorner (Point a
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point a
p) Point a
q forall a. a -> [a] -> [a]
: forall a. Num a => [(Point a, PathJoin a)] -> [PenSegment a]
pathToPen' [(Point a, PathJoin a)]
tl

pathToPen' ((Point a
_, JoinCurve Point a
_ Point a
_):tl :: [(Point a, PathJoin a)]
tl@((Point a
_, PathJoin a
JoinLine):[(Point a, PathJoin a)]
_)) =
  forall a. Num a => [(Point a, PathJoin a)] -> [PenSegment a]
pathToPen' [(Point a, PathJoin a)]
tl

pathToPen' ((Point a
p, PathJoin a
JoinLine):tl :: [(Point a, PathJoin a)]
tl@((Point a
q1, JoinCurve Point a
q2 Point a
q3):(Point a
q4, PathJoin a
_):[(Point a, PathJoin a)]
_)) =
  forall a. Point a -> CubicBezier a -> PenSegment a
PenCurve  (Point a
q1 forall v. AdditiveGroup v => v -> v -> v
^-^ Point a
p) (forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point a
q1 Point a
q2 Point a
q3 Point a
q4) forall a. a -> [a] -> [a]
:
  forall a. Num a => [(Point a, PathJoin a)] -> [PenSegment a]
pathToPen' [(Point a, PathJoin a)]
tl

pathToPen' ((Point a
_, JoinCurve Point a
_ Point a
p3):tl :: [(Point a, PathJoin a)]
tl@((Point a
q1, JoinCurve Point a
q2 Point a
q3):(Point a
q4, PathJoin a
_):[(Point a, PathJoin a)]
_)) =
  forall a. Point a -> CubicBezier a -> PenSegment a
PenCurve  (Point a
q1 forall v. AdditiveGroup v => v -> v -> v
^-^ Point a
p3) (forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point a
q1 Point a
q2 Point a
q3 Point a
q4) forall a. a -> [a] -> [a]
:
  forall a. Num a => [(Point a, PathJoin a)] -> [PenSegment a]
pathToPen' [(Point a, PathJoin a)]
tl

  
noTranslate :: Num a => Transform a -> Transform a
noTranslate :: forall a. Num a => Transform a -> Transform a
noTranslate (Transform a
a a
b a
_ a
c a
d a
_) =
  forall a. a -> a -> a -> a -> a -> a -> Transform a
Transform a
a a
b a
0 a
c a
d a
0

instance (Floating a, Eq a) => AffineTransform (Pen a) a where
  {-# SPECIALIZE transform :: Transform Double -> Pen Double -> Pen Double #-}
  transform :: Transform a -> Pen a -> Pen a
transform Transform a
t (PenEllipse Transform a
trans Transform a
_ Transform a
_) =
    let t2 :: Transform a
t2@(Transform a
a a
b a
c a
d a
e a
f) = forall a b. AffineTransform a b => Transform b -> a -> a
transform Transform a
t Transform a
trans
    in case forall a.
(Eq a, Fractional a) =>
Transform a -> Maybe (Transform a)
inverse forall a b. (a -> b) -> a -> b
$ forall a. Num a => Transform a -> Transform a
noTranslate Transform a
t2 of
      Maybe (Transform a)
Nothing -> forall a. Floating a => ClosedPath a -> Pen a
pathToPen forall a b. (a -> b) -> a -> b
$
        forall a. [(Point a, PathJoin a)] -> ClosedPath a
ClosedPath [
        (forall a. a -> a -> Point a
Point a
c a
f forall v. AdditiveGroup v => v -> v -> v
^+^ Point a
p, forall a. PathJoin a
JoinLine),
        (forall a. a -> a -> Point a
Point a
c a
f forall v. AdditiveGroup v => v -> v -> v
^-^ Point a
p, forall a. PathJoin a
JoinLine)]
        where
          p :: Point a
p | a
a forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& a
b forall a. Eq a => a -> a -> Bool
/= a
0 =
                forall a. Floating a => a -> a
sqrt(a
1 forall a. Num a => a -> a -> a
+ a
aforall a. Num a => a -> a -> a
*a
aforall a. Fractional a => a -> a -> a
/(a
bforall a. Num a => a -> a -> a
*a
b)) forall v. VectorSpace v => Scalar v -> v -> v
*^ forall a. a -> a -> Point a
Point a
a a
d
            | a
d forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& a
e forall a. Eq a => a -> a -> Bool
/= a
0 =
                forall a. Floating a => a -> a
sqrt(a
1 forall a. Num a => a -> a -> a
+ a
dforall a. Num a => a -> a -> a
*a
dforall a. Fractional a => a -> a -> a
/(a
eforall a. Num a => a -> a -> a
*a
e)) forall v. VectorSpace v => Scalar v -> v -> v
*^ forall a. a -> a -> Point a
Point a
a a
d
            | a
a forall a. Eq a => a -> a -> Bool
/= a
0 = forall a. a -> a -> Point a
Point (a
aforall a. Num a => a -> a -> a
+a
d) a
0
            | a
b forall a. Eq a => a -> a -> Bool
/= a
0 = forall a. a -> a -> Point a
Point a
0 (a
bforall a. Num a => a -> a -> a
+a
e)
              -- singular point: create tiny pen instead of an error
            | Bool
otherwise = forall a. a -> a -> Point a
Point a
1e-5 a
1e-5
      Just Transform a
inv ->
        forall a. Transform a -> Transform a -> Transform a -> Pen a
PenEllipse Transform a
t2 (forall a b. AffineTransform a b => Transform b -> a -> a
transform forall s. Floating s => Transform s
rotate90L Transform a
inv) (forall a b. AffineTransform a b => Transform b -> a -> a
transform forall s. Floating s => Transform s
rotate90R Transform a
inv)

  transform Transform a
t (PenPath [PenSegment a]
segments) =
    forall a. [PenSegment a] -> Pen a
PenPath forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall b. Num b => Transform b -> PenSegment b -> PenSegment b
transformSegment Transform a
t) [PenSegment a]
segments

transformSegment :: Num b => Transform b -> PenSegment b -> PenSegment b
transformSegment :: forall b. Num b => Transform b -> PenSegment b -> PenSegment b
transformSegment Transform b
t (PenCorner Point b
p Point b
q) =
  forall a. Point a -> Point a -> PenSegment a
PenCorner (forall a b. AffineTransform a b => Transform b -> a -> a
transform Transform b
t (Point b
qforall v. AdditiveGroup v => v -> v -> v
^+^Point b
p) forall v. AdditiveGroup v => v -> v -> v
^-^ Point b
q')  Point b
q'
  where q' :: Point b
q' = forall a b. AffineTransform a b => Transform b -> a -> a
transform Transform b
t Point b
q

transformSegment Transform b
t (PenCurve Point b
p CubicBezier b
c) =
  forall a. Point a -> CubicBezier a -> PenSegment a
PenCurve (forall a b. AffineTransform a b => Transform b -> a -> a
transform Transform b
t (forall a. CubicBezier a -> Point a
cubicC0 CubicBezier b
cforall v. AdditiveGroup v => v -> v -> v
^+^Point b
p) forall v. AdditiveGroup v => v -> v -> v
^-^ forall a. CubicBezier a -> Point a
cubicC0 CubicBezier b
c')  CubicBezier b
c'
  where c' :: CubicBezier b
c' = forall a b. AffineTransform a b => Transform b -> a -> a
transform Transform b
t CubicBezier b
c

offsetPoint :: (Floating a) =>  a -> Point a -> Point a -> Point a
offsetPoint :: forall a. Floating a => a -> Point a -> Point a -> Point a
offsetPoint a
dist Point a
start Point a
tangent =
  Point a
start forall v. AdditiveGroup v => v -> v -> v
^+^ (forall s. Floating s => Transform s
rotate90L forall a b. AffineTransform a b => Transform b -> a -> a
$* a
dist forall v. VectorSpace v => Scalar v -> v -> v
*^ forall a. Floating a => Point a -> Point a
normVector Point a
tangent)

bezierOffsetPoint :: CubicBezier Double -> Double -> Double -> (DPoint, DPoint)
bezierOffsetPoint :: CubicBezier Double
-> Double -> Double -> (Point Double, Point Double)
bezierOffsetPoint CubicBezier Double
cb Double
dist Double
t = (forall a. Floating a => a -> Point a -> Point a -> Point a
offsetPoint Double
dist Point Double
p Point Double
p', Point Double
p')
  where (Point Double
p, Point Double
p') = forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (Point a, Point a)
evalBezierDeriv CubicBezier Double
cb Double
t

-- | Calculate an offset path from the bezier curve to within
-- tolerance.  If the distance is positive offset to the left,
-- otherwise to the right. A smaller tolerance may require more bezier
-- curves in the path to approximate the offset curve
bezierOffset :: CubicBezier Double -- ^ The curve
             -> Double      -- ^ Offset distance.
             -> Maybe Int   -- ^ maximum subcurves
             -> Double      -- ^ Tolerance.
             -> Bool        -- ^ Calculate the curve faster but with
                            -- more subcurves
             -> [CubicBezier Double]        -- ^ The offset curve
bezierOffset :: CubicBezier Double
-> Double -> Maybe Int -> Double -> Bool -> [CubicBezier Double]
bezierOffset CubicBezier Double
cb Double
dist (Just Int
m) Double
tol Bool
faster =
  forall a.
(Unbox a, Floating a, Ord a) =>
Int
-> (a -> (Point a, Point a))
-> Int
-> a
-> a
-> a
-> Bool
-> [CubicBezier a]
approximatePathMax Int
m (CubicBezier Double
-> Double -> Double -> (Point Double, Point Double)
bezierOffsetPoint CubicBezier Double
cb Double
dist) Int
15 Double
tol Double
0 Double
1 Bool
faster

bezierOffset CubicBezier Double
cb Double
dist Maybe Int
Nothing Double
tol Bool
faster =
  forall a.
(Unbox a, Ord a, Floating a) =>
(a -> (Point a, Point a))
-> Int -> a -> a -> a -> Bool -> [CubicBezier a]
approximatePath (CubicBezier Double
-> Double -> Double -> (Point Double, Point Double)
bezierOffsetPoint CubicBezier Double
cb Double
dist) Int
15 Double
tol Double
0 Double
1 Bool
faster

penOffset :: Pen Double -> Point Double -> Point Double
penOffset :: Pen Double -> Point Double -> Point Double
penOffset (PenEllipse Transform Double
trans Transform Double
leftInv Transform Double
_) Point Double
dir =
  forall a b. AffineTransform a b => Transform b -> a -> a
transform Transform Double
trans forall a b. (a -> b) -> a -> b
$ forall a. Floating a => Point a -> Point a
normVector forall a b. (a -> b) -> a -> b
$ Transform Double
leftInv forall a b. AffineTransform a b => Transform b -> a -> a
$* Point Double
dir

penOffset (PenPath [PenSegment Double]
segments) Point Double
dir =
    [PenSegment Double] -> Point Double -> Point Double
pathOffsetPoint (forall a. [a] -> [a]
cycle [PenSegment Double]
segments) Point Double
dir

penOffsetFun :: Pen Double -> (Double -> (DPoint, DPoint)) -> Double -> (Point Double, Point Double)
penOffsetFun :: Pen Double
-> (Double -> (Point Double, Point Double))
-> Double
-> (Point Double, Point Double)
penOffsetFun Pen Double
pen Double -> (Point Double, Point Double)
f Double
t =
  (Point Double
px forall v. AdditiveGroup v => v -> v -> v
^+^ Pen Double -> Point Double -> Point Double
penOffset Pen Double
pen Point Double
px', Point Double
px')
  where
    (Point Double
px, Point Double
px') = Double -> (Point Double, Point Double)
f Double
t

firstPoint :: PenSegment a -> Point a
firstPoint :: forall a. PenSegment a -> Point a
firstPoint (PenCorner Point a
_ Point a
p) = Point a
p
firstPoint (PenCurve Point a
_ CubicBezier a
c) = forall a. CubicBezier a -> Point a
cubicC0 CubicBezier a
c

pathOffsetPoint :: [PenSegment Double] -> Point Double -> Point Double
pathOffsetPoint :: [PenSegment Double] -> Point Double -> Point Double
pathOffsetPoint (PenCorner Point Double
c Point Double
p:PenSegment Double
b:[PenSegment Double]
rest) Point Double
dir
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
dir Point Double
c forall a. Ord a => a -> a -> Bool
> Double
0 = [PenSegment Double] -> Point Double -> Point Double
pathOffsetPoint (PenSegment Double
bforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
dir
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
dir (forall a. PenSegment a -> Point a
firstPoint PenSegment Double
b forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p) forall a. Ord a => a -> a -> Bool
> Double
0 = Point Double
p
  | Bool
otherwise = [PenSegment Double] -> Point Double -> Point Double
pathOffsetPoint (PenSegment Double
bforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
dir
  
pathOffsetPoint (PenCurve Point Double
c curve :: CubicBezier Double
curve@(CubicBezier Point Double
p1 Point Double
p2 Point Double
p3 Point Double
p4):PenSegment Double
b:[PenSegment Double]
rest) Point Double
dir
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
dir Point Double
c forall a. Ord a => a -> a -> Bool
> Double
0 = [PenSegment Double] -> Point Double -> Point Double
pathOffsetPoint (PenSegment Double
bforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
dir
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
dir (Point Double
p2 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p1) forall a. Ord a => a -> a -> Bool
> Double
0 = Point Double
p1
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
dir (Point Double
p3 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p4) forall a. Ord a => a -> a -> Bool
> Double
0 =
    case Point Double -> CubicBezier Double -> [Double]
findBezierTangent Point Double
dir CubicBezier Double
curve of
      (Double
t:[Double]
_) -> forall (b :: * -> *) a.
(GenericBezier b, Unbox a, Fractional a) =>
b a -> a -> Point a
evalBezier CubicBezier Double
curve Double
t
      [] -> Point Double
p4
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
dir (forall a. PenSegment a -> Point a
firstPoint PenSegment Double
b forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p4) forall a. Ord a => a -> a -> Bool
> Double
0 = Point Double
p4
  | Bool
otherwise = [PenSegment Double] -> Point Double -> Point Double
pathOffsetPoint (PenSegment Double
bforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
dir

pathOffsetPoint [PenSegment Double]
_ Point Double
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"unexpected end of list"

segDirs :: [(DPoint, PathJoin Double)] -> Point Double -> [(DPoint, DPoint)]
segDirs :: [(Point Double, PathJoin Double)]
-> Point Double -> [(Point Double, Point Double)]
segDirs [] Point Double
_ = []
segDirs [(Point Double
p, PathJoin Double
JoinLine)] Point Double
q = [(Point Double
dp, Point Double
dp)]
  where dp :: Point Double
dp = Point Double
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p
segDirs [(Point Double
p1, JoinCurve Point Double
p2 Point Double
p3 )] Point Double
p4 = [(Point Double
p2 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p1, Point Double
p4 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p3)]
segDirs ((Point Double
p, PathJoin Double
JoinLine):r :: [(Point Double, PathJoin Double)]
r@((Point Double
q, PathJoin Double
_):[(Point Double, PathJoin Double)]
_)) Point Double
s = (Point Double
dp, Point Double
dp)forall a. a -> [a] -> [a]
: [(Point Double, PathJoin Double)]
-> Point Double -> [(Point Double, Point Double)]
segDirs [(Point Double, PathJoin Double)]
r Point Double
s
  where dp :: Point Double
dp = Point Double
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p
segDirs ((Point Double
p1, JoinCurve Point Double
p2 Point Double
p3 ):r :: [(Point Double, PathJoin Double)]
r@((Point Double
p4,PathJoin Double
_):[(Point Double, PathJoin Double)]
_)) Point Double
q = (Point Double
p2 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p1, Point Double
p4 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p3)forall a. a -> [a] -> [a]
:[(Point Double, PathJoin Double)]
-> Point Double -> [(Point Double, Point Double)]
segDirs [(Point Double, PathJoin Double)]
r Point Double
q

penStrokeOpen :: Int -> Double -> Bool -> Pen Double -> OpenPath Double -> [ClosedPath Double]
penStrokeOpen :: Int
-> Double
-> Bool
-> Pen Double
-> OpenPath Double
-> [ClosedPath Double]
penStrokeOpen Int
samples Double
tol Bool
fast Pen Double
pen (OpenPath [(Point Double, PathJoin Double)]
segments Point Double
p)  =
  [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
union [forall a. OpenPath a -> ClosedPath a
closeOpenPath OpenPath Double
path] FillRule
NonZero Double
tol
  where
    dirs :: [(Point Double, Point Double)]
dirs = [(Point Double, PathJoin Double)]
-> Point Double -> [(Point Double, Point Double)]
segDirs [(Point Double, PathJoin Double)]
segments (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Point Double, PathJoin Double)]
segments)
    fdirs :: [Point Double]
fdirs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. [a] -> [a]
tail [(Point Double, Point Double)]
dirs)
    fd :: Point Double
fd = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Point Double, Point Double)]
dirs
    ld :: Point Double
ld = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [(Point Double, Point Double)]
dirs
    ldirs :: [Point Double]
ldirs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Point Double, Point Double)]
dirs 
    pts :: [Point Double]
pts = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. [a] -> [a]
tail [(Point Double, PathJoin Double)]
segments) forall a. [a] -> [a] -> [a]
++ [Point Double
p]
    leftJoins :: [OpenPath Double]
leftJoins = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinLeft Pen Double
pen) [Point Double]
ldirs [Point Double]
fdirs
    leftStrokes :: [OpenPath Double]
leftStrokes = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> Double
-> Bool
-> Pen Double
-> (Point Double, PathJoin Double)
-> Point Double
-> OpenPath Double
strokeLeft Int
samples Double
tol Bool
fast Pen Double
pen) [(Point Double, PathJoin Double)]
segments [Point Double]
pts
    rightJoins :: [OpenPath Double]
rightJoins = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinRight Pen Double
pen) [Point Double]
ldirs [Point Double]
fdirs
    rightStrokes :: [OpenPath Double]
rightStrokes = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> Double
-> Bool
-> Pen Double
-> (Point Double, PathJoin Double)
-> Point Double
-> OpenPath Double
strokeRight Int
samples Double
tol Bool
fast Pen Double
pen) [(Point Double, PathJoin Double)]
segments [Point Double]
pts
    path :: OpenPath Double
path =
      forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
      Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinLeft Pen Double
pen (forall a. Num a => Point a -> Point a
turnAround Point Double
fd) Point Double
fd forall a. a -> [a] -> [a]
:
      forall a. [a] -> [a] -> [a]
interleave [OpenPath Double]
leftStrokes [OpenPath Double]
leftJoins forall a. [a] -> [a] -> [a]
++
      Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinLeft Pen Double
pen Point Double
ld (forall a. Num a => Point a -> Point a
turnAround Point Double
ld) forall a. a -> [a] -> [a]
:
      forall a. [a] -> [a]
reverse (forall a. [a] -> [a] -> [a]
interleave [OpenPath Double]
rightStrokes [OpenPath Double]
rightJoins)

interleave :: [a] -> [a] -> [a]
interleave :: forall a. [a] -> [a] -> [a]
interleave [] [a]
xs = [a]
xs
interleave [a]
xs [] = [a]
xs
interleave (a
x:[a]
xs) (a
y:[a]
ys) = a
xforall a. a -> [a] -> [a]
:a
yforall a. a -> [a] -> [a]
:forall a. [a] -> [a] -> [a]
interleave [a]
xs [a]
ys 

--penStrokeClosed :: ClosedPath Double -> Pen Double -> Double -> [ClosedPath Double]
penStrokeClosed :: Int -> Double -> Bool -> Pen Double -> ClosedPath Double
                -> [ClosedPath Double]
penStrokeClosed :: Int
-> Double
-> Bool
-> Pen Double
-> ClosedPath Double
-> [ClosedPath Double]
penStrokeClosed Int
_ Double
_ Bool
_ Pen Double
_ (ClosedPath [])  = [forall a. [(Point a, PathJoin a)] -> ClosedPath a
ClosedPath []]
penStrokeClosed Int
samples Double
tol Bool
fast Pen Double
pen (ClosedPath [(Point Double, PathJoin Double)]
segments) =
  [ClosedPath Double] -> FillRule -> Double -> [ClosedPath Double]
union [forall a. OpenPath a -> ClosedPath a
closeOpenPath OpenPath Double
leftPath, forall a. OpenPath a -> ClosedPath a
closeOpenPath OpenPath Double
rightPath] FillRule
NonZero Double
tol
  where
    dirs :: [(Point Double, Point Double)]
dirs = [(Point Double, PathJoin Double)]
-> Point Double -> [(Point Double, Point Double)]
segDirs [(Point Double, PathJoin Double)]
segments (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [(Point Double, PathJoin Double)]
segments)
    fdirs :: [Point Double]
fdirs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. [a] -> [a]
tail [(Point Double, Point Double)]
dirs) forall a. [a] -> [a] -> [a]
++ [forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(Point Double, Point Double)]
dirs)]
    ldirs :: [Point Double]
ldirs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Point Double, Point Double)]
dirs
    pts :: [Point Double]
pts = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. [a] -> [a]
tail [(Point Double, PathJoin Double)]
segments) forall a. [a] -> [a] -> [a]
++ [forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(Point Double, PathJoin Double)]
segments)]
    leftJoins :: [OpenPath Double]
leftJoins = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinLeft Pen Double
pen) [Point Double]
ldirs [Point Double]
fdirs
    leftStrokes :: [OpenPath Double]
leftStrokes = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> Double
-> Bool
-> Pen Double
-> (Point Double, PathJoin Double)
-> Point Double
-> OpenPath Double
strokeLeft Int
samples Double
tol Bool
fast Pen Double
pen) [(Point Double, PathJoin Double)]
segments [Point Double]
pts
    rightJoins :: [OpenPath Double]
rightJoins = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinRight Pen Double
pen) [Point Double]
ldirs [Point Double]
fdirs
    rightStrokes :: [OpenPath Double]
rightStrokes = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int
-> Double
-> Bool
-> Pen Double
-> (Point Double, PathJoin Double)
-> Point Double
-> OpenPath Double
strokeRight Int
samples Double
tol Bool
fast Pen Double
pen) [(Point Double, PathJoin Double)]
segments [Point Double]
pts
    leftPath :: OpenPath Double
leftPath =
      forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a] -> [a]
interleave [OpenPath Double]
leftStrokes [OpenPath Double]
leftJoins
    rightPath :: OpenPath Double
rightPath =
      forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a] -> [a]
interleave [OpenPath Double]
rightStrokes [OpenPath Double]
rightJoins

strokeLeft :: Int -> Double -> Bool -> Pen Double -> (DPoint, PathJoin Double) -> DPoint -> OpenPath Double
strokeLeft :: Int
-> Double
-> Bool
-> Pen Double
-> (Point Double, PathJoin Double)
-> Point Double
-> OpenPath Double
strokeLeft Int
_ Double
_ Bool
_ Pen Double
pen (Point Double
p, PathJoin Double
JoinLine) Point Double
q =
  forall a. [(Point a, PathJoin a)] -> Point a -> OpenPath a
OpenPath [(Point Double
p forall v. AdditiveGroup v => v -> v -> v
^+^ Point Double
offset, forall a. PathJoin a
JoinLine)] (Point Double
q forall v. AdditiveGroup v => v -> v -> v
^+^ Point Double
offset)
  where offset :: Point Double
offset = Pen Double -> Point Double -> Point Double
penOffset Pen Double
pen (Point Double
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p)

strokeLeft Int
samples Double
tol Bool
fast Pen Double
pen (Point Double
p1, JoinCurve Point Double
p2 Point Double
p3) Point Double
p4 =
  forall a. [CubicBezier a] -> OpenPath a
curvesToOpen forall a b. (a -> b) -> a -> b
$ forall a.
(Unbox a, Ord a, Floating a) =>
(a -> (Point a, Point a))
-> Int -> a -> a -> a -> Bool -> [CubicBezier a]
approximatePath
  (Pen Double
-> (Double -> (Point Double, Point Double))
-> Double
-> (Point Double, Point Double)
penOffsetFun Pen Double
pen (forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (Point a, Point a)
evalBezierDeriv (forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point Double
p1 Point Double
p2 Point Double
p3 Point Double
p4)))
  Int
samples Double
tol Double
0 Double
1 Bool
fast

strokeRight :: Int -> Double -> Bool -> Pen Double -> (DPoint, PathJoin Double) -> DPoint -> OpenPath Double
strokeRight :: Int
-> Double
-> Bool
-> Pen Double
-> (Point Double, PathJoin Double)
-> Point Double
-> OpenPath Double
strokeRight Int
_ Double
_ Bool
_ Pen Double
pen (Point Double
p, PathJoin Double
JoinLine) Point Double
q =
  forall a. [(Point a, PathJoin a)] -> Point a -> OpenPath a
OpenPath [(Point Double
q forall v. AdditiveGroup v => v -> v -> v
^+^ Point Double
offset, forall a. PathJoin a
JoinLine)] (Point Double
p forall v. AdditiveGroup v => v -> v -> v
^+^ Point Double
offset)
  where offset :: Point Double
offset = Pen Double -> Point Double -> Point Double
penOffset Pen Double
pen (Point Double
p forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
q)

strokeRight Int
samples Double
tol Bool
fast Pen Double
pen (Point Double
p1, JoinCurve Point Double
p2 Point Double
p3) Point Double
p4 =
  forall a. [CubicBezier a] -> OpenPath a
curvesToOpen forall a b. (a -> b) -> a -> b
$ forall a.
(Unbox a, Ord a, Floating a) =>
(a -> (Point a, Point a))
-> Int -> a -> a -> a -> Bool -> [CubicBezier a]
approximatePath
  (Pen Double
-> (Double -> (Point Double, Point Double))
-> Double
-> (Point Double, Point Double)
penOffsetFun Pen Double
pen (forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (Point a, Point a)
evalBezierDeriv (forall a. Point a -> Point a -> Point a -> Point a -> CubicBezier a
CubicBezier Point Double
p4 Point Double
p3 Point Double
p2 Point Double
p1)))
  Int
samples Double
tol Double
0 Double
1 Bool
fast

penJoinLeft :: Pen Double -> DPoint -> DPoint -> OpenPath Double
penJoinLeft :: Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinLeft = Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoin

penJoinRight :: Pen Double -> DPoint -> DPoint -> OpenPath Double
penJoinRight :: Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoinRight Pen Double
pen Point Double
from Point Double
to = Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoin Pen Double
pen (forall a. Num a => Point a -> Point a
turnAround Point Double
to) (forall a. Num a => Point a -> Point a
turnAround Point Double
from)

ellipticArc :: Transform Double -> Transform Double
            -> Point Double -> Point Double -> CubicBezier Double
ellipticArc :: Transform Double
-> Transform Double
-> Point Double
-> Point Double
-> CubicBezier Double
ellipticArc Transform Double
trans Transform Double
leftInv Point Double
from Point Double
to =
  Transform Double
trans forall a b. AffineTransform a b => Transform b -> a -> a
$* Double -> Double -> CubicBezier Double
bezierArc
  (forall a. RealFloat a => Point a -> a
vectorAngle forall a b. (a -> b) -> a -> b
$ Transform Double
leftInv forall a b. AffineTransform a b => Transform b -> a -> a
$* Point Double
from)
  (forall a. RealFloat a => Point a -> a
vectorAngle forall a b. (a -> b) -> a -> b
$ Transform Double
leftInv forall a b. AffineTransform a b => Transform b -> a -> a
$* Point Double
to)

segmentsToPath :: (Eq a) => [PenSegment a] -> OpenPath a
segmentsToPath :: forall a. Eq a => [PenSegment a] -> OpenPath a
segmentsToPath [PenCorner Point a
_ Point a
q] =
  forall a. [(Point a, PathJoin a)] -> Point a -> OpenPath a
OpenPath [] Point a
q
segmentsToPath [PenCurve Point a
_ (CubicBezier Point a
p1 Point a
p2 Point a
p3 Point a
p4)] =
  forall a. [(Point a, PathJoin a)] -> Point a -> OpenPath a
OpenPath [(Point a
p1, forall a. Point a -> Point a -> PathJoin a
JoinCurve Point a
p2 Point a
p3)] Point a
p4
  
segmentsToPath (PenCorner Point a
_ Point a
p:[PenSegment a]
r) =
  forall a. Point a -> PathJoin a -> OpenPath a -> OpenPath a
consOpenPath Point a
p forall a. PathJoin a
JoinLine (forall a. Eq a => [PenSegment a] -> OpenPath a
segmentsToPath [PenSegment a]
r)

segmentsToPath (PenCurve Point a
_ (CubicBezier Point a
p1 Point a
p2 Point a
p3 Point a
p4):[PenSegment a]
r) =
  forall a. Point a -> PathJoin a -> OpenPath a -> OpenPath a
consOpenPath Point a
p1 (forall a. Point a -> Point a -> PathJoin a
JoinCurve Point a
p2 Point a
p3) forall a b. (a -> b) -> a -> b
$
  case [PenSegment a]
r of
    (PenCurve Point a
_ (CubicBezier Point a
q1 Point a
_ Point a
_ Point a
_):[PenSegment a]
_)
      | Point a
p4 forall a. Eq a => a -> a -> Bool
/= Point a
q1  -> forall a. Point a -> PathJoin a -> OpenPath a -> OpenPath a
consOpenPath Point a
p4 forall a. PathJoin a
JoinLine forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [PenSegment a] -> OpenPath a
segmentsToPath [PenSegment a]
r
    [PenSegment a]
_ -> forall a. Eq a => [PenSegment a] -> OpenPath a
segmentsToPath [PenSegment a]
r

segmentsToPath [] = forall a. OpenPath a
emptyOpenPath  

emptyOpenPath :: OpenPath a
emptyOpenPath :: forall a. OpenPath a
emptyOpenPath = forall a. [(Point a, PathJoin a)] -> Point a -> OpenPath a
OpenPath [] (forall a. HasCallStack => [Char] -> a
error [Char]
"empty path")
  
penJoin :: Pen Double -> Point Double
        -> Point Double -> OpenPath Double
penJoin :: Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoin pen :: Pen Double
pen@(PenEllipse Transform Double
trans Transform Double
leftInv Transform Double
_) Point Double
from Point Double
to
  | Double
dir forall a. Eq a => a -> a -> Bool
== Double
0 = forall a. OpenPath a
emptyOpenPath
  | Double
dir forall a. Ord a => a -> a -> Bool
> Double
0 Bool -> Bool -> Bool
&&
    forall a. (Num a, Eq a) => Point a -> Point a -> Bool
sameQuadrant Point Double
from Point Double
to =
    forall a. [CubicBezier a] -> OpenPath a
curvesToOpen [Transform Double
-> Transform Double
-> Point Double
-> Point Double
-> CubicBezier Double
ellipticArc Transform Double
trans Transform Double
leftInv Point Double
from Point Double
to]
  | Bool
otherwise =
      forall a. [CubicBezier a] -> OpenPath a
curvesToOpen [Transform Double
-> Transform Double
-> Point Double
-> Point Double
-> CubicBezier Double
ellipticArc Transform Double
trans Transform Double
leftInv Point Double
from Point Double
next] forall a. Semigroup a => a -> a -> a
<>
      Pen Double -> Point Double -> Point Double -> OpenPath Double
penJoin Pen Double
pen Point Double
next Point Double
to
      where next :: Point Double
next = forall a1 a. (Ord a1, Num a1, Num a) => Point a1 -> Point a
nextVector Point Double
from
            dir :: Double
dir = forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
from Point Double
to

penJoin (PenPath [PenSegment Double]
segments) Point Double
from Point Double
to =
  forall a. Eq a => [PenSegment a] -> OpenPath a
segmentsToPath forall a b. (a -> b) -> a -> b
$
  [PenSegment Double] -> Point Double -> [PenSegment Double]
nextSegments ([PenSegment Double] -> Point Double -> [PenSegment Double]
firstSegment (forall a. [a] -> [a]
cycle [PenSegment Double]
segments) Point Double
from) Point Double
to

firstSegment :: [PenSegment Double] -> Point Double -> [PenSegment Double]
firstSegment :: [PenSegment Double] -> Point Double -> [PenSegment Double]
firstSegment segments :: [PenSegment Double]
segments@(PenCorner Point Double
c Point Double
_:PenSegment Double
q:[PenSegment Double]
rest) Point Double
from
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
from Point Double
c forall a. Ord a => a -> a -> Bool
> Double
0 =
    [PenSegment Double] -> Point Double -> [PenSegment Double]
firstSegment (PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
from
  | Bool
otherwise = [PenSegment Double]
segments

firstSegment segments :: [PenSegment Double]
segments@(PenCurve Point Double
c curve :: CubicBezier Double
curve@(CubicBezier Point Double
p1 Point Double
p2 Point Double
p3 Point Double
p4):PenSegment Double
q:[PenSegment Double]
rest) Point Double
from
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
from Point Double
c forall a. Ord a => a -> a -> Bool
> Double
0 = [PenSegment Double] -> Point Double -> [PenSegment Double]
firstSegment (PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
from
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
from (Point Double
p2 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p1) forall a. Ord a => a -> a -> Bool
> Double
0 = [PenSegment Double]
segments
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
from (Point Double
p4 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p3) forall a. Ord a => a -> a -> Bool
> Double
0 =
      case Point Double -> CubicBezier Double -> [Double]
findBezierTangent Point Double
from CubicBezier Double
curve of
        (Double
t:[Double]
_) -> forall a. Point a -> CubicBezier a -> PenSegment a
PenCurve Point Double
from (forall a b. (a, b) -> b
snd (forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
curve Double
t))forall a. a -> [a] -> [a]
:PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest
        [Double]
_ -> PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
from (forall a. PenSegment a -> Point a
firstPoint PenSegment Double
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p4) forall a. Ord a => a -> a -> Bool
> Double
0 =
      forall a. Point a -> Point a -> PenSegment a
PenCorner (forall a. PenSegment a -> Point a
firstPoint PenSegment Double
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p4) Point Double
p4forall a. a -> [a] -> [a]
:PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest
  | Bool
otherwise = [PenSegment Double] -> Point Double -> [PenSegment Double]
firstSegment (PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
from

firstSegment [PenSegment Double]
_ Point Double
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"firstsegment: finite list"  

nextSegments :: [PenSegment Double] -> Point Double -> [PenSegment Double]
nextSegments :: [PenSegment Double] -> Point Double -> [PenSegment Double]
nextSegments (PenCorner Point Double
c Point Double
p:PenSegment Double
q:[PenSegment Double]
rest) Point Double
to
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
to Point Double
c forall a. Ord a => a -> a -> Bool
> Double
0 =
      forall a. Point a -> Point a -> PenSegment a
PenCorner Point Double
c Point Double
pforall a. a -> [a] -> [a]
: [PenSegment Double] -> Point Double -> [PenSegment Double]
nextSegments (PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
to
  | Bool
otherwise = []

nextSegments (pc :: PenSegment Double
pc@(PenCurve Point Double
c curve :: CubicBezier Double
curve@(CubicBezier Point Double
p1 Point Double
p2 Point Double
p3 Point Double
p4)):PenSegment Double
q:[PenSegment Double]
rest) Point Double
to  
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
to Point Double
c forall a. Ord a => a -> a -> Bool
> Double
0 = PenSegment Double
pcforall a. a -> [a] -> [a]
: [PenSegment Double] -> Point Double -> [PenSegment Double]
nextSegments (PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
to
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
to (Point Double
p2 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p1) forall a. Ord a => a -> a -> Bool
> Double
0 = []
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
to (Point Double
p4 forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p3) forall a. Ord a => a -> a -> Bool
> Double
0 =
      case Point Double -> CubicBezier Double -> [Double]
findBezierTangent Point Double
to CubicBezier Double
curve of
        (Double
t:[Double]
_) -> [forall a. Point a -> CubicBezier a -> PenSegment a
PenCurve Point Double
c (forall a b. (a, b) -> a
fst (forall a (b :: * -> *).
(Unbox a, Fractional a, GenericBezier b) =>
b a -> a -> (b a, b a)
splitBezier CubicBezier Double
curve Double
t))]
        [Double]
_ -> []
  | forall a. Num a => Point a -> Point a -> a
vectorCross Point Double
to (forall a. PenSegment a -> Point a
firstPoint PenSegment Double
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p4) forall a. Ord a => a -> a -> Bool
> Double
0 =
      [forall a. Point a -> Point a -> PenSegment a
PenCorner (forall a. PenSegment a -> Point a
firstPoint PenSegment Double
q forall v. AdditiveGroup v => v -> v -> v
^-^ Point Double
p4) Point Double
p4]
  | Bool
otherwise = PenSegment Double
pcforall a. a -> [a] -> [a]
:[PenSegment Double] -> Point Double -> [PenSegment Double]
firstSegment (PenSegment Double
qforall a. a -> [a] -> [a]
:[PenSegment Double]
rest) Point Double
to

nextSegments [PenSegment Double]
_ Point Double
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"nextSegments: finite list"

sameQuadrant :: (Num a, Eq a) => Point a -> Point a -> Bool
sameQuadrant :: forall a. (Num a, Eq a) => Point a -> Point a -> Bool
sameQuadrant Point a
v Point a
w =
  forall a. Num a => a -> a
signum (forall a. Point a -> a
pointX Point a
v) forall a. Eq a => a -> a -> Bool
/= -forall a. Num a => a -> a
signum (forall a. Point a -> a
pointX Point a
w) Bool -> Bool -> Bool
&&
  forall a. Num a => a -> a
signum (forall a. Point a -> a
pointY Point a
v) forall a. Eq a => a -> a -> Bool
/= -forall a. Num a => a -> a
signum (forall a. Point a -> a
pointY Point a
w)

nextVector :: (Ord a1, Num a1, Num a) => Point a1 -> Point a
nextVector :: forall a1 a. (Ord a1, Num a1, Num a) => Point a1 -> Point a
nextVector Point a1
v
  | forall a. Point a -> a
pointX Point a1
v forall a. Ord a => a -> a -> Bool
>= a1
0 Bool -> Bool -> Bool
&&
    forall a. Point a -> a
pointY Point a1
v forall a. Ord a => a -> a -> Bool
> a1
0 = forall a. a -> a -> Point a
Point a
1 a
0
  | forall a. Point a -> a
pointX Point a1
v forall a. Ord a => a -> a -> Bool
> a1
0 Bool -> Bool -> Bool
&&
    forall a. Point a -> a
pointY Point a1
v forall a. Ord a => a -> a -> Bool
<= a1
0 = forall a. a -> a -> Point a
Point a
0 (-a
1)
  | forall a. Point a -> a
pointX Point a1
v forall a. Ord a => a -> a -> Bool
<= a1
0 Bool -> Bool -> Bool
&&
    forall a. Point a -> a
pointY Point a1
v forall a. Ord a => a -> a -> Bool
< a1
0 = forall a. a -> a -> Point a
Point (-a
1) a
0
  | Bool
otherwise = forall a. a -> a -> Point a
Point a
0 a
1