module Graphics.Rasterific.StrokeInternal
    ( flatten
    , dashize
    , strokize
    , dashedStrokize
    , splitPrimitiveUntil
    , approximatePathLength
    , isPrimitivePoint
    , sanitize
    , sanitizeFilling
    )  where

import Graphics.Rasterific.Linear
             ( V2( .. )
             , (^-^)
             , (^+^)
             , (^*)
             , dot
             , nearZero
             )

import Graphics.Rasterific.Operators
import Graphics.Rasterific.Types
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.Line

lastPoint :: Primitive -> Point
lastPoint :: Primitive -> Point
lastPoint (LinePrim (Line Point
_ Point
x1)) = Point
x1
lastPoint (BezierPrim (Bezier Point
_ Point
_ Point
x2)) = Point
x2
lastPoint (CubicBezierPrim (CubicBezier Point
_ Point
_ Point
_ Point
x3)) = Point
x3

lastPointAndNormal :: Primitive -> (Point, Vector)
lastPointAndNormal :: Primitive -> (Point, Point)
lastPointAndNormal (LinePrim (Line Point
a Point
b)) = (Point
b, Point
a Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
b)
lastPointAndNormal (BezierPrim (Bezier Point
_ Point
b Point
c)) = (Point
c, Point
b Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
c)
lastPointAndNormal (CubicBezierPrim (CubicBezier Point
_ Point
_ Point
c Point
d)) = (Point
d, Point
c Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
d)

firstPointAndNormal :: Primitive -> (Point, Vector)
firstPointAndNormal :: Primitive -> (Point, Point)
firstPointAndNormal (LinePrim (Line Point
a Point
b)) = (Point
a, Point
a Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
b)
firstPointAndNormal (BezierPrim (Bezier Point
a Point
b Point
_)) = (Point
a, Point
a Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
b)
firstPointAndNormal (CubicBezierPrim (CubicBezier Point
a Point
b Point
_ Point
_)) = (Point
a, Point
a Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
b)

isPrimitivePoint :: Primitive -> Bool
isPrimitivePoint :: Primitive -> Bool
isPrimitivePoint Primitive
p = case Primitive
p of
  LinePrim Line
l -> Line -> Bool
isLinePoint Line
l
  BezierPrim Bezier
b -> Bezier -> Bool
isBezierPoint Bezier
b
  CubicBezierPrim CubicBezier
c -> CubicBezier -> Bool
isCubicBezierPoint CubicBezier
c

reversePrimitive :: Primitive -> Primitive
reversePrimitive :: Primitive -> Primitive
reversePrimitive (LinePrim (Line Point
a Point
b)) = Line -> Primitive
LinePrim (Point -> Point -> Line
Line Point
b Point
a)
reversePrimitive (BezierPrim (Bezier Point
a Point
b Point
c)) =
    Bezier -> Primitive
BezierPrim (Point -> Point -> Point -> Bezier
Bezier Point
c Point
b Point
a)
reversePrimitive (CubicBezierPrim (CubicBezier Point
a Point
b Point
c Point
d)) =
    CubicBezier -> Primitive
CubicBezierPrim (Point -> Point -> Point -> Point -> CubicBezier
CubicBezier Point
d Point
c Point
b Point
a)

-- | Create a "rounded" join or cap

roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive
roundJoin :: Float -> Point -> Point -> Point -> Container Primitive
roundJoin Float
offset Point
p = Point -> Point -> Container Primitive
forall (f :: * -> *).
(Applicative f, Semigroup (f Primitive)) =>
Point -> Point -> f Primitive
go
  where go :: Point -> Point -> f Primitive
go Point
u Point
v
          -- If we're already on a nice curvature,

          -- don't bother doing anything

          | Point
u Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
w Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
0.9 = Primitive -> f Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> f Primitive)
-> (Bezier -> Primitive) -> Bezier -> f Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bezier -> Primitive
BezierPrim (Bezier -> f Primitive) -> Bezier -> f Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Point -> Bezier
Bezier Point
a Point
b Point
c
          | Bool
otherwise = Point -> Point -> f Primitive
go Point
u Point
w f Primitive -> f Primitive -> f Primitive
forall a. Semigroup a => a -> a -> a
<> Point -> Point -> f Primitive
go Point
w Point
v
          where --     ^

                --     |w

                -- a X---X c

                --    \ /

                --     Xp

                -- ^  / \  ^

                -- u\/   \/v

                --  /     \   .

                a :: Point
a = Point
p Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
u Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset
                c :: Point
c = Point
p Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
v Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset

                w :: Point
w = (Point
a Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
c) Point -> Point -> Point
forall v. Epsilon v => v -> v -> v
`ifZero` Point
u

                -- Same as offseting

                n :: Point
n = Point
p Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
w Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset
                b :: Point
b = Point
n Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
2 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ (Point
a Point -> Point -> Point
forall (a :: * -> *) coord.
(Additive a, Fractional coord) =>
a coord -> a coord -> a coord
`midPoint` Point
c)

-- | Put a cap at the end of a bezier curve, depending

-- on the kind of cap wanted.

cap :: Float -> Cap -> Primitive -> Container Primitive
cap :: Float -> Cap -> Primitive -> Container Primitive
cap Float
offset Cap
CapRound Primitive
prim 
  | Point -> Bool
forall a. Epsilon a => a -> Bool
nearZero Point
u = Float -> Cap -> Primitive -> Container Primitive
cap Float
offset (Float -> Cap
CapStraight Float
0) Primitive
prim
  | Bool
otherwise = Float -> Point -> Point -> Point -> Container Primitive
roundJoin Float
offset Point
p Point
u (- Point
u)
  where (Point
p, Point
u) = Primitive -> (Point, Point)
lastPointAndNormal Primitive
prim

cap Float
offset (CapStraight Float
cVal) Primitive
prim =
   Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point
d Point -> Point -> Primitive
`lineFromTo` Point
e) Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point
e Point -> Point -> Primitive
`lineFromTo` Point
f)
                           Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point
f Point -> Point -> Primitive
`lineFromTo` Point
g)
  where -- The usual "normal"

        (Point
p, u :: Point
u@(V2 Float
ux Float
uy)) = Primitive -> (Point, Point)
lastPointAndNormal Primitive
prim
        -- Vector pointing in the direction of the curve

        -- of norm 1

        v :: Point
v = Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
uy (Float -> Point) -> Float -> Point
forall a b. (a -> b) -> a -> b
$ Float -> Float
forall a. Num a => a -> a
negate Float
ux

        -- Finishing points around the edge

        -- -u*offset u*offset

        --       <-><->

        --     d/  /  /g

        --     /  /  /

        --    /  /  /

        --      /

        --     / curve

        --

        d :: Point
d = Point
p Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
u Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset
        g :: Point
g = Point
p Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
u Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset

        -- Create the "far" points

        --

        --       e        f

        --        /     /   ^

        --       /     /   / v * offset * cVal

        --     d/  /  /g

        --     /  /  /

        --    /  /  /

        --      /

        --     / curve

        --

        e :: Point
e = Point
d Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
v Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (Float
offset Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cVal)
        f :: Point
f = Point
g Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
v Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* (Float
offset Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
cVal)

lineFromTo :: Point -> Point -> Primitive
lineFromTo :: Point -> Point -> Primitive
lineFromTo Point
a Point
b = Line -> Primitive
LinePrim (Point -> Point -> Line
Line Point
a Point
b)

miterJoin :: Float -> Float -> Point -> Vector -> Vector
          -> Container Primitive
miterJoin :: Float -> Float -> Point -> Point -> Point -> Container Primitive
miterJoin Float
offset Float
l Point
point Point
u Point
v
  | Float
uDotW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
l Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
1 Float
l Bool -> Bool -> Bool
&& Float
uDotW Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0.01 =
      Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point
a Point -> Point -> Primitive
`lineFromTo` Point
m) Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Point
m Point -> Point -> Primitive
`lineFromTo` Point
c)
  -- A simple straight junction

  | Bool
otherwise = Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> Container Primitive)
-> Primitive -> Container Primitive
forall a b. (a -> b) -> a -> b
$ Point
a Point -> Point -> Primitive
`lineFromTo` Point
c
  where --      X m

        --     /\

        --    /|w\

        -- a X---X c

        --    \ /

        --     Xp

        -- ^  / \  ^

        -- u\/   \/v

        --  /     \     .

        a :: Point
a = Point
point Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
u Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset
        c :: Point
c = Point
point Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Point
v Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset
        w :: Point
w = (Point
a Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
c) Point -> Point -> Point
forall v. Epsilon v => v -> v -> v
`ifZero` Point
u

        uDotW :: Float
uDotW =  Point
u Point -> Point -> Float
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Point
w

        -- Calculate the maximum distance on the

        -- u axis

        p :: Float
p = Float
offset Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
uDotW
        -- middle point for "straight joining"

        m :: Point
m = Point
point Point -> Point -> Point
forall a. Num a => a -> a -> a
+ Point
w Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
p

joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive
               -> Container Primitive
joinPrimitives :: Float -> Join -> Primitive -> Primitive -> Container Primitive
joinPrimitives Float
offset Join
join Primitive
prim1 Primitive
prim2  =
  case Join
join of
    Join
JoinRound | Point -> Bool
forall a. Epsilon a => a -> Bool
nearZero Point
u Bool -> Bool -> Bool
|| Point -> Bool
forall a. Epsilon a => a -> Bool
nearZero Point
v -> Float -> Float -> Point -> Point -> Point -> Container Primitive
miterJoin Float
offset Float
0 Point
p Point
u Point
v
    Join
JoinRound -> Float -> Point -> Point -> Point -> Container Primitive
roundJoin Float
offset Point
p Point
u Point
v
    JoinMiter Float
l -> Float -> Float -> Point -> Point -> Point -> Container Primitive
miterJoin Float
offset Float
l Point
p Point
u Point
v
  where (Point
p, Point
u) = Primitive -> (Point, Point)
lastPointAndNormal Primitive
prim1
        (Point
_, Point
v) = Primitive -> (Point, Point)
firstPointAndNormal Primitive
prim2

offsetPrimitives :: Float -> Primitive -> Container Primitive
offsetPrimitives :: Float -> Primitive -> Container Primitive
offsetPrimitives Float
offset (LinePrim Line
l) = Float -> Line -> Container Primitive
offsetLine Float
offset Line
l
offsetPrimitives Float
offset (BezierPrim Bezier
b) = Float -> Bezier -> Container Primitive
offsetBezier Float
offset Bezier
b
offsetPrimitives Float
offset (CubicBezierPrim CubicBezier
c) = Float -> CubicBezier -> Container Primitive
offsetCubicBezier Float
offset CubicBezier
c

offsetAndJoin :: Float -> Join -> Cap -> [Primitive]
              -> Container Primitive
offsetAndJoin :: Float -> Join -> Cap -> [Primitive] -> Container Primitive
offsetAndJoin Float
_ Join
_ Cap
_ [] = Container Primitive
forall a. Monoid a => a
mempty
offsetAndJoin Float
offset Join
join Cap
caping (Primitive
firstShape:[Primitive]
rest) = Primitive -> [Primitive] -> Container Primitive
go Primitive
firstShape [Primitive]
rest
  where joiner :: Primitive -> Primitive -> Container Primitive
joiner = Float -> Join -> Primitive -> Primitive -> Container Primitive
joinPrimitives Float
offset Join
join
        offseter :: Primitive -> Container Primitive
offseter = Float -> Primitive -> Container Primitive
offsetPrimitives Float
offset
        (Point
firstPoint, Point
_) = Primitive -> (Point, Point)
firstPointAndNormal Primitive
firstShape

        go :: Primitive -> [Primitive] -> Container Primitive
go Primitive
prev []
           | Point
firstPoint Point -> Point -> Bool
`isNearby` Primitive -> Point
lastPoint Primitive
prev = Primitive -> Container Primitive
offseter Primitive
prev Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Primitive -> Primitive -> Container Primitive
joiner Primitive
prev Primitive
firstShape
           | Bool
otherwise = Primitive -> Container Primitive
offseter Primitive
prev Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Float -> Cap -> Primitive -> Container Primitive
cap Float
offset Cap
caping Primitive
prev
        go Primitive
prev (Primitive
x:[Primitive]
xs) =
             Primitive -> Container Primitive
offseter Primitive
prev Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Primitive -> Primitive -> Container Primitive
joiner Primitive
prev Primitive
x Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Primitive -> [Primitive] -> Container Primitive
go Primitive
x [Primitive]
xs

approximateLength :: Primitive -> Float
approximateLength :: Primitive -> Float
approximateLength (LinePrim Line
l) = Line -> Float
lineLength Line
l
approximateLength (BezierPrim Bezier
b) = Bezier -> Float
bezierLengthApproximation Bezier
b
approximateLength (CubicBezierPrim CubicBezier
c) = CubicBezier -> Float
cubicBezierLengthApproximation CubicBezier
c


sanitize :: Primitive -> Container Primitive
sanitize :: Primitive -> Container Primitive
sanitize (LinePrim Line
l) = Line -> Container Primitive
sanitizeLine Line
l
sanitize (BezierPrim Bezier
b) = Bezier -> Container Primitive
sanitizeBezier Bezier
b
sanitize (CubicBezierPrim CubicBezier
c) = CubicBezier -> Container Primitive
sanitizeCubicBezier CubicBezier
c

-- | Sanitizing that don't cull really small elements, only

-- Degenerate case, to allow them to participate to the correct

-- coverage, even if really small.

sanitizeFilling :: Primitive -> Container Primitive
sanitizeFilling :: Primitive -> Container Primitive
sanitizeFilling (LinePrim Line
l) = Line -> Container Primitive
sanitizeLineFilling Line
l
sanitizeFilling (BezierPrim Bezier
b) = Bezier -> Container Primitive
sanitizeBezierFilling Bezier
b
sanitizeFilling (CubicBezierPrim CubicBezier
c) = CubicBezier -> Container Primitive
sanitizeCubicBezierFilling CubicBezier
c

strokize :: Geometry geom
         => StrokeWidth -> Join -> (Cap, Cap) -> geom
         -> Container Primitive
strokize :: Float -> Join -> (Cap, Cap) -> geom -> Container Primitive
strokize Float
width Join
join (Cap
capStart, Cap
capEnd) geom
geom = ([Primitive] -> Container Primitive)
-> [[Primitive]] -> Container Primitive
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [Primitive] -> Container Primitive
pathOffseter [[Primitive]]
sanitized
  where 
    sanitized :: [[Primitive]]
sanitized = (Primitive -> [Primitive]) -> [Primitive] -> [Primitive]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer (Container Primitive -> [Primitive])
-> (Primitive -> Container Primitive) -> Primitive -> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Primitive -> Container Primitive
sanitize) ([Primitive] -> [Primitive]) -> [[Primitive]] -> [[Primitive]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Primitive] -> [[Primitive]]
resplit (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
geom)
    offseter :: Cap -> [Primitive] -> Container Primitive
offseter = Float -> Join -> Cap -> [Primitive] -> Container Primitive
offsetAndJoin (Float
width Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) Join
join
    pathOffseter :: [Primitive] -> Container Primitive
pathOffseter [Primitive]
v =
        Cap -> [Primitive] -> Container Primitive
offseter Cap
capEnd [Primitive]
v Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Cap -> [Primitive] -> Container Primitive
offseter Cap
capStart ([Primitive] -> [Primitive]
forall a. [a] -> [a]
reverse ([Primitive] -> [Primitive]) -> [Primitive] -> [Primitive]
forall a b. (a -> b) -> a -> b
$ Primitive -> Primitive
reversePrimitive (Primitive -> Primitive) -> [Primitive] -> [Primitive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Primitive]
v)

flattenPrimitive :: Primitive -> Container Primitive
flattenPrimitive :: Primitive -> Container Primitive
flattenPrimitive (BezierPrim Bezier
bezier) = Bezier -> Container Primitive
flattenBezier Bezier
bezier
flattenPrimitive (CubicBezierPrim CubicBezier
bezier) = CubicBezier -> Container Primitive
flattenCubicBezier CubicBezier
bezier
flattenPrimitive (LinePrim Line
line) = Line -> Container Primitive
flattenLine Line
line

breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive)
breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive)
breakPrimitiveAt (BezierPrim Bezier
bezier) Float
at = (Bezier -> Primitive
BezierPrim Bezier
a, Bezier -> Primitive
BezierPrim Bezier
b)
  where (Bezier
a, Bezier
b) = Bezier -> Float -> (Bezier, Bezier)
bezierBreakAt Bezier
bezier Float
at
breakPrimitiveAt (CubicBezierPrim CubicBezier
bezier) Float
at = (CubicBezier -> Primitive
CubicBezierPrim CubicBezier
a, CubicBezier -> Primitive
CubicBezierPrim CubicBezier
b)
  where (CubicBezier
a, CubicBezier
b) = CubicBezier -> Float -> (CubicBezier, CubicBezier)
cubicBezierBreakAt CubicBezier
bezier Float
at
breakPrimitiveAt (LinePrim Line
line) Float
at = (Line -> Primitive
LinePrim Line
a, Line -> Primitive
LinePrim Line
b)
  where (Line
a, Line
b) = Line -> Float -> (Line, Line)
lineBreakAt Line
line Float
at


flatten :: Container Primitive -> Container Primitive
flatten :: Container Primitive -> Container Primitive
flatten = (Primitive -> Container Primitive)
-> Container Primitive -> Container Primitive
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Primitive -> Container Primitive
flattenPrimitive

splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive])
splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive])
splitPrimitiveUntil = Float -> [Primitive] -> ([Primitive], [Primitive])
go
  where
    go :: Float -> [Primitive] -> ([Primitive], [Primitive])
go Float
_ [] = ([], [])
    go Float
left [Primitive]
lst
      | Float
left Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = ([], [Primitive]
lst)
    go Float
left (Primitive
x : [Primitive]
xs)
      | Float
left Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
primLength = (Primitive
x Primitive -> [Primitive] -> [Primitive]
forall a. a -> [a] -> [a]
: [Primitive]
inInterval, [Primitive]
afterInterval)
      | Bool
otherwise = ([Primitive
beforeStop], Primitive
afterStop Primitive -> [Primitive] -> [Primitive]
forall a. a -> [a] -> [a]
: [Primitive]
xs)
      where
        primLength :: Float
primLength = Primitive -> Float
approximateLength Primitive
x
        ([Primitive]
inInterval, [Primitive]
afterInterval) = Float -> [Primitive] -> ([Primitive], [Primitive])
go (Float
left Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
primLength) [Primitive]
xs

        (Primitive
beforeStop, Primitive
afterStop) =
            Primitive -> Float -> (Primitive, Primitive)
breakPrimitiveAt Primitive
x (Float -> (Primitive, Primitive))
-> Float -> (Primitive, Primitive)
forall a b. (a -> b) -> a -> b
$ Float
left Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
primLength

dropPattern :: Float -> DashPattern -> DashPattern
dropPattern :: Float -> DashPattern -> DashPattern
dropPattern = Float -> DashPattern -> DashPattern
forall t. (Ord t, Num t) => t -> [t] -> [t]
go
  where
    go :: t -> [t] -> [t]
go t
_ [] = []
    go t
offset (t
x:[t]
xs)
        | t
x t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 = t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
xs -- sanitizing

        | t
offset t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
x = t
x t -> t -> t
forall a. Num a => a -> a -> a
- t
offset t -> [t] -> [t]
forall a. a -> [a] -> [a]
: [t]
xs
        | Bool
otherwise {- offset >= x -} = t -> [t] -> [t]
go (t
offset t -> t -> t
forall a. Num a => a -> a -> a
- t
x) [t]
xs

-- | Don't make them completly flat, but suficiently

-- to assume they are.

linearizePrimitives :: [Primitive] -> [Primitive]
linearizePrimitives :: [Primitive] -> [Primitive]
linearizePrimitives =
  Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer (Container Primitive -> [Primitive])
-> ([Primitive] -> Container Primitive)
-> [Primitive]
-> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Primitive -> Container Primitive)
-> Container Primitive -> Container Primitive
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Primitive -> Container Primitive
flattenPrimitive (Container Primitive -> Container Primitive)
-> ([Primitive] -> Container Primitive)
-> [Primitive]
-> Container Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Primitive -> Container Primitive)
-> [Primitive] -> Container Primitive
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Primitive -> Container Primitive
sanitize

-- | Return an approximation of the length of a given path.

-- It's results is not precise but should be enough for

-- rough calculations

approximatePathLength :: Path -> Float
approximatePathLength :: Path -> Float
approximatePathLength = [Primitive] -> Float
approximatePrimitivesLength ([Primitive] -> Float) -> (Path -> [Primitive]) -> Path -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [Primitive]
pathToPrimitives

approximatePrimitivesLength :: [Primitive] -> Float
approximatePrimitivesLength :: [Primitive] -> Float
approximatePrimitivesLength [Primitive]
prims =
  DashPattern -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (DashPattern -> Float) -> DashPattern -> Float
forall a b. (a -> b) -> a -> b
$ Primitive -> Float
approximateLength (Primitive -> Float) -> [Primitive] -> DashPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Primitive] -> [Primitive]
linearizePrimitives [Primitive]
prims

dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]]
dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]]
dashize Float
offset DashPattern
pattern = DashPattern -> [Primitive] -> [[Primitive]]
taker DashPattern
infinitePattern ([Primitive] -> [[Primitive]])
-> ([Primitive] -> [Primitive]) -> [Primitive] -> [[Primitive]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Primitive] -> [Primitive]
linearizePrimitives 
  where
    realOffset :: Float
realOffset | Float
offset Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
0 = Float
offset
               | Bool
otherwise = Float
offset Float -> Float -> Float
forall a. Num a => a -> a -> a
+ DashPattern -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum DashPattern
pattern

    infinitePattern :: DashPattern
infinitePattern =
        Float -> DashPattern -> DashPattern
dropPattern Float
realOffset (DashPattern -> DashPattern)
-> (DashPattern -> DashPattern) -> DashPattern -> DashPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DashPattern -> DashPattern
forall a. [a] -> [a]
cycle (DashPattern -> DashPattern) -> DashPattern -> DashPattern
forall a b. (a -> b) -> a -> b
$ (Float -> Bool) -> DashPattern -> DashPattern
forall a. (a -> Bool) -> [a] -> [a]
filter (Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0) DashPattern
pattern

    taker :: DashPattern -> [Primitive] -> [[Primitive]]
taker DashPattern
_ [] = []
    taker [] [Primitive]
_ = [] -- Impossible by construction, pattern is infinite

    taker (Float
atValue:DashPattern
atRest) [Primitive]
stream = [Primitive]
toKeep [Primitive] -> [[Primitive]] -> [[Primitive]]
forall a. a -> [a] -> [a]
: DashPattern -> [Primitive] -> [[Primitive]]
droper DashPattern
atRest [Primitive]
next
      where ([Primitive]
toKeep, [Primitive]
next) = Float -> [Primitive] -> ([Primitive], [Primitive])
splitPrimitiveUntil Float
atValue [Primitive]
stream

    droper :: DashPattern -> [Primitive] -> [[Primitive]]
droper DashPattern
_ [] = []
    droper [] [Primitive]
_ = [] -- Impossible by construction, pattern is infinite

    droper (Float
atValue:DashPattern
atRest) [Primitive]
stream = DashPattern -> [Primitive] -> [[Primitive]]
taker DashPattern
atRest [Primitive]
next
      where ([Primitive]
_toKeep, [Primitive]
next) = Float -> [Primitive] -> ([Primitive], [Primitive])
splitPrimitiveUntil Float
atValue [Primitive]
stream

-- | Create a list of outlines corresponding to all the

-- dashed elements. They can be then stroked

--

-- > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $

-- >     dashedStrokize 0 [10, 5]

-- >                    40 JoinRound (CapStraight 0, CapStraight 0) $

-- >         CubicBezier (V2  40 160) (V2 40   40) (V2 160  40) (V2 160 160)

--

-- <<docimages/strokize_dashed_path.png>>

--

dashedStrokize :: Geometry geom
               => Float       -- ^ Starting offset

               -> DashPattern -- ^ Dashing pattern to use for stroking

               -> StrokeWidth -- ^ Stroke width

               -> Join        -- ^ Which kind of join will be used

               -> (Cap, Cap)  -- ^ Start and end capping.

               -> geom        -- ^ Elements to transform

               -> [[Primitive]]
dashedStrokize :: Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> [[Primitive]]
dashedStrokize Float
offset DashPattern
dashPattern Float
width Join
join (Cap, Cap)
capping geom
geom =
    Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer (Container Primitive -> [Primitive])
-> ([Primitive] -> Container Primitive)
-> [Primitive]
-> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Join -> (Cap, Cap) -> [Primitive] -> Container Primitive
forall geom.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Container Primitive
strokize Float
width Join
join (Cap, Cap)
capping
        ([Primitive] -> [Primitive]) -> [[Primitive]] -> [[Primitive]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Float -> DashPattern -> [Primitive] -> [[Primitive]]
dashize Float
offset DashPattern
dashPattern (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
geom)