{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Gather all the types used in the rasterization engine.

module Graphics.Rasterific.Types
    ( -- * Geometry description

      Vector
    , Point
    , Line( .. )
    , Bezier( .. )
    , CubicBezier( .. )
    , Primitive( .. )

    , Primitivable( .. )
    , Geometry( .. )

    , Producer
    , Container
    , containerOfList
    , listOfContainer
    , containerOfFunction
    , PathCommand( .. )
    , Path( .. )
    , Transformable( .. )
    , PointFoldable( .. )

      -- * Rasterization control types

    , Cap( .. )
    , Join( .. )
    , FillMethod( .. )
    , SamplerRepeat( .. )
    , DashPattern
    , StrokeWidth

      -- * Internal type

    , EdgeSample( .. )
    , pathToPrimitives

      -- * Little geometry helpers

    , firstTangeantOf
    , lastTangeantOf
    , firstPointOf
    , lastPointOf
    , resplit

      -- * RankNType helper

    , Proxy( Proxy )
    ) where

import Data.DList( DList, fromList )

import Control.Monad.Identity( runIdentity )
import Data.Foldable( foldl', toList )
import qualified Data.Foldable as F
import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero )
import Graphics.Rasterific.Operators
import Foreign.Ptr( castPtr )
import Foreign.Storable( Storable( sizeOf
                       , alignment
                       , peek
                       , poke
                       , peekElemOff
                       , pokeElemOff ) )

-- | Represent a vector

type Vector = V2 Float

-- | Type alias just to get more meaningful

-- type signatures

type StrokeWidth = Float

-- | Dash pattern to use

type DashPattern = [Float]

data Proxy p = Proxy

-- | Describe how we will "finish" the stroking

-- that don't loop.

data Cap
    -- | Create a straight caping on the stroke.

    -- Cap value should be positive and represent

    -- the distance from the end of curve to the actual cap

    --

    --  * cap straight with param 0 : <<docimages/cap_straight.png>>

    --

    --  * cap straight with param 1 : <<docimages/cap_straight_1.png>>

    --

  = CapStraight Float

    -- | Create a rounded caping on the stroke.

    -- <<docimages/cap_round.png>>

  | CapRound
  deriving (Cap -> Cap -> Bool
(Cap -> Cap -> Bool) -> (Cap -> Cap -> Bool) -> Eq Cap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cap -> Cap -> Bool
$c/= :: Cap -> Cap -> Bool
== :: Cap -> Cap -> Bool
$c== :: Cap -> Cap -> Bool
Eq, Int -> Cap -> ShowS
[Cap] -> ShowS
Cap -> String
(Int -> Cap -> ShowS)
-> (Cap -> String) -> ([Cap] -> ShowS) -> Show Cap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cap] -> ShowS
$cshowList :: [Cap] -> ShowS
show :: Cap -> String
$cshow :: Cap -> String
showsPrec :: Int -> Cap -> ShowS
$cshowsPrec :: Int -> Cap -> ShowS
Show)

-- | Describe how to display the join of broken lines

-- while stroking.

data Join
    -- | Make a curved join.

    -- <<docimages/join_round.png>>

  = JoinRound
    -- | Make a mitter join. Value must be positive or null.

    -- Seems to make sense in [0;1] only

    --

    --  * Miter join with 0 : <<docimages/join_miter.png>>

    --

    --  * Miter join with 5 : <<docimages/join_miter_5.png>>

    --

  | JoinMiter Float
  deriving (Join -> Join -> Bool
(Join -> Join -> Bool) -> (Join -> Join -> Bool) -> Eq Join
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Join -> Join -> Bool
$c/= :: Join -> Join -> Bool
== :: Join -> Join -> Bool
$c== :: Join -> Join -> Bool
Eq, Int -> Join -> ShowS
[Join] -> ShowS
Join -> String
(Int -> Join -> ShowS)
-> (Join -> String) -> ([Join] -> ShowS) -> Show Join
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Join] -> ShowS
$cshowList :: [Join] -> ShowS
show :: Join -> String
$cshow :: Join -> String
showsPrec :: Int -> Join -> ShowS
$cshowsPrec :: Int -> Join -> ShowS
Show)

-- | Tell how to fill complex shapes when there is self 

-- intersections. If the filling mode is not specified,

-- then it's the `FillWinding` method which is used.

--

-- The examples used are produced with the following

-- function:

--

--

-- > fillingSample :: FillMethod -> Drawing px ()

-- > fillingSample fillMethod = fillWithMethod fillMethod geometry where

-- >   geometry = transform (applyTransformation $ scale 0.35 0.4

-- >                                            <> translate (V2 (-80) (-180)))

-- >      [ Path (V2 484 499) True

-- >          [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314)

-- >          , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499)

-- >          ]

-- >      , Path (V2 136 377) True

-- >          [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489)

-- >          , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377)

-- >          ]

-- >      , Path (V2 340 265) True

-- >          [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536)

-- >          , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575)

-- >          , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265)

-- >          ]

-- >      ]

data FillMethod
  -- | Also known as nonzero rule.

  -- To determine if a point falls inside the curve, you draw 

  -- an imaginary line through that point. Next you will count

  -- how many times that line crosses the curve before it reaches

  -- that point. For every clockwise rotation, you subtract 1 and

  -- for every counter-clockwise rotation you add 1.

  --

  -- <<docimages/fill_winding.png>>

  = FillWinding

  -- | This rule determines the insideness of a point on 

  -- the canvas by drawing a ray from that point to infinity

  -- in any direction and counting the number of path segments

  -- from the given shape that the ray crosses. If this number

  -- is odd, the point is inside; if even, the point is outside.

  --

  -- <<docimages/fill_evenodd.png>>

  | FillEvenOdd
  deriving (FillMethod -> FillMethod -> Bool
(FillMethod -> FillMethod -> Bool)
-> (FillMethod -> FillMethod -> Bool) -> Eq FillMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FillMethod -> FillMethod -> Bool
$c/= :: FillMethod -> FillMethod -> Bool
== :: FillMethod -> FillMethod -> Bool
$c== :: FillMethod -> FillMethod -> Bool
Eq, Int -> FillMethod
FillMethod -> Int
FillMethod -> [FillMethod]
FillMethod -> FillMethod
FillMethod -> FillMethod -> [FillMethod]
FillMethod -> FillMethod -> FillMethod -> [FillMethod]
(FillMethod -> FillMethod)
-> (FillMethod -> FillMethod)
-> (Int -> FillMethod)
-> (FillMethod -> Int)
-> (FillMethod -> [FillMethod])
-> (FillMethod -> FillMethod -> [FillMethod])
-> (FillMethod -> FillMethod -> [FillMethod])
-> (FillMethod -> FillMethod -> FillMethod -> [FillMethod])
-> Enum FillMethod
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: FillMethod -> FillMethod -> FillMethod -> [FillMethod]
$cenumFromThenTo :: FillMethod -> FillMethod -> FillMethod -> [FillMethod]
enumFromTo :: FillMethod -> FillMethod -> [FillMethod]
$cenumFromTo :: FillMethod -> FillMethod -> [FillMethod]
enumFromThen :: FillMethod -> FillMethod -> [FillMethod]
$cenumFromThen :: FillMethod -> FillMethod -> [FillMethod]
enumFrom :: FillMethod -> [FillMethod]
$cenumFrom :: FillMethod -> [FillMethod]
fromEnum :: FillMethod -> Int
$cfromEnum :: FillMethod -> Int
toEnum :: Int -> FillMethod
$ctoEnum :: Int -> FillMethod
pred :: FillMethod -> FillMethod
$cpred :: FillMethod -> FillMethod
succ :: FillMethod -> FillMethod
$csucc :: FillMethod -> FillMethod
Enum, Int -> FillMethod -> ShowS
[FillMethod] -> ShowS
FillMethod -> String
(Int -> FillMethod -> ShowS)
-> (FillMethod -> String)
-> ([FillMethod] -> ShowS)
-> Show FillMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FillMethod] -> ShowS
$cshowList :: [FillMethod] -> ShowS
show :: FillMethod -> String
$cshow :: FillMethod -> String
showsPrec :: Int -> FillMethod -> ShowS
$cshowsPrec :: Int -> FillMethod -> ShowS
Show)

-- | Describe the behaviour of samplers and texturers

-- when they are out of the bounds of image and/or gradient.

data SamplerRepeat
    -- | Will clamp (ie. repeat the last pixel) when

    -- out of bound

    -- <<docimages/sampler_pad.png>>

  = SamplerPad
    -- | Will loop on it's definition domain

    -- <<docimages/sampler_repeat.png>>

  | SamplerRepeat
    -- | Will loop inverting axises

    -- <<docimages/sampler_reflect.png>>

  | SamplerReflect
  deriving (SamplerRepeat -> SamplerRepeat -> Bool
(SamplerRepeat -> SamplerRepeat -> Bool)
-> (SamplerRepeat -> SamplerRepeat -> Bool) -> Eq SamplerRepeat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SamplerRepeat -> SamplerRepeat -> Bool
$c/= :: SamplerRepeat -> SamplerRepeat -> Bool
== :: SamplerRepeat -> SamplerRepeat -> Bool
$c== :: SamplerRepeat -> SamplerRepeat -> Bool
Eq, Int -> SamplerRepeat
SamplerRepeat -> Int
SamplerRepeat -> [SamplerRepeat]
SamplerRepeat -> SamplerRepeat
SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
SamplerRepeat -> SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
(SamplerRepeat -> SamplerRepeat)
-> (SamplerRepeat -> SamplerRepeat)
-> (Int -> SamplerRepeat)
-> (SamplerRepeat -> Int)
-> (SamplerRepeat -> [SamplerRepeat])
-> (SamplerRepeat -> SamplerRepeat -> [SamplerRepeat])
-> (SamplerRepeat -> SamplerRepeat -> [SamplerRepeat])
-> (SamplerRepeat
    -> SamplerRepeat -> SamplerRepeat -> [SamplerRepeat])
-> Enum SamplerRepeat
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SamplerRepeat -> SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
$cenumFromThenTo :: SamplerRepeat -> SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
enumFromTo :: SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
$cenumFromTo :: SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
enumFromThen :: SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
$cenumFromThen :: SamplerRepeat -> SamplerRepeat -> [SamplerRepeat]
enumFrom :: SamplerRepeat -> [SamplerRepeat]
$cenumFrom :: SamplerRepeat -> [SamplerRepeat]
fromEnum :: SamplerRepeat -> Int
$cfromEnum :: SamplerRepeat -> Int
toEnum :: Int -> SamplerRepeat
$ctoEnum :: Int -> SamplerRepeat
pred :: SamplerRepeat -> SamplerRepeat
$cpred :: SamplerRepeat -> SamplerRepeat
succ :: SamplerRepeat -> SamplerRepeat
$csucc :: SamplerRepeat -> SamplerRepeat
Enum, Int -> SamplerRepeat -> ShowS
[SamplerRepeat] -> ShowS
SamplerRepeat -> String
(Int -> SamplerRepeat -> ShowS)
-> (SamplerRepeat -> String)
-> ([SamplerRepeat] -> ShowS)
-> Show SamplerRepeat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SamplerRepeat] -> ShowS
$cshowList :: [SamplerRepeat] -> ShowS
show :: SamplerRepeat -> String
$cshow :: SamplerRepeat -> String
showsPrec :: Int -> SamplerRepeat -> ShowS
$cshowsPrec :: Int -> SamplerRepeat -> ShowS
Show)

-- | Represent a raster line

data EdgeSample = EdgeSample
  { EdgeSample -> Float
_sampleX     :: {-# UNPACK #-} !Float -- ^ Horizontal position

  , EdgeSample -> Float
_sampleY     :: {-# UNPACK #-} !Float -- ^ Vertical position

  , EdgeSample -> Float
_sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha

  , EdgeSample -> Float
_sampleH     :: {-# UNPACK #-} !Float -- ^ Height

  }
  deriving Int -> EdgeSample -> ShowS
[EdgeSample] -> ShowS
EdgeSample -> String
(Int -> EdgeSample -> ShowS)
-> (EdgeSample -> String)
-> ([EdgeSample] -> ShowS)
-> Show EdgeSample
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EdgeSample] -> ShowS
$cshowList :: [EdgeSample] -> ShowS
show :: EdgeSample -> String
$cshow :: EdgeSample -> String
showsPrec :: Int -> EdgeSample -> ShowS
$cshowsPrec :: Int -> EdgeSample -> ShowS
Show

-- | Just to get faster sorting

instance Storable EdgeSample where
   sizeOf :: EdgeSample -> Int
sizeOf EdgeSample
_ = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Float -> Int
forall a. Storable a => a -> Int
sizeOf (Float
0 :: Float)
   alignment :: EdgeSample -> Int
alignment = EdgeSample -> Int
forall a. Storable a => a -> Int
sizeOf

   {-# INLINE peek #-}
   peek :: Ptr EdgeSample -> IO EdgeSample
peek Ptr EdgeSample
ptr = do
     let q :: Ptr Float
q = Ptr EdgeSample -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr EdgeSample
ptr
     Float
sx <- Ptr Float -> Int -> IO Float
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Float
q Int
0
     Float
sy <- Ptr Float -> Int -> IO Float
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Float
q Int
1
     Float
sa <- Ptr Float -> Int -> IO Float
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Float
q Int
2
     Float
sh <- Ptr Float -> Int -> IO Float
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Float
q Int
3
     EdgeSample -> IO EdgeSample
forall (m :: * -> *) a. Monad m => a -> m a
return (EdgeSample -> IO EdgeSample) -> EdgeSample -> IO EdgeSample
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Float -> EdgeSample
EdgeSample Float
sx Float
sy Float
sa Float
sh
      
   {-# INLINE poke #-}
   poke :: Ptr EdgeSample -> EdgeSample -> IO ()
poke Ptr EdgeSample
ptr (EdgeSample Float
sx Float
sy Float
sa Float
sh) = do
     let q :: Ptr Float
q = Ptr EdgeSample -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr EdgeSample
ptr
     Ptr Float -> Int -> Float -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Float
q Int
0 Float
sx
     Ptr Float -> Int -> Float -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Float
q Int
1 Float
sy
     Ptr Float -> Int -> Float -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Float
q Int
2 Float
sa
     Ptr Float -> Int -> Float -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Float
q Int
3 Float
sh

-- | This typeclass is there to help transform the geometry,

-- by applying a transformation on every point of a geometric

-- element.

class Transformable a where
    -- | Apply a transformation function for every

    --  point in the element.

    transform :: (Point -> Point) -> a -> a
    transform Point -> Point
f = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (a -> Identity a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point -> Identity Point) -> a -> Identity a
forall a (m :: * -> *).
(Transformable a, Monad m) =>
(Point -> m Point) -> a -> m a
transformM (Point -> Identity Point
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> Identity Point)
-> (Point -> Point) -> Point -> Identity Point
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point -> Point
f)

    -- | Transform but monadic

    transformM :: Monad m => (Point -> m Point) -> a -> m a

-- | Typeclass helper gathering all the points of a given

-- geometry.

class PointFoldable a where
    -- | Fold an accumulator on all the points of

    -- the primitive.

    foldPoints :: (b -> Point -> b) -> b -> a -> b

-- | Just apply the function

instance Transformable Point where
    {-# INLINE transform #-}
    transform :: (Point -> Point) -> Point -> Point
transform Point -> Point
f = Point -> Point
f
    {-# INLINE transformM #-}
    transformM :: (Point -> m Point) -> Point -> m Point
transformM Point -> m Point
f = Point -> m Point
f

-- | Just apply the function

instance PointFoldable Point where
    {-# INLINE foldPoints #-}
    foldPoints :: (b -> Point -> b) -> b -> Point -> b
foldPoints b -> Point -> b
f = b -> Point -> b
f

-- | Describe a simple 2D line between two points.

--

-- > fill [ Line (V2 10 10) (V2 190 10)

-- >      , Line (V2 190 10) (V2 95 170)

-- >      , Line (V2 95 170) (V2 10 10)]

--

-- <<docimages/simple_line.png>>

--

data Line = Line
  { Line -> Point
_lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point

  , Line -> Point
_lineX1 :: {-# UNPACK #-} !Point -- ^ End point

  }
  deriving Line -> Line -> Bool
(Line -> Line -> Bool) -> (Line -> Line -> Bool) -> Eq Line
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c== :: Line -> Line -> Bool
Eq

instance Show Line where
  show :: Line -> String
show (Line Point
a Point
b) =
      String
"Line (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") ("
               String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

instance Transformable Line where
    {-# INLINE transformM #-}
    transformM :: (Point -> m Point) -> Line -> m Line
transformM Point -> m Point
f (Line Point
a Point
b) = Point -> Point -> Line
Line (Point -> Point -> Line) -> m Point -> m (Point -> Line)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> m Point
f Point
a m (Point -> Line) -> m Point -> m Line
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
b

instance PointFoldable Line where
    {-# INLINE foldPoints #-}
    foldPoints :: (b -> Point -> b) -> b -> Line -> b
foldPoints b -> Point -> b
f b
acc (Line Point
a Point
b) = b -> Point -> b
f (b -> Point -> b
f b
acc Point
b) Point
a

-- | Describe a quadratic bezier spline, described

-- using 3 points.

--

-- > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100)

-- >      ,Bezier (V2 200 100) (V2 150 200) (V2 120 175)

-- >      ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)]

--

-- <<docimages/quadratic_bezier.png>>

--

data Bezier = Bezier
  { -- | Origin points, the spline will pass through it.

    Bezier -> Point
_bezierX0 :: {-# UNPACK #-} !Point
    -- | Control point, the spline won't pass on it.

  , Bezier -> Point
_bezierX1 :: {-# UNPACK #-} !Point
    -- | End point, the spline will pass through it.

  , Bezier -> Point
_bezierX2 :: {-# UNPACK #-} !Point
  }
  deriving Bezier -> Bezier -> Bool
(Bezier -> Bezier -> Bool)
-> (Bezier -> Bezier -> Bool) -> Eq Bezier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bezier -> Bezier -> Bool
$c/= :: Bezier -> Bezier -> Bool
== :: Bezier -> Bezier -> Bool
$c== :: Bezier -> Bezier -> Bool
Eq

instance Show Bezier where
    show :: Bezier -> String
show (Bezier Point
a Point
b Point
c) =
        String
"Bezier (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") ("
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") ("
                   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

instance Transformable Bezier where
    {-# INLINE transform #-}
    transform :: (Point -> Point) -> Bezier -> Bezier
transform Point -> Point
f (Bezier Point
a Point
b Point
c) = Point -> Point -> Point -> Bezier
Bezier (Point -> Point
f Point
a) (Point -> Point
f Point
b) (Point -> Bezier) -> Point -> Bezier
forall a b. (a -> b) -> a -> b
$ Point -> Point
f Point
c
    {-# INLINE transformM #-}
    transformM :: (Point -> m Point) -> Bezier -> m Bezier
transformM Point -> m Point
f (Bezier Point
a Point
b Point
c) = Point -> Point -> Point -> Bezier
Bezier (Point -> Point -> Point -> Bezier)
-> m Point -> m (Point -> Point -> Bezier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> m Point
f Point
a m (Point -> Point -> Bezier) -> m Point -> m (Point -> Bezier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
b m (Point -> Bezier) -> m Point -> m Bezier
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
c

instance PointFoldable Bezier where
    {-# INLINE foldPoints #-}
    foldPoints :: (b -> Point -> b) -> b -> Bezier -> b
foldPoints b -> Point -> b
f b
acc (Bezier Point
a Point
b Point
c) =
        (b -> Point -> b) -> b -> [Point] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> Point -> b
f b
acc [Point
a, Point
b, Point
c]

-- | Describe a cubic bezier spline, described

-- using 4 points.

--

-- > stroke 4 JoinRound (CapRound, CapRound) $

-- >    CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35)

--

-- <<docimages/cubic_bezier.png>>

--

data CubicBezier = CubicBezier
  { -- | Origin point, the spline will pass through it.

    CubicBezier -> Point
_cBezierX0 :: {-# UNPACK #-} !Point
    -- | First control point of the cubic bezier curve.

  , CubicBezier -> Point
_cBezierX1 :: {-# UNPACK #-} !Point
    -- | Second control point of the cubic bezier curve.

  , CubicBezier -> Point
_cBezierX2 :: {-# UNPACK #-} !Point
    -- | End point of the cubic bezier curve

  , CubicBezier -> Point
_cBezierX3 :: {-# UNPACK #-} !Point
  }
  deriving CubicBezier -> CubicBezier -> Bool
(CubicBezier -> CubicBezier -> Bool)
-> (CubicBezier -> CubicBezier -> Bool) -> Eq CubicBezier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CubicBezier -> CubicBezier -> Bool
$c/= :: CubicBezier -> CubicBezier -> Bool
== :: CubicBezier -> CubicBezier -> Bool
$c== :: CubicBezier -> CubicBezier -> Bool
Eq

instance Show CubicBezier where
  show :: CubicBezier -> String
show (CubicBezier Point
a Point
b Point
c Point
d) =
     String
"CubicBezier (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") ("
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
b String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") ("
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") ("
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"

instance Transformable CubicBezier where
    {-# INLINE transform #-}
    transform :: (Point -> Point) -> CubicBezier -> CubicBezier
transform Point -> Point
f (CubicBezier Point
a Point
b Point
c Point
d) =
       Point -> Point -> Point -> Point -> CubicBezier
CubicBezier (Point -> Point
f Point
a) (Point -> Point
f Point
b) (Point -> Point
f Point
c) (Point -> CubicBezier) -> Point -> CubicBezier
forall a b. (a -> b) -> a -> b
$ Point -> Point
f Point
d
    transformM :: (Point -> m Point) -> CubicBezier -> m CubicBezier
transformM Point -> m Point
f (CubicBezier Point
a Point
b Point
c Point
d) =
       Point -> Point -> Point -> Point -> CubicBezier
CubicBezier (Point -> Point -> Point -> Point -> CubicBezier)
-> m Point -> m (Point -> Point -> Point -> CubicBezier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> m Point
f Point
a m (Point -> Point -> Point -> CubicBezier)
-> m Point -> m (Point -> Point -> CubicBezier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
b m (Point -> Point -> CubicBezier)
-> m Point -> m (Point -> CubicBezier)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
c m (Point -> CubicBezier) -> m Point -> m CubicBezier
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
d

instance PointFoldable CubicBezier where
    {-# INLINE foldPoints #-}
    foldPoints :: (b -> Point -> b) -> b -> CubicBezier -> b
foldPoints b -> Point -> b
f b
acc (CubicBezier Point
a Point
b Point
c Point
d) =
        (b -> Point -> b) -> b -> [Point] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> Point -> b
f b
acc [Point
a, Point
b, Point
c, Point
d]

-- | This datatype gather all the renderable primitives,

-- they are kept separated otherwise to allow specialization

-- on some specific algorithms. You can mix the different

-- primitives in a single call :

--

-- > fill [ toPrim $ CubicBezier (V2 50 20) (V2 90 60)

-- >                             (V2  5 100) (V2 50 140)

-- >      , toPrim $ Line (V2 50 140) (V2 120 80)

-- >      , toPrim $ Line (V2 120 80) (V2 50 20) ]

--

-- <<docimages/primitive_mixed.png>>

--

data Primitive
  = LinePrim !Line      -- ^ Primitive used for lines

  | BezierPrim !Bezier  -- ^ Primitive used for quadratic beziers curves

  | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve

  deriving (Primitive -> Primitive -> Bool
(Primitive -> Primitive -> Bool)
-> (Primitive -> Primitive -> Bool) -> Eq Primitive
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Primitive -> Primitive -> Bool
$c/= :: Primitive -> Primitive -> Bool
== :: Primitive -> Primitive -> Bool
$c== :: Primitive -> Primitive -> Bool
Eq, Int -> Primitive -> ShowS
[Primitive] -> ShowS
Primitive -> String
(Int -> Primitive -> ShowS)
-> (Primitive -> String)
-> ([Primitive] -> ShowS)
-> Show Primitive
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Primitive] -> ShowS
$cshowList :: [Primitive] -> ShowS
show :: Primitive -> String
$cshow :: Primitive -> String
showsPrec :: Int -> Primitive -> ShowS
$cshowsPrec :: Int -> Primitive -> ShowS
Show)

-- | Generalizing constructors of the `Primitive` type to work

-- generically.

class Primitivable a where
  toPrim :: a -> Primitive

-- | @toPrim = id@

instance Primitivable Primitive where toPrim :: Primitive -> Primitive
toPrim = Primitive -> Primitive
forall a. a -> a
id

-- | @toPrim = LinePrim@

instance Primitivable Line where toPrim :: Line -> Primitive
toPrim = Line -> Primitive
LinePrim

-- | @toPrim = BezierPrim@

instance Primitivable Bezier where toPrim :: Bezier -> Primitive
toPrim = Bezier -> Primitive
BezierPrim

-- | @toPrim = CubicBezierPrim@

instance Primitivable CubicBezier where toPrim :: CubicBezier -> Primitive
toPrim = CubicBezier -> Primitive
CubicBezierPrim

-- | All the rasterization works on lists of primitives,

-- in order to ease the use of the library, the Geometry

-- type class provides conversion facility, which help

-- generalising the geometry definition and avoid applying

-- Primitive constructor.

--

-- Also streamline the Path conversion.

class Geometry a where
  -- | Convert an element to a list of primitives

  -- to be rendered.

  toPrimitives :: a -> [Primitive]

  -- | Helper method to avoid overlaping instances.

  -- You shouldn't use it directly.

  listToPrims :: (Foldable f) => f a -> [Primitive]
  {-# INLINE listToPrims #-}
  listToPrims = (a -> [Primitive]) -> [a] -> [Primitive]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
F.concatMap a -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives ([a] -> [Primitive]) -> (f a -> [a]) -> f a -> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList

instance Geometry Path where
  {-# INLINE toPrimitives #-}
  toPrimitives :: Path -> [Primitive]
toPrimitives = Path -> [Primitive]
pathToPrimitives

instance Geometry Primitive where
  toPrimitives :: Primitive -> [Primitive]
toPrimitives Primitive
e = [Primitive
e]
  {-# INLINE listToPrims #-}
  listToPrims :: f Primitive -> [Primitive]
listToPrims = f Primitive -> [Primitive]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList -- Open question, is it optimised as `id`?


instance Geometry Line where
  {-# INLINE toPrimitives #-}
  toPrimitives :: Line -> [Primitive]
toPrimitives Line
e = [Line -> Primitive
forall a. Primitivable a => a -> Primitive
toPrim Line
e]

instance Geometry Bezier where
  {-# INLINE toPrimitives #-}
  toPrimitives :: Bezier -> [Primitive]
toPrimitives Bezier
e = [Bezier -> Primitive
forall a. Primitivable a => a -> Primitive
toPrim Bezier
e]

instance Geometry CubicBezier where
  {-# INLINE toPrimitives #-}
  toPrimitives :: CubicBezier -> [Primitive]
toPrimitives CubicBezier
e = [CubicBezier -> Primitive
forall a. Primitivable a => a -> Primitive
toPrim CubicBezier
e]

-- | Generalize the geometry to any foldable container,

-- so you can throw any container to the the 'fill' or

-- 'stroke' function.

instance (Foldable f, Geometry a) => Geometry (f a) where
  {-# INLINE toPrimitives #-}
  toPrimitives :: f a -> [Primitive]
toPrimitives = f a -> [Primitive]
forall a (f :: * -> *).
(Geometry a, Foldable f) =>
f a -> [Primitive]
listToPrims


instance Transformable Primitive where
    {-# INLINE transform #-}
    transform :: (Point -> Point) -> Primitive -> Primitive
transform Point -> Point
f (LinePrim Line
l) = Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> Line -> Line
forall a. Transformable a => (Point -> Point) -> a -> a
transform Point -> Point
f Line
l
    transform Point -> Point
f (BezierPrim Bezier
b) = Bezier -> Primitive
BezierPrim (Bezier -> Primitive) -> Bezier -> Primitive
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> Bezier -> Bezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform Point -> Point
f Bezier
b
    transform Point -> Point
f (CubicBezierPrim CubicBezier
c) = CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive) -> CubicBezier -> Primitive
forall a b. (a -> b) -> a -> b
$ (Point -> Point) -> CubicBezier -> CubicBezier
forall a. Transformable a => (Point -> Point) -> a -> a
transform Point -> Point
f CubicBezier
c

    transformM :: (Point -> m Point) -> Primitive -> m Primitive
transformM Point -> m Point
f (LinePrim Line
l) = Line -> Primitive
LinePrim (Line -> Primitive) -> m Line -> m Primitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Point -> m Point) -> Line -> m Line
forall a (m :: * -> *).
(Transformable a, Monad m) =>
(Point -> m Point) -> a -> m a
transformM Point -> m Point
f Line
l
    transformM Point -> m Point
f (BezierPrim Bezier
b) = Bezier -> Primitive
BezierPrim (Bezier -> Primitive) -> m Bezier -> m Primitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Point -> m Point) -> Bezier -> m Bezier
forall a (m :: * -> *).
(Transformable a, Monad m) =>
(Point -> m Point) -> a -> m a
transformM Point -> m Point
f Bezier
b
    transformM Point -> m Point
f (CubicBezierPrim CubicBezier
c) = CubicBezier -> Primitive
CubicBezierPrim (CubicBezier -> Primitive) -> m CubicBezier -> m Primitive
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Point -> m Point) -> CubicBezier -> m CubicBezier
forall a (m :: * -> *).
(Transformable a, Monad m) =>
(Point -> m Point) -> a -> m a
transformM Point -> m Point
f CubicBezier
c

instance PointFoldable Primitive where
    {-# INLINE foldPoints #-}
    foldPoints :: (b -> Point -> b) -> b -> Primitive -> b
foldPoints b -> Point -> b
f b
acc = Primitive -> b
go
      where go :: Primitive -> b
go (LinePrim Line
l) = (b -> Point -> b) -> b -> Line -> b
forall a b. PointFoldable a => (b -> Point -> b) -> b -> a -> b
foldPoints b -> Point -> b
f b
acc Line
l
            go (BezierPrim Bezier
b) = (b -> Point -> b) -> b -> Bezier -> b
forall a b. PointFoldable a => (b -> Point -> b) -> b -> a -> b
foldPoints b -> Point -> b
f b
acc Bezier
b
            go (CubicBezierPrim CubicBezier
c) = (b -> Point -> b) -> b -> CubicBezier -> b
forall a b. PointFoldable a => (b -> Point -> b) -> b -> a -> b
foldPoints b -> Point -> b
f b
acc CubicBezier
c

instance {-# OVERLAPPABLE #-} (Traversable f, Transformable a)
      => Transformable (f a) where
    transform :: (Point -> Point) -> f a -> f a
transform Point -> Point
f = (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point -> Point) -> a -> a
forall a. Transformable a => (Point -> Point) -> a -> a
transform Point -> Point
f)
    transformM :: (Point -> m Point) -> f a -> m (f a)
transformM Point -> m Point
f = (a -> m a) -> f a -> m (f a)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Point -> m Point) -> a -> m a
forall a (m :: * -> *).
(Transformable a, Monad m) =>
(Point -> m Point) -> a -> m a
transformM Point -> m Point
f)

instance {-# OVERLAPPABLE #-} (Foldable f, PointFoldable a)
      => PointFoldable (f a) where
    foldPoints :: (b -> Point -> b) -> b -> f a -> b
foldPoints b -> Point -> b
f = (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((b -> Point -> b) -> b -> a -> b
forall a b. PointFoldable a => (b -> Point -> b) -> b -> a -> b
foldPoints b -> Point -> b
f)

type Producer a = [a] -> [a]

type Container a = DList a

containerOfFunction :: ([a] -> [a]) -> Container a
containerOfFunction :: ([a] -> [a]) -> Container a
containerOfFunction [a] -> [a]
f = [a] -> Container a
forall a. [a] -> DList a
fromList ([a] -> Container a) -> [a] -> Container a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
f []

containerOfList :: [a] -> Container a
containerOfList :: [a] -> Container a
containerOfList = [a] -> Container a
forall a. [a] -> DList a
fromList

listOfContainer :: Container a -> [a]
listOfContainer :: Container a -> [a]
listOfContainer = Container a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Describe a path in a way similar to many graphical

-- packages, using a "pen" position in memory and reusing

-- it for the next "move"

-- For example the example from Primitive could be rewritten:

--

-- > fill $ Path (V2 50 20) True

-- >    [ PathCubicBezierCurveTo (V2 90 60) (V2  5 100) (V2 50 140)

-- >    , PathLineTo (V2 120 80) ]

--

-- <<docimages/path_example.png>>

--

data Path = Path
    { -- | Origin of the point, equivalent to the

      -- first "move" command.

      Path -> Point
_pathOriginPoint :: Point
      -- | Tell if we must close the path.

    , Path -> Bool
_pathClose       :: Bool
      -- | List of commands in the path

    , Path -> [PathCommand]
_pathCommand     :: [PathCommand]
    }
    deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> String
$cshow :: Path -> String
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show)

instance Transformable Path where
    {-# INLINE transform #-}
    transform :: (Point -> Point) -> Path -> Path
transform Point -> Point
f (Path Point
orig Bool
close [PathCommand]
rest) =
        Point -> Bool -> [PathCommand] -> Path
Path (Point -> Point
f Point
orig) Bool
close ((Point -> Point) -> [PathCommand] -> [PathCommand]
forall a. Transformable a => (Point -> Point) -> a -> a
transform Point -> Point
f [PathCommand]
rest)

    transformM :: (Point -> m Point) -> Path -> m Path
transformM Point -> m Point
f (Path Point
orig Bool
close [PathCommand]
rest) =
        Point -> Bool -> [PathCommand] -> Path
Path (Point -> Bool -> [PathCommand] -> Path)
-> m Point -> m (Bool -> [PathCommand] -> Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> m Point
f Point
orig m (Bool -> [PathCommand] -> Path)
-> m Bool -> m ([PathCommand] -> Path)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
close m ([PathCommand] -> Path) -> m [PathCommand] -> m Path
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Point -> m Point) -> [PathCommand] -> m [PathCommand]
forall a (m :: * -> *).
(Transformable a, Monad m) =>
(Point -> m Point) -> a -> m a
transformM Point -> m Point
f [PathCommand]
rest


instance PointFoldable Path where
    {-# INLINE foldPoints #-}
    foldPoints :: (b -> Point -> b) -> b -> Path -> b
foldPoints b -> Point -> b
f b
acc (Path Point
o Bool
_ [PathCommand]
rest) =
        (b -> Point -> b) -> b -> [PathCommand] -> b
forall a b. PointFoldable a => (b -> Point -> b) -> b -> a -> b
foldPoints b -> Point -> b
f (b -> Point -> b
f b
acc Point
o) [PathCommand]
rest

-- | Actions to create a path

data PathCommand
    = -- | Draw a line from the current point to another point

      PathLineTo Point
      -- | Draw a quadratic bezier curve from the current point

      -- through the control point to the end point.

    | PathQuadraticBezierCurveTo Point Point

      -- | Draw a cubic bezier curve using 2 control points.

    | PathCubicBezierCurveTo Point Point Point
    deriving (PathCommand -> PathCommand -> Bool
(PathCommand -> PathCommand -> Bool)
-> (PathCommand -> PathCommand -> Bool) -> Eq PathCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathCommand -> PathCommand -> Bool
$c/= :: PathCommand -> PathCommand -> Bool
== :: PathCommand -> PathCommand -> Bool
$c== :: PathCommand -> PathCommand -> Bool
Eq, Int -> PathCommand -> ShowS
[PathCommand] -> ShowS
PathCommand -> String
(Int -> PathCommand -> ShowS)
-> (PathCommand -> String)
-> ([PathCommand] -> ShowS)
-> Show PathCommand
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathCommand] -> ShowS
$cshowList :: [PathCommand] -> ShowS
show :: PathCommand -> String
$cshow :: PathCommand -> String
showsPrec :: Int -> PathCommand -> ShowS
$cshowsPrec :: Int -> PathCommand -> ShowS
Show)

instance Transformable PathCommand where
    transform :: (Point -> Point) -> PathCommand -> PathCommand
transform Point -> Point
f (PathLineTo Point
p) = Point -> PathCommand
PathLineTo (Point -> PathCommand) -> Point -> PathCommand
forall a b. (a -> b) -> a -> b
$ Point -> Point
f Point
p
    transform Point -> Point
f (PathQuadraticBezierCurveTo Point
p1 Point
p2) =
        Point -> Point -> PathCommand
PathQuadraticBezierCurveTo (Point -> Point
f Point
p1) (Point -> PathCommand) -> Point -> PathCommand
forall a b. (a -> b) -> a -> b
$ Point -> Point
f Point
p2
    transform Point -> Point
f (PathCubicBezierCurveTo Point
p1 Point
p2 Point
p3) =
        Point -> Point -> Point -> PathCommand
PathCubicBezierCurveTo (Point -> Point
f Point
p1) (Point -> Point
f Point
p2) (Point -> PathCommand) -> Point -> PathCommand
forall a b. (a -> b) -> a -> b
$ Point -> Point
f Point
p3

    transformM :: (Point -> m Point) -> PathCommand -> m PathCommand
transformM Point -> m Point
f (PathLineTo Point
p) = Point -> PathCommand
PathLineTo (Point -> PathCommand) -> m Point -> m PathCommand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> m Point
f Point
p
    transformM Point -> m Point
f (PathQuadraticBezierCurveTo Point
p1 Point
p2) =
        Point -> Point -> PathCommand
PathQuadraticBezierCurveTo (Point -> Point -> PathCommand)
-> m Point -> m (Point -> PathCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> m Point
f Point
p1 m (Point -> PathCommand) -> m Point -> m PathCommand
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
p2
    transformM Point -> m Point
f (PathCubicBezierCurveTo Point
p1 Point
p2 Point
p3) =
        Point -> Point -> Point -> PathCommand
PathCubicBezierCurveTo (Point -> Point -> Point -> PathCommand)
-> m Point -> m (Point -> Point -> PathCommand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point -> m Point
f Point
p1 m (Point -> Point -> PathCommand)
-> m Point -> m (Point -> PathCommand)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
p2 m (Point -> PathCommand) -> m Point -> m PathCommand
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point -> m Point
f Point
p3

instance PointFoldable PathCommand where
    foldPoints :: (b -> Point -> b) -> b -> PathCommand -> b
foldPoints b -> Point -> b
f b
acc (PathLineTo Point
p) = b -> Point -> b
f b
acc Point
p
    foldPoints b -> Point -> b
f b
acc (PathQuadraticBezierCurveTo Point
p1 Point
p2) =
        b -> Point -> b
f (b -> Point -> b
f b
acc Point
p1) Point
p2
    foldPoints b -> Point -> b
f b
acc (PathCubicBezierCurveTo Point
p1 Point
p2 Point
p3) =
        (b -> Point -> b) -> b -> [Point] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> Point -> b
f b
acc [Point
p1, Point
p2, Point
p3]

-- | Transform a path description into a list of renderable

-- primitives.

pathToPrimitives :: Path -> [Primitive]
pathToPrimitives :: Path -> [Primitive]
pathToPrimitives (Path Point
origin Bool
needClosing [PathCommand]
commands) = Point -> [PathCommand] -> [Primitive]
go Point
origin [PathCommand]
commands
  where
    go :: Point -> [PathCommand] -> [Primitive]
go Point
prev [] | Point
prev Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
/= Point
origin Bool -> Bool -> Bool
&& Bool
needClosing = [Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line Point
prev Point
origin]
    go Point
_ [] = []
    go Point
prev (PathLineTo Point
to : [PathCommand]
xs) =
        Line -> Primitive
LinePrim (Point -> Point -> Line
Line Point
prev Point
to) Primitive -> [Primitive] -> [Primitive]
forall a. a -> [a] -> [a]
: Point -> [PathCommand] -> [Primitive]
go Point
to [PathCommand]
xs
    go Point
prev (PathQuadraticBezierCurveTo Point
c1 Point
to : [PathCommand]
xs) =
        Bezier -> Primitive
BezierPrim (Point -> Point -> Point -> Bezier
Bezier Point
prev Point
c1 Point
to) Primitive -> [Primitive] -> [Primitive]
forall a. a -> [a] -> [a]
: Point -> [PathCommand] -> [Primitive]
go Point
to [PathCommand]
xs
    go Point
prev (PathCubicBezierCurveTo Point
c1 Point
c2 Point
to : [PathCommand]
xs) =
        CubicBezier -> Primitive
CubicBezierPrim (Point -> Point -> Point -> Point -> CubicBezier
CubicBezier Point
prev Point
c1 Point
c2 Point
to) Primitive -> [Primitive] -> [Primitive]
forall a. a -> [a] -> [a]
: Point -> [PathCommand] -> [Primitive]
go Point
to [PathCommand]
xs

-- | Gives the orientation vector for the start of the

-- primitive.

firstTangeantOf :: Primitive -> Vector
firstTangeantOf :: Primitive -> Point
firstTangeantOf Primitive
p = case Primitive
p of
  LinePrim (Line Point
p0 Point
p1) -> Point
p1 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p0
  BezierPrim (Bezier Point
p0 Point
p1 Point
p2) ->
      (Point
p1 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p0) Point -> Point -> Point
forall p. Epsilon p => p -> p -> p
`ifBigEnough` (Point
p2 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p1)
  CubicBezierPrim (CubicBezier Point
p0 Point
p1 Point
p2 Point
_) -> 
       (Point
p1 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p0) Point -> Point -> Point
forall p. Epsilon p => p -> p -> p
`ifBigEnough` (Point
p2 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p1)
 where
   ifBigEnough :: p -> p -> p
ifBigEnough p
a p
b | p -> Bool
forall a. Epsilon a => a -> Bool
nearZero p
a = p
b
                   | Bool
otherwise = p
a

-- | Gives the orientation vector at the end of the

-- primitive.

lastTangeantOf :: Primitive -> Vector
lastTangeantOf :: Primitive -> Point
lastTangeantOf Primitive
p = case Primitive
p of
  LinePrim (Line Point
p0 Point
p1) -> Point
p1 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p0
  BezierPrim (Bezier Point
_ Point
p1 Point
p2) -> Point
p2 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p1
  CubicBezierPrim (CubicBezier Point
_ Point
_ Point
p2 Point
p3) -> Point
p3 Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
p2

-- | Extract the first point of the primitive.

firstPointOf :: Primitive -> Point
firstPointOf :: Primitive -> Point
firstPointOf Primitive
p = case Primitive
p of
  LinePrim (Line Point
p0 Point
_) -> Point
p0
  BezierPrim (Bezier Point
p0 Point
_ Point
_) -> Point
p0
  CubicBezierPrim (CubicBezier Point
p0 Point
_ Point
_ Point
_) -> Point
p0

-- | Return the last point of a given primitive.

lastPointOf :: Primitive -> Point
lastPointOf :: Primitive -> Point
lastPointOf Primitive
p = case Primitive
p of
  LinePrim (Line Point
_ Point
p0) -> Point
p0
  BezierPrim (Bezier Point
_ Point
_ Point
p0) -> Point
p0
  CubicBezierPrim (CubicBezier Point
_ Point
_ Point
_ Point
p0) -> Point
p0

resplit :: [Primitive] -> [[Primitive]]
resplit :: [Primitive] -> [[Primitive]]
resplit = ([Primitive] -> [[Primitive]] -> [[Primitive]])
-> ([Primitive], [[Primitive]]) -> [[Primitive]]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) (([Primitive], [[Primitive]]) -> [[Primitive]])
-> ([Primitive] -> ([Primitive], [[Primitive]]))
-> [Primitive]
-> [[Primitive]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Primitive] -> ([Primitive], [[Primitive]])
go where
  go :: [Primitive] -> ([Primitive], [[Primitive]])
go [] = ([], [])
  go (Primitive
x:xs :: [Primitive]
xs@(Primitive
y:[Primitive]
_)) | Primitive -> Point
lastPointOf Primitive
x Point -> Point -> Bool
`isDistingableFrom` Primitive -> Point
firstPointOf Primitive
y =
      ([Primitive
x], [Primitive]
after[Primitive] -> [[Primitive]] -> [[Primitive]]
forall a. a -> [a] -> [a]
:[[Primitive]]
rest) where ([Primitive]
after, [[Primitive]]
rest) = [Primitive] -> ([Primitive], [[Primitive]])
go [Primitive]
xs
  go (Primitive
x:[Primitive]
xs) = (Primitive
xPrimitive -> [Primitive] -> [Primitive]
forall a. a -> [a] -> [a]
:[Primitive]
curr, [[Primitive]]
rest) where ([Primitive]
curr, [[Primitive]]
rest) = [Primitive] -> ([Primitive], [[Primitive]])
go [Primitive]
xs