Rasterific 0.6.1.1 → 0.7

raw patch · 50 files changed

+3117/−576 lines, 50 filesdep +transformersdep ~basebinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Rasterific.cabal +8/−2
• docimages/cap_straight.png binary
• docimages/dashed_stroke.png binary
• docimages/dashed_stroke_with_offset.png binary
• docimages/dummy.png +0/−0
• docimages/fill_evenodd.png binary
• docimages/fill_winding.png binary
• docimages/geometry_on_path.png binary
• docimages/linear_gradient.png binary
• docimages/linear_gradient_rotated.png binary
• docimages/logo.png binary
• docimages/mesh_patch_interp_bicubic.png binary
• docimages/mesh_patch_interp_bilinear.png binary
• docimages/mesh_patch_interp_clip.png binary
• docimages/mesh_patch_transp.png binary
• docimages/module_example.png binary
• docimages/radial_gradient_focus.png binary
• docimages/sampled_texture_reflect.png binary
• docimages/sampled_texture_rotate.png binary
• docimages/sampled_texture_scaled.png binary
• docimages/sampler_pad.png binary
• docimages/sampler_reflect.png binary
• docimages/sampler_repeat.png binary
• docimages/stroke_line.png binary
• docimages/stroke_polyline.png binary
• docimages/strokize_dashed_path.png binary
• docimages/text_complex_example.png binary
• docimages/text_on_path.png binary
• exec-src/docImageGenerator.hs +69/−1
• src/Graphics/Rasterific.hs +94/−2
• src/Graphics/Rasterific/BiSampleable.hs +91/−0
• src/Graphics/Rasterific/Command.hs +28/−2
• src/Graphics/Rasterific/Compositor.hs +55/−2
• src/Graphics/Rasterific/CubicBezier.hs +13/−6
• src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs +199/−0
• src/Graphics/Rasterific/Immediate.hs +40/−18
• src/Graphics/Rasterific/Line.hs +2/−2
• src/Graphics/Rasterific/Linear.hs +416/−230
• src/Graphics/Rasterific/MeshPatch.hs +604/−0
• src/Graphics/Rasterific/MicroPdf.hs +87/−0
• src/Graphics/Rasterific/MiniLens.hs +38/−5
• src/Graphics/Rasterific/Operators.hs +1/−1
• src/Graphics/Rasterific/Patch.hs +597/−0
• src/Graphics/Rasterific/PatchTypes.hs +396/−0
• src/Graphics/Rasterific/QuadraticBezier.hs +3/−3
• src/Graphics/Rasterific/Rasterize.hs +97/−92
• src/Graphics/Rasterific/Shading.hs +50/−7
• src/Graphics/Rasterific/Texture.hs +7/−0
• src/Graphics/Rasterific/Transformations.hs +189/−198
• src/Graphics/Rasterific/Types.hs +33/−5

@@ -1,7 +1,7 @@ -- Initial Rasterific.cabal generated by cabal init.  For further  -- documentation, see http://haskell.org/cabal/users-guide/ name:                Rasterific-version:             0.6.1.1+version:             0.7 synopsis:            A pure haskell drawing engine. -- A longer description of the package. description:@@ -40,7 +40,7 @@ Source-Repository this     Type:      git     Location:  git://github.com/Twinside/Rasterific.git-    Tag:       v0.6.1.1+    Tag:       v0.7  flag embed_linear   description: Embed a reduced version of Linear avoiding a (huge) dep@@ -56,6 +56,9 @@                  , Graphics.Rasterific.Transformations                  , Graphics.Rasterific.Immediate                  , Graphics.Rasterific.PathWalker+                 , Graphics.Rasterific.Patch+                 , Graphics.Rasterific.BiSampleable+                 , Graphics.Rasterific.MeshPatch    other-modules: Graphics.Rasterific.Line                , Graphics.Rasterific.Command@@ -72,6 +75,8 @@                , Graphics.Rasterific.Shading                , Graphics.Rasterific.PlaneBoundable                , Graphics.Rasterific.QuadraticFormula+               , Graphics.Rasterific.PatchTypes+               , Graphics.Rasterific.CubicBezier.FastForwardDifference    ghc-options: -O3 -Wall    -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques@@ -87,6 +92,7 @@                , vector-algorithms >= 0.3                , bytestring  >= 0.10.2                , containers  >= 0.5+               , transformers    if !flag(embed_linear)       build-depends: linear >= 1.3

binary file changed (1785 → 1786 bytes)

binary file changed (662 → 741 bytes)

binary file changed (661 → 731 bytes)

binary file changed (6039 → 6040 bytes)

binary file changed (4454 → 4454 bytes)

binary file changed (5126 → 5127 bytes)

binary file changed (4401 → 4870 bytes)

binary file changed (absent → 5693 bytes)

binary file changed (3594 → 21143 bytes)

binary file changed (absent → 55553 bytes)

binary file changed (absent → 48653 bytes)

binary file changed (absent → 29676 bytes)

binary file changed (absent → 39645 bytes)

binary file changed (2331 → 2335 bytes)

binary file changed (19019 → 19023 bytes)

binary file changed (65351 → 64952 bytes)

binary file changed (109884 → 109884 bytes)

binary file changed (102643 → 102643 bytes)

binary file changed (1819 → 2650 bytes)

binary file changed (2980 → 5931 bytes)

binary file changed (2374 → 4896 bytes)

binary file changed (3022 → 3023 bytes)

binary file changed (2830 → 2849 bytes)

binary file changed (10013 → 10104 bytes)

binary file changed (2246 → 2246 bytes)

binary file changed (6746 → 6749 bytes)

@@ -15,10 +15,12 @@ import Graphics.Rasterific.Outline import Graphics.Rasterific.Texture import Graphics.Rasterific.Transformations+import Graphics.Rasterific.MeshPatch import Graphics.Rasterific.Immediate import System.Directory( createDirectoryIfMissing ) import System.FilePath( (</>) ) import qualified Data.ByteString.Lazy as LB+import qualified Data.Vector as V  import Graphics.Rasterific.Linear( (^+^) ) @@ -345,6 +347,14 @@         withTexture (linearGradientTexture gradDef (V2 40 40) (V2 130 130)) $             fill $ circle (V2 100 100) 100) +    produceDocImage (outFolder </> "linear_gradient_rotated.png") $+       (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)+                      ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)+                      ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in+        withTransformation (rotate 1) $+          withTexture (linearGradientTexture gradDef (V2 40 40) (V2 130 130)) $+              fill $ circle (V2 100 100) 100)+     produceDocImage (outFolder </> "radial_gradient.png") $        (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)                       ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)@@ -366,7 +376,18 @@         withTexture (linearGradientTexture gradDef (V2 80 100) (V2 120 110)) $             fill $ rectangle (V2 10 10) 180 180) -    produceDocImage (outFolder </> "logo.png") $+    produceDocImage (outFolder </> "logo.png") $ do+      let colorCycle = cycle+            [ PixelRGBA8 0 0x86 0xc1 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0 0x86 0xc1 255+            , PixelRGBA8 0xDf 0xD4 0xc1 255+            , PixelRGBA8 0 0x86 0xc1 255+            , PixelRGBA8 0 0x86 0xc1 255]+          colors = V.fromListN (4 * 4) colorCycle+          mesh = generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors+      withTexture (transformTexture (scale 0.7 0.7 <> rotateCenter (-0.4) (V2 100 100)) $+                    meshPatchTexture PatchBicubic mesh) $         fill $ logo 80 False (V2 20 20) ++                 logo 40 True (V2 40 40) @@ -503,6 +524,53 @@             fill $ circle (V2 70 100) 60         withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) .             fill $ circle (V2 120 100) 60++    produceDocImage (outFolder </> "mesh_patch_interp_bilinear.png") $ do+      let colorCycle = cycle+            [ PixelRGBA8 0 0x86 0xc1 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0xFF 0x53 0x73 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0 0x86 0xc1 255]+          colors = V.fromListN (4 * 4) colorCycle+      withTransformation (rotate 0.2) $+        renderMeshPatch PatchBilinear $+            generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors++    produceDocImage (outFolder </> "mesh_patch_interp_clip.png") $ do+      let colorCycle = cycle+            [ PixelRGBA8 0 0x86 0xc1 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0xFF 0x53 0x73 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0 0x86 0xc1 255]+          colors = V.fromListN (4 * 4) colorCycle+      withClipping (fill $ circle (V2 100 100) 75) $+        renderMeshPatch PatchBilinear $+            generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors++    produceDocImage (outFolder </> "mesh_patch_interp_bicubic.png") $ do+      let colorCycle = cycle+            [ PixelRGBA8 0 0x86 0xc1 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0xFF 0x53 0x73 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0 0x86 0xc1 255]+          colors = V.fromListN (4 * 4) colorCycle+      renderMeshPatch PatchBicubic $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors++    produceDocImage (outFolder </> "mesh_patch_transp.png") $ do+      let colorCycle = cycle+            [ PixelRGBA8 0 0x86 0xc1 255+            , PixelRGBA8 0xff 0xf4 0xc1 255+            , PixelRGBA8 0xFF 0x53 0x73 127+            , PixelRGBA8 0xff 0xf4 0xc1 127+            ]+          colors = V.fromListN (1 * 4) colorCycle+      withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $+        fill $ rectangle (V2 0 70) 200 60+      renderMeshPatch PatchBicubic $+        generateLinearGrid 1 1 (V2 10 10) (V2 180 180) colors      textExample     textMultipleExample

@@ -45,6 +45,7 @@       -- ** Filling       fill     , fillWithMethod+    , renderMeshPatch       -- ** Stroking     , stroke     , dashedStroke@@ -132,6 +133,7 @@     , Cap( .. )     , SamplerRepeat( .. )     , FillMethod( .. )+    , PatchInterpolation( .. )     , DashPattern     , drawOrdersOfDrawing @@ -149,7 +151,7 @@  import Control.Monad.Free( Free( .. ), liftF ) import Control.Monad.Free.Church( fromF )-import Control.Monad.ST( runST )+import Control.Monad.ST( ST, runST ) import Control.Monad.State( modify, execState ) import Data.Maybe( fromMaybe ) import Codec.Picture.Types( Image( .. )@@ -158,6 +160,8 @@                           , 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@@ -174,6 +178,9 @@ import Graphics.Rasterific.Immediate import Graphics.Rasterific.PathWalker 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@@ -373,6 +380,11 @@         , _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. --@@ -490,6 +502,26 @@ cacheDrawing maxWidth maxHeight dpi sub =   cacheOrders Nothing $ 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) @@ -510,6 +542,10 @@       renderDrawing width height clipBackground             . withTexture (SolidTexture clipForeground) +    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@@ -565,6 +601,60 @@        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 $ 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 = DrawOrder @@ -572,6 +662,7 @@             , _orderTexture    = textureOf ctxt             , _orderFillMethod = method             , _orderMask       = currentClip ctxt+            , _orderDirect     = return ()             }      go ctxt (Free (Stroke w j cap prims next)) rest =@@ -579,7 +670,8 @@             where 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 { currentTexture = preComputeTexture width height 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

@@ -0,0 +1,91 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+-- | Module to describe bi-sampleable types+module Graphics.Rasterific.BiSampleable+    ( BiSampleable( .. )+    , bilinearInterpolation+    ) where++import Codec.Picture( PixelRGBA8( .. ) )++import Graphics.Rasterific.Linear+import Graphics.Rasterific.Types+import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Shading+import Graphics.Rasterific.PatchTypes+import Graphics.Rasterific.Transformations++import Codec.Picture( Pixel( .. ) )++-- | Interpolate a 2D point in a given type+class BiSampleable sampled px | sampled -> px where+  -- | The interpolation function+  interpolate :: sampled -> Float -> Float -> px++-- | Basic bilinear interpolator+instance  (Pixel px, Modulable (PixelBaseComponent px))+    => BiSampleable (ParametricValues px) px where+  {-# INLINE interpolate #-}+  interpolate = bilinearPixelInterpolation++-- | Bicubic interpolator+instance ( InterpolablePixel px+         , Num (Holder px Float)+         ) => BiSampleable (CubicCoefficient px) px where+  {-# INLINE interpolate #-}+  interpolate = bicubicInterpolation++-- | Bilinear interpolation of an image+instance BiSampleable (ImageMesh PixelRGBA8) PixelRGBA8 where+  {-# INLINE interpolate #-}+  interpolate imesh xb yb = sampledImageShader (_meshImage imesh) SamplerPad x y+    where (V2 x y) = applyTransformation (_meshTransform imesh) (V2 xb yb)++bilinearPixelInterpolation :: (Pixel px, Modulable (PixelBaseComponent px))+                           => ParametricValues px -> Float -> Float -> px+{-# SPECIALIZE INLINE+    bilinearPixelInterpolation :: ParametricValues PixelRGBA8 -> Float -> Float -> PixelRGBA8+  #-}+bilinearPixelInterpolation (ParametricValues { .. }) !dx !dy = +  mixWith (const $ alphaOver covY icovY)+        (mixWith (const $ alphaOver covX icovX) _northValue _eastValue)+        (mixWith (const $ alphaOver covX icovX) _westValue _southValue)+  where+   (!covX, !icovX) = clampCoverage dx+   (!covY, !icovY) = clampCoverage dy++bilinearInterpolation :: InterpolablePixel px+                      => ParametricValues px -> Float -> Float -> px+{-# INLINE bilinearInterpolation #-}+bilinearInterpolation ParametricValues { .. } u v = fromFloatPixel $ lerp v uBottom uTop where+  -- The arguments are flipped, because the lerp function from Linear is...+  -- inversed in u v+  !uTop = lerp u (toFloatPixel _eastValue) (toFloatPixel _northValue)+  !uBottom = lerp u (toFloatPixel _southValue) (toFloatPixel _westValue)+++bicubicInterpolation :: forall px . (InterpolablePixel px, Num (Holder px Float))+                     => CubicCoefficient px -> Float -> Float -> px+bicubicInterpolation params x y =+  fromFloatPixel . fmap clamp $ af ^+^ bf ^+^ cf ^+^ df+  where+    ParametricValues a b c d = getCubicCoefficients params+    maxi = maxRepresentable (Proxy :: Proxy px)+    clamp = max 0 . min maxi+    xv, vy, vyy, vyyy :: V4 Float+    xv = V4 1 x (x*x) (x*x*x)+    vy = xv ^* y+    vyy = vy ^* y+    vyyy = vyy ^* y++    v1 ^^*^ v2 = (^*) <$> v1 <*> v2++    V4 af bf cf df = (a ^^*^ xv) ^+^ (b ^^*^ vy) ^+^ (c ^^*^ vyy) ^+^ (d ^^*^ vyyy)+

@@ -6,6 +6,7 @@ {-# LANGUAGE CPP #-} module Graphics.Rasterific.Command ( Drawing                                    , DrawCommand( .. )+                                   , DrawContext                                    , TextRange( .. )                                    , dumpDrawing                                    , Texture( .. )@@ -19,18 +20,27 @@ import Data.Monoid( Monoid( .. ) ) #endif +import Control.Monad.ST( ST )+import Control.Monad.State( StateT )+import Control.Monad.Primitive( PrimState ) import Control.Monad.Free( Free( .. ), liftF ) import Control.Monad.Free.Church( F, fromF ) import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 ) +import Codec.Picture.Types( MutableImage ) import Graphics.Rasterific.Types import Graphics.Rasterific.Transformations+import Graphics.Rasterific.PatchTypes  import Graphics.Text.TrueType( Font, PointSize )  -- | Monad used to record the drawing actions. type Drawing px = F (DrawCommand px) +-- | Monad used to describe the drawing context.+type DrawContext m px =+    StateT (MutableImage (PrimState m) px) m+ -- | Structure defining how to render a text range data TextRange px = TextRange     { _textFont    :: Font      -- ^ Font used during the rendering@@ -56,7 +66,7 @@ type Gradient px = [(Float, px)]  -- | Reification of texture type-data Texture px+data Texture (px :: *)   = SolidTexture !px   | LinearGradientTexture !(Gradient px) !Line    | RadialGradientTexture !(Gradient px) !Point !Float@@ -67,11 +77,15 @@   | RawTexture     !(Image px)   | ShaderTexture  !(ShaderFunction px)   | ModulateTexture (Texture px) (Texture (PixelBaseComponent px))+  | AlphaModulateTexture (Texture px) (Texture (PixelBaseComponent px))   | PatternTexture !Int !Int !px (Drawing px ()) (Image px)+  | MeshPatchTexture !PatchInterpolation !(MeshPatch px)   data DrawCommand px next   = Fill FillMethod [Primitive] next+  | CustomRender (forall s. DrawContext (ST s) px ()) next+  | MeshPatchRender !PatchInterpolation (MeshPatch px) next   | Stroke Float Join (Cap, Cap) [Primitive] next   | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next   | TextFill Point [TextRange px] next@@ -104,6 +118,10 @@          ) => Free (DrawCommand px) () -> String   go (Pure ()) = "return ()"+  go (Free (MeshPatchRender i m next)) =+    "renderMeshPatch (" ++ show i ++ ") (" ++ show m ++ ") >>= " ++ go next+  go (Free (CustomRender _r next)) =+    "customRender _ >>= " ++ go next   go (Free (WithImageEffect _effect sub next)) =     "withImageEffect ({- fun -}) (" ++ go (fromF sub) ++ ") >>= " ++ go next   go (Free (WithGlobalOpacity opa sub next)) =@@ -151,7 +169,8 @@                , PixelBaseComponent (PixelBaseComponent px)                     ~ (PixelBaseComponent px)                ) => Texture px -> String-dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px++ ")"+dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px ++ ")"+dumpTexture (MeshPatchTexture i mpx) = "meshTexture (" ++ show i ++ ") (" ++ show mpx ++ ")" dumpTexture (LinearGradientTexture grad (Line a b)) =     "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")" dumpTexture (RadialGradientTexture grad p rad) =@@ -169,6 +188,9 @@ dumpTexture (ModulateTexture sub mask) =     "modulateTexture (" ++ dumpTexture sub ++ ") ("                         ++ dumpTexture mask ++ ")"+dumpTexture (AlphaModulateTexture sub mask) =+    "alphaModulate (" ++ dumpTexture sub ++ ") ("+                      ++ dumpTexture mask ++ ")" dumpTexture (PatternTexture w h px sub _) =     "patternTexture " ++ show w ++ " " ++ show h ++ " " ++ show px                       ++ " (" ++ dumpDrawing sub ++ ")"@@ -179,6 +201,8 @@         WithImageEffect effect sub $ f next     fmap f (TextFill pos texts next) =         TextFill pos texts $ f next+    fmap f (CustomRender m next) =+        CustomRender m $ f next     fmap f (WithGlobalOpacity opa sub next) =         WithGlobalOpacity opa sub $ f next     fmap f (Fill method  prims next) = Fill method prims $ f next@@ -193,6 +217,8 @@         WithTransform trans draw $ f next     fmap f (WithPathOrientation path point draw next) =         WithPathOrientation path point draw $ f next+    fmap f (MeshPatchRender i mesh next) =+        MeshPatchRender i mesh $ f next  instance Monoid (Drawing px ()) where     mempty = return ()

@@ -7,8 +7,10 @@ module Graphics.Rasterific.Compositor     ( Compositor     , Modulable( .. )-    , ModulablePixel+    , InterpolablePixel( .. )+    , maxDistance     , RenderablePixel+    , ModulablePixel     , compositionDestination     , compositionAlpha     , emptyPx@@ -18,18 +20,66 @@ import Data.Bits( unsafeShiftR ) import Data.Word( Word8, Word32 ) -import Codec.Picture.Types( Pixel( .. ), PackeablePixel( .. ) )+import Codec.Picture.Types+    ( Pixel( .. )+    , PixelRGB8( .. )+    , PixelRGBA8( .. )+    , PackeablePixel( .. ) ) +import Graphics.Rasterific.Linear+import Graphics.Rasterific.Types+ type Compositor px =     PixelBaseComponent px ->         PixelBaseComponent px -> px -> px -> px +-- | Used for Coon patch rendering+class ( Applicative (Holder a)+      , Functor  (Holder a)+      , Foldable (Holder a)+      , Additive (Holder a) ) => InterpolablePixel a where+  type Holder a :: * -> *+  toFloatPixel :: a -> Holder a Float+  fromFloatPixel :: Holder a Float -> a+  maxRepresentable :: Proxy a -> Float++maxDistance :: InterpolablePixel a => a -> a -> Float+maxDistance p1 p2 = maximum $ abs <$> (toFloatPixel p1 ^-^ toFloatPixel p2)++instance InterpolablePixel Float where+  type Holder Float = V1+  toFloatPixel = V1+  fromFloatPixel (V1 f) = f+  maxRepresentable Proxy = 1++instance InterpolablePixel Word8 where+  type Holder Word8 = V1+  toFloatPixel = V1 . fromIntegral+  fromFloatPixel (V1 f) = floor f+  maxRepresentable Proxy = 255++instance InterpolablePixel PixelRGB8 where+  type Holder PixelRGB8 = V3+  toFloatPixel (PixelRGB8 r g b) = V3 (to r) (to g) (to b) where to n = fromIntegral n+  fromFloatPixel (V3 r g b) = PixelRGB8 (to r) (to g) (to b) where to = floor+  maxRepresentable Proxy = 255++instance InterpolablePixel PixelRGBA8 where+  type Holder PixelRGBA8 = V4+  toFloatPixel (PixelRGBA8 r g b a) = V4 (to r) (to g) (to b) (to a)+    where to n = fromIntegral n+  fromFloatPixel (V4 r g b a) = PixelRGBA8 (to r) (to g) (to b) (to a)+    where to = floor+  maxRepresentable Proxy = 255+ -- | This constraint ensure that a type is a pixel -- and we're allowed to modulate it's color components -- generically. type ModulablePixel px =     ( Pixel px     , PackeablePixel px+    , InterpolablePixel px+    , InterpolablePixel (PixelBaseComponent px)     , Storable (PackedRepresentation px)     , Modulable (PixelBaseComponent px)) @@ -44,6 +94,8 @@     , PackeablePixel (PixelBaseComponent px)     , Num (PackedRepresentation px)     , Num (PackedRepresentation (PixelBaseComponent px))+    , Num (Holder px Float)+    , Num (Holder (PixelBaseComponent px) Float)     , Storable (PackedRepresentation (PixelBaseComponent px))     , PixelBaseComponent (PixelBaseComponent px)             ~ (PixelBaseComponent px)@@ -75,6 +127,7 @@    -- | Like modulate but also return the inverse coverage.   coverageModulate :: a -> a -> (a, a)+  {-# INLINE coverageModulate #-}   coverageModulate c a = (clamped, fullValue - clamped)     where clamped = modulate a c 

@@ -7,6 +7,7 @@     ( cubicBezierCircle     , cubicBezierFromPath     , cubicBezierBreakAt+    , divideCubicBezier     , clipCubicBezier     , decomposeCubicBeziers     , sanitizeCubicBezier@@ -254,19 +255,25 @@         edge = vpartition edgeSeparator mini maxi         m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd +divideCubicBezier :: CubicBezier -> (CubicBezier, CubicBezier)+divideCubicBezier bezier@(CubicBezier a _ _ d) = (left, right) where+  left = CubicBezier a ab abbc abbcbccd+  right = CubicBezier abbcbccd bccd cd d+  (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier+ -- | Will subdivide the bezier from 0 to coeff and coeff to 1 cubicBezierBreakAt :: CubicBezier -> Float                    -> (CubicBezier, CubicBezier) cubicBezierBreakAt (CubicBezier a b c d) val =     (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d)   where-    ab = lerp val a b-    bc = lerp val b c-    cd = lerp val c d+    ab = lerp val b a+    bc = lerp val c b+    cd = lerp val d c -    abbc = lerp val ab bc-    bccd = lerp val bc cd-    abbcbccd = lerp val abbc bccd+    abbc = lerp val bc ab+    bccd = lerp val cd bc+    abbcbccd = lerp val bccd abbc  decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) =

@@ -0,0 +1,199 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+module Graphics.Rasterific.CubicBezier.FastForwardDifference+    ( ForwardDifferenceCoefficient( .. )+    , bezierToForwardDifferenceCoeff+    , rasterizerCubicBezier+    , rasterizeTensorPatch+    , rasterizeCoonPatch+    , estimateFDStepCount+    ) where++import Control.Monad.Primitive( PrimMonad )+import Control.Monad.State( lift, get )+import Control.Monad.ST( ST )+import Data.Bits( unsafeShiftL )++import Codec.Picture( PixelRGBA8 )+import Codec.Picture.Types( MutableImage( .. ) )++import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Immediate+import Graphics.Rasterific.Types+import Graphics.Rasterific.Linear+import Graphics.Rasterific.BiSampleable+import Graphics.Rasterific.PatchTypes+import Graphics.Rasterific.Shading++data ForwardDifferenceCoefficient = ForwardDifferenceCoefficient+    { _fdA :: {-# UNPACK #-} !Float+    , _fdB :: {-# UNPACK #-} !Float+    , _fdC :: {-# UNPACK #-} !Float+    }++-- | Given a cubic curve, return the initial step size and+-- the coefficient for the forward difference.+-- Initial step is assumed to be "1"+bezierToForwardDifferenceCoeff+    :: CubicBezier+    -> V2 ForwardDifferenceCoefficient+bezierToForwardDifferenceCoeff (CubicBezier x y z w) = V2 xCoeffs yCoeffs+  where+    xCoeffs = ForwardDifferenceCoefficient { _fdA = ax, _fdB = bx, _fdC = cx }+    yCoeffs = ForwardDifferenceCoefficient { _fdA = ay, _fdB = by, _fdC = cy }++    V2 ax ay = w ^-^ x+    V2 bx by = (w ^-^ z ^* 2 ^+^ y) ^* 6+    V2 cx cy = (w ^-^ z ^* 3 ^+^ y ^* 3 ^-^ x) ^* 6++halveFDCoefficients :: ForwardDifferenceCoefficient -> ForwardDifferenceCoefficient+halveFDCoefficients (ForwardDifferenceCoefficient a b c) =+    ForwardDifferenceCoefficient { _fdA = a', _fdB = b', _fdC = c' }+  where+    c' = c * 0.125+    b' = b * 0.25 - c'+    a' = (a - b') * 0.5++updateForwardDifferencing :: ForwardDifferenceCoefficient -> ForwardDifferenceCoefficient+updateForwardDifferencing (ForwardDifferenceCoefficient a b c) =+  ForwardDifferenceCoefficient (a + b) (b + c) c++updatePointsAndCoeff :: (Applicative f', Applicative f, Additive f)+                     => f' (f Float) -> f' (f ForwardDifferenceCoefficient)+                     -> (f' (f Float), f' (f ForwardDifferenceCoefficient))+updatePointsAndCoeff pts coeffs =+    (advancePoint <$> pts <*> coeffs, fmap updateForwardDifferencing <$> coeffs)+  where+    fstOf (ForwardDifferenceCoefficient a _ _) = a+    advancePoint v c = v ^+^ (fstOf <$> c)+++estimateFDStepCount :: CubicBezier -> Int+estimateFDStepCount (CubicBezier p0 p1 p2 p3) =+  toInt $ maximum [p0 `qd` p1, p2 `qd` p3, (p0 `qd` p2) / 4, (p1 `qd` p3) / 4]+  where+    toInt = scale . frexp . max 1 . (18 *)+    scale (_, r) = (r + 1) `div` 2+++fixIter :: Int -> (a -> a) -> a -> a+fixIter count f = go count+  where+    go 0 a = a+    go n a = go (n-1) $ f a++isPointInImage :: MutableImage s a -> Point -> Bool+isPointInImage MutableImage { mutableImageWidth = w, mutableImageHeight = h } (V2 x y) =+   0 <= x && x < fromIntegral w && 0 <= y && y < fromIntegral h++isCubicBezierOutsideImage :: MutableImage s a -> CubicBezier -> Bool+isCubicBezierOutsideImage img (CubicBezier a b c d) =+  not $ isIn a || isIn b || isIn c || isIn d+  where isIn = isPointInImage img++isCubicBezierInImage :: MutableImage s a -> CubicBezier -> Bool+isCubicBezierInImage img (CubicBezier a b c d) =+    isIn a && isIn b && isIn c && isIn d+  where isIn = isPointInImage img++-- | Rasterize a cubic bezier curve using the Fast Forward Diffrence+-- algorithm.+rasterizerCubicBezier :: (PrimMonad m, ModulablePixel px, BiSampleable src px)+                      => src -> CubicBezier+                      -> Float -> Float+                      -> Float -> Float+                      -> DrawContext m px ()+{-# SPECIALIZE INLINE+  rasterizerCubicBezier :: (ParametricValues PixelRGBA8) -> CubicBezier+                        -> Float -> Float+                        -> Float -> Float+                        -> DrawContext (ST s) PixelRGBA8 () #-}+rasterizerCubicBezier source bez uStart vStart uEnd vEnd = do+  canvas <- get+  let !baseFfd = bezierToForwardDifferenceCoeff bez+      !shiftCount = estimateFDStepCount bez+      maxStepCount :: Int+      maxStepCount = 1 `unsafeShiftL` shiftCount+      !(V2 (ForwardDifferenceCoefficient ax' bx' cx)+           (ForwardDifferenceCoefficient ay' by' cy)) =+               fixIter shiftCount halveFDCoefficients <$> baseFfd++      !(V2 _du dv) = (V2 uEnd vEnd ^-^ V2 uStart vStart) ^/ fromIntegral maxStepCount+      !(V2 xStart yStart) = _cBezierX0 bez+      +      go !currentStep _ _ _ _ _ _ _ | currentStep >= maxStepCount = return ()+      go !currentStep !ax !bx !ay !by !x !y !v = do+        let !color = interpolate source uStart v+        plotOpaquePixel canvas color (floor x) (floor y)+        go (currentStep + 1)+            (ax + bx) (bx + cx)+            (ay + by) (by + cy)+            (x  + ax) (y  + ay)+            (v  + dv)++      goUnsafe !currentStep _ _ _ _ _ _ _ | currentStep >= maxStepCount = return ()+      goUnsafe !currentStep !ax !bx !ay !by !x !y !v = do+        let !color = interpolate source uStart v+        unsafePlotOpaquePixel canvas color (floor x) (floor y)+        goUnsafe (currentStep + 1)+            (ax + bx) (bx + cx)+            (ay + by) (by + cy)+            (x  + ax) (y  + ay)+            (v  + dv)++  if isCubicBezierOutsideImage canvas bez then+    return ()+  else if isCubicBezierInImage canvas bez then+    lift $ goUnsafe 0 ax' bx' ay' by' xStart yStart vStart+  else+    lift $ go 0 ax' bx' ay' by' xStart yStart vStart++-- | Rasterize a coon patch using the Fast Forward Diffrence algorithm,+-- likely to be faster than the subdivision one.+rasterizeCoonPatch :: (PrimMonad m, ModulablePixel px, BiSampleable src px)+                    => CoonPatch src -> DrawContext m px ()+{-# SPECIALIZE rasterizeCoonPatch :: CoonPatch (ParametricValues PixelRGBA8)+                                  -> DrawContext (ST s) PixelRGBA8 () #-}+rasterizeCoonPatch = rasterizeTensorPatch . toTensorPatch++-- | Rasterize a tensor patch using the Fast Forward Diffrence algorithm,+-- likely to be faster than the subdivision one.+rasterizeTensorPatch :: (PrimMonad m, ModulablePixel px, BiSampleable src px)+                     => TensorPatch src -> DrawContext m px ()+{-# SPECIALIZE rasterizeTensorPatch :: TensorPatch (ParametricValues PixelRGBA8)+                                    -> DrawContext (ST s) PixelRGBA8 () #-}+rasterizeTensorPatch TensorPatch { .. } =+    go maxStepCount basePoints ffCoeff 0+  where+    !curves = V4 _curve0 _curve1 _curve2 _curve3+    !shiftStep = maximum $ estimateFDStepCount <$> [_curve0, _curve1, _curve2, _curve3]+    +    !basePoints = _cBezierX0 <$> curves+    !ffCoeff =+      fmap (fixIter shiftStep halveFDCoefficients) . bezierToForwardDifferenceCoeff <$> curves+    +    maxStepCount :: Int+    !maxStepCount = 1 `unsafeShiftL` shiftStep++    !du = 1 / fromIntegral maxStepCount+    +    toBezier (V4 a b c d) = CubicBezier a b c d+    +    go 0 _pts _coeffs _uvStart = return ()+    go i !pts !coeffs !ut = do+      let (newPoints, newCoeff) = updatePointsAndCoeff pts coeffs+      rasterizerCubicBezier _tensorValues (toBezier pts) ut 0 ut 1+      go (i - 1) newPoints newCoeff (ut + du)++frexp :: Float -> (Float, Int)+frexp x+   | isNaN x = error "NaN given to frexp"+   | isInfinite x = error "infinity given to frexp"+   | otherwise  = go x 0+  where+    go s e+      | s >= 1.0 = go (s / 2) (e + 1)+      | s < 0.5 = go (s * 2) (e - 1)+      | otherwise = (s, e)+

@@ -24,29 +24,32 @@     , runDrawContext     , fillWithTextureAndMask     , fillWithTexture+    , fillWithTextureNoAA     , fillOrder      , textToDrawOrders     , transformOrder     ) where + #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) import Data.Foldable( foldMap ) #endif +import Control.Monad.ST( ST ) import Data.Maybe( fromMaybe ) import qualified Data.Foldable as F import Control.Monad.Free( liftF )-import Control.Monad.State( StateT, execStateT, get, lift )-import Control.Monad.State.Class(MonadState)+import Control.Monad.State( evalStateT, execStateT, lift )+import Control.Monad.Trans.State( get ) import Codec.Picture.Types( Image( .. )                           , Pixel( .. )                           , MutableImage( .. )                           , unsafeFreezeImage                           , fillImageWith ) -import Control.Monad.Primitive( PrimState, PrimMonad, primToPrim )+import Control.Monad.Primitive( PrimMonad, primToPrim ) import qualified Data.Vector.Storable.Mutable as M import Graphics.Rasterific.Compositor import Graphics.Rasterific.Linear( V2( .. ) )@@ -60,10 +63,6 @@ import qualified Data.Vector.Unboxed as VU import Graphics.Text.TrueType( Dpi, getStringCurveAtPoint ) --- | Monad used to describe the drawing context.-type DrawContext m px =-    StateT (MutableImage (PrimState m) px) m- -- | Reify a filling function call, to be able to manipulate -- them in a simpler fashion. data DrawOrder px = DrawOrder@@ -75,6 +74,8 @@     , _orderFillMethod :: !FillMethod       -- | Optional mask used for clipping.     , _orderMask       :: !(Maybe (Texture (PixelBaseComponent px)))+      -- | Function to perform direct drawing+    , _orderDirect     :: !(forall s. DrawContext (ST s) px ())     }  instance PlaneBoundable (DrawOrder px) where@@ -85,8 +86,14 @@ transformOrder f order =   order { _orderPrimitives = transform f $ _orderPrimitives order } +transformOrderM :: Monad m => (Point -> m Point) -> DrawOrder px -> m (DrawOrder px)+transformOrderM f order = do+  v <- transformM f $ _orderPrimitives order +  return $ order { _orderPrimitives = v}+ instance Transformable (DrawOrder px) where   transform = transformOrder+  transformM = transformOrderM  -- | Transform back a low level drawing order to a more -- high level Drawing@@ -102,12 +109,17 @@ -- | Render the drawing orders on the canvas. fillOrder :: (PrimMonad m, RenderablePixel px)           => DrawOrder px -> DrawContext m px ()-fillOrder o@DrawOrder { _orderMask = Nothing } =+fillOrder o@DrawOrder { _orderMask = Nothing } = do   F.forM_ (_orderPrimitives o) $     fillWithTexture (_orderFillMethod o) (_orderTexture o)-fillOrder o@DrawOrder { _orderMask = Just mask } =+  img <- get+  lift $ primToPrim $ flip evalStateT img $ _orderDirect o++fillOrder o@DrawOrder { _orderMask = Just mask } = do   F.forM_ (_orderPrimitives o) $     fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask+  img <- get+  lift $ primToPrim $ flip evalStateT img $ _orderDirect o  -- | Start an image rendering. See `fillWithTexture` for -- an usage example. This function can work with either@@ -150,10 +162,7 @@ -- -- <<docimages/immediate_fill.png>> ---fillWithTexture :: (PrimMonad m, RenderablePixel px,-                    MonadState (MutableImage (PrimState m) px)-                               (DrawContext m px)-                   )+fillWithTexture :: (PrimMonad m, RenderablePixel px)                 => FillMethod                 -> Texture px  -- ^ Color/Texture used for the filling                 -> [Primitive] -- ^ Primitives to fill@@ -167,6 +176,22 @@         spans = rasterize fillMethod clipped     lift . mapExec filler $ filter (isCoverageDrawable img) spans +-- | Function identical to 'fillWithTexture' but with anti-aliasing+-- (and transparency) disabled.+fillWithTextureNoAA :: (PrimMonad m, RenderablePixel px)+                => FillMethod+                -> Texture px  -- ^ Color/Texture used for the filling+                -> [Primitive] -- ^ Primitives to fill+                -> DrawContext m px ()+fillWithTextureNoAA fillMethod texture els = do+    img@(MutableImage width height _) <- get+    let !mini = V2 0 0+        !maxi = V2 (fromIntegral width) (fromIntegral height)+        !filler = primToPrim . transformTextureToFiller texture img+        clipped = foldMap (clip mini maxi) els+        spans = rasterize fillMethod clipped+    lift . mapExec (filler . toOpaqueCoverage) $ filter (isCoverageDrawable img) spans+ -- | Fill some geometry using a composition mask for visibility. -- -- > immediateDrawMaskExample :: Image PixelRGBA8@@ -188,11 +213,7 @@ -- <<docimages/immediate_mask.png>> -- fillWithTextureAndMask-    :: ( PrimMonad m-       , RenderablePixel px-       , MonadState (MutableImage (PrimState m) px)-                    (DrawContext m px)-       )+    :: (PrimMonad m, RenderablePixel px)     => FillMethod     -> Texture px  -- ^ Color/Texture used for the filling of the geometry     -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask.@@ -221,6 +242,7 @@     , _orderFillMethod = FillWinding     , _orderMask = Nothing     , _orderTexture = fromMaybe defaultTexture $ _textTexture d+    , _orderDirect = return ()     }    floatCurves =

@@ -54,7 +54,7 @@  lineBreakAt :: Line -> Float -> (Line, Line) lineBreakAt (Line a b) t = (Line a ab, Line ab b)-  where ab = lerp t a b+  where ab = lerp t b a  flattenLine :: Line -> Container Primitive flattenLine = pure . LinePrim@@ -175,5 +175,5 @@            -> Line   -- ^ Line to transform            -> Line extendLine beg end (Line p1 p2) =-    Line (lerp beg p1 p2) (lerp end p1 p2)+    Line (lerp beg p2 p1) (lerp end p2 p1) 

@@ -1,230 +1,416 @@--- | This module is a reduction of the `Linear` package
--- from Edward Kmett to match just the need of Rasterific.
---
--- If the flag `embed_linear` is disabled, this module is
--- just a reexport from the real linear package.
---
-{-# LANGUAGE CPP #-}
-module Graphics.Rasterific.Linear
-    ( V2( .. )
-    , V1( .. )
-    , Additive( .. )
-    , Epsilon( .. )
-    , Metric( .. )
-    , (^*)
-    , (^/)
-    , normalize
-    ) where
-
-#ifdef EXTERNAL_LINEAR
--- We just reexport
-import Linear
-#else
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative( Applicative, pure, (<*>) )
-#endif
-
-infixl 6 ^+^, ^-^
-infixl 7 ^*, ^/
-
--- | A 2-dimensional vector
---
--- >>> pure 1 :: V2 Int
--- V2 1 1
---
--- >>> V2 1 2 + V2 3 4
--- V2 4 6
---
--- >>> V2 1 2 * V2 3 4
--- V2 3 8
---
--- >>> sum (V2 1 2)
--- 3
-data V2 a = V2 !a !a
-    deriving (Eq, Show)
-
--- | A 1-dimensional vector
-newtype V1 a = V1 a
-    deriving (Eq, Show)
-
-instance Functor V2 where
-    {-# INLINE fmap #-}
-    fmap f (V2 a b) = V2 (f a) (f b)
-
-instance Num a => Num (V2 a) where
-  (V2 a b) + (V2 a' b') = V2 (a + a') (b + b')
-  {-# INLINE (+) #-}
-  (V2 a b) - (V2 a' b') = V2 (a - a') (b - b')
-  {-# INLINE (-) #-}
-  (V2 a b) * (V2 a' b') = V2 (a * a') (b * b')
-  {-# INLINE (*) #-}
-  negate (V2 a b) = V2 (negate a) (negate b)
-  {-# INLINE negate #-}
-  abs (V2 a b) = V2 (abs a) (abs b)
-  {-# INLINE abs #-}
-  signum (V2 a b) = V2 (signum a) (signum b)
-  {-# INLINE signum #-}
-  fromInteger = pure . fromInteger
-  {-# INLINE fromInteger #-}
-
-instance Functor V1 where
-    {-# INLINE fmap #-}
-    fmap f (V1 a) = V1 $ f a
-
-instance Applicative V2 where
-    {-# INLINE pure #-}
-    pure a = V2 a a
-    {-# INLINE (<*>) #-}
-    (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b)
-
-instance Applicative V1 where
-    {-# INLINE pure #-}
-    pure = V1 
-    {-# INLINE (<*>) #-}
-    (V1 f) <*> (V1 v) = V1 $ f v
-
--- | A vector is an additive group with additional structure.
-class Functor f => Additive f where
-  -- | The zero vector
-  zero :: Num a => f a
-  -- | Compute the sum of two vectors
-  --
-  -- >>> V2 1 2 ^+^ V2 3 4
-  -- V2 4 6
-  (^+^) :: Num a => f a -> f a -> f a
-
-  -- | Compute the difference between two vectors
-  --
-  -- >>> V2 4 5 - V2 3 1
-  -- V2 1 4
-  (^-^) :: Num a => f a -> f a -> f a
-
-  -- | Linearly interpolate between two vectors.
-  lerp :: Num a => a -> f a -> f a -> f a
-
--- | Provides a fairly subjective test to see if a quantity is near zero.
---
--- >>> nearZero (1e-11 :: Double)
--- False
---
--- >>> nearZero (1e-17 :: Double)
--- True
---
--- >>> nearZero (1e-5 :: Float)
--- False
---
--- >>> nearZero (1e-7 :: Float)
--- True
-class Num a => Epsilon a where
-  -- | Determine if a quantity is near zero.
-  nearZero :: a -> Bool
-
--- | @'abs' a '<=' 1e-6@
-instance Epsilon Float where
-  nearZero a = abs a <= 1e-6
-  {-# INLINE nearZero #-}
-
--- | @'abs' a '<=' 1e-12@
-instance Epsilon Double where
-  nearZero a = abs a <= 1e-12
-  {-# INLINE nearZero #-}
-
-instance Epsilon a => Epsilon (V2 a) where
-  nearZero = nearZero . quadrance
-  {-# INLINE nearZero #-}
-
-instance Additive V2 where
-    zero = V2 0 0
-    {-# INLINE zero #-}
-
-    (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b')
-    {-# INLINE (^+^) #-}
-
-    (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b')
-    {-# INLINE (^-^) #-}
-
-    lerp v a b = a ^+^ (b ^-^ a) ^* v
-    {-# INLINE lerp #-}
-
-instance Additive V1 where
-    zero = V1 0
-    {-# INLINE zero #-}
-
-    (V1 a) ^+^ (V1 a') = V1 (a + a')
-    {-# INLINE (^+^) #-}
-
-    (V1 a) ^-^ (V1 a') = V1 (a - a')
-    {-# INLINE (^-^) #-}
-
-    lerp v a b = a ^+^ (b ^-^ a) ^* v
-    {-# INLINE lerp #-}
-
--- | Free and sparse inner product/metric spaces.
-class Additive f => Metric f where
-  -- | Compute the inner product of two vectors or (equivalently)
-  -- convert a vector @f a@ into a covector @f a -> a@.
-  --
-  -- >>> V2 1 2 `dot` V2 3 4
-  -- 11
-  dot :: Num a => f a -> f a -> a
-
-  -- | Compute the squared norm. The name quadrance arises from
-  -- Norman J. Wildberger's rational trigonometry.
-  quadrance :: Num a => f a -> a
-  {-# INLINE quadrance #-}
-  quadrance v = dot v v
-
-  -- | Compute the quadrance of the difference
-  qd :: Num a => f a -> f a -> a
-  {-# INLINE qd #-}
-  qd f g = quadrance (f ^-^ g)
-
-  -- | Compute the distance between two vectors in a metric space
-  distance :: Floating a => f a -> f a -> a
-  {-# INLINE distance #-}
-  distance f g = norm (f ^-^ g)
-
-  -- | Compute the norm of a vector in a metric space
-  norm :: Floating a => f a -> a
-  {-# INLINE norm #-}
-  norm v = sqrt (quadrance v)
-
-  -- | Convert a non-zero vector to unit vector.
-  signorm :: Floating a => f a -> f a
-  signorm v = fmap (/ m) v where
-    m = norm v
-
-instance Metric V2 where
-    dot (V2 a b) (V2 a' b') = a * a' + b * b'
-    {-# INLINE dot #-}
-
-    quadrance (V2 a b) = a * a + b * b
-    {-# INLINE quadrance #-}
-
-    norm v = sqrt (quadrance v)
-    {-# INLINE norm #-}
-
--- | Compute the right scalar product
---
--- >>> V2 3 4 ^* 2
--- V2 6 8
-(^*) :: (Functor f, Num a) => f a -> a -> f a
-{-# INLINE (^*) #-}
-(^*) f n = fmap (* n) f
-
--- | Compute division by a scalar on the right.
-(^/) :: (Functor f, Floating a) => f a -> a -> f a
-{-# INLINE (^/) #-}
-(^/) f n = fmap (/ n) f
-
--- | Normalize a 'Metric' functor to have unit 'norm'. This function
--- does not change the functor if its 'norm' is 0 or 1.
-normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a
-{-# INLINE normalize #-}
-normalize v = if nearZero l || nearZero (1-l) then v
-             else fmap (/ sqrt l) v
-  where l = quadrance v
-
-#endif
-
+-- | This module is a reduction of the `Linear` package+-- from Edward Kmett to match just the need of Rasterific.+--+-- If the flag `embed_linear` is disabled, this module is+-- just a reexport from the real linear package.+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Graphics.Rasterific.Linear+    ( V1( .. )+    , V2( .. )+    , V3( .. )+    , V4( .. )+    , R1( .. )+    , R2( .. )+    , Additive( .. )+    , Epsilon( .. )+    , Metric( .. )+    , (^*)+    , (^/)+    , normalize+    ) where++#ifdef EXTERNAL_LINEAR+-- We just reexport+import Linear+#else++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( Applicative, pure, (<$>), (<*>) )+import Data.Monoid( mappend )+import Data.Foldable( Foldable( .. ) )+import Data.Traversable( Traversable( .. ) )+#endif++import Graphics.Rasterific.MiniLens++infixl 6 ^+^, ^-^+infixl 7 ^*, ^/++-- | A 2-dimensional vector+--+-- >>> pure 1 :: V2 Int+-- V2 1 1+--+-- >>> V2 1 2 + V2 3 4+-- V2 4 6+--+-- >>> V2 1 2 * V2 3 4+-- V2 3 8+--+-- >>> sum (V2 1 2)+-- 3+data V2 a = V2 !a !a+    deriving (Eq, Show)++-- | A 3-dimensional vector+data V3 a = V3 !a !a !a+    deriving (Eq, Show)++-- | A 4-dimensional vector+data V4 a = V4 !a !a !a !a+    deriving (Eq, Show)++class R1 t where+  _x :: Lens' (t a) a++class R2 t where+  _y :: Lens' (t a) a++instance R1 V1 where+  _x = lens (\(V1 a) -> a) (\_ -> V1)++instance R1 V2 where+  _x = lens (\(V2 x _) -> x) (\(V2 _ y) x -> V2 x y)++instance R2 V2 where+  _y = lens (\(V2 _ y) -> y) (\(V2 x _) y -> V2 x y)++instance R1 V3 where+  _x = lens (\(V3 x _ _) -> x) (\(V3 _ y z) x -> V3 x y z)++instance R2 V3 where+  _y = lens (\(V3 _ y _) -> y) (\(V3 x _ z) y -> V3 x y z)++instance R1 V4 where+  _x = lens (\(V4 x _ _ _) -> x) (\(V4 _ y z w) x -> V4 x y z w)++instance R2 V4 where+  _y = lens (\(V4 _ y _ _) -> y) (\(V4 x _ z w) y -> V4 x y z w)++-- | A 1-dimensional vector+newtype V1 a = V1 a+    deriving (Eq, Show, Num)++instance Functor V1 where+    {-# INLINE fmap #-}+    fmap f (V1 a) = V1 $ f a++instance Functor V2 where+    {-# INLINE fmap #-}+    fmap f (V2 a b) = V2 (f a) (f b)++instance Functor V3 where+    {-# INLINE fmap #-}+    fmap f (V3 a b c) = V3 (f a) (f b) (f c)++instance Functor V4 where+    {-# INLINE fmap #-}+    fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d)++instance Foldable V3 where+  foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c+  {-# INLINE foldMap #-}++instance Traversable V3 where+  traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c+  {-# INLINE traverse #-}++instance Foldable V2 where+  foldMap f (V2 a b) = f a `mappend` f b+  {-# INLINE foldMap #-}++instance Traversable V2 where+  traverse f (V2 a b) = V2 <$> f a <*> f b+  {-# INLINE traverse #-}++instance Foldable V4 where+  foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d+  {-# INLINE foldMap #-}++instance Traversable V4 where+  traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d+  {-# INLINE traverse #-}++instance Foldable V1 where+  foldMap f (V1 a) = f a+  {-# INLINE foldMap #-}++instance Traversable V1 where+  traverse f (V1 a) = V1 <$> f a+  {-# INLINE traverse #-}++instance Num a => Num (V2 a) where+  (V2 a b) + (V2 a' b') = V2 (a + a') (b + b')+  {-# INLINE (+) #-}+  (V2 a b) - (V2 a' b') = V2 (a - a') (b - b')+  {-# INLINE (-) #-}+  (V2 a b) * (V2 a' b') = V2 (a * a') (b * b')+  {-# INLINE (*) #-}+  negate (V2 a b) = V2 (negate a) (negate b)+  {-# INLINE negate #-}+  abs (V2 a b) = V2 (abs a) (abs b)+  {-# INLINE abs #-}+  signum (V2 a b) = V2 (signum a) (signum b)+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}++instance Num a => Num (V3 a) where+  (V3 a b c) + (V3 a' b' c') = V3 (a + a') (b + b') (c + c')+  {-# INLINE (+) #-}+  (V3 a b c) - (V3 a' b' c') = V3 (a - a') (b - b') (c - c')+  {-# INLINE (-) #-}+  (V3 a b c) * (V3 a' b' c') = V3 (a * a') (b * b') (c * c')+  {-# INLINE (*) #-}+  negate (V3 a b c) = V3 (negate a) (negate b) (negate c)+  {-# INLINE negate #-}+  abs (V3 a b c) = V3 (abs a) (abs b) (abs c)+  {-# INLINE abs #-}+  signum (V3 a b c) = V3 (signum a) (signum b) (signum c)+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}++instance Num a => Num (V4 a) where+  (V4 a b c d) + (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')+  {-# INLINE (+) #-}+  (V4 a b c d) - (V4 a' b' c' d') = V4 (a - a') (b - b') (c - c') (d - d')+  {-# INLINE (-) #-}+  (V4 a b c d) * (V4 a' b' c' d') = V4 (a * a') (b * b') (c * c') (d * d')+  {-# INLINE (*) #-}+  negate (V4 a b c d) = V4 (negate a) (negate b) (negate c) (negate d)+  {-# INLINE negate #-}+  abs (V4 a b c d) = V4 (abs a) (abs b) (abs c) (abs d)+  {-# INLINE abs #-}+  signum (V4 a b c d) = V4 (signum a) (signum b) (signum c) (signum d)+  {-# INLINE signum #-}+  fromInteger = pure . fromInteger+  {-# INLINE fromInteger #-}++instance Applicative V4 where+    {-# INLINE pure #-}+    pure a = V4 a a a a+    {-# INLINE (<*>) #-}+    (V4 f1 f2 f3 f4) <*> (V4 a b c d) = V4 (f1 a) (f2 b) (f3 c) (f4 d)++instance Applicative V3 where+    {-# INLINE pure #-}+    pure a = V3 a a a+    {-# INLINE (<*>) #-}+    (V3 f1 f2 f3) <*> (V3 a b c) = V3 (f1 a) (f2 b) (f3 c)++instance Applicative V2 where+    {-# INLINE pure #-}+    pure a = V2 a a+    {-# INLINE (<*>) #-}+    (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b)++instance Applicative V1 where+    {-# INLINE pure #-}+    pure = V1 +    {-# INLINE (<*>) #-}+    (V1 f) <*> (V1 v) = V1 $ f v++-- | A vector is an additive group with additional structure.+class Functor f => Additive f where+  -- | The zero vector+  zero :: Num a => f a+  -- | Compute the sum of two vectors+  --+  -- >>> V2 1 2 ^+^ V2 3 4+  -- V2 4 6+  (^+^) :: Num a => f a -> f a -> f a++  -- | Compute the difference between two vectors+  --+  -- >>> V2 4 5 - V2 3 1+  -- V2 1 4+  (^-^) :: Num a => f a -> f a -> f a++  -- | Linearly interpolate between two vectors.+  lerp :: Num a => a -> f a -> f a -> f a++-- | Provides a fairly subjective test to see if a quantity is near zero.+--+-- >>> nearZero (1e-11 :: Double)+-- False+--+-- >>> nearZero (1e-17 :: Double)+-- True+--+-- >>> nearZero (1e-5 :: Float)+-- False+--+-- >>> nearZero (1e-7 :: Float)+-- True+class Num a => Epsilon a where+  -- | Determine if a quantity is near zero.+  nearZero :: a -> Bool++-- | @'abs' a '<=' 1e-6@+instance Epsilon Float where+  nearZero a = abs a <= 1e-6+  {-# INLINE nearZero #-}++-- | @'abs' a '<=' 1e-12@+instance Epsilon Double where+  nearZero a = abs a <= 1e-12+  {-# INLINE nearZero #-}++instance Epsilon a => Epsilon (V4 a) where+  nearZero = nearZero . quadrance+  {-# INLINE nearZero #-}++instance Epsilon a => Epsilon (V3 a) where+  nearZero = nearZero . quadrance+  {-# INLINE nearZero #-}++instance Epsilon a => Epsilon (V2 a) where+  nearZero = nearZero . quadrance+  {-# INLINE nearZero #-}++instance Epsilon a => Epsilon (V1 a) where+  nearZero (V1 a) = nearZero a+  {-# INLINE nearZero #-}++instance Additive V4 where+    zero = V4 0 0 0 0+    {-# INLINE zero #-}++    (V4 a b c d) ^+^ (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')+    {-# INLINE (^+^) #-}++    (V4 a b c d) ^-^ (V4 a' b' c' d') = V4 (a - a') (b - b') (c + c') (d + d')+    {-# INLINE (^-^) #-}+    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)+    {-# INLINE lerp #-}++instance Additive V3 where+    zero = V3 0 0 0+    {-# INLINE zero #-}++    (V3 a b c) ^+^ (V3 a' b' c') = V3 (a + a') (b + b') (c + c')+    {-# INLINE (^+^) #-}++    (V3 a b c) ^-^ (V3 a' b' c') = V3 (a - a') (b - b') (c + c')+    {-# INLINE (^-^) #-}++    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)+    {-# INLINE lerp #-}++instance Additive V2 where+    zero = V2 0 0+    {-# INLINE zero #-}++    (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b')+    {-# INLINE (^+^) #-}++    (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b')+    {-# INLINE (^-^) #-}++    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)+    {-# INLINE lerp #-}++instance Additive V1 where+    zero = V1 0+    {-# INLINE zero #-}++    (V1 a) ^+^ (V1 a') = V1 (a + a')+    {-# INLINE (^+^) #-}++    (V1 a) ^-^ (V1 a') = V1 (a - a')+    {-# INLINE (^-^) #-}++    lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)+    {-# INLINE lerp #-}++-- | Free and sparse inner product/metric spaces.+class Additive f => Metric f where+  -- | Compute the inner product of two vectors or (equivalently)+  -- convert a vector @f a@ into a covector @f a -> a@.+  --+  -- >>> V2 1 2 `dot` V2 3 4+  -- 11+  dot :: Num a => f a -> f a -> a++  -- | Compute the squared norm. The name quadrance arises from+  -- Norman J. Wildberger's rational trigonometry.+  quadrance :: Num a => f a -> a+  {-# INLINE quadrance #-}+  quadrance v = dot v v++  -- | Compute the quadrance of the difference+  qd :: Num a => f a -> f a -> a+  {-# INLINE qd #-}+  qd f g = quadrance (f ^-^ g)++  -- | Compute the distance between two vectors in a metric space+  distance :: Floating a => f a -> f a -> a+  {-# INLINE distance #-}+  distance f g = norm (f ^-^ g)++  -- | Compute the norm of a vector in a metric space+  norm :: Floating a => f a -> a+  {-# INLINE norm #-}+  norm v = sqrt (quadrance v)++  -- | Convert a non-zero vector to unit vector.+  signorm :: Floating a => f a -> f a+  signorm v = fmap (/ m) v where+    m = norm v++instance Metric V4 where+    dot (V4 a b c d) (V4 a' b' c' d') = a * a' + b * b' + c * c' + d * d'+    {-# INLINE dot #-}++    quadrance (V4 a b c d) = a * a + b * b + c * c + d * d+    {-# INLINE quadrance #-}++    norm v = sqrt (quadrance v)+    {-# INLINE norm #-}++instance Metric V3 where+    dot (V3 a b c) (V3 a' b' c') = a * a' + b * b' + c * c'+    {-# INLINE dot #-}++    quadrance (V3 a b c) = a * a + b * b + c * c+    {-# INLINE quadrance #-}++    norm v = sqrt (quadrance v)+    {-# INLINE norm #-}++instance Metric V2 where+    dot (V2 a b) (V2 a' b') = a * a' + b * b'+    {-# INLINE dot #-}++    quadrance (V2 a b) = a * a + b * b+    {-# INLINE quadrance #-}++    norm v = sqrt (quadrance v)+    {-# INLINE norm #-}++-- | Compute the right scalar product+--+-- >>> V2 3 4 ^* 2+-- V2 6 8+(^*) :: (Functor f, Num a) => f a -> a -> f a+{-# INLINE (^*) #-}+(^*) f n = fmap (* n) f++-- | Compute division by a scalar on the right.+(^/) :: (Functor f, Floating a) => f a -> a -> f a+{-# INLINE (^/) #-}+(^/) f n = fmap (/ n) f++-- | Normalize a 'Metric' functor to have unit 'norm'. This function+-- does not change the functor if its 'norm' is 0 or 1.+normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a+{-# INLINE normalize #-}+normalize v = if nearZero l || nearZero (1-l) then v+             else fmap (/ sqrt l) v+  where l = quadrance v++#endif+

@@ -0,0 +1,604 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+#define SVG_2+-- | Module defining the type of mesh patch grid.+module Graphics.Rasterific.MeshPatch+    ( -- * Types+      InterBezier( .. )+    , Derivatives( .. )+    , MeshPatch( .. )+    , CubicCoefficient( .. )++     -- * Functions+    , calculateMeshColorDerivative+    , verticeAt+    , generateLinearGrid+    , generateImageMesh++      -- * Extraction functions+      -- ** Simple+    , coonPatchAt+    , tensorPatchAt+    , coonImagePatchAt+    , tensorImagePatchAt+    , coonPatchAtWithDerivative+    , tensorPatchAtWithDerivative++      -- ** Multiple+    , coonPatchesOf+    , tensorPatchesOf+    , imagePatchesOf+    , tensorImagePatchesOf+    , cubicCoonPatchesOf+    , cubicTensorPatchesOf++      -- * Mutable mesh+    , MutableMesh+    , thawMesh+    , freezeMesh++     -- * Monadic mesh creation+    , withMesh+    , setVertice+    , getVertice+    , setHorizPoints+    , setVertPoints+    , setColor+    ) where++{-import Debug.Trace-}+{-import Text.Printf-}++import Data.Monoid( (<>) )+import Control.Monad.ST( runST )+import Control.Monad.Reader( runReaderT )+import Control.Monad.Reader.Class+import Control.Monad.Primitive( PrimMonad, PrimState )+import Data.Vector( (!) )+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Generic as VG++import Codec.Picture( Image( imageWidth, imageHeight ) )+import Graphics.Rasterific.Linear+import Graphics.Rasterific.MiniLens+import Graphics.Rasterific.Types+import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Transformations+import Graphics.Rasterific.PatchTypes++#ifdef SVG_2+slopeOf :: (Additive h, Applicative h)+        => h Float -> h Float -> h Float+        -> Point -> Point -> Point+        -> h Float+slopeOf prevColor thisColor nextColor+        prevPoint thisPoint nextPoint +  | nearZero distPrev || nearZero distNext = zero+  | otherwise = slopeVal <$> slopePrev <*> slope <*> slopeNext+  where+    distPrev = thisPoint `distance` prevPoint+    distNext = thisPoint `distance` nextPoint++    slopePrev | nearZero distPrev = zero+              | otherwise = (thisColor ^-^ prevColor) ^/ distPrev+    slopeNext | nearZero distNext = zero+              | otherwise = (nextColor ^-^ thisColor) ^/ distNext+    slope = (slopePrev ^+^ slopeNext) ^* 0.5++    slopeVal :: Float -> Float -> Float -> Float+    slopeVal sp s sn+      | signum sp /= signum sn = 0+      | abs s > abs minSlope = minSlope+      | otherwise = s+      where+        minSlope+          | abs sp < abs sn = 3 * sp+          | otherwise = 3 * sn+#else+slopeBasic :: (Additive h)+           => h Float -> h Float+           -> Point -> Point+           -> h Float+slopeBasic prevColor nextColor prevPoint nextPoint +  | nearZero d = zero+  | otherwise = (nextColor ^-^ prevColor) ^/ d+  where+    d = prevPoint `distance` nextPoint+#endif++-- | Prepare a gradient mesh to use cubic color interpolation, see+-- renderCubicMesh documentation to see the global use of this function.+calculateMeshColorDerivative :: forall px. (InterpolablePixel px)+                             => MeshPatch px -> MeshPatch (Derivative px)+calculateMeshColorDerivative mesh = mesh { _meshColors = withEdgesDerivatives } where+  withEdgesDerivatives =+     colorDerivatives V.// (topDerivative <> bottomDerivative <> leftDerivative <> rightDerivative)+  colorDerivatives =+     V.fromListN (w * h) [interiorDerivative x y | y <- [0 .. h - 1], x <- [0 .. w - 1]]++  w = _meshPatchWidth mesh + 1+  h = _meshPatchHeight mesh + 1+  clampX = max 0 . min (w - 1)+  clampY = max 0 . min (h - 1)++  rawColorAt x y =_meshColors mesh V.! (y * w + x)+  atColor x y = toFloatPixel $ rawColorAt (clampX x) (clampY y)+#ifdef SVG_2+  isOnVerticalBorder x = x == 0 || x == w - 1 +  isOnHorizontalBorder y = y == 0 || y == h - 1+#endif++  pointAt x y = verticeAt mesh (clampX x) (clampY y)+  derivAt x y = colorDerivatives  V.! (y * w + x)+++  topDerivative = +    [edgeDerivative yDerivative 0 1 x 0 | x <- [1 .. w - 2]]+  bottomDerivative = +    [edgeDerivative yDerivative 0 (-1) x (h - 1) | x <- [1 .. w - 2]]+  leftDerivative =+    [edgeDerivative xDerivative 1 0 0 y | y <- [1 .. h - 2]]+  rightDerivative = +    [edgeDerivative xDerivative (-1) 0 (w - 1) y | y <- [1 .. h - 2]]++  edgeDerivative :: Lens' (Derivative px) (Holder px Float) -> Int -> Int -> Int -> Int+                 -> (Int, Derivative px)+  edgeDerivative coord dx dy x y+    | nearZero d = (ix, oldDeriv)+    | otherwise = (ix, oldDeriv & coord .~ otherDeriv)+    where+      ix = y * w + x+      oldDeriv = derivAt x y+      derivs = oldDeriv .^ coord+      otherDeriv = (c ^/ d) ^-^ derivs+      c = (atColor (x+dx) (y+dy) ^-^ atColor x y) ^* 2+      d = pointAt (x+dx) (y+dy) `distance` pointAt x y++  -- General case+  interiorDerivative x y+#ifdef SVG_2+    | isOnHorizontalBorder y && isOnVerticalBorder x = Derivative thisColor zero zero zero+    | isOnHorizontalBorder y = Derivative thisColor dx zero zero+    | isOnVerticalBorder x = Derivative thisColor zero dy zero+#endif+    | otherwise = Derivative thisColor dx dy dxy+    where+#ifdef SVG_2+      dx = slopeOf+          cxPrev thisColor cxNext+          xPrev this xNext+      +      dy = slopeOf+          cyPrev thisColor cyNext+          yPrev this yNext+          -- -}+      +      dxy = zero+#else+      dx = slopeBasic cxPrev cxNext xPrev xNext+      dy = slopeBasic cyPrev cyNext yPrev yNext++      dxy | nearZero xyDist = zero+          | otherwise = (cxyNext ^-^ cyxPrev ^-^ cyxNext ^+^ cxyPrev) ^/ (xyDist)+      xyDist = (xNext `distance` xPrev) * (yNext `distance` yPrev)++      cxyPrev = atColor (x - 1) (y - 1)+      xyPrev = pointAt (x - 1) (y - 1)++      cxyNext = atColor (x + 1) (y + 1)+      xyNext = pointAt (x + 1) (y + 1)++      cyxPrev = atColor (x - 1) (y + 1)+      yxPrev = pointAt (x - 1) (y + 1)++      cyxNext = atColor (x + 1) (y - 1)+      yxNext = pointAt (x + 1) (y - 1)+#endif++      cxPrev = atColor (x - 1) y+      thisColor = atColor x y+      cxNext = atColor (x + 1) y+      +      cyPrev = atColor x (y - 1)+      cyNext = atColor x (y + 1)+      +      xPrev = pointAt (x - 1) y+      this  = pointAt x y+      xNext = pointAt (x + 1) y+      +      yPrev = pointAt x (y - 1)+      yNext = pointAt x (y + 1)++-- | Mutable version of a MeshPatch+data MutableMesh s px = MutableMesh+  { _meshMutWidth :: !Int+  , _meshMutHeight :: !Int+  , _meshMutPrimaryVertices :: !(MV.MVector s Point)+  , _meshMutHorizSecondary :: !(MV.MVector s InterBezier)+  , _meshMutVertSecondary :: !(MV.MVector s InterBezier)+  , _meshMutColors :: !(MV.MVector s px)+  , _meshMutTensorDerivatives :: !(Maybe (MV.MVector s Derivatives))+  }++-- | Normal mesh to mutable mesh+thawMesh :: PrimMonad m => MeshPatch px -> m (MutableMesh (PrimState m) px)+thawMesh MeshPatch { .. } = do+  let _meshMutWidth = _meshPatchWidth+      _meshMutHeight = _meshPatchHeight+  _meshMutPrimaryVertices <- V.thaw _meshPrimaryVertices +  _meshMutHorizSecondary <- V.thaw _meshHorizontalSecondary+  _meshMutVertSecondary <- V.thaw _meshVerticalSecondary+  _meshMutColors <- V.thaw _meshColors+  _meshMutTensorDerivatives <- case _meshTensorDerivatives of+      Nothing -> return Nothing+      Just v -> Just <$> V.thaw v+  return MutableMesh { .. }++-- | Mutable mesh to freezed mesh.+freezeMesh :: PrimMonad m => MutableMesh (PrimState m) px -> m (MeshPatch px)+freezeMesh MutableMesh { .. } = do+  let _meshPatchWidth = _meshMutWidth+      _meshPatchHeight = _meshMutHeight+  _meshPrimaryVertices <- V.freeze _meshMutPrimaryVertices +  _meshHorizontalSecondary <- V.freeze _meshMutHorizSecondary+  _meshVerticalSecondary <- V.freeze _meshMutVertSecondary+  _meshTensorDerivatives <- case _meshMutTensorDerivatives of+        Nothing -> return Nothing+        Just v -> Just <$> V.freeze v+  _meshColors <- V.freeze _meshMutColors+  return MeshPatch { .. }++-- | Retrieve a mesh primary vertice purely+verticeAt :: MeshPatch px+          -> Int -- ^ Between 0 and _meshPatchWidth + 1 (excluded)+          -> Int -- ^ Between 0 and _meshPatchHeight + 1 (excluded)+          -> Point+verticeAt m x y = _meshPrimaryVertices m ! idx where+    idx = y * (_meshPatchWidth m + 1) + x++-- | Given an original MeshPatch, provide context to mutate it through+-- modification functions.+withMesh :: MeshPatch px+         -> (forall m. (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) =>+                        m a)+         -> (a, MeshPatch px)+withMesh mesh act = runST $ do+  mut <- thawMesh  mesh+  v <- runReaderT act mut+  final <- freezeMesh mut+  return (v, final)++-- | Set the vertice of a mesh at a given coordinate+setVertice :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+           => Int   -- ^ x coordinate in [0, w]+           -> Int   -- ^ y coordinate in [0, h]+           -> Point -- ^ new point value+           -> m ()+setVertice x y p = do+  MutableMesh { .. } <- ask+  let idx = y * (_meshMutWidth + 1) + x+  MV.write _meshMutPrimaryVertices idx p++-- | Get the position of vertice+getVertice :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+           => Int -> Int -> m Point+getVertice x y = do+  p <- ask+  let idx = y * (_meshMutWidth p + 1) + x+  MV.read (_meshMutPrimaryVertices p) idx++-- | Set the two control bezier points horizontally+setHorizPoints :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+               => Int -> Int -> InterBezier -> m ()+setHorizPoints x y p = do+  MutableMesh { .. } <- ask+  let idx = y * _meshMutWidth + x+  MV.write _meshMutHorizSecondary idx p++-- | Set the two control bezier points vertically+setVertPoints :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+              => Int -> Int -> InterBezier -> m ()+setVertPoints x y p = do+  MutableMesh { .. } <- ask+  let idx = y * (_meshMutWidth + 1) + x+  MV.write _meshMutVertSecondary idx p+++-- | Set the value associated to a vertex+setColor :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+         => Int -> Int -> px -> m ()+setColor x y p = do+  MutableMesh { .. } <- ask+  let idx = y * (_meshMutWidth + 1) + x+  MV.write _meshMutColors idx p++-- | Generate a meshpatch at the size given by the image and+-- a number of cell in a mesh+generateImageMesh :: Int      -- ^ Horizontal cell count+                  -> Int      -- ^ Vertical cell count+                  -> Point    -- ^ Position of the corner upper left+                  -> Image px -- ^ Image to transform through a mesh+                  -> MeshPatch (ImageMesh px)+generateImageMesh w h base img = generateLinearGrid w h base (V2 dx dy) infos where+  dx = fromIntegral (imageWidth img) / fromIntegral w+  dy = fromIntegral (imageHeight img) / fromIntegral h+  infos = V.fromListN ((w + 1) * (h + 1))+    [ImageMesh img $ trans <> scaling+        | y <- [0 .. h]+        , x <- [0 .. w]+        , let fx = fromIntegral x+              fy = fromIntegral y+              trans = translate (V2 (fx * dx) (fy * dy))+              scaling = scale dx dy]+++-- | Generate a valid gradient with the shape of a simple grid+-- using some simple information. You can use `thawMesh` and `freezeMesh`+-- to mutate it.+generateLinearGrid :: Int           -- ^ Width in patch+                   -> Int           -- ^ Height in patch+                   -> Point         -- ^ Position of the upper left corner+                   -> V2 Float      -- ^ Size of each patch in x adn y+                   -> V.Vector px   -- ^ Vector of values, size must be (width + 1) * (height + 1)+                   -> MeshPatch px+generateLinearGrid w h base (V2 dx dy) colors = MeshPatch+  { _meshPatchWidth = w+  , _meshPatchHeight = h+  , _meshPrimaryVertices = vertices +  , _meshHorizontalSecondary = hSecondary +  , _meshVerticalSecondary = vSecondary+  , _meshTensorDerivatives = Nothing+  , _meshColors = colors+  }+  where+    vertexCount = (w + 1) * (h + 1)+    vertices =+      V.fromListN vertexCount [base ^+^ V2 (dx * fromIntegral x) (dy * fromIntegral y)+                                        | y <- [0 .. h], x <- [0 .. w]]+    at x y = vertices ! (y * (w + 1) + x)+    hSecondary = V.fromListN ((h + 1) * w)+        [InterBezier (p0 ^+^ delta ^* (1/3)) (p0 ^+^ delta ^* (2/3))+            | y <- [0 .. h], x <- [0 .. w - 1]+            , let p0 = at x y+                  p1 = at (x + 1) y+                  delta = p1 ^-^ p0+            ]++    vSecondary = V.fromListN ((w + 1) * h)+        [InterBezier (p0 ^+^ delta ^* (1/3)) (p0 ^+^ delta ^* (2/3))+            | y <- [0 .. h - 1], x <- [0 .. w]+            , let p0 = at x y+                  p1 = at x (y + 1)+                  delta = p1 ^-^ p0+            ]++type ColorPreparator px pxt = ParametricValues px -> pxt++-- | Extract a coon patch at a given position.+coonPatchAt :: MeshPatch px+            -> Int -- ^ x+            -> Int -- ^ y+            -> CoonPatch (ParametricValues px)+coonPatchAt = coonPatchAt' id++-- | Extract a tensor patch at a given position+tensorPatchAt :: MeshPatch px+              -> Int -- ^ x+              -> Int -- ^ y+              -> TensorPatch (ParametricValues px)+tensorPatchAt = tensorPatchAt' id++-- | Extract an image patch out of a mesh at a given position.+coonImagePatchAt :: MeshPatch (ImageMesh px)+                 -> Int -- ^ x+                 -> Int -- ^ y+                 -> CoonPatch (ImageMesh px)+coonImagePatchAt = coonPatchAt' _northValue+++-- | Extract a tensor image patch out of a mesh at+-- a given position.+tensorImagePatchAt :: MeshPatch (ImageMesh px)+                   -> Int -- ^ x+                   -> Int -- ^ y+                   -> TensorPatch (ImageMesh px)+tensorImagePatchAt = tensorPatchAt' _northValue++-- | Extract a coon patch for cubic interpolation at a given position+-- see `calculateMeshColorDerivative`+coonPatchAtWithDerivative :: (InterpolablePixel px)+                          => MeshPatch (Derivative px)+                          -> Int -- ^ x+                          -> Int -- ^ y+                          -> CoonPatch (CubicCoefficient px)+coonPatchAtWithDerivative = coonPatchAt' cubicPreparator++-- | Extract a tensor patch for cubic interpolation at a given position+-- see `calculateMeshColorDerivative`+tensorPatchAtWithDerivative :: (InterpolablePixel px)+                            => MeshPatch (Derivative px)+                            -> Int -- ^ x+                            -> Int -- ^ y+                            -> TensorPatch (CubicCoefficient px)+tensorPatchAtWithDerivative = tensorPatchAt' cubicPreparator++rawMatrix :: V.Vector (V.Vector Float)+rawMatrix = V.fromListN 16 $ V.fromListN 16 <$>+  [ [ 1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0 ]+  , [ 0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0 ]+  , [-3, 3, 0, 0, -2,-1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0 ]+  , [ 2,-2, 0, 0,  1, 1, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0 ]+  , [ 0, 0, 0, 0,  0, 0, 0, 0,  1, 0, 0, 0,  0, 0, 0, 0 ]+  , [ 0, 0, 0, 0,  0, 0, 0, 0,  0, 0, 0, 0,  1, 0, 0, 0 ]+  , [ 0, 0, 0, 0,  0, 0, 0, 0, -3, 3, 0, 0, -2,-1, 0, 0 ]+  , [ 0, 0, 0, 0,  0, 0, 0, 0,  2,-2, 0, 0,  1, 1, 0, 0 ]+  , [-3, 0, 3, 0,  0, 0, 0, 0, -2, 0,-1, 0,  0, 0, 0, 0 ]+  , [ 0, 0, 0, 0, -3, 0, 3, 0,  0, 0, 0, 0, -2, 0,-1, 0 ]+  , [ 9,-9,-9, 9,  6, 3,-6,-3,  6,-6, 3,-3,  4, 2, 2, 1 ]+  , [-6, 6, 6,-6, -3,-3, 3, 3, -4, 4,-2, 2, -2,-2,-1,-1 ]+  , [ 2, 0,-2, 0,  0, 0, 0, 0,  1, 0, 1, 0,  0, 0, 0, 0 ]+  , [ 0, 0, 0, 0,  2, 0,-2, 0,  0, 0, 0, 0,  1, 0, 1, 0 ]+  , [-6, 6, 6,-6, -4,-2, 4, 2, -3, 3,-3, 3, -2,-1,-2,-1 ]+  , [ 4,-4,-4, 4,  2, 2,-2,-2,  2,-2, 2,-2,  1, 1, 1, 1 ]+  ]++cubicPreparator :: (InterpolablePixel px)+                => ParametricValues (Derivative px)+                -> CubicCoefficient px+cubicPreparator ParametricValues { .. } =+    CubicCoefficient $ ParametricValues (sliceAt 0) (sliceAt 4) (sliceAt 8) (sliceAt 12) where+  Derivative c00 fx00 fy00 fxy00 = _northValue+  Derivative c10 fx10 fy10 fxy10 = _eastValue+  Derivative c01 fx01 fy01 fxy01 = _westValue+  Derivative c11 fx11 fy11 fxy11 = _southValue++  resultVector = mulVec $ V.fromListN 16+    [  c00,   c10,   c01,   c11+    , fx00,  fx10,  fx01,  fx11 +    , fy00,  fy10,  fy01,  fy11 +    ,fxy00, fxy10, fxy01, fxy11+    ]++  mulVec vec = VG.foldl' (^+^) zero . VG.zipWith (^*) vec <$> rawMatrix++  sliceAt i = V4 +    (resultVector V.! i)+    (resultVector V.! (i + 1))+    (resultVector V.! (i + 2))+    (resultVector V.! (i + 3))++tensorPatchAt' :: ColorPreparator px pxt -> MeshPatch px -> Int -> Int+               -> TensorPatch pxt+tensorPatchAt' preparator mesh@MeshPatch { _meshTensorDerivatives = Nothing } x y =+    toTensorPatch $ coonPatchAt' preparator mesh x y+tensorPatchAt' preparator mesh x y = TensorPatch+  { _curve0 = CubicBezier p00 p01 p02 p03+  , _curve1 = CubicBezier p10 p11 p12 p13+  , _curve2 = CubicBezier p20 p21 p22 p23+  , _curve3 = CubicBezier p30 p31 p32 p33+  , _tensorValues = preparator $ ParametricValues+        { _northValue = c00+        , _eastValue  = c03+        , _southValue = c33+        , _westValue  = c30+        }+  }+  where+    w = _meshPatchWidth mesh+    vertices = _meshPrimaryVertices mesh+    colors = _meshColors mesh+    +    hInter = _meshHorizontalSecondary mesh+    vInter = _meshVerticalSecondary mesh+    +    baseIx = (w + 1) * y + x+    p00 = vertices ! baseIx+    c00 = colors   ! baseIx+    +    p03 = vertices ! (baseIx + 1)+    c03 = colors   ! (baseIx + 1)+    +    p30 = vertices ! (baseIx + w + 1)+    c30 = colors   ! (baseIx + w + 1)+    p33 = vertices ! (baseIx + w + 2)+    c33 = colors   ! (baseIx + w + 2)+    +    baseH = w * y + x+    InterBezier p01 p02 = hInter ! baseH+    InterBezier p31 p32 = hInter ! (baseH + w)++    baseV = (w + 1) * y + x+    InterBezier p10 p20 = vInter ! baseV+    InterBezier p13 p23 = vInter ! (baseV + 1)++    Derivatives p11 p12 p21 p22 = case _meshTensorDerivatives mesh of+      Nothing -> error "Not a tensor patch"+      Just v -> v ! (w * y + x)+++coonPatchAt' :: ColorPreparator px pxt+             -> MeshPatch px -> Int -> Int -> CoonPatch pxt+coonPatchAt' preparator mesh x y = CoonPatch +    { _north = CubicBezier p00 p01 p02 p03+    , _east  = CubicBezier p03 p13 p23 p33+    , _south = CubicBezier p33 p32 p31 p30+    , _west  = CubicBezier p30 p20 p10 p00+    , _coonValues = preparator $ ParametricValues+        { _northValue = c00+        , _eastValue  = c03+        , _southValue = c33+        , _westValue  = c30+        }+    }+  where+    w = _meshPatchWidth mesh+    vertices = _meshPrimaryVertices mesh+    colors = _meshColors mesh+    +    hInter = _meshHorizontalSecondary mesh+    vInter = _meshVerticalSecondary mesh+    +    baseIx = (w + 1) * y + x+    p00 = vertices ! baseIx+    c00 = colors   ! baseIx+    +    p03 = vertices ! (baseIx + 1)+    c03 = colors   ! (baseIx + 1)+    +    p30 = vertices ! (baseIx + w + 1)+    c30 = colors   ! (baseIx + w + 1)+    p33 = vertices ! (baseIx + w + 2)+    c33 = colors   ! (baseIx + w + 2)+    +    baseH = w * y + x+    InterBezier p01 p02 = hInter ! baseH+    InterBezier p31 p32 = hInter ! (baseH + w)++    baseV = (w + 1) * y + x+    InterBezier p10 p20 = vInter ! baseV+    InterBezier p13 p23 = vInter ! (baseV + 1)++-- | Extract a list of all the coon patches of the mesh.+coonPatchesOf :: MeshPatch px -> [CoonPatch (ParametricValues px)]+coonPatchesOf mesh@MeshPatch { .. } =+  [coonPatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract a list of all the tensor patches of the mesh.+tensorPatchesOf :: MeshPatch px -> [TensorPatch (ParametricValues px)]+tensorPatchesOf mesh@MeshPatch { .. } =+  [tensorPatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract all the coon patch of a mesh using an image interpolation.+imagePatchesOf :: MeshPatch (ImageMesh px) -> [CoonPatch (ImageMesh px)]+imagePatchesOf mesh@MeshPatch { .. } =+  [coonImagePatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract all the tensor patch of a mesh using an image interpolation.+tensorImagePatchesOf :: MeshPatch (ImageMesh px) -> [TensorPatch (ImageMesh px)]+tensorImagePatchesOf mesh@MeshPatch { .. } =+  [tensorImagePatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract all the coon patch of a mesh using cubic interpolation.+cubicCoonPatchesOf :: (InterpolablePixel px)+                   => MeshPatch (Derivative px)+                   -> [CoonPatch (CubicCoefficient px)]+cubicCoonPatchesOf mesh@MeshPatch { .. } =+  [coonPatchAtWithDerivative mesh x y+        | y <- [0 .. _meshPatchHeight - 1]+        , x <- [0 .. _meshPatchWidth - 1] ]++-- | Extract all the tensor patch of a mesh using cubic interpolation.+cubicTensorPatchesOf :: (InterpolablePixel px)+                     => MeshPatch (Derivative px)+                     -> [TensorPatch (CubicCoefficient px)]+cubicTensorPatchesOf mesh@MeshPatch { .. } =+  [tensorPatchAtWithDerivative mesh x y+        | y <- [0 .. _meshPatchHeight - 1]+        , x <- [0 .. _meshPatchWidth - 1] ]+

@@ -25,9 +25,12 @@ import Numeric( showFFloat ) import Data.Monoid( (<>) ) import qualified Data.Foldable as F+import Data.Word( Word32 ) import Data.ByteString.Builder( byteString                               , intDec                               , toLazyByteString+                              , word32BE+                              , word8                               , Builder ) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB@@ -45,12 +48,16 @@ import Graphics.Rasterific.Compositor import Graphics.Rasterific.Command import Graphics.Rasterific.CubicBezier+import Graphics.Rasterific.PlaneBoundable import Graphics.Rasterific.Line import Graphics.Rasterific.Immediate import Graphics.Rasterific.Operators import Graphics.Rasterific.Transformations import Graphics.Rasterific.PathWalker import Graphics.Rasterific.ComplexPrimitive+import Graphics.Rasterific.Patch+import Graphics.Rasterific.PatchTypes+import Graphics.Rasterific.MeshPatch import Graphics.Text.TrueType( Dpi ) import Text.Printf {-import Debug.Trace-}@@ -341,7 +348,30 @@     BezierPrim b -> toPdf b     CubicBezierPrim c -> toPdf c +instance PdfColorable px => ToPdf (V2 Double, V2 Float, V2 Float, TensorPatch (ParametricValues px)) where+  toPdf (V2 sx sy, V2 dx dy, V2 _tx ty, patch) = word8 0 <> coords <> foldMap colorToBinaryPdf [c00, c03, c33, c30] where+    fx x = floor . max 0 . min maxi $ realToFrac (x + dx) * sx+    fy y = floor . max 0 . min maxi $ realToFrac (ty - (y + dy)) * sy +    maxi = fromIntegral (maxBound :: Word32)++    coords = foldMap word32BE+       [ fx x00, fy y00, fx x01, fy y01, fx x02, fy y02, fx x03, fy y03+       , fx x13, fy y13, fx x23, fy y23, fx x33, fy y33, fx x32, fy y32+       , fx x31, fy y31, fx x30, fy y30, fx x20, fy y20, fx x10, fy y10+       , fx x11, fy y11, fx x12, fy y12, fx x22, fy y22, fx x21, fy y21 ]++    CubicBezier (V2 x00 y00) (V2 x10 y10) (V2 x20 y20) (V2 x30 y30) = _curve0 patch+    CubicBezier (V2 x01 y01) (V2 x11 y11) (V2 x21 y21) (V2 x31 y31) = _curve1 patch+    CubicBezier (V2 x02 y02) (V2 x12 y12) (V2 x22 y22) (V2 x32 y32) = _curve2 patch+    CubicBezier (V2 x03 y03) (V2 x13 y13) (V2 x23 y23) (V2 x33 y33) = _curve3 patch+    param = _tensorValues patch++    c00 = _northValue param+    c30 = _eastValue param+    c33 = _southValue param+    c03 = _westValue param+ -------------------------------------------------- ----            Helper functions --------------------------------------------------@@ -444,6 +474,48 @@     coords = arrayOf $ toPdf center <> tp " " <> toPdf radius                     <> " " <> toPdf focus <> tp " 0" +meshGradientObject :: PdfColorable px => MeshPatch px -> Int -> PdfId -> PdfObject+meshGradientObject mesh height pid = PdfObject+  { _pdfId       = pid+  , _pdfRevision = 0+  , _pdfAnnot    =+      [ ("ShadingType", "7")+      , ("ColorSpace", "/DeviceRGB")+      , ("BitsPerComponent", "8")+      , ("BitsPerCoordinate", "32")+      , ("BitsPerFlag", "8")+      , ("Decode", B.pack $ printf "[%g %g %g %g 0 1 0 1 0 1]" +                                     x0 x1 (fromIntegral height - y1)+                                     (fromIntegral height - y0))+      ]+  , _pdfStream = buildToStrict+               . foldMap (\patch -> toPdf (scal, transl, fullSize, patch))+               $ tensorPatchesOf mesh+  }+  where+    maxi = fromIntegral (maxBound :: Word32)+    scaleOf :: Float -> Float -> Double+    scaleOf a b | nearZero $ a - b = 0+                | otherwise = maxi / (realToFrac b - realToFrac a)++    fullSize = V2 (x1 - x0) (y1 - y0)+    transl = V2 (-x0) (-y0)+    scal = V2 (scaleOf x0 x1) (scaleOf y0 y1)+    PlaneBound (V2 x0 y0) (V2 x1 y1) =+      foldMeshPoints (\v -> mappend v . planeBounds) mempty mesh++createMeshGradient :: forall px. PdfBaseColorable px+                   => Builder -> MeshPatch px -> PdfEnv (Either String Builder)+createMeshGradient inner mesh = do+  height <- asks _pdfHeight      +  meshId <- generateObject $ meshGradientObject mesh height +  patId <- generateObject (gradientPatternObject mempty meshId)+  pat <- namePatternObject $ refOf patId+  pure . pure $+    "/Pattern cs\n" <> pat <> " scn\n" <>+    "/Pattern CS\n" <> pat <> " SCN\n" <> inner++ contentObject :: B.ByteString -> PdfId -> PdfObject contentObject content pid = PdfObject   { _pdfId       = pid@@ -461,15 +533,19 @@ class RenderablePixel px => PdfColorable px where   pdfColorSpace :: Proxy px -> B.ByteString   colorToPdf :: px -> Builder+  colorToBinaryPdf :: px -> Builder  instance PdfColorable Pixel8 where   pdfColorSpace _ = "/DeviceGray"   colorToPdf c = toPdf (fromIntegral c / 255 :: Float)+  colorToBinaryPdf = word8  instance PdfColorable PixelRGBA8 where   pdfColorSpace _ = "/DeviceRGB"   colorToPdf (PixelRGBA8 r g b _a) =       colorToPdf r <> tp " " <> colorToPdf g <> tp " " <> colorToPdf b+  colorToBinaryPdf (PixelRGBA8 r g b _a) = +     colorToBinaryPdf r <> colorToBinaryPdf g <> colorToBinaryPdf b   maskObject :: PdfId -> PdfId -> PdfObject@@ -789,6 +865,7 @@ opacityToPdf comp = fromIntegral comp / fromIntegral fv where   fv = fullValue :: n + textureToPdf :: forall px. PdfBaseColorable px              => Transformation -> Builder -> Texture px              -> PdfEnv (Either String Builder)@@ -797,6 +874,7 @@     SampledTexture _img -> return $ Left "Unsupported raw image in PDF output."     ShaderTexture  _f -> return $ Left "Unsupported shader function in PDF output."     ModulateTexture _tx _modulation -> return $ Left "Unsupported modulation in PDF output."+    AlphaModulateTexture _tx _modulation -> return $ Left "Unsupported alpha modulation in PDF output."     RawTexture img -> go currTrans sampler (SampledTexture img)     WithSampler newSampler tx -> go currTrans newSampler tx     SolidTexture px | isPixelTransparent px -> do@@ -807,6 +885,7 @@     SolidTexture px ->       pure . pure $ "/ao gs " <> co <> " rg\n" <> co <> " RG\n" <> inner         where co = colorToPdf px+    MeshPatchTexture _ mesh -> createMeshGradient inner mesh     LinearGradientTexture grad line -> createLinearGradient inner currTrans sampler grad line     RadialGradientTexture grad center radius ->        go currTrans sampler $ RadialGradientWithFocusTexture grad center radius center@@ -954,6 +1033,14 @@      => Bool -> Transformation -> (FillMethod -> Builder) -> Texture px      -> DrawCommand px (Free (DrawCommand px) ()) -> PdfEnv Builder   go forceInverse activeTrans filler prevTexture com = case com of+     CustomRender _mesh next -> recurse next+     MeshPatchRender i m next -> do+       w <- asks $ fromIntegral . _pdfWidth+       h <- asks $ fromIntegral . _pdfHeight+       let rect = rectangle (V2 0 0) w h+       go forceInverse activeTrans filler prevTexture $+         SetTexture (MeshPatchTexture i m) (liftF $ Fill FillWinding rect ()) next+                 Fill method prims next -> do        after <- recurse next        pure $ foldMap pathToPdf (resplit prims)

@@ -1,13 +1,16 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-} module Graphics.Rasterific.MiniLens     ( -- * Types       Lens     , Lens'     , Traversal     , Traversal'+    , lens        -- * Getter     , (.^)+    , view     , use        -- * Setter@@ -15,16 +18,31 @@     , (.=)     , (%=)     , (+=)+    , set++      -- * Helper+    , (&)     ) where  import Control.Monad.Identity import Control.Applicative import Control.Monad.State        as State +#if MIN_VERSION_base(4,8,0)+import Data.Function( (&) )+#endif+ infixl 8 .^ infixr 4 .~ infix  4 .=,%=,+= +#if !MIN_VERSION_base(4,8,0)+infixl 1 &++(&) :: a -> (a -> b) -> b+x & f = f x+#endif+ -- | Does it look familiar? yes it's the official -- Lens type. type Lens s t a b =@@ -40,22 +58,37 @@  type Traversal' s a = Traversal s s a a +-- | Create a full lens out of setter and getter+lens :: (s -> a)+     -> (s -> b -> t)+     -> Lens s t a b+{-# INLINE lens #-}+lens accessor setter = \f src ->+  fmap (setter src) $ f (accessor src) +view :: s -> Lens s t a b -> a+{-# INLINE view #-}+view v l = getConst (l Const v)+ (.^) :: s -> Lens s t a b -> a {-# INLINE (.^) #-}-(.^) v l = getConst (l Const v)+(.^) = view -(.~) :: s -> Lens' s a -> a -> s+set :: Lens' s a -> a -> s -> s+{-# INLINE set #-}+set l new v = runIdentity $ l (\_ -> Identity new) v++(.~) :: Lens' s a -> a -> s -> s {-# INLINE (.~) #-}-(.~) v l new = runIdentity $ l (\_ -> Identity new) v+(.~) = set  (.=) :: MonadState s m => Lens' s a -> a -> m () {-# INLINE (.=) #-}-(.=) l v = State.modify $ \s -> (s .~ l) v+(.=) l v = State.modify (l .~ v)  (%=) :: MonadState s m => Lens' s a -> (a -> a) -> m () {-# INLINE (%=) #-}-(%=) l f = State.modify $ \s -> (s .~ l) $ f (s .^ l)+(%=) l f = State.modify $ \s -> s & l .~ f (s .^ l)  (+=) :: (Num a, MonadState s m) => Lens' s a -> a -> m () {-# INLINE (+=) #-}

@@ -120,7 +120,7 @@  -- | Given two points, return a point in the middle -- of them.-midPoint :: (Additive a) => a Float -> a Float -> a Float+midPoint :: (Additive a, Fractional coord) => a coord -> a coord -> a coord {-# INLINE midPoint #-} midPoint a b = (a ^+^ b) ^* 0.5 

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

@@ -0,0 +1,396 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Graphics.Rasterific.PatchTypes+  ( -- * New geometry+    CoonPatch( .. )+  , TensorPatch( .. )+  , MeshPatch( .. )+  , InterBezier( .. )++    -- * Types+  , CoonColorWeight+  , PatchInterpolation( .. )+  , ParametricValues( .. )+  , Derivative( .. )+  , Derivatives( .. )+  , UV+  , UVPatch+  , CubicCoefficient( .. )+  , ImageMesh( .. )++    -- * Helper functions+  , transposeParametricValues +  , coonPointAt+  , toTensorPatch+  , foldMeshPoints+  , isVerticalOrientation++    -- * Lenses+  , xDerivative+  , yDerivative+  ) where++import Data.Monoid( (<>) )+import qualified Data.Vector as V++import Codec.Picture( Image )++import Graphics.Rasterific.CubicBezier+import Graphics.Rasterific.MiniLens+import Graphics.Rasterific.Linear+import Graphics.Rasterific.Types+import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Transformations++-- | Type of coordinate interpolation+type CoonColorWeight = Float++-- | How do we want to perform color/image interpolation+-- within the patch.+data PatchInterpolation+  = -- | Bilinear interpolation+    --+    -- @+    -- import qualified Data.Vector as V+    -- let colorCycle = cycle+    --       [ PixelRGBA8 0 0x86 0xc1 255+    --       , PixelRGBA8 0xff 0xf4 0xc1 255+    --       , PixelRGBA8 0xFF 0x53 0x73 255+    --       , PixelRGBA8 0xff 0xf4 0xc1 255+    --       , PixelRGBA8 0 0x86 0xc1 255]+    --     colors = V.fromListN (4 * 4) colorCycle+    -- renderMeshPatch PatchBilinear $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors+    -- @+    --+    -- <<docimages/mesh_patch_interp_bilinear.png>>+    --+    PatchBilinear+    -- | Bicubic interpolation+    --+    -- @+    -- import qualified Data.Vector as V+    -- let colorCycle = cycle+    --       [ PixelRGBA8 0 0x86 0xc1 255+    --       , PixelRGBA8 0xff 0xf4 0xc1 255+    --       , PixelRGBA8 0xFF 0x53 0x73 255+    --       , PixelRGBA8 0xff 0xf4 0xc1 255+    --       , PixelRGBA8 0 0x86 0xc1 255]+    --     colors = V.fromListN (4 * 4) colorCycle+    -- renderMeshPatch PatchBicubic $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors+    -- @+    --+    -- <<docimages/mesh_patch_interp_bicubic.png>>+    --+  | PatchBicubic+  deriving (Eq, Show)++-- | Values associated to the corner of a patch+--+-- @+--  North               East+--      +--------------++--      |0            1|+--      |              |+--      |              |+--      |              |+--      |3            2|+--      +--------------++--  West                South+-- @+--+data ParametricValues a = ParametricValues+  { _northValue :: !a+  , _eastValue  :: !a+  , _southValue :: !a+  , _westValue  :: !a+  }+  deriving (Functor, Show)++-- | Store the derivative necessary for cubic interpolation in+-- the gradient mesh.+data Derivative px = Derivative+  { _derivValues :: !(Holder px Float)+  , _xDerivative :: !(Holder px Float)+  , _yDerivative :: !(Holder px Float)+  , _xyDerivative :: !(Holder px Float)+  }++deriving instance Show (Holder px Float) => Show (Derivative px)++-- | Helping lens+xDerivative :: Lens' (Derivative px) (Holder px Float)+xDerivative = lens _xDerivative setter where+  setter o v = o { _xDerivative = v }++-- | Help lens+yDerivative :: Lens' (Derivative px) (Holder px Float)+yDerivative = lens _yDerivative setter where+  setter o v = o { _yDerivative = v }++instance Applicative ParametricValues where+    pure a = ParametricValues a a a a+    ParametricValues n e s w <*> ParametricValues n' e' s' w' =+        ParametricValues (n n') (e e') (s s') (w w')++instance Foldable ParametricValues where+  foldMap f (ParametricValues n e s w) = f n <> f e <> f s <> f w++-- | Transpose (switch vertical/horizontal orientation) of values.+transposeParametricValues :: ParametricValues a -> ParametricValues a+transposeParametricValues (ParametricValues n e s w) = ParametricValues n w s e++-- | Describe a tensor patch+data TensorPatch weight = TensorPatch+  { _curve0 :: !CubicBezier+  , _curve1 :: !CubicBezier+  , _curve2 :: !CubicBezier+  , _curve3 :: !CubicBezier+  , _tensorValues :: !weight+  }++isVerticalOrientation :: TensorPatch a -> Bool+isVerticalOrientation p = dy > dx where+  CubicBezier a _ _ d = _curve0 p+  V2 dx dy = abs <$> (d ^-^ a)++instance Transformable (TensorPatch px) where+  transform f (TensorPatch c0 c1 c2 c3 v) =+    TensorPatch+        (transform f c0)+        (transform f c1)+        (transform f c2)+        (transform f c3)+        v+  transformM f (TensorPatch c0 c1 c2 c3 v) =+    TensorPatch+        <$> transformM f c0+        <*> transformM f c1+        <*> transformM f c2+        <*> transformM f c3+        <*> return v+++instance {-# OVERLAPPING #-} PointFoldable (TensorPatch px) where+  foldPoints f acc (TensorPatch c0 c1 c2 c3 _) = g c3 . g c2 . g c1 $ g c0 acc+    where g v a = foldPoints f a v++-- | Define the boundary and interpolated values of a coon patch.+--+-- @+--                        ----->+--                  North     _____----------------++--   ^          +------------//                     // .+--   |         //                                  //       |+--   |        //                                  //        |+--   |       //                                  //  east   |+--   | west |                                  /          |+--          |                                 |           v+--           \\                                 \\   .+--            \\                  __-------------++--             +----------------/+--                    South+--                       <-----+-- @+--+data CoonPatch weight = CoonPatch+    { _north :: !CubicBezier -- ^ North border, from left to right at top+    , _east :: !CubicBezier  -- ^ East obrder, from top to bottom+    , _south :: !CubicBezier -- ^ South border from right to left+    , _west :: !CubicBezier  -- ^ West border from bottom to top+    , _coonValues :: !weight -- ^ The patch values+    }+    deriving Show++instance {-# OVERLAPPING #-} Transformable (CoonPatch px) where+  transformM = transformCoonM+  transform = transformCoon ++instance {-# OVERLAPPING #-} PointFoldable (CoonPatch px) where+  foldPoints f acc (CoonPatch n e s w _) = g n . g e . g s $ g w acc+    where g v a = foldPoints f a v++transformCoonM :: Monad m => (Point -> m Point) -> CoonPatch px -> m (CoonPatch px)+transformCoonM f (CoonPatch n e s w v) =+  CoonPatch <$> transformM f n <*> transformM f e <*> transformM f s <*> transformM f w+            <*> return v++transformCoon :: (Point -> Point) -> CoonPatch px -> CoonPatch px+transformCoon f (CoonPatch n e s w v) =+    CoonPatch+        (transform f n)+        (transform f e)+        (transform f s)+        (transform f w)+        v++-- | Define a mesh patch grid, the grid is conceptually+-- a regular grid of _meshPatchWidth * _meshPatchHeight+-- patches but with shared edges+data MeshPatch px = MeshPatch+  { -- | Count of horizontal of *patch*+    _meshPatchWidth  :: !Int+    -- | Count of vertical of *patch*+  , _meshPatchHeight :: !Int+    -- | Main points defining the patch, of size+    -- (_meshPatchWidth + 1) * (_meshPatchHeight + 1)+  , _meshPrimaryVertices :: !(V.Vector Point)+    -- | For each line, store the points in between each+    -- vertex. There is two points between each vertex, so+    -- _meshPatchWidth * (_meshPatchHeight + 1) points+  , _meshHorizontalSecondary :: !(V.Vector InterBezier)+    -- | For each colun, store the points in between each+    -- vertex. Two points between each vertex, so+    -- _meshPatchHeight * (_meshPatchWidth + 1)+  , _meshVerticalSecondary :: !(V.Vector InterBezier)+    -- | Colors for each vertex points+  , _meshColors :: !(V.Vector px)+    -- | Points used to define tensor patch, if  not define,+    -- the rest of the data structure describes a Coon patch.+    -- size must be equal to `_meshPatchWidth*_meshPatchHeight`+  , _meshTensorDerivatives :: !(Maybe (V.Vector Derivatives))+  }+  deriving (Eq, Show, Functor)++-- | Store the two bezier control points of a bezier.+data InterBezier = InterBezier +  { _inter0 :: !Point+  , _inter1 :: !Point+  }+  deriving (Eq, Show)++instance Transformable InterBezier where+  transform f (InterBezier a b) = InterBezier (f a) (f b)+  transformM f (InterBezier a b) = InterBezier <$> f a <*> f b++instance PointFoldable InterBezier where+  foldPoints f acc (InterBezier a b) = f (f acc a) b++transformMeshM :: Monad m => (Point -> m Point) -> MeshPatch px -> m (MeshPatch px)+transformMeshM f MeshPatch { .. } = do+  vertices <- mapM f _meshPrimaryVertices+  hSecondary <- mapM (transformM f) _meshHorizontalSecondary+  vSecondary <- mapM (transformM f) _meshVerticalSecondary+  return $ MeshPatch+      { _meshPatchWidth = _meshPatchWidth +      , _meshPatchHeight = _meshPatchHeight+      , _meshPrimaryVertices = vertices +      , _meshHorizontalSecondary = hSecondary +      , _meshVerticalSecondary = vSecondary+      , _meshColors = _meshColors+      , _meshTensorDerivatives = Nothing+      }++instance {-# OVERLAPPING  #-} Transformable (MeshPatch px) where+  transformM = transformMeshM++instance {-# OVERLAPPING  #-} PointFoldable (MeshPatch px) where+  foldPoints = foldMeshPoints++foldMeshPoints :: (a -> Point -> a) -> a -> MeshPatch px -> a+foldMeshPoints f acc m = acc4 where+  acc1 = V.foldl' f acc (_meshPrimaryVertices m)+  acc2 = foldPoints f acc1 (_meshHorizontalSecondary m)+  acc3 = foldPoints f acc2 (_meshVerticalSecondary m)+  acc4 = case _meshTensorDerivatives m of+    Nothing -> acc3+    Just v -> foldPoints f acc3 v++-- | Store the inner points of a tensor patch.+data Derivatives = Derivatives+  { _interNorthWest :: !Point+  , _interNorthEast :: !Point+  , _interSouthWest :: !Point+  , _interSouthEast :: !Point+  }+  deriving (Eq, Show)++instance Transformable Derivatives where+  transform f (Derivatives a b c d) =+     Derivatives (f a) (f b) (f c) (f d)+  transformM f (Derivatives a b c d) =+     Derivatives <$> f a <*> f b <*> f c <*> f d++instance PointFoldable Derivatives where+  foldPoints f acc (Derivatives a b c d) = f (f (f (f acc a) b) c) d++-- | Represent a point in the paramaetric U,V space+-- from [0, 1]^2+type UV = V2 CoonColorWeight++-- | Define a rectangle in the U,V parametric space.+type UVPatch = ParametricValues UV++-- | Store information for cubic interpolation in a patch.+newtype CubicCoefficient px = CubicCoefficient+    { getCubicCoefficients :: ParametricValues (V4 (Holder px Float))+    }++-- | Type storing the information to be able to interpolate+-- part of an image in a patch.+data ImageMesh px = ImageMesh+    { _meshImage :: !(Image px)+    , _meshTransform :: !Transformation+    }++-- C1: top      _north+-- C2: bottom   _south+-- D1: left     _west+-- D2: right    _east++-- | Return a postion of a point in the coon patch.+coonPointAt :: CoonPatch a -> UV -> Point+coonPointAt CoonPatch { .. } (V2 u v) = sc ^+^ sd ^-^ sb+  where+    CubicBezier c10 _ _ c11 = _north+    CubicBezier c21 _ _ c20 = _south++    sc = lerp v c2 c1+    sd = lerp u d2 d1+    sb = lerp v (lerp u c21 c20)+                (lerp u c11 c10)++    CubicBezier _ _ _ c1 = fst $ cubicBezierBreakAt _north u+    CubicBezier _ _ _ c2 = fst $ cubicBezierBreakAt _south (1 - u)++    CubicBezier _ _ _ d2 = fst $ cubicBezierBreakAt _east v+    CubicBezier _ _ _ d1 = fst $ cubicBezierBreakAt _west (1 - v)++-- | Convert a coon patch in+toTensorPatch :: CoonPatch a -> TensorPatch a+toTensorPatch CoonPatch { .. } = TensorPatch+    { _curve0 = _north+    , _curve1 = CubicBezier wt p11 p21 et+    , _curve2 = CubicBezier wb p12 p22 eb+    , _curve3 = CubicBezier sd  sc  sb sa+    , _tensorValues = _coonValues+    }+  where+    formula a b c d e f g h =+      (a ^* (-4) ^+^+       (b ^+^ c) ^* 6 ^-^+       (d ^+^ e) ^* 2 ^+^+       (f ^+^ g) ^* 3 ^-^+       h) ^* (1/9)++    p11 = formula p00 p10 p01 p30 p03 p13 p31 p33+    p21 = formula p30 p20 p31 p00 p33 p23 p01 p03+    p12 = formula p03 p13 p02 p33 p00 p10 p32 p30+    p22 = formula p33 p23 p32 p03 p30 p20 p02 p00++    CubicBezier p00 p10 p20 p30 = _north+    CubicBezier _ p02 p01 _ = _west+    CubicBezier _ p31 p32 _ = _east+    CubicBezier p33 p23 p13 p03 = _south++    CubicBezier sa sb sc sd = _south+    CubicBezier _ et eb _ = _east+    CubicBezier _ wb wt _ = _west++

@@ -217,9 +217,9 @@     --     / abbc  \     --    /         \     -- A X           X C-    ab = lerp t a b-    bc = lerp t b c-    abbc = lerp t ab bc+    ab = lerp t b a+    bc = lerp t c b+    abbc = lerp t bc ab  splitBezier :: Bezier -> (Point, Point, Point) {-# INLINE splitBezier #-}

@@ -1,92 +1,97 @@-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-module Graphics.Rasterific.Rasterize
-    ( CoverageSpan( .. )
-    , rasterize
-    , clip
-    ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Data.Foldable( foldMap )
-#endif
-
-import Control.Monad.ST( runST )
-import Data.Fixed( mod' )
-import Data.Monoid( Endo( Endo, appEndo ) )
-import Graphics.Rasterific.Types
-import Graphics.Rasterific.QuadraticBezier
-import Graphics.Rasterific.CubicBezier
-import Graphics.Rasterific.Line
-import qualified Data.Vector as V
-import qualified Data.Vector.Algorithms.Intro as VS
-
-data CoverageSpan = CoverageSpan
-    { _coverageX      :: {-# UNPACK #-} !Float
-    , _coverageY      :: {-# UNPACK #-} !Float
-    , _coverageVal    :: {-# UNPACK #-} !Float
-    , _coverageLength :: {-# UNPACK #-} !Float
-    }
-    deriving Show
-
-combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample
-                   -> [CoverageSpan]
-{-# INLINE combineEdgeSamples #-}
-combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0
-  where
-    !maxi = V.length vec
-    go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1]
-    go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where
-      sub (EdgeSample x' y' a' h')
-        | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h')
-        | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h')
-        | otherwise =
-           CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h'
-             where p1 = CoverageSpan x y (prepareCoverage a) 1
-                   p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1)
-
--- | Clip the geometry to a rectangle.
-clip :: Point     -- ^ Minimum point (corner upper left)
-     -> Point     -- ^ Maximum point (corner bottom right)
-     -> Primitive -- ^ Primitive to be clipped
-     -> Container Primitive
-clip mini maxi (LinePrim l) = clipLine mini maxi l
-clip mini maxi (BezierPrim b) = clipBezier mini maxi b
-clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c
-
-decompose :: Primitive -> Producer EdgeSample
-decompose (LinePrim l) = decomposeLine l
-decompose (BezierPrim b) = decomposeBeziers b
-decompose (CubicBezierPrim c) =
-    {-decomposeCubicBezierForwardDifference c-}
-    decomposeCubicBeziers c
-
-xyCompare :: EdgeSample -> EdgeSample -> Ordering
-{-# INLINE xyCompare #-}
-xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax })
-          !(EdgeSample { _sampleY = by, _sampleX = bx }) =
-  case compare ay by of
-    EQ -> compare ax bx
-    c -> c
-
-sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample
-sortEdgeSamples samples = runST $ do
-    -- Resist the urge to make this a storable vector,
-    -- it is actually a pessimisation.
-    mutableVector <- V.unsafeThaw $ V.fromList samples
-    VS.sortBy xyCompare mutableVector
-    V.unsafeFreeze mutableVector
-
-rasterize :: FillMethod -> Container Primitive -> [CoverageSpan]
-rasterize method = 
-  case method of
-    FillWinding -> combineEdgeSamples combineWinding 
-                        . sortEdgeSamples
-                        . (($ []) . appEndo)
-                        . foldMap (Endo . decompose)
-    FillEvenOdd -> combineEdgeSamples combineEvenOdd
-                        . sortEdgeSamples
-                        . (($ []) . appEndo)
-                        . foldMap (Endo . decompose)
-  where combineWinding = min 1 . abs
-        combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1
-
+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+module Graphics.Rasterific.Rasterize+    ( CoverageSpan( .. )+    , rasterize+    , toOpaqueCoverage+    , clip+    ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Foldable( foldMap )+#endif++import Control.Monad.ST( runST )+import Data.Fixed( mod' )+import Data.Monoid( Endo( Endo, appEndo ) )+import Graphics.Rasterific.Types+import Graphics.Rasterific.QuadraticBezier+import Graphics.Rasterific.CubicBezier+import Graphics.Rasterific.Line+import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Intro as VS++data CoverageSpan = CoverageSpan+    { _coverageX      :: {-# UNPACK #-} !Float+    , _coverageY      :: {-# UNPACK #-} !Float+    , _coverageVal    :: {-# UNPACK #-} !Float+    , _coverageLength :: {-# UNPACK #-} !Float+    }+    deriving Show++toOpaqueCoverage :: CoverageSpan -> CoverageSpan+{-# INLINE toOpaqueCoverage #-}+toOpaqueCoverage coverage = coverage { _coverageVal = 1 }++combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample+                   -> [CoverageSpan]+{-# INLINE combineEdgeSamples #-}+combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0+  where+    !maxi = V.length vec+    go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1]+    go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where+      sub (EdgeSample x' y' a' h')+        | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h')+        | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h')+        | otherwise =+           CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h'+             where p1 = CoverageSpan x y (prepareCoverage a) 1+                   p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1)++-- | Clip the geometry to a rectangle.+clip :: Point     -- ^ Minimum point (corner upper left)+     -> Point     -- ^ Maximum point (corner bottom right)+     -> Primitive -- ^ Primitive to be clipped+     -> Container Primitive+clip mini maxi (LinePrim l) = clipLine mini maxi l+clip mini maxi (BezierPrim b) = clipBezier mini maxi b+clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c++decompose :: Primitive -> Producer EdgeSample+decompose (LinePrim l) = decomposeLine l+decompose (BezierPrim b) = decomposeBeziers b+decompose (CubicBezierPrim c) =+    {-decomposeCubicBezierForwardDifference c-}+    decomposeCubicBeziers c++xyCompare :: EdgeSample -> EdgeSample -> Ordering+{-# INLINE xyCompare #-}+xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax })+          !(EdgeSample { _sampleY = by, _sampleX = bx }) =+  case compare ay by of+    EQ -> compare ax bx+    c -> c++sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample+sortEdgeSamples samples = runST $ do+    -- Resist the urge to make this a storable vector,+    -- it is actually a pessimisation.+    mutableVector <- V.unsafeThaw $ V.fromList samples+    VS.sortBy xyCompare mutableVector+    V.unsafeFreeze mutableVector++rasterize :: FillMethod -> Container Primitive -> [CoverageSpan]+rasterize method = +  case method of+    FillWinding -> combineEdgeSamples combineWinding +                        . sortEdgeSamples+                        . (($ []) . appEndo)+                        . foldMap (Endo . decompose)+    FillEvenOdd -> combineEdgeSamples combineEvenOdd+                        . sortEdgeSamples+                        . (($ []) . appEndo)+                        . foldMap (Endo . decompose)+  where combineWinding = min 1 . abs+        combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1+

@@ -3,11 +3,17 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-}-module Graphics.Rasterific.Shading( transformTextureToFiller ) where+module Graphics.Rasterific.Shading+    ( transformTextureToFiller+    , sampledImageShader+    , plotOpaquePixel+    , unsafePlotOpaquePixel+    ) where +import Control.Monad.ST( ST ) import Control.Monad.Primitive( PrimState                               -- one day (GHC >= 7.10 ?)-                              {-, PrimMonad-}+                              , PrimMonad                               ) import Data.Fixed( mod' ) import Data.Monoid( (<>) )@@ -20,8 +26,6 @@              , norm              ) --import Control.Monad.ST( ST ) import qualified Data.Vector as V  import Codec.Picture.Types( Pixel( .. )@@ -98,6 +102,29 @@         $ compositionAlpha cov icov oldPixel color       go (count + 1) $ idx + compCount ++-- | Plot a single pixel on the resulting image.+plotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m)+                => MutableImage (PrimState m) px -> px -> Int -> Int+                -> m ()+{-# INLINE plotOpaquePixel #-}+plotOpaquePixel img _color x y+   | x < 0 || y < 0 || +     x >= mutableImageWidth img || y >= mutableImageHeight img = return ()+plotOpaquePixel img color x y = do+  let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px))+  writePackedPixelAt img idx color++-- | Plot a single pixel on the resulting image, no bounds check are+-- performed, ensure index is correct!+unsafePlotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m)+                      => MutableImage (PrimState m) px -> px -> Int -> Int+                      -> m ()+{-# INLINE unsafePlotOpaquePixel #-}+unsafePlotOpaquePixel img color x y = do+  let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px))+  writePackedPixelAt img idx color+ shaderFiller :: forall s px . (ModulablePixel px)              => ShaderFunction px -> MutableImage s px              -> Filler (ST s)@@ -179,6 +206,7 @@     shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8                     -> ShaderFunction Pixel8 #-} shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px+shaderOfTexture _ _ (MeshPatchTexture _ _) = error "MeshPatch should be precomputed" shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) =   withTrans trans $ linearGradientShader grad a b sampling shaderOfTexture trans sampling (RadialGradientTexture grad center radius) =@@ -203,6 +231,10 @@ shaderOfTexture trans sampling (ModulateTexture texture modulation) =   modulateTexture (shaderOfTexture trans sampling texture)                   (shaderOfTexture trans sampling modulation)+shaderOfTexture trans sampling (AlphaModulateTexture texture modulation) =+  alphaModulateTexture+    (shaderOfTexture trans sampling texture)+    (shaderOfTexture trans sampling modulation)   -- | This function will interpret the texture description, helping@@ -322,11 +354,11 @@    pyn = clampedY $ y + 1     dx, dy :: Float-   dx = x - fromIntegral (floor x :: Int)-   dy = y - fromIntegral (floor y :: Int)+   !dx = x - fromIntegral (floor x :: Int)+   !dy = y - fromIntegral (floor y :: Int)     at :: Int -> Int -> px-   at xx yy =+   at !xx !yy =         unsafePixelAt rawData $ (yy * w + xx) * compCount     (covX, icovX) = clampCoverage dx@@ -436,4 +468,15 @@ {-# INLINE modulateTexture #-} modulateTexture fullTexture modulator x y =     colorMap (modulate $ modulator x y) $ fullTexture x y++-- | Perform a multiplication operation between a full color texture+-- and a greyscale one, used for clip-path implementation.+alphaModulateTexture :: ModulablePixel px+                => ShaderFunction px+                -> ShaderFunction (PixelBaseComponent px)+                -> ShaderFunction px+{-# INLINE alphaModulateTexture #-}+alphaModulateTexture fullTexture modulator x y =+  let px = fullTexture x y in+  mixWithAlpha (\_ _ a -> a) (\_ _ -> modulator x y) px px 

@@ -19,6 +19,7 @@     , radialGradientWithFocusTexture     , sampledImageTexture     , patternTexture+    , meshPatchTexture        -- * Texture manipulation     , modulateTexture@@ -29,6 +30,7 @@ import Codec.Picture.Types( Pixel( .. ), Image( .. ) ) import Graphics.Text.TrueType( Dpi ) import Graphics.Rasterific+import Graphics.Rasterific.MeshPatch import Graphics.Rasterific.Command import Graphics.Rasterific.Transformations @@ -78,6 +80,11 @@ uniformTexture :: px -- ^ The color used for all the texture.                -> Texture px uniformTexture = SolidTexture+++-- | Texture using a mesh patch as definition+meshPatchTexture :: PatchInterpolation -> MeshPatch px -> Texture px+meshPatchTexture = MeshPatchTexture  -- | Linear gradient texture. --

@@ -1,198 +1,189 @@--- | This module provide some helpers in order
--- to perform basic geometric transformation on
--- the drawable primitives.
---
--- You can combine the transformation is `mappend` or
--- the `(\<\>)` operator from "Data.Monoid" .
-{-# LANGUAGE CPP #-}
-module Graphics.Rasterific.Transformations
-    ( Transformation( .. )
-    , applyTransformation
-    , applyVectorTransformation
-    , translate
-    , scale
-    , rotate
-    , rotateCenter
-    , skewX
-    , skewY
-    , toNewXBase
-    , inverseTransformation
-    ) where
-
-#if !MIN_VERSION_base(4,8,0)
-import Data.Monoid( Monoid( .. )  )
-#endif
-import Data.Monoid( (<>) )
-import Graphics.Rasterific.Types
-import Graphics.Rasterific.Linear( V2( .. ), (^+^), normalize )
-
--- | Represent a 3*3 matrix for homogenous coordinates.
---
--- > | A C E |
--- > | B D F |
--- > | 0 0 1 |
---
-data Transformation = Transformation
-    { _transformA :: {-# UNPACK #-} !Float
-    , _transformC :: {-# UNPACK #-} !Float
-    , _transformE :: {-# UNPACK #-} !Float -- ^ X translation
-
-    , _transformB :: {-# UNPACK #-} !Float
-    , _transformD :: {-# UNPACK #-} !Float
-    , _transformF :: {-# UNPACK #-} !Float -- ^ Y translation
-    }
-    deriving (Eq, Show)
-
-transformCombine :: Transformation -> Transformation -> Transformation
-transformCombine (Transformation a c e
-                                 b d f)
-
-                 (Transformation a' c' e'
-                                 b' d' f') =
-    Transformation (a * a' + c * b' {- below b' is zero -})
-              (a * c' + c * d' {- below d' is zero -})
-              (a * e' + c * f' + e {- below f' is one -})
-
-              (b * a' + d * b' {- below b' is zero -})
-              (b * c' + d * d' {- below d' is zero -})
-              (b * e' + d * f' + f {- below f' is one -})
-
-instance Monoid Transformation where
-    mappend = transformCombine
-    mempty = Transformation 1 0 0
-                            0 1 0
-
--- | Effectively transform a point given a transformation.
-applyTransformation :: Transformation -> Point -> Point
-applyTransformation (Transformation a c e
-                                    b d f) (V2 x y) =
-    V2 (a * x + y * c + e) (b * x + d * y + f)
-
--- | Effectively transform a vector given a transformation.
--- The translation part won't be applied.
-applyVectorTransformation :: Transformation -> Vector -> Vector
-applyVectorTransformation
-    (Transformation a c _e
-                    b d _f) (V2 x y) =
-    V2 (a * x + y * c) (b * x + d * y)
-
-
--- | Create a transformation representing a rotation
--- on the plane.
---
--- > fill . transform (applyTransformation $ rotate 0.2)
--- >      $ rectangle (V2 40 40) 120 120
---
--- <<docimages/transform_rotate.png>>
---
-rotate :: Float  -- ^ Rotation angle in radian.
-       -> Transformation
-rotate angle = Transformation ca (-sa) 0
-                              sa   ca  0
-  where ca = cos angle
-        sa = sin angle
-
--- | Create a transformation representing a rotation
--- on the plane. The rotation center is given in parameter
---
--- > fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200))
--- >      $ rectangle (V2 40 40) 120 120
---
--- <<docimages/transform_rotate_center.png>>
---
-rotateCenter :: Float -- ^ Rotation angle in radian
-             -> Point -- ^ Rotation center
-             -> Transformation
-rotateCenter angle p =
-    translate p <> rotate angle <> translate (negate p)
-
-
--- | Perform a scaling of the given primitives.
---
--- > fill . transform (applyTransformation $ scale 2 2)
--- >      $ rectangle (V2 40 40) 40 40
---
--- <<docimages/transform_scale.png>>
---
-scale :: Float -> Float -> Transformation
-{-# RULES
-    "scale mappend" forall ax ay bx by.
-       mappend (scale ax ay) (scale bx by) =
-         scale (ax * bx) (ay * by)
-  #-}
-scale scaleX scaleY =
-    Transformation scaleX      0 0
-                        0 scaleY 0
-
--- | Perform a translation of the given primitives.
---
--- > fill . transform (applyTransformation $ translate (V2 100 100))
--- >      $ rectangle (V2 40 40) 40 40
---
--- <<docimages/transform_translate.png>>
---
-translate :: Vector -> Transformation
-{-# RULES
-    "translate mappend" forall a b.
-      mappend (translate a) (translate b) = translate (a ^+^ b)
-  #-}
-translate (V2 x y) =
-    Transformation 1 0 x
-                   0 1 y
-
--- | Skew transformation along the
--- X axis.
---
--- > fill . transform (applyTransformation $ skewX 0.3)
--- >      $ rectangle (V2 50 50) 80 80
---
--- <<docimages/transform_skewx.png>>
---
-skewX :: Float -> Transformation
-skewX v =
-    Transformation 1 t 0
-                   0 1 0
-  where t = tan v
-
--- | Skew transformation along the Y axis.
---
--- > fill . transform (applyTransformation $ skewY 0.3)
--- >      $ rectangle (V2 50 50) 80 80
---
--- <<docimages/transform_skewy.png>>
---
-skewY :: Float -> Transformation
-skewY v =
-    Transformation 1 0 0
-                   t 1 0
-  where t = tan v
-
--- | Given a new X-acis vector, create a rotation matrix
--- to get into this new base, assuming an Y basis orthonormal
--- to the X one.
-toNewXBase :: Vector -> Transformation
-toNewXBase vec =
-    Transformation dx (-dy) 0
-                   dy   dx  0
-  where V2 dx dy = normalize vec
-
-transformationDeterminant :: Transformation -> Float
-transformationDeterminant (Transformation a c _e
-                                          b d _f) = a * d - c * b
-
--- | Inverse a transformation (if possible)
-inverseTransformation :: Transformation -> Maybe Transformation
-inverseTransformation trans
-    | transformationDeterminant trans == 0 = Nothing
-inverseTransformation (Transformation a c e
-                                      b d f) =
-    Just $ Transformation a' c' e' b' d' f'
-  where det = a * d - b * c
-        a' = d / det
-        c' = (- c) / det
-        e' = (c * f - e * d) / det
-
-        b' = (- b) / det
-        d' = a / det
-        f' = (e * b - a * f) / det
-
+-- | This module provide some helpers in order+-- to perform basic geometric transformation on+-- the drawable primitives.+--+-- You can combine the transformation is `mappend` or+-- the `(\<\>)` operator from "Data.Monoid" .+{-# LANGUAGE CPP #-}+module Graphics.Rasterific.Transformations+    ( Transformation( .. )+    , applyTransformation+    , applyVectorTransformation+    , translate+    , scale+    , rotate+    , rotateCenter+    , skewX+    , skewY+    , toNewXBase+    , inverseTransformation+    ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( Monoid( .. )  )+#endif+import Data.Monoid( (<>) )+import Graphics.Rasterific.Types+import Graphics.Rasterific.Linear( V2( .. ), normalize )++-- | Represent a 3*3 matrix for homogenous coordinates.+--+-- > | A C E |+-- > | B D F |+-- > | 0 0 1 |+--+data Transformation = Transformation+    { _transformA :: {-# UNPACK #-} !Float+    , _transformC :: {-# UNPACK #-} !Float+    , _transformE :: {-# UNPACK #-} !Float -- ^ X translation++    , _transformB :: {-# UNPACK #-} !Float+    , _transformD :: {-# UNPACK #-} !Float+    , _transformF :: {-# UNPACK #-} !Float -- ^ Y translation+    }+    deriving (Eq, Show)++transformCombine :: Transformation -> Transformation -> Transformation+transformCombine (Transformation a c e+                                 b d f)++                 (Transformation a' c' e'+                                 b' d' f') =+    Transformation (a * a' + c * b' {- below b' is zero -})+              (a * c' + c * d' {- below d' is zero -})+              (a * e' + c * f' + e {- below f' is one -})++              (b * a' + d * b' {- below b' is zero -})+              (b * c' + d * d' {- below d' is zero -})+              (b * e' + d * f' + f {- below f' is one -})++instance Monoid Transformation where+    mappend = transformCombine+    mempty = Transformation 1 0 0+                            0 1 0++-- | Effectively transform a point given a transformation.+applyTransformation :: Transformation -> Point -> Point+applyTransformation (Transformation a c e+                                    b d f) (V2 x y) =+    V2 (a * x + y * c + e) (b * x + d * y + f)++-- | Effectively transform a vector given a transformation.+-- The translation part won't be applied.+applyVectorTransformation :: Transformation -> Vector -> Vector+applyVectorTransformation+    (Transformation a c _e+                    b d _f) (V2 x y) =+    V2 (a * x + y * c) (b * x + d * y)+++-- | Create a transformation representing a rotation+-- on the plane.+--+-- > fill . transform (applyTransformation $ rotate 0.2)+-- >      $ rectangle (V2 40 40) 120 120+--+-- <<docimages/transform_rotate.png>>+--+rotate :: Float  -- ^ Rotation angle in radian.+       -> Transformation+rotate angle = Transformation ca (-sa) 0+                              sa   ca  0+  where ca = cos angle+        sa = sin angle++-- | Create a transformation representing a rotation+-- on the plane. The rotation center is given in parameter+--+-- > fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200))+-- >      $ rectangle (V2 40 40) 120 120+--+-- <<docimages/transform_rotate_center.png>>+--+rotateCenter :: Float -- ^ Rotation angle in radian+             -> Point -- ^ Rotation center+             -> Transformation+rotateCenter angle p =+    translate p <> rotate angle <> translate (negate p)+++-- | Perform a scaling of the given primitives.+--+-- > fill . transform (applyTransformation $ scale 2 2)+-- >      $ rectangle (V2 40 40) 40 40+--+-- <<docimages/transform_scale.png>>+--+scale :: Float -> Float -> Transformation+scale scaleX scaleY =+    Transformation scaleX      0 0+                        0 scaleY 0++-- | Perform a translation of the given primitives.+--+-- > fill . transform (applyTransformation $ translate (V2 100 100))+-- >      $ rectangle (V2 40 40) 40 40+--+-- <<docimages/transform_translate.png>>+--+translate :: Vector -> Transformation+translate (V2 x y) =+    Transformation 1 0 x+                   0 1 y++-- | Skew transformation along the+-- X axis.+--+-- > fill . transform (applyTransformation $ skewX 0.3)+-- >      $ rectangle (V2 50 50) 80 80+--+-- <<docimages/transform_skewx.png>>+--+skewX :: Float -> Transformation+skewX v =+    Transformation 1 t 0+                   0 1 0+  where t = tan v++-- | Skew transformation along the Y axis.+--+-- > fill . transform (applyTransformation $ skewY 0.3)+-- >      $ rectangle (V2 50 50) 80 80+--+-- <<docimages/transform_skewy.png>>+--+skewY :: Float -> Transformation+skewY v =+    Transformation 1 0 0+                   t 1 0+  where t = tan v++-- | Given a new X-acis vector, create a rotation matrix+-- to get into this new base, assuming an Y basis orthonormal+-- to the X one.+toNewXBase :: Vector -> Transformation+toNewXBase vec =+    Transformation dx (-dy) 0+                   dy   dx  0+  where V2 dx dy = normalize vec++transformationDeterminant :: Transformation -> Float+transformationDeterminant (Transformation a c _e+                                          b d _f) = a * d - c * b++-- | Inverse a transformation (if possible)+inverseTransformation :: Transformation -> Maybe Transformation+inverseTransformation trans+    | transformationDeterminant trans == 0 = Nothing+inverseTransformation (Transformation a c e+                                      b d f) =+    Just $ Transformation a' c' e' b' d' f'+  where det = a * d - b * c+        a' = d / det+        c' = (- c) / det+        e' = (c * f - e * d) / det++        b' = (- b) / det+        d' = a / det+        f' = (e * b - a * f) / det+

@@ -53,7 +53,10 @@  #if !MIN_VERSION_base(4,8,0) import Data.Foldable( Foldable )+import Data.Traversable( Traversable )+import Control.Applicative( (<$>), (<*>), pure ) #endif+import Control.Monad.Identity( runIdentity ) import Data.Foldable( foldl', toList ) import qualified Data.Foldable as F import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero )@@ -212,7 +215,11 @@     -- | Apply a transformation function for every     --  point in the element.     transform :: (Point -> Point) -> a -> a+    transform f = runIdentity . transformM (return . f) +    -- | Transform but monadic+    transformM :: Monad m => (Point -> m Point) -> a -> m a+ -- | Typeclass helper gathering all the points of a given -- geometry. class PointFoldable a where@@ -224,6 +231,8 @@ instance Transformable Point where     {-# INLINE transform #-}     transform f = f+    {-# INLINE transformM #-}+    transformM f = f  -- | Just apply the function instance PointFoldable Point where@@ -250,8 +259,8 @@                ++ show b ++ ")"  instance Transformable Line where-    {-# INLINE transform #-}-    transform f (Line a b) = Line (f a) $ f b+    {-# INLINE transformM #-}+    transformM f (Line a b) = Line <$> f a <*> f b  instance PointFoldable Line where     {-# INLINE foldPoints #-}@@ -285,6 +294,8 @@ instance Transformable Bezier where     {-# INLINE transform #-}     transform f (Bezier a b c) = Bezier (f a) (f b) $ f c+    {-# INLINE transformM #-}+    transformM f (Bezier a b c) = Bezier <$> f a <*> f b <*> f c  instance PointFoldable Bezier where     {-# INLINE foldPoints #-}@@ -321,7 +332,9 @@ instance Transformable CubicBezier where     {-# INLINE transform #-}     transform f (CubicBezier a b c d) =-        CubicBezier (f a) (f b) (f c) $ f d+       CubicBezier (f a) (f b) (f c) $ f d+    transformM f (CubicBezier a b c d) =+       CubicBezier <$> f a <*> f b <*> f c <*> f d  instance PointFoldable CubicBezier where     {-# INLINE foldPoints #-}@@ -416,6 +429,10 @@     transform f (BezierPrim b) = BezierPrim $ transform f b     transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c +    transformM f (LinePrim l) = LinePrim <$> transformM f l+    transformM f (BezierPrim b) = BezierPrim <$> transformM f b+    transformM f (CubicBezierPrim c) = CubicBezierPrim <$> transformM f c+ instance PointFoldable Primitive where     {-# INLINE foldPoints #-}     foldPoints f acc = go@@ -423,11 +440,12 @@             go (BezierPrim b) = foldPoints f acc b             go (CubicBezierPrim c) = foldPoints f acc c -instance (Functor f, Transformable a)+instance {-# OVERLAPPABLE #-} (Traversable f, Transformable a)       => Transformable (f a) where     transform f = fmap (transform f)+    transformM f = mapM (transformM f) -instance (Foldable f, PointFoldable a)+instance {-# OVERLAPPABLE #-} (Foldable f, PointFoldable a)       => PointFoldable (f a) where     foldPoints f = foldl' (foldPoints f) @@ -471,6 +489,10 @@     transform f (Path orig close rest) =         Path (f orig) close (transform f rest) +    transformM f (Path orig close rest) =+        Path <$> f orig <*> pure close <*> transformM f rest++ instance PointFoldable Path where     {-# INLINE foldPoints #-}     foldPoints f acc (Path o _ rest) =@@ -494,6 +516,12 @@         PathQuadraticBezierCurveTo (f p1) $ f p2     transform f (PathCubicBezierCurveTo p1 p2 p3) =         PathCubicBezierCurveTo (f p1) (f p2) $ f p3++    transformM f (PathLineTo p) = PathLineTo <$> f p+    transformM f (PathQuadraticBezierCurveTo p1 p2) =+        PathQuadraticBezierCurveTo <$> f p1 <*> f p2+    transformM f (PathCubicBezierCurveTo p1 p2 p3) =+        PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3  instance PointFoldable PathCommand where     foldPoints f acc (PathLineTo p) = f acc p