Rasterific 0.5.0.1 → 0.5.0.2
raw patch · 44 files changed
+5189/−6104 lines, 44 filesdep −QuickCheckdep −Rasterificdep −binarydep ~FontyFruitydep ~JuicyPixelsdep ~basesetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies removed: QuickCheck, Rasterific, binary, criterion, deepseq, directory, filepath, statistics
Dependency ranges changed: FontyFruity, JuicyPixels, base, vector
API changes (from Hackage documentation)
Files
- LICENSE +30/−30
- Rasterific.cabal +87/−111
- Setup.hs +2/−2
- changelog +87/−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/Arbitrary.hs +0/−95
- exec-src/Sample.hs +0/−46
- exec-src/docImageGenerator.hs +468/−468
- exec-src/rastertest.hs +0/−750
- 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,111 +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.1 -synopsis: A pure haskell drawing engine. --- A longer description of the package. -description: - <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAMAAACahl6sAAAA7VBMVEUBhsECh8EFiMIIisMLi8QMjMQOjcQSj8UTj8YVkMYZkscakscbk8ghlskmmMozns02oM44oc86os9CpdFEptJXr9Zbsdddsthes9hhtNljtdlsudtxvNx+wuB/wuCAw+CCxOGDxOGExeGHxuKVzeWb0Oed0Oek1Omm1emo1uqp1uqr1+ux2uyy2uy02+223O294O/J5fLK5vLM5/PN5/PY7PbZ7fbj8vjk8vjl8/nm8/np9frq9frr9vrs9vru9/vw+Pv2+/33+/37/f6g0ug8otBNq9S63u6Jx+IEiMJfs9hzvd3f8Pcqmsv///+OsMg+AAAFP0lEQVR4XuzPSQ0AIAwAQcT15PIvhy8OaMiOg2n7E0TeI0KECJH6iBAhQoQIESJEiEyXGN10ZbvkUusjxGf9yGHvjhpRW8Iwjj+oIIQQlh0FgBARiEIs7eb7f5xzdW5m9j5nzbPe1rwX/b7B343VzDszD+f1yvIs/tfscqV+/qAz5PlksJqHl/zq4ORZVUjnaHMepPnNo46OkNbeElJa2muFDrmvDSFiWLsPF9I7LkNQ+bgXJOSlOgNhM9WXzEPa2znIQ267nWnIUzSJEZmMnjIL6dYKGKFCrZtNSGMBI7bQyCDkbR0ZWH8bdcjFHDIxdzHSkG40gYxMRN3RhbRLyFCpPaqQZhGZKjZHE3KWQ8ZyZ6MI2Y+RuXhfPmQXQewSIXzHVKlSPby8ef03+vXm8rBaKU2JlMiG7ONvCmsHLfMXrYO1AtLalww5i/FHizvX7+Y/vV/vLCKV+EwupJnDn5SvTCJXZaSRa0qFtItwxRu3JrHbjRi8YlsmpFuCq39nvNz1wSt1RUIiOKZPjbfTadAiiZCLCdhWHg3hcQWsiYv0IW9zsG31DKW3BdbcW+qQddh+GdovsNbThjS4DvmSRrqQ7gIsWyaVLZAWuqlCarCs9EwqvRWQamlCngpWx/SjSelxGpzCU4qQCJZTk9opSBEf0rbXE/tGQB+cyTYdsm11xHdGwF0MzjYb8pKzQjaMiA1wci9kSBWWWyPiFqQqF9Kz9z/KRkgZnJkeFXIMy5URcgXSMRHi/t0WjZhFcMpMyD0sO0bMDkj3REgNlmsj5hqkGhEytDoK70bMewGcoX9IC5Y1I2gNpJZ3yB4sB0bQAUh73iFL7t9CUAukJd+QDixTRtQUSB3PkCNYSkZUCaQjz5BNWCpGVAWkTc+QeViqRlQVpHm/kGfYDo2oQ7CevUJOYLs0oi7BOvEKGcB2Y0TdgDXwClmF7dWIegVr1SskD5sRBlbeJ+QBekPw4BFyrjnk3COkrjmk7hFS0RxS8QhZ1hyy7BEyqzlk1iMEmkOQPOQ3oPcfIvA7ccgXoPcTBfhKHPIB6P1oBD4Sh3wDej/jge/EIQM45H9Y8QaJQ37gkP+py/tJHNKHQ37xgddPHPIJh/xyEO8zccgQDvkFOt4wcUgMh/ySKS9OHAJL2EVsFxGiaFuBD1G20cOHaNt640OUbYbyIdq2p/kQZQMDfIi2EQ4+JORQjXyI/JhToBD5wbOgIfKjgDzmozH8cKYrZj7jw4/LuobUD6vgA8yuT+qnbvCRclefW3wIPeTv+iGXgwIfu3AN2AW6sAdhXN/skmnYo0muD3oRO+hhMdcXv60Q9vgev61g4JA/UMlLtfUmfsSVN5tqM5Q/dCxuOd32dIBj4ALb03UoVidGOFQ6J4ZqVHogxpw0yhODZyqtEqOAKg2I4UyVTohxWZWeiQFmjeaJkXKVNokhf5WOiGMXKnWIgzAaLRFHk1TaIw6LqdRiju8pNKQOVCpUo464KnTPHTpWp0weA1fnmD2Yrwl/MN9UoUyVv7xCldwLf52IKtsCF7wEIHnBi4mgSCRwCVIA7CVI+r9TagIXhWmw0BW4uk2DhsBlehqsS1xvqMDcm8iFkwGQF05q/2cSSV3KGlipK3ZNblDFtuDFxQHlmqJXSQcTn8le7h3MvvR164Hsji/A1/UkwfiRCF3PdowfUtH1tM34sSFVzz+NH+RS9UTa+NE6Tc8Ijh921PTU5vjxU8XP0Y4fCB4/2cw/ov1Pe3cgAwAAACDM3zqOtmdwgmzNjeZBQEA+gYCAgICAgICAgIAETuKXxaAVTVgAAAAASUVORK5CYII=>> - . - Rasterific is a vector drawing library (a rasterizer) - implemented in pure haskell - -license: BSD3 -license-file: LICENSE -author: Vincent Berthoux -maintainer: twinside@gmail.com - --- A copyright notice. --- copyright: -category: Graphics -build-type: Simple - --- extra-source-files: - -cabal-version: >= 1.10 -extra-doc-files: docimages/*.png -extra-source-files: changelog - , docimages/*.png - , exec-src/docImageGenerator.hs - - - -Source-Repository head - Type: git - Location: git://github.com/Twinside/Rasterific.git - -Source-Repository this - Type: git - Location: git://github.com/Twinside/Rasterific.git - Tag: v0.5.0.1 - -flag embed_linear - description: Embed a reduced version of Linear avoiding a (huge) dep - Default: True - -library - hs-source-dirs: src - exposed-modules: Graphics.Rasterific - , Graphics.Rasterific.Outline - , Graphics.Rasterific.Texture - , Graphics.Rasterific.Linear - , Graphics.Rasterific.Lenses - , Graphics.Rasterific.Transformations - , Graphics.Rasterific.Immediate - , Graphics.Rasterific.PathWalker - - other-modules: Graphics.Rasterific.Line - , Graphics.Rasterific.Command - , Graphics.Rasterific.CubicBezier - , Graphics.Rasterific.QuadraticBezier - , Graphics.Rasterific.Operators - , Graphics.Rasterific.Rasterize - , Graphics.Rasterific.StrokeInternal - , Graphics.Rasterific.Types - , Graphics.Rasterific.Compositor - , Graphics.Rasterific.Shading - , Graphics.Rasterific.PlaneBoundable - , Graphics.Rasterific.QuadraticFormula - - ghc-options: -O3 -Wall - -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques - ghc-prof-options: -Wall -prof -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 - -Test-Suite test - type: exitcode-stdio-1.0 - default-language: Haskell2010 - Main-Is: rastertest.hs - ghc-options: -Wall -O2 - ghc-prof-options: -rtsopts -Wall -prof -auto-all - Hs-Source-Dirs: exec-src - other-modules: Arbitrary - , Sample - - Build-Depends: base >= 4.6 - , Rasterific - , JuicyPixels - , directory >= 1.2 - , filepath - , vector - , FontyFruity - , binary - , QuickCheck - , deepseq - , criterion >= 1.0 - , statistics - --, groom - +-- 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+
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
changelog view
@@ -1,87 +1,87 @@--*-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.1 February 2015+ * Fix: adding missing Arbitrary file in the distribution.++v0.5 February 2015+ * Breaking Change: Font size is now a newtype in FontyFruity,+ propagating the changes.+ * Allowing to specify DPI at the top level of the rendering+ request.+ * Adding: an helper function to retrieve the distance to the+ * Changed: font size switched to float.++v0.4.2 February 2015+ * Fix: Cubic bezier clipping++v0.4.1 January 2015+ * Fix: GHC 7.10 compilation+ * Adding: Various lens to access some primitive informations.++v0.4 December 2014+ * Breaking change: Changed the original position scheme for+ text, allowing to specify baseline or upper left corner++ * Tried: Fast forward differencing for cubic bezier, not worth+ the hassle+ * Enhancement: Further optimized decomposition of all primitives,+ less alocated memory.+ * Enhancement: After optimizing pixel writing, optimized pixel+ reading, yielding non-negligeable speed improvements.+ * Added: an "immediate" module to avoid constructing+ a scene tree.+ * Enhancement: Allowing both IO & (ST s) as drawing monads, enabling+ interleaved drawing with io operations.+ * Added: a "withPathOrientation" function to orient primitives+ on a path (allow to draw curved text)+ * Added: toNewXBase transformation to create a new basis given+ a X axis vector.+ * Added: a PathWalker module, to give access to the lower level+ path orientation facility.+ * Added: some GHC rules for transformations+ * Added: a new text function: 'printTextRanges' to allow+ easier complex text rendering++v0.3 June 2014+ * Enhancement: Switching main free monad type to the church encoded one.+ * Enhancement: Optimized the bezier decomposition, strictness annotations+ made wonders. May require forward differencing in the future.+ * Enhancement: Implementing specific decomposition for lines.+ * Enhancement: Reworked texture system, now allowing some specialized+ filler (hoping faster computation). For now only the+ solid color has been optimized, and all the transformed+ textures.+ * Enhancement: Fixing space leak in combineEdgeSamples, avoiding+ many allocations.+ * Adding: bounding box calculation facility.+ * Adding: Exposing outline creation capability+ * Adding: a skewX & skewY transformation function.+ * Fixing: some numerical stability with the mitter join.++v0.2.1 April 2014+ * Fixing: transparency in gradients.+ * Fixing: alpha composition on top of translucent+ background.++v0.2 April 2014+ * Adding: an ellipse helper.+ * Adding: a polyline helper.+ * Adding: a polygon helper.+ * Adding: monoid instance for Drawing.+ * Fixing: some stroking bug with cubic bezier curve.+ * Fixing: some documentation snippets.+ * Adding: a rounded rectangle helper.+ * Added: a even-odd filling rule.+ * Added: an offset for dashed stroking.+ * Added: a transformation module.+ * Change: Changed the Transformable typeclass, splitted+ it in two.+ * Added: a dumping function for the constructed+ drawing.+ * Adding: an image texture with bilinear filtering.+ * Adding: an image helper.+ * Enhancement: Some modest performance gain.++v0.1 February 2014+ * Initial version.+
docimages/cap_straight.png view
binary file changed (1786 → 1787 bytes)
− docimages/coordinate.png
binary file changed (4542 → absent bytes)
docimages/cubic_bezier.png view
binary file changed (4513 → 4519 bytes)
− docimages/geometry_on_path.png
binary file changed (5228 → absent bytes)
docimages/image_resize.png view
binary file changed (40755 → 40719 bytes)
docimages/image_simple.png view
binary file changed (12132 → 12189 bytes)
− docimages/immediate_fill.png
binary file changed (3052 → absent bytes)
− docimages/immediate_mask.png
binary file changed (4917 → absent bytes)
docimages/sampled_texture_reflect.png view
binary file changed (64698 → 65013 bytes)
− docimages/strokize_dashed_path.png
binary file changed (10017 → absent bytes)
− docimages/strokize_path.png
binary file changed (4960 → absent bytes)
− docimages/text_complex_example.png
binary file changed (2284 → absent bytes)
− docimages/text_example.png
binary file changed (2388 → absent bytes)
− docimages/text_on_path.png
binary file changed (6582 → absent bytes)
− docimages/transform_skewx.png
binary file changed (1818 → absent bytes)
− docimages/transform_skewy.png
binary file changed (1609 → absent bytes)
− exec-src/Arbitrary.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Arbitrary( randomTests ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), pure ) -#endif - -import Control.DeepSeq -import Control.Applicative( (<$>) ) -import Test.QuickCheck -import Codec.Picture -import Graphics.Rasterific -import Graphics.Rasterific.Texture - -instance Arbitrary a => Arbitrary (V2 a) where - arbitrary = V2 <$> arbitrary <*> arbitrary - -instance Arbitrary PathCommand where - arbitrary = oneof - [ PathLineTo <$> arbitrary - , PathQuadraticBezierCurveTo <$> arbitrary <*> arbitrary - , PathCubicBezierCurveTo <$> arbitrary <*> arbitrary <*> arbitrary - ] - -instance Arbitrary Path where - arbitrary = Path <$> arbitrary <*> pure True <*> arbitrary - -instance Arbitrary SamplerRepeat where - arbitrary = oneof $ map pure [toEnum 0 ..] - -instance Arbitrary FillMethod where - arbitrary = oneof $ map pure [toEnum 0 ..] - -instance Arbitrary Join where - arbitrary = oneof [pure JoinRound, JoinMiter <$> arbitrary] - -instance Arbitrary Cap where - arbitrary = oneof [pure CapRound, CapStraight <$> arbitrary] - -newtype StrokeTest = StrokeTest (Drawing PixelRGBA8 ()) - -instance Show StrokeTest where - show (StrokeTest sub) = - "StrokeTest " ++ dumpDrawing sub - -instance Arbitrary StrokeTest where - arbitrary = StrokeTest <$> - (stroke <$> (getPositive <$> arbitrary) - <*> arbitrary - <*> arbitrary - <*> (pathToPrimitives <$> arbitrary)) - -newtype DashedStrokeTest = DashedStrokeTest (Drawing PixelRGBA8 ()) - -instance Show DashedStrokeTest where - show (DashedStrokeTest sub) = - "StrokeTest " ++ dumpDrawing sub - - -instance Arbitrary DashedStrokeTest where - arbitrary = DashedStrokeTest <$> - (dashedStroke <$> (fmap getPositive <$> arbitrary) - <*> (getPositive <$> arbitrary) - <*> arbitrary <*> arbitrary - <*> (pathToPrimitives <$> arbitrary)) - -backgroundColor :: PixelRGBA8 -backgroundColor = PixelRGBA8 255 255 255 255 - -frontTexture :: Texture PixelRGBA8 -frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 - -fillTest :: Path -> Bool -fillTest path = deepseq img True - where img = renderDrawing 200 200 backgroundColor $ - withTexture frontTexture $ - fill $ pathToPrimitives path - -strokeTest :: StrokeTest -> Bool -strokeTest (StrokeTest test) = deepseq img True - where img = renderDrawing 200 200 backgroundColor $ - withTexture frontTexture test - -dashedStrokeTest :: DashedStrokeTest -> Bool -dashedStrokeTest (DashedStrokeTest test) = deepseq img True - where img = renderDrawing 200 200 backgroundColor $ - withTexture frontTexture test - -randomTests :: IO () -randomTests = do - quickCheck fillTest - quickCheck strokeTest - quickCheck dashedStrokeTest -
− exec-src/Sample.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -module Sample where - -import Data.Monoid -import Codec.Picture -import Codec.Picture.Gif -import Graphics.Rasterific -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Transformations - -triangles :: IO () -triangles = - case writeGifImages "triangles.gif" LoopingForever images of - Left err -> putStrLn err - Right v -> v - - where - frameCount = 140 - images = - [(greyPalette, 3, go (i * pi * 2 * (1 / frameCount))) - | i <- [0 .. frameCount] ] - go angle = renderDrawing 400 400 0 $ - mapM_ (render angle) [1 .. 25] - - render angle n = - withTransformation - ( translate (V2 200 180) <> - scale (1 / n + 1) (1 / n + 1) <> - rotate (angle + 0.1 * angle * n) ) $ - - withTexture (uniformTexture (155 + 4 * floor n)) $ - stroke 2 (JoinMiter 0) - (CapStraight 0, CapStraight 0) - triangle - - - triangle = pathToPrimitives $ - Path (V2 0 50) True - [ PathLineTo (V2 50 (-30)) - , PathLineTo (V2 (-50) (-30)) - ] - -main :: IO () -main = do - triangles
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+
− exec-src/rastertest.hs
@@ -1,750 +0,0 @@-{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable( foldMap ) -#endif - -import System.FilePath( (</>) ) -import System.Directory( createDirectoryIfMissing ) - -import Data.Monoid( (<>) ) -import Control.Applicative( (<$>) ) -import Graphics.Rasterific hiding ( fill - , dashedStrokeWithOffset - , dashedStroke - , fillWithMethod, stroke) -import qualified Graphics.Rasterific as R -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Linear( (^+^), (^-^) ) -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Immediate - -import Graphics.Text.TrueType( loadFontFile ) -import Codec.Picture -import Arbitrary -import System.Environment( getArgs ) -import Criterion.Main.Options( defaultConfig ) -import Criterion.Main( defaultMainWith - , bench - , nfIO - ) -{-import Text.Groom( groom )-} -import qualified Sample as Sample - -type Stroker = - Float -> Join -> (Cap, Cap) -> [Primitive] - -> Drawing PixelRGBA8 () - -type DashStroker = DashPattern -> Stroker - -outFolder :: FilePath -outFolder = "test_results" - -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 - - -background, blue, black, yellow, red, white :: PixelRGBA8 -background = PixelRGBA8 128 128 128 255 -blue = PixelRGBA8 0 020 150 255 -red = PixelRGBA8 255 0 0 255 -black = PixelRGBA8 0 0 0 255 -{-grey = PixelRGBA8 128 128 128 255-} -yellow = PixelRGBA8 255 255 0 255 -{-brightblue = PixelRGBA8 0 255 255 255-} -white = PixelRGBA8 255 255 255 255 - -biColor, triColor :: Gradient PixelRGBA8 -biColor = [ (0.0, black) , (1.0, yellow) ] -triColor = [ (0.0, blue), (0.5, white) , (1.0, red) ] - -fill :: [Primitive] -> Drawing PixelRGBA8 () -fill = fillWithMethod FillWinding - -drawBoundingBox :: [Primitive] -> Drawing PixelRGBA8 () -drawBoundingBox prims = do - let PlaneBound mini maxi = foldMap planeBounds prims - V2 width height = maxi ^-^ mini - withTexture (uniformTexture red) $ - R.stroke 2 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ - rectangle mini width height - -stroke :: Float -> Join -> (Cap, Cap) -> [Primitive] - -> Drawing PixelRGBA8 () -stroke w j cap prims = - R.stroke w j cap prims -- >> drawBoundingBox prims - -dashedStroke :: DashPattern -> Float -> Join -> (Cap, Cap) -> [Primitive] - -> Drawing PixelRGBA8 () -dashedStroke p w j c prims = - R.dashedStroke p w j c prims >> drawBoundingBox prims - -dashedStrokeWithOffset - :: Float -> DashPattern -> Float -> Join -> (Cap, Cap) -> [Primitive] - -> Drawing PixelRGBA8 () -dashedStrokeWithOffset o p w j c prims = - R.dashedStrokeWithOffset o p w j c prims >> drawBoundingBox prims - -fillWithMethod :: FillMethod -> [Primitive] -> Drawing PixelRGBA8 () -fillWithMethod method prims = - R.fillWithMethod method prims >> drawBoundingBox prims - -logoTest :: Texture PixelRGBA8 -> String -> IO () -logoTest texture prefix = - writePng (outFolder </> (prefix ++ "logo.png")) img - where - beziers = logo 40 False $ V2 10 10 - inverse = logo 20 True $ V2 20 20 - drawing = withTexture texture . fill $ beziers ++ inverse - img = renderDrawing 100 100 background drawing - -makeBox :: Point -> Point -> [Primitive] -makeBox (V2 sx sy) (V2 ex ey) = map LinePrim $ lineFromPath - [ V2 sx sy - , V2 ex sy - , V2 ex ey - , V2 sx ey - , V2 sx sy - ] - -bigBox :: Texture PixelRGBA8 -> String -> IO () -bigBox texture prefix = - writePng (outFolder </> (prefix ++ "box.png")) img - where - drawing = withTexture texture . fill $ makeBox (V2 10 10) (V2 390 390) - img = renderDrawing 400 400 background drawing - -circleTest :: Texture PixelRGBA8 -> String -> IO () -circleTest texture prefix = - writePng (outFolder </> (prefix ++ "circle.png")) img - where - drawing = withTexture texture . fill $ circle (V2 100 100) 90 - img = renderDrawing 200 200 background drawing - -cubicTest :: [Primitive] -cubicTest = map CubicBezierPrim $ cubicBezierFromPath - [ V2 50 20 - , V2 90 60 - , V2 5 100 - , V2 50 140 - - , V2 70 120 - , V2 80 100 - , V2 120 80 - - , V2 100 60 - , V2 70 20 - , V2 50 20 - ] - -cubicTest1 :: IO () -cubicTest1 = writePng (outFolder </> "cubic1.png") img - where texture = uniformTexture blue - drawing = withTexture texture $ fill cubicTest - img = renderDrawing 150 150 background drawing - -clipTest :: IO () -clipTest = writePng (outFolder </> "clip.png") img - where texture = uniformTexture blue - beziers = - [ logo 20 False $ V2 (-10) (-10) - , logo 20 False $ V2 80 80 - , logo 20 False $ V2 0 80 - , logo 20 False $ V2 80 0 - ] - - drawing = withTexture texture $ mapM_ fill beziers - img = renderDrawing 100 100 background drawing - -strokeTest2 :: Stroker -> String -> IO () -strokeTest2 stroker prefix = - writePng (outFolder </> (prefix ++ "stroke2.png")) img - where texture = uniformTexture blue - points = - [ V2 10 10, V2 100 100 - , V2 200 20, V2 300 100, V2 450 50] - - drawing = withTexture texture . sequence_ . concat $ - [ [] - , [stroker 9 JoinRound (CapRound, CapStraight 0) - . map LinePrim . lineFromPath $ - (^+^ (V2 15 (20 * (ix + 5)))) <$> points - | ix <- [-5 .. -1] ] - , [stroker 9 (JoinMiter $ ix * 3) (CapStraight 0, CapRound) - . map LinePrim . lineFromPath $ - (^+^ (V2 15 (20 * (ix + 5)))) <$> points - | ix <- [0 .. 5] ] - ] - - img = renderDrawing 500 500 background drawing - -strokeTestCliping :: Stroker -> String -> IO () -strokeTestCliping stroker prefix = - writePng (outFolder </> (prefix ++ "stroke_clipping.png")) img - where texture = uniformTexture blue - points = - [ V2 10 10, V2 100 100 - , V2 200 20, V2 300 100, V2 450 50] - - clipShape = R.fill $ circle (V2 250 250) 200 - - drawing = do - withClipping clipShape . - withTexture texture . sequence_ . concat $ - [ [] - , [stroker 9 JoinRound (CapRound, CapStraight 0) - . map LinePrim . lineFromPath $ - (^+^ (V2 15 (20 * (ix + 5)))) <$> points - | ix <- [-5 .. -1] ] - , [stroker 9 (JoinMiter $ ix * 3) (CapStraight 0, CapRound) - . map LinePrim . lineFromPath $ - (^+^ (V2 15 (20 * (ix + 5)))) <$> points - | ix <- [0 .. 5] ] - ] - withTexture (uniformTexture $ PixelRGBA8 255 128 100 128) - . fill $ circle (V2 150 150) 40 - - img = renderDrawing 500 500 background drawing - -strokeLogo :: Stroker -> String -> IO () -strokeLogo stroker prefix = - writePng (outFolder </> (prefix ++ "stroke_logo.png")) img - where texture = uniformTexture blue - beziers = logo 40 False $ V2 10 10 - inverse = logo 20 True $ V2 20 20 - img = renderDrawing 100 100 background - . withTexture texture - . stroker 4 JoinRound (CapRound, CapRound) - $ beziers ++ inverse - -strokeQuadraticIntersection :: - Stroker -> Texture PixelRGBA8 -> String -> IO () -strokeQuadraticIntersection stroker texture prefix = - writePng (outFolder </> (prefix ++ "stroke_quad_intersection.png")) img - where img = renderDrawing 500 500 background - . withTexture texture - . stroker 40 JoinRound (CapRound, CapRound) - . map BezierPrim - $ bezierFromPath - [ V2 30 30 - , V2 150 200 - , V2 450 450 - - , V2 450 90 - , V2 30 450 - ] - -strokeCubic :: Stroker -> Texture PixelRGBA8 -> String - -> IO () -strokeCubic stroker texture prefix = - writePng (outFolder </> (prefix ++ "cubicStroke.png")) img - where img = renderDrawing 500 500 background drawing - cusp = CubicBezier - (V2 10 230) - (V2 350 570) - (V2 10 570) - (V2 350 230) - - loop = CubicBezier - (V2 160 20) - (V2 770 500) - (V2 140 500) - (V2 480 70) - - drawing = withTexture texture . sequence_ . concat $ - [ [] - , [stroker 4 JoinRound (CapRound, CapRound) - $ take 1 cubicTest ] - - , [stroker 15 (JoinMiter 0) - (CapStraight 0, CapStraight 0) - [CubicBezierPrim cusp]] - - , [stroker 25 (JoinMiter 0) - (CapStraight 0, CapStraight 0) - [CubicBezierPrim loop]] - ] - -strokeCubicDashed :: DashStroker -> Texture PixelRGBA8 -> String - -> IO () -strokeCubicDashed stroker texture prefix = - writePng (outFolder </> (prefix ++ "cubicStrokeDashed.png")) img - where img = renderDrawing 500 500 background drawing - cusp = CubicBezier - (V2 10 230) - (V2 350 570) - (V2 10 570) - (V2 350 230) - - loop = CubicBezier - (V2 160 20) - (V2 770 500) - (V2 140 500) - (V2 480 70) - - dashPattern = [10, 5, 20, 10] - - drawing = withTexture texture . sequence_ . concat $ - [ [] - , [stroker dashPattern 4 JoinRound (CapRound, CapRound) - $ take 1 cubicTest ] - - , [stroker dashPattern 15 (JoinMiter 0) - (CapStraight 0, CapStraight 0) - [CubicBezierPrim cusp]] - - , [stroker dashPattern 25 (JoinMiter 0) - (CapStraight 0, CapStraight 0) - [CubicBezierPrim loop]] - ] - -textAlignStringTest :: String -> String -> String -> IO () -textAlignStringTest fontName filename txt = do - putStrLn $ "Rendering " ++ fontName - fontErr <- loadFontFile $ "C:/Windows/Fonts/" ++ fontName ++ ".ttf" - case fontErr of - Left err -> putStrLn err - Right font -> - writePng (outFolder </> filename) . - renderDrawing 300 70 white - . withTexture (uniformTexture black) $ - printTextAt font (PointSize 12) (V2 20 40) txt - -textStrokeTest :: String -> String -> String -> IO () -textStrokeTest fontName filename txt = do - putStrLn $ "Rendering " ++ fontName - fontErr <- loadFontFile $ "C:/Windows/Fonts/" ++ fontName ++ ".ttf" - case fontErr of - Left err -> putStrLn err - Right font -> do - let drawing = printTextAt font (PointSize 20) (V2 30 30) txt - orders = drawOrdersOfDrawing 300 300 96 (PixelRGBA8 0 0 0 0) drawing - writePng (outFolder </> filename) . - renderDrawing 300 70 white . - withTexture (uniformTexture black) . - mapM_ (mapM_ (stroke 1 (JoinMiter 0) (CapRound, CapRound) - ) . _orderPrimitives) $ orders - -strokeTest :: Stroker -> Texture PixelRGBA8 -> String - -> IO () -strokeTest stroker texture prefix = - writePng (outFolder </> (prefix ++ "stroke.png")) img - where beziers base = take 1 <$> - take 3 [ logo 100 False $ V2 ix ix | ix <- [base, base + 20 ..] ] - drawing = withTexture texture $ sequence_ . concat $ - [ [] - , [stroker (6 + ix) (JoinMiter ix) - (CapStraight 0, CapRound) b - | (ix, b) <- zip [1 ..] (beziers 10)] - , [stroker ix - (JoinMiter 1) (CapRound, CapStraight 1) b - | (ix, b) <- zip [1 ..] (beziers 60)] - , [stroker ix (JoinMiter 1) (CapRound, CapRound) b - | (ix, b) <- zip [1 ..] (beziers 110)] - , [stroker 15 - (JoinMiter 1) (CapStraight 1, CapStraight 0) - . take 1 $ - logo 150 False $ V2 200 200] - , [stroker 5 - (JoinMiter 1) (CapStraight 0, CapStraight 0) $ - logo 100 False $ V2 240 240] - ] - img = renderDrawing 500 500 background drawing - -orientationAxisText :: IO () -orientationAxisText = - let trans = translate (V2 200 200) <> toNewXBase (V2 1 (-0.5)) in - writePng (outFolder </> "axis_transform.png") - . renderDrawing 400 400 white - . withTexture (uniformTexture blue) - . fill . transform (applyTransformation trans) - . pathToPrimitives - $ Path (V2 (-100) (-10)) True - [ PathLineTo (V2 (-20) (-10)) - , PathLineTo (V2 0 5) - , PathLineTo (V2 20 (-10)) - , PathLineTo (V2 100 (-10)) - , PathLineTo (V2 100 10) - , PathLineTo (V2 (-100) 10) - ] - -complexEvenOddTest :: Int -> Texture PixelRGBA8 -> IO () -complexEvenOddTest size texture = mapM_ tester [(filling, ix) - | filling <- [(FillEvenOdd, "evenodd") - ,(FillWinding, "winding")] - , ix <- [1 :: Int .. 3]] where - command = - [ 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) - ] - ] - - tester ((method, name), i) = - writePng (outFolder </> ("complex_" ++ name ++ "_" ++ show i ++ "_" ++ show size ++ "px.png")) - . renderDrawing size size white - . withTexture texture - . fillWithMethod method - . fmap (transform . applyTransformation $ - rotateCenter (fromIntegral i / 6) (V2 (350) (350))) - $ concatMap pathToPrimitives command - -evenOddTest :: Texture PixelRGBA8 -> IO () -evenOddTest texture = mapM_ tester [1 :: Int .. 3] where - command = - Path (V2 250 75) True - [ PathLineTo (V2 323 301) - , PathLineTo (V2 131 161) - , PathLineTo (V2 369 161) - , PathLineTo (V2 177 301) - ] - tester i = - writePng (outFolder </> ("even_odd" ++ show i ++ ".png")) - . renderDrawing 300 300 white - . withTexture texture - . fillWithMethod FillEvenOdd - . fmap (transform . applyTransformation $ - translate (V2 (-80) (-40)) - <> rotateCenter (fromIntegral i / 6) (V2 (250) (200))) - $ pathToPrimitives command - -crash :: Texture PixelRGBA8 -> IO () -crash texture = do - writePng (outFolder </> "crash00.png") $ - renderDrawing 600 600 background $ - withTexture texture $ fill geom - where - geom = concat - [line (V2 572.7273 572.7273) (V2 572.7273 27.272766) - ,line (V2 572.7273 27.272728) (V2 27.272766 27.272728) - ,line (V2 27.272728 27.272728) (V2 27.272728 572.72723) - ,line (V2 27.272728 572.7273) (V2 572.72723 572.7273) - - ,line (V2 481.81818 481.81818) (V2 118.18182 481.81818) - ,line (V2 118.181816 481.81818) (V2 118.181816 118.18182) - ,line (V2 118.181816 118.181816) (V2 481.81818 118.181816) - ,line (V2 481.81818 118.181816) (V2 481.81818 481.81818) - ] -strokeCrash :: IO () -strokeCrash = do - let drawColor = PixelRGBA8 0 0x86 0xc1 255 - img = renderDrawing 600 600 white $ - withTexture (uniformTexture drawColor) $ do - stroke 5 (JoinMiter 0) (CapStraight 0, CapStraight 0) - [LinePrim (Line (V2 572.7273 572.7273) (V2 572.7273 27.272766)) - ,LinePrim (Line (V2 572.7273 27.272728) (V2 27.272766 27.272728)) - ,LinePrim (Line (V2 27.272728 27.272728) (V2 27.272728 572.72723)) - ,LinePrim (Line (V2 27.272728 572.7273) (V2 572.72723 572.7273)) - ] - stroke 5 (JoinMiter 0) (CapStraight 0, CapStraight 0) - [LinePrim (Line (V2 481.81818 481.81818) (V2 118.18182 481.81818)) - ,LinePrim (Line (V2 118.181816 481.81818) (V2 118.181816 118.18182)) - ,LinePrim (Line (V2 118.181816 118.181816) (V2 481.81818 118.181816)) - ,LinePrim (Line (V2 481.81818 118.181816) (V2 481.81818 481.81818)) - ] - - writePng (outFolder </> "stroke_crash.png") img - -dashTest :: IO () -dashTest = writePng (outFolder </> "dashed_wheel.png") - . renderDrawing 550 550 white - $ withTexture (uniformTexture black) drawing - where - drawing = - dashedStrokeWithOffset 0.0 [4.0,4.0] 10.0 - (JoinMiter 0.0) (CapStraight 0.0,CapStraight 0.0) - [CubicBezierPrim - (CubicBezier (V2 525.0 275.0) (V2 525.0 136.92882) - (V2 413.0712 25.0) (V2 275.0 25.0)) - ] - -weirdCircle :: IO () -weirdCircle = writePng (outFolder </> "bad_circle.png") - . renderDrawing 400 200 white - $ withTexture (uniformTexture black) drawing - where - drawing = - fill [CubicBezierPrim $ CubicBezier (V2 375.0 125.0) - (V2 375.0 55.96441) - (V2 319.03558 0.0) - (V2 250.0 0.0) - ,CubicBezierPrim $ CubicBezier (V2 250.0 (-1.4210855e-14)) - (V2 180.96442 (-1.8438066e-14)) - (V2 125.0 55.964405) - (V2 125.0 125.0) - ,CubicBezierPrim $ CubicBezier (V2 125.0 125.0) - (V2 125.0 194.03558) - (V2 180.9644 250.0) - (V2 250.0 250.0) - ,CubicBezierPrim $ CubicBezier (V2 250.0 250.0) - (V2 319.03558 250.0) - (V2 375.0 194.0356) - (V2 375.0 125.0) - ] - -transparentGradient :: IO () -transparentGradient = - writePng (outFolder </> "transparent_gradient.png") $ renderDrawing 400 200 white img - where img = withTexture (withSampler SamplerPad - (linearGradientTexture gradDef - (V2 40 40) (V2 130 130))) $ - fill $ circle (V2 100 100) 100 - gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 50)] - -gradientRadial :: String -> PixelRGBA8 -> IO () -gradientRadial name back = - writePng (outFolder </> ("rad_opacity" ++ name ++ ".png")) $ - renderDrawing 500 500 back img - where img = withTexture (withSampler SamplerRepeat - (radialGradientTexture gradDef - (V2 250 250) 100)) $ - fill $ rectangle (V2 0 0) 500 500 - gradDef = - [(0 , PixelRGBA8 255 165 0 102) - ,(0.5, PixelRGBA8 255 165 0 102) - ,(0.5, PixelRGBA8 255 165 0 102) - ,(0.525, PixelRGBA8 255 165 0 255) - ,(0.675, PixelRGBA8 128 128 128 64) - ,(0.75, PixelRGBA8 0 128 128 255) - ,(1, PixelRGBA8 0 128 128 255) - ] - -strokeBad2 :: IO () -strokeBad2 = - writePng (outFolder </> ("bad_stroke_letter.png")) $ - renderDrawing 70 70 white drawing - where - drawing = - withTexture (uniformTexture (PixelRGBA8 76 0 0 255)) $ - stroke 1.0 (JoinMiter 0.0) (CapRound - ,CapRound) $ - BezierPrim <$> - [ - {- - Bezier (V2 44.958496 23.413086) (V2 39.9292 23.413086) (V2 34.91211 23.413086) - ,Bezier (V2 34.91211 23.413086) (V2 34.91211 24.67041) (V2 35.290527 25.610352) - ,Bezier (V2 35.290527 25.610352) (V2 35.668945 26.538086) (V2 36.328125 27.13623) - ,Bezier (V2 36.328125 27.13623) (V2 36.96289 27.722168) (V2 37.82959 28.015137) - ,Bezier (V2 37.82959 28.015137) (V2 38.708496 28.308105) (V2 39.7583 28.308105) - ,Bezier (V2 39.7583 28.308105) (V2 41.149902 28.308105) (V2 42.55371 27.75879) - ,Bezier (V2 42.55371 27.75879) (V2 43.969727 27.197266) (V2 44.56787 26.660156) - ,Bezier (V2 44.56787 26.660156) (V2 44.628906 26.660156) (V2 44.68994 26.660156) - ,Bezier (V2 44.68994 26.660156) (V2 44.68994 27.91748) (V2 44.68994 29.162598) - ,Bezier (V2 44.68994 29.162598) (V2 43.530273 29.650879) (V2 42.321777 29.980469) - -} - {- - Bezier (V2 42.321777 29.980469) (V2 41.11328 30.310059) (V2 39.782715 30.310059) - ,Bezier (V2 39.782715 30.310059) (V2 36.38916 30.310059) (V2 34.484863 28.479004) - ,Bezier (V2 34.484863 28.479004) (V2 32.580566 26.635742) (V2 32.580566 23.254395) - ,Bezier (V2 32.580566 23.254395) (V2 32.580566 19.909668) (V2 34.399414 17.944336) - ,Bezier (V2 34.399414 17.944336) (V2 36.23047 15.979004) (V2 39.208984 15.979004) - ,Bezier (V2 39.208984 15.979004) (V2 41.967773 15.979004) (V2 43.45703 17.590332) - -} - -- Bezier (V2 43.45703 17.590332) (V2 44.958496 19.20166) (V2 44.958496 22.167969) - Bezier (V2 44.958496 22.167969) (V2 44.958496 22.790527) (V2 44.958496 23.413086) - ,Bezier (V2 42.72461 21.655273) (V2 42.712402 19.848633) (V2 41.809082 18.859863) - {- - Bezier (V2 41.809082 18.859863) (V2 40.91797 17.871094) (V2 39.086914 17.871094) - ,Bezier (V2 39.086914 17.871094) (V2 37.243652 17.871094) (V2 36.14502 18.95752) - ,Bezier (V2 36.14502 18.95752) (V2 35.058594 20.043945) (V2 34.91211 21.655273) - ,Bezier (V2 34.91211 21.655273) (V2 38.81836 21.655273) (V2 42.72461 21.655273) - -- -} - ] - -strokeBad :: IO () -strokeBad = - writePng (outFolder </> ("bad_stroke_tiger.png")) $ - renderDrawing 500 500 white drawing - where - drawing = - withTransformation (Transformation { _transformA = 1.6 - , _transformC = 0.0 - , _transformE = 350.0 - , _transformB = 0.0 - , _transformD = 1.6 - , _transformF = 300.0}) $ - withTexture (uniformTexture (PixelRGBA8 76 0 0 255)) $ - stroke 2.0 (JoinMiter 1.0) (CapStraight 0.0 - ,CapStraight 0.0) $ - CubicBezierPrim <$> - [CubicBezier (V2 21.2 63.0) - (V2 21.2 63.0) - (V2 4.200001 55.8) - (V2 (-10.599998) 53.6) - ,CubicBezier (V2 (-10.599998) 53.6) - (V2 (-10.599998) 53.6) - (V2 (-27.199999) 51.0) - (V2 (-43.8) 58.199997) - ,CubicBezier (V2 (-43.8) 58.199997) - (V2 (-43.8) 58.199997) - (V2 (-56.0) 64.2) - (V2 (-61.4) 74.399994)] -pledgeTest :: IO () -pledgeTest = do - (Right (ImageRGBA8 png)) <- readImage "exec-src/test_img.png" - writePng (outFolder </> "pledge_render.png") . - renderDrawing 389 89 white $ - drawImage png 0 (V2 0 0) - -shouldBeTheSame :: IO () -shouldBeTheSame = do - writePng (outFolder </> "should_be_same_0.png") $ img prim1 - writePng (outFolder </> "should_be_same_1.png") $ img prim2 - where - drawColor = PixelRGBA8 0 0x86 0xc1 255 - prim1 = CubicBezier (V2 10 10) (V2 210 210) - (V2 210 210) (V2 10 410) - prim2 = CubicBezier (V2 10 10) (V2 210 210) - (V2 210 210.1) (V2 10 410) - - img bez = renderDrawing 400 200 white $ - withTexture (uniformTexture drawColor) $ - stroke 4 JoinRound (CapRound, CapRound) [CubicBezierPrim bez] - -clipFail :: IO () -clipFail = writePng (outFolder </> "cubicbezier_clipError.png") img - where - trans = applyTransformation $ translate (V2 0 (-20)) - img = renderDrawing 512 256 white . - withTexture (uniformTexture red) $ fill geometry - - geometry = transform trans $ CubicBezierPrim <$> - [ CubicBezier (V2 104.707344 88.55418) (V2 153.00671 140.66666) - (V2 201.30609 192.77914) (V2 249.60547 244.89162) - , CubicBezier (V2 249.60547 244.89162) (V2 349.59445 206.46687) - (V2 449.58347 168.04214) (V2 549.57245 129.6174) - , CubicBezier (V2 549.57245 129.6174) (V2 401.28406 115.92966) - (V2 252.99573 102.24192) (V2 104.707344 88.55418) - ] - -testSuite :: IO () -testSuite = do - let uniform = uniformTexture blue - biGradient = - linearGradientTexture biColor (V2 10 10) (V2 90 90) - radBiGradient = - radialGradientTexture biColor (V2 45 45) 60 - bigBiGradient = - linearGradientTexture biColor (V2 0 10) (V2 0 390) - triGradient = - linearGradientTexture triColor (V2 0 10) (V2 0 390) - radTriGradient = - radialGradientTexture triColor (V2 250 250) 200 - radFocusTriGradient = - radialGradientWithFocusTexture - triColor (V2 200 200) 70 (V2 250 200) - radFocusTriGradient2 = - radialGradientWithFocusTexture - triColor (V2 200 200) 70 (V2 150 170) - - createDirectoryIfMissing True outFolder - clipFail - pledgeTest - strokeBad - strokeBad2 - evenOddTest uniform - orientationAxisText - complexEvenOddTest 700 uniform - complexEvenOddTest 350 uniform - - weirdCircle - dashTest - - strokeCrash - logoTest uniform "" - logoTest biGradient "gradient_" - crash uniform - transparentGradient - gradientRadial "white_opaque" white - gradientRadial "black_opaque" black - gradientRadial "white_transparent" (PixelRGBA8 255 255 255 0) - gradientRadial "white_semi" (PixelRGBA8 255 255 255 128) - gradientRadial "black_transparent" (PixelRGBA8 0 0 0 0) - gradientRadial "gray_opaque" (PixelRGBA8 128 128 128 255) - gradientRadial "gray_transparent" (PixelRGBA8 128 128 128 0) - gradientRadial "gray_semi" (PixelRGBA8 128 128 128 128) - - bigBox uniform "" - bigBox biGradient "gradient_" - bigBox bigBiGradient "gradient_big_" - bigBox triGradient "gradient_tri_" - bigBox radBiGradient "rad_gradient_" - bigBox radTriGradient "rad_trigradient_" - bigBox radFocusTriGradient "rad_focus_trigradient_" - bigBox radFocusTriGradient2 "rad_focus_trigradient_2_" - - circleTest uniform "" - strokeTestCliping stroke "" - - cubicTest1 - clipTest - strokeTest stroke uniform "" - strokeTest stroke bigBiGradient "gradient_" - strokeTest stroke radTriGradient "rad_gradient_" - strokeLogo stroke "" - - strokeQuadraticIntersection stroke uniform "" - strokeQuadraticIntersection stroke triGradient "gradient_" - strokeQuadraticIntersection stroke radBiGradient "rad_gradient_" - - strokeTest2 stroke "" - - strokeCubic stroke uniform "" - strokeCubic stroke bigBiGradient "gradient_" - strokeCubic stroke radTriGradient "rad_gradient_" - - strokeCubicDashed dashedStroke uniform "" - shouldBeTheSame - - let testText = - "Test of a text! It seems to be; à é è ç, working? () {} [] \" '" - - textAlignStringTest "CONSOLA" "alignedConsola.png" testText - textAlignStringTest "arial" "alignedArial.png" - "Just a simple test, gogo !!! Yay ; quoi ?" - textStrokeTest "verdana" "stroke_verdana.png" "e" - -- -} - -benchTest :: [String] -> IO () -benchTest _args = do - defaultMainWith defaultConfig - [bench "testsuite" $ nfIO testSuite, - bench "Triangles" $ nfIO Sample.triangles] - -main :: IO () -main = do - args <- getArgs - case args of - "random":_ -> randomTests - "bench":rest -> benchTest rest - "prof":_ -> Sample.triangles - _ -> testSuite -
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+