Rasterific 0.3 → 0.4
raw patch · 76 files changed
+1193/−453 lines, 76 filesdep +primitivedep ~FontyFruitydep ~JuicyPixelsdep ~QuickCheckbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: primitive
Dependency ranges changed: FontyFruity, JuicyPixels, QuickCheck, base, criterion, statistics
API changes (from Hackage documentation)
- Graphics.Rasterific: instance Functor (DrawCommand px)
- Graphics.Rasterific: instance Monoid (Drawing px ())
+ Graphics.Rasterific: TextRange :: Font -> PointSize -> String -> Maybe (Texture px) -> TextRange px
+ Graphics.Rasterific: _text :: TextRange px -> String
+ Graphics.Rasterific: _textFont :: TextRange px -> Font
+ Graphics.Rasterific: _textSize :: TextRange px -> PointSize
+ Graphics.Rasterific: _textTexture :: TextRange px -> Maybe (Texture px)
+ Graphics.Rasterific: boundHeight :: PlaneBound -> Float
+ Graphics.Rasterific: boundLowerLeftCorner :: PlaneBound -> Point
+ Graphics.Rasterific: boundWidth :: PlaneBound -> Float
+ Graphics.Rasterific: data TextRange px
+ Graphics.Rasterific: drawOrdersOfDrawing :: RenderablePixel px => Int -> Int -> px -> Drawing px () -> [DrawOrder px]
+ Graphics.Rasterific: printTextRanges :: Point -> [TextRange px] -> Drawing px ()
+ Graphics.Rasterific: withPathOrientation :: Path -> Float -> Drawing px () -> Drawing px ()
+ Graphics.Rasterific.Immediate: DrawOrder :: ![[Primitive]] -> !(Texture px) -> !FillMethod -> !(Maybe (Texture (PixelBaseComponent px))) -> DrawOrder px
+ Graphics.Rasterific.Immediate: _orderFillMethod :: DrawOrder px -> !FillMethod
+ Graphics.Rasterific.Immediate: _orderMask :: DrawOrder px -> !(Maybe (Texture (PixelBaseComponent px)))
+ Graphics.Rasterific.Immediate: _orderPrimitives :: DrawOrder px -> ![[Primitive]]
+ Graphics.Rasterific.Immediate: _orderTexture :: DrawOrder px -> !(Texture px)
+ Graphics.Rasterific.Immediate: data DrawOrder px
+ Graphics.Rasterific.Immediate: fillOrder :: (PrimMonad m, RenderablePixel px) => DrawOrder px -> DrawContext m px ()
+ Graphics.Rasterific.Immediate: fillWithTexture :: (PrimMonad m, RenderablePixel px) => FillMethod -> Texture px -> [Primitive] -> DrawContext m px ()
+ Graphics.Rasterific.Immediate: fillWithTextureAndMask :: (PrimMonad m, RenderablePixel px) => FillMethod -> Texture px -> Texture (PixelBaseComponent px) -> [Primitive] -> DrawContext m px ()
+ Graphics.Rasterific.Immediate: orderToDrawing :: DrawOrder px -> Drawing px ()
+ Graphics.Rasterific.Immediate: runDrawContext :: (PrimMonad m, RenderablePixel px) => Int -> Int -> px -> DrawContext m px () -> m (Image px)
+ Graphics.Rasterific.Immediate: type DrawContext m px a = StateT (MutableImage (PrimState m) px) m a
+ Graphics.Rasterific.Outline: approximatePathLength :: Path -> Float
+ Graphics.Rasterific.Outline: type StrokeWidth = Float
+ Graphics.Rasterific.PathWalker: advanceBy :: Monad m => Float -> PathWalkerT m ()
+ Graphics.Rasterific.PathWalker: currentPosition :: Monad m => PathWalkerT m (Maybe Point)
+ Graphics.Rasterific.PathWalker: currentTangeant :: Monad m => PathWalkerT m (Maybe Vector)
+ Graphics.Rasterific.PathWalker: data PathWalkerT m a
+ Graphics.Rasterific.PathWalker: drawOrdersOnPath :: Monad m => PathDrawer m px -> Float -> Float -> Path -> [DrawOrder px] -> m ()
+ Graphics.Rasterific.PathWalker: instance (Monad m, Functor m) => Applicative (PathWalkerT m)
+ Graphics.Rasterific.PathWalker: instance Functor m => Functor (PathWalkerT m)
+ Graphics.Rasterific.PathWalker: instance Monad m => Monad (PathWalkerT m)
+ Graphics.Rasterific.PathWalker: instance MonadTrans PathWalkerT
+ Graphics.Rasterific.PathWalker: runPathWalking :: Monad m => Path -> PathWalkerT m a -> m a
+ Graphics.Rasterific.PathWalker: type PathDrawer m px = Transformation -> PlaneBound -> DrawOrder px -> m ()
+ Graphics.Rasterific.PathWalker: type PathWalker a = PathWalkerT Identity a
+ Graphics.Rasterific.Transformations: toNewXBase :: Vector -> Transformation
- Graphics.Rasterific: type ModulablePixel px = (Pixel px, Modulable (PixelBaseComponent px))
+ Graphics.Rasterific: type ModulablePixel px = (Pixel px, PackeablePixel px, Storable (PackedRepresentation px), Modulable (PixelBaseComponent px))
- Graphics.Rasterific: type RenderablePixel px = (ModulablePixel px, Pixel (PixelBaseComponent px), PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px))
+ Graphics.Rasterific: type RenderablePixel px = (ModulablePixel px, Pixel (PixelBaseComponent px), PackeablePixel (PixelBaseComponent px), Storable (PackedRepresentation (PixelBaseComponent px)), PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px))
Files
- Rasterific.cabal +16/−10
- changelog +52/−28
- docimages/cap_round.png binary
- docimages/cap_straight.png binary
- docimages/cap_straight_1.png binary
- docimages/coordinate.png binary
- docimages/cubic_bezier.png binary
- docimages/dashed_stroke.png binary
- docimages/dashed_stroke_with_offset.png binary
- docimages/fill_circle.png binary
- docimages/fill_ellipse.png binary
- docimages/fill_evenodd.png binary
- docimages/fill_polygon.png binary
- docimages/fill_rect.png binary
- docimages/fill_roundedRectangle.png binary
- docimages/fill_winding.png binary
- docimages/geometry_on_path.png binary
- docimages/image_resize.png binary
- docimages/image_simple.png binary
- docimages/immediate_fill.png binary
- docimages/immediate_mask.png binary
- docimages/join_miter.png binary
- docimages/join_miter_5.png binary
- docimages/join_round.png binary
- docimages/linear_gradient.png binary
- docimages/logo.png binary
- docimages/module_example.png binary
- docimages/path_example.png binary
- docimages/primitive_mixed.png binary
- docimages/quadratic_bezier.png binary
- docimages/radial_gradient.png binary
- docimages/radial_gradient_focus.png binary
- docimages/sampled_texture_pad.png binary
- docimages/sampled_texture_reflect.png binary
- docimages/sampled_texture_repeat.png binary
- docimages/sampled_texture_rotate.png binary
- docimages/sampled_texture_scaled.png binary
- docimages/sampler_pad.png binary
- docimages/sampler_reflect.png binary
- docimages/sampler_repeat.png binary
- docimages/simple_line.png binary
- docimages/stroke_circle.png binary
- docimages/stroke_line.png binary
- docimages/stroke_polyline.png binary
- docimages/stroke_roundedRectangle.png binary
- docimages/strokize_dashed_path.png binary
- docimages/strokize_path.png binary
- docimages/text_complex_example.png binary
- docimages/text_example.png binary
- docimages/text_on_path.png binary
- docimages/transform_rotate.png binary
- docimages/transform_rotate_center.png binary
- docimages/transform_scale.png binary
- docimages/transform_skewx.png binary
- docimages/transform_skewy.png binary
- docimages/transform_translate.png binary
- docimages/with_clipping.png binary
- docimages/with_texture.png binary
- exec-src/rastertest.hs +105/−1
- src/Graphics/Rasterific.hs +165/−221
- src/Graphics/Rasterific/Command.hs +127/−0
- src/Graphics/Rasterific/Compositor.hs +13/−6
- src/Graphics/Rasterific/CubicBezier.hs +79/−62
- src/Graphics/Rasterific/Immediate.hs +185/−0
- src/Graphics/Rasterific/Line.hs +35/−27
- src/Graphics/Rasterific/Linear.hs +1/−0
- src/Graphics/Rasterific/Operators.hs +5/−0
- src/Graphics/Rasterific/Outline.hs +3/−1
- src/Graphics/Rasterific/PathWalker.hs +140/−0
- src/Graphics/Rasterific/PlaneBoundable.hs +18/−1
- src/Graphics/Rasterific/QuadraticBezier.hs +62/−36
- src/Graphics/Rasterific/Rasterize.hs +30/−8
- src/Graphics/Rasterific/Shading.hs +72/−37
- src/Graphics/Rasterific/StrokeInternal.hs +26/−11
- src/Graphics/Rasterific/Transformations.hs +20/−1
- src/Graphics/Rasterific/Types.hs +39/−3
Rasterific.cabal view
@@ -1,7 +1,7 @@ -- Initial Rasterific.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: Rasterific -version: 0.3 +version: 0.4 synopsis: A pure haskell drawing engine. -- A longer description of the package. description: @@ -34,7 +34,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Rasterific.git - Tag: v0.3 + Tag: v0.4 flag embed_linear description: Embed a reduced version of Linear avoiding a (huge) dep @@ -47,8 +47,11 @@ , Graphics.Rasterific.Texture , Graphics.Rasterific.Linear , 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 @@ -60,17 +63,19 @@ , Graphics.Rasterific.PlaneBoundable , Graphics.Rasterific.QuadraticFormula - ghc-options: -O2 -Wall + ghc-options: -O3 -Wall + -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques ghc-prof-options: -Wall -prof -auto-all default-language: Haskell2010 build-depends: base >= 4.6 && < 4.9 - , JuicyPixels >= 3.1.5.2 && < 3.2 - , FontyFruity >= 0.3 && < 0.4 - , vector >= 0.9 - , vector-algorithms >= 0.3 , free >= 4.7 + , JuicyPixels >= 3.2 + , FontyFruity >= 0.4 && < 0.5 + , 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 @@ -91,8 +96,9 @@ , vector , FontyFruity , binary - , QuickCheck >= 2.7 + , QuickCheck , deepseq - , criterion >= 0.8 && < 0.9 - , statistics >= 0.10 && < 0.11 + , criterion + , statistics + --, groom
changelog view
@@ -1,44 +1,68 @@ -*-change-log-*- -v0.3 2014 - * Switching main free monad type to the church encoded one. - * Optimized the bezier decomposition, strictness annotations +v0.4 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. - * Implementing specific decomposition for lines. - * Reworked texture system, now allowing some specialized + * 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. - * Fixing space leak in combineEdgeSamples, avoiding many - allocations. - * Adding bounding box calculation facility. - * Exposing outline creation capability - * Adding a skewX & skewY transformation function. - * Fixing some numerical stability with the mitter join. + * 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 + * Fixing: transparency in gradients. + * Fixing: alpha composition on top of translucent background. v0.2 April 2014 - * Adding an ellipse helper. - * Adding a polyline helper. - * Adding a polygon helper. - * Adding monoid instance for Drawing. - * Fixing some stroking bug with cubic bezier curve. - * Fixing some documentation snippets. - * Adding a rounded rectangle helper. - * Added a even-odd filling rule. - * Added an offset for dashed stroking. - * Added a transformation module. - * Changed the Transformable typeclass, splitted + * 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 + * Added: a dumping function for the constructed drawing. - * Adding an image texture with bilinear filtering. - * Adding an image helper. - * Made some modest performance enhancements. + * Adding: an image texture with bilinear filtering. + * Adding: an image helper. + * Enhancement: Some modest performance gain. v0.1 February 2014 * Initial version.
docimages/cap_round.png view
binary file changed (1129 → 1891 bytes)
docimages/cap_straight.png view
binary file changed (1077 → 1785 bytes)
docimages/cap_straight_1.png view
binary file changed (1137 → 1843 bytes)
docimages/coordinate.png view
binary file changed (1868 → 4448 bytes)
docimages/cubic_bezier.png view
binary file changed (2856 → 4519 bytes)
docimages/dashed_stroke.png view
binary file changed (222 → 662 bytes)
docimages/dashed_stroke_with_offset.png view
binary file changed (221 → 661 bytes)
docimages/fill_circle.png view
binary file changed (1065 → 2710 bytes)
docimages/fill_ellipse.png view
binary file changed (809 → 1828 bytes)
docimages/fill_evenodd.png view
binary file changed (3774 → 6039 bytes)
docimages/fill_polygon.png view
binary file changed (1371 → 2366 bytes)
docimages/fill_rect.png view
binary file changed (122 → 1454 bytes)
docimages/fill_roundedRectangle.png view
binary file changed (442 → 1279 bytes)
docimages/fill_winding.png view
binary file changed (2781 → 4454 bytes)
+ docimages/geometry_on_path.png view
binary file changed (absent → 5067 bytes)
docimages/image_resize.png view
binary file changed (21960 → 40755 bytes)
docimages/image_simple.png view
binary file changed (7646 → 12132 bytes)
+ docimages/immediate_fill.png view
binary file changed (absent → 3052 bytes)
+ docimages/immediate_mask.png view
binary file changed (absent → 4917 bytes)
docimages/join_miter.png view
binary file changed (1416 → 2338 bytes)
docimages/join_miter_5.png view
binary file changed (1343 → 2247 bytes)
docimages/join_round.png view
binary file changed (1377 → 2288 bytes)
docimages/linear_gradient.png view
binary file changed (4139 → 4401 bytes)
docimages/logo.png view
binary file changed (1649 → 3594 bytes)
docimages/module_example.png view
binary file changed (1047 → 2331 bytes)
docimages/path_example.png view
binary file changed (1355 → 2216 bytes)
docimages/primitive_mixed.png view
binary file changed (1355 → 2216 bytes)
docimages/quadratic_bezier.png view
binary file changed (2283 → 3697 bytes)
docimages/radial_gradient.png view
binary file changed (10038 → 17016 bytes)
docimages/radial_gradient_focus.png view
binary file changed (11755 → 19019 bytes)
docimages/sampled_texture_pad.png view
binary file changed (7587 → 12035 bytes)
docimages/sampled_texture_reflect.png view
binary file changed (46327 → 64727 bytes)
docimages/sampled_texture_repeat.png view
binary file changed (23294 → 35496 bytes)
docimages/sampled_texture_rotate.png view
binary file changed (84500 → 109884 bytes)
docimages/sampled_texture_scaled.png view
binary file changed (56543 → 102643 bytes)
docimages/sampler_pad.png view
binary file changed (1683 → 1819 bytes)
docimages/sampler_reflect.png view
binary file changed (4708 → 2980 bytes)
docimages/sampler_repeat.png view
binary file changed (3864 → 2374 bytes)
docimages/simple_line.png view
binary file changed (1887 → 2948 bytes)
docimages/stroke_circle.png view
binary file changed (1744 → 4302 bytes)
docimages/stroke_line.png view
binary file changed (1449 → 3022 bytes)
docimages/stroke_polyline.png view
binary file changed (1594 → 2830 bytes)
docimages/stroke_roundedRectangle.png view
binary file changed (571 → 1734 bytes)
docimages/strokize_dashed_path.png view
binary file changed (9361 → 10013 bytes)
docimages/strokize_path.png view
binary file changed (3199 → 4960 bytes)
+ docimages/text_complex_example.png view
binary file changed (absent → 2024 bytes)
docimages/text_example.png view
binary file changed (1042 → 2233 bytes)
+ docimages/text_on_path.png view
binary file changed (absent → 6313 bytes)
docimages/transform_rotate.png view
binary file changed (1824 → 3114 bytes)
docimages/transform_rotate_center.png view
binary file changed (1828 → 3070 bytes)
docimages/transform_scale.png view
binary file changed (117 → 1008 bytes)
docimages/transform_skewx.png view
binary file changed (1022 → 1818 bytes)
docimages/transform_skewy.png view
binary file changed (907 → 1609 bytes)
docimages/transform_translate.png view
binary file changed (122 → 701 bytes)
docimages/with_clipping.png view
binary file changed (1796 → 3294 bytes)
docimages/with_texture.png view
binary file changed (807 → 1579 bytes)
exec-src/rastertest.hs view
@@ -14,6 +14,7 @@ import Graphics.Rasterific.Texture import Graphics.Rasterific.Linear( (^+^), (^-^) ) import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Immediate import Graphics.Text.TrueType( loadFontFile ) import Codec.Picture @@ -25,6 +26,7 @@ , defaultMainWith , bench ) +{-import Text.Groom( groom )-} import qualified Sample as Sample type Stroker = @@ -83,7 +85,7 @@ stroke :: Float -> Join -> (Cap, Cap) -> [Primitive] -> Drawing PixelRGBA8 () stroke w j cap prims = - R.stroke w j cap prims >> drawBoundingBox prims + R.stroke w j cap prims -- >> drawBoundingBox prims dashedStroke :: DashPattern -> Float -> Join -> (Cap, Cap) -> [Primitive] -> Drawing PixelRGBA8 () @@ -321,6 +323,21 @@ . withTexture (uniformTexture black) $ printTextAt font 12 (V2 20 40) txt +textStrokeTest :: String -> String -> String -> IO () +textStrokeTest fontName filename txt = do + putStrLn $ "Rendering " ++ fontName + fontErr <- loadFontFile $ "C:/Windows/Fonts/" ++ fontName ++ ".ttf" + case fontErr of + Left err -> putStrLn err + Right font -> do + let drawing = printTextAt font 20 (V2 30 30) txt + orders = drawOrdersOfDrawing 300 300 (PixelRGBA8 0 0 0 0) drawing + writePng (outFolder </> filename) . + renderDrawing 300 70 white . + withTexture (uniformTexture black) . + mapM_ (mapM_ (stroke 1 (JoinMiter 0) (CapRound, CapRound) + ) . _orderPrimitives) $ orders + strokeTest :: Stroker -> Texture PixelRGBA8 -> String -> IO () strokeTest stroker texture prefix = @@ -347,6 +364,23 @@ ] img = renderDrawing 500 500 background drawing +orientationAxisText :: IO () +orientationAxisText = + let trans = translate (V2 200 200) <> toNewXBase (V2 1 (-0.5)) in + writePng (outFolder </> "axis_transform.png") + . renderDrawing 400 400 white + . withTexture (uniformTexture blue) + . fill . transform (applyTransformation trans) + . pathToPrimitives + $ Path (V2 (-100) (-10)) True + [ PathLineTo (V2 (-20) (-10)) + , PathLineTo (V2 0 5) + , PathLineTo (V2 20 (-10)) + , PathLineTo (V2 100 (-10)) + , PathLineTo (V2 100 10) + , PathLineTo (V2 (-100) 10) + ] + complexEvenOddTest :: Int -> Texture PixelRGBA8 -> IO () complexEvenOddTest size texture = mapM_ tester [(filling, ix) | filling <- [(FillEvenOdd, "evenodd") @@ -498,6 +532,49 @@ ,(0.75, PixelRGBA8 0 128 128 255) ,(1, PixelRGBA8 0 128 128 255) ] + +strokeBad2 :: IO () +strokeBad2 = + writePng (outFolder </> ("bad_stroke_letter.png")) $ + renderDrawing 70 70 white drawing + where + drawing = + withTexture (uniformTexture (PixelRGBA8 76 0 0 255)) $ + stroke 1.0 (JoinMiter 0.0) (CapRound + ,CapRound) $ + BezierPrim <$> + [ + {- + Bezier (V2 44.958496 23.413086) (V2 39.9292 23.413086) (V2 34.91211 23.413086) + ,Bezier (V2 34.91211 23.413086) (V2 34.91211 24.67041) (V2 35.290527 25.610352) + ,Bezier (V2 35.290527 25.610352) (V2 35.668945 26.538086) (V2 36.328125 27.13623) + ,Bezier (V2 36.328125 27.13623) (V2 36.96289 27.722168) (V2 37.82959 28.015137) + ,Bezier (V2 37.82959 28.015137) (V2 38.708496 28.308105) (V2 39.7583 28.308105) + ,Bezier (V2 39.7583 28.308105) (V2 41.149902 28.308105) (V2 42.55371 27.75879) + ,Bezier (V2 42.55371 27.75879) (V2 43.969727 27.197266) (V2 44.56787 26.660156) + ,Bezier (V2 44.56787 26.660156) (V2 44.628906 26.660156) (V2 44.68994 26.660156) + ,Bezier (V2 44.68994 26.660156) (V2 44.68994 27.91748) (V2 44.68994 29.162598) + ,Bezier (V2 44.68994 29.162598) (V2 43.530273 29.650879) (V2 42.321777 29.980469) + -} + {- + Bezier (V2 42.321777 29.980469) (V2 41.11328 30.310059) (V2 39.782715 30.310059) + ,Bezier (V2 39.782715 30.310059) (V2 36.38916 30.310059) (V2 34.484863 28.479004) + ,Bezier (V2 34.484863 28.479004) (V2 32.580566 26.635742) (V2 32.580566 23.254395) + ,Bezier (V2 32.580566 23.254395) (V2 32.580566 19.909668) (V2 34.399414 17.944336) + ,Bezier (V2 34.399414 17.944336) (V2 36.23047 15.979004) (V2 39.208984 15.979004) + ,Bezier (V2 39.208984 15.979004) (V2 41.967773 15.979004) (V2 43.45703 17.590332) + -} + -- Bezier (V2 43.45703 17.590332) (V2 44.958496 19.20166) (V2 44.958496 22.167969) + Bezier (V2 44.958496 22.167969) (V2 44.958496 22.790527) (V2 44.958496 23.413086) + ,Bezier (V2 42.72461 21.655273) (V2 42.712402 19.848633) (V2 41.809082 18.859863) + {- + Bezier (V2 41.809082 18.859863) (V2 40.91797 17.871094) (V2 39.086914 17.871094) + ,Bezier (V2 39.086914 17.871094) (V2 37.243652 17.871094) (V2 36.14502 18.95752) + ,Bezier (V2 36.14502 18.95752) (V2 35.058594 20.043945) (V2 34.91211 21.655273) + ,Bezier (V2 34.91211 21.655273) (V2 38.81836 21.655273) (V2 42.72461 21.655273) + -- -} + ] + strokeBad :: IO () strokeBad = writePng (outFolder </> ("bad_stroke_tiger.png")) $ @@ -526,7 +603,29 @@ (V2 (-43.8) 58.199997) (V2 (-56.0) 64.2) (V2 (-61.4) 74.399994)] +pledgeTest :: IO () +pledgeTest = do + (Right (ImageRGBA8 png)) <- readImage "exec-src/test_img.png" + writePng (outFolder </> "pledge_render.png") . + renderDrawing 389 89 white $ + drawImage png 0 (V2 0 0) +shouldBeTheSame :: IO () +shouldBeTheSame = do + writePng (outFolder </> "should_be_same_0.png") $ img prim1 + writePng (outFolder </> "should_be_same_1.png") $ img prim2 + where + drawColor = PixelRGBA8 0 0x86 0xc1 255 + prim1 = CubicBezier (V2 10 10) (V2 210 210) + (V2 210 210) (V2 10 410) + prim2 = CubicBezier (V2 10 10) (V2 210 210) + (V2 210 210.1) (V2 10 410) + + img bez = renderDrawing 400 200 white $ + withTexture (uniformTexture drawColor) $ + stroke 4 JoinRound (CapRound, CapRound) [CubicBezierPrim bez] + + testSuite :: IO () testSuite = do let uniform = uniformTexture blue @@ -548,8 +647,11 @@ triColor (V2 200 200) 70 (V2 150 170) createDirectoryIfMissing True outFolder + pledgeTest strokeBad + strokeBad2 evenOddTest uniform + orientationAxisText complexEvenOddTest 700 uniform complexEvenOddTest 350 uniform @@ -600,6 +702,7 @@ strokeCubic stroke radTriGradient "rad_gradient_" strokeCubicDashed dashedStroke uniform "" + shouldBeTheSame let testText = "Test of a text! It seems to be; à é è ç, working? () {} [] \" '" @@ -607,6 +710,7 @@ textAlignStringTest "CONSOLA" "alignedConsola.png" testText textAlignStringTest "arial" "alignedArial.png" "Just a simple test, gogo !!! Yay ; quoi ?" + textStrokeTest "verdana" "stroke_verdana.png" "e" -- -} benchTest :: [String] -> IO ()
src/Graphics/Rasterific.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} -- | Main module of Rasterific, an Haskell rasterization engine. -- @@ -46,10 +45,13 @@ , withTexture , withClipping , withTransformation + , withPathOrientation , stroke , dashedStroke , dashedStrokeWithOffset , printTextAt + , printTextRanges + , TextRange( .. ) -- * Generating images , ModulablePixel @@ -76,6 +78,9 @@ , PointFoldable( .. ) , PlaneBoundable( .. ) , PlaneBound( .. ) + , boundWidth + , boundHeight + , boundLowerLeftCorner -- * Helpers , line @@ -100,32 +105,25 @@ , SamplerRepeat( .. ) , FillMethod( .. ) , DashPattern + , drawOrdersOfDrawing -- * Debugging helper , dumpDrawing ) where -import qualified Data.Foldable as F import Control.Applicative( (<$>) ) -import Control.Monad( forM_ ) import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.Free.Church( F, fromF ) -import Control.Monad.ST( ST, runST ) -import Control.Monad.State( StateT, execStateT, get, lift ) +import Control.Monad.Free.Church( fromF ) +import Control.Monad.ST( runST ) +import Control.Monad.State( modify, execState ) import Data.Maybe( fromMaybe ) import Data.Monoid( Monoid( .. ), (<>) ) -import Codec.Picture.Types( Image( .. ) - , Pixel( .. ) - , Pixel8 - , PixelRGBA8 - , MutableImage( .. ) - , createMutableImage - , unsafeFreezeImage ) +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.Linear( V2( .. ), (^+^), (^-^), (^*) ) import Graphics.Rasterific.Rasterize import Graphics.Rasterific.Texture import Graphics.Rasterific.Shading @@ -136,105 +134,20 @@ 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, PointSize, getStringCurveAtPoint ) +import Graphics.Text.TrueType( Font, getStringCurveAtPoint ) {-import Debug.Trace-} {-import Text.Printf-} --- | Monad used to describe the drawing context. -type DrawContext s px a = - StateT (MutableImage s px) (ST s) a - ------------------------------------------------ ---- Free Monad DSL section ------------------------------------------------ --- | Monad used to record the drawing actions. -type Drawing px = F (DrawCommand px) - -data DrawCommand px next - = Fill FillMethod [Primitive] next - | Stroke Float Join (Cap, Cap) [Primitive] next - | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next - | TextFill Font PointSize Point String next - | SetTexture (Texture px) - (Drawing px ()) next - | WithCliping (forall innerPixel. Drawing innerPixel ()) - (Drawing px ()) next - | WithTransform Transformation (Drawing px ()) next - --- | This function will spit out drawing instructions to --- help debugging. --- --- The outputted code looks like Haskell, but there is no --- guarantee that it is compilable. -dumpDrawing :: ( Show px - , 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 (Fill _ prims next)) = - "fill " ++ show prims ++ " >>=\n" ++ go next - go (Free (TextFill _ _ _ text next)) = - "-- Text : " ++ text ++ "\n" ++ 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) - - -instance Functor (DrawCommand px) where - fmap f (TextFill font size pos str next) = - TextFill font size pos str $ f next - fmap f (Fill method prims next) = Fill method prims $ f next - fmap f (SetTexture t sub next) = SetTexture t sub $ f next - fmap f (WithCliping sub com next) = - WithCliping sub com $ f next - fmap f (Stroke w j caps prims next) = - Stroke w j caps prims $ f next - fmap f (DashedStroke st pat w j caps prims next) = - DashedStroke st pat w j caps prims $ f next - fmap f (WithTransform trans draw next) = - WithTransform trans draw $ f next - -instance Monoid (Drawing px ()) where - mempty = return () - mappend a b = a >> b - -- | Define the texture applyied to all the children -- draw call. -- @@ -255,6 +168,47 @@ withTransformation trans sub = liftF $ WithTransform trans sub () +-- | This command allows you to draw primitives on a given curve, +-- for example, you can draw text on a curve: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] in +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) $ +-- > pathToPrimitives path +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > withPathOrientation path 0 $ +-- > printTextAt font 24 (V2 0 0) "Text on path" +-- +-- <<docimages/text_on_path.png>> +-- +-- You can note that the position of the baseline match the size of the +-- characters. +-- +-- You are not limited to text drawing while using this function, +-- you can draw arbitrary geometry like in the following example: +-- +-- > let path = Path (V2 100 180) False +-- > [PathCubicBezierCurveTo (V2 20 20) (V2 170 20) (V2 300 200)] +-- > withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > stroke 3 JoinRound (CapStraight 0, CapStraight 0) $ +-- > pathToPrimitives path +-- > +-- > withPathOrientation path 0 $ do +-- > printTextAt font 24 (V2 0 0) "TX" +-- > fill $ rectangle (V2 (-10) (-10)) 30 20 +-- > fill $ rectangle (V2 45 0) 10 20 +-- > fill $ rectangle (V2 60 (-10)) 20 20 +-- > fill $ rectangle (V2 100 (-15)) 20 50 +-- +-- <<docimages/geometry_on_path.png>> +-- +withPathOrientation :: Path -- ^ Path directing the orientation. + -> Float -- ^ Basline Y axis position, used to align text properly. + -> Drawing px () -- ^ The sub drawings. + -> Drawing px () +withPathOrientation path p sub = + liftF $ WithPathOrientation path p sub () + -- | Fill some geometry. The geometry should be "looping", -- ie. the last point of the last primitive should -- be equal to the first point of the first primitive. @@ -326,20 +280,38 @@ -- > writePng "text_example.png" . -- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) -- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > printTextAt font 12 (V2 20 40) "A simple text test!" +-- > printTextAt font 12 (V2 20 40) +-- > "A simple text test!" -- -- <<docimages/text_example.png>> -- -- You can use any texture, like a gradient while rendering text. -- -printTextAt :: Font -- ^ Drawing font - -> Int -- ^ font Point size - -> Point -- ^ Baseline begining position - -> String -- ^ String to print +printTextAt :: Font -- ^ Drawing font + -> Int -- ^ font Point size + -> Point -- ^ Drawing starting point (base line) + -> String -- ^ String to print -> Drawing px () printTextAt font pointSize point string = - liftF $ TextFill 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. +-- +-- <<docimages/text_complex_example.png>> +-- +printTextRanges :: Point -- ^ Starting point of the base line + -> [TextRange px] -- ^ Ranges description to be printed + -> Drawing px () +printTextRanges point ranges = liftF $ TextFill point ranges () + data RenderContext px = RenderContext { currentClip :: Maybe (Texture (PixelBaseComponent px)) , currentTexture :: Texture px @@ -356,16 +328,25 @@ -> px -- ^ Background color -> Drawing px () -- ^ Rendering action -> Image px -renderDrawing width height background drawing = runST $ - createMutableImage width height background - >>= execStateT (go initialContext $ fromF drawing) - >>= unsafeFreezeImage +renderDrawing width height background drawing = + runST $ runDrawContext width height background + $ mapM_ fillOrder + $ drawOrdersOfDrawing width height background drawing + +-- | Transform a drawing into a serie of low-level drawing orders. +drawOrdersOfDrawing + :: forall px . (RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> [DrawOrder px] +drawOrdersOfDrawing width height background drawing = + go initialContext (fromF drawing) [] where initialContext = RenderContext Nothing stupidDefaultTexture Nothing clipBackground = emptyValue :: PixelBaseComponent px clipForeground = fullValue :: PixelBaseComponent px - stupidDefaultTexture = - uniformTexture $ colorMap (const clipBackground) background clipRender = renderDrawing width height clipBackground @@ -379,58 +360,84 @@ transform (applyTransformation trans) geometryOf _ = id - go :: RenderContext px - -> Free (DrawCommand px) () - -> DrawContext s px () - go _ (Pure ()) = return () - go ctxt (Free (WithTransform trans sub next)) = do - let trans' - | Just (t, _) <- currentTransformation ctxt = t <> trans - | otherwise = trans - invTrans = - fromMaybe mempty $ inverseTransformation trans' - go ctxt { currentTransformation = - Just (trans', invTrans) } $ fromF sub - go ctxt next - go ctxt@RenderContext { currentClip = Nothing } - (Free (Fill method prims next)) = do - fillWithTexture method (textureOf ctxt) $ geometryOf ctxt prims - go ctxt next - go ctxt@RenderContext { currentClip = Just moduler } - (Free (Fill method prims next)) = do - fillWithTextureAndMask method (textureOf ctxt) - moduler $ geometryOf ctxt prims - go ctxt next + stupidDefaultTexture = + uniformTexture $ colorMap (const clipBackground) background - go ctxt (Free (Stroke w j cap prims next)) = - go ctxt . Free $ Fill FillWinding prim' next + 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)) = do - go (ctxt { currentTexture = tx }) $ fromF sub - go ctxt next - go ctxt (Free (DashedStroke o d w j cap prims next)) = do - let recurse sub = - go ctxt . liftF $ Fill FillWinding sub () - mapM_ recurse $ dashedStrokize o d w j cap prims - go ctxt next - go ctxt (Free (TextFill font size (V2 x y) str next)) = do - forM_ drawCalls (go ctxt) - go ctxt next + 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 90 (x, y) + [(_textFont d, _textSize d, _text d) | d <- descriptions] + + linearDescriptions = + concat [map (const d) $ _text d | d <- descriptions] + drawCalls = - beziersOfChar <$> getStringCurveAtPoint 90 (x, y) - [(font, size, str)] + [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)) = do - go (ctxt { currentClip = newModuler }) $ fromF path - go ctxt next + 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 @@ -480,70 +487,6 @@ dashedStrokeWithOffset offset dashing width join caping prims = liftF $ DashedStroke offset dashing width join caping prims () --- | Clip the geometry to a rectangle. -clip :: Point -- ^ Minimum point (corner upper left) - -> Point -- ^ Maximum point (corner bottom right) - -> Primitive -- ^ Primitive to be clipped - -> Container Primitive -clip mini maxi (LinePrim l) = clipLine mini maxi l -clip mini maxi (BezierPrim b) = clipBezier mini maxi b -clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c - -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. The geometry should be "looping", --- ie. the last point of the last primitive should --- be equal to the first point of the first primitive. --- --- The primitive should be connected. -fillWithTexture :: RenderablePixel px - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling - -> [Primitive] -- ^ Primitives to fill - -> DrawContext s px () -{-# SPECIALIZE fillWithTexture - :: FillMethod -> Texture PixelRGBA8 -> [Primitive] - -> DrawContext s PixelRGBA8 () #-} -{-# SPECIALIZE fillWithTexture - :: FillMethod -> Texture Pixel8 -> [Primitive] - -> DrawContext s Pixel8 () #-} -fillWithTexture fillMethod texture els = do - img@(MutableImage width height _) <- get - let !mini = V2 0 0 - !maxi = V2 (fromIntegral width) (fromIntegral height) - !filler = transformTextureToFiller texture img - clipped = F.foldMap (clip mini maxi) els - spans = rasterize fillMethod clipped - lift . mapExec filler $ filter (isCoverageDrawable img) spans - -mapExec :: Monad m => (a -> m ()) -> [a] -> m () -mapExec f = go - where - go [] = return () - go (x : xs) = f x >> go xs - -fillWithTextureAndMask - :: RenderablePixel px - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling - -> Texture (PixelBaseComponent px) - -> [Primitive] -- ^ Primitives to fill - -> DrawContext s px () -fillWithTextureAndMask fillMethod texture mask els = do - img@(MutableImage width height _) <- get - let !mini = V2 0 0 - !maxi = V2 (fromIntegral width) (fromIntegral height) - spans = rasterize fillMethod $ F.foldMap (clip mini maxi) els - !shader = transformTextureToFiller (modulateTexture texture mask) img - lift . mapM_ shader $ filter (isCoverageDrawable img) spans - -- | Generate a list of primitive representing a circle. -- -- > fill $ circle (V2 100 100) 75 @@ -638,17 +581,18 @@ -> Float -- ^ Width of the drawn image -> Float -- ^ Height of the drawn image -> Drawing px () -drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize p +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) $ 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
+ src/Graphics/Rasterific/Command.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module Graphics.Rasterific.Command ( Drawing + , DrawCommand( .. ) + , TextRange( .. ) + , dumpDrawing + ) where + +import Control.Monad.Free( Free( .. ), liftF ) +import Control.Monad.Free.Church( F, fromF ) +import Data.Monoid( Monoid( .. ) ) +import Codec.Picture.Types( Pixel( .. ), Pixel8 ) + +import Graphics.Rasterific.Types +import Graphics.Rasterific.Texture +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Shading + +import Graphics.Text.TrueType( Font, PointSize ) + +-- | Monad used to record the drawing actions. +type Drawing px = F (DrawCommand px) + +-- | Structure defining how to render a text range +data TextRange px = TextRange + { _textFont :: Font -- ^ Font used during the rendering + , _textSize :: PointSize -- ^ Size of the text (in pixels) + , _text :: String -- ^ Text to draw + -- | Texture to use for drawing, if Nothing, the currently + -- active texture is used. + , _textTexture :: Maybe (Texture px) + } + +data DrawCommand px next + = Fill FillMethod [Primitive] next + | Stroke Float Join (Cap, Cap) [Primitive] next + | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next + | TextFill Point [TextRange px] next + | SetTexture (Texture px) + (Drawing px ()) next + | WithCliping (forall innerPixel. Drawing innerPixel ()) + (Drawing px ()) next + | WithTransform Transformation (Drawing px ()) next + | WithPathOrientation Path Float (Drawing px ()) next + +-- | This function will spit out drawing instructions to +-- help debugging. +-- +-- The outputted code looks like Haskell, but there is no +-- guarantee that it is compilable. +dumpDrawing :: ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + + ) => Drawing px () -> String +dumpDrawing = go . fromF where + go :: + ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + + ) => Free (DrawCommand px) () -> String + go (Pure ()) = "return ()" + go (Free (WithPathOrientation path point drawing next)) = + "withPathOrientation (" ++ show path ++ ") (" + ++ show point ++ ") (" + ++ go (fromF drawing) ++ ") >>= " + ++ go next + go (Free (Fill _ prims next)) = + "fill " ++ show prims ++ " >>=\n" ++ go next + go (Free (TextFill _ texts next)) = + concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next + go (Free (SetTexture tx drawing next)) = + "withTexture (" ++ dumpTexture tx ++ ") (" ++ + go (fromF drawing) ++ ") >>=\n" ++ go next + go (Free (DashedStroke o pat w j cap prims next)) = + "dashedStrokeWithOffset " + ++ show o ++ " " + ++ show pat ++ " " + ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ go next + go (Free (Stroke w j cap prims next)) = + "stroke " ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ go next + go (Free (WithTransform trans sub next)) = + "withTransform (" ++ show trans ++ ") (" + ++ go (fromF sub) ++ ") >>=\n " + ++ go next + go (Free (WithCliping clipping draw next)) = + "withClipping (" ++ go (fromF $ withTexture clipTexture clipping) + ++ ")\n" ++ + " (" ++ go (fromF draw) ++ ")\n >>= " ++ + go next + where clipTexture = uniformTexture (0xFF :: Pixel8) + withTexture texture subActions = + liftF $ SetTexture texture subActions () + + +instance Functor (DrawCommand px) where + fmap f (TextFill pos texts next) = + TextFill pos texts $ f next + fmap f (Fill method prims next) = Fill method prims $ f next + fmap f (SetTexture t sub next) = SetTexture t sub $ f next + fmap f (WithCliping sub com next) = + WithCliping sub com $ f next + fmap f (Stroke w j caps prims next) = + Stroke w j caps prims $ f next + fmap f (DashedStroke st pat w j caps prims next) = + DashedStroke st pat w j caps prims $ f next + fmap f (WithTransform trans draw next) = + WithTransform trans draw $ f next + fmap f (WithPathOrientation path point draw next) = + WithPathOrientation path point draw $ f next + +instance Monoid (Drawing px ()) where + mempty = return () + mappend a b = a >> b +
src/Graphics/Rasterific/Compositor.hs view
@@ -12,20 +12,24 @@ , compositionAlpha ) where +import Foreign.Storable( Storable ) import Data.Bits( unsafeShiftR ) import Data.Word( Word8, Word32 ) -import Codec.Picture.Types( Pixel( .. ) ) +import Codec.Picture.Types( Pixel( .. ), PackeablePixel( .. ) ) type Compositor px = - (PixelBaseComponent px) -> - (PixelBaseComponent px) -> px -> px -> 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, Modulable (PixelBaseComponent 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, @@ -35,6 +39,8 @@ type RenderablePixel px = ( ModulablePixel px , Pixel (PixelBaseComponent px) + , PackeablePixel (PixelBaseComponent px) + , Storable (PackedRepresentation (PixelBaseComponent px)) , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px) ) @@ -120,11 +126,12 @@ toWord8 :: Float -> Int +{-# INLINE toWord8 #-} toWord8 r = floor $ r * 255 + 0.5 compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) => Compositor px -compositionDestination c _ _ a = colorMap (modulate c) $ a +compositionDestination c _ _ = colorMap (modulate c) compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) => Compositor px @@ -136,7 +143,7 @@ let bottomOpacity = pixelOpacity bottom alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top) colorComposer _ back fore = - (alphaOver c ic (back `modulate` bottomOpacity) fore) + alphaOver c ic (back `modulate` bottomOpacity) fore `modiv` alphaOut in mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top
src/Graphics/Rasterific/CubicBezier.hs view
@@ -18,12 +18,10 @@ import Prelude hiding( or ) import Control.Applicative( liftA2 , (<$>) - , (<*>) , pure ) import Graphics.Rasterific.Linear - ( V1( .. ) - , V2( .. ) + ( V2( .. ) , (^-^) , (^+^) , (^*) @@ -35,7 +33,6 @@ import Graphics.Rasterific.Operators import Graphics.Rasterific.Types import Graphics.Rasterific.QuadraticFormula -import Graphics.Rasterific.QuadraticBezier( sanitizeBezier ) -- | Create a list of cubic bezier patch from a list of points. -- @@ -78,12 +75,9 @@ V2 x y = vmax (u ^*^ u) (v ^*^ v) tolerance = 16 * tol * tol -flattenCubicBezier :: CubicBezier -> Container Primitive -flattenCubicBezier bezier@(CubicBezier a b c d) - | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier - | otherwise = - flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> - flattenCubicBezier (CubicBezier abbcbccd bccd cd d) +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 @@ -103,6 +97,14 @@ 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 @@ -112,13 +114,22 @@ -- 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 !Float !Float !Float !Float +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 @@ -139,8 +150,8 @@ -- | Find the coefficient of the extremum points extremums :: CachedBezier -> [Float] extremums cached = - nub [ root | root <- formulaRoots $ cachedBezierDerivative cached - , 0 <= root && root <= 1.0 ] + [ root | root <- formulaRoots $ cachedBezierDerivative cached + , 0 <= root && root <= 1.0 ] extremumPoints :: (CachedBezier, CachedBezier) -> [Point] extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY) @@ -173,23 +184,17 @@ -- / \ -- / \ -- A X X D - ab = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d + (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier w = ab `normal` bc x = bc `normal` cd - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd - shiftedA = a ^+^ (u ^* offset) shiftedD = d ^+^ (v ^* offset) {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-} - shiftedB = (b ^+^ (w ^* offset)) - shiftedC = (c ^+^ (x ^* offset)) + shiftedB = b ^+^ (w ^* offset) + shiftedC = c ^+^ (x ^* offset) -- | Clamp the cubic bezier curve inside a rectangle -- given in parameter. @@ -237,13 +242,7 @@ -- / \ -- / \ -- 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 + (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) edge = vpartition edgeSeparator mini maxi @@ -263,21 +262,34 @@ bccd = lerp val bc cd abbcbccd = lerp val abbc bccd -decomposeCubicBeziers :: CubicBezier -> Container EdgeSample -decomposeCubicBeziers (CubicBezier aR bR cR dR) = go aR bR cR dR where - go a@(V2 ax ay) _b _c d@(V2 dx dy) | insideX && insideY = - pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h +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 - !floorA = vfloor a - !floorD = vfloor d - !(V2 px py) = fromIntegral <$> vmin floorA floorD - !(V1 w) = (px + 1 -) <$> (V1 dx `midPoint` V1 ax) - !h = dy - ay - !(V2 insideX insideY) = - floorA ^==^ floorD ^||^ vceil a ^==^ vceil d + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay - go a b c d = go a ab abbc m <> go m bccd cd d - where + !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 -- / ___/ \___ \ @@ -288,35 +300,40 @@ -- / \ -- / \ -- A X X D - !ab = a `midPoint` b - !bc = b `midPoint` c - !cd = c `midPoint` d - !abbc = ab `midPoint` bc - !bccd = bc `midPoint` cd + !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 - !abbcbccd = abbc `midPoint` bccd + !abbcbccdx = abbcx `middle` bccdx + !abbcbccdy = abbcy `middle` bccdy - mini = fromIntegral <$> vfloor abbcbccd - maxi = fromIntegral <$> vceil abbcbccd - !nearmin = vabs (abbcbccd ^-^ mini) ^< 0.1 - !nearmax = vabs (abbcbccd ^-^ maxi) ^< 0.1 + !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) - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p + !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) - !m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax - <*> abbcbccd sanitizeCubicBezier :: CubicBezier -> Container Primitive sanitizeCubicBezier bezier@(CubicBezier a b c d) - | b `isNearby` c = sanitizeBezier $ Bezier a c d | a `isDistingableFrom` b && c `isDistingableFrom` d = pure . CubicBezierPrim $ bezier - | (ac `isDistingableFrom` b && - bd `isDistingableFrom` c) = + | ac `isDistingableFrom` b && + bd `isDistingableFrom` c = pure . CubicBezierPrim $ bezier | ac `isDistingableFrom` b = pure . CubicBezierPrim $ CubicBezier a ac c d
+ src/Graphics/Rasterific/Immediate.hs view
@@ -0,0 +1,185 @@+{-# 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.ST( ST ) +import Control.Monad.State( StateT, execStateT, get, lift ) +import Codec.Picture.Types( Image( .. ) + , Pixel( .. ) + , Pixel8 + , PixelRGBA8 + , 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 a = + StateT (MutableImage (PrimState m) px) m a + +-- | Reify a filling function call, to be able to manipulate +-- them in a simpler fashion. +data DrawOrder px = DrawOrder + { -- | Primitives to be filled. + _orderPrimitives :: ![[Primitive]] + -- | Texture for the filled primitives. + , _orderTexture :: !(Texture px) + -- | How to fill the primitives. + , _orderFillMethod :: !FillMethod + -- | Optional mask used for clipping. + , _orderMask :: !(Maybe (Texture (PixelBaseComponent px))) + } + +-- | Transform back a low level drawing order to a more +-- high level Drawing +orderToDrawing :: DrawOrder px -> Drawing px () +orderToDrawing order = + usingTexture . mapM_ filler $ _orderPrimitives order + where + usingTexture sub = + liftF $ SetTexture (_orderTexture order) sub () + filler prims = + liftF $ Fill (_orderFillMethod order) prims () + +-- | Render the drawing orders on the canvas. +fillOrder :: (PrimMonad m, RenderablePixel px) + => DrawOrder px -> DrawContext m px () +fillOrder o@DrawOrder { _orderMask = Nothing } = + F.forM_ (_orderPrimitives o) $ + fillWithTexture (_orderFillMethod o) (_orderTexture o) +fillOrder o@DrawOrder { _orderMask = Just mask } = + F.forM_ (_orderPrimitives o) $ + fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask + +-- | Start an image rendering. See `fillWithTexture` for +-- an usage example. This function can work with either +-- `IO` or `ST`. +runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> DrawContext m px () -- ^ Actual drawing computation + -> m (Image px) +runDrawContext width height background drawing = do + buff <- M.new (width * height * componentCount background) + let mutable = MutableImage width height buff + fillImageWith mutable background + img <- execStateT drawing mutable + unsafeFreezeImage img + +mapExec :: Monad m => (a -> m ()) -> [a] -> m () +mapExec f = foldr ((>>) . f) (return ()) + +isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool +isCoverageDrawable img coverage = + _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight + where + !imgWidth = fromIntegral $ mutableImageWidth img + !imgHeight = fromIntegral $ mutableImageHeight img + x = _coverageX coverage + y = _coverageY coverage + +-- | Fill some geometry. +-- +-- > immediateDrawExample :: Image PixelRGBA8 +-- > immediateDrawExample = runST $ +-- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $ +-- > fillWithTexture FillWinding texture geometry +-- > where +-- > circlePrimitives = circle (V2 100 100) 50 +-- > geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives +-- > texture = uniformTexture (PixelRGBA8 255 255 255 255) +-- +-- <<docimages/immediate_fill.png>> +-- +fillWithTexture :: (PrimMonad m, RenderablePixel px) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling + -> [Primitive] -- ^ Primitives to fill + -> DrawContext m px () +{-# SPECIALIZE fillWithTexture + :: FillMethod -> Texture PixelRGBA8 -> [Primitive] + -> DrawContext (ST s) PixelRGBA8 () #-} +{-# SPECIALIZE fillWithTexture + :: FillMethod -> Texture Pixel8 -> [Primitive] + -> DrawContext (ST s) Pixel8 () #-} +fillWithTexture fillMethod texture els = do + img@(MutableImage width height _) <- get + let !mini = V2 0 0 + !maxi = V2 (fromIntegral width) (fromIntegral height) + !filler = primToPrim . transformTextureToFiller texture img + clipped = F.foldMap (clip mini maxi) els + spans = rasterize fillMethod clipped + lift . mapExec filler $ filter (isCoverageDrawable img) spans + +-- | Fill some geometry using a composition mask for visibility. +-- +-- > immediateDrawMaskExample :: Image PixelRGBA8 +-- > immediateDrawMaskExample = runST $ +-- > runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ +-- > forM_ [1 .. 10] $ \ix -> +-- > fillWithTextureAndMask FillWinding texture mask $ +-- > rectangle (V2 10 (ix * 18 - 5)) 180 13 +-- > where +-- > texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 +-- > mask = sampledImageTexture +-- > $ runST +-- > $ runDrawContext 200 200 0 +-- > $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry +-- > +-- > maskGeometry = strokize 15 JoinRound (CapRound, CapRound) +-- > $ circle (V2 100 100) 80 +-- +-- <<docimages/immediate_mask.png>> +-- +fillWithTextureAndMask + :: (PrimMonad m, RenderablePixel px) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling of the geometry + -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask. + -> [Primitive] -- ^ Primitives to fill + -> DrawContext m px () +fillWithTextureAndMask fillMethod texture mask els = do + img@(MutableImage width height _) <- get + let !mini = V2 0 0 + !maxi = V2 (fromIntegral width) (fromIntegral height) + spans = rasterize fillMethod $ F.foldMap (clip mini maxi) els + !shader = primToPrim + . transformTextureToFiller (modulateTexture texture mask) img + lift . mapM_ shader $ filter (isCoverageDrawable img) spans +
src/Graphics/Rasterific/Line.hs view
@@ -11,11 +11,10 @@ , offsetLine ) where -import Control.Applicative( (<$>), (<*>), pure ) +import Control.Applicative( (<$>), pure ) import Data.Monoid( (<>), mempty ) import Graphics.Rasterific.Linear - ( V1( .. ) - , V2( .. ) + ( V2( .. ) , (^-^) , (^+^) , (^*) @@ -91,7 +90,7 @@ -- A X-----X-----X B -- AB - ab = (a `midPoint` b) + ab = a `midPoint` b -- mini -- +-------------+ @@ -117,33 +116,42 @@ -- TODO: implement better algorithm for lines, should -- be doable. -decomposeLine :: Line -> Container EdgeSample -decomposeLine (Line aRoot bRoot) = go aRoot bRoot where - go !a@(V2 ax ay) !b@(V2 bx by) - | insideX && insideY = pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h +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 - !floorA = vfloor a - !floorB = vfloor b - !(V2 insideX insideY) = - floorA ^==^ floorB ^||^ vceil a ^==^ vceil b + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay - !(V2 px py) = fromIntegral <$> vmin floorA floorB - !(V1 w) = (px + 1 -) <$> (V1 bx `midPoint` V1 ax) - !h = by - ay + !floorBx = floor bx + !floorBy = floor by - go a b = go a m <> go m b - where - !ab = a `midPoint` b + !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int) + !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int) - !mini = fromIntegral <$> vfloor ab - !maxi = fromIntegral <$> vceil ab - !nearmin = vabs (ab ^-^ mini) ^< 0.1 - !nearmax = vabs (ab ^-^ maxi) ^< 0.1 - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p + 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 - !m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> ab + !mx | abs (abx - mini) < 0.1 = mini + | abs (abx - maxi) < 0.1 = maxi + | otherwise = abx + where !mini = fromIntegral (floor abx :: Int) + !maxi = fromIntegral (ceiling abx :: Int) + + !my | abs (aby - mini) < 0.1 = mini + | abs (aby - maxi) < 0.1 = maxi + | otherwise = aby + where !mini = fromIntegral (floor aby :: Int) + !maxi = fromIntegral (ceiling aby :: Int)
src/Graphics/Rasterific/Linear.hs view
@@ -42,6 +42,7 @@ data V2 a = V2 !a !a deriving (Eq, Show) +-- | A 1-dimensional vector newtype V1 a = V1 a deriving (Eq, Show)
src/Graphics/Rasterific/Operators.hs view
@@ -18,6 +18,7 @@ , vceil , clampPoint , midPoint + , middle , vpartition , normal , ifZero @@ -120,6 +121,10 @@ 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.
src/Graphics/Rasterific/Outline.hs view
@@ -1,8 +1,10 @@ -- | This module provide helper functions to create outline -- of shapes. module Graphics.Rasterific.Outline - ( strokize + ( StrokeWidth + , strokize , S.dashedStrokize + , S.approximatePathLength ) where import Graphics.Rasterific.Types
+ src/Graphics/Rasterific/PathWalker.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | 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 + +import Data.Foldable( foldMap ) +import Control.Applicative( Applicative, (<$>), (<*>) ) +import Control.Monad.Identity( Identity ) +import Control.Monad.State( StateT + , MonadTrans + , lift + , evalStateT + , modify + , gets ) +import Data.Monoid( mempty, (<>) ) +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 } + +-- | Extract the first point of the primitive. +firstPointOf :: Primitive -> Point +firstPointOf p = case p of + LinePrim (Line p0 _) -> p0 + BezierPrim (Bezier p0 _ _) -> p0 + CubicBezierPrim (CubicBezier p0 _ _ _) -> p0 + +-- | 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 + +-- | Gives the orientation vector for the current point on +-- the path. +firstTangeantOf :: Primitive -> Vector +firstTangeantOf p = case p of + LinePrim (Line p0 p1) -> p1 ^-^ p0 + BezierPrim (Bezier p0 p1 _) -> p1 ^-^ p0 + CubicBezierPrim (CubicBezier p0 p1 _ _) -> p1 ^-^ p0 + +-- | Obtain the current tangeant of the path if we're still +-- on it. Return Nothing otherwise. +currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector) +currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims) + where + currTangeant [] = Nothing + currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim + +-- | Callback function in charge to transform the DrawOrder +-- given the transformation to place it on the path. +type PathDrawer m px = + Transformation -> PlaneBound -> DrawOrder px -> m () + +-- | This function is the workhorse of the placement, it will +-- walk the path and calculate the appropriate transformation +-- for every order. +drawOrdersOnPath :: Monad m + => PathDrawer m px -- ^ Function handling the placement of the order. + -> Float -- ^ Starting offset + -> Float -- ^ Baseline vertical position in the orders. + -> Path -- ^ Path on which to place the orders. + -> [DrawOrder px] -- ^ Orders to place on a path. + -> m () +drawOrdersOnPath drawer startOffset baseline path orders = + runPathWalking path $ advanceBy startOffset >> go Nothing orders where + go _ [] = return () + go prevX (img : rest) = do + let bounds = + foldMap (foldMap planeBounds) $ _orderPrimitives img + width = boundWidth bounds + cx = fromMaybe startX prevX + V2 startX _ = boundLowerLeftCorner bounds + V2 endX _ = _planeMaxBound bounds + halfWidth = width / 2 + spaceWidth = abs $ startX - cx + translation = V2 (negate startX - halfWidth) (- baseline) + + if bounds == mempty then go prevX rest + else do + advanceBy (halfWidth + spaceWidth) + mayPos <- currentPosition + mayDir <- currentTangeant + case (,) <$> mayPos <*> mayDir of + Nothing -> return () -- out of path, stop drawing + Just (pos, dir) -> do + let imageTransform = + translate pos <> toNewXBase dir + <> translate translation + lift $ drawer imageTransform bounds img + advanceBy halfWidth + go (Just endX) rest +
src/Graphics/Rasterific/PlaneBoundable.hs view
@@ -3,7 +3,11 @@ -- | Module implementing types used for geometry -- bound calculations. module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. ) - , PlaneBoundable( .. ) ) where + , PlaneBoundable( .. ) + , boundWidth + , boundHeight + , boundLowerLeftCorner + ) where import Control.Applicative( (<$>), (<*>) ) import Data.Monoid( Monoid( .. ), (<>) ) @@ -26,6 +30,19 @@ , _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
src/Graphics/Rasterific/QuadraticBezier.hs view
@@ -16,10 +16,9 @@ , bezierLengthApproximation ) where -import Control.Applicative( (<$>), (<*>), pure ) +import Control.Applicative( pure ) import Graphics.Rasterific.Linear ( V2( .. ) - , V1( .. ) , (^-^) , (^+^) , (^*) @@ -48,38 +47,54 @@ bezierLengthApproximation (Bezier a _ c) = norm $ c ^-^ a -decomposeBeziers :: Bezier -> Container EdgeSample -decomposeBeziers (Bezier aRoot bRoot cRoot) = go aRoot bRoot cRoot where - go !a@(V2 ax ay) !_ !c@(V2 cx cy) - | insideX && insideY = pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h +decomposeBeziers :: Bezier -> Producer EdgeSample +decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) = + go aRx aRy bRx bRy cRx cRy where + go ax ay _bx _by cx cy cont + | insideX && insideY = + let !px = fromIntegral $ min floorAx floorCx + !py = fromIntegral $ min floorAy floorCy + !w = px + 1 - cx `middle` ax + !h = cy - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont where - !floorA = vfloor a - !floorC = vfloor c - !(V2 insideX insideY) = - floorA ^==^ floorC ^||^ vceil a ^==^ vceil c + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay - !(V2 px py) = fromIntegral <$> vmin floorA floorC - !(V1 w) = (px + 1 -) <$> (V1 cx `midPoint` V1 ax) - !h = cy - ay + !floorCx = floor cx + !floorCy = floor cy - go a b c = go a ab m <> go m bc c + !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int) + !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int) + + + go !ax !ay !bx !by !cx !cy cont = + go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont where - !ab = a `midPoint` b - !bc = b `midPoint` c - !abbc = ab `midPoint` bc + !abx = ax `middle` bx + !aby = ay `middle` by - !mini = fromIntegral <$> vfloor abbc - !maxi = fromIntegral <$> vceil abbc - !nearmin = vabs (abbc ^-^ mini) ^< 0.1 - !nearmax = vabs (abbc ^-^ maxi) ^< 0.1 + !bcx = bx `middle` cx + !bcy = by `middle` cy - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p + !abbcx = abx `middle` bcx + !abbcy = aby `middle` bcy - !m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc + !mx | abs (abbcx - mini) < 0.1 = mini + | abs (abbcx - maxi) < 0.1 = maxi + | otherwise = abbcx + where !mini = fromIntegral (floor abbcx :: Int) + !maxi = fromIntegral (ceiling abbcx :: Int) + !my | abs (abbcy - mini) < 0.1 = mini + | abs (abbcy - maxi) < 0.1 = maxi + | otherwise = abbcy + where !mini = fromIntegral (floor abbcy :: Int) + !maxi = fromIntegral (ceiling abbcy :: Int) + + -- | Create a quadratic bezier curve representing -- a straight line. straightLine :: Point -> Point -> Bezier @@ -129,9 +144,7 @@ -- / \ -- A X X C -- - ab = a `midPoint` b - bc = b `midPoint` c - abbc = ab `midPoint` bc + (ab, bc, abbc) = splitBezier bezier -- mini -- +-------------+ @@ -197,6 +210,23 @@ bc = lerp t b c abbc = lerp t ab bc +splitBezier :: Bezier -> (Point, Point, Point) +{-# INLINE splitBezier #-} +splitBezier (Bezier a b c) = (ab, bc, abbc) + where + -- + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + -- + ab = a `midPoint` b + bc = b `midPoint` c + abbc = ab `midPoint` bc + flattenBezier :: Bezier -> Container Primitive flattenBezier bezier@(Bezier a b c) -- If the spline is not too curvy, just return the @@ -219,13 +249,11 @@ u = a `normal` b v = b `normal` c - ab = (a `midPoint` b) - bc = (b `midPoint` c) - abbc = ab `midPoint` bc + (ab, bc, abbc) = splitBezier bezier -- | Move the bezier to a new position with an offset. offsetBezier :: Float -> Bezier -> Container Primitive -offsetBezier offset (Bezier a b c) +offsetBezier offset bezier@(Bezier a b c) -- If the spline is not too curvy, just return the -- shifted component | u `dot` v >= 0.9 = @@ -248,9 +276,7 @@ v = b `normal` c w = ab `normal` bc - ab = (a `midPoint` b) - bc = (b `midPoint` c) - abbc = ab `midPoint` bc + (ab, bc, abbc) = splitBezier bezier shiftedA = a ^+^ (u ^* offset) shiftedC = c ^+^ (v ^* offset)
src/Graphics/Rasterific/Rasterize.hs view
@@ -2,11 +2,13 @@ module Graphics.Rasterific.Rasterize ( CoverageSpan( .. ) , rasterize + , clip ) where import Control.Monad.ST( runST ) import Data.Fixed( mod' ) import Data.Foldable( foldMap ) +import Data.Monoid( Endo( Endo, appEndo ) ) import Graphics.Rasterific.Types import Graphics.Rasterific.QuadraticBezier import Graphics.Rasterific.CubicBezier @@ -38,16 +40,36 @@ where p1 = CoverageSpan x y (prepareCoverage a) 1 p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) -decompose :: Primitive -> Container EdgeSample +-- | Clip the geometry to a rectangle. +clip :: Point -- ^ Minimum point (corner upper left) + -> Point -- ^ Maximum point (corner bottom right) + -> Primitive -- ^ Primitive to be clipped + -> Container Primitive +clip mini maxi (LinePrim l) = clipLine mini maxi l +clip mini maxi (BezierPrim b) = clipBezier mini maxi b +clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c + +decompose :: Primitive -> Producer EdgeSample decompose (LinePrim l) = decomposeLine l decompose (BezierPrim b) = decomposeBeziers b -decompose (CubicBezierPrim c) = decomposeCubicBeziers c +decompose (CubicBezierPrim c) = + {-decomposeCubicBezierForwardDifference c-} + decomposeCubicBeziers c +xyCompare :: EdgeSample -> EdgeSample -> Ordering +{-# INLINE xyCompare #-} +xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax }) + !(EdgeSample { _sampleY = by, _sampleX = bx }) = + case compare ay by of + EQ -> compare ax bx + c -> c + sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample sortEdgeSamples samples = runST $ do + -- Resist the urge to make this a storable vector, + -- it is actually a pessimisation. mutableVector <- V.unsafeThaw $ V.fromList samples - let xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b) - VS.sortBy xy mutableVector + VS.sortBy xyCompare mutableVector V.unsafeFreeze mutableVector rasterize :: FillMethod -> Container Primitive -> [CoverageSpan] @@ -55,12 +77,12 @@ case method of FillWinding -> combineEdgeSamples combineWinding . sortEdgeSamples - . listOfContainer - . foldMap decompose + . (($ []) . appEndo) + . foldMap (Endo . decompose) FillEvenOdd -> combineEdgeSamples combineEvenOdd . sortEdgeSamples - . listOfContainer - . foldMap decompose + . (($ []) . appEndo) + . foldMap (Endo . decompose) where combineWinding = min 1 . abs combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1
src/Graphics/Rasterific/Shading.hs view
@@ -11,6 +11,10 @@ , dumpTexture ) where +import Control.Monad.Primitive( PrimState + -- one day (GHC >= 7.10 ?) + {-, PrimMonad-} + ) import Data.Fixed( mod' ) import Data.Monoid( (<>) ) import Graphics.Rasterific.Linear @@ -21,6 +25,7 @@ , norm ) + import Control.Monad.ST( ST ) import qualified Data.Vector as V @@ -29,7 +34,11 @@ , MutableImage( .. ) , Pixel8 , PixelRGBA8 + , unsafeWritePixelBetweenAt + , readPackedPixelAt + , writePackedPixelAt ) + import Graphics.Rasterific.Types( Point , Vector , Line( .. ) @@ -90,18 +99,20 @@ } deriving (Eq, Show) -type CoverageFiller s px = - MutableImage s px -> CoverageSpan -> ST s () +type CoverageFiller m px = + MutableImage (PrimState m) px -> CoverageSpan -> m () -type Filler s = - TextureSpaceInfo -> ST s () +type Filler m = + TextureSpaceInfo -> m () -solidColor :: forall s px . ModulablePixel px - => px -> MutableImage s px -> Filler s +-- | 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 - -> Filler s #-} + -> TextureSpaceInfo -> ST s () #-} {-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8 - -> Filler s #-} + -> TextureSpaceInfo -> ST s () #-} solidColor color _ tsInfo | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 = return () @@ -109,18 +120,12 @@ -- We are in the case fully opaque, so we can -- just overwrite what was there before | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 = - go 0 $ _tsBaseIndex tsInfo + unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi + {-go 0 $ _tsBaseIndex tsInfo-} where !fullOpacity = fullValue :: PixelBaseComponent px !maxi = _tsRepeat tsInfo - !compCount = componentCount (undefined :: px) - !vectorData = mutableImageData img - go count _ | count >= maxi = return () - go count writeIndex = do - (vectorData `unsafeWritePixel` writeIndex) color - go (count + 1) $ writeIndex + compCount - -- We can be transparent, so perform alpha blending. solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo where @@ -128,42 +133,40 @@ !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo !(cov, icov) = coverageModulate scanCoverage opacity !maxi = _tsRepeat tsInfo - !imgData = mutableImageData img !compCount = componentCount (undefined :: px) go count _ | count >= maxi = return () go !count !idx = do - oldPixel <- unsafeReadPixel imgData idx - unsafeWritePixel imgData idx + oldPixel <- readPackedPixelAt img idx + writePackedPixelAt img idx $ compositionAlpha cov icov oldPixel color go (count + 1) $ idx + compCount -shaderFiller :: forall s px . ModulablePixel px +shaderFiller :: forall s px . (ModulablePixel px) => ShaderFunction px -> MutableImage s px - -> Filler s + -> Filler (ST s) {-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8 -> MutableImage s PixelRGBA8 - -> Filler s #-} + -> Filler (ST s) #-} {-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8 -> MutableImage s Pixel8 - -> Filler s #-} + -> Filler (ST s) #-} shaderFiller shader img tsInfo = go 0 (_tsBaseIndex tsInfo) xStart yStart where !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo !maxi = _tsRepeat tsInfo - !imgData = mutableImageData img !compCount = componentCount (undefined :: px) - !(V2 xStart yStart) = _tsStart tsInfo - !(V2 dx dy) = _tsDelta tsInfo + (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 <- unsafeReadPixel imgData idx - unsafeWritePixel imgData idx + oldPixel <- readPackedPixelAt img idx + writePackedPixelAt img idx $ compositionAlpha cov icov oldPixel color go (count + 1) (idx + compCount) (x + dx) (y + dy) @@ -213,6 +216,12 @@ 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 @@ -241,11 +250,9 @@ -- | This function will interpret the texture description, helping -- prepare and optimize the real calculation transformTextureToFiller - :: RenderablePixel px - => Texture px -> CoverageFiller s px -{-# SPECIALIZE transformTextureToFiller - :: Texture PixelRGBA8 -> CoverageFiller s PixelRGBA8 #-} -transformTextureToFiller texture = go Nothing SamplerPad texture + :: (RenderablePixel px) + => Texture px -> CoverageFiller (ST s) px +transformTextureToFiller = go Nothing SamplerPad where go _ _ (SolidTexture px) = \img -> solidColor px img . prepareInfoNoTransform img @@ -279,6 +286,8 @@ => 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 @@ -298,6 +307,9 @@ {-# 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 @@ -310,8 +322,14 @@ -> 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 + \x y -> colorAt $ (V2 x y `dot` d) - s00 where colorAt = gradientColorAtRepeat repeating gradArray gradArray = V.fromList gradient @@ -395,8 +413,16 @@ -> 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 + \x y -> colorAt $ norm (V2 x y ^-^ center) / radius where !colorAt = gradientColorAtRepeat repeating gradArray !gradArray = V.fromList gradient @@ -409,8 +435,16 @@ -> 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 + \x y -> colorAt . go $ V2 x y ^-^ center where focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center colorAt = gradientColorAtRepeat repeating gradArray @@ -450,6 +484,7 @@ => ShaderFunction px -> ShaderFunction (PixelBaseComponent px) -> ShaderFunction px -modulateTexture fullTexture modulator = \x y -> +{-# INLINE modulateTexture #-} +modulateTexture fullTexture modulator x y = colorMap (modulate $ modulator x y) $ fullTexture x y
src/Graphics/Rasterific/StrokeInternal.hs view
@@ -3,6 +3,8 @@ , dashize , strokize , dashedStrokize + , splitPrimitiveUntil + , approximatePathLength ) where import Control.Applicative( (<$>), pure ) @@ -38,11 +40,11 @@ firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) reversePrimitive :: Primitive -> Primitive -reversePrimitive (LinePrim (Line a b)) = (LinePrim (Line b a)) +reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a) reversePrimitive (BezierPrim (Bezier a b c)) = - (BezierPrim (Bezier c b a)) + BezierPrim (Bezier c b a) reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) = - (CubicBezierPrim (CubicBezier d c b a)) + CubicBezierPrim (CubicBezier d c b a) -- | Create a "rounded" join or cap roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive @@ -116,7 +118,7 @@ miterJoin :: Float -> Float -> Point -> Vector -> Vector -> Container Primitive miterJoin offset l point u v - | uDotW > l / max 1 l && uDotW > 0.001 = + | 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 @@ -186,7 +188,7 @@ offseter capEnd sanitized <> offseter capStart (reverse $ reversePrimitive <$> sanitized) where - sanitized = foldMap (listOfContainer . sanitize) $ beziers + sanitized = foldMap (listOfContainer . sanitize) beziers offseter = offsetAndJoin (width / 2) join flattenPrimitive :: Primitive -> Container Primitive @@ -207,7 +209,7 @@ flatten = foldMap flattenPrimitive splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) -splitPrimitiveUntil at = go at +splitPrimitiveUntil = go where go _ [] = ([], []) go left lst @@ -227,15 +229,28 @@ where go _ [] = [] go offset (x:xs) - | x < 0 = (x:xs) -- sanitizing + | 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 . listOfContainer - . foldMap flattenPrimitive - . foldMap sanitize +dashize offset pattern = taker infinitePattern . linearizePrimitives where realOffset | offset >= 0 = offset | otherwise = offset + sum pattern
src/Graphics/Rasterific/Transformations.hs view
@@ -14,12 +14,13 @@ , rotateCenter , skewX , skewY + , toNewXBase , inverseTransformation ) where import Data.Monoid( Monoid( .. ), (<>) ) import Graphics.Rasterific.Types -import Graphics.Rasterific.Linear( V2( .. ) ) +import Graphics.Rasterific.Linear( V2( .. ), (^+^), normalize ) -- | Represent a 3*3 matrix for homogenous coordinates. -- @@ -110,6 +111,11 @@ -- <<docimages/transform_scale.png>> -- scale :: Float -> Float -> Transformation +{-# RULES + "scale mappend" forall ax ay bx by. + mappend (scale ax ay) (scale bx by) = + scale (ax * bx) (ay * by) + #-} scale scaleX scaleY = Transformation scaleX 0 0 0 scaleY 0 @@ -122,6 +128,10 @@ -- <<docimages/transform_translate.png>> -- translate :: Vector -> Transformation +{-# RULES + "translate mappend" forall a b. + mappend (translate a) (translate b) = translate (a ^+^ b) + #-} translate (V2 x y) = Transformation 1 0 x 0 1 y @@ -152,6 +162,15 @@ Transformation 1 0 0 t 1 0 where t = tan v + +-- | Given a new X-acis vector, create a rotation matrix +-- to get into this new base, assuming an Y basis orthonormal +-- to the X one. +toNewXBase :: Vector -> Transformation +toNewXBase vec = + Transformation dx (-dy) 0 + dy dx 0 + where V2 dx dy = normalize vec transformationDeterminant :: Transformation -> Float transformationDeterminant (Transformation a c _e
src/Graphics/Rasterific/Types.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} -- | Gather all the types used in the rasterization engine. module Graphics.Rasterific.Types @@ -12,9 +11,11 @@ , Bezier( .. ) , CubicBezier( .. ) , Primitive( .. ) + , Producer , Container , containerOfList , listOfContainer + , containerOfFunction , PathCommand( .. ) , Path( .. ) , Transformable( .. ) @@ -37,6 +38,14 @@ import Data.Foldable( Foldable, foldl' ) import Graphics.Rasterific.Linear( V2( .. ) ) +import Foreign.Ptr( castPtr ) +import Foreign.Storable( Storable( sizeOf + , alignment + , peek + , poke + , peekElemOff + , pokeElemOff ) ) + -- | Represent a vector type Vector = V2 Float @@ -156,6 +165,28 @@ } deriving Show +-- | Just to get faster sorting +instance Storable EdgeSample where + sizeOf _ = 4 * sizeOf (0 :: Float) + alignment = sizeOf + + {-# INLINE peek #-} + peek ptr = do + let q = castPtr ptr + sx <- peekElemOff q 0 + sy <- peekElemOff q 1 + sa <- peekElemOff q 2 + sh <- peekElemOff q 3 + return $ EdgeSample sx sy sa sh + + {-# INLINE poke #-} + poke ptr (EdgeSample sx sy sa sh) = do + let q = castPtr ptr + pokeElemOff q 0 sx + pokeElemOff q 1 sy + pokeElemOff q 2 sa + pokeElemOff q 3 sh + -- | This typeclass is there to help transform the geometry, -- by applying a transformation on every point of a geometric -- element. @@ -173,11 +204,11 @@ instance Transformable Point where {-# INLINE transform #-} - transform f p = f p + transform f = f instance PointFoldable Point where {-# INLINE foldPoints #-} - foldPoints f acc p = f acc p + foldPoints f = f -- | Describe a simple 2D line between two points. -- @@ -318,7 +349,12 @@ => PointFoldable (f a) where foldPoints f = foldl' (foldPoints f) +type Producer a = [a] -> [a] + type Container a = DList a + +containerOfFunction :: ([a] -> [a]) -> Container a +containerOfFunction f = fromList $ f [] containerOfList :: [a] -> Container a containerOfList = fromList