{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}

-- | Main module of Rasterific, an Haskell rasterization engine.
--
-- Creating an image is rather simple, here is a simple example
-- of a drawing and saving it in a PNG file:
--
-- > import Codec.Picture( PixelRGBA8( .. ), writePng )
-- > import Graphics.Rasterific
-- > import Graphics.Rasterific.Texture
-- >
-- > main :: IO ()
-- > main = do
-- >   let white = PixelRGBA8 255 255 255 255
-- >       drawColor = PixelRGBA8 0 0x86 0xc1 255
-- >       recColor = PixelRGBA8 0xFF 0x53 0x73 255
-- >       img = renderDrawing 400 200 white $
-- >          withTexture (uniformTexture drawColor) $ do
-- >             fill $ circle (V2 0 0) 30
-- >             stroke 4 JoinRound (CapRound, CapRound) $
-- >                    circle (V2 400 200) 40
-- >             withTexture (uniformTexture recColor) .
-- >                    fill $ rectangle (V2 100 100) 200 100
-- >
-- >   writePng "yourimage.png" img
--
-- <<docimages/module_example.png>>
--
-- The coordinate system is the picture classic one, with the origin in
-- the upper left corner; with the y axis growing to the bottom and the
-- x axis growing to the right:
--
-- <<docimages/coordinate.png>>
--
module Graphics.Rasterific
    (
      -- * Rasterization command
      -- ** Filling
      fill
    , fillWithMethod
    , renderMeshPatch
      -- ** Stroking
    , stroke
    , dashedStroke
    , dashedStrokeWithOffset
      -- ** Text rendering
    , printTextAt
    , printTextRanges
      -- ** Texturing
    , withTexture
    , withClipping
    , withGroupOpacity
      -- ** Transformations
    , withTransformation
    , withPathOrientation
    , TextRange( .. )
    , PointSize( .. )

      -- * Generating images
    , ModulablePixel
    , RenderablePixel
    , renderDrawing
    , renderDrawingAtDpi
    , renderDrawingAtDpiToPDF
    , renderDrawingsAtDpiToPDF
    , renderOrdersAtDpiToPdf 
    , pathToPrimitives

      -- * Rasterization types
    , Texture
    , Drawing
    , Modulable

      -- * Geometry description
    , V2( .. )
    , Point
    , Vector
    , CubicBezier( .. )
    , Line( .. )
    , Bezier( .. )
    , Primitive( .. )
    , Path( .. )
    , PathCommand( .. )

      -- * Generic geometry description
    , Primitivable( .. )
    , Geometry( .. )

      -- * Generic geometry manipulation
    , Transformable( .. )
    , PointFoldable( .. )
    , PlaneBoundable( .. )
    , PlaneBound( .. )
    , boundWidth
    , boundHeight
    , boundLowerLeftCorner

      -- * Helpers
      -- ** line
    , line
      -- ** Rectangle
    , rectangle
    , roundedRectangle
      -- ** Circles
    , circle
    , ellipse
      -- ** Polygons
    , polyline
    , polygon
      -- ** Images
    , drawImageAtSize
    , drawImage
    , cacheDrawing

      -- ** Geometry Helpers
    , clip
    , bezierFromPath
    , lineFromPath
    , cubicBezierFromPath
    , firstTangeantOf
    , lastTangeantOf
    , firstPointOf
    , lastPointOf

      -- *** Arc traduction
    , Direction( .. )
    , arcInDirection

      -- * Rasterization control
    , Join( .. )
    , Cap( .. )
    , SamplerRepeat( .. )
    , FillMethod( .. )
    , PatchInterpolation( .. )
    , DashPattern
    , drawOrdersOfDrawing

      -- * Debugging helper
    , dumpDrawing
    ) where

import Control.Monad.Free( Free( .. ), liftF )
import Control.Monad.Free.Church( fromF )
import Control.Monad.ST( ST, runST )
import Control.Monad.State( modify, execState )
import Data.Maybe( fromMaybe )
import Codec.Picture.Types( Image( .. )
                          , Pixel( .. )
                          , PixelRGBA8
                          , pixelMapXY )

import qualified Data.ByteString.Lazy as LB
import qualified Data.Vector as V

import Graphics.Rasterific.Compositor
import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^) )
import Graphics.Rasterific.Rasterize
import Graphics.Rasterific.MicroPdf
{-import Graphics.Rasterific.Texture-}
import Graphics.Rasterific.ComplexPrimitive
import Graphics.Rasterific.Types
import Graphics.Rasterific.Line
import Graphics.Rasterific.QuadraticBezier
import Graphics.Rasterific.CubicBezier
import Graphics.Rasterific.StrokeInternal
import Graphics.Rasterific.Transformations
import Graphics.Rasterific.PlaneBoundable
import Graphics.Rasterific.Immediate
import Graphics.Rasterific.PathWalker
import Graphics.Rasterific.Arc
import Graphics.Rasterific.Command
import Graphics.Rasterific.PatchTypes
import Graphics.Rasterific.Patch
import Graphics.Rasterific.MeshPatch
{-import Graphics.Rasterific.TensorPatch-}

import Graphics.Text.TrueType( Font
                             , Dpi
                             , PointSize( .. )
                             )

{-import Debug.Trace-}
{-import Text.Printf-}

------------------------------------------------
----    Free Monad DSL section
------------------------------------------------

-- | Define the texture applyied to all the children
-- draw call.
--
-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ do
-- >     fill $ circle (V2 50 50) 20
-- >     fill $ circle (V2 100 100) 20
-- >     withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255)
-- >          $ circle (V2 150 150) 20
--
-- <<docimages/with_texture.png>>
--
withTexture :: Texture px -> Drawing px () -> Drawing px ()
withTexture texture subActions =
    liftF $ SetTexture texture subActions ()

-- | Will render the whole subaction with a given group opacity, after
-- each element has been rendered. That means that completly opaque
-- overlapping shapes will be rendered transparently, not one after
-- another.
--
-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $
-- >     stroke 3 JoinRound (CapRound, CapRound) $
-- >         line (V2 0 100) (V2 200 100)
-- >
-- > withGroupOpacity 128 $ do
-- >    withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) .
-- >       fill $ circle (V2 70 100) 60
-- >    withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255) .
-- >       fill $ circle (V2 120 100) 60
--
-- <<docimages/group_opacity.png>>
--
-- To be compared to the item opacity
--
-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $
-- >     stroke 3 JoinRound (CapRound, CapRound) $
-- >         line (V2 0 100) (V2 200 100)
-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) .
-- >    fill $ circle (V2 70 100) 60
-- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) .
-- >    fill $ circle (V2 120 100) 60
--
-- <<docimages/item_opacity.png>>
withGroupOpacity :: PixelBaseComponent px -> Drawing px ()-> Drawing px ()
withGroupOpacity opa sub = liftF $ WithGlobalOpacity opa sub ()

-- | Draw all the sub drawing commands using a transformation.
withTransformation :: Transformation -> Drawing px () -> Drawing px ()
withTransformation trans sub =
    liftF $ WithTransform trans sub ()

-- | This command allows you to draw primitives on a given curve,
-- for example, you can draw text on a curve:
--
-- > let path = Path (V2 100 180) False
-- >                 [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in
-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path
-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $
-- >   withPathOrientation path 0 $
-- >     printTextAt font (PointSize 24) (V2 0 0) "Text on path"
--
-- <<docimages/text_on_path.png>>
--
-- You can note that the position of the baseline match the size of the
-- characters.
--
-- You are not limited to text drawing while using this function,
-- you can draw arbitrary geometry like in the following example:
--
-- > let path = Path (V2 100 180) False
-- >                 [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)]
-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $
-- >   stroke 3 JoinRound (CapStraight 0, CapStraight 0) path
-- > 
-- > withPathOrientation path 0 $ do
-- >   printTextAt font (PointSize 24) (V2 0 0) "TX"
-- >   fill $ rectangle (V2 (-10) (-10)) 30 20
-- >   fill $ rectangle (V2 45 0) 10 20
-- >   fill $ rectangle (V2 60 (-10)) 20 20
-- >   fill $ rectangle (V2 100 (-15)) 20 50
--
-- <<docimages/geometry_on_path.png>>
--
withPathOrientation :: Path            -- ^ Path directing the orientation.
                    -> Float           -- ^ Basline Y axis position, used to align text properly.
                    -> Drawing px ()   -- ^ The sub drawings.
                    -> Drawing px ()
withPathOrientation path p sub =
    liftF $ WithPathOrientation path p sub ()

-- | Fill some geometry. The geometry should be "looping",
-- ie. the last point of the last primitive should
-- be equal to the first point of the first primitive.
--
-- The primitive should be connected.
--
-- > fill $ circle (V2 100 100) 75
--
-- <<docimages/fill_circle.png>>
--
fill :: Geometry geom => geom -> Drawing px ()
fill prims = liftF $ Fill FillWinding (toPrimitives prims) ()

-- | This function let you choose how to fill the primitives
-- in case of self intersection. See `FillMethod` documentation
-- for more information.
fillWithMethod :: Geometry geom
               => FillMethod -> geom -> Drawing px ()
fillWithMethod method prims =
    liftF $ Fill method (toPrimitives prims) ()

-- | Draw some geometry using a clipping path.
--
-- > withClipping (fill $ circle (V2 100 100) 75) $
-- >     mapM_ (stroke 7 JoinRound (CapRound, CapRound))
-- >       [line (V2 0 yf) (V2 200 (yf + 10))
-- >                      | y <- [5 :: Int, 17 .. 200]
-- >                      , let yf = fromIntegral y ]
--
-- <<docimages/with_clipping.png>>
--
withClipping
    :: (forall innerPixel. Drawing innerPixel ()) -- ^ The clipping path
    -> Drawing px () -- ^ The actual geometry to clip
    -> Drawing px ()
withClipping clipPath drawing =
    liftF $ WithCliping clipPath drawing ()

-- | Will stroke geometry with a given stroke width.
-- The elements should be connected
--
-- > stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75
--
-- <<docimages/stroke_circle.png>>
--
stroke :: (Geometry geom)
       => Float       -- ^ Stroke width
       -> Join        -- ^ Which kind of join will be used
       -> (Cap, Cap)  -- ^ Start and end capping.
       -> geom        -- ^ List of elements to render
       -> Drawing px ()
stroke width join caping prims =
    liftF $ Stroke width join caping (toPrimitives prims) ()

-- | Draw a string at a given position.
-- Text printing imply loading a font, there is no default
-- font (yet). Below an example of font rendering using a
-- font installed on Microsoft Windows.
--
-- > import Graphics.Text.TrueType( loadFontFile )
-- > import Codec.Picture( PixelRGBA8( .. ), writePng )
-- > import Graphics.Rasterific
-- > import Graphics.Rasterific.Texture
-- >
-- > main :: IO ()
-- > main = do
-- >   fontErr <- loadFontFile "test_fonts/DejaVuSans.ttf"
-- >   case fontErr of
-- >     Left err -> putStrLn err
-- >     Right font ->
-- >       writePng "text_example.png" .
-- >           renderDrawing 300 70 (PixelRGBA8 255 255 255 255)
-- >               . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $
-- >                       printTextAt font (PointSize 12) (V2 20 40)
-- >                            "A simple text test!"
--
-- <<docimages/text_example.png>>
--
-- You can use any texture, like a gradient while rendering text.
--
printTextAt :: Font            -- ^ Drawing font
            -> PointSize       -- ^ font Point size
            -> Point           -- ^ Drawing starting point (base line)
            -> String          -- ^ String to print
            -> Drawing px ()
printTextAt font pointSize point string =
    liftF $ TextFill point [description] ()
  where
    description = TextRange
        { _textFont    = font
        , _textSize    = pointSize
        , _text        = string
        , _textTexture = Nothing
        }

-- | Render a mesh patch as an object. Warning, there is
-- no antialiasing on mesh patch objects!
renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch i mesh = liftF $ MeshPatchRender i mesh ()

-- | Print complex text, using different texture font and
-- point size for different parts of the text.
--
-- > let blackTexture =
-- >       Just . uniformTexture $ PixelRGBA8 0 0 0 255
-- >     redTexture =
-- >       Just . uniformTexture $ PixelRGBA8 255 0 0 255
-- > in
-- > printTextRanges (V2 20 40)
-- >   [ TextRange font1 (PointSize 12) "A complex " blackTexture
-- >   , TextRange font2 (PointSize 8) "text test" redTexture]
--
-- <<docimages/text_complex_example.png>>
--
printTextRanges :: Point            -- ^ Starting point of the base line
                -> [TextRange px]   -- ^ Ranges description to be printed
                -> Drawing px ()
printTextRanges point ranges = liftF $ TextFill point ranges ()

data RenderContext px = RenderContext
    { currentClip           :: Maybe (Texture (PixelBaseComponent px))
    , currentTexture        :: Texture px
    , currentTransformation :: Maybe (Transformation, Transformation)
    }

-- | Function to call in order to start the image creation.
-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types
-- in other colorspace will probably produce weird results.
-- Default DPI is 96
renderDrawing
    :: forall px . (RenderablePixel px)
    => Int -- ^ Rendering width
    -> Int -- ^ Rendering height
    -> px  -- ^ Background color
    -> Drawing px () -- ^ Rendering action
    -> Image px
renderDrawing width height = renderDrawingAtDpi width height 96

renderOrdersAtDpiToPdf 
    :: Int -- ^ Rendering width
    -> Int -- ^ Rendering height
    -> Dpi -- ^ Current DPI used for text rendering.
    -> [DrawOrder PixelRGBA8]  -- ^ Drawing Orders
    -> LB.ByteString
renderOrdersAtDpiToPdf w h dpi =
  renderOrdersToPdf renderer w h dpi
    where
      renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
      renderer = drawOrdersOfDrawing w h dpi emptyPx

renderDrawingAtDpiToPDF
    :: Int -- ^ Rendering width
    -> Int -- ^ Rendering height
    -> Dpi -- ^ Current DPI used for text rendering.
    -> Drawing PixelRGBA8 () -- ^ Rendering action
    -> LB.ByteString
renderDrawingAtDpiToPDF w h dpi d = renderDrawingsAtDpiToPDF w h dpi [d]

renderDrawingsAtDpiToPDF
    :: Int -- ^ Rendering width
    -> Int -- ^ Rendering height
    -> Dpi -- ^ Current DPI used for text rendering.
    -> [Drawing PixelRGBA8 ()] -- ^ Rendering actions
    -> LB.ByteString
renderDrawingsAtDpiToPDF w h dpi =
  renderDrawingsToPdf renderer w h dpi
    where
      renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
      renderer = drawOrdersOfDrawing w h dpi emptyPx

-- | Function to call in order to start the image creation.
-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types
-- in other colorspace will probably produce weird results.
renderDrawingAtDpi
    :: forall px . (RenderablePixel px)
    => Int -- ^ Rendering width
    -> Int -- ^ Rendering height
    -> Dpi -- ^ Current DPI used for text rendering.
    -> px  -- ^ Background color
    -> Drawing px () -- ^ Rendering action
    -> Image px
renderDrawingAtDpi width height dpi background drawing =
    runST $ runDrawContext width height background
          $ mapM_ fillOrder
          $ drawOrdersOfDrawing width height dpi background drawing

cacheOrders :: forall px. (RenderablePixel px)
            => Maybe (Image px -> ImageTransformer px)
            -> Int -- ^ width
            -> Int -- ^ Height
            -> [DrawOrder px] -> Drawing px ()
cacheOrders imageFilter maxWidth maxHeight orders = case imageFilter of
    Nothing -> drawImageAtSize resultImage 0 cornerUpperLeft width height
    Just f -> drawImage (pixelMapXY (f resultImage) resultImage) 0 cornerUpperLeft
  where
   PlaneBound mini maxi = foldMap planeBounds orders
   cornerUpperLeftInt = floor <$> mini :: V2 Int
   cornerUpperLeft = fromIntegral <$> cornerUpperLeftInt

   V2 width height = min <$> (maxi ^-^ cornerUpperLeft ^+^ V2 1 1)
                         <*> (V2 (fromIntegral maxWidth) (fromIntegral maxHeight))
   
   shiftOrder order@DrawOrder { _orderPrimitives = prims } =
       order { _orderPrimitives = fmap (transform (^-^ cornerUpperLeft)) <$> prims 
             , _orderTexture =
                 WithTextureTransform (translate cornerUpperLeft) $ _orderTexture order
             , _orderMask =
                 WithTextureTransform (translate cornerUpperLeft) <$> _orderMask order
             }
   
   resultImage =
     runST $ runDrawContext (ceiling width) (ceiling height) emptyPx
           $ mapM_ (fillOrder . shiftOrder) orders

-- | This function perform an optimisation, it will render a drawing
-- to an image interanlly and create a new order to render this image
-- instead of the geometry, effectively cuting the geometry generation
-- part.
--
-- It can save execution time when drawing complex elements multiple
-- times.
cacheDrawing
    :: forall px . (RenderablePixel px)
    => Int -- ^ Max rendering width
    -> Int -- ^ Max rendering height
    -> Dpi
    -> Drawing px ()
    -> Drawing px ()
cacheDrawing maxWidth maxHeight dpi sub =
  cacheOrders Nothing maxWidth maxHeight $
    drawOrdersOfDrawing maxWidth maxHeight dpi emptyPx sub

{-  
preComputeTexture :: (RenderablePixel px)
                  => Int -> Int -> Texture px -> Texture px
preComputeTexture w h = go where
  go :: RenderablePixel px => Texture px -> Texture px
  go t = case t of
    SolidTexture _ -> t
    LinearGradientTexture _ _ -> t
    RadialGradientTexture _ _ _ -> t
    RadialGradientWithFocusTexture _ _ _ _ -> t
    WithSampler s sub -> WithSampler s $ go sub
    WithTextureTransform trans sub -> WithTextureTransform trans $ go sub
    SampledTexture _ -> t
    RawTexture _ -> t
    ShaderTexture _ -> t
    ModulateTexture t1 t2 -> ModulateTexture (go t1) (go t2)
    PatternTexture _ _ _ _ _ -> t
    AlphaModulateTexture i m -> AlphaModulateTexture (go i) (go m)
    MeshPatchTexture i m ->
        RawTexture $ renderDrawing w h emptyPx $ renderMeshPatch i m
-- -}

-- | Transform a drawing into a serie of low-level drawing orders.
drawOrdersOfDrawing
    :: forall px . (RenderablePixel px) 
    => Int -- ^ Rendering width
    -> Int -- ^ Rendering height
    -> Dpi -- ^ Current assumed DPI
    -> px  -- ^ Background color
    -> Drawing px () -- ^ Rendering action
    -> [DrawOrder px]
drawOrdersOfDrawing width height dpi background drawing =
    go initialContext (fromF drawing) []
  where
    initialContext = RenderContext Nothing stupidDefaultTexture Nothing
    clipBackground = emptyValue :: PixelBaseComponent px
    clipForeground = fullValue :: PixelBaseComponent px

    clipRender ctxt =
      renderDrawing width height clipBackground . 
        transformer .
          withTexture (SolidTexture clipForeground)
       where 
         transformer = maybe id (withTransformation . fst) $ currentTransformation ctxt


    subRender :: (forall s. DrawContext (ST s) px ()) -> Image px
    subRender act =
      runST $ runDrawContext width height background act

    textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } =
        WithTextureTransform t $ currentTexture ctxt
    textureOf ctxt = currentTexture ctxt

    geometryOf :: Transformable a => RenderContext px -> a -> a
    geometryOf RenderContext { currentTransformation = Just (trans, _) } =
        transform (applyTransformation trans)
    geometryOf _ = id

    geometryOfO RenderContext { currentTransformation = Just (trans, _) } =
        transformOrder (applyTransformation trans)
    geometryOfO _ = id

    stupidDefaultTexture =
        SolidTexture $ colorMap (const clipBackground) background

    orderOf ctxt method primitives = DrawOrder 
        { _orderPrimitives = primitives
        , _orderTexture    = textureOf ctxt
        , _orderFillMethod = method
        , _orderMask       = currentClip ctxt
        , _orderDirect     = return ()
        }

    go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px]
       -> [DrawOrder px]
    go _ (Pure ()) rest = rest
    go ctxt (Free (WithGlobalOpacity opa sub next)) rest =
        go ctxt (Free (WithImageEffect opacifier sub next)) rest
      where 
        -- Todo: a colorMapWithAlpha is really needed in JP API.
        opacifier _ _ _ px = mixWithAlpha ignore alphaModulate px px
        ignore _ _ a = a
        alphaModulate _ v = opa `modulate` v

    go ctxt (Free (WithImageEffect effect sub next)) rest =
        go freeContext (fromF cached) after
      where
        cached = cacheOrders (Just effect) maxBound maxBound $ go ctxt (fromF sub) []
        after = go ctxt next rest
        freeContext = ctxt { currentClip = Nothing, currentTransformation = Nothing }


    go ctxt (Free (WithPathOrientation path base sub next)) rest = final where
      final = orders <> go ctxt next rest
      images = go ctxt (fromF sub) []

      drawer trans _ order =
        modify (transformOrder (applyTransformation trans) order :)

      orders = reverse $ execState (drawOrdersOnPath drawer 0 base path images) []

    go ctxt (Free (WithTransform trans sub next)) rest = final where
      trans'
        | Just (t, _) <- currentTransformation ctxt = t <> trans
        | otherwise = trans
      invTrans = fromMaybe mempty $ inverseTransformation trans'
      after = go ctxt next rest
      subContext =
          ctxt { currentTransformation = Just (trans', invTrans) }

      final = go subContext (fromF sub) after

    go ctxt (Free (CustomRender cust next)) rest = order : after where
      after = go ctxt next rest
      order = DrawOrder 
            { _orderPrimitives = []
            , _orderTexture    = textureOf ctxt
            , _orderFillMethod = FillWinding
            , _orderMask       = currentClip ctxt
            , _orderDirect     = cust
            }

    go ctxt (Free (MeshPatchRender i mesh next)) rest = order : after where
      after = go ctxt next rest
      rendering :: DrawContext (ST s) px ()
      rendering = case i of
        PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf $ geometryOf ctxt opaqueMesh 
        PatchBicubic ->
            mapM_ rasterizeCoonPatch
                . cubicCoonPatchesOf 
                $ calculateMeshColorDerivative $ geometryOf ctxt opaqueMesh 

      hasTransparency =
          V.any ((/= fullValue) . pixelOpacity) $ _meshColors mesh

      opacifier px = mixWithAlpha (\_ _ a -> a) (\_ _ -> fullValue) px px

      opaqueMesh = opacifier <$> mesh
      transparencyMesh = pixelOpacity <$> mesh

      clipPath
        | not hasTransparency = currentClip ctxt
        | otherwise =
            let newMask :: Image (PixelBaseComponent (PixelBaseComponent px))
                newMask = clipRender ctxt $ renderMeshPatch i transparencyMesh in
            case currentClip ctxt of
              Nothing -> Just $ RawTexture newMask
              Just v -> Just $ ModulateTexture v (RawTexture newMask)

      order = case clipPath of
        -- Good, we can directly render on the final canvas
        Nothing -> DrawOrder 
            { _orderPrimitives = []
            , _orderTexture    = textureOf ctxt
            , _orderFillMethod = FillWinding
            , _orderMask       = clipPath
            , _orderDirect     = rendering
            }
        Just c -> DrawOrder
            { _orderPrimitives = [geometryOf ctxt $ rectangle (V2 0 0) (fromIntegral width) (fromIntegral height)]
            , _orderTexture    = AlphaModulateTexture (RawTexture $ subRender rendering) c
            , _orderFillMethod = FillWinding
            , _orderMask       = Nothing
            , _orderDirect     = return ()
            }

    go ctxt (Free (Fill method prims next)) rest = order : after where
      after = go ctxt next rest
      order = orderOf ctxt method [geometryOf ctxt prims >>= listOfContainer . sanitizeFilling]

    go ctxt (Free (Stroke w j cap prims next)) rest = order : after where
      after = go ctxt next rest
      order = orderOf ctxt FillWinding [geometryOf ctxt prim']
      prim' = listOfContainer $ strokize w j cap prims

    go ctxt (Free (SetTexture tx sub next)) rest =
        go (ctxt { currentTexture = tx }) (fromF sub) $
            go ctxt next rest

    go ctxt (Free (DashedStroke o d w j cap prims next)) rest =
        foldr recurse after $ dashedStrokize o d w j cap prims
      where
        after = go ctxt next rest
        recurse sub =
            go ctxt (liftF $ Fill FillWinding sub ())

    go ctxt (Free (TextFill p descriptions next)) rest = calls <> go ctxt next rest where
      calls =
        geometryOfO ctxt <$> textToDrawOrders dpi (currentTexture ctxt) p descriptions

    go ctxt (Free (WithCliping clipPath path next)) rest =
        go (ctxt { currentClip = newModuler }) (fromF path) $
            go ctxt next rest
      where
        modulationTexture :: Texture (PixelBaseComponent px)
        modulationTexture = RawTexture $ clipRender ctxt clipPath

        newModuler = Just . subModuler $ currentClip ctxt

        subModuler Nothing = modulationTexture
        subModuler (Just v) =
            ModulateTexture v modulationTexture

-- | With stroke geometry with a given stroke width, using
-- a dash pattern.
--
-- > dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $
-- >     line (V2 0 100) (V2 200 100)
--
-- <<docimages/dashed_stroke.png>>
--
dashedStroke
    :: Geometry geom
    => DashPattern -- ^ Dashing pattern to use for stroking
    -> Float       -- ^ Stroke width
    -> Join        -- ^ Which kind of join will be used
    -> (Cap, Cap)  -- ^ Start and end capping.
    -> geom        -- ^ List of elements to render
    -> Drawing px ()
dashedStroke = dashedStrokeWithOffset 0.0

-- | With stroke geometry with a given stroke width, using
-- a dash pattern. The offset is there to specify the starting
-- point into the pattern, the value can be negative.
--
-- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $
-- >     line (V2 0 100) (V2 200 100)
--
-- <<docimages/dashed_stroke_with_offset.png>>
--
dashedStrokeWithOffset
    :: Geometry geom
    => Float       -- ^ Starting offset
    -> DashPattern -- ^ Dashing pattern to use for stroking
    -> Float       -- ^ Stroke width
    -> Join        -- ^ Which kind of join will be used
    -> (Cap, Cap)  -- ^ Start and end capping.
    -> geom        -- ^ List of elements to render
    -> Drawing px ()
dashedStrokeWithOffset _ [] width join caping prims =
    stroke width join caping prims
dashedStrokeWithOffset offset dashing width join caping prims =
    liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) ()

-- | Generate a strokable line out of points list.
-- Just an helper around `lineFromPath`.
--
-- > stroke 4 JoinRound (CapRound, CapRound) $
-- >    polyline [V2 10 10, V2 100 70, V2 190 190]
--
-- <<docimages/stroke_polyline.png>>
--
polyline :: [Point] -> [Primitive]
polyline = map LinePrim . lineFromPath

-- | Generate a fillable polygon out of points list.
-- Similar to the `polyline` function, but close the
-- path.
--
-- > fill $ polygon [V2 30 30, V2 100 70, V2 80 170]
--
-- <<docimages/fill_polygon.png>>
--
polygon :: [Point] -> [Primitive]
polygon [] = []
polygon [_] = []
polygon [_,_] = []
polygon lst@(p:_) = polyline $ lst ++ [p]

-- | Simply draw an image into the canvas. Take into account
-- any previous transformation performed on the geometry.
--
-- > drawImage textureImage 0 (V2 30 30)
--
-- <<docimages/image_simple.png>>
--
drawImage :: Image px       -- ^ Image to be drawn
          -> StrokeWidth    -- ^ Border size, drawn with current texture.
          -> Point          -- ^ Position of the corner upper left of the image.
          -> Drawing px ()
drawImage img@Image { imageWidth = w, imageHeight = h } s p =
    drawImageAtSize img s p (fromIntegral w) (fromIntegral h)

-- | Draw an image with the desired size
--
-- > drawImageAtSize textureImage 2 (V2 30 30) 128 128
--
-- <<docimages/image_resize.png>>
--
drawImageAtSize :: Image px    -- ^ Image to be drawn
                -> StrokeWidth -- ^ Border size, drawn with current texture.
                -> Point -- ^ Position of the corner upper left of the image.
                -> Float -- ^ Width of the drawn image
                -> Float -- ^ Height of the drawn image
                -> Drawing px ()
drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip
            reqWidth reqHeight
    | borderSize <= 0 =
        withTransformation (translate p <> scale scaleX scaleY) .
            withTexture (SampledTexture img) $ fill rect
    | otherwise = do
        withTransformation (translate p <> scale scaleX scaleY) $
            withTexture (SampledTexture img) $ fill rect
        stroke (borderSize / 2) (JoinMiter 0)
               (CapStraight 0, CapStraight 0) rect'
        where
          p = ip ^-^ V2 0.5 0.5
          rect = rectangle (V2 0 0) rw rh
          rect' = rectangle p reqWidth reqHeight

          (rw, rh) = (fromIntegral w, fromIntegral h)
          scaleX | reqWidth == 0 = 1
                 | otherwise = reqWidth / rw

          scaleY | reqHeight == 0 = 1
                 | otherwise = reqHeight / rh

-- | Return a simple line ready to be stroked.
--
-- > stroke 17 JoinRound (CapRound, CapRound) $
-- >     line (V2 10 10) (V2 180 170)
--
-- <<docimages/stroke_line.png>>
--
line :: Point -> Point -> [Primitive]
line p1 p2 = [LinePrim $ Line p1 p2]