diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -1,100 +1,101 @@ --- Initial Rasterific.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ -name: Rasterific -version: 0.7 -synopsis: A pure haskell drawing engine. --- A longer description of the package. -description: - <> - . - Rasterific is a vector drawing library (a rasterizer) - implemented in pure haskell. - . - Can render vector graphics to an image and export vector data to PDF. - -license: BSD3 -license-file: LICENSE -author: Vincent Berthoux -maintainer: twinside@gmail.com - --- A copyright notice. --- copyright: -category: Graphics -build-type: Simple - --- extra-source-files: - -cabal-version: >= 1.10 -extra-doc-files: docimages/*.png -extra-source-files: changelog - , README.md - , docimages/*.png - , exec-src/docImageGenerator.hs - - - -Source-Repository head - Type: git - Location: git://github.com/Twinside/Rasterific.git - -Source-Repository this - Type: git - Location: git://github.com/Twinside/Rasterific.git - Tag: v0.7 - -flag embed_linear - description: Embed a reduced version of Linear avoiding a (huge) dep - Default: True - -library - hs-source-dirs: src - exposed-modules: Graphics.Rasterific - , Graphics.Rasterific.Outline - , Graphics.Rasterific.Texture - , Graphics.Rasterific.Linear - , Graphics.Rasterific.Lenses - , 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 - , Graphics.Rasterific.CubicBezier - , Graphics.Rasterific.QuadraticBezier - , Graphics.Rasterific.Operators - , Graphics.Rasterific.Rasterize - , Graphics.Rasterific.StrokeInternal - , Graphics.Rasterific.ComplexPrimitive - , Graphics.Rasterific.Types - , Graphics.Rasterific.Compositor - , Graphics.Rasterific.MicroPdf - , Graphics.Rasterific.MiniLens - , 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 - default-language: Haskell2010 - build-depends: base >= 4.5 && < 5 - , free >= 4.7 - , JuicyPixels >= 3.2 - , FontyFruity >= 0.5.3.2 && < 0.6 - , vector >= 0.9 - , mtl >= 1.9 - , dlist >= 0.6 - , primitive >= 0.5 - , vector-algorithms >= 0.3 - , bytestring >= 0.10.2 - , containers >= 0.5 - , transformers - - if !flag(embed_linear) - build-depends: linear >= 1.3 - cpp-options: -DEXTERNAL_LINEAR - +-- Initial Rasterific.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ +name: Rasterific +version: 0.7.1 +synopsis: A pure haskell drawing engine. +-- A longer description of the package. +description: + <> + . + Rasterific is a vector drawing library (a rasterizer) + implemented in pure haskell. + . + Can render vector graphics to an image and export vector data to PDF. + +license: BSD3 +license-file: LICENSE +author: Vincent Berthoux +maintainer: twinside@gmail.com + +-- A copyright notice. +-- copyright: +category: Graphics +build-type: Simple + +-- extra-source-files: + +cabal-version: >= 1.10 +extra-doc-files: docimages/*.png +extra-source-files: changelog + , README.md + , docimages/*.png + , exec-src/docImageGenerator.hs + + + +Source-Repository head + Type: git + Location: git://github.com/Twinside/Rasterific.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/Rasterific.git + Tag: v0.7.1 + +flag embed_linear + description: Embed a reduced version of Linear avoiding a (huge) dep + Default: True + +library + hs-source-dirs: src + exposed-modules: Graphics.Rasterific + , Graphics.Rasterific.Outline + , Graphics.Rasterific.Texture + , Graphics.Rasterific.Linear + , Graphics.Rasterific.Lenses + , 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 + , Graphics.Rasterific.CubicBezier + , Graphics.Rasterific.QuadraticBezier + , Graphics.Rasterific.Operators + , Graphics.Rasterific.Rasterize + , Graphics.Rasterific.StrokeInternal + , Graphics.Rasterific.ComplexPrimitive + , Graphics.Rasterific.Types + , Graphics.Rasterific.Compositor + , Graphics.Rasterific.MicroPdf + , Graphics.Rasterific.MiniLens + , Graphics.Rasterific.Shading + , Graphics.Rasterific.PlaneBoundable + , Graphics.Rasterific.QuadraticFormula + , Graphics.Rasterific.PatchTypes + , Graphics.Rasterific.CubicBezier.FastForwardDifference + , Graphics.Rasterific.Arc + + ghc-options: -O3 -Wall + -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques + default-language: Haskell2010 + build-depends: base >= 4.5 && < 5 + , free >= 4.7 + , JuicyPixels >= 3.2 + , FontyFruity >= 0.5.3.2 && < 0.6 + , vector >= 0.9 + , mtl >= 1.9 + , dlist >= 0.6 + , primitive >= 0.5 + , vector-algorithms >= 0.3 + , bytestring >= 0.10.2 + , containers >= 0.5 + , transformers + + if !flag(embed_linear) + build-depends: linear >= 1.3 + cpp-options: -DEXTERNAL_LINEAR + diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,147 +1,158 @@ -Change log -========== - -v0.6.1.1 May 2016 ------------------ - - * Fix: GHC 8.0 bound fix - -v0.6.1 May 2015 ---------------- - - * Fix: Correcting bytestring lower bounds - -v0.6 May 2015 -------------- - - * Adding: repeating background pattern texture. - * Added: PDF output without images (for now) - -v0.5.2.1 April 2015 -------------------- - - * Fixed: non-composability of cached elements - * Fixed: Border size when drawing images was twice too large. - -v0.5.2 April 2015 ------------------ - - * Enhancement: Added a withGroupOpacity to render elements with - a global opacity. - -v0.5.1 March 2015 ------------------ - - * Enhancement: Generalizing geometry description, with automatic - conversion, reducing the need of type constructor from Primitive, - and directly filling Path. - -v0.5.0.3 February 2015 ----------------------- - - * Fix: hackage documentation - -v0.5.0.2 February 2015 ----------------------- - * Removing test-suite as it's dependent of some repository-local files - -v0.5.0.1 February 2015 ----------------------- - * Fix: adding missing Arbitrary file in the distribution. - -v0.5 February 2015 ------------------- - - * Breaking Change: Font size is now a newtype in FontyFruity, - propagating the changes. - * Allowing to specify DPI at the top level of the rendering - request. - * Adding: an helper function to retrieve the distance to the - * Changed: font size switched to float. - -v0.4.2 February 2015 --------------------- - * Fix: Cubic bezier clipping - -v0.4.1 January 2015 -------------------- - * Fix: GHC 7.10 compilation - * Adding: Various lens to access some primitive informations. - -v0.4 December 2014 ------------------- - - * Breaking change: Changed the original position scheme for - text, allowing to specify baseline or upper left corner - - * Tried: Fast forward differencing for cubic bezier, not worth - the hassle - * Enhancement: Further optimized decomposition of all primitives, - less alocated memory. - * Enhancement: After optimizing pixel writing, optimized pixel - reading, yielding non-negligeable speed improvements. - * Added: an "immediate" module to avoid constructing - a scene tree. - * Enhancement: Allowing both IO & (ST s) as drawing monads, enabling - interleaved drawing with io operations. - * Added: a "withPathOrientation" function to orient primitives - on a path (allow to draw curved text) - * Added: toNewXBase transformation to create a new basis given - a X axis vector. - * Added: a PathWalker module, to give access to the lower level - path orientation facility. - * Added: some GHC rules for transformations - * Added: a new text function: 'printTextRanges' to allow - easier complex text rendering - -v0.3 June 2014 --------------- - - * Enhancement: Switching main free monad type to the church encoded one. - * Enhancement: Optimized the bezier decomposition, strictness annotations - made wonders. May require forward differencing in the future. - * Enhancement: Implementing specific decomposition for lines. - * Enhancement: Reworked texture system, now allowing some specialized - filler (hoping faster computation). For now only the - solid color has been optimized, and all the transformed - textures. - * Enhancement: Fixing space leak in combineEdgeSamples, avoiding - many allocations. - * Adding: bounding box calculation facility. - * Adding: Exposing outline creation capability - * Adding: a skewX & skewY transformation function. - * Fixing: some numerical stability with the mitter join. - -v0.2.1 April 2014 ------------------ - - * Fixing: transparency in gradients. - * Fixing: alpha composition on top of translucent - background. - -v0.2 April 2014 ---------------- - - * Adding: an ellipse helper. - * Adding: a polyline helper. - * Adding: a polygon helper. - * Adding: monoid instance for Drawing. - * Fixing: some stroking bug with cubic bezier curve. - * Fixing: some documentation snippets. - * Adding: a rounded rectangle helper. - * Added: a even-odd filling rule. - * Added: an offset for dashed stroking. - * Added: a transformation module. - * Change: Changed the Transformable typeclass, splitted - it in two. - * Added: a dumping function for the constructed - drawing. - * Adding: an image texture with bilinear filtering. - * Adding: an image helper. - * Enhancement: Some modest performance gain. - -v0.1 February 2014 ------------------- - - * Initial version. - +Change log +========== + +v0.7.1 +------ + + * Addition: arc path helper + * Fix: Composition of clip path with transformation. + +V0.7 +---- + + * Addition: Gradient Mesh! + +v0.6.1.1 May 2016 +----------------- + + * Fix: GHC 8.0 bound fix + +v0.6.1 May 2015 +--------------- + + * Fix: Correcting bytestring lower bounds + +v0.6 May 2015 +------------- + + * Adding: repeating background pattern texture. + * Added: PDF output without images (for now) + +v0.5.2.1 April 2015 +------------------- + + * Fixed: non-composability of cached elements + * Fixed: Border size when drawing images was twice too large. + +v0.5.2 April 2015 +----------------- + + * Enhancement: Added a withGroupOpacity to render elements with + a global opacity. + +v0.5.1 March 2015 +----------------- + + * Enhancement: Generalizing geometry description, with automatic + conversion, reducing the need of type constructor from Primitive, + and directly filling Path. + +v0.5.0.3 February 2015 +---------------------- + + * Fix: hackage documentation + +v0.5.0.2 February 2015 +---------------------- + * Removing test-suite as it's dependent of some repository-local files + +v0.5.0.1 February 2015 +---------------------- + * Fix: adding missing Arbitrary file in the distribution. + +v0.5 February 2015 +------------------ + + * Breaking Change: Font size is now a newtype in FontyFruity, + propagating the changes. + * Allowing to specify DPI at the top level of the rendering + request. + * Adding: an helper function to retrieve the distance to the + * Changed: font size switched to float. + +v0.4.2 February 2015 +-------------------- + * Fix: Cubic bezier clipping + +v0.4.1 January 2015 +------------------- + * Fix: GHC 7.10 compilation + * Adding: Various lens to access some primitive informations. + +v0.4 December 2014 +------------------ + + * Breaking change: Changed the original position scheme for + text, allowing to specify baseline or upper left corner + + * Tried: Fast forward differencing for cubic bezier, not worth + the hassle + * Enhancement: Further optimized decomposition of all primitives, + less alocated memory. + * Enhancement: After optimizing pixel writing, optimized pixel + reading, yielding non-negligeable speed improvements. + * Added: an "immediate" module to avoid constructing + a scene tree. + * Enhancement: Allowing both IO & (ST s) as drawing monads, enabling + interleaved drawing with io operations. + * Added: a "withPathOrientation" function to orient primitives + on a path (allow to draw curved text) + * Added: toNewXBase transformation to create a new basis given + a X axis vector. + * Added: a PathWalker module, to give access to the lower level + path orientation facility. + * Added: some GHC rules for transformations + * Added: a new text function: 'printTextRanges' to allow + easier complex text rendering + +v0.3 June 2014 +-------------- + + * Enhancement: Switching main free monad type to the church encoded one. + * Enhancement: Optimized the bezier decomposition, strictness annotations + made wonders. May require forward differencing in the future. + * Enhancement: Implementing specific decomposition for lines. + * Enhancement: Reworked texture system, now allowing some specialized + filler (hoping faster computation). For now only the + solid color has been optimized, and all the transformed + textures. + * Enhancement: Fixing space leak in combineEdgeSamples, avoiding + many allocations. + * Adding: bounding box calculation facility. + * Adding: Exposing outline creation capability + * Adding: a skewX & skewY transformation function. + * Fixing: some numerical stability with the mitter join. + +v0.2.1 April 2014 +----------------- + + * Fixing: transparency in gradients. + * Fixing: alpha composition on top of translucent + background. + +v0.2 April 2014 +--------------- + + * Adding: an ellipse helper. + * Adding: a polyline helper. + * Adding: a polygon helper. + * Adding: monoid instance for Drawing. + * Fixing: some stroking bug with cubic bezier curve. + * Fixing: some documentation snippets. + * Adding: a rounded rectangle helper. + * Added: a even-odd filling rule. + * Added: an offset for dashed stroking. + * Added: a transformation module. + * Change: Changed the Transformable typeclass, splitted + it in two. + * Added: a dumping function for the constructed + drawing. + * Adding: an image texture with bilinear filtering. + * Adding: an image helper. + * Enhancement: Some modest performance gain. + +v0.1 February 2014 +------------------ + + * Initial version. + diff --git a/exec-src/docImageGenerator.hs b/exec-src/docImageGenerator.hs --- a/exec-src/docImageGenerator.hs +++ b/exec-src/docImageGenerator.hs @@ -1,580 +1,572 @@ -{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - - -import Control.Monad( forM_ ) -import Control.Monad.ST( runST ) -import Data.Monoid( (<>) ) -import Codec.Picture -import Codec.Picture.Types( promoteImage ) -import Graphics.Text.TrueType( loadFontFile ) -import Graphics.Rasterific -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( (^+^) ) - -logo :: Int -> Bool -> Vector -> [Primitive] -logo size inv offset = - toPrimitives . bezierFromPath . way $ map (^+^ offset) - [ (V2 0 is) - , (V2 0 0) - , (V2 is 0) - , (V2 is2 0) - , (V2 is2 is) - , (V2 is2 is2) - , (V2 is is2) - , (V2 0 is2) - , (V2 0 is) - ] - where is = fromIntegral size - is2 = is + is - - way | inv = reverse - | otherwise = id - -backgroundColor :: PixelRGBA8 -backgroundColor = PixelRGBA8 255 255 255 255 - -frontColor, accentColor, accent2Color :: PixelRGBA8 -frontColor = PixelRGBA8 0 0x86 0xc1 255 -accentColor = PixelRGBA8 0xff 0xf4 0xc1 255 -accent2Color = PixelRGBA8 0xFF 0x53 0x73 255 - -frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8 -frontTexture = uniformTexture frontColor -accentTexture = uniformTexture accentColor -accent2Texture = uniformTexture accent2Color - -produceDocImageAtSize :: Int -> Int -> FilePath -> Drawing PixelRGBA8 () -> IO () -produceDocImageAtSize width height filename drawing = do - putStrLn $ "Producing " <> filename - writePng filename img - writePdf $ filename <> ".draw.pdf" - writeOrderPdf $ filename <> ".order.pdf" - where - img = renderDrawing width height backgroundColor - $ withTexture frontTexture drawing - - writeOrderPdf fname = - LB.writeFile fname . - renderOrdersAtDpiToPdf width height 92 $ - drawOrdersOfDrawing width height 92 (PixelRGBA8 0 0 0 0) $ - withTexture frontTexture drawing - - writePdf fname = - LB.writeFile fname . - renderDrawingAtDpiToPDF width height 92 $ - withTexture frontTexture drawing - -produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO () -produceDocImage = produceDocImageAtSize 200 200 - -capTester :: (FilePath, Cap) -> IO () -capTester (filename, cap) = - produceDocImage filename $ do - stroke 30 JoinRound (cap, cap) base_stroke - withTexture accentTexture $ - stroke 2 JoinRound (cap, cap) base_stroke - where - base_stroke = line (V2 0 200) (V2 100 100) - -joinTester :: (FilePath, Join) -> IO () -joinTester (filename, join) = - produceDocImage filename $ do - stroke 30 join (CapRound, CapRound) base_stroke - withTexture accentTexture $ - stroke 2 join (CapRound, CapRound) base_stroke - where - base_stroke = - [ Line (V2 0 200) (V2 100 100) - , Line (V2 100 100) (V2 200 200) - ] - -samplerTester :: (FilePath, SamplerRepeat) -> IO () -samplerTester (filename, sampler) = - produceDocImage filename $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (withSampler sampler $ linearGradientTexture gradDef - (V2 80 100) (V2 120 110)) $ - fill $ rectangle (V2 10 10) 180 180) - -outFolder :: FilePath -outFolder = "docimages" - -moduleExample :: IO () -moduleExample = do - let drawColor = PixelRGBA8 0 0x86 0xc1 255 - recColor = PixelRGBA8 0xFF 0x53 0x73 255 - img = - withTexture (uniformTexture drawColor) $ do - fill $ circle (V2 0 0) 30 - stroke 4 JoinRound (CapRound, CapRound) $ - circle (V2 400 200) 40 - withTexture (uniformTexture recColor) . - fill $ rectangle (V2 100 100) 200 100 - - produceDocImageAtSize 400 200 (outFolder "module_example.png") img - -sansSerifFont :: FilePath -sansSerifFont = "test_fonts/DejaVuSans.ttf" - -monospaceFont :: FilePath -monospaceFont = "test_fonts/DejaVuSansMono.ttf" - -textOnPathExample :: IO () -textOnPathExample = do - fontErr <- loadFontFile sansSerifFont - case fontErr of - Left err -> putStrLn err - Right font -> - let path = Path (V2 100 180) False - [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] - in - produceDocImage (outFolder "text_on_path.png") $ do - stroke 3 JoinRound (CapStraight 0, CapStraight 0) path - - withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ do - withPathOrientation path 0 $ - printTextAt font (PointSize 24) (V2 0 0) "Text on path" - -geometryOnPath :: IO () -geometryOnPath = do - fontErr <- loadFontFile sansSerifFont - case fontErr of - Left err -> putStrLn err - Right font -> - produceDocImage (outFolder "geometry_on_path.png") $ do - let path = Path (V2 100 180) False - [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] - withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ - stroke 3 JoinRound (CapStraight 0, CapStraight 0) path - - withPathOrientation path 0 $ do - printTextAt font (PointSize 24) (V2 0 0) "TX" - fill $ rectangle (V2 (-10) (-10)) 30 20 - fill $ rectangle (V2 45 0) 10 20 - fill $ rectangle (V2 60 (-10)) 20 20 - fill $ rectangle (V2 100 (-15)) 20 50 - -textExample :: IO () -textExample = do - fontErr <- loadFontFile sansSerifFont - case fontErr of - Left err -> putStrLn err - Right font -> - produceDocImageAtSize 300 70 (outFolder "text_example.png") - . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ - printTextAt font (PointSize 12) (V2 20 40) "A simple text test!" - -textMultipleExample :: IO () -textMultipleExample = do - eitherFont1 <- loadFontFile sansSerifFont - eitherFont2 <- loadFontFile monospaceFont - case (,) <$> eitherFont1 <*> eitherFont2 of - Left err -> putStrLn err - Right (font1, font2) -> - produceDocImageAtSize 300 70 (outFolder "text_complex_example.png") $ - let blackTexture = - Just . uniformTexture $ PixelRGBA8 0 0 0 255 - redTexture = - Just . uniformTexture $ PixelRGBA8 255 0 0 255 - in - printTextRanges (V2 20 40) - [ TextRange font1 (PointSize 12) "A complex " blackTexture - , TextRange font2 (PointSize 8) "text test" redTexture] - -coordinateSystem :: IO () -coordinateSystem = do - fontErr <- loadFontFile sansSerifFont - case fontErr of - Left err -> putStrLn err - Right font -> - produceDocImage (outFolder "coordinate.png") $ create font - where - black = PixelRGBA8 0 0 0 255 - stroker = stroke 4 JoinRound (CapStraight 0, CapStraight 0) - create font = withTexture (uniformTexture black) $ do - stroker $ line (V2 10 40) (V2 190 40) - stroker $ line (V2 40 10) (V2 40 190) - printTextAt font (PointSize 12) (V2 4 37) "(0,0)" - printTextAt font (PointSize 12) (V2 100 37) "(width, 0)" - printTextAt font (PointSize 12) (V2 57 190) "(0, height)" - fill $ Path (V2 170 30) True - [PathLineTo (V2 195 40), PathLineTo (V2 170 50)] - fill $ Path (V2 30 170) True - [PathLineTo (V2 40 195), PathLineTo (V2 50 170)] - -fillingSample :: FillMethod -> Drawing px () -fillingSample fillMethod = fillWithMethod fillMethod geometry where - geometry = transform (applyTransformation $ scale 0.35 0.4 - <> translate (V2 (-80) (-180))) - [ Path (V2 484 499) True - [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) - , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) - ] - , Path (V2 136 377) True - [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) - , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) - ] - , Path (V2 340 265) True - [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) - , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) - , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) - ] - ] - -immediateDrawExample :: Image PixelRGBA8 -immediateDrawExample = runST $ - runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ - fillWithTexture FillWinding texture geometry - where - circlePrimitives = circle (V2 100 100) 50 - geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives - texture = uniformTexture (PixelRGBA8 255 255 255 255) - -immediateDrawMaskExample :: Image PixelRGBA8 -immediateDrawMaskExample = runST $ - runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ - forM_ [1 .. 10] $ \ix -> - fillWithTextureAndMask FillWinding texture mask $ - rectangle (V2 10 (ix * 18 - 5)) 180 13 - where - texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 - mask = sampledImageTexture - $ runST - $ runDrawContext 200 200 0 - $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry - - maskGeometry = strokize 15 JoinRound (CapRound, CapRound) - $ circle (V2 100 100) 80 - -main :: IO () -main = do - let addFolder (p, v) = (outFolder p, v) - createDirectoryIfMissing True outFolder - moduleExample - mapM_ (capTester . addFolder) - [ ("cap_straight.png", CapStraight 0) - , ("cap_straight_1.png", CapStraight 1) - , ("cap_round.png", CapRound) - ] - - mapM_ (joinTester . addFolder) - [ ("join_round.png", JoinRound) - , ("join_miter.png", JoinMiter 0) - , ("join_miter_5.png", JoinMiter 5) - ] - - mapM_ (samplerTester . addFolder) - [ ("sampler_pad.png", SamplerPad) - , ("sampler_repeat.png", SamplerRepeat) - , ("sampler_reflect.png", SamplerReflect) - ] - - writePng (outFolder "immediate_fill.png") immediateDrawExample - writePng (outFolder "immediate_mask.png") immediateDrawMaskExample - - produceDocImage (outFolder "fill_circle.png") $ - fill $ circle (V2 100 100) 75 - - produceDocImage (outFolder "fill_ellipse.png") $ - fill $ ellipse (V2 100 100) 75 30 - - produceDocImage (outFolder "stroke_circle.png") $ - stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 - - produceDocImage (outFolder "dashed_stroke.png") $ - dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ - line (V2 0 100) (V2 200 100) - - produceDocImage (outFolder "dashed_stroke_with_offset.png") $ - dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ - line (V2 0 100) (V2 200 100) - - produceDocImage (outFolder "fill_rect.png") $ - fill $ rectangle (V2 30 30) 150 100 - - produceDocImage (outFolder "with_texture.png") $ - withTexture frontTexture $ do - fill $ circle (V2 50 50) 20 - fill $ circle (V2 100 100) 20 - withTexture accent2Texture $ - fill $ circle (V2 150 150) 20 - - produceDocImage (outFolder "strokize_path.png") $ - stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ - strokize 40 JoinRound (CapRound, CapRound) $ - CubicBezier (V2 40 160) (V2 40 40) - (V2 160 40) (V2 160 160) - - produceDocImage (outFolder "strokize_dashed_path.png") $ - mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ - dashedStrokize 0 [10, 5] - 40 JoinRound (CapStraight 0, CapStraight 0) - [CubicBezier (V2 40 160) (V2 40 40) - (V2 160 40) (V2 160 160)] - - produceDocImage (outFolder "with_clipping.png") $ - withClipping (fill $ circle (V2 100 100) 75) $ - mapM_ (stroke 7 JoinRound (CapRound, CapRound)) - [line (V2 0 yf) (V2 200 (yf + 10)) - | y <- [5 :: Int, 17 .. 200] - , let yf = fromIntegral y ] - - {-produceDocImage (outFolder "clip_compose.png") $-} - - produceDocImage (outFolder "stroke_line.png") $ - stroke 17 JoinRound (CapRound, CapRound) $ - line (V2 10 10) (V2 180 170) - - produceDocImage (outFolder "linear_gradient.png") $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - 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) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (radialGradientTexture gradDef (V2 100 100) 75) $ - fill $ circle (V2 100 100) 100) - - produceDocImage (outFolder "radial_gradient_focus.png") $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (radialGradientWithFocusTexture gradDef (V2 100 100) 75 (V2 70 70)) $ - fill $ circle (V2 100 100) 100) - - produceDocImage (outFolder "sampler_pad.png") $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (linearGradientTexture gradDef (V2 80 100) (V2 120 110)) $ - fill $ rectangle (V2 10 10) 180 180) - - 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) - - produceDocImage (outFolder "cubic_bezier.png") $ - stroke 5 JoinRound (CapRound, CapRound) $ - CubicBezier (V2 0 10) (V2 205 250) - (V2 (-10) 250) (V2 160 35) - - produceDocImage (outFolder "quadratic_bezier.png") $ - fill [ Bezier (V2 10 10) (V2 200 50) (V2 200 100) - , Bezier (V2 200 100) (V2 150 200) (V2 120 175) - , Bezier (V2 120 175) (V2 30 100) (V2 10 10)] - - produceDocImage (outFolder "simple_line.png") $ - fill [ Line (V2 10 10) (V2 190 10) - , Line (V2 190 10) (V2 95 170) - , Line (V2 95 170) (V2 10 10) ] - - produceDocImage (outFolder "primitive_mixed.png") $ - fill - [ toPrim $ CubicBezier (V2 50 20) (V2 90 60) - (V2 5 100) (V2 50 140) - , toPrim $ Line (V2 50 140) (V2 120 80) - , toPrim $ Line (V2 120 80) (V2 50 20) ] - - produceDocImage (outFolder "path_example.png") $ - fill $ Path (V2 50 20) True - [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) - , PathLineTo (V2 120 80) ] - - produceDocImage (outFolder "stroke_polyline.png") $ - stroke 4 JoinRound (CapRound, CapRound) $ - polyline [V2 10 10, V2 100 70, V2 190 190] - - produceDocImage (outFolder "fill_polygon.png") $ - fill $ polygon [V2 30 30, V2 100 70, V2 80 170] - - produceDocImage (outFolder "fill_roundedRectangle.png") $ - fill $ roundedRectangle (V2 10 10) 150 150 20 10 - - produceDocImage (outFolder "stroke_roundedRectangle.png") $ - stroke 4 JoinRound (CapRound, CapRound) $ - roundedRectangle (V2 10 10) 150 150 20 10 - - produceDocImage (outFolder "fill_evenodd.png") $ - fillingSample FillEvenOdd - - produceDocImage (outFolder "fill_winding.png") $ - fillingSample FillWinding - - produceDocImage (outFolder "transform_rotate.png") $ - fill . transform (applyTransformation $ rotate 0.2) - $ rectangle (V2 40 40) 120 120 - - produceDocImage (outFolder "transform_rotate_center.png") $ - fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200)) - $ rectangle (V2 40 40) 120 120 - - produceDocImage (outFolder "transform_translate.png") $ - fill . transform (applyTransformation $ translate (V2 100 100)) - $ rectangle (V2 40 40) 40 40 - - produceDocImage (outFolder "transform_scale.png") $ - fill . transform (applyTransformation $ scale 2 2) - $ rectangle (V2 40 40) 40 40 - - produceDocImage (outFolder "transform_skewx.png") $ - fill . transform (applyTransformation $ skewX 0.3) - $ rectangle (V2 50 50) 80 80 - - produceDocImage (outFolder "transform_skewy.png") $ - fill . transform (applyTransformation $ skewY 0.3) - $ rectangle (V2 50 50) 80 80 - - Right (ImageRGB8 img) <- readImage "avatar.png" - let textureImage = promoteImage img - produceDocImage (outFolder "sampled_texture_repeat.png") $ - withTexture (withSampler SamplerRepeat $ - sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "image_simple.png") $ - drawImage textureImage 0 (V2 30 30) - - produceDocImage (outFolder "image_resize.png") $ - drawImageAtSize textureImage 2 (V2 30 30) 128 128 - - produceDocImage (outFolder "sampled_texture_reflect.png") $ - withTexture (withSampler SamplerReflect $ - sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "sampled_texture_pad.png") $ - withTexture (sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "sampled_texture_rotate.png") $ - withTexture (withSampler SamplerRepeat $ - transformTexture (rotateCenter 1 (V2 0 0)) - $ sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "sampled_texture_scaled.png") $ - withTexture (withSampler SamplerRepeat $ - transformTexture (rotateCenter 1 (V2 0 0) <> - scale 0.5 0.25) - $ sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "group_opacity.png") $ do - withTexture accent2Texture $ - stroke 3 JoinRound (CapRound, CapRound) $ - line (V2 0 100) (V2 200 100) - - withGroupOpacity 128 $ do - withTexture frontTexture . fill $ circle (V2 70 100) 60 - withTexture accentTexture . fill $ circle (V2 120 100) 60 - - produceDocImage (outFolder "pattern_texture.png") $ - let pattern = - patternTexture 40 40 96 accent2Color . - withTexture frontTexture $ - fill $ circle (V2 20 20) 13 - in - withTexture pattern $ - fill $ roundedRectangle (V2 20 20) 160 160 20 20 - - produceDocImage (outFolder "item_opacity.png") $ do - withTexture accent2Texture $ - stroke 3 JoinRound (CapRound, CapRound) $ - line (V2 0 100) (V2 200 100) - - withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) . - fill $ circle (V2 70 100) 60 - withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) . - fill $ circle (V2 120 100) 60 - - 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 - coordinateSystem - textOnPathExample - geometryOnPath - +{-# LANGUAGE CPP #-} + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + + +import Control.Monad( forM_ ) +import Control.Monad.ST( runST ) +import Data.Monoid( (<>) ) +import Codec.Picture +import Codec.Picture.Types( promoteImage ) +import Graphics.Text.TrueType( loadFontFile ) +import Graphics.Rasterific +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( (^+^) ) + +logo :: Int -> Bool -> Vector -> [Primitive] +logo size inv offset = + toPrimitives . bezierFromPath . way $ map (^+^ offset) + [ (V2 0 is) + , (V2 0 0) + , (V2 is 0) + , (V2 is2 0) + , (V2 is2 is) + , (V2 is2 is2) + , (V2 is is2) + , (V2 0 is2) + , (V2 0 is) + ] + where is = fromIntegral size + is2 = is + is + + way | inv = reverse + | otherwise = id + +backgroundColor :: PixelRGBA8 +backgroundColor = PixelRGBA8 255 255 255 255 + +frontColor, accentColor, accent2Color :: PixelRGBA8 +frontColor = PixelRGBA8 0 0x86 0xc1 255 +accentColor = PixelRGBA8 0xff 0xf4 0xc1 255 +accent2Color = PixelRGBA8 0xFF 0x53 0x73 255 + +frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8 +frontTexture = uniformTexture frontColor +accentTexture = uniformTexture accentColor +accent2Texture = uniformTexture accent2Color + +produceDocImageAtSize :: Int -> Int -> FilePath -> Drawing PixelRGBA8 () -> IO () +produceDocImageAtSize width height filename drawing = do + putStrLn $ "Producing " <> filename + writePng filename img + writePdf $ filename <> ".draw.pdf" + writeOrderPdf $ filename <> ".order.pdf" + where + img = renderDrawing width height backgroundColor + $ withTexture frontTexture drawing + + writeOrderPdf fname = + LB.writeFile fname . + renderOrdersAtDpiToPdf width height 92 $ + drawOrdersOfDrawing width height 92 (PixelRGBA8 0 0 0 0) $ + withTexture frontTexture drawing + + writePdf fname = + LB.writeFile fname . + renderDrawingAtDpiToPDF width height 92 $ + withTexture frontTexture drawing + +produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO () +produceDocImage = produceDocImageAtSize 200 200 + +capTester :: (FilePath, Cap) -> IO () +capTester (filename, cap) = + produceDocImage filename $ do + stroke 30 JoinRound (cap, cap) base_stroke + withTexture accentTexture $ + stroke 2 JoinRound (cap, cap) base_stroke + where + base_stroke = line (V2 0 200) (V2 100 100) + +joinTester :: (FilePath, Join) -> IO () +joinTester (filename, join) = + produceDocImage filename $ do + stroke 30 join (CapRound, CapRound) base_stroke + withTexture accentTexture $ + stroke 2 join (CapRound, CapRound) base_stroke + where + base_stroke = + [ Line (V2 0 200) (V2 100 100) + , Line (V2 100 100) (V2 200 200) + ] + +samplerTester :: (FilePath, SamplerRepeat) -> IO () +samplerTester (filename, sampler) = + produceDocImage filename $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (withSampler sampler $ linearGradientTexture gradDef + (V2 80 100) (V2 120 110)) $ + fill $ rectangle (V2 10 10) 180 180) + +outFolder :: FilePath +outFolder = "docimages" + +moduleExample :: IO () +moduleExample = do + let drawColor = PixelRGBA8 0 0x86 0xc1 255 + recColor = PixelRGBA8 0xFF 0x53 0x73 255 + img = + withTexture (uniformTexture drawColor) $ do + fill $ circle (V2 0 0) 30 + stroke 4 JoinRound (CapRound, CapRound) $ + circle (V2 400 200) 40 + withTexture (uniformTexture recColor) . + fill $ rectangle (V2 100 100) 200 100 + + produceDocImageAtSize 400 200 (outFolder "module_example.png") img + +sansSerifFont :: FilePath +sansSerifFont = "test_fonts/DejaVuSans.ttf" + +monospaceFont :: FilePath +monospaceFont = "test_fonts/DejaVuSansMono.ttf" + +textOnPathExample :: IO () +textOnPathExample = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + let path = Path (V2 100 180) False + [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] + in + produceDocImage (outFolder "text_on_path.png") $ do + stroke 3 JoinRound (CapStraight 0, CapStraight 0) path + + withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ do + withPathOrientation path 0 $ + printTextAt font (PointSize 24) (V2 0 0) "Text on path" + +geometryOnPath :: IO () +geometryOnPath = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + produceDocImage (outFolder "geometry_on_path.png") $ do + let path = Path (V2 100 180) False + [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] + withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ + stroke 3 JoinRound (CapStraight 0, CapStraight 0) path + + withPathOrientation path 0 $ do + printTextAt font (PointSize 24) (V2 0 0) "TX" + fill $ rectangle (V2 (-10) (-10)) 30 20 + fill $ rectangle (V2 45 0) 10 20 + fill $ rectangle (V2 60 (-10)) 20 20 + fill $ rectangle (V2 100 (-15)) 20 50 + +textExample :: IO () +textExample = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + produceDocImageAtSize 300 70 (outFolder "text_example.png") + . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ + printTextAt font (PointSize 12) (V2 20 40) "A simple text test!" + +textMultipleExample :: IO () +textMultipleExample = do + eitherFont1 <- loadFontFile sansSerifFont + eitherFont2 <- loadFontFile monospaceFont + case (,) <$> eitherFont1 <*> eitherFont2 of + Left err -> putStrLn err + Right (font1, font2) -> + produceDocImageAtSize 300 70 (outFolder "text_complex_example.png") $ + let blackTexture = + Just . uniformTexture $ PixelRGBA8 0 0 0 255 + redTexture = + Just . uniformTexture $ PixelRGBA8 255 0 0 255 + in + printTextRanges (V2 20 40) + [ TextRange font1 (PointSize 12) "A complex " blackTexture + , TextRange font2 (PointSize 8) "text test" redTexture] + +coordinateSystem :: IO () +coordinateSystem = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + produceDocImage (outFolder "coordinate.png") $ create font + where + black = PixelRGBA8 0 0 0 255 + stroker = stroke 4 JoinRound (CapStraight 0, CapStraight 0) + create font = withTexture (uniformTexture black) $ do + stroker $ line (V2 10 40) (V2 190 40) + stroker $ line (V2 40 10) (V2 40 190) + printTextAt font (PointSize 12) (V2 4 37) "(0,0)" + printTextAt font (PointSize 12) (V2 100 37) "(width, 0)" + printTextAt font (PointSize 12) (V2 57 190) "(0, height)" + fill $ Path (V2 170 30) True + [PathLineTo (V2 195 40), PathLineTo (V2 170 50)] + fill $ Path (V2 30 170) True + [PathLineTo (V2 40 195), PathLineTo (V2 50 170)] + +fillingSample :: FillMethod -> Drawing px () +fillingSample fillMethod = fillWithMethod fillMethod geometry where + geometry = transform (applyTransformation $ scale 0.35 0.4 + <> translate (V2 (-80) (-180))) + [ Path (V2 484 499) True + [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) + , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) + ] + , Path (V2 136 377) True + [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) + , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) + ] + , Path (V2 340 265) True + [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) + , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) + , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) + ] + ] + +immediateDrawExample :: Image PixelRGBA8 +immediateDrawExample = runST $ + runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ + fillWithTexture FillWinding texture geometry + where + circlePrimitives = circle (V2 100 100) 50 + geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives + texture = uniformTexture (PixelRGBA8 255 255 255 255) + +immediateDrawMaskExample :: Image PixelRGBA8 +immediateDrawMaskExample = runST $ + runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ + forM_ [1 .. 10] $ \ix -> + fillWithTextureAndMask FillWinding texture mask $ + rectangle (V2 10 (ix * 18 - 5)) 180 13 + where + texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 + mask = sampledImageTexture + $ runST + $ runDrawContext 200 200 0 + $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry + + maskGeometry = strokize 15 JoinRound (CapRound, CapRound) + $ circle (V2 100 100) 80 + +main :: IO () +main = do + let addFolder (p, v) = (outFolder p, v) + createDirectoryIfMissing True outFolder + moduleExample + mapM_ (capTester . addFolder) + [ ("cap_straight.png", CapStraight 0) + , ("cap_straight_1.png", CapStraight 1) + , ("cap_round.png", CapRound) + ] + + mapM_ (joinTester . addFolder) + [ ("join_round.png", JoinRound) + , ("join_miter.png", JoinMiter 0) + , ("join_miter_5.png", JoinMiter 5) + ] + + mapM_ (samplerTester . addFolder) + [ ("sampler_pad.png", SamplerPad) + , ("sampler_repeat.png", SamplerRepeat) + , ("sampler_reflect.png", SamplerReflect) + ] + + writePng (outFolder "immediate_fill.png") immediateDrawExample + writePng (outFolder "immediate_mask.png") immediateDrawMaskExample + + produceDocImage (outFolder "fill_circle.png") $ + fill $ circle (V2 100 100) 75 + + produceDocImage (outFolder "fill_ellipse.png") $ + fill $ ellipse (V2 100 100) 75 30 + + produceDocImage (outFolder "stroke_circle.png") $ + stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 + + produceDocImage (outFolder "dashed_stroke.png") $ + dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ + line (V2 0 100) (V2 200 100) + + produceDocImage (outFolder "dashed_stroke_with_offset.png") $ + dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ + line (V2 0 100) (V2 200 100) + + produceDocImage (outFolder "fill_rect.png") $ + fill $ rectangle (V2 30 30) 150 100 + + produceDocImage (outFolder "with_texture.png") $ + withTexture frontTexture $ do + fill $ circle (V2 50 50) 20 + fill $ circle (V2 100 100) 20 + withTexture accent2Texture $ + fill $ circle (V2 150 150) 20 + + produceDocImage (outFolder "strokize_path.png") $ + stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ + strokize 40 JoinRound (CapRound, CapRound) $ + CubicBezier (V2 40 160) (V2 40 40) + (V2 160 40) (V2 160 160) + + produceDocImage (outFolder "strokize_dashed_path.png") $ + mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ + dashedStrokize 0 [10, 5] + 40 JoinRound (CapStraight 0, CapStraight 0) + [CubicBezier (V2 40 160) (V2 40 40) + (V2 160 40) (V2 160 160)] + + produceDocImage (outFolder "with_clipping.png") $ + withClipping (fill $ circle (V2 100 100) 75) $ + mapM_ (stroke 7 JoinRound (CapRound, CapRound)) + [line (V2 0 yf) (V2 200 (yf + 10)) + | y <- [5 :: Int, 17 .. 200] + , let yf = fromIntegral y ] + + {-produceDocImage (outFolder "clip_compose.png") $-} + + produceDocImage (outFolder "stroke_line.png") $ + stroke 17 JoinRound (CapRound, CapRound) $ + line (V2 10 10) (V2 180 170) + + produceDocImage (outFolder "linear_gradient.png") $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + 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) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (radialGradientTexture gradDef (V2 100 100) 75) $ + fill $ circle (V2 100 100) 100) + + produceDocImage (outFolder "radial_gradient_focus.png") $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (radialGradientWithFocusTexture gradDef (V2 100 100) 75 (V2 70 70)) $ + fill $ circle (V2 100 100) 100) + + produceDocImage (outFolder "sampler_pad.png") $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (linearGradientTexture gradDef (V2 80 100) (V2 120 110)) $ + fill $ rectangle (V2 10 10) 180 180) + + 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) + + produceDocImage (outFolder "cubic_bezier.png") $ + stroke 5 JoinRound (CapRound, CapRound) $ + CubicBezier (V2 0 10) (V2 205 250) + (V2 (-10) 250) (V2 160 35) + + produceDocImage (outFolder "quadratic_bezier.png") $ + fill [ Bezier (V2 10 10) (V2 200 50) (V2 200 100) + , Bezier (V2 200 100) (V2 150 200) (V2 120 175) + , Bezier (V2 120 175) (V2 30 100) (V2 10 10)] + + produceDocImage (outFolder "simple_line.png") $ + fill [ Line (V2 10 10) (V2 190 10) + , Line (V2 190 10) (V2 95 170) + , Line (V2 95 170) (V2 10 10) ] + + produceDocImage (outFolder "primitive_mixed.png") $ + fill + [ toPrim $ CubicBezier (V2 50 20) (V2 90 60) + (V2 5 100) (V2 50 140) + , toPrim $ Line (V2 50 140) (V2 120 80) + , toPrim $ Line (V2 120 80) (V2 50 20) ] + + produceDocImage (outFolder "path_example.png") $ + fill $ Path (V2 50 20) True + [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) + , PathLineTo (V2 120 80) ] + + produceDocImage (outFolder "stroke_polyline.png") $ + stroke 4 JoinRound (CapRound, CapRound) $ + polyline [V2 10 10, V2 100 70, V2 190 190] + + produceDocImage (outFolder "fill_polygon.png") $ + fill $ polygon [V2 30 30, V2 100 70, V2 80 170] + + produceDocImage (outFolder "fill_roundedRectangle.png") $ + fill $ roundedRectangle (V2 10 10) 150 150 20 10 + + produceDocImage (outFolder "stroke_roundedRectangle.png") $ + stroke 4 JoinRound (CapRound, CapRound) $ + roundedRectangle (V2 10 10) 150 150 20 10 + + produceDocImage (outFolder "fill_evenodd.png") $ + fillingSample FillEvenOdd + + produceDocImage (outFolder "fill_winding.png") $ + fillingSample FillWinding + + produceDocImage (outFolder "transform_rotate.png") $ + fill . transform (applyTransformation $ rotate 0.2) + $ rectangle (V2 40 40) 120 120 + + produceDocImage (outFolder "transform_rotate_center.png") $ + fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200)) + $ rectangle (V2 40 40) 120 120 + + produceDocImage (outFolder "transform_translate.png") $ + fill . transform (applyTransformation $ translate (V2 100 100)) + $ rectangle (V2 40 40) 40 40 + + produceDocImage (outFolder "transform_scale.png") $ + fill . transform (applyTransformation $ scale 2 2) + $ rectangle (V2 40 40) 40 40 + + produceDocImage (outFolder "transform_skewx.png") $ + fill . transform (applyTransformation $ skewX 0.3) + $ rectangle (V2 50 50) 80 80 + + produceDocImage (outFolder "transform_skewy.png") $ + fill . transform (applyTransformation $ skewY 0.3) + $ rectangle (V2 50 50) 80 80 + + Right (ImageRGB8 img) <- readImage "avatar.png" + let textureImage = promoteImage img + produceDocImage (outFolder "sampled_texture_repeat.png") $ + withTexture (withSampler SamplerRepeat $ + sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "image_simple.png") $ + drawImage textureImage 0 (V2 30 30) + + produceDocImage (outFolder "image_resize.png") $ + drawImageAtSize textureImage 2 (V2 30 30) 128 128 + + produceDocImage (outFolder "sampled_texture_reflect.png") $ + withTexture (withSampler SamplerReflect $ + sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "sampled_texture_pad.png") $ + withTexture (sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "sampled_texture_rotate.png") $ + withTexture (withSampler SamplerRepeat $ + transformTexture (rotateCenter 1 (V2 0 0)) + $ sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "sampled_texture_scaled.png") $ + withTexture (withSampler SamplerRepeat $ + transformTexture (rotateCenter 1 (V2 0 0) <> + scale 0.5 0.25) + $ sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "group_opacity.png") $ do + withTexture accent2Texture $ + stroke 3 JoinRound (CapRound, CapRound) $ + line (V2 0 100) (V2 200 100) + + withGroupOpacity 128 $ do + withTexture frontTexture . fill $ circle (V2 70 100) 60 + withTexture accentTexture . fill $ circle (V2 120 100) 60 + + produceDocImage (outFolder "pattern_texture.png") $ + let pattern = + patternTexture 40 40 96 accent2Color . + withTexture frontTexture $ + fill $ circle (V2 20 20) 13 + in + withTexture pattern $ + fill $ roundedRectangle (V2 20 20) 160 160 20 20 + + produceDocImage (outFolder "item_opacity.png") $ do + withTexture accent2Texture $ + stroke 3 JoinRound (CapRound, CapRound) $ + line (V2 0 100) (V2 200 100) + + withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) . + fill $ circle (V2 70 100) 60 + withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) . + fill $ circle (V2 120 100) 60 + + 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 + coordinateSystem + textOnPathExample + geometryOnPath + diff --git a/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs --- a/src/Graphics/Rasterific.hs +++ b/src/Graphics/Rasterific.hs @@ -1,823 +1,832 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} - --- | Main module of Rasterific, an Haskell rasterization engine. --- --- Creating an image is rather simple, here is a simple example --- of a drawing and saving it in a PNG file: --- --- > import Codec.Picture( PixelRGBA8( .. ), writePng ) --- > import Graphics.Rasterific --- > import Graphics.Rasterific.Texture --- > --- > main :: IO () --- > main = do --- > let white = PixelRGBA8 255 255 255 255 --- > drawColor = PixelRGBA8 0 0x86 0xc1 255 --- > recColor = PixelRGBA8 0xFF 0x53 0x73 255 --- > img = renderDrawing 400 200 white $ --- > withTexture (uniformTexture drawColor) $ do --- > fill $ circle (V2 0 0) 30 --- > stroke 4 JoinRound (CapRound, CapRound) $ --- > circle (V2 400 200) 40 --- > withTexture (uniformTexture recColor) . --- > fill $ rectangle (V2 100 100) 200 100 --- > --- > writePng "yourimage.png" img --- --- <> --- --- The coordinate system is the picture classic one, with the origin in --- the upper left corner; with the y axis growing to the bottom and the --- x axis growing to the right: --- --- <> --- -module Graphics.Rasterific - ( - -- * Rasterization command - -- ** Filling - fill - , fillWithMethod - , renderMeshPatch - -- ** Stroking - , stroke - , dashedStroke - , dashedStrokeWithOffset - -- ** Text rendering - , printTextAt - , printTextRanges - -- ** Texturing - , withTexture - , withClipping - , withGroupOpacity - -- ** Transformations - , withTransformation - , withPathOrientation - , TextRange( .. ) - , PointSize( .. ) - - -- * Generating images - , ModulablePixel - , RenderablePixel - , renderDrawing - , renderDrawingAtDpi - , renderDrawingAtDpiToPDF - , renderOrdersAtDpiToPdf - , pathToPrimitives - - -- * Rasterization types - , Texture - , Drawing - , Modulable - - -- * Geometry description - , V2( .. ) - , Point - , Vector - , CubicBezier( .. ) - , Line( .. ) - , Bezier( .. ) - , Primitive( .. ) - , Path( .. ) - , PathCommand( .. ) - - -- * Generic geometry description - , Primitivable( .. ) - , Geometry( .. ) - - -- * Generic geometry manipulation - , Transformable( .. ) - , PointFoldable( .. ) - , PlaneBoundable( .. ) - , PlaneBound( .. ) - , boundWidth - , boundHeight - , boundLowerLeftCorner - - -- * Helpers - -- ** line - , line - -- ** Rectangle - , rectangle - , roundedRectangle - -- ** Circles - , circle - , ellipse - -- ** Polygons - , polyline - , polygon - -- ** Images - , drawImageAtSize - , drawImage - , cacheDrawing - - -- ** Geometry Helpers - , clip - , bezierFromPath - , lineFromPath - , cubicBezierFromPath - , firstTangeantOf - , lastTangeantOf - , firstPointOf - , lastPointOf - - -- * Rasterization control - , Join( .. ) - , Cap( .. ) - , SamplerRepeat( .. ) - , FillMethod( .. ) - , PatchInterpolation( .. ) - , DashPattern - , drawOrdersOfDrawing - - -- * Debugging helper - , dumpDrawing - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -import Data.Foldable( foldMap ) -import Data.Monoid( Monoid( .. ) ) -#endif - -import Data.Monoid( (<>) ) - -import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.Free.Church( fromF ) -import Control.Monad.ST( ST, runST ) -import Control.Monad.State( modify, execState ) -import Data.Maybe( fromMaybe ) -import Codec.Picture.Types( Image( .. ) - , Pixel( .. ) - , PixelRGBA8 - , pixelMapXY ) - -import qualified Data.ByteString.Lazy as LB -import qualified Data.Vector as V - -import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^) ) -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.MicroPdf -{-import Graphics.Rasterific.Texture-} -import Graphics.Rasterific.ComplexPrimitive -import Graphics.Rasterific.Types -import Graphics.Rasterific.Line -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.StrokeInternal -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.PlaneBoundable -import Graphics.Rasterific.Immediate -import Graphics.Rasterific.PathWalker -import Graphics.Rasterific.Command -import Graphics.Rasterific.PatchTypes -import Graphics.Rasterific.Patch -import Graphics.Rasterific.MeshPatch -{-import Graphics.Rasterific.TensorPatch-} - -import Graphics.Text.TrueType( Font - , Dpi - , PointSize( .. ) - ) - -{-import Debug.Trace-} -{-import Text.Printf-} - ------------------------------------------------- ----- Free Monad DSL section ------------------------------------------------- - --- | Define the texture applyied to all the children --- draw call. --- --- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ do --- > fill $ circle (V2 50 50) 20 --- > fill $ circle (V2 100 100) 20 --- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) --- > $ circle (V2 150 150) 20 --- --- <> --- -withTexture :: Texture px -> Drawing px () -> Drawing px () -withTexture texture subActions = - liftF $ SetTexture texture subActions () - --- | Will render the whole subaction with a given group opacity, after --- each element has been rendered. That means that completly opaque --- overlapping shapes will be rendered transparently, not one after --- another. --- --- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ --- > stroke 3 JoinRound (CapRound, CapRound) $ --- > line (V2 0 100) (V2 200 100) --- > --- > withGroupOpacity 128 $ do --- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) . --- > fill $ circle (V2 70 100) 60 --- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255) . --- > fill $ circle (V2 120 100) 60 --- --- <> --- --- To be compared to the item opacity --- --- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ --- > stroke 3 JoinRound (CapRound, CapRound) $ --- > line (V2 0 100) (V2 200 100) --- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) . --- > fill $ circle (V2 70 100) 60 --- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) . --- > fill $ circle (V2 120 100) 60 --- --- <> -withGroupOpacity :: PixelBaseComponent px -> Drawing px ()-> Drawing px () -withGroupOpacity opa sub = liftF $ WithGlobalOpacity opa sub () - --- | Draw all the sub drawing commands using a transformation. -withTransformation :: Transformation -> Drawing px () -> Drawing px () -withTransformation trans sub = - liftF $ WithTransform trans sub () - --- | This command allows you to draw primitives on a given curve, --- for example, you can draw text on a curve: --- --- > let path = Path (V2 100 180) False --- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in --- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path --- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > withPathOrientation path 0 $ --- > printTextAt font (PointSize 24) (V2 0 0) "Text on path" --- --- <> --- --- You can note that the position of the baseline match the size of the --- characters. --- --- You are not limited to text drawing while using this function, --- you can draw arbitrary geometry like in the following example: --- --- > let path = Path (V2 100 180) False --- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] --- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path --- > --- > withPathOrientation path 0 $ do --- > printTextAt font (PointSize 24) (V2 0 0) "TX" --- > fill $ rectangle (V2 (-10) (-10)) 30 20 --- > fill $ rectangle (V2 45 0) 10 20 --- > fill $ rectangle (V2 60 (-10)) 20 20 --- > fill $ rectangle (V2 100 (-15)) 20 50 --- --- <> --- -withPathOrientation :: Path -- ^ Path directing the orientation. - -> Float -- ^ Basline Y axis position, used to align text properly. - -> Drawing px () -- ^ The sub drawings. - -> Drawing px () -withPathOrientation path p sub = - liftF $ WithPathOrientation path p sub () - --- | Fill some geometry. The geometry should be "looping", --- ie. the last point of the last primitive should --- be equal to the first point of the first primitive. --- --- The primitive should be connected. --- --- > fill $ circle (V2 100 100) 75 --- --- <> --- -fill :: Geometry geom => geom -> Drawing px () -fill prims = liftF $ Fill FillWinding (toPrimitives prims) () - --- | This function let you choose how to fill the primitives --- in case of self intersection. See `FillMethod` documentation --- for more information. -fillWithMethod :: Geometry geom - => FillMethod -> geom -> Drawing px () -fillWithMethod method prims = - liftF $ Fill method (toPrimitives prims) () - --- | Draw some geometry using a clipping path. --- --- > withClipping (fill $ circle (V2 100 100) 75) $ --- > mapM_ (stroke 7 JoinRound (CapRound, CapRound)) --- > [line (V2 0 yf) (V2 200 (yf + 10)) --- > | y <- [5 :: Int, 17 .. 200] --- > , let yf = fromIntegral y ] --- --- <> --- -withClipping - :: (forall innerPixel. Drawing innerPixel ()) -- ^ The clipping path - -> Drawing px () -- ^ The actual geometry to clip - -> Drawing px () -withClipping clipPath drawing = - liftF $ WithCliping clipPath drawing () - --- | Will stroke geometry with a given stroke width. --- The elements should be connected --- --- > stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 --- --- <> --- -stroke :: (Geometry geom) - => Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ List of elements to render - -> Drawing px () -stroke width join caping prims = - liftF $ Stroke width join caping (toPrimitives prims) () - --- | Draw a string at a given position. --- Text printing imply loading a font, there is no default --- font (yet). Below an example of font rendering using a --- font installed on Microsoft Windows. --- --- > import Graphics.Text.TrueType( loadFontFile ) --- > import Codec.Picture( PixelRGBA8( .. ), writePng ) --- > import Graphics.Rasterific --- > import Graphics.Rasterific.Texture --- > --- > main :: IO () --- > main = do --- > fontErr <- loadFontFile "test_fonts/DejaVuSans.ttf" --- > case fontErr of --- > Left err -> putStrLn err --- > Right font -> --- > writePng "text_example.png" . --- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) --- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > printTextAt font (PointSize 12) (V2 20 40) --- > "A simple text test!" --- --- <> --- --- You can use any texture, like a gradient while rendering text. --- -printTextAt :: Font -- ^ Drawing font - -> PointSize -- ^ font Point size - -> Point -- ^ Drawing starting point (base line) - -> String -- ^ String to print - -> Drawing px () -printTextAt font pointSize point string = - liftF $ TextFill point [description] () - where - description = TextRange - { _textFont = font - , _textSize = pointSize - , _text = string - , _textTexture = Nothing - } - --- | Render a mesh patch as an object. Warning, there is --- no antialiasing on mesh patch objects! -renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px () -renderMeshPatch i mesh = liftF $ MeshPatchRender i mesh () - --- | Print complex text, using different texture font and --- point size for different parts of the text. --- --- > let blackTexture = --- > Just . uniformTexture $ PixelRGBA8 0 0 0 255 --- > redTexture = --- > Just . uniformTexture $ PixelRGBA8 255 0 0 255 --- > in --- > printTextRanges (V2 20 40) --- > [ TextRange font1 (PointSize 12) "A complex " blackTexture --- > , TextRange font2 (PointSize 8) "text test" redTexture] --- --- <> --- -printTextRanges :: Point -- ^ Starting point of the base line - -> [TextRange px] -- ^ Ranges description to be printed - -> Drawing px () -printTextRanges point ranges = liftF $ TextFill point ranges () - -data RenderContext px = RenderContext - { currentClip :: Maybe (Texture (PixelBaseComponent px)) - , currentTexture :: Texture px - , currentTransformation :: Maybe (Transformation, Transformation) - } - --- | Function to call in order to start the image creation. --- Tested pixels type are PixelRGBA8 and Pixel8, pixel types --- in other colorspace will probably produce weird results. --- Default DPI is 96 -renderDrawing - :: forall px . (RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> Image px -renderDrawing width height = renderDrawingAtDpi width height 96 - -renderOrdersAtDpiToPdf - :: Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> Dpi -- ^ Current DPI used for text rendering. - -> [DrawOrder PixelRGBA8] -- ^ Drawing Orders - -> LB.ByteString -renderOrdersAtDpiToPdf w h dpi = - renderOrdersToPdf renderer w h dpi - where - renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px] - renderer = drawOrdersOfDrawing w h dpi emptyPx - -renderDrawingAtDpiToPDF - :: Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> Dpi -- ^ Current DPI used for text rendering. - -> Drawing PixelRGBA8 () -- ^ Rendering action - -> LB.ByteString -renderDrawingAtDpiToPDF w h dpi = - renderDrawingToPdf renderer w h dpi - where - renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px] - renderer = drawOrdersOfDrawing w h dpi emptyPx - --- | Function to call in order to start the image creation. --- Tested pixels type are PixelRGBA8 and Pixel8, pixel types --- in other colorspace will probably produce weird results. -renderDrawingAtDpi - :: forall px . (RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> Dpi -- ^ Current DPI used for text rendering. - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> Image px -renderDrawingAtDpi width height dpi background drawing = - runST $ runDrawContext width height background - $ mapM_ fillOrder - $ drawOrdersOfDrawing width height dpi background drawing - -cacheOrders :: forall px. (RenderablePixel px) - => Maybe (Image px -> ImageTransformer px) -> [DrawOrder px] -> Drawing px () -cacheOrders imageFilter orders = case imageFilter of - Nothing -> drawImage resultImage 0 cornerUpperLeft - Just f -> drawImage (pixelMapXY (f resultImage) resultImage) 0 cornerUpperLeft - where - PlaneBound mini maxi = foldMap planeBounds orders - cornerUpperLeftInt = floor <$> mini :: V2 Int - cornerUpperLeft = fromIntegral <$> cornerUpperLeftInt - - V2 width height = maxi ^-^ cornerUpperLeft ^+^ V2 1 1 - - shiftOrder order@DrawOrder { _orderPrimitives = prims } = - order { _orderPrimitives = fmap (transform (^-^ cornerUpperLeft)) <$> prims - , _orderTexture = - WithTextureTransform (translate cornerUpperLeft) $ _orderTexture order - } - - resultImage = - runST $ runDrawContext (ceiling width) (ceiling height) emptyPx - $ mapM_ (fillOrder . shiftOrder) orders - --- | This function perform an optimisation, it will render a drawing --- to an image interanlly and create a new order to render this image --- instead of the geometry, effectively cuting the geometry generation --- part. --- --- It can save execution time when drawing complex elements multiple --- times. -cacheDrawing - :: forall px . (RenderablePixel px) - => Int -- ^ Max rendering width - -> Int -- ^ Max rendering height - -> Dpi - -> Drawing px () - -> Drawing px () -cacheDrawing maxWidth maxHeight dpi sub = - cacheOrders Nothing $ drawOrdersOfDrawing maxWidth maxHeight dpi emptyPx sub - -preComputeTexture :: (RenderablePixel px) - => Int -> Int -> Texture px -> Texture px -preComputeTexture w h = go where - go :: RenderablePixel px => Texture px -> Texture px - go t = case t of - SolidTexture _ -> t - LinearGradientTexture _ _ -> t - RadialGradientTexture _ _ _ -> t - RadialGradientWithFocusTexture _ _ _ _ -> t - WithSampler s sub -> WithSampler s $ go sub - WithTextureTransform trans sub -> WithTextureTransform trans $ go sub - SampledTexture _ -> t - RawTexture _ -> t - ShaderTexture _ -> t - ModulateTexture t1 t2 -> ModulateTexture (go t1) (go t2) - PatternTexture _ _ _ _ _ -> t - AlphaModulateTexture i m -> AlphaModulateTexture (go i) (go m) - MeshPatchTexture i m -> - RawTexture $ renderDrawing w h emptyPx $ renderMeshPatch i m - --- | Transform a drawing into a serie of low-level drawing orders. -drawOrdersOfDrawing - :: forall px . (RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> Dpi -- ^ Current assumed DPI - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> [DrawOrder px] -drawOrdersOfDrawing width height dpi background drawing = - go initialContext (fromF drawing) [] - where - initialContext = RenderContext Nothing stupidDefaultTexture Nothing - clipBackground = emptyValue :: PixelBaseComponent px - clipForeground = fullValue :: PixelBaseComponent px - - clipRender = - 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 - - geometryOf :: Transformable a => RenderContext px -> a -> a - geometryOf RenderContext { currentTransformation = Just (trans, _) } = - transform (applyTransformation trans) - geometryOf _ = id - - geometryOfO RenderContext { currentTransformation = Just (trans, _) } = - transformOrder (applyTransformation trans) - geometryOfO _ = id - - stupidDefaultTexture = - SolidTexture $ colorMap (const clipBackground) background - - go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px] - -> [DrawOrder px] - go _ (Pure ()) rest = rest - go ctxt (Free (WithGlobalOpacity opa sub next)) rest = - go ctxt (Free (WithImageEffect opacifier sub next)) rest - where - -- Todo: a colorMapWithAlpha is really needed in JP API. - opacifier _ _ _ px = mixWithAlpha ignore alphaModulate px px - ignore _ _ a = a - alphaModulate _ v = opa `modulate` v - - go ctxt (Free (WithImageEffect effect sub next)) rest = - go freeContext (fromF cached) after - where - cached = cacheOrders (Just effect) $ go ctxt (fromF sub) [] - after = go ctxt next rest - freeContext = ctxt { currentClip = Nothing, currentTransformation = Nothing } - - - go ctxt (Free (WithPathOrientation path base sub next)) rest = final where - final = orders <> go ctxt next rest - images = go ctxt (fromF sub) [] - - drawer trans _ order = - modify (transformOrder (applyTransformation trans) order :) - - orders = reverse $ execState (drawOrdersOnPath drawer 0 base path images) [] - - go ctxt (Free (WithTransform trans sub next)) rest = final where - trans' - | Just (t, _) <- currentTransformation ctxt = t <> trans - | otherwise = trans - invTrans = fromMaybe mempty $ inverseTransformation trans' - after = go ctxt next rest - subContext = - ctxt { currentTransformation = Just (trans', invTrans) } - - final = go subContext (fromF sub) after - - go ctxt (Free (CustomRender cust next)) rest = order : after where - after = go ctxt next rest - order = DrawOrder - { _orderPrimitives = [] - , _orderTexture = textureOf ctxt - , _orderFillMethod = FillWinding - , _orderMask = currentClip ctxt - , _orderDirect = cust - } - - go ctxt (Free (MeshPatchRender i mesh next)) rest = order : after where - after = go ctxt next rest - rendering :: DrawContext (ST s) px () - rendering = case i of - PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf $ geometryOf ctxt opaqueMesh - PatchBicubic -> - mapM_ rasterizeCoonPatch - . cubicCoonPatchesOf - $ calculateMeshColorDerivative $ geometryOf ctxt opaqueMesh - - hasTransparency = - V.any ((/= fullValue) . pixelOpacity) $ _meshColors mesh - - opacifier px = mixWithAlpha (\_ _ a -> a) (\_ _ -> fullValue) px px - - opaqueMesh = opacifier <$> mesh - transparencyMesh = pixelOpacity <$> mesh - - clipPath - | not hasTransparency = currentClip ctxt - | otherwise = - let newMask :: Image (PixelBaseComponent (PixelBaseComponent px)) - newMask = clipRender $ 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 - { _orderPrimitives = [geometryOf ctxt prims] - , _orderTexture = textureOf ctxt - , _orderFillMethod = method - , _orderMask = currentClip ctxt - , _orderDirect = return () - } - - go ctxt (Free (Stroke w j cap prims next)) rest = - go ctxt (Free $ Fill FillWinding prim' next) rest - where prim' = listOfContainer $ strokize w j cap prims - - go ctxt (Free (SetTexture tx sub 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 - where - after = go ctxt next rest - recurse sub = - go ctxt (liftF $ Fill FillWinding sub ()) - - go ctxt (Free (TextFill p descriptions next)) rest = calls <> go ctxt next rest where - calls = - geometryOfO ctxt <$> textToDrawOrders dpi (currentTexture ctxt) p descriptions - - go ctxt (Free (WithCliping clipPath path next)) rest = - go (ctxt { currentClip = newModuler }) (fromF path) $ - go ctxt next rest - where - modulationTexture :: Texture (PixelBaseComponent px) - modulationTexture = RawTexture $ clipRender clipPath - - newModuler = Just . subModuler $ currentClip ctxt - - subModuler Nothing = modulationTexture - subModuler (Just v) = - ModulateTexture v modulationTexture - --- | With stroke geometry with a given stroke width, using --- a dash pattern. --- --- > dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ --- > line (V2 0 100) (V2 200 100) --- --- <> --- -dashedStroke - :: Geometry geom - => DashPattern -- ^ Dashing pattern to use for stroking - -> Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ List of elements to render - -> Drawing px () -dashedStroke = dashedStrokeWithOffset 0.0 - --- | With stroke geometry with a given stroke width, using --- a dash pattern. The offset is there to specify the starting --- point into the pattern, the value can be negative. --- --- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ --- > line (V2 0 100) (V2 200 100) --- --- <> --- -dashedStrokeWithOffset - :: Geometry geom - => Float -- ^ Starting offset - -> DashPattern -- ^ Dashing pattern to use for stroking - -> Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ List of elements to render - -> Drawing px () -dashedStrokeWithOffset _ [] width join caping prims = - stroke width join caping prims -dashedStrokeWithOffset offset dashing width join caping prims = - liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) () - --- | Generate a strokable line out of points list. --- Just an helper around `lineFromPath`. --- --- > stroke 4 JoinRound (CapRound, CapRound) $ --- > polyline [V2 10 10, V2 100 70, V2 190 190] --- --- <> --- -polyline :: [Point] -> [Primitive] -polyline = map LinePrim . lineFromPath - --- | Generate a fillable polygon out of points list. --- Similar to the `polyline` function, but close the --- path. --- --- > fill $ polygon [V2 30 30, V2 100 70, V2 80 170] --- --- <> --- -polygon :: [Point] -> [Primitive] -polygon [] = [] -polygon [_] = [] -polygon [_,_] = [] -polygon lst@(p:_) = polyline $ lst ++ [p] - --- | Simply draw an image into the canvas. Take into account --- any previous transformation performed on the geometry. --- --- > drawImage textureImage 0 (V2 30 30) --- --- <> --- -drawImage :: Image px -- ^ Image to be drawn - -> StrokeWidth -- ^ Border size, drawn with current texture. - -> Point -- ^ Position of the corner upper left of the image. - -> Drawing px () -drawImage img@Image { imageWidth = w, imageHeight = h } s p = - drawImageAtSize img s p (fromIntegral w) (fromIntegral h) - --- | Draw an image with the desired size --- --- > drawImageAtSize textureImage 2 (V2 30 30) 128 128 --- --- <> --- -drawImageAtSize :: Image px -- ^ Image to be drawn - -> StrokeWidth -- ^ Border size, drawn with current texture. - -> Point -- ^ Position of the corner upper left of the image. - -> Float -- ^ Width of the drawn image - -> Float -- ^ Height of the drawn image - -> Drawing px () -drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip - reqWidth reqHeight - | borderSize <= 0 = - withTransformation (translate p <> scale scaleX scaleY) . - withTexture (SampledTexture img) $ fill rect - | otherwise = do - withTransformation (translate p <> scale scaleX scaleY) $ - withTexture (SampledTexture img) $ fill rect - stroke (borderSize / 2) (JoinMiter 0) - (CapStraight 0, CapStraight 0) rect' - where - p = ip ^-^ V2 0.5 0.5 - rect = rectangle (V2 0 0) rw rh - rect' = rectangle p reqWidth reqHeight - - (rw, rh) = (fromIntegral w, fromIntegral h) - scaleX | reqWidth == 0 = 1 - | otherwise = reqWidth / rw - - scaleY | reqHeight == 0 = 1 - | otherwise = reqHeight / rh - --- | Return a simple line ready to be stroked. --- --- > stroke 17 JoinRound (CapRound, CapRound) $ --- > line (V2 10 10) (V2 180 170) --- --- <> --- -line :: Point -> Point -> [Primitive] -line p1 p2 = [LinePrim $ Line p1 p2] - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} + +-- | Main module of Rasterific, an Haskell rasterization engine. +-- +-- Creating an image is rather simple, here is a simple example +-- of a drawing and saving it in a PNG file: +-- +-- > import Codec.Picture( PixelRGBA8( .. ), writePng ) +-- > import Graphics.Rasterific +-- > import Graphics.Rasterific.Texture +-- > +-- > main :: IO () +-- > main = do +-- > let white = PixelRGBA8 255 255 255 255 +-- > drawColor = PixelRGBA8 0 0x86 0xc1 255 +-- > recColor = PixelRGBA8 0xFF 0x53 0x73 255 +-- > img = renderDrawing 400 200 white $ +-- > withTexture (uniformTexture drawColor) $ do +-- > fill $ circle (V2 0 0) 30 +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > circle (V2 400 200) 40 +-- > withTexture (uniformTexture recColor) . +-- > fill $ rectangle (V2 100 100) 200 100 +-- > +-- > writePng "yourimage.png" img +-- +-- <> +-- +-- The coordinate system is the picture classic one, with the origin in +-- the upper left corner; with the y axis growing to the bottom and the +-- x axis growing to the right: +-- +-- <> +-- +module Graphics.Rasterific + ( + -- * Rasterization command + -- ** Filling + fill + , fillWithMethod + , renderMeshPatch + -- ** Stroking + , stroke + , dashedStroke + , dashedStrokeWithOffset + -- ** Text rendering + , printTextAt + , printTextRanges + -- ** Texturing + , withTexture + , withClipping + , withGroupOpacity + -- ** Transformations + , withTransformation + , withPathOrientation + , TextRange( .. ) + , PointSize( .. ) + + -- * Generating images + , ModulablePixel + , RenderablePixel + , renderDrawing + , renderDrawingAtDpi + , renderDrawingAtDpiToPDF + , renderOrdersAtDpiToPdf + , pathToPrimitives + + -- * Rasterization types + , Texture + , Drawing + , Modulable + + -- * Geometry description + , V2( .. ) + , Point + , Vector + , CubicBezier( .. ) + , Line( .. ) + , Bezier( .. ) + , Primitive( .. ) + , Path( .. ) + , PathCommand( .. ) + + -- * Generic geometry description + , Primitivable( .. ) + , Geometry( .. ) + + -- * Generic geometry manipulation + , Transformable( .. ) + , PointFoldable( .. ) + , PlaneBoundable( .. ) + , PlaneBound( .. ) + , boundWidth + , boundHeight + , boundLowerLeftCorner + + -- * Helpers + -- ** line + , line + -- ** Rectangle + , rectangle + , roundedRectangle + -- ** Circles + , circle + , ellipse + -- ** Polygons + , polyline + , polygon + -- ** Images + , drawImageAtSize + , drawImage + , cacheDrawing + + -- ** Geometry Helpers + , clip + , bezierFromPath + , lineFromPath + , cubicBezierFromPath + , firstTangeantOf + , lastTangeantOf + , firstPointOf + , lastPointOf + + -- *** Arc traduction + , Direction( .. ) + , arcInDirection + + -- * Rasterization control + , Join( .. ) + , Cap( .. ) + , SamplerRepeat( .. ) + , FillMethod( .. ) + , PatchInterpolation( .. ) + , DashPattern + , drawOrdersOfDrawing + + -- * Debugging helper + , dumpDrawing + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +import Data.Foldable( foldMap ) +import Data.Monoid( Monoid( .. ) ) +#endif + +import Data.Monoid( (<>) ) + +import Control.Monad.Free( Free( .. ), liftF ) +import Control.Monad.Free.Church( fromF ) +import Control.Monad.ST( ST, runST ) +import Control.Monad.State( modify, execState ) +import Data.Maybe( fromMaybe ) +import Codec.Picture.Types( Image( .. ) + , Pixel( .. ) + , PixelRGBA8 + , pixelMapXY ) + +import qualified Data.ByteString.Lazy as LB +import qualified Data.Vector as V + +import Graphics.Rasterific.Compositor +import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^) ) +import Graphics.Rasterific.Rasterize +import Graphics.Rasterific.MicroPdf +{-import Graphics.Rasterific.Texture-} +import Graphics.Rasterific.ComplexPrimitive +import Graphics.Rasterific.Types +import Graphics.Rasterific.Line +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.StrokeInternal +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.PlaneBoundable +import Graphics.Rasterific.Immediate +import Graphics.Rasterific.PathWalker +import Graphics.Rasterific.Arc +import Graphics.Rasterific.Command +import Graphics.Rasterific.PatchTypes +import Graphics.Rasterific.Patch +import Graphics.Rasterific.MeshPatch +{-import Graphics.Rasterific.TensorPatch-} + +import Graphics.Text.TrueType( Font + , Dpi + , PointSize( .. ) + ) + +{-import Debug.Trace-} +{-import Text.Printf-} + +------------------------------------------------ +---- Free Monad DSL section +------------------------------------------------ + +-- | Define the texture applyied to all the children +-- draw call. +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ do +-- > fill $ circle (V2 50 50) 20 +-- > fill $ circle (V2 100 100) 20 +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) +-- > $ circle (V2 150 150) 20 +-- +-- <> +-- +withTexture :: Texture px -> Drawing px () -> Drawing px () +withTexture texture subActions = + liftF $ SetTexture texture subActions () + +-- | Will render the whole subaction with a given group opacity, after +-- each element has been rendered. That means that completly opaque +-- overlapping shapes will be rendered transparently, not one after +-- another. +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ +-- > stroke 3 JoinRound (CapRound, CapRound) $ +-- > line (V2 0 100) (V2 200 100) +-- > +-- > withGroupOpacity 128 $ do +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) . +-- > fill $ circle (V2 70 100) 60 +-- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255) . +-- > fill $ circle (V2 120 100) 60 +-- +-- <> +-- +-- To be compared to the item opacity +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ +-- > stroke 3 JoinRound (CapRound, CapRound) $ +-- > line (V2 0 100) (V2 200 100) +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) . +-- > fill $ circle (V2 70 100) 60 +-- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) . +-- > fill $ circle (V2 120 100) 60 +-- +-- <> +withGroupOpacity :: PixelBaseComponent px -> Drawing px ()-> Drawing px () +withGroupOpacity opa sub = liftF $ WithGlobalOpacity opa sub () + +-- | Draw all the sub drawing commands using a transformation. +withTransformation :: Transformation -> Drawing px () -> Drawing px () +withTransformation trans sub = + liftF $ WithTransform trans sub () + +-- | This command allows you to draw primitives on a given curve, +-- for example, you can draw text on a curve: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > withPathOrientation path 0 $ +-- > printTextAt font (PointSize 24) (V2 0 0) "Text on path" +-- +-- <> +-- +-- You can note that the position of the baseline match the size of the +-- characters. +-- +-- You are not limited to text drawing while using this function, +-- you can draw arbitrary geometry like in the following example: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path +-- > +-- > withPathOrientation path 0 $ do +-- > printTextAt font (PointSize 24) (V2 0 0) "TX" +-- > fill $ rectangle (V2 (-10) (-10)) 30 20 +-- > fill $ rectangle (V2 45 0) 10 20 +-- > fill $ rectangle (V2 60 (-10)) 20 20 +-- > fill $ rectangle (V2 100 (-15)) 20 50 +-- +-- <> +-- +withPathOrientation :: Path -- ^ Path directing the orientation. + -> Float -- ^ Basline Y axis position, used to align text properly. + -> Drawing px () -- ^ The sub drawings. + -> Drawing px () +withPathOrientation path p sub = + liftF $ WithPathOrientation path p sub () + +-- | Fill some geometry. The geometry should be "looping", +-- ie. the last point of the last primitive should +-- be equal to the first point of the first primitive. +-- +-- The primitive should be connected. +-- +-- > fill $ circle (V2 100 100) 75 +-- +-- <> +-- +fill :: Geometry geom => geom -> Drawing px () +fill prims = liftF $ Fill FillWinding (toPrimitives prims) () + +-- | This function let you choose how to fill the primitives +-- in case of self intersection. See `FillMethod` documentation +-- for more information. +fillWithMethod :: Geometry geom + => FillMethod -> geom -> Drawing px () +fillWithMethod method prims = + liftF $ Fill method (toPrimitives prims) () + +-- | Draw some geometry using a clipping path. +-- +-- > withClipping (fill $ circle (V2 100 100) 75) $ +-- > mapM_ (stroke 7 JoinRound (CapRound, CapRound)) +-- > [line (V2 0 yf) (V2 200 (yf + 10)) +-- > | y <- [5 :: Int, 17 .. 200] +-- > , let yf = fromIntegral y ] +-- +-- <> +-- +withClipping + :: (forall innerPixel. Drawing innerPixel ()) -- ^ The clipping path + -> Drawing px () -- ^ The actual geometry to clip + -> Drawing px () +withClipping clipPath drawing = + liftF $ WithCliping clipPath drawing () + +-- | Will stroke geometry with a given stroke width. +-- The elements should be connected +-- +-- > stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 +-- +-- <> +-- +stroke :: (Geometry geom) + => Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +stroke width join caping prims = + liftF $ Stroke width join caping (toPrimitives prims) () + +-- | Draw a string at a given position. +-- Text printing imply loading a font, there is no default +-- font (yet). Below an example of font rendering using a +-- font installed on Microsoft Windows. +-- +-- > import Graphics.Text.TrueType( loadFontFile ) +-- > import Codec.Picture( PixelRGBA8( .. ), writePng ) +-- > import Graphics.Rasterific +-- > import Graphics.Rasterific.Texture +-- > +-- > main :: IO () +-- > main = do +-- > fontErr <- loadFontFile "test_fonts/DejaVuSans.ttf" +-- > case fontErr of +-- > Left err -> putStrLn err +-- > Right font -> +-- > writePng "text_example.png" . +-- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) +-- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > printTextAt font (PointSize 12) (V2 20 40) +-- > "A simple text test!" +-- +-- <> +-- +-- You can use any texture, like a gradient while rendering text. +-- +printTextAt :: Font -- ^ Drawing font + -> PointSize -- ^ font Point size + -> Point -- ^ Drawing starting point (base line) + -> String -- ^ String to print + -> Drawing px () +printTextAt font pointSize point string = + liftF $ TextFill point [description] () + where + description = TextRange + { _textFont = font + , _textSize = pointSize + , _text = string + , _textTexture = Nothing + } + +-- | Render a mesh patch as an object. Warning, there is +-- no antialiasing on mesh patch objects! +renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px () +renderMeshPatch i mesh = liftF $ MeshPatchRender i mesh () + +-- | Print complex text, using different texture font and +-- point size for different parts of the text. +-- +-- > let blackTexture = +-- > Just . uniformTexture $ PixelRGBA8 0 0 0 255 +-- > redTexture = +-- > Just . uniformTexture $ PixelRGBA8 255 0 0 255 +-- > in +-- > printTextRanges (V2 20 40) +-- > [ TextRange font1 (PointSize 12) "A complex " blackTexture +-- > , TextRange font2 (PointSize 8) "text test" redTexture] +-- +-- <> +-- +printTextRanges :: Point -- ^ Starting point of the base line + -> [TextRange px] -- ^ Ranges description to be printed + -> Drawing px () +printTextRanges point ranges = liftF $ TextFill point ranges () + +data RenderContext px = RenderContext + { currentClip :: Maybe (Texture (PixelBaseComponent px)) + , currentTexture :: Texture px + , currentTransformation :: Maybe (Transformation, Transformation) + } + +-- | Function to call in order to start the image creation. +-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types +-- in other colorspace will probably produce weird results. +-- Default DPI is 96 +renderDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> Image px +renderDrawing width height = renderDrawingAtDpi width height 96 + +renderOrdersAtDpiToPdf + :: Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> [DrawOrder PixelRGBA8] -- ^ Drawing Orders + -> LB.ByteString +renderOrdersAtDpiToPdf w h dpi = + renderOrdersToPdf renderer w h dpi + where + renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px] + renderer = drawOrdersOfDrawing w h dpi emptyPx + +renderDrawingAtDpiToPDF + :: Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> Drawing PixelRGBA8 () -- ^ Rendering action + -> LB.ByteString +renderDrawingAtDpiToPDF w h dpi = + renderDrawingToPdf renderer w h dpi + where + renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px] + renderer = drawOrdersOfDrawing w h dpi emptyPx + +-- | Function to call in order to start the image creation. +-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types +-- in other colorspace will probably produce weird results. +renderDrawingAtDpi + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> Image px +renderDrawingAtDpi width height dpi background drawing = + runST $ runDrawContext width height background + $ mapM_ fillOrder + $ drawOrdersOfDrawing width height dpi background drawing + +cacheOrders :: forall px. (RenderablePixel px) + => Maybe (Image px -> ImageTransformer px) -> [DrawOrder px] -> Drawing px () +cacheOrders imageFilter orders = case imageFilter of + Nothing -> drawImage resultImage 0 cornerUpperLeft + Just f -> drawImage (pixelMapXY (f resultImage) resultImage) 0 cornerUpperLeft + where + PlaneBound mini maxi = foldMap planeBounds orders + cornerUpperLeftInt = floor <$> mini :: V2 Int + cornerUpperLeft = fromIntegral <$> cornerUpperLeftInt + + V2 width height = maxi ^-^ cornerUpperLeft ^+^ V2 1 1 + + shiftOrder order@DrawOrder { _orderPrimitives = prims } = + order { _orderPrimitives = fmap (transform (^-^ cornerUpperLeft)) <$> prims + , _orderTexture = + WithTextureTransform (translate cornerUpperLeft) $ _orderTexture order + } + + resultImage = + runST $ runDrawContext (ceiling width) (ceiling height) emptyPx + $ mapM_ (fillOrder . shiftOrder) orders + +-- | This function perform an optimisation, it will render a drawing +-- to an image interanlly and create a new order to render this image +-- instead of the geometry, effectively cuting the geometry generation +-- part. +-- +-- It can save execution time when drawing complex elements multiple +-- times. +cacheDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Max rendering width + -> Int -- ^ Max rendering height + -> Dpi + -> Drawing px () + -> Drawing px () +cacheDrawing maxWidth maxHeight dpi sub = + cacheOrders Nothing $ drawOrdersOfDrawing maxWidth maxHeight dpi emptyPx sub + +preComputeTexture :: (RenderablePixel px) + => Int -> Int -> Texture px -> Texture px +preComputeTexture w h = go where + go :: RenderablePixel px => Texture px -> Texture px + go t = case t of + SolidTexture _ -> t + LinearGradientTexture _ _ -> t + RadialGradientTexture _ _ _ -> t + RadialGradientWithFocusTexture _ _ _ _ -> t + WithSampler s sub -> WithSampler s $ go sub + WithTextureTransform trans sub -> WithTextureTransform trans $ go sub + SampledTexture _ -> t + RawTexture _ -> t + ShaderTexture _ -> t + ModulateTexture t1 t2 -> ModulateTexture (go t1) (go t2) + PatternTexture _ _ _ _ _ -> t + AlphaModulateTexture i m -> AlphaModulateTexture (go i) (go m) + MeshPatchTexture i m -> + RawTexture $ renderDrawing w h emptyPx $ renderMeshPatch i m + +-- | Transform a drawing into a serie of low-level drawing orders. +drawOrdersOfDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current assumed DPI + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> [DrawOrder px] +drawOrdersOfDrawing width height dpi background drawing = + go initialContext (fromF drawing) [] + where + initialContext = RenderContext Nothing stupidDefaultTexture Nothing + clipBackground = emptyValue :: PixelBaseComponent px + clipForeground = fullValue :: PixelBaseComponent px + + clipRender ctxt = + renderDrawing width height clipBackground . + transformer . + withTexture (SolidTexture clipForeground) + where + transformer = maybe id (withTransformation . fst) $ currentTransformation ctxt + + + subRender :: (forall s. DrawContext (ST s) px ()) -> Image px + subRender act = + runST $ runDrawContext width height background act + + textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } = + WithTextureTransform t $ currentTexture ctxt + textureOf ctxt = currentTexture ctxt + + geometryOf :: Transformable a => RenderContext px -> a -> a + geometryOf RenderContext { currentTransformation = Just (trans, _) } = + transform (applyTransformation trans) + geometryOf _ = id + + geometryOfO RenderContext { currentTransformation = Just (trans, _) } = + transformOrder (applyTransformation trans) + geometryOfO _ = id + + stupidDefaultTexture = + SolidTexture $ colorMap (const clipBackground) background + + go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px] + -> [DrawOrder px] + go _ (Pure ()) rest = rest + go ctxt (Free (WithGlobalOpacity opa sub next)) rest = + go ctxt (Free (WithImageEffect opacifier sub next)) rest + where + -- Todo: a colorMapWithAlpha is really needed in JP API. + opacifier _ _ _ px = mixWithAlpha ignore alphaModulate px px + ignore _ _ a = a + alphaModulate _ v = opa `modulate` v + + go ctxt (Free (WithImageEffect effect sub next)) rest = + go freeContext (fromF cached) after + where + cached = cacheOrders (Just effect) $ go ctxt (fromF sub) [] + after = go ctxt next rest + freeContext = ctxt { currentClip = Nothing, currentTransformation = Nothing } + + + go ctxt (Free (WithPathOrientation path base sub next)) rest = final where + final = orders <> go ctxt next rest + images = go ctxt (fromF sub) [] + + drawer trans _ order = + modify (transformOrder (applyTransformation trans) order :) + + orders = reverse $ execState (drawOrdersOnPath drawer 0 base path images) [] + + go ctxt (Free (WithTransform trans sub next)) rest = final where + trans' + | Just (t, _) <- currentTransformation ctxt = t <> trans + | otherwise = trans + invTrans = fromMaybe mempty $ inverseTransformation trans' + after = go ctxt next rest + subContext = + ctxt { currentTransformation = Just (trans', invTrans) } + + final = go subContext (fromF sub) after + + go ctxt (Free (CustomRender cust next)) rest = order : after where + after = go ctxt next rest + order = DrawOrder + { _orderPrimitives = [] + , _orderTexture = textureOf ctxt + , _orderFillMethod = FillWinding + , _orderMask = currentClip ctxt + , _orderDirect = cust + } + + go ctxt (Free (MeshPatchRender i mesh next)) rest = order : after where + after = go ctxt next rest + rendering :: DrawContext (ST s) px () + rendering = case i of + PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf $ geometryOf ctxt opaqueMesh + PatchBicubic -> + mapM_ rasterizeCoonPatch + . cubicCoonPatchesOf + $ calculateMeshColorDerivative $ geometryOf ctxt opaqueMesh + + hasTransparency = + V.any ((/= fullValue) . pixelOpacity) $ _meshColors mesh + + opacifier px = mixWithAlpha (\_ _ a -> a) (\_ _ -> fullValue) px px + + opaqueMesh = opacifier <$> mesh + transparencyMesh = pixelOpacity <$> mesh + + clipPath + | not hasTransparency = currentClip ctxt + | otherwise = + let newMask :: Image (PixelBaseComponent (PixelBaseComponent px)) + newMask = clipRender ctxt $ renderMeshPatch i transparencyMesh in + case currentClip ctxt of + Nothing -> Just $ RawTexture newMask + Just v -> Just $ ModulateTexture v (RawTexture newMask) + + order = case clipPath of + -- Good, we can directly render on the final canvas + Nothing -> DrawOrder + { _orderPrimitives = [] + , _orderTexture = textureOf ctxt + , _orderFillMethod = FillWinding + , _orderMask = clipPath + , _orderDirect = rendering + } + Just c -> DrawOrder + { _orderPrimitives = [geometryOf ctxt $ rectangle (V2 0 0) (fromIntegral width) (fromIntegral height)] + , _orderTexture = AlphaModulateTexture (RawTexture $ subRender rendering) c + , _orderFillMethod = FillWinding + , _orderMask = Nothing + , _orderDirect = return () + } + + go ctxt (Free (Fill method prims next)) rest = order : after where + after = go ctxt next rest + order = DrawOrder + { _orderPrimitives = [geometryOf ctxt prims] + , _orderTexture = textureOf ctxt + , _orderFillMethod = method + , _orderMask = currentClip ctxt + , _orderDirect = return () + } + + go ctxt (Free (Stroke w j cap prims next)) rest = + go ctxt (Free $ Fill FillWinding prim' next) rest + where prim' = listOfContainer $ strokize w j cap prims + + go ctxt (Free (SetTexture tx sub 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 + where + after = go ctxt next rest + recurse sub = + go ctxt (liftF $ Fill FillWinding sub ()) + + go ctxt (Free (TextFill p descriptions next)) rest = calls <> go ctxt next rest where + calls = + geometryOfO ctxt <$> textToDrawOrders dpi (currentTexture ctxt) p descriptions + + go ctxt (Free (WithCliping clipPath path next)) rest = + go (ctxt { currentClip = newModuler }) (fromF path) $ + go ctxt next rest + where + modulationTexture :: Texture (PixelBaseComponent px) + modulationTexture = RawTexture $ clipRender ctxt clipPath + + newModuler = Just . subModuler $ currentClip ctxt + + subModuler Nothing = modulationTexture + subModuler (Just v) = + ModulateTexture v modulationTexture + +-- | With stroke geometry with a given stroke width, using +-- a dash pattern. +-- +-- > dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ +-- > line (V2 0 100) (V2 200 100) +-- +-- <> +-- +dashedStroke + :: Geometry geom + => DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +dashedStroke = dashedStrokeWithOffset 0.0 + +-- | With stroke geometry with a given stroke width, using +-- a dash pattern. The offset is there to specify the starting +-- point into the pattern, the value can be negative. +-- +-- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ +-- > line (V2 0 100) (V2 200 100) +-- +-- <> +-- +dashedStrokeWithOffset + :: Geometry geom + => Float -- ^ Starting offset + -> DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +dashedStrokeWithOffset _ [] width join caping prims = + stroke width join caping prims +dashedStrokeWithOffset offset dashing width join caping prims = + liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) () + +-- | Generate a strokable line out of points list. +-- Just an helper around `lineFromPath`. +-- +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > polyline [V2 10 10, V2 100 70, V2 190 190] +-- +-- <> +-- +polyline :: [Point] -> [Primitive] +polyline = map LinePrim . lineFromPath + +-- | Generate a fillable polygon out of points list. +-- Similar to the `polyline` function, but close the +-- path. +-- +-- > fill $ polygon [V2 30 30, V2 100 70, V2 80 170] +-- +-- <> +-- +polygon :: [Point] -> [Primitive] +polygon [] = [] +polygon [_] = [] +polygon [_,_] = [] +polygon lst@(p:_) = polyline $ lst ++ [p] + +-- | Simply draw an image into the canvas. Take into account +-- any previous transformation performed on the geometry. +-- +-- > drawImage textureImage 0 (V2 30 30) +-- +-- <> +-- +drawImage :: Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Drawing px () +drawImage img@Image { imageWidth = w, imageHeight = h } s p = + drawImageAtSize img s p (fromIntegral w) (fromIntegral h) + +-- | Draw an image with the desired size +-- +-- > drawImageAtSize textureImage 2 (V2 30 30) 128 128 +-- +-- <> +-- +drawImageAtSize :: Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Float -- ^ Width of the drawn image + -> Float -- ^ Height of the drawn image + -> Drawing px () +drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip + reqWidth reqHeight + | borderSize <= 0 = + withTransformation (translate p <> scale scaleX scaleY) . + withTexture (SampledTexture img) $ fill rect + | otherwise = do + withTransformation (translate p <> scale scaleX scaleY) $ + withTexture (SampledTexture img) $ fill rect + stroke (borderSize / 2) (JoinMiter 0) + (CapStraight 0, CapStraight 0) rect' + where + p = ip ^-^ V2 0.5 0.5 + rect = rectangle (V2 0 0) rw rh + rect' = rectangle p reqWidth reqHeight + + (rw, rh) = (fromIntegral w, fromIntegral h) + scaleX | reqWidth == 0 = 1 + | otherwise = reqWidth / rw + + scaleY | reqHeight == 0 = 1 + | otherwise = reqHeight / rh + +-- | Return a simple line ready to be stroked. +-- +-- > stroke 17 JoinRound (CapRound, CapRound) $ +-- > line (V2 10 10) (V2 180 170) +-- +-- <> +-- +line :: Point -> Point -> [Primitive] +line p1 p2 = [LinePrim $ Line p1 p2] + diff --git a/src/Graphics/Rasterific/Arc.hs b/src/Graphics/Rasterific/Arc.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Arc.hs @@ -0,0 +1,170 @@ +-- | Translation of cairo-arc.c +module Graphics.Rasterific.Arc( Direction( .. ), arcInDirection ) where + +import Data.Maybe( fromMaybe ) +import Data.Monoid( (<>) ) +import qualified Data.Vector.Unboxed as VU + +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Linear +import Graphics.Rasterific.Types + + +errorTable :: VU.Vector (Float, Float) +errorTable = VU.imap calcAngle errors where + calcAngle i a = (pi / fromIntegral i, a) + errors = VU.fromListN 10 + [ 0.0185185185185185036127 + , 0.000272567143730179811158 + , 2.38647043651461047433e-05 + , 4.2455377443222443279e-06 + , 1.11281001494389081528e-06 + , 3.72662000942734705475e-07 + , 1.47783685574284411325e-07 + , 6.63240432022601149057e-08 + , 3.2715520137536980553e-08 + , 1.73863223499021216974e-08 + , 9.81410988043554039085e-09 ] + +{- Spline deviation from the circle in radius would be given by: + + error = sqrt (x**2 + y**2) - 1 + + A simpler error function to work with is: + + e = x**2 + y**2 - 1 + + From "Good approximation of circles by curvature-continuous Bezier + curves", Tor Dokken and Morten Daehlen, Computer Aided Geometric + Design 8 (1990) 22-41, we learn: + + abs (max(e)) = 4/27 * sin**6(angle/4) / cos**2(angle/4) + + and + abs (error) =~ 1/2 * e + + Of course, this error value applies only for the particular spline + approximation that is used in _cairo_gstate_arc_segment. -} +fixAngleError :: Int -> Float -> Float +fixAngleError i tolerance + | errorNormalized > tolerance = fixAngleError (i + 1) tolerance + | otherwise = angle + where + angle = pi / fromIntegral i + errorNormalized = 2.0/27.0 * (sin (angle / 4) ** 6) / (cos (angle / 4) ** 2) + +arcMaxAngleForToleranceNormalized :: Float -> Float +arcMaxAngleForToleranceNormalized tolerance = fixAngleError (angleIndex + 1) tolerance + where + angleIndex = fromMaybe + (VU.length errorTable) $ + VU.findIndex ((< tolerance) . snd) errorTable + +arcSegmentsNeeded :: Float -> Float -> Transformation -> Float + -> Int +arcSegmentsNeeded angle radius trans tolerance = ceiling (angle / maxAngle) where + -- the error is amplified by at most the length of the + -- major axis of the circle; see cairo-pen.c for a more detailed analysis + -- of this. + majorAxis = matrixTransformedCircleMajorAxis trans radius + maxAngle = arcMaxAngleForToleranceNormalized (tolerance / majorAxis) + +-- determine the length of the major axis of a circle of the given radius +-- after applying the transformation matrix. +matrixTransformedCircleMajorAxis :: Transformation -> Float -> Float +matrixTransformedCircleMajorAxis (Transformation a c _ + b d _) radius = + radius * sqrt (f + norm v) + where + i = a*a + b*b; + j = c*c + d*d; + + f = 0.5 * (i + j) + v = V2 (0.5 * (i - j)) (a * c + b * d) + -- we don't need the minor axis length, which is + -- double min = radius * sqrt (f - sqrt (g*g+h*h)); + +-- | Direction of the arc +data Direction = Forward | Backward + +clampAngle :: Float -> Float -> Float +clampAngle angleMin = go where + go angleMax + | angleMax - angleMin > 4 * pi = go $ angleMax - 2 * pi + | otherwise = angleMax + +subdivideAngles :: (Monoid m) + => Direction -> (Float -> Float -> m) -> Float -> Float -> m +subdivideAngles dir f aMin = go aMin . clampAngle aMin where + go angleMin angleMax | deltaAngle > pi = case dir of + Forward -> go angleMin angleMid <> go angleMid angleMax + Backward -> go angleMid angleMax <> go angleMin angleMid + where + deltaAngle = angleMax - angleMin + angleMid = angleMin + deltaAngle / 2 + go angleMin angleMax = f angleMin angleMax + + +{- We want to draw a single spline approximating a circular arc radius + R from angle A to angle B. Since we want a symmetric spline that + matches the endpoints of the arc in position and slope, we know + that the spline control points must be: + + (R * cos(A), R * sin(A)) + (R * cos(A) - h * sin(A), R * sin(A) + h * cos (A)) + (R * cos(B) + h * sin(B), R * sin(B) - h * cos (B)) + (R * cos(B), R * sin(B)) + + for some value of h. + + "Approximation of circular arcs by cubic poynomials", Michael + Goldapp, Computer Aided Geometric Design 8 (1991) 227-238, provides + various values of h along with error analysis for each. + + From that paper, a very practical value of h is: + + h = 4/3 * tan(angle/4) + + This value does not give the spline with minimal error, but it does + provide a very good approximation, (6th-order convergence), and the + error expression is quite simple, (see the comment for + _arc_error_normalized). +-} +arcSegment :: Point -> Float -> Float -> Float -> PathCommand +arcSegment (V2 xc yc) radius angleA angleB = PathCubicBezierCurveTo p1 p2 p3 where + rSinA = radius * sin angleA + rCosA = radius * cos angleA + rSinB = radius * sin angleB + rCosB = radius * cos angleB + + h = 4.0/3.0 * tan ((angleB - angleA) / 4.0) + + p1 = V2 (xc + rCosA - h * rSinA) (yc + rSinA + h * rCosA) + p2 = V2 (xc + rCosB + h * rSinB) (yc + rSinB - h * rCosB) + p3 = V2 (xc + rCosB) (yc + rSinB) + +-- | Translate an arc with a definition similar to the +-- one given in Cairo to a list of bezier path command +arcInDirection :: Point -- ^ center + -> Float -- ^ Radius + -> Direction + -> Float -- ^ Tolerance + -> Float -- ^ Angle minimum + -> Float -- ^ Angle maximum + -> [PathCommand] +arcInDirection p@(V2 px py) radius dir tolerance + | isNaN px || isNaN py || isNaN radius = mempty + | otherwise = subdivideAngles dir go where + go angleMin angleMax = commands where + deltaAngle = angleMax - angleMin + segmentCount = arcSegmentsNeeded deltaAngle radius mempty tolerance + + (angle, angleStep) = case dir of + Forward -> (angleMin, deltaAngle / fromIntegral segmentCount) + Backward -> (angleMax, - deltaAngle / fromIntegral segmentCount) + + commands = + [arcSegment p radius a (a + angleStep) + | i <- [0 .. segmentCount - 1] + , let a = angle + angleStep * fromIntegral i] + diff --git a/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs b/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs --- a/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs +++ b/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs @@ -1,199 +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) - +{-# 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/Patch.hs b/src/Graphics/Rasterific/Patch.hs --- a/src/Graphics/Rasterific/Patch.hs +++ b/src/Graphics/Rasterific/Patch.hs @@ -1,597 +1,609 @@ -{-# 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 - +{-# 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 +-- @ + + +-- TODO: find a new way to calculate that... +maxColorDeepness :: forall px. InterpolablePixel px => ParametricValues px -> Int +maxColorDeepness values = ceiling $ log (maxDelta * range) / log 2 where + range = maxRepresentable (Proxy :: Proxy px) + maxDelta = + maximum [ maxDistance north east + , maxDistance east south + , maxDistance south west + , maxDistance west north] + ParametricValues { _westValue = west, _northValue = north + , _southValue = south, _eastValue = east } = values + +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 +