diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -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.2.1 +version: 0.3 synopsis: A pure haskell drawing engine. -- A longer description of the package. description: @@ -34,31 +34,65 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Rasterific.git - Tag: v0.2.1 + Tag: v0.3 +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.Transformations other-modules: Graphics.Rasterific.Line - , Graphics.Rasterific.QuadraticBezier , Graphics.Rasterific.CubicBezier - , Graphics.Rasterific.Stroke + , 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: -O2 -Wall ghc-prof-options: -Wall -prof -auto-all default-language: Haskell2010 build-depends: base >= 4.6 && < 4.9 - , JuicyPixels >= 3.1.5 && < 3.2 - , linear >= 1.3.1 && < 1.9 - , free >= 4.5 && < 4.7 - , FontyFruity >= 0.2 && < 0.3 + , JuicyPixels >= 3.1.5.2 && < 3.2 + , FontyFruity >= 0.3 && < 0.4 , vector >= 0.9 - , mtl >= 2.1 + , vector-algorithms >= 0.3 + , free >= 4.7 + , mtl >= 1.9 + , dlist >= 0.6 + + if !flag(embed_linear) + build-depends: linear >= 1.3 + cpp-options: -DEXTERNAL_LINEAR + +Test-Suite test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + Main-Is: rastertest.hs + ghc-options: -Wall -O2 + ghc-prof-options: -rtsopts -Wall -prof -auto-all + Hs-Source-Dirs: exec-src + Build-Depends: base >= 4.6 + , Rasterific + , JuicyPixels + , directory >= 1.2 + , filepath + , vector + , FontyFruity + , binary + , QuickCheck >= 2.7 + , deepseq + , criterion >= 0.8 && < 0.9 + , statistics >= 0.10 && < 0.11 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,21 @@ -*-change-log-*- +v0.3 2014 + * Switching main free monad type to the church encoded one. + * 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 + 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. + v0.2.1 April 2014 * Fixing transparency in gradients. * Fixing alpha composition on top of translucent diff --git a/docimages/cap_round.png b/docimages/cap_round.png Binary files a/docimages/cap_round.png and b/docimages/cap_round.png differ 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/cap_straight_1.png b/docimages/cap_straight_1.png Binary files a/docimages/cap_straight_1.png and b/docimages/cap_straight_1.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_polygon.png b/docimages/fill_polygon.png Binary files a/docimages/fill_polygon.png and b/docimages/fill_polygon.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/image_resize.png b/docimages/image_resize.png Binary files a/docimages/image_resize.png and b/docimages/image_resize.png differ diff --git a/docimages/image_simple.png b/docimages/image_simple.png Binary files a/docimages/image_simple.png and b/docimages/image_simple.png differ diff --git a/docimages/join_miter.png b/docimages/join_miter.png Binary files a/docimages/join_miter.png and b/docimages/join_miter.png differ diff --git a/docimages/join_miter_5.png b/docimages/join_miter_5.png Binary files a/docimages/join_miter_5.png and b/docimages/join_miter_5.png differ diff --git a/docimages/join_round.png b/docimages/join_round.png Binary files a/docimages/join_round.png and b/docimages/join_round.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/path_example.png b/docimages/path_example.png Binary files a/docimages/path_example.png and b/docimages/path_example.png differ diff --git a/docimages/primitive_mixed.png b/docimages/primitive_mixed.png Binary files a/docimages/primitive_mixed.png and b/docimages/primitive_mixed.png differ diff --git a/docimages/radial_gradient.png b/docimages/radial_gradient.png Binary files a/docimages/radial_gradient.png and b/docimages/radial_gradient.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_pad.png b/docimages/sampled_texture_pad.png Binary files a/docimages/sampled_texture_pad.png and b/docimages/sampled_texture_pad.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_repeat.png b/docimages/sampled_texture_repeat.png Binary files a/docimages/sampled_texture_repeat.png and b/docimages/sampled_texture_repeat.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/simple_line.png b/docimages/simple_line.png Binary files a/docimages/simple_line.png and b/docimages/simple_line.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/stroke_roundedRectangle.png b/docimages/stroke_roundedRectangle.png Binary files a/docimages/stroke_roundedRectangle.png and b/docimages/stroke_roundedRectangle.png differ diff --git a/docimages/strokize_dashed_path.png b/docimages/strokize_dashed_path.png new file mode 100644 Binary files /dev/null and b/docimages/strokize_dashed_path.png differ diff --git a/docimages/strokize_path.png b/docimages/strokize_path.png new file mode 100644 Binary files /dev/null and b/docimages/strokize_path.png differ diff --git a/docimages/transform_rotate.png b/docimages/transform_rotate.png Binary files a/docimages/transform_rotate.png and b/docimages/transform_rotate.png differ diff --git a/docimages/transform_rotate_center.png b/docimages/transform_rotate_center.png Binary files a/docimages/transform_rotate_center.png and b/docimages/transform_rotate_center.png differ diff --git a/docimages/transform_skewx.png b/docimages/transform_skewx.png new file mode 100644 Binary files /dev/null and b/docimages/transform_skewx.png differ diff --git a/docimages/transform_skewy.png b/docimages/transform_skewy.png new file mode 100644 Binary files /dev/null and b/docimages/transform_skewy.png differ diff --git a/docimages/with_clipping.png b/docimages/with_clipping.png Binary files a/docimages/with_clipping.png and b/docimages/with_clipping.png differ diff --git a/exec-src/rastertest.hs b/exec-src/rastertest.hs new file mode 100644 --- /dev/null +++ b/exec-src/rastertest.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +import System.FilePath( () ) +import System.Directory( createDirectoryIfMissing ) + +import Data.Foldable( foldMap ) +import Data.Monoid( (<>) ) +import Control.Applicative( (<$>) ) +import Graphics.Rasterific hiding ( fill + , dashedStrokeWithOffset + , dashedStroke + , fillWithMethod, stroke) +import qualified Graphics.Rasterific as R +import Graphics.Rasterific.Texture +import Graphics.Rasterific.Linear( (^+^), (^-^) ) +import Graphics.Rasterific.Transformations + +import Graphics.Text.TrueType( loadFontFile ) +import Codec.Picture +import Arbitrary +import System.Environment( getArgs ) +import Criterion.Config( defaultConfig ) +import Criterion.Main( parseArgs + , defaultOptions + , defaultMainWith + , bench + ) +import qualified Sample as Sample + +type Stroker = + Float -> Join -> (Cap, Cap) -> [Primitive] + -> Drawing PixelRGBA8 () + +type DashStroker = DashPattern -> Stroker + +outFolder :: FilePath +outFolder = "test_results" + +logo :: Int -> Bool -> Vector -> [Primitive] +logo size inv offset = map BezierPrim . bezierFromPath . way $ map (^+^ offset) + [ (V2 0 is) + , (V2 0 0) + , (V2 is 0) + , (V2 is2 0) + , (V2 is2 is) + , (V2 is2 is2) + , (V2 is is2) + , (V2 0 is2) + , (V2 0 is) + ] + where is = fromIntegral size + is2 = is + is + + way | inv = reverse + | otherwise = id + + +background, blue, black, yellow, red, white :: PixelRGBA8 +background = PixelRGBA8 128 128 128 255 +blue = PixelRGBA8 0 020 150 255 +red = PixelRGBA8 255 0 0 255 +black = PixelRGBA8 0 0 0 255 +{-grey = PixelRGBA8 128 128 128 255-} +yellow = PixelRGBA8 255 255 0 255 +{-brightblue = PixelRGBA8 0 255 255 255-} +white = PixelRGBA8 255 255 255 255 + +biColor, triColor :: Gradient PixelRGBA8 +biColor = [ (0.0, black) , (1.0, yellow) ] +triColor = [ (0.0, blue), (0.5, white) , (1.0, red) ] + +fill :: [Primitive] -> Drawing PixelRGBA8 () +fill = fillWithMethod FillWinding + +drawBoundingBox :: [Primitive] -> Drawing PixelRGBA8 () +drawBoundingBox prims = do + let PlaneBound mini maxi = foldMap planeBounds prims + V2 width height = maxi ^-^ mini + withTexture (uniformTexture red) $ + R.stroke 2 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ + rectangle mini width height + +stroke :: Float -> Join -> (Cap, Cap) -> [Primitive] + -> Drawing PixelRGBA8 () +stroke w j cap prims = + R.stroke w j cap prims >> drawBoundingBox prims + +dashedStroke :: DashPattern -> Float -> Join -> (Cap, Cap) -> [Primitive] + -> Drawing PixelRGBA8 () +dashedStroke p w j c prims = + R.dashedStroke p w j c prims >> drawBoundingBox prims + +dashedStrokeWithOffset + :: Float -> DashPattern -> Float -> Join -> (Cap, Cap) -> [Primitive] + -> Drawing PixelRGBA8 () +dashedStrokeWithOffset o p w j c prims = + R.dashedStrokeWithOffset o p w j c prims >> drawBoundingBox prims + +fillWithMethod :: FillMethod -> [Primitive] -> Drawing PixelRGBA8 () +fillWithMethod method prims = + R.fillWithMethod method prims >> drawBoundingBox prims + +logoTest :: Texture PixelRGBA8 -> String -> IO () +logoTest texture prefix = + writePng (outFolder (prefix ++ "logo.png")) img + where + beziers = logo 40 False $ V2 10 10 + inverse = logo 20 True $ V2 20 20 + drawing = withTexture texture . fill $ beziers ++ inverse + img = renderDrawing 100 100 background drawing + +makeBox :: Point -> Point -> [Primitive] +makeBox (V2 sx sy) (V2 ex ey) = map LinePrim $ lineFromPath + [ V2 sx sy + , V2 ex sy + , V2 ex ey + , V2 sx ey + , V2 sx sy + ] + +bigBox :: Texture PixelRGBA8 -> String -> IO () +bigBox texture prefix = + writePng (outFolder (prefix ++ "box.png")) img + where + drawing = withTexture texture . fill $ makeBox (V2 10 10) (V2 390 390) + img = renderDrawing 400 400 background drawing + +circleTest :: Texture PixelRGBA8 -> String -> IO () +circleTest texture prefix = + writePng (outFolder (prefix ++ "circle.png")) img + where + drawing = withTexture texture . fill $ circle (V2 100 100) 90 + img = renderDrawing 200 200 background drawing + +cubicTest :: [Primitive] +cubicTest = map CubicBezierPrim $ cubicBezierFromPath + [ V2 50 20 + , V2 90 60 + , V2 5 100 + , V2 50 140 + + , V2 70 120 + , V2 80 100 + , V2 120 80 + + , V2 100 60 + , V2 70 20 + , V2 50 20 + ] + +cubicTest1 :: IO () +cubicTest1 = writePng (outFolder "cubic1.png") img + where texture = uniformTexture blue + drawing = withTexture texture $ fill cubicTest + img = renderDrawing 150 150 background drawing + +clipTest :: IO () +clipTest = writePng (outFolder "clip.png") img + where texture = uniformTexture blue + beziers = + [ logo 20 False $ V2 (-10) (-10) + , logo 20 False $ V2 80 80 + , logo 20 False $ V2 0 80 + , logo 20 False $ V2 80 0 + ] + + drawing = withTexture texture $ mapM_ fill beziers + img = renderDrawing 100 100 background drawing + +strokeTest2 :: Stroker -> String -> IO () +strokeTest2 stroker prefix = + writePng (outFolder (prefix ++ "stroke2.png")) img + where texture = uniformTexture blue + points = + [ V2 10 10, V2 100 100 + , V2 200 20, V2 300 100, V2 450 50] + + drawing = withTexture texture . sequence_ . concat $ + [ [] + , [stroker 9 JoinRound (CapRound, CapStraight 0) + . map LinePrim . lineFromPath $ + (^+^ (V2 15 (20 * (ix + 5)))) <$> points + | ix <- [-5 .. -1] ] + , [stroker 9 (JoinMiter $ ix * 3) (CapStraight 0, CapRound) + . map LinePrim . lineFromPath $ + (^+^ (V2 15 (20 * (ix + 5)))) <$> points + | ix <- [0 .. 5] ] + ] + + img = renderDrawing 500 500 background drawing + +strokeTestCliping :: Stroker -> String -> IO () +strokeTestCliping stroker prefix = + writePng (outFolder (prefix ++ "stroke_clipping.png")) img + where texture = uniformTexture blue + points = + [ V2 10 10, V2 100 100 + , V2 200 20, V2 300 100, V2 450 50] + + clipShape = R.fill $ circle (V2 250 250) 200 + + drawing = do + withClipping clipShape . + withTexture texture . sequence_ . concat $ + [ [] + , [stroker 9 JoinRound (CapRound, CapStraight 0) + . map LinePrim . lineFromPath $ + (^+^ (V2 15 (20 * (ix + 5)))) <$> points + | ix <- [-5 .. -1] ] + , [stroker 9 (JoinMiter $ ix * 3) (CapStraight 0, CapRound) + . map LinePrim . lineFromPath $ + (^+^ (V2 15 (20 * (ix + 5)))) <$> points + | ix <- [0 .. 5] ] + ] + withTexture (uniformTexture $ PixelRGBA8 255 128 100 128) + . fill $ circle (V2 150 150) 40 + + img = renderDrawing 500 500 background drawing + +strokeLogo :: Stroker -> String -> IO () +strokeLogo stroker prefix = + writePng (outFolder (prefix ++ "stroke_logo.png")) img + where texture = uniformTexture blue + beziers = logo 40 False $ V2 10 10 + inverse = logo 20 True $ V2 20 20 + img = renderDrawing 100 100 background + . withTexture texture + . stroker 4 JoinRound (CapRound, CapRound) + $ beziers ++ inverse + +strokeQuadraticIntersection :: + Stroker -> Texture PixelRGBA8 -> String -> IO () +strokeQuadraticIntersection stroker texture prefix = + writePng (outFolder (prefix ++ "stroke_quad_intersection.png")) img + where img = renderDrawing 500 500 background + . withTexture texture + . stroker 40 JoinRound (CapRound, CapRound) + . map BezierPrim + $ bezierFromPath + [ V2 30 30 + , V2 150 200 + , V2 450 450 + + , V2 450 90 + , V2 30 450 + ] + +strokeCubic :: Stroker -> Texture PixelRGBA8 -> String + -> IO () +strokeCubic stroker texture prefix = + writePng (outFolder (prefix ++ "cubicStroke.png")) img + where img = renderDrawing 500 500 background drawing + cusp = CubicBezier + (V2 10 230) + (V2 350 570) + (V2 10 570) + (V2 350 230) + + loop = CubicBezier + (V2 160 20) + (V2 770 500) + (V2 140 500) + (V2 480 70) + + drawing = withTexture texture . sequence_ . concat $ + [ [] + , [stroker 4 JoinRound (CapRound, CapRound) + $ take 1 cubicTest ] + + , [stroker 15 (JoinMiter 0) + (CapStraight 0, CapStraight 0) + [CubicBezierPrim cusp]] + + , [stroker 25 (JoinMiter 0) + (CapStraight 0, CapStraight 0) + [CubicBezierPrim loop]] + ] + +strokeCubicDashed :: DashStroker -> Texture PixelRGBA8 -> String + -> IO () +strokeCubicDashed stroker texture prefix = + writePng (outFolder (prefix ++ "cubicStrokeDashed.png")) img + where img = renderDrawing 500 500 background drawing + cusp = CubicBezier + (V2 10 230) + (V2 350 570) + (V2 10 570) + (V2 350 230) + + loop = CubicBezier + (V2 160 20) + (V2 770 500) + (V2 140 500) + (V2 480 70) + + dashPattern = [10, 5, 20, 10] + + drawing = withTexture texture . sequence_ . concat $ + [ [] + , [stroker dashPattern 4 JoinRound (CapRound, CapRound) + $ take 1 cubicTest ] + + , [stroker dashPattern 15 (JoinMiter 0) + (CapStraight 0, CapStraight 0) + [CubicBezierPrim cusp]] + + , [stroker dashPattern 25 (JoinMiter 0) + (CapStraight 0, CapStraight 0) + [CubicBezierPrim loop]] + ] + +textAlignStringTest :: String -> String -> String -> IO () +textAlignStringTest fontName filename txt = do + putStrLn $ "Rendering " ++ fontName + fontErr <- loadFontFile $ "C:/Windows/Fonts/" ++ fontName ++ ".ttf" + case fontErr of + Left err -> putStrLn err + Right font -> + writePng (outFolder filename) . + renderDrawing 300 70 white + . withTexture (uniformTexture black) $ + printTextAt font 12 (V2 20 40) txt + +strokeTest :: Stroker -> Texture PixelRGBA8 -> String + -> IO () +strokeTest stroker texture prefix = + writePng (outFolder (prefix ++ "stroke.png")) img + where beziers base = take 1 <$> + take 3 [ logo 100 False $ V2 ix ix | ix <- [base, base + 20 ..] ] + drawing = withTexture texture $ sequence_ . concat $ + [ [] + , [stroker (6 + ix) (JoinMiter ix) + (CapStraight 0, CapRound) b + | (ix, b) <- zip [1 ..] (beziers 10)] + , [stroker ix + (JoinMiter 1) (CapRound, CapStraight 1) b + | (ix, b) <- zip [1 ..] (beziers 60)] + , [stroker ix (JoinMiter 1) (CapRound, CapRound) b + | (ix, b) <- zip [1 ..] (beziers 110)] + , [stroker 15 + (JoinMiter 1) (CapStraight 1, CapStraight 0) + . take 1 $ + logo 150 False $ V2 200 200] + , [stroker 5 + (JoinMiter 1) (CapStraight 0, CapStraight 0) $ + logo 100 False $ V2 240 240] + ] + img = renderDrawing 500 500 background drawing + +complexEvenOddTest :: Int -> Texture PixelRGBA8 -> IO () +complexEvenOddTest size texture = mapM_ tester [(filling, ix) + | filling <- [(FillEvenOdd, "evenodd") + ,(FillWinding, "winding")] + , ix <- [1 :: Int .. 3]] where + command = + [ Path (V2 484 499) True + [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) + , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) + ] + , Path (V2 136 377) True + [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) + , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) + ] + , Path (V2 340 265) True + [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) + , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) + , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) + ] + ] + + tester ((method, name), i) = + writePng (outFolder ("complex_" ++ name ++ "_" ++ show i ++ "_" ++ show size ++ "px.png")) + . renderDrawing size size white + . withTexture texture + . fillWithMethod method + . fmap (transform . applyTransformation $ + rotateCenter (fromIntegral i / 6) (V2 (350) (350))) + $ concatMap pathToPrimitives command + +evenOddTest :: Texture PixelRGBA8 -> IO () +evenOddTest texture = mapM_ tester [1 :: Int .. 3] where + command = + Path (V2 250 75) True + [ PathLineTo (V2 323 301) + , PathLineTo (V2 131 161) + , PathLineTo (V2 369 161) + , PathLineTo (V2 177 301) + ] + tester i = + writePng (outFolder ("even_odd" ++ show i ++ ".png")) + . renderDrawing 300 300 white + . withTexture texture + . fillWithMethod FillEvenOdd + . fmap (transform . applyTransformation $ + translate (V2 (-80) (-40)) + <> rotateCenter (fromIntegral i / 6) (V2 (250) (200))) + $ pathToPrimitives command + +crash :: Texture PixelRGBA8 -> IO () +crash texture = do + writePng (outFolder "crash00.png") $ + renderDrawing 600 600 background $ + withTexture texture $ fill geom + where + geom = concat + [line (V2 572.7273 572.7273) (V2 572.7273 27.272766) + ,line (V2 572.7273 27.272728) (V2 27.272766 27.272728) + ,line (V2 27.272728 27.272728) (V2 27.272728 572.72723) + ,line (V2 27.272728 572.7273) (V2 572.72723 572.7273) + + ,line (V2 481.81818 481.81818) (V2 118.18182 481.81818) + ,line (V2 118.181816 481.81818) (V2 118.181816 118.18182) + ,line (V2 118.181816 118.181816) (V2 481.81818 118.181816) + ,line (V2 481.81818 118.181816) (V2 481.81818 481.81818) + ] +strokeCrash :: IO () +strokeCrash = do + let drawColor = PixelRGBA8 0 0x86 0xc1 255 + img = renderDrawing 600 600 white $ + withTexture (uniformTexture drawColor) $ do + stroke 5 (JoinMiter 0) (CapStraight 0, CapStraight 0) + [LinePrim (Line (V2 572.7273 572.7273) (V2 572.7273 27.272766)) + ,LinePrim (Line (V2 572.7273 27.272728) (V2 27.272766 27.272728)) + ,LinePrim (Line (V2 27.272728 27.272728) (V2 27.272728 572.72723)) + ,LinePrim (Line (V2 27.272728 572.7273) (V2 572.72723 572.7273)) + ] + stroke 5 (JoinMiter 0) (CapStraight 0, CapStraight 0) + [LinePrim (Line (V2 481.81818 481.81818) (V2 118.18182 481.81818)) + ,LinePrim (Line (V2 118.181816 481.81818) (V2 118.181816 118.18182)) + ,LinePrim (Line (V2 118.181816 118.181816) (V2 481.81818 118.181816)) + ,LinePrim (Line (V2 481.81818 118.181816) (V2 481.81818 481.81818)) + ] + + writePng (outFolder "stroke_crash.png") img + +dashTest :: IO () +dashTest = writePng (outFolder "dashed_wheel.png") + . renderDrawing 550 550 white + $ withTexture (uniformTexture black) drawing + where + drawing = + dashedStrokeWithOffset 0.0 [4.0,4.0] 10.0 + (JoinMiter 0.0) (CapStraight 0.0,CapStraight 0.0) + [CubicBezierPrim + (CubicBezier (V2 525.0 275.0) (V2 525.0 136.92882) + (V2 413.0712 25.0) (V2 275.0 25.0)) + ] + +weirdCircle :: IO () +weirdCircle = writePng (outFolder "bad_circle.png") + . renderDrawing 400 200 white + $ withTexture (uniformTexture black) drawing + where + drawing = + fill [CubicBezierPrim $ CubicBezier (V2 375.0 125.0) + (V2 375.0 55.96441) + (V2 319.03558 0.0) + (V2 250.0 0.0) + ,CubicBezierPrim $ CubicBezier (V2 250.0 (-1.4210855e-14)) + (V2 180.96442 (-1.8438066e-14)) + (V2 125.0 55.964405) + (V2 125.0 125.0) + ,CubicBezierPrim $ CubicBezier (V2 125.0 125.0) + (V2 125.0 194.03558) + (V2 180.9644 250.0) + (V2 250.0 250.0) + ,CubicBezierPrim $ CubicBezier (V2 250.0 250.0) + (V2 319.03558 250.0) + (V2 375.0 194.0356) + (V2 375.0 125.0) + ] + +transparentGradient :: IO () +transparentGradient = + writePng (outFolder "transparent_gradient.png") $ renderDrawing 400 200 white img + where img = withTexture (withSampler SamplerPad + (linearGradientTexture gradDef + (V2 40 40) (V2 130 130))) $ + fill $ circle (V2 100 100) 100 + gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) + ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) + ,(1, PixelRGBA8 0xFF 0x53 0x73 50)] + +gradientRadial :: String -> PixelRGBA8 -> IO () +gradientRadial name back = + writePng (outFolder ("rad_opacity" ++ name ++ ".png")) $ + renderDrawing 500 500 back img + where img = withTexture (withSampler SamplerRepeat + (radialGradientTexture gradDef + (V2 250 250) 100)) $ + fill $ rectangle (V2 0 0) 500 500 + gradDef = + [(0 , PixelRGBA8 255 165 0 102) + ,(0.5, PixelRGBA8 255 165 0 102) + ,(0.5, PixelRGBA8 255 165 0 102) + ,(0.525, PixelRGBA8 255 165 0 255) + ,(0.675, PixelRGBA8 128 128 128 64) + ,(0.75, PixelRGBA8 0 128 128 255) + ,(1, PixelRGBA8 0 128 128 255) + ] +strokeBad :: IO () +strokeBad = + writePng (outFolder ("bad_stroke_tiger.png")) $ + renderDrawing 500 500 white drawing + where + drawing = + withTransformation (Transformation { _transformA = 1.6 + , _transformC = 0.0 + , _transformE = 350.0 + , _transformB = 0.0 + , _transformD = 1.6 + , _transformF = 300.0}) $ + withTexture (uniformTexture (PixelRGBA8 76 0 0 255)) $ + stroke 2.0 (JoinMiter 1.0) (CapStraight 0.0 + ,CapStraight 0.0) $ + CubicBezierPrim <$> + [CubicBezier (V2 21.2 63.0) + (V2 21.2 63.0) + (V2 4.200001 55.8) + (V2 (-10.599998) 53.6) + ,CubicBezier (V2 (-10.599998) 53.6) + (V2 (-10.599998) 53.6) + (V2 (-27.199999) 51.0) + (V2 (-43.8) 58.199997) + ,CubicBezier (V2 (-43.8) 58.199997) + (V2 (-43.8) 58.199997) + (V2 (-56.0) 64.2) + (V2 (-61.4) 74.399994)] + +testSuite :: IO () +testSuite = do + let uniform = uniformTexture blue + biGradient = + linearGradientTexture biColor (V2 10 10) (V2 90 90) + radBiGradient = + radialGradientTexture biColor (V2 45 45) 60 + bigBiGradient = + linearGradientTexture biColor (V2 0 10) (V2 0 390) + triGradient = + linearGradientTexture triColor (V2 0 10) (V2 0 390) + radTriGradient = + radialGradientTexture triColor (V2 250 250) 200 + radFocusTriGradient = + radialGradientWithFocusTexture + triColor (V2 200 200) 70 (V2 250 200) + radFocusTriGradient2 = + radialGradientWithFocusTexture + triColor (V2 200 200) 70 (V2 150 170) + + createDirectoryIfMissing True outFolder + strokeBad + evenOddTest uniform + complexEvenOddTest 700 uniform + complexEvenOddTest 350 uniform + + weirdCircle + dashTest + + strokeCrash + logoTest uniform "" + logoTest biGradient "gradient_" + crash uniform + transparentGradient + gradientRadial "white_opaque" white + gradientRadial "black_opaque" black + gradientRadial "white_transparent" (PixelRGBA8 255 255 255 0) + gradientRadial "white_semi" (PixelRGBA8 255 255 255 128) + gradientRadial "black_transparent" (PixelRGBA8 0 0 0 0) + gradientRadial "gray_opaque" (PixelRGBA8 128 128 128 255) + gradientRadial "gray_transparent" (PixelRGBA8 128 128 128 0) + gradientRadial "gray_semi" (PixelRGBA8 128 128 128 128) + + bigBox uniform "" + bigBox biGradient "gradient_" + bigBox bigBiGradient "gradient_big_" + bigBox triGradient "gradient_tri_" + bigBox radBiGradient "rad_gradient_" + bigBox radTriGradient "rad_trigradient_" + bigBox radFocusTriGradient "rad_focus_trigradient_" + bigBox radFocusTriGradient2 "rad_focus_trigradient_2_" + + circleTest uniform "" + strokeTestCliping stroke "" + + cubicTest1 + clipTest + strokeTest stroke uniform "" + strokeTest stroke bigBiGradient "gradient_" + strokeTest stroke radTriGradient "rad_gradient_" + strokeLogo stroke "" + + strokeQuadraticIntersection stroke uniform "" + strokeQuadraticIntersection stroke triGradient "gradient_" + strokeQuadraticIntersection stroke radBiGradient "rad_gradient_" + + strokeTest2 stroke "" + + strokeCubic stroke uniform "" + strokeCubic stroke bigBiGradient "gradient_" + strokeCubic stroke radTriGradient "rad_gradient_" + + strokeCubicDashed dashedStroke uniform "" + + let testText = + "Test of a text! It seems to be; à é è ç, working? () {} [] \" '" + + textAlignStringTest "CONSOLA" "alignedConsola.png" testText + textAlignStringTest "arial" "alignedArial.png" + "Just a simple test, gogo !!! Yay ; quoi ?" + -- -} + +benchTest :: [String] -> IO () +benchTest args = do + (config, _) <- + parseArgs defaultConfig defaultOptions args + defaultMainWith config (return ()) + [bench "testsuite" testSuite, + bench "Triangles" Sample.triangles] + +main :: IO () +main = do + args <- getArgs + case args of + "random":_ -> randomTests + "bench":rest -> benchTest rest + "prof":_ -> Sample.triangles + _ -> testSuite + diff --git a/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs --- a/src/Graphics/Rasterific.hs +++ b/src/Graphics/Rasterific.hs @@ -4,6 +4,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} -- | Main module of Rasterific, an Haskell rasterization engine. -- -- Creating an image is rather simple, here is a simple example @@ -49,6 +51,9 @@ , dashedStrokeWithOffset , printTextAt + -- * Generating images + , ModulablePixel + , RenderablePixel , renderDrawing , pathToPrimitives @@ -69,6 +74,8 @@ , PathCommand( .. ) , Transformable( .. ) , PointFoldable( .. ) + , PlaneBoundable( .. ) + , PlaneBound( .. ) -- * Helpers , line @@ -99,11 +106,14 @@ ) 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 Data.Maybe( fromMaybe ) import Data.Monoid( Monoid( .. ), (<>) ) import Codec.Picture.Types( Image( .. ) , Pixel( .. ) @@ -114,18 +124,19 @@ , unsafeFreezeImage ) import qualified Data.Vector.Unboxed as VU -import Linear( V2( .. ), (^+^), (^*) ) - import Graphics.Rasterific.Compositor -{-import Graphics.Rasterific.Operators-} +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.Stroke +import Graphics.Rasterific.StrokeInternal import Graphics.Rasterific.Transformations +import Graphics.Rasterific.PlaneBoundable +{-import Graphics.Rasterific.TensorPatch-} import Graphics.Text.TrueType( Font, PointSize, getStringCurveAtPoint ) @@ -141,7 +152,7 @@ ------------------------------------------------ -- | Monad used to record the drawing actions. -type Drawing px = Free (DrawCommand px) +type Drawing px = F (DrawCommand px) data DrawCommand px next = Fill FillMethod [Primitive] next @@ -159,37 +170,50 @@ -- -- The outputted code looks like Haskell, but there is no -- guarantee that it is compilable. -dumpDrawing :: (Show px) => Drawing px () -> String -dumpDrawing (Pure ()) = "return ()" -dumpDrawing (Free (Fill _ prims next)) = - "fill " ++ show prims ++ " >>=\n" ++ dumpDrawing next -dumpDrawing (Free (TextFill _ _ _ text next)) = - "-- Text : " ++ text ++ "\n" ++ dumpDrawing next -dumpDrawing (Free (SetTexture _tx drawing next)) = - "withTexture ({- texture -}) (" ++ - dumpDrawing drawing ++ ") >>=\n" ++ dumpDrawing next -dumpDrawing (Free (DashedStroke o pat w j cap prims next)) = +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" ++ dumpDrawing next -dumpDrawing (Free (Stroke w j cap prims next)) = + ++ show prims ++ " >>=\n" ++ go next + go (Free (Stroke w j cap prims next)) = "stroke " ++ show w ++ " (" ++ show j ++ ") " ++ show cap ++ " " - ++ show prims ++ " >>=\n" ++ dumpDrawing next -dumpDrawing (Free (WithTransform trans sub next)) = - "withTransform (" ++ show trans ++ ") (" - ++ dumpDrawing sub ++ ") >>=\n " - ++ dumpDrawing next -dumpDrawing (Free (WithCliping clipping draw next)) = - "withClipping (" ++ dumpDrawing (withTexture clipTexture clipping) + ++ 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" ++ - " (" ++ dumpDrawing draw++ ")\n >>= " ++ - dumpDrawing next + " (" ++ go (fromF draw) ++ ")\n >>= " ++ + go next where clipTexture = uniformTexture (0xFF :: Pixel8) @@ -209,9 +233,6 @@ instance Monoid (Drawing px ()) where mempty = return () - - mappend (Pure ()) b = b - mappend a (Pure ()) = a mappend a b = a >> b -- | Define the texture applyied to all the children @@ -329,12 +350,7 @@ -- Tested pixels type are PixelRGBA8 and Pixel8, pixel types -- in other colorspace will probably produce weird results. renderDrawing - :: forall px - . ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px) - ) + :: forall px . (RenderablePixel px) => Int -- ^ Rendering width -> Int -- ^ Rendering height -> px -- ^ Background color @@ -342,7 +358,7 @@ -> Image px renderDrawing width height background drawing = runST $ createMutableImage width height background - >>= execStateT (go initialContext drawing) + >>= execStateT (go initialContext $ fromF drawing) >>= unsafeFreezeImage where initialContext = RenderContext Nothing stupidDefaultTexture Nothing @@ -364,15 +380,17 @@ geometryOf _ = id go :: RenderContext px - -> Drawing 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', inverseTransformation trans') } sub + Just (trans', invTrans) } $ fromF sub go ctxt next go ctxt@RenderContext { currentClip = Nothing } (Free (Fill method prims next)) = do @@ -380,15 +398,15 @@ go ctxt next go ctxt@RenderContext { currentClip = Just moduler } (Free (Fill method prims next)) = do - fillWithTextureAndMask method (currentTexture ctxt) + fillWithTextureAndMask method (textureOf ctxt) moduler $ geometryOf ctxt prims go ctxt next go ctxt (Free (Stroke w j cap prims next)) = go ctxt . Free $ Fill FillWinding prim' next - where prim' = strokize w j cap prims + where prim' = listOfContainer $ strokize w j cap prims go ctxt (Free (SetTexture tx sub next)) = do - go (ctxt { currentTexture = tx }) sub + go (ctxt { currentTexture = tx }) $ fromF sub go ctxt next go ctxt (Free (DashedStroke o d w j cap prims next)) = do let recurse sub = @@ -411,11 +429,11 @@ $ VU.toList c | c <- curves] go ctxt (Free (WithCliping clipPath path next)) = do - go (ctxt { currentClip = newModuler }) path + go (ctxt { currentClip = newModuler }) $ fromF path go ctxt next where modulationTexture :: Texture (PixelBaseComponent px) - modulationTexture = imageTexture $ clipRender clipPath + modulationTexture = RawTexture $ clipRender clipPath newModuler = Just . subModuler $ currentClip ctxt @@ -466,32 +484,53 @@ clip :: Point -- ^ Minimum point (corner upper left) -> Point -- ^ Maximum point (corner bottom right) -> Primitive -- ^ Primitive to be clipped - -> [Primitive] + -> 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 :: (Pixel px, Modulable (PixelBaseComponent px)) +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) - spans = rasterize fillMethod $ els >>= clip mini maxi - lift $ mapM_ (composeCoverageSpan texture img) spans + 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 - :: ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px)) + :: RenderablePixel px => FillMethod -> Texture px -- ^ Color/Texture used for the filling -> Texture (PixelBaseComponent px) @@ -499,97 +538,11 @@ -> DrawContext s px () fillWithTextureAndMask fillMethod texture mask els = do img@(MutableImage width height _) <- get - let mini = V2 0 0 - maxi = V2 (fromIntegral width) (fromIntegral height) - spans = rasterize fillMethod $ els >>= clip mini maxi - lift $ mapM_ (composeCoverageSpanWithMask texture mask img) spans - -composeCoverageSpan :: forall s px . - ( Pixel px, Modulable (PixelBaseComponent px) ) - => Texture px - -> MutableImage s px - -> CoverageSpan - -> ST s () -{-# SPECIALIZE - composeCoverageSpan - :: forall s. - Texture PixelRGBA8 - -> MutableImage s PixelRGBA8 - -> CoverageSpan -> ST s () #-} -{-# SPECIALIZE - composeCoverageSpan - :: forall s. - Texture Pixel8 - -> MutableImage s Pixel8 - -> CoverageSpan -> ST s () #-} -composeCoverageSpan texture img coverage - | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () - | otherwise = go 0 initialX initIndex - where compCount = componentCount (undefined :: px) - maxi = _coverageLength coverage - imgData = mutableImageData img - y = floor $ _coverageY coverage - initialX = floor $ _coverageX coverage - imgWidth = mutableImageWidth img - imgHeight = mutableImageHeight img - initIndex = (initialX + y * imgWidth) * compCount - (initialCov, _) = - clampCoverage $ _coverageVal coverage - - shader = texture SamplerPad - - go count _ _ | count >= maxi = return () - go count x idx = do - oldPixel <- unsafeReadPixel imgData idx - let px = shader (fromIntegral x) (fromIntegral y) - opacity = pixelOpacity px - (cov, icov) = coverageModulate initialCov opacity - unsafeWritePixel imgData idx - $ compositionAlpha cov icov oldPixel px - - go (count + 1) (x + 1) $ idx + compCount - -composeCoverageSpanWithMask - :: forall s px - . ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px) ) - => Texture px - -> Texture (PixelBaseComponent px) - -> MutableImage s px - -> CoverageSpan - -> ST s () -{-# INLINE composeCoverageSpanWithMask #-} -composeCoverageSpanWithMask texture mask img coverage - | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () - | otherwise = go 0 initialX initIndex - where compCount = componentCount (undefined :: px) - maxi = _coverageLength coverage - imgData = mutableImageData img - y = floor $ _coverageY coverage - initialX = floor $ _coverageX coverage - imgWidth = mutableImageWidth img - imgHeight = mutableImageHeight img - initIndex = (initialX + y * imgWidth) * compCount - (initialCov, _) = - clampCoverage $ _coverageVal coverage - - maskShader = mask SamplerPad - shader = texture SamplerPad - - go count _ _ | count >= maxi = return () - go count x idx = do - oldPixel <- unsafeReadPixel imgData idx - let fx = fromIntegral x - fy = fromIntegral y - maskValue = maskShader fx fy - px = shader fx fy - (coeffMasked, _) = coverageModulate initialCov maskValue - (cov, icov) = coverageModulate coeffMasked $ pixelOpacity px - unsafeWritePixel imgData idx - $ compositionAlpha cov icov oldPixel px - go (count + 1) (x + 1) $ idx + compCount - + 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. -- @@ -664,7 +617,7 @@ -- -- <> -- -drawImage :: (Pixel px, Modulable (PixelBaseComponent px)) +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. 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,10 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} -- | 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 @@ -18,6 +21,24 @@ (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)) + +-- | 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) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + ) + -- | Typeclass intented at pixel value modulation. -- May be throwed out soon. class (Ord a, Num a) => Modulable a where @@ -58,31 +79,41 @@ 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 - modulate c a = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + {-# INLINE modulate #-} + modulate c a = fromIntegral . div255 $ fi c * fi a + 128 where fi :: Word8 -> Word32 fi = fromIntegral - v = fi c * fi a + 128 + {-# 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 $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + 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 $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + fromIntegral $ div255 v where fi :: Word8 -> Word32 fi = fromIntegral v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 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,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.Rasterific.CubicBezier ( cubicBezierCircle @@ -11,25 +12,29 @@ , offsetCubicBezier , flattenCubicBezier , cubicBezierLengthApproximation + , cubicBezierBounds ) where import Prelude hiding( or ) -import Control.Applicative( Applicative - , liftA2 +import Control.Applicative( liftA2 , (<$>) , (<*>) , pure ) -import Linear( V1( .. ) +import Graphics.Rasterific.Linear + ( V1( .. ) , V2( .. ) , (^-^) , (^+^) , (^*) , norm + , lerp ) -import Data.Monoid( Monoid, mempty, (<>) ) +import Data.List( nub ) +import Data.Monoid( mempty, (<>) ) 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. @@ -107,6 +112,44 @@ -- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y -- 0 1 2 3 +-- | Represent the cubic bezier curve as a vector ready +-- for matrix multiplication +data CachedBezier = CachedBezier !Float !Float !Float !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 = + nub [ 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 = @@ -212,61 +255,59 @@ cubicBezierBreakAt (CubicBezier a b c d) val = (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d) where - ab = lerpPoint a b val - bc = lerpPoint b c val - cd = lerpPoint c d val + ab = lerp val a b + bc = lerp val b c + cd = lerp val c d - abbc = lerpPoint ab bc val - bccd = lerpPoint bc cd val - abbcbccd = lerpPoint abbc bccd val + abbc = lerp val ab bc + bccd = lerp val bc cd + abbcbccd = lerp val abbc bccd decomposeCubicBeziers :: CubicBezier -> Container EdgeSample -decomposeCubicBeziers (CubicBezier a@(V2 ax ay) b c d@(V2 dx dy)) - | insideX && insideY = - pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h - | otherwise = - recurse (CubicBezier a ab abbc m) <> - recurse (CubicBezier m bccd cd d) - where recurse = decomposeCubicBeziers - floorA = vfloor a - floorD = vfloor d - V2 px py = fromIntegral <$> vmin floorA floorD - V1 w = (px + 1 -) <$> (V1 dx `midPoint` V1 ax) - h = dy - ay - - V2 insideX insideY = - floorA ^==^ floorD ^||^ vceil a ^==^ vceil d +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 + 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 - -- BC - -- B X----------X---------X C - -- / ___/ \___ \ - -- / __X------X------X_ \ - -- /___/ ABBC BCCD \___\ - -- AB X/ \X CD - -- / \ - -- / \ - -- / \ - -- A X X D - ab = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd + go a b c d = go a ab abbc m <> go m bccd cd d + where + -- BC + -- B X----------X---------X C + -- / ___/ \___ \ + -- / __X------X------X_ \ + -- /___/ ABBC BCCD \___\ + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + !ab = a `midPoint` b + !bc = b `midPoint` c + !cd = c `midPoint` d + !abbc = ab `midPoint` bc + !bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd + !abbcbccd = abbc `midPoint` bccd - mini = fromIntegral <$> vfloor abbcbccd - maxi = fromIntegral <$> vceil abbcbccd - nearmin = vabs (abbcbccd ^-^ mini) ^< 0.1 - nearmax = vabs (abbcbccd ^-^ maxi) ^< 0.1 + mini = fromIntegral <$> vfloor abbcbccd + maxi = fromIntegral <$> vceil abbcbccd + !nearmin = vabs (abbcbccd ^-^ mini) ^< 0.1 + !nearmax = vabs (abbcbccd ^-^ maxi) ^< 0.1 - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p + minMaxing mi nearmi ma nearma p + | nearmi = mi + | nearma = ma + | otherwise = p - m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax - <*> abbcbccd + !m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax + <*> abbcbccd sanitizeCubicBezier :: CubicBezier -> Container Primitive sanitizeCubicBezier bezier@(CubicBezier a b c d) @@ -274,9 +315,9 @@ | a `isDistingableFrom` b && c `isDistingableFrom` d = pure . CubicBezierPrim $ bezier - | ac `isDistingableFrom` b && - bd `isDistingableFrom` c = - pure . CubicBezierPrim $ CubicBezier a ac bd d + | (ac `isDistingableFrom` b && + bd `isDistingableFrom` c) = + pure . CubicBezierPrim $ bezier | ac `isDistingableFrom` b = pure . CubicBezierPrim $ CubicBezier a ac c d | bd `isDistingableFrom` c = 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,16 +1,26 @@ +{-# LANGUAGE BangPatterns #-} -- | Handle straight lines polygon. module Graphics.Rasterific.Line ( lineFromPath + , decomposeLine , clipLine , sanitizeLine , lineBreakAt , flattenLine , lineLength + , offsetLine ) where -import Control.Applicative( Applicative, (<$>), pure ) -import Data.Monoid( Monoid, (<>), mempty ) -import Linear( V2( .. ), (^-^), norm ) +import Control.Applicative( (<$>), (<*>), pure ) +import Data.Monoid( (<>), mempty ) +import Graphics.Rasterific.Linear + ( V1( .. ) + , V2( .. ) + , (^-^) + , (^+^) + , (^*) + , lerp + , norm ) import Graphics.Rasterific.Operators import Graphics.Rasterific.Types @@ -34,11 +44,18 @@ lineBreakAt :: Line -> Float -> (Line, Line) lineBreakAt (Line a b) t = (Line a ab, Line ab b) - where ab = lerpPoint a b t + 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 @@ -97,4 +114,36 @@ -- 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 -> 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 + where + !floorA = vfloor a + !floorB = vfloor b + !(V2 insideX insideY) = + floorA ^==^ floorB ^||^ vceil a ^==^ vceil b + + !(V2 px py) = fromIntegral <$> vmin floorA floorB + !(V1 w) = (px + 1 -) <$> (V1 bx `midPoint` V1 ax) + !h = by - ay + + go a b = go a m <> go m b + where + !ab = a `midPoint` b + + !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 + + !m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> ab diff --git a/src/Graphics/Rasterific/Linear.hs b/src/Graphics/Rasterific/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Linear.hs @@ -0,0 +1,227 @@ +-- | This module is a reduction of the `Linear` package +-- from Edward Kmett to match just the need of Rasterific. +-- +-- If the flag `embed_linear` is disabled, this module is +-- just a reexport from the real linear package. +-- +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Linear + ( V2( .. ) + , V1( .. ) + , Additive( .. ) + , Epsilon( .. ) + , Metric( .. ) + , (^*) + , (^/) + , normalize + ) where + +#ifdef EXTERNAL_LINEAR +-- We just reexport +import Linear +#else + +import Control.Applicative( Applicative, pure, (<*>) ) + +infixl 6 ^+^, ^-^ +infixl 7 ^*, ^/ + +-- | A 2-dimensional vector +-- +-- >>> pure 1 :: V2 Int +-- V2 1 1 +-- +-- >>> V2 1 2 + V2 3 4 +-- V2 4 6 +-- +-- >>> V2 1 2 * V2 3 4 +-- V2 3 8 +-- +-- >>> sum (V2 1 2) +-- 3 +data V2 a = V2 !a !a + deriving (Eq, Show) + +newtype V1 a = V1 a + deriving (Eq, Show) + +instance Functor V2 where + {-# INLINE fmap #-} + fmap f (V2 a b) = V2 (f a) (f b) + +instance Num a => Num (V2 a) where + (V2 a b) + (V2 a' b') = V2 (a + a') (b + b') + {-# INLINE (+) #-} + (V2 a b) - (V2 a' b') = V2 (a - a') (b - b') + {-# INLINE (-) #-} + (V2 a b) * (V2 a' b') = V2 (a * a') (b * b') + {-# INLINE (*) #-} + negate (V2 a b) = V2 (negate a) (negate b) + {-# INLINE negate #-} + abs (V2 a b) = V2 (abs a) (abs b) + {-# INLINE abs #-} + signum (V2 a b) = V2 (signum a) (signum b) + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Functor V1 where + {-# INLINE fmap #-} + fmap f (V1 a) = V1 $ f a + +instance Applicative V2 where + {-# INLINE pure #-} + pure a = V2 a a + {-# INLINE (<*>) #-} + (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b) + +instance Applicative V1 where + {-# INLINE pure #-} + pure = V1 + {-# INLINE (<*>) #-} + (V1 f) <*> (V1 v) = V1 $ f v + +-- | A vector is an additive group with additional structure. +class Functor f => Additive f where + -- | The zero vector + zero :: Num a => f a + -- | Compute the sum of two vectors + -- + -- >>> V2 1 2 ^+^ V2 3 4 + -- V2 4 6 + (^+^) :: Num a => f a -> f a -> f a + + -- | Compute the difference between two vectors + -- + -- >>> V2 4 5 - V2 3 1 + -- V2 1 4 + (^-^) :: Num a => f a -> f a -> f a + + -- | Linearly interpolate between two vectors. + lerp :: Num a => a -> f a -> f a -> f a + +-- | Provides a fairly subjective test to see if a quantity is near zero. +-- +-- >>> nearZero (1e-11 :: Double) +-- False +-- +-- >>> nearZero (1e-17 :: Double) +-- True +-- +-- >>> nearZero (1e-5 :: Float) +-- False +-- +-- >>> nearZero (1e-7 :: Float) +-- True +class Num a => Epsilon a where + -- | Determine if a quantity is near zero. + nearZero :: a -> Bool + +-- | @'abs' a '<=' 1e-6@ +instance Epsilon Float where + nearZero a = abs a <= 1e-6 + {-# INLINE nearZero #-} + +-- | @'abs' a '<=' 1e-12@ +instance Epsilon Double where + nearZero a = abs a <= 1e-12 + {-# INLINE nearZero #-} + +instance Epsilon a => Epsilon (V2 a) where + nearZero = nearZero . quadrance + {-# INLINE nearZero #-} + +instance Additive V2 where + zero = V2 0 0 + {-# INLINE zero #-} + + (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b') + {-# INLINE (^+^) #-} + + (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b') + {-# INLINE (^-^) #-} + + lerp v a b = a ^+^ (b ^-^ a) ^* v + {-# INLINE lerp #-} + +instance Additive V1 where + zero = V1 0 + {-# INLINE zero #-} + + (V1 a) ^+^ (V1 a') = V1 (a + a') + {-# INLINE (^+^) #-} + + (V1 a) ^-^ (V1 a') = V1 (a - a') + {-# INLINE (^-^) #-} + + lerp v a b = a ^+^ (b ^-^ a) ^* v + {-# INLINE lerp #-} + +-- | Free and sparse inner product/metric spaces. +class Additive f => Metric f where + -- | Compute the inner product of two vectors or (equivalently) + -- convert a vector @f a@ into a covector @f a -> a@. + -- + -- >>> V2 1 2 `dot` V2 3 4 + -- 11 + dot :: Num a => f a -> f a -> a + + -- | Compute the squared norm. The name quadrance arises from + -- Norman J. Wildberger's rational trigonometry. + quadrance :: Num a => f a -> a + {-# INLINE quadrance #-} + quadrance v = dot v v + + -- | Compute the quadrance of the difference + qd :: Num a => f a -> f a -> a + {-# INLINE qd #-} + qd f g = quadrance (f ^-^ g) + + -- | Compute the distance between two vectors in a metric space + distance :: Floating a => f a -> f a -> a + {-# INLINE distance #-} + distance f g = norm (f ^-^ g) + + -- | Compute the norm of a vector in a metric space + norm :: Floating a => f a -> a + {-# INLINE norm #-} + norm v = sqrt (quadrance v) + + -- | Convert a non-zero vector to unit vector. + signorm :: Floating a => f a -> f a + signorm v = fmap (/ m) v where + m = norm v + +instance Metric V2 where + dot (V2 a b) (V2 a' b') = a * a' + b * b' + {-# INLINE dot #-} + + quadrance (V2 a b) = a * a + b * b + {-# INLINE quadrance #-} + + norm v = sqrt (quadrance v) + {-# INLINE norm #-} + +-- | Compute the right scalar product +-- +-- >>> V2 3 4 ^* 2 +-- V2 6 8 +(^*) :: (Functor f, Num a) => f a -> a -> f a +{-# INLINE (^*) #-} +(^*) f n = fmap (* n) f + +-- | Compute division by a scalar on the right. +(^/) :: (Functor f, Floating a) => f a -> a -> f a +{-# INLINE (^/) #-} +(^/) f n = fmap (/ n) f + +-- | Normalize a 'Metric' functor to have unit 'norm'. This function +-- does not change the functor if its 'norm' is 0 or 1. +normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a +{-# INLINE normalize #-} +normalize v = if nearZero l || nearZero (1-l) then v + else fmap (/ sqrt l) v + where l = quadrance v + +#endif + 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 @@ -18,7 +18,6 @@ , vceil , clampPoint , midPoint - , lerpPoint , vpartition , normal , ifZero @@ -32,12 +31,11 @@ , (<$>) ) -import Linear( V2( .. ) +import Graphics.Rasterific.Linear + ( V2( .. ) , Additive( .. ) - {-, Metric( .. )-} , Epsilon( nearZero ) , (^+^) - {-, (^/)-} , (^*) , dot , normalize @@ -122,10 +120,6 @@ midPoint :: (Additive a) => a Float -> a Float -> a Float {-# INLINE midPoint #-} midPoint a b = (a ^+^ b) ^* 0.5 - -lerpPoint :: (Additive a) => a Float -> a Float -> Float -> a Float -{-# INLINE lerpPoint #-} -lerpPoint a b v = a ^+^ (b ^-^ a) ^* v -- | Given a boolean choice vector, return elements of -- the first one if true, of the second one otherwise. diff --git a/src/Graphics/Rasterific/Outline.hs b/src/Graphics/Rasterific/Outline.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Outline.hs @@ -0,0 +1,28 @@ +-- | This module provide helper functions to create outline +-- of shapes. +module Graphics.Rasterific.Outline + ( strokize + , S.dashedStrokize + ) where + +import Graphics.Rasterific.Types +import qualified Graphics.Rasterific.StrokeInternal as S + +-- | This function will create the outline of a given geometry +-- given a path. You can then stroke it. +-- +-- > stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ +-- > strokize 40 JoinRound (CapRound, CapRound) +-- > [CubicBezierPrim $ +-- > CubicBezier (V2 40 160) (V2 40 40) +-- > (V2 160 40) (V2 160 160)] +-- +-- <> +-- +strokize :: StrokeWidth -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ List of elements to strokize + -> [Primitive] +strokize w j c = listOfContainer . S.strokize w j c + diff --git a/src/Graphics/Rasterific/PlaneBoundable.hs b/src/Graphics/Rasterific/PlaneBoundable.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/PlaneBoundable.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Module implementing types used for geometry +-- bound calculations. +module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. ) + , PlaneBoundable( .. ) ) where + +import Control.Applicative( (<$>), (<*>) ) +import Data.Monoid( Monoid( .. ), (<>) ) +import Data.Foldable( foldMap ) + +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) + +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/QuadraticBezier.hs b/src/Graphics/Rasterific/QuadraticBezier.hs --- a/src/Graphics/Rasterific/QuadraticBezier.hs +++ b/src/Graphics/Rasterific/QuadraticBezier.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} -- | Module handling math regarding the handling of quadratic -- and cubic bezier curve. module Graphics.Rasterific.QuadraticBezier @@ -15,17 +16,16 @@ , bezierLengthApproximation ) where -import Control.Applicative( (<$>) - , (<*>) - , Applicative - , pure ) -import Linear( V2( .. ) +import Control.Applicative( (<$>), (<*>), pure ) +import Graphics.Rasterific.Linear + ( V2( .. ) , V1( .. ) , (^-^) , (^+^) , (^*) , dot , norm + , lerp ) import Data.Monoid( Monoid( mempty ), (<>) ) import Graphics.Rasterific.Operators @@ -48,38 +48,38 @@ bezierLengthApproximation (Bezier a _ c) = norm $ c ^-^ a -decomposeBeziers :: Bezier -> [EdgeSample] -decomposeBeziers (Bezier a@(V2 ax ay) b c@(V2 cx cy)) - | insideX && insideY = [EdgeSample (px + 0.5) (py + 0.5) (w * h) h] - | otherwise = recurse (Bezier a ab m) <> - recurse (Bezier m bc c) - where floorA = vfloor a - floorC = vfloor c - V2 px py = fromIntegral <$> vmin floorA floorC - V1 w = (px + 1 -) <$> (V1 cx `midPoint` V1 ax) - h = cy - ay - - recurse = decomposeBeziers - - V2 insideX insideY = +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 + where + !floorA = vfloor a + !floorC = vfloor c + !(V2 insideX insideY) = floorA ^==^ floorC ^||^ vceil a ^==^ vceil c - ab = a `midPoint` b - bc = b `midPoint` c - abbc = ab `midPoint` bc + !(V2 px py) = fromIntegral <$> vmin floorA floorC + !(V1 w) = (px + 1 -) <$> (V1 cx `midPoint` V1 ax) + !h = cy - ay - mini = fromIntegral <$> vfloor abbc - maxi = fromIntegral <$> vceil abbc - nearmin = vabs (abbc ^-^ mini) ^< 0.1 - nearmax = vabs (abbc ^-^ maxi) ^< 0.1 + go a b c = go a ab m <> go m bc c + where + !ab = a `midPoint` b + !bc = b `midPoint` c + !abbc = ab `midPoint` bc - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p + !mini = fromIntegral <$> vfloor abbc + !maxi = fromIntegral <$> vceil abbc + !nearmin = vabs (abbc ^-^ mini) ^< 0.1 + !nearmax = vabs (abbc ^-^ maxi) ^< 0.1 - m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc + minMaxing mi nearmi ma nearma p + | nearmi = mi + | nearma = ma + | otherwise = p + !m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc + -- | Create a quadratic bezier curve representing -- a straight line. straightLine :: Point -> Point -> Bezier @@ -193,9 +193,9 @@ -- / abbc \ -- / \ -- A X X C - ab = lerpPoint a b t - bc = lerpPoint b c t - abbc = lerpPoint ab bc t + ab = lerp t a b + bc = lerp t b c + abbc = lerp t ab bc flattenBezier :: Bezier -> Container Primitive flattenBezier bezier@(Bezier a b c) diff --git a/src/Graphics/Rasterific/QuadraticFormula.hs b/src/Graphics/Rasterific/QuadraticFormula.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/QuadraticFormula.hs @@ -0,0 +1,53 @@ +module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. ) + , discriminant + , formulaRoots + ) where + +import Control.Applicative( Applicative( .. ) ) + +-- | Represent an equation `a * x^2 + b * x + c = 0` +data QuadraticFormula a = QuadraticFormula + { _coeffA :: !a -- ^ Coefficient for the square part (x^2) + , _coeffB :: !a -- ^ Coefficient the linear part (x) + , _coeffC :: !a -- ^ Constant + } + +instance Functor QuadraticFormula where + {-# INLINE fmap #-} + fmap f (QuadraticFormula a b c) = + QuadraticFormula (f a) (f b) (f c) + + + +instance Applicative QuadraticFormula where + pure a = QuadraticFormula a a a + {-# INLINE pure #-} + + QuadraticFormula a b c <*> QuadraticFormula d e f = + QuadraticFormula (a d) (b e) (c f) + {-# INLINE (<*>) #-} + +-- | Discriminant equation, if the result is: +-- +-- * Below 0, then the formula doesn't have any solution +-- +-- * Equal to 0, then the formula has an unique root. +-- +-- * Above 0, the formula has two solutions +-- +discriminant :: Num a => QuadraticFormula a -> a +discriminant (QuadraticFormula a b c) = b * b - 4 * a *c + +-- | Extract all the roots of the formula ie. where the +-- unknown gives a result of 0 +formulaRoots :: (Ord a, Floating a) => QuadraticFormula a -> [a] +formulaRoots formula@(QuadraticFormula a b _) + | disc < 0 = [] + | disc == 0 = [positiveResult] + | otherwise = [positiveResult, negativeResult] + where + disc = discriminant formula + squarePart = sqrt disc + positiveResult = (negate b + squarePart) / (2 * a) + negativeResult = (negate b - squarePart) / (2 * a) + diff --git a/src/Graphics/Rasterific/Rasterize.hs b/src/Graphics/Rasterific/Rasterize.hs --- a/src/Graphics/Rasterific/Rasterize.hs +++ b/src/Graphics/Rasterific/Rasterize.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE BangPatterns #-} module Graphics.Rasterific.Rasterize ( CoverageSpan( .. ) , rasterize ) where +import Control.Monad.ST( runST ) import Data.Fixed( mod' ) -import Data.List( mapAccumL, sortBy ) +import Data.Foldable( foldMap ) import Graphics.Rasterific.Types import Graphics.Rasterific.QuadraticBezier import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Line +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Intro as VS data CoverageSpan = CoverageSpan { _coverageX :: {-# UNPACK #-} !Float @@ -17,31 +22,45 @@ } deriving Show -combineEdgeSamples :: (Float -> Float) -> [EdgeSample] -> [CoverageSpan] +combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample + -> [CoverageSpan] {-# INLINE combineEdgeSamples #-} -combineEdgeSamples prepareCoverage = append . mapAccumL go (0, 0, 0, 0) - where append ((x, y, a, _), lst) = - concat lst ++ [CoverageSpan x y (prepareCoverage a) 1] - - go (x, y, a, h) (EdgeSample x' y' a' h') - | y == y' && x == x' = ((x', y', a + a', h + h'), []) - | y == y' = ((x', y', h + a', h + h'), [p1, p2]) - | otherwise = - ((x', y', a', h'), [CoverageSpan x y (prepareCoverage a) 1]) - where p1 = CoverageSpan x y (prepareCoverage a) 1 - p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) +combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0 + where + !maxi = V.length vec + go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1] + go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where + sub (EdgeSample x' y' a' h') + | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h') + | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h') + | otherwise = + CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h' + where p1 = CoverageSpan x y (prepareCoverage a) 1 + p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) -decompose :: Primitive -> [EdgeSample] -decompose (LinePrim (Line x1 x2)) = decomposeBeziers $ straightLine x1 x2 +decompose :: Primitive -> Container EdgeSample +decompose (LinePrim l) = decomposeLine l decompose (BezierPrim b) = decomposeBeziers b decompose (CubicBezierPrim c) = decomposeCubicBeziers c -rasterize :: FillMethod -> [Primitive] -> [CoverageSpan] +sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample +sortEdgeSamples samples = runST $ do + mutableVector <- V.unsafeThaw $ V.fromList samples + let xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b) + VS.sortBy xy mutableVector + V.unsafeFreeze mutableVector + +rasterize :: FillMethod -> Container Primitive -> [CoverageSpan] rasterize method = case method of - FillWinding -> combineEdgeSamples combineWinding . sortBy xy . concatMap decompose - FillEvenOdd -> combineEdgeSamples combineEvenOdd . sortBy xy . concatMap decompose - where xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b) - combineWinding = min 1 . abs + FillWinding -> combineEdgeSamples combineWinding + . sortEdgeSamples + . listOfContainer + . foldMap decompose + FillEvenOdd -> combineEdgeSamples combineEvenOdd + . sortEdgeSamples + . listOfContainer + . foldMap decompose + where combineWinding = min 1 . abs combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1 diff --git a/src/Graphics/Rasterific/Shading.hs b/src/Graphics/Rasterific/Shading.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Shading.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +module Graphics.Rasterific.Shading + ( Texture( .. ) + , Gradient + , ShaderFunction + , transformTextureToFiller + , dumpTexture + ) where + +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 + ) +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 s px = + MutableImage s px -> CoverageSpan -> ST s () + +type Filler s = + TextureSpaceInfo -> ST s () + +solidColor :: forall s px . ModulablePixel px + => px -> MutableImage s px -> Filler s +{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8 + -> Filler s #-} +{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8 + -> Filler 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 = + 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 + !opacity = pixelOpacity color + !(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 + $ compositionAlpha cov icov oldPixel color + go (count + 1) $ idx + compCount + +shaderFiller :: forall s px . ModulablePixel px + => ShaderFunction px -> MutableImage s px + -> Filler s +{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8 + -> MutableImage s PixelRGBA8 + -> Filler s #-} +{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8 + -> MutableImage s Pixel8 + -> Filler 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 + + 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 + $ 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 +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 s px +{-# SPECIALIZE transformTextureToFiller + :: Texture PixelRGBA8 -> CoverageFiller s PixelRGBA8 #-} +transformTextureToFiller texture = go Nothing SamplerPad texture + 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 #-} +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 #-} +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 +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 +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 +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 +modulateTexture fullTexture modulator = \x y -> + colorMap (modulate $ modulator x y) $ fullTexture x y + diff --git a/src/Graphics/Rasterific/Stroke.hs b/src/Graphics/Rasterific/Stroke.hs deleted file mode 100644 --- a/src/Graphics/Rasterific/Stroke.hs +++ /dev/null @@ -1,258 +0,0 @@ -module Graphics.Rasterific.Stroke - ( flatten - , dashize - , strokize - , dashedStrokize - ) where - -import Control.Applicative( Applicative, (<$>), pure ) -import Data.Monoid( Monoid, (<>), mempty ) -import Data.Foldable( Foldable, foldMap ) -import Linear( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , dot - ) - -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.Line - -lastPoint :: Primitive -> Point -lastPoint (LinePrim (Line _ x1)) = x1 -lastPoint (BezierPrim (Bezier _ _ x2)) = x2 -lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3 - -lastPointAndNormal :: Primitive -> (Point, Vector) -lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b) -lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c) -lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d) - -firstPointAndNormal :: Primitive -> (Point, Vector) -firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b) -firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b) -firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) - -reversePrimitive :: Primitive -> Primitive -reversePrimitive (LinePrim (Line a b)) = (LinePrim (Line b a)) -reversePrimitive (BezierPrim (Bezier a b c)) = - (BezierPrim (Bezier c b a)) -reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) = - (CubicBezierPrim (CubicBezier d c b a)) - --- | Create a "rounded" join or cap -roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive -roundJoin offset p = go - where go u v - -- If we're already on a nice curvature, - -- don't bother doing anything - | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c - | otherwise = go w v <> go u w - where -- ^ - -- |w - -- a X---X c - -- \ / - -- Xp - -- ^ / \ ^ - -- u\/ \/v - -- / \ - a = p ^+^ u ^* offset - c = p ^+^ v ^* offset - - w = (a `normal` c) `ifZero` u - - -- Same as offseting - n = p ^+^ w ^* offset - b = n ^* 2 ^-^ (a `midPoint` c) - --- | Put a cap at the end of a bezier curve, depending --- on the kind of cap wanted. -cap :: Float -> Cap -> Primitive -> Container Primitive -cap offset CapRound prim = roundJoin offset p u (- u) - where (p, u) = lastPointAndNormal prim - -cap offset (CapStraight cVal) prim = - pure (d `lineFromTo` e) <> pure (e `lineFromTo` f) - <> pure (f `lineFromTo` g) - where -- The usual "normal" - (p, u@(V2 ux uy)) = lastPointAndNormal prim - -- Vector pointing in the direction of the curve - -- of norm 1 - v = V2 uy $ negate ux - - -- Finishing points around the edge - -- -u*offset u*offset - -- <-><-> - -- d/ / /g - -- / / / - -- / / / - -- / - -- / curve - -- - d = p ^+^ u ^* offset - g = p ^-^ u ^* offset - - -- Create the "far" points - -- - -- e f - -- / / ^ - -- / / / v * offset * cVal - -- d/ / /g - -- / / / - -- / / / - -- / - -- / curve - -- - e = d ^+^ v ^* (offset * cVal) - f = g ^+^ v ^* (offset * cVal) - -lineFromTo :: Point -> Point -> Primitive -lineFromTo a b = LinePrim (Line a b) - -miterJoin :: Float -> Float -> Point -> Vector -> Vector - -> Container Primitive -miterJoin offset l point u v - | uDotW > l / max 1 l && uDotW > 0 = - pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) - -- A simple straight junction - | otherwise = pure $ a `lineFromTo` c - where -- X m - -- /\ - -- /|w\ - -- a X---X c - -- \ / - -- Xp - -- ^ / \ ^ - -- u\/ \/v - -- / \ - a = point ^+^ u ^* offset - c = point ^+^ v ^* offset - w = (a `normal` c) `ifZero` u - - uDotW = u `dot` w - - -- Calculate the maximum distance on the - -- u axis - p = offset / uDotW - -- middle point for "straight joining" - m = point + w ^* p - -joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive - -> Container Primitive -joinPrimitives offset join prim1 prim2 = - case join of - JoinRound -> roundJoin offset p u v - JoinMiter l -> miterJoin offset l p u v - where (p, u) = lastPointAndNormal prim1 - (_, v) = firstPointAndNormal prim2 - -offsetPrimitives :: Float -> Primitive -> Container Primitive -offsetPrimitives offset (LinePrim (Line x1 x2)) = - offsetPrimitives offset . BezierPrim $ straightLine x1 x2 -offsetPrimitives offset (BezierPrim b) = offsetBezier offset b -offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c - -offsetAndJoin :: Float -> Join -> Cap -> [Primitive] - -> Container Primitive -offsetAndJoin _ _ _ [] = mempty -offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest - where joiner = joinPrimitives offset join - offseter = offsetPrimitives offset - (firstPoint, _) = firstPointAndNormal firstShape - - go prev [] - | firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev - | otherwise = cap offset caping prev <> offseter prev - go prev (x:xs) = - joiner prev x <> offseter prev <> go x xs - -approximateLength :: Primitive -> Float -approximateLength (LinePrim l) = lineLength l -approximateLength (BezierPrim b) = bezierLengthApproximation b -approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c - - -sanitize :: Primitive -> Container Primitive -sanitize (LinePrim l) = sanitizeLine l -sanitize (BezierPrim b) = sanitizeBezier b -sanitize (CubicBezierPrim c) = sanitizeCubicBezier c - -strokize :: StrokeWidth -> Join -> (Cap, Cap) -> [Primitive] - -> [Primitive] -strokize width join (capStart, capEnd) beziers = - offseter capEnd sanitized <> - offseter capStart (reverse $ reversePrimitive <$> sanitized) - where sanitized = foldMap sanitize beziers - offseter = offsetAndJoin (width / 2) join - -flattenPrimitive :: Primitive -> Container Primitive -flattenPrimitive (BezierPrim bezier) = flattenBezier bezier -flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier -flattenPrimitive (LinePrim line) = flattenLine line - -breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive) -breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b) - where (a, b) = bezierBreakAt bezier at -breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b) - where (a, b) = cubicBezierBreakAt bezier at -breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b) - where (a, b) = lineBreakAt line at - - -flatten :: Container Primitive -> Container Primitive -flatten = foldMap flattenPrimitive - -splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) -splitPrimitiveUntil at = go at - where - go _ [] = ([], []) - go left lst - | left <= 0 = ([], lst) - go left (x : xs) - | left > primLength = (x : inInterval, afterInterval) - | otherwise = ([beforeStop], afterStop : xs) - where - primLength = approximateLength x - (inInterval, afterInterval) = go (left - primLength) xs - - (beforeStop, afterStop) = - breakPrimitiveAt x $ left / primLength - -dropPattern :: Float -> DashPattern -> DashPattern -dropPattern = go - where - go _ [] = [] - go offset (x:xs) - | x < 0 = (x:xs) -- sanitizing - | offset < x = x - offset : xs - | otherwise {- offset >= x -} = go (offset - x) xs - -dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] -dashize offset pattern = - taker infinitePattern . concatMap flattenPrimitive . concatMap sanitize - where - realOffset | offset >= 0 = offset - | otherwise = offset + sum pattern - - infinitePattern = - dropPattern realOffset . cycle $ filter (> 0) pattern - - taker _ [] = [] - taker [] _ = [] -- Impossible by construction, pattern is infinite - taker (atValue:atRest) stream = toKeep : droper atRest next - where (toKeep, next) = splitPrimitiveUntil atValue stream - - droper _ [] = [] - droper [] _ = [] -- Impossible by construction, pattern is infinite - droper (atValue:atRest) stream = taker atRest next - where (_toKeep, next) = splitPrimitiveUntil atValue stream - -dashedStrokize :: Float -> DashPattern -> StrokeWidth - -> Join -> (Cap, Cap) -> [Primitive] - -> [[Primitive]] -dashedStrokize offset dashPattern width join capping beziers = - strokize width join capping <$> dashize offset dashPattern beziers - diff --git a/src/Graphics/Rasterific/StrokeInternal.hs b/src/Graphics/Rasterific/StrokeInternal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/StrokeInternal.hs @@ -0,0 +1,278 @@ +module Graphics.Rasterific.StrokeInternal + ( flatten + , dashize + , strokize + , dashedStrokize + ) where + +import Control.Applicative( (<$>), pure ) +import Data.Monoid( (<>), mempty ) +import Data.Foldable( foldMap ) +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.001 = + pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) + -- A simple straight junction + | otherwise = pure $ a `lineFromTo` c + where -- X m + -- /\ + -- /|w\ + -- a X---X c + -- \ / + -- Xp + -- ^ / \ ^ + -- u\/ \/v + -- / \ + a = point ^+^ u ^* offset + c = point ^+^ v ^* offset + w = (a `normal` c) `ifZero` u + + uDotW = u `dot` w + + -- Calculate the maximum distance on the + -- u axis + p = offset / uDotW + -- middle point for "straight joining" + m = point + w ^* p + +joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive + -> Container Primitive +joinPrimitives offset join prim1 prim2 = + case join of + JoinRound -> roundJoin offset p u v + JoinMiter l -> miterJoin offset l p u v + where (p, u) = lastPointAndNormal prim1 + (_, v) = firstPointAndNormal prim2 + +offsetPrimitives :: Float -> Primitive -> Container Primitive +offsetPrimitives offset (LinePrim l) = offsetLine offset l +offsetPrimitives offset (BezierPrim b) = offsetBezier offset b +offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c + +offsetAndJoin :: Float -> Join -> Cap -> [Primitive] + -> Container Primitive +offsetAndJoin _ _ _ [] = mempty +offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest + where joiner = joinPrimitives offset join + offseter = offsetPrimitives offset + (firstPoint, _) = firstPointAndNormal firstShape + + go prev [] + | firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev + | otherwise = offseter prev <> cap offset caping prev + go prev (x:xs) = + joiner prev x <> offseter prev <> go x xs + +approximateLength :: Primitive -> Float +approximateLength (LinePrim l) = lineLength l +approximateLength (BezierPrim b) = bezierLengthApproximation b +approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c + + +sanitize :: Primitive -> Container Primitive +sanitize (LinePrim l) = sanitizeLine l +sanitize (BezierPrim b) = sanitizeBezier b +sanitize (CubicBezierPrim c) = sanitizeCubicBezier c + +strokize :: StrokeWidth -> Join -> (Cap, Cap) -> [Primitive] + -> Container Primitive +strokize width join (capStart, capEnd) beziers = + offseter capEnd sanitized <> + offseter capStart (reverse $ reversePrimitive <$> sanitized) + where + sanitized = foldMap (listOfContainer . sanitize) $ beziers + offseter = offsetAndJoin (width / 2) join + +flattenPrimitive :: Primitive -> Container Primitive +flattenPrimitive (BezierPrim bezier) = flattenBezier bezier +flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier +flattenPrimitive (LinePrim line) = flattenLine line + +breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive) +breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b) + where (a, b) = bezierBreakAt bezier at +breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b) + where (a, b) = cubicBezierBreakAt bezier at +breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b) + where (a, b) = lineBreakAt line at + + +flatten :: Container Primitive -> Container Primitive +flatten = foldMap flattenPrimitive + +splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) +splitPrimitiveUntil at = go at + where + go _ [] = ([], []) + go left lst + | left <= 0 = ([], lst) + go left (x : xs) + | left > primLength = (x : inInterval, afterInterval) + | otherwise = ([beforeStop], afterStop : xs) + where + primLength = approximateLength x + (inInterval, afterInterval) = go (left - primLength) xs + + (beforeStop, afterStop) = + breakPrimitiveAt x $ left / primLength + +dropPattern :: Float -> DashPattern -> DashPattern +dropPattern = go + where + go _ [] = [] + go offset (x:xs) + | x < 0 = (x:xs) -- sanitizing + | offset < x = x - offset : xs + | otherwise {- offset >= x -} = go (offset - x) xs + +dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] +dashize offset pattern = + taker infinitePattern . listOfContainer + . foldMap flattenPrimitive + . foldMap sanitize + where + realOffset | offset >= 0 = offset + | otherwise = offset + sum pattern + + infinitePattern = + dropPattern realOffset . cycle $ filter (> 0) pattern + + taker _ [] = [] + taker [] _ = [] -- Impossible by construction, pattern is infinite + taker (atValue:atRest) stream = toKeep : droper atRest next + where (toKeep, next) = splitPrimitiveUntil atValue stream + + droper _ [] = [] + droper [] _ = [] -- Impossible by construction, pattern is infinite + droper (atValue:atRest) stream = taker atRest next + where (_toKeep, next) = splitPrimitiveUntil atValue stream + +-- | Create a list of outlines corresponding to all the +-- dashed elements. They can be then stroked +-- +-- > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ +-- > dashedStrokize 0 [10, 5] +-- > 40 JoinRound (CapStraight 0, CapStraight 0) +-- > [CubicBezierPrim $ +-- > CubicBezier (V2 40 160) (V2 40 40) +-- > (V2 160 40) (V2 160 160)] +-- +-- <> +-- +dashedStrokize :: Float -- ^ Starting offset + -> DashPattern -- ^ Dashing pattern to use for stroking + -> StrokeWidth -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ List of elements to transform + -> [[Primitive]] +dashedStrokize offset dashPattern width join capping beziers = + listOfContainer . strokize width join capping + <$> dashize offset dashPattern beziers + diff --git a/src/Graphics/Rasterific/Texture.hs b/src/Graphics/Rasterific/Texture.hs --- a/src/Graphics/Rasterific/Texture.hs +++ b/src/Graphics/Rasterific/Texture.hs @@ -14,7 +14,6 @@ , linearGradientTexture , radialGradientTexture , radialGradientWithFocusTexture - , imageTexture , sampledImageTexture -- * Texture manipulation @@ -22,31 +21,14 @@ , transformTexture ) where -import Data.Fixed( mod' ) -import Linear( V2( .. ) - , (^-^) - , (^/) - , dot - , norm - ) -import qualified Data.Vector as V - import Codec.Picture.Types( Pixel( .. ) , Image( .. ) - , Pixel8 - , PixelRGBA8 ) -import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ) ) +import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ), Line( .. ) ) +import Graphics.Rasterific.Shading import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Compositor( Modulable( clampCoverage, modulate, alphaOver ) ) --- | A texture is just a function which given pixel coordinate --- give back a pixel. --- The float coordinate type allow for transformations --- to happen in the pixel space. -type Texture px = SamplerRepeat -> Float -> Float -> px - -- | Set the repeat pattern of the texture (if any). -- With padding: -- @@ -72,7 +54,7 @@ -- <> -- withSampler :: SamplerRepeat -> Texture px -> Texture px -withSampler repeating texture _ = texture repeating +withSampler = WithSampler -- | Transform the coordinates used for texture before applying -- it, allow interesting transformations. @@ -86,62 +68,13 @@ -- <> -- transformTexture :: Transformation -> Texture px -> Texture px -transformTexture trans tx samp x y = tx samp x' y' - where - (V2 x' y') = applyTransformation trans (V2 x y) +transformTexture = WithTextureTransform -- | The uniform texture is the simplest texture of all: -- an uniform color. uniformTexture :: px -- ^ The color used for all the texture. -> Texture px -uniformTexture px _ _ _ = px - --- | A gradient definition is just a list of stop --- and pixel values. For instance for a simple gradient --- of black to white, the finition would be : --- --- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)] --- --- the first stop value must be zero and the last, one. --- -type Gradient px = [(Float, px)] -type GradientArray px = V.Vector (Float, px) - -repeatGradient :: Float -> Float -repeatGradient s = s - fromIntegral (floor s :: Int) - -reflectGradient :: Float -> Float -reflectGradient s = - abs (abs (s - 1) `mod'` 2 - 1) - -gradientColorAt :: (Pixel px, Modulable (PixelBaseComponent px)) - => GradientArray px -> Float -> px -{-# SPECIALIZE - gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -gradientColorAt grad at - | at <= 0 = snd $ V.head grad - | at >= 1.0 = snd $ V.last grad - | otherwise = go (0, snd $ V.head grad) 0 - where - maxi = V.length grad - go (prevCoeff, prevValue) ix - | ix >= maxi = snd $ V.last grad - | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px - | otherwise = go value $ ix + 1 - where value@(coeff, px) = grad `V.unsafeIndex` ix - zeroToOne = (at - prevCoeff) / (coeff - prevCoeff) - (cov, icov) = clampCoverage zeroToOne - -gradientColorAtRepeat :: (Pixel px, Modulable (PixelBaseComponent px)) - => SamplerRepeat -> GradientArray px -> Float -> px -{-# SPECIALIZE INLINE - gradientColorAtRepeat :: - SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -gradientColorAtRepeat SamplerPad grad = gradientColorAt grad -gradientColorAtRepeat SamplerRepeat grad = - gradientColorAt grad . repeatGradient -gradientColorAtRepeat SamplerReflect grad = - gradientColorAt grad . reflectGradient +uniformTexture = SolidTexture -- | Linear gradient texture. -- @@ -154,177 +87,61 @@ -- -- <> -- -linearGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description. +linearGradientTexture :: Gradient px -- ^ Gradient description. -> Point -- ^ Linear gradient start point. -> Point -- ^ Linear gradient end point. -> Texture px -{-# SPECIALIZE - linearGradientTexture - :: Gradient PixelRGBA8 -> Point -> Point - -> Texture PixelRGBA8 #-} -linearGradientTexture gradient start end repeating = - \x y -> colorAt $ ((V2 x y) `dot` d) - s00 - where - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - vector = end ^-^ start - d = vector ^/ (vector `dot` vector) - s00 = start `dot` d +linearGradientTexture gradient start end = + LinearGradientTexture gradient (Line start end) -- | Use another image as a texture for the filling. -- Contrary to `imageTexture`, this function perform a bilinear -- filtering on the texture. -- -sampledImageTexture :: forall px. - ( Pixel px, Modulable (PixelBaseComponent px)) - => Image px -> Texture px -{-# SPECIALIZE - sampledImageTexture :: Image Pixel8 -> Texture Pixel8 #-} -{-# SPECIALIZE - sampledImageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-} -sampledImageTexture img sampling x y = - (at px py `interpX` at pxn py) - `interpY` - (at px pyn `interpX` at pxn pyn) - where - coordSampler SamplerPad maxi v = - min (maxi - 1) . max 0 $ floor v - coordSampler SamplerReflect maxi v = - floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1) - where maxif = fromIntegral maxi - coordSampler SamplerRepeat maxi v = floor v `mod` maxi - - w = fromIntegral $ imageWidth img - h = fromIntegral $ imageHeight img - - clampedX = coordSampler sampling w - clampedY = coordSampler sampling h - - px = clampedX x - pxn = clampedX $ x + 1 - py = clampedY y - pyn = clampedY $ y + 1 - - dx, dy :: Float - dx = x - fromIntegral (floor x :: Int) - dy = y - fromIntegral (floor y :: Int) - - at :: Int -> Int -> px - at xx yy = - unsafePixelAt rawData $ (yy * w + xx) * compCount - - (covX, icovX) = clampCoverage dx - (covY, icovY) = clampCoverage dy - - interpX = mixWith (const $ alphaOver covX icovX) - interpY = mixWith (const $ alphaOver covY icovY) - - compCount = componentCount (undefined :: px) - rawData = imageData img - --- | Use another image as a texture for the filling. --- This texture use the "nearest" filtering, AKA no --- filtering at all. -imageTexture :: forall px. (Pixel px) => Image px -> Texture px -{-# SPECIALIZE - imageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-} -{-# SPECIALIZE - imageTexture :: Image Pixel8 -> Texture Pixel8 #-} -imageTexture img _ x y = - unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount - where - clampedX = min (w - 1) . max 0 $ floor x - clampedY = min (h - 1) . max 0 $ floor y - compCount = componentCount (undefined :: px) - w = imageWidth img - h = imageHeight img - rawData = imageData img +sampledImageTexture :: Image px -> Texture px +sampledImageTexture = SampledTexture -- | Radial gradient texture -- -- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) -- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) -- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in --- > withTexture (radialGradientTexture SamplerPad gradDef +-- > withTexture (radialGradientTexture gradDef -- > (V2 100 100) 75) $ -- > fill $ circle (V2 100 100) 100 -- -- <> -- -radialGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description +radialGradientTexture :: Gradient px -- ^ Gradient description -> Point -- ^ Radial gradient center -> Float -- ^ Radial gradient radius -> Texture px -radialGradientTexture gradient center radius repeating = - \x y -> colorAt $ norm ((V2 x y) ^-^ center) / radius - where - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - +radialGradientTexture = RadialGradientTexture -- | Radial gradient texture with a focus point. -- -- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) -- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) -- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in --- > withTexture (radialGradientWithFocusTexture SamplerPad gradDef +-- > withTexture (radialGradientWithFocusTexture gradDef -- > (V2 100 100) 75 (V2 70 70) ) $ -- > fill $ circle (V2 100 100) 100 -- -- <> -- radialGradientWithFocusTexture - :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description + :: Gradient px -- ^ Gradient description -> Point -- ^ Radial gradient center -> Float -- ^ Radial gradient radius -> Point -- ^ Radial gradient focus point -> Texture px -radialGradientWithFocusTexture gradient center radius focusScreen repeating = - \x y -> colorAt . go $ (V2 x y) ^-^ center - where - focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - radiusSquared = radius * radius - dist = sqrt $ focus `dot` focus - clampedFocus@(V2 focusX focusY) - | dist <= r = focus - | otherwise = V2 (r * cos a) (r * sin a) - where a = atan2 origFocusY origFocusX - r = radius * 0.99 - trivial = sqrt $ radiusSquared - origFocusX * origFocusX - - solutionOf (V2 x y) | x == focusX = - V2 focusX (if y > focusY then trivial else negate trivial) - solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint - where - slope = (y - focusY) / (x - focusX) - yint = y - (slope * x) - - a = slope * slope + 1 - b = 2 * slope * yint - c = yint * yint - radiusSquared - det = sqrt $ b * b - 4 * a * c - xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a) - - go pos = sqrt $ curToFocus / distSquared - where - solution = solutionOf pos ^-^ clampedFocus - toFocus = pos ^-^ clampedFocus - distSquared = solution `dot` solution - curToFocus = toFocus `dot` toFocus +radialGradientWithFocusTexture = RadialGradientWithFocusTexture -- | Perform a multiplication operation between a full color texture -- and a greyscale one, used for clip-path implementation. -modulateTexture :: (Pixel px, Modulable (PixelBaseComponent px)) +modulateTexture :: (Pixel px) => Texture px -- ^ The full blown texture. -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. -> Texture px -- ^ The resulting texture. -modulateTexture fullTexture modulator repeating = \x y -> - colorMap (modulate $ modulationTexture x y) $ full x y - where modulationTexture = modulator repeating - full = fullTexture repeating +modulateTexture = ModulateTexture diff --git a/src/Graphics/Rasterific/Transformations.hs b/src/Graphics/Rasterific/Transformations.hs --- a/src/Graphics/Rasterific/Transformations.hs +++ b/src/Graphics/Rasterific/Transformations.hs @@ -7,16 +7,19 @@ module Graphics.Rasterific.Transformations ( Transformation( .. ) , applyTransformation + , applyVectorTransformation , translate , scale , rotate , rotateCenter + , skewX + , skewY , inverseTransformation ) where import Data.Monoid( Monoid( .. ), (<>) ) import Graphics.Rasterific.Types -import Linear( V2( .. ) ) +import Graphics.Rasterific.Linear( V2( .. ) ) -- | Represent a 3*3 matrix for homogenous coordinates. -- @@ -60,7 +63,15 @@ b d f) (V2 x y) = V2 (a * x + y * c + e) (b * x + d * y + f) +-- | Effectively transform a vector given a transformation. +-- The translation part won't be applied. +applyVectorTransformation :: Transformation -> Vector -> Vector +applyVectorTransformation + (Transformation a c _e + b d _f) (V2 x y) = + V2 (a * x + y * c) (b * x + d * y) + -- | Create a transformation representing a rotation -- on the plane. -- @@ -115,11 +126,44 @@ Transformation 1 0 x 0 1 y +-- | Skew transformation along the +-- X axis. +-- +-- > fill . transform (applyTransformation $ skewX 0.3) +-- > $ rectangle (V2 50 50) 80 80 +-- +-- <> +-- +skewX :: Float -> Transformation +skewX v = + Transformation 1 t 0 + 0 1 0 + where t = tan v + +-- | Skew transformation along the Y axis. +-- +-- > fill . transform (applyTransformation $ skewY 0.3) +-- > $ rectangle (V2 50 50) 80 80 +-- +-- <> +-- +skewY :: Float -> Transformation +skewY v = + Transformation 1 0 0 + t 1 0 + where t = tan v + +transformationDeterminant :: Transformation -> Float +transformationDeterminant (Transformation a c _e + b d _f) = a * d - c * b + -- | Inverse a transformation (if possible) -inverseTransformation :: Transformation -> Transformation +inverseTransformation :: Transformation -> Maybe Transformation +inverseTransformation trans + | transformationDeterminant trans == 0 = Nothing inverseTransformation (Transformation a c e b d f) = - Transformation a' c' e' b' d' f' + Just $ Transformation a' c' e' b' d' f' where det = a * d - b * c a' = d / det c' = (- c) / det @@ -128,3 +172,4 @@ b' = (- b) / det d' = a / det f' = (e * b - a * f) / det + diff --git a/src/Graphics/Rasterific/Types.hs b/src/Graphics/Rasterific/Types.hs --- a/src/Graphics/Rasterific/Types.hs +++ b/src/Graphics/Rasterific/Types.hs @@ -13,6 +13,8 @@ , CubicBezier( .. ) , Primitive( .. ) , Container + , containerOfList + , listOfContainer , PathCommand( .. ) , Path( .. ) , Transformable( .. ) @@ -31,8 +33,9 @@ , pathToPrimitives ) where +import Data.DList( DList, fromList, toList ) import Data.Foldable( Foldable, foldl' ) -import Linear( V2( .. ) ) +import Graphics.Rasterific.Linear( V2( .. ) ) -- | Represent a vector type Vector = V2 Float @@ -168,7 +171,6 @@ -- the primitive. foldPoints :: (b -> Point -> b) -> b -> a -> b - instance Transformable Point where {-# INLINE transform #-} transform f p = f p @@ -316,7 +318,13 @@ => PointFoldable (f a) where foldPoints f = foldl' (foldPoints f) -type Container a = [a] +type Container a = DList a + +containerOfList :: [a] -> Container a +containerOfList = fromList + +listOfContainer :: Container a -> [a] +listOfContainer = toList -- | Describe a path in a way similar to many graphical -- packages, using a "pen" position in memory and reusing