{-# 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 (Eq, 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 (Eq, 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 (Eq, Enum, 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 (Eq, Enum, Show)

-- | Represent a raster line

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

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

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

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

  }
  deriving Show

-- | Just to get faster sorting

instance Storable EdgeSample where
   sizeOf _ = 4 * sizeOf (0 :: Float)
   alignment = sizeOf

   {-# INLINE peek #-}
   peek ptr = do
     let q = castPtr ptr
     sx <- peekElemOff q 0
     sy <- peekElemOff q 1
     sa <- peekElemOff q 2
     sh <- peekElemOff q 3
     return $ EdgeSample sx sy sa sh

   {-# INLINE poke #-}
   poke ptr (EdgeSample sx sy sa sh) = do
     let q = castPtr ptr
     pokeElemOff q 0 sx
     pokeElemOff q 1 sy
     pokeElemOff q 2 sa
     pokeElemOff q 3 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 f = runIdentity . transformM (return . 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 f = f
    {-# INLINE transformM #-}
    transformM f = f

-- | Just apply the function

instance PointFoldable Point where
    {-# INLINE foldPoints #-}
    foldPoints f = 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
  { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point

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

  }
  deriving Eq

instance Show Line where
  show (Line a b) =
      "Line (" ++ show a ++ ") ("
               ++ show b ++ ")"

instance Transformable Line where
    {-# INLINE transformM #-}
    transformM f (Line a b) = Line <$> f a <*> f b

instance PointFoldable Line where
    {-# INLINE foldPoints #-}
    foldPoints f acc (Line a b) = f (f acc b) 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.

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

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

  , _bezierX2 :: {-# UNPACK #-} !Point
  }
  deriving Eq

instance Show Bezier where
    show (Bezier a b c) =
        "Bezier (" ++ show a ++ ") ("
                   ++ show b ++ ") ("
                   ++ show c ++ ")"

instance Transformable Bezier where
    {-# INLINE transform #-}
    transform f (Bezier a b c) = Bezier (f a) (f b) $ f c
    {-# INLINE transformM #-}
    transformM f (Bezier a b c) = Bezier <$> f a <*> f b <*> f c

instance PointFoldable Bezier where
    {-# INLINE foldPoints #-}
    foldPoints f acc (Bezier a b c) =
        foldl' f acc [a, b, 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.

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

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

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

  , _cBezierX3 :: {-# UNPACK #-} !Point
  }
  deriving Eq

instance Show CubicBezier where
  show (CubicBezier a b c d) =
     "CubicBezier (" ++ show a ++ ") ("
                ++ show b ++ ") ("
                ++ show c ++ ") ("
                ++ show d ++ ")"

instance Transformable CubicBezier where
    {-# INLINE transform #-}
    transform f (CubicBezier a b c d) =
       CubicBezier (f a) (f b) (f c) $ f d
    transformM f (CubicBezier a b c d) =
       CubicBezier <$> f a <*> f b <*> f c <*> f d

instance PointFoldable CubicBezier where
    {-# INLINE foldPoints #-}
    foldPoints f acc (CubicBezier a b c d) =
        foldl' f acc [a, b, c, 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 (Eq, Show)

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

-- generically.

class Primitivable a where
  toPrim :: a -> Primitive

-- | @toPrim = id@

instance Primitivable Primitive where toPrim = id

-- | @toPrim = LinePrim@

instance Primitivable Line where toPrim = LinePrim

-- | @toPrim = BezierPrim@

instance Primitivable Bezier where toPrim = BezierPrim

-- | @toPrim = CubicBezierPrim@

instance Primitivable CubicBezier where toPrim = 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 = F.concatMap toPrimitives . F.toList

instance Geometry Path where
  {-# INLINE toPrimitives #-}
  toPrimitives = pathToPrimitives

instance Geometry Primitive where
  toPrimitives e = [e]
  {-# INLINE listToPrims #-}
  listToPrims = F.toList -- Open question, is it optimised as `id`?


instance Geometry Line where
  {-# INLINE toPrimitives #-}
  toPrimitives e = [toPrim e]

instance Geometry Bezier where
  {-# INLINE toPrimitives #-}
  toPrimitives e = [toPrim e]

instance Geometry CubicBezier where
  {-# INLINE toPrimitives #-}
  toPrimitives e = [toPrim 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 = listToPrims


instance Transformable Primitive where
    {-# INLINE transform #-}
    transform f (LinePrim l) = LinePrim $ transform f l
    transform f (BezierPrim b) = BezierPrim $ transform f b
    transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c

    transformM f (LinePrim l) = LinePrim <$> transformM f l
    transformM f (BezierPrim b) = BezierPrim <$> transformM f b
    transformM f (CubicBezierPrim c) = CubicBezierPrim <$> transformM f c

instance PointFoldable Primitive where
    {-# INLINE foldPoints #-}
    foldPoints f acc = go
      where go (LinePrim l) = foldPoints f acc l
            go (BezierPrim b) = foldPoints f acc b
            go (CubicBezierPrim c) = foldPoints f acc c

instance {-# OVERLAPPABLE #-} (Traversable f, Transformable a)
      => Transformable (f a) where
    transform f = fmap (transform f)
    transformM f = mapM (transformM f)

instance {-# OVERLAPPABLE #-} (Foldable f, PointFoldable a)
      => PointFoldable (f a) where
    foldPoints f = foldl' (foldPoints f)

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

type Container a = DList a

containerOfFunction :: ([a] -> [a]) -> Container a
containerOfFunction f = fromList $ f []

containerOfList :: [a] -> Container a
containerOfList = fromList

listOfContainer :: Container a -> [a]
listOfContainer = 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.

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

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

    , _pathCommand     :: [PathCommand]
    }
    deriving (Eq, Show)

instance Transformable Path where
    {-# INLINE transform #-}
    transform f (Path orig close rest) =
        Path (f orig) close (transform f rest)

    transformM f (Path orig close rest) =
        Path <$> f orig <*> pure close <*> transformM f rest


instance PointFoldable Path where
    {-# INLINE foldPoints #-}
    foldPoints f acc (Path o _ rest) =
        foldPoints f (f acc o) 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 (Eq, Show)

instance Transformable PathCommand where
    transform f (PathLineTo p) = PathLineTo $ f p
    transform f (PathQuadraticBezierCurveTo p1 p2) =
        PathQuadraticBezierCurveTo (f p1) $ f p2
    transform f (PathCubicBezierCurveTo p1 p2 p3) =
        PathCubicBezierCurveTo (f p1) (f p2) $ f p3

    transformM f (PathLineTo p) = PathLineTo <$> f p
    transformM f (PathQuadraticBezierCurveTo p1 p2) =
        PathQuadraticBezierCurveTo <$> f p1 <*> f p2
    transformM f (PathCubicBezierCurveTo p1 p2 p3) =
        PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3

instance PointFoldable PathCommand where
    foldPoints f acc (PathLineTo p) = f acc p
    foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) =
        f (f acc p1) p2
    foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) =
        foldl' f acc [p1, p2, p3]

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

-- primitives.

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

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

-- primitive.

firstTangeantOf :: Primitive -> Vector
firstTangeantOf p = case p of
  LinePrim (Line p0 p1) -> p1 ^-^ p0
  BezierPrim (Bezier p0 p1 p2) ->
      (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)
  CubicBezierPrim (CubicBezier p0 p1 p2 _) ->
       (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)
 where
   ifBigEnough a b | nearZero a = b
                   | otherwise = a

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

-- primitive.

lastTangeantOf :: Primitive -> Vector
lastTangeantOf p = case p of
  LinePrim (Line p0 p1) -> p1 ^-^ p0
  BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1
  CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2

-- | Extract the first point of the primitive.

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

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

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

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