Rasterific 0.7 → 0.7.1
raw patch · 7 files changed
+2641/−2446 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Graphics.Rasterific: Backward :: Direction
+ Graphics.Rasterific: Forward :: Direction
+ Graphics.Rasterific: arcInDirection :: Point -> Float -> Direction -> Float -> Float -> Float -> [PathCommand]
+ Graphics.Rasterific: data Direction
Files
- Rasterific.cabal +101/−100
- changelog +158/−147
- exec-src/docImageGenerator.hs +572/−580
- src/Graphics/Rasterific.hs +832/−823
- src/Graphics/Rasterific/Arc.hs +170/−0
- src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs +199/−199
- src/Graphics/Rasterific/Patch.hs +609/−597
Rasterific.cabal view
@@ -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:- <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAMAAACahl6sAAAA7VBMVEUBhsECh8EFiMIIisMLi8QMjMQOjcQSj8UTj8YVkMYZkscakscbk8ghlskmmMozns02oM44oc86os9CpdFEptJXr9Zbsdddsthes9hhtNljtdlsudtxvNx+wuB/wuCAw+CCxOGDxOGExeGHxuKVzeWb0Oed0Oek1Omm1emo1uqp1uqr1+ux2uyy2uy02+223O294O/J5fLK5vLM5/PN5/PY7PbZ7fbj8vjk8vjl8/nm8/np9frq9frr9vrs9vru9/vw+Pv2+/33+/37/f6g0ug8otBNq9S63u6Jx+IEiMJfs9hzvd3f8Pcqmsv///+OsMg+AAAFP0lEQVR4XuzPSQ0AIAwAQcT15PIvhy8OaMiOg2n7E0TeI0KECJH6iBAhQoQIESJEiEyXGN10ZbvkUusjxGf9yGHvjhpRW8Iwjj+oIIQQlh0FgBARiEIs7eb7f5xzdW5m9j5nzbPe1rwX/b7B343VzDszD+f1yvIs/tfscqV+/qAz5PlksJqHl/zq4ORZVUjnaHMepPnNo46OkNbeElJa2muFDrmvDSFiWLsPF9I7LkNQ+bgXJOSlOgNhM9WXzEPa2znIQ267nWnIUzSJEZmMnjIL6dYKGKFCrZtNSGMBI7bQyCDkbR0ZWH8bdcjFHDIxdzHSkG40gYxMRN3RhbRLyFCpPaqQZhGZKjZHE3KWQ8ZyZ6MI2Y+RuXhfPmQXQewSIXzHVKlSPby8ef03+vXm8rBaKU2JlMiG7ONvCmsHLfMXrYO1AtLalww5i/FHizvX7+Y/vV/vLCKV+EwupJnDn5SvTCJXZaSRa0qFtItwxRu3JrHbjRi8YlsmpFuCq39nvNz1wSt1RUIiOKZPjbfTadAiiZCLCdhWHg3hcQWsiYv0IW9zsG31DKW3BdbcW+qQddh+GdovsNbThjS4DvmSRrqQ7gIsWyaVLZAWuqlCarCs9EwqvRWQamlCngpWx/SjSelxGpzCU4qQCJZTk9opSBEf0rbXE/tGQB+cyTYdsm11xHdGwF0MzjYb8pKzQjaMiA1wci9kSBWWWyPiFqQqF9Kz9z/KRkgZnJkeFXIMy5URcgXSMRHi/t0WjZhFcMpMyD0sO0bMDkj3REgNlmsj5hqkGhEytDoK70bMewGcoX9IC5Y1I2gNpJZ3yB4sB0bQAUh73iFL7t9CUAukJd+QDixTRtQUSB3PkCNYSkZUCaQjz5BNWCpGVAWkTc+QeViqRlQVpHm/kGfYDo2oQ7CevUJOYLs0oi7BOvEKGcB2Y0TdgDXwClmF7dWIegVr1SskD5sRBlbeJ+QBekPw4BFyrjnk3COkrjmk7hFS0RxS8QhZ1hyy7BEyqzlk1iMEmkOQPOQ3oPcfIvA7ccgXoPcTBfhKHPIB6P1oBD4Sh3wDej/jge/EIQM45H9Y8QaJQ37gkP+py/tJHNKHQ37xgddPHPIJh/xyEO8zccgQDvkFOt4wcUgMh/ySKS9OHAJL2EVsFxGiaFuBD1G20cOHaNt640OUbYbyIdq2p/kQZQMDfIi2EQ4+JORQjXyI/JhToBD5wbOgIfKjgDzmozH8cKYrZj7jw4/LuobUD6vgA8yuT+qnbvCRclefW3wIPeTv+iGXgwIfu3AN2AW6sAdhXN/skmnYo0muD3oRO+hhMdcXv60Q9vgev61g4JA/UMlLtfUmfsSVN5tqM5Q/dCxuOd32dIBj4ALb03UoVidGOFQ6J4ZqVHogxpw0yhODZyqtEqOAKg2I4UyVTohxWZWeiQFmjeaJkXKVNokhf5WOiGMXKnWIgzAaLRFHk1TaIw6LqdRiju8pNKQOVCpUo464KnTPHTpWp0weA1fnmD2Yrwl/MN9UoUyVv7xCldwLf52IKtsCF7wEIHnBi4mgSCRwCVIA7CVI+r9TagIXhWmw0BW4uk2DhsBlehqsS1xvqMDcm8iFkwGQF05q/2cSSV3KGlipK3ZNblDFtuDFxQHlmqJXSQcTn8le7h3MvvR164Hsji/A1/UkwfiRCF3PdowfUtH1tM34sSFVzz+NH+RS9UTa+NE6Tc8Ijh921PTU5vjxU8XP0Y4fCB4/2cw/ov1Pe3cgAwAAACDM3zqOtmdwgmzNjeZBQEA+gYCAgICAgICAgIAETuKXxaAVTVgAAAAASUVORK5CYII=>>- .- 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: + <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAMAAACahl6sAAAA7VBMVEUBhsECh8EFiMIIisMLi8QMjMQOjcQSj8UTj8YVkMYZkscakscbk8ghlskmmMozns02oM44oc86os9CpdFEptJXr9Zbsdddsthes9hhtNljtdlsudtxvNx+wuB/wuCAw+CCxOGDxOGExeGHxuKVzeWb0Oed0Oek1Omm1emo1uqp1uqr1+ux2uyy2uy02+223O294O/J5fLK5vLM5/PN5/PY7PbZ7fbj8vjk8vjl8/nm8/np9frq9frr9vrs9vru9/vw+Pv2+/33+/37/f6g0ug8otBNq9S63u6Jx+IEiMJfs9hzvd3f8Pcqmsv///+OsMg+AAAFP0lEQVR4XuzPSQ0AIAwAQcT15PIvhy8OaMiOg2n7E0TeI0KECJH6iBAhQoQIESJEiEyXGN10ZbvkUusjxGf9yGHvjhpRW8Iwjj+oIIQQlh0FgBARiEIs7eb7f5xzdW5m9j5nzbPe1rwX/b7B343VzDszD+f1yvIs/tfscqV+/qAz5PlksJqHl/zq4ORZVUjnaHMepPnNo46OkNbeElJa2muFDrmvDSFiWLsPF9I7LkNQ+bgXJOSlOgNhM9WXzEPa2znIQ267nWnIUzSJEZmMnjIL6dYKGKFCrZtNSGMBI7bQyCDkbR0ZWH8bdcjFHDIxdzHSkG40gYxMRN3RhbRLyFCpPaqQZhGZKjZHE3KWQ8ZyZ6MI2Y+RuXhfPmQXQewSIXzHVKlSPby8ef03+vXm8rBaKU2JlMiG7ONvCmsHLfMXrYO1AtLalww5i/FHizvX7+Y/vV/vLCKV+EwupJnDn5SvTCJXZaSRa0qFtItwxRu3JrHbjRi8YlsmpFuCq39nvNz1wSt1RUIiOKZPjbfTadAiiZCLCdhWHg3hcQWsiYv0IW9zsG31DKW3BdbcW+qQddh+GdovsNbThjS4DvmSRrqQ7gIsWyaVLZAWuqlCarCs9EwqvRWQamlCngpWx/SjSelxGpzCU4qQCJZTk9opSBEf0rbXE/tGQB+cyTYdsm11xHdGwF0MzjYb8pKzQjaMiA1wci9kSBWWWyPiFqQqF9Kz9z/KRkgZnJkeFXIMy5URcgXSMRHi/t0WjZhFcMpMyD0sO0bMDkj3REgNlmsj5hqkGhEytDoK70bMewGcoX9IC5Y1I2gNpJZ3yB4sB0bQAUh73iFL7t9CUAukJd+QDixTRtQUSB3PkCNYSkZUCaQjz5BNWCpGVAWkTc+QeViqRlQVpHm/kGfYDo2oQ7CevUJOYLs0oi7BOvEKGcB2Y0TdgDXwClmF7dWIegVr1SskD5sRBlbeJ+QBekPw4BFyrjnk3COkrjmk7hFS0RxS8QhZ1hyy7BEyqzlk1iMEmkOQPOQ3oPcfIvA7ccgXoPcTBfhKHPIB6P1oBD4Sh3wDej/jge/EIQM45H9Y8QaJQ37gkP+py/tJHNKHQ37xgddPHPIJh/xyEO8zccgQDvkFOt4wcUgMh/ySKS9OHAJL2EVsFxGiaFuBD1G20cOHaNt640OUbYbyIdq2p/kQZQMDfIi2EQ4+JORQjXyI/JhToBD5wbOgIfKjgDzmozH8cKYrZj7jw4/LuobUD6vgA8yuT+qnbvCRclefW3wIPeTv+iGXgwIfu3AN2AW6sAdhXN/skmnYo0muD3oRO+hhMdcXv60Q9vgev61g4JA/UMlLtfUmfsSVN5tqM5Q/dCxuOd32dIBj4ALb03UoVidGOFQ6J4ZqVHogxpw0yhODZyqtEqOAKg2I4UyVTohxWZWeiQFmjeaJkXKVNokhf5WOiGMXKnWIgzAaLRFHk1TaIw6LqdRiju8pNKQOVCpUo464KnTPHTpWp0weA1fnmD2Yrwl/MN9UoUyVv7xCldwLf52IKtsCF7wEIHnBi4mgSCRwCVIA7CVI+r9TagIXhWmw0BW4uk2DhsBlehqsS1xvqMDcm8iFkwGQF05q/2cSSV3KGlipK3ZNblDFtuDFxQHlmqJXSQcTn8le7h3MvvR164Hsji/A1/UkwfiRCF3PdowfUtH1tM34sSFVzz+NH+RS9UTa+NE6Tc8Ijh921PTU5vjxU8XP0Y4fCB4/2cw/ov1Pe3cgAwAAACDM3zqOtmdwgmzNjeZBQEA+gYCAgICAgICAgIAETuKXxaAVTVgAAAAASUVORK5CYII=>> + . + 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 +
changelog view
@@ -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. +
exec-src/docImageGenerator.hs view
@@ -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 +
src/Graphics/Rasterific.hs view
@@ -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------ <<docimages/module_example.png>>------ The coordinate system is the picture classic one, with the origin in--- the upper left corner; with the y axis growing to the bottom and the--- x axis growing to the right:------ <<docimages/coordinate.png>>----module Graphics.Rasterific- (- -- * Rasterization command- -- ** Filling- fill- , fillWithMethod- , renderMeshPatch- -- ** Stroking- , stroke- , dashedStroke- , dashedStrokeWithOffset- -- ** Text rendering- , printTextAt- , printTextRanges- -- ** Texturing- , withTexture- , withClipping- , withGroupOpacity- -- ** Transformations- , withTransformation- , withPathOrientation- , TextRange( .. )- , PointSize( .. )-- -- * Generating images- , ModulablePixel- , RenderablePixel- , renderDrawing- , renderDrawingAtDpi- , renderDrawingAtDpiToPDF- , 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------ <<docimages/with_texture.png>>----withTexture :: Texture px -> Drawing px () -> Drawing px ()-withTexture texture subActions =- liftF $ SetTexture texture subActions ()---- | Will render the whole subaction with a given group opacity, after--- each element has been rendered. That means that completly opaque--- overlapping shapes will be rendered transparently, not one after--- another.------ > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $--- > stroke 3 JoinRound (CapRound, CapRound) $--- > line (V2 0 100) (V2 200 100)--- >--- > withGroupOpacity 128 $ do--- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) .--- > fill $ circle (V2 70 100) 60--- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255) .--- > fill $ circle (V2 120 100) 60------ <<docimages/group_opacity.png>>------ To be compared to the item opacity------ > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $--- > stroke 3 JoinRound (CapRound, CapRound) $--- > line (V2 0 100) (V2 200 100)--- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) .--- > fill $ circle (V2 70 100) 60--- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) .--- > fill $ circle (V2 120 100) 60------ <<docimages/item_opacity.png>>-withGroupOpacity :: PixelBaseComponent px -> Drawing px ()-> Drawing px ()-withGroupOpacity opa sub = liftF $ WithGlobalOpacity opa sub ()---- | Draw all the sub drawing commands using a transformation.-withTransformation :: Transformation -> Drawing px () -> Drawing px ()-withTransformation trans sub =- liftF $ WithTransform trans sub ()---- | This command allows you to draw primitives on a given curve,--- for example, you can draw text on a curve:------ > let path = Path (V2 100 180) False--- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in--- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path--- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $--- > withPathOrientation path 0 $--- > printTextAt font (PointSize 24) (V2 0 0) "Text on path"------ <<docimages/text_on_path.png>>------ You can note that the position of the baseline match the size of the--- characters.------ You are not limited to text drawing while using this function,--- you can draw arbitrary geometry like in the following example:------ > let path = Path (V2 100 180) False--- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)]--- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $--- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path--- > --- > withPathOrientation path 0 $ do--- > printTextAt font (PointSize 24) (V2 0 0) "TX"--- > fill $ rectangle (V2 (-10) (-10)) 30 20--- > fill $ rectangle (V2 45 0) 10 20--- > fill $ rectangle (V2 60 (-10)) 20 20--- > fill $ rectangle (V2 100 (-15)) 20 50------ <<docimages/geometry_on_path.png>>----withPathOrientation :: Path -- ^ Path directing the orientation.- -> Float -- ^ Basline Y axis position, used to align text properly.- -> Drawing px () -- ^ The sub drawings.- -> Drawing px ()-withPathOrientation path p sub =- liftF $ WithPathOrientation path p sub ()---- | Fill some geometry. The geometry should be "looping",--- ie. the last point of the last primitive should--- be equal to the first point of the first primitive.------ The primitive should be connected.------ > fill $ circle (V2 100 100) 75------ <<docimages/fill_circle.png>>----fill :: Geometry geom => geom -> Drawing px ()-fill prims = liftF $ Fill FillWinding (toPrimitives prims) ()---- | This function let you choose how to fill the primitives--- in case of self intersection. See `FillMethod` documentation--- for more information.-fillWithMethod :: Geometry geom- => FillMethod -> geom -> Drawing px ()-fillWithMethod method prims =- liftF $ Fill method (toPrimitives prims) ()---- | Draw some geometry using a clipping path.------ > withClipping (fill $ circle (V2 100 100) 75) $--- > mapM_ (stroke 7 JoinRound (CapRound, CapRound))--- > [line (V2 0 yf) (V2 200 (yf + 10))--- > | y <- [5 :: Int, 17 .. 200]--- > , let yf = fromIntegral y ]------ <<docimages/with_clipping.png>>----withClipping- :: (forall innerPixel. Drawing innerPixel ()) -- ^ The clipping path- -> Drawing px () -- ^ The actual geometry to clip- -> Drawing px ()-withClipping clipPath drawing =- liftF $ WithCliping clipPath drawing ()---- | Will stroke geometry with a given stroke width.--- The elements should be connected------ > stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75------ <<docimages/stroke_circle.png>>----stroke :: (Geometry geom)- => Float -- ^ Stroke width- -> Join -- ^ Which kind of join will be used- -> (Cap, Cap) -- ^ Start and end capping.- -> geom -- ^ List of elements to render- -> Drawing px ()-stroke width join caping prims =- liftF $ Stroke width join caping (toPrimitives prims) ()---- | Draw a string at a given position.--- Text printing imply loading a font, there is no default--- font (yet). Below an example of font rendering using a--- font installed on Microsoft Windows.------ > import Graphics.Text.TrueType( loadFontFile )--- > import Codec.Picture( PixelRGBA8( .. ), writePng )--- > import Graphics.Rasterific--- > import Graphics.Rasterific.Texture--- >--- > main :: IO ()--- > main = do--- > fontErr <- loadFontFile "test_fonts/DejaVuSans.ttf"--- > case fontErr of--- > Left err -> putStrLn err--- > Right font ->--- > writePng "text_example.png" .--- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255)--- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $--- > printTextAt font (PointSize 12) (V2 20 40)--- > "A simple text test!"------ <<docimages/text_example.png>>------ You can use any texture, like a gradient while rendering text.----printTextAt :: Font -- ^ Drawing font- -> PointSize -- ^ font Point size- -> Point -- ^ Drawing starting point (base line)- -> String -- ^ String to print- -> Drawing px ()-printTextAt font pointSize point string =- liftF $ TextFill point [description] ()- where- description = TextRange- { _textFont = font- , _textSize = pointSize- , _text = string- , _textTexture = Nothing- }---- | Render a mesh patch as an object. Warning, there is--- no antialiasing on mesh patch objects!-renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px ()-renderMeshPatch i mesh = liftF $ MeshPatchRender i mesh ()---- | Print complex text, using different texture font and--- point size for different parts of the text.------ > let blackTexture =--- > Just . uniformTexture $ PixelRGBA8 0 0 0 255--- > redTexture =--- > Just . uniformTexture $ PixelRGBA8 255 0 0 255--- > in--- > printTextRanges (V2 20 40)--- > [ TextRange font1 (PointSize 12) "A complex " blackTexture--- > , TextRange font2 (PointSize 8) "text test" redTexture]------ <<docimages/text_complex_example.png>>----printTextRanges :: Point -- ^ Starting point of the base line- -> [TextRange px] -- ^ Ranges description to be printed- -> Drawing px ()-printTextRanges point ranges = liftF $ TextFill point ranges ()--data RenderContext px = RenderContext- { currentClip :: Maybe (Texture (PixelBaseComponent px))- , currentTexture :: Texture px- , currentTransformation :: Maybe (Transformation, Transformation)- }---- | Function to call in order to start the image creation.--- Tested pixels type are PixelRGBA8 and Pixel8, pixel types--- in other colorspace will probably produce weird results.--- Default DPI is 96-renderDrawing- :: forall px . (RenderablePixel px)- => Int -- ^ Rendering width- -> Int -- ^ Rendering height- -> px -- ^ Background color- -> Drawing px () -- ^ Rendering action- -> Image px-renderDrawing width height = renderDrawingAtDpi width height 96--renderOrdersAtDpiToPdf - :: Int -- ^ Rendering width- -> Int -- ^ Rendering height- -> Dpi -- ^ Current DPI used for text rendering.- -> [DrawOrder PixelRGBA8] -- ^ Drawing Orders- -> LB.ByteString-renderOrdersAtDpiToPdf w h dpi =- renderOrdersToPdf renderer w h dpi- where- renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px]- renderer = drawOrdersOfDrawing w h dpi emptyPx--renderDrawingAtDpiToPDF- :: Int -- ^ Rendering width- -> Int -- ^ Rendering height- -> Dpi -- ^ Current DPI used for text rendering.- -> Drawing PixelRGBA8 () -- ^ Rendering action- -> LB.ByteString-renderDrawingAtDpiToPDF w h dpi =- 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)------ <<docimages/dashed_stroke.png>>----dashedStroke- :: Geometry geom- => DashPattern -- ^ Dashing pattern to use for stroking- -> Float -- ^ Stroke width- -> Join -- ^ Which kind of join will be used- -> (Cap, Cap) -- ^ Start and end capping.- -> geom -- ^ List of elements to render- -> Drawing px ()-dashedStroke = dashedStrokeWithOffset 0.0---- | With stroke geometry with a given stroke width, using--- a dash pattern. The offset is there to specify the starting--- point into the pattern, the value can be negative.------ > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $--- > line (V2 0 100) (V2 200 100)------ <<docimages/dashed_stroke_with_offset.png>>----dashedStrokeWithOffset- :: Geometry geom- => Float -- ^ Starting offset- -> DashPattern -- ^ Dashing pattern to use for stroking- -> Float -- ^ Stroke width- -> Join -- ^ Which kind of join will be used- -> (Cap, Cap) -- ^ Start and end capping.- -> geom -- ^ List of elements to render- -> Drawing px ()-dashedStrokeWithOffset _ [] width join caping prims =- stroke width join caping prims-dashedStrokeWithOffset offset dashing width join caping prims =- liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) ()---- | Generate a strokable line out of points list.--- Just an helper around `lineFromPath`.------ > stroke 4 JoinRound (CapRound, CapRound) $--- > polyline [V2 10 10, V2 100 70, V2 190 190]------ <<docimages/stroke_polyline.png>>----polyline :: [Point] -> [Primitive]-polyline = map LinePrim . lineFromPath---- | Generate a fillable polygon out of points list.--- Similar to the `polyline` function, but close the--- path.------ > fill $ polygon [V2 30 30, V2 100 70, V2 80 170]------ <<docimages/fill_polygon.png>>----polygon :: [Point] -> [Primitive]-polygon [] = []-polygon [_] = []-polygon [_,_] = []-polygon lst@(p:_) = polyline $ lst ++ [p]---- | Simply draw an image into the canvas. Take into account--- any previous transformation performed on the geometry.------ > drawImage textureImage 0 (V2 30 30)------ <<docimages/image_simple.png>>----drawImage :: Image px -- ^ Image to be drawn- -> StrokeWidth -- ^ Border size, drawn with current texture.- -> Point -- ^ Position of the corner upper left of the image.- -> Drawing px ()-drawImage img@Image { imageWidth = w, imageHeight = h } s p =- drawImageAtSize img s p (fromIntegral w) (fromIntegral h)---- | Draw an image with the desired size------ > drawImageAtSize textureImage 2 (V2 30 30) 128 128------ <<docimages/image_resize.png>>----drawImageAtSize :: Image px -- ^ Image to be drawn- -> StrokeWidth -- ^ Border size, drawn with current texture.- -> Point -- ^ Position of the corner upper left of the image.- -> Float -- ^ Width of the drawn image- -> Float -- ^ Height of the drawn image- -> Drawing px ()-drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip- reqWidth reqHeight- | borderSize <= 0 =- withTransformation (translate p <> scale scaleX scaleY) .- withTexture (SampledTexture img) $ fill rect- | otherwise = do- withTransformation (translate p <> scale scaleX scaleY) $- withTexture (SampledTexture img) $ fill rect- stroke (borderSize / 2) (JoinMiter 0)- (CapStraight 0, CapStraight 0) rect'- where- p = ip ^-^ V2 0.5 0.5- rect = rectangle (V2 0 0) rw rh- rect' = rectangle p reqWidth reqHeight-- (rw, rh) = (fromIntegral w, fromIntegral h)- scaleX | reqWidth == 0 = 1- | otherwise = reqWidth / rw-- scaleY | reqHeight == 0 = 1- | otherwise = reqHeight / rh---- | Return a simple line ready to be stroked.------ > stroke 17 JoinRound (CapRound, CapRound) $--- > line (V2 10 10) (V2 180 170)------ <<docimages/stroke_line.png>>----line :: Point -> Point -> [Primitive]-line p1 p2 = [LinePrim $ Line p1 p2]-+{-# 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 +-- +-- <<docimages/module_example.png>> +-- +-- The coordinate system is the picture classic one, with the origin in +-- the upper left corner; with the y axis growing to the bottom and the +-- x axis growing to the right: +-- +-- <<docimages/coordinate.png>> +-- +module Graphics.Rasterific + ( + -- * Rasterization command + -- ** Filling + fill + , fillWithMethod + , renderMeshPatch + -- ** Stroking + , stroke + , dashedStroke + , dashedStrokeWithOffset + -- ** Text rendering + , printTextAt + , printTextRanges + -- ** Texturing + , withTexture + , withClipping + , withGroupOpacity + -- ** Transformations + , withTransformation + , withPathOrientation + , TextRange( .. ) + , PointSize( .. ) + + -- * Generating images + , ModulablePixel + , RenderablePixel + , renderDrawing + , renderDrawingAtDpi + , renderDrawingAtDpiToPDF + , 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 +-- +-- <<docimages/with_texture.png>> +-- +withTexture :: Texture px -> Drawing px () -> Drawing px () +withTexture texture subActions = + liftF $ SetTexture texture subActions () + +-- | Will render the whole subaction with a given group opacity, after +-- each element has been rendered. That means that completly opaque +-- overlapping shapes will be rendered transparently, not one after +-- another. +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ +-- > stroke 3 JoinRound (CapRound, CapRound) $ +-- > line (V2 0 100) (V2 200 100) +-- > +-- > withGroupOpacity 128 $ do +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) . +-- > fill $ circle (V2 70 100) 60 +-- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255) . +-- > fill $ circle (V2 120 100) 60 +-- +-- <<docimages/group_opacity.png>> +-- +-- To be compared to the item opacity +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ +-- > stroke 3 JoinRound (CapRound, CapRound) $ +-- > line (V2 0 100) (V2 200 100) +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) . +-- > fill $ circle (V2 70 100) 60 +-- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) . +-- > fill $ circle (V2 120 100) 60 +-- +-- <<docimages/item_opacity.png>> +withGroupOpacity :: PixelBaseComponent px -> Drawing px ()-> Drawing px () +withGroupOpacity opa sub = liftF $ WithGlobalOpacity opa sub () + +-- | Draw all the sub drawing commands using a transformation. +withTransformation :: Transformation -> Drawing px () -> Drawing px () +withTransformation trans sub = + liftF $ WithTransform trans sub () + +-- | This command allows you to draw primitives on a given curve, +-- for example, you can draw text on a curve: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > withPathOrientation path 0 $ +-- > printTextAt font (PointSize 24) (V2 0 0) "Text on path" +-- +-- <<docimages/text_on_path.png>> +-- +-- You can note that the position of the baseline match the size of the +-- characters. +-- +-- You are not limited to text drawing while using this function, +-- you can draw arbitrary geometry like in the following example: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path +-- > +-- > withPathOrientation path 0 $ do +-- > printTextAt font (PointSize 24) (V2 0 0) "TX" +-- > fill $ rectangle (V2 (-10) (-10)) 30 20 +-- > fill $ rectangle (V2 45 0) 10 20 +-- > fill $ rectangle (V2 60 (-10)) 20 20 +-- > fill $ rectangle (V2 100 (-15)) 20 50 +-- +-- <<docimages/geometry_on_path.png>> +-- +withPathOrientation :: Path -- ^ Path directing the orientation. + -> Float -- ^ Basline Y axis position, used to align text properly. + -> Drawing px () -- ^ The sub drawings. + -> Drawing px () +withPathOrientation path p sub = + liftF $ WithPathOrientation path p sub () + +-- | Fill some geometry. The geometry should be "looping", +-- ie. the last point of the last primitive should +-- be equal to the first point of the first primitive. +-- +-- The primitive should be connected. +-- +-- > fill $ circle (V2 100 100) 75 +-- +-- <<docimages/fill_circle.png>> +-- +fill :: Geometry geom => geom -> Drawing px () +fill prims = liftF $ Fill FillWinding (toPrimitives prims) () + +-- | This function let you choose how to fill the primitives +-- in case of self intersection. See `FillMethod` documentation +-- for more information. +fillWithMethod :: Geometry geom + => FillMethod -> geom -> Drawing px () +fillWithMethod method prims = + liftF $ Fill method (toPrimitives prims) () + +-- | Draw some geometry using a clipping path. +-- +-- > withClipping (fill $ circle (V2 100 100) 75) $ +-- > mapM_ (stroke 7 JoinRound (CapRound, CapRound)) +-- > [line (V2 0 yf) (V2 200 (yf + 10)) +-- > | y <- [5 :: Int, 17 .. 200] +-- > , let yf = fromIntegral y ] +-- +-- <<docimages/with_clipping.png>> +-- +withClipping + :: (forall innerPixel. Drawing innerPixel ()) -- ^ The clipping path + -> Drawing px () -- ^ The actual geometry to clip + -> Drawing px () +withClipping clipPath drawing = + liftF $ WithCliping clipPath drawing () + +-- | Will stroke geometry with a given stroke width. +-- The elements should be connected +-- +-- > stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 +-- +-- <<docimages/stroke_circle.png>> +-- +stroke :: (Geometry geom) + => Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +stroke width join caping prims = + liftF $ Stroke width join caping (toPrimitives prims) () + +-- | Draw a string at a given position. +-- Text printing imply loading a font, there is no default +-- font (yet). Below an example of font rendering using a +-- font installed on Microsoft Windows. +-- +-- > import Graphics.Text.TrueType( loadFontFile ) +-- > import Codec.Picture( PixelRGBA8( .. ), writePng ) +-- > import Graphics.Rasterific +-- > import Graphics.Rasterific.Texture +-- > +-- > main :: IO () +-- > main = do +-- > fontErr <- loadFontFile "test_fonts/DejaVuSans.ttf" +-- > case fontErr of +-- > Left err -> putStrLn err +-- > Right font -> +-- > writePng "text_example.png" . +-- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) +-- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > printTextAt font (PointSize 12) (V2 20 40) +-- > "A simple text test!" +-- +-- <<docimages/text_example.png>> +-- +-- You can use any texture, like a gradient while rendering text. +-- +printTextAt :: Font -- ^ Drawing font + -> PointSize -- ^ font Point size + -> Point -- ^ Drawing starting point (base line) + -> String -- ^ String to print + -> Drawing px () +printTextAt font pointSize point string = + liftF $ TextFill point [description] () + where + description = TextRange + { _textFont = font + , _textSize = pointSize + , _text = string + , _textTexture = Nothing + } + +-- | Render a mesh patch as an object. Warning, there is +-- no antialiasing on mesh patch objects! +renderMeshPatch :: PatchInterpolation -> MeshPatch px -> Drawing px () +renderMeshPatch i mesh = liftF $ MeshPatchRender i mesh () + +-- | Print complex text, using different texture font and +-- point size for different parts of the text. +-- +-- > let blackTexture = +-- > Just . uniformTexture $ PixelRGBA8 0 0 0 255 +-- > redTexture = +-- > Just . uniformTexture $ PixelRGBA8 255 0 0 255 +-- > in +-- > printTextRanges (V2 20 40) +-- > [ TextRange font1 (PointSize 12) "A complex " blackTexture +-- > , TextRange font2 (PointSize 8) "text test" redTexture] +-- +-- <<docimages/text_complex_example.png>> +-- +printTextRanges :: Point -- ^ Starting point of the base line + -> [TextRange px] -- ^ Ranges description to be printed + -> Drawing px () +printTextRanges point ranges = liftF $ TextFill point ranges () + +data RenderContext px = RenderContext + { currentClip :: Maybe (Texture (PixelBaseComponent px)) + , currentTexture :: Texture px + , currentTransformation :: Maybe (Transformation, Transformation) + } + +-- | Function to call in order to start the image creation. +-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types +-- in other colorspace will probably produce weird results. +-- Default DPI is 96 +renderDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> Image px +renderDrawing width height = renderDrawingAtDpi width height 96 + +renderOrdersAtDpiToPdf + :: Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> [DrawOrder PixelRGBA8] -- ^ Drawing Orders + -> LB.ByteString +renderOrdersAtDpiToPdf w h dpi = + renderOrdersToPdf renderer w h dpi + where + renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px] + renderer = drawOrdersOfDrawing w h dpi emptyPx + +renderDrawingAtDpiToPDF + :: Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> Drawing PixelRGBA8 () -- ^ Rendering action + -> LB.ByteString +renderDrawingAtDpiToPDF w h dpi = + 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) +-- +-- <<docimages/dashed_stroke.png>> +-- +dashedStroke + :: Geometry geom + => DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +dashedStroke = dashedStrokeWithOffset 0.0 + +-- | With stroke geometry with a given stroke width, using +-- a dash pattern. The offset is there to specify the starting +-- point into the pattern, the value can be negative. +-- +-- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ +-- > line (V2 0 100) (V2 200 100) +-- +-- <<docimages/dashed_stroke_with_offset.png>> +-- +dashedStrokeWithOffset + :: Geometry geom + => Float -- ^ Starting offset + -> DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +dashedStrokeWithOffset _ [] width join caping prims = + stroke width join caping prims +dashedStrokeWithOffset offset dashing width join caping prims = + liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) () + +-- | Generate a strokable line out of points list. +-- Just an helper around `lineFromPath`. +-- +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > polyline [V2 10 10, V2 100 70, V2 190 190] +-- +-- <<docimages/stroke_polyline.png>> +-- +polyline :: [Point] -> [Primitive] +polyline = map LinePrim . lineFromPath + +-- | Generate a fillable polygon out of points list. +-- Similar to the `polyline` function, but close the +-- path. +-- +-- > fill $ polygon [V2 30 30, V2 100 70, V2 80 170] +-- +-- <<docimages/fill_polygon.png>> +-- +polygon :: [Point] -> [Primitive] +polygon [] = [] +polygon [_] = [] +polygon [_,_] = [] +polygon lst@(p:_) = polyline $ lst ++ [p] + +-- | Simply draw an image into the canvas. Take into account +-- any previous transformation performed on the geometry. +-- +-- > drawImage textureImage 0 (V2 30 30) +-- +-- <<docimages/image_simple.png>> +-- +drawImage :: Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Drawing px () +drawImage img@Image { imageWidth = w, imageHeight = h } s p = + drawImageAtSize img s p (fromIntegral w) (fromIntegral h) + +-- | Draw an image with the desired size +-- +-- > drawImageAtSize textureImage 2 (V2 30 30) 128 128 +-- +-- <<docimages/image_resize.png>> +-- +drawImageAtSize :: Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Float -- ^ Width of the drawn image + -> Float -- ^ Height of the drawn image + -> Drawing px () +drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip + reqWidth reqHeight + | borderSize <= 0 = + withTransformation (translate p <> scale scaleX scaleY) . + withTexture (SampledTexture img) $ fill rect + | otherwise = do + withTransformation (translate p <> scale scaleX scaleY) $ + withTexture (SampledTexture img) $ fill rect + stroke (borderSize / 2) (JoinMiter 0) + (CapStraight 0, CapStraight 0) rect' + where + p = ip ^-^ V2 0.5 0.5 + rect = rectangle (V2 0 0) rw rh + rect' = rectangle p reqWidth reqHeight + + (rw, rh) = (fromIntegral w, fromIntegral h) + scaleX | reqWidth == 0 = 1 + | otherwise = reqWidth / rw + + scaleY | reqHeight == 0 = 1 + | otherwise = reqHeight / rh + +-- | Return a simple line ready to be stroked. +-- +-- > stroke 17 JoinRound (CapRound, CapRound) $ +-- > line (V2 10 10) (V2 180 170) +-- +-- <<docimages/stroke_line.png>> +-- +line :: Point -> Point -> [Primitive] +line p1 p2 = [LinePrim $ Line p1 p2] +
+ src/Graphics/Rasterific/Arc.hs view
@@ -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] +
src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs view
@@ -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) +
src/Graphics/Rasterific/Patch.hs view
@@ -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 +