Rasterific 0.5.0.2 → 0.5.0.3
raw patch · 41 files changed
+5195/−5189 lines, 41 filessetup-changedbinary-addedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- LICENSE +30/−30
- Rasterific.cabal +87/−87
- Setup.hs +2/−2
- changelog +93/−87
- docimages/cap_straight.png binary
- docimages/coordinate.png binary
- docimages/cubic_bezier.png binary
- docimages/geometry_on_path.png binary
- docimages/image_resize.png binary
- docimages/image_simple.png binary
- docimages/immediate_fill.png binary
- docimages/immediate_mask.png binary
- docimages/sampled_texture_reflect.png binary
- docimages/strokize_dashed_path.png binary
- docimages/strokize_path.png binary
- docimages/text_complex_example.png binary
- docimages/text_example.png binary
- docimages/text_on_path.png binary
- docimages/transform_skewx.png binary
- docimages/transform_skewy.png binary
- exec-src/docImageGenerator.hs +468/−468
- src/Graphics/Rasterific.hs +689/−689
- src/Graphics/Rasterific/Command.hs +131/−131
- src/Graphics/Rasterific/Compositor.hs +151/−151
- src/Graphics/Rasterific/CubicBezier.hs +349/−349
- src/Graphics/Rasterific/Immediate.hs +184/−184
- src/Graphics/Rasterific/Lenses.hs +147/−147
- src/Graphics/Rasterific/Line.hs +164/−164
- src/Graphics/Rasterific/Linear.hs +230/−230
- src/Graphics/Rasterific/Operators.hs +165/−165
- src/Graphics/Rasterific/Outline.hs +30/−30
- src/Graphics/Rasterific/PathWalker.hs +131/−131
- src/Graphics/Rasterific/PlaneBoundable.hs +88/−88
- src/Graphics/Rasterific/QuadraticBezier.hs +291/−291
- src/Graphics/Rasterific/QuadraticFormula.hs +56/−56
- src/Graphics/Rasterific/Rasterize.hs +92/−92
- src/Graphics/Rasterific/Shading.hs +490/−490
- src/Graphics/Rasterific/StrokeInternal.hs +300/−300
- src/Graphics/Rasterific/Texture.hs +147/−147
- src/Graphics/Rasterific/Transformations.hs +198/−198
- src/Graphics/Rasterific/Types.hs +482/−482
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2013, Vincent Berthoux--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Vincent Berthoux nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2013, Vincent Berthoux + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Vincent Berthoux nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
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.0.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.0.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 -auto-all- 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.0.3 +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.0.3 + +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 -auto-all + 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 +
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
changelog view
@@ -1,87 +1,93 @@--*-change-log-*---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.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 (1787 → 1786 bytes)
+ docimages/coordinate.png view
binary file changed (absent → 4542 bytes)
docimages/cubic_bezier.png view
binary file changed (4519 → 4513 bytes)
+ docimages/geometry_on_path.png view
binary file changed (absent → 5228 bytes)
docimages/image_resize.png view
binary file changed (40719 → 40755 bytes)
docimages/image_simple.png view
binary file changed (12189 → 12132 bytes)
+ docimages/immediate_fill.png view
binary file changed (absent → 3052 bytes)
+ docimages/immediate_mask.png view
binary file changed (absent → 4917 bytes)
docimages/sampled_texture_reflect.png view
binary file changed (65013 → 64682 bytes)
+ docimages/strokize_dashed_path.png view
binary file changed (absent → 10017 bytes)
+ docimages/strokize_path.png view
binary file changed (absent → 4960 bytes)
+ docimages/text_complex_example.png view
binary file changed (absent → 2284 bytes)
+ docimages/text_example.png view
binary file changed (absent → 2388 bytes)
+ docimages/text_on_path.png view
binary file changed (absent → 6582 bytes)
+ docimages/transform_skewx.png view
binary file changed (absent → 1818 bytes)
+ docimages/transform_skewy.png view
binary file changed (absent → 1609 bytes)
exec-src/docImageGenerator.hs view
@@ -1,468 +1,468 @@-{-# 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 =- map BezierPrim . 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 = LinePrim <$>- [ 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---textOnPathExample :: IO ()-textOnPathExample = do- fontErr <- loadFontFile "C:/Windows/Fonts/arial.ttf"- 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) $- pathToPrimitives 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 "C:/Windows/Fonts/arial.ttf"- 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) $- pathToPrimitives 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 "C:/Windows/Fonts/arial.ttf"- 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 "C:/Windows/Fonts/arial.ttf"- eitherFont2 <- loadFontFile "C:/Windows/Fonts/consola.ttf"- 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 "C:/Windows/Fonts/arial.ttf"- 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)- filler = fill . pathToPrimitives- 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)"- filler $ Path (V2 170 30) True- [PathLineTo (V2 195 40), PathLineTo (V2 170 50)]- filler $ 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)))- $ concatMap pathToPrimitives- [ 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)- [CubicBezierPrim $- 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)- [CubicBezierPrim $- 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) $- [CubicBezierPrim $ CubicBezier (V2 0 10) (V2 205 250)- (V2 (-10) 250) (V2 160 35)]-- produceDocImage (outFolder </> "quadratic_bezier.png") $- fill $ BezierPrim <$> [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 $ LinePrim <$> [ 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- [ CubicBezierPrim $ CubicBezier (V2 50 20) (V2 90 60)- (V2 5 100) (V2 50 140)- , LinePrim $ Line (V2 50 140) (V2 120 80)- , LinePrim $ Line (V2 120 80) (V2 50 20) ]-- produceDocImage (outFolder </> "path_example.png") $- fill . pathToPrimitives $ 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.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 = + map BezierPrim . 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 = LinePrim <$> + [ 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 + + +textOnPathExample :: IO () +textOnPathExample = do + fontErr <- loadFontFile "C:/Windows/Fonts/arial.ttf" + 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) $ + pathToPrimitives 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 "C:/Windows/Fonts/arial.ttf" + 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) $ + pathToPrimitives 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 "C:/Windows/Fonts/arial.ttf" + 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 "C:/Windows/Fonts/arial.ttf" + eitherFont2 <- loadFontFile "C:/Windows/Fonts/consola.ttf" + 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 "C:/Windows/Fonts/arial.ttf" + 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) + filler = fill . pathToPrimitives + 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)" + filler $ Path (V2 170 30) True + [PathLineTo (V2 195 40), PathLineTo (V2 170 50)] + filler $ 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))) + $ concatMap pathToPrimitives + [ 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) + [CubicBezierPrim $ + 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) + [CubicBezierPrim $ + 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) $ + [CubicBezierPrim $ CubicBezier (V2 0 10) (V2 205 250) + (V2 (-10) 250) (V2 160 35)] + + produceDocImage (outFolder </> "quadratic_bezier.png") $ + fill $ BezierPrim <$> [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 $ LinePrim <$> [ 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 + [ CubicBezierPrim $ CubicBezier (V2 50 20) (V2 90 60) + (V2 5 100) (V2 50 140) + , LinePrim $ Line (V2 50 140) (V2 120 80) + , LinePrim $ Line (V2 120 80) (V2 50 20) ] + + produceDocImage (outFolder </> "path_example.png") $ + fill . pathToPrimitives $ 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 +
src/Graphics/Rasterific.hs view
@@ -1,689 +1,689 @@-{-# 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( .. )- , 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) $--- > pathToPrimitives 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) $--- > pathToPrimitives 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 :: [Primitive] -> Drawing px ()-fill prims = liftF $ Fill FillWinding prims ()---- | This function let you choose how to fill the primitives--- in case of self intersection. See `FillMethod` documentation--- for more information.-fillWithMethod :: FillMethod -> [Primitive] -> Drawing px ()-fillWithMethod method prims =- liftF $ Fill method 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 :: Float -- ^ Stroke width- -> Join -- ^ Which kind of join will be used- -> (Cap, Cap) -- ^ Start and end capping.- -> [Primitive] -- ^ List of elements to render- -> Drawing px ()-stroke width join caping prims =- liftF $ Stroke width join caping 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- :: DashPattern -- ^ Dashing pattern to use for stroking- -> Float -- ^ Stroke width- -> Join -- ^ Which kind of join will be used- -> (Cap, Cap) -- ^ Start and end capping.- -> [Primitive] -- ^ 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- :: 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.- -> [Primitive] -- ^ 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 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 + 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( .. ) + , 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) $ +-- > pathToPrimitives 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) $ +-- > pathToPrimitives 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 :: [Primitive] -> Drawing px () +fill prims = liftF $ Fill FillWinding prims () + +-- | This function let you choose how to fill the primitives +-- in case of self intersection. See `FillMethod` documentation +-- for more information. +fillWithMethod :: FillMethod -> [Primitive] -> Drawing px () +fillWithMethod method prims = + liftF $ Fill method 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 :: Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ List of elements to render + -> Drawing px () +stroke width join caping prims = + liftF $ Stroke width join caping 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 + :: DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ 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 + :: 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. + -> [Primitive] -- ^ 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 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,131 @@-{-# 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( 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 +
src/Graphics/Rasterific/Compositor.hs view
@@ -1,151 +1,151 @@-{-# 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) + , 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,184 @@-{-# 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 #-} +-- | 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 +
src/Graphics/Rasterific/Lenses.hs view
@@ -1,147 +1,147 @@-{-# 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 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 +
src/Graphics/Rasterific/Line.hs view
@@ -1,164 +1,164 @@-{-# 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 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) +
src/Graphics/Rasterific/Linear.hs view
@@ -1,230 +1,230 @@--- | This module is a reduction of the `Linear` package--- from Edward Kmett to match just the need of Rasterific.------ If the flag `embed_linear` is disabled, this module is--- just a reexport from the real linear package.----{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Linear- ( V2( .. )- , V1( .. )- , Additive( .. )- , Epsilon( .. )- , Metric( .. )- , (^*)- , (^/)- , normalize- ) where--#ifdef EXTERNAL_LINEAR--- We just reexport-import Linear-#else--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( Applicative, pure, (<*>) )-#endif--infixl 6 ^+^, ^-^-infixl 7 ^*, ^/---- | A 2-dimensional vector------ >>> pure 1 :: V2 Int--- V2 1 1------ >>> V2 1 2 + V2 3 4--- V2 4 6------ >>> V2 1 2 * V2 3 4--- V2 3 8------ >>> sum (V2 1 2)--- 3-data V2 a = V2 !a !a- deriving (Eq, Show)---- | A 1-dimensional vector-newtype V1 a = V1 a- deriving (Eq, Show)--instance Functor V2 where- {-# INLINE fmap #-}- fmap f (V2 a b) = V2 (f a) (f b)--instance Num a => Num (V2 a) where- (V2 a b) + (V2 a' b') = V2 (a + a') (b + b')- {-# INLINE (+) #-}- (V2 a b) - (V2 a' b') = V2 (a - a') (b - b')- {-# INLINE (-) #-}- (V2 a b) * (V2 a' b') = V2 (a * a') (b * b')- {-# INLINE (*) #-}- negate (V2 a b) = V2 (negate a) (negate b)- {-# INLINE negate #-}- abs (V2 a b) = V2 (abs a) (abs b)- {-# INLINE abs #-}- signum (V2 a b) = V2 (signum a) (signum b)- {-# INLINE signum #-}- fromInteger = pure . fromInteger- {-# INLINE fromInteger #-}--instance Functor V1 where- {-# INLINE fmap #-}- fmap f (V1 a) = V1 $ f a--instance Applicative V2 where- {-# INLINE pure #-}- pure a = V2 a a- {-# INLINE (<*>) #-}- (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b)--instance Applicative V1 where- {-# INLINE pure #-}- pure = V1 - {-# INLINE (<*>) #-}- (V1 f) <*> (V1 v) = V1 $ f v---- | A vector is an additive group with additional structure.-class Functor f => Additive f where- -- | The zero vector- zero :: Num a => f a- -- | Compute the sum of two vectors- --- -- >>> V2 1 2 ^+^ V2 3 4- -- V2 4 6- (^+^) :: Num a => f a -> f a -> f a-- -- | Compute the difference between two vectors- --- -- >>> V2 4 5 - V2 3 1- -- V2 1 4- (^-^) :: Num a => f a -> f a -> f a-- -- | Linearly interpolate between two vectors.- lerp :: Num a => a -> f a -> f a -> f a---- | Provides a fairly subjective test to see if a quantity is near zero.------ >>> nearZero (1e-11 :: Double)--- False------ >>> nearZero (1e-17 :: Double)--- True------ >>> nearZero (1e-5 :: Float)--- False------ >>> nearZero (1e-7 :: Float)--- True-class Num a => Epsilon a where- -- | Determine if a quantity is near zero.- nearZero :: a -> Bool---- | @'abs' a '<=' 1e-6@-instance Epsilon Float where- nearZero a = abs a <= 1e-6- {-# INLINE nearZero #-}---- | @'abs' a '<=' 1e-12@-instance Epsilon Double where- nearZero a = abs a <= 1e-12- {-# INLINE nearZero #-}--instance Epsilon a => Epsilon (V2 a) where- nearZero = nearZero . quadrance- {-# INLINE nearZero #-}--instance Additive V2 where- zero = V2 0 0- {-# INLINE zero #-}-- (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b')- {-# INLINE (^+^) #-}-- (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b')- {-# INLINE (^-^) #-}-- lerp v a b = a ^+^ (b ^-^ a) ^* v- {-# INLINE lerp #-}--instance Additive V1 where- zero = V1 0- {-# INLINE zero #-}-- (V1 a) ^+^ (V1 a') = V1 (a + a')- {-# INLINE (^+^) #-}-- (V1 a) ^-^ (V1 a') = V1 (a - a')- {-# INLINE (^-^) #-}-- lerp v a b = a ^+^ (b ^-^ a) ^* v- {-# INLINE lerp #-}---- | Free and sparse inner product/metric spaces.-class Additive f => Metric f where- -- | Compute the inner product of two vectors or (equivalently)- -- convert a vector @f a@ into a covector @f a -> a@.- --- -- >>> V2 1 2 `dot` V2 3 4- -- 11- dot :: Num a => f a -> f a -> a-- -- | Compute the squared norm. The name quadrance arises from- -- Norman J. Wildberger's rational trigonometry.- quadrance :: Num a => f a -> a- {-# INLINE quadrance #-}- quadrance v = dot v v-- -- | Compute the quadrance of the difference- qd :: Num a => f a -> f a -> a- {-# INLINE qd #-}- qd f g = quadrance (f ^-^ g)-- -- | Compute the distance between two vectors in a metric space- distance :: Floating a => f a -> f a -> a- {-# INLINE distance #-}- distance f g = norm (f ^-^ g)-- -- | Compute the norm of a vector in a metric space- norm :: Floating a => f a -> a- {-# INLINE norm #-}- norm v = sqrt (quadrance v)-- -- | Convert a non-zero vector to unit vector.- signorm :: Floating a => f a -> f a- signorm v = fmap (/ m) v where- m = norm v--instance Metric V2 where- dot (V2 a b) (V2 a' b') = a * a' + b * b'- {-# INLINE dot #-}-- quadrance (V2 a b) = a * a + b * b- {-# INLINE quadrance #-}-- norm v = sqrt (quadrance v)- {-# INLINE norm #-}---- | Compute the right scalar product------ >>> V2 3 4 ^* 2--- V2 6 8-(^*) :: (Functor f, Num a) => f a -> a -> f a-{-# INLINE (^*) #-}-(^*) f n = fmap (* n) f---- | Compute division by a scalar on the right.-(^/) :: (Functor f, Floating a) => f a -> a -> f a-{-# INLINE (^/) #-}-(^/) f n = fmap (/ n) f---- | Normalize a 'Metric' functor to have unit 'norm'. This function--- does not change the functor if its 'norm' is 0 or 1.-normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a-{-# INLINE normalize #-}-normalize v = if nearZero l || nearZero (1-l) then v- else fmap (/ sqrt l) v- where l = quadrance v--#endif-+-- | This module is a reduction of the `Linear` package +-- from Edward Kmett to match just the need of Rasterific. +-- +-- If the flag `embed_linear` is disabled, this module is +-- just a reexport from the real linear package. +-- +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Linear + ( V2( .. ) + , V1( .. ) + , Additive( .. ) + , Epsilon( .. ) + , Metric( .. ) + , (^*) + , (^/) + , normalize + ) where + +#ifdef EXTERNAL_LINEAR +-- We just reexport +import Linear +#else + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( Applicative, pure, (<*>) ) +#endif + +infixl 6 ^+^, ^-^ +infixl 7 ^*, ^/ + +-- | A 2-dimensional vector +-- +-- >>> pure 1 :: V2 Int +-- V2 1 1 +-- +-- >>> V2 1 2 + V2 3 4 +-- V2 4 6 +-- +-- >>> V2 1 2 * V2 3 4 +-- V2 3 8 +-- +-- >>> sum (V2 1 2) +-- 3 +data V2 a = V2 !a !a + deriving (Eq, Show) + +-- | A 1-dimensional vector +newtype V1 a = V1 a + deriving (Eq, Show) + +instance Functor V2 where + {-# INLINE fmap #-} + fmap f (V2 a b) = V2 (f a) (f b) + +instance Num a => Num (V2 a) where + (V2 a b) + (V2 a' b') = V2 (a + a') (b + b') + {-# INLINE (+) #-} + (V2 a b) - (V2 a' b') = V2 (a - a') (b - b') + {-# INLINE (-) #-} + (V2 a b) * (V2 a' b') = V2 (a * a') (b * b') + {-# INLINE (*) #-} + negate (V2 a b) = V2 (negate a) (negate b) + {-# INLINE negate #-} + abs (V2 a b) = V2 (abs a) (abs b) + {-# INLINE abs #-} + signum (V2 a b) = V2 (signum a) (signum b) + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Functor V1 where + {-# INLINE fmap #-} + fmap f (V1 a) = V1 $ f a + +instance Applicative V2 where + {-# INLINE pure #-} + pure a = V2 a a + {-# INLINE (<*>) #-} + (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b) + +instance Applicative V1 where + {-# INLINE pure #-} + pure = V1 + {-# INLINE (<*>) #-} + (V1 f) <*> (V1 v) = V1 $ f v + +-- | A vector is an additive group with additional structure. +class Functor f => Additive f where + -- | The zero vector + zero :: Num a => f a + -- | Compute the sum of two vectors + -- + -- >>> V2 1 2 ^+^ V2 3 4 + -- V2 4 6 + (^+^) :: Num a => f a -> f a -> f a + + -- | Compute the difference between two vectors + -- + -- >>> V2 4 5 - V2 3 1 + -- V2 1 4 + (^-^) :: Num a => f a -> f a -> f a + + -- | Linearly interpolate between two vectors. + lerp :: Num a => a -> f a -> f a -> f a + +-- | Provides a fairly subjective test to see if a quantity is near zero. +-- +-- >>> nearZero (1e-11 :: Double) +-- False +-- +-- >>> nearZero (1e-17 :: Double) +-- True +-- +-- >>> nearZero (1e-5 :: Float) +-- False +-- +-- >>> nearZero (1e-7 :: Float) +-- True +class Num a => Epsilon a where + -- | Determine if a quantity is near zero. + nearZero :: a -> Bool + +-- | @'abs' a '<=' 1e-6@ +instance Epsilon Float where + nearZero a = abs a <= 1e-6 + {-# INLINE nearZero #-} + +-- | @'abs' a '<=' 1e-12@ +instance Epsilon Double where + nearZero a = abs a <= 1e-12 + {-# INLINE nearZero #-} + +instance Epsilon a => Epsilon (V2 a) where + nearZero = nearZero . quadrance + {-# INLINE nearZero #-} + +instance Additive V2 where + zero = V2 0 0 + {-# INLINE zero #-} + + (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b') + {-# INLINE (^+^) #-} + + (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b') + {-# INLINE (^-^) #-} + + lerp v a b = a ^+^ (b ^-^ a) ^* v + {-# INLINE lerp #-} + +instance Additive V1 where + zero = V1 0 + {-# INLINE zero #-} + + (V1 a) ^+^ (V1 a') = V1 (a + a') + {-# INLINE (^+^) #-} + + (V1 a) ^-^ (V1 a') = V1 (a - a') + {-# INLINE (^-^) #-} + + lerp v a b = a ^+^ (b ^-^ a) ^* v + {-# INLINE lerp #-} + +-- | Free and sparse inner product/metric spaces. +class Additive f => Metric f where + -- | Compute the inner product of two vectors or (equivalently) + -- convert a vector @f a@ into a covector @f a -> a@. + -- + -- >>> V2 1 2 `dot` V2 3 4 + -- 11 + dot :: Num a => f a -> f a -> a + + -- | Compute the squared norm. The name quadrance arises from + -- Norman J. Wildberger's rational trigonometry. + quadrance :: Num a => f a -> a + {-# INLINE quadrance #-} + quadrance v = dot v v + + -- | Compute the quadrance of the difference + qd :: Num a => f a -> f a -> a + {-# INLINE qd #-} + qd f g = quadrance (f ^-^ g) + + -- | Compute the distance between two vectors in a metric space + distance :: Floating a => f a -> f a -> a + {-# INLINE distance #-} + distance f g = norm (f ^-^ g) + + -- | Compute the norm of a vector in a metric space + norm :: Floating a => f a -> a + {-# INLINE norm #-} + norm v = sqrt (quadrance v) + + -- | Convert a non-zero vector to unit vector. + signorm :: Floating a => f a -> f a + signorm v = fmap (/ m) v where + m = norm v + +instance Metric V2 where + dot (V2 a b) (V2 a' b') = a * a' + b * b' + {-# INLINE dot #-} + + quadrance (V2 a b) = a * a + b * b + {-# INLINE quadrance #-} + + norm v = sqrt (quadrance v) + {-# INLINE norm #-} + +-- | Compute the right scalar product +-- +-- >>> V2 3 4 ^* 2 +-- V2 6 8 +(^*) :: (Functor f, Num a) => f a -> a -> f a +{-# INLINE (^*) #-} +(^*) f n = fmap (* n) f + +-- | Compute division by a scalar on the right. +(^/) :: (Functor f, Floating a) => f a -> a -> f a +{-# INLINE (^/) #-} +(^/) f n = fmap (/ n) f + +-- | Normalize a 'Metric' functor to have unit 'norm'. This function +-- does not change the functor if its 'norm' is 0 or 1. +normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a +{-# INLINE normalize #-} +normalize v = if nearZero l || nearZero (1-l) then v + else fmap (/ sqrt l) v + where l = quadrance v + +#endif +
src/Graphics/Rasterific/Operators.hs view
@@ -1,165 +1,165 @@-{-# 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/Outline.hs view
@@ -1,30 +1,30 @@--- | This module provide helper functions to create outline--- of shapes.-module Graphics.Rasterific.Outline- ( StrokeWidth- , strokize- , S.dashedStrokize - , S.approximatePathLength- ) where--import Graphics.Rasterific.Types-import qualified Graphics.Rasterific.StrokeInternal as S---- | This function will create the outline of a given geometry--- given a path. You can then stroke it.------ > stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $--- > strokize 40 JoinRound (CapRound, CapRound)--- > [CubicBezierPrim $--- > CubicBezier (V2 40 160) (V2 40 40)--- > (V2 160 40) (V2 160 160)]------ <<docimages/strokize_path.png>>----strokize :: StrokeWidth -- ^ Stroke width- -> Join -- ^ Which kind of join will be used- -> (Cap, Cap) -- ^ Start and end capping.- -> [Primitive] -- ^ List of elements to strokize- -> [Primitive]-strokize w j c = listOfContainer . S.strokize w j c-+-- | This module provide helper functions to create outline +-- of shapes. +module Graphics.Rasterific.Outline + ( StrokeWidth + , strokize + , S.dashedStrokize + , S.approximatePathLength + ) where + +import Graphics.Rasterific.Types +import qualified Graphics.Rasterific.StrokeInternal as S + +-- | This function will create the outline of a given geometry +-- given a path. You can then stroke it. +-- +-- > stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ +-- > strokize 40 JoinRound (CapRound, CapRound) +-- > [CubicBezierPrim $ +-- > CubicBezier (V2 40 160) (V2 40 40) +-- > (V2 160 40) (V2 160 160)] +-- +-- <<docimages/strokize_path.png>> +-- +strokize :: StrokeWidth -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ List of elements to strokize + -> [Primitive] +strokize w j c = listOfContainer . S.strokize w j c +
src/Graphics/Rasterific/PathWalker.hs view
@@ -1,131 +1,131 @@-{-# 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.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 +
src/Graphics/Rasterific/PlaneBoundable.hs view
@@ -1,88 +1,88 @@-{-# 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( 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 +
src/Graphics/Rasterific/QuadraticBezier.hs view
@@ -1,291 +1,291 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--- | Module handling math regarding the handling of quadratic--- and cubic bezier curve.-module Graphics.Rasterific.QuadraticBezier- ( -- * Helper functions- straightLine- , bezierFromPath- , decomposeBeziers- , clipBezier- , sanitizeBezier- , offsetBezier- , flattenBezier- , bezierBreakAt- , bezierLengthApproximation- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( pure )-import Data.Monoid( Monoid( mempty ) )-#endif-import Graphics.Rasterific.Linear- ( V2( .. )- , (^-^)- , (^+^)- , (^*)- , dot- , norm- , lerp- )--import Data.Monoid( (<>) )-import Graphics.Rasterific.Operators-import Graphics.Rasterific.Types---- | Create a list of bezier patch from a list of points,------ > bezierFromPath [a, b, c, d, e] == [Bezier a b c, Bezier c d e]--- > bezierFromPath [a, b, c, d, e, f] == [Bezier a b c, Bezier c d e]--- > bezierFromPath [a, b, c, d, e, f, g] ==--- > [Bezier a b c, Bezier c d e, Bezier e f g]----bezierFromPath :: [Point] -> [Bezier]-bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest-bezierFromPath _ = []---- | Only work if the quadratic bezier curve--- is nearly flat-bezierLengthApproximation :: Bezier -> Float-bezierLengthApproximation (Bezier a _ c) =- norm $ c ^-^ a--decomposeBeziers :: Bezier -> Producer EdgeSample-decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) =- go aRx aRy bRx bRy cRx cRy where- go ax ay _bx _by cx cy cont- | insideX && insideY =- let !px = fromIntegral $ min floorAx floorCx- !py = fromIntegral $ min floorAy floorCy- !w = px + 1 - cx `middle` ax- !h = cy - ay- in- EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont- where- floorAx, floorAy :: Int- !floorAx = floor ax- !floorAy = floor ay-- !floorCx = floor cx- !floorCy = floor cy-- !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int)- !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int)--- go !ax !ay !bx !by !cx !cy cont =- go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont- where- !abx = ax `middle` bx- !aby = ay `middle` by-- !bcx = bx `middle` cx- !bcy = by `middle` cy-- !abbcx = abx `middle` bcx- !abbcy = aby `middle` bcy-- !mx | abs (abbcx - mini) < 0.1 = mini- | abs (abbcx - maxi) < 0.1 = maxi- | otherwise = abbcx- where !mini = fromIntegral (floor abbcx :: Int)- !maxi = fromIntegral (ceiling abbcx :: Int)-- !my | abs (abbcy - mini) < 0.1 = mini- | abs (abbcy - maxi) < 0.1 = maxi- | otherwise = abbcy- where !mini = fromIntegral (floor abbcy :: Int)- !maxi = fromIntegral (ceiling abbcy :: Int)----- | Create a quadratic bezier curve representing--- a straight line.-straightLine :: Point -> Point -> Bezier-straightLine a c = Bezier a (a `midPoint` c) c---- | Clamp the bezier curve inside a rectangle--- given in parameter.-clipBezier :: Point -- ^ Point representing the "minimal" point for cliping- -> Point -- ^ Point representing the "maximal" point for cliping- -> Bezier -- ^ The quadratic bezier curve to be clamped- -> Container Primitive-clipBezier mini maxi bezier@(Bezier a b c)- -- If we are in the range bound, return the curve- -- unaltered- | insideX && insideY = pure $ BezierPrim 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 . BezierPrim $ clampedA `straightLine` clampedC- -- Not completly inside nor outside, just divide- -- and conquer.- | otherwise =- recurse (Bezier a ab m) <>- recurse (Bezier m bc c)- where -- Minimal & maximal dimension of the bezier curve- bmin = vmin a $ vmin b c- bmax = vmax a $ vmax b c-- recurse = clipBezier mini maxi-- clamper = clampPoint mini maxi- clampedA = clamper a- clampedC = clamper c-- V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi- V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin-- --- -- X B- -- / \- -- / \- -- ab X--X--X bc- -- / abbc \- -- / \- -- A X X C- --- (ab, bc, abbc) = splitBezier bezier-- -- 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 (abbc ^-^ mini) ^<^ vabs (abbc ^-^ 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 (abbc ^-^ edge) ^< 0.1) edge abbc----- | Rewrite the bezier curve to avoid degenerate cases.-sanitizeBezier :: Bezier -> Container Primitive-sanitizeBezier bezier@(Bezier a b c)- -- If the two normals vector are far apart (cos nearly -1)- --- -- u v- -- <---------- ------------>- -- because u dot v = ||u|| * ||v|| * cos(uv)- --- -- This imply that AB and BC are nearly parallel- | u `dot` v < -0.9999 =- -- divide in to halves with- sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <>- sanitizeBezier (Bezier abbc (abbc `midPoint` c) c)-- -- b is far enough of b and c, (it's not a point)- | a `isDistingableFrom` b && b `isDistingableFrom` c =- pure . BezierPrim $ bezier-- -- if b is to nearby a or c, take the midpoint as new reference.- | ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c)- | otherwise = mempty- where u = a `normal` b- v = b `normal` c- ac = a `midPoint` c- abbc = (a `midPoint` b) `midPoint` (b `midPoint` c)--bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier)-bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c)- where- -- X B- -- / \- -- / \- -- ab X--X--X bc- -- / abbc \- -- / \- -- A X X C- ab = lerp t a b- bc = lerp t b c- abbc = lerp t ab bc--splitBezier :: Bezier -> (Point, Point, Point)-{-# INLINE splitBezier #-}-splitBezier (Bezier a b c) = (ab, bc, abbc)- where- --- -- X B- -- / \- -- / \- -- ab X--X--X bc- -- / abbc \- -- / \- -- A X X C- --- ab = a `midPoint` b- bc = b `midPoint` c- abbc = ab `midPoint` bc--flattenBezier :: Bezier -> Container Primitive-flattenBezier bezier@(Bezier a b c)- -- If the spline is not too curvy, just return the- -- shifted component- | u `dot` v >= 0.9 = pure $ BezierPrim bezier- -- Otherwise, divide and conquer- | a /= b && b /= c =- flattenBezier (Bezier a ab abbc) <>- flattenBezier (Bezier abbc bc c)- | otherwise = mempty- where --- -- X B - -- ^ /^\ ^- -- u \ /w| \ / v- -- X-----X- -- / \- -- / \- -- A X X C- --- u = a `normal` b- v = b `normal` c-- (ab, bc, abbc) = splitBezier bezier---- | Move the bezier to a new position with an offset.-offsetBezier :: Float -> Bezier -> Container Primitive-offsetBezier offset bezier@(Bezier a b c)- -- If the spline is not too curvy, just return the- -- shifted component- | u `dot` v >= 0.9 =- pure . BezierPrim $ Bezier shiftedA mergedB shiftedC- -- Otherwise, divide and conquer- | a /= b && b /= c =- offsetBezier offset (Bezier a ab abbc) <>- offsetBezier offset (Bezier abbc bc c)- | otherwise = mempty- where --- -- X B - -- ^ /^\ ^- -- u \ /w| \ / v- -- X-----X- -- / \- -- / \- -- A X X C- --- u = a `normal` b- v = b `normal` c- w = ab `normal` bc-- (ab, bc, abbc) = splitBezier bezier-- shiftedA = a ^+^ (u ^* offset)- shiftedC = c ^+^ (v ^* offset)- shiftedABBC = abbc ^+^ (w ^* offset)- mergedB =- (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC)-+{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +-- | Module handling math regarding the handling of quadratic +-- and cubic bezier curve. +module Graphics.Rasterific.QuadraticBezier + ( -- * Helper functions + straightLine + , bezierFromPath + , decomposeBeziers + , clipBezier + , sanitizeBezier + , offsetBezier + , flattenBezier + , bezierBreakAt + , bezierLengthApproximation + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure ) +import Data.Monoid( Monoid( mempty ) ) +#endif +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , dot + , norm + , lerp + ) + +import Data.Monoid( (<>) ) +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types + +-- | Create a list of bezier patch from a list of points, +-- +-- > bezierFromPath [a, b, c, d, e] == [Bezier a b c, Bezier c d e] +-- > bezierFromPath [a, b, c, d, e, f] == [Bezier a b c, Bezier c d e] +-- > bezierFromPath [a, b, c, d, e, f, g] == +-- > [Bezier a b c, Bezier c d e, Bezier e f g] +-- +bezierFromPath :: [Point] -> [Bezier] +bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest +bezierFromPath _ = [] + +-- | Only work if the quadratic bezier curve +-- is nearly flat +bezierLengthApproximation :: Bezier -> Float +bezierLengthApproximation (Bezier a _ c) = + norm $ c ^-^ a + +decomposeBeziers :: Bezier -> Producer EdgeSample +decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) = + go aRx aRy bRx bRy cRx cRy where + go ax ay _bx _by cx cy cont + | insideX && insideY = + let !px = fromIntegral $ min floorAx floorCx + !py = fromIntegral $ min floorAy floorCy + !w = px + 1 - cx `middle` ax + !h = cy - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont + where + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay + + !floorCx = floor cx + !floorCy = floor cy + + !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int) + !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int) + + + go !ax !ay !bx !by !cx !cy cont = + go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont + where + !abx = ax `middle` bx + !aby = ay `middle` by + + !bcx = bx `middle` cx + !bcy = by `middle` cy + + !abbcx = abx `middle` bcx + !abbcy = aby `middle` bcy + + !mx | abs (abbcx - mini) < 0.1 = mini + | abs (abbcx - maxi) < 0.1 = maxi + | otherwise = abbcx + where !mini = fromIntegral (floor abbcx :: Int) + !maxi = fromIntegral (ceiling abbcx :: Int) + + !my | abs (abbcy - mini) < 0.1 = mini + | abs (abbcy - maxi) < 0.1 = maxi + | otherwise = abbcy + where !mini = fromIntegral (floor abbcy :: Int) + !maxi = fromIntegral (ceiling abbcy :: Int) + + +-- | Create a quadratic bezier curve representing +-- a straight line. +straightLine :: Point -> Point -> Bezier +straightLine a c = Bezier a (a `midPoint` c) c + +-- | Clamp the bezier curve inside a rectangle +-- given in parameter. +clipBezier :: Point -- ^ Point representing the "minimal" point for cliping + -> Point -- ^ Point representing the "maximal" point for cliping + -> Bezier -- ^ The quadratic bezier curve to be clamped + -> Container Primitive +clipBezier mini maxi bezier@(Bezier a b c) + -- If we are in the range bound, return the curve + -- unaltered + | insideX && insideY = pure $ BezierPrim 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 . BezierPrim $ clampedA `straightLine` clampedC + -- Not completly inside nor outside, just divide + -- and conquer. + | otherwise = + recurse (Bezier a ab m) <> + recurse (Bezier m bc c) + where -- Minimal & maximal dimension of the bezier curve + bmin = vmin a $ vmin b c + bmax = vmax a $ vmax b c + + recurse = clipBezier mini maxi + + clamper = clampPoint mini maxi + clampedA = clamper a + clampedC = clamper c + + V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi + V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin + + -- + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + -- + (ab, bc, abbc) = splitBezier bezier + + -- 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 (abbc ^-^ mini) ^<^ vabs (abbc ^-^ 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 (abbc ^-^ edge) ^< 0.1) edge abbc + + +-- | Rewrite the bezier curve to avoid degenerate cases. +sanitizeBezier :: Bezier -> Container Primitive +sanitizeBezier bezier@(Bezier a b c) + -- If the two normals vector are far apart (cos nearly -1) + -- + -- u v + -- <---------- ------------> + -- because u dot v = ||u|| * ||v|| * cos(uv) + -- + -- This imply that AB and BC are nearly parallel + | u `dot` v < -0.9999 = + -- divide in to halves with + sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <> + sanitizeBezier (Bezier abbc (abbc `midPoint` c) c) + + -- b is far enough of b and c, (it's not a point) + | a `isDistingableFrom` b && b `isDistingableFrom` c = + pure . BezierPrim $ bezier + + -- if b is to nearby a or c, take the midpoint as new reference. + | ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c) + | otherwise = mempty + where u = a `normal` b + v = b `normal` c + ac = a `midPoint` c + abbc = (a `midPoint` b) `midPoint` (b `midPoint` c) + +bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier) +bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c) + where + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + ab = lerp t a b + bc = lerp t b c + abbc = lerp t ab bc + +splitBezier :: Bezier -> (Point, Point, Point) +{-# INLINE splitBezier #-} +splitBezier (Bezier a b c) = (ab, bc, abbc) + where + -- + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + -- + ab = a `midPoint` b + bc = b `midPoint` c + abbc = ab `midPoint` bc + +flattenBezier :: Bezier -> Container Primitive +flattenBezier bezier@(Bezier a b c) + -- If the spline is not too curvy, just return the + -- shifted component + | u `dot` v >= 0.9 = pure $ BezierPrim bezier + -- Otherwise, divide and conquer + | a /= b && b /= c = + flattenBezier (Bezier a ab abbc) <> + flattenBezier (Bezier abbc bc c) + | otherwise = mempty + where -- + -- X B + -- ^ /^\ ^ + -- u \ /w| \ / v + -- X-----X + -- / \ + -- / \ + -- A X X C + -- + u = a `normal` b + v = b `normal` c + + (ab, bc, abbc) = splitBezier bezier + +-- | Move the bezier to a new position with an offset. +offsetBezier :: Float -> Bezier -> Container Primitive +offsetBezier offset bezier@(Bezier a b c) + -- If the spline is not too curvy, just return the + -- shifted component + | u `dot` v >= 0.9 = + pure . BezierPrim $ Bezier shiftedA mergedB shiftedC + -- Otherwise, divide and conquer + | a /= b && b /= c = + offsetBezier offset (Bezier a ab abbc) <> + offsetBezier offset (Bezier abbc bc c) + | otherwise = mempty + where -- + -- X B + -- ^ /^\ ^ + -- u \ /w| \ / v + -- X-----X + -- / \ + -- / \ + -- A X X C + -- + u = a `normal` b + v = b `normal` c + w = ab `normal` bc + + (ab, bc, abbc) = splitBezier bezier + + shiftedA = a ^+^ (u ^* offset) + shiftedC = c ^+^ (v ^* offset) + shiftedABBC = abbc ^+^ (w ^* offset) + mergedB = + (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC) +
src/Graphics/Rasterific/QuadraticFormula.hs view
@@ -1,56 +1,56 @@-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. )- , discriminant- , formulaRoots- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( Applicative( .. ) )-#endif---- | Represent an equation `a * x^2 + b * x + c = 0`-data QuadraticFormula a = QuadraticFormula- { _coeffA :: !a -- ^ Coefficient for the square part (x^2)- , _coeffB :: !a -- ^ Coefficient the linear part (x)- , _coeffC :: !a -- ^ Constant- }--instance Functor QuadraticFormula where- {-# INLINE fmap #-}- fmap f (QuadraticFormula a b c) =- QuadraticFormula (f a) (f b) (f c)----instance Applicative QuadraticFormula where- pure a = QuadraticFormula a a a- {-# INLINE pure #-}-- QuadraticFormula a b c <*> QuadraticFormula d e f =- QuadraticFormula (a d) (b e) (c f)- {-# INLINE (<*>) #-}---- | Discriminant equation, if the result is:------ * Below 0, then the formula doesn't have any solution------ * Equal to 0, then the formula has an unique root.------ * Above 0, the formula has two solutions----discriminant :: Num a => QuadraticFormula a -> a-discriminant (QuadraticFormula a b c) = b * b - 4 * a *c---- | Extract all the roots of the formula ie. where the--- unknown gives a result of 0-formulaRoots :: (Ord a, Floating a) => QuadraticFormula a -> [a]-formulaRoots formula@(QuadraticFormula a b _)- | disc < 0 = []- | disc == 0 = [positiveResult]- | otherwise = [positiveResult, negativeResult]- where- disc = discriminant formula- squarePart = sqrt disc- positiveResult = (negate b + squarePart) / (2 * a)- negativeResult = (negate b - squarePart) / (2 * a)-+{-# LANGUAGE CPP #-} +module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. ) + , discriminant + , formulaRoots + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( Applicative( .. ) ) +#endif + +-- | Represent an equation `a * x^2 + b * x + c = 0` +data QuadraticFormula a = QuadraticFormula + { _coeffA :: !a -- ^ Coefficient for the square part (x^2) + , _coeffB :: !a -- ^ Coefficient the linear part (x) + , _coeffC :: !a -- ^ Constant + } + +instance Functor QuadraticFormula where + {-# INLINE fmap #-} + fmap f (QuadraticFormula a b c) = + QuadraticFormula (f a) (f b) (f c) + + + +instance Applicative QuadraticFormula where + pure a = QuadraticFormula a a a + {-# INLINE pure #-} + + QuadraticFormula a b c <*> QuadraticFormula d e f = + QuadraticFormula (a d) (b e) (c f) + {-# INLINE (<*>) #-} + +-- | Discriminant equation, if the result is: +-- +-- * Below 0, then the formula doesn't have any solution +-- +-- * Equal to 0, then the formula has an unique root. +-- +-- * Above 0, the formula has two solutions +-- +discriminant :: Num a => QuadraticFormula a -> a +discriminant (QuadraticFormula a b c) = b * b - 4 * a *c + +-- | Extract all the roots of the formula ie. where the +-- unknown gives a result of 0 +formulaRoots :: (Ord a, Floating a) => QuadraticFormula a -> [a] +formulaRoots formula@(QuadraticFormula a b _) + | disc < 0 = [] + | disc == 0 = [positiveResult] + | otherwise = [positiveResult, negativeResult] + where + disc = discriminant formula + squarePart = sqrt disc + positiveResult = (negate b + squarePart) / (2 * a) + negativeResult = (negate b - squarePart) / (2 * a) +
src/Graphics/Rasterific/Rasterize.hs view
@@ -1,92 +1,92 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Rasterize- ( CoverageSpan( .. )- , rasterize- , clip- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable( foldMap )-#endif--import Control.Monad.ST( runST )-import Data.Fixed( mod' )-import Data.Monoid( Endo( Endo, appEndo ) )-import Graphics.Rasterific.Types-import Graphics.Rasterific.QuadraticBezier-import Graphics.Rasterific.CubicBezier-import Graphics.Rasterific.Line-import qualified Data.Vector as V-import qualified Data.Vector.Algorithms.Intro as VS--data CoverageSpan = CoverageSpan- { _coverageX :: {-# UNPACK #-} !Float- , _coverageY :: {-# UNPACK #-} !Float- , _coverageVal :: {-# UNPACK #-} !Float- , _coverageLength :: {-# UNPACK #-} !Float- }- deriving Show--combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample- -> [CoverageSpan]-{-# INLINE combineEdgeSamples #-}-combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0- where- !maxi = V.length vec- go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1]- go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where- sub (EdgeSample x' y' a' h')- | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h')- | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h')- | otherwise =- CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h'- where p1 = CoverageSpan x y (prepareCoverage a) 1- p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1)---- | Clip the geometry to a rectangle.-clip :: Point -- ^ Minimum point (corner upper left)- -> Point -- ^ Maximum point (corner bottom right)- -> Primitive -- ^ Primitive to be clipped- -> Container Primitive-clip mini maxi (LinePrim l) = clipLine mini maxi l-clip mini maxi (BezierPrim b) = clipBezier mini maxi b-clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c--decompose :: Primitive -> Producer EdgeSample-decompose (LinePrim l) = decomposeLine l-decompose (BezierPrim b) = decomposeBeziers b-decompose (CubicBezierPrim c) =- {-decomposeCubicBezierForwardDifference c-}- decomposeCubicBeziers c--xyCompare :: EdgeSample -> EdgeSample -> Ordering-{-# INLINE xyCompare #-}-xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax })- !(EdgeSample { _sampleY = by, _sampleX = bx }) =- case compare ay by of- EQ -> compare ax bx- c -> c--sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample-sortEdgeSamples samples = runST $ do- -- Resist the urge to make this a storable vector,- -- it is actually a pessimisation.- mutableVector <- V.unsafeThaw $ V.fromList samples- VS.sortBy xyCompare mutableVector- V.unsafeFreeze mutableVector--rasterize :: FillMethod -> Container Primitive -> [CoverageSpan]-rasterize method = - case method of- FillWinding -> combineEdgeSamples combineWinding - . sortEdgeSamples- . (($ []) . appEndo)- . foldMap (Endo . decompose)- FillEvenOdd -> combineEdgeSamples combineEvenOdd- . sortEdgeSamples- . (($ []) . appEndo)- . foldMap (Endo . decompose)- where combineWinding = min 1 . abs- combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1-+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Rasterize + ( CoverageSpan( .. ) + , rasterize + , clip + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable( foldMap ) +#endif + +import Control.Monad.ST( runST ) +import Data.Fixed( mod' ) +import Data.Monoid( Endo( Endo, appEndo ) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Line +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Intro as VS + +data CoverageSpan = CoverageSpan + { _coverageX :: {-# UNPACK #-} !Float + , _coverageY :: {-# UNPACK #-} !Float + , _coverageVal :: {-# UNPACK #-} !Float + , _coverageLength :: {-# UNPACK #-} !Float + } + deriving Show + +combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample + -> [CoverageSpan] +{-# INLINE combineEdgeSamples #-} +combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0 + where + !maxi = V.length vec + go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1] + go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where + sub (EdgeSample x' y' a' h') + | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h') + | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h') + | otherwise = + CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h' + where p1 = CoverageSpan x y (prepareCoverage a) 1 + p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) + +-- | Clip the geometry to a rectangle. +clip :: Point -- ^ Minimum point (corner upper left) + -> Point -- ^ Maximum point (corner bottom right) + -> Primitive -- ^ Primitive to be clipped + -> Container Primitive +clip mini maxi (LinePrim l) = clipLine mini maxi l +clip mini maxi (BezierPrim b) = clipBezier mini maxi b +clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c + +decompose :: Primitive -> Producer EdgeSample +decompose (LinePrim l) = decomposeLine l +decompose (BezierPrim b) = decomposeBeziers b +decompose (CubicBezierPrim c) = + {-decomposeCubicBezierForwardDifference c-} + decomposeCubicBeziers c + +xyCompare :: EdgeSample -> EdgeSample -> Ordering +{-# INLINE xyCompare #-} +xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax }) + !(EdgeSample { _sampleY = by, _sampleX = bx }) = + case compare ay by of + EQ -> compare ax bx + c -> c + +sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample +sortEdgeSamples samples = runST $ do + -- Resist the urge to make this a storable vector, + -- it is actually a pessimisation. + mutableVector <- V.unsafeThaw $ V.fromList samples + VS.sortBy xyCompare mutableVector + V.unsafeFreeze mutableVector + +rasterize :: FillMethod -> Container Primitive -> [CoverageSpan] +rasterize method = + case method of + FillWinding -> combineEdgeSamples combineWinding + . sortEdgeSamples + . (($ []) . appEndo) + . foldMap (Endo . decompose) + FillEvenOdd -> combineEdgeSamples combineEvenOdd + . sortEdgeSamples + . (($ []) . appEndo) + . foldMap (Endo . decompose) + where combineWinding = min 1 . abs + combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1 +
src/Graphics/Rasterific/Shading.hs view
@@ -1,490 +1,490 @@-{-# 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 + , 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 +
src/Graphics/Rasterific/StrokeInternal.hs view
@@ -1,300 +1,300 @@-{-# 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 :: StrokeWidth -> Join -> (Cap, Cap) -> [Primitive]- -> Container Primitive-strokize width join (capStart, capEnd) beziers =- offseter capEnd sanitized <>- offseter capStart (reverse $ reversePrimitive <$> sanitized)- where - sanitized = foldMap (listOfContainer . sanitize) beziers- 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)--- > [CubicBezierPrim $--- > CubicBezier (V2 40 160) (V2 40 40)--- > (V2 160 40) (V2 160 160)]------ <<docimages/strokize_dashed_path.png>>----dashedStrokize :: 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.- -> [Primitive] -- ^ List of elements to transform- -> [[Primitive]]-dashedStrokize offset dashPattern width join capping beziers =- listOfContainer . strokize width join capping- <$> dashize offset dashPattern beziers-+{-# 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 :: StrokeWidth -> Join -> (Cap, Cap) -> [Primitive] + -> Container Primitive +strokize width join (capStart, capEnd) beziers = + offseter capEnd sanitized <> + offseter capStart (reverse $ reversePrimitive <$> sanitized) + where + sanitized = foldMap (listOfContainer . sanitize) beziers + 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) +-- > [CubicBezierPrim $ +-- > CubicBezier (V2 40 160) (V2 40 40) +-- > (V2 160 40) (V2 160 160)] +-- +-- <<docimages/strokize_dashed_path.png>> +-- +dashedStrokize :: 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. + -> [Primitive] -- ^ List of elements to transform + -> [[Primitive]] +dashedStrokize offset dashPattern width join capping beziers = + listOfContainer . strokize width join capping + <$> dashize offset dashPattern beziers +
src/Graphics/Rasterific/Texture.hs view
@@ -1,147 +1,147 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Module describing the various filling method of the--- geometric primitives.------ All points coordinate given in this module are expressed--- final image pixel coordinates.-module Graphics.Rasterific.Texture- ( Texture- , Gradient- , withSampler- , uniformTexture- -- * Texture kind- , linearGradientTexture- , radialGradientTexture- , radialGradientWithFocusTexture- , sampledImageTexture-- -- * Texture manipulation- , modulateTexture- , transformTexture - ) where---import Codec.Picture.Types( Pixel( .. )- , Image( .. )- )-import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ), Line( .. ) )-import Graphics.Rasterific.Shading-import Graphics.Rasterific.Transformations---- | Set the repeat pattern of the texture (if any).--- With padding:------ > withTexture (sampledImageTexture textureImage) $--- > fill $ rectangle (V2 0 0) 200 200------ <<docimages/sampled_texture_pad.png>>------ With repeat:------ > withTexture (withSampler SamplerRepeat $--- > sampledImageTexture textureImage) $--- > fill $ rectangle (V2 0 0) 200 200------ <<docimages/sampled_texture_repeat.png>>------ With reflect:------ > withTexture (withSampler SamplerReflect $--- > sampledImageTexture textureImage) $--- > fill $ rectangle (V2 0 0) 200 200------ <<docimages/sampled_texture_reflect.png>>----withSampler :: SamplerRepeat -> Texture px -> Texture px-withSampler = WithSampler---- | Transform the coordinates used for texture before applying--- it, allow interesting transformations.------ > withTexture (withSampler SamplerRepeat $--- > transformTexture (rotateCenter 1 (V2 0 0) <> --- > scale 0.5 0.25)--- > $ sampledImageTexture textureImage) $--- > fill $ rectangle (V2 0 0) 200 200------ <<docimages/sampled_texture_scaled.png>>----transformTexture :: Transformation -> Texture px -> Texture px-transformTexture = WithTextureTransform---- | The uniform texture is the simplest texture of all:--- an uniform color.-uniformTexture :: px -- ^ The color used for all the texture.- -> Texture px-uniformTexture = SolidTexture---- | Linear gradient texture.------ > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255)--- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255)--- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in--- > withTexture (linearGradientTexture SamplerPad gradDef--- > (V2 40 40) (V2 130 130)) $--- > fill $ circle (V2 100 100) 100------ <<docimages/linear_gradient.png>>----linearGradientTexture :: Gradient px -- ^ Gradient description.- -> Point -- ^ Linear gradient start point.- -> Point -- ^ Linear gradient end point.- -> Texture px-linearGradientTexture gradient start end =- LinearGradientTexture gradient (Line start end)---- | Use another image as a texture for the filling.--- Contrary to `imageTexture`, this function perform a bilinear--- filtering on the texture.----sampledImageTexture :: Image px -> Texture px-sampledImageTexture = SampledTexture---- | Radial gradient texture------ > 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------ <<docimages/radial_gradient.png>>----radialGradientTexture :: Gradient px -- ^ Gradient description- -> Point -- ^ Radial gradient center- -> Float -- ^ Radial gradient radius- -> Texture px-radialGradientTexture = RadialGradientTexture---- | Radial gradient texture with a focus point.------ > 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------ <<docimages/radial_gradient_focus.png>>----radialGradientWithFocusTexture- :: Gradient px -- ^ Gradient description- -> Point -- ^ Radial gradient center- -> Float -- ^ Radial gradient radius- -> Point -- ^ Radial gradient focus point- -> Texture px-radialGradientWithFocusTexture = RadialGradientWithFocusTexture---- | Perform a multiplication operation between a full color texture--- and a greyscale one, used for clip-path implementation.-modulateTexture :: (Pixel px)- => Texture px -- ^ The full blown texture.- -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture.- -> Texture px -- ^ The resulting texture.-modulateTexture = ModulateTexture-+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module describing the various filling method of the +-- geometric primitives. +-- +-- All points coordinate given in this module are expressed +-- final image pixel coordinates. +module Graphics.Rasterific.Texture + ( Texture + , Gradient + , withSampler + , uniformTexture + -- * Texture kind + , linearGradientTexture + , radialGradientTexture + , radialGradientWithFocusTexture + , sampledImageTexture + + -- * Texture manipulation + , modulateTexture + , transformTexture + ) where + + +import Codec.Picture.Types( Pixel( .. ) + , Image( .. ) + ) +import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ), Line( .. ) ) +import Graphics.Rasterific.Shading +import Graphics.Rasterific.Transformations + +-- | Set the repeat pattern of the texture (if any). +-- With padding: +-- +-- > withTexture (sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <<docimages/sampled_texture_pad.png>> +-- +-- With repeat: +-- +-- > withTexture (withSampler SamplerRepeat $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <<docimages/sampled_texture_repeat.png>> +-- +-- With reflect: +-- +-- > withTexture (withSampler SamplerReflect $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <<docimages/sampled_texture_reflect.png>> +-- +withSampler :: SamplerRepeat -> Texture px -> Texture px +withSampler = WithSampler + +-- | Transform the coordinates used for texture before applying +-- it, allow interesting transformations. +-- +-- > withTexture (withSampler SamplerRepeat $ +-- > transformTexture (rotateCenter 1 (V2 0 0) <> +-- > scale 0.5 0.25) +-- > $ sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <<docimages/sampled_texture_scaled.png>> +-- +transformTexture :: Transformation -> Texture px -> Texture px +transformTexture = WithTextureTransform + +-- | The uniform texture is the simplest texture of all: +-- an uniform color. +uniformTexture :: px -- ^ The color used for all the texture. + -> Texture px +uniformTexture = SolidTexture + +-- | Linear gradient texture. +-- +-- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) +-- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) +-- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in +-- > withTexture (linearGradientTexture SamplerPad gradDef +-- > (V2 40 40) (V2 130 130)) $ +-- > fill $ circle (V2 100 100) 100 +-- +-- <<docimages/linear_gradient.png>> +-- +linearGradientTexture :: Gradient px -- ^ Gradient description. + -> Point -- ^ Linear gradient start point. + -> Point -- ^ Linear gradient end point. + -> Texture px +linearGradientTexture gradient start end = + LinearGradientTexture gradient (Line start end) + +-- | Use another image as a texture for the filling. +-- Contrary to `imageTexture`, this function perform a bilinear +-- filtering on the texture. +-- +sampledImageTexture :: Image px -> Texture px +sampledImageTexture = SampledTexture + +-- | Radial gradient texture +-- +-- > 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 +-- +-- <<docimages/radial_gradient.png>> +-- +radialGradientTexture :: Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Texture px +radialGradientTexture = RadialGradientTexture + +-- | Radial gradient texture with a focus point. +-- +-- > 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 +-- +-- <<docimages/radial_gradient_focus.png>> +-- +radialGradientWithFocusTexture + :: Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Point -- ^ Radial gradient focus point + -> Texture px +radialGradientWithFocusTexture = RadialGradientWithFocusTexture + +-- | Perform a multiplication operation between a full color texture +-- and a greyscale one, used for clip-path implementation. +modulateTexture :: (Pixel px) + => Texture px -- ^ The full blown texture. + -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. + -> Texture px -- ^ The resulting texture. +modulateTexture = ModulateTexture +
src/Graphics/Rasterific/Transformations.hs view
@@ -1,198 +1,198 @@--- | This module provide some helpers in order--- to perform basic geometric transformation on--- the drawable primitives.------ You can combine the transformation is `mappend` or--- the `(\<\>)` operator from "Data.Monoid" .-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Transformations- ( Transformation( .. )- , applyTransformation- , applyVectorTransformation- , translate- , scale- , rotate- , rotateCenter- , skewX- , skewY- , toNewXBase- , inverseTransformation- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( Monoid( .. ) )-#endif-import Data.Monoid( (<>) )-import Graphics.Rasterific.Types-import Graphics.Rasterific.Linear( V2( .. ), (^+^), normalize )---- | Represent a 3*3 matrix for homogenous coordinates.------ > | A C E |--- > | B D F |--- > | 0 0 1 |----data Transformation = Transformation- { _transformA :: {-# UNPACK #-} !Float- , _transformC :: {-# UNPACK #-} !Float- , _transformE :: {-# UNPACK #-} !Float -- ^ X translation-- , _transformB :: {-# UNPACK #-} !Float- , _transformD :: {-# UNPACK #-} !Float- , _transformF :: {-# UNPACK #-} !Float -- ^ Y translation- }- deriving (Eq, Show)--transformCombine :: Transformation -> Transformation -> Transformation-transformCombine (Transformation a c e- b d f)-- (Transformation a' c' e'- b' d' f') =- Transformation (a * a' + c * b' {- below b' is zero -})- (a * c' + c * d' {- below d' is zero -})- (a * e' + c * f' + e {- below f' is one -})-- (b * a' + d * b' {- below b' is zero -})- (b * c' + d * d' {- below d' is zero -})- (b * e' + d * f' + f {- below f' is one -})--instance Monoid Transformation where- mappend = transformCombine- mempty = Transformation 1 0 0- 0 1 0---- | Effectively transform a point given a transformation.-applyTransformation :: Transformation -> Point -> Point-applyTransformation (Transformation a c e- b d f) (V2 x y) =- V2 (a * x + y * c + e) (b * x + d * y + f)---- | Effectively transform a vector given a transformation.--- The translation part won't be applied.-applyVectorTransformation :: Transformation -> Vector -> Vector-applyVectorTransformation- (Transformation a c _e- b d _f) (V2 x y) =- V2 (a * x + y * c) (b * x + d * y)----- | Create a transformation representing a rotation--- on the plane.------ > fill . transform (applyTransformation $ rotate 0.2)--- > $ rectangle (V2 40 40) 120 120------ <<docimages/transform_rotate.png>>----rotate :: Float -- ^ Rotation angle in radian.- -> Transformation-rotate angle = Transformation ca (-sa) 0- sa ca 0- where ca = cos angle- sa = sin angle---- | Create a transformation representing a rotation--- on the plane. The rotation center is given in parameter------ > fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200))--- > $ rectangle (V2 40 40) 120 120------ <<docimages/transform_rotate_center.png>>----rotateCenter :: Float -- ^ Rotation angle in radian- -> Point -- ^ Rotation center- -> Transformation-rotateCenter angle p =- translate p <> rotate angle <> translate (negate p)----- | Perform a scaling of the given primitives.------ > fill . transform (applyTransformation $ scale 2 2)--- > $ rectangle (V2 40 40) 40 40------ <<docimages/transform_scale.png>>----scale :: Float -> Float -> Transformation-{-# RULES- "scale mappend" forall ax ay bx by.- mappend (scale ax ay) (scale bx by) =- scale (ax * bx) (ay * by)- #-}-scale scaleX scaleY =- Transformation scaleX 0 0- 0 scaleY 0---- | Perform a translation of the given primitives.------ > fill . transform (applyTransformation $ translate (V2 100 100))--- > $ rectangle (V2 40 40) 40 40------ <<docimages/transform_translate.png>>----translate :: Vector -> Transformation-{-# RULES- "translate mappend" forall a b.- mappend (translate a) (translate b) = translate (a ^+^ b)- #-}-translate (V2 x y) =- Transformation 1 0 x- 0 1 y---- | Skew transformation along the--- X axis.------ > fill . transform (applyTransformation $ skewX 0.3)--- > $ rectangle (V2 50 50) 80 80------ <<docimages/transform_skewx.png>>----skewX :: Float -> Transformation-skewX v =- Transformation 1 t 0- 0 1 0- where t = tan v---- | Skew transformation along the Y axis.------ > fill . transform (applyTransformation $ skewY 0.3)--- > $ rectangle (V2 50 50) 80 80------ <<docimages/transform_skewy.png>>----skewY :: Float -> Transformation-skewY v =- Transformation 1 0 0- t 1 0- where t = tan v---- | Given a new X-acis vector, create a rotation matrix--- to get into this new base, assuming an Y basis orthonormal--- to the X one.-toNewXBase :: Vector -> Transformation-toNewXBase vec =- Transformation dx (-dy) 0- dy dx 0- where V2 dx dy = normalize vec--transformationDeterminant :: Transformation -> Float-transformationDeterminant (Transformation a c _e- b d _f) = a * d - c * b---- | Inverse a transformation (if possible)-inverseTransformation :: Transformation -> Maybe Transformation-inverseTransformation trans- | transformationDeterminant trans == 0 = Nothing-inverseTransformation (Transformation a c e- b d f) =- Just $ Transformation a' c' e' b' d' f'- where det = a * d - b * c- a' = d / det- c' = (- c) / det- e' = (c * f - e * d) / det-- b' = (- b) / det- d' = a / det- f' = (e * b - a * f) / det-+-- | This module provide some helpers in order +-- to perform basic geometric transformation on +-- the drawable primitives. +-- +-- You can combine the transformation is `mappend` or +-- the `(\<\>)` operator from "Data.Monoid" . +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Transformations + ( Transformation( .. ) + , applyTransformation + , applyVectorTransformation + , translate + , scale + , rotate + , rotateCenter + , skewX + , skewY + , toNewXBase + , inverseTransformation + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid( .. ) ) +#endif +import Data.Monoid( (<>) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.Linear( V2( .. ), (^+^), normalize ) + +-- | Represent a 3*3 matrix for homogenous coordinates. +-- +-- > | A C E | +-- > | B D F | +-- > | 0 0 1 | +-- +data Transformation = Transformation + { _transformA :: {-# UNPACK #-} !Float + , _transformC :: {-# UNPACK #-} !Float + , _transformE :: {-# UNPACK #-} !Float -- ^ X translation + + , _transformB :: {-# UNPACK #-} !Float + , _transformD :: {-# UNPACK #-} !Float + , _transformF :: {-# UNPACK #-} !Float -- ^ Y translation + } + deriving (Eq, Show) + +transformCombine :: Transformation -> Transformation -> Transformation +transformCombine (Transformation a c e + b d f) + + (Transformation a' c' e' + b' d' f') = + Transformation (a * a' + c * b' {- below b' is zero -}) + (a * c' + c * d' {- below d' is zero -}) + (a * e' + c * f' + e {- below f' is one -}) + + (b * a' + d * b' {- below b' is zero -}) + (b * c' + d * d' {- below d' is zero -}) + (b * e' + d * f' + f {- below f' is one -}) + +instance Monoid Transformation where + mappend = transformCombine + mempty = Transformation 1 0 0 + 0 1 0 + +-- | Effectively transform a point given a transformation. +applyTransformation :: Transformation -> Point -> Point +applyTransformation (Transformation a c e + b d f) (V2 x y) = + V2 (a * x + y * c + e) (b * x + d * y + f) + +-- | Effectively transform a vector given a transformation. +-- The translation part won't be applied. +applyVectorTransformation :: Transformation -> Vector -> Vector +applyVectorTransformation + (Transformation a c _e + b d _f) (V2 x y) = + V2 (a * x + y * c) (b * x + d * y) + + +-- | Create a transformation representing a rotation +-- on the plane. +-- +-- > fill . transform (applyTransformation $ rotate 0.2) +-- > $ rectangle (V2 40 40) 120 120 +-- +-- <<docimages/transform_rotate.png>> +-- +rotate :: Float -- ^ Rotation angle in radian. + -> Transformation +rotate angle = Transformation ca (-sa) 0 + sa ca 0 + where ca = cos angle + sa = sin angle + +-- | Create a transformation representing a rotation +-- on the plane. The rotation center is given in parameter +-- +-- > fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200)) +-- > $ rectangle (V2 40 40) 120 120 +-- +-- <<docimages/transform_rotate_center.png>> +-- +rotateCenter :: Float -- ^ Rotation angle in radian + -> Point -- ^ Rotation center + -> Transformation +rotateCenter angle p = + translate p <> rotate angle <> translate (negate p) + + +-- | Perform a scaling of the given primitives. +-- +-- > fill . transform (applyTransformation $ scale 2 2) +-- > $ rectangle (V2 40 40) 40 40 +-- +-- <<docimages/transform_scale.png>> +-- +scale :: Float -> Float -> Transformation +{-# RULES + "scale mappend" forall ax ay bx by. + mappend (scale ax ay) (scale bx by) = + scale (ax * bx) (ay * by) + #-} +scale scaleX scaleY = + Transformation scaleX 0 0 + 0 scaleY 0 + +-- | Perform a translation of the given primitives. +-- +-- > fill . transform (applyTransformation $ translate (V2 100 100)) +-- > $ rectangle (V2 40 40) 40 40 +-- +-- <<docimages/transform_translate.png>> +-- +translate :: Vector -> Transformation +{-# RULES + "translate mappend" forall a b. + mappend (translate a) (translate b) = translate (a ^+^ b) + #-} +translate (V2 x y) = + Transformation 1 0 x + 0 1 y + +-- | Skew transformation along the +-- X axis. +-- +-- > fill . transform (applyTransformation $ skewX 0.3) +-- > $ rectangle (V2 50 50) 80 80 +-- +-- <<docimages/transform_skewx.png>> +-- +skewX :: Float -> Transformation +skewX v = + Transformation 1 t 0 + 0 1 0 + where t = tan v + +-- | Skew transformation along the Y axis. +-- +-- > fill . transform (applyTransformation $ skewY 0.3) +-- > $ rectangle (V2 50 50) 80 80 +-- +-- <<docimages/transform_skewy.png>> +-- +skewY :: Float -> Transformation +skewY v = + Transformation 1 0 0 + t 1 0 + where t = tan v + +-- | Given a new X-acis vector, create a rotation matrix +-- to get into this new base, assuming an Y basis orthonormal +-- to the X one. +toNewXBase :: Vector -> Transformation +toNewXBase vec = + Transformation dx (-dy) 0 + dy dx 0 + where V2 dx dy = normalize vec + +transformationDeterminant :: Transformation -> Float +transformationDeterminant (Transformation a c _e + b d _f) = a * d - c * b + +-- | Inverse a transformation (if possible) +inverseTransformation :: Transformation -> Maybe Transformation +inverseTransformation trans + | transformationDeterminant trans == 0 = Nothing +inverseTransformation (Transformation a c e + b d f) = + Just $ Transformation a' c' e' b' d' f' + where det = a * d - b * c + a' = d / det + c' = (- c) / det + e' = (c * f - e * d) / det + + b' = (- b) / det + d' = a / det + f' = (e * b - a * f) / det +
src/Graphics/Rasterific/Types.hs view
@@ -1,482 +1,482 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}--- | Gather all the types used in the rasterization engine.-module Graphics.Rasterific.Types- ( -- * Geometry description- Vector- , Point- , Line( .. )- , Bezier( .. )- , CubicBezier( .. )- , Primitive( .. )- , Producer- , Container- , containerOfList- , listOfContainer- , containerOfFunction- , PathCommand( .. )- , Path( .. )- , Transformable( .. )- , PointFoldable( .. )-- -- * Rasterization control types- , Cap( .. )- , Join( .. )- , FillMethod( .. )- , SamplerRepeat( .. )- , DashPattern- , StrokeWidth-- -- * Internal type- , EdgeSample( .. )- , pathToPrimitives-- -- * Little geometry helpers- , firstTangeantOf- , lastTangeantOf- , firstPointOf- , lastPointOf- ) where--import Data.DList( DList, fromList, toList )--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable( Foldable )-#endif-import Data.Foldable( foldl' )-import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero )--import Foreign.Ptr( castPtr )-import Foreign.Storable( Storable( sizeOf- , alignment- , peek- , poke- , peekElemOff- , pokeElemOff ) )---- | Represent a vector-type Vector = V2 Float---- | Represent a point-type Point = V2 Float---- | Type alias just to get more meaningful--- type signatures-type StrokeWidth = Float---- | Dash pattern to use-type DashPattern = [Float]---- | Describe how we will "finish" the stroking--- that don't loop.-data Cap- -- | Create a straight caping on the stroke.- -- Cap value should be positive and represent- -- the distance from the end of curve to the actual cap- --- -- * cap straight with param 0 : <<docimages/cap_straight.png>>- --- -- * cap straight with param 1 : <<docimages/cap_straight_1.png>>- --- = CapStraight Float-- -- | Create a rounded caping on the stroke.- -- <<docimages/cap_round.png>>- | CapRound- deriving (Eq, Show)---- | Describe how to display the join of broken lines--- while stroking.-data Join- -- | Make a curved join.- -- <<docimages/join_round.png>>- = JoinRound- -- | Make a mitter join. Value must be positive or null.- -- Seems to make sense in [0;1] only- --- -- * Miter join with 0 : <<docimages/join_miter.png>>- --- -- * Miter join with 5 : <<docimages/join_miter_5.png>>- --- | JoinMiter Float- deriving (Eq, Show)---- | Tell how to fill complex shapes when there is self --- intersections. If the filling mode is not specified,--- then it's the `FillWinding` method which is used.------ The examples used are produced with the following--- function:--------- > fillingSample :: FillMethod -> Drawing px ()--- > fillingSample fillMethod = fillWithMethod fillMethod geometry where--- > geometry = transform (applyTransformation $ scale 0.35 0.4--- > <> translate (V2 (-80) (-180)))--- > $ concatMap pathToPrimitives--- > [ 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)--- > ]--- > ]-data FillMethod- -- | Also known as nonzero rule.- -- To determine if a point falls inside the curve, you draw - -- an imaginary line through that point. Next you will count- -- how many times that line crosses the curve before it reaches- -- that point. For every clockwise rotation, you subtract 1 and- -- for every counter-clockwise rotation you add 1.- --- -- <<docimages/fill_winding.png>>- = FillWinding-- -- | This rule determines the insideness of a point on - -- the canvas by drawing a ray from that point to infinity- -- in any direction and counting the number of path segments- -- from the given shape that the ray crosses. If this number- -- is odd, the point is inside; if even, the point is outside.- --- -- <<docimages/fill_evenodd.png>>- | FillEvenOdd- deriving (Eq, Enum, Show)---- | Describe the behaviour of samplers and texturers--- when they are out of the bounds of image and/or gradient.-data SamplerRepeat- -- | Will clamp (ie. repeat the last pixel) when- -- out of bound- -- <<docimages/sampler_pad.png>>- = SamplerPad- -- | Will loop on it's definition domain- -- <<docimages/sampler_repeat.png>>- | SamplerRepeat- -- | Will loop inverting axises- -- <<docimages/sampler_reflect.png>>- | SamplerReflect- deriving (Eq, Enum, Show)---- | Represent a raster line-data EdgeSample = EdgeSample- { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position- , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position- , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha- , _sampleH :: {-# UNPACK #-} !Float -- ^ Height- }- deriving Show---- | Just to get faster sorting-instance Storable EdgeSample where- sizeOf _ = 4 * sizeOf (0 :: Float)- alignment = sizeOf-- {-# INLINE peek #-}- peek ptr = do- let q = castPtr ptr- sx <- peekElemOff q 0- sy <- peekElemOff q 1- sa <- peekElemOff q 2- sh <- peekElemOff q 3- return $ EdgeSample sx sy sa sh- - {-# INLINE poke #-}- poke ptr (EdgeSample sx sy sa sh) = do- let q = castPtr ptr- pokeElemOff q 0 sx- pokeElemOff q 1 sy- pokeElemOff q 2 sa- pokeElemOff q 3 sh---- | This typeclass is there to help transform the geometry,--- by applying a transformation on every point of a geometric--- element.-class Transformable a where- -- | Apply a transformation function for every- -- point in the element.- transform :: (Point -> Point) -> a -> a---- | Typeclass helper gathering all the points of a given--- geometry.-class PointFoldable a where- -- | Fold an accumulator on all the points of- -- the primitive.- foldPoints :: (b -> Point -> b) -> b -> a -> b--instance Transformable Point where- {-# INLINE transform #-}- transform f = f--instance PointFoldable Point where- {-# INLINE foldPoints #-}- foldPoints f = f---- | Describe a simple 2D line between two points.------ > fill $ LinePrim <$> [ Line (V2 10 10) (V2 190 10)--- > , Line (V2 190 10) (V2 95 170)--- > , Line (V2 95 170) (V2 10 10)]------ <<docimages/simple_line.png>>----data Line = Line- { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point- , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point- }- deriving Eq--instance Show Line where- show (Line a b) =- "Line (" ++ show a ++ ") ("- ++ show b ++ ")"--instance Transformable Line where- {-# INLINE transform #-}- transform f (Line a b) = Line (f a) $ f b--instance PointFoldable Line where- {-# INLINE foldPoints #-}- foldPoints f acc (Line a b) = f (f acc b) a---- | Describe a quadratic bezier spline, described--- using 3 points.------ > fill $ BezierPrim <$> [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)]------ <<docimages/quadratic_bezier.png>>----data Bezier = Bezier- { -- | Origin points, the spline will pass through it.- _bezierX0 :: {-# UNPACK #-} !Point- -- | Control point, the spline won't pass on it.- , _bezierX1 :: {-# UNPACK #-} !Point- -- | End point, the spline will pass through it.- , _bezierX2 :: {-# UNPACK #-} !Point- }- deriving Eq--instance Show Bezier where- show (Bezier a b c) =- "Bezier (" ++ show a ++ ") ("- ++ show b ++ ") ("- ++ show c ++ ")"--instance Transformable Bezier where- {-# INLINE transform #-}- transform f (Bezier a b c) = Bezier (f a) (f b) $ f c--instance PointFoldable Bezier where- {-# INLINE foldPoints #-}- foldPoints f acc (Bezier a b c) =- foldl' f acc [a, b, c]---- | Describe a cubic bezier spline, described--- using 4 points.------ > stroke 4 JoinRound (CapRound, CapRound) $--- > [CubicBezierPrim $ CubicBezier (V2 0 10) (V2 205 250)--- > (V2 (-10) 250) (V2 160 35)]------ <<docimages/cubic_bezier.png>>----data CubicBezier = CubicBezier- { -- | Origin point, the spline will pass through it.- _cBezierX0 :: {-# UNPACK #-} !Point- -- | First control point of the cubic bezier curve.- , _cBezierX1 :: {-# UNPACK #-} !Point- -- | Second control point of the cubic bezier curve.- , _cBezierX2 :: {-# UNPACK #-} !Point- -- | End point of the cubic bezier curve- , _cBezierX3 :: {-# UNPACK #-} !Point- }- deriving Eq--instance Show CubicBezier where- show (CubicBezier a b c d) =- "CubicBezier (" ++ show a ++ ") ("- ++ show b ++ ") ("- ++ show c ++ ") ("- ++ show d ++ ")"--instance Transformable CubicBezier where- {-# INLINE transform #-}- transform f (CubicBezier a b c d) =- CubicBezier (f a) (f b) (f c) $ f d--instance PointFoldable CubicBezier where- {-# INLINE foldPoints #-}- foldPoints f acc (CubicBezier a b c d) =- foldl' f acc [a, b, c, d]---- | This datatype gather all the renderable primitives,--- they are kept separated otherwise to allow specialization--- on some specific algorithms. You can mix the different--- primitives in a single call :------ > fill--- > [ CubicBezierPrim $ CubicBezier (V2 50 20) (V2 90 60)--- > (V2 5 100) (V2 50 140)--- > , LinePrim $ Line (V2 50 140) (V2 120 80)--- > , LinePrim $ Line (V2 120 80) (V2 50 20) ]------ <<docimages/primitive_mixed.png>>----data Primitive- = LinePrim !Line -- ^ Primitive used for lines- | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves- | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve- deriving (Eq, Show)--instance Transformable Primitive where- {-# INLINE transform #-}- transform f (LinePrim l) = LinePrim $ transform f l- transform f (BezierPrim b) = BezierPrim $ transform f b- transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c--instance PointFoldable Primitive where- {-# INLINE foldPoints #-}- foldPoints f acc = go- where go (LinePrim l) = foldPoints f acc l- go (BezierPrim b) = foldPoints f acc b- go (CubicBezierPrim c) = foldPoints f acc c--instance (Functor f, Transformable a)- => Transformable (f a) where- transform f = fmap (transform f)--instance (Foldable f, PointFoldable a)- => PointFoldable (f a) where- foldPoints f = foldl' (foldPoints f)--type Producer a = [a] -> [a]--type Container a = DList a--containerOfFunction :: ([a] -> [a]) -> Container a-containerOfFunction f = fromList $ f []--containerOfList :: [a] -> Container a-containerOfList = fromList--listOfContainer :: Container a -> [a]-listOfContainer = toList---- | Describe a path in a way similar to many graphical--- packages, using a "pen" position in memory and reusing--- it for the next "move"--- For example the example from Primitive could be rewritten:------ > fill . pathToPrimitives $ Path (V2 50 20) True--- > [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140)--- > , PathLineTo (V2 120 80) ]------ <<docimages/path_example.png>>----data Path = Path- { -- | Origin of the point, equivalent to the- -- first "move" command.- _pathOriginPoint :: Point- -- | Tell if we must close the path.- , _pathClose :: Bool- -- | List of commands in the path- , _pathCommand :: [PathCommand]- }- deriving (Eq, Show)--instance Transformable Path where- {-# INLINE transform #-}- transform f (Path orig close rest) =- Path (f orig) close (transform f rest)--instance PointFoldable Path where- {-# INLINE foldPoints #-}- foldPoints f acc (Path o _ rest) =- foldPoints f (f acc o) rest---- | Actions to create a path-data PathCommand- = -- | Draw a line from the current point to another point- PathLineTo Point- -- | Draw a quadratic bezier curve from the current point- -- through the control point to the end point.- | PathQuadraticBezierCurveTo Point Point-- -- | Draw a cubic bezier curve using 2 control points.- | PathCubicBezierCurveTo Point Point Point- deriving (Eq, Show)--instance Transformable PathCommand where- transform f (PathLineTo p) = PathLineTo $ f p- transform f (PathQuadraticBezierCurveTo p1 p2) =- PathQuadraticBezierCurveTo (f p1) $ f p2- transform f (PathCubicBezierCurveTo p1 p2 p3) =- PathCubicBezierCurveTo (f p1) (f p2) $ f p3--instance PointFoldable PathCommand where- foldPoints f acc (PathLineTo p) = f acc p- foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) =- f (f acc p1) p2- foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) =- foldl' f acc [p1, p2, p3]---- | Transform a path description into a list of renderable--- primitives.-pathToPrimitives :: Path -> [Primitive]-pathToPrimitives (Path origin needClosing commands) = go origin commands- where- go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin]- go _ [] = []- go prev (PathLineTo to : xs) =- LinePrim (Line prev to) : go to xs- go prev (PathQuadraticBezierCurveTo c1 to : xs) =- BezierPrim (Bezier prev c1 to) : go to xs- go prev (PathCubicBezierCurveTo c1 c2 to : xs) =- CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs---- | Gives the orientation vector for the start of the--- primitive.-firstTangeantOf :: Primitive -> Vector-firstTangeantOf p = case p of- LinePrim (Line p0 p1) -> p1 ^-^ p0- BezierPrim (Bezier p0 p1 p2) ->- (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)- CubicBezierPrim (CubicBezier p0 p1 p2 _) -> - (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)- where- ifBigEnough a b | nearZero a = b- | otherwise = a---- | Gives the orientation vector at the end of the--- primitive.-lastTangeantOf :: Primitive -> Vector-lastTangeantOf p = case p of- LinePrim (Line p0 p1) -> p1 ^-^ p0- BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1- CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2---- | Extract the first point of the primitive.-firstPointOf :: Primitive -> Point-firstPointOf p = case p of- LinePrim (Line p0 _) -> p0- BezierPrim (Bezier p0 _ _) -> p0- CubicBezierPrim (CubicBezier p0 _ _ _) -> p0---- | Return the last point of a given primitive.-lastPointOf :: Primitive -> Point-lastPointOf p = case p of- LinePrim (Line _ p0) -> p0- BezierPrim (Bezier _ _ p0) -> p0- CubicBezierPrim (CubicBezier _ _ _ p0) -> p0-+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +-- | Gather all the types used in the rasterization engine. +module Graphics.Rasterific.Types + ( -- * Geometry description + Vector + , Point + , Line( .. ) + , Bezier( .. ) + , CubicBezier( .. ) + , Primitive( .. ) + , Producer + , Container + , containerOfList + , listOfContainer + , containerOfFunction + , PathCommand( .. ) + , Path( .. ) + , Transformable( .. ) + , PointFoldable( .. ) + + -- * Rasterization control types + , Cap( .. ) + , Join( .. ) + , FillMethod( .. ) + , SamplerRepeat( .. ) + , DashPattern + , StrokeWidth + + -- * Internal type + , EdgeSample( .. ) + , pathToPrimitives + + -- * Little geometry helpers + , firstTangeantOf + , lastTangeantOf + , firstPointOf + , lastPointOf + ) where + +import Data.DList( DList, fromList, toList ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable( Foldable ) +#endif +import Data.Foldable( foldl' ) +import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero ) + +import Foreign.Ptr( castPtr ) +import Foreign.Storable( Storable( sizeOf + , alignment + , peek + , poke + , peekElemOff + , pokeElemOff ) ) + +-- | Represent a vector +type Vector = V2 Float + +-- | Represent a point +type Point = V2 Float + +-- | Type alias just to get more meaningful +-- type signatures +type StrokeWidth = Float + +-- | Dash pattern to use +type DashPattern = [Float] + +-- | Describe how we will "finish" the stroking +-- that don't loop. +data Cap + -- | Create a straight caping on the stroke. + -- Cap value should be positive and represent + -- the distance from the end of curve to the actual cap + -- + -- * cap straight with param 0 : <<docimages/cap_straight.png>> + -- + -- * cap straight with param 1 : <<docimages/cap_straight_1.png>> + -- + = CapStraight Float + + -- | Create a rounded caping on the stroke. + -- <<docimages/cap_round.png>> + | CapRound + deriving (Eq, Show) + +-- | Describe how to display the join of broken lines +-- while stroking. +data Join + -- | Make a curved join. + -- <<docimages/join_round.png>> + = JoinRound + -- | Make a mitter join. Value must be positive or null. + -- Seems to make sense in [0;1] only + -- + -- * Miter join with 0 : <<docimages/join_miter.png>> + -- + -- * Miter join with 5 : <<docimages/join_miter_5.png>> + -- + | JoinMiter Float + deriving (Eq, Show) + +-- | Tell how to fill complex shapes when there is self +-- intersections. If the filling mode is not specified, +-- then it's the `FillWinding` method which is used. +-- +-- The examples used are produced with the following +-- function: +-- +-- +-- > fillingSample :: FillMethod -> Drawing px () +-- > fillingSample fillMethod = fillWithMethod fillMethod geometry where +-- > geometry = transform (applyTransformation $ scale 0.35 0.4 +-- > <> translate (V2 (-80) (-180))) +-- > $ concatMap pathToPrimitives +-- > [ 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) +-- > ] +-- > ] +data FillMethod + -- | Also known as nonzero rule. + -- To determine if a point falls inside the curve, you draw + -- an imaginary line through that point. Next you will count + -- how many times that line crosses the curve before it reaches + -- that point. For every clockwise rotation, you subtract 1 and + -- for every counter-clockwise rotation you add 1. + -- + -- <<docimages/fill_winding.png>> + = FillWinding + + -- | This rule determines the insideness of a point on + -- the canvas by drawing a ray from that point to infinity + -- in any direction and counting the number of path segments + -- from the given shape that the ray crosses. If this number + -- is odd, the point is inside; if even, the point is outside. + -- + -- <<docimages/fill_evenodd.png>> + | FillEvenOdd + deriving (Eq, Enum, Show) + +-- | Describe the behaviour of samplers and texturers +-- when they are out of the bounds of image and/or gradient. +data SamplerRepeat + -- | Will clamp (ie. repeat the last pixel) when + -- out of bound + -- <<docimages/sampler_pad.png>> + = SamplerPad + -- | Will loop on it's definition domain + -- <<docimages/sampler_repeat.png>> + | SamplerRepeat + -- | Will loop inverting axises + -- <<docimages/sampler_reflect.png>> + | SamplerReflect + deriving (Eq, Enum, Show) + +-- | Represent a raster line +data EdgeSample = EdgeSample + { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position + , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position + , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha + , _sampleH :: {-# UNPACK #-} !Float -- ^ Height + } + deriving Show + +-- | Just to get faster sorting +instance Storable EdgeSample where + sizeOf _ = 4 * sizeOf (0 :: Float) + alignment = sizeOf + + {-# INLINE peek #-} + peek ptr = do + let q = castPtr ptr + sx <- peekElemOff q 0 + sy <- peekElemOff q 1 + sa <- peekElemOff q 2 + sh <- peekElemOff q 3 + return $ EdgeSample sx sy sa sh + + {-# INLINE poke #-} + poke ptr (EdgeSample sx sy sa sh) = do + let q = castPtr ptr + pokeElemOff q 0 sx + pokeElemOff q 1 sy + pokeElemOff q 2 sa + pokeElemOff q 3 sh + +-- | This typeclass is there to help transform the geometry, +-- by applying a transformation on every point of a geometric +-- element. +class Transformable a where + -- | Apply a transformation function for every + -- point in the element. + transform :: (Point -> Point) -> a -> a + +-- | Typeclass helper gathering all the points of a given +-- geometry. +class PointFoldable a where + -- | Fold an accumulator on all the points of + -- the primitive. + foldPoints :: (b -> Point -> b) -> b -> a -> b + +instance Transformable Point where + {-# INLINE transform #-} + transform f = f + +instance PointFoldable Point where + {-# INLINE foldPoints #-} + foldPoints f = f + +-- | Describe a simple 2D line between two points. +-- +-- > fill $ LinePrim <$> [ Line (V2 10 10) (V2 190 10) +-- > , Line (V2 190 10) (V2 95 170) +-- > , Line (V2 95 170) (V2 10 10)] +-- +-- <<docimages/simple_line.png>> +-- +data Line = Line + { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point + , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point + } + deriving Eq + +instance Show Line where + show (Line a b) = + "Line (" ++ show a ++ ") (" + ++ show b ++ ")" + +instance Transformable Line where + {-# INLINE transform #-} + transform f (Line a b) = Line (f a) $ f b + +instance PointFoldable Line where + {-# INLINE foldPoints #-} + foldPoints f acc (Line a b) = f (f acc b) a + +-- | Describe a quadratic bezier spline, described +-- using 3 points. +-- +-- > fill $ BezierPrim <$> [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)] +-- +-- <<docimages/quadratic_bezier.png>> +-- +data Bezier = Bezier + { -- | Origin points, the spline will pass through it. + _bezierX0 :: {-# UNPACK #-} !Point + -- | Control point, the spline won't pass on it. + , _bezierX1 :: {-# UNPACK #-} !Point + -- | End point, the spline will pass through it. + , _bezierX2 :: {-# UNPACK #-} !Point + } + deriving Eq + +instance Show Bezier where + show (Bezier a b c) = + "Bezier (" ++ show a ++ ") (" + ++ show b ++ ") (" + ++ show c ++ ")" + +instance Transformable Bezier where + {-# INLINE transform #-} + transform f (Bezier a b c) = Bezier (f a) (f b) $ f c + +instance PointFoldable Bezier where + {-# INLINE foldPoints #-} + foldPoints f acc (Bezier a b c) = + foldl' f acc [a, b, c] + +-- | Describe a cubic bezier spline, described +-- using 4 points. +-- +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > [CubicBezierPrim $ CubicBezier (V2 0 10) (V2 205 250) +-- > (V2 (-10) 250) (V2 160 35)] +-- +-- <<docimages/cubic_bezier.png>> +-- +data CubicBezier = CubicBezier + { -- | Origin point, the spline will pass through it. + _cBezierX0 :: {-# UNPACK #-} !Point + -- | First control point of the cubic bezier curve. + , _cBezierX1 :: {-# UNPACK #-} !Point + -- | Second control point of the cubic bezier curve. + , _cBezierX2 :: {-# UNPACK #-} !Point + -- | End point of the cubic bezier curve + , _cBezierX3 :: {-# UNPACK #-} !Point + } + deriving Eq + +instance Show CubicBezier where + show (CubicBezier a b c d) = + "CubicBezier (" ++ show a ++ ") (" + ++ show b ++ ") (" + ++ show c ++ ") (" + ++ show d ++ ")" + +instance Transformable CubicBezier where + {-# INLINE transform #-} + transform f (CubicBezier a b c d) = + CubicBezier (f a) (f b) (f c) $ f d + +instance PointFoldable CubicBezier where + {-# INLINE foldPoints #-} + foldPoints f acc (CubicBezier a b c d) = + foldl' f acc [a, b, c, d] + +-- | This datatype gather all the renderable primitives, +-- they are kept separated otherwise to allow specialization +-- on some specific algorithms. You can mix the different +-- primitives in a single call : +-- +-- > fill +-- > [ CubicBezierPrim $ CubicBezier (V2 50 20) (V2 90 60) +-- > (V2 5 100) (V2 50 140) +-- > , LinePrim $ Line (V2 50 140) (V2 120 80) +-- > , LinePrim $ Line (V2 120 80) (V2 50 20) ] +-- +-- <<docimages/primitive_mixed.png>> +-- +data Primitive + = LinePrim !Line -- ^ Primitive used for lines + | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves + | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve + deriving (Eq, Show) + +instance Transformable Primitive where + {-# INLINE transform #-} + transform f (LinePrim l) = LinePrim $ transform f l + transform f (BezierPrim b) = BezierPrim $ transform f b + transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c + +instance PointFoldable Primitive where + {-# INLINE foldPoints #-} + foldPoints f acc = go + where go (LinePrim l) = foldPoints f acc l + go (BezierPrim b) = foldPoints f acc b + go (CubicBezierPrim c) = foldPoints f acc c + +instance (Functor f, Transformable a) + => Transformable (f a) where + transform f = fmap (transform f) + +instance (Foldable f, PointFoldable a) + => PointFoldable (f a) where + foldPoints f = foldl' (foldPoints f) + +type Producer a = [a] -> [a] + +type Container a = DList a + +containerOfFunction :: ([a] -> [a]) -> Container a +containerOfFunction f = fromList $ f [] + +containerOfList :: [a] -> Container a +containerOfList = fromList + +listOfContainer :: Container a -> [a] +listOfContainer = toList + +-- | Describe a path in a way similar to many graphical +-- packages, using a "pen" position in memory and reusing +-- it for the next "move" +-- For example the example from Primitive could be rewritten: +-- +-- > fill . pathToPrimitives $ Path (V2 50 20) True +-- > [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) +-- > , PathLineTo (V2 120 80) ] +-- +-- <<docimages/path_example.png>> +-- +data Path = Path + { -- | Origin of the point, equivalent to the + -- first "move" command. + _pathOriginPoint :: Point + -- | Tell if we must close the path. + , _pathClose :: Bool + -- | List of commands in the path + , _pathCommand :: [PathCommand] + } + deriving (Eq, Show) + +instance Transformable Path where + {-# INLINE transform #-} + transform f (Path orig close rest) = + Path (f orig) close (transform f rest) + +instance PointFoldable Path where + {-# INLINE foldPoints #-} + foldPoints f acc (Path o _ rest) = + foldPoints f (f acc o) rest + +-- | Actions to create a path +data PathCommand + = -- | Draw a line from the current point to another point + PathLineTo Point + -- | Draw a quadratic bezier curve from the current point + -- through the control point to the end point. + | PathQuadraticBezierCurveTo Point Point + + -- | Draw a cubic bezier curve using 2 control points. + | PathCubicBezierCurveTo Point Point Point + deriving (Eq, Show) + +instance Transformable PathCommand where + transform f (PathLineTo p) = PathLineTo $ f p + transform f (PathQuadraticBezierCurveTo p1 p2) = + PathQuadraticBezierCurveTo (f p1) $ f p2 + transform f (PathCubicBezierCurveTo p1 p2 p3) = + PathCubicBezierCurveTo (f p1) (f p2) $ f p3 + +instance PointFoldable PathCommand where + foldPoints f acc (PathLineTo p) = f acc p + foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) = + f (f acc p1) p2 + foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) = + foldl' f acc [p1, p2, p3] + +-- | Transform a path description into a list of renderable +-- primitives. +pathToPrimitives :: Path -> [Primitive] +pathToPrimitives (Path origin needClosing commands) = go origin commands + where + go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin] + go _ [] = [] + go prev (PathLineTo to : xs) = + LinePrim (Line prev to) : go to xs + go prev (PathQuadraticBezierCurveTo c1 to : xs) = + BezierPrim (Bezier prev c1 to) : go to xs + go prev (PathCubicBezierCurveTo c1 c2 to : xs) = + CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs + +-- | Gives the orientation vector for the start of the +-- primitive. +firstTangeantOf :: Primitive -> Vector +firstTangeantOf p = case p of + LinePrim (Line p0 p1) -> p1 ^-^ p0 + BezierPrim (Bezier p0 p1 p2) -> + (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) + CubicBezierPrim (CubicBezier p0 p1 p2 _) -> + (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) + where + ifBigEnough a b | nearZero a = b + | otherwise = a + +-- | Gives the orientation vector at the end of the +-- primitive. +lastTangeantOf :: Primitive -> Vector +lastTangeantOf p = case p of + LinePrim (Line p0 p1) -> p1 ^-^ p0 + BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1 + CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2 + +-- | Extract the first point of the primitive. +firstPointOf :: Primitive -> Point +firstPointOf p = case p of + LinePrim (Line p0 _) -> p0 + BezierPrim (Bezier p0 _ _) -> p0 + CubicBezierPrim (CubicBezier p0 _ _ _) -> p0 + +-- | Return the last point of a given primitive. +lastPointOf :: Primitive -> Point +lastPointOf p = case p of + LinePrim (Line _ p0) -> p0 + BezierPrim (Bezier _ _ p0) -> p0 + CubicBezierPrim (CubicBezier _ _ _ p0) -> p0 +