Rasterific 0.2 → 0.2.1
raw patch · 16 files changed
+2957/−2916 lines, 16 filesdep ~freesetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: free
API changes (from Hackage documentation)
- Graphics.Rasterific: V2 :: !a -> !a -> V2 a
+ Graphics.Rasterific: V2 :: SrictNotUnpackeda -> SrictNotUnpackeda -> V2 a
- Graphics.Rasterific: class (Ord a, Num a) => Modulable a
+ Graphics.Rasterific: class (Ord a, Num a) => Modulable a where coverageModulate c a = (clamped, fullValue - clamped) where clamped = modulate a c
Files
- LICENSE +30/−30
- Rasterific.cabal +64/−64
- Setup.hs +2/−2
- changelog +29/−24
- docimages/sampled_texture_reflect.png binary
- src/Graphics/Rasterific.hs +753/−753
- src/Graphics/Rasterific/Compositor.hs +112/−75
- src/Graphics/Rasterific/CubicBezier.hs +287/−287
- src/Graphics/Rasterific/Line.hs +100/−100
- src/Graphics/Rasterific/Operators.hs +163/−163
- src/Graphics/Rasterific/QuadraticBezier.hs +260/−260
- src/Graphics/Rasterific/Rasterize.hs +47/−47
- src/Graphics/Rasterific/Stroke.hs +258/−258
- src/Graphics/Rasterific/Texture.hs +330/−331
- src/Graphics/Rasterific/Transformations.hs +130/−130
- src/Graphics/Rasterific/Types.hs +392/−392
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,64 +1,64 @@--- 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-+-- Initial Rasterific.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ +name: Rasterific +version: 0.2.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.2.1 + +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.7 + , 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,24 +1,29 @@--*-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.-+-*-change-log-*- + +v0.2.1 April 2014 + * Fixing transparency in gradients. + * Fixing alpha composition on top of translucent + background. + +v0.2 April 2014 + * Adding an ellipse helper. + * Adding a polyline helper. + * Adding a polygon helper. + * Adding monoid instance for Drawing. + * Fixing some stroking bug with cubic bezier curve. + * Fixing some documentation snippets. + * Adding a rounded rectangle helper. + * Added a even-odd filling rule. + * Added an offset for dashed stroking. + * Added a transformation module. + * 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/sampled_texture_reflect.png view
binary file changed (34555 → 34615 bytes)
src/Graphics/Rasterific.hs view
@@ -1,753 +1,753 @@-{-# 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]-+{-# 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,75 +1,112 @@-{-# 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)-+{-# 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 + -- | Empty value representing total transparency for the given type. + emptyValue :: a + -- | Full value representing total opacity for a given type. + fullValue :: a + -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue] + -- The second value is the inverse coverage + clampCoverage :: Float -> (a, a) + + -- | Modulate two elements, staying in the [emptyValue; fullValue] range. + modulate :: a -> a -> a + + -- | Implement a division between two elements. + modiv :: a -> a -> a + + alphaOver :: a -- ^ coverage + -> a -- ^ inverse coverage + -> a -- ^ background + -> a -- ^ foreground + -> a + alphaCompose :: a -> a -> a -> a -> a + + -- | Like modulate but also return the inverse coverage. + coverageModulate :: a -> a -> (a, a) + coverageModulate c a = (clamped, fullValue - clamped) + where clamped = modulate a c + +instance Modulable Float where + emptyValue = 0 + fullValue = 1 + clampCoverage f = (f, 1 - f) + modulate = (*) + modiv = (/) + alphaCompose coverage inverseCoverage backAlpha _ = + coverage + backAlpha * inverseCoverage + alphaOver coverage inverseCoverage background painted = + coverage * painted + background * inverseCoverage + +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 + + modiv c 0 = c + modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a + where fi :: Word8 -> Word32 + fi = fromIntegral + + 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 = \bottom top -> + let bottomOpacity = pixelOpacity bottom + alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top) + colorComposer _ back fore = + (alphaOver c ic (back `modulate` bottomOpacity) fore) + `modiv` alphaOut + in + mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top +
src/Graphics/Rasterific/CubicBezier.hs view
@@ -1,287 +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-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-+{-# 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 `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-+-- | 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,163 +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- , 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-+-- | 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)- | 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)-+{-# 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,47 +1,47 @@-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-+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,258 +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- | 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-+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,331 +1,330 @@-{-# 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-+{-# 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 ) ) + +-- | 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 = mixWith (\_ -> alphaOver cov icov) prevValue px + | otherwise = go value $ ix + 1 + where value@(coeff, px) = grad `V.unsafeIndex` ix + zeroToOne = (at - prevCoeff) / (coeff - prevCoeff) + (cov, icov) = clampCoverage zeroToOne + +gradientColorAtRepeat :: (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
@@ -1,130 +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+-- | 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,392 +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( .. )- , 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-+{-# 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 +