diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -1,87 +1,87 @@ --- Initial Rasterific.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ -name: Rasterific -version: 0.5.1 -synopsis: A pure haskell drawing engine. --- A longer description of the package. -description: - <> - . - Rasterific is a vector drawing library (a rasterizer) - implemented in pure haskell - -license: BSD3 -license-file: LICENSE -author: Vincent Berthoux -maintainer: twinside@gmail.com - --- A copyright notice. --- copyright: -category: Graphics -build-type: Simple - --- extra-source-files: - -cabal-version: >= 1.10 -extra-doc-files: docimages/*.png -extra-source-files: changelog - , docimages/*.png - , exec-src/docImageGenerator.hs - - - -Source-Repository head - Type: git - Location: git://github.com/Twinside/Rasterific.git - -Source-Repository this - Type: git - Location: git://github.com/Twinside/Rasterific.git - Tag: v0.5.1 - -flag embed_linear - description: Embed a reduced version of Linear avoiding a (huge) dep - Default: True - -library - hs-source-dirs: src - exposed-modules: Graphics.Rasterific - , Graphics.Rasterific.Outline - , Graphics.Rasterific.Texture - , Graphics.Rasterific.Linear - , Graphics.Rasterific.Lenses - , Graphics.Rasterific.Transformations - , Graphics.Rasterific.Immediate - , Graphics.Rasterific.PathWalker - - other-modules: Graphics.Rasterific.Line - , Graphics.Rasterific.Command - , Graphics.Rasterific.CubicBezier - , Graphics.Rasterific.QuadraticBezier - , Graphics.Rasterific.Operators - , Graphics.Rasterific.Rasterize - , Graphics.Rasterific.StrokeInternal - , Graphics.Rasterific.Types - , Graphics.Rasterific.Compositor - , Graphics.Rasterific.Shading - , Graphics.Rasterific.PlaneBoundable - , Graphics.Rasterific.QuadraticFormula - - ghc-options: -O3 -Wall - -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques - ghc-prof-options: -Wall -prof - default-language: Haskell2010 - build-depends: base >= 4.6 && < 4.9 - , free >= 4.7 - , JuicyPixels >= 3.2 - , FontyFruity >= 0.5 && < 0.6 - , vector >= 0.9 - , mtl >= 1.9 - , dlist >= 0.6 - , primitive >= 0.5 - , vector-algorithms >= 0.3 - - if !flag(embed_linear) - build-depends: linear >= 1.3 - cpp-options: -DEXTERNAL_LINEAR - +-- Initial Rasterific.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ +name: Rasterific +version: 0.5.2 +synopsis: A pure haskell drawing engine. +-- A longer description of the package. +description: + <> + . + Rasterific is a vector drawing library (a rasterizer) + implemented in pure haskell + +license: BSD3 +license-file: LICENSE +author: Vincent Berthoux +maintainer: twinside@gmail.com + +-- A copyright notice. +-- copyright: +category: Graphics +build-type: Simple + +-- extra-source-files: + +cabal-version: >= 1.10 +extra-doc-files: docimages/*.png +extra-source-files: changelog + , docimages/*.png + , exec-src/docImageGenerator.hs + + + +Source-Repository head + Type: git + Location: git://github.com/Twinside/Rasterific.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/Rasterific.git + Tag: v0.5.2 + +flag embed_linear + description: Embed a reduced version of Linear avoiding a (huge) dep + Default: True + +library + hs-source-dirs: src + exposed-modules: Graphics.Rasterific + , Graphics.Rasterific.Outline + , Graphics.Rasterific.Texture + , Graphics.Rasterific.Linear + , Graphics.Rasterific.Lenses + , Graphics.Rasterific.Transformations + , Graphics.Rasterific.Immediate + , Graphics.Rasterific.PathWalker + + other-modules: Graphics.Rasterific.Line + , Graphics.Rasterific.Command + , Graphics.Rasterific.CubicBezier + , Graphics.Rasterific.QuadraticBezier + , Graphics.Rasterific.Operators + , Graphics.Rasterific.Rasterize + , Graphics.Rasterific.StrokeInternal + , Graphics.Rasterific.Types + , Graphics.Rasterific.Compositor + , Graphics.Rasterific.Shading + , Graphics.Rasterific.PlaneBoundable + , Graphics.Rasterific.QuadraticFormula + + ghc-options: -O3 -Wall + -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques + ghc-prof-options: -Wall -prof + default-language: Haskell2010 + build-depends: base >= 4.6 && < 4.9 + , free >= 4.7 + , JuicyPixels >= 3.2 + , FontyFruity >= 0.5 && < 0.6 + , vector >= 0.9 + , mtl >= 1.9 + , dlist >= 0.6 + , primitive >= 0.5 + , vector-algorithms >= 0.3 + + if !flag(embed_linear) + build-depends: linear >= 1.3 + cpp-options: -DEXTERNAL_LINEAR + diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,98 +1,102 @@ --*-change-log-*- - -v0.5.1 March 2015 - * Enhancement: Generalizing geometry description, with automatic - conversion, reducing the need of type constructor from Primitive, - and directly filling Path. - -v0.5.0.3 February 2015 - * Fix: hackage documentation - -v0.5.0.2 February 2015 - * Removing test-suite as it's dependent of some repository-local files - -v0.5.0.1 February 2015 - * Fix: adding missing Arbitrary file in the distribution. - -v0.5 February 2015 - * Breaking Change: Font size is now a newtype in FontyFruity, - propagating the changes. - * Allowing to specify DPI at the top level of the rendering - request. - * Adding: an helper function to retrieve the distance to the - * Changed: font size switched to float. - -v0.4.2 February 2015 - * Fix: Cubic bezier clipping - -v0.4.1 January 2015 - * Fix: GHC 7.10 compilation - * Adding: Various lens to access some primitive informations. - -v0.4 December 2014 - * Breaking change: Changed the original position scheme for - text, allowing to specify baseline or upper left corner - - * Tried: Fast forward differencing for cubic bezier, not worth - the hassle - * Enhancement: Further optimized decomposition of all primitives, - less alocated memory. - * Enhancement: After optimizing pixel writing, optimized pixel - reading, yielding non-negligeable speed improvements. - * Added: an "immediate" module to avoid constructing - a scene tree. - * Enhancement: Allowing both IO & (ST s) as drawing monads, enabling - interleaved drawing with io operations. - * Added: a "withPathOrientation" function to orient primitives - on a path (allow to draw curved text) - * Added: toNewXBase transformation to create a new basis given - a X axis vector. - * Added: a PathWalker module, to give access to the lower level - path orientation facility. - * Added: some GHC rules for transformations - * Added: a new text function: 'printTextRanges' to allow - easier complex text rendering - -v0.3 June 2014 - * Enhancement: Switching main free monad type to the church encoded one. - * Enhancement: Optimized the bezier decomposition, strictness annotations - made wonders. May require forward differencing in the future. - * Enhancement: Implementing specific decomposition for lines. - * Enhancement: Reworked texture system, now allowing some specialized - filler (hoping faster computation). For now only the - solid color has been optimized, and all the transformed - textures. - * Enhancement: Fixing space leak in combineEdgeSamples, avoiding - many allocations. - * Adding: bounding box calculation facility. - * Adding: Exposing outline creation capability - * Adding: a skewX & skewY transformation function. - * Fixing: some numerical stability with the mitter join. - -v0.2.1 April 2014 - * Fixing: transparency in gradients. - * Fixing: alpha composition on top of translucent - background. - -v0.2 April 2014 - * Adding: an ellipse helper. - * Adding: a polyline helper. - * Adding: a polygon helper. - * Adding: monoid instance for Drawing. - * Fixing: some stroking bug with cubic bezier curve. - * Fixing: some documentation snippets. - * Adding: a rounded rectangle helper. - * Added: a even-odd filling rule. - * Added: an offset for dashed stroking. - * Added: a transformation module. - * Change: Changed the Transformable typeclass, splitted - it in two. - * Added: a dumping function for the constructed - drawing. - * Adding: an image texture with bilinear filtering. - * Adding: an image helper. - * Enhancement: Some modest performance gain. - -v0.1 February 2014 - * Initial version. - +-*-change-log-*- + +v0.5.2 April 2015 + * Enhancement: Added a withGroupOpacity to render elements with + a global opacity. + +v0.5.1 March 2015 + * Enhancement: Generalizing geometry description, with automatic + conversion, reducing the need of type constructor from Primitive, + and directly filling Path. + +v0.5.0.3 February 2015 + * Fix: hackage documentation + +v0.5.0.2 February 2015 + * Removing test-suite as it's dependent of some repository-local files + +v0.5.0.1 February 2015 + * Fix: adding missing Arbitrary file in the distribution. + +v0.5 February 2015 + * Breaking Change: Font size is now a newtype in FontyFruity, + propagating the changes. + * Allowing to specify DPI at the top level of the rendering + request. + * Adding: an helper function to retrieve the distance to the + * Changed: font size switched to float. + +v0.4.2 February 2015 + * Fix: Cubic bezier clipping + +v0.4.1 January 2015 + * Fix: GHC 7.10 compilation + * Adding: Various lens to access some primitive informations. + +v0.4 December 2014 + * Breaking change: Changed the original position scheme for + text, allowing to specify baseline or upper left corner + + * Tried: Fast forward differencing for cubic bezier, not worth + the hassle + * Enhancement: Further optimized decomposition of all primitives, + less alocated memory. + * Enhancement: After optimizing pixel writing, optimized pixel + reading, yielding non-negligeable speed improvements. + * Added: an "immediate" module to avoid constructing + a scene tree. + * Enhancement: Allowing both IO & (ST s) as drawing monads, enabling + interleaved drawing with io operations. + * Added: a "withPathOrientation" function to orient primitives + on a path (allow to draw curved text) + * Added: toNewXBase transformation to create a new basis given + a X axis vector. + * Added: a PathWalker module, to give access to the lower level + path orientation facility. + * Added: some GHC rules for transformations + * Added: a new text function: 'printTextRanges' to allow + easier complex text rendering + +v0.3 June 2014 + * Enhancement: Switching main free monad type to the church encoded one. + * Enhancement: Optimized the bezier decomposition, strictness annotations + made wonders. May require forward differencing in the future. + * Enhancement: Implementing specific decomposition for lines. + * Enhancement: Reworked texture system, now allowing some specialized + filler (hoping faster computation). For now only the + solid color has been optimized, and all the transformed + textures. + * Enhancement: Fixing space leak in combineEdgeSamples, avoiding + many allocations. + * Adding: bounding box calculation facility. + * Adding: Exposing outline creation capability + * Adding: a skewX & skewY transformation function. + * Fixing: some numerical stability with the mitter join. + +v0.2.1 April 2014 + * Fixing: transparency in gradients. + * Fixing: alpha composition on top of translucent + background. + +v0.2 April 2014 + * Adding: an ellipse helper. + * Adding: a polyline helper. + * Adding: a polygon helper. + * Adding: monoid instance for Drawing. + * Fixing: some stroking bug with cubic bezier curve. + * Fixing: some documentation snippets. + * Adding: a rounded rectangle helper. + * Added: a even-odd filling rule. + * Added: an offset for dashed stroking. + * Added: a transformation module. + * Change: Changed the Transformable typeclass, splitted + it in two. + * Added: a dumping function for the constructed + drawing. + * Adding: an image texture with bilinear filtering. + * Adding: an image helper. + * Enhancement: Some modest performance gain. + +v0.1 February 2014 + * Initial version. + diff --git a/docimages/cap_straight.png b/docimages/cap_straight.png Binary files a/docimages/cap_straight.png and b/docimages/cap_straight.png differ diff --git a/docimages/coordinate.png b/docimages/coordinate.png Binary files a/docimages/coordinate.png and b/docimages/coordinate.png differ diff --git a/docimages/fill_evenodd.png b/docimages/fill_evenodd.png Binary files a/docimages/fill_evenodd.png and b/docimages/fill_evenodd.png differ diff --git a/docimages/fill_winding.png b/docimages/fill_winding.png Binary files a/docimages/fill_winding.png and b/docimages/fill_winding.png differ diff --git a/docimages/geometry_on_path.png b/docimages/geometry_on_path.png Binary files a/docimages/geometry_on_path.png and b/docimages/geometry_on_path.png differ diff --git a/docimages/group_opacity.png b/docimages/group_opacity.png new file mode 100644 Binary files /dev/null and b/docimages/group_opacity.png differ diff --git a/docimages/item_opacity.png b/docimages/item_opacity.png new file mode 100644 Binary files /dev/null and b/docimages/item_opacity.png differ diff --git a/docimages/linear_gradient.png b/docimages/linear_gradient.png Binary files a/docimages/linear_gradient.png and b/docimages/linear_gradient.png differ diff --git a/docimages/module_example.png b/docimages/module_example.png Binary files a/docimages/module_example.png and b/docimages/module_example.png differ diff --git a/docimages/radial_gradient_focus.png b/docimages/radial_gradient_focus.png Binary files a/docimages/radial_gradient_focus.png and b/docimages/radial_gradient_focus.png differ diff --git a/docimages/sampled_texture_reflect.png b/docimages/sampled_texture_reflect.png Binary files a/docimages/sampled_texture_reflect.png and b/docimages/sampled_texture_reflect.png differ diff --git a/docimages/sampled_texture_rotate.png b/docimages/sampled_texture_rotate.png Binary files a/docimages/sampled_texture_rotate.png and b/docimages/sampled_texture_rotate.png differ diff --git a/docimages/sampled_texture_scaled.png b/docimages/sampled_texture_scaled.png Binary files a/docimages/sampled_texture_scaled.png and b/docimages/sampled_texture_scaled.png differ diff --git a/docimages/sampler_pad.png b/docimages/sampler_pad.png Binary files a/docimages/sampler_pad.png and b/docimages/sampler_pad.png differ diff --git a/docimages/sampler_reflect.png b/docimages/sampler_reflect.png Binary files a/docimages/sampler_reflect.png and b/docimages/sampler_reflect.png differ diff --git a/docimages/sampler_repeat.png b/docimages/sampler_repeat.png Binary files a/docimages/sampler_repeat.png and b/docimages/sampler_repeat.png differ diff --git a/docimages/stroke_line.png b/docimages/stroke_line.png Binary files a/docimages/stroke_line.png and b/docimages/stroke_line.png differ diff --git a/docimages/stroke_polyline.png b/docimages/stroke_polyline.png Binary files a/docimages/stroke_polyline.png and b/docimages/stroke_polyline.png differ diff --git a/docimages/strokize_dashed_path.png b/docimages/strokize_dashed_path.png Binary files a/docimages/strokize_dashed_path.png and b/docimages/strokize_dashed_path.png differ diff --git a/docimages/text_complex_example.png b/docimages/text_complex_example.png Binary files a/docimages/text_complex_example.png and b/docimages/text_complex_example.png differ diff --git a/docimages/text_example.png b/docimages/text_example.png Binary files a/docimages/text_example.png and b/docimages/text_example.png differ diff --git a/docimages/text_on_path.png b/docimages/text_on_path.png Binary files a/docimages/text_on_path.png and b/docimages/text_on_path.png differ diff --git a/exec-src/docImageGenerator.hs b/exec-src/docImageGenerator.hs --- a/exec-src/docImageGenerator.hs +++ b/exec-src/docImageGenerator.hs @@ -1,477 +1,485 @@ -{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>) ) -#endif - -import Control.Applicative( (<$>) ) - -import Control.Monad( forM_ ) -import Control.Monad.ST( runST ) -import Data.Monoid( (<>) ) -import Codec.Picture -import Codec.Picture.Types( promoteImage ) -import Graphics.Text.TrueType( loadFontFile ) -import Graphics.Rasterific -import Graphics.Rasterific.Outline -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Immediate -import System.Directory( createDirectoryIfMissing ) -import System.FilePath( () ) - -import Graphics.Rasterific.Linear( (^+^) ) - -logo :: Int -> Bool -> Vector -> [Primitive] -logo size inv offset = - toPrimitives . bezierFromPath . way $ map (^+^ offset) - [ (V2 0 is) - , (V2 0 0) - , (V2 is 0) - , (V2 is2 0) - , (V2 is2 is) - , (V2 is2 is2) - , (V2 is is2) - , (V2 0 is2) - , (V2 0 is) - ] - where is = fromIntegral size - is2 = is + is - - way | inv = reverse - | otherwise = id - -backgroundColor :: PixelRGBA8 -backgroundColor = PixelRGBA8 255 255 255 255 - -frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8 -frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 -accentTexture = uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255 -accent2Texture = uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255 - -produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO () -produceDocImage filename drawing = writePng filename img - where - img = renderDrawing 200 200 backgroundColor - $ withTexture frontTexture drawing - -capTester :: (FilePath, Cap) -> IO () -capTester (filename, cap) = - produceDocImage filename $ do - stroke 30 JoinRound (cap, cap) base_stroke - withTexture accentTexture $ - stroke 2 JoinRound (cap, cap) base_stroke - where - base_stroke = line (V2 0 200) (V2 100 100) - -joinTester :: (FilePath, Join) -> IO () -joinTester (filename, join) = - produceDocImage filename $ do - stroke 30 join (CapRound, CapRound) base_stroke - withTexture accentTexture $ - stroke 2 join (CapRound, CapRound) base_stroke - where - base_stroke = - [ Line (V2 0 200) (V2 100 100) - , Line (V2 100 100) (V2 200 200) - ] - -samplerTester :: (FilePath, SamplerRepeat) -> IO () -samplerTester (filename, sampler) = - produceDocImage filename $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (withSampler sampler $ linearGradientTexture gradDef - (V2 80 100) (V2 120 110)) $ - fill $ rectangle (V2 10 10) 180 180) - -outFolder :: FilePath -outFolder = "docimages" - -moduleExample :: IO () -moduleExample = do - let white = PixelRGBA8 255 255 255 255 - drawColor = PixelRGBA8 0 0x86 0xc1 255 - recColor = PixelRGBA8 0xFF 0x53 0x73 255 - img = renderDrawing 400 200 white $ - withTexture (uniformTexture drawColor) $ do - fill $ circle (V2 0 0) 30 - stroke 4 JoinRound (CapRound, CapRound) $ - circle (V2 400 200) 40 - withTexture (uniformTexture recColor) . - fill $ rectangle (V2 100 100) 200 100 - - writePng (outFolder "module_example.png") img - -arialFont :: FilePath -arialFont = -#ifdef __WIN32__ - "C:/Windows/Fonts/arial.ttf" -#else - "/usr/share/fonts/truetype/msttcorefonts/arial.ttf" -#endif - -monospaceFont :: FilePath -monospaceFont = -#ifdef __WIN32__ - "C:/Windows/Fonts/consola.ttf" -#else - "/usr/share/fonts/truetype/dejavu/DejaVuSansMono.ttf" -#endif - -textOnPathExample :: IO () -textOnPathExample = do - fontErr <- loadFontFile arialFont - case fontErr of - Left err -> putStrLn err - Right font -> - let path = Path (V2 100 180) False - [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] - in - produceDocImage (outFolder "text_on_path.png") $ do - stroke 3 JoinRound (CapStraight 0, CapStraight 0) path - - withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ do - withPathOrientation path 0 $ - printTextAt font (PointSize 24) (V2 0 0) "Text on path" - -geometryOnPath :: IO () -geometryOnPath = do - fontErr <- loadFontFile arialFont - case fontErr of - Left err -> putStrLn err - Right font -> - produceDocImage (outFolder "geometry_on_path.png") $ do - let path = Path (V2 100 180) False - [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] - withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ - stroke 3 JoinRound (CapStraight 0, CapStraight 0) path - - withPathOrientation path 0 $ do - printTextAt font (PointSize 24) (V2 0 0) "TX" - fill $ rectangle (V2 (-10) (-10)) 30 20 - fill $ rectangle (V2 45 0) 10 20 - fill $ rectangle (V2 60 (-10)) 20 20 - fill $ rectangle (V2 100 (-15)) 20 50 - -textExample :: IO () -textExample = do - fontErr <- loadFontFile arialFont - case fontErr of - Left err -> putStrLn err - Right font -> - writePng (outFolder "text_example.png") . - renderDrawing 300 70 (PixelRGBA8 255 255 255 255) - . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ - printTextAt font (PointSize 12) (V2 20 40) "A simple text test!" - -textMultipleExample :: IO () -textMultipleExample = do - eitherFont1 <- loadFontFile arialFont - eitherFont2 <- loadFontFile monospaceFont - case (,) <$> eitherFont1 <*> eitherFont2 of - Left err -> putStrLn err - Right (font1, font2) -> - writePng (outFolder "text_complex_example.png") . - renderDrawing 300 70 (PixelRGBA8 255 255 255 255) $ - let blackTexture = - Just . uniformTexture $ PixelRGBA8 0 0 0 255 - redTexture = - Just . uniformTexture $ PixelRGBA8 255 0 0 255 - in - printTextRanges (V2 20 40) - [ TextRange font1 (PointSize 12) "A complex " blackTexture - , TextRange font2 (PointSize 8) "text test" redTexture] - - - -coordinateSystem :: IO () -coordinateSystem = do - fontErr <- loadFontFile arialFont - case fontErr of - Left err -> putStrLn err - Right font -> - writePng (outFolder "coordinate.png") - . renderDrawing 200 200 white - $ create font - where - white = PixelRGBA8 255 255 255 255 - black = PixelRGBA8 0 0 0 255 - stroker = stroke 4 JoinRound (CapStraight 0, CapStraight 0) - create font = withTexture (uniformTexture black) $ do - stroker $ line (V2 10 40) (V2 190 40) - stroker $ line (V2 40 10) (V2 40 190) - printTextAt font (PointSize 12) (V2 4 37) "(0,0)" - printTextAt font (PointSize 12) (V2 100 37) "(width, 0)" - printTextAt font (PointSize 12) (V2 57 190) "(0, height)" - fill $ Path (V2 170 30) True - [PathLineTo (V2 195 40), PathLineTo (V2 170 50)] - fill $ Path (V2 30 170) True - [PathLineTo (V2 40 195), PathLineTo (V2 50 170)] - -fillingSample :: FillMethod -> Drawing px () -fillingSample fillMethod = fillWithMethod fillMethod geometry where - geometry = transform (applyTransformation $ scale 0.35 0.4 - <> translate (V2 (-80) (-180))) - [ Path (V2 484 499) True - [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) - , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) - ] - , Path (V2 136 377) True - [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) - , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) - ] - , Path (V2 340 265) True - [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) - , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) - , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) - ] - ] - -immediateDrawExample :: Image PixelRGBA8 -immediateDrawExample = runST $ - runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ - fillWithTexture FillWinding texture geometry - where - circlePrimitives = circle (V2 100 100) 50 - geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives - texture = uniformTexture (PixelRGBA8 255 255 255 255) - -immediateDrawMaskExample :: Image PixelRGBA8 -immediateDrawMaskExample = runST $ - runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ - forM_ [1 .. 10] $ \ix -> - fillWithTextureAndMask FillWinding texture mask $ - rectangle (V2 10 (ix * 18 - 5)) 180 13 - where - texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 - mask = sampledImageTexture - $ runST - $ runDrawContext 200 200 0 - $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry - - maskGeometry = strokize 15 JoinRound (CapRound, CapRound) - $ circle (V2 100 100) 80 - -main :: IO () -main = do - let addFolder (p, v) = (outFolder p, v) - createDirectoryIfMissing True outFolder - moduleExample - mapM_ (capTester . addFolder) - [ ("cap_straight.png", CapStraight 0) - , ("cap_straight_1.png", CapStraight 1) - , ("cap_round.png", CapRound) - ] - - mapM_ (joinTester . addFolder) - [ ("join_round.png", JoinRound) - , ("join_miter.png", JoinMiter 0) - , ("join_miter_5.png", JoinMiter 5) - ] - - mapM_ (samplerTester . addFolder) - [ ("sampler_pad.png", SamplerPad) - , ("sampler_repeat.png", SamplerRepeat) - , ("sampler_reflect.png", SamplerReflect) - ] - - writePng (outFolder "immediate_fill.png") immediateDrawExample - writePng (outFolder "immediate_mask.png") immediateDrawMaskExample - - produceDocImage (outFolder "fill_circle.png") $ - fill $ circle (V2 100 100) 75 - - produceDocImage (outFolder "fill_ellipse.png") $ - fill $ ellipse (V2 100 100) 75 30 - - produceDocImage (outFolder "stroke_circle.png") $ - stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 - - produceDocImage (outFolder "dashed_stroke.png") $ - dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ - line (V2 0 100) (V2 200 100) - - produceDocImage (outFolder "dashed_stroke_with_offset.png") $ - dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ - line (V2 0 100) (V2 200 100) - - produceDocImage (outFolder "fill_rect.png") $ - fill $ rectangle (V2 30 30) 150 100 - - produceDocImage (outFolder "with_texture.png") $ - withTexture frontTexture $ do - fill $ circle (V2 50 50) 20 - fill $ circle (V2 100 100) 20 - withTexture accent2Texture $ - fill $ circle (V2 150 150) 20 - - produceDocImage (outFolder "strokize_path.png") $ - stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ - strokize 40 JoinRound (CapRound, CapRound) $ - CubicBezier (V2 40 160) (V2 40 40) - (V2 160 40) (V2 160 160) - - produceDocImage (outFolder "strokize_dashed_path.png") $ - mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ - dashedStrokize 0 [10, 5] - 40 JoinRound (CapStraight 0, CapStraight 0) - [CubicBezier (V2 40 160) (V2 40 40) - (V2 160 40) (V2 160 160)] - - produceDocImage (outFolder "with_clipping.png") $ - withClipping (fill $ circle (V2 100 100) 75) $ - mapM_ (stroke 7 JoinRound (CapRound, CapRound)) - [line (V2 0 yf) (V2 200 (yf + 10)) - | y <- [5 :: Int, 17 .. 200] - , let yf = fromIntegral y ] - - produceDocImage (outFolder "stroke_line.png") $ - stroke 17 JoinRound (CapRound, CapRound) $ - line (V2 10 10) (V2 180 170) - - produceDocImage (outFolder "linear_gradient.png") $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (linearGradientTexture gradDef (V2 40 40) (V2 130 130)) $ - fill $ circle (V2 100 100) 100) - - produceDocImage (outFolder "radial_gradient.png") $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (radialGradientTexture gradDef (V2 100 100) 75) $ - fill $ circle (V2 100 100) 100) - - produceDocImage (outFolder "radial_gradient_focus.png") $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (radialGradientWithFocusTexture gradDef (V2 100 100) 75 (V2 70 70)) $ - fill $ circle (V2 100 100) 100) - - produceDocImage (outFolder "sampler_pad.png") $ - (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) - ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) - ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in - withTexture (linearGradientTexture gradDef (V2 80 100) (V2 120 110)) $ - fill $ rectangle (V2 10 10) 180 180) - - produceDocImage (outFolder "logo.png") $ - fill $ logo 80 False (V2 20 20) ++ - logo 40 True (V2 40 40) - - produceDocImage (outFolder "cubic_bezier.png") $ - stroke 5 JoinRound (CapRound, CapRound) $ - CubicBezier (V2 0 10) (V2 205 250) - (V2 (-10) 250) (V2 160 35) - - produceDocImage (outFolder "quadratic_bezier.png") $ - fill [ Bezier (V2 10 10) (V2 200 50) (V2 200 100) - , Bezier (V2 200 100) (V2 150 200) (V2 120 175) - , Bezier (V2 120 175) (V2 30 100) (V2 10 10)] - - produceDocImage (outFolder "simple_line.png") $ - fill [ Line (V2 10 10) (V2 190 10) - , Line (V2 190 10) (V2 95 170) - , Line (V2 95 170) (V2 10 10) ] - - produceDocImage (outFolder "primitive_mixed.png") $ - fill - [ toPrim $ CubicBezier (V2 50 20) (V2 90 60) - (V2 5 100) (V2 50 140) - , toPrim $ Line (V2 50 140) (V2 120 80) - , toPrim $ Line (V2 120 80) (V2 50 20) ] - - produceDocImage (outFolder "path_example.png") $ - fill $ Path (V2 50 20) True - [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) - , PathLineTo (V2 120 80) ] - - produceDocImage (outFolder "stroke_polyline.png") $ - stroke 4 JoinRound (CapRound, CapRound) $ - polyline [V2 10 10, V2 100 70, V2 190 190] - - produceDocImage (outFolder "fill_polygon.png") $ - fill $ polygon [V2 30 30, V2 100 70, V2 80 170] - - produceDocImage (outFolder "fill_roundedRectangle.png") $ - fill $ roundedRectangle (V2 10 10) 150 150 20 10 - - produceDocImage (outFolder "stroke_roundedRectangle.png") $ - stroke 4 JoinRound (CapRound, CapRound) $ - roundedRectangle (V2 10 10) 150 150 20 10 - - produceDocImage (outFolder "fill_evenodd.png") $ - fillingSample FillEvenOdd - - produceDocImage (outFolder "fill_winding.png") $ - fillingSample FillWinding - - produceDocImage (outFolder "transform_rotate.png") $ - fill . transform (applyTransformation $ rotate 0.2) - $ rectangle (V2 40 40) 120 120 - - produceDocImage (outFolder "transform_rotate_center.png") $ - fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200)) - $ rectangle (V2 40 40) 120 120 - - produceDocImage (outFolder "transform_translate.png") $ - fill . transform (applyTransformation $ translate (V2 100 100)) - $ rectangle (V2 40 40) 40 40 - - produceDocImage (outFolder "transform_scale.png") $ - fill . transform (applyTransformation $ scale 2 2) - $ rectangle (V2 40 40) 40 40 - - produceDocImage (outFolder "transform_skewx.png") $ - fill . transform (applyTransformation $ skewX 0.3) - $ rectangle (V2 50 50) 80 80 - - produceDocImage (outFolder "transform_skewy.png") $ - fill . transform (applyTransformation $ skewY 0.3) - $ rectangle (V2 50 50) 80 80 - - Right (ImageRGB8 img) <- readImage "avatar.png" - let textureImage = promoteImage img - produceDocImage (outFolder "sampled_texture_repeat.png") $ - withTexture (withSampler SamplerRepeat $ - sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "image_simple.png") $ - drawImage textureImage 0 (V2 30 30) - - produceDocImage (outFolder "image_resize.png") $ - drawImageAtSize textureImage 2 (V2 30 30) 128 128 - - produceDocImage (outFolder "sampled_texture_reflect.png") $ - withTexture (withSampler SamplerReflect $ - sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "sampled_texture_pad.png") $ - withTexture (sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "sampled_texture_rotate.png") $ - withTexture (withSampler SamplerRepeat $ - transformTexture (rotateCenter 1 (V2 0 0)) - $ sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - produceDocImage (outFolder "sampled_texture_scaled.png") $ - withTexture (withSampler SamplerRepeat $ - transformTexture (rotateCenter 1 (V2 0 0) <> - scale 0.5 0.25) - $ sampledImageTexture textureImage) $ - fill $ rectangle (V2 0 0) 200 200 - - textExample - textMultipleExample - coordinateSystem - textOnPathExample - geometryOnPath - +{-# LANGUAGE CPP #-} + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + + +import Control.Monad( forM_ ) +import Control.Monad.ST( runST ) +import Data.Monoid( (<>) ) +import Codec.Picture +import Codec.Picture.Types( promoteImage ) +import Graphics.Text.TrueType( loadFontFile ) +import Graphics.Rasterific +import Graphics.Rasterific.Outline +import Graphics.Rasterific.Texture +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Immediate +import System.Directory( createDirectoryIfMissing ) +import System.FilePath( () ) + +import Graphics.Rasterific.Linear( (^+^) ) + +logo :: Int -> Bool -> Vector -> [Primitive] +logo size inv offset = + toPrimitives . bezierFromPath . way $ map (^+^ offset) + [ (V2 0 is) + , (V2 0 0) + , (V2 is 0) + , (V2 is2 0) + , (V2 is2 is) + , (V2 is2 is2) + , (V2 is is2) + , (V2 0 is2) + , (V2 0 is) + ] + where is = fromIntegral size + is2 = is + is + + way | inv = reverse + | otherwise = id + +backgroundColor :: PixelRGBA8 +backgroundColor = PixelRGBA8 255 255 255 255 + +frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8 +frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 +accentTexture = uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255 +accent2Texture = uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255 + +produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO () +produceDocImage filename drawing = writePng filename img + where + img = renderDrawing 200 200 backgroundColor + $ withTexture frontTexture drawing + +capTester :: (FilePath, Cap) -> IO () +capTester (filename, cap) = + produceDocImage filename $ do + stroke 30 JoinRound (cap, cap) base_stroke + withTexture accentTexture $ + stroke 2 JoinRound (cap, cap) base_stroke + where + base_stroke = line (V2 0 200) (V2 100 100) + +joinTester :: (FilePath, Join) -> IO () +joinTester (filename, join) = + produceDocImage filename $ do + stroke 30 join (CapRound, CapRound) base_stroke + withTexture accentTexture $ + stroke 2 join (CapRound, CapRound) base_stroke + where + base_stroke = + [ Line (V2 0 200) (V2 100 100) + , Line (V2 100 100) (V2 200 200) + ] + +samplerTester :: (FilePath, SamplerRepeat) -> IO () +samplerTester (filename, sampler) = + produceDocImage filename $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (withSampler sampler $ linearGradientTexture gradDef + (V2 80 100) (V2 120 110)) $ + fill $ rectangle (V2 10 10) 180 180) + +outFolder :: FilePath +outFolder = "docimages" + +moduleExample :: IO () +moduleExample = do + let white = PixelRGBA8 255 255 255 255 + drawColor = PixelRGBA8 0 0x86 0xc1 255 + recColor = PixelRGBA8 0xFF 0x53 0x73 255 + img = renderDrawing 400 200 white $ + withTexture (uniformTexture drawColor) $ do + fill $ circle (V2 0 0) 30 + stroke 4 JoinRound (CapRound, CapRound) $ + circle (V2 400 200) 40 + withTexture (uniformTexture recColor) . + fill $ rectangle (V2 100 100) 200 100 + + writePng (outFolder "module_example.png") img + +sansSerifFont :: FilePath +sansSerifFont = "test_fonts/DejaVuSans.ttf" + +monospaceFont :: FilePath +monospaceFont = "test_fonts/DejaVuSansMono.ttf" + +textOnPathExample :: IO () +textOnPathExample = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + let path = Path (V2 100 180) False + [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] + in + produceDocImage (outFolder "text_on_path.png") $ do + stroke 3 JoinRound (CapStraight 0, CapStraight 0) path + + withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ do + withPathOrientation path 0 $ + printTextAt font (PointSize 24) (V2 0 0) "Text on path" + +geometryOnPath :: IO () +geometryOnPath = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + produceDocImage (outFolder "geometry_on_path.png") $ do + let path = Path (V2 100 180) False + [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] + withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ + stroke 3 JoinRound (CapStraight 0, CapStraight 0) path + + withPathOrientation path 0 $ do + printTextAt font (PointSize 24) (V2 0 0) "TX" + fill $ rectangle (V2 (-10) (-10)) 30 20 + fill $ rectangle (V2 45 0) 10 20 + fill $ rectangle (V2 60 (-10)) 20 20 + fill $ rectangle (V2 100 (-15)) 20 50 + +textExample :: IO () +textExample = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + writePng (outFolder "text_example.png") . + renderDrawing 300 70 (PixelRGBA8 255 255 255 255) + . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ + printTextAt font (PointSize 12) (V2 20 40) "A simple text test!" + +textMultipleExample :: IO () +textMultipleExample = do + eitherFont1 <- loadFontFile sansSerifFont + eitherFont2 <- loadFontFile monospaceFont + case (,) <$> eitherFont1 <*> eitherFont2 of + Left err -> putStrLn err + Right (font1, font2) -> + writePng (outFolder "text_complex_example.png") . + renderDrawing 300 70 (PixelRGBA8 255 255 255 255) $ + let blackTexture = + Just . uniformTexture $ PixelRGBA8 0 0 0 255 + redTexture = + Just . uniformTexture $ PixelRGBA8 255 0 0 255 + in + printTextRanges (V2 20 40) + [ TextRange font1 (PointSize 12) "A complex " blackTexture + , TextRange font2 (PointSize 8) "text test" redTexture] + + + +coordinateSystem :: IO () +coordinateSystem = do + fontErr <- loadFontFile sansSerifFont + case fontErr of + Left err -> putStrLn err + Right font -> + writePng (outFolder "coordinate.png") + . renderDrawing 200 200 white + $ create font + where + white = PixelRGBA8 255 255 255 255 + black = PixelRGBA8 0 0 0 255 + stroker = stroke 4 JoinRound (CapStraight 0, CapStraight 0) + create font = withTexture (uniformTexture black) $ do + stroker $ line (V2 10 40) (V2 190 40) + stroker $ line (V2 40 10) (V2 40 190) + printTextAt font (PointSize 12) (V2 4 37) "(0,0)" + printTextAt font (PointSize 12) (V2 100 37) "(width, 0)" + printTextAt font (PointSize 12) (V2 57 190) "(0, height)" + fill $ Path (V2 170 30) True + [PathLineTo (V2 195 40), PathLineTo (V2 170 50)] + fill $ Path (V2 30 170) True + [PathLineTo (V2 40 195), PathLineTo (V2 50 170)] + +fillingSample :: FillMethod -> Drawing px () +fillingSample fillMethod = fillWithMethod fillMethod geometry where + geometry = transform (applyTransformation $ scale 0.35 0.4 + <> translate (V2 (-80) (-180))) + [ Path (V2 484 499) True + [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) + , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) + ] + , Path (V2 136 377) True + [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) + , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) + ] + , Path (V2 340 265) True + [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) + , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) + , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) + ] + ] + +immediateDrawExample :: Image PixelRGBA8 +immediateDrawExample = runST $ + runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ + fillWithTexture FillWinding texture geometry + where + circlePrimitives = circle (V2 100 100) 50 + geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives + texture = uniformTexture (PixelRGBA8 255 255 255 255) + +immediateDrawMaskExample :: Image PixelRGBA8 +immediateDrawMaskExample = runST $ + runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ + forM_ [1 .. 10] $ \ix -> + fillWithTextureAndMask FillWinding texture mask $ + rectangle (V2 10 (ix * 18 - 5)) 180 13 + where + texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 + mask = sampledImageTexture + $ runST + $ runDrawContext 200 200 0 + $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry + + maskGeometry = strokize 15 JoinRound (CapRound, CapRound) + $ circle (V2 100 100) 80 + +main :: IO () +main = do + let addFolder (p, v) = (outFolder p, v) + createDirectoryIfMissing True outFolder + moduleExample + mapM_ (capTester . addFolder) + [ ("cap_straight.png", CapStraight 0) + , ("cap_straight_1.png", CapStraight 1) + , ("cap_round.png", CapRound) + ] + + mapM_ (joinTester . addFolder) + [ ("join_round.png", JoinRound) + , ("join_miter.png", JoinMiter 0) + , ("join_miter_5.png", JoinMiter 5) + ] + + mapM_ (samplerTester . addFolder) + [ ("sampler_pad.png", SamplerPad) + , ("sampler_repeat.png", SamplerRepeat) + , ("sampler_reflect.png", SamplerReflect) + ] + + writePng (outFolder "immediate_fill.png") immediateDrawExample + writePng (outFolder "immediate_mask.png") immediateDrawMaskExample + + produceDocImage (outFolder "fill_circle.png") $ + fill $ circle (V2 100 100) 75 + + produceDocImage (outFolder "fill_ellipse.png") $ + fill $ ellipse (V2 100 100) 75 30 + + produceDocImage (outFolder "stroke_circle.png") $ + stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 + + produceDocImage (outFolder "dashed_stroke.png") $ + dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ + line (V2 0 100) (V2 200 100) + + produceDocImage (outFolder "dashed_stroke_with_offset.png") $ + dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ + line (V2 0 100) (V2 200 100) + + produceDocImage (outFolder "fill_rect.png") $ + fill $ rectangle (V2 30 30) 150 100 + + produceDocImage (outFolder "with_texture.png") $ + withTexture frontTexture $ do + fill $ circle (V2 50 50) 20 + fill $ circle (V2 100 100) 20 + withTexture accent2Texture $ + fill $ circle (V2 150 150) 20 + + produceDocImage (outFolder "strokize_path.png") $ + stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ + strokize 40 JoinRound (CapRound, CapRound) $ + CubicBezier (V2 40 160) (V2 40 40) + (V2 160 40) (V2 160 160) + + produceDocImage (outFolder "strokize_dashed_path.png") $ + mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ + dashedStrokize 0 [10, 5] + 40 JoinRound (CapStraight 0, CapStraight 0) + [CubicBezier (V2 40 160) (V2 40 40) + (V2 160 40) (V2 160 160)] + + produceDocImage (outFolder "with_clipping.png") $ + withClipping (fill $ circle (V2 100 100) 75) $ + mapM_ (stroke 7 JoinRound (CapRound, CapRound)) + [line (V2 0 yf) (V2 200 (yf + 10)) + | y <- [5 :: Int, 17 .. 200] + , let yf = fromIntegral y ] + + produceDocImage (outFolder "stroke_line.png") $ + stroke 17 JoinRound (CapRound, CapRound) $ + line (V2 10 10) (V2 180 170) + + produceDocImage (outFolder "linear_gradient.png") $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (linearGradientTexture gradDef (V2 40 40) (V2 130 130)) $ + fill $ circle (V2 100 100) 100) + + produceDocImage (outFolder "radial_gradient.png") $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (radialGradientTexture gradDef (V2 100 100) 75) $ + fill $ circle (V2 100 100) 100) + + produceDocImage (outFolder "radial_gradient_focus.png") $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (radialGradientWithFocusTexture gradDef (V2 100 100) 75 (V2 70 70)) $ + fill $ circle (V2 100 100) 100) + + produceDocImage (outFolder "sampler_pad.png") $ + (let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in + withTexture (linearGradientTexture gradDef (V2 80 100) (V2 120 110)) $ + fill $ rectangle (V2 10 10) 180 180) + + produceDocImage (outFolder "logo.png") $ + fill $ logo 80 False (V2 20 20) ++ + logo 40 True (V2 40 40) + + produceDocImage (outFolder "cubic_bezier.png") $ + stroke 5 JoinRound (CapRound, CapRound) $ + CubicBezier (V2 0 10) (V2 205 250) + (V2 (-10) 250) (V2 160 35) + + produceDocImage (outFolder "quadratic_bezier.png") $ + fill [ Bezier (V2 10 10) (V2 200 50) (V2 200 100) + , Bezier (V2 200 100) (V2 150 200) (V2 120 175) + , Bezier (V2 120 175) (V2 30 100) (V2 10 10)] + + produceDocImage (outFolder "simple_line.png") $ + fill [ Line (V2 10 10) (V2 190 10) + , Line (V2 190 10) (V2 95 170) + , Line (V2 95 170) (V2 10 10) ] + + produceDocImage (outFolder "primitive_mixed.png") $ + fill + [ toPrim $ CubicBezier (V2 50 20) (V2 90 60) + (V2 5 100) (V2 50 140) + , toPrim $ Line (V2 50 140) (V2 120 80) + , toPrim $ Line (V2 120 80) (V2 50 20) ] + + produceDocImage (outFolder "path_example.png") $ + fill $ Path (V2 50 20) True + [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) + , PathLineTo (V2 120 80) ] + + produceDocImage (outFolder "stroke_polyline.png") $ + stroke 4 JoinRound (CapRound, CapRound) $ + polyline [V2 10 10, V2 100 70, V2 190 190] + + produceDocImage (outFolder "fill_polygon.png") $ + fill $ polygon [V2 30 30, V2 100 70, V2 80 170] + + produceDocImage (outFolder "fill_roundedRectangle.png") $ + fill $ roundedRectangle (V2 10 10) 150 150 20 10 + + produceDocImage (outFolder "stroke_roundedRectangle.png") $ + stroke 4 JoinRound (CapRound, CapRound) $ + roundedRectangle (V2 10 10) 150 150 20 10 + + produceDocImage (outFolder "fill_evenodd.png") $ + fillingSample FillEvenOdd + + produceDocImage (outFolder "fill_winding.png") $ + fillingSample FillWinding + + produceDocImage (outFolder "transform_rotate.png") $ + fill . transform (applyTransformation $ rotate 0.2) + $ rectangle (V2 40 40) 120 120 + + produceDocImage (outFolder "transform_rotate_center.png") $ + fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200)) + $ rectangle (V2 40 40) 120 120 + + produceDocImage (outFolder "transform_translate.png") $ + fill . transform (applyTransformation $ translate (V2 100 100)) + $ rectangle (V2 40 40) 40 40 + + produceDocImage (outFolder "transform_scale.png") $ + fill . transform (applyTransformation $ scale 2 2) + $ rectangle (V2 40 40) 40 40 + + produceDocImage (outFolder "transform_skewx.png") $ + fill . transform (applyTransformation $ skewX 0.3) + $ rectangle (V2 50 50) 80 80 + + produceDocImage (outFolder "transform_skewy.png") $ + fill . transform (applyTransformation $ skewY 0.3) + $ rectangle (V2 50 50) 80 80 + + Right (ImageRGB8 img) <- readImage "avatar.png" + let textureImage = promoteImage img + produceDocImage (outFolder "sampled_texture_repeat.png") $ + withTexture (withSampler SamplerRepeat $ + sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "image_simple.png") $ + drawImage textureImage 0 (V2 30 30) + + produceDocImage (outFolder "image_resize.png") $ + drawImageAtSize textureImage 2 (V2 30 30) 128 128 + + produceDocImage (outFolder "sampled_texture_reflect.png") $ + withTexture (withSampler SamplerReflect $ + sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "sampled_texture_pad.png") $ + withTexture (sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "sampled_texture_rotate.png") $ + withTexture (withSampler SamplerRepeat $ + transformTexture (rotateCenter 1 (V2 0 0)) + $ sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "sampled_texture_scaled.png") $ + withTexture (withSampler SamplerRepeat $ + transformTexture (rotateCenter 1 (V2 0 0) <> + scale 0.5 0.25) + $ sampledImageTexture textureImage) $ + fill $ rectangle (V2 0 0) 200 200 + + produceDocImage (outFolder "group_opacity.png") $ do + withTexture accent2Texture $ + stroke 3 JoinRound (CapRound, CapRound) $ + line (V2 0 100) (V2 200 100) + + withGroupOpacity 128 $ do + withTexture frontTexture . fill $ circle (V2 70 100) 60 + withTexture accentTexture . fill $ circle (V2 120 100) 60 + + produceDocImage (outFolder "item_opacity.png") $ do + withTexture accent2Texture $ + stroke 3 JoinRound (CapRound, CapRound) $ + line (V2 0 100) (V2 200 100) + + withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) . + fill $ circle (V2 70 100) 60 + withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) . + fill $ circle (V2 120 100) 60 + + textExample + textMultipleExample + coordinateSystem + textOnPathExample + geometryOnPath + diff --git a/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs --- a/src/Graphics/Rasterific.hs +++ b/src/Graphics/Rasterific.hs @@ -1,696 +1,801 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} --- | Main module of Rasterific, an Haskell rasterization engine. --- --- Creating an image is rather simple, here is a simple example --- of a drawing and saving it in a PNG file: --- --- > import Codec.Picture( PixelRGBA8( .. ), writePng ) --- > import Graphics.Rasterific --- > import Graphics.Rasterific.Texture --- > --- > main :: IO () --- > main = do --- > let white = PixelRGBA8 255 255 255 255 --- > drawColor = PixelRGBA8 0 0x86 0xc1 255 --- > recColor = PixelRGBA8 0xFF 0x53 0x73 255 --- > img = renderDrawing 400 200 white $ --- > withTexture (uniformTexture drawColor) $ do --- > fill $ circle (V2 0 0) 30 --- > stroke 4 JoinRound (CapRound, CapRound) $ --- > circle (V2 400 200) 40 --- > withTexture (uniformTexture recColor) . --- > fill $ rectangle (V2 100 100) 200 100 --- > --- > writePng "yourimage.png" img --- --- <> --- --- 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: --- --- <> --- -module Graphics.Rasterific - ( - -- * Rasterization command - fill - , fillWithMethod - , withTexture - , withClipping - , withTransformation - , withPathOrientation - , stroke - , dashedStroke - , dashedStrokeWithOffset - , printTextAt - , printTextRanges - , TextRange( .. ) - , PointSize( .. ) - - -- * Generating images - , ModulablePixel - , RenderablePixel - , renderDrawing - , renderDrawingAtDpi - , pathToPrimitives - - -- * Rasterization types - , Texture - , Drawing - , Modulable - - -- * Geometry description - , V2( .. ) - , Point - , Vector - , CubicBezier( .. ) - , Line( .. ) - , Bezier( .. ) - , Primitive( .. ) - , Path( .. ) - , PathCommand( .. ) - - -- * Generic geometry description - , Primitivable( .. ) - , Geometry( .. ) - - -- * Generic geometry manipulation - , Transformable( .. ) - , PointFoldable( .. ) - , PlaneBoundable( .. ) - , PlaneBound( .. ) - , boundWidth - , boundHeight - , boundLowerLeftCorner - - -- * Helpers - , line - , rectangle - , roundedRectangle - , circle - , ellipse - , polyline - , polygon - , drawImageAtSize - , drawImage - - -- ** Geometry Helpers - , clip - , bezierFromPath - , lineFromPath - , cubicBezierFromPath - , firstTangeantOf - , lastTangeantOf - , firstPointOf - , lastPointOf - - -- * Rasterization control - , Join( .. ) - , Cap( .. ) - , SamplerRepeat( .. ) - , FillMethod( .. ) - , DashPattern - , drawOrdersOfDrawing - - -- * Debugging helper - , dumpDrawing - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid( .. ) ) -#endif - -import Data.Monoid( (<>) ) - -import Control.Applicative( (<$>) ) -import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.Free.Church( fromF ) -import Control.Monad.ST( runST ) -import Control.Monad.State( modify, execState ) -import Data.Maybe( fromMaybe ) -import Codec.Picture.Types( Image( .. ), Pixel( .. ) ) - -import qualified Data.Vector.Unboxed as VU -import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^), (^*) ) -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Shading -import Graphics.Rasterific.Types -import Graphics.Rasterific.Line -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.StrokeInternal -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.PlaneBoundable -import Graphics.Rasterific.Immediate -import Graphics.Rasterific.PathWalker -import Graphics.Rasterific.Command -{-import Graphics.Rasterific.TensorPatch-} - -import Graphics.Text.TrueType( Font - , Dpi - , PointSize( .. ) - , getStringCurveAtPoint ) - -{-import Debug.Trace-} -{-import Text.Printf-} - ------------------------------------------------- ----- Free Monad DSL section ------------------------------------------------- - --- | Define the texture applyied to all the children --- draw call. --- --- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ do --- > fill $ circle (V2 50 50) 20 --- > fill $ circle (V2 100 100) 20 --- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) --- > $ circle (V2 150 150) 20 --- --- <> --- -withTexture :: Texture px -> Drawing px () -> Drawing px () -withTexture texture subActions = - liftF $ SetTexture texture subActions () - --- | Draw all the sub drawing commands using a transformation. -withTransformation :: Transformation -> Drawing px () -> Drawing px () -withTransformation trans sub = - liftF $ WithTransform trans sub () - --- | This command allows you to draw primitives on a given curve, --- for example, you can draw text on a curve: --- --- > let path = Path (V2 100 180) False --- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in --- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path --- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > withPathOrientation path 0 $ --- > printTextAt font (PointSize 24) (V2 0 0) "Text on path" --- --- <> --- --- You can note that the position of the baseline match the size of the --- characters. --- --- You are not limited to text drawing while using this function, --- you can draw arbitrary geometry like in the following example: --- --- > let path = Path (V2 100 180) False --- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] --- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path --- > --- > withPathOrientation path 0 $ do --- > printTextAt font (PointSize 24) (V2 0 0) "TX" --- > fill $ rectangle (V2 (-10) (-10)) 30 20 --- > fill $ rectangle (V2 45 0) 10 20 --- > fill $ rectangle (V2 60 (-10)) 20 20 --- > fill $ rectangle (V2 100 (-15)) 20 50 --- --- <> --- -withPathOrientation :: Path -- ^ Path directing the orientation. - -> Float -- ^ Basline Y axis position, used to align text properly. - -> Drawing px () -- ^ The sub drawings. - -> Drawing px () -withPathOrientation path p sub = - liftF $ WithPathOrientation path p sub () - --- | Fill some geometry. The geometry should be "looping", --- ie. the last point of the last primitive should --- be equal to the first point of the first primitive. --- --- The primitive should be connected. --- --- > fill $ circle (V2 100 100) 75 --- --- <> --- -fill :: Geometry geom => geom -> Drawing px () -fill prims = liftF $ Fill FillWinding (toPrimitives prims) () - --- | This function let you choose how to fill the primitives --- in case of self intersection. See `FillMethod` documentation --- for more information. -fillWithMethod :: Geometry geom - => FillMethod -> geom -> Drawing px () -fillWithMethod method prims = - liftF $ Fill method (toPrimitives prims) () - --- | Draw some geometry using a clipping path. --- --- > withClipping (fill $ circle (V2 100 100) 75) $ --- > mapM_ (stroke 7 JoinRound (CapRound, CapRound)) --- > [line (V2 0 yf) (V2 200 (yf + 10)) --- > | y <- [5 :: Int, 17 .. 200] --- > , let yf = fromIntegral y ] --- --- <> --- -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 --- --- <> --- -stroke :: (Geometry geom) - => Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ List of elements to render - -> Drawing px () -stroke width join caping prims = - liftF $ Stroke width join caping (toPrimitives prims) () - --- | Draw a string at a given position. --- Text printing imply loading a font, there is no default --- font (yet). Below an example of font rendering using a --- font installed on Microsoft Windows. --- --- > import Graphics.Text.TrueType( loadFontFile ) --- > import Codec.Picture( PixelRGBA8( .. ), writePng ) --- > import Graphics.Rasterific --- > import Graphics.Rasterific.Texture --- > --- > main :: IO () --- > main = do --- > fontErr <- loadFontFile "C:/Windows/Fonts/arial.ttf" --- > case fontErr of --- > Left err -> putStrLn err --- > Right font -> --- > writePng "text_example.png" . --- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) --- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > printTextAt font (PointSize 12) (V2 20 40) --- > "A simple text test!" --- --- <> --- --- You can use any texture, like a gradient while rendering text. --- -printTextAt :: Font -- ^ Drawing font - -> PointSize -- ^ font Point size - -> Point -- ^ Drawing starting point (base line) - -> String -- ^ String to print - -> Drawing px () -printTextAt font pointSize point string = - liftF $ TextFill point [description] () - where - description = TextRange - { _textFont = font - , _textSize = pointSize - , _text = string - , _textTexture = Nothing - } - --- | Print complex text, using different texture font and --- point size for different parts of the text. --- --- > let blackTexture = --- > Just . uniformTexture $ PixelRGBA8 0 0 0 255 --- > redTexture = --- > Just . uniformTexture $ PixelRGBA8 255 0 0 255 --- > in --- > printTextRanges (V2 20 40) --- > [ TextRange font1 (PointSize 12) "A complex " blackTexture --- > , TextRange font2 (PointSize 8) "text test" redTexture] --- --- <> --- -printTextRanges :: Point -- ^ Starting point of the base line - -> [TextRange px] -- ^ Ranges description to be printed - -> Drawing px () -printTextRanges point ranges = liftF $ TextFill point ranges () - -data RenderContext px = RenderContext - { currentClip :: Maybe (Texture (PixelBaseComponent px)) - , currentTexture :: Texture px - , currentTransformation :: Maybe (Transformation, Transformation) - } - --- | Function to call in order to start the image creation. --- Tested pixels type are PixelRGBA8 and Pixel8, pixel types --- in other colorspace will probably produce weird results. --- Default DPI is 96 -renderDrawing - :: forall px . (RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> Image px -renderDrawing width height = renderDrawingAtDpi width height 96 - --- | Function to call in order to start the image creation. --- Tested pixels type are PixelRGBA8 and Pixel8, pixel types --- in other colorspace will probably produce weird results. -renderDrawingAtDpi - :: forall px . (RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> Dpi -- ^ Current DPI used for text rendering. - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> Image px -renderDrawingAtDpi width height dpi background drawing = - runST $ runDrawContext width height background - $ mapM_ fillOrder - $ drawOrdersOfDrawing width height dpi background drawing - --- | Transform a drawing into a serie of low-level drawing orders. -drawOrdersOfDrawing - :: forall px . (RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> Dpi -- ^ Current assumed DPI - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> [DrawOrder px] -drawOrdersOfDrawing width height dpi background drawing = - go initialContext (fromF drawing) [] - where - initialContext = RenderContext Nothing stupidDefaultTexture Nothing - clipBackground = emptyValue :: PixelBaseComponent px - clipForeground = fullValue :: PixelBaseComponent px - - clipRender = - renderDrawing width height clipBackground - . withTexture (uniformTexture clipForeground) - - textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } = - transformTexture t $ currentTexture ctxt - textureOf ctxt = currentTexture ctxt - - geometryOf RenderContext { currentTransformation = Just (trans, _) } = - transform (applyTransformation trans) - geometryOf _ = id - - stupidDefaultTexture = - uniformTexture $ colorMap (const clipBackground) background - - go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px] - -> [DrawOrder px] - go _ (Pure ()) rest = rest - go ctxt (Free (WithPathOrientation path base sub next)) rest = final where - final = orders <> go ctxt next rest - images = go ctxt (fromF sub) [] - - drawer trans _ order = modify $ \lst -> finalOrder : lst - where - toFinalPos = transform $ applyTransformation trans - finalOrder = - order { _orderPrimitives = toFinalPos $ _orderPrimitives order } - orders = reverse $ execState (drawOrdersOnPath drawer 0 base path images) [] - - go ctxt (Free (WithTransform trans sub next)) rest = final where - trans' - | Just (t, _) <- currentTransformation ctxt = t <> trans - | otherwise = trans - invTrans = fromMaybe mempty $ inverseTransformation trans' - after = go ctxt next rest - subContext = - ctxt { currentTransformation = Just (trans', invTrans) } - - final = go subContext (fromF sub) after - - go ctxt (Free (Fill method prims next)) rest = order : after where - after = go ctxt next rest - order = DrawOrder - { _orderPrimitives = [geometryOf ctxt prims] - , _orderTexture = textureOf ctxt - , _orderFillMethod = method - , _orderMask = currentClip ctxt - } - - go ctxt (Free (Stroke w j cap prims next)) rest = - go ctxt (Free $ Fill FillWinding prim' next) rest - where prim' = listOfContainer $ strokize w j cap prims - - go ctxt (Free (SetTexture tx sub next)) rest = - go (ctxt { currentTexture = tx }) (fromF sub) $ go ctxt next rest - - go ctxt (Free (DashedStroke o d w j cap prims next)) rest = - foldr recurse after $ dashedStrokize o d w j cap prims - where - after = go ctxt next rest - recurse sub = - go ctxt (liftF $ Fill FillWinding sub ()) - - go ctxt (Free (TextFill (V2 x y) descriptions next)) rest = - go ctxt (sequence_ drawCalls) $ go ctxt next rest - where - floatCurves = - getStringCurveAtPoint dpi (x, y) - [(_textFont d, _textSize d, _text d) | d <- descriptions] - - linearDescriptions = - concat [map (const d) $ _text d | d <- descriptions] - - drawCalls = - [texturize d $ beziersOfChar curve - | (curve, d) <- zip floatCurves linearDescriptions] - - texturize descr sub = case _textTexture descr of - Nothing -> fromF sub - Just t -> liftF $ SetTexture t sub () - - beziersOfChar curves = liftF $ Fill FillWinding bezierCurves () - where - bezierCurves = concat - [map BezierPrim . bezierFromPath . map (uncurry V2) - $ VU.toList c | c <- curves] - - go ctxt (Free (WithCliping clipPath path next)) rest = - go (ctxt { currentClip = newModuler }) (fromF path) $ - go ctxt next rest - where - modulationTexture :: Texture (PixelBaseComponent px) - modulationTexture = RawTexture $ clipRender clipPath - - newModuler = Just . subModuler $ currentClip ctxt - - subModuler Nothing = modulationTexture - subModuler (Just v) = - modulateTexture v modulationTexture - --- | With stroke geometry with a given stroke width, using --- a dash pattern. --- --- > dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ --- > line (V2 0 100) (V2 200 100) --- --- <> --- -dashedStroke - :: Geometry geom - => DashPattern -- ^ Dashing pattern to use for stroking - -> Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ List of elements to render - -> Drawing px () -dashedStroke = dashedStrokeWithOffset 0.0 - --- | With stroke geometry with a given stroke width, using --- a dash pattern. The offset is there to specify the starting --- point into the pattern, the value can be negative. --- --- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ --- > line (V2 0 100) (V2 200 100) --- --- <> --- -dashedStrokeWithOffset - :: Geometry geom - => Float -- ^ Starting offset - -> DashPattern -- ^ Dashing pattern to use for stroking - -> Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ List of elements to render - -> Drawing px () -dashedStrokeWithOffset _ [] width join caping prims = - stroke width join caping prims -dashedStrokeWithOffset offset dashing width join caping prims = - liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) () - --- | Generate a list of primitive representing a circle. --- --- > fill $ circle (V2 100 100) 75 --- --- <> --- -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 --- --- <> --- -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] --- --- <> --- -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] --- --- <> --- -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 --- --- <> --- -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) --- --- <> --- -drawImage :: ModulablePixel px - => Image px -- ^ Image to be drawn - -> StrokeWidth -- ^ Border size, drawn with current texture. - -> Point -- ^ Position of the corner upper left of the image. - -> Drawing px () -drawImage img@Image { imageWidth = w, imageHeight = h } s p = - drawImageAtSize img s p (fromIntegral w) (fromIntegral h) - --- | Draw an image with the desired size --- --- > drawImageAtSize textureImage 2 (V2 30 30) 128 128 --- --- <> --- -drawImageAtSize :: (Pixel px, Modulable (PixelBaseComponent px)) - => Image px -- ^ Image to be drawn - -> StrokeWidth -- ^ Border size, drawn with current texture. - -> Point -- ^ Position of the corner upper left of the image. - -> Float -- ^ Width of the drawn image - -> Float -- ^ Height of the drawn image - -> Drawing px () -drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip - reqWidth reqHeight - | borderSize <= 0 = - withTransformation (translate p <> scale scaleX scaleY) . - withTexture (sampledImageTexture img) $ fill rect - | otherwise = do - withTransformation (translate p <> scale scaleX scaleY) $ - withTexture (sampledImageTexture img) $ fill rect - stroke borderSize (JoinMiter 0) - (CapStraight 0, CapStraight 0) rect' - where - p = ip ^-^ V2 0.5 0.5 - rect = rectangle (V2 0 0) rw rh - rect' = rectangle p reqWidth reqHeight - - (rw, rh) = (fromIntegral w, fromIntegral h) - scaleX | reqWidth == 0 = 1 - | otherwise = reqWidth / rw - - scaleY | reqHeight == 0 = 1 - | otherwise = reqHeight / rh - --- | Generate a list of primitive representing a rectangle --- with rounded corner. --- --- > fill $ roundedRectangle (V2 10 10) 150 150 20 10 --- --- <> --- -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) --- --- <> --- -line :: Point -> Point -> [Primitive] -line p1 p2 = [LinePrim $ Line p1 p2] - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +-- | Main module of Rasterific, an Haskell rasterization engine. +-- +-- Creating an image is rather simple, here is a simple example +-- of a drawing and saving it in a PNG file: +-- +-- > import Codec.Picture( PixelRGBA8( .. ), writePng ) +-- > import Graphics.Rasterific +-- > import Graphics.Rasterific.Texture +-- > +-- > main :: IO () +-- > main = do +-- > let white = PixelRGBA8 255 255 255 255 +-- > drawColor = PixelRGBA8 0 0x86 0xc1 255 +-- > recColor = PixelRGBA8 0xFF 0x53 0x73 255 +-- > img = renderDrawing 400 200 white $ +-- > withTexture (uniformTexture drawColor) $ do +-- > fill $ circle (V2 0 0) 30 +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > circle (V2 400 200) 40 +-- > withTexture (uniformTexture recColor) . +-- > fill $ rectangle (V2 100 100) 200 100 +-- > +-- > writePng "yourimage.png" img +-- +-- <> +-- +-- 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: +-- +-- <> +-- +module Graphics.Rasterific + ( + -- * Rasterization command + -- ** Filling + fill + , fillWithMethod + -- ** Stroking + , stroke + , dashedStroke + , dashedStrokeWithOffset + -- ** Text rendering + , printTextAt + , printTextRanges + -- ** Texturing + , withTexture + , withClipping + , withGroupOpacity + -- ** Transformations + , withTransformation + , withPathOrientation + , TextRange( .. ) + , PointSize( .. ) + + -- * Generating images + , ModulablePixel + , RenderablePixel + , renderDrawing + , renderDrawingAtDpi + , pathToPrimitives + + -- * Rasterization types + , Texture + , Drawing + , Modulable + + -- * Geometry description + , V2( .. ) + , Point + , Vector + , CubicBezier( .. ) + , Line( .. ) + , Bezier( .. ) + , Primitive( .. ) + , Path( .. ) + , PathCommand( .. ) + + -- * Generic geometry description + , Primitivable( .. ) + , Geometry( .. ) + + -- * Generic geometry manipulation + , Transformable( .. ) + , PointFoldable( .. ) + , PlaneBoundable( .. ) + , PlaneBound( .. ) + , boundWidth + , boundHeight + , boundLowerLeftCorner + + -- * Helpers + -- ** line + , line + -- ** Rectangle + , rectangle + , roundedRectangle + -- ** Circles + , circle + , ellipse + -- ** Polygons + , polyline + , polygon + -- ** Images + , drawImageAtSize + , drawImage + , cacheDrawing + + -- ** Geometry Helpers + , clip + , bezierFromPath + , lineFromPath + , cubicBezierFromPath + , firstTangeantOf + , lastTangeantOf + , firstPointOf + , lastPointOf + + -- * Rasterization control + , Join( .. ) + , Cap( .. ) + , SamplerRepeat( .. ) + , FillMethod( .. ) + , DashPattern + , drawOrdersOfDrawing + + -- * Debugging helper + , dumpDrawing + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +import Data.Foldable( foldMap ) +import Data.Monoid( Monoid( .. ) ) +#endif + +import Data.Monoid( (<>) ) + +import Control.Monad.Free( Free( .. ), liftF ) +import Control.Monad.Free.Church( fromF ) +import Control.Monad.ST( runST ) +import Control.Monad.State( modify, execState ) +import Data.Maybe( fromMaybe ) +import Codec.Picture.Types( Image( .. ) + , Pixel( .. ) + , unpackPixel + , pixelMapXY ) + +import qualified Data.Vector.Unboxed as VU +import Graphics.Rasterific.Compositor +import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^), (^*) ) +import Graphics.Rasterific.Rasterize +import Graphics.Rasterific.Texture +import Graphics.Rasterific.Shading +import Graphics.Rasterific.Types +import Graphics.Rasterific.Line +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.StrokeInternal +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.PlaneBoundable +import Graphics.Rasterific.Immediate +import Graphics.Rasterific.PathWalker +import Graphics.Rasterific.Command +{-import Graphics.Rasterific.TensorPatch-} + +import Graphics.Text.TrueType( Font + , Dpi + , PointSize( .. ) + , getStringCurveAtPoint ) + +{-import Debug.Trace-} +{-import Text.Printf-} + +------------------------------------------------ +---- Free Monad DSL section +------------------------------------------------ + +-- | Define the texture applyied to all the children +-- draw call. +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ do +-- > fill $ circle (V2 50 50) 20 +-- > fill $ circle (V2 100 100) 20 +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) +-- > $ circle (V2 150 150) 20 +-- +-- <> +-- +withTexture :: Texture px -> Drawing px () -> Drawing px () +withTexture texture subActions = + liftF $ SetTexture texture subActions () + +-- | Will render the whole subaction with a given group opacity, after +-- each element has been rendered. That means that completly opaque +-- overlapping shapes will be rendered transparently, not one after +-- another. +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ +-- > stroke 3 JoinRound (CapRound, CapRound) $ +-- > line (V2 0 100) (V2 200 100) +-- > +-- > withGroupOpacity 128 $ do +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) . +-- > fill $ circle (V2 70 100) 60 +-- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255) . +-- > fill $ circle (V2 120 100) 60 +-- +-- <> +-- +-- To be compared to the item opacity +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) $ +-- > stroke 3 JoinRound (CapRound, CapRound) $ +-- > line (V2 0 100) (V2 200 100) +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 128) . +-- > fill $ circle (V2 70 100) 60 +-- > withTexture (uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 128) . +-- > fill $ circle (V2 120 100) 60 +-- +-- <> +withGroupOpacity :: Pixel px => PixelBaseComponent px -> Drawing px ()-> Drawing px () +withGroupOpacity opa sub = + liftF $ WithGlobalOpacity opa sub () + +-- | Draw all the sub drawing commands using a transformation. +withTransformation :: Transformation -> Drawing px () -> Drawing px () +withTransformation trans sub = + liftF $ WithTransform trans sub () + +-- | This command allows you to draw primitives on a given curve, +-- for example, you can draw text on a curve: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > withPathOrientation path 0 $ +-- > printTextAt font (PointSize 24) (V2 0 0) "Text on path" +-- +-- <> +-- +-- You can note that the position of the baseline match the size of the +-- characters. +-- +-- You are not limited to text drawing while using this function, +-- you can draw arbitrary geometry like in the following example: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) path +-- > +-- > withPathOrientation path 0 $ do +-- > printTextAt font (PointSize 24) (V2 0 0) "TX" +-- > fill $ rectangle (V2 (-10) (-10)) 30 20 +-- > fill $ rectangle (V2 45 0) 10 20 +-- > fill $ rectangle (V2 60 (-10)) 20 20 +-- > fill $ rectangle (V2 100 (-15)) 20 50 +-- +-- <> +-- +withPathOrientation :: Path -- ^ Path directing the orientation. + -> Float -- ^ Basline Y axis position, used to align text properly. + -> Drawing px () -- ^ The sub drawings. + -> Drawing px () +withPathOrientation path p sub = + liftF $ WithPathOrientation path p sub () + +-- | Fill some geometry. The geometry should be "looping", +-- ie. the last point of the last primitive should +-- be equal to the first point of the first primitive. +-- +-- The primitive should be connected. +-- +-- > fill $ circle (V2 100 100) 75 +-- +-- <> +-- +fill :: Geometry geom => geom -> Drawing px () +fill prims = liftF $ Fill FillWinding (toPrimitives prims) () + +-- | This function let you choose how to fill the primitives +-- in case of self intersection. See `FillMethod` documentation +-- for more information. +fillWithMethod :: Geometry geom + => FillMethod -> geom -> Drawing px () +fillWithMethod method prims = + liftF $ Fill method (toPrimitives prims) () + +-- | Draw some geometry using a clipping path. +-- +-- > withClipping (fill $ circle (V2 100 100) 75) $ +-- > mapM_ (stroke 7 JoinRound (CapRound, CapRound)) +-- > [line (V2 0 yf) (V2 200 (yf + 10)) +-- > | y <- [5 :: Int, 17 .. 200] +-- > , let yf = fromIntegral y ] +-- +-- <> +-- +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 +-- +-- <> +-- +stroke :: (Geometry geom) + => Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +stroke width join caping prims = + liftF $ Stroke width join caping (toPrimitives prims) () + +-- | Draw a string at a given position. +-- Text printing imply loading a font, there is no default +-- font (yet). Below an example of font rendering using a +-- font installed on Microsoft Windows. +-- +-- > import Graphics.Text.TrueType( loadFontFile ) +-- > import Codec.Picture( PixelRGBA8( .. ), writePng ) +-- > import Graphics.Rasterific +-- > import Graphics.Rasterific.Texture +-- > +-- > main :: IO () +-- > main = do +-- > fontErr <- loadFontFile "test_fonts/DejaVuSans.ttf" +-- > case fontErr of +-- > Left err -> putStrLn err +-- > Right font -> +-- > writePng "text_example.png" . +-- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) +-- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > printTextAt font (PointSize 12) (V2 20 40) +-- > "A simple text test!" +-- +-- <> +-- +-- You can use any texture, like a gradient while rendering text. +-- +printTextAt :: Font -- ^ Drawing font + -> PointSize -- ^ font Point size + -> Point -- ^ Drawing starting point (base line) + -> String -- ^ String to print + -> Drawing px () +printTextAt font pointSize point string = + liftF $ TextFill point [description] () + where + description = TextRange + { _textFont = font + , _textSize = pointSize + , _text = string + , _textTexture = Nothing + } + +-- | Print complex text, using different texture font and +-- point size for different parts of the text. +-- +-- > let blackTexture = +-- > Just . uniformTexture $ PixelRGBA8 0 0 0 255 +-- > redTexture = +-- > Just . uniformTexture $ PixelRGBA8 255 0 0 255 +-- > in +-- > printTextRanges (V2 20 40) +-- > [ TextRange font1 (PointSize 12) "A complex " blackTexture +-- > , TextRange font2 (PointSize 8) "text test" redTexture] +-- +-- <> +-- +printTextRanges :: Point -- ^ Starting point of the base line + -> [TextRange px] -- ^ Ranges description to be printed + -> Drawing px () +printTextRanges point ranges = liftF $ TextFill point ranges () + +data RenderContext px = RenderContext + { currentClip :: Maybe (Texture (PixelBaseComponent px)) + , currentTexture :: Texture px + , currentTransformation :: Maybe (Transformation, Transformation) + } + +-- | Function to call in order to start the image creation. +-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types +-- in other colorspace will probably produce weird results. +-- Default DPI is 96 +renderDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> Image px +renderDrawing width height = renderDrawingAtDpi width height 96 + +-- | Function to call in order to start the image creation. +-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types +-- in other colorspace will probably produce weird results. +renderDrawingAtDpi + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> Image px +renderDrawingAtDpi width height dpi background drawing = + runST $ runDrawContext width height background + $ mapM_ fillOrder + $ drawOrdersOfDrawing width height dpi background drawing + +emptyPx :: (RenderablePixel px) => px +-- | Really need a "builder" function for pixel +emptyPx = colorMap (const emptyValue) $ unpackPixel 0 + +cacheOrders :: forall px. (RenderablePixel px) + => Maybe (Image px -> ImageTransformer px) -> [DrawOrder px] -> Drawing px () +cacheOrders imageFilter orders = case imageFilter of + Nothing -> drawImage resultImage 0 mini + Just f -> drawImage (pixelMapXY (f resultImage) resultImage) 0 mini + where + PlaneBound mini maxi = foldMap planeBounds orders + cornerUpperLeftInt = floor <$> mini :: V2 Int + cornerUpperLeft = fromIntegral <$> cornerUpperLeftInt + + V2 width height = maxi ^-^ cornerUpperLeft ^+^ V2 1 1 + + shiftOrder order@DrawOrder { _orderPrimitives = prims } = + order { _orderPrimitives = fmap (transform (^-^ cornerUpperLeft)) <$> prims } + + resultImage = + runST $ runDrawContext (ceiling width) (ceiling height) emptyPx + $ mapM_ fillOrder + $ shiftOrder <$> orders + +-- | This function perform an optimisation, it will render a drawing +-- to an image interanlly and create a new order to render this image +-- instead of the geometry, effectively cuting the geometry generation +-- part. +-- +-- It can save execution time when drawing complex elements multiple +-- times. +cacheDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Max rendering width + -> Int -- ^ Max rendering height + -> Dpi + -> Drawing px () + -> Drawing px () +cacheDrawing maxWidth maxHeight dpi sub = + cacheOrders Nothing $ drawOrdersOfDrawing maxWidth maxHeight dpi emptyPx sub + +-- | Transform a drawing into a serie of low-level drawing orders. +drawOrdersOfDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current assumed DPI + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> [DrawOrder px] +drawOrdersOfDrawing width height dpi background drawing = + go initialContext (fromF drawing) [] + where + initialContext = RenderContext Nothing stupidDefaultTexture Nothing + clipBackground = emptyValue :: PixelBaseComponent px + clipForeground = fullValue :: PixelBaseComponent px + + clipRender = + renderDrawing width height clipBackground + . withTexture (uniformTexture clipForeground) + + textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } = + transformTexture t $ currentTexture ctxt + textureOf ctxt = currentTexture ctxt + + geometryOf RenderContext { currentTransformation = Just (trans, _) } = + transform (applyTransformation trans) + geometryOf _ = id + + stupidDefaultTexture = + uniformTexture $ colorMap (const clipBackground) background + + go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px] + -> [DrawOrder px] + go _ (Pure ()) rest = rest + go ctxt (Free (WithGlobalOpacity opa sub next)) rest = + go ctxt (Free (WithImageEffect opacifier sub next)) rest + where + -- Todo: a colorMapWithAlpha is really needed in JP API. + opacifier _ _ _ px = mixWithAlpha ignore alphaModulate px px + ignore _ _ a = a + alphaModulate _ v = opa `modulate` v + + go ctxt (Free (WithImageEffect effect sub next)) rest = + go freeContext (fromF cached) after + where + cached = cacheOrders (Just effect) $ go ctxt (fromF sub) [] + after = go ctxt next rest + freeContext = ctxt { currentClip = Nothing, currentTransformation = Nothing } + + + go ctxt (Free (WithPathOrientation path base sub next)) rest = final where + final = orders <> go ctxt next rest + images = go ctxt (fromF sub) [] + + drawer trans _ order = modify $ \lst -> finalOrder : lst + where + toFinalPos = transform $ applyTransformation trans + finalOrder = + order { _orderPrimitives = toFinalPos $ _orderPrimitives order } + orders = reverse $ execState (drawOrdersOnPath drawer 0 base path images) [] + + go ctxt (Free (WithTransform trans sub next)) rest = final where + trans' + | Just (t, _) <- currentTransformation ctxt = t <> trans + | otherwise = trans + invTrans = fromMaybe mempty $ inverseTransformation trans' + after = go ctxt next rest + subContext = + ctxt { currentTransformation = Just (trans', invTrans) } + + final = go subContext (fromF sub) after + + go ctxt (Free (Fill method prims next)) rest = order : after where + after = go ctxt next rest + order = DrawOrder + { _orderPrimitives = [geometryOf ctxt prims] + , _orderTexture = textureOf ctxt + , _orderFillMethod = method + , _orderMask = currentClip ctxt + } + + go ctxt (Free (Stroke w j cap prims next)) rest = + go ctxt (Free $ Fill FillWinding prim' next) rest + where prim' = listOfContainer $ strokize w j cap prims + + go ctxt (Free (SetTexture tx sub next)) rest = + go (ctxt { currentTexture = tx }) (fromF sub) $ go ctxt next rest + + go ctxt (Free (DashedStroke o d w j cap prims next)) rest = + foldr recurse after $ dashedStrokize o d w j cap prims + where + after = go ctxt next rest + recurse sub = + go ctxt (liftF $ Fill FillWinding sub ()) + + go ctxt (Free (TextFill (V2 x y) descriptions next)) rest = + go ctxt (sequence_ drawCalls) $ go ctxt next rest + where + floatCurves = + getStringCurveAtPoint dpi (x, y) + [(_textFont d, _textSize d, _text d) | d <- descriptions] + + linearDescriptions = + concat [map (const d) $ _text d | d <- descriptions] + + drawCalls = + [texturize d $ beziersOfChar curve + | (curve, d) <- zip floatCurves linearDescriptions] + + texturize descr sub = case _textTexture descr of + Nothing -> fromF sub + Just t -> liftF $ SetTexture t sub () + + beziersOfChar curves = liftF $ Fill FillWinding bezierCurves () + where + bezierCurves = concat + [map BezierPrim . bezierFromPath . map (uncurry V2) + $ VU.toList c | c <- curves] + + go ctxt (Free (WithCliping clipPath path next)) rest = + go (ctxt { currentClip = newModuler }) (fromF path) $ + go ctxt next rest + where + modulationTexture :: Texture (PixelBaseComponent px) + modulationTexture = RawTexture $ clipRender clipPath + + newModuler = Just . subModuler $ currentClip ctxt + + subModuler Nothing = modulationTexture + subModuler (Just v) = + modulateTexture v modulationTexture + +-- | With stroke geometry with a given stroke width, using +-- a dash pattern. +-- +-- > dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ +-- > line (V2 0 100) (V2 200 100) +-- +-- <> +-- +dashedStroke + :: Geometry geom + => DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +dashedStroke = dashedStrokeWithOffset 0.0 + +-- | With stroke geometry with a given stroke width, using +-- a dash pattern. The offset is there to specify the starting +-- point into the pattern, the value can be negative. +-- +-- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) $ +-- > line (V2 0 100) (V2 200 100) +-- +-- <> +-- +dashedStrokeWithOffset + :: Geometry geom + => Float -- ^ Starting offset + -> DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ List of elements to render + -> Drawing px () +dashedStrokeWithOffset _ [] width join caping prims = + stroke width join caping prims +dashedStrokeWithOffset offset dashing width join caping prims = + liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) () + +-- | Generate a list of primitive representing a circle. +-- +-- > fill $ circle (V2 100 100) 75 +-- +-- <> +-- +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 +-- +-- <> +-- +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] +-- +-- <> +-- +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] +-- +-- <> +-- +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 +-- +-- <> +-- +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) +-- +-- <> +-- +drawImage :: ModulablePixel px + => Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Drawing px () +drawImage img@Image { imageWidth = w, imageHeight = h } s p = + drawImageAtSize img s p (fromIntegral w) (fromIntegral h) + +-- | Draw an image with the desired size +-- +-- > drawImageAtSize textureImage 2 (V2 30 30) 128 128 +-- +-- <> +-- +drawImageAtSize :: (Pixel px, Modulable (PixelBaseComponent px)) + => Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Float -- ^ Width of the drawn image + -> Float -- ^ Height of the drawn image + -> Drawing px () +drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize ip + reqWidth reqHeight + | borderSize <= 0 = + withTransformation (translate p <> scale scaleX scaleY) . + withTexture (sampledImageTexture img) $ fill rect + | otherwise = do + withTransformation (translate p <> scale scaleX scaleY) $ + withTexture (sampledImageTexture img) $ fill rect + stroke borderSize (JoinMiter 0) + (CapStraight 0, CapStraight 0) rect' + where + p = ip ^-^ V2 0.5 0.5 + rect = rectangle (V2 0 0) rw rh + rect' = rectangle p reqWidth reqHeight + + (rw, rh) = (fromIntegral w, fromIntegral h) + scaleX | reqWidth == 0 = 1 + | otherwise = reqWidth / rw + + scaleY | reqHeight == 0 = 1 + | otherwise = reqHeight / rh + +-- | Generate a list of primitive representing a rectangle +-- with rounded corner. +-- +-- > fill $ roundedRectangle (V2 10 10) 150 150 20 10 +-- +-- <> +-- +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) +-- +-- <> +-- +line :: Point -> Point -> [Primitive] +line p1 p2 = [LinePrim $ Line p1 p2] + diff --git a/src/Graphics/Rasterific/Command.hs b/src/Graphics/Rasterific/Command.hs --- a/src/Graphics/Rasterific/Command.hs +++ b/src/Graphics/Rasterific/Command.hs @@ -1,131 +1,141 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Graphics.Rasterific.Command ( Drawing - , DrawCommand( .. ) - , TextRange( .. ) - , dumpDrawing - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( Monoid( .. ) ) -#endif - -import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.Free.Church( F, fromF ) -import Codec.Picture.Types( Pixel( .. ), Pixel8 ) - -import Graphics.Rasterific.Types -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Shading - -import Graphics.Text.TrueType( Font, PointSize ) - --- | Monad used to record the drawing actions. -type Drawing px = F (DrawCommand px) - --- | Structure defining how to render a text range -data TextRange px = TextRange - { _textFont :: Font -- ^ Font used during the rendering - , _textSize :: PointSize -- ^ Size of the text (in pixels) - , _text :: String -- ^ Text to draw - -- | Texture to use for drawing, if Nothing, the currently - -- active texture is used. - , _textTexture :: Maybe (Texture px) - } - -data DrawCommand px next - = Fill FillMethod [Primitive] next - | Stroke Float Join (Cap, Cap) [Primitive] next - | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next - | TextFill Point [TextRange px] next - | SetTexture (Texture px) - (Drawing px ()) next - | WithCliping (forall innerPixel. Drawing innerPixel ()) - (Drawing px ()) next - | WithTransform Transformation (Drawing px ()) next - | WithPathOrientation Path Float (Drawing px ()) next - --- | This function will spit out drawing instructions to --- help debugging. --- --- The outputted code looks like Haskell, but there is no --- guarantee that it is compilable. -dumpDrawing :: ( Show px - , Show (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - - ) => Drawing px () -> String -dumpDrawing = go . fromF where - go :: - ( Show px - , Show (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - - ) => Free (DrawCommand px) () -> String - go (Pure ()) = "return ()" - go (Free (WithPathOrientation path point drawing next)) = - "withPathOrientation (" ++ show path ++ ") (" - ++ show point ++ ") (" - ++ go (fromF drawing) ++ ") >>= " - ++ go next - go (Free (Fill _ prims next)) = - "fill " ++ show prims ++ " >>=\n" ++ go next - go (Free (TextFill _ texts next)) = - concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next - go (Free (SetTexture tx drawing next)) = - "withTexture (" ++ dumpTexture tx ++ ") (" ++ - go (fromF drawing) ++ ") >>=\n" ++ go next - go (Free (DashedStroke o pat w j cap prims next)) = - "dashedStrokeWithOffset " - ++ show o ++ " " - ++ show pat ++ " " - ++ show w ++ " (" - ++ show j ++ ") " - ++ show cap ++ " " - ++ show prims ++ " >>=\n" ++ go next - go (Free (Stroke w j cap prims next)) = - "stroke " ++ show w ++ " (" - ++ show j ++ ") " - ++ show cap ++ " " - ++ show prims ++ " >>=\n" ++ go next - go (Free (WithTransform trans sub next)) = - "withTransform (" ++ show trans ++ ") (" - ++ go (fromF sub) ++ ") >>=\n " - ++ go next - go (Free (WithCliping clipping draw next)) = - "withClipping (" ++ go (fromF $ withTexture clipTexture clipping) - ++ ")\n" ++ - " (" ++ go (fromF draw) ++ ")\n >>= " ++ - go next - where clipTexture = uniformTexture (0xFF :: Pixel8) - withTexture texture subActions = - liftF $ SetTexture texture subActions () - - -instance Functor (DrawCommand px) where - fmap f (TextFill pos texts next) = - TextFill pos texts $ f next - fmap f (Fill method prims next) = Fill method prims $ f next - fmap f (SetTexture t sub next) = SetTexture t sub $ f next - fmap f (WithCliping sub com next) = - WithCliping sub com $ f next - fmap f (Stroke w j caps prims next) = - Stroke w j caps prims $ f next - fmap f (DashedStroke st pat w j caps prims next) = - DashedStroke st pat w j caps prims $ f next - fmap f (WithTransform trans draw next) = - WithTransform trans draw $ f next - fmap f (WithPathOrientation path point draw next) = - WithPathOrientation path point draw $ f next - -instance Monoid (Drawing px ()) where - mempty = return () - mappend a b = a >> b - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Command ( Drawing + , DrawCommand( .. ) + , TextRange( .. ) + , dumpDrawing + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid( .. ) ) +#endif + +import Control.Monad.Free( Free( .. ), liftF ) +import Control.Monad.Free.Church( F, fromF ) +import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 ) + +import Graphics.Rasterific.Types +import Graphics.Rasterific.Texture +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Shading + +import Graphics.Text.TrueType( Font, PointSize ) + +-- | Monad used to record the drawing actions. +type Drawing px = F (DrawCommand px) + +-- | Structure defining how to render a text range +data TextRange px = TextRange + { _textFont :: Font -- ^ Font used during the rendering + , _textSize :: PointSize -- ^ Size of the text (in pixels) + , _text :: String -- ^ Text to draw + -- | Texture to use for drawing, if Nothing, the currently + -- active texture is used. + , _textTexture :: Maybe (Texture px) + } + +data DrawCommand px next + = Fill FillMethod [Primitive] next + | Stroke Float Join (Cap, Cap) [Primitive] next + | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next + | TextFill Point [TextRange px] next + | SetTexture (Texture px) + (Drawing px ()) next + | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next + | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next + | WithCliping (forall innerPixel. Drawing innerPixel ()) + (Drawing px ()) next + | WithTransform Transformation (Drawing px ()) next + | WithPathOrientation Path Float (Drawing px ()) next + +-- | This function will spit out drawing instructions to +-- help debugging. +-- +-- The outputted code looks like Haskell, but there is no +-- guarantee that it is compilable. +dumpDrawing :: ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + + ) => Drawing px () -> String +dumpDrawing = go . fromF where + go :: + ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + + ) => Free (DrawCommand px) () -> String + go (Pure ()) = "return ()" + go (Free (WithImageEffect _effect sub next)) = + "withImageEffect ({- fun -}) (" ++ go (fromF sub) ++ ") >>= " ++ go next + go (Free (WithGlobalOpacity opa sub next)) = + "withGlobalOpacity " ++ show opa ++ " (" ++ go (fromF sub) ++ ") >>= " ++ go next + go (Free (WithPathOrientation path point drawing next)) = + "withPathOrientation (" ++ show path ++ ") (" + ++ show point ++ ") (" + ++ go (fromF drawing) ++ ") >>= " + ++ go next + go (Free (Fill _ prims next)) = + "fill " ++ show prims ++ " >>=\n" ++ go next + go (Free (TextFill _ texts next)) = + concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next + go (Free (SetTexture tx drawing next)) = + "withTexture (" ++ dumpTexture tx ++ ") (" ++ + go (fromF drawing) ++ ") >>=\n" ++ go next + go (Free (DashedStroke o pat w j cap prims next)) = + "dashedStrokeWithOffset " + ++ show o ++ " " + ++ show pat ++ " " + ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ go next + go (Free (Stroke w j cap prims next)) = + "stroke " ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ go next + go (Free (WithTransform trans sub next)) = + "withTransform (" ++ show trans ++ ") (" + ++ go (fromF sub) ++ ") >>=\n " + ++ go next + go (Free (WithCliping clipping draw next)) = + "withClipping (" ++ go (fromF $ withTexture clipTexture clipping) + ++ ")\n" ++ + " (" ++ go (fromF draw) ++ ")\n >>= " ++ + go next + where clipTexture = uniformTexture (0xFF :: Pixel8) + withTexture texture subActions = + liftF $ SetTexture texture subActions () + + +instance Functor (DrawCommand px) where + fmap f (WithImageEffect effect sub next) = + WithImageEffect effect sub $ f next + fmap f (TextFill pos texts next) = + TextFill pos texts $ f next + fmap f (WithGlobalOpacity opa sub next) = + WithGlobalOpacity opa sub $ f next + fmap f (Fill method prims next) = Fill method prims $ f next + fmap f (SetTexture t sub next) = SetTexture t sub $ f next + fmap f (WithCliping sub com next) = + WithCliping sub com $ f next + fmap f (Stroke w j caps prims next) = + Stroke w j caps prims $ f next + fmap f (DashedStroke st pat w j caps prims next) = + DashedStroke st pat w j caps prims $ f next + fmap f (WithTransform trans draw next) = + WithTransform trans draw $ f next + fmap f (WithPathOrientation path point draw next) = + WithPathOrientation path point draw $ f next + +instance Monoid (Drawing px ()) where + mempty = return () + mappend a b = a >> b + diff --git a/src/Graphics/Rasterific/Compositor.hs b/src/Graphics/Rasterific/Compositor.hs --- a/src/Graphics/Rasterific/Compositor.hs +++ b/src/Graphics/Rasterific/Compositor.hs @@ -1,151 +1,153 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} --- | Compositor handle the pixel composition, which --- leads to texture composition. --- Very much a work in progress -module Graphics.Rasterific.Compositor - ( Compositor - , Modulable( .. ) - , ModulablePixel - , RenderablePixel - , compositionDestination - , compositionAlpha - ) where - -import Foreign.Storable( Storable ) -import Data.Bits( unsafeShiftR ) -import Data.Word( Word8, Word32 ) - -import Codec.Picture.Types( Pixel( .. ), PackeablePixel( .. ) ) - -type Compositor px = - PixelBaseComponent px -> - PixelBaseComponent px -> px -> px -> px - --- | This constraint ensure that a type is a pixel --- and we're allowed to modulate it's color components --- generically. -type ModulablePixel px = - ( Pixel px - , PackeablePixel px - , Storable (PackedRepresentation px) - , Modulable (PixelBaseComponent px)) - --- | This constraint tells us that pixel component --- must also be pixel and be the "bottom" of component, --- we cannot go further than a PixelBaseComponent level. --- --- All pixel instances of JuicyPixels should be usable. -type RenderablePixel px = - ( ModulablePixel px - , Pixel (PixelBaseComponent px) - , PackeablePixel (PixelBaseComponent px) - , Storable (PackedRepresentation (PixelBaseComponent px)) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - ) - --- | Typeclass intented at pixel value modulation. --- May be throwed out soon. -class (Ord a, Num a) => Modulable a where - -- | Empty value representing total transparency for the given type. - emptyValue :: a - -- | Full value representing total opacity for a given type. - fullValue :: a - -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue] - -- The second value is the inverse coverage - clampCoverage :: Float -> (a, a) - - -- | Modulate two elements, staying in the [emptyValue; fullValue] range. - modulate :: a -> a -> a - - -- | Implement a division between two elements. - modiv :: a -> a -> a - - alphaOver :: a -- ^ coverage - -> a -- ^ inverse coverage - -> a -- ^ background - -> a -- ^ foreground - -> a - alphaCompose :: a -> a -> a -> a -> a - - -- | Like modulate but also return the inverse coverage. - coverageModulate :: a -> a -> (a, a) - coverageModulate c a = (clamped, fullValue - clamped) - where clamped = modulate a c - -instance Modulable Float where - emptyValue = 0 - fullValue = 1 - clampCoverage f = (f, 1 - f) - modulate = (*) - modiv = (/) - alphaCompose coverage inverseCoverage backAlpha _ = - coverage + backAlpha * inverseCoverage - alphaOver coverage inverseCoverage background painted = - coverage * painted + background * inverseCoverage - -div255 :: Word32 -> Word32 -{-# INLINE div255 #-} -div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 - -instance Modulable Word8 where - {-# INLINE emptyValue #-} - emptyValue = 0 - {-# INLINE fullValue #-} - fullValue = 255 - {-# INLINE clampCoverage #-} - clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) - where c = toWord8 f - - {-# INLINE modulate #-} - modulate c a = fromIntegral . div255 $ fi c * fi a + 128 - where fi :: Word8 -> Word32 - fi = fromIntegral - - {-# INLINE modiv #-} - modiv c 0 = c - modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a - where fi :: Word8 -> Word32 - fi = fromIntegral - - {-# INLINE alphaCompose #-} - alphaCompose coverage inverseCoverage backgroundAlpha _ = - fromIntegral $ div255 v - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi coverage * 255 - + fi backgroundAlpha * fi inverseCoverage + 128 - - {-# INLINE alphaOver #-} - alphaOver coverage inverseCoverage background painted = - fromIntegral $ div255 v - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 - - -toWord8 :: Float -> Int -{-# INLINE toWord8 #-} -toWord8 r = floor $ r * 255 + 0.5 - -compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -compositionDestination c _ _ = colorMap (modulate c) - -compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -{-# INLINE compositionAlpha #-} -compositionAlpha c ic - | c == emptyValue = const - | c == fullValue = \_ n -> n - | otherwise = \bottom top -> - let bottomOpacity = pixelOpacity bottom - alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top) - colorComposer _ back fore = - alphaOver c ic (back `modulate` bottomOpacity) fore - `modiv` alphaOut - in - mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- | Compositor handle the pixel composition, which +-- leads to texture composition. +-- Very much a work in progress +module Graphics.Rasterific.Compositor + ( Compositor + , Modulable( .. ) + , ModulablePixel + , RenderablePixel + , compositionDestination + , compositionAlpha + ) where + +import Foreign.Storable( Storable ) +import Data.Bits( unsafeShiftR ) +import Data.Word( Word8, Word32 ) + +import Codec.Picture.Types( Pixel( .. ), PackeablePixel( .. ) ) + +type Compositor px = + PixelBaseComponent px -> + PixelBaseComponent px -> px -> px -> px + +-- | This constraint ensure that a type is a pixel +-- and we're allowed to modulate it's color components +-- generically. +type ModulablePixel px = + ( Pixel px + , PackeablePixel px + , Storable (PackedRepresentation px) + , Modulable (PixelBaseComponent px)) + +-- | This constraint tells us that pixel component +-- must also be pixel and be the "bottom" of component, +-- we cannot go further than a PixelBaseComponent level. +-- +-- All pixel instances of JuicyPixels should be usable. +type RenderablePixel px = + ( ModulablePixel px + , Pixel (PixelBaseComponent px) + , PackeablePixel (PixelBaseComponent px) + , Num (PackedRepresentation px) + , Num (PackedRepresentation (PixelBaseComponent px)) + , Storable (PackedRepresentation (PixelBaseComponent px)) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + ) + +-- | Typeclass intented at pixel value modulation. +-- May be throwed out soon. +class (Ord a, Num a) => Modulable a where + -- | Empty value representing total transparency for the given type. + emptyValue :: a + -- | Full value representing total opacity for a given type. + fullValue :: a + -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue] + -- The second value is the inverse coverage + clampCoverage :: Float -> (a, a) + + -- | Modulate two elements, staying in the [emptyValue; fullValue] range. + modulate :: a -> a -> a + + -- | Implement a division between two elements. + modiv :: a -> a -> a + + alphaOver :: a -- ^ coverage + -> a -- ^ inverse coverage + -> a -- ^ background + -> a -- ^ foreground + -> a + alphaCompose :: a -> a -> a -> a -> a + + -- | Like modulate but also return the inverse coverage. + coverageModulate :: a -> a -> (a, a) + coverageModulate c a = (clamped, fullValue - clamped) + where clamped = modulate a c + +instance Modulable Float where + emptyValue = 0 + fullValue = 1 + clampCoverage f = (f, 1 - f) + modulate = (*) + modiv = (/) + alphaCompose coverage inverseCoverage backAlpha _ = + coverage + backAlpha * inverseCoverage + alphaOver coverage inverseCoverage background painted = + coverage * painted + background * inverseCoverage + +div255 :: Word32 -> Word32 +{-# INLINE div255 #-} +div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + +instance Modulable Word8 where + {-# INLINE emptyValue #-} + emptyValue = 0 + {-# INLINE fullValue #-} + fullValue = 255 + {-# INLINE clampCoverage #-} + clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) + where c = toWord8 f + + {-# INLINE modulate #-} + modulate c a = fromIntegral . div255 $ fi c * fi a + 128 + where fi :: Word8 -> Word32 + fi = fromIntegral + + {-# INLINE modiv #-} + modiv c 0 = c + modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a + where fi :: Word8 -> Word32 + fi = fromIntegral + + {-# INLINE alphaCompose #-} + alphaCompose coverage inverseCoverage backgroundAlpha _ = + fromIntegral $ div255 v + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi coverage * 255 + + fi backgroundAlpha * fi inverseCoverage + 128 + + {-# INLINE alphaOver #-} + alphaOver coverage inverseCoverage background painted = + fromIntegral $ div255 v + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 + + +toWord8 :: Float -> Int +{-# INLINE toWord8 #-} +toWord8 r = floor $ r * 255 + 0.5 + +compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) + => Compositor px +compositionDestination c _ _ = colorMap (modulate c) + +compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) + => Compositor px +{-# INLINE compositionAlpha #-} +compositionAlpha c ic + | c == emptyValue = const + | c == fullValue = \_ n -> n + | otherwise = \bottom top -> + let bottomOpacity = pixelOpacity bottom + alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top) + colorComposer _ back fore = + alphaOver c ic (back `modulate` bottomOpacity) fore + `modiv` alphaOut + in + mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top + diff --git a/src/Graphics/Rasterific/CubicBezier.hs b/src/Graphics/Rasterific/CubicBezier.hs --- a/src/Graphics/Rasterific/CubicBezier.hs +++ b/src/Graphics/Rasterific/CubicBezier.hs @@ -1,349 +1,349 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Graphics.Rasterific.CubicBezier - ( cubicBezierCircle - , cubicBezierFromPath - , cubicBezierBreakAt - , clipCubicBezier - , decomposeCubicBeziers - , sanitizeCubicBezier - , offsetCubicBezier - , flattenCubicBezier - , cubicBezierLengthApproximation - , cubicBezierBounds - ) where - -import Prelude hiding( or ) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( mempty ) -#endif - -import Data.Monoid( (<>) ) -import Control.Applicative( liftA2, (<$>)) -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , norm - , lerp - ) -import Data.List( nub ) -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticFormula - --- | Create a list of cubic bezier patch from a list of points. --- --- > cubicBezierFromPath [a, b, c, d, e] = [CubicBezier a b c d] --- > cubicBezierFromPath [a, b, c, d, e, f, g] = --- > [CubicBezier a b c d, CubicBezier d e f g] --- -cubicBezierFromPath :: [Point] -> [CubicBezier] -cubicBezierFromPath (a:b:c:rest@(d:_)) = - CubicBezier a b c d : cubicBezierFromPath rest -cubicBezierFromPath _ = [] - -cubicBezierLengthApproximation :: CubicBezier -> Float -cubicBezierLengthApproximation (CubicBezier a _ _ d) = - norm $ d ^-^ a - --- | Represent a circle of radius 1 centered on 0 of --- a cubic bezier curve. -cubicBezierCircle :: [CubicBezier] -cubicBezierCircle = - [ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0) - , CubicBezier (V2 1 0) (V2 1 (-c)) (V2 c (-1)) (V2 0 (-1)) - , CubicBezier (V2 0 (-1)) (V2 (-c) (-1)) (V2 (-1) (-c)) (V2 (-1) 0) - , CubicBezier (V2 (-1) 0) (V2 (-1) c) (V2 (-c) 1) (V2 0 1) - ] - where c = 0.551915024494 -- magic constant? magic constant. - -straightLine :: Point -> Point -> CubicBezier -straightLine a b = CubicBezier a p p b - where p = a `midPoint` b - -isSufficientlyFlat :: Float -- ^ Tolerance - -> CubicBezier - -> Bool -isSufficientlyFlat tol (CubicBezier a b c d) = - x + y <= tolerance - where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d - v = (c ^* 3) ^-^ (d ^* 2) ^-^ a - (^*^) = liftA2 (*) - V2 x y = vmax (u ^*^ u) (v ^*^ v) - tolerance = 16 * tol * tol - -splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point) -{-# INLINE splitCubicBezier #-} -splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd) - where - -- BC - -- B X----------X---------X C - -- ^ / ___/ \___ \ ^ - -- u \ / __X------X------X_ \ / v - -- \ /___/ ABBC BCCD \___\ / - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - ab = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d - - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd - -flattenCubicBezier :: CubicBezier -> Container Primitive -flattenCubicBezier bezier@(CubicBezier a _ _ d) - | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier - | otherwise = - flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> - flattenCubicBezier (CubicBezier abbcbccd bccd cd d) - where - (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier - --- 3 2 2 3 --- x(t) = (1 - t) ∙x + 3∙t∙(1 - t) ∙x + 3∙t ∙(1 - t)∙x + t ∙x --- 0 1 2 3 --- --- 3 2 2 3 --- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y --- 0 1 2 3 - --- Other representation: --- 3 2 2 3 --- B(t) = x(1 - t) + 3∙y∙t∙(1 - t) + 3∙z∙t ∙(1 - t) + w∙t - - --- | Represent the cubic bezier curve as a vector ready --- for matrix multiplication -data CachedBezier = CachedBezier - { _cachedA :: {-# UNPACK #-} !Float - , _cachedB :: {-# UNPACK #-} !Float - , _cachedC :: {-# UNPACK #-} !Float - , _cachedD :: {-# UNPACK #-} !Float - } - -cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier) -cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) = - (CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY) - where - V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3 - V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3 - V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0 - -cachedBezierAt :: CachedBezier -> Float -> Float -cachedBezierAt (CachedBezier a b c d) t = - a + b * t + c * tSquare + tCube * d - where - tSquare = t * t - tCube = tSquare * t - -cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float -cachedBezierDerivative (CachedBezier _ b c d) = - QuadraticFormula (3 * d) (2 * c) b - --- | Find the coefficient of the extremum points -extremums :: CachedBezier -> [Float] -extremums cached = - [ root | root <- formulaRoots $ cachedBezierDerivative cached - , 0 <= root && root <= 1.0 ] - -extremumPoints :: (CachedBezier, CachedBezier) -> [Point] -extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY) - where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at) - -cubicBezierBounds :: CubicBezier -> [Point] -cubicBezierBounds bez@(CubicBezier p0 _ _ p3) = - p0 : p3 : extremumPoints (cacheBezier bez) - -offsetCubicBezier :: Float -> CubicBezier -> Container Primitive -offsetCubicBezier offset bezier@(CubicBezier a b c d) - | isSufficientlyFlat 1 bezier = - pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD - | otherwise = - recurse (CubicBezier a ab abbc abbcbccd) <> - recurse (CubicBezier abbcbccd bccd cd d) - where - recurse = offsetCubicBezier offset - - u = a `normal` b - v = c `normal` d - - -- BC - -- B X----------X---------X C - -- ^ / ___/ \___ \ ^ - -- u \ / __X------X------X_ \ / v - -- \ /___/ ABBC BCCD \___\ / - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier - - w = ab `normal` bc - x = bc `normal` cd - - shiftedA = a ^+^ (u ^* offset) - shiftedD = d ^+^ (v ^* offset) - - {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-} - shiftedB = b ^+^ (w ^* offset) - shiftedC = c ^+^ (x ^* offset) - --- | Clamp the cubic bezier curve inside a rectangle --- given in parameter. -clipCubicBezier - :: Point -- ^ Point representing the "minimal" point for cliping - -> Point -- ^ Point representing the "maximal" point for cliping - -> CubicBezier -- ^ The cubic bezier curve to be clamped - -> Container Primitive -clipCubicBezier mini maxi bezier@(CubicBezier a b c d) - -- If we are in the range bound, return the curve - -- unaltered - | insideX && insideY = pure $ CubicBezierPrim bezier - -- If one of the component is outside, clamp - -- the components on the boundaries and output a - -- straight line on this boundary. Useful for the - -- filing case, to clamp the polygon drawing on - -- the edge - | outsideX || outsideY = - pure . CubicBezierPrim $ clampedA `straightLine` clampedD - -- Not completly inside nor outside, just divide - -- and conquer. - | otherwise = - recurse (CubicBezier a ab abbc m) <> - recurse (CubicBezier m bccd cd d) - where -- Minimal & maximal dimension of the bezier curve - bmin = vmin a . vmin b $ vmin c d - bmax = vmax a . vmax b $ vmax c d - - recurse = clipCubicBezier mini maxi - - clamper = clampPoint mini maxi - clampedA = clamper a - clampedD = clamper d - - V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi - V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin - - -- BC - -- B X----------X---------X C - -- / ___/ \___ \ - -- / __X------X------X_ \ - -- /___/ ABBC BCCD \___\ - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier - - edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) - edge = vpartition edgeSeparator mini maxi - m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd - --- | Will subdivide the bezier from 0 to coeff and coeff to 1 -cubicBezierBreakAt :: CubicBezier -> Float - -> (CubicBezier, CubicBezier) -cubicBezierBreakAt (CubicBezier a b c d) val = - (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d) - where - ab = lerp val a b - bc = lerp val b c - cd = lerp val c d - - abbc = lerp val ab bc - bccd = lerp val bc cd - abbcbccd = lerp val abbc bccd - -decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample -decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) = - go aRx aRy bRx bRy cRx cRy dRx dRy where - go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY = - let !px = fromIntegral $ min floorAx floorDx - !py = fromIntegral $ min floorAy floorDy - !w = px + 1 - (dx `middle` ax) - !h = dy - ay - in - EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont - where - floorAx, floorAy :: Int - !floorAx = floor ax - !floorAy = floor ay - - !floorDx = floor dx - !floorDy = floor dy - - !insideX = - floorAx == floorDx || ceiling ax == (ceiling dx :: Int) - !insideY = - floorAy == floorDy || ceiling ay == (ceiling dy :: Int) - - - go !ax !ay !bx !by !cx !cy !dx !dy cont = - go ax ay abx aby abbcx abbcy mx my $ - go mx my bccdx bccdy cdx cdy dx dy cont - where - -- BC - -- B X----------X---------X C - -- / ___/ \___ \ - -- / __X------X------X_ \ - -- /___/ ABBC BCCD \___\ - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - !abx = ax `middle` bx - !aby = ay `middle` by - !bcx = bx `middle` cx - !bcy = by `middle` cy - !cdx = cx `middle` dx - !cdy = cy `middle` dy - !abbcx = abx `middle` bcx - !abbcy = aby `middle` bcy - !bccdx = bcx `middle` cdx - !bccdy = bcy `middle` cdy - - !abbcbccdx = abbcx `middle` bccdx - !abbcbccdy = abbcy `middle` bccdy - - !mx | abs (abbcbccdx - mini) < 0.1 = mini - | abs (abbcbccdx - maxi) < 0.1 = maxi - | otherwise = abbcbccdx - where !mini = fromIntegral (floor abbcbccdx :: Int) - !maxi = fromIntegral (ceiling abbcbccdx :: Int) - - !my | abs (abbcbccdy - mini) < 0.1 = mini - | abs (abbcbccdy - maxi) < 0.1 = maxi - | otherwise = abbcbccdy - where !mini = fromIntegral (floor abbcbccdy :: Int) - !maxi = fromIntegral (ceiling abbcbccdy :: Int) - - -sanitizeCubicBezier :: CubicBezier -> Container Primitive -sanitizeCubicBezier bezier@(CubicBezier a b c d) - | a `isDistingableFrom` b && - c `isDistingableFrom` d = - pure . CubicBezierPrim $ bezier - | ac `isDistingableFrom` b && - bd `isDistingableFrom` c = - pure . CubicBezierPrim $ bezier - | ac `isDistingableFrom` b = - pure . CubicBezierPrim $ CubicBezier a ac c d - | bd `isDistingableFrom` c = - pure . CubicBezierPrim $ CubicBezier a b bd d - | otherwise = mempty - where ac = a `midPoint` c - bd = a `midPoint` d - +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Graphics.Rasterific.CubicBezier + ( cubicBezierCircle + , cubicBezierFromPath + , cubicBezierBreakAt + , clipCubicBezier + , decomposeCubicBeziers + , sanitizeCubicBezier + , offsetCubicBezier + , flattenCubicBezier + , cubicBezierLengthApproximation + , cubicBezierBounds + ) where + +import Prelude hiding( or ) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), pure ) +import Data.Monoid( mempty ) +#endif + +import Data.Monoid( (<>) ) +import Control.Applicative( liftA2 ) +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , norm + , lerp + ) +import Data.List( nub ) +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticFormula + +-- | Create a list of cubic bezier patch from a list of points. +-- +-- > cubicBezierFromPath [a, b, c, d, e] = [CubicBezier a b c d] +-- > cubicBezierFromPath [a, b, c, d, e, f, g] = +-- > [CubicBezier a b c d, CubicBezier d e f g] +-- +cubicBezierFromPath :: [Point] -> [CubicBezier] +cubicBezierFromPath (a:b:c:rest@(d:_)) = + CubicBezier a b c d : cubicBezierFromPath rest +cubicBezierFromPath _ = [] + +cubicBezierLengthApproximation :: CubicBezier -> Float +cubicBezierLengthApproximation (CubicBezier a _ _ d) = + norm $ d ^-^ a + +-- | Represent a circle of radius 1 centered on 0 of +-- a cubic bezier curve. +cubicBezierCircle :: [CubicBezier] +cubicBezierCircle = + [ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0) + , CubicBezier (V2 1 0) (V2 1 (-c)) (V2 c (-1)) (V2 0 (-1)) + , CubicBezier (V2 0 (-1)) (V2 (-c) (-1)) (V2 (-1) (-c)) (V2 (-1) 0) + , CubicBezier (V2 (-1) 0) (V2 (-1) c) (V2 (-c) 1) (V2 0 1) + ] + where c = 0.551915024494 -- magic constant? magic constant. + +straightLine :: Point -> Point -> CubicBezier +straightLine a b = CubicBezier a p p b + where p = a `midPoint` b + +isSufficientlyFlat :: Float -- ^ Tolerance + -> CubicBezier + -> Bool +isSufficientlyFlat tol (CubicBezier a b c d) = + x + y <= tolerance + where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d + v = (c ^* 3) ^-^ (d ^* 2) ^-^ a + (^*^) = liftA2 (*) + V2 x y = vmax (u ^*^ u) (v ^*^ v) + tolerance = 16 * tol * tol + +splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point) +{-# INLINE splitCubicBezier #-} +splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd) + where + -- BC + -- B X----------X---------X C + -- ^ / ___/ \___ \ ^ + -- u \ / __X------X------X_ \ / v + -- \ /___/ ABBC BCCD \___\ / + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + ab = a `midPoint` b + bc = b `midPoint` c + cd = c `midPoint` d + + abbc = ab `midPoint` bc + bccd = bc `midPoint` cd + abbcbccd = abbc `midPoint` bccd + +flattenCubicBezier :: CubicBezier -> Container Primitive +flattenCubicBezier bezier@(CubicBezier a _ _ d) + | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier + | otherwise = + flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> + flattenCubicBezier (CubicBezier abbcbccd bccd cd d) + where + (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier + +-- 3 2 2 3 +-- x(t) = (1 - t) ∙x + 3∙t∙(1 - t) ∙x + 3∙t ∙(1 - t)∙x + t ∙x +-- 0 1 2 3 +-- +-- 3 2 2 3 +-- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y +-- 0 1 2 3 + +-- Other representation: +-- 3 2 2 3 +-- B(t) = x(1 - t) + 3∙y∙t∙(1 - t) + 3∙z∙t ∙(1 - t) + w∙t + + +-- | Represent the cubic bezier curve as a vector ready +-- for matrix multiplication +data CachedBezier = CachedBezier + { _cachedA :: {-# UNPACK #-} !Float + , _cachedB :: {-# UNPACK #-} !Float + , _cachedC :: {-# UNPACK #-} !Float + , _cachedD :: {-# UNPACK #-} !Float + } + +cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier) +cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) = + (CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY) + where + V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3 + V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3 + V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0 + +cachedBezierAt :: CachedBezier -> Float -> Float +cachedBezierAt (CachedBezier a b c d) t = + a + b * t + c * tSquare + tCube * d + where + tSquare = t * t + tCube = tSquare * t + +cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float +cachedBezierDerivative (CachedBezier _ b c d) = + QuadraticFormula (3 * d) (2 * c) b + +-- | Find the coefficient of the extremum points +extremums :: CachedBezier -> [Float] +extremums cached = + [ root | root <- formulaRoots $ cachedBezierDerivative cached + , 0 <= root && root <= 1.0 ] + +extremumPoints :: (CachedBezier, CachedBezier) -> [Point] +extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY) + where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at) + +cubicBezierBounds :: CubicBezier -> [Point] +cubicBezierBounds bez@(CubicBezier p0 _ _ p3) = + p0 : p3 : extremumPoints (cacheBezier bez) + +offsetCubicBezier :: Float -> CubicBezier -> Container Primitive +offsetCubicBezier offset bezier@(CubicBezier a b c d) + | isSufficientlyFlat 1 bezier = + pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD + | otherwise = + recurse (CubicBezier a ab abbc abbcbccd) <> + recurse (CubicBezier abbcbccd bccd cd d) + where + recurse = offsetCubicBezier offset + + u = a `normal` b + v = c `normal` d + + -- BC + -- B X----------X---------X C + -- ^ / ___/ \___ \ ^ + -- u \ / __X------X------X_ \ / v + -- \ /___/ ABBC BCCD \___\ / + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier + + w = ab `normal` bc + x = bc `normal` cd + + shiftedA = a ^+^ (u ^* offset) + shiftedD = d ^+^ (v ^* offset) + + {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-} + shiftedB = b ^+^ (w ^* offset) + shiftedC = c ^+^ (x ^* offset) + +-- | Clamp the cubic bezier curve inside a rectangle +-- given in parameter. +clipCubicBezier + :: Point -- ^ Point representing the "minimal" point for cliping + -> Point -- ^ Point representing the "maximal" point for cliping + -> CubicBezier -- ^ The cubic bezier curve to be clamped + -> Container Primitive +clipCubicBezier mini maxi bezier@(CubicBezier a b c d) + -- If we are in the range bound, return the curve + -- unaltered + | insideX && insideY = pure $ CubicBezierPrim bezier + -- If one of the component is outside, clamp + -- the components on the boundaries and output a + -- straight line on this boundary. Useful for the + -- filing case, to clamp the polygon drawing on + -- the edge + | outsideX || outsideY = + pure . CubicBezierPrim $ clampedA `straightLine` clampedD + -- Not completly inside nor outside, just divide + -- and conquer. + | otherwise = + recurse (CubicBezier a ab abbc m) <> + recurse (CubicBezier m bccd cd d) + where -- Minimal & maximal dimension of the bezier curve + bmin = vmin a . vmin b $ vmin c d + bmax = vmax a . vmax b $ vmax c d + + recurse = clipCubicBezier mini maxi + + clamper = clampPoint mini maxi + clampedA = clamper a + clampedD = clamper d + + V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi + V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin + + -- BC + -- B X----------X---------X C + -- / ___/ \___ \ + -- / __X------X------X_ \ + -- /___/ ABBC BCCD \___\ + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier + + edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) + edge = vpartition edgeSeparator mini maxi + m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd + +-- | Will subdivide the bezier from 0 to coeff and coeff to 1 +cubicBezierBreakAt :: CubicBezier -> Float + -> (CubicBezier, CubicBezier) +cubicBezierBreakAt (CubicBezier a b c d) val = + (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d) + where + ab = lerp val a b + bc = lerp val b c + cd = lerp val c d + + abbc = lerp val ab bc + bccd = lerp val bc cd + abbcbccd = lerp val abbc bccd + +decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample +decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) = + go aRx aRy bRx bRy cRx cRy dRx dRy where + go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY = + let !px = fromIntegral $ min floorAx floorDx + !py = fromIntegral $ min floorAy floorDy + !w = px + 1 - (dx `middle` ax) + !h = dy - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont + where + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay + + !floorDx = floor dx + !floorDy = floor dy + + !insideX = + floorAx == floorDx || ceiling ax == (ceiling dx :: Int) + !insideY = + floorAy == floorDy || ceiling ay == (ceiling dy :: Int) + + + go !ax !ay !bx !by !cx !cy !dx !dy cont = + go ax ay abx aby abbcx abbcy mx my $ + go mx my bccdx bccdy cdx cdy dx dy cont + where + -- BC + -- B X----------X---------X C + -- / ___/ \___ \ + -- / __X------X------X_ \ + -- /___/ ABBC BCCD \___\ + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + !abx = ax `middle` bx + !aby = ay `middle` by + !bcx = bx `middle` cx + !bcy = by `middle` cy + !cdx = cx `middle` dx + !cdy = cy `middle` dy + !abbcx = abx `middle` bcx + !abbcy = aby `middle` bcy + !bccdx = bcx `middle` cdx + !bccdy = bcy `middle` cdy + + !abbcbccdx = abbcx `middle` bccdx + !abbcbccdy = abbcy `middle` bccdy + + !mx | abs (abbcbccdx - mini) < 0.1 = mini + | abs (abbcbccdx - maxi) < 0.1 = maxi + | otherwise = abbcbccdx + where !mini = fromIntegral (floor abbcbccdx :: Int) + !maxi = fromIntegral (ceiling abbcbccdx :: Int) + + !my | abs (abbcbccdy - mini) < 0.1 = mini + | abs (abbcbccdy - maxi) < 0.1 = maxi + | otherwise = abbcbccdy + where !mini = fromIntegral (floor abbcbccdy :: Int) + !maxi = fromIntegral (ceiling abbcbccdy :: Int) + + +sanitizeCubicBezier :: CubicBezier -> Container Primitive +sanitizeCubicBezier bezier@(CubicBezier a b c d) + | a `isDistingableFrom` b && + c `isDistingableFrom` d = + pure . CubicBezierPrim $ bezier + | ac `isDistingableFrom` b && + bd `isDistingableFrom` c = + pure . CubicBezierPrim $ bezier + | ac `isDistingableFrom` b = + pure . CubicBezierPrim $ CubicBezier a ac c d + | bd `isDistingableFrom` c = + pure . CubicBezierPrim $ CubicBezier a b bd d + | otherwise = mempty + where ac = a `midPoint` c + bd = a `midPoint` d + diff --git a/src/Graphics/Rasterific/Immediate.hs b/src/Graphics/Rasterific/Immediate.hs --- a/src/Graphics/Rasterific/Immediate.hs +++ b/src/Graphics/Rasterific/Immediate.hs @@ -1,184 +1,194 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} --- | This module implements drawing primitives to draw directly into --- the output texture, without generating an intermediate scene --- representation. --- --- If you need to draw complex scenes or plot an important set of --- data, this is the module you should use. The downside is that --- you must specify everything you need at each draw call, there --- is no API to help you propagate constants. --- --- The "stroking" must be done using the functions of the --- `Graphics.Rasterific.Outline` module. -module Graphics.Rasterific.Immediate - ( DrawContext - , DrawOrder( .. ) - , orderToDrawing - - , runDrawContext - , fillWithTextureAndMask - , fillWithTexture - , fillOrder - ) where - -import qualified Data.Foldable as F -import Control.Monad.Free( liftF ) -import Control.Monad.State( StateT, execStateT, get, lift ) -import Control.Monad.State.Class(MonadState) -import Codec.Picture.Types( Image( .. ) - , Pixel( .. ) - , MutableImage( .. ) - , unsafeFreezeImage - , fillImageWith ) - -import Control.Monad.Primitive( PrimState, PrimMonad, primToPrim ) -import qualified Data.Vector.Storable.Mutable as M -import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Linear( V2( .. ) ) -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Shading -import Graphics.Rasterific.Types -import Graphics.Rasterific.Command - --- | Monad used to describe the drawing context. -type DrawContext m px = - StateT (MutableImage (PrimState m) px) m - --- | Reify a filling function call, to be able to manipulate --- them in a simpler fashion. -data DrawOrder px = DrawOrder - { -- | Primitives to be filled. - _orderPrimitives :: ![[Primitive]] - -- | Texture for the filled primitives. - , _orderTexture :: !(Texture px) - -- | How to fill the primitives. - , _orderFillMethod :: !FillMethod - -- | Optional mask used for clipping. - , _orderMask :: !(Maybe (Texture (PixelBaseComponent px))) - } - --- | Transform back a low level drawing order to a more --- high level Drawing -orderToDrawing :: DrawOrder px -> Drawing px () -orderToDrawing order = - usingTexture . mapM_ filler $ _orderPrimitives order - where - usingTexture sub = - liftF $ SetTexture (_orderTexture order) sub () - filler prims = - liftF $ Fill (_orderFillMethod order) prims () - --- | Render the drawing orders on the canvas. -fillOrder :: (PrimMonad m, RenderablePixel px) - => DrawOrder px -> DrawContext m px () -fillOrder o@DrawOrder { _orderMask = Nothing } = - F.forM_ (_orderPrimitives o) $ - fillWithTexture (_orderFillMethod o) (_orderTexture o) -fillOrder o@DrawOrder { _orderMask = Just mask } = - F.forM_ (_orderPrimitives o) $ - fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask - --- | Start an image rendering. See `fillWithTexture` for --- an usage example. This function can work with either --- `IO` or `ST`. -runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> px -- ^ Background color - -> DrawContext m px () -- ^ Actual drawing computation - -> m (Image px) -runDrawContext width height background drawing = do - buff <- M.new (width * height * componentCount background) - let mutable = MutableImage width height buff - fillImageWith mutable background - img <- execStateT drawing mutable - unsafeFreezeImage img - -mapExec :: Monad m => (a -> m ()) -> [a] -> m () -mapExec f = foldr ((>>) . f) (return ()) - -isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool -isCoverageDrawable img coverage = - _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight - where - !imgWidth = fromIntegral $ mutableImageWidth img - !imgHeight = fromIntegral $ mutableImageHeight img - x = _coverageX coverage - y = _coverageY coverage - --- | Fill some geometry. --- --- > immediateDrawExample :: Image PixelRGBA8 --- > immediateDrawExample = runST $ --- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $ --- > fillWithTexture FillWinding texture geometry --- > where --- > circlePrimitives = circle (V2 100 100) 50 --- > geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives --- > texture = uniformTexture (PixelRGBA8 255 255 255 255) --- --- <> --- -fillWithTexture :: (PrimMonad m, RenderablePixel px, - MonadState (MutableImage (PrimState m) px) - (DrawContext m px) - ) - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling - -> [Primitive] -- ^ Primitives to fill - -> DrawContext m px () -fillWithTexture fillMethod texture els = do - img@(MutableImage width height _) <- get - let !mini = V2 0 0 - !maxi = V2 (fromIntegral width) (fromIntegral height) - !filler = primToPrim . transformTextureToFiller texture img - clipped = F.foldMap (clip mini maxi) els - spans = rasterize fillMethod clipped - lift . mapExec filler $ filter (isCoverageDrawable img) spans - --- | Fill some geometry using a composition mask for visibility. --- --- > immediateDrawMaskExample :: Image PixelRGBA8 --- > immediateDrawMaskExample = runST $ --- > runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ --- > forM_ [1 .. 10] $ \ix -> --- > fillWithTextureAndMask FillWinding texture mask $ --- > rectangle (V2 10 (ix * 18 - 5)) 180 13 --- > where --- > texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 --- > mask = sampledImageTexture --- > $ runST --- > $ runDrawContext 200 200 0 --- > $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry --- > --- > maskGeometry = strokize 15 JoinRound (CapRound, CapRound) --- > $ circle (V2 100 100) 80 --- --- <> --- -fillWithTextureAndMask - :: ( PrimMonad m - , RenderablePixel px - , MonadState (MutableImage (PrimState m) px) - (DrawContext m px) - ) - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling of the geometry - -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask. - -> [Primitive] -- ^ Primitives to fill - -> DrawContext m px () -fillWithTextureAndMask fillMethod texture mask els = do - img@(MutableImage width height _) <- get - let !mini = V2 0 0 - !maxi = V2 (fromIntegral width) (fromIntegral height) - spans = rasterize fillMethod $ F.foldMap (clip mini maxi) els - !shader = primToPrim - . transformTextureToFiller (modulateTexture texture mask) img - lift . mapM_ shader $ filter (isCoverageDrawable img) spans - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +-- | This module implements drawing primitives to draw directly into +-- the output texture, without generating an intermediate scene +-- representation. +-- +-- If you need to draw complex scenes or plot an important set of +-- data, this is the module you should use. The downside is that +-- you must specify everything you need at each draw call, there +-- is no API to help you propagate constants. +-- +-- The "stroking" must be done using the functions of the +-- `Graphics.Rasterific.Outline` module. +module Graphics.Rasterific.Immediate + ( DrawContext + , DrawOrder( .. ) + , orderToDrawing + + , runDrawContext + , fillWithTextureAndMask + , fillWithTexture + , fillOrder + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable( foldMap ) +#endif + +import qualified Data.Foldable as F +import Control.Monad.Free( liftF ) +import Control.Monad.State( StateT, execStateT, get, lift ) +import Control.Monad.State.Class(MonadState) +import Codec.Picture.Types( Image( .. ) + , Pixel( .. ) + , MutableImage( .. ) + , unsafeFreezeImage + , fillImageWith ) + +import Control.Monad.Primitive( PrimState, PrimMonad, primToPrim ) +import qualified Data.Vector.Storable.Mutable as M +import Graphics.Rasterific.Compositor +import Graphics.Rasterific.Linear( V2( .. ) ) +import Graphics.Rasterific.Rasterize +import Graphics.Rasterific.Texture +import Graphics.Rasterific.Shading +import Graphics.Rasterific.Types +import Graphics.Rasterific.Command +import Graphics.Rasterific.PlaneBoundable + +-- | Monad used to describe the drawing context. +type DrawContext m px = + StateT (MutableImage (PrimState m) px) m + +-- | Reify a filling function call, to be able to manipulate +-- them in a simpler fashion. +data DrawOrder px = DrawOrder + { -- | Primitives to be filled. + _orderPrimitives :: ![[Primitive]] + -- | Texture for the filled primitives. + , _orderTexture :: !(Texture px) + -- | How to fill the primitives. + , _orderFillMethod :: !FillMethod + -- | Optional mask used for clipping. + , _orderMask :: !(Maybe (Texture (PixelBaseComponent px))) + } + +instance PlaneBoundable (DrawOrder px) where + planeBounds = + foldMap (foldMap planeBounds) . _orderPrimitives + +-- | Transform back a low level drawing order to a more +-- high level Drawing +orderToDrawing :: DrawOrder px -> Drawing px () +orderToDrawing order = + usingTexture . mapM_ filler $ _orderPrimitives order + where + usingTexture sub = + liftF $ SetTexture (_orderTexture order) sub () + filler prims = + liftF $ Fill (_orderFillMethod order) prims () + +-- | Render the drawing orders on the canvas. +fillOrder :: (PrimMonad m, RenderablePixel px) + => DrawOrder px -> DrawContext m px () +fillOrder o@DrawOrder { _orderMask = Nothing } = + F.forM_ (_orderPrimitives o) $ + fillWithTexture (_orderFillMethod o) (_orderTexture o) +fillOrder o@DrawOrder { _orderMask = Just mask } = + F.forM_ (_orderPrimitives o) $ + fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask + +-- | Start an image rendering. See `fillWithTexture` for +-- an usage example. This function can work with either +-- `IO` or `ST`. +runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> DrawContext m px () -- ^ Actual drawing computation + -> m (Image px) +runDrawContext width height background drawing = do + buff <- M.new (width * height * componentCount background) + let mutable = MutableImage width height buff + fillImageWith mutable background + img <- execStateT drawing mutable + unsafeFreezeImage img + +mapExec :: Monad m => (a -> m ()) -> [a] -> m () +mapExec f = foldr ((>>) . f) (return ()) + +isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool +isCoverageDrawable img coverage = + _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight + where + !imgWidth = fromIntegral $ mutableImageWidth img + !imgHeight = fromIntegral $ mutableImageHeight img + x = _coverageX coverage + y = _coverageY coverage + +-- | Fill some geometry. +-- +-- > immediateDrawExample :: Image PixelRGBA8 +-- > immediateDrawExample = runST $ +-- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $ +-- > fillWithTexture FillWinding texture geometry +-- > where +-- > circlePrimitives = circle (V2 100 100) 50 +-- > geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives +-- > texture = uniformTexture (PixelRGBA8 255 255 255 255) +-- +-- <> +-- +fillWithTexture :: (PrimMonad m, RenderablePixel px, + MonadState (MutableImage (PrimState m) px) + (DrawContext m px) + ) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling + -> [Primitive] -- ^ Primitives to fill + -> DrawContext m px () +fillWithTexture fillMethod texture els = do + img@(MutableImage width height _) <- get + let !mini = V2 0 0 + !maxi = V2 (fromIntegral width) (fromIntegral height) + !filler = primToPrim . transformTextureToFiller texture img + clipped = foldMap (clip mini maxi) els + spans = rasterize fillMethod clipped + lift . mapExec filler $ filter (isCoverageDrawable img) spans + +-- | Fill some geometry using a composition mask for visibility. +-- +-- > immediateDrawMaskExample :: Image PixelRGBA8 +-- > immediateDrawMaskExample = runST $ +-- > runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ +-- > forM_ [1 .. 10] $ \ix -> +-- > fillWithTextureAndMask FillWinding texture mask $ +-- > rectangle (V2 10 (ix * 18 - 5)) 180 13 +-- > where +-- > texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 +-- > mask = sampledImageTexture +-- > $ runST +-- > $ runDrawContext 200 200 0 +-- > $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry +-- > +-- > maskGeometry = strokize 15 JoinRound (CapRound, CapRound) +-- > $ circle (V2 100 100) 80 +-- +-- <> +-- +fillWithTextureAndMask + :: ( PrimMonad m + , RenderablePixel px + , MonadState (MutableImage (PrimState m) px) + (DrawContext m px) + ) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling of the geometry + -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask. + -> [Primitive] -- ^ Primitives to fill + -> DrawContext m px () +fillWithTextureAndMask fillMethod texture mask els = do + img@(MutableImage width height _) <- get + let !mini = V2 0 0 + !maxi = V2 (fromIntegral width) (fromIntegral height) + spans = rasterize fillMethod $ foldMap (clip mini maxi) els + !shader = primToPrim + . transformTextureToFiller (modulateTexture texture mask) img + lift . mapM_ shader $ filter (isCoverageDrawable img) spans + diff --git a/src/Graphics/Rasterific/Lenses.hs b/src/Graphics/Rasterific/Lenses.hs --- a/src/Graphics/Rasterific/Lenses.hs +++ b/src/Graphics/Rasterific/Lenses.hs @@ -1,147 +1,146 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} --- | This module provide lenses compatible with the `lens` --- module but without the dependency to it. -module Graphics.Rasterific.Lenses - ( -- * Line lenses - lineX0 - , lineX1 - , linePoints - - -- * Quadratic bezier curve - , bezX0 - , bezX1 - , bezX2 - , bezierPoints - - -- * Cubic bezier lenses - , cbezX0 - , cbezX1 - , cbezX2 - , cbezX3 - , cubicBezierPoints - - -- * Primitive lenses - , primitivePoints - - -- * Path oriented lenses - , pathCommandPoints - , pathPoints - - -- * Type definition to match Lens - , Lens - , Lens' - , Traversal - , Traversal' - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Traversable( traverse ) -import Control.Applicative( Applicative, (<*>), pure ) -#endif - -import Control.Applicative( (<$>) ) -import Graphics.Rasterific.Types - --- | Does it look familiar? yes it's the official --- Lens type. -type Lens s t a b = - forall f. Functor f => (a -> f b) -> s -> f t - --- | Try to match the Lens' type alias. -type Lens' s a = Lens s s a a - --- | Traversal type, matched to the one of the lens --- package. -type Traversal s t a b = - forall f. Applicative f => (a -> f b) -> s -> f t - -type Traversal' s a = Traversal s s a a - --- | Create a full lens out of setter and getter -lens :: (s -> a) - -> (s -> b -> t) - -> Lens s t a b -{-# INLINE lens #-} -lens accessor setter = \f src -> - fmap (setter src) $ f (accessor src) - --- | Traverse all the points of a line. -linePoints :: Traversal' Line Point -linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1 - --- | Line origin point. -lineX0 :: Lens' Line Point -lineX0 = lens _lineX0 setter where - setter a b = a { _lineX0 = b } - --- | Line end point. -lineX1 :: Lens' Line Point -lineX1 = lens _lineX1 setter where - setter a b = a { _lineX1 = b } - --- | Quadratic bezier starting point. -bezX0 :: Lens' Bezier Point -bezX0 = lens _bezierX0 setter where - setter a b = a { _bezierX0 = b } - --- | bezier control point. -bezX1 :: Lens' Bezier Point -bezX1 = lens _bezierX1 setter where - setter a b = a { _bezierX1 = b } - --- | bezier end point. -bezX2 :: Lens' Bezier Point -bezX2 = lens _bezierX2 setter where - setter a b = a { _bezierX2 = b } - --- | Traversal of all the bezier's points. -bezierPoints :: Traversal' Bezier Point -bezierPoints f (Bezier p0 p1 p2) = - Bezier <$> f p0 <*> f p1 <*> f p2 - --- | Cubic bezier first point -cbezX0 :: Lens' CubicBezier Point -cbezX0 = lens _cBezierX0 setter where - setter a b = a { _cBezierX0 = b } - --- | Cubic bezier first control point. -cbezX1 :: Lens' CubicBezier Point -cbezX1 = lens _cBezierX1 setter where - setter a b = a { _cBezierX1 = b } - --- | Cubic bezier second control point. -cbezX2 :: Lens' CubicBezier Point -cbezX2 = lens _cBezierX2 setter where - setter a b = a { _cBezierX2 = b } - --- | Cubic bezier last point. -cbezX3 :: Lens' CubicBezier Point -cbezX3 = lens _cBezierX2 setter where - setter a b = a { _cBezierX3 = b } - --- | Traversal of all the points of the cubic bezier. -cubicBezierPoints :: Traversal' CubicBezier Point -cubicBezierPoints f (CubicBezier p0 p1 p2 p3) = - CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3 - --- | Traverse all the points defined in the primitive. -primitivePoints :: Traversal' Primitive Point -primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l -primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b -primitivePoints f (CubicBezierPrim c) = - CubicBezierPrim <$> cubicBezierPoints f c - --- | Traversal of all the points of a path -pathCommandPoints :: Traversal' PathCommand Point -pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p -pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) = - PathQuadraticBezierCurveTo <$> f p1 <*> f p2 -pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) = - PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3 - --- | Traversal of all the points in a path. -pathPoints :: Traversal' Path Point -pathPoints f (Path p0 yn comms) = - Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +-- | This module provide lenses compatible with the `lens` +-- module but without the dependency to it. +module Graphics.Rasterific.Lenses + ( -- * Line lenses + lineX0 + , lineX1 + , linePoints + + -- * Quadratic bezier curve + , bezX0 + , bezX1 + , bezX2 + , bezierPoints + + -- * Cubic bezier lenses + , cbezX0 + , cbezX1 + , cbezX2 + , cbezX3 + , cubicBezierPoints + + -- * Primitive lenses + , primitivePoints + + -- * Path oriented lenses + , pathCommandPoints + , pathPoints + + -- * Type definition to match Lens + , Lens + , Lens' + , Traversal + , Traversal' + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Traversable( traverse ) +import Control.Applicative( Applicative, (<*>), (<$>), pure ) +#endif + +import Graphics.Rasterific.Types + +-- | Does it look familiar? yes it's the official +-- Lens type. +type Lens s t a b = + forall f. Functor f => (a -> f b) -> s -> f t + +-- | Try to match the Lens' type alias. +type Lens' s a = Lens s s a a + +-- | Traversal type, matched to the one of the lens +-- package. +type Traversal s t a b = + forall f. Applicative f => (a -> f b) -> s -> f t + +type Traversal' s a = Traversal s s a a + +-- | Create a full lens out of setter and getter +lens :: (s -> a) + -> (s -> b -> t) + -> Lens s t a b +{-# INLINE lens #-} +lens accessor setter = \f src -> + fmap (setter src) $ f (accessor src) + +-- | Traverse all the points of a line. +linePoints :: Traversal' Line Point +linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1 + +-- | Line origin point. +lineX0 :: Lens' Line Point +lineX0 = lens _lineX0 setter where + setter a b = a { _lineX0 = b } + +-- | Line end point. +lineX1 :: Lens' Line Point +lineX1 = lens _lineX1 setter where + setter a b = a { _lineX1 = b } + +-- | Quadratic bezier starting point. +bezX0 :: Lens' Bezier Point +bezX0 = lens _bezierX0 setter where + setter a b = a { _bezierX0 = b } + +-- | bezier control point. +bezX1 :: Lens' Bezier Point +bezX1 = lens _bezierX1 setter where + setter a b = a { _bezierX1 = b } + +-- | bezier end point. +bezX2 :: Lens' Bezier Point +bezX2 = lens _bezierX2 setter where + setter a b = a { _bezierX2 = b } + +-- | Traversal of all the bezier's points. +bezierPoints :: Traversal' Bezier Point +bezierPoints f (Bezier p0 p1 p2) = + Bezier <$> f p0 <*> f p1 <*> f p2 + +-- | Cubic bezier first point +cbezX0 :: Lens' CubicBezier Point +cbezX0 = lens _cBezierX0 setter where + setter a b = a { _cBezierX0 = b } + +-- | Cubic bezier first control point. +cbezX1 :: Lens' CubicBezier Point +cbezX1 = lens _cBezierX1 setter where + setter a b = a { _cBezierX1 = b } + +-- | Cubic bezier second control point. +cbezX2 :: Lens' CubicBezier Point +cbezX2 = lens _cBezierX2 setter where + setter a b = a { _cBezierX2 = b } + +-- | Cubic bezier last point. +cbezX3 :: Lens' CubicBezier Point +cbezX3 = lens _cBezierX2 setter where + setter a b = a { _cBezierX3 = b } + +-- | Traversal of all the points of the cubic bezier. +cubicBezierPoints :: Traversal' CubicBezier Point +cubicBezierPoints f (CubicBezier p0 p1 p2 p3) = + CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3 + +-- | Traverse all the points defined in the primitive. +primitivePoints :: Traversal' Primitive Point +primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l +primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b +primitivePoints f (CubicBezierPrim c) = + CubicBezierPrim <$> cubicBezierPoints f c + +-- | Traversal of all the points of a path +pathCommandPoints :: Traversal' PathCommand Point +pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p +pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) = + PathQuadraticBezierCurveTo <$> f p1 <*> f p2 +pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) = + PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3 + +-- | Traversal of all the points in a path. +pathPoints :: Traversal' Path Point +pathPoints f (Path p0 yn comms) = + Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms + diff --git a/src/Graphics/Rasterific/Line.hs b/src/Graphics/Rasterific/Line.hs --- a/src/Graphics/Rasterific/Line.hs +++ b/src/Graphics/Rasterific/Line.hs @@ -1,164 +1,163 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} --- | Handle straight lines polygon. -module Graphics.Rasterific.Line - ( lineFromPath - , decomposeLine - , clipLine - , sanitizeLine - , lineBreakAt - , flattenLine - , lineLength - , offsetLine - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( mempty ) -#endif - -import Data.Monoid( (<>) ) -import Control.Applicative( (<$>) ) - -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , lerp - , norm ) - -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types - --- | Transform a list a point to a list of lines --- --- > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d] --- -lineFromPath :: [Point] -> [Line] -lineFromPath [] = [] -lineFromPath lst@(_:rest) = - uncurry Line <$> zip lst rest - -lineLength :: Line -> Float -lineLength (Line a b) = norm (b ^-^ a) - -sanitizeLine :: Line -> Container Primitive -sanitizeLine l@(Line p1 p2) - | p1 `isNearby` p2 = mempty - | otherwise = pure $ LinePrim l - -lineBreakAt :: Line -> Float -> (Line, Line) -lineBreakAt (Line a b) t = (Line a ab, Line ab b) - where ab = lerp t a b - -flattenLine :: Line -> Container Primitive -flattenLine = pure . LinePrim - -offsetLine :: Float -> Line -> Container Primitive -offsetLine offset (Line a b) = pure . LinePrim $ Line shiftedA shiftedB - where - u = a `normal` b - shiftedA = a ^+^ (u ^* offset) - shiftedB = b ^+^ (u ^* offset) - --- | Clamp the bezier curve inside a rectangle --- given in parameter. -clipLine :: Point -- ^ Point representing the "minimal" point for cliping - -> Point -- ^ Point representing the "maximal" point for cliping - -> Line -- ^ The line - -> Container Primitive -clipLine mini maxi poly@(Line a b) - -- If we are in the range bound, return the curve - -- unaltered - | insideX && insideY = pure . LinePrim $ poly - -- If one of the component is outside, clamp - -- the components on the boundaries and output a - -- straight line on this boundary. Useful for the - -- filing case, to clamp the polygon drawing on - -- the edge - | outsideX || outsideY = pure . LinePrim $ Line clampedA clampedB - - -- Not completly inside nor outside, just divide - -- and conquer. - | otherwise = recurse (Line a m) <> recurse (Line m b) - where -- Minimal & maximal dimension of the bezier curve - bmin = vmin a b - bmax = vmax a b - - recurse = clipLine mini maxi - - clamper = clampPoint mini maxi - clampedA = clamper a - clampedB = clamper b - - V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi - V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin - - -- A X-----X-----X B - -- AB - ab = a `midPoint` b - - -- mini - -- +-------------+ - -- | | - -- | | - -- | | - -- +-------------+ - -- maxi - -- the edgeSeparator vector encode which edge - -- is te nearest to the midpoint. - -- if True then it's the 'min' edges which are - -- the nearest, otherwise it's the maximum edge - edgeSeparator = - vabs (ab ^-^ mini) ^<^ vabs (ab ^-^ maxi) - - -- So here we 'solidify' the nearest edge position - -- in an edge vector. - edge = vpartition edgeSeparator mini maxi - - -- If we're near an edge, snap the component to the - -- edge. - m = vpartition (vabs (ab ^-^ edge) ^< 0.1) edge ab - --- TODO: implement better algorithm for lines, should --- be doable. -decomposeLine :: Line -> Producer EdgeSample -decomposeLine (Line (V2 aRx aRy) (V2 bRx bRy)) = go aRx aRy bRx bRy where - go !ax !ay !bx !by cont - | insideX && insideY = - let !px = fromIntegral $ min floorAx floorBx - !py = fromIntegral $ min floorAy floorBy - !w = px + 1 - (bx `middle` ax) - !h = by - ay - in - EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont - where - floorAx, floorAy :: Int - !floorAx = floor ax - !floorAy = floor ay - - !floorBx = floor bx - !floorBy = floor by - - !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int) - !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int) - - - go !ax !ay !bx !by cont = go ax ay mx my $ go mx my bx by cont - where - !abx = ax `middle` bx - !aby = ay `middle` by - - !mx | abs (abx - mini) < 0.1 = mini - | abs (abx - maxi) < 0.1 = maxi - | otherwise = abx - where !mini = fromIntegral (floor abx :: Int) - !maxi = fromIntegral (ceiling abx :: Int) - - !my | abs (aby - mini) < 0.1 = mini - | abs (aby - maxi) < 0.1 = maxi - | otherwise = aby - where !mini = fromIntegral (floor aby :: Int) - !maxi = fromIntegral (ceiling aby :: Int) - +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +-- | Handle straight lines polygon. +module Graphics.Rasterific.Line + ( lineFromPath + , decomposeLine + , clipLine + , sanitizeLine + , lineBreakAt + , flattenLine + , lineLength + , offsetLine + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<$>) ) +import Data.Monoid( mempty ) +#endif + +import Data.Monoid( (<>) ) + +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , lerp + , norm ) + +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types + +-- | Transform a list a point to a list of lines +-- +-- > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d] +-- +lineFromPath :: [Point] -> [Line] +lineFromPath [] = [] +lineFromPath lst@(_:rest) = + uncurry Line <$> zip lst rest + +lineLength :: Line -> Float +lineLength (Line a b) = norm (b ^-^ a) + +sanitizeLine :: Line -> Container Primitive +sanitizeLine l@(Line p1 p2) + | p1 `isNearby` p2 = mempty + | otherwise = pure $ LinePrim l + +lineBreakAt :: Line -> Float -> (Line, Line) +lineBreakAt (Line a b) t = (Line a ab, Line ab b) + where ab = lerp t a b + +flattenLine :: Line -> Container Primitive +flattenLine = pure . LinePrim + +offsetLine :: Float -> Line -> Container Primitive +offsetLine offset (Line a b) = pure . LinePrim $ Line shiftedA shiftedB + where + u = a `normal` b + shiftedA = a ^+^ (u ^* offset) + shiftedB = b ^+^ (u ^* offset) + +-- | Clamp the bezier curve inside a rectangle +-- given in parameter. +clipLine :: Point -- ^ Point representing the "minimal" point for cliping + -> Point -- ^ Point representing the "maximal" point for cliping + -> Line -- ^ The line + -> Container Primitive +clipLine mini maxi poly@(Line a b) + -- If we are in the range bound, return the curve + -- unaltered + | insideX && insideY = pure . LinePrim $ poly + -- If one of the component is outside, clamp + -- the components on the boundaries and output a + -- straight line on this boundary. Useful for the + -- filing case, to clamp the polygon drawing on + -- the edge + | outsideX || outsideY = pure . LinePrim $ Line clampedA clampedB + + -- Not completly inside nor outside, just divide + -- and conquer. + | otherwise = recurse (Line a m) <> recurse (Line m b) + where -- Minimal & maximal dimension of the bezier curve + bmin = vmin a b + bmax = vmax a b + + recurse = clipLine mini maxi + + clamper = clampPoint mini maxi + clampedA = clamper a + clampedB = clamper b + + V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi + V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin + + -- A X-----X-----X B + -- AB + ab = a `midPoint` b + + -- mini + -- +-------------+ + -- | | + -- | | + -- | | + -- +-------------+ + -- maxi + -- the edgeSeparator vector encode which edge + -- is te nearest to the midpoint. + -- if True then it's the 'min' edges which are + -- the nearest, otherwise it's the maximum edge + edgeSeparator = + vabs (ab ^-^ mini) ^<^ vabs (ab ^-^ maxi) + + -- So here we 'solidify' the nearest edge position + -- in an edge vector. + edge = vpartition edgeSeparator mini maxi + + -- If we're near an edge, snap the component to the + -- edge. + m = vpartition (vabs (ab ^-^ edge) ^< 0.1) edge ab + +-- TODO: implement better algorithm for lines, should +-- be doable. +decomposeLine :: Line -> Producer EdgeSample +decomposeLine (Line (V2 aRx aRy) (V2 bRx bRy)) = go aRx aRy bRx bRy where + go !ax !ay !bx !by cont + | insideX && insideY = + let !px = fromIntegral $ min floorAx floorBx + !py = fromIntegral $ min floorAy floorBy + !w = px + 1 - (bx `middle` ax) + !h = by - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont + where + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay + + !floorBx = floor bx + !floorBy = floor by + + !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int) + !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int) + + + go !ax !ay !bx !by cont = go ax ay mx my $ go mx my bx by cont + where + !abx = ax `middle` bx + !aby = ay `middle` by + + !mx | abs (abx - mini) < 0.1 = mini + | abs (abx - maxi) < 0.1 = maxi + | otherwise = abx + where !mini = fromIntegral (floor abx :: Int) + !maxi = fromIntegral (ceiling abx :: Int) + + !my | abs (aby - mini) < 0.1 = mini + | abs (aby - maxi) < 0.1 = maxi + | otherwise = aby + where !mini = fromIntegral (floor aby :: Int) + !maxi = fromIntegral (ceiling aby :: Int) + diff --git a/src/Graphics/Rasterific/Operators.hs b/src/Graphics/Rasterific/Operators.hs --- a/src/Graphics/Rasterific/Operators.hs +++ b/src/Graphics/Rasterific/Operators.hs @@ -1,165 +1,162 @@ -{-# LANGUAGE CPP #-} --- | Module providing basic helper functions to help --- build vector/point calculations. -module Graphics.Rasterific.Operators - ( -- * Lifted operators - (^&&^) - , (^||^) - , (^==^) - , (^/=^) - , (^<=^) - , (^<^) - , (^<) - - -- * Lifted functions - , vmin - , vmax - , vabs - , vfloor - , vceil - , clampPoint - , midPoint - , middle - , vpartition - , normal - , ifZero - , isNearby - , isDistingableFrom - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( Applicative ) -#endif -import Control.Applicative( liftA2 - , liftA3 - , (<$>) - ) - -import Graphics.Rasterific.Linear - ( V2( .. ) - , Additive( .. ) - , Epsilon( nearZero ) - , (^+^) - , (^*) - , dot - , normalize - ) - -import Graphics.Rasterific.Types - -infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ -infixr 3 ^&&^ -infixr 2 ^||^ - --- | Pairwise boolean and operator -(^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool -{-# INLINE (^&&^) #-} -(^&&^) = liftA2 (&&) - --- | Pairwise boolean or operator -(^||^) :: (Applicative a) => a Bool -> a Bool -> a Bool -{-# INLINE (^||^) #-} -(^||^) = liftA2 (||) - --- | Pairwise vector/point equal operator -(^==^) :: (Eq v, Applicative a) => a v -> a v -> a Bool -{-# INLINE (^==^) #-} -(^==^) = liftA2 (==) - --- | Pairwise vector/point lower than or equal operator -(^<=^) :: (Ord v, Applicative a) => a v -> a v -> a Bool -{-# INLINE (^<=^) #-} -(^<=^) = liftA2 (<=) - --- | Pairwise vector/point lower than operator -(^<^) :: (Ord v, Applicative a) => a v -> a v -> a Bool -{-# INLINE (^<^) #-} -(^<^) = liftA2 (<) - --- | Component/scalar lower than operator. -(^<) :: (Applicative a, Ord v) => a v -> v -> a Bool -{-# INLINE (^<) #-} -(^<) vec v = (< v) <$> vec - --- | Pairwise vector/point difference operator. -(^/=^) :: (Applicative a, Eq v) => a v -> a v -> a Bool -{-# INLINE (^/=^) #-} -(^/=^) = liftA2 (/=) - --- | Min function between two vector/points. --- Work on every component separately. -vmin :: (Ord n, Applicative a) => a n -> a n -> a n -{-# INLINE vmin #-} -vmin = liftA2 min - --- | Max function between to vector/point. --- Work on every component separatly. -vmax :: (Ord n, Applicative a) => a n -> a n -> a n -{-# INLINE vmax #-} -vmax = liftA2 max - --- | Abs function for every component of the vector/point. -vabs :: (Num n, Functor a) => a n -> a n -{-# INLINE vabs #-} -vabs = fmap abs - --- | Floor function for every component of the vector/point. -vfloor :: (Functor a) => a Float -> a Int -{-# INLINE vfloor #-} -vfloor = fmap floor - --- | ceil function for every component of the vector/point. -vceil :: (Functor a) => a Float -> a Int -{-# INLINE vceil #-} -vceil = fmap ceiling - --- | Given a point, clamp every coordinates between --- a given minimum and maximum. -clampPoint :: Point -> Point -> Point -> Point -{-# INLINE clampPoint #-} -clampPoint mini maxi v = vmin maxi $ vmax mini v - --- | Given two points, return a point in the middle --- of them. -midPoint :: (Additive a) => a Float -> a Float -> a Float -{-# INLINE midPoint #-} -midPoint a b = (a ^+^ b) ^* 0.5 - -middle :: (Fractional a) => a -> a -> a -{-# INLINE middle #-} -middle a b = (a + b) * 0.5 - --- | Given a boolean choice vector, return elements of --- the first one if true, of the second one otherwise. -vpartition :: (Applicative a) => a Bool -> a v -> a v -> a v -{-# INLINE vpartition #-} -vpartition = liftA3 choose - where choose True a _ = a - choose False _ b = b - --- | Calculate a normal vector -normal :: (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v -{-# INLINE normal #-} -normal (V2 ax ay) (V2 bx by) = normalize $ V2 (ay - by) (bx - ax) - --- | Return the second operand if the vector is --- nearly null -ifZero :: (Epsilon v) => v -> v -> v -{-# INLINE ifZero #-} -ifZero u v | nearZero u = v - | otherwise = u - --- | Tell if two points are nearly indistinguishable. --- If indistinguishable, we can treat them as the same --- point. -isNearby :: Point -> Point -> Bool -{-# INLINE isNearby #-} -isNearby p1 p2 = squareDist < 0.0001 - where vec = p1 ^-^ p2 - squareDist = vec `dot` vec - --- | simply `not (a `isNearby` b)` -isDistingableFrom :: Point -> Point -> Bool -{-# INLINE isDistingableFrom #-} -isDistingableFrom a b = not $ isNearby a b - +{-# LANGUAGE CPP #-} +-- | Module providing basic helper functions to help +-- build vector/point calculations. +module Graphics.Rasterific.Operators + ( -- * Lifted operators + (^&&^) + , (^||^) + , (^==^) + , (^/=^) + , (^<=^) + , (^<^) + , (^<) + + -- * Lifted functions + , vmin + , vmax + , vabs + , vfloor + , vceil + , clampPoint + , midPoint + , middle + , vpartition + , normal + , ifZero + , isNearby + , isDistingableFrom + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( Applicative, (<$>) ) +#endif +import Control.Applicative( liftA2, liftA3 ) + +import Graphics.Rasterific.Linear + ( V2( .. ) + , Additive( .. ) + , Epsilon( nearZero ) + , (^+^) + , (^*) + , dot + , normalize + ) + +import Graphics.Rasterific.Types + +infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ +infixr 3 ^&&^ +infixr 2 ^||^ + +-- | Pairwise boolean and operator +(^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool +{-# INLINE (^&&^) #-} +(^&&^) = liftA2 (&&) + +-- | Pairwise boolean or operator +(^||^) :: (Applicative a) => a Bool -> a Bool -> a Bool +{-# INLINE (^||^) #-} +(^||^) = liftA2 (||) + +-- | Pairwise vector/point equal operator +(^==^) :: (Eq v, Applicative a) => a v -> a v -> a Bool +{-# INLINE (^==^) #-} +(^==^) = liftA2 (==) + +-- | Pairwise vector/point lower than or equal operator +(^<=^) :: (Ord v, Applicative a) => a v -> a v -> a Bool +{-# INLINE (^<=^) #-} +(^<=^) = liftA2 (<=) + +-- | Pairwise vector/point lower than operator +(^<^) :: (Ord v, Applicative a) => a v -> a v -> a Bool +{-# INLINE (^<^) #-} +(^<^) = liftA2 (<) + +-- | Component/scalar lower than operator. +(^<) :: (Applicative a, Ord v) => a v -> v -> a Bool +{-# INLINE (^<) #-} +(^<) vec v = (< v) <$> vec + +-- | Pairwise vector/point difference operator. +(^/=^) :: (Applicative a, Eq v) => a v -> a v -> a Bool +{-# INLINE (^/=^) #-} +(^/=^) = liftA2 (/=) + +-- | Min function between two vector/points. +-- Work on every component separately. +vmin :: (Ord n, Applicative a) => a n -> a n -> a n +{-# INLINE vmin #-} +vmin = liftA2 min + +-- | Max function between to vector/point. +-- Work on every component separatly. +vmax :: (Ord n, Applicative a) => a n -> a n -> a n +{-# INLINE vmax #-} +vmax = liftA2 max + +-- | Abs function for every component of the vector/point. +vabs :: (Num n, Functor a) => a n -> a n +{-# INLINE vabs #-} +vabs = fmap abs + +-- | Floor function for every component of the vector/point. +vfloor :: (Functor a) => a Float -> a Int +{-# INLINE vfloor #-} +vfloor = fmap floor + +-- | ceil function for every component of the vector/point. +vceil :: (Functor a) => a Float -> a Int +{-# INLINE vceil #-} +vceil = fmap ceiling + +-- | Given a point, clamp every coordinates between +-- a given minimum and maximum. +clampPoint :: Point -> Point -> Point -> Point +{-# INLINE clampPoint #-} +clampPoint mini maxi v = vmin maxi $ vmax mini v + +-- | Given two points, return a point in the middle +-- of them. +midPoint :: (Additive a) => a Float -> a Float -> a Float +{-# INLINE midPoint #-} +midPoint a b = (a ^+^ b) ^* 0.5 + +middle :: (Fractional a) => a -> a -> a +{-# INLINE middle #-} +middle a b = (a + b) * 0.5 + +-- | Given a boolean choice vector, return elements of +-- the first one if true, of the second one otherwise. +vpartition :: (Applicative a) => a Bool -> a v -> a v -> a v +{-# INLINE vpartition #-} +vpartition = liftA3 choose + where choose True a _ = a + choose False _ b = b + +-- | Calculate a normal vector +normal :: (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v +{-# INLINE normal #-} +normal (V2 ax ay) (V2 bx by) = normalize $ V2 (ay - by) (bx - ax) + +-- | Return the second operand if the vector is +-- nearly null +ifZero :: (Epsilon v) => v -> v -> v +{-# INLINE ifZero #-} +ifZero u v | nearZero u = v + | otherwise = u + +-- | Tell if two points are nearly indistinguishable. +-- If indistinguishable, we can treat them as the same +-- point. +isNearby :: Point -> Point -> Bool +{-# INLINE isNearby #-} +isNearby p1 p2 = squareDist < 0.0001 + where vec = p1 ^-^ p2 + squareDist = vec `dot` vec + +-- | simply `not (a `isNearby` b)` +isDistingableFrom :: Point -> Point -> Bool +{-# INLINE isDistingableFrom #-} +isDistingableFrom a b = not $ isNearby a b + diff --git a/src/Graphics/Rasterific/PathWalker.hs b/src/Graphics/Rasterific/PathWalker.hs --- a/src/Graphics/Rasterific/PathWalker.hs +++ b/src/Graphics/Rasterific/PathWalker.hs @@ -1,131 +1,128 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | This module help the walking of path of any shape, --- being able to return the current position and the --- actual orientation. -module Graphics.Rasterific.PathWalker( PathWalkerT - , PathWalker - , PathDrawer - , runPathWalking - , advanceBy - , currentPosition - , currentTangeant - , drawOrdersOnPath - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable( foldMap ) -import Data.Monoid( mempty ) -import Control.Applicative( Applicative, (<*>) ) -#endif - -import Data.Monoid( (<>) ) -import Control.Applicative( (<$>) ) - -import Control.Monad.Identity( Identity ) -import Control.Monad.State( StateT - , MonadTrans - , lift - , evalStateT - , modify - , gets ) -import Data.Maybe( fromMaybe ) - -import Graphics.Rasterific.Types -import Graphics.Rasterific.Linear -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.StrokeInternal -import Graphics.Rasterific.PlaneBoundable -import Graphics.Rasterific.Immediate - --- | The walking transformer monad. -newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a) - deriving (Monad, Applicative, Functor, MonadTrans) - --- | Simpler alias if monad transformers are not --- needed. -type PathWalker a = PathWalkerT Identity a - --- | State of the path walker, just a bunch of primitives --- with continuity guarantee. The continuity is guaranteed --- by the Path used to derive this primitives. -data WalkerState = WalkerState - { _walkerPrims :: ![Primitive] - } - --- | Create a path walker from a given path -runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a -runPathWalking path (PathWalkerT walker) = evalStateT walker initialState - where - initialState = WalkerState primsOfPath - primsOfPath = listOfContainer - . flatten - . containerOfList - $ pathToPrimitives path - --- | Advance by the given amount of pixels on the path. -advanceBy :: Monad m => Float -> PathWalkerT m () -advanceBy by = PathWalkerT . modify $ \s -> - let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in - s { _walkerPrims = leftPrimitives } - --- | Obtain the current position if we are still on the --- path, if not, return Nothing. -currentPosition :: (Monad m) => PathWalkerT m (Maybe Point) -currentPosition = PathWalkerT $ gets (currPos . _walkerPrims) - where - currPos [] = Nothing - currPos (prim:_) = Just $ firstPointOf prim - --- | Obtain the current tangeant of the path if we're still --- on it. Return Nothing otherwise. -currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector) -currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims) - where - currTangeant [] = Nothing - currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim - --- | Callback function in charge to transform the DrawOrder --- given the transformation to place it on the path. -type PathDrawer m px = - Transformation -> PlaneBound -> DrawOrder px -> m () - --- | This function is the workhorse of the placement, it will --- walk the path and calculate the appropriate transformation --- for every order. -drawOrdersOnPath :: Monad m - => PathDrawer m px -- ^ Function handling the placement of the order. - -> Float -- ^ Starting offset - -> Float -- ^ Baseline vertical position in the orders. - -> Path -- ^ Path on which to place the orders. - -> [DrawOrder px] -- ^ Orders to place on a path. - -> m () -drawOrdersOnPath drawer startOffset baseline path orders = - runPathWalking path $ advanceBy startOffset >> go Nothing orders where - go _ [] = return () - go prevX (img : rest) = do - let bounds = - foldMap (foldMap planeBounds) $ _orderPrimitives img - width = boundWidth bounds - cx = fromMaybe startX prevX - V2 startX _ = boundLowerLeftCorner bounds - V2 endX _ = _planeMaxBound bounds - halfWidth = width / 2 - spaceWidth = abs $ startX - cx - translation = V2 (negate startX - halfWidth) (- baseline) - - if bounds == mempty then go prevX rest - else do - advanceBy (halfWidth + spaceWidth) - mayPos <- currentPosition - mayDir <- currentTangeant - case (,) <$> mayPos <*> mayDir of - Nothing -> return () -- out of path, stop drawing - Just (pos, dir) -> do - let imageTransform = - translate pos <> toNewXBase dir - <> translate translation - lift $ drawer imageTransform bounds img - advanceBy halfWidth - go (Just endX) rest - +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +-- | This module help the walking of path of any shape, +-- being able to return the current position and the +-- actual orientation. +module Graphics.Rasterific.PathWalker( PathWalkerT + , PathWalker + , PathDrawer + , runPathWalking + , advanceBy + , currentPosition + , currentTangeant + , drawOrdersOnPath + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( Applicative, (<*>), (<$>) ) +#endif + +import Data.Monoid( (<>) ) + +import Control.Monad.Identity( Identity ) +import Control.Monad.State( StateT + , MonadTrans + , lift + , evalStateT + , modify + , gets ) +import Data.Maybe( fromMaybe ) + +import Graphics.Rasterific.Types +import Graphics.Rasterific.Linear +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.StrokeInternal +import Graphics.Rasterific.PlaneBoundable +import Graphics.Rasterific.Immediate + +-- | The walking transformer monad. +newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a) + deriving (Monad, Applicative, Functor, MonadTrans) + +-- | Simpler alias if monad transformers are not +-- needed. +type PathWalker a = PathWalkerT Identity a + +-- | State of the path walker, just a bunch of primitives +-- with continuity guarantee. The continuity is guaranteed +-- by the Path used to derive this primitives. +data WalkerState = WalkerState + { _walkerPrims :: ![Primitive] + } + +-- | Create a path walker from a given path +runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a +runPathWalking path (PathWalkerT walker) = evalStateT walker initialState + where + initialState = WalkerState primsOfPath + primsOfPath = listOfContainer + . flatten + . containerOfList + $ pathToPrimitives path + +-- | Advance by the given amount of pixels on the path. +advanceBy :: Monad m => Float -> PathWalkerT m () +advanceBy by = PathWalkerT . modify $ \s -> + let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in + s { _walkerPrims = leftPrimitives } + +-- | Obtain the current position if we are still on the +-- path, if not, return Nothing. +currentPosition :: (Monad m) => PathWalkerT m (Maybe Point) +currentPosition = PathWalkerT $ gets (currPos . _walkerPrims) + where + currPos [] = Nothing + currPos (prim:_) = Just $ firstPointOf prim + +-- | Obtain the current tangeant of the path if we're still +-- on it. Return Nothing otherwise. +currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector) +currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims) + where + currTangeant [] = Nothing + currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim + +-- | Callback function in charge to transform the DrawOrder +-- given the transformation to place it on the path. +type PathDrawer m px = + Transformation -> PlaneBound -> DrawOrder px -> m () + +-- | This function is the workhorse of the placement, it will +-- walk the path and calculate the appropriate transformation +-- for every order. +drawOrdersOnPath :: Monad m + => PathDrawer m px -- ^ Function handling the placement of the order. + -> Float -- ^ Starting offset + -> Float -- ^ Baseline vertical position in the orders. + -> Path -- ^ Path on which to place the orders. + -> [DrawOrder px] -- ^ Orders to place on a path. + -> m () +drawOrdersOnPath drawer startOffset baseline path orders = + runPathWalking path $ advanceBy startOffset >> go Nothing orders where + go _ [] = return () + go prevX (img : rest) = do + let bounds = planeBounds img + width = boundWidth bounds + cx = fromMaybe startX prevX + V2 startX _ = boundLowerLeftCorner bounds + V2 endX _ = _planeMaxBound bounds + halfWidth = width / 2 + spaceWidth = abs $ startX - cx + translation = V2 (negate startX - halfWidth) (- baseline) + + if bounds == mempty then go prevX rest + else do + advanceBy (halfWidth + spaceWidth) + mayPos <- currentPosition + mayDir <- currentTangeant + case (,) <$> mayPos <*> mayDir of + Nothing -> return () -- out of path, stop drawing + Just (pos, dir) -> do + let imageTransform = + translate pos <> toNewXBase dir + <> translate translation + lift $ drawer imageTransform bounds img + advanceBy halfWidth + go (Just endX) rest + diff --git a/src/Graphics/Rasterific/PlaneBoundable.hs b/src/Graphics/Rasterific/PlaneBoundable.hs --- a/src/Graphics/Rasterific/PlaneBoundable.hs +++ b/src/Graphics/Rasterific/PlaneBoundable.hs @@ -1,88 +1,87 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} --- | Module implementing types used for geometry --- bound calculations. -module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. ) - , PlaneBoundable( .. ) - , boundWidth - , boundHeight - , boundLowerLeftCorner - ) where - -#if !MIN_VERSION_base(4,8,0) --- to be removed with GHC 7.12 ? -import Control.Applicative( (<*>) ) -import Data.Monoid( Monoid( .. ) ) -import Data.Foldable( foldMap ) -#endif - -import Control.Applicative( (<$>) ) -import Data.Monoid( (<>) ) - -import Graphics.Rasterific.Linear( V2( .. ) ) -import Graphics.Rasterific.Types -import Graphics.Rasterific.CubicBezier - --- | Represent the minimal axis aligned rectangle --- in which some primitives can be drawn. Should --- fit to bezier curve and not use directly their --- control points. -data PlaneBound = PlaneBound - { -- | Corner upper left of the bounding box of - -- the considered primitives. - _planeMinBound :: !Point - -- | Corner lower right of the bounding box of - -- the considered primitives. - , _planeMaxBound :: !Point - } - deriving (Eq, Show) - --- | Extract the width of the bounds -boundWidth :: PlaneBound -> Float -boundWidth (PlaneBound (V2 x0 _) (V2 x1 _)) = x1 - x0 - --- | Extract the height of the bound -boundHeight :: PlaneBound -> Float -boundHeight (PlaneBound (V2 _ y0) (V2 _ y1)) = y1 - y0 - --- | Extract the position of the lower left corner of the --- bounds. -boundLowerLeftCorner :: PlaneBound -> Point -boundLowerLeftCorner (PlaneBound (V2 x _) (V2 _ y)) = V2 x y - -instance Monoid PlaneBound where - mempty = PlaneBound infPoint negInfPoint - where - infPoint = V2 (1 / 0) (1 / 0) - negInfPoint = V2 (negate 1 / 0) (negate 1 / 0) - - mappend (PlaneBound mini1 maxi1) (PlaneBound mini2 maxi2) = - PlaneBound (min <$> mini1 <*> mini2) - (max <$> maxi1 <*> maxi2) - --- | Class used to calculate bounds of various geometrical --- primitives. The calculated is precise, the bounding should --- be minimal with respect with drawn curve. -class PlaneBoundable a where - -- | Given a graphical elements, calculate it's bounds. - planeBounds :: a -> PlaneBound - -instance PlaneBoundable Point where - planeBounds a = PlaneBound a a - -instance PlaneBoundable Line where - planeBounds (Line p1 p2) = planeBounds p1 <> planeBounds p2 - -instance PlaneBoundable Bezier where - planeBounds (Bezier p0 p1 p2) = - planeBounds (CubicBezier p0 p1 p1 p2) - -instance PlaneBoundable CubicBezier where - planeBounds = foldMap planeBounds . cubicBezierBounds - -instance PlaneBoundable Primitive where - planeBounds (LinePrim l) = planeBounds l - planeBounds (BezierPrim b) = planeBounds b - planeBounds (CubicBezierPrim c) = planeBounds c - +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +-- | Module implementing types used for geometry +-- bound calculations. +module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. ) + , PlaneBoundable( .. ) + , boundWidth + , boundHeight + , boundLowerLeftCorner + ) where + +#if !MIN_VERSION_base(4,8,0) +-- to be removed with GHC 7.12 ? +import Control.Applicative( (<$>), (<*>) ) +import Data.Monoid( Monoid( .. ) ) +import Data.Foldable( Foldable( foldMap ) ) +#endif + +import Data.Monoid( (<>) ) + +import Graphics.Rasterific.Linear( V2( .. ) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.CubicBezier + +-- | Represent the minimal axis aligned rectangle +-- in which some primitives can be drawn. Should +-- fit to bezier curve and not use directly their +-- control points. +data PlaneBound = PlaneBound + { -- | Corner upper left of the bounding box of + -- the considered primitives. + _planeMinBound :: !Point + -- | Corner lower right of the bounding box of + -- the considered primitives. + , _planeMaxBound :: !Point + } + deriving (Eq, Show) + +-- | Extract the width of the bounds +boundWidth :: PlaneBound -> Float +boundWidth (PlaneBound (V2 x0 _) (V2 x1 _)) = x1 - x0 + +-- | Extract the height of the bound +boundHeight :: PlaneBound -> Float +boundHeight (PlaneBound (V2 _ y0) (V2 _ y1)) = y1 - y0 + +-- | Extract the position of the lower left corner of the +-- bounds. +boundLowerLeftCorner :: PlaneBound -> Point +boundLowerLeftCorner (PlaneBound (V2 x _) (V2 _ y)) = V2 x y + +instance Monoid PlaneBound where + mempty = PlaneBound infPoint negInfPoint + where + infPoint = V2 (1 / 0) (1 / 0) + negInfPoint = V2 (negate 1 / 0) (negate 1 / 0) + + mappend (PlaneBound mini1 maxi1) (PlaneBound mini2 maxi2) = + PlaneBound (min <$> mini1 <*> mini2) + (max <$> maxi1 <*> maxi2) + +-- | Class used to calculate bounds of various geometrical +-- primitives. The calculated is precise, the bounding should +-- be minimal with respect with drawn curve. +class PlaneBoundable a where + -- | Given a graphical elements, calculate it's bounds. + planeBounds :: a -> PlaneBound + +instance PlaneBoundable Point where + planeBounds a = PlaneBound a a + +instance PlaneBoundable Line where + planeBounds (Line p1 p2) = planeBounds p1 <> planeBounds p2 + +instance PlaneBoundable Bezier where + planeBounds (Bezier p0 p1 p2) = + planeBounds (CubicBezier p0 p1 p1 p2) + +instance PlaneBoundable CubicBezier where + planeBounds = foldMap planeBounds . cubicBezierBounds + +instance PlaneBoundable Primitive where + planeBounds (LinePrim l) = planeBounds l + planeBounds (BezierPrim b) = planeBounds b + planeBounds (CubicBezierPrim c) = planeBounds c + diff --git a/src/Graphics/Rasterific/Shading.hs b/src/Graphics/Rasterific/Shading.hs --- a/src/Graphics/Rasterific/Shading.hs +++ b/src/Graphics/Rasterific/Shading.hs @@ -1,490 +1,493 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -module Graphics.Rasterific.Shading - ( Texture( .. ) - , Gradient - , ShaderFunction - , transformTextureToFiller - , dumpTexture - ) where - -import Control.Monad.Primitive( PrimState - -- one day (GHC >= 7.10 ?) - {-, PrimMonad-} - ) -import Data.Fixed( mod' ) -import Data.Monoid( (<>) ) -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^/) - , dot - , norm - ) - - -import Control.Monad.ST( ST ) -import qualified Data.Vector as V - -import Codec.Picture.Types( Pixel( .. ) - , Image( .. ) - , MutableImage( .. ) - , Pixel8 - , PixelRGBA8 - , unsafeWritePixelBetweenAt - , readPackedPixelAt - , writePackedPixelAt - ) - -import Graphics.Rasterific.Types( Point - , Vector - , Line( .. ) - , SamplerRepeat( .. ) ) -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Compositor( Modulable( .. ) - , ModulablePixel - , RenderablePixel - , compositionAlpha ) - -type ShaderFunction px = Float -> Float -> px - --- | Reification of texture type -data Texture px - = SolidTexture !px - | LinearGradientTexture !(Gradient px) !Line - | RadialGradientTexture !(Gradient px) !Point !Float - | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point - | WithSampler !SamplerRepeat (Texture px) - | WithTextureTransform !Transformation (Texture px) - | SampledTexture !(Image px) - | RawTexture !(Image px) - | ShaderTexture !(ShaderFunction px) - | ModulateTexture (Texture px) (Texture (PixelBaseComponent px)) - -dumpTexture :: ( Show px - , Show (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - ) => Texture px -> String -dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px++ ")" -dumpTexture (LinearGradientTexture grad (Line a b)) = - "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")" -dumpTexture (RadialGradientTexture grad p rad) = - "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad -dumpTexture (RadialGradientWithFocusTexture grad center rad focus) = - "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center - ++ ") " ++ show rad ++ " (" ++ show focus ++ ")" -dumpTexture (WithSampler sampler sub) = - "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")" -dumpTexture (WithTextureTransform trans sub) = - "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")" -dumpTexture (SampledTexture _) = "sampledImageTexture " -dumpTexture (RawTexture _) = "" -dumpTexture (ShaderTexture _) = "shaderFunction " -dumpTexture (ModulateTexture sub mask) = - "modulateTexture (" ++ dumpTexture sub ++ ") (" - ++ dumpTexture mask ++ ")" - - -data TextureSpaceInfo = TextureSpaceInfo - { _tsStart :: {-# UNPACK #-} !Point - , _tsDelta :: {-# UNPACK #-} !Vector - , _tsCoverage :: {-# UNPACK #-} !Float - , _tsRepeat :: {-# UNPACK #-} !Int - , _tsBaseIndex :: {-# UNPACK #-} !Int - } - deriving (Eq, Show) - -type CoverageFiller m px = - MutableImage (PrimState m) px -> CoverageSpan -> m () - -type Filler m = - TextureSpaceInfo -> m () - --- | Right now, we must stick to ST, due to the fact that --- we can't specialize with parameterized monad :( -solidColor :: forall s px . (ModulablePixel px) - => px -> MutableImage s px -> Filler (ST s) -{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8 - -> TextureSpaceInfo -> ST s () #-} -{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8 - -> TextureSpaceInfo -> ST s () #-} -solidColor color _ tsInfo - | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 = - return () -solidColor color img tsInfo - -- We are in the case fully opaque, so we can - -- just overwrite what was there before - | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 = - unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi - {-go 0 $ _tsBaseIndex tsInfo-} - where - !fullOpacity = fullValue :: PixelBaseComponent px - !maxi = _tsRepeat tsInfo - --- We can be transparent, so perform alpha blending. -solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo - where - !opacity = pixelOpacity color - !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo - !(cov, icov) = coverageModulate scanCoverage opacity - !maxi = _tsRepeat tsInfo - !compCount = componentCount (undefined :: px) - - go count _ | count >= maxi = return () - go !count !idx = do - oldPixel <- readPackedPixelAt img idx - writePackedPixelAt img idx - $ compositionAlpha cov icov oldPixel color - go (count + 1) $ idx + compCount - -shaderFiller :: forall s px . (ModulablePixel px) - => ShaderFunction px -> MutableImage s px - -> Filler (ST s) -{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8 - -> MutableImage s PixelRGBA8 - -> Filler (ST s) #-} -{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8 - -> MutableImage s Pixel8 - -> Filler (ST s) #-} -shaderFiller shader img tsInfo = - go 0 (_tsBaseIndex tsInfo) xStart yStart - where - !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo - !maxi = _tsRepeat tsInfo - !compCount = componentCount (undefined :: px) - (V2 xStart yStart) = _tsStart tsInfo - (V2 dx dy) = _tsDelta tsInfo - - go count _ _ _ | count >= maxi = return () - go !count !idx !x !y = do - let !color = shader x y - !opacity = pixelOpacity color - (cov, icov) = coverageModulate scanCoverage opacity - oldPixel <- readPackedPixelAt img idx - writePackedPixelAt img idx - $ compositionAlpha cov icov oldPixel color - go (count + 1) (idx + compCount) (x + dx) (y + dy) - -prepareInfoNoTransform :: (Pixel px) - => MutableImage s px -> CoverageSpan - -> TextureSpaceInfo -prepareInfoNoTransform img coverage = TextureSpaceInfo - { _tsStart = V2 (_coverageX coverage) (_coverageY coverage) - , _tsDelta = V2 1 0 - , _tsCoverage = _coverageVal coverage - , _tsRepeat = floor $ _coverageLength coverage - , _tsBaseIndex = - mutablePixelBaseIndex img (floor $ _coverageX coverage) - (floor $ _coverageY coverage) - } - -prepareInfo :: (Pixel px) - => Maybe Transformation -> MutableImage s px -> CoverageSpan - -> TextureSpaceInfo -prepareInfo Nothing img covSpan = prepareInfoNoTransform img covSpan -prepareInfo (Just t) img covSpan = TextureSpaceInfo - { _tsStart = applyTransformation t - $ V2 (_coverageX covSpan) (_coverageY covSpan) - , _tsDelta = applyVectorTransformation t $ V2 1 0 - , _tsCoverage = _coverageVal covSpan - , _tsRepeat = floor $ _coverageLength covSpan - , _tsBaseIndex = - mutablePixelBaseIndex img (floor $ _coverageX covSpan) - (floor $ _coverageY covSpan) - } - -combineTransform :: Maybe Transformation -> Transformation - -> Maybe Transformation -combineTransform Nothing a = Just a -combineTransform (Just v) a = Just $ v <> a - -withTrans :: Maybe Transformation -> ShaderFunction px - -> ShaderFunction px -withTrans Nothing shader = shader -withTrans (Just v) shader = \x y -> - let V2 x' y' = applyTransformation v (V2 x y) in - shader x' y' - --- | The intent of shader texture is to provide ease of implementation --- If possible providing a custom filler will be more efficient, --- like already done for the solid colors. -shaderOfTexture :: forall px . RenderablePixel px - => Maybe Transformation -> SamplerRepeat -> Texture px - -> ShaderFunction px -{-# SPECIALIZE - shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8 - -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8 - -> ShaderFunction Pixel8 #-} -shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px -shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) = - withTrans trans $ linearGradientShader grad a b sampling -shaderOfTexture trans sampling (RadialGradientTexture grad center radius) = - withTrans trans $ radialGradientShader grad center radius sampling -shaderOfTexture trans sampling (RadialGradientWithFocusTexture grad center - radius focus) = - withTrans trans - $ radialGradientWithFocusShader grad center radius focus - sampling -shaderOfTexture trans _ (WithSampler sampler sub) = - shaderOfTexture trans sampler sub -shaderOfTexture trans sampling (WithTextureTransform transform sub) = - shaderOfTexture (combineTransform trans transform) sampling sub -shaderOfTexture trans sampling (SampledTexture img) = - withTrans trans $ sampledImageShader img sampling -shaderOfTexture trans _ (ShaderTexture func) = - withTrans trans func -shaderOfTexture trans _ (RawTexture img) = - withTrans trans $ imageShader img -shaderOfTexture trans sampling (ModulateTexture texture modulation) = - modulateTexture (shaderOfTexture trans sampling texture) - (shaderOfTexture trans sampling modulation) - - --- | This function will interpret the texture description, helping --- prepare and optimize the real calculation -transformTextureToFiller - :: (RenderablePixel px) - => Texture px -> CoverageFiller (ST s) px -transformTextureToFiller = go Nothing SamplerPad - where - go _ _ (SolidTexture px) = - \img -> solidColor px img . prepareInfoNoTransform img - go trans sampling (WithTextureTransform transform sub) = - go (combineTransform trans transform) sampling sub - go trans _ (WithSampler sampler sub) = - go trans sampler sub - go trans sampling tex = - \img -> shaderFiller shader img . prepareInfo trans img - where shader = shaderOfTexture Nothing sampling tex - --- | A gradient definition is just a list of stop --- and pixel values. For instance for a simple gradient --- of black to white, the finition would be : --- --- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)] --- --- the first stop value must be zero and the last, one. --- -type Gradient px = [(Float, px)] -type GradientArray px = V.Vector (Float, px) - -repeatGradient :: Float -> Float -repeatGradient s = s - fromIntegral (floor s :: Int) - -reflectGradient :: Float -> Float -reflectGradient s = - abs (abs (s - 1) `mod'` 2 - 1) - -gradientColorAt :: ModulablePixel px - => GradientArray px -> Float -> px -{-# SPECIALIZE - gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -{-# SPECIALIZE - gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-} -gradientColorAt grad at - | at <= 0 = snd $ V.head grad - | at >= 1.0 = snd $ V.last grad - | otherwise = go (0, snd $ V.head grad) 0 - where - !maxi = V.length grad - go (prevCoeff, prevValue) ix - | ix >= maxi = snd $ V.last grad - | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px - | otherwise = go value $ ix + 1 - where value@(coeff, px) = grad `V.unsafeIndex` ix - zeroToOne = (at - prevCoeff) / (coeff - prevCoeff) - (cov, icov) = clampCoverage zeroToOne - -gradientColorAtRepeat :: ModulablePixel px - => SamplerRepeat -> GradientArray px -> Float -> px -{-# SPECIALIZE INLINE - gradientColorAtRepeat :: - SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -{-# SPECIALIZE INLINE - gradientColorAtRepeat :: - SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-} -gradientColorAtRepeat SamplerPad grad = gradientColorAt grad -gradientColorAtRepeat SamplerRepeat grad = - gradientColorAt grad . repeatGradient -gradientColorAtRepeat SamplerReflect grad = - gradientColorAt grad . reflectGradient - -linearGradientShader :: ModulablePixel px - => Gradient px -- ^ Gradient description. - -> Point -- ^ Linear gradient start point. - -> Point -- ^ Linear gradient end point. - -> SamplerRepeat - -> ShaderFunction px -{-# SPECIALIZE linearGradientShader - :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat - -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE linearGradientShader - :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat - -> ShaderFunction Pixel8 #-} -linearGradientShader gradient start end repeating = - \x y -> colorAt $ (V2 x y `dot` d) - s00 - where - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - vector = end ^-^ start - d = vector ^/ (vector `dot` vector) - s00 = start `dot` d - --- | Use another image as a texture for the filling. --- Contrary to `imageTexture`, this function perform a bilinear --- filtering on the texture. --- -sampledImageShader :: forall px. ModulablePixel px - => Image px -> SamplerRepeat -> ShaderFunction px -{-# SPECIALIZE - sampledImageShader :: Image Pixel8 -> SamplerRepeat - -> ShaderFunction Pixel8 #-} -{-# SPECIALIZE - sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat - -> ShaderFunction PixelRGBA8 #-} -sampledImageShader img sampling x y = - (at px py `interpX` at pxn py) - `interpY` - (at px pyn `interpX` at pxn pyn) - where - coordSampler SamplerPad maxi v = - min (maxi - 1) . max 0 $ floor v - coordSampler SamplerReflect maxi v = - floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1) - where maxif = fromIntegral maxi - coordSampler SamplerRepeat maxi v = floor v `mod` maxi - - w = fromIntegral $ imageWidth img - h = fromIntegral $ imageHeight img - - clampedX = coordSampler sampling w - clampedY = coordSampler sampling h - - px = clampedX x - pxn = clampedX $ x + 1 - py = clampedY y - pyn = clampedY $ y + 1 - - dx, dy :: Float - dx = x - fromIntegral (floor x :: Int) - dy = y - fromIntegral (floor y :: Int) - - at :: Int -> Int -> px - at xx yy = - unsafePixelAt rawData $ (yy * w + xx) * compCount - - (covX, icovX) = clampCoverage dx - (covY, icovY) = clampCoverage dy - - interpX = mixWith (const $ alphaOver covX icovX) - interpY = mixWith (const $ alphaOver covY icovY) - - compCount = componentCount (undefined :: px) - rawData = imageData img - --- | Use another image as a texture for the filling. --- This texture use the "nearest" filtering, AKA no --- filtering at all. -imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px -{-# SPECIALIZE - imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-} -imageShader img x y = - unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount - where - clampedX = min (w - 1) . max 0 $ floor x - clampedY = min (h - 1) . max 0 $ floor y - !compCount = componentCount (undefined :: px) - !w = imageWidth img - !h = imageHeight img - !rawData = imageData img - -radialGradientShader :: ModulablePixel px - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> SamplerRepeat - -> ShaderFunction px -{-# SPECIALIZE - radialGradientShader - :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat - -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - radialGradientShader - :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat - -> ShaderFunction Pixel8 #-} -radialGradientShader gradient center radius repeating = - \x y -> colorAt $ norm (V2 x y ^-^ center) / radius - where - !colorAt = gradientColorAtRepeat repeating gradArray - !gradArray = V.fromList gradient - -radialGradientWithFocusShader - :: ModulablePixel px - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Point -- ^ Radial gradient focus point - -> SamplerRepeat - -> ShaderFunction px -{-# SPECIALIZE - radialGradientWithFocusShader - :: Gradient PixelRGBA8 -> Point -> Float -> Point - -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-} -{-# SPECIALIZE - radialGradientWithFocusShader - :: Gradient Pixel8 -> Point -> Float -> Point - -> SamplerRepeat -> ShaderFunction Pixel8 #-} -radialGradientWithFocusShader gradient center radius focusScreen repeating = - \x y -> colorAt . go $ V2 x y ^-^ center - where - focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - radiusSquared = radius * radius - dist = sqrt $ focus `dot` focus - clampedFocus@(V2 focusX focusY) - | dist <= r = focus - | otherwise = V2 (r * cos a) (r * sin a) - where a = atan2 origFocusY origFocusX - r = radius * 0.99 - trivial = sqrt $ radiusSquared - origFocusX * origFocusX - - solutionOf (V2 x y) | x == focusX = - V2 focusX (if y > focusY then trivial else negate trivial) - solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint - where - slope = (y - focusY) / (x - focusX) - yint = y - (slope * x) - - a = slope * slope + 1 - b = 2 * slope * yint - c = yint * yint - radiusSquared - det = sqrt $ b * b - 4 * a * c - xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a) - - go pos = sqrt $ curToFocus / distSquared - where - solution = solutionOf pos ^-^ clampedFocus - toFocus = pos ^-^ clampedFocus - distSquared = solution `dot` solution - curToFocus = toFocus `dot` toFocus - --- | Perform a multiplication operation between a full color texture --- and a greyscale one, used for clip-path implementation. -modulateTexture :: ModulablePixel px - => ShaderFunction px - -> ShaderFunction (PixelBaseComponent px) - -> ShaderFunction px -{-# INLINE modulateTexture #-} -modulateTexture fullTexture modulator x y = - colorMap (modulate $ modulator x y) $ fullTexture x y - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +module Graphics.Rasterific.Shading + ( Texture( .. ) + , Gradient + , ShaderFunction + , ImageTransformer + , transformTextureToFiller + , dumpTexture + ) where + +import Control.Monad.Primitive( PrimState + -- one day (GHC >= 7.10 ?) + {-, PrimMonad-} + ) +import Data.Fixed( mod' ) +import Data.Monoid( (<>) ) +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^/) + , dot + , norm + ) + + +import Control.Monad.ST( ST ) +import qualified Data.Vector as V + +import Codec.Picture.Types( Pixel( .. ) + , Image( .. ) + , MutableImage( .. ) + , Pixel8 + , PixelRGBA8 + , unsafeWritePixelBetweenAt + , readPackedPixelAt + , writePackedPixelAt + ) + +import Graphics.Rasterific.Types( Point + , Vector + , Line( .. ) + , SamplerRepeat( .. ) ) +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Rasterize +import Graphics.Rasterific.Compositor( Modulable( .. ) + , ModulablePixel + , RenderablePixel + , compositionAlpha ) + +type ShaderFunction px = Float -> Float -> px + +type ImageTransformer px = Int -> Int -> px -> px + +-- | Reification of texture type +data Texture px + = SolidTexture !px + | LinearGradientTexture !(Gradient px) !Line + | RadialGradientTexture !(Gradient px) !Point !Float + | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point + | WithSampler !SamplerRepeat (Texture px) + | WithTextureTransform !Transformation (Texture px) + | SampledTexture !(Image px) + | RawTexture !(Image px) + | ShaderTexture !(ShaderFunction px) + | ModulateTexture (Texture px) (Texture (PixelBaseComponent px)) + +dumpTexture :: ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + ) => Texture px -> String +dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px++ ")" +dumpTexture (LinearGradientTexture grad (Line a b)) = + "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")" +dumpTexture (RadialGradientTexture grad p rad) = + "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad +dumpTexture (RadialGradientWithFocusTexture grad center rad focus) = + "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center + ++ ") " ++ show rad ++ " (" ++ show focus ++ ")" +dumpTexture (WithSampler sampler sub) = + "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")" +dumpTexture (WithTextureTransform trans sub) = + "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")" +dumpTexture (SampledTexture _) = "sampledImageTexture " +dumpTexture (RawTexture _) = "" +dumpTexture (ShaderTexture _) = "shaderFunction " +dumpTexture (ModulateTexture sub mask) = + "modulateTexture (" ++ dumpTexture sub ++ ") (" + ++ dumpTexture mask ++ ")" + + +data TextureSpaceInfo = TextureSpaceInfo + { _tsStart :: {-# UNPACK #-} !Point + , _tsDelta :: {-# UNPACK #-} !Vector + , _tsCoverage :: {-# UNPACK #-} !Float + , _tsRepeat :: {-# UNPACK #-} !Int + , _tsBaseIndex :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) + +type CoverageFiller m px = + MutableImage (PrimState m) px -> CoverageSpan -> m () + +type Filler m = + TextureSpaceInfo -> m () + +-- | Right now, we must stick to ST, due to the fact that +-- we can't specialize with parameterized monad :( +solidColor :: forall s px . (ModulablePixel px) + => px -> MutableImage s px -> Filler (ST s) +{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8 + -> TextureSpaceInfo -> ST s () #-} +{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8 + -> TextureSpaceInfo -> ST s () #-} +solidColor color _ tsInfo + | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 = + return () +solidColor color img tsInfo + -- We are in the case fully opaque, so we can + -- just overwrite what was there before + | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 = + unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi + {-go 0 $ _tsBaseIndex tsInfo-} + where + !fullOpacity = fullValue :: PixelBaseComponent px + !maxi = _tsRepeat tsInfo + +-- We can be transparent, so perform alpha blending. +solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo + where + !opacity = pixelOpacity color + !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo + !(cov, icov) = coverageModulate scanCoverage opacity + !maxi = _tsRepeat tsInfo + !compCount = componentCount (undefined :: px) + + go count _ | count >= maxi = return () + go !count !idx = do + oldPixel <- readPackedPixelAt img idx + writePackedPixelAt img idx + $ compositionAlpha cov icov oldPixel color + go (count + 1) $ idx + compCount + +shaderFiller :: forall s px . (ModulablePixel px) + => ShaderFunction px -> MutableImage s px + -> Filler (ST s) +{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8 + -> MutableImage s PixelRGBA8 + -> Filler (ST s) #-} +{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8 + -> MutableImage s Pixel8 + -> Filler (ST s) #-} +shaderFiller shader img tsInfo = + go 0 (_tsBaseIndex tsInfo) xStart yStart + where + !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo + !maxi = _tsRepeat tsInfo + !compCount = componentCount (undefined :: px) + (V2 xStart yStart) = _tsStart tsInfo + (V2 dx dy) = _tsDelta tsInfo + + go count _ _ _ | count >= maxi = return () + go !count !idx !x !y = do + let !color = shader x y + !opacity = pixelOpacity color + (cov, icov) = coverageModulate scanCoverage opacity + oldPixel <- readPackedPixelAt img idx + writePackedPixelAt img idx + $ compositionAlpha cov icov oldPixel color + go (count + 1) (idx + compCount) (x + dx) (y + dy) + +prepareInfoNoTransform :: (Pixel px) + => MutableImage s px -> CoverageSpan + -> TextureSpaceInfo +prepareInfoNoTransform img coverage = TextureSpaceInfo + { _tsStart = V2 (_coverageX coverage) (_coverageY coverage) + , _tsDelta = V2 1 0 + , _tsCoverage = _coverageVal coverage + , _tsRepeat = floor $ _coverageLength coverage + , _tsBaseIndex = + mutablePixelBaseIndex img (floor $ _coverageX coverage) + (floor $ _coverageY coverage) + } + +prepareInfo :: (Pixel px) + => Maybe Transformation -> MutableImage s px -> CoverageSpan + -> TextureSpaceInfo +prepareInfo Nothing img covSpan = prepareInfoNoTransform img covSpan +prepareInfo (Just t) img covSpan = TextureSpaceInfo + { _tsStart = applyTransformation t + $ V2 (_coverageX covSpan) (_coverageY covSpan) + , _tsDelta = applyVectorTransformation t $ V2 1 0 + , _tsCoverage = _coverageVal covSpan + , _tsRepeat = floor $ _coverageLength covSpan + , _tsBaseIndex = + mutablePixelBaseIndex img (floor $ _coverageX covSpan) + (floor $ _coverageY covSpan) + } + +combineTransform :: Maybe Transformation -> Transformation + -> Maybe Transformation +combineTransform Nothing a = Just a +combineTransform (Just v) a = Just $ v <> a + +withTrans :: Maybe Transformation -> ShaderFunction px + -> ShaderFunction px +withTrans Nothing shader = shader +withTrans (Just v) shader = \x y -> + let V2 x' y' = applyTransformation v (V2 x y) in + shader x' y' + +-- | The intent of shader texture is to provide ease of implementation +-- If possible providing a custom filler will be more efficient, +-- like already done for the solid colors. +shaderOfTexture :: forall px . RenderablePixel px + => Maybe Transformation -> SamplerRepeat -> Texture px + -> ShaderFunction px +{-# SPECIALIZE + shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8 + -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8 + -> ShaderFunction Pixel8 #-} +shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px +shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) = + withTrans trans $ linearGradientShader grad a b sampling +shaderOfTexture trans sampling (RadialGradientTexture grad center radius) = + withTrans trans $ radialGradientShader grad center radius sampling +shaderOfTexture trans sampling (RadialGradientWithFocusTexture grad center + radius focus) = + withTrans trans + $ radialGradientWithFocusShader grad center radius focus + sampling +shaderOfTexture trans _ (WithSampler sampler sub) = + shaderOfTexture trans sampler sub +shaderOfTexture trans sampling (WithTextureTransform transform sub) = + shaderOfTexture (combineTransform trans transform) sampling sub +shaderOfTexture trans sampling (SampledTexture img) = + withTrans trans $ sampledImageShader img sampling +shaderOfTexture trans _ (ShaderTexture func) = + withTrans trans func +shaderOfTexture trans _ (RawTexture img) = + withTrans trans $ imageShader img +shaderOfTexture trans sampling (ModulateTexture texture modulation) = + modulateTexture (shaderOfTexture trans sampling texture) + (shaderOfTexture trans sampling modulation) + + +-- | This function will interpret the texture description, helping +-- prepare and optimize the real calculation +transformTextureToFiller + :: (RenderablePixel px) + => Texture px -> CoverageFiller (ST s) px +transformTextureToFiller = go Nothing SamplerPad + where + go _ _ (SolidTexture px) = + \img -> solidColor px img . prepareInfoNoTransform img + go trans sampling (WithTextureTransform transform sub) = + go (combineTransform trans transform) sampling sub + go trans _ (WithSampler sampler sub) = + go trans sampler sub + go trans sampling tex = + \img -> shaderFiller shader img . prepareInfo trans img + where shader = shaderOfTexture Nothing sampling tex + +-- | A gradient definition is just a list of stop +-- and pixel values. For instance for a simple gradient +-- of black to white, the finition would be : +-- +-- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)] +-- +-- the first stop value must be zero and the last, one. +-- +type Gradient px = [(Float, px)] +type GradientArray px = V.Vector (Float, px) + +repeatGradient :: Float -> Float +repeatGradient s = s - fromIntegral (floor s :: Int) + +reflectGradient :: Float -> Float +reflectGradient s = + abs (abs (s - 1) `mod'` 2 - 1) + +gradientColorAt :: ModulablePixel px + => GradientArray px -> Float -> px +{-# SPECIALIZE + gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} +{-# SPECIALIZE + gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-} +gradientColorAt grad at + | at <= 0 = snd $ V.head grad + | at >= 1.0 = snd $ V.last grad + | otherwise = go (0, snd $ V.head grad) 0 + where + !maxi = V.length grad + go (prevCoeff, prevValue) ix + | ix >= maxi = snd $ V.last grad + | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px + | otherwise = go value $ ix + 1 + where value@(coeff, px) = grad `V.unsafeIndex` ix + zeroToOne = (at - prevCoeff) / (coeff - prevCoeff) + (cov, icov) = clampCoverage zeroToOne + +gradientColorAtRepeat :: ModulablePixel px + => SamplerRepeat -> GradientArray px -> Float -> px +{-# SPECIALIZE INLINE + gradientColorAtRepeat :: + SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} +{-# SPECIALIZE INLINE + gradientColorAtRepeat :: + SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-} +gradientColorAtRepeat SamplerPad grad = gradientColorAt grad +gradientColorAtRepeat SamplerRepeat grad = + gradientColorAt grad . repeatGradient +gradientColorAtRepeat SamplerReflect grad = + gradientColorAt grad . reflectGradient + +linearGradientShader :: ModulablePixel px + => Gradient px -- ^ Gradient description. + -> Point -- ^ Linear gradient start point. + -> Point -- ^ Linear gradient end point. + -> SamplerRepeat + -> ShaderFunction px +{-# SPECIALIZE linearGradientShader + :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat + -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE linearGradientShader + :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat + -> ShaderFunction Pixel8 #-} +linearGradientShader gradient start end repeating = + \x y -> colorAt $ (V2 x y `dot` d) - s00 + where + colorAt = gradientColorAtRepeat repeating gradArray + gradArray = V.fromList gradient + vector = end ^-^ start + d = vector ^/ (vector `dot` vector) + s00 = start `dot` d + +-- | Use another image as a texture for the filling. +-- Contrary to `imageTexture`, this function perform a bilinear +-- filtering on the texture. +-- +sampledImageShader :: forall px. ModulablePixel px + => Image px -> SamplerRepeat -> ShaderFunction px +{-# SPECIALIZE + sampledImageShader :: Image Pixel8 -> SamplerRepeat + -> ShaderFunction Pixel8 #-} +{-# SPECIALIZE + sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat + -> ShaderFunction PixelRGBA8 #-} +sampledImageShader img sampling x y = + (at px py `interpX` at pxn py) + `interpY` + (at px pyn `interpX` at pxn pyn) + where + coordSampler SamplerPad maxi v = + min (maxi - 1) . max 0 $ floor v + coordSampler SamplerReflect maxi v = + floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1) + where maxif = fromIntegral maxi + coordSampler SamplerRepeat maxi v = floor v `mod` maxi + + w = fromIntegral $ imageWidth img + h = fromIntegral $ imageHeight img + + clampedX = coordSampler sampling w + clampedY = coordSampler sampling h + + px = clampedX x + pxn = clampedX $ x + 1 + py = clampedY y + pyn = clampedY $ y + 1 + + dx, dy :: Float + dx = x - fromIntegral (floor x :: Int) + dy = y - fromIntegral (floor y :: Int) + + at :: Int -> Int -> px + at xx yy = + unsafePixelAt rawData $ (yy * w + xx) * compCount + + (covX, icovX) = clampCoverage dx + (covY, icovY) = clampCoverage dy + + interpX = mixWith (const $ alphaOver covX icovX) + interpY = mixWith (const $ alphaOver covY icovY) + + compCount = componentCount (undefined :: px) + rawData = imageData img + +-- | Use another image as a texture for the filling. +-- This texture use the "nearest" filtering, AKA no +-- filtering at all. +imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px +{-# SPECIALIZE + imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-} +imageShader img x y = + unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount + where + clampedX = min (w - 1) . max 0 $ floor x + clampedY = min (h - 1) . max 0 $ floor y + !compCount = componentCount (undefined :: px) + !w = imageWidth img + !h = imageHeight img + !rawData = imageData img + +radialGradientShader :: ModulablePixel px + => Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> SamplerRepeat + -> ShaderFunction px +{-# SPECIALIZE + radialGradientShader + :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat + -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + radialGradientShader + :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat + -> ShaderFunction Pixel8 #-} +radialGradientShader gradient center radius repeating = + \x y -> colorAt $ norm (V2 x y ^-^ center) / radius + where + !colorAt = gradientColorAtRepeat repeating gradArray + !gradArray = V.fromList gradient + +radialGradientWithFocusShader + :: ModulablePixel px + => Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Point -- ^ Radial gradient focus point + -> SamplerRepeat + -> ShaderFunction px +{-# SPECIALIZE + radialGradientWithFocusShader + :: Gradient PixelRGBA8 -> Point -> Float -> Point + -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + radialGradientWithFocusShader + :: Gradient Pixel8 -> Point -> Float -> Point + -> SamplerRepeat -> ShaderFunction Pixel8 #-} +radialGradientWithFocusShader gradient center radius focusScreen repeating = + \x y -> colorAt . go $ V2 x y ^-^ center + where + focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center + colorAt = gradientColorAtRepeat repeating gradArray + gradArray = V.fromList gradient + radiusSquared = radius * radius + dist = sqrt $ focus `dot` focus + clampedFocus@(V2 focusX focusY) + | dist <= r = focus + | otherwise = V2 (r * cos a) (r * sin a) + where a = atan2 origFocusY origFocusX + r = radius * 0.99 + trivial = sqrt $ radiusSquared - origFocusX * origFocusX + + solutionOf (V2 x y) | x == focusX = + V2 focusX (if y > focusY then trivial else negate trivial) + solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint + where + slope = (y - focusY) / (x - focusX) + yint = y - (slope * x) + + a = slope * slope + 1 + b = 2 * slope * yint + c = yint * yint - radiusSquared + det = sqrt $ b * b - 4 * a * c + xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a) + + go pos = sqrt $ curToFocus / distSquared + where + solution = solutionOf pos ^-^ clampedFocus + toFocus = pos ^-^ clampedFocus + distSquared = solution `dot` solution + curToFocus = toFocus `dot` toFocus + +-- | Perform a multiplication operation between a full color texture +-- and a greyscale one, used for clip-path implementation. +modulateTexture :: ModulablePixel px + => ShaderFunction px + -> ShaderFunction (PixelBaseComponent px) + -> ShaderFunction px +{-# INLINE modulateTexture #-} +modulateTexture fullTexture modulator x y = + colorMap (modulate $ modulator x y) $ fullTexture x y + diff --git a/src/Graphics/Rasterific/StrokeInternal.hs b/src/Graphics/Rasterific/StrokeInternal.hs --- a/src/Graphics/Rasterific/StrokeInternal.hs +++ b/src/Graphics/Rasterific/StrokeInternal.hs @@ -1,300 +1,299 @@ -{-# LANGUAGE CPP #-} -module Graphics.Rasterific.StrokeInternal - ( flatten - , dashize - , strokize - , dashedStrokize - , splitPrimitiveUntil - , approximatePathLength - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( mempty ) -import Data.Foldable( foldMap ) -#endif - -import Control.Applicative( (<$>) ) -import Data.Monoid( (<>) ) - -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , dot - ) - -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.Line - -lastPoint :: Primitive -> Point -lastPoint (LinePrim (Line _ x1)) = x1 -lastPoint (BezierPrim (Bezier _ _ x2)) = x2 -lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3 - -lastPointAndNormal :: Primitive -> (Point, Vector) -lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b) -lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c) -lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d) - -firstPointAndNormal :: Primitive -> (Point, Vector) -firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b) -firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b) -firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) - -reversePrimitive :: Primitive -> Primitive -reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a) -reversePrimitive (BezierPrim (Bezier a b c)) = - BezierPrim (Bezier c b a) -reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) = - CubicBezierPrim (CubicBezier d c b a) - --- | Create a "rounded" join or cap -roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive -roundJoin offset p = go - where go u v - -- If we're already on a nice curvature, - -- don't bother doing anything - | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c - | otherwise = go u w <> go w v - where -- ^ - -- |w - -- a X---X c - -- \ / - -- Xp - -- ^ / \ ^ - -- u\/ \/v - -- / \ . - a = p ^+^ u ^* offset - c = p ^+^ v ^* offset - - w = (a `normal` c) `ifZero` u - - -- Same as offseting - n = p ^+^ w ^* offset - b = n ^* 2 ^-^ (a `midPoint` c) - --- | Put a cap at the end of a bezier curve, depending --- on the kind of cap wanted. -cap :: Float -> Cap -> Primitive -> Container Primitive -cap offset CapRound prim = roundJoin offset p u (- u) - where (p, u) = lastPointAndNormal prim - -cap offset (CapStraight cVal) prim = - pure (d `lineFromTo` e) <> pure (e `lineFromTo` f) - <> pure (f `lineFromTo` g) - where -- The usual "normal" - (p, u@(V2 ux uy)) = lastPointAndNormal prim - -- Vector pointing in the direction of the curve - -- of norm 1 - v = V2 uy $ negate ux - - -- Finishing points around the edge - -- -u*offset u*offset - -- <-><-> - -- d/ / /g - -- / / / - -- / / / - -- / - -- / curve - -- - d = p ^+^ u ^* offset - g = p ^-^ u ^* offset - - -- Create the "far" points - -- - -- e f - -- / / ^ - -- / / / v * offset * cVal - -- d/ / /g - -- / / / - -- / / / - -- / - -- / curve - -- - e = d ^+^ v ^* (offset * cVal) - f = g ^+^ v ^* (offset * cVal) - -lineFromTo :: Point -> Point -> Primitive -lineFromTo a b = LinePrim (Line a b) - -miterJoin :: Float -> Float -> Point -> Vector -> Vector - -> Container Primitive -miterJoin offset l point u v - | uDotW > l / max 1 l && uDotW > 0.01 = - pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) - -- A simple straight junction - | otherwise = pure $ a `lineFromTo` c - where -- X m - -- /\ - -- /|w\ - -- a X---X c - -- \ / - -- Xp - -- ^ / \ ^ - -- u\/ \/v - -- / \ . - a = point ^+^ u ^* offset - c = point ^+^ v ^* offset - w = (a `normal` c) `ifZero` u - - uDotW = u `dot` w - - -- Calculate the maximum distance on the - -- u axis - p = offset / uDotW - -- middle point for "straight joining" - m = point + w ^* p - -joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive - -> Container Primitive -joinPrimitives offset join prim1 prim2 = - case join of - JoinRound -> roundJoin offset p u v - JoinMiter l -> miterJoin offset l p u v - where (p, u) = lastPointAndNormal prim1 - (_, v) = firstPointAndNormal prim2 - -offsetPrimitives :: Float -> Primitive -> Container Primitive -offsetPrimitives offset (LinePrim l) = offsetLine offset l -offsetPrimitives offset (BezierPrim b) = offsetBezier offset b -offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c - -offsetAndJoin :: Float -> Join -> Cap -> [Primitive] - -> Container Primitive -offsetAndJoin _ _ _ [] = mempty -offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest - where joiner = joinPrimitives offset join - offseter = offsetPrimitives offset - (firstPoint, _) = firstPointAndNormal firstShape - - go prev [] - | firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev - | otherwise = offseter prev <> cap offset caping prev - go prev (x:xs) = - joiner prev x <> offseter prev <> go x xs - -approximateLength :: Primitive -> Float -approximateLength (LinePrim l) = lineLength l -approximateLength (BezierPrim b) = bezierLengthApproximation b -approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c - - -sanitize :: Primitive -> Container Primitive -sanitize (LinePrim l) = sanitizeLine l -sanitize (BezierPrim b) = sanitizeBezier b -sanitize (CubicBezierPrim c) = sanitizeCubicBezier c - -strokize :: Geometry geom - => StrokeWidth -> Join -> (Cap, Cap) -> geom - -> Container Primitive -strokize width join (capStart, capEnd) geom = - offseter capEnd sanitized <> - offseter capStart (reverse $ reversePrimitive <$> sanitized) - where - sanitized = foldMap (listOfContainer . sanitize) $ toPrimitives geom - offseter = offsetAndJoin (width / 2) join - -flattenPrimitive :: Primitive -> Container Primitive -flattenPrimitive (BezierPrim bezier) = flattenBezier bezier -flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier -flattenPrimitive (LinePrim line) = flattenLine line - -breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive) -breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b) - where (a, b) = bezierBreakAt bezier at -breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b) - where (a, b) = cubicBezierBreakAt bezier at -breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b) - where (a, b) = lineBreakAt line at - - -flatten :: Container Primitive -> Container Primitive -flatten = foldMap flattenPrimitive - -splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) -splitPrimitiveUntil = go - where - go _ [] = ([], []) - go left lst - | left <= 0 = ([], lst) - go left (x : xs) - | left > primLength = (x : inInterval, afterInterval) - | otherwise = ([beforeStop], afterStop : xs) - where - primLength = approximateLength x - (inInterval, afterInterval) = go (left - primLength) xs - - (beforeStop, afterStop) = - breakPrimitiveAt x $ left / primLength - -dropPattern :: Float -> DashPattern -> DashPattern -dropPattern = go - where - go _ [] = [] - go offset (x:xs) - | x < 0 = x:xs -- sanitizing - | offset < x = x - offset : xs - | otherwise {- offset >= x -} = go (offset - x) xs - --- | Don't make them completly flat, but suficiently --- to assume they are. -linearizePrimitives :: [Primitive] -> [Primitive] -linearizePrimitives = - listOfContainer . foldMap flattenPrimitive . foldMap sanitize - --- | Return an approximation of the length of a given path. --- It's results is not precise but should be enough for --- rough calculations -approximatePathLength :: Path -> Float -approximatePathLength = approximatePrimitivesLength . pathToPrimitives - -approximatePrimitivesLength :: [Primitive] -> Float -approximatePrimitivesLength prims = - sum $ approximateLength <$> linearizePrimitives prims - -dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] -dashize offset pattern = taker infinitePattern . linearizePrimitives - where - realOffset | offset >= 0 = offset - | otherwise = offset + sum pattern - - infinitePattern = - dropPattern realOffset . cycle $ filter (> 0) pattern - - taker _ [] = [] - taker [] _ = [] -- Impossible by construction, pattern is infinite - taker (atValue:atRest) stream = toKeep : droper atRest next - where (toKeep, next) = splitPrimitiveUntil atValue stream - - droper _ [] = [] - droper [] _ = [] -- Impossible by construction, pattern is infinite - droper (atValue:atRest) stream = taker atRest next - where (_toKeep, next) = splitPrimitiveUntil atValue stream - --- | Create a list of outlines corresponding to all the --- dashed elements. They can be then stroked --- --- > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ --- > dashedStrokize 0 [10, 5] --- > 40 JoinRound (CapStraight 0, CapStraight 0) $ --- > CubicBezier (V2 40 160) (V2 40 40) (V2 160 40) (V2 160 160) --- --- <> --- -dashedStrokize :: Geometry geom - => Float -- ^ Starting offset - -> DashPattern -- ^ Dashing pattern to use for stroking - -> StrokeWidth -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> geom -- ^ Elements to transform - -> [[Primitive]] -dashedStrokize offset dashPattern width join capping geom = - listOfContainer . strokize width join capping - <$> dashize offset dashPattern (toPrimitives geom) - +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.StrokeInternal + ( flatten + , dashize + , strokize + , dashedStrokize + , splitPrimitiveUntil + , approximatePathLength + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), pure ) +import Data.Monoid( mempty ) +import Data.Foldable( foldMap ) +#endif + +import Data.Monoid( (<>) ) + +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , dot + ) + +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Line + +lastPoint :: Primitive -> Point +lastPoint (LinePrim (Line _ x1)) = x1 +lastPoint (BezierPrim (Bezier _ _ x2)) = x2 +lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3 + +lastPointAndNormal :: Primitive -> (Point, Vector) +lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b) +lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c) +lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d) + +firstPointAndNormal :: Primitive -> (Point, Vector) +firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b) +firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b) +firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) + +reversePrimitive :: Primitive -> Primitive +reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a) +reversePrimitive (BezierPrim (Bezier a b c)) = + BezierPrim (Bezier c b a) +reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) = + CubicBezierPrim (CubicBezier d c b a) + +-- | Create a "rounded" join or cap +roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive +roundJoin offset p = go + where go u v + -- If we're already on a nice curvature, + -- don't bother doing anything + | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c + | otherwise = go u w <> go w v + where -- ^ + -- |w + -- a X---X c + -- \ / + -- Xp + -- ^ / \ ^ + -- u\/ \/v + -- / \ . + a = p ^+^ u ^* offset + c = p ^+^ v ^* offset + + w = (a `normal` c) `ifZero` u + + -- Same as offseting + n = p ^+^ w ^* offset + b = n ^* 2 ^-^ (a `midPoint` c) + +-- | Put a cap at the end of a bezier curve, depending +-- on the kind of cap wanted. +cap :: Float -> Cap -> Primitive -> Container Primitive +cap offset CapRound prim = roundJoin offset p u (- u) + where (p, u) = lastPointAndNormal prim + +cap offset (CapStraight cVal) prim = + pure (d `lineFromTo` e) <> pure (e `lineFromTo` f) + <> pure (f `lineFromTo` g) + where -- The usual "normal" + (p, u@(V2 ux uy)) = lastPointAndNormal prim + -- Vector pointing in the direction of the curve + -- of norm 1 + v = V2 uy $ negate ux + + -- Finishing points around the edge + -- -u*offset u*offset + -- <-><-> + -- d/ / /g + -- / / / + -- / / / + -- / + -- / curve + -- + d = p ^+^ u ^* offset + g = p ^-^ u ^* offset + + -- Create the "far" points + -- + -- e f + -- / / ^ + -- / / / v * offset * cVal + -- d/ / /g + -- / / / + -- / / / + -- / + -- / curve + -- + e = d ^+^ v ^* (offset * cVal) + f = g ^+^ v ^* (offset * cVal) + +lineFromTo :: Point -> Point -> Primitive +lineFromTo a b = LinePrim (Line a b) + +miterJoin :: Float -> Float -> Point -> Vector -> Vector + -> Container Primitive +miterJoin offset l point u v + | uDotW > l / max 1 l && uDotW > 0.01 = + pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) + -- A simple straight junction + | otherwise = pure $ a `lineFromTo` c + where -- X m + -- /\ + -- /|w\ + -- a X---X c + -- \ / + -- Xp + -- ^ / \ ^ + -- u\/ \/v + -- / \ . + a = point ^+^ u ^* offset + c = point ^+^ v ^* offset + w = (a `normal` c) `ifZero` u + + uDotW = u `dot` w + + -- Calculate the maximum distance on the + -- u axis + p = offset / uDotW + -- middle point for "straight joining" + m = point + w ^* p + +joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive + -> Container Primitive +joinPrimitives offset join prim1 prim2 = + case join of + JoinRound -> roundJoin offset p u v + JoinMiter l -> miterJoin offset l p u v + where (p, u) = lastPointAndNormal prim1 + (_, v) = firstPointAndNormal prim2 + +offsetPrimitives :: Float -> Primitive -> Container Primitive +offsetPrimitives offset (LinePrim l) = offsetLine offset l +offsetPrimitives offset (BezierPrim b) = offsetBezier offset b +offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c + +offsetAndJoin :: Float -> Join -> Cap -> [Primitive] + -> Container Primitive +offsetAndJoin _ _ _ [] = mempty +offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest + where joiner = joinPrimitives offset join + offseter = offsetPrimitives offset + (firstPoint, _) = firstPointAndNormal firstShape + + go prev [] + | firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev + | otherwise = offseter prev <> cap offset caping prev + go prev (x:xs) = + joiner prev x <> offseter prev <> go x xs + +approximateLength :: Primitive -> Float +approximateLength (LinePrim l) = lineLength l +approximateLength (BezierPrim b) = bezierLengthApproximation b +approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c + + +sanitize :: Primitive -> Container Primitive +sanitize (LinePrim l) = sanitizeLine l +sanitize (BezierPrim b) = sanitizeBezier b +sanitize (CubicBezierPrim c) = sanitizeCubicBezier c + +strokize :: Geometry geom + => StrokeWidth -> Join -> (Cap, Cap) -> geom + -> Container Primitive +strokize width join (capStart, capEnd) geom = + offseter capEnd sanitized <> + offseter capStart (reverse $ reversePrimitive <$> sanitized) + where + sanitized = foldMap (listOfContainer . sanitize) $ toPrimitives geom + offseter = offsetAndJoin (width / 2) join + +flattenPrimitive :: Primitive -> Container Primitive +flattenPrimitive (BezierPrim bezier) = flattenBezier bezier +flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier +flattenPrimitive (LinePrim line) = flattenLine line + +breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive) +breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b) + where (a, b) = bezierBreakAt bezier at +breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b) + where (a, b) = cubicBezierBreakAt bezier at +breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b) + where (a, b) = lineBreakAt line at + + +flatten :: Container Primitive -> Container Primitive +flatten = foldMap flattenPrimitive + +splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) +splitPrimitiveUntil = go + where + go _ [] = ([], []) + go left lst + | left <= 0 = ([], lst) + go left (x : xs) + | left > primLength = (x : inInterval, afterInterval) + | otherwise = ([beforeStop], afterStop : xs) + where + primLength = approximateLength x + (inInterval, afterInterval) = go (left - primLength) xs + + (beforeStop, afterStop) = + breakPrimitiveAt x $ left / primLength + +dropPattern :: Float -> DashPattern -> DashPattern +dropPattern = go + where + go _ [] = [] + go offset (x:xs) + | x < 0 = x:xs -- sanitizing + | offset < x = x - offset : xs + | otherwise {- offset >= x -} = go (offset - x) xs + +-- | Don't make them completly flat, but suficiently +-- to assume they are. +linearizePrimitives :: [Primitive] -> [Primitive] +linearizePrimitives = + listOfContainer . foldMap flattenPrimitive . foldMap sanitize + +-- | Return an approximation of the length of a given path. +-- It's results is not precise but should be enough for +-- rough calculations +approximatePathLength :: Path -> Float +approximatePathLength = approximatePrimitivesLength . pathToPrimitives + +approximatePrimitivesLength :: [Primitive] -> Float +approximatePrimitivesLength prims = + sum $ approximateLength <$> linearizePrimitives prims + +dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] +dashize offset pattern = taker infinitePattern . linearizePrimitives + where + realOffset | offset >= 0 = offset + | otherwise = offset + sum pattern + + infinitePattern = + dropPattern realOffset . cycle $ filter (> 0) pattern + + taker _ [] = [] + taker [] _ = [] -- Impossible by construction, pattern is infinite + taker (atValue:atRest) stream = toKeep : droper atRest next + where (toKeep, next) = splitPrimitiveUntil atValue stream + + droper _ [] = [] + droper [] _ = [] -- Impossible by construction, pattern is infinite + droper (atValue:atRest) stream = taker atRest next + where (_toKeep, next) = splitPrimitiveUntil atValue stream + +-- | Create a list of outlines corresponding to all the +-- dashed elements. They can be then stroked +-- +-- > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ +-- > dashedStrokize 0 [10, 5] +-- > 40 JoinRound (CapStraight 0, CapStraight 0) $ +-- > CubicBezier (V2 40 160) (V2 40 40) (V2 160 40) (V2 160 160) +-- +-- <> +-- +dashedStrokize :: Geometry geom + => Float -- ^ Starting offset + -> DashPattern -- ^ Dashing pattern to use for stroking + -> StrokeWidth -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ Elements to transform + -> [[Primitive]] +dashedStrokize offset dashPattern width join capping geom = + listOfContainer . strokize width join capping + <$> dashize offset dashPattern (toPrimitives geom) +