Rasterific 0.5.1 → 0.5.2
raw patch · 37 files changed
+3790/−3658 lines, 37 filesbinary-addedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Graphics.Rasterific: cacheDrawing :: RenderablePixel px => Int -> Int -> Dpi -> Drawing px () -> Drawing px ()
+ Graphics.Rasterific: withGroupOpacity :: Pixel px => PixelBaseComponent px -> Drawing px () -> Drawing px ()
+ Graphics.Rasterific.Immediate: instance PlaneBoundable (DrawOrder px)
- Graphics.Rasterific: type RenderablePixel px = (ModulablePixel px, Pixel (PixelBaseComponent px), PackeablePixel (PixelBaseComponent px), Storable (PackedRepresentation (PixelBaseComponent px)), PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px))
+ Graphics.Rasterific: type RenderablePixel px = (ModulablePixel px, Pixel (PixelBaseComponent px), PackeablePixel (PixelBaseComponent px), Num (PackedRepresentation px), Num (PackedRepresentation (PixelBaseComponent px)), Storable (PackedRepresentation (PixelBaseComponent px)), PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px))
Files
- Rasterific.cabal +87/−87
- changelog +102/−98
- docimages/cap_straight.png binary
- docimages/coordinate.png binary
- docimages/fill_evenodd.png binary
- docimages/fill_winding.png binary
- docimages/geometry_on_path.png binary
- docimages/group_opacity.png binary
- docimages/item_opacity.png binary
- docimages/linear_gradient.png binary
- docimages/module_example.png binary
- docimages/radial_gradient_focus.png binary
- docimages/sampled_texture_reflect.png binary
- docimages/sampled_texture_rotate.png binary
- docimages/sampled_texture_scaled.png binary
- docimages/sampler_pad.png binary
- docimages/sampler_reflect.png binary
- docimages/sampler_repeat.png binary
- docimages/stroke_line.png binary
- docimages/stroke_polyline.png binary
- docimages/strokize_dashed_path.png binary
- docimages/text_complex_example.png binary
- docimages/text_example.png binary
- docimages/text_on_path.png binary
- exec-src/docImageGenerator.hs +485/−477
- src/Graphics/Rasterific.hs +801/−696
- src/Graphics/Rasterific/Command.hs +141/−131
- src/Graphics/Rasterific/Compositor.hs +153/−151
- src/Graphics/Rasterific/CubicBezier.hs +349/−349
- src/Graphics/Rasterific/Immediate.hs +194/−184
- src/Graphics/Rasterific/Lenses.hs +146/−147
- src/Graphics/Rasterific/Line.hs +163/−164
- src/Graphics/Rasterific/Operators.hs +162/−165
- src/Graphics/Rasterific/PathWalker.hs +128/−131
- src/Graphics/Rasterific/PlaneBoundable.hs +87/−88
- src/Graphics/Rasterific/Shading.hs +493/−490
- src/Graphics/Rasterific/StrokeInternal.hs +299/−300
Rasterific.cabal view
@@ -1,87 +1,87 @@--- Initial Rasterific.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ -name: Rasterific -version: 0.5.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 - -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 - , 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.5.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 - - 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.Types - , Graphics.Rasterific.Compositor - , Graphics.Rasterific.Shading - , Graphics.Rasterific.PlaneBoundable - , Graphics.Rasterific.QuadraticFormula - - ghc-options: -O3 -Wall - -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques - ghc-prof-options: -Wall -prof - default-language: Haskell2010 - build-depends: base >= 4.6 && < 4.9 - , free >= 4.7 - , JuicyPixels >= 3.2 - , FontyFruity >= 0.5 && < 0.6 - , vector >= 0.9 - , mtl >= 1.9 - , dlist >= 0.6 - , primitive >= 0.5 - , vector-algorithms >= 0.3 - - 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.5.2+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++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+ , 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.5.2++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++ 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.Types+ , Graphics.Rasterific.Compositor+ , Graphics.Rasterific.Shading+ , Graphics.Rasterific.PlaneBoundable+ , Graphics.Rasterific.QuadraticFormula++ ghc-options: -O3 -Wall + -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques+ ghc-prof-options: -Wall -prof+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 4.9+ , free >= 4.7+ , JuicyPixels >= 3.2+ , FontyFruity >= 0.5 && < 0.6+ , vector >= 0.9+ , mtl >= 1.9+ , dlist >= 0.6+ , primitive >= 0.5+ , vector-algorithms >= 0.3++ if !flag(embed_linear)+ build-depends: linear >= 1.3+ cpp-options: -DEXTERNAL_LINEAR+
changelog view
@@ -1,98 +1,102 @@--*-change-log-*- - -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.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.+
docimages/cap_straight.png view
binary file changed (1786 → 1785 bytes)
docimages/coordinate.png view
binary file changed (4542 → 4539 bytes)
docimages/fill_evenodd.png view
binary file changed (6040 → 6039 bytes)
docimages/fill_winding.png view
binary file changed (4454 → 4454 bytes)
docimages/geometry_on_path.png view
binary file changed (5228 → 5126 bytes)
+ docimages/group_opacity.png view
binary file changed (absent → 3014 bytes)
+ docimages/item_opacity.png view
binary file changed (absent → 3494 bytes)
docimages/linear_gradient.png view
binary file changed (4870 → 4401 bytes)
docimages/module_example.png view
binary file changed (2335 → 2331 bytes)
docimages/radial_gradient_focus.png view
binary file changed (19023 → 19019 bytes)
docimages/sampled_texture_reflect.png view
binary file changed (64813 → 65251 bytes)
docimages/sampled_texture_rotate.png view
binary file changed (109884 → 109884 bytes)
docimages/sampled_texture_scaled.png view
binary file changed (102643 → 102643 bytes)
docimages/sampler_pad.png view
binary file changed (2650 → 1819 bytes)
docimages/sampler_reflect.png view
binary file changed (5931 → 2980 bytes)
docimages/sampler_repeat.png view
binary file changed (4896 → 2374 bytes)
docimages/stroke_line.png view
binary file changed (3023 → 3022 bytes)
docimages/stroke_polyline.png view
binary file changed (2849 → 2830 bytes)
docimages/strokize_dashed_path.png view
binary file changed (10017 → 10013 bytes)
docimages/text_complex_example.png view
binary file changed (2284 → 2246 bytes)
docimages/text_example.png view
binary file changed (2388 → 2355 bytes)
docimages/text_on_path.png view
binary file changed (6582 → 6746 bytes)
exec-src/docImageGenerator.hs view
@@ -1,477 +1,485 @@-{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>) ) -#endif - -import Control.Applicative( (<$>) ) - -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.Immediate -import System.Directory( createDirectoryIfMissing ) -import System.FilePath( (</>) ) - -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 - -frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8 -frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 -accentTexture = uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255 -accent2Texture = uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255 - -produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO () -produceDocImage filename drawing = writePng filename img - where - img = renderDrawing 200 200 backgroundColor - $ withTexture frontTexture drawing - -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 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 (outFolder </> "module_example.png") img - -arialFont :: FilePath -arialFont = -#ifdef __WIN32__ - "C:/Windows/Fonts/arial.ttf" -#else - "/usr/share/fonts/truetype/msttcorefonts/arial.ttf" -#endif - -monospaceFont :: FilePath -monospaceFont = -#ifdef __WIN32__ - "C:/Windows/Fonts/consola.ttf" -#else - "/usr/share/fonts/truetype/dejavu/DejaVuSansMono.ttf" -#endif - -textOnPathExample :: IO () -textOnPathExample = do - fontErr <- loadFontFile arialFont - 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 arialFont - 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 arialFont - case fontErr of - Left err -> putStrLn err - Right font -> - writePng (outFolder </> "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!" - -textMultipleExample :: IO () -textMultipleExample = do - eitherFont1 <- loadFontFile arialFont - eitherFont2 <- loadFontFile monospaceFont - case (,) <$> eitherFont1 <*> eitherFont2 of - Left err -> putStrLn err - Right (font1, font2) -> - writePng (outFolder </> "text_complex_example.png") . - renderDrawing 300 70 (PixelRGBA8 255 255 255 255) $ - 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 arialFont - case fontErr of - Left err -> putStrLn err - Right font -> - writePng (outFolder </> "coordinate.png") - . renderDrawing 200 200 white - $ create font - where - white = PixelRGBA8 255 255 255 255 - 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 </> "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") $ - 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 - - 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.Immediate+import System.Directory( createDirectoryIfMissing )+import System.FilePath( (</>) )++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++frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8+frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255+accentTexture = uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255+accent2Texture = uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255++produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO ()+produceDocImage filename drawing = writePng filename img+ where+ img = renderDrawing 200 200 backgroundColor+ $ withTexture frontTexture drawing++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 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 (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 ->+ writePng (outFolder </> "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!"++textMultipleExample :: IO ()+textMultipleExample = do+ eitherFont1 <- loadFontFile sansSerifFont+ eitherFont2 <- loadFontFile monospaceFont+ case (,) <$> eitherFont1 <*> eitherFont2 of+ Left err -> putStrLn err+ Right (font1, font2) ->+ writePng (outFolder </> "text_complex_example.png") .+ renderDrawing 300 70 (PixelRGBA8 255 255 255 255) $+ 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 -> + writePng (outFolder </> "coordinate.png") + . renderDrawing 200 200 white+ $ create font+ where+ white = PixelRGBA8 255 255 255 255+ 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 </> "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") $+ 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 </> "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++ textExample+ textMultipleExample + coordinateSystem+ textOnPathExample+ geometryOnPath+
src/Graphics/Rasterific.hs view
@@ -1,696 +1,801 @@-{-# 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 - fill - , fillWithMethod - , withTexture - , withClipping - , withTransformation - , withPathOrientation - , stroke - , dashedStroke - , dashedStrokeWithOffset - , printTextAt - , printTextRanges - , TextRange( .. ) - , PointSize( .. ) - - -- * Generating images - , ModulablePixel - , RenderablePixel - , renderDrawing - , renderDrawingAtDpi - , 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 - , rectangle - , roundedRectangle - , circle - , ellipse - , polyline - , polygon - , drawImageAtSize - , drawImage - - -- ** Geometry Helpers - , clip - , bezierFromPath - , lineFromPath - , cubicBezierFromPath - , firstTangeantOf - , lastTangeantOf - , firstPointOf - , lastPointOf - - -- * Rasterization control - , Join( .. ) - , Cap( .. ) - , SamplerRepeat( .. ) - , FillMethod( .. ) - , DashPattern - , drawOrdersOfDrawing - - -- * Debugging helper - , dumpDrawing - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid( .. ) ) -#endif - -import Data.Monoid( (<>) ) - -import Control.Applicative( (<$>) ) -import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.Free.Church( fromF ) -import Control.Monad.ST( runST ) -import Control.Monad.State( modify, execState ) -import Data.Maybe( fromMaybe ) -import Codec.Picture.Types( Image( .. ), Pixel( .. ) ) - -import qualified Data.Vector.Unboxed as VU -import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^), (^*) ) -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Shading -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.TensorPatch-} - -import Graphics.Text.TrueType( Font - , Dpi - , PointSize( .. ) - , getStringCurveAtPoint ) - -{-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 () - --- | 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 "C:/Windows/Fonts/arial.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 - } - --- | 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 - --- | 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 - --- | 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 (uniformTexture clipForeground) - - textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } = - transformTexture t $ currentTexture ctxt - textureOf ctxt = currentTexture ctxt - - geometryOf RenderContext { currentTransformation = Just (trans, _) } = - transform (applyTransformation trans) - geometryOf _ = id - - stupidDefaultTexture = - uniformTexture $ colorMap (const clipBackground) background - - go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px] - -> [DrawOrder px] - go _ (Pure ()) rest = rest - 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 $ \lst -> finalOrder : lst - where - toFinalPos = transform $ applyTransformation trans - finalOrder = - order { _orderPrimitives = toFinalPos $ _orderPrimitives 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 (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 - } - - 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 = 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 (V2 x y) descriptions next)) rest = - go ctxt (sequence_ drawCalls) $ go ctxt next rest - where - floatCurves = - getStringCurveAtPoint dpi (x, y) - [(_textFont d, _textSize d, _text d) | d <- descriptions] - - linearDescriptions = - concat [map (const d) $ _text d | d <- descriptions] - - drawCalls = - [texturize d $ beziersOfChar curve - | (curve, d) <- zip floatCurves linearDescriptions] - - texturize descr sub = case _textTexture descr of - Nothing -> fromF sub - Just t -> liftF $ SetTexture t sub () - - beziersOfChar curves = liftF $ Fill FillWinding bezierCurves () - where - bezierCurves = concat - [map BezierPrim . bezierFromPath . map (uncurry V2) - $ VU.toList c | c <- curves] - - 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 list of primitive representing a circle. --- --- > fill $ circle (V2 100 100) 75 --- --- <<docimages/fill_circle.png>> --- -circle :: Point -- ^ Circle center in pixels - -> Float -- ^ Circle radius in pixels - -> [Primitive] -circle center radius = - CubicBezierPrim . transform mv <$> cubicBezierCircle - where - mv p = (p ^* radius) ^+^ center - --- | Generate a list of primitive representing an ellipse. --- --- > fill $ ellipse (V2 100 100) 75 30 --- --- <<docimages/fill_ellipse.png>> --- -ellipse :: Point -> Float -> Float -> [Primitive] -ellipse center rx ry = - CubicBezierPrim . transform mv <$> cubicBezierCircle - where - mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center - --- | 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] - --- | Generate a list of primitive representing a --- rectangle --- --- > fill $ rectangle (V2 30 30) 150 100 --- --- <<docimages/fill_rect.png>> --- -rectangle :: Point -- ^ Corner upper left - -> Float -- ^ Width in pixel - -> Float -- ^ Height in pixel - -> [Primitive] -rectangle p@(V2 px py) w h = - LinePrim <$> lineFromPath - [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), 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 :: ModulablePixel px - => 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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => 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 (sampledImageTexture img) $ fill rect - | otherwise = do - withTransformation (translate p <> scale scaleX scaleY) $ - withTexture (sampledImageTexture img) $ fill rect - stroke borderSize (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 - --- | Generate a list of primitive representing a rectangle --- with rounded corner. --- --- > fill $ roundedRectangle (V2 10 10) 150 150 20 10 --- --- <<docimages/fill_roundedRectangle.png>> --- -roundedRectangle :: Point -- ^ Corner upper left - -> Float -- ^ Width in pixel - -> Float -- ^ Height in pixel. - -> Float -- ^ Radius along the x axis of the rounded corner. In pixel. - -> Float -- ^ Radius along the y axis of the rounded corner. In pixel. - -> [Primitive] -roundedRectangle (V2 px py) w h rx ry = - [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR - , LinePrim $ Line (V2 xFar py) (V2 xNear py) - , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL - , LinePrim $ Line (V2 px yNear) (V2 px yFar) - , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL - , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h)) - , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR - , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear) - ] - where - xNear = px + rx - xFar = px + w - rx - - yNear = py + ry - yFar = py + h - ry - - (cornerBottomR : - cornerTopR : - cornerTopL : - cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle - --- | 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+ -- ** Stroking+ , stroke+ , dashedStroke+ , dashedStrokeWithOffset+ -- ** Text rendering+ , printTextAt+ , printTextRanges+ -- ** Texturing+ , withTexture+ , withClipping+ , withGroupOpacity+ -- ** Transformations+ , withTransformation+ , withPathOrientation+ , TextRange( .. )+ , PointSize( .. )++ -- * Generating images+ , ModulablePixel+ , RenderablePixel+ , renderDrawing+ , renderDrawingAtDpi+ , 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( .. )+ , 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( runST )+import Control.Monad.State( modify, execState )+import Data.Maybe( fromMaybe )+import Codec.Picture.Types( Image( .. )+ , Pixel( .. )+ , unpackPixel+ , pixelMapXY )++import qualified Data.Vector.Unboxed as VU+import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^), (^*) )+import Graphics.Rasterific.Rasterize+import Graphics.Rasterific.Texture+import Graphics.Rasterific.Shading+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.TensorPatch-}++import Graphics.Text.TrueType( Font+ , Dpi+ , PointSize( .. )+ , getStringCurveAtPoint )++{-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 :: Pixel px => 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+ }++-- | 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++-- | 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++emptyPx :: (RenderablePixel px) => px+-- | Really need a "builder" function for pixel+emptyPx = colorMap (const emptyValue) $ unpackPixel 0++cacheOrders :: forall px. (RenderablePixel px)+ => Maybe (Image px -> ImageTransformer px) -> [DrawOrder px] -> Drawing px ()+cacheOrders imageFilter orders = case imageFilter of+ Nothing -> drawImage resultImage 0 mini+ Just f -> drawImage (pixelMapXY (f resultImage) resultImage) 0 mini+ 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 }+ + 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++-- | 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 (uniformTexture clipForeground)++ textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } =+ transformTexture t $ currentTexture ctxt+ textureOf ctxt = currentTexture ctxt++ geometryOf RenderContext { currentTransformation = Just (trans, _) } =+ transform (applyTransformation trans)+ geometryOf _ = id++ stupidDefaultTexture =+ uniformTexture $ 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 $ \lst -> finalOrder : lst+ where+ toFinalPos = transform $ applyTransformation trans+ finalOrder =+ order { _orderPrimitives = toFinalPos $ _orderPrimitives 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 (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+ }++ 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 = 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 (V2 x y) descriptions next)) rest =+ go ctxt (sequence_ drawCalls) $ go ctxt next rest+ where+ floatCurves =+ getStringCurveAtPoint dpi (x, y)+ [(_textFont d, _textSize d, _text d) | d <- descriptions]++ linearDescriptions =+ concat [map (const d) $ _text d | d <- descriptions]++ drawCalls =+ [texturize d $ beziersOfChar curve+ | (curve, d) <- zip floatCurves linearDescriptions]++ texturize descr sub = case _textTexture descr of+ Nothing -> fromF sub+ Just t -> liftF $ SetTexture t sub ()++ beziersOfChar curves = liftF $ Fill FillWinding bezierCurves ()+ where+ bezierCurves = concat+ [map BezierPrim . bezierFromPath . map (uncurry V2)+ $ VU.toList c | c <- curves]++ 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 list of primitive representing a circle.+--+-- > fill $ circle (V2 100 100) 75+--+-- <<docimages/fill_circle.png>>+--+circle :: Point -- ^ Circle center in pixels+ -> Float -- ^ Circle radius in pixels+ -> [Primitive]+circle center radius =+ CubicBezierPrim . transform mv <$> cubicBezierCircle+ where+ mv p = (p ^* radius) ^+^ center++-- | Generate a list of primitive representing an ellipse.+--+-- > fill $ ellipse (V2 100 100) 75 30+--+-- <<docimages/fill_ellipse.png>>+--+ellipse :: Point -> Float -> Float -> [Primitive]+ellipse center rx ry =+ CubicBezierPrim . transform mv <$> cubicBezierCircle+ where+ mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center++-- | 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]++-- | Generate a list of primitive representing a+-- rectangle+--+-- > fill $ rectangle (V2 30 30) 150 100+--+-- <<docimages/fill_rect.png>>+--+rectangle :: Point -- ^ Corner upper left+ -> Float -- ^ Width in pixel+ -> Float -- ^ Height in pixel+ -> [Primitive]+rectangle p@(V2 px py) w h =+ LinePrim <$> lineFromPath+ [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), 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 :: ModulablePixel px+ => 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 :: (Pixel px, Modulable (PixelBaseComponent px))+ => 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 (sampledImageTexture img) $ fill rect+ | otherwise = do+ withTransformation (translate p <> scale scaleX scaleY) $+ withTexture (sampledImageTexture img) $ fill rect+ stroke borderSize (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++-- | Generate a list of primitive representing a rectangle+-- with rounded corner.+--+-- > fill $ roundedRectangle (V2 10 10) 150 150 20 10+--+-- <<docimages/fill_roundedRectangle.png>>+--+roundedRectangle :: Point -- ^ Corner upper left+ -> Float -- ^ Width in pixel+ -> Float -- ^ Height in pixel.+ -> Float -- ^ Radius along the x axis of the rounded corner. In pixel.+ -> Float -- ^ Radius along the y axis of the rounded corner. In pixel.+ -> [Primitive]+roundedRectangle (V2 px py) w h rx ry =+ [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR+ , LinePrim $ Line (V2 xFar py) (V2 xNear py)+ , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL+ , LinePrim $ Line (V2 px yNear) (V2 px yFar)+ , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL+ , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h))+ , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR+ , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear)+ ]+ where+ xNear = px + rx+ xFar = px + w - rx++ yNear = py + ry+ yFar = py + h - ry++ (cornerBottomR :+ cornerTopR :+ cornerTopL :+ cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle++-- | 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/Command.hs view
@@ -1,131 +1,141 @@-{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Graphics.Rasterific.Command ( Drawing - , DrawCommand( .. ) - , TextRange( .. ) - , dumpDrawing - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid( .. ) ) -#endif - -import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.Free.Church( F, fromF ) -import Codec.Picture.Types( Pixel( .. ), Pixel8 ) - -import Graphics.Rasterific.Types -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Shading - -import Graphics.Text.TrueType( Font, PointSize ) - --- | Monad used to record the drawing actions. -type Drawing px = F (DrawCommand px) - --- | Structure defining how to render a text range -data TextRange px = TextRange - { _textFont :: Font -- ^ Font used during the rendering - , _textSize :: PointSize -- ^ Size of the text (in pixels) - , _text :: String -- ^ Text to draw - -- | Texture to use for drawing, if Nothing, the currently - -- active texture is used. - , _textTexture :: Maybe (Texture px) - } - -data DrawCommand px next - = Fill FillMethod [Primitive] next - | Stroke Float Join (Cap, Cap) [Primitive] next - | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next - | TextFill Point [TextRange px] next - | SetTexture (Texture px) - (Drawing px ()) next - | WithCliping (forall innerPixel. Drawing innerPixel ()) - (Drawing px ()) next - | WithTransform Transformation (Drawing px ()) next - | WithPathOrientation Path Float (Drawing px ()) next - --- | This function will spit out drawing instructions to --- help debugging. --- --- The outputted code looks like Haskell, but there is no --- guarantee that it is compilable. -dumpDrawing :: ( Show px - , Show (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - - ) => Drawing px () -> String -dumpDrawing = go . fromF where - go :: - ( Show px - , Show (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - - ) => Free (DrawCommand px) () -> String - go (Pure ()) = "return ()" - go (Free (WithPathOrientation path point drawing next)) = - "withPathOrientation (" ++ show path ++ ") (" - ++ show point ++ ") (" - ++ go (fromF drawing) ++ ") >>= " - ++ go next - go (Free (Fill _ prims next)) = - "fill " ++ show prims ++ " >>=\n" ++ go next - go (Free (TextFill _ texts next)) = - concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next - go (Free (SetTexture tx drawing next)) = - "withTexture (" ++ dumpTexture tx ++ ") (" ++ - go (fromF drawing) ++ ") >>=\n" ++ go next - go (Free (DashedStroke o pat w j cap prims next)) = - "dashedStrokeWithOffset " - ++ show o ++ " " - ++ show pat ++ " " - ++ show w ++ " (" - ++ show j ++ ") " - ++ show cap ++ " " - ++ show prims ++ " >>=\n" ++ go next - go (Free (Stroke w j cap prims next)) = - "stroke " ++ show w ++ " (" - ++ show j ++ ") " - ++ show cap ++ " " - ++ show prims ++ " >>=\n" ++ go next - go (Free (WithTransform trans sub next)) = - "withTransform (" ++ show trans ++ ") (" - ++ go (fromF sub) ++ ") >>=\n " - ++ go next - go (Free (WithCliping clipping draw next)) = - "withClipping (" ++ go (fromF $ withTexture clipTexture clipping) - ++ ")\n" ++ - " (" ++ go (fromF draw) ++ ")\n >>= " ++ - go next - where clipTexture = uniformTexture (0xFF :: Pixel8) - withTexture texture subActions = - liftF $ SetTexture texture subActions () - - -instance Functor (DrawCommand px) where - fmap f (TextFill pos texts next) = - TextFill pos texts $ f next - fmap f (Fill method prims next) = Fill method prims $ f next - fmap f (SetTexture t sub next) = SetTexture t sub $ f next - fmap f (WithCliping sub com next) = - WithCliping sub com $ f next - fmap f (Stroke w j caps prims next) = - Stroke w j caps prims $ f next - fmap f (DashedStroke st pat w j caps prims next) = - DashedStroke st pat w j caps prims $ f next - fmap f (WithTransform trans draw next) = - WithTransform trans draw $ f next - fmap f (WithPathOrientation path point draw next) = - WithPathOrientation path point draw $ f next - -instance Monoid (Drawing px ()) where - mempty = return () - mappend a b = a >> b - +{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+module Graphics.Rasterific.Command ( Drawing+ , DrawCommand( .. )+ , TextRange( .. )+ , dumpDrawing+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( Monoid( .. ) )+#endif++import Control.Monad.Free( Free( .. ), liftF )+import Control.Monad.Free.Church( F, fromF )+import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 )++import Graphics.Rasterific.Types+import Graphics.Rasterific.Texture+import Graphics.Rasterific.Transformations+import Graphics.Rasterific.Shading++import Graphics.Text.TrueType( Font, PointSize )++-- | Monad used to record the drawing actions.+type Drawing px = F (DrawCommand px)++-- | Structure defining how to render a text range+data TextRange px = TextRange+ { _textFont :: Font -- ^ Font used during the rendering+ , _textSize :: PointSize -- ^ Size of the text (in pixels)+ , _text :: String -- ^ Text to draw+ -- | Texture to use for drawing, if Nothing, the currently+ -- active texture is used.+ , _textTexture :: Maybe (Texture px)+ }++data DrawCommand px next+ = Fill FillMethod [Primitive] next+ | Stroke Float Join (Cap, Cap) [Primitive] next+ | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next+ | TextFill Point [TextRange px] next+ | SetTexture (Texture px)+ (Drawing px ()) next+ | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next+ | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next+ | WithCliping (forall innerPixel. Drawing innerPixel ())+ (Drawing px ()) next+ | WithTransform Transformation (Drawing px ()) next+ | WithPathOrientation Path Float (Drawing px ()) next++-- | This function will spit out drawing instructions to+-- help debugging.+--+-- The outputted code looks like Haskell, but there is no+-- guarantee that it is compilable.+dumpDrawing :: ( Show px+ , Show (PixelBaseComponent px)+ , PixelBaseComponent (PixelBaseComponent px)+ ~ (PixelBaseComponent px)++ ) => Drawing px () -> String+dumpDrawing = go . fromF where+ go ::+ ( Show px+ , Show (PixelBaseComponent px)+ , PixelBaseComponent (PixelBaseComponent px)+ ~ (PixelBaseComponent px)++ ) => Free (DrawCommand px) () -> String+ go (Pure ()) = "return ()"+ go (Free (WithImageEffect _effect sub next)) =+ "withImageEffect ({- fun -}) (" ++ go (fromF sub) ++ ") >>= " ++ go next+ go (Free (WithGlobalOpacity opa sub next)) =+ "withGlobalOpacity " ++ show opa ++ " (" ++ go (fromF sub) ++ ") >>= " ++ go next+ go (Free (WithPathOrientation path point drawing next)) =+ "withPathOrientation (" ++ show path ++ ") ("+ ++ show point ++ ") ("+ ++ go (fromF drawing) ++ ") >>= "+ ++ go next+ go (Free (Fill _ prims next)) =+ "fill " ++ show prims ++ " >>=\n" ++ go next+ go (Free (TextFill _ texts next)) =+ concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next+ go (Free (SetTexture tx drawing next)) =+ "withTexture (" ++ dumpTexture tx ++ ") (" +++ go (fromF drawing) ++ ") >>=\n" ++ go next+ go (Free (DashedStroke o pat w j cap prims next)) =+ "dashedStrokeWithOffset "+ ++ show o ++ " "+ ++ show pat ++ " "+ ++ show w ++ " ("+ ++ show j ++ ") "+ ++ show cap ++ " "+ ++ show prims ++ " >>=\n" ++ go next+ go (Free (Stroke w j cap prims next)) =+ "stroke " ++ show w ++ " ("+ ++ show j ++ ") "+ ++ show cap ++ " "+ ++ show prims ++ " >>=\n" ++ go next+ go (Free (WithTransform trans sub next)) =+ "withTransform (" ++ show trans ++ ") ("+ ++ go (fromF sub) ++ ") >>=\n "+ ++ go next+ go (Free (WithCliping clipping draw next)) =+ "withClipping (" ++ go (fromF $ withTexture clipTexture clipping)+ ++ ")\n" +++ " (" ++ go (fromF draw) ++ ")\n >>= " +++ go next+ where clipTexture = uniformTexture (0xFF :: Pixel8)+ withTexture texture subActions =+ liftF $ SetTexture texture subActions ()+++instance Functor (DrawCommand px) where+ fmap f (WithImageEffect effect sub next) =+ WithImageEffect effect sub $ f next+ fmap f (TextFill pos texts next) =+ TextFill pos texts $ f next+ fmap f (WithGlobalOpacity opa sub next) =+ WithGlobalOpacity opa sub $ f next+ fmap f (Fill method prims next) = Fill method prims $ f next+ fmap f (SetTexture t sub next) = SetTexture t sub $ f next+ fmap f (WithCliping sub com next) =+ WithCliping sub com $ f next+ fmap f (Stroke w j caps prims next) =+ Stroke w j caps prims $ f next+ fmap f (DashedStroke st pat w j caps prims next) =+ DashedStroke st pat w j caps prims $ f next+ fmap f (WithTransform trans draw next) =+ WithTransform trans draw $ f next+ fmap f (WithPathOrientation path point draw next) =+ WithPathOrientation path point draw $ f next++instance Monoid (Drawing px ()) where+ mempty = return ()+ mappend a b = a >> b+
src/Graphics/Rasterific/Compositor.hs view
@@ -1,151 +1,153 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} --- | Compositor handle the pixel composition, which --- leads to texture composition. --- Very much a work in progress -module Graphics.Rasterific.Compositor - ( Compositor - , Modulable( .. ) - , ModulablePixel - , RenderablePixel - , compositionDestination - , compositionAlpha - ) where - -import Foreign.Storable( Storable ) -import Data.Bits( unsafeShiftR ) -import Data.Word( Word8, Word32 ) - -import Codec.Picture.Types( Pixel( .. ), PackeablePixel( .. ) ) - -type Compositor px = - PixelBaseComponent px -> - PixelBaseComponent px -> px -> px -> px - --- | This constraint ensure that a type is a pixel --- and we're allowed to modulate it's color components --- generically. -type ModulablePixel px = - ( Pixel px - , PackeablePixel px - , Storable (PackedRepresentation px) - , Modulable (PixelBaseComponent px)) - --- | This constraint tells us that pixel component --- must also be pixel and be the "bottom" of component, --- we cannot go further than a PixelBaseComponent level. --- --- All pixel instances of JuicyPixels should be usable. -type RenderablePixel px = - ( ModulablePixel px - , Pixel (PixelBaseComponent px) - , PackeablePixel (PixelBaseComponent px) - , Storable (PackedRepresentation (PixelBaseComponent px)) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - ) - --- | Typeclass intented at pixel value modulation. --- May be throwed out soon. -class (Ord a, Num a) => Modulable a where - -- | Empty value representing total transparency for the given type. - emptyValue :: a - -- | Full value representing total opacity for a given type. - fullValue :: a - -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue] - -- The second value is the inverse coverage - clampCoverage :: Float -> (a, a) - - -- | Modulate two elements, staying in the [emptyValue; fullValue] range. - modulate :: a -> a -> a - - -- | Implement a division between two elements. - modiv :: a -> a -> a - - alphaOver :: a -- ^ coverage - -> a -- ^ inverse coverage - -> a -- ^ background - -> a -- ^ foreground - -> a - alphaCompose :: a -> a -> a -> a -> a - - -- | Like modulate but also return the inverse coverage. - coverageModulate :: a -> a -> (a, a) - coverageModulate c a = (clamped, fullValue - clamped) - where clamped = modulate a c - -instance Modulable Float where - emptyValue = 0 - fullValue = 1 - clampCoverage f = (f, 1 - f) - modulate = (*) - modiv = (/) - alphaCompose coverage inverseCoverage backAlpha _ = - coverage + backAlpha * inverseCoverage - alphaOver coverage inverseCoverage background painted = - coverage * painted + background * inverseCoverage - -div255 :: Word32 -> Word32 -{-# INLINE div255 #-} -div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 - -instance Modulable Word8 where - {-# INLINE emptyValue #-} - emptyValue = 0 - {-# INLINE fullValue #-} - fullValue = 255 - {-# INLINE clampCoverage #-} - clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) - where c = toWord8 f - - {-# INLINE modulate #-} - modulate c a = fromIntegral . div255 $ fi c * fi a + 128 - where fi :: Word8 -> Word32 - fi = fromIntegral - - {-# INLINE modiv #-} - modiv c 0 = c - modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a - where fi :: Word8 -> Word32 - fi = fromIntegral - - {-# INLINE alphaCompose #-} - alphaCompose coverage inverseCoverage backgroundAlpha _ = - fromIntegral $ div255 v - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi coverage * 255 - + fi backgroundAlpha * fi inverseCoverage + 128 - - {-# INLINE alphaOver #-} - alphaOver coverage inverseCoverage background painted = - fromIntegral $ div255 v - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 - - -toWord8 :: Float -> Int -{-# INLINE toWord8 #-} -toWord8 r = floor $ r * 255 + 0.5 - -compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -compositionDestination c _ _ = colorMap (modulate c) - -compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -{-# INLINE compositionAlpha #-} -compositionAlpha c ic - | c == emptyValue = const - | c == fullValue = \_ n -> n - | otherwise = \bottom top -> - let bottomOpacity = pixelOpacity bottom - alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top) - colorComposer _ back fore = - alphaOver c ic (back `modulate` bottomOpacity) fore - `modiv` alphaOut - in - mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top - +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+-- | Compositor handle the pixel composition, which+-- leads to texture composition.+-- Very much a work in progress+module Graphics.Rasterific.Compositor+ ( Compositor+ , Modulable( .. )+ , ModulablePixel+ , RenderablePixel+ , compositionDestination+ , compositionAlpha+ ) where++import Foreign.Storable( Storable )+import Data.Bits( unsafeShiftR )+import Data.Word( Word8, Word32 )++import Codec.Picture.Types( Pixel( .. ), PackeablePixel( .. ) )++type Compositor px =+ PixelBaseComponent px ->+ PixelBaseComponent px -> px -> px -> px++-- | This constraint ensure that a type is a pixel+-- and we're allowed to modulate it's color components+-- generically.+type ModulablePixel px =+ ( Pixel px+ , PackeablePixel px+ , Storable (PackedRepresentation px)+ , Modulable (PixelBaseComponent px))++-- | This constraint tells us that pixel component+-- must also be pixel and be the "bottom" of component,+-- we cannot go further than a PixelBaseComponent level.+--+-- All pixel instances of JuicyPixels should be usable.+type RenderablePixel px =+ ( ModulablePixel px+ , Pixel (PixelBaseComponent px)+ , PackeablePixel (PixelBaseComponent px)+ , Num (PackedRepresentation px)+ , Num (PackedRepresentation (PixelBaseComponent px))+ , Storable (PackedRepresentation (PixelBaseComponent px))+ , PixelBaseComponent (PixelBaseComponent px)+ ~ (PixelBaseComponent px)+ )++-- | Typeclass intented at pixel value modulation.+-- May be throwed out soon.+class (Ord a, Num a) => Modulable a where+ -- | Empty value representing total transparency for the given type.+ emptyValue :: a+ -- | Full value representing total opacity for a given type.+ fullValue :: a+ -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue]+ -- The second value is the inverse coverage+ clampCoverage :: Float -> (a, a)++ -- | Modulate two elements, staying in the [emptyValue; fullValue] range.+ modulate :: a -> a -> a++ -- | Implement a division between two elements.+ modiv :: a -> a -> a++ alphaOver :: a -- ^ coverage+ -> a -- ^ inverse coverage+ -> a -- ^ background+ -> a -- ^ foreground+ -> a+ alphaCompose :: a -> a -> a -> a -> a++ -- | Like modulate but also return the inverse coverage.+ coverageModulate :: a -> a -> (a, a)+ coverageModulate c a = (clamped, fullValue - clamped)+ where clamped = modulate a c++instance Modulable Float where+ emptyValue = 0+ fullValue = 1+ clampCoverage f = (f, 1 - f)+ modulate = (*)+ modiv = (/)+ alphaCompose coverage inverseCoverage backAlpha _ =+ coverage + backAlpha * inverseCoverage+ alphaOver coverage inverseCoverage background painted =+ coverage * painted + background * inverseCoverage++div255 :: Word32 -> Word32+{-# INLINE div255 #-}+div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8++instance Modulable Word8 where+ {-# INLINE emptyValue #-}+ emptyValue = 0+ {-# INLINE fullValue #-}+ fullValue = 255+ {-# INLINE clampCoverage #-}+ clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c)+ where c = toWord8 f++ {-# INLINE modulate #-}+ modulate c a = fromIntegral . div255 $ fi c * fi a + 128+ where fi :: Word8 -> Word32+ fi = fromIntegral++ {-# INLINE modiv #-}+ modiv c 0 = c+ modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a+ where fi :: Word8 -> Word32+ fi = fromIntegral++ {-# INLINE alphaCompose #-}+ alphaCompose coverage inverseCoverage backgroundAlpha _ =+ fromIntegral $ div255 v+ where fi :: Word8 -> Word32+ fi = fromIntegral+ v = fi coverage * 255+ + fi backgroundAlpha * fi inverseCoverage + 128++ {-# INLINE alphaOver #-}+ alphaOver coverage inverseCoverage background painted =+ fromIntegral $ div255 v+ where fi :: Word8 -> Word32+ fi = fromIntegral+ v = fi coverage * fi painted + fi background * fi inverseCoverage + 128+++toWord8 :: Float -> Int+{-# INLINE toWord8 #-}+toWord8 r = floor $ r * 255 + 0.5++compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px))+ => Compositor px+compositionDestination c _ _ = colorMap (modulate c)++compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px))+ => Compositor px+{-# INLINE compositionAlpha #-}+compositionAlpha c ic+ | c == emptyValue = const+ | c == fullValue = \_ n -> n+ | otherwise = \bottom top ->+ let bottomOpacity = pixelOpacity bottom+ alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top)+ colorComposer _ back fore =+ alphaOver c ic (back `modulate` bottomOpacity) fore+ `modiv` alphaOut+ in+ mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top+
src/Graphics/Rasterific/CubicBezier.hs view
@@ -1,349 +1,349 @@-{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Graphics.Rasterific.CubicBezier - ( cubicBezierCircle - , cubicBezierFromPath - , cubicBezierBreakAt - , clipCubicBezier - , decomposeCubicBeziers - , sanitizeCubicBezier - , offsetCubicBezier - , flattenCubicBezier - , cubicBezierLengthApproximation - , cubicBezierBounds - ) where - -import Prelude hiding( or ) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( mempty ) -#endif - -import Data.Monoid( (<>) ) -import Control.Applicative( liftA2, (<$>)) -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , norm - , lerp - ) -import Data.List( nub ) -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticFormula - --- | Create a list of cubic bezier patch from a list of points. --- --- > cubicBezierFromPath [a, b, c, d, e] = [CubicBezier a b c d] --- > cubicBezierFromPath [a, b, c, d, e, f, g] = --- > [CubicBezier a b c d, CubicBezier d e f g] --- -cubicBezierFromPath :: [Point] -> [CubicBezier] -cubicBezierFromPath (a:b:c:rest@(d:_)) = - CubicBezier a b c d : cubicBezierFromPath rest -cubicBezierFromPath _ = [] - -cubicBezierLengthApproximation :: CubicBezier -> Float -cubicBezierLengthApproximation (CubicBezier a _ _ d) = - norm $ d ^-^ a - --- | Represent a circle of radius 1 centered on 0 of --- a cubic bezier curve. -cubicBezierCircle :: [CubicBezier] -cubicBezierCircle = - [ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0) - , CubicBezier (V2 1 0) (V2 1 (-c)) (V2 c (-1)) (V2 0 (-1)) - , CubicBezier (V2 0 (-1)) (V2 (-c) (-1)) (V2 (-1) (-c)) (V2 (-1) 0) - , CubicBezier (V2 (-1) 0) (V2 (-1) c) (V2 (-c) 1) (V2 0 1) - ] - where c = 0.551915024494 -- magic constant? magic constant. - -straightLine :: Point -> Point -> CubicBezier -straightLine a b = CubicBezier a p p b - where p = a `midPoint` b - -isSufficientlyFlat :: Float -- ^ Tolerance - -> CubicBezier - -> Bool -isSufficientlyFlat tol (CubicBezier a b c d) = - x + y <= tolerance - where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d - v = (c ^* 3) ^-^ (d ^* 2) ^-^ a - (^*^) = liftA2 (*) - V2 x y = vmax (u ^*^ u) (v ^*^ v) - tolerance = 16 * tol * tol - -splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point) -{-# INLINE splitCubicBezier #-} -splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd) - where - -- BC - -- B X----------X---------X C - -- ^ / ___/ \___ \ ^ - -- u \ / __X------X------X_ \ / v - -- \ /___/ ABBC BCCD \___\ / - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - ab = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d - - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd - -flattenCubicBezier :: CubicBezier -> Container Primitive -flattenCubicBezier bezier@(CubicBezier a _ _ d) - | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier - | otherwise = - flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> - flattenCubicBezier (CubicBezier abbcbccd bccd cd d) - where - (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier - --- 3 2 2 3 --- x(t) = (1 - t) ∙x + 3∙t∙(1 - t) ∙x + 3∙t ∙(1 - t)∙x + t ∙x --- 0 1 2 3 --- --- 3 2 2 3 --- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y --- 0 1 2 3 - --- Other representation: --- 3 2 2 3 --- B(t) = x(1 - t) + 3∙y∙t∙(1 - t) + 3∙z∙t ∙(1 - t) + w∙t - - --- | Represent the cubic bezier curve as a vector ready --- for matrix multiplication -data CachedBezier = CachedBezier - { _cachedA :: {-# UNPACK #-} !Float - , _cachedB :: {-# UNPACK #-} !Float - , _cachedC :: {-# UNPACK #-} !Float - , _cachedD :: {-# UNPACK #-} !Float - } - -cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier) -cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) = - (CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY) - where - V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3 - V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3 - V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0 - -cachedBezierAt :: CachedBezier -> Float -> Float -cachedBezierAt (CachedBezier a b c d) t = - a + b * t + c * tSquare + tCube * d - where - tSquare = t * t - tCube = tSquare * t - -cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float -cachedBezierDerivative (CachedBezier _ b c d) = - QuadraticFormula (3 * d) (2 * c) b - --- | Find the coefficient of the extremum points -extremums :: CachedBezier -> [Float] -extremums cached = - [ root | root <- formulaRoots $ cachedBezierDerivative cached - , 0 <= root && root <= 1.0 ] - -extremumPoints :: (CachedBezier, CachedBezier) -> [Point] -extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY) - where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at) - -cubicBezierBounds :: CubicBezier -> [Point] -cubicBezierBounds bez@(CubicBezier p0 _ _ p3) = - p0 : p3 : extremumPoints (cacheBezier bez) - -offsetCubicBezier :: Float -> CubicBezier -> Container Primitive -offsetCubicBezier offset bezier@(CubicBezier a b c d) - | isSufficientlyFlat 1 bezier = - pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD - | otherwise = - recurse (CubicBezier a ab abbc abbcbccd) <> - recurse (CubicBezier abbcbccd bccd cd d) - where - recurse = offsetCubicBezier offset - - u = a `normal` b - v = c `normal` d - - -- BC - -- B X----------X---------X C - -- ^ / ___/ \___ \ ^ - -- u \ / __X------X------X_ \ / v - -- \ /___/ ABBC BCCD \___\ / - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier - - w = ab `normal` bc - x = bc `normal` cd - - shiftedA = a ^+^ (u ^* offset) - shiftedD = d ^+^ (v ^* offset) - - {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-} - shiftedB = b ^+^ (w ^* offset) - shiftedC = c ^+^ (x ^* offset) - --- | Clamp the cubic bezier curve inside a rectangle --- given in parameter. -clipCubicBezier - :: Point -- ^ Point representing the "minimal" point for cliping - -> Point -- ^ Point representing the "maximal" point for cliping - -> CubicBezier -- ^ The cubic bezier curve to be clamped - -> Container Primitive -clipCubicBezier mini maxi bezier@(CubicBezier a b c d) - -- If we are in the range bound, return the curve - -- unaltered - | insideX && insideY = pure $ CubicBezierPrim bezier - -- If one of the component is outside, clamp - -- the components on the boundaries and output a - -- straight line on this boundary. Useful for the - -- filing case, to clamp the polygon drawing on - -- the edge - | outsideX || outsideY = - pure . CubicBezierPrim $ clampedA `straightLine` clampedD - -- Not completly inside nor outside, just divide - -- and conquer. - | otherwise = - recurse (CubicBezier a ab abbc m) <> - recurse (CubicBezier m bccd cd d) - where -- Minimal & maximal dimension of the bezier curve - bmin = vmin a . vmin b $ vmin c d - bmax = vmax a . vmax b $ vmax c d - - recurse = clipCubicBezier mini maxi - - clamper = clampPoint mini maxi - clampedA = clamper a - clampedD = clamper d - - V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi - V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin - - -- BC - -- B X----------X---------X C - -- / ___/ \___ \ - -- / __X------X------X_ \ - -- /___/ ABBC BCCD \___\ - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier - - edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) - edge = vpartition edgeSeparator mini maxi - m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd - --- | Will subdivide the bezier from 0 to coeff and coeff to 1 -cubicBezierBreakAt :: CubicBezier -> Float - -> (CubicBezier, CubicBezier) -cubicBezierBreakAt (CubicBezier a b c d) val = - (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d) - where - ab = lerp val a b - bc = lerp val b c - cd = lerp val c d - - abbc = lerp val ab bc - bccd = lerp val bc cd - abbcbccd = lerp val abbc bccd - -decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample -decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) = - go aRx aRy bRx bRy cRx cRy dRx dRy where - go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY = - let !px = fromIntegral $ min floorAx floorDx - !py = fromIntegral $ min floorAy floorDy - !w = px + 1 - (dx `middle` ax) - !h = dy - ay - in - EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont - where - floorAx, floorAy :: Int - !floorAx = floor ax - !floorAy = floor ay - - !floorDx = floor dx - !floorDy = floor dy - - !insideX = - floorAx == floorDx || ceiling ax == (ceiling dx :: Int) - !insideY = - floorAy == floorDy || ceiling ay == (ceiling dy :: Int) - - - go !ax !ay !bx !by !cx !cy !dx !dy cont = - go ax ay abx aby abbcx abbcy mx my $ - go mx my bccdx bccdy cdx cdy dx dy cont - where - -- BC - -- B X----------X---------X C - -- / ___/ \___ \ - -- / __X------X------X_ \ - -- /___/ ABBC BCCD \___\ - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - !abx = ax `middle` bx - !aby = ay `middle` by - !bcx = bx `middle` cx - !bcy = by `middle` cy - !cdx = cx `middle` dx - !cdy = cy `middle` dy - !abbcx = abx `middle` bcx - !abbcy = aby `middle` bcy - !bccdx = bcx `middle` cdx - !bccdy = bcy `middle` cdy - - !abbcbccdx = abbcx `middle` bccdx - !abbcbccdy = abbcy `middle` bccdy - - !mx | abs (abbcbccdx - mini) < 0.1 = mini - | abs (abbcbccdx - maxi) < 0.1 = maxi - | otherwise = abbcbccdx - where !mini = fromIntegral (floor abbcbccdx :: Int) - !maxi = fromIntegral (ceiling abbcbccdx :: Int) - - !my | abs (abbcbccdy - mini) < 0.1 = mini - | abs (abbcbccdy - maxi) < 0.1 = maxi - | otherwise = abbcbccdy - where !mini = fromIntegral (floor abbcbccdy :: Int) - !maxi = fromIntegral (ceiling abbcbccdy :: Int) - - -sanitizeCubicBezier :: CubicBezier -> Container Primitive -sanitizeCubicBezier bezier@(CubicBezier a b c d) - | a `isDistingableFrom` b && - c `isDistingableFrom` d = - pure . CubicBezierPrim $ bezier - | ac `isDistingableFrom` b && - bd `isDistingableFrom` c = - pure . CubicBezierPrim $ bezier - | ac `isDistingableFrom` b = - pure . CubicBezierPrim $ CubicBezier a ac c d - | bd `isDistingableFrom` c = - pure . CubicBezierPrim $ CubicBezier a b bd d - | otherwise = mempty - where ac = a `midPoint` c - bd = a `midPoint` d - +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.Rasterific.CubicBezier+ ( cubicBezierCircle+ , cubicBezierFromPath+ , cubicBezierBreakAt+ , clipCubicBezier+ , decomposeCubicBeziers+ , sanitizeCubicBezier+ , offsetCubicBezier+ , flattenCubicBezier+ , cubicBezierLengthApproximation+ , cubicBezierBounds+ ) where++import Prelude hiding( or )++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>), pure )+import Data.Monoid( mempty )+#endif++import Data.Monoid( (<>) )+import Control.Applicative( liftA2 )+import Graphics.Rasterific.Linear+ ( V2( .. )+ , (^-^)+ , (^+^)+ , (^*)+ , norm+ , lerp+ )+import Data.List( nub )+import Graphics.Rasterific.Operators+import Graphics.Rasterific.Types+import Graphics.Rasterific.QuadraticFormula++-- | Create a list of cubic bezier patch from a list of points.+--+-- > cubicBezierFromPath [a, b, c, d, e] = [CubicBezier a b c d]+-- > cubicBezierFromPath [a, b, c, d, e, f, g] =+-- > [CubicBezier a b c d, CubicBezier d e f g]+--+cubicBezierFromPath :: [Point] -> [CubicBezier]+cubicBezierFromPath (a:b:c:rest@(d:_)) =+ CubicBezier a b c d : cubicBezierFromPath rest+cubicBezierFromPath _ = []++cubicBezierLengthApproximation :: CubicBezier -> Float+cubicBezierLengthApproximation (CubicBezier a _ _ d) =+ norm $ d ^-^ a++-- | Represent a circle of radius 1 centered on 0 of+-- a cubic bezier curve.+cubicBezierCircle :: [CubicBezier]+cubicBezierCircle =+ [ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0)+ , CubicBezier (V2 1 0) (V2 1 (-c)) (V2 c (-1)) (V2 0 (-1))+ , CubicBezier (V2 0 (-1)) (V2 (-c) (-1)) (V2 (-1) (-c)) (V2 (-1) 0)+ , CubicBezier (V2 (-1) 0) (V2 (-1) c) (V2 (-c) 1) (V2 0 1)+ ]+ where c = 0.551915024494 -- magic constant? magic constant.++straightLine :: Point -> Point -> CubicBezier+straightLine a b = CubicBezier a p p b+ where p = a `midPoint` b++isSufficientlyFlat :: Float -- ^ Tolerance+ -> CubicBezier+ -> Bool+isSufficientlyFlat tol (CubicBezier a b c d) =+ x + y <= tolerance+ where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d+ v = (c ^* 3) ^-^ (d ^* 2) ^-^ a+ (^*^) = liftA2 (*)+ V2 x y = vmax (u ^*^ u) (v ^*^ v)+ tolerance = 16 * tol * tol++splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point)+{-# INLINE splitCubicBezier #-}+splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd)+ where+ -- BC+ -- B X----------X---------X C+ -- ^ / ___/ \___ \ ^+ -- u \ / __X------X------X_ \ / v+ -- \ /___/ ABBC BCCD \___\ /+ -- AB X/ \X CD+ -- / \+ -- / \+ -- / \+ -- A X X D+ ab = a `midPoint` b+ bc = b `midPoint` c+ cd = c `midPoint` d++ abbc = ab `midPoint` bc+ bccd = bc `midPoint` cd+ abbcbccd = abbc `midPoint` bccd++flattenCubicBezier :: CubicBezier -> Container Primitive+flattenCubicBezier bezier@(CubicBezier a _ _ d)+ | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier+ | otherwise =+ flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <>+ flattenCubicBezier (CubicBezier abbcbccd bccd cd d)+ where+ (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier++-- 3 2 2 3+-- x(t) = (1 - t) ∙x + 3∙t∙(1 - t) ∙x + 3∙t ∙(1 - t)∙x + t ∙x+-- 0 1 2 3+--+-- 3 2 2 3+-- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y+-- 0 1 2 3++-- Other representation:+-- 3 2 2 3+-- B(t) = x(1 - t) + 3∙y∙t∙(1 - t) + 3∙z∙t ∙(1 - t) + w∙t+++-- | Represent the cubic bezier curve as a vector ready+-- for matrix multiplication+data CachedBezier = CachedBezier+ { _cachedA :: {-# UNPACK #-} !Float+ , _cachedB :: {-# UNPACK #-} !Float+ , _cachedC :: {-# UNPACK #-} !Float+ , _cachedD :: {-# UNPACK #-} !Float+ }++cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier)+cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) =+ (CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY)+ where+ V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3+ V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3+ V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0++cachedBezierAt :: CachedBezier -> Float -> Float+cachedBezierAt (CachedBezier a b c d) t =+ a + b * t + c * tSquare + tCube * d+ where+ tSquare = t * t+ tCube = tSquare * t++cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float+cachedBezierDerivative (CachedBezier _ b c d) =+ QuadraticFormula (3 * d) (2 * c) b++-- | Find the coefficient of the extremum points+extremums :: CachedBezier -> [Float]+extremums cached =+ [ root | root <- formulaRoots $ cachedBezierDerivative cached+ , 0 <= root && root <= 1.0 ]++extremumPoints :: (CachedBezier, CachedBezier) -> [Point]+extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY)+ where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at)++cubicBezierBounds :: CubicBezier -> [Point]+cubicBezierBounds bez@(CubicBezier p0 _ _ p3) =+ p0 : p3 : extremumPoints (cacheBezier bez)++offsetCubicBezier :: Float -> CubicBezier -> Container Primitive+offsetCubicBezier offset bezier@(CubicBezier a b c d)+ | isSufficientlyFlat 1 bezier =+ pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD+ | otherwise =+ recurse (CubicBezier a ab abbc abbcbccd) <>+ recurse (CubicBezier abbcbccd bccd cd d)+ where+ recurse = offsetCubicBezier offset++ u = a `normal` b+ v = c `normal` d++ -- BC+ -- B X----------X---------X C+ -- ^ / ___/ \___ \ ^+ -- u \ / __X------X------X_ \ / v+ -- \ /___/ ABBC BCCD \___\ /+ -- AB X/ \X CD+ -- / \+ -- / \+ -- / \+ -- A X X D+ (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier++ w = ab `normal` bc+ x = bc `normal` cd++ shiftedA = a ^+^ (u ^* offset)+ shiftedD = d ^+^ (v ^* offset)++ {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-}+ shiftedB = b ^+^ (w ^* offset)+ shiftedC = c ^+^ (x ^* offset)++-- | Clamp the cubic bezier curve inside a rectangle+-- given in parameter.+clipCubicBezier+ :: Point -- ^ Point representing the "minimal" point for cliping+ -> Point -- ^ Point representing the "maximal" point for cliping+ -> CubicBezier -- ^ The cubic bezier curve to be clamped+ -> Container Primitive+clipCubicBezier mini maxi bezier@(CubicBezier a b c d)+ -- If we are in the range bound, return the curve+ -- unaltered+ | insideX && insideY = pure $ CubicBezierPrim bezier+ -- If one of the component is outside, clamp+ -- the components on the boundaries and output a+ -- straight line on this boundary. Useful for the+ -- filing case, to clamp the polygon drawing on+ -- the edge+ | outsideX || outsideY =+ pure . CubicBezierPrim $ clampedA `straightLine` clampedD+ -- Not completly inside nor outside, just divide+ -- and conquer.+ | otherwise =+ recurse (CubicBezier a ab abbc m) <>+ recurse (CubicBezier m bccd cd d)+ where -- Minimal & maximal dimension of the bezier curve+ bmin = vmin a . vmin b $ vmin c d+ bmax = vmax a . vmax b $ vmax c d++ recurse = clipCubicBezier mini maxi++ clamper = clampPoint mini maxi+ clampedA = clamper a+ clampedD = clamper d++ V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi+ V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin++ -- BC+ -- B X----------X---------X C+ -- / ___/ \___ \+ -- / __X------X------X_ \+ -- /___/ ABBC BCCD \___\+ -- AB X/ \X CD+ -- / \+ -- / \+ -- / \+ -- A X X D+ (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier++ edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi)+ edge = vpartition edgeSeparator mini maxi+ m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd++-- | Will subdivide the bezier from 0 to coeff and coeff to 1+cubicBezierBreakAt :: CubicBezier -> Float+ -> (CubicBezier, CubicBezier)+cubicBezierBreakAt (CubicBezier a b c d) val =+ (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d)+ where+ ab = lerp val a b+ bc = lerp val b c+ cd = lerp val c d++ abbc = lerp val ab bc+ bccd = lerp val bc cd+ abbcbccd = lerp val abbc bccd++decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample+decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) =+ go aRx aRy bRx bRy cRx cRy dRx dRy where+ go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY =+ let !px = fromIntegral $ min floorAx floorDx+ !py = fromIntegral $ min floorAy floorDy+ !w = px + 1 - (dx `middle` ax)+ !h = dy - ay+ in+ EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont+ where+ floorAx, floorAy :: Int+ !floorAx = floor ax+ !floorAy = floor ay++ !floorDx = floor dx+ !floorDy = floor dy++ !insideX =+ floorAx == floorDx || ceiling ax == (ceiling dx :: Int)+ !insideY =+ floorAy == floorDy || ceiling ay == (ceiling dy :: Int)+++ go !ax !ay !bx !by !cx !cy !dx !dy cont =+ go ax ay abx aby abbcx abbcy mx my $+ go mx my bccdx bccdy cdx cdy dx dy cont+ where+ -- BC+ -- B X----------X---------X C+ -- / ___/ \___ \+ -- / __X------X------X_ \+ -- /___/ ABBC BCCD \___\+ -- AB X/ \X CD+ -- / \+ -- / \+ -- / \+ -- A X X D+ !abx = ax `middle` bx+ !aby = ay `middle` by+ !bcx = bx `middle` cx+ !bcy = by `middle` cy+ !cdx = cx `middle` dx+ !cdy = cy `middle` dy+ !abbcx = abx `middle` bcx+ !abbcy = aby `middle` bcy+ !bccdx = bcx `middle` cdx+ !bccdy = bcy `middle` cdy++ !abbcbccdx = abbcx `middle` bccdx+ !abbcbccdy = abbcy `middle` bccdy++ !mx | abs (abbcbccdx - mini) < 0.1 = mini+ | abs (abbcbccdx - maxi) < 0.1 = maxi+ | otherwise = abbcbccdx+ where !mini = fromIntegral (floor abbcbccdx :: Int)+ !maxi = fromIntegral (ceiling abbcbccdx :: Int)++ !my | abs (abbcbccdy - mini) < 0.1 = mini+ | abs (abbcbccdy - maxi) < 0.1 = maxi+ | otherwise = abbcbccdy+ where !mini = fromIntegral (floor abbcbccdy :: Int)+ !maxi = fromIntegral (ceiling abbcbccdy :: Int)+++sanitizeCubicBezier :: CubicBezier -> Container Primitive+sanitizeCubicBezier bezier@(CubicBezier a b c d)+ | a `isDistingableFrom` b &&+ c `isDistingableFrom` d =+ pure . CubicBezierPrim $ bezier+ | ac `isDistingableFrom` b &&+ bd `isDistingableFrom` c =+ pure . CubicBezierPrim $ bezier+ | ac `isDistingableFrom` b =+ pure . CubicBezierPrim $ CubicBezier a ac c d+ | bd `isDistingableFrom` c =+ pure . CubicBezierPrim $ CubicBezier a b bd d+ | otherwise = mempty+ where ac = a `midPoint` c+ bd = a `midPoint` d+
src/Graphics/Rasterific/Immediate.hs view
@@ -1,184 +1,194 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} --- | This module implements drawing primitives to draw directly into --- the output texture, without generating an intermediate scene --- representation. --- --- If you need to draw complex scenes or plot an important set of --- data, this is the module you should use. The downside is that --- you must specify everything you need at each draw call, there --- is no API to help you propagate constants. --- --- The "stroking" must be done using the functions of the --- `Graphics.Rasterific.Outline` module. -module Graphics.Rasterific.Immediate - ( DrawContext - , DrawOrder( .. ) - , orderToDrawing - - , runDrawContext - , fillWithTextureAndMask - , fillWithTexture - , fillOrder - ) where - -import qualified Data.Foldable as F -import Control.Monad.Free( liftF ) -import Control.Monad.State( StateT, execStateT, get, lift ) -import Control.Monad.State.Class(MonadState) -import Codec.Picture.Types( Image( .. ) - , Pixel( .. ) - , MutableImage( .. ) - , unsafeFreezeImage - , fillImageWith ) - -import Control.Monad.Primitive( PrimState, PrimMonad, primToPrim ) -import qualified Data.Vector.Storable.Mutable as M -import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Linear( V2( .. ) ) -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Shading -import Graphics.Rasterific.Types -import Graphics.Rasterific.Command - --- | Monad used to describe the drawing context. -type DrawContext m px = - StateT (MutableImage (PrimState m) px) m - --- | Reify a filling function call, to be able to manipulate --- them in a simpler fashion. -data DrawOrder px = DrawOrder - { -- | Primitives to be filled. - _orderPrimitives :: ![[Primitive]] - -- | Texture for the filled primitives. - , _orderTexture :: !(Texture px) - -- | How to fill the primitives. - , _orderFillMethod :: !FillMethod - -- | Optional mask used for clipping. - , _orderMask :: !(Maybe (Texture (PixelBaseComponent px))) - } - --- | Transform back a low level drawing order to a more --- high level Drawing -orderToDrawing :: DrawOrder px -> Drawing px () -orderToDrawing order = - usingTexture . mapM_ filler $ _orderPrimitives order - where - usingTexture sub = - liftF $ SetTexture (_orderTexture order) sub () - filler prims = - liftF $ Fill (_orderFillMethod order) prims () - --- | Render the drawing orders on the canvas. -fillOrder :: (PrimMonad m, RenderablePixel px) - => DrawOrder px -> DrawContext m px () -fillOrder o@DrawOrder { _orderMask = Nothing } = - F.forM_ (_orderPrimitives o) $ - fillWithTexture (_orderFillMethod o) (_orderTexture o) -fillOrder o@DrawOrder { _orderMask = Just mask } = - F.forM_ (_orderPrimitives o) $ - fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask - --- | Start an image rendering. See `fillWithTexture` for --- an usage example. This function can work with either --- `IO` or `ST`. -runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> px -- ^ Background color - -> DrawContext m px () -- ^ Actual drawing computation - -> m (Image px) -runDrawContext width height background drawing = do - buff <- M.new (width * height * componentCount background) - let mutable = MutableImage width height buff - fillImageWith mutable background - img <- execStateT drawing mutable - unsafeFreezeImage img - -mapExec :: Monad m => (a -> m ()) -> [a] -> m () -mapExec f = foldr ((>>) . f) (return ()) - -isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool -isCoverageDrawable img coverage = - _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight - where - !imgWidth = fromIntegral $ mutableImageWidth img - !imgHeight = fromIntegral $ mutableImageHeight img - x = _coverageX coverage - y = _coverageY coverage - --- | Fill some geometry. --- --- > immediateDrawExample :: Image PixelRGBA8 --- > immediateDrawExample = runST $ --- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $ --- > 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) --- --- <<docimages/immediate_fill.png>> --- -fillWithTexture :: (PrimMonad m, RenderablePixel px, - MonadState (MutableImage (PrimState m) px) - (DrawContext m px) - ) - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling - -> [Primitive] -- ^ Primitives to fill - -> DrawContext m px () -fillWithTexture fillMethod texture els = do - img@(MutableImage width height _) <- get - let !mini = V2 0 0 - !maxi = V2 (fromIntegral width) (fromIntegral height) - !filler = primToPrim . transformTextureToFiller texture img - clipped = F.foldMap (clip mini maxi) els - spans = rasterize fillMethod clipped - lift . mapExec filler $ filter (isCoverageDrawable img) spans - --- | Fill some geometry using a composition mask for visibility. --- --- > 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 --- --- <<docimages/immediate_mask.png>> --- -fillWithTextureAndMask - :: ( PrimMonad m - , RenderablePixel px - , MonadState (MutableImage (PrimState m) px) - (DrawContext m px) - ) - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling of the geometry - -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask. - -> [Primitive] -- ^ Primitives to fill - -> DrawContext m px () -fillWithTextureAndMask fillMethod texture mask els = do - img@(MutableImage width height _) <- get - let !mini = V2 0 0 - !maxi = V2 (fromIntegral width) (fromIntegral height) - spans = rasterize fillMethod $ F.foldMap (clip mini maxi) els - !shader = primToPrim - . transformTextureToFiller (modulateTexture texture mask) img - lift . mapM_ shader $ filter (isCoverageDrawable img) spans - +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+-- | This module implements drawing primitives to draw directly into+-- the output texture, without generating an intermediate scene+-- representation.+--+-- If you need to draw complex scenes or plot an important set of+-- data, this is the module you should use. The downside is that+-- you must specify everything you need at each draw call, there+-- is no API to help you propagate constants.+--+-- The "stroking" must be done using the functions of the+-- `Graphics.Rasterific.Outline` module.+module Graphics.Rasterific.Immediate+ ( DrawContext+ , DrawOrder( .. )+ , orderToDrawing++ , runDrawContext+ , fillWithTextureAndMask+ , fillWithTexture+ , fillOrder+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Foldable( foldMap )+#endif++import qualified Data.Foldable as F+import Control.Monad.Free( liftF )+import Control.Monad.State( StateT, execStateT, get, lift )+import Control.Monad.State.Class(MonadState)+import Codec.Picture.Types( Image( .. )+ , Pixel( .. )+ , MutableImage( .. )+ , unsafeFreezeImage+ , fillImageWith )++import Control.Monad.Primitive( PrimState, PrimMonad, primToPrim )+import qualified Data.Vector.Storable.Mutable as M+import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Linear( V2( .. ) )+import Graphics.Rasterific.Rasterize+import Graphics.Rasterific.Texture+import Graphics.Rasterific.Shading+import Graphics.Rasterific.Types+import Graphics.Rasterific.Command+import Graphics.Rasterific.PlaneBoundable++-- | Monad used to describe the drawing context.+type DrawContext m px =+ StateT (MutableImage (PrimState m) px) m++-- | Reify a filling function call, to be able to manipulate+-- them in a simpler fashion.+data DrawOrder px = DrawOrder+ { -- | Primitives to be filled.+ _orderPrimitives :: ![[Primitive]]+ -- | Texture for the filled primitives.+ , _orderTexture :: !(Texture px)+ -- | How to fill the primitives.+ , _orderFillMethod :: !FillMethod+ -- | Optional mask used for clipping.+ , _orderMask :: !(Maybe (Texture (PixelBaseComponent px)))+ }++instance PlaneBoundable (DrawOrder px) where+ planeBounds =+ foldMap (foldMap planeBounds) . _orderPrimitives++-- | Transform back a low level drawing order to a more+-- high level Drawing+orderToDrawing :: DrawOrder px -> Drawing px ()+orderToDrawing order =+ usingTexture . mapM_ filler $ _orderPrimitives order+ where+ usingTexture sub =+ liftF $ SetTexture (_orderTexture order) sub ()+ filler prims =+ liftF $ Fill (_orderFillMethod order) prims ()++-- | Render the drawing orders on the canvas.+fillOrder :: (PrimMonad m, RenderablePixel px)+ => DrawOrder px -> DrawContext m px ()+fillOrder o@DrawOrder { _orderMask = Nothing } =+ F.forM_ (_orderPrimitives o) $+ fillWithTexture (_orderFillMethod o) (_orderTexture o)+fillOrder o@DrawOrder { _orderMask = Just mask } =+ F.forM_ (_orderPrimitives o) $+ fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask++-- | Start an image rendering. See `fillWithTexture` for+-- an usage example. This function can work with either+-- `IO` or `ST`.+runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px)+ => Int -- ^ Rendering width+ -> Int -- ^ Rendering height+ -> px -- ^ Background color+ -> DrawContext m px () -- ^ Actual drawing computation+ -> m (Image px)+runDrawContext width height background drawing = do+ buff <- M.new (width * height * componentCount background)+ let mutable = MutableImage width height buff+ fillImageWith mutable background+ img <- execStateT drawing mutable+ unsafeFreezeImage img++mapExec :: Monad m => (a -> m ()) -> [a] -> m ()+mapExec f = foldr ((>>) . f) (return ())++isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool+isCoverageDrawable img coverage =+ _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight+ where+ !imgWidth = fromIntegral $ mutableImageWidth img+ !imgHeight = fromIntegral $ mutableImageHeight img+ x = _coverageX coverage+ y = _coverageY coverage++-- | Fill some geometry.+--+-- > immediateDrawExample :: Image PixelRGBA8+-- > immediateDrawExample = runST $+-- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $+-- > 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)+--+-- <<docimages/immediate_fill.png>>+--+fillWithTexture :: (PrimMonad m, RenderablePixel px,+ MonadState (MutableImage (PrimState m) px)+ (DrawContext m px)+ )+ => FillMethod+ -> Texture px -- ^ Color/Texture used for the filling+ -> [Primitive] -- ^ Primitives to fill+ -> DrawContext m px ()+fillWithTexture fillMethod texture els = do+ img@(MutableImage width height _) <- get+ let !mini = V2 0 0+ !maxi = V2 (fromIntegral width) (fromIntegral height)+ !filler = primToPrim . transformTextureToFiller texture img+ clipped = foldMap (clip mini maxi) els+ spans = rasterize fillMethod clipped+ lift . mapExec filler $ filter (isCoverageDrawable img) spans++-- | Fill some geometry using a composition mask for visibility.+--+-- > 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+--+-- <<docimages/immediate_mask.png>>+--+fillWithTextureAndMask+ :: ( PrimMonad m+ , RenderablePixel px+ , MonadState (MutableImage (PrimState m) px)+ (DrawContext m px)+ )+ => FillMethod+ -> Texture px -- ^ Color/Texture used for the filling of the geometry+ -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask.+ -> [Primitive] -- ^ Primitives to fill+ -> DrawContext m px ()+fillWithTextureAndMask fillMethod texture mask els = do+ img@(MutableImage width height _) <- get+ let !mini = V2 0 0+ !maxi = V2 (fromIntegral width) (fromIntegral height)+ spans = rasterize fillMethod $ foldMap (clip mini maxi) els+ !shader = primToPrim+ . transformTextureToFiller (modulateTexture texture mask) img+ lift . mapM_ shader $ filter (isCoverageDrawable img) spans+
src/Graphics/Rasterific/Lenses.hs view
@@ -1,147 +1,146 @@-{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} --- | This module provide lenses compatible with the `lens` --- module but without the dependency to it. -module Graphics.Rasterific.Lenses - ( -- * Line lenses - lineX0 - , lineX1 - , linePoints - - -- * Quadratic bezier curve - , bezX0 - , bezX1 - , bezX2 - , bezierPoints - - -- * Cubic bezier lenses - , cbezX0 - , cbezX1 - , cbezX2 - , cbezX3 - , cubicBezierPoints - - -- * Primitive lenses - , primitivePoints - - -- * Path oriented lenses - , pathCommandPoints - , pathPoints - - -- * Type definition to match Lens - , Lens - , Lens' - , Traversal - , Traversal' - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Traversable( traverse ) -import Control.Applicative( Applicative, (<*>), pure ) -#endif - -import Control.Applicative( (<$>) ) -import Graphics.Rasterific.Types - --- | Does it look familiar? yes it's the official --- Lens type. -type Lens s t a b = - forall f. Functor f => (a -> f b) -> s -> f t - --- | Try to match the Lens' type alias. -type Lens' s a = Lens s s a a - --- | Traversal type, matched to the one of the lens --- package. -type Traversal s t a b = - forall f. Applicative f => (a -> f b) -> s -> f t - -type Traversal' s a = Traversal s s a a - --- | Create a full lens out of setter and getter -lens :: (s -> a) - -> (s -> b -> t) - -> Lens s t a b -{-# INLINE lens #-} -lens accessor setter = \f src -> - fmap (setter src) $ f (accessor src) - --- | Traverse all the points of a line. -linePoints :: Traversal' Line Point -linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1 - --- | Line origin point. -lineX0 :: Lens' Line Point -lineX0 = lens _lineX0 setter where - setter a b = a { _lineX0 = b } - --- | Line end point. -lineX1 :: Lens' Line Point -lineX1 = lens _lineX1 setter where - setter a b = a { _lineX1 = b } - --- | Quadratic bezier starting point. -bezX0 :: Lens' Bezier Point -bezX0 = lens _bezierX0 setter where - setter a b = a { _bezierX0 = b } - --- | bezier control point. -bezX1 :: Lens' Bezier Point -bezX1 = lens _bezierX1 setter where - setter a b = a { _bezierX1 = b } - --- | bezier end point. -bezX2 :: Lens' Bezier Point -bezX2 = lens _bezierX2 setter where - setter a b = a { _bezierX2 = b } - --- | Traversal of all the bezier's points. -bezierPoints :: Traversal' Bezier Point -bezierPoints f (Bezier p0 p1 p2) = - Bezier <$> f p0 <*> f p1 <*> f p2 - --- | Cubic bezier first point -cbezX0 :: Lens' CubicBezier Point -cbezX0 = lens _cBezierX0 setter where - setter a b = a { _cBezierX0 = b } - --- | Cubic bezier first control point. -cbezX1 :: Lens' CubicBezier Point -cbezX1 = lens _cBezierX1 setter where - setter a b = a { _cBezierX1 = b } - --- | Cubic bezier second control point. -cbezX2 :: Lens' CubicBezier Point -cbezX2 = lens _cBezierX2 setter where - setter a b = a { _cBezierX2 = b } - --- | Cubic bezier last point. -cbezX3 :: Lens' CubicBezier Point -cbezX3 = lens _cBezierX2 setter where - setter a b = a { _cBezierX3 = b } - --- | Traversal of all the points of the cubic bezier. -cubicBezierPoints :: Traversal' CubicBezier Point -cubicBezierPoints f (CubicBezier p0 p1 p2 p3) = - CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3 - --- | Traverse all the points defined in the primitive. -primitivePoints :: Traversal' Primitive Point -primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l -primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b -primitivePoints f (CubicBezierPrim c) = - CubicBezierPrim <$> cubicBezierPoints f c - --- | Traversal of all the points of a path -pathCommandPoints :: Traversal' PathCommand Point -pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p -pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) = - PathQuadraticBezierCurveTo <$> f p1 <*> f p2 -pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) = - PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3 - --- | Traversal of all the points in a path. -pathPoints :: Traversal' Path Point -pathPoints f (Path p0 yn comms) = - Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms - +{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+-- | This module provide lenses compatible with the `lens`+-- module but without the dependency to it.+module Graphics.Rasterific.Lenses+ ( -- * Line lenses+ lineX0+ , lineX1+ , linePoints++ -- * Quadratic bezier curve+ , bezX0+ , bezX1+ , bezX2+ , bezierPoints++ -- * Cubic bezier lenses+ , cbezX0+ , cbezX1+ , cbezX2+ , cbezX3+ , cubicBezierPoints++ -- * Primitive lenses+ , primitivePoints++ -- * Path oriented lenses+ , pathCommandPoints+ , pathPoints++ -- * Type definition to match Lens+ , Lens+ , Lens'+ , Traversal+ , Traversal'+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Traversable( traverse )+import Control.Applicative( Applicative, (<*>), (<$>), pure )+#endif++import Graphics.Rasterific.Types++-- | Does it look familiar? yes it's the official+-- Lens type.+type Lens s t a b =+ forall f. Functor f => (a -> f b) -> s -> f t++-- | Try to match the Lens' type alias.+type Lens' s a = Lens s s a a++-- | Traversal type, matched to the one of the lens+-- package.+type Traversal s t a b =+ forall f. Applicative f => (a -> f b) -> s -> f t++type Traversal' s a = Traversal s s a a++-- | Create a full lens out of setter and getter+lens :: (s -> a)+ -> (s -> b -> t)+ -> Lens s t a b+{-# INLINE lens #-}+lens accessor setter = \f src ->+ fmap (setter src) $ f (accessor src)++-- | Traverse all the points of a line.+linePoints :: Traversal' Line Point+linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1++-- | Line origin point.+lineX0 :: Lens' Line Point+lineX0 = lens _lineX0 setter where+ setter a b = a { _lineX0 = b }++-- | Line end point.+lineX1 :: Lens' Line Point+lineX1 = lens _lineX1 setter where+ setter a b = a { _lineX1 = b }++-- | Quadratic bezier starting point.+bezX0 :: Lens' Bezier Point+bezX0 = lens _bezierX0 setter where+ setter a b = a { _bezierX0 = b }++-- | bezier control point.+bezX1 :: Lens' Bezier Point+bezX1 = lens _bezierX1 setter where+ setter a b = a { _bezierX1 = b }++-- | bezier end point.+bezX2 :: Lens' Bezier Point+bezX2 = lens _bezierX2 setter where+ setter a b = a { _bezierX2 = b }++-- | Traversal of all the bezier's points.+bezierPoints :: Traversal' Bezier Point+bezierPoints f (Bezier p0 p1 p2) =+ Bezier <$> f p0 <*> f p1 <*> f p2++-- | Cubic bezier first point+cbezX0 :: Lens' CubicBezier Point+cbezX0 = lens _cBezierX0 setter where+ setter a b = a { _cBezierX0 = b }++-- | Cubic bezier first control point.+cbezX1 :: Lens' CubicBezier Point+cbezX1 = lens _cBezierX1 setter where+ setter a b = a { _cBezierX1 = b }++-- | Cubic bezier second control point.+cbezX2 :: Lens' CubicBezier Point+cbezX2 = lens _cBezierX2 setter where+ setter a b = a { _cBezierX2 = b }++-- | Cubic bezier last point.+cbezX3 :: Lens' CubicBezier Point+cbezX3 = lens _cBezierX2 setter where+ setter a b = a { _cBezierX3 = b }++-- | Traversal of all the points of the cubic bezier.+cubicBezierPoints :: Traversal' CubicBezier Point+cubicBezierPoints f (CubicBezier p0 p1 p2 p3) =+ CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3++-- | Traverse all the points defined in the primitive.+primitivePoints :: Traversal' Primitive Point+primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l+primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b+primitivePoints f (CubicBezierPrim c) =+ CubicBezierPrim <$> cubicBezierPoints f c++-- | Traversal of all the points of a path+pathCommandPoints :: Traversal' PathCommand Point+pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p+pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) =+ PathQuadraticBezierCurveTo <$> f p1 <*> f p2+pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) =+ PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3++-- | Traversal of all the points in a path.+pathPoints :: Traversal' Path Point+pathPoints f (Path p0 yn comms) =+ Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms+
src/Graphics/Rasterific/Line.hs view
@@ -1,164 +1,163 @@-{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} --- | Handle straight lines polygon. -module Graphics.Rasterific.Line - ( lineFromPath - , decomposeLine - , clipLine - , sanitizeLine - , lineBreakAt - , flattenLine - , lineLength - , offsetLine - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( mempty ) -#endif - -import Data.Monoid( (<>) ) -import Control.Applicative( (<$>) ) - -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , lerp - , norm ) - -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types - --- | Transform a list a point to a list of lines --- --- > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d] --- -lineFromPath :: [Point] -> [Line] -lineFromPath [] = [] -lineFromPath lst@(_:rest) = - uncurry Line <$> zip lst rest - -lineLength :: Line -> Float -lineLength (Line a b) = norm (b ^-^ a) - -sanitizeLine :: Line -> Container Primitive -sanitizeLine l@(Line p1 p2) - | p1 `isNearby` p2 = mempty - | otherwise = pure $ LinePrim l - -lineBreakAt :: Line -> Float -> (Line, Line) -lineBreakAt (Line a b) t = (Line a ab, Line ab b) - where ab = lerp t a b - -flattenLine :: Line -> Container Primitive -flattenLine = pure . LinePrim - -offsetLine :: Float -> Line -> Container Primitive -offsetLine offset (Line a b) = pure . LinePrim $ Line shiftedA shiftedB - where - u = a `normal` b - shiftedA = a ^+^ (u ^* offset) - shiftedB = b ^+^ (u ^* offset) - --- | Clamp the bezier curve inside a rectangle --- given in parameter. -clipLine :: Point -- ^ Point representing the "minimal" point for cliping - -> Point -- ^ Point representing the "maximal" point for cliping - -> Line -- ^ The line - -> Container Primitive -clipLine mini maxi poly@(Line a b) - -- If we are in the range bound, return the curve - -- unaltered - | insideX && insideY = pure . LinePrim $ poly - -- If one of the component is outside, clamp - -- the components on the boundaries and output a - -- straight line on this boundary. Useful for the - -- filing case, to clamp the polygon drawing on - -- the edge - | outsideX || outsideY = pure . LinePrim $ Line clampedA clampedB - - -- Not completly inside nor outside, just divide - -- and conquer. - | otherwise = recurse (Line a m) <> recurse (Line m b) - where -- Minimal & maximal dimension of the bezier curve - bmin = vmin a b - bmax = vmax a b - - recurse = clipLine mini maxi - - clamper = clampPoint mini maxi - clampedA = clamper a - clampedB = clamper b - - V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi - V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin - - -- A X-----X-----X B - -- AB - ab = a `midPoint` b - - -- mini - -- +-------------+ - -- | | - -- | | - -- | | - -- +-------------+ - -- maxi - -- the edgeSeparator vector encode which edge - -- is te nearest to the midpoint. - -- if True then it's the 'min' edges which are - -- the nearest, otherwise it's the maximum edge - edgeSeparator = - vabs (ab ^-^ mini) ^<^ vabs (ab ^-^ maxi) - - -- So here we 'solidify' the nearest edge position - -- in an edge vector. - edge = vpartition edgeSeparator mini maxi - - -- If we're near an edge, snap the component to the - -- edge. - m = vpartition (vabs (ab ^-^ edge) ^< 0.1) edge ab - --- TODO: implement better algorithm for lines, should --- be doable. -decomposeLine :: Line -> Producer EdgeSample -decomposeLine (Line (V2 aRx aRy) (V2 bRx bRy)) = go aRx aRy bRx bRy where - go !ax !ay !bx !by cont - | insideX && insideY = - let !px = fromIntegral $ min floorAx floorBx - !py = fromIntegral $ min floorAy floorBy - !w = px + 1 - (bx `middle` ax) - !h = by - ay - in - EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont - where - floorAx, floorAy :: Int - !floorAx = floor ax - !floorAy = floor ay - - !floorBx = floor bx - !floorBy = floor by - - !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int) - !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int) - - - go !ax !ay !bx !by cont = go ax ay mx my $ go mx my bx by cont - where - !abx = ax `middle` bx - !aby = ay `middle` by - - !mx | abs (abx - mini) < 0.1 = mini - | abs (abx - maxi) < 0.1 = maxi - | otherwise = abx - where !mini = fromIntegral (floor abx :: Int) - !maxi = fromIntegral (ceiling abx :: Int) - - !my | abs (aby - mini) < 0.1 = mini - | abs (aby - maxi) < 0.1 = maxi - | otherwise = aby - where !mini = fromIntegral (floor aby :: Int) - !maxi = fromIntegral (ceiling aby :: Int) - +{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+-- | Handle straight lines polygon.+module Graphics.Rasterific.Line+ ( lineFromPath+ , decomposeLine+ , clipLine+ , sanitizeLine+ , lineBreakAt+ , flattenLine+ , lineLength+ , offsetLine+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( pure, (<$>) )+import Data.Monoid( mempty )+#endif++import Data.Monoid( (<>) )++import Graphics.Rasterific.Linear+ ( V2( .. )+ , (^-^)+ , (^+^)+ , (^*)+ , lerp+ , norm )++import Graphics.Rasterific.Operators+import Graphics.Rasterific.Types++-- | Transform a list a point to a list of lines+--+-- > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d]+--+lineFromPath :: [Point] -> [Line]+lineFromPath [] = []+lineFromPath lst@(_:rest) =+ uncurry Line <$> zip lst rest++lineLength :: Line -> Float+lineLength (Line a b) = norm (b ^-^ a)++sanitizeLine :: Line -> Container Primitive+sanitizeLine l@(Line p1 p2)+ | p1 `isNearby` p2 = mempty+ | otherwise = pure $ LinePrim l++lineBreakAt :: Line -> Float -> (Line, Line)+lineBreakAt (Line a b) t = (Line a ab, Line ab b)+ where ab = lerp t a b++flattenLine :: Line -> Container Primitive+flattenLine = pure . LinePrim++offsetLine :: Float -> Line -> Container Primitive+offsetLine offset (Line a b) = pure . LinePrim $ Line shiftedA shiftedB+ where+ u = a `normal` b+ shiftedA = a ^+^ (u ^* offset)+ shiftedB = b ^+^ (u ^* offset)++-- | Clamp the bezier curve inside a rectangle+-- given in parameter.+clipLine :: Point -- ^ Point representing the "minimal" point for cliping+ -> Point -- ^ Point representing the "maximal" point for cliping+ -> Line -- ^ The line+ -> Container Primitive+clipLine mini maxi poly@(Line a b)+ -- If we are in the range bound, return the curve+ -- unaltered+ | insideX && insideY = pure . LinePrim $ poly+ -- If one of the component is outside, clamp+ -- the components on the boundaries and output a+ -- straight line on this boundary. Useful for the+ -- filing case, to clamp the polygon drawing on+ -- the edge+ | outsideX || outsideY = pure . LinePrim $ Line clampedA clampedB++ -- Not completly inside nor outside, just divide+ -- and conquer.+ | otherwise = recurse (Line a m) <> recurse (Line m b)+ where -- Minimal & maximal dimension of the bezier curve+ bmin = vmin a b+ bmax = vmax a b++ recurse = clipLine mini maxi++ clamper = clampPoint mini maxi+ clampedA = clamper a+ clampedB = clamper b++ V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi+ V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin++ -- A X-----X-----X B+ -- AB+ ab = a `midPoint` b++ -- mini+ -- +-------------++ -- | |+ -- | |+ -- | |+ -- +-------------++ -- maxi+ -- the edgeSeparator vector encode which edge+ -- is te nearest to the midpoint.+ -- if True then it's the 'min' edges which are+ -- the nearest, otherwise it's the maximum edge+ edgeSeparator =+ vabs (ab ^-^ mini) ^<^ vabs (ab ^-^ maxi)++ -- So here we 'solidify' the nearest edge position+ -- in an edge vector.+ edge = vpartition edgeSeparator mini maxi++ -- If we're near an edge, snap the component to the+ -- edge.+ m = vpartition (vabs (ab ^-^ edge) ^< 0.1) edge ab++-- TODO: implement better algorithm for lines, should+-- be doable.+decomposeLine :: Line -> Producer EdgeSample+decomposeLine (Line (V2 aRx aRy) (V2 bRx bRy)) = go aRx aRy bRx bRy where+ go !ax !ay !bx !by cont+ | insideX && insideY =+ let !px = fromIntegral $ min floorAx floorBx+ !py = fromIntegral $ min floorAy floorBy+ !w = px + 1 - (bx `middle` ax)+ !h = by - ay+ in+ EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont+ where+ floorAx, floorAy :: Int+ !floorAx = floor ax+ !floorAy = floor ay++ !floorBx = floor bx+ !floorBy = floor by++ !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int)+ !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int)+++ go !ax !ay !bx !by cont = go ax ay mx my $ go mx my bx by cont+ where+ !abx = ax `middle` bx+ !aby = ay `middle` by++ !mx | abs (abx - mini) < 0.1 = mini+ | abs (abx - maxi) < 0.1 = maxi+ | otherwise = abx+ where !mini = fromIntegral (floor abx :: Int)+ !maxi = fromIntegral (ceiling abx :: Int)++ !my | abs (aby - mini) < 0.1 = mini+ | abs (aby - maxi) < 0.1 = maxi+ | otherwise = aby+ where !mini = fromIntegral (floor aby :: Int)+ !maxi = fromIntegral (ceiling aby :: Int)+
src/Graphics/Rasterific/Operators.hs view
@@ -1,165 +1,162 @@-{-# LANGUAGE CPP #-} --- | Module providing basic helper functions to help --- build vector/point calculations. -module Graphics.Rasterific.Operators - ( -- * Lifted operators - (^&&^) - , (^||^) - , (^==^) - , (^/=^) - , (^<=^) - , (^<^) - , (^<) - - -- * Lifted functions - , vmin - , vmax - , vabs - , vfloor - , vceil - , clampPoint - , midPoint - , middle - , vpartition - , normal - , ifZero - , isNearby - , isDistingableFrom - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( Applicative ) -#endif -import Control.Applicative( liftA2 - , liftA3 - , (<$>) - ) - -import Graphics.Rasterific.Linear - ( V2( .. ) - , Additive( .. ) - , Epsilon( nearZero ) - , (^+^) - , (^*) - , dot - , normalize - ) - -import Graphics.Rasterific.Types - -infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ -infixr 3 ^&&^ -infixr 2 ^||^ - --- | Pairwise boolean and operator -(^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool -{-# INLINE (^&&^) #-} -(^&&^) = liftA2 (&&) - --- | Pairwise boolean or operator -(^||^) :: (Applicative a) => a Bool -> a Bool -> a Bool -{-# INLINE (^||^) #-} -(^||^) = liftA2 (||) - --- | Pairwise vector/point equal operator -(^==^) :: (Eq v, Applicative a) => a v -> a v -> a Bool -{-# INLINE (^==^) #-} -(^==^) = liftA2 (==) - --- | Pairwise vector/point lower than or equal operator -(^<=^) :: (Ord v, Applicative a) => a v -> a v -> a Bool -{-# INLINE (^<=^) #-} -(^<=^) = liftA2 (<=) - --- | Pairwise vector/point lower than operator -(^<^) :: (Ord v, Applicative a) => a v -> a v -> a Bool -{-# INLINE (^<^) #-} -(^<^) = liftA2 (<) - --- | Component/scalar lower than operator. -(^<) :: (Applicative a, Ord v) => a v -> v -> a Bool -{-# INLINE (^<) #-} -(^<) vec v = (< v) <$> vec - --- | Pairwise vector/point difference operator. -(^/=^) :: (Applicative a, Eq v) => a v -> a v -> a Bool -{-# INLINE (^/=^) #-} -(^/=^) = liftA2 (/=) - --- | Min function between two vector/points. --- Work on every component separately. -vmin :: (Ord n, Applicative a) => a n -> a n -> a n -{-# INLINE vmin #-} -vmin = liftA2 min - --- | Max function between to vector/point. --- Work on every component separatly. -vmax :: (Ord n, Applicative a) => a n -> a n -> a n -{-# INLINE vmax #-} -vmax = liftA2 max - --- | Abs function for every component of the vector/point. -vabs :: (Num n, Functor a) => a n -> a n -{-# INLINE vabs #-} -vabs = fmap abs - --- | Floor function for every component of the vector/point. -vfloor :: (Functor a) => a Float -> a Int -{-# INLINE vfloor #-} -vfloor = fmap floor - --- | ceil function for every component of the vector/point. -vceil :: (Functor a) => a Float -> a Int -{-# INLINE vceil #-} -vceil = fmap ceiling - --- | Given a point, clamp every coordinates between --- a given minimum and maximum. -clampPoint :: Point -> Point -> Point -> Point -{-# INLINE clampPoint #-} -clampPoint mini maxi v = vmin maxi $ vmax mini v - --- | Given two points, return a point in the middle --- of them. -midPoint :: (Additive a) => a Float -> a Float -> a Float -{-# INLINE midPoint #-} -midPoint a b = (a ^+^ b) ^* 0.5 - -middle :: (Fractional a) => a -> a -> a -{-# INLINE middle #-} -middle a b = (a + b) * 0.5 - --- | Given a boolean choice vector, return elements of --- the first one if true, of the second one otherwise. -vpartition :: (Applicative a) => a Bool -> a v -> a v -> a v -{-# INLINE vpartition #-} -vpartition = liftA3 choose - where choose True a _ = a - choose False _ b = b - --- | Calculate a normal vector -normal :: (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v -{-# INLINE normal #-} -normal (V2 ax ay) (V2 bx by) = normalize $ V2 (ay - by) (bx - ax) - --- | Return the second operand if the vector is --- nearly null -ifZero :: (Epsilon v) => v -> v -> v -{-# INLINE ifZero #-} -ifZero u v | nearZero u = v - | otherwise = u - --- | Tell if two points are nearly indistinguishable. --- If indistinguishable, we can treat them as the same --- point. -isNearby :: Point -> Point -> Bool -{-# INLINE isNearby #-} -isNearby p1 p2 = squareDist < 0.0001 - where vec = p1 ^-^ p2 - squareDist = vec `dot` vec - --- | simply `not (a `isNearby` b)` -isDistingableFrom :: Point -> Point -> Bool -{-# INLINE isDistingableFrom #-} -isDistingableFrom a b = not $ isNearby a b - +{-# LANGUAGE CPP #-}+-- | Module providing basic helper functions to help+-- build vector/point calculations.+module Graphics.Rasterific.Operators+ ( -- * Lifted operators+ (^&&^)+ , (^||^)+ , (^==^)+ , (^/=^)+ , (^<=^)+ , (^<^)+ , (^<)++ -- * Lifted functions+ , vmin+ , vmax+ , vabs+ , vfloor+ , vceil+ , clampPoint+ , midPoint+ , middle+ , vpartition + , normal+ , ifZero+ , isNearby+ , isDistingableFrom+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( Applicative, (<$>) )+#endif+import Control.Applicative( liftA2, liftA3 )++import Graphics.Rasterific.Linear+ ( V2( .. )+ , Additive( .. )+ , Epsilon( nearZero )+ , (^+^)+ , (^*)+ , dot+ , normalize+ )++import Graphics.Rasterific.Types++infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^+infixr 3 ^&&^+infixr 2 ^||^++-- | Pairwise boolean and operator+(^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool+{-# INLINE (^&&^) #-}+(^&&^) = liftA2 (&&)++-- | Pairwise boolean or operator+(^||^) :: (Applicative a) => a Bool -> a Bool -> a Bool+{-# INLINE (^||^) #-}+(^||^) = liftA2 (||)++-- | Pairwise vector/point equal operator+(^==^) :: (Eq v, Applicative a) => a v -> a v -> a Bool+{-# INLINE (^==^) #-}+(^==^) = liftA2 (==)++-- | Pairwise vector/point lower than or equal operator+(^<=^) :: (Ord v, Applicative a) => a v -> a v -> a Bool+{-# INLINE (^<=^) #-}+(^<=^) = liftA2 (<=)++-- | Pairwise vector/point lower than operator+(^<^) :: (Ord v, Applicative a) => a v -> a v -> a Bool+{-# INLINE (^<^) #-}+(^<^) = liftA2 (<)++-- | Component/scalar lower than operator.+(^<) :: (Applicative a, Ord v) => a v -> v -> a Bool+{-# INLINE (^<) #-}+(^<) vec v = (< v) <$> vec++-- | Pairwise vector/point difference operator.+(^/=^) :: (Applicative a, Eq v) => a v -> a v -> a Bool+{-# INLINE (^/=^) #-}+(^/=^) = liftA2 (/=)++-- | Min function between two vector/points.+-- Work on every component separately.+vmin :: (Ord n, Applicative a) => a n -> a n -> a n+{-# INLINE vmin #-}+vmin = liftA2 min++-- | Max function between to vector/point.+-- Work on every component separatly.+vmax :: (Ord n, Applicative a) => a n -> a n -> a n+{-# INLINE vmax #-}+vmax = liftA2 max++-- | Abs function for every component of the vector/point.+vabs :: (Num n, Functor a) => a n -> a n+{-# INLINE vabs #-}+vabs = fmap abs++-- | Floor function for every component of the vector/point.+vfloor :: (Functor a) => a Float -> a Int+{-# INLINE vfloor #-}+vfloor = fmap floor++-- | ceil function for every component of the vector/point.+vceil :: (Functor a) => a Float -> a Int+{-# INLINE vceil #-}+vceil = fmap ceiling++-- | Given a point, clamp every coordinates between+-- a given minimum and maximum.+clampPoint :: Point -> Point -> Point -> Point+{-# INLINE clampPoint #-}+clampPoint mini maxi v = vmin maxi $ vmax mini v++-- | Given two points, return a point in the middle+-- of them.+midPoint :: (Additive a) => a Float -> a Float -> a Float+{-# INLINE midPoint #-}+midPoint a b = (a ^+^ b) ^* 0.5++middle :: (Fractional a) => a -> a -> a+{-# INLINE middle #-}+middle a b = (a + b) * 0.5++-- | Given a boolean choice vector, return elements of+-- the first one if true, of the second one otherwise.+vpartition :: (Applicative a) => a Bool -> a v -> a v -> a v+{-# INLINE vpartition #-}+vpartition = liftA3 choose+ where choose True a _ = a+ choose False _ b = b++-- | Calculate a normal vector+normal :: (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v+{-# INLINE normal #-}+normal (V2 ax ay) (V2 bx by) = normalize $ V2 (ay - by) (bx - ax)++-- | Return the second operand if the vector is+-- nearly null+ifZero :: (Epsilon v) => v -> v -> v+{-# INLINE ifZero #-}+ifZero u v | nearZero u = v+ | otherwise = u++-- | Tell if two points are nearly indistinguishable.+-- If indistinguishable, we can treat them as the same+-- point.+isNearby :: Point -> Point -> Bool+{-# INLINE isNearby #-}+isNearby p1 p2 = squareDist < 0.0001+ where vec = p1 ^-^ p2+ squareDist = vec `dot` vec++-- | simply `not (a `isNearby` b)`+isDistingableFrom :: Point -> Point -> Bool+{-# INLINE isDistingableFrom #-}+isDistingableFrom a b = not $ isNearby a b+
src/Graphics/Rasterific/PathWalker.hs view
@@ -1,131 +1,128 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | This module help the walking of path of any shape, --- being able to return the current position and the --- actual orientation. -module Graphics.Rasterific.PathWalker( PathWalkerT - , PathWalker - , PathDrawer - , runPathWalking - , advanceBy - , currentPosition - , currentTangeant - , drawOrdersOnPath - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable( foldMap ) -import Data.Monoid( mempty ) -import Control.Applicative( Applicative, (<*>) ) -#endif - -import Data.Monoid( (<>) ) -import Control.Applicative( (<$>) ) - -import Control.Monad.Identity( Identity ) -import Control.Monad.State( StateT - , MonadTrans - , lift - , evalStateT - , modify - , gets ) -import Data.Maybe( fromMaybe ) - -import Graphics.Rasterific.Types -import Graphics.Rasterific.Linear -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.StrokeInternal -import Graphics.Rasterific.PlaneBoundable -import Graphics.Rasterific.Immediate - --- | The walking transformer monad. -newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a) - deriving (Monad, Applicative, Functor, MonadTrans) - --- | Simpler alias if monad transformers are not --- needed. -type PathWalker a = PathWalkerT Identity a - --- | State of the path walker, just a bunch of primitives --- with continuity guarantee. The continuity is guaranteed --- by the Path used to derive this primitives. -data WalkerState = WalkerState - { _walkerPrims :: ![Primitive] - } - --- | Create a path walker from a given path -runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a -runPathWalking path (PathWalkerT walker) = evalStateT walker initialState - where - initialState = WalkerState primsOfPath - primsOfPath = listOfContainer - . flatten - . containerOfList - $ pathToPrimitives path - --- | Advance by the given amount of pixels on the path. -advanceBy :: Monad m => Float -> PathWalkerT m () -advanceBy by = PathWalkerT . modify $ \s -> - let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in - s { _walkerPrims = leftPrimitives } - --- | Obtain the current position if we are still on the --- path, if not, return Nothing. -currentPosition :: (Monad m) => PathWalkerT m (Maybe Point) -currentPosition = PathWalkerT $ gets (currPos . _walkerPrims) - where - currPos [] = Nothing - currPos (prim:_) = Just $ firstPointOf prim - --- | Obtain the current tangeant of the path if we're still --- on it. Return Nothing otherwise. -currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector) -currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims) - where - currTangeant [] = Nothing - currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim - --- | Callback function in charge to transform the DrawOrder --- given the transformation to place it on the path. -type PathDrawer m px = - Transformation -> PlaneBound -> DrawOrder px -> m () - --- | This function is the workhorse of the placement, it will --- walk the path and calculate the appropriate transformation --- for every order. -drawOrdersOnPath :: Monad m - => PathDrawer m px -- ^ Function handling the placement of the order. - -> Float -- ^ Starting offset - -> Float -- ^ Baseline vertical position in the orders. - -> Path -- ^ Path on which to place the orders. - -> [DrawOrder px] -- ^ Orders to place on a path. - -> m () -drawOrdersOnPath drawer startOffset baseline path orders = - runPathWalking path $ advanceBy startOffset >> go Nothing orders where - go _ [] = return () - go prevX (img : rest) = do - let bounds = - foldMap (foldMap planeBounds) $ _orderPrimitives img - width = boundWidth bounds - cx = fromMaybe startX prevX - V2 startX _ = boundLowerLeftCorner bounds - V2 endX _ = _planeMaxBound bounds - halfWidth = width / 2 - spaceWidth = abs $ startX - cx - translation = V2 (negate startX - halfWidth) (- baseline) - - if bounds == mempty then go prevX rest - else do - advanceBy (halfWidth + spaceWidth) - mayPos <- currentPosition - mayDir <- currentTangeant - case (,) <$> mayPos <*> mayDir of - Nothing -> return () -- out of path, stop drawing - Just (pos, dir) -> do - let imageTransform = - translate pos <> toNewXBase dir - <> translate translation - lift $ drawer imageTransform bounds img - advanceBy halfWidth - go (Just endX) rest - +{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+-- | This module help the walking of path of any shape,+-- being able to return the current position and the+-- actual orientation.+module Graphics.Rasterific.PathWalker( PathWalkerT+ , PathWalker+ , PathDrawer+ , runPathWalking+ , advanceBy+ , currentPosition+ , currentTangeant+ , drawOrdersOnPath+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( Applicative, (<*>), (<$>) )+#endif++import Data.Monoid( (<>) )++import Control.Monad.Identity( Identity )+import Control.Monad.State( StateT+ , MonadTrans+ , lift+ , evalStateT+ , modify+ , gets )+import Data.Maybe( fromMaybe )++import Graphics.Rasterific.Types+import Graphics.Rasterific.Linear+import Graphics.Rasterific.Transformations+import Graphics.Rasterific.StrokeInternal+import Graphics.Rasterific.PlaneBoundable+import Graphics.Rasterific.Immediate++-- | The walking transformer monad.+newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a)+ deriving (Monad, Applicative, Functor, MonadTrans)++-- | Simpler alias if monad transformers are not+-- needed.+type PathWalker a = PathWalkerT Identity a++-- | State of the path walker, just a bunch of primitives+-- with continuity guarantee. The continuity is guaranteed+-- by the Path used to derive this primitives.+data WalkerState = WalkerState+ { _walkerPrims :: ![Primitive]+ }++-- | Create a path walker from a given path+runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a+runPathWalking path (PathWalkerT walker) = evalStateT walker initialState+ where+ initialState = WalkerState primsOfPath+ primsOfPath = listOfContainer+ . flatten+ . containerOfList+ $ pathToPrimitives path++-- | Advance by the given amount of pixels on the path.+advanceBy :: Monad m => Float -> PathWalkerT m ()+advanceBy by = PathWalkerT . modify $ \s ->+ let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in+ s { _walkerPrims = leftPrimitives }++-- | Obtain the current position if we are still on the+-- path, if not, return Nothing.+currentPosition :: (Monad m) => PathWalkerT m (Maybe Point)+currentPosition = PathWalkerT $ gets (currPos . _walkerPrims)+ where+ currPos [] = Nothing+ currPos (prim:_) = Just $ firstPointOf prim++-- | Obtain the current tangeant of the path if we're still+-- on it. Return Nothing otherwise.+currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector)+currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims)+ where+ currTangeant [] = Nothing+ currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim++-- | Callback function in charge to transform the DrawOrder+-- given the transformation to place it on the path.+type PathDrawer m px =+ Transformation -> PlaneBound -> DrawOrder px -> m ()++-- | This function is the workhorse of the placement, it will+-- walk the path and calculate the appropriate transformation+-- for every order.+drawOrdersOnPath :: Monad m+ => PathDrawer m px -- ^ Function handling the placement of the order.+ -> Float -- ^ Starting offset+ -> Float -- ^ Baseline vertical position in the orders.+ -> Path -- ^ Path on which to place the orders.+ -> [DrawOrder px] -- ^ Orders to place on a path.+ -> m ()+drawOrdersOnPath drawer startOffset baseline path orders =+ runPathWalking path $ advanceBy startOffset >> go Nothing orders where+ go _ [] = return ()+ go prevX (img : rest) = do+ let bounds = planeBounds img+ width = boundWidth bounds+ cx = fromMaybe startX prevX+ V2 startX _ = boundLowerLeftCorner bounds+ V2 endX _ = _planeMaxBound bounds+ halfWidth = width / 2+ spaceWidth = abs $ startX - cx+ translation = V2 (negate startX - halfWidth) (- baseline)++ if bounds == mempty then go prevX rest+ else do+ advanceBy (halfWidth + spaceWidth)+ mayPos <- currentPosition+ mayDir <- currentTangeant+ case (,) <$> mayPos <*> mayDir of+ Nothing -> return () -- out of path, stop drawing+ Just (pos, dir) -> do+ let imageTransform =+ translate pos <> toNewXBase dir+ <> translate translation+ lift $ drawer imageTransform bounds img+ advanceBy halfWidth+ go (Just endX) rest+
src/Graphics/Rasterific/PlaneBoundable.hs view
@@ -1,88 +1,87 @@-{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} --- | Module implementing types used for geometry --- bound calculations. -module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. ) - , PlaneBoundable( .. ) - , boundWidth - , boundHeight - , boundLowerLeftCorner - ) where - -#if !MIN_VERSION_base(4,8,0) --- to be removed with GHC 7.12 ? -import Control.Applicative( (<*>) ) -import Data.Monoid( Monoid( .. ) ) -import Data.Foldable( foldMap ) -#endif - -import Control.Applicative( (<$>) ) -import Data.Monoid( (<>) ) - -import Graphics.Rasterific.Linear( V2( .. ) ) -import Graphics.Rasterific.Types -import Graphics.Rasterific.CubicBezier - --- | Represent the minimal axis aligned rectangle --- in which some primitives can be drawn. Should --- fit to bezier curve and not use directly their --- control points. -data PlaneBound = PlaneBound - { -- | Corner upper left of the bounding box of - -- the considered primitives. - _planeMinBound :: !Point - -- | Corner lower right of the bounding box of - -- the considered primitives. - , _planeMaxBound :: !Point - } - deriving (Eq, Show) - --- | Extract the width of the bounds -boundWidth :: PlaneBound -> Float -boundWidth (PlaneBound (V2 x0 _) (V2 x1 _)) = x1 - x0 - --- | Extract the height of the bound -boundHeight :: PlaneBound -> Float -boundHeight (PlaneBound (V2 _ y0) (V2 _ y1)) = y1 - y0 - --- | Extract the position of the lower left corner of the --- bounds. -boundLowerLeftCorner :: PlaneBound -> Point -boundLowerLeftCorner (PlaneBound (V2 x _) (V2 _ y)) = V2 x y - -instance Monoid PlaneBound where - mempty = PlaneBound infPoint negInfPoint - where - infPoint = V2 (1 / 0) (1 / 0) - negInfPoint = V2 (negate 1 / 0) (negate 1 / 0) - - mappend (PlaneBound mini1 maxi1) (PlaneBound mini2 maxi2) = - PlaneBound (min <$> mini1 <*> mini2) - (max <$> maxi1 <*> maxi2) - --- | Class used to calculate bounds of various geometrical --- primitives. The calculated is precise, the bounding should --- be minimal with respect with drawn curve. -class PlaneBoundable a where - -- | Given a graphical elements, calculate it's bounds. - planeBounds :: a -> PlaneBound - -instance PlaneBoundable Point where - planeBounds a = PlaneBound a a - -instance PlaneBoundable Line where - planeBounds (Line p1 p2) = planeBounds p1 <> planeBounds p2 - -instance PlaneBoundable Bezier where - planeBounds (Bezier p0 p1 p2) = - planeBounds (CubicBezier p0 p1 p1 p2) - -instance PlaneBoundable CubicBezier where - planeBounds = foldMap planeBounds . cubicBezierBounds - -instance PlaneBoundable Primitive where - planeBounds (LinePrim l) = planeBounds l - planeBounds (BezierPrim b) = planeBounds b - planeBounds (CubicBezierPrim c) = planeBounds c - +{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+-- | Module implementing types used for geometry+-- bound calculations.+module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. )+ , PlaneBoundable( .. )+ , boundWidth+ , boundHeight+ , boundLowerLeftCorner+ ) where++#if !MIN_VERSION_base(4,8,0)+-- to be removed with GHC 7.12 ?+import Control.Applicative( (<$>), (<*>) )+import Data.Monoid( Monoid( .. ) )+import Data.Foldable( Foldable( foldMap ) )+#endif++import Data.Monoid( (<>) )++import Graphics.Rasterific.Linear( V2( .. ) )+import Graphics.Rasterific.Types+import Graphics.Rasterific.CubicBezier++-- | Represent the minimal axis aligned rectangle+-- in which some primitives can be drawn. Should+-- fit to bezier curve and not use directly their+-- control points.+data PlaneBound = PlaneBound+ { -- | Corner upper left of the bounding box of+ -- the considered primitives.+ _planeMinBound :: !Point+ -- | Corner lower right of the bounding box of+ -- the considered primitives.+ , _planeMaxBound :: !Point+ }+ deriving (Eq, Show)++-- | Extract the width of the bounds+boundWidth :: PlaneBound -> Float+boundWidth (PlaneBound (V2 x0 _) (V2 x1 _)) = x1 - x0++-- | Extract the height of the bound+boundHeight :: PlaneBound -> Float+boundHeight (PlaneBound (V2 _ y0) (V2 _ y1)) = y1 - y0++-- | Extract the position of the lower left corner of the+-- bounds.+boundLowerLeftCorner :: PlaneBound -> Point+boundLowerLeftCorner (PlaneBound (V2 x _) (V2 _ y)) = V2 x y++instance Monoid PlaneBound where+ mempty = PlaneBound infPoint negInfPoint+ where+ infPoint = V2 (1 / 0) (1 / 0)+ negInfPoint = V2 (negate 1 / 0) (negate 1 / 0)++ mappend (PlaneBound mini1 maxi1) (PlaneBound mini2 maxi2) =+ PlaneBound (min <$> mini1 <*> mini2)+ (max <$> maxi1 <*> maxi2)++-- | Class used to calculate bounds of various geometrical+-- primitives. The calculated is precise, the bounding should+-- be minimal with respect with drawn curve.+class PlaneBoundable a where+ -- | Given a graphical elements, calculate it's bounds.+ planeBounds :: a -> PlaneBound++instance PlaneBoundable Point where+ planeBounds a = PlaneBound a a++instance PlaneBoundable Line where+ planeBounds (Line p1 p2) = planeBounds p1 <> planeBounds p2++instance PlaneBoundable Bezier where+ planeBounds (Bezier p0 p1 p2) =+ planeBounds (CubicBezier p0 p1 p1 p2)++instance PlaneBoundable CubicBezier where+ planeBounds = foldMap planeBounds . cubicBezierBounds++instance PlaneBoundable Primitive where+ planeBounds (LinePrim l) = planeBounds l+ planeBounds (BezierPrim b) = planeBounds b+ planeBounds (CubicBezierPrim c) = planeBounds c+
src/Graphics/Rasterific/Shading.hs view
@@ -1,490 +1,493 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -module Graphics.Rasterific.Shading - ( Texture( .. ) - , Gradient - , ShaderFunction - , transformTextureToFiller - , dumpTexture - ) where - -import Control.Monad.Primitive( PrimState - -- one day (GHC >= 7.10 ?) - {-, PrimMonad-} - ) -import Data.Fixed( mod' ) -import Data.Monoid( (<>) ) -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^/) - , dot - , norm - ) - - -import Control.Monad.ST( ST ) -import qualified Data.Vector as V - -import Codec.Picture.Types( Pixel( .. ) - , Image( .. ) - , MutableImage( .. ) - , Pixel8 - , PixelRGBA8 - , unsafeWritePixelBetweenAt - , readPackedPixelAt - , writePackedPixelAt - ) - -import Graphics.Rasterific.Types( Point - , Vector - , Line( .. ) - , SamplerRepeat( .. ) ) -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Compositor( Modulable( .. ) - , ModulablePixel - , RenderablePixel - , compositionAlpha ) - -type ShaderFunction px = Float -> Float -> px - --- | Reification of texture type -data Texture px - = SolidTexture !px - | LinearGradientTexture !(Gradient px) !Line - | RadialGradientTexture !(Gradient px) !Point !Float - | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point - | WithSampler !SamplerRepeat (Texture px) - | WithTextureTransform !Transformation (Texture px) - | SampledTexture !(Image px) - | RawTexture !(Image px) - | ShaderTexture !(ShaderFunction px) - | ModulateTexture (Texture px) (Texture (PixelBaseComponent px)) - -dumpTexture :: ( Show px - , Show (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - ) => Texture px -> String -dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px++ ")" -dumpTexture (LinearGradientTexture grad (Line a b)) = - "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")" -dumpTexture (RadialGradientTexture grad p rad) = - "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad -dumpTexture (RadialGradientWithFocusTexture grad center rad focus) = - "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center - ++ ") " ++ show rad ++ " (" ++ show focus ++ ")" -dumpTexture (WithSampler sampler sub) = - "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")" -dumpTexture (WithTextureTransform trans sub) = - "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")" -dumpTexture (SampledTexture _) = "sampledImageTexture <IMG>" -dumpTexture (RawTexture _) = "<RAWTEXTURE>" -dumpTexture (ShaderTexture _) = "shaderFunction <FUNCTION>" -dumpTexture (ModulateTexture sub mask) = - "modulateTexture (" ++ dumpTexture sub ++ ") (" - ++ dumpTexture mask ++ ")" - - -data TextureSpaceInfo = TextureSpaceInfo - { _tsStart :: {-# UNPACK #-} !Point - , _tsDelta :: {-# UNPACK #-} !Vector - , _tsCoverage :: {-# UNPACK #-} !Float - , _tsRepeat :: {-# UNPACK #-} !Int - , _tsBaseIndex :: {-# UNPACK #-} !Int - } - deriving (Eq, Show) - -type CoverageFiller m px = - MutableImage (PrimState m) px -> CoverageSpan -> m () - -type Filler m = - TextureSpaceInfo -> m () - --- | Right now, we must stick to ST, due to the fact that --- we can't specialize with parameterized monad :( -solidColor :: forall s px . (ModulablePixel px) - => px -> MutableImage s px -> Filler (ST s) -{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8 - -> TextureSpaceInfo -> ST s () #-} -{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8 - -> TextureSpaceInfo -> ST s () #-} -solidColor color _ tsInfo - | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 = - return () -solidColor color img tsInfo - -- We are in the case fully opaque, so we can - -- just overwrite what was there before - | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 = - unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi - {-go 0 $ _tsBaseIndex tsInfo-} - where - !fullOpacity = fullValue :: PixelBaseComponent px - !maxi = _tsRepeat tsInfo - --- We can be transparent, so perform alpha blending. -solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo - where - !opacity = pixelOpacity color - !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo - !(cov, icov) = coverageModulate scanCoverage opacity - !maxi = _tsRepeat tsInfo - !compCount = componentCount (undefined :: px) - - go count _ | count >= maxi = return () - go !count !idx = do - oldPixel <- readPackedPixelAt img idx - writePackedPixelAt img idx - $ compositionAlpha cov icov oldPixel color - go (count + 1) $ idx + compCount - -shaderFiller :: forall s px . (ModulablePixel px) - => ShaderFunction px -> MutableImage s px - -> Filler (ST s) -{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8 - -> MutableImage s PixelRGBA8 - -> Filler (ST s) #-} -{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8 - -> MutableImage s Pixel8 - -> Filler (ST s) #-} -shaderFiller shader img tsInfo = - go 0 (_tsBaseIndex tsInfo) xStart yStart - where - !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo - !maxi = _tsRepeat tsInfo - !compCount = componentCount (undefined :: px) - (V2 xStart yStart) = _tsStart tsInfo - (V2 dx dy) = _tsDelta tsInfo - - go count _ _ _ | count >= maxi = return () - go !count !idx !x !y = do - let !color = shader x y - !opacity = pixelOpacity color - (cov, icov) = coverageModulate scanCoverage opacity - oldPixel <- readPackedPixelAt img idx - writePackedPixelAt img idx - $ compositionAlpha cov icov oldPixel color - go (count + 1) (idx + compCount) (x + dx) (y + dy) - -prepareInfoNoTransform :: (Pixel px) - => MutableImage s px -> CoverageSpan - -> TextureSpaceInfo -prepareInfoNoTransform img coverage = TextureSpaceInfo - { _tsStart = V2 (_coverageX coverage) (_coverageY coverage) - , _tsDelta = V2 1 0 - , _tsCoverage = _coverageVal coverage - , _tsRepeat = floor $ _coverageLength coverage - , _tsBaseIndex = - mutablePixelBaseIndex img (floor $ _coverageX coverage) - (floor $ _coverageY coverage) - } - -prepareInfo :: (Pixel px) - => Maybe Transformation -> MutableImage s px -> CoverageSpan - -> TextureSpaceInfo -prepareInfo Nothing img covSpan = prepareInfoNoTransform img covSpan -prepareInfo (Just t) img covSpan = TextureSpaceInfo - { _tsStart = applyTransformation t - $ V2 (_coverageX covSpan) (_coverageY covSpan) - , _tsDelta = applyVectorTransformation t $ V2 1 0 - , _tsCoverage = _coverageVal covSpan - , _tsRepeat = floor $ _coverageLength covSpan - , _tsBaseIndex = - mutablePixelBaseIndex img (floor $ _coverageX covSpan) - (floor $ _coverageY covSpan) - } - -combineTransform :: Maybe Transformation -> Transformation - -> Maybe Transformation -combineTransform Nothing a = Just a -combineTransform (Just v) a = Just $ v <> a - -withTrans :: Maybe Transformation -> ShaderFunction px - -> ShaderFunction px -withTrans Nothing shader = shader -withTrans (Just v) shader = \x y -> - let V2 x' y' = applyTransformation v (V2 x y) in - shader x' y' - --- | The intent of shader texture is to provide ease of implementation --- If possible providing a custom filler will be more efficient, --- like already done for the solid colors. -shaderOfTexture :: forall px . RenderablePixel px - => Maybe Transformation -> SamplerRepeat -> Texture px - -> ShaderFunction px -{-# SPECIALIZE - shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8 - -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8 - -> ShaderFunction Pixel8 #-} -shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px -shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) = - withTrans trans $ linearGradientShader grad a b sampling -shaderOfTexture trans sampling (RadialGradientTexture grad center radius) = - withTrans trans $ radialGradientShader grad center radius sampling -shaderOfTexture trans sampling (RadialGradientWithFocusTexture grad center - radius focus) = - withTrans trans - $ radialGradientWithFocusShader grad center radius focus - sampling -shaderOfTexture trans _ (WithSampler sampler sub) = - shaderOfTexture trans sampler sub -shaderOfTexture trans sampling (WithTextureTransform transform sub) = - shaderOfTexture (combineTransform trans transform) sampling sub -shaderOfTexture trans sampling (SampledTexture img) = - withTrans trans $ sampledImageShader img sampling -shaderOfTexture trans _ (ShaderTexture func) = - withTrans trans func -shaderOfTexture trans _ (RawTexture img) = - withTrans trans $ imageShader img -shaderOfTexture trans sampling (ModulateTexture texture modulation) = - modulateTexture (shaderOfTexture trans sampling texture) - (shaderOfTexture trans sampling modulation) - - --- | This function will interpret the texture description, helping --- prepare and optimize the real calculation -transformTextureToFiller - :: (RenderablePixel px) - => Texture px -> CoverageFiller (ST s) px -transformTextureToFiller = go Nothing SamplerPad - where - go _ _ (SolidTexture px) = - \img -> solidColor px img . prepareInfoNoTransform img - go trans sampling (WithTextureTransform transform sub) = - go (combineTransform trans transform) sampling sub - go trans _ (WithSampler sampler sub) = - go trans sampler sub - go trans sampling tex = - \img -> shaderFiller shader img . prepareInfo trans img - where shader = shaderOfTexture Nothing sampling tex - --- | A gradient definition is just a list of stop --- and pixel values. For instance for a simple gradient --- of black to white, the finition would be : --- --- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)] --- --- the first stop value must be zero and the last, one. --- -type Gradient px = [(Float, px)] -type GradientArray px = V.Vector (Float, px) - -repeatGradient :: Float -> Float -repeatGradient s = s - fromIntegral (floor s :: Int) - -reflectGradient :: Float -> Float -reflectGradient s = - abs (abs (s - 1) `mod'` 2 - 1) - -gradientColorAt :: ModulablePixel px - => GradientArray px -> Float -> px -{-# SPECIALIZE - gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -{-# SPECIALIZE - gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-} -gradientColorAt grad at - | at <= 0 = snd $ V.head grad - | at >= 1.0 = snd $ V.last grad - | otherwise = go (0, snd $ V.head grad) 0 - where - !maxi = V.length grad - go (prevCoeff, prevValue) ix - | ix >= maxi = snd $ V.last grad - | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px - | otherwise = go value $ ix + 1 - where value@(coeff, px) = grad `V.unsafeIndex` ix - zeroToOne = (at - prevCoeff) / (coeff - prevCoeff) - (cov, icov) = clampCoverage zeroToOne - -gradientColorAtRepeat :: ModulablePixel px - => SamplerRepeat -> GradientArray px -> Float -> px -{-# SPECIALIZE INLINE - gradientColorAtRepeat :: - SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -{-# SPECIALIZE INLINE - gradientColorAtRepeat :: - SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-} -gradientColorAtRepeat SamplerPad grad = gradientColorAt grad -gradientColorAtRepeat SamplerRepeat grad = - gradientColorAt grad . repeatGradient -gradientColorAtRepeat SamplerReflect grad = - gradientColorAt grad . reflectGradient - -linearGradientShader :: ModulablePixel px - => Gradient px -- ^ Gradient description. - -> Point -- ^ Linear gradient start point. - -> Point -- ^ Linear gradient end point. - -> SamplerRepeat - -> ShaderFunction px -{-# SPECIALIZE linearGradientShader - :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat - -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE linearGradientShader - :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat - -> ShaderFunction Pixel8 #-} -linearGradientShader gradient start end repeating = - \x y -> colorAt $ (V2 x y `dot` d) - s00 - where - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - vector = end ^-^ start - d = vector ^/ (vector `dot` vector) - s00 = start `dot` d - --- | Use another image as a texture for the filling. --- Contrary to `imageTexture`, this function perform a bilinear --- filtering on the texture. --- -sampledImageShader :: forall px. ModulablePixel px - => Image px -> SamplerRepeat -> ShaderFunction px -{-# SPECIALIZE - sampledImageShader :: Image Pixel8 -> SamplerRepeat - -> ShaderFunction Pixel8 #-} -{-# SPECIALIZE - sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat - -> ShaderFunction PixelRGBA8 #-} -sampledImageShader img sampling x y = - (at px py `interpX` at pxn py) - `interpY` - (at px pyn `interpX` at pxn pyn) - where - coordSampler SamplerPad maxi v = - min (maxi - 1) . max 0 $ floor v - coordSampler SamplerReflect maxi v = - floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1) - where maxif = fromIntegral maxi - coordSampler SamplerRepeat maxi v = floor v `mod` maxi - - w = fromIntegral $ imageWidth img - h = fromIntegral $ imageHeight img - - clampedX = coordSampler sampling w - clampedY = coordSampler sampling h - - px = clampedX x - pxn = clampedX $ x + 1 - py = clampedY y - pyn = clampedY $ y + 1 - - dx, dy :: Float - dx = x - fromIntegral (floor x :: Int) - dy = y - fromIntegral (floor y :: Int) - - at :: Int -> Int -> px - at xx yy = - unsafePixelAt rawData $ (yy * w + xx) * compCount - - (covX, icovX) = clampCoverage dx - (covY, icovY) = clampCoverage dy - - interpX = mixWith (const $ alphaOver covX icovX) - interpY = mixWith (const $ alphaOver covY icovY) - - compCount = componentCount (undefined :: px) - rawData = imageData img - --- | Use another image as a texture for the filling. --- This texture use the "nearest" filtering, AKA no --- filtering at all. -imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px -{-# SPECIALIZE - imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-} -imageShader img x y = - unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount - where - clampedX = min (w - 1) . max 0 $ floor x - clampedY = min (h - 1) . max 0 $ floor y - !compCount = componentCount (undefined :: px) - !w = imageWidth img - !h = imageHeight img - !rawData = imageData img - -radialGradientShader :: ModulablePixel px - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> SamplerRepeat - -> ShaderFunction px -{-# SPECIALIZE - radialGradientShader - :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat - -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - radialGradientShader - :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat - -> ShaderFunction Pixel8 #-} -radialGradientShader gradient center radius repeating = - \x y -> colorAt $ norm (V2 x y ^-^ center) / radius - where - !colorAt = gradientColorAtRepeat repeating gradArray - !gradArray = V.fromList gradient - -radialGradientWithFocusShader - :: ModulablePixel px - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Point -- ^ Radial gradient focus point - -> SamplerRepeat - -> ShaderFunction px -{-# SPECIALIZE - radialGradientWithFocusShader - :: Gradient PixelRGBA8 -> Point -> Float -> Point - -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - radialGradientWithFocusShader - :: Gradient Pixel8 -> Point -> Float -> Point - -> SamplerRepeat -> ShaderFunction Pixel8 #-} -radialGradientWithFocusShader gradient center radius focusScreen repeating = - \x y -> colorAt . go $ V2 x y ^-^ center - where - focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - radiusSquared = radius * radius - dist = sqrt $ focus `dot` focus - clampedFocus@(V2 focusX focusY) - | dist <= r = focus - | otherwise = V2 (r * cos a) (r * sin a) - where a = atan2 origFocusY origFocusX - r = radius * 0.99 - trivial = sqrt $ radiusSquared - origFocusX * origFocusX - - solutionOf (V2 x y) | x == focusX = - V2 focusX (if y > focusY then trivial else negate trivial) - solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint - where - slope = (y - focusY) / (x - focusX) - yint = y - (slope * x) - - a = slope * slope + 1 - b = 2 * slope * yint - c = yint * yint - radiusSquared - det = sqrt $ b * b - 4 * a * c - xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a) - - go pos = sqrt $ curToFocus / distSquared - where - solution = solutionOf pos ^-^ clampedFocus - toFocus = pos ^-^ clampedFocus - distSquared = solution `dot` solution - curToFocus = toFocus `dot` toFocus - --- | Perform a multiplication operation between a full color texture --- and a greyscale one, used for clip-path implementation. -modulateTexture :: ModulablePixel px - => ShaderFunction px - -> ShaderFunction (PixelBaseComponent px) - -> ShaderFunction px -{-# INLINE modulateTexture #-} -modulateTexture fullTexture modulator x y = - colorMap (modulate $ modulator x y) $ fullTexture x y - +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+module Graphics.Rasterific.Shading+ ( Texture( .. )+ , Gradient+ , ShaderFunction+ , ImageTransformer+ , transformTextureToFiller+ , dumpTexture+ ) where++import Control.Monad.Primitive( PrimState+ -- one day (GHC >= 7.10 ?)+ {-, PrimMonad-}+ )+import Data.Fixed( mod' )+import Data.Monoid( (<>) )+import Graphics.Rasterific.Linear+ ( V2( .. )+ , (^-^)+ , (^/)+ , dot+ , norm+ )+++import Control.Monad.ST( ST )+import qualified Data.Vector as V++import Codec.Picture.Types( Pixel( .. )+ , Image( .. )+ , MutableImage( .. )+ , Pixel8+ , PixelRGBA8+ , unsafeWritePixelBetweenAt+ , readPackedPixelAt+ , writePackedPixelAt+ )++import Graphics.Rasterific.Types( Point+ , Vector+ , Line( .. )+ , SamplerRepeat( .. ) )+import Graphics.Rasterific.Transformations+import Graphics.Rasterific.Rasterize+import Graphics.Rasterific.Compositor( Modulable( .. )+ , ModulablePixel+ , RenderablePixel+ , compositionAlpha )++type ShaderFunction px = Float -> Float -> px++type ImageTransformer px = Int -> Int -> px -> px++-- | Reification of texture type+data Texture px+ = SolidTexture !px+ | LinearGradientTexture !(Gradient px) !Line + | RadialGradientTexture !(Gradient px) !Point !Float+ | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point+ | WithSampler !SamplerRepeat (Texture px)+ | WithTextureTransform !Transformation (Texture px)+ | SampledTexture !(Image px)+ | RawTexture !(Image px)+ | ShaderTexture !(ShaderFunction px)+ | ModulateTexture (Texture px) (Texture (PixelBaseComponent px))++dumpTexture :: ( Show px+ , Show (PixelBaseComponent px)+ , PixelBaseComponent (PixelBaseComponent px)+ ~ (PixelBaseComponent px)+ ) => Texture px -> String+dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px++ ")"+dumpTexture (LinearGradientTexture grad (Line a b)) =+ "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")"+dumpTexture (RadialGradientTexture grad p rad) =+ "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad+dumpTexture (RadialGradientWithFocusTexture grad center rad focus) =+ "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center + ++ ") " ++ show rad ++ " (" ++ show focus ++ ")"+dumpTexture (WithSampler sampler sub) =+ "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")"+dumpTexture (WithTextureTransform trans sub) =+ "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")"+dumpTexture (SampledTexture _) = "sampledImageTexture <IMG>"+dumpTexture (RawTexture _) = "<RAWTEXTURE>"+dumpTexture (ShaderTexture _) = "shaderFunction <FUNCTION>"+dumpTexture (ModulateTexture sub mask) =+ "modulateTexture (" ++ dumpTexture sub ++ ") ("+ ++ dumpTexture mask ++ ")"+++data TextureSpaceInfo = TextureSpaceInfo+ { _tsStart :: {-# UNPACK #-} !Point+ , _tsDelta :: {-# UNPACK #-} !Vector+ , _tsCoverage :: {-# UNPACK #-} !Float+ , _tsRepeat :: {-# UNPACK #-} !Int+ , _tsBaseIndex :: {-# UNPACK #-} !Int+ }+ deriving (Eq, Show)++type CoverageFiller m px =+ MutableImage (PrimState m) px -> CoverageSpan -> m ()++type Filler m =+ TextureSpaceInfo -> m ()++-- | Right now, we must stick to ST, due to the fact that+-- we can't specialize with parameterized monad :(+solidColor :: forall s px . (ModulablePixel px)+ => px -> MutableImage s px -> Filler (ST s)+{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8+ -> TextureSpaceInfo -> ST s () #-}+{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8+ -> TextureSpaceInfo -> ST s () #-}+solidColor color _ tsInfo+ | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 =+ return ()+solidColor color img tsInfo+ -- We are in the case fully opaque, so we can+ -- just overwrite what was there before+ | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 =+ unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi+ {-go 0 $ _tsBaseIndex tsInfo-}+ where+ !fullOpacity = fullValue :: PixelBaseComponent px+ !maxi = _tsRepeat tsInfo++-- We can be transparent, so perform alpha blending.+solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo+ where+ !opacity = pixelOpacity color+ !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo+ !(cov, icov) = coverageModulate scanCoverage opacity+ !maxi = _tsRepeat tsInfo+ !compCount = componentCount (undefined :: px)++ go count _ | count >= maxi = return ()+ go !count !idx = do+ oldPixel <- readPackedPixelAt img idx+ writePackedPixelAt img idx+ $ compositionAlpha cov icov oldPixel color+ go (count + 1) $ idx + compCount++shaderFiller :: forall s px . (ModulablePixel px)+ => ShaderFunction px -> MutableImage s px+ -> Filler (ST s)+{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8+ -> MutableImage s PixelRGBA8+ -> Filler (ST s) #-}+{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8+ -> MutableImage s Pixel8+ -> Filler (ST s) #-}+shaderFiller shader img tsInfo =+ go 0 (_tsBaseIndex tsInfo) xStart yStart+ where+ !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo+ !maxi = _tsRepeat tsInfo+ !compCount = componentCount (undefined :: px)+ (V2 xStart yStart) = _tsStart tsInfo+ (V2 dx dy) = _tsDelta tsInfo++ go count _ _ _ | count >= maxi = return ()+ go !count !idx !x !y = do+ let !color = shader x y+ !opacity = pixelOpacity color+ (cov, icov) = coverageModulate scanCoverage opacity+ oldPixel <- readPackedPixelAt img idx+ writePackedPixelAt img idx+ $ compositionAlpha cov icov oldPixel color+ go (count + 1) (idx + compCount) (x + dx) (y + dy)++prepareInfoNoTransform :: (Pixel px)+ => MutableImage s px -> CoverageSpan+ -> TextureSpaceInfo+prepareInfoNoTransform img coverage = TextureSpaceInfo+ { _tsStart = V2 (_coverageX coverage) (_coverageY coverage)+ , _tsDelta = V2 1 0+ , _tsCoverage = _coverageVal coverage+ , _tsRepeat = floor $ _coverageLength coverage+ , _tsBaseIndex =+ mutablePixelBaseIndex img (floor $ _coverageX coverage)+ (floor $ _coverageY coverage)+ }++prepareInfo :: (Pixel px)+ => Maybe Transformation -> MutableImage s px -> CoverageSpan+ -> TextureSpaceInfo+prepareInfo Nothing img covSpan = prepareInfoNoTransform img covSpan+prepareInfo (Just t) img covSpan = TextureSpaceInfo+ { _tsStart = applyTransformation t+ $ V2 (_coverageX covSpan) (_coverageY covSpan)+ , _tsDelta = applyVectorTransformation t $ V2 1 0+ , _tsCoverage = _coverageVal covSpan+ , _tsRepeat = floor $ _coverageLength covSpan+ , _tsBaseIndex =+ mutablePixelBaseIndex img (floor $ _coverageX covSpan)+ (floor $ _coverageY covSpan)+ }++combineTransform :: Maybe Transformation -> Transformation+ -> Maybe Transformation+combineTransform Nothing a = Just a+combineTransform (Just v) a = Just $ v <> a++withTrans :: Maybe Transformation -> ShaderFunction px+ -> ShaderFunction px+withTrans Nothing shader = shader+withTrans (Just v) shader = \x y ->+ let V2 x' y' = applyTransformation v (V2 x y) in+ shader x' y'++-- | The intent of shader texture is to provide ease of implementation+-- If possible providing a custom filler will be more efficient,+-- like already done for the solid colors.+shaderOfTexture :: forall px . RenderablePixel px+ => Maybe Transformation -> SamplerRepeat -> Texture px+ -> ShaderFunction px+{-# SPECIALIZE+ shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8+ -> ShaderFunction PixelRGBA8 #-}+{-# SPECIALIZE+ shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8+ -> ShaderFunction Pixel8 #-}+shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px+shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) =+ withTrans trans $ linearGradientShader grad a b sampling+shaderOfTexture trans sampling (RadialGradientTexture grad center radius) =+ withTrans trans $ radialGradientShader grad center radius sampling+shaderOfTexture trans sampling (RadialGradientWithFocusTexture grad center + radius focus) =+ withTrans trans+ $ radialGradientWithFocusShader grad center radius focus+ sampling+shaderOfTexture trans _ (WithSampler sampler sub) =+ shaderOfTexture trans sampler sub+shaderOfTexture trans sampling (WithTextureTransform transform sub) =+ shaderOfTexture (combineTransform trans transform) sampling sub+shaderOfTexture trans sampling (SampledTexture img) =+ withTrans trans $ sampledImageShader img sampling+shaderOfTexture trans _ (ShaderTexture func) =+ withTrans trans func+shaderOfTexture trans _ (RawTexture img) =+ withTrans trans $ imageShader img+shaderOfTexture trans sampling (ModulateTexture texture modulation) =+ modulateTexture (shaderOfTexture trans sampling texture)+ (shaderOfTexture trans sampling modulation)+++-- | This function will interpret the texture description, helping+-- prepare and optimize the real calculation+transformTextureToFiller+ :: (RenderablePixel px)+ => Texture px -> CoverageFiller (ST s) px+transformTextureToFiller = go Nothing SamplerPad+ where+ go _ _ (SolidTexture px) =+ \img -> solidColor px img . prepareInfoNoTransform img+ go trans sampling (WithTextureTransform transform sub) =+ go (combineTransform trans transform) sampling sub+ go trans _ (WithSampler sampler sub) =+ go trans sampler sub+ go trans sampling tex =+ \img -> shaderFiller shader img . prepareInfo trans img+ where shader = shaderOfTexture Nothing sampling tex++-- | A gradient definition is just a list of stop+-- and pixel values. For instance for a simple gradient+-- of black to white, the finition would be :+--+-- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)]+-- +-- the first stop value must be zero and the last, one.+--+type Gradient px = [(Float, px)]+type GradientArray px = V.Vector (Float, px)++repeatGradient :: Float -> Float+repeatGradient s = s - fromIntegral (floor s :: Int)++reflectGradient :: Float -> Float+reflectGradient s =+ abs (abs (s - 1) `mod'` 2 - 1)+ +gradientColorAt :: ModulablePixel px+ => GradientArray px -> Float -> px+{-# SPECIALIZE+ gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}+{-# SPECIALIZE+ gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-}+gradientColorAt grad at+ | at <= 0 = snd $ V.head grad+ | at >= 1.0 = snd $ V.last grad+ | otherwise = go (0, snd $ V.head grad) 0+ where+ !maxi = V.length grad+ go (prevCoeff, prevValue) ix+ | ix >= maxi = snd $ V.last grad+ | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px+ | otherwise = go value $ ix + 1+ where value@(coeff, px) = grad `V.unsafeIndex` ix+ zeroToOne = (at - prevCoeff) / (coeff - prevCoeff)+ (cov, icov) = clampCoverage zeroToOne++gradientColorAtRepeat :: ModulablePixel px+ => SamplerRepeat -> GradientArray px -> Float -> px+{-# SPECIALIZE INLINE+ gradientColorAtRepeat ::+ SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}+{-# SPECIALIZE INLINE+ gradientColorAtRepeat ::+ SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-}+gradientColorAtRepeat SamplerPad grad = gradientColorAt grad+gradientColorAtRepeat SamplerRepeat grad =+ gradientColorAt grad . repeatGradient+gradientColorAtRepeat SamplerReflect grad =+ gradientColorAt grad . reflectGradient++linearGradientShader :: ModulablePixel px+ => Gradient px -- ^ Gradient description.+ -> Point -- ^ Linear gradient start point.+ -> Point -- ^ Linear gradient end point.+ -> SamplerRepeat+ -> ShaderFunction px+{-# SPECIALIZE linearGradientShader+ :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat+ -> ShaderFunction PixelRGBA8 #-}+{-# SPECIALIZE linearGradientShader+ :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat+ -> ShaderFunction Pixel8 #-}+linearGradientShader gradient start end repeating =+ \x y -> colorAt $ (V2 x y `dot` d) - s00+ where+ colorAt = gradientColorAtRepeat repeating gradArray+ gradArray = V.fromList gradient+ vector = end ^-^ start+ d = vector ^/ (vector `dot` vector)+ s00 = start `dot` d++-- | Use another image as a texture for the filling.+-- Contrary to `imageTexture`, this function perform a bilinear+-- filtering on the texture.+--+sampledImageShader :: forall px. ModulablePixel px+ => Image px -> SamplerRepeat -> ShaderFunction px+{-# SPECIALIZE+ sampledImageShader :: Image Pixel8 -> SamplerRepeat+ -> ShaderFunction Pixel8 #-}+{-# SPECIALIZE+ sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat+ -> ShaderFunction PixelRGBA8 #-}+sampledImageShader img sampling x y =+ (at px py `interpX` at pxn py)+ `interpY`+ (at px pyn `interpX` at pxn pyn)+ where+ coordSampler SamplerPad maxi v =+ min (maxi - 1) . max 0 $ floor v+ coordSampler SamplerReflect maxi v =+ floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1)+ where maxif = fromIntegral maxi+ coordSampler SamplerRepeat maxi v = floor v `mod` maxi++ w = fromIntegral $ imageWidth img+ h = fromIntegral $ imageHeight img++ clampedX = coordSampler sampling w+ clampedY = coordSampler sampling h++ px = clampedX x+ pxn = clampedX $ x + 1+ py = clampedY y+ pyn = clampedY $ y + 1++ dx, dy :: Float+ dx = x - fromIntegral (floor x :: Int)+ dy = y - fromIntegral (floor y :: Int)++ at :: Int -> Int -> px+ at xx yy =+ unsafePixelAt rawData $ (yy * w + xx) * compCount++ (covX, icovX) = clampCoverage dx+ (covY, icovY) = clampCoverage dy++ interpX = mixWith (const $ alphaOver covX icovX)+ interpY = mixWith (const $ alphaOver covY icovY)++ compCount = componentCount (undefined :: px)+ rawData = imageData img++-- | Use another image as a texture for the filling.+-- This texture use the "nearest" filtering, AKA no+-- filtering at all.+imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px+{-# SPECIALIZE+ imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-}+{-# SPECIALIZE+ imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-}+imageShader img x y =+ unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount+ where+ clampedX = min (w - 1) . max 0 $ floor x+ clampedY = min (h - 1) . max 0 $ floor y+ !compCount = componentCount (undefined :: px)+ !w = imageWidth img+ !h = imageHeight img+ !rawData = imageData img++radialGradientShader :: ModulablePixel px+ => Gradient px -- ^ Gradient description+ -> Point -- ^ Radial gradient center+ -> Float -- ^ Radial gradient radius+ -> SamplerRepeat+ -> ShaderFunction px+{-# SPECIALIZE + radialGradientShader+ :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat+ -> ShaderFunction PixelRGBA8 #-}+{-# SPECIALIZE + radialGradientShader+ :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat+ -> ShaderFunction Pixel8 #-}+radialGradientShader gradient center radius repeating =+ \x y -> colorAt $ norm (V2 x y ^-^ center) / radius+ where+ !colorAt = gradientColorAtRepeat repeating gradArray+ !gradArray = V.fromList gradient++radialGradientWithFocusShader+ :: ModulablePixel px+ => Gradient px -- ^ Gradient description+ -> Point -- ^ Radial gradient center+ -> Float -- ^ Radial gradient radius+ -> Point -- ^ Radial gradient focus point+ -> SamplerRepeat+ -> ShaderFunction px+{-# SPECIALIZE+ radialGradientWithFocusShader+ :: Gradient PixelRGBA8 -> Point -> Float -> Point+ -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-}+{-# SPECIALIZE+ radialGradientWithFocusShader+ :: Gradient Pixel8 -> Point -> Float -> Point+ -> SamplerRepeat -> ShaderFunction Pixel8 #-}+radialGradientWithFocusShader gradient center radius focusScreen repeating =+ \x y -> colorAt . go $ V2 x y ^-^ center+ where+ focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center+ colorAt = gradientColorAtRepeat repeating gradArray+ gradArray = V.fromList gradient+ radiusSquared = radius * radius+ dist = sqrt $ focus `dot` focus+ clampedFocus@(V2 focusX focusY)+ | dist <= r = focus+ | otherwise = V2 (r * cos a) (r * sin a)+ where a = atan2 origFocusY origFocusX+ r = radius * 0.99+ trivial = sqrt $ radiusSquared - origFocusX * origFocusX++ solutionOf (V2 x y) | x == focusX =+ V2 focusX (if y > focusY then trivial else negate trivial)+ solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint+ where+ slope = (y - focusY) / (x - focusX)+ yint = y - (slope * x)++ a = slope * slope + 1+ b = 2 * slope * yint+ c = yint * yint - radiusSquared+ det = sqrt $ b * b - 4 * a * c+ xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a)++ go pos = sqrt $ curToFocus / distSquared+ where+ solution = solutionOf pos ^-^ clampedFocus+ toFocus = pos ^-^ clampedFocus+ distSquared = solution `dot` solution+ curToFocus = toFocus `dot` toFocus++-- | Perform a multiplication operation between a full color texture+-- and a greyscale one, used for clip-path implementation.+modulateTexture :: ModulablePixel px+ => ShaderFunction px+ -> ShaderFunction (PixelBaseComponent px)+ -> ShaderFunction px+{-# INLINE modulateTexture #-}+modulateTexture fullTexture modulator x y =+ colorMap (modulate $ modulator x y) $ fullTexture x y+
src/Graphics/Rasterific/StrokeInternal.hs view
@@ -1,300 +1,299 @@-{-# LANGUAGE CPP #-} -module Graphics.Rasterific.StrokeInternal - ( flatten - , dashize - , strokize - , dashedStrokize - , splitPrimitiveUntil - , approximatePathLength - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( mempty ) -import Data.Foldable( foldMap ) -#endif - -import Control.Applicative( (<$>) ) -import Data.Monoid( (<>) ) - -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , dot - ) - -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.Line - -lastPoint :: Primitive -> Point -lastPoint (LinePrim (Line _ x1)) = x1 -lastPoint (BezierPrim (Bezier _ _ x2)) = x2 -lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3 - -lastPointAndNormal :: Primitive -> (Point, Vector) -lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b) -lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c) -lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d) - -firstPointAndNormal :: Primitive -> (Point, Vector) -firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b) -firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b) -firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) - -reversePrimitive :: Primitive -> Primitive -reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a) -reversePrimitive (BezierPrim (Bezier a b c)) = - BezierPrim (Bezier c b a) -reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) = - CubicBezierPrim (CubicBezier d c b a) - --- | Create a "rounded" join or cap -roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive -roundJoin offset p = go - where go u v - -- If we're already on a nice curvature, - -- don't bother doing anything - | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c - | otherwise = go u w <> go w v - where -- ^ - -- |w - -- a X---X c - -- \ / - -- Xp - -- ^ / \ ^ - -- u\/ \/v - -- / \ . - a = p ^+^ u ^* offset - c = p ^+^ v ^* offset - - w = (a `normal` c) `ifZero` u - - -- Same as offseting - n = p ^+^ w ^* offset - b = n ^* 2 ^-^ (a `midPoint` c) - --- | Put a cap at the end of a bezier curve, depending --- on the kind of cap wanted. -cap :: Float -> Cap -> Primitive -> Container Primitive -cap offset CapRound prim = roundJoin offset p u (- u) - where (p, u) = lastPointAndNormal prim - -cap offset (CapStraight cVal) prim = - pure (d `lineFromTo` e) <> pure (e `lineFromTo` f) - <> pure (f `lineFromTo` g) - where -- The usual "normal" - (p, u@(V2 ux uy)) = lastPointAndNormal prim - -- Vector pointing in the direction of the curve - -- of norm 1 - v = V2 uy $ negate ux - - -- Finishing points around the edge - -- -u*offset u*offset - -- <-><-> - -- d/ / /g - -- / / / - -- / / / - -- / - -- / curve - -- - d = p ^+^ u ^* offset - g = p ^-^ u ^* offset - - -- Create the "far" points - -- - -- e f - -- / / ^ - -- / / / v * offset * cVal - -- d/ / /g - -- / / / - -- / / / - -- / - -- / curve - -- - e = d ^+^ v ^* (offset * cVal) - f = g ^+^ v ^* (offset * cVal) - -lineFromTo :: Point -> Point -> Primitive -lineFromTo a b = LinePrim (Line a b) - -miterJoin :: Float -> Float -> Point -> Vector -> Vector - -> Container Primitive -miterJoin offset l point u v - | uDotW > l / max 1 l && uDotW > 0.01 = - pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) - -- A simple straight junction - | otherwise = pure $ a `lineFromTo` c - where -- X m - -- /\ - -- /|w\ - -- a X---X c - -- \ / - -- Xp - -- ^ / \ ^ - -- u\/ \/v - -- / \ . - a = point ^+^ u ^* offset - c = point ^+^ v ^* offset - w = (a `normal` c) `ifZero` u - - uDotW = u `dot` w - - -- Calculate the maximum distance on the - -- u axis - p = offset / uDotW - -- middle point for "straight joining" - m = point + w ^* p - -joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive - -> Container Primitive -joinPrimitives offset join prim1 prim2 = - case join of - JoinRound -> roundJoin offset p u v - JoinMiter l -> miterJoin offset l p u v - where (p, u) = lastPointAndNormal prim1 - (_, v) = firstPointAndNormal prim2 - -offsetPrimitives :: Float -> Primitive -> Container Primitive -offsetPrimitives offset (LinePrim l) = offsetLine offset l -offsetPrimitives offset (BezierPrim b) = offsetBezier offset b -offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c - -offsetAndJoin :: Float -> Join -> Cap -> [Primitive] - -> Container Primitive -offsetAndJoin _ _ _ [] = mempty -offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest - where joiner = joinPrimitives offset join - offseter = offsetPrimitives offset - (firstPoint, _) = firstPointAndNormal firstShape - - go prev [] - | firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev - | otherwise = offseter prev <> cap offset caping prev - go prev (x:xs) = - joiner prev x <> offseter prev <> go x xs - -approximateLength :: Primitive -> Float -approximateLength (LinePrim l) = lineLength l -approximateLength (BezierPrim b) = bezierLengthApproximation b -approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c - - -sanitize :: Primitive -> Container Primitive -sanitize (LinePrim l) = sanitizeLine l -sanitize (BezierPrim b) = sanitizeBezier b -sanitize (CubicBezierPrim c) = sanitizeCubicBezier c - -strokize :: Geometry geom - => StrokeWidth -> Join -> (Cap, Cap) -> geom - -> Container Primitive -strokize width join (capStart, capEnd) geom = - offseter capEnd sanitized <> - offseter capStart (reverse $ reversePrimitive <$> sanitized) - where - sanitized = foldMap (listOfContainer . sanitize) $ toPrimitives geom - offseter = offsetAndJoin (width / 2) join - -flattenPrimitive :: Primitive -> Container Primitive -flattenPrimitive (BezierPrim bezier) = flattenBezier bezier -flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier -flattenPrimitive (LinePrim line) = flattenLine line - -breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive) -breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b) - where (a, b) = bezierBreakAt bezier at -breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b) - where (a, b) = cubicBezierBreakAt bezier at -breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b) - where (a, b) = lineBreakAt line at - - -flatten :: Container Primitive -> Container Primitive -flatten = foldMap flattenPrimitive - -splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) -splitPrimitiveUntil = go - where - go _ [] = ([], []) - go left lst - | left <= 0 = ([], lst) - go left (x : xs) - | left > primLength = (x : inInterval, afterInterval) - | otherwise = ([beforeStop], afterStop : xs) - where - primLength = approximateLength x - (inInterval, afterInterval) = go (left - primLength) xs - - (beforeStop, afterStop) = - breakPrimitiveAt x $ left / primLength - -dropPattern :: Float -> DashPattern -> DashPattern -dropPattern = go - where - go _ [] = [] - go offset (x:xs) - | x < 0 = x:xs -- sanitizing - | offset < x = x - offset : xs - | otherwise {- offset >= x -} = go (offset - x) xs - --- | Don't make them completly flat, but suficiently --- to assume they are. -linearizePrimitives :: [Primitive] -> [Primitive] -linearizePrimitives = - listOfContainer . foldMap flattenPrimitive . foldMap sanitize - --- | Return an approximation of the length of a given path. --- It's results is not precise but should be enough for --- rough calculations -approximatePathLength :: Path -> Float -approximatePathLength = approximatePrimitivesLength . pathToPrimitives - -approximatePrimitivesLength :: [Primitive] -> Float -approximatePrimitivesLength prims = - sum $ approximateLength <$> linearizePrimitives prims - -dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] -dashize offset pattern = taker infinitePattern . linearizePrimitives - where - realOffset | offset >= 0 = offset - | otherwise = offset + sum pattern - - infinitePattern = - dropPattern realOffset . cycle $ filter (> 0) pattern - - taker _ [] = [] - taker [] _ = [] -- Impossible by construction, pattern is infinite - taker (atValue:atRest) stream = toKeep : droper atRest next - where (toKeep, next) = splitPrimitiveUntil atValue stream - - droper _ [] = [] - droper [] _ = [] -- Impossible by construction, pattern is infinite - droper (atValue:atRest) stream = taker atRest next - where (_toKeep, next) = splitPrimitiveUntil atValue stream - --- | Create a list of outlines corresponding to all the --- dashed elements. They can be then stroked --- --- > 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) --- --- <<docimages/strokize_dashed_path.png>> --- -dashedStrokize :: Geometry geom - => Float -- ^ Starting offset - -> DashPattern -- ^ Dashing pattern to use for stroking - -> StrokeWidth -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ Elements to transform - -> [[Primitive]] -dashedStrokize offset dashPattern width join capping geom = - listOfContainer . strokize width join capping - <$> dashize offset dashPattern (toPrimitives geom) - +{-# LANGUAGE CPP #-}+module Graphics.Rasterific.StrokeInternal+ ( flatten+ , dashize+ , strokize+ , dashedStrokize+ , splitPrimitiveUntil+ , approximatePathLength+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>), pure )+import Data.Monoid( mempty )+import Data.Foldable( foldMap )+#endif++import Data.Monoid( (<>) )++import Graphics.Rasterific.Linear+ ( V2( .. )+ , (^-^)+ , (^+^)+ , (^*)+ , dot+ )++import Graphics.Rasterific.Operators+import Graphics.Rasterific.Types+import Graphics.Rasterific.QuadraticBezier+import Graphics.Rasterific.CubicBezier+import Graphics.Rasterific.Line++lastPoint :: Primitive -> Point+lastPoint (LinePrim (Line _ x1)) = x1+lastPoint (BezierPrim (Bezier _ _ x2)) = x2+lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3++lastPointAndNormal :: Primitive -> (Point, Vector)+lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b)+lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c)+lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d)++firstPointAndNormal :: Primitive -> (Point, Vector)+firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b)+firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b)+firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b)++reversePrimitive :: Primitive -> Primitive+reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a)+reversePrimitive (BezierPrim (Bezier a b c)) =+ BezierPrim (Bezier c b a)+reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) =+ CubicBezierPrim (CubicBezier d c b a)++-- | Create a "rounded" join or cap+roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive+roundJoin offset p = go+ where go u v+ -- If we're already on a nice curvature,+ -- don't bother doing anything+ | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c+ | otherwise = go u w <> go w v+ where -- ^+ -- |w+ -- a X---X c+ -- \ /+ -- Xp+ -- ^ / \ ^+ -- u\/ \/v+ -- / \ .+ a = p ^+^ u ^* offset+ c = p ^+^ v ^* offset++ w = (a `normal` c) `ifZero` u++ -- Same as offseting+ n = p ^+^ w ^* offset+ b = n ^* 2 ^-^ (a `midPoint` c)++-- | Put a cap at the end of a bezier curve, depending+-- on the kind of cap wanted.+cap :: Float -> Cap -> Primitive -> Container Primitive+cap offset CapRound prim = roundJoin offset p u (- u)+ where (p, u) = lastPointAndNormal prim++cap offset (CapStraight cVal) prim =+ pure (d `lineFromTo` e) <> pure (e `lineFromTo` f)+ <> pure (f `lineFromTo` g)+ where -- The usual "normal"+ (p, u@(V2 ux uy)) = lastPointAndNormal prim+ -- Vector pointing in the direction of the curve+ -- of norm 1+ v = V2 uy $ negate ux++ -- Finishing points around the edge+ -- -u*offset u*offset+ -- <-><->+ -- d/ / /g+ -- / / /+ -- / / /+ -- /+ -- / curve+ --+ d = p ^+^ u ^* offset+ g = p ^-^ u ^* offset++ -- Create the "far" points+ --+ -- e f+ -- / / ^+ -- / / / v * offset * cVal+ -- d/ / /g+ -- / / /+ -- / / /+ -- /+ -- / curve+ --+ e = d ^+^ v ^* (offset * cVal)+ f = g ^+^ v ^* (offset * cVal)++lineFromTo :: Point -> Point -> Primitive+lineFromTo a b = LinePrim (Line a b)++miterJoin :: Float -> Float -> Point -> Vector -> Vector+ -> Container Primitive+miterJoin offset l point u v+ | uDotW > l / max 1 l && uDotW > 0.01 =+ pure (m `lineFromTo` c) <> pure (a `lineFromTo` m)+ -- A simple straight junction+ | otherwise = pure $ a `lineFromTo` c+ where -- X m+ -- /\+ -- /|w\+ -- a X---X c+ -- \ /+ -- Xp+ -- ^ / \ ^+ -- u\/ \/v+ -- / \ .+ a = point ^+^ u ^* offset+ c = point ^+^ v ^* offset+ w = (a `normal` c) `ifZero` u++ uDotW = u `dot` w++ -- Calculate the maximum distance on the+ -- u axis+ p = offset / uDotW+ -- middle point for "straight joining"+ m = point + w ^* p++joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive+ -> Container Primitive+joinPrimitives offset join prim1 prim2 =+ case join of+ JoinRound -> roundJoin offset p u v+ JoinMiter l -> miterJoin offset l p u v+ where (p, u) = lastPointAndNormal prim1+ (_, v) = firstPointAndNormal prim2++offsetPrimitives :: Float -> Primitive -> Container Primitive+offsetPrimitives offset (LinePrim l) = offsetLine offset l+offsetPrimitives offset (BezierPrim b) = offsetBezier offset b+offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c++offsetAndJoin :: Float -> Join -> Cap -> [Primitive]+ -> Container Primitive+offsetAndJoin _ _ _ [] = mempty+offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest+ where joiner = joinPrimitives offset join+ offseter = offsetPrimitives offset+ (firstPoint, _) = firstPointAndNormal firstShape++ go prev []+ | firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev+ | otherwise = offseter prev <> cap offset caping prev+ go prev (x:xs) =+ joiner prev x <> offseter prev <> go x xs++approximateLength :: Primitive -> Float+approximateLength (LinePrim l) = lineLength l+approximateLength (BezierPrim b) = bezierLengthApproximation b+approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c+++sanitize :: Primitive -> Container Primitive+sanitize (LinePrim l) = sanitizeLine l+sanitize (BezierPrim b) = sanitizeBezier b+sanitize (CubicBezierPrim c) = sanitizeCubicBezier c++strokize :: Geometry geom+ => StrokeWidth -> Join -> (Cap, Cap) -> geom+ -> Container Primitive+strokize width join (capStart, capEnd) geom =+ offseter capEnd sanitized <>+ offseter capStart (reverse $ reversePrimitive <$> sanitized)+ where + sanitized = foldMap (listOfContainer . sanitize) $ toPrimitives geom+ offseter = offsetAndJoin (width / 2) join++flattenPrimitive :: Primitive -> Container Primitive+flattenPrimitive (BezierPrim bezier) = flattenBezier bezier+flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier+flattenPrimitive (LinePrim line) = flattenLine line++breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive)+breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b)+ where (a, b) = bezierBreakAt bezier at+breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b)+ where (a, b) = cubicBezierBreakAt bezier at+breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b)+ where (a, b) = lineBreakAt line at+++flatten :: Container Primitive -> Container Primitive+flatten = foldMap flattenPrimitive++splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive])+splitPrimitiveUntil = go+ where+ go _ [] = ([], [])+ go left lst+ | left <= 0 = ([], lst)+ go left (x : xs)+ | left > primLength = (x : inInterval, afterInterval)+ | otherwise = ([beforeStop], afterStop : xs)+ where+ primLength = approximateLength x+ (inInterval, afterInterval) = go (left - primLength) xs++ (beforeStop, afterStop) =+ breakPrimitiveAt x $ left / primLength++dropPattern :: Float -> DashPattern -> DashPattern+dropPattern = go+ where+ go _ [] = []+ go offset (x:xs)+ | x < 0 = x:xs -- sanitizing+ | offset < x = x - offset : xs+ | otherwise {- offset >= x -} = go (offset - x) xs++-- | Don't make them completly flat, but suficiently+-- to assume they are.+linearizePrimitives :: [Primitive] -> [Primitive]+linearizePrimitives =+ listOfContainer . foldMap flattenPrimitive . foldMap sanitize++-- | Return an approximation of the length of a given path.+-- It's results is not precise but should be enough for+-- rough calculations+approximatePathLength :: Path -> Float+approximatePathLength = approximatePrimitivesLength . pathToPrimitives++approximatePrimitivesLength :: [Primitive] -> Float+approximatePrimitivesLength prims =+ sum $ approximateLength <$> linearizePrimitives prims++dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]]+dashize offset pattern = taker infinitePattern . linearizePrimitives + where+ realOffset | offset >= 0 = offset+ | otherwise = offset + sum pattern++ infinitePattern =+ dropPattern realOffset . cycle $ filter (> 0) pattern++ taker _ [] = []+ taker [] _ = [] -- Impossible by construction, pattern is infinite+ taker (atValue:atRest) stream = toKeep : droper atRest next+ where (toKeep, next) = splitPrimitiveUntil atValue stream++ droper _ [] = []+ droper [] _ = [] -- Impossible by construction, pattern is infinite+ droper (atValue:atRest) stream = taker atRest next+ where (_toKeep, next) = splitPrimitiveUntil atValue stream++-- | Create a list of outlines corresponding to all the+-- dashed elements. They can be then stroked+--+-- > 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)+--+-- <<docimages/strokize_dashed_path.png>>+--+dashedStrokize :: Geometry geom+ => Float -- ^ Starting offset+ -> DashPattern -- ^ Dashing pattern to use for stroking+ -> StrokeWidth -- ^ Stroke width+ -> Join -- ^ Which kind of join will be used+ -> (Cap, Cap) -- ^ Start and end capping.+ -> geom -- ^ Elements to transform+ -> [[Primitive]]+dashedStrokize offset dashPattern width join capping geom =+ listOfContainer . strokize width join capping+ <$> dashize offset dashPattern (toPrimitives geom)+