Rasterific 0.1 → 0.2
raw patch · 62 files changed
+2916/−2211 lines, 62 filesdep ~FontyFruitydep ~JuicyPixelsdep ~linearsetup-changedbinary-added
Dependency ranges changed: FontyFruity, JuicyPixels, linear
Files
- LICENSE +30/−30
- Rasterific.cabal +64/−63
- Setup.hs +2/−2
- changelog +24/−5
- docimages/cap_round.png binary
- docimages/cap_straight.png binary
- docimages/cap_straight_1.png binary
- docimages/coordinate.png binary
- docimages/cubic_bezier.png binary
- docimages/dashed_stroke.png binary
- docimages/dashed_stroke_with_offset.png binary
- docimages/fill_circle.png binary
- docimages/fill_ellipse.png binary
- docimages/fill_evenodd.png binary
- docimages/fill_polygon.png binary
- docimages/fill_rect.png binary
- docimages/fill_roundedRectangle.png binary
- docimages/fill_winding.png binary
- docimages/image_resize.png binary
- docimages/image_simple.png binary
- docimages/join_miter.png binary
- docimages/join_miter_5.png binary
- docimages/join_round.png binary
- docimages/linear_gradient.png binary
- docimages/logo.png binary
- docimages/module_example.png binary
- docimages/path_example.png binary
- docimages/primitive_mixed.png binary
- docimages/quadratic_bezier.png binary
- docimages/radial_gradient.png binary
- docimages/radial_gradient_focus.png binary
- docimages/sampled_texture_pad.png binary
- docimages/sampled_texture_reflect.png binary
- docimages/sampled_texture_repeat.png binary
- docimages/sampled_texture_rotate.png binary
- docimages/sampled_texture_scaled.png binary
- docimages/sampler_pad.png binary
- docimages/sampler_reflect.png binary
- docimages/sampler_repeat.png binary
- docimages/simple_line.png binary
- docimages/stroke_circle.png binary
- docimages/stroke_line.png binary
- docimages/stroke_polyline.png binary
- docimages/stroke_roundedRectangle.png binary
- docimages/text_example.png binary
- docimages/transform_rotate.png binary
- docimages/transform_rotate_center.png binary
- docimages/transform_scale.png binary
- docimages/transform_translate.png binary
- docimages/with_clipping.png binary
- docimages/with_texture.png binary
- src/Graphics/Rasterific.hs +753/−485
- src/Graphics/Rasterific/Compositor.hs +75/−66
- src/Graphics/Rasterific/CubicBezier.hs +287/−285
- src/Graphics/Rasterific/Line.hs +100/−100
- src/Graphics/Rasterific/Operators.hs +163/−146
- src/Graphics/Rasterific/QuadraticBezier.hs +260/−260
- src/Graphics/Rasterific/Rasterize.hs +47/−40
- src/Graphics/Rasterific/Stroke.hs +258/−244
- src/Graphics/Rasterific/Texture.hs +331/−231
- src/Graphics/Rasterific/Transformations.hs +130/−0
- src/Graphics/Rasterific/Types.hs +392/−254
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,63 +1,64 @@--- Initial Rasterific.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ -name: Rasterific -version: 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-source-files: changelog, docimages/*.png -extra-doc-files: docimages/*.png - - -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.1 - -library - hs-source-dirs: src - exposed-modules: Graphics.Rasterific - , Graphics.Rasterific.Texture - - other-modules: Graphics.Rasterific.Line - , Graphics.Rasterific.QuadraticBezier - , Graphics.Rasterific.CubicBezier - , Graphics.Rasterific.Stroke - , Graphics.Rasterific.Operators - , Graphics.Rasterific.Rasterize - , Graphics.Rasterific.Types - , Graphics.Rasterific.Compositor - - ghc-options: -O2 -Wall - ghc-prof-options: -Wall -prof -auto-all - default-language: Haskell2010 - build-depends: base >= 4.6 && < 4.9 - , JuicyPixels >= 3.1.4 && < 3.2 - , linear >= 1.3.1 && < 1.4 - , free >= 4.5 && < 4.6 - , FontyFruity >= 0.1.0.2 && < 0.2 - , vector >= 0.9 - , mtl >= 2.1 - +-- Initial Rasterific.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/+name: Rasterific+version: 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-source-files: changelog, docimages/*.png+extra-doc-files: docimages/*.png+++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.2++library+ hs-source-dirs: src+ exposed-modules: Graphics.Rasterific+ , Graphics.Rasterific.Texture+ , Graphics.Rasterific.Transformations++ other-modules: Graphics.Rasterific.Line+ , Graphics.Rasterific.QuadraticBezier+ , Graphics.Rasterific.CubicBezier+ , Graphics.Rasterific.Stroke+ , Graphics.Rasterific.Operators+ , Graphics.Rasterific.Rasterize+ , Graphics.Rasterific.Types+ , Graphics.Rasterific.Compositor++ ghc-options: -O2 -Wall+ ghc-prof-options: -Wall -prof -auto-all+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 4.9+ , JuicyPixels >= 3.1.5 && < 3.2+ , linear >= 1.3.1 && < 1.9+ , free >= 4.5 && < 4.6+ , FontyFruity >= 0.2 && < 0.3+ , vector >= 0.9+ , mtl >= 2.1+
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
changelog view
@@ -1,5 +1,24 @@--*-change-log-*- - -v0.1 February 2014 - * Initial version - +-*-change-log-*-++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.+ * 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.+ * Made some modest performance enhancements.++v0.1 February 2014+ * Initial version.+
docimages/cap_round.png view
binary file changed (1781 → 1070 bytes)
docimages/cap_straight.png view
binary file changed (1664 → 986 bytes)
docimages/cap_straight_1.png view
binary file changed (1767 → 1082 bytes)
docimages/coordinate.png view
binary file changed (4195 → 1870 bytes)
docimages/cubic_bezier.png view
binary file changed (4490 → 2856 bytes)
docimages/dashed_stroke.png view
binary file changed (665 → 222 bytes)
+ docimages/dashed_stroke_with_offset.png view
binary file changed (absent → 221 bytes)
docimages/fill_circle.png view
binary file changed (2672 → 1065 bytes)
+ docimages/fill_ellipse.png view
binary file changed (absent → 809 bytes)
+ docimages/fill_evenodd.png view
binary file changed (absent → 3775 bytes)
+ docimages/fill_polygon.png view
binary file changed (absent → 1392 bytes)
docimages/fill_rect.png view
binary file changed (785 → 122 bytes)
+ docimages/fill_roundedRectangle.png view
binary file changed (absent → 442 bytes)
+ docimages/fill_winding.png view
binary file changed (absent → 2782 bytes)
+ docimages/image_resize.png view
binary file changed (absent → 22315 bytes)
+ docimages/image_simple.png view
binary file changed (absent → 8387 bytes)
docimages/join_miter.png view
binary file changed (2216 → 1322 bytes)
docimages/join_miter_5.png view
binary file changed (2093 → 1239 bytes)
docimages/join_round.png view
binary file changed (2130 → 1277 bytes)
docimages/linear_gradient.png view
binary file changed (4400 → 3778 bytes)
docimages/logo.png view
binary file changed (3588 → 1649 bytes)
docimages/module_example.png view
binary file changed (2322 → 1046 bytes)
docimages/path_example.png view
binary file changed (2175 → 1316 bytes)
docimages/primitive_mixed.png view
binary file changed (2175 → 1316 bytes)
docimages/quadratic_bezier.png view
binary file changed (3688 → 2283 bytes)
docimages/radial_gradient.png view
binary file changed (16884 → 10158 bytes)
docimages/radial_gradient_focus.png view
binary file changed (19015 → 11747 bytes)
+ docimages/sampled_texture_pad.png view
binary file changed (absent → 8287 bytes)
+ docimages/sampled_texture_reflect.png view
binary file changed (absent → 34555 bytes)
+ docimages/sampled_texture_repeat.png view
binary file changed (absent → 25162 bytes)
+ docimages/sampled_texture_rotate.png view
binary file changed (absent → 84457 bytes)
+ docimages/sampled_texture_scaled.png view
binary file changed (absent → 56580 bytes)
docimages/sampler_pad.png view
binary file changed (1815 → 1097 bytes)
docimages/sampler_reflect.png view
binary file changed (2581 → 1437 bytes)
docimages/sampler_repeat.png view
binary file changed (2271 → 1459 bytes)
docimages/simple_line.png view
binary file changed (3100 → 1960 bytes)
docimages/stroke_circle.png view
binary file changed (4301 → 1744 bytes)
docimages/stroke_line.png view
binary file changed (3321 → 1567 bytes)
+ docimages/stroke_polyline.png view
binary file changed (absent → 1451 bytes)
+ docimages/stroke_roundedRectangle.png view
binary file changed (absent → 571 bytes)
docimages/text_example.png view
binary file changed (2210 → 1042 bytes)
+ docimages/transform_rotate.png view
binary file changed (absent → 1873 bytes)
+ docimages/transform_rotate_center.png view
binary file changed (absent → 1890 bytes)
+ docimages/transform_scale.png view
binary file changed (absent → 117 bytes)
+ docimages/transform_translate.png view
binary file changed (absent → 122 bytes)
docimages/with_clipping.png view
binary file changed (3166 → 1707 bytes)
docimages/with_texture.png view
binary file changed (1581 → 807 bytes)
src/Graphics/Rasterific.hs view
@@ -1,485 +1,753 @@-{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} --- | 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 --- > --- > 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 - , withTexture - , withClipping - , stroke - , dashedStroke - , printTextAt - - , strokeDebug - , renderDrawing - , pathToPrimitives - - -- * Rasterization types - , Texture - , Drawing - , Modulable - - -- * Geometry description - , V2( .. ) - , Point - , Vector - , CubicBezier( .. ) - , Line( .. ) - , Bezier( .. ) - , Primitive( .. ) - , Path( .. ) - , PathCommand( .. ) - , Transformable( .. ) - - -- * Helpers - , line - , rectangle - , circle - - -- ** Geometry Helpers - , clip - , bezierFromPath - , lineFromPath - , cubicBezierFromPath - - -- * Rasterization control - , Join( .. ) - , Cap( .. ) - , SamplerRepeat( .. ) - , DashPattern - - ) where - -import Control.Applicative( (<$>) ) -import Control.Monad( forM_ ) -import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.ST( ST, runST ) -import Control.Monad.State( StateT, execStateT, get, lift ) -import Codec.Picture.Types( Image( .. ) - , Pixel( .. ) - , MutableImage( .. ) - , createMutableImage - , unsafeFreezeImage ) - -import qualified Data.Vector.Unboxed as VU -import Linear( V2( .. ), (^+^), (^*) ) - -import Graphics.Rasterific.Compositor -{-import Graphics.Rasterific.Operators-} -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Types -import Graphics.Rasterific.Line -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.Stroke - -import Graphics.Text.TrueType( Font, PointSize, getStringCurveAtPoint ) - -{-import Debug.Trace-} -{-import Text.Printf-} - --- | Monad used to describe the drawing context. -type DrawContext s px a = - StateT (MutableImage s px) (ST s) a - ------------------------------------------------- ----- Free Monad DSL section ------------------------------------------------- - --- | Monad used to record the drawing actions. -type Drawing px a = Free (DrawCommand px) a - -data DrawCommand px next - = Fill [Primitive] next - | TextFill Font PointSize Point String next - | SetTexture (Texture px) - (Drawing px ()) next - | WithCliping (forall innerPixel. Drawing innerPixel ()) - (Drawing px ()) next - -instance Functor (DrawCommand px) where - fmap f (TextFill font size pos str next) = - TextFill font size pos str $ f next - fmap f (Fill prims next) = Fill 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) - --- | 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 () - --- | 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 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 = fill . strokize width join caping - --- | 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 --- > --- > 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 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 - -> Int -- ^ font Point size - -> Point -- ^ Baseline begining position - -> String -- ^ String to print - -> Drawing px () -printTextAt font pointSize point string = - liftF $ TextFill font pointSize point string () - --- | 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. -renderDrawing - :: forall px - . ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px) - ) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> Image px -renderDrawing width height background drawing = runST $ - createMutableImage width height background - >>= execStateT (go Nothing stupidDefaultTexture drawing) - >>= unsafeFreezeImage - where - clipBackground = emptyValue :: PixelBaseComponent px - clipForeground = fullValue :: PixelBaseComponent px - stupidDefaultTexture = - uniformTexture $ colorMap (const clipBackground) background - - clipRender = - renderDrawing width height clipBackground - . withTexture (uniformTexture clipForeground) - - - go :: Maybe (Texture (PixelBaseComponent px)) - -> Texture px - -> Drawing px () - -> DrawContext s px () - go _ _ (Pure ()) = return () - go Nothing texture (Free (Fill prims next)) = - fillWithTexture texture prims >> go Nothing texture next - go mo@(Just moduler) texture (Free (Fill prims next)) = - fillWithTextureAndMask texture moduler prims >> go mo texture next - go moduler texture (Free (SetTexture tx sub next)) = - go moduler tx sub >> go moduler texture next - go moduler texture (Free (TextFill font size (V2 x y) str next)) = - forM_ drawCalls (go moduler texture) >> go moduler texture next - where - drawCalls = beziersOfChar <$> getStringCurveAtPoint 90 (x, y) [(font, size, str)] - - beziersOfChar curves = liftF $ Fill bezierCurves () - where - bezierCurves = concat - [map BezierPrim . bezierFromPath . map (uncurry V2) - $ VU.toList c | c <- curves] - - go moduler texture (Free (WithCliping clipPath path next)) = - go newModuler texture path >> go moduler texture next - where - modulationTexture :: Texture (PixelBaseComponent px) - modulationTexture = imageTexture $ clipRender clipPath - - newModuler = Just $ subModuler moduler - - 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 dashing width join caping = - mapM_ fill . dashedStrokize dashing width join caping - --- | Internal debug function -strokeDebug :: ( Pixel px, Modulable (PixelBaseComponent px)) - => Texture px -> Texture px - -> Float -> Join -> (Cap, Cap) - -> [Primitive] -> Drawing px () -strokeDebug debugPair debugImpair width join caping elems = do - fill stroked - forM_ (zip debugColor stroked) subStroke - where stroked = strokize width join caping elems - -- | Infinite list repeating color pattern - debugColor = debugPair : debugImpair : debugColor - subStroke (color, el) = - withTexture color $ stroke 2 (JoinMiter 0) - (CapStraight 0, CapStraight 0) [el] - --- | Clip the geometry to a rectangle. -clip :: Point -- ^ Minimum point (corner upper left) - -> Point -- ^ Maximum point (corner bottom right) - -> Primitive -- ^ Primitive to be clipped - -> [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 - --- | 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. -fillWithTexture :: (Pixel px, Modulable (PixelBaseComponent px)) - => Texture px -- ^ Color/Texture used for the filling - -> [Primitive] -- ^ Primitives to fill - -> DrawContext s px () -fillWithTexture texture els = do - img@(MutableImage width height _) <- get - let mini = V2 0 0 - maxi = V2 (fromIntegral width) (fromIntegral height) - spans = rasterize $ els >>= clip mini maxi - lift $ mapM_ (composeCoverageSpan texture img) spans - -fillWithTextureAndMask - :: ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px)) - => Texture px -- ^ Color/Texture used for the filling - -> Texture (PixelBaseComponent px) - -> [Primitive] -- ^ Primitives to fill - -> DrawContext s px () -fillWithTextureAndMask texture mask els = do - img@(MutableImage width height _) <- get - let mini = V2 0 0 - maxi = V2 (fromIntegral width) (fromIntegral height) - spans = rasterize $ els >>= clip mini maxi - lift $ mapM_ (composeCoverageSpanWithMask texture mask img) spans - -composeCoverageSpan :: forall s px . - ( Pixel px, Modulable (PixelBaseComponent px) ) - => Texture px - -> MutableImage s px - -> CoverageSpan - -> ST s () -{-# INLINE composeCoverageSpan #-} -composeCoverageSpan texture img coverage - | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () - | otherwise = go 0 initialX initIndex - where compCount = componentCount (undefined :: px) - maxi = _coverageLength coverage - imgData = mutableImageData img - y = floor $ _coverageY coverage - initialX = floor $ _coverageX coverage - imgWidth = mutableImageWidth img - imgHeight = mutableImageHeight img - initIndex = (initialX + y * imgWidth) * compCount - (initialCov, _) = - clampCoverage $ _coverageVal coverage - - shader = texture SamplerPad - - go count _ _ | count >= maxi = return () - go count x idx = do - oldPixel <- unsafeReadPixel imgData idx - let px = shader (fromIntegral x) (fromIntegral y) - opacity = pixelOpacity px - (cov, icov) = coverageModulate initialCov opacity - unsafeWritePixel imgData idx - $ compositionAlpha cov icov oldPixel px - - go (count + 1) (x + 1) $ idx + compCount - -composeCoverageSpanWithMask - :: forall s px - . ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px) ) - => Texture px - -> Texture (PixelBaseComponent px) - -> MutableImage s px - -> CoverageSpan - -> ST s () -{-# INLINE composeCoverageSpanWithMask #-} -composeCoverageSpanWithMask texture mask img coverage - | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () - | otherwise = go 0 initialX initIndex - where compCount = componentCount (undefined :: px) - maxi = _coverageLength coverage - imgData = mutableImageData img - y = floor $ _coverageY coverage - initialX = floor $ _coverageX coverage - imgWidth = mutableImageWidth img - imgHeight = mutableImageHeight img - initIndex = (initialX + y * imgWidth) * compCount - (initialCov, _) = - clampCoverage $ _coverageVal coverage - - maskShader = mask SamplerPad - shader = texture SamplerPad - - go count _ _ | count >= maxi = return () - go count x idx = do - oldPixel <- unsafeReadPixel imgData idx - let fx = fromIntegral x - fy = fromIntegral y - maskValue = maskShader fx fy - px = shader fx fy - (coeffMasked, _) = coverageModulate initialCov maskValue - (cov, icov) = coverageModulate coeffMasked $ pixelOpacity px - unsafeWritePixel imgData idx - $ compositionAlpha cov icov oldPixel px - go (count + 1) (x + 1) $ idx + compCount - - --- | 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 . scaleMove <$> cubicBezierCircle - where - mv p = (p ^* radius) ^+^ center - scaleMove (CubicBezier p1 p2 p3 p4) = - CubicBezier (mv p1) (mv p2) (mv p3) (mv p4) - --- | 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 ] - --- | 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 #-}+-- | 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+ , stroke+ , dashedStroke+ , dashedStrokeWithOffset+ , printTextAt++ , renderDrawing+ , pathToPrimitives++ -- * Rasterization types+ , Texture+ , Drawing+ , Modulable++ -- * Geometry description+ , V2( .. )+ , Point+ , Vector+ , CubicBezier( .. )+ , Line( .. )+ , Bezier( .. )+ , Primitive( .. )+ , Path( .. )+ , PathCommand( .. )+ , Transformable( .. )+ , PointFoldable( .. )++ -- * Helpers+ , line+ , rectangle+ , roundedRectangle+ , circle+ , ellipse+ , polyline+ , polygon+ , drawImageAtSize+ , drawImage++ -- ** Geometry Helpers+ , clip+ , bezierFromPath+ , lineFromPath+ , cubicBezierFromPath++ -- * Rasterization control+ , Join( .. )+ , Cap( .. )+ , SamplerRepeat( .. )+ , FillMethod( .. )+ , DashPattern++ -- * Debugging helper+ , dumpDrawing++ ) where++import Control.Applicative( (<$>) )+import Control.Monad( forM_ )+import Control.Monad.Free( Free( .. ), liftF )+import Control.Monad.ST( ST, runST )+import Control.Monad.State( StateT, execStateT, get, lift )+import Data.Monoid( Monoid( .. ), (<>) )+import Codec.Picture.Types( Image( .. )+ , Pixel( .. )+ , Pixel8+ , PixelRGBA8+ , MutableImage( .. )+ , createMutableImage+ , unsafeFreezeImage )++import qualified Data.Vector.Unboxed as VU+import Linear( V2( .. ), (^+^), (^*) )++import Graphics.Rasterific.Compositor+{-import Graphics.Rasterific.Operators-}+import Graphics.Rasterific.Rasterize+import Graphics.Rasterific.Texture+import Graphics.Rasterific.Types+import Graphics.Rasterific.Line+import Graphics.Rasterific.QuadraticBezier+import Graphics.Rasterific.CubicBezier+import Graphics.Rasterific.Stroke+import Graphics.Rasterific.Transformations++import Graphics.Text.TrueType( Font, PointSize, getStringCurveAtPoint )++{-import Debug.Trace-}+{-import Text.Printf-}++-- | Monad used to describe the drawing context.+type DrawContext s px a =+ StateT (MutableImage s px) (ST s) a++------------------------------------------------+---- Free Monad DSL section+------------------------------------------------++-- | Monad used to record the drawing actions.+type Drawing px = Free (DrawCommand 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 Font PointSize Point String next+ | SetTexture (Texture px)+ (Drawing px ()) next+ | WithCliping (forall innerPixel. Drawing innerPixel ())+ (Drawing px ()) next+ | WithTransform Transformation (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) => Drawing px () -> String+dumpDrawing (Pure ()) = "return ()"+dumpDrawing (Free (Fill _ prims next)) =+ "fill " ++ show prims ++ " >>=\n" ++ dumpDrawing next+dumpDrawing (Free (TextFill _ _ _ text next)) =+ "-- Text : " ++ text ++ "\n" ++ dumpDrawing next+dumpDrawing (Free (SetTexture _tx drawing next)) =+ "withTexture ({- texture -}) (" +++ dumpDrawing drawing ++ ") >>=\n" ++ dumpDrawing next+dumpDrawing (Free (DashedStroke o pat w j cap prims next)) =+ "dashedStrokeWithOffset "+ ++ show o ++ " "+ ++ show pat ++ " "+ ++ show w ++ " ("+ ++ show j ++ ") "+ ++ show cap ++ " "+ ++ show prims ++ " >>=\n" ++ dumpDrawing next+dumpDrawing (Free (Stroke w j cap prims next)) =+ "stroke " ++ show w ++ " ("+ ++ show j ++ ") "+ ++ show cap ++ " "+ ++ show prims ++ " >>=\n" ++ dumpDrawing next+dumpDrawing (Free (WithTransform trans sub next)) =+ "withTransform (" ++ show trans ++ ") (" + ++ dumpDrawing sub ++ ") >>=\n "+ ++ dumpDrawing next+dumpDrawing (Free (WithCliping clipping draw next)) =+ "withClipping (" ++ dumpDrawing (withTexture clipTexture clipping)+ ++ ")\n" +++ " (" ++ dumpDrawing draw++ ")\n >>= " +++ dumpDrawing next+ where clipTexture = uniformTexture (0xFF :: Pixel8)+++instance Functor (DrawCommand px) where+ fmap f (TextFill font size pos str next) =+ TextFill font size pos str $ 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++instance Monoid (Drawing px ()) where+ mempty = return ()++ mappend (Pure ()) b = b+ mappend a (Pure ()) = a+ mappend a b = a >> b++-- | 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 ()++-- | 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 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+ -> Int -- ^ font Point size+ -> Point -- ^ Baseline begining position+ -> String -- ^ String to print+ -> Drawing px ()+printTextAt font pointSize point string =+ liftF $ TextFill font pointSize point string ()++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.+renderDrawing+ :: forall px+ . ( Pixel px+ , Pixel (PixelBaseComponent px)+ , Modulable (PixelBaseComponent px)+ , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px)+ )+ => Int -- ^ Rendering width+ -> Int -- ^ Rendering height+ -> px -- ^ Background color+ -> Drawing px () -- ^ Rendering action+ -> Image px+renderDrawing width height background drawing = runST $+ createMutableImage width height background+ >>= execStateT (go initialContext drawing)+ >>= unsafeFreezeImage+ where+ initialContext = RenderContext Nothing stupidDefaultTexture Nothing+ clipBackground = emptyValue :: PixelBaseComponent px+ clipForeground = fullValue :: PixelBaseComponent px+ stupidDefaultTexture =+ uniformTexture $ colorMap (const clipBackground) background++ 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++ go :: RenderContext px+ -> Drawing px ()+ -> DrawContext s px ()+ go _ (Pure ()) = return ()+ go ctxt (Free (WithTransform trans sub next)) = do+ let trans'+ | Just (t, _) <- currentTransformation ctxt = t <> trans+ | otherwise = trans+ go ctxt { currentTransformation =+ Just (trans', inverseTransformation trans') } sub+ go ctxt next+ go ctxt@RenderContext { currentClip = Nothing }+ (Free (Fill method prims next)) = do+ fillWithTexture method (textureOf ctxt) $ geometryOf ctxt prims+ go ctxt next+ go ctxt@RenderContext { currentClip = Just moduler }+ (Free (Fill method prims next)) = do+ fillWithTextureAndMask method (currentTexture ctxt)+ moduler $ geometryOf ctxt prims+ go ctxt next++ go ctxt (Free (Stroke w j cap prims next)) =+ go ctxt . Free $ Fill FillWinding prim' next+ where prim' = strokize w j cap prims+ go ctxt (Free (SetTexture tx sub next)) = do+ go (ctxt { currentTexture = tx }) sub+ go ctxt next+ go ctxt (Free (DashedStroke o d w j cap prims next)) = do+ let recurse sub =+ go ctxt . liftF $ Fill FillWinding sub ()+ mapM_ recurse $ dashedStrokize o d w j cap prims+ go ctxt next++ go ctxt (Free (TextFill font size (V2 x y) str next)) = do+ forM_ drawCalls (go ctxt)+ go ctxt next+ where+ drawCalls =+ beziersOfChar <$> getStringCurveAtPoint 90 (x, y)+ [(font, size, str)]++ 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)) = do+ go (ctxt { currentClip = newModuler }) path+ go ctxt next+ where+ modulationTexture :: Texture (PixelBaseComponent px)+ modulationTexture = imageTexture $ 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 ()++-- | Clip the geometry to a rectangle.+clip :: Point -- ^ Minimum point (corner upper left)+ -> Point -- ^ Maximum point (corner bottom right)+ -> Primitive -- ^ Primitive to be clipped+ -> [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++-- | 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.+fillWithTexture :: (Pixel px, Modulable (PixelBaseComponent px))+ => FillMethod+ -> Texture px -- ^ Color/Texture used for the filling+ -> [Primitive] -- ^ Primitives to fill+ -> DrawContext s px ()+fillWithTexture fillMethod texture els = do+ img@(MutableImage width height _) <- get+ let mini = V2 0 0+ maxi = V2 (fromIntegral width) (fromIntegral height)+ spans = rasterize fillMethod $ els >>= clip mini maxi+ lift $ mapM_ (composeCoverageSpan texture img) spans++fillWithTextureAndMask+ :: ( Pixel px+ , Pixel (PixelBaseComponent px)+ , Modulable (PixelBaseComponent px))+ => FillMethod+ -> Texture px -- ^ Color/Texture used for the filling+ -> Texture (PixelBaseComponent px)+ -> [Primitive] -- ^ Primitives to fill+ -> DrawContext s 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 $ els >>= clip mini maxi+ lift $ mapM_ (composeCoverageSpanWithMask texture mask img) spans++composeCoverageSpan :: forall s px .+ ( Pixel px, Modulable (PixelBaseComponent px) )+ => Texture px+ -> MutableImage s px+ -> CoverageSpan+ -> ST s ()+{-# SPECIALIZE+ composeCoverageSpan+ :: forall s. + Texture PixelRGBA8+ -> MutableImage s PixelRGBA8+ -> CoverageSpan -> ST s () #-}+{-# SPECIALIZE+ composeCoverageSpan+ :: forall s. + Texture Pixel8+ -> MutableImage s Pixel8+ -> CoverageSpan -> ST s () #-}+composeCoverageSpan texture img coverage+ | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return ()+ | otherwise = go 0 initialX initIndex+ where compCount = componentCount (undefined :: px)+ maxi = _coverageLength coverage+ imgData = mutableImageData img+ y = floor $ _coverageY coverage+ initialX = floor $ _coverageX coverage+ imgWidth = mutableImageWidth img+ imgHeight = mutableImageHeight img+ initIndex = (initialX + y * imgWidth) * compCount+ (initialCov, _) =+ clampCoverage $ _coverageVal coverage++ shader = texture SamplerPad++ go count _ _ | count >= maxi = return ()+ go count x idx = do+ oldPixel <- unsafeReadPixel imgData idx+ let px = shader (fromIntegral x) (fromIntegral y)+ opacity = pixelOpacity px+ (cov, icov) = coverageModulate initialCov opacity+ unsafeWritePixel imgData idx+ $ compositionAlpha cov icov oldPixel px++ go (count + 1) (x + 1) $ idx + compCount++composeCoverageSpanWithMask+ :: forall s px+ . ( Pixel px+ , Pixel (PixelBaseComponent px)+ , Modulable (PixelBaseComponent px) )+ => Texture px+ -> Texture (PixelBaseComponent px)+ -> MutableImage s px+ -> CoverageSpan+ -> ST s ()+{-# INLINE composeCoverageSpanWithMask #-}+composeCoverageSpanWithMask texture mask img coverage+ | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return ()+ | otherwise = go 0 initialX initIndex+ where compCount = componentCount (undefined :: px)+ maxi = _coverageLength coverage+ imgData = mutableImageData img+ y = floor $ _coverageY coverage+ initialX = floor $ _coverageX coverage+ imgWidth = mutableImageWidth img+ imgHeight = mutableImageHeight img+ initIndex = (initialX + y * imgWidth) * compCount+ (initialCov, _) =+ clampCoverage $ _coverageVal coverage++ maskShader = mask SamplerPad+ shader = texture SamplerPad++ go count _ _ | count >= maxi = return ()+ go count x idx = do+ oldPixel <- unsafeReadPixel imgData idx+ let fx = fromIntegral x+ fy = fromIntegral y+ maskValue = maskShader fx fy+ px = shader fx fy+ (coeffMasked, _) = coverageModulate initialCov maskValue+ (cov, icov) = coverageModulate coeffMasked $ pixelOpacity px+ unsafeWritePixel imgData idx+ $ compositionAlpha cov icov oldPixel px+ go (count + 1) (x + 1) $ idx + compCount+++-- | 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 :: (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.+ -> 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 p+ reqWidth reqHeight+ | borderSize <= 0 =+ withTransformation (translate p <> scale scaleX scaleY) .+ withTexture (sampledImageTexture img) $ fill rect+ | otherwise = do+ withTransformation (translate p <> scale scaleX scaleY) $ do+ withTexture (sampledImageTexture img) $ fill rect+ stroke borderSize (JoinMiter 0)+ (CapStraight 0, CapStraight 0) rect'+ where+ 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/Compositor.hs view
@@ -1,66 +1,75 @@-{-# LANGUAGE FlexibleContexts #-} --- | Compositor handle the pixel composition, which --- leads to texture composition. --- Very much a work in progress -module Graphics.Rasterific.Compositor - ( Compositor - , Modulable( .. ) - , compositionDestination - , compositionAlpha - ) where - -import Data.Bits( unsafeShiftR ) -import Data.Word( Word8, Word32 ) - -import Codec.Picture.Types( Pixel( .. ) ) - -type Compositor px = - (PixelBaseComponent px) -> - (PixelBaseComponent px) -> px -> px -> px - --- | Typeclass intented at pixel value modulation. --- May be throwed out soon. -class Ord a => Modulable a where - emptyValue :: a - fullValue :: a - clampCoverage :: Float -> (a, a) - modulate :: a -> a -> a - alphaOver :: a -> a -> a -> a -> a - coverageModulate :: a -> a -> (a, a) - -instance Modulable Word8 where - emptyValue = 0 - fullValue = 255 - clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) - where c = toWord8 f - - modulate c a = fromIntegral $ v `unsafeShiftR` 8 - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi c * fi a - - coverageModulate c a = (clamped, fullValue - clamped) - where - v = fromIntegral c * fromIntegral a :: Word32 - clamped = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 - - alphaOver c ic b a = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi c * fi a + fi b * fi ic + 128 - - -toWord8 :: Float -> Int -toWord8 r = floor $ r * 255 + 0.5 - -compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -compositionDestination c _ _ a = colorMap (modulate c) $ a - -compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -compositionAlpha c ic - | c == emptyValue = const - | c == fullValue = \_ n -> n - | otherwise = mixWith (\_ -> alphaOver c ic) - +{-# LANGUAGE FlexibleContexts #-}+-- | Compositor handle the pixel composition, which+-- leads to texture composition.+-- Very much a work in progress+module Graphics.Rasterific.Compositor+ ( Compositor+ , Modulable( .. )+ , compositionDestination+ , compositionAlpha+ ) where++import Data.Bits( unsafeShiftR )+import Data.Word( Word8, Word32 )++import Codec.Picture.Types( Pixel( .. ) )++type Compositor px =+ (PixelBaseComponent px) ->+ (PixelBaseComponent px) -> px -> px -> px++-- | Typeclass intented at pixel value modulation.+-- May be throwed out soon.+class (Ord a, Num a) => Modulable a where+ emptyValue :: a+ fullValue :: a+ clampCoverage :: Float -> (a, a)+ modulate :: a -> a -> a+ alphaOver :: a -> a -> a -> a -> a+ alphaCompose :: a -> a -> a -> a -> a+ coverageModulate :: a -> a -> (a, a)++instance Modulable Word8 where+ emptyValue = 0+ fullValue = 255+ clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c)+ where c = toWord8 f++ modulate c a = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8+ where fi :: Word8 -> Word32+ fi = fromIntegral+ v = fi c * fi a + 128++ coverageModulate c a = (clamped, fullValue - clamped)+ where clamped = modulate a c++ alphaCompose coverage inverseCoverage backgroundAlpha _ =+ fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8+ where fi :: Word8 -> Word32+ fi = fromIntegral+ v = fi coverage * 255+ + fi backgroundAlpha * fi inverseCoverage + 128++ alphaOver coverage inverseCoverage background painted =+ fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8+ where fi :: Word8 -> Word32+ fi = fromIntegral+ v = fi coverage * fi painted + fi background * fi inverseCoverage + 128+++toWord8 :: Float -> Int+toWord8 r = floor $ r * 255 + 0.5++compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px))+ => Compositor px+compositionDestination c _ _ a = colorMap (modulate c) $ a++compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px))+ => Compositor px+{-# INLINE compositionAlpha #-}+compositionAlpha c ic + | c == emptyValue = const+ | c == fullValue = \_ n -> n+ | otherwise = mixWithAlpha (\_ -> alphaOver c ic)+ (alphaCompose c ic)+
src/Graphics/Rasterific/CubicBezier.hs view
@@ -1,285 +1,287 @@-{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Graphics.Rasterific.CubicBezier - ( cubicBezierCircle - , cubicBezierFromPath - , cubicBezierBreakAt - , clipCubicBezier - , decomposeCubicBeziers - , sanitizeCubicBezier - , offsetCubicBezier - , flattenCubicBezier - , cubicBezierLengthApproximation - ) where - -import Prelude hiding( or ) -import Control.Applicative( Applicative - , liftA2 - , (<$>) - , (<*>) - , pure - ) -import Linear( V1( .. ) - , V2( .. ) - , (^-^) - , (^+^) - , (^*) - , norm - ) -import Data.Monoid( Monoid, mempty, (<>) ) -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types - --- | 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 - -flattenCubicBezier :: CubicBezier -> Container Primitive -flattenCubicBezier bezier@(CubicBezier a b c d) - | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier - | otherwise = - flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> - flattenCubicBezier (CubicBezier abbcbccd bccd cd d) - 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 - - --- 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 - -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 = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d - - w = ab `normal` bc - x = bc `normal` cd - - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd - - 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 $ vmin 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 = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d - - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd - - edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) - edge = vpartition edgeSeparator mini maxi - m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbc - --- | 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 = lerpPoint a b val - bc = lerpPoint b c val - cd = lerpPoint c d val - - abbc = lerpPoint ab bc val - bccd = lerpPoint bc cd val - abbcbccd = lerpPoint abbc bccd val - -decomposeCubicBeziers :: CubicBezier -> Container EdgeSample -decomposeCubicBeziers (CubicBezier a@(V2 ax ay) b c d@(V2 dx dy)) - | insideX && insideY = - pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h - | otherwise = - recurse (CubicBezier a ab abbc m) <> - recurse (CubicBezier m bccd cd d) - where recurse = decomposeCubicBeziers - floorA = vfloor a - floorD = vfloor d - V2 px py = fromIntegral <$> vmin floorA floorD - V1 w = (px + 1 -) <$> (V1 dx `midPoint` V1 ax) - h = dy - ay - - V2 insideX insideY = - floorA ^==^ floorD ^||^ vceil a ^==^ vceil d - - -- BC - -- B X----------X---------X C - -- / ___/ \___ \ - -- / __X------X------X_ \ - -- /___/ 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 - - mini = fromIntegral <$> vfloor abbcbccd - maxi = fromIntegral <$> vceil abbcbccd - nearmin = vabs (abbcbccd ^-^ mini) ^< 0.1 - nearmax = vabs (abbcbccd ^-^ maxi) ^< 0.1 - - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p - - m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax - <*> abbcbccd - -sanitizeCubicBezier :: CubicBezier -> Container Primitive -sanitizeCubicBezier bezier@(CubicBezier a b c d) - | norm (a ^-^ b) > 0.0001 && - norm (b ^-^ c) > 0.0001 && - norm (c ^-^ d) > 0.0001 = - pure . CubicBezierPrim $ bezier - | ac /= b && bd /= c = - pure . CubicBezierPrim $ CubicBezier a ac bd d - | ac /= b = - pure . CubicBezierPrim $ CubicBezier a ac c d - | bd /= c = - pure . CubicBezierPrim $ CubicBezier a b bd d - | otherwise = mempty - where ac = a `midPoint` c - bd = a `midPoint` d - +{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Graphics.Rasterific.CubicBezier+ ( cubicBezierCircle+ , cubicBezierFromPath+ , cubicBezierBreakAt+ , clipCubicBezier+ , decomposeCubicBeziers+ , sanitizeCubicBezier+ , offsetCubicBezier+ , flattenCubicBezier+ , cubicBezierLengthApproximation+ ) where++import Prelude hiding( or )+import Control.Applicative( Applicative+ , liftA2+ , (<$>)+ , (<*>)+ , pure+ )+import Linear( V1( .. )+ , V2( .. )+ , (^-^)+ , (^+^)+ , (^*)+ , norm+ )+import Data.Monoid( Monoid, mempty, (<>) )+import Graphics.Rasterific.Operators+import Graphics.Rasterific.Types+import Graphics.Rasterific.QuadraticBezier( sanitizeBezier )++-- | 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++flattenCubicBezier :: CubicBezier -> Container Primitive+flattenCubicBezier bezier@(CubicBezier a b c d)+ | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier+ | otherwise =+ flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <>+ flattenCubicBezier (CubicBezier abbcbccd bccd cd d)+ 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+++-- 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++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 = a `midPoint` b+ bc = b `midPoint` c+ cd = c `midPoint` d++ w = ab `normal` bc+ x = bc `normal` cd++ abbc = ab `midPoint` bc+ bccd = bc `midPoint` cd+ abbcbccd = abbc `midPoint` bccd++ 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 $ vmin 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 = a `midPoint` b+ bc = b `midPoint` c+ cd = c `midPoint` d++ abbc = ab `midPoint` bc+ bccd = bc `midPoint` cd+ abbcbccd = abbc `midPoint` bccd++ 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 = lerpPoint a b val+ bc = lerpPoint b c val+ cd = lerpPoint c d val++ abbc = lerpPoint ab bc val+ bccd = lerpPoint bc cd val+ abbcbccd = lerpPoint abbc bccd val++decomposeCubicBeziers :: CubicBezier -> Container EdgeSample+decomposeCubicBeziers (CubicBezier a@(V2 ax ay) b c d@(V2 dx dy))+ | insideX && insideY =+ pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h+ | otherwise =+ recurse (CubicBezier a ab abbc m) <>+ recurse (CubicBezier m bccd cd d)+ where recurse = decomposeCubicBeziers+ floorA = vfloor a+ floorD = vfloor d+ V2 px py = fromIntegral <$> vmin floorA floorD+ V1 w = (px + 1 -) <$> (V1 dx `midPoint` V1 ax)+ h = dy - ay++ V2 insideX insideY =+ floorA ^==^ floorD ^||^ vceil a ^==^ vceil d++ -- BC+ -- B X----------X---------X C+ -- / ___/ \___ \+ -- / __X------X------X_ \+ -- /___/ 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++ mini = fromIntegral <$> vfloor abbcbccd+ maxi = fromIntegral <$> vceil abbcbccd+ nearmin = vabs (abbcbccd ^-^ mini) ^< 0.1+ nearmax = vabs (abbcbccd ^-^ maxi) ^< 0.1++ minMaxing mi nearmi ma nearma p+ | nearmi = mi+ | nearma = ma+ | otherwise = p++ m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax+ <*> abbcbccd++sanitizeCubicBezier :: CubicBezier -> Container Primitive+sanitizeCubicBezier bezier@(CubicBezier a b c d)+ | b `isNearby` c = sanitizeBezier $ Bezier a c d+ | a `isDistingableFrom` b &&+ c `isDistingableFrom` d =+ pure . CubicBezierPrim $ bezier+ | ac `isDistingableFrom` b && + bd `isDistingableFrom` c =+ pure . CubicBezierPrim $ CubicBezier a ac bd d+ | 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/Line.hs view
@@ -1,100 +1,100 @@--- | Handle straight lines polygon. -module Graphics.Rasterific.Line - ( lineFromPath - , clipLine - , sanitizeLine - , lineBreakAt - , flattenLine - , lineLength - ) where - -import Control.Applicative( Applicative, (<$>), pure ) -import Data.Monoid( Monoid, (<>), mempty ) -import Linear( V2( .. ), (^-^), 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 == p2 = mempty - | otherwise = pure $ LinePrim l - -lineBreakAt :: Line -> Float -> (Line, Line) -lineBreakAt (Line a b) t = (Line a ab, Line ab b) - where ab = lerpPoint a b t - -flattenLine :: Line -> Container Primitive -flattenLine = pure . LinePrim - --- | 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 - +-- | Handle straight lines polygon.+module Graphics.Rasterific.Line+ ( lineFromPath+ , clipLine+ , sanitizeLine+ , lineBreakAt+ , flattenLine+ , lineLength+ ) where++import Control.Applicative( Applicative, (<$>), pure )+import Data.Monoid( Monoid, (<>), mempty )+import Linear( V2( .. ), (^-^), 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 = lerpPoint a b t++flattenLine :: Line -> Container Primitive+flattenLine = pure . LinePrim++-- | 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+
src/Graphics/Rasterific/Operators.hs view
@@ -1,146 +1,163 @@--- | 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 - , lerpPoint - , vpartition - , normal - , ifZero - ) where - -import Control.Applicative( Applicative - , liftA2 - , liftA3 - , (<$>) - ) - -import Linear( V2( .. ) - , Additive( .. ) - {-, Metric( .. )-} - , Epsilon( nearZero ) - , (^+^) - {-, (^/)-} - , (^*) - , 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 - -lerpPoint :: (Additive a) => a Float -> a Float -> Float -> a Float -{-# INLINE lerpPoint #-} -lerpPoint a b v = a ^+^ (b ^-^ a) ^* v - --- | 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 - +-- | 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+ , lerpPoint+ , vpartition + , normal+ , ifZero+ , isNearby+ , isDistingableFrom+ ) where++import Control.Applicative( Applicative+ , liftA2+ , liftA3+ , (<$>)+ )++import Linear( V2( .. )+ , Additive( .. )+ {-, Metric( .. )-}+ , 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++lerpPoint :: (Additive a) => a Float -> a Float -> Float -> a Float+{-# INLINE lerpPoint #-}+lerpPoint a b v = a ^+^ (b ^-^ a) ^* v++-- | 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/QuadraticBezier.hs view
@@ -1,260 +1,260 @@-{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} --- | 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 - -import Control.Applicative( (<$>) - , (<*>) - , Applicative - , pure ) -import Linear( V2( .. ) - , V1( .. ) - , (^-^) - , (^+^) - , (^*) - , dot - , norm - ) -import Data.Monoid( Monoid( mempty ), (<>) ) -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 -> [EdgeSample] -decomposeBeziers (Bezier a@(V2 ax ay) b c@(V2 cx cy)) - | insideX && insideY = [EdgeSample (px + 0.5) (py + 0.5) (w * h) h] - | otherwise = recurse (Bezier a ab m) <> - recurse (Bezier m bc c) - where floorA = vfloor a - floorC = vfloor c - V2 px py = fromIntegral <$> vmin floorA floorC - V1 w = (px + 1 -) <$> (V1 cx `midPoint` V1 ax) - h = cy - ay - - recurse = decomposeBeziers - - V2 insideX insideY = - floorA ^==^ floorC ^||^ vceil a ^==^ vceil c - - ab = a `midPoint` b - bc = b `midPoint` c - abbc = ab `midPoint` bc - - mini = fromIntegral <$> vfloor abbc - maxi = fromIntegral <$> vceil abbc - nearmin = vabs (abbc ^-^ mini) ^< 0.1 - nearmax = vabs (abbc ^-^ maxi) ^< 0.1 - - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p - - m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc - --- | 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 = a `midPoint` b - bc = b `midPoint` c - abbc = ab `midPoint` bc - - -- 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) - | norm (a ^-^ b) > 0.0001 && norm (b ^-^ c) > 0.0001 = - pure . BezierPrim $ bezier - - -- if b is to nearby a or c, take the midpoint as new reference. - | ac /= 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 = lerpPoint a b t - bc = lerpPoint b c t - abbc = lerpPoint ab bc t - -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 = (a `midPoint` b) - bc = (b `midPoint` c) - abbc = ab `midPoint` bc - --- | Move the bezier to a new position with an offset. -offsetBezier :: Float -> Bezier -> Container Primitive -offsetBezier offset (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 = (a `midPoint` b) - bc = (b `midPoint` c) - abbc = ab `midPoint` bc - - shiftedA = a ^+^ (u ^* offset) - shiftedC = c ^+^ (v ^* offset) - shiftedABBC = abbc ^+^ (w ^* offset) - mergedB = - (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC) - +{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+-- | 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++import Control.Applicative( (<$>)+ , (<*>)+ , Applicative+ , pure )+import Linear( V2( .. )+ , V1( .. )+ , (^-^)+ , (^+^)+ , (^*)+ , dot+ , norm+ )+import Data.Monoid( Monoid( mempty ), (<>) )+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 -> [EdgeSample]+decomposeBeziers (Bezier a@(V2 ax ay) b c@(V2 cx cy))+ | insideX && insideY = [EdgeSample (px + 0.5) (py + 0.5) (w * h) h]+ | otherwise = recurse (Bezier a ab m) <>+ recurse (Bezier m bc c)+ where floorA = vfloor a+ floorC = vfloor c+ V2 px py = fromIntegral <$> vmin floorA floorC+ V1 w = (px + 1 -) <$> (V1 cx `midPoint` V1 ax)+ h = cy - ay++ recurse = decomposeBeziers++ V2 insideX insideY =+ floorA ^==^ floorC ^||^ vceil a ^==^ vceil c++ ab = a `midPoint` b+ bc = b `midPoint` c+ abbc = ab `midPoint` bc++ mini = fromIntegral <$> vfloor abbc+ maxi = fromIntegral <$> vceil abbc+ nearmin = vabs (abbc ^-^ mini) ^< 0.1+ nearmax = vabs (abbc ^-^ maxi) ^< 0.1++ minMaxing mi nearmi ma nearma p+ | nearmi = mi+ | nearma = ma+ | otherwise = p++ m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc++-- | 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 = a `midPoint` b+ bc = b `midPoint` c+ abbc = ab `midPoint` bc++ -- 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 = lerpPoint a b t+ bc = lerpPoint b c t+ abbc = lerpPoint ab bc t++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 = (a `midPoint` b)+ bc = (b `midPoint` c)+ abbc = ab `midPoint` bc++-- | Move the bezier to a new position with an offset.+offsetBezier :: Float -> Bezier -> Container Primitive+offsetBezier offset (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 = (a `midPoint` b)+ bc = (b `midPoint` c)+ abbc = ab `midPoint` bc++ shiftedA = a ^+^ (u ^* offset)+ shiftedC = c ^+^ (v ^* offset)+ shiftedABBC = abbc ^+^ (w ^* offset)+ mergedB =+ (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC)+
src/Graphics/Rasterific/Rasterize.hs view
@@ -1,40 +1,47 @@-module Graphics.Rasterific.Rasterize - ( CoverageSpan( .. ) - , rasterize - ) where - -import Data.List( mapAccumL, sortBy ) -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier - -data CoverageSpan = CoverageSpan - { _coverageX :: !Float - , _coverageY :: !Float - , _coverageVal :: !Float - , _coverageLength :: !Float - } - deriving Show - -combineEdgeSamples :: [EdgeSample] -> [CoverageSpan] -combineEdgeSamples = append . mapAccumL go (0, 0, 0, 0) - where append ((x, y, a, _), lst) = - concat lst ++ [CoverageSpan x y (min 1 $ abs a) 1] - - go (x, y, a, h) (EdgeSample x' y' a' h') - | y == y' && x == x' = ((x', y', a + a', h + h'), []) - | y == y' = ((x', y', h + a', h + h'), [p1, p2]) - | otherwise = - ((x', y', a', h'), [CoverageSpan x y (min 1 $ abs a) 1]) - where p1 = CoverageSpan x y (min 1 $ abs a) 1 - p2 = CoverageSpan (x + 1) y (min 1 $ abs h) (x' - x - 1) - -decompose :: Primitive -> [EdgeSample] -decompose (LinePrim (Line x1 x2)) = decomposeBeziers $ straightLine x1 x2 -decompose (BezierPrim b) = decomposeBeziers b -decompose (CubicBezierPrim c) = decomposeCubicBeziers c - -rasterize :: [Primitive] -> [CoverageSpan] -rasterize = combineEdgeSamples . sortBy xy . concatMap decompose - where xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b) - +module Graphics.Rasterific.Rasterize+ ( CoverageSpan( .. )+ , rasterize+ ) where++import Data.Fixed( mod' )+import Data.List( mapAccumL, sortBy )+import Graphics.Rasterific.Types+import Graphics.Rasterific.QuadraticBezier+import Graphics.Rasterific.CubicBezier++data CoverageSpan = CoverageSpan+ { _coverageX :: {-# UNPACK #-} !Float+ , _coverageY :: {-# UNPACK #-} !Float+ , _coverageVal :: {-# UNPACK #-} !Float+ , _coverageLength :: {-# UNPACK #-} !Float+ }+ deriving Show++combineEdgeSamples :: (Float -> Float) -> [EdgeSample] -> [CoverageSpan]+{-# INLINE combineEdgeSamples #-}+combineEdgeSamples prepareCoverage = append . mapAccumL go (0, 0, 0, 0)+ where append ((x, y, a, _), lst) =+ concat lst ++ [CoverageSpan x y (prepareCoverage a) 1]++ go (x, y, a, h) (EdgeSample x' y' a' h')+ | y == y' && x == x' = ((x', y', a + a', h + h'), [])+ | y == y' = ((x', y', h + a', h + h'), [p1, p2])+ | otherwise =+ ((x', y', a', h'), [CoverageSpan x y (prepareCoverage a) 1])+ where p1 = CoverageSpan x y (prepareCoverage a) 1+ p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1)++decompose :: Primitive -> [EdgeSample]+decompose (LinePrim (Line x1 x2)) = decomposeBeziers $ straightLine x1 x2+decompose (BezierPrim b) = decomposeBeziers b+decompose (CubicBezierPrim c) = decomposeCubicBeziers c++rasterize :: FillMethod -> [Primitive] -> [CoverageSpan]+rasterize method = + case method of+ FillWinding -> combineEdgeSamples combineWinding . sortBy xy . concatMap decompose+ FillEvenOdd -> combineEdgeSamples combineEvenOdd . sortBy xy . concatMap decompose+ where xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b)+ combineWinding = min 1 . abs+ combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1+
src/Graphics/Rasterific/Stroke.hs view
@@ -1,244 +1,258 @@-module Graphics.Rasterific.Stroke - ( flatten - , dashize - , strokize - , dashedStrokize - ) where - -import Control.Applicative( Applicative, (<$>), pure ) -import Data.Monoid( Monoid, (<>), mempty ) -import Data.Foldable( Foldable, foldMap ) -import 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 w v <> go u w - 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 - | u `dot` w >= l / max 1 l = - 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 - - -- Calculate the maximum distance on the - -- u axis - p = offset / (u `dot` w) - -- 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 (Line x1 x2)) = - offsetPrimitives offset . BezierPrim $ straightLine x1 x2 -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 == lastPoint prev = joiner prev firstShape <> offseter prev - | otherwise = cap offset caping prev <> offseter 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] - -> [Primitive] -strokize width join (capStart, capEnd) beziers = - offseter capEnd sanitized <> - offseter capStart (reverse $ reversePrimitive <$> sanitized) - where sanitized = foldMap 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 at = go at - 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 - - -dashize :: DashPattern -> [Primitive] -> [[Primitive]] -dashize pattern = taker infinitePattern - . concatMap flattenPrimitive - . concatMap sanitize - where - infinitePattern = cycle 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 - -dashedStrokize :: DashPattern -> StrokeWidth -> Join -> (Cap, Cap) -> [Primitive] - -> [[Primitive]] -dashedStrokize dashPattern width join capping beziers = - strokize width join capping <$> dashize dashPattern beziers - +module Graphics.Rasterific.Stroke+ ( flatten+ , dashize+ , strokize+ , dashedStrokize+ ) where++import Control.Applicative( Applicative, (<$>), pure )+import Data.Monoid( Monoid, (<>), mempty )+import Data.Foldable( Foldable, foldMap )+import 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 w v <> go u w+ 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 =+ 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 (Line x1 x2)) =+ offsetPrimitives offset . BezierPrim $ straightLine x1 x2+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 = cap offset caping prev <> offseter 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]+ -> [Primitive]+strokize width join (capStart, capEnd) beziers =+ offseter capEnd sanitized <>+ offseter capStart (reverse $ reversePrimitive <$> sanitized)+ where sanitized = foldMap 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 at = go at+ 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++dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]]+dashize offset pattern =+ taker infinitePattern . concatMap flattenPrimitive . concatMap sanitize+ 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++dashedStrokize :: Float -> DashPattern -> StrokeWidth+ -> Join -> (Cap, Cap) -> [Primitive]+ -> [[Primitive]]+dashedStrokize offset dashPattern width join capping beziers =+ strokize width join capping <$> dashize offset dashPattern beziers+
src/Graphics/Rasterific/Texture.hs view
@@ -1,231 +1,331 @@-{-# 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 - , linearGradientTexture - , radialGradientTexture - , radialGradientWithFocusTexture - , imageTexture - , sampledImageTexture - , modulateTexture - ) where - -import Data.Fixed( mod' ) -import Linear( V2( .. ) - , (^-^) - , (^/) - , dot - , norm - ) - -import qualified Data.Vector as V - -import Codec.Picture.Types( Pixel( .. ) - , Image( .. ) - ) -import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ) ) -import Graphics.Rasterific.Compositor - ( Modulable( clampCoverage, modulate ), compositionAlpha ) - --- | A texture is just a function which given pixel coordinate --- give back a pixel. --- The float coordinate type allow for transformations --- to happen in the pixel space. -type Texture px = SamplerRepeat -> Float -> Float -> px - --- | Set the repeat pattern of the texture (if any). -withSampler :: SamplerRepeat -> Texture px -> Texture px -withSampler repeating texture _ = texture repeating - --- | The uniform texture is the simplest texture of all: --- an uniform color. -uniformTexture :: px -- ^ The color used for all the texture. - -> Texture px -uniformTexture px _ _ _ = px - --- | 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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => GradientArray px -> Float -> px -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 = compositionAlpha 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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => SamplerRepeat -> GradientArray px -> Float -> px -gradientColorAtRepeat SamplerPad grad = gradientColorAt grad -gradientColorAtRepeat SamplerRepeat grad = - gradientColorAt grad . repeatGradient -gradientColorAtRepeat SamplerReflect grad = - gradientColorAt grad . reflectGradient - --- | 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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description. - -> Point -- ^ Linear gradient start point. - -> Point -- ^ Linear gradient end point. - -> Texture px -linearGradientTexture 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. -imageTexture :: forall px. (Pixel px) => Image px -> Texture px -imageTexture 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 - --- | Use another image as a texture for the filling, --- but allow repeating and reflecting alongside with --- padding. -sampledImageTexture :: (Pixel px) => Image px -> Texture px -sampledImageTexture img SamplerPad = imageTexture img SamplerPad -sampledImageTexture img SamplerReflect = imageTexture img SamplerPad -sampledImageTexture img SamplerRepeat = \x y -> texture (x `mod'` w) (y `mod'` h) - where - texture = imageTexture img SamplerPad - w = fromIntegral $ imageWidth img - h = fromIntegral $ imageHeight img - --- | 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 SamplerPad gradDef --- > (V2 100 100) 75) $ --- > fill $ circle (V2 100 100) 100 --- --- <<docimages/radial_gradient.png>> --- -radialGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Texture px -radialGradientTexture gradient center radius repeating = - \x y -> colorAt $ norm ((V2 x y) ^-^ center) / radius - where - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - - --- | 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 SamplerPad gradDef --- > (V2 100 100) 75 (V2 70 70) ) $ --- > fill $ circle (V2 100 100) 100 --- --- <<docimages/radial_gradient_focus.png>> --- -radialGradientWithFocusTexture - :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Point -- ^ Radial gradient focus point - -> Texture px -radialGradientWithFocusTexture 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 - focusX * focusY - - 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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => Texture px -- ^ The full blown texture. - -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. - -> Texture px -- ^ The resulting texture. -modulateTexture fullTexture modulator repeating = \x y -> - colorMap (modulate $ modulationTexture x y) $ full x y - where modulationTexture = modulator repeating - full = fullTexture repeating - +{-# 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+ , imageTexture+ , sampledImageTexture++ -- * Texture manipulation+ , modulateTexture+ , transformTexture + ) where++import Data.Fixed( mod' )+import Linear( V2( .. )+ , (^-^)+ , (^/)+ , dot+ , norm+ )++import qualified Data.Vector as V++import Codec.Picture.Types( Pixel( .. )+ , Image( .. )+ , Pixel8+ , PixelRGBA8+ )+import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ) )+import Graphics.Rasterific.Transformations+import Graphics.Rasterific.Compositor+ ( Modulable( clampCoverage, modulate, alphaOver ), compositionAlpha )++-- | A texture is just a function which given pixel coordinate+-- give back a pixel.+-- The float coordinate type allow for transformations+-- to happen in the pixel space.+type Texture px = SamplerRepeat -> Float -> Float -> px++-- | 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 repeating texture _ = texture repeating++-- | 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 trans tx samp x y = tx samp x' y'+ where+ (V2 x' y') = applyTransformation trans (V2 x y)++-- | The uniform texture is the simplest texture of all:+-- an uniform color.+uniformTexture :: px -- ^ The color used for all the texture.+ -> Texture px+uniformTexture px _ _ _ = px++-- | 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 :: (Pixel px, Modulable (PixelBaseComponent px))+ => GradientArray px -> Float -> px+{-# SPECIALIZE+ gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}+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 = compositionAlpha 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 :: (Pixel px, Modulable (PixelBaseComponent px))+ => SamplerRepeat -> GradientArray px -> Float -> px+{-# SPECIALIZE INLINE+ gradientColorAtRepeat ::+ SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}+gradientColorAtRepeat SamplerPad grad = gradientColorAt grad+gradientColorAtRepeat SamplerRepeat grad =+ gradientColorAt grad . repeatGradient+gradientColorAtRepeat SamplerReflect grad =+ gradientColorAt grad . reflectGradient++-- | 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 :: (Pixel px, Modulable (PixelBaseComponent px))+ => Gradient px -- ^ Gradient description.+ -> Point -- ^ Linear gradient start point.+ -> Point -- ^ Linear gradient end point.+ -> Texture px+{-# SPECIALIZE+ linearGradientTexture+ :: Gradient PixelRGBA8 -> Point -> Point+ -> Texture PixelRGBA8 #-}+linearGradientTexture 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.+--+sampledImageTexture :: forall px.+ ( Pixel px, Modulable (PixelBaseComponent px))+ => Image px -> Texture px+{-# SPECIALIZE+ sampledImageTexture :: Image Pixel8 -> Texture Pixel8 #-}+{-# SPECIALIZE+ sampledImageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-}+sampledImageTexture 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.+imageTexture :: forall px. (Pixel px) => Image px -> Texture px+{-# SPECIALIZE+ imageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-}+{-# SPECIALIZE+ imageTexture :: Image Pixel8 -> Texture Pixel8 #-}+imageTexture 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++-- | 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 SamplerPad gradDef+-- > (V2 100 100) 75) $+-- > fill $ circle (V2 100 100) 100+--+-- <<docimages/radial_gradient.png>>+--+radialGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px))+ => Gradient px -- ^ Gradient description+ -> Point -- ^ Radial gradient center+ -> Float -- ^ Radial gradient radius+ -> Texture px+radialGradientTexture gradient center radius repeating =+ \x y -> colorAt $ norm ((V2 x y) ^-^ center) / radius+ where+ colorAt = gradientColorAtRepeat repeating gradArray+ gradArray = V.fromList gradient+++-- | 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 SamplerPad gradDef+-- > (V2 100 100) 75 (V2 70 70) ) $+-- > fill $ circle (V2 100 100) 100+--+-- <<docimages/radial_gradient_focus.png>>+--+radialGradientWithFocusTexture+ :: (Pixel px, Modulable (PixelBaseComponent px))+ => Gradient px -- ^ Gradient description+ -> Point -- ^ Radial gradient center+ -> Float -- ^ Radial gradient radius+ -> Point -- ^ Radial gradient focus point+ -> Texture px+radialGradientWithFocusTexture 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 :: (Pixel px, Modulable (PixelBaseComponent px))+ => Texture px -- ^ The full blown texture.+ -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture.+ -> Texture px -- ^ The resulting texture.+modulateTexture fullTexture modulator repeating = \x y ->+ colorMap (modulate $ modulationTexture x y) $ full x y+ where modulationTexture = modulator repeating+ full = fullTexture repeating+
+ src/Graphics/Rasterific/Transformations.hs view
@@ -0,0 +1,130 @@+-- | 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" .+module Graphics.Rasterific.Transformations+ ( Transformation( .. )+ , applyTransformation+ , translate+ , scale+ , rotate+ , rotateCenter+ , inverseTransformation+ ) where++import Data.Monoid( Monoid( .. ), (<>) )+import Graphics.Rasterific.Types+import Linear( V2( .. ) )++-- | 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)+++-- | 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+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+translate (V2 x y) =+ Transformation 1 0 x+ 0 1 y++-- | Inverse a transformation (if possible)+inverseTransformation :: Transformation -> Transformation+inverseTransformation (Transformation a c e+ b d f) =+ 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,254 +1,392 @@-{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} --- | Gather all the types used in the rasterization engine. -module Graphics.Rasterific.Types - ( -- * Geometry description - Vector - , Point - , Line( .. ) - , Bezier( .. ) - , CubicBezier( .. ) - , Primitive( .. ) - , Container - , PathCommand( .. ) - , Path( .. ) - , Transformable( .. ) - - -- * Rasterization control types - , Cap( .. ) - , Join( .. ) - , SamplerRepeat( .. ) - , DashPattern - , StrokeWidth - - -- * Internal type - , EdgeSample( .. ) - , pathToPrimitives - ) where - -import Linear( V2( .. ) ) - --- | 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) - --- | 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, 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 - --- | 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 - --- | 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, Show) - -instance Transformable Line where - {-# INLINE transform #-} - transform f (Line a b) = Line (f a) $ f b - --- | 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, Show) - -instance Transformable Bezier where - {-# INLINE transform #-} - transform f (Bezier a b c) = Bezier (f a) (f b) $ f 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, Show) - -instance Transformable CubicBezier where - {-# INLINE transform #-} - transform f (CubicBezier a b c d) = - CubicBezier (f a) (f b) (f c) $ f 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 - -type Container a = [a] - --- | 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) - --- | 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) - --- | 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 - +{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+-- | Gather all the types used in the rasterization engine.+module Graphics.Rasterific.Types+ ( -- * Geometry description+ Vector+ , Point+ , Line( .. )+ , Bezier( .. )+ , CubicBezier( .. )+ , Primitive( .. )+ , Container+ , PathCommand( .. )+ , Path( .. )+ , Transformable( .. )+ , PointFoldable( .. )++ -- * Rasterization control types+ , Cap( .. )+ , Join( .. )+ , FillMethod( .. )+ , SamplerRepeat( .. )+ , DashPattern+ , StrokeWidth++ -- * Internal type+ , EdgeSample( .. )+ , pathToPrimitives+ ) where++import Data.Foldable( Foldable, foldl' )+import Linear( V2( .. ) )++-- | 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++-- | 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 p = f p++instance PointFoldable Point where+ {-# INLINE foldPoints #-}+ foldPoints f acc p = f acc p++-- | 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 Container a = [a]++-- | 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+