diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -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 diff --git a/docimages/cap_straight.png b/docimages/cap_straight.png Binary files a/docimages/cap_straight.png and b/docimages/cap_straight.png differ diff --git a/docimages/dashed_stroke.png b/docimages/dashed_stroke.png Binary files a/docimages/dashed_stroke.png and b/docimages/dashed_stroke.png differ diff --git a/docimages/dashed_stroke_with_offset.png b/docimages/dashed_stroke_with_offset.png Binary files a/docimages/dashed_stroke_with_offset.png and b/docimages/dashed_stroke_with_offset.png differ diff --git a/docimages/dummy.png b/docimages/dummy.png deleted file mode 100644 --- a/docimages/dummy.png +++ /dev/null diff --git a/docimages/fill_evenodd.png b/docimages/fill_evenodd.png Binary files a/docimages/fill_evenodd.png and b/docimages/fill_evenodd.png differ diff --git a/docimages/fill_winding.png b/docimages/fill_winding.png Binary files a/docimages/fill_winding.png and b/docimages/fill_winding.png differ diff --git a/docimages/geometry_on_path.png b/docimages/geometry_on_path.png Binary files a/docimages/geometry_on_path.png and b/docimages/geometry_on_path.png differ diff --git a/docimages/linear_gradient.png b/docimages/linear_gradient.png Binary files a/docimages/linear_gradient.png and b/docimages/linear_gradient.png differ diff --git a/docimages/linear_gradient_rotated.png b/docimages/linear_gradient_rotated.png new file mode 100644 Binary files /dev/null and b/docimages/linear_gradient_rotated.png differ diff --git a/docimages/logo.png b/docimages/logo.png Binary files a/docimages/logo.png and b/docimages/logo.png differ diff --git a/docimages/mesh_patch_interp_bicubic.png b/docimages/mesh_patch_interp_bicubic.png new file mode 100644 Binary files /dev/null and b/docimages/mesh_patch_interp_bicubic.png differ diff --git a/docimages/mesh_patch_interp_bilinear.png b/docimages/mesh_patch_interp_bilinear.png new file mode 100644 Binary files /dev/null and b/docimages/mesh_patch_interp_bilinear.png differ diff --git a/docimages/mesh_patch_interp_clip.png b/docimages/mesh_patch_interp_clip.png new file mode 100644 Binary files /dev/null and b/docimages/mesh_patch_interp_clip.png differ diff --git a/docimages/mesh_patch_transp.png b/docimages/mesh_patch_transp.png new file mode 100644 Binary files /dev/null and b/docimages/mesh_patch_transp.png differ diff --git a/docimages/module_example.png b/docimages/module_example.png Binary files a/docimages/module_example.png and b/docimages/module_example.png differ diff --git a/docimages/radial_gradient_focus.png b/docimages/radial_gradient_focus.png Binary files a/docimages/radial_gradient_focus.png and b/docimages/radial_gradient_focus.png differ diff --git a/docimages/sampled_texture_reflect.png b/docimages/sampled_texture_reflect.png Binary files a/docimages/sampled_texture_reflect.png and b/docimages/sampled_texture_reflect.png differ diff --git a/docimages/sampled_texture_rotate.png b/docimages/sampled_texture_rotate.png Binary files a/docimages/sampled_texture_rotate.png and b/docimages/sampled_texture_rotate.png differ diff --git a/docimages/sampled_texture_scaled.png b/docimages/sampled_texture_scaled.png Binary files a/docimages/sampled_texture_scaled.png and b/docimages/sampled_texture_scaled.png differ diff --git a/docimages/sampler_pad.png b/docimages/sampler_pad.png Binary files a/docimages/sampler_pad.png and b/docimages/sampler_pad.png differ diff --git a/docimages/sampler_reflect.png b/docimages/sampler_reflect.png Binary files a/docimages/sampler_reflect.png and b/docimages/sampler_reflect.png differ diff --git a/docimages/sampler_repeat.png b/docimages/sampler_repeat.png Binary files a/docimages/sampler_repeat.png and b/docimages/sampler_repeat.png differ diff --git a/docimages/stroke_line.png b/docimages/stroke_line.png Binary files a/docimages/stroke_line.png and b/docimages/stroke_line.png differ diff --git a/docimages/stroke_polyline.png b/docimages/stroke_polyline.png Binary files a/docimages/stroke_polyline.png and b/docimages/stroke_polyline.png differ diff --git a/docimages/strokize_dashed_path.png b/docimages/strokize_dashed_path.png Binary files a/docimages/strokize_dashed_path.png and b/docimages/strokize_dashed_path.png differ diff --git a/docimages/text_complex_example.png b/docimages/text_complex_example.png Binary files a/docimages/text_complex_example.png and b/docimages/text_complex_example.png differ diff --git a/docimages/text_on_path.png b/docimages/text_on_path.png Binary files a/docimages/text_on_path.png and b/docimages/text_on_path.png differ diff --git a/exec-src/docImageGenerator.hs b/exec-src/docImageGenerator.hs --- a/exec-src/docImageGenerator.hs +++ b/exec-src/docImageGenerator.hs @@ -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 diff --git a/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs --- a/src/Graphics/Rasterific.hs +++ b/src/Graphics/Rasterific.hs @@ -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 diff --git a/src/Graphics/Rasterific/BiSampleable.hs b/src/Graphics/Rasterific/BiSampleable.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/BiSampleable.hs @@ -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) + diff --git a/src/Graphics/Rasterific/Command.hs b/src/Graphics/Rasterific/Command.hs --- a/src/Graphics/Rasterific/Command.hs +++ b/src/Graphics/Rasterific/Command.hs @@ -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 () diff --git a/src/Graphics/Rasterific/Compositor.hs b/src/Graphics/Rasterific/Compositor.hs --- a/src/Graphics/Rasterific/Compositor.hs +++ b/src/Graphics/Rasterific/Compositor.hs @@ -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 diff --git a/src/Graphics/Rasterific/CubicBezier.hs b/src/Graphics/Rasterific/CubicBezier.hs --- a/src/Graphics/Rasterific/CubicBezier.hs +++ b/src/Graphics/Rasterific/CubicBezier.hs @@ -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)) = diff --git a/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs b/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs @@ -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) + diff --git a/src/Graphics/Rasterific/Immediate.hs b/src/Graphics/Rasterific/Immediate.hs --- a/src/Graphics/Rasterific/Immediate.hs +++ b/src/Graphics/Rasterific/Immediate.hs @@ -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 @@ -- -- <> -- -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 @@ -- <> -- 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 = diff --git a/src/Graphics/Rasterific/Line.hs b/src/Graphics/Rasterific/Line.hs --- a/src/Graphics/Rasterific/Line.hs +++ b/src/Graphics/Rasterific/Line.hs @@ -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) diff --git a/src/Graphics/Rasterific/Linear.hs b/src/Graphics/Rasterific/Linear.hs --- a/src/Graphics/Rasterific/Linear.hs +++ b/src/Graphics/Rasterific/Linear.hs @@ -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 + diff --git a/src/Graphics/Rasterific/MeshPatch.hs b/src/Graphics/Rasterific/MeshPatch.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/MeshPatch.hs @@ -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] ] + diff --git a/src/Graphics/Rasterific/MicroPdf.hs b/src/Graphics/Rasterific/MicroPdf.hs --- a/src/Graphics/Rasterific/MicroPdf.hs +++ b/src/Graphics/Rasterific/MicroPdf.hs @@ -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) diff --git a/src/Graphics/Rasterific/MiniLens.hs b/src/Graphics/Rasterific/MiniLens.hs --- a/src/Graphics/Rasterific/MiniLens.hs +++ b/src/Graphics/Rasterific/MiniLens.hs @@ -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 (+=) #-} diff --git a/src/Graphics/Rasterific/Operators.hs b/src/Graphics/Rasterific/Operators.hs --- a/src/Graphics/Rasterific/Operators.hs +++ b/src/Graphics/Rasterific/Operators.hs @@ -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 diff --git a/src/Graphics/Rasterific/Patch.hs b/src/Graphics/Rasterific/Patch.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Patch.hs @@ -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 + diff --git a/src/Graphics/Rasterific/PatchTypes.hs b/src/Graphics/Rasterific/PatchTypes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/PatchTypes.hs @@ -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 + -- @ + -- + -- <> + -- + 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 + -- @ + -- + -- <> + -- + | 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 + + diff --git a/src/Graphics/Rasterific/QuadraticBezier.hs b/src/Graphics/Rasterific/QuadraticBezier.hs --- a/src/Graphics/Rasterific/QuadraticBezier.hs +++ b/src/Graphics/Rasterific/QuadraticBezier.hs @@ -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 #-} diff --git a/src/Graphics/Rasterific/Rasterize.hs b/src/Graphics/Rasterific/Rasterize.hs --- a/src/Graphics/Rasterific/Rasterize.hs +++ b/src/Graphics/Rasterific/Rasterize.hs @@ -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 + diff --git a/src/Graphics/Rasterific/Shading.hs b/src/Graphics/Rasterific/Shading.hs --- a/src/Graphics/Rasterific/Shading.hs +++ b/src/Graphics/Rasterific/Shading.hs @@ -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 diff --git a/src/Graphics/Rasterific/Texture.hs b/src/Graphics/Rasterific/Texture.hs --- a/src/Graphics/Rasterific/Texture.hs +++ b/src/Graphics/Rasterific/Texture.hs @@ -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. -- diff --git a/src/Graphics/Rasterific/Transformations.hs b/src/Graphics/Rasterific/Transformations.hs --- a/src/Graphics/Rasterific/Transformations.hs +++ b/src/Graphics/Rasterific/Transformations.hs @@ -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 + diff --git a/src/Graphics/Rasterific/Types.hs b/src/Graphics/Rasterific/Types.hs --- a/src/Graphics/Rasterific/Types.hs +++ b/src/Graphics/Rasterific/Types.hs @@ -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