content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  -- | Implementation using
  -- "An efficient algorithm for subdivising linear Coons surfaces"
  -- C.Yao and J.Rokne
  -- Computer aided design 8 (1991) 291-303
  module Graphics.Rasterific.Patch
      ( -- * Types
        CoonPatch( .. )
      , TensorPatch( .. )
      , ParametricValues( .. )
      , PatchInterpolation( .. )
      , CoonColorWeight
      , Subdivided( .. )
      , InterpolablePixel
  
        -- * Rendering functions
  
        -- ** Using Fast Forward Differences
      , rasterizeTensorPatch 
      , rasterizeCoonPatch
      , renderImageMesh
      , renderCoonMesh
      , renderCoonMeshBicubic
  
        -- ** Subdivision patch rendering
      , renderCoonPatch
      , renderCoonPatchAtDeepness
      , renderTensorPatch
      , renderTensorPatchAtDeepness
  
        -- * Debugging
      , DebugOption( .. )
      , defaultDebug
      , drawCoonPatchOutline
      , debugDrawCoonPatch
      , debugDrawTensorPatch
      , parametricBase
  
        -- * Manipulation
      , subdividePatch
      , subdivideTensorPatch
      , horizontalTensorSubdivide
      , transposePatch
      )  where
  
  import Control.Monad.Free( liftF )
  import Control.Monad( when, forM_ )
  import Control.Monad.Primitive( PrimMonad )
  import Data.Monoid( Sum( .. ) )
  import Graphics.Rasterific.Types
  import Graphics.Rasterific.CubicBezier
  import Graphics.Rasterific.CubicBezier.FastForwardDifference
  import Graphics.Rasterific.Operators
  import Graphics.Rasterific.Linear
  import Graphics.Rasterific.Compositor
  import Graphics.Rasterific.ComplexPrimitive
  import Graphics.Rasterific.Line( lineFromPath )
  import Graphics.Rasterific.Immediate
  import Graphics.Rasterific.BiSampleable
  import Graphics.Rasterific.PatchTypes
  import Graphics.Rasterific.MeshPatch
  import Graphics.Rasterific.Command
  
  import Codec.Picture.Types( PixelRGBA8( .. ) )
  
  -- @
  --  North    ----->     East
  --      +--------------+
  --      |      0       |
  --    ^ |              | |
  --    | |3            1| |
  --    | |              | v
  --      |      2       |
  --      +--------------+
  --  West    <-----      South
  -- @
  
  
  estimateCoonSubdivision :: CoonPatch px -> Int
  estimateCoonSubdivision CoonPatch { .. } = min 8 $
      maximum $ estimateFDStepCount <$> [_north, _west, _south, _east]
  
  estimateTensorSubdivision :: TensorPatch px -> Int
  estimateTensorSubdivision p = min 8 $
    maximum $ estimateFDStepCount <$> (fmap ($ p) axx ++ fmap ($ t) axx)
      where
       axx = [_curve0, _curve1, _curve2, _curve3]
       t = transposePatch p { _tensorValues = parametricBase }
  
  meanValue :: ParametricValues UV -> UV
  meanValue = (^* 0.25) . getSum . foldMap Sum
  
  -- | Horizontally divides the parametric plane
  --
  -- @
  --  N    midNorthEast   E
  --      +-------+------+
  --      |0      :     1|
  --      |       :      |
  --      | Left  :Right |
  --      |       :      |
  --      |3      :     2|
  --      +-------+------+
  --  W    midSouthWest   S
  -- @
  subdivideHorizontal :: ParametricValues UV -> (ParametricValues UV, ParametricValues UV)
  subdivideHorizontal ParametricValues { .. } = (l, r) where
    midNorthEast = _northValue `midPoint` _eastValue
    midSouthWest = _westValue `midPoint` _southValue
  
    l = ParametricValues
      { _northValue = _northValue
      , _eastValue = midNorthEast
      , _southValue = midSouthWest
      , _westValue = _westValue
      }
  
    r = ParametricValues
      { _northValue = midNorthEast
      , _eastValue = _eastValue
      , _southValue = _southValue
      , _westValue = midSouthWest
      }
  
  -- | Create UVPatch information for each new quadrant
  subdivideWeights :: UVPatch -> Subdivided UVPatch
  subdivideWeights values = Subdivided { .. } where
    ParametricValues
      { _northValue = north
      , _eastValue = east
      , _southValue = south
      , _westValue = west
      } = values
  
    --  N       midNorth    E
    --      +-------+------+
    --      |0      :     1|
    --   mid|   grid:Mid   |
    --  West+=======:======+ midEast
    --      |       :      |
    --      |3      :     2|
    --      +-------+------+
    --  W       midSouth    S
    midNorthValue = north `midPoint` east
    midWestValue = north `midPoint` west
    midSoutValue = west `midPoint` south
    midEastValue = east `midPoint` south
  
    gridMidValue = midSoutValue `midPoint` midNorthValue
  
    _northWest = ParametricValues
      { _northValue = north
      , _eastValue = midNorthValue
      , _southValue = gridMidValue
      , _westValue = midWestValue
      }
  
    _northEast = ParametricValues
      { _northValue = midNorthValue
      , _eastValue = east
      , _southValue = midEastValue
      , _westValue = gridMidValue
      }
  
    _southWest = ParametricValues
      { _northValue = midWestValue
      , _eastValue  = gridMidValue
      , _southValue = midSoutValue
      , _westValue = west
      }
    
    _southEast = ParametricValues
      { _northValue = gridMidValue
      , _eastValue = midEastValue
      , _southValue = south
      , _westValue = midSoutValue
      }
  
  westCurveOfPatch :: TensorPatch px -> CubicBezier
  westCurveOfPatch TensorPatch
    { _curve0 = CubicBezier c0 _ _ _
    , _curve1 = CubicBezier c1 _ _ _
    , _curve2 = CubicBezier c2 _ _ _
    , _curve3 = CubicBezier c3 _ _ _
    } = CubicBezier c0 c1 c2 c3
  
  eastCurveOfPatch :: TensorPatch px -> CubicBezier
  eastCurveOfPatch TensorPatch
    { _curve0 = CubicBezier _ _ _ c0
    , _curve1 = CubicBezier _ _ _ c1
    , _curve2 = CubicBezier _ _ _ c2
    , _curve3 = CubicBezier _ _ _ c3
    } = CubicBezier c0 c1 c2 c3
  
  -- | Swap vertical/horizontal orientation of a tensor patch
  transposePatch :: TensorPatch (ParametricValues a) -> TensorPatch (ParametricValues a)
  transposePatch TensorPatch
    { _curve0 = CubicBezier c00 c01 c02 c03
    , _curve1 = CubicBezier c10 c11 c12 c13
    , _curve2 = CubicBezier c20 c21 c22 c23
    , _curve3 = CubicBezier c30 c31 c32 c33
    , _tensorValues = values
    } = TensorPatch
      { _curve0 = CubicBezier c00 c10 c20 c30
      , _curve1 = CubicBezier c01 c11 c21 c31
      , _curve2 = CubicBezier c02 c12 c22 c32
      , _curve3 = CubicBezier c03 c13 c23 c33
      , _tensorValues = transposeParametricValues values
      }
  
  
  -- | Perform an operation like:
  --
  -- @
  --    o--------o--------o--------o
  --    |        |        |        |
  --    |        |        |        |
  --    |        |        |        |
  --    o--------o--------o--------o
  --    |        |        |        |
  --    |        |        |        |
  --    |        |        |        |
  --    o--------o--------o--------o
  --    |        |        |        |
  --    |        |        |        |
  --    |        |        |        |
  --    o--------o--------o--------o
  --    |        |        |        |
  --    |        |        |        |
  --    |        |        |        |
  --    o--------o--------o--------o
  --
  --       to (more or less)
  --
  --    o----*---o----*----o----*---o
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    o----*---o----*----o----*---o
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    o----*---o----*----o----*---o
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    o----*---o----*----o----*---o
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    |    |   |    |    |    |   |
  --    o----*---o----*----o----*---o
  --    <------------><------------->
  --       Left            Right
  -- @
  --
  horizontalTensorSubdivide :: TensorPatch UVPatch -> (TensorPatch UVPatch, TensorPatch UVPatch)
  horizontalTensorSubdivide p = (TensorPatch l0 l1 l2 l3 vl, TensorPatch r0 r1 r2 r3 vr) where
    (l0, r0) = divideCubicBezier $ _curve0 p
    (l1, r1) = divideCubicBezier $ _curve1 p
    (l2, r2) = divideCubicBezier $ _curve2 p
    (l3, r3) = divideCubicBezier $ _curve3 p
    (vl, vr) = subdivideHorizontal $ _tensorValues p
  
  -- | Subdivide a tensor patch into 4 new quadrant.
  -- Perform twice the horizontal subdivision with a transposition.
  subdivideTensorPatch :: TensorPatch UVPatch -> Subdivided (TensorPatch UVPatch)
  subdivideTensorPatch p = subdivided where
    (west, east) = horizontalTensorSubdivide p
    (northWest, southWest) = horizontalTensorSubdivide $ transposePatch west
    (northEast, southEast) = horizontalTensorSubdivide $ transposePatch east
    subdivided = Subdivided
      { _northWest = northWest
      , _northEast = northEast
      , _southWest = southWest
      , _southEast = southEast
      }
  
  basePointOfCoonPatch :: CoonPatch (ParametricValues px) -> [(Point, px)]
  basePointOfCoonPatch CoonPatch
      { _north = CubicBezier a _ _ b
      , _south = CubicBezier c _ _ d
      , _coonValues = ParametricValues { .. }
      } = [(a, _northValue), (b, _eastValue), (c, _southValue), (d, _westValue)]
  
  controlPointOfCoonPatch :: CoonPatch px -> [Point]
  controlPointOfCoonPatch CoonPatch
      { _north = CubicBezier _ a b _
      , _east  = CubicBezier _ c d _
      , _south = CubicBezier _ e f _
      , _west  = CubicBezier _ g h _
      } = [a, b, c, d, e, f, g, h]
  
  -- | Store the new generated information after subdivision
  -- in 4 quadrants.
  data Subdivided a = Subdivided
    { _northWest :: !a -- ^ Upper left
    , _northEast :: !a -- ^ Upper right
    , _southWest :: !a -- ^ Lower left
    , _southEast :: !a -- ^ Lower right
    }
  
  -- | Split a coon patch into four new quadrants
  subdividePatch :: CoonPatch UVPatch -> Subdivided (CoonPatch UVPatch)
  subdividePatch patch = Subdivided
      { _northWest = northWest
      , _northEast = northEast
      , _southWest = southWest
      , _southEast = southEast
      } where
    north@(CubicBezier nw _ _ ne) = _north patch
    south@(CubicBezier se _ _ sw) = _south patch
  
    midNorthLinear = nw `midPoint` ne
    midSouthLinear = sw `midPoint` se
    midWestLinear = nw `midPoint` sw
    midEastLinear = ne `midPoint` se
  
    -- These points are to calculate S_C and S_D
    (northLeft@(CubicBezier _ _ _ midNorth), northRight) = divideCubicBezier north
    (southRight, southLeft@(CubicBezier midSouth _ _ _ )) = divideCubicBezier south
    (westBottom, westTop@(CubicBezier midWest _ _ _)) = divideCubicBezier $ _west patch
    (eastTop@(CubicBezier _ _ _ midEast), eastBottom) = divideCubicBezier $ _east patch
  
    -- This points are to calculate S_B
    midNorthSouth = north `midCurve` south
    midEastWest = _east patch `midCurve` _west patch 
  
    (splitNorthSouthTop, splitNorthSouthBottom) =
        divideCubicBezier $ combine
          midEastWest
          (midNorth `straightLine` midSouth)
          (midNorthLinear `straightLine` midSouthLinear)
  
    (splitWestEastLeft, splitWestEastRight) =
        divideCubicBezier $ combine
          midNorthSouth
          (midWest `straightLine` midEast)
          (midWestLinear `straightLine` midEastLinear)
  
    weights = subdivideWeights $ _coonValues patch
  
    northWest = CoonPatch
      { _west = westTop
      , _north = northLeft
      , _east = splitNorthSouthTop
      , _south = inverseBezier splitWestEastLeft
      , _coonValues = _northWest weights
      }
  
    northEast = CoonPatch
      { _west = inverseBezier splitNorthSouthTop
      , _north = northRight
      , _east = eastTop
      , _south = inverseBezier splitWestEastRight
      , _coonValues = _northEast weights
      }
  
    southWest = CoonPatch
      { _west = westBottom
      , _north = splitWestEastLeft
      , _east = splitNorthSouthBottom
      , _south = southLeft
      , _coonValues = _southWest weights
      }
  
    southEast = CoonPatch
      { _west = inverseBezier splitNorthSouthBottom
      , _north = splitWestEastRight
      , _east = eastBottom
      , _south = southRight
      , _coonValues = _southEast weights
      }
  
  
  -- | We must reinverse some bezier curve to match the global
  -- direction
  inverseBezier :: CubicBezier -> CubicBezier
  inverseBezier (CubicBezier a b c d) = CubicBezier d c b a
  
  -- | Calculate the new cubic bezier using S
  combine :: CubicBezier -> CubicBezier -> CubicBezier -> CubicBezier
  combine (CubicBezier a1 b1 c1 d1)
          (CubicBezier a2 b2 c2 d2)
          (CubicBezier a3 b3 c3 d3) =
    CubicBezier (a1 ^+^ a2 ^-^ a3)
                (b1 ^+^ b2 ^-^ b3)
                (c1 ^+^ c2 ^-^ c3)
                (d1 ^+^ d2 ^-^ d3)
  
  
  straightLine :: Point -> Point -> CubicBezier
  straightLine a b = CubicBezier a p1 p2 b where
    p1 = lerp (1/3) b a
    p2 = lerp (2/3) b a
  
  
  -- | The curves in the coon patch are inversed!
  midCurve :: CubicBezier -> CubicBezier -> CubicBezier
  midCurve (CubicBezier a b c d) (CubicBezier d' c' b' a') =
    CubicBezier
      (a `midPoint` a')
      (b `midPoint` b')
      (c `midPoint` c')
      (d `midPoint` d')
  
  -- | Draw the 4 bezier spline representing the boundary of a coon patch.
  drawCoonPatchOutline :: CoonPatch px -> Drawing pxb ()
  drawCoonPatchOutline CoonPatch { .. } =
    liftF $ Stroke 2 JoinRound (CapRound, CapRound) prims ()
    where
      prims = toPrimitives [_north, _east, _south, _west]
  
  pointsOf :: PointFoldable v => v -> [Point]
  pointsOf = foldPoints (flip (:)) []
  
  -- | Used to describe how to debug print a coon/tensort patch.
  data DebugOption = DebugOption
    { _drawControlMesh    :: !Bool
    , _drawBaseVertices   :: !Bool
    , _drawControVertices :: !Bool
    , _colorVertices      :: !Bool
    , _drawOutline        :: !Bool
    , _outlineColor       :: !PixelRGBA8
    , _controlMeshColor   :: !PixelRGBA8
    , _vertexColor        :: !PixelRGBA8
    , _controlColor       :: !PixelRGBA8
    }
  
  -- | Default options drawing nearly everything.
  defaultDebug :: DebugOption
  defaultDebug = DebugOption
    { _drawControlMesh    = True
    , _drawBaseVertices   = True
    , _drawControVertices = True
    , _drawOutline        = True
    , _colorVertices      = False
    , _outlineColor       = PixelRGBA8 0 0 0 255
    , _controlMeshColor   = PixelRGBA8 50 50 128 255
    , _vertexColor        = PixelRGBA8 20 20 40 255
    , _controlColor       = PixelRGBA8 20 20 40 255
    }
  
  -- | Helper function drawing many information about a coon patch.
  debugDrawCoonPatch :: DebugOption -> CoonPatch (ParametricValues PixelRGBA8)
                     -> Drawing PixelRGBA8 ()
  debugDrawCoonPatch DebugOption { .. } patch@(CoonPatch { .. }) = do
    let stroker v = liftF $ Stroke 2 JoinRound (CapRound, CapRound) v ()
        fill sub = liftF $ Fill FillWinding sub ()
        setColor' c inner = liftF $ SetTexture (SolidTexture c) inner ()
    when _drawOutline $
      setColor' _outlineColor (drawCoonPatchOutline patch)
  
    when _drawBaseVertices $
      forM_ (basePointOfCoonPatch patch) $ \(p, c) ->
         if not _colorVertices then
           setColor' _vertexColor (stroker $ circle p 4)
         else do
           setColor' c . fill $ circle p 4
           setColor' _vertexColor . stroker $ circle p 5
  
    when _drawControVertices $
      forM_ (controlPointOfCoonPatch patch) $ \p ->
         setColor' _controlColor . stroker $ circle p 4
  
    let controlDraw = stroker . toPrimitives . lineFromPath . pointsOf
    when _drawControlMesh $
      setColor' _controlMeshColor $ do
          mapM_ controlDraw [_north, _east, _west, _south]
  
  -- | Helper function drawing many information about a tensor patch.
  debugDrawTensorPatch :: DebugOption -> TensorPatch (ParametricValues px)
                       -> Drawing PixelRGBA8 ()
  debugDrawTensorPatch DebugOption { .. } p = do
    let stroker v = liftF $ Stroke 2 JoinRound (CapRound, CapRound) v ()
        setColor' c inner =
            liftF $ SetTexture (SolidTexture c) inner ()
        p' = transposePatch p
  
    when _drawOutline $
      setColor' _outlineColor $
          mapM_ (stroker . toPrimitives)
              [ _curve0 p, _curve1 p, _curve2 p, _curve3 p
              , _curve0 p', _curve1 p', _curve2 p', _curve3 p']
  
    when _drawBaseVertices   $
      setColor' _vertexColor $
          forM_ (pointsOf p) $ \pp -> stroker $ circle pp 4
  
    let controlDraw = stroker . toPrimitives . lineFromPath . pointsOf
    when _drawControlMesh $
      setColor' _controlMeshColor $ do
          mapM_ controlDraw
              [ _curve0 p, _curve1 p, _curve2 p, _curve3 p
              , _curve0 p', _curve1 p', _curve2 p', _curve3 p']
  
  -- | Define the unit square in [0, 1]^2
  parametricBase :: UVPatch
  parametricBase = ParametricValues
    { _northValue = V2 0 0
    , _eastValue  = V2 1 0
    , _southValue = V2 1 1
    , _westValue  = V2 0 1
    }
  
  -- | Render a simple coon mesh, with only color on the vertices.
  renderCoonMesh :: forall m px.
                    (PrimMonad m, RenderablePixel px, BiSampleable (ParametricValues px) px)
                 => MeshPatch px -> DrawContext m px ()
  renderCoonMesh = mapM_ (rasterizeTensorPatch . toTensorPatch) . coonPatchesOf
  
  -- | Render a coon mesh but using cubic interpolation for the color.
  renderCoonMeshBicubic :: forall m px.
                           ( PrimMonad m
                           , RenderablePixel px
                           , BiSampleable (CubicCoefficient px) px)
                        => MeshPatch px -> DrawContext m px ()
  renderCoonMeshBicubic =
    mapM_ (rasterizeTensorPatch . toTensorPatch)
      . cubicCoonPatchesOf
      . calculateMeshColorDerivative
  
  -- | Render an mesh patch by interpolating accross an image.
  renderImageMesh :: PrimMonad m
                  => MeshPatch (ImageMesh PixelRGBA8) -> DrawContext m PixelRGBA8 ()
  renderImageMesh = mapM_ (rasterizeTensorPatch . toTensorPatch) . imagePatchesOf
  
  -- | Render a coon patch using the subdivision algorithm (potentially slower
  -- and less precise in case of image mesh.
  renderCoonPatch :: forall m interp px.
                     (PrimMonad m, RenderablePixel px, BiSampleable interp px)
                  => CoonPatch interp -> DrawContext m px ()
  renderCoonPatch p = renderCoonPatchAtDeepness (estimateCoonSubdivision p) p
  
  -- | Render a coon patch using the subdivision algorithm (potentially slower
  -- and less precise in case of image mesh). You can provide a max deepness
  renderCoonPatchAtDeepness
      :: forall m interp px.
         (PrimMonad m, RenderablePixel px, BiSampleable interp px)
      => Int              -- ^ Maximum subdivision deepness
      -> CoonPatch interp
      -> DrawContext m px ()
  renderCoonPatchAtDeepness maxDeepness originalPatch = go maxDeepness basePatch where
    baseColors = _coonValues originalPatch
  
    basePatch = originalPatch { _coonValues = parametricBase }
  
    drawPatchUniform CoonPatch { .. } = fillWithTextureNoAA FillWinding texture geometry where
      geometry = toPrim <$> [_north, _east, _south, _west]
      !(V2 u v) =meanValue _coonValues
      !texture = SolidTexture $ interpolate baseColors u v
  
    go 0 patch = drawPatchUniform patch
    go depth (subdividePatch -> Subdivided { .. }) =
      let d = depth - (1 :: Int) in
      go d _northWest >> go d _northEast >> go d _southWest >> go d _southEast
  
  renderTensorPatch :: forall m sampled px. 
                       (PrimMonad m, RenderablePixel px, BiSampleable sampled px)
                    => TensorPatch sampled -> DrawContext m px ()
  renderTensorPatch p = renderTensorPatchAtDeepness (estimateTensorSubdivision p) p
  
  -- | Render a tensor patch using the subdivision algorithm (potentially slower
  -- and less precise in case of image mesh.
  renderTensorPatchAtDeepness
    :: forall m sampled px. 
       (PrimMonad m, RenderablePixel px, BiSampleable sampled px)
    => Int -> TensorPatch sampled -> DrawContext m px ()
  renderTensorPatchAtDeepness maxDeepness originalPatch = go maxDeepness basePatch where
    baseColors = _tensorValues originalPatch
  
    basePatch = originalPatch { _tensorValues = parametricBase }
  
    drawPatchUniform p = fillWithTextureNoAA FillWinding texture geometry where
      geometry = toPrim <$> [_curve0 p, westCurveOfPatch p, _curve3 p, eastCurveOfPatch p]
      !(V2 u v) = meanValue $ _tensorValues p
      texture = SolidTexture $ interpolate baseColors u v
  
    go 0 patch = drawPatchUniform patch
    go depth (subdivideTensorPatch -> Subdivided { .. }) =
      let d = depth - (1 :: Int) in
      go d _northWest >> go d _northEast >> go d _southWest >> go d _southEast
  
  