{-# 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 px -> Drawing px () -> Drawing px ()
withTexture Texture px
texture Drawing px ()
subActions =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Texture px -> Drawing px () -> () -> DrawCommand px ()
forall px next.
Texture px -> Drawing px () -> next -> DrawCommand px next
SetTexture Texture px
texture Drawing px ()
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 :: PixelBaseComponent px -> Drawing px () -> Drawing px ()
withGroupOpacity PixelBaseComponent px
opa Drawing px ()
sub = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ PixelBaseComponent px -> Drawing px () -> () -> DrawCommand px ()
forall px next.
PixelBaseComponent px
-> Drawing px () -> next -> DrawCommand px next
WithGlobalOpacity PixelBaseComponent px
opa Drawing px ()
sub ()

-- | Draw all the sub drawing commands using a transformation.

withTransformation :: Transformation -> Drawing px () -> Drawing px ()
withTransformation :: Transformation -> Drawing px () -> Drawing px ()
withTransformation Transformation
trans Drawing px ()
sub =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Transformation -> Drawing px () -> () -> DrawCommand px ()
forall px next.
Transformation -> Drawing px () -> next -> DrawCommand px next
WithTransform Transformation
trans Drawing px ()
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 -> Float -> Drawing px () -> Drawing px ()
withPathOrientation Path
path Float
p Drawing px ()
sub =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Path -> Float -> Drawing px () -> () -> DrawCommand px ()
forall px next.
Path -> Float -> Drawing px () -> next -> DrawCommand px next
WithPathOrientation Path
path Float
p Drawing px ()
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 :: geom -> Drawing px ()
fill geom
prims = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ FillMethod -> [Primitive] -> () -> DrawCommand px ()
forall px next.
FillMethod -> [Primitive] -> next -> DrawCommand px next
Fill FillMethod
FillWinding (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
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 :: FillMethod -> geom -> Drawing px ()
fillWithMethod FillMethod
method geom
prims =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ FillMethod -> [Primitive] -> () -> DrawCommand px ()
forall px next.
FillMethod -> [Primitive] -> next -> DrawCommand px next
Fill FillMethod
method (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
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 :: (forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> Drawing px ()
withClipping forall innerPixel. Drawing innerPixel ()
clipPath Drawing px ()
drawing =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ (forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> () -> DrawCommand px ()
forall px next.
(forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> next -> DrawCommand px next
WithCliping forall innerPixel. Drawing innerPixel ()
clipPath Drawing px ()
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 :: Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
stroke Float
width Join
join (Cap, Cap)
caping geom
prims =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Float
-> Join -> (Cap, Cap) -> [Primitive] -> () -> DrawCommand px ()
forall px next.
Float
-> Join -> (Cap, Cap) -> [Primitive] -> next -> DrawCommand px next
Stroke Float
width Join
join (Cap, Cap)
caping (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
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 -> Drawing px ()
printTextAt Font
font PointSize
pointSize Point
point String
string =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Point -> [TextRange px] -> () -> DrawCommand px ()
forall px next.
Point -> [TextRange px] -> next -> DrawCommand px next
TextFill Point
point [TextRange px
description] ()
  where
    description :: TextRange px
description = TextRange :: forall px.
Font -> PointSize -> String -> Maybe (Texture px) -> TextRange px
TextRange
        { _textFont :: Font
_textFont    = Font
font
        , _textSize :: PointSize
_textSize    = PointSize
pointSize
        , _text :: String
_text        = String
string
        , _textTexture :: Maybe (Texture px)
_textTexture = Maybe (Texture px)
forall a. Maybe a
Nothing
        }

-- | Render a mesh patch as an object. Warning, there is

-- no antialiasing on mesh patch objects!

renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch PatchInterpolation
i MeshPatch px
mesh = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ PatchInterpolation -> MeshPatch px -> () -> DrawCommand px ()
forall px next.
PatchInterpolation -> MeshPatch px -> next -> DrawCommand px next
MeshPatchRender PatchInterpolation
i MeshPatch px
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 -> [TextRange px] -> Drawing px ()
printTextRanges Point
point [TextRange px]
ranges = DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Point -> [TextRange px] -> () -> DrawCommand px ()
forall px next.
Point -> [TextRange px] -> next -> DrawCommand px next
TextFill Point
point [TextRange px]
ranges ()

data RenderContext px = RenderContext
    { RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip           :: Maybe (Texture (PixelBaseComponent px))
    , RenderContext px -> Texture px
currentTexture        :: Texture px
    , RenderContext px -> Maybe (Transformation, Transformation)
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 :: Int -> Int -> px -> Drawing px () -> Image px
renderDrawing Int
width Int
height = Int -> Int -> Int -> px -> Drawing px () -> Image px
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> Image px
renderDrawingAtDpi Int
width Int
height Int
96

renderOrdersAtDpiToPdf 
    :: Int -- ^ Rendering width

    -> Int -- ^ Rendering height

    -> Dpi -- ^ Current DPI used for text rendering.

    -> [DrawOrder PixelRGBA8]  -- ^ Drawing Orders

    -> LB.ByteString
renderOrdersAtDpiToPdf :: Int -> Int -> Int -> [DrawOrder PixelRGBA8] -> ByteString
renderOrdersAtDpiToPdf Int
w Int
h Int
dpi =
  InnerRenderer
-> Int -> Int -> Int -> [DrawOrder PixelRGBA8] -> ByteString
renderOrdersToPdf forall px. RenderablePixel px => Drawing px () -> [DrawOrder px]
InnerRenderer
renderer Int
w Int
h Int
dpi
    where
      renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
      renderer :: Drawing px () -> [DrawOrder px]
renderer = Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
w Int
h Int
dpi px
forall px. RenderablePixel px => px
emptyPx

renderDrawingAtDpiToPDF
    :: Int -- ^ Rendering width

    -> Int -- ^ Rendering height

    -> Dpi -- ^ Current DPI used for text rendering.

    -> Drawing PixelRGBA8 () -- ^ Rendering action

    -> LB.ByteString
renderDrawingAtDpiToPDF :: Int -> Int -> Int -> Drawing PixelRGBA8 () -> ByteString
renderDrawingAtDpiToPDF Int
w Int
h Int
dpi Drawing PixelRGBA8 ()
d = Int -> Int -> Int -> [Drawing PixelRGBA8 ()] -> ByteString
renderDrawingsAtDpiToPDF Int
w Int
h Int
dpi [Drawing PixelRGBA8 ()
d]

renderDrawingsAtDpiToPDF
    :: Int -- ^ Rendering width

    -> Int -- ^ Rendering height

    -> Dpi -- ^ Current DPI used for text rendering.

    -> [Drawing PixelRGBA8 ()] -- ^ Rendering actions

    -> LB.ByteString
renderDrawingsAtDpiToPDF :: Int -> Int -> Int -> [Drawing PixelRGBA8 ()] -> ByteString
renderDrawingsAtDpiToPDF Int
w Int
h Int
dpi =
  InnerRenderer
-> Int -> Int -> Int -> [Drawing PixelRGBA8 ()] -> ByteString
renderDrawingsToPdf forall px. RenderablePixel px => Drawing px () -> [DrawOrder px]
InnerRenderer
renderer Int
w Int
h Int
dpi
    where
      renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]
      renderer :: Drawing px () -> [DrawOrder px]
renderer = Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
w Int
h Int
dpi px
forall px. RenderablePixel px => px
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 :: Int -> Int -> Int -> px -> Drawing px () -> Image px
renderDrawingAtDpi Int
width Int
height Int
dpi px
background Drawing px ()
drawing =
    (forall s. ST s (Image px)) -> Image px
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Image px)) -> Image px)
-> (forall s. ST s (Image px)) -> Image px
forall a b. (a -> b) -> a -> b
$ Int -> Int -> px -> DrawContext (ST s) px () -> ST s (Image px)
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
Int -> Int -> px -> DrawContext m px () -> m (Image px)
runDrawContext Int
width Int
height px
background
          (DrawContext (ST s) px () -> ST s (Image px))
-> DrawContext (ST s) px () -> ST s (Image px)
forall a b. (a -> b) -> a -> b
$ (DrawOrder px -> StateT (MutableImage s px) (ST s) ())
-> [DrawOrder px] -> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DrawOrder px -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
DrawOrder px -> DrawContext m px ()
fillOrder
          ([DrawOrder px] -> StateT (MutableImage s px) (ST s) ())
-> [DrawOrder px] -> StateT (MutableImage s px) (ST s) ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
width Int
height Int
dpi px
background Drawing px ()
drawing

cacheOrders :: forall px. (RenderablePixel px)
            => Maybe (Image px -> ImageTransformer px)
            -> Int -- ^ width

            -> Int -- ^ Height

            -> [DrawOrder px] -> Drawing px ()
cacheOrders :: Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
cacheOrders Maybe (Image px -> ImageTransformer px)
imageFilter Int
maxWidth Int
maxHeight [DrawOrder px]
orders = case Maybe (Image px -> ImageTransformer px)
imageFilter of
    Maybe (Image px -> ImageTransformer px)
Nothing -> Image px -> Float -> Point -> Float -> Float -> Drawing px ()
forall px.
Image px -> Float -> Point -> Float -> Float -> Drawing px ()
drawImageAtSize Image px
resultImage Float
0 Point
cornerUpperLeft Float
width Float
height
    Just Image px -> ImageTransformer px
f -> Image px -> Float -> Point -> Drawing px ()
forall px. Image px -> Float -> Point -> Drawing px ()
drawImage (ImageTransformer px -> Image px -> Image px
forall a b.
(Pixel a, Pixel b) =>
(Int -> Int -> a -> b) -> Image a -> Image b
pixelMapXY (Image px -> ImageTransformer px
f Image px
resultImage) Image px
resultImage) Float
0 Point
cornerUpperLeft
  where
   PlaneBound Point
mini Point
maxi = (DrawOrder px -> PlaneBound) -> [DrawOrder px] -> PlaneBound
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DrawOrder px -> PlaneBound
forall a. PlaneBoundable a => a -> PlaneBound
planeBounds [DrawOrder px]
orders
   cornerUpperLeftInt :: V2 Int
cornerUpperLeftInt = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int) -> Point -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point
mini :: V2 Int
   cornerUpperLeft :: Point
cornerUpperLeft = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Float) -> V2 Int -> Point
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Int
cornerUpperLeftInt

   V2 Float
width Float
height = Float -> Float -> Float
forall a. Ord a => a -> a -> a
min (Float -> Float -> Float) -> Point -> V2 (Float -> Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Point
maxi Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
cornerUpperLeft Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
1 Float
1)
                         V2 (Float -> Float) -> Point -> Point
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxWidth) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxHeight))
   
   shiftOrder :: DrawOrder px -> DrawOrder px
shiftOrder order :: DrawOrder px
order@DrawOrder { _orderPrimitives :: forall px. DrawOrder px -> [[Primitive]]
_orderPrimitives = [[Primitive]]
prims } =
       DrawOrder px
order { _orderPrimitives :: [[Primitive]]
_orderPrimitives = (Primitive -> Primitive) -> [Primitive] -> [Primitive]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point -> Point) -> Primitive -> Primitive
forall a. Transformable a => (Point -> Point) -> a -> a
transform (Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
cornerUpperLeft)) ([Primitive] -> [Primitive]) -> [[Primitive]] -> [[Primitive]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Primitive]]
prims 
             , _orderTexture :: Texture px
_orderTexture =
                 Transformation -> Texture px -> Texture px
forall px. Transformation -> Texture px -> Texture px
WithTextureTransform (Point -> Transformation
translate Point
cornerUpperLeft) (Texture px -> Texture px) -> Texture px -> Texture px
forall a b. (a -> b) -> a -> b
$ DrawOrder px -> Texture px
forall px. DrawOrder px -> Texture px
_orderTexture DrawOrder px
order
             , _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask =
                 Transformation
-> Texture (PixelBaseComponent px)
-> Texture (PixelBaseComponent px)
forall px. Transformation -> Texture px -> Texture px
WithTextureTransform (Point -> Transformation
translate Point
cornerUpperLeft) (Texture (PixelBaseComponent px)
 -> Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DrawOrder px -> Maybe (Texture (PixelBaseComponent px))
forall px. DrawOrder px -> Maybe (Texture (PixelBaseComponent px))
_orderMask DrawOrder px
order
             }
   
   resultImage :: Image px
resultImage =
     (forall s. ST s (Image px)) -> Image px
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Image px)) -> Image px)
-> (forall s. ST s (Image px)) -> Image px
forall a b. (a -> b) -> a -> b
$ Int -> Int -> px -> DrawContext (ST s) px () -> ST s (Image px)
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
Int -> Int -> px -> DrawContext m px () -> m (Image px)
runDrawContext (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
width) (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
height) px
forall px. RenderablePixel px => px
emptyPx
           (DrawContext (ST s) px () -> ST s (Image px))
-> DrawContext (ST s) px () -> ST s (Image px)
forall a b. (a -> b) -> a -> b
$ (DrawOrder px -> StateT (MutableImage s px) (ST s) ())
-> [DrawOrder px] -> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DrawOrder px -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
DrawOrder px -> DrawContext m px ()
fillOrder (DrawOrder px -> StateT (MutableImage s px) (ST s) ())
-> (DrawOrder px -> DrawOrder px)
-> DrawOrder px
-> StateT (MutableImage s px) (ST s) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawOrder px -> DrawOrder px
shiftOrder) [DrawOrder px]
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 :: Int -> Int -> Int -> Drawing px () -> Drawing px ()
cacheDrawing Int
maxWidth Int
maxHeight Int
dpi Drawing px ()
sub =
  Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
forall px.
RenderablePixel px =>
Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
cacheOrders Maybe (Image px -> ImageTransformer px)
forall a. Maybe a
Nothing Int
maxWidth Int
maxHeight ([DrawOrder px] -> Drawing px ())
-> [DrawOrder px] -> Drawing px ()
forall a b. (a -> b) -> a -> b
$
    Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
forall px.
RenderablePixel px =>
Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
maxWidth Int
maxHeight Int
dpi px
forall px. RenderablePixel px => px
emptyPx Drawing px ()
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 :: Int -> Int -> Int -> px -> Drawing px () -> [DrawOrder px]
drawOrdersOfDrawing Int
width Int
height Int
dpi px
background Drawing px ()
drawing =
    RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
initialContext (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
drawing) []
  where
    initialContext :: RenderContext px
initialContext = Maybe (Texture (PixelBaseComponent px))
-> Texture px
-> Maybe (Transformation, Transformation)
-> RenderContext px
forall px.
Maybe (Texture (PixelBaseComponent px))
-> Texture px
-> Maybe (Transformation, Transformation)
-> RenderContext px
RenderContext Maybe (Texture (PixelBaseComponent px))
forall a. Maybe a
Nothing Texture px
stupidDefaultTexture Maybe (Transformation, Transformation)
forall a. Maybe a
Nothing
    clipBackground :: PixelBaseComponent px
clipBackground = PixelBaseComponent px
forall a. Modulable a => a
emptyValue :: PixelBaseComponent px
    clipForeground :: PixelBaseComponent px
clipForeground = PixelBaseComponent px
forall a. Modulable a => a
fullValue :: PixelBaseComponent px

    clipRender :: RenderContext px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
clipRender RenderContext px
ctxt =
      Int
-> Int
-> PixelBaseComponent px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
forall px.
RenderablePixel px =>
Int -> Int -> px -> Drawing px () -> Image px
renderDrawing Int
width Int
height PixelBaseComponent px
clipBackground (Drawing (PixelBaseComponent px) ()
 -> Image (PixelBaseComponent px))
-> (Drawing (PixelBaseComponent px) ()
    -> Drawing (PixelBaseComponent px) ())
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
        Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
transformer (Drawing (PixelBaseComponent px) ()
 -> Drawing (PixelBaseComponent px) ())
-> (Drawing (PixelBaseComponent px) ()
    -> Drawing (PixelBaseComponent px) ())
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Texture (PixelBaseComponent px)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall px. Texture px -> Drawing px () -> Drawing px ()
withTexture (PixelBaseComponent px -> Texture (PixelBaseComponent px)
forall px. px -> Texture px
SolidTexture PixelBaseComponent px
clipForeground)
       where 
         transformer :: Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
transformer = (Drawing (PixelBaseComponent px) ()
 -> Drawing (PixelBaseComponent px) ())
-> ((Transformation, Transformation)
    -> Drawing (PixelBaseComponent px) ()
    -> Drawing (PixelBaseComponent px) ())
-> Maybe (Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall a. a -> a
id (Transformation
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall px. Transformation -> Drawing px () -> Drawing px ()
withTransformation (Transformation
 -> Drawing (PixelBaseComponent px) ()
 -> Drawing (PixelBaseComponent px) ())
-> ((Transformation, Transformation) -> Transformation)
-> (Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Transformation, Transformation) -> Transformation
forall a b. (a, b) -> a
fst) (Maybe (Transformation, Transformation)
 -> Drawing (PixelBaseComponent px) ()
 -> Drawing (PixelBaseComponent px) ())
-> Maybe (Transformation, Transformation)
-> Drawing (PixelBaseComponent px) ()
-> Drawing (PixelBaseComponent px) ()
forall a b. (a -> b) -> a -> b
$ RenderContext px -> Maybe (Transformation, Transformation)
forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation RenderContext px
ctxt


    subRender :: (forall s. DrawContext (ST s) px ()) -> Image px
    subRender :: (forall s. DrawContext (ST s) px ()) -> Image px
subRender forall s. DrawContext (ST s) px ()
act =
      (forall s. ST s (Image px)) -> Image px
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Image px)) -> Image px)
-> (forall s. ST s (Image px)) -> Image px
forall a b. (a -> b) -> a -> b
$ Int -> Int -> px -> DrawContext (ST s) px () -> ST s (Image px)
forall (m :: * -> *) px.
(PrimMonad m, RenderablePixel px) =>
Int -> Int -> px -> DrawContext m px () -> m (Image px)
runDrawContext Int
width Int
height px
background DrawContext (ST s) px ()
forall s. DrawContext (ST s) px ()
act

    textureOf :: RenderContext px -> Texture px
textureOf ctxt :: RenderContext px
ctxt@RenderContext { currentTransformation :: forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation = Just (Transformation
_, Transformation
t) } =
        Transformation -> Texture px -> Texture px
forall px. Transformation -> Texture px -> Texture px
WithTextureTransform Transformation
t (Texture px -> Texture px) -> Texture px -> Texture px
forall a b. (a -> b) -> a -> b
$ RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
currentTexture RenderContext px
ctxt
    textureOf RenderContext px
ctxt = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
currentTexture RenderContext px
ctxt

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

    geometryOfO :: RenderContext px -> DrawOrder px -> DrawOrder px
geometryOfO RenderContext { currentTransformation :: forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation = Just (Transformation
trans, Transformation
_) } =
        (Point -> Point) -> DrawOrder px -> DrawOrder px
forall px. (Point -> Point) -> DrawOrder px -> DrawOrder px
transformOrder (Transformation -> Point -> Point
applyTransformation Transformation
trans)
    geometryOfO RenderContext px
_ = DrawOrder px -> DrawOrder px
forall a. a -> a
id

    stupidDefaultTexture :: Texture px
stupidDefaultTexture =
        px -> Texture px
forall px. px -> Texture px
SolidTexture (px -> Texture px) -> px -> Texture px
forall a b. (a -> b) -> a -> b
$ (PixelBaseComponent px -> PixelBaseComponent px) -> px -> px
forall a.
Pixel a =>
(PixelBaseComponent a -> PixelBaseComponent a) -> a -> a
colorMap (PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a b. a -> b -> a
const PixelBaseComponent px
clipBackground) px
background

    orderOf :: RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
orderOf RenderContext px
ctxt FillMethod
method [[Primitive]]
primitives = DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder 
        { _orderPrimitives :: [[Primitive]]
_orderPrimitives = [[Primitive]]
primitives
        , _orderTexture :: Texture px
_orderTexture    = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
textureOf RenderContext px
ctxt
        , _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
method
        , _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask       = RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt
        , _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect     = () -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        }

    go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px]
       -> [DrawOrder px]
    go :: RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
_ (Pure ()) [DrawOrder px]
rest = [DrawOrder px]
rest
    go RenderContext px
ctxt (Free (WithGlobalOpacity PixelBaseComponent px
opa Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
        RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (DrawCommand px (Free (DrawCommand px) ())
-> Free (DrawCommand px) ()
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free ((Image px -> ImageTransformer px)
-> Drawing px ()
-> Free (DrawCommand px) ()
-> DrawCommand px (Free (DrawCommand px) ())
forall px next.
(Image px -> ImageTransformer px)
-> Drawing px () -> next -> DrawCommand px next
WithImageEffect Image px -> ImageTransformer px
opacifier Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest
      where 
        -- Todo: a colorMapWithAlpha is really needed in JP API.

        opacifier :: Image px -> ImageTransformer px
opacifier Image px
_ Int
_ Int
_ px
px = (Int
 -> PixelBaseComponent px
 -> PixelBaseComponent px
 -> PixelBaseComponent px)
-> (PixelBaseComponent px
    -> PixelBaseComponent px -> PixelBaseComponent px)
-> px
-> px
-> px
forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> (PixelBaseComponent a
    -> PixelBaseComponent a -> PixelBaseComponent a)
-> a
-> a
-> a
mixWithAlpha Int
-> PixelBaseComponent px
-> PixelBaseComponent px
-> PixelBaseComponent px
forall p p p. p -> p -> p -> p
ignore PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
alphaModulate px
px px
px
        ignore :: p -> p -> p -> p
ignore p
_ p
_ p
a = p
a
        alphaModulate :: PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
alphaModulate PixelBaseComponent px
_ PixelBaseComponent px
v = PixelBaseComponent px
opa PixelBaseComponent px
-> PixelBaseComponent px -> PixelBaseComponent px
forall a. Modulable a => a -> a -> a
`modulate` PixelBaseComponent px
v

    go RenderContext px
ctxt (Free (WithImageEffect Image px -> ImageTransformer px
effect Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
        RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
freeContext (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
cached) [DrawOrder px]
after
      where
        cached :: Drawing px ()
cached = Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
forall px.
RenderablePixel px =>
Maybe (Image px -> ImageTransformer px)
-> Int -> Int -> [DrawOrder px] -> Drawing px ()
cacheOrders ((Image px -> ImageTransformer px)
-> Maybe (Image px -> ImageTransformer px)
forall a. a -> Maybe a
Just Image px -> ImageTransformer px
effect) Int
forall a. Bounded a => a
maxBound Int
forall a. Bounded a => a
maxBound ([DrawOrder px] -> Drawing px ())
-> [DrawOrder px] -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) []
        after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
        freeContext :: RenderContext px
freeContext = RenderContext px
ctxt { currentClip :: Maybe (Texture (PixelBaseComponent px))
currentClip = Maybe (Texture (PixelBaseComponent px))
forall a. Maybe a
Nothing, currentTransformation :: Maybe (Transformation, Transformation)
currentTransformation = Maybe (Transformation, Transformation)
forall a. Maybe a
Nothing }


    go RenderContext px
ctxt (Free (WithPathOrientation Path
path Float
base Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = [DrawOrder px]
final where
      final :: [DrawOrder px]
final = [DrawOrder px]
orders [DrawOrder px] -> [DrawOrder px] -> [DrawOrder px]
forall a. Semigroup a => a -> a -> a
<> RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
      images :: [DrawOrder px]
images = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) []

      drawer :: Transformation -> p -> DrawOrder px -> m ()
drawer Transformation
trans p
_ DrawOrder px
order =
        ([DrawOrder px] -> [DrawOrder px]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Point -> Point) -> DrawOrder px -> DrawOrder px
forall px. (Point -> Point) -> DrawOrder px -> DrawOrder px
transformOrder (Transformation -> Point -> Point
applyTransformation Transformation
trans) DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
:)

      orders :: [DrawOrder px]
orders = [DrawOrder px] -> [DrawOrder px]
forall a. [a] -> [a]
reverse ([DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$ State [DrawOrder px] () -> [DrawOrder px] -> [DrawOrder px]
forall s a. State s a -> s -> s
execState (PathDrawer (StateT [DrawOrder px] Identity) px
-> Float
-> Float
-> Path
-> [DrawOrder px]
-> State [DrawOrder px] ()
forall (m :: * -> *) px.
Monad m =>
PathDrawer m px -> Float -> Float -> Path -> [DrawOrder px] -> m ()
drawOrdersOnPath PathDrawer (StateT [DrawOrder px] Identity) px
forall px (m :: * -> *) p.
MonadState [DrawOrder px] m =>
Transformation -> p -> DrawOrder px -> m ()
drawer Float
0 Float
base Path
path [DrawOrder px]
images) []

    go RenderContext px
ctxt (Free (WithTransform Transformation
trans Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = [DrawOrder px]
final where
      trans' :: Transformation
trans'
        | Just (Transformation
t, Transformation
_) <- RenderContext px -> Maybe (Transformation, Transformation)
forall px.
RenderContext px -> Maybe (Transformation, Transformation)
currentTransformation RenderContext px
ctxt = Transformation
t Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
trans
        | Bool
otherwise = Transformation
trans
      invTrans :: Transformation
invTrans = Transformation -> Maybe Transformation -> Transformation
forall a. a -> Maybe a -> a
fromMaybe Transformation
forall a. Monoid a => a
mempty (Maybe Transformation -> Transformation)
-> Maybe Transformation -> Transformation
forall a b. (a -> b) -> a -> b
$ Transformation -> Maybe Transformation
inverseTransformation Transformation
trans'
      after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
      subContext :: RenderContext px
subContext =
          RenderContext px
ctxt { currentTransformation :: Maybe (Transformation, Transformation)
currentTransformation = (Transformation, Transformation)
-> Maybe (Transformation, Transformation)
forall a. a -> Maybe a
Just (Transformation
trans', Transformation
invTrans) }

      final :: [DrawOrder px]
final = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
subContext (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) [DrawOrder px]
after

    go RenderContext px
ctxt (Free (CustomRender forall s. DrawContext (ST s) px ()
cust Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
      after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
      order :: DrawOrder px
order = DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder 
            { _orderPrimitives :: [[Primitive]]
_orderPrimitives = []
            , _orderTexture :: Texture px
_orderTexture    = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
textureOf RenderContext px
ctxt
            , _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
FillWinding
            , _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask       = RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt
            , _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect     = forall s. DrawContext (ST s) px ()
cust
            }

    go RenderContext px
ctxt (Free (MeshPatchRender PatchInterpolation
i MeshPatch px
mesh Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
      after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
      rendering :: DrawContext (ST s) px ()
      rendering :: DrawContext (ST s) px ()
rendering = case PatchInterpolation
i of
        PatchInterpolation
PatchBilinear -> (CoonPatch (ParametricValues px)
 -> StateT (MutableImage s px) (ST s) ())
-> [CoonPatch (ParametricValues px)]
-> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoonPatch (ParametricValues px)
-> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px src.
(PrimMonad m, ModulablePixel px, BiSampleable src px) =>
CoonPatch src -> DrawContext m px ()
rasterizeCoonPatch ([CoonPatch (ParametricValues px)]
 -> StateT (MutableImage s px) (ST s) ())
-> [CoonPatch (ParametricValues px)]
-> StateT (MutableImage s px) (ST s) ()
forall a b. (a -> b) -> a -> b
$ MeshPatch px -> [CoonPatch (ParametricValues px)]
forall px. MeshPatch px -> [CoonPatch (ParametricValues px)]
coonPatchesOf (MeshPatch px -> [CoonPatch (ParametricValues px)])
-> MeshPatch px -> [CoonPatch (ParametricValues px)]
forall a b. (a -> b) -> a -> b
$ RenderContext px -> MeshPatch px -> MeshPatch px
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt MeshPatch px
opaqueMesh 
        PatchInterpolation
PatchBicubic ->
            (CoonPatch (CubicCoefficient px)
 -> StateT (MutableImage s px) (ST s) ())
-> [CoonPatch (CubicCoefficient px)]
-> StateT (MutableImage s px) (ST s) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoonPatch (CubicCoefficient px)
-> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) px src.
(PrimMonad m, ModulablePixel px, BiSampleable src px) =>
CoonPatch src -> DrawContext m px ()
rasterizeCoonPatch
                ([CoonPatch (CubicCoefficient px)]
 -> StateT (MutableImage s px) (ST s) ())
-> (MeshPatch (Derivative px) -> [CoonPatch (CubicCoefficient px)])
-> MeshPatch (Derivative px)
-> StateT (MutableImage s px) (ST s) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MeshPatch (Derivative px) -> [CoonPatch (CubicCoefficient px)]
forall px.
InterpolablePixel px =>
MeshPatch (Derivative px) -> [CoonPatch (CubicCoefficient px)]
cubicCoonPatchesOf 
                (MeshPatch (Derivative px) -> StateT (MutableImage s px) (ST s) ())
-> MeshPatch (Derivative px)
-> StateT (MutableImage s px) (ST s) ()
forall a b. (a -> b) -> a -> b
$ MeshPatch px -> MeshPatch (Derivative px)
forall px.
InterpolablePixel px =>
MeshPatch px -> MeshPatch (Derivative px)
calculateMeshColorDerivative (MeshPatch px -> MeshPatch (Derivative px))
-> MeshPatch px -> MeshPatch (Derivative px)
forall a b. (a -> b) -> a -> b
$ RenderContext px -> MeshPatch px -> MeshPatch px
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt MeshPatch px
opaqueMesh 

      hasTransparency :: Bool
hasTransparency =
          (px -> Bool) -> Vector px -> Bool
forall a. (a -> Bool) -> Vector a -> Bool
V.any ((PixelBaseComponent px -> PixelBaseComponent px -> Bool
forall a. Eq a => a -> a -> Bool
/= PixelBaseComponent px
forall a. Modulable a => a
fullValue) (PixelBaseComponent px -> Bool)
-> (px -> PixelBaseComponent px) -> px -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity) (Vector px -> Bool) -> Vector px -> Bool
forall a b. (a -> b) -> a -> b
$ MeshPatch px -> Vector px
forall px. MeshPatch px -> Vector px
_meshColors MeshPatch px
mesh

      opacifier :: a -> a
opacifier a
px = (Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> (PixelBaseComponent a
    -> PixelBaseComponent a -> PixelBaseComponent a)
-> a
-> a
-> a
forall a.
Pixel a =>
(Int
 -> PixelBaseComponent a
 -> PixelBaseComponent a
 -> PixelBaseComponent a)
-> (PixelBaseComponent a
    -> PixelBaseComponent a -> PixelBaseComponent a)
-> a
-> a
-> a
mixWithAlpha (\Int
_ PixelBaseComponent a
_ PixelBaseComponent a
a -> PixelBaseComponent a
a) (\PixelBaseComponent a
_ PixelBaseComponent a
_ -> PixelBaseComponent a
forall a. Modulable a => a
fullValue) a
px a
px

      opaqueMesh :: MeshPatch px
opaqueMesh = px -> px
forall a. (Pixel a, Modulable (PixelBaseComponent a)) => a -> a
opacifier (px -> px) -> MeshPatch px -> MeshPatch px
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MeshPatch px
mesh
      transparencyMesh :: MeshPatch (PixelBaseComponent px)
transparencyMesh = px -> PixelBaseComponent px
forall a. Pixel a => a -> PixelBaseComponent a
pixelOpacity (px -> PixelBaseComponent px)
-> MeshPatch px -> MeshPatch (PixelBaseComponent px)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MeshPatch px
mesh

      clipPath :: Maybe (Texture (PixelBaseComponent px))
clipPath
        | Bool -> Bool
not Bool
hasTransparency = RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt
        | Bool
otherwise =
            let newMask :: Image (PixelBaseComponent (PixelBaseComponent px))
                newMask :: Image (PixelBaseComponent (PixelBaseComponent px))
newMask = RenderContext px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
clipRender RenderContext px
ctxt (Drawing (PixelBaseComponent px) ()
 -> Image (PixelBaseComponent px))
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
forall a b. (a -> b) -> a -> b
$ PatchInterpolation
-> MeshPatch (PixelBaseComponent px)
-> Drawing (PixelBaseComponent px) ()
forall px. PatchInterpolation -> MeshPatch px -> Drawing px ()
renderMeshPatch PatchInterpolation
i MeshPatch (PixelBaseComponent px)
transparencyMesh in
            case RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt of
              Maybe (Texture (PixelBaseComponent px))
Nothing -> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a. a -> Maybe a
Just (Texture (PixelBaseComponent px)
 -> Maybe (Texture (PixelBaseComponent px)))
-> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a b. (a -> b) -> a -> b
$ Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall px. Image px -> Texture px
RawTexture Image (PixelBaseComponent px)
Image (PixelBaseComponent (PixelBaseComponent px))
newMask
              Just Texture (PixelBaseComponent px)
v -> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a. a -> Maybe a
Just (Texture (PixelBaseComponent px)
 -> Maybe (Texture (PixelBaseComponent px)))
-> Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a b. (a -> b) -> a -> b
$ Texture (PixelBaseComponent px)
-> Texture (PixelBaseComponent (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
forall px.
Texture px -> Texture (PixelBaseComponent px) -> Texture px
ModulateTexture Texture (PixelBaseComponent px)
v (Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall px. Image px -> Texture px
RawTexture Image (PixelBaseComponent px)
Image (PixelBaseComponent (PixelBaseComponent px))
newMask)

      order :: DrawOrder px
order = case Maybe (Texture (PixelBaseComponent px))
clipPath of
        -- Good, we can directly render on the final canvas

        Maybe (Texture (PixelBaseComponent px))
Nothing -> DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder 
            { _orderPrimitives :: [[Primitive]]
_orderPrimitives = []
            , _orderTexture :: Texture px
_orderTexture    = RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
textureOf RenderContext px
ctxt
            , _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
FillWinding
            , _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask       = Maybe (Texture (PixelBaseComponent px))
clipPath
            , _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect     = forall s. DrawContext (ST s) px ()
rendering
            }
        Just Texture (PixelBaseComponent px)
c -> DrawOrder :: forall px.
[[Primitive]]
-> Texture px
-> FillMethod
-> Maybe (Texture (PixelBaseComponent px))
-> (forall s. DrawContext (ST s) px ())
-> DrawOrder px
DrawOrder
            { _orderPrimitives :: [[Primitive]]
_orderPrimitives = [RenderContext px -> [Primitive] -> [Primitive]
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt ([Primitive] -> [Primitive]) -> [Primitive] -> [Primitive]
forall a b. (a -> b) -> a -> b
$ Point -> Float -> Float -> [Primitive]
rectangle (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
0 Float
0) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)]
            , _orderTexture :: Texture px
_orderTexture    = Texture px -> Texture (PixelBaseComponent px) -> Texture px
forall px.
Texture px -> Texture (PixelBaseComponent px) -> Texture px
AlphaModulateTexture (Image px -> Texture px
forall px. Image px -> Texture px
RawTexture (Image px -> Texture px) -> Image px -> Texture px
forall a b. (a -> b) -> a -> b
$ (forall s. DrawContext (ST s) px ()) -> Image px
subRender forall s. DrawContext (ST s) px ()
rendering) Texture (PixelBaseComponent px)
c
            , _orderFillMethod :: FillMethod
_orderFillMethod = FillMethod
FillWinding
            , _orderMask :: Maybe (Texture (PixelBaseComponent px))
_orderMask       = Maybe (Texture (PixelBaseComponent px))
forall a. Maybe a
Nothing
            , _orderDirect :: forall s. DrawContext (ST s) px ()
_orderDirect     = () -> StateT (MutableImage s px) (ST s) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            }

    go RenderContext px
ctxt (Free (Fill FillMethod
method [Primitive]
prims Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
      after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
      order :: DrawOrder px
order = RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
forall px.
RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
orderOf RenderContext px
ctxt FillMethod
method [RenderContext px -> [Primitive] -> [Primitive]
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt [Primitive]
prims [Primitive] -> (Primitive -> [Primitive]) -> [Primitive]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer (Container Primitive -> [Primitive])
-> (Primitive -> Container Primitive) -> Primitive -> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Primitive -> Container Primitive
sanitizeFilling]

    go RenderContext px
ctxt (Free (Stroke Float
w Join
j (Cap, Cap)
cap [Primitive]
prims Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = DrawOrder px
order DrawOrder px -> [DrawOrder px] -> [DrawOrder px]
forall a. a -> [a] -> [a]
: [DrawOrder px]
after where
      after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
      order :: DrawOrder px
order = RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
forall px.
RenderContext px -> FillMethod -> [[Primitive]] -> DrawOrder px
orderOf RenderContext px
ctxt FillMethod
FillWinding [RenderContext px -> [Primitive] -> [Primitive]
forall a. Transformable a => RenderContext px -> a -> a
geometryOf RenderContext px
ctxt [Primitive]
prim']
      prim' :: [Primitive]
prim' = Container Primitive -> [Primitive]
forall a. Container a -> [a]
listOfContainer (Container Primitive -> [Primitive])
-> Container Primitive -> [Primitive]
forall a b. (a -> b) -> a -> b
$ Float -> Join -> (Cap, Cap) -> [Primitive] -> Container Primitive
forall geom.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Container Primitive
strokize Float
w Join
j (Cap, Cap)
cap [Primitive]
prims

    go RenderContext px
ctxt (Free (SetTexture Texture px
tx Drawing px ()
sub Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
        RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go (RenderContext px
ctxt { currentTexture :: Texture px
currentTexture = Texture px
tx }) (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) ([DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$
            RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest

    go RenderContext px
ctxt (Free (DashedStroke Float
o DashPattern
d Float
w Join
j (Cap, Cap)
cap [Primitive]
prims Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
        ([Primitive] -> [DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [[Primitive]] -> [DrawOrder px]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Primitive] -> [DrawOrder px] -> [DrawOrder px]
recurse [DrawOrder px]
after ([[Primitive]] -> [DrawOrder px])
-> [[Primitive]] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$ Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> [[Primitive]]
forall geom.
Geometry geom =>
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> [[Primitive]]
dashedStrokize Float
o DashPattern
d Float
w Join
j (Cap, Cap)
cap [Primitive]
prims
      where
        after :: [DrawOrder px]
after = RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
        recurse :: [Primitive] -> [DrawOrder px] -> [DrawOrder px]
recurse [Primitive]
sub =
            RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt (DrawCommand px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Free (DrawCommand px) ())
-> DrawCommand px () -> Free (DrawCommand px) ()
forall a b. (a -> b) -> a -> b
$ FillMethod -> [Primitive] -> () -> DrawCommand px ()
forall px next.
FillMethod -> [Primitive] -> next -> DrawCommand px next
Fill FillMethod
FillWinding [Primitive]
sub ())

    go RenderContext px
ctxt (Free (TextFill Point
p [TextRange px]
descriptions Free (DrawCommand px) ()
next)) [DrawOrder px]
rest = [DrawOrder px]
calls [DrawOrder px] -> [DrawOrder px] -> [DrawOrder px]
forall a. Semigroup a => a -> a -> a
<> RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest where
      calls :: [DrawOrder px]
calls =
        RenderContext px -> DrawOrder px -> DrawOrder px
forall px px. RenderContext px -> DrawOrder px -> DrawOrder px
geometryOfO RenderContext px
ctxt (DrawOrder px -> DrawOrder px) -> [DrawOrder px] -> [DrawOrder px]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Texture px -> Point -> [TextRange px] -> [DrawOrder px]
forall px.
Int -> Texture px -> Point -> [TextRange px] -> [DrawOrder px]
textToDrawOrders Int
dpi (RenderContext px -> Texture px
forall px. RenderContext px -> Texture px
currentTexture RenderContext px
ctxt) Point
p [TextRange px]
descriptions

    go RenderContext px
ctxt (Free (WithCliping forall innerPixel. Drawing innerPixel ()
clipPath Drawing px ()
path Free (DrawCommand px) ()
next)) [DrawOrder px]
rest =
        RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go (RenderContext px
ctxt { currentClip :: Maybe (Texture (PixelBaseComponent px))
currentClip = Maybe (Texture (PixelBaseComponent px))
newModuler }) (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
path) ([DrawOrder px] -> [DrawOrder px])
-> [DrawOrder px] -> [DrawOrder px]
forall a b. (a -> b) -> a -> b
$
            RenderContext px
-> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px]
go RenderContext px
ctxt Free (DrawCommand px) ()
next [DrawOrder px]
rest
      where
        modulationTexture :: Texture (PixelBaseComponent px)
        modulationTexture :: Texture (PixelBaseComponent px)
modulationTexture = Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall px. Image px -> Texture px
RawTexture (Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px))
-> Image (PixelBaseComponent px) -> Texture (PixelBaseComponent px)
forall a b. (a -> b) -> a -> b
$ RenderContext px
-> Drawing (PixelBaseComponent px) ()
-> Image (PixelBaseComponent px)
clipRender RenderContext px
ctxt Drawing (PixelBaseComponent px) ()
forall innerPixel. Drawing innerPixel ()
clipPath

        newModuler :: Maybe (Texture (PixelBaseComponent px))
newModuler = Texture (PixelBaseComponent px)
-> Maybe (Texture (PixelBaseComponent px))
forall a. a -> Maybe a
Just (Texture (PixelBaseComponent px)
 -> Maybe (Texture (PixelBaseComponent px)))
-> (Maybe (Texture (PixelBaseComponent px))
    -> Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Texture (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
subModuler (Maybe (Texture (PixelBaseComponent px))
 -> Maybe (Texture (PixelBaseComponent px)))
-> Maybe (Texture (PixelBaseComponent px))
-> Maybe (Texture (PixelBaseComponent px))
forall a b. (a -> b) -> a -> b
$ RenderContext px -> Maybe (Texture (PixelBaseComponent px))
forall px.
RenderContext px -> Maybe (Texture (PixelBaseComponent px))
currentClip RenderContext px
ctxt

        subModuler :: Maybe (Texture (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
subModuler Maybe (Texture (PixelBaseComponent px))
Nothing = Texture (PixelBaseComponent px)
modulationTexture
        subModuler (Just Texture (PixelBaseComponent px)
v) =
            Texture (PixelBaseComponent px)
-> Texture (PixelBaseComponent (PixelBaseComponent px))
-> Texture (PixelBaseComponent px)
forall px.
Texture px -> Texture (PixelBaseComponent px) -> Texture px
ModulateTexture Texture (PixelBaseComponent px)
v Texture (PixelBaseComponent px)
Texture (PixelBaseComponent (PixelBaseComponent px))
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 :: DashPattern -> Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
dashedStroke = Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
forall geom px.
Geometry geom =>
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStrokeWithOffset Float
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 :: Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> geom
-> Drawing px ()
dashedStrokeWithOffset Float
_ [] Float
width Join
join (Cap, Cap)
caping geom
prims =
    Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
forall geom px.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
stroke Float
width Join
join (Cap, Cap)
caping geom
prims
dashedStrokeWithOffset Float
offset DashPattern
dashing Float
width Join
join (Cap, Cap)
caping geom
prims =
    DrawCommand px () -> Drawing px ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> Drawing px ())
-> DrawCommand px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> ()
-> DrawCommand px ()
forall px next.
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> next
-> DrawCommand px next
DashedStroke Float
offset DashPattern
dashing Float
width Join
join (Cap, Cap)
caping (geom -> [Primitive]
forall a. Geometry a => a -> [Primitive]
toPrimitives geom
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 :: [Point] -> [Primitive]
polyline = (Line -> Primitive) -> [Line] -> [Primitive]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Primitive
LinePrim ([Line] -> [Primitive])
-> ([Point] -> [Line]) -> [Point] -> [Primitive]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> [Line]
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 :: [Point] -> [Primitive]
polygon [] = []
polygon [Point
_] = []
polygon [Point
_,Point
_] = []
polygon lst :: [Point]
lst@(Point
p:[Point]
_) = [Point] -> [Primitive]
polyline ([Point] -> [Primitive]) -> [Point] -> [Primitive]
forall a b. (a -> b) -> a -> b
$ [Point]
lst [Point] -> [Point] -> [Point]
forall a. [a] -> [a] -> [a]
++ [Point
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 :: Image px -> Float -> Point -> Drawing px ()
drawImage img :: Image px
img@Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h } Float
s Point
p =
    Image px -> Float -> Point -> Float -> Float -> Drawing px ()
forall px.
Image px -> Float -> Point -> Float -> Float -> Drawing px ()
drawImageAtSize Image px
img Float
s Point
p (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 :: Image px -> Float -> Point -> Float -> Float -> Drawing px ()
drawImageAtSize img :: Image px
img@Image { imageWidth :: forall a. Image a -> Int
imageWidth = Int
w, imageHeight :: forall a. Image a -> Int
imageHeight = Int
h } Float
borderSize Point
ip
            Float
reqWidth Float
reqHeight
    | Float
borderSize Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 =
        Transformation -> Drawing px () -> Drawing px ()
forall px. Transformation -> Drawing px () -> Drawing px ()
withTransformation (Point -> Transformation
translate Point
p Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Float -> Float -> Transformation
scale Float
scaleX Float
scaleY) (Drawing px () -> Drawing px ())
-> (Drawing px () -> Drawing px ())
-> Drawing px ()
-> Drawing px ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            Texture px -> Drawing px () -> Drawing px ()
forall px. Texture px -> Drawing px () -> Drawing px ()
withTexture (Image px -> Texture px
forall px. Image px -> Texture px
SampledTexture Image px
img) (Drawing px () -> Drawing px ()) -> Drawing px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ [Primitive] -> Drawing px ()
forall geom px. Geometry geom => geom -> Drawing px ()
fill [Primitive]
rect
    | Bool
otherwise = do
        Transformation -> Drawing px () -> Drawing px ()
forall px. Transformation -> Drawing px () -> Drawing px ()
withTransformation (Point -> Transformation
translate Point
p Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Float -> Float -> Transformation
scale Float
scaleX Float
scaleY) (Drawing px () -> Drawing px ()) -> Drawing px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$
            Texture px -> Drawing px () -> Drawing px ()
forall px. Texture px -> Drawing px () -> Drawing px ()
withTexture (Image px -> Texture px
forall px. Image px -> Texture px
SampledTexture Image px
img) (Drawing px () -> Drawing px ()) -> Drawing px () -> Drawing px ()
forall a b. (a -> b) -> a -> b
$ [Primitive] -> Drawing px ()
forall geom px. Geometry geom => geom -> Drawing px ()
fill [Primitive]
rect
        Float -> Join -> (Cap, Cap) -> [Primitive] -> Drawing px ()
forall geom px.
Geometry geom =>
Float -> Join -> (Cap, Cap) -> geom -> Drawing px ()
stroke (Float
borderSize Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2) (Float -> Join
JoinMiter Float
0)
               (Float -> Cap
CapStraight Float
0, Float -> Cap
CapStraight Float
0) [Primitive]
rect'
        where
          p :: Point
p = Point
ip Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
0.5 Float
0.5
          rect :: [Primitive]
rect = Point -> Float -> Float -> [Primitive]
rectangle (Float -> Float -> Point
forall a. a -> a -> V2 a
V2 Float
0 Float
0) Float
rw Float
rh
          rect' :: [Primitive]
rect' = Point -> Float -> Float -> [Primitive]
rectangle Point
p Float
reqWidth Float
reqHeight

          (Float
rw, Float
rh) = (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w, Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
          scaleX :: Float
scaleX | Float
reqWidth Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 = Float
1
                 | Bool
otherwise = Float
reqWidth Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
rw

          scaleY :: Float
scaleY | Float
reqHeight Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 = Float
1
                 | Bool
otherwise = Float
reqHeight Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
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 :: Point -> Point -> [Primitive]
line Point
p1 Point
p2 = [Line -> Primitive
LinePrim (Line -> Primitive) -> Line -> Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line Point
p1 Point
p2]