diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,27 @@ +Rasterific +========== + +![Rasterific logo](https://raw.github.com/Twinside/Rasterific/master/img/logo.png) + +[![Build Status](https://travis-ci.org/Twinside/Rasterific.png?branch=master)](https://travis-ci.org/Twinside/Rasterific) +[![Hackage](https://img.shields.io/hackage/v/Rasterific.svg)](http://hackage.haskell.org/package/Rasterific) + +Rasterific is a Haskell rasterization engine (a vectorial renderer) +implemented on top of [JuicyPixels](https://github.com/Twinside/Juicy.Pixels). +Rasterific bases its text rendering on [FontyFruity](https://github.com/Twinside/FontyFruity). + +Main capability +--------------- + + * Draw vector graphics to an image. + * Export graphics to PDF (since 0.6). + +Design +------ +The renderer design is based on the +[Nile](https://github.com/damelang/nile) / +[Gezira](https://github.com/damelang/gezira) renderer from the STEP +project from the [VPRI](http://www.vpri.org/index.html) institute. The +interesting thing about this renderer is the conciseness of it's +implementation, providing antialiased rendering in the way. + diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -1,14 +1,16 @@ -- Initial Rasterific.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: Rasterific -version: 0.5.2.1 +version: 0.6 synopsis: A pure haskell drawing engine. -- A longer description of the package. description: <> . Rasterific is a vector drawing library (a rasterizer) - implemented in pure haskell + implemented in pure haskell. + . + Can render vector graphics to an image and export vector data to PDF. license: BSD3 license-file: LICENSE @@ -25,6 +27,7 @@ cabal-version: >= 1.10 extra-doc-files: docimages/*.png extra-source-files: changelog + , README.md , docimages/*.png , exec-src/docImageGenerator.hs @@ -37,7 +40,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Rasterific.git - Tag: v0.5.2.1 + Tag: v0.6 flag embed_linear description: Embed a reduced version of Linear avoiding a (huge) dep @@ -61,8 +64,11 @@ , Graphics.Rasterific.Operators , Graphics.Rasterific.Rasterize , Graphics.Rasterific.StrokeInternal + , Graphics.Rasterific.ComplexPrimitive , Graphics.Rasterific.Types , Graphics.Rasterific.Compositor + , Graphics.Rasterific.MicroPdf + , Graphics.Rasterific.MiniLens , Graphics.Rasterific.Shading , Graphics.Rasterific.PlaneBoundable , Graphics.Rasterific.QuadraticFormula @@ -80,6 +86,8 @@ , dlist >= 0.6 , primitive >= 0.5 , vector-algorithms >= 0.3 + , bytestring + , containers if !flag(embed_linear) build-depends: linear >= 1.3 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,28 +1,47 @@ --*-change-log-*- +Change log +========== +v0.6 May 2015 +------------- + + * Adding: repeating background pattern texture. + * Added: PDF output without images (for now) + v0.5.2.1 April 2015 +------------------- + * Fixed: non-composability of cached elements * Fixed: Border size when drawing images was twice too large. v0.5.2 April 2015 +----------------- + * Enhancement: Added a withGroupOpacity to render elements with a global opacity. v0.5.1 March 2015 +----------------- + * Enhancement: Generalizing geometry description, with automatic conversion, reducing the need of type constructor from Primitive, and directly filling Path. v0.5.0.3 February 2015 +---------------------- + * Fix: hackage documentation v0.5.0.2 February 2015 +---------------------- * Removing test-suite as it's dependent of some repository-local files v0.5.0.1 February 2015 +---------------------- * Fix: adding missing Arbitrary file in the distribution. v0.5 February 2015 +------------------ + * Breaking Change: Font size is now a newtype in FontyFruity, propagating the changes. * Allowing to specify DPI at the top level of the rendering @@ -31,13 +50,17 @@ * Changed: font size switched to float. v0.4.2 February 2015 +-------------------- * Fix: Cubic bezier clipping v0.4.1 January 2015 +------------------- * Fix: GHC 7.10 compilation * Adding: Various lens to access some primitive informations. v0.4 December 2014 +------------------ + * Breaking change: Changed the original position scheme for text, allowing to specify baseline or upper left corner @@ -62,6 +85,8 @@ easier complex text rendering v0.3 June 2014 +-------------- + * Enhancement: Switching main free monad type to the church encoded one. * Enhancement: Optimized the bezier decomposition, strictness annotations made wonders. May require forward differencing in the future. @@ -78,11 +103,15 @@ * Fixing: some numerical stability with the mitter join. v0.2.1 April 2014 +----------------- + * Fixing: transparency in gradients. * Fixing: alpha composition on top of translucent background. v0.2 April 2014 +--------------- + * Adding: an ellipse helper. * Adding: a polyline helper. * Adding: a polygon helper. @@ -102,5 +131,7 @@ * Enhancement: Some modest performance gain. v0.1 February 2014 +------------------ + * Initial version. 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/pattern_texture.png b/docimages/pattern_texture.png new file mode 100644 Binary files /dev/null and b/docimages/pattern_texture.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/exec-src/docImageGenerator.hs b/exec-src/docImageGenerator.hs --- a/exec-src/docImageGenerator.hs +++ b/exec-src/docImageGenerator.hs @@ -18,6 +18,7 @@ import Graphics.Rasterific.Immediate import System.Directory( createDirectoryIfMissing ) import System.FilePath( () ) +import qualified Data.ByteString.Lazy as LB import Graphics.Rasterific.Linear( (^+^) ) @@ -43,17 +44,40 @@ backgroundColor :: PixelRGBA8 backgroundColor = PixelRGBA8 255 255 255 255 +frontColor, accentColor, accent2Color :: PixelRGBA8 +frontColor = PixelRGBA8 0 0x86 0xc1 255 +accentColor = PixelRGBA8 0xff 0xf4 0xc1 255 +accent2Color = PixelRGBA8 0xFF 0x53 0x73 255 + frontTexture, accentTexture, accent2Texture :: Texture PixelRGBA8 -frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 -accentTexture = uniformTexture $ PixelRGBA8 0xff 0xf4 0xc1 255 -accent2Texture = uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255 +frontTexture = uniformTexture frontColor +accentTexture = uniformTexture accentColor +accent2Texture = uniformTexture accent2Color -produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO () -produceDocImage filename drawing = writePng filename img +produceDocImageAtSize :: Int -> Int -> FilePath -> Drawing PixelRGBA8 () -> IO () +produceDocImageAtSize width height filename drawing = do + putStrLn $ "Producing " <> filename + writePng filename img + writePdf $ filename <> ".draw.pdf" + writeOrderPdf $ filename <> ".order.pdf" where - img = renderDrawing 200 200 backgroundColor + img = renderDrawing width height backgroundColor $ withTexture frontTexture drawing + writeOrderPdf fname = + LB.writeFile fname . + renderOrdersAtDpiToPdf width height 92 $ + drawOrdersOfDrawing width height 92 (PixelRGBA8 0 0 0 0) $ + withTexture frontTexture drawing + + writePdf fname = + LB.writeFile fname . + renderDrawingAtDpiToPDF width height 92 $ + withTexture frontTexture drawing + +produceDocImage :: FilePath -> Drawing PixelRGBA8 () -> IO () +produceDocImage = produceDocImageAtSize 200 200 + capTester :: (FilePath, Cap) -> IO () capTester (filename, cap) = produceDocImage filename $ do @@ -90,10 +114,9 @@ moduleExample :: IO () moduleExample = do - let white = PixelRGBA8 255 255 255 255 - drawColor = PixelRGBA8 0 0x86 0xc1 255 + let drawColor = PixelRGBA8 0 0x86 0xc1 255 recColor = PixelRGBA8 0xFF 0x53 0x73 255 - img = renderDrawing 400 200 white $ + img = withTexture (uniformTexture drawColor) $ do fill $ circle (V2 0 0) 30 stroke 4 JoinRound (CapRound, CapRound) $ @@ -101,7 +124,7 @@ withTexture (uniformTexture recColor) . fill $ rectangle (V2 100 100) 200 100 - writePng (outFolder "module_example.png") img + produceDocImageAtSize 400 200 (outFolder "module_example.png") img sansSerifFont :: FilePath sansSerifFont = "test_fonts/DejaVuSans.ttf" @@ -150,10 +173,9 @@ case fontErr of Left err -> putStrLn err Right font -> - writePng (outFolder "text_example.png") . - renderDrawing 300 70 (PixelRGBA8 255 255 255 255) - . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ - printTextAt font (PointSize 12) (V2 20 40) "A simple text test!" + produceDocImageAtSize 300 70 (outFolder "text_example.png") + . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ + printTextAt font (PointSize 12) (V2 20 40) "A simple text test!" textMultipleExample :: IO () textMultipleExample = do @@ -162,18 +184,15 @@ case (,) <$> eitherFont1 <*> eitherFont2 of Left err -> putStrLn err Right (font1, font2) -> - writePng (outFolder "text_complex_example.png") . - renderDrawing 300 70 (PixelRGBA8 255 255 255 255) $ - let blackTexture = - Just . uniformTexture $ PixelRGBA8 0 0 0 255 - redTexture = - Just . uniformTexture $ PixelRGBA8 255 0 0 255 - in - printTextRanges (V2 20 40) - [ TextRange font1 (PointSize 12) "A complex " blackTexture - , TextRange font2 (PointSize 8) "text test" redTexture] - - + produceDocImageAtSize 300 70 (outFolder "text_complex_example.png") $ + let blackTexture = + Just . uniformTexture $ PixelRGBA8 0 0 0 255 + redTexture = + Just . uniformTexture $ PixelRGBA8 255 0 0 255 + in + printTextRanges (V2 20 40) + [ TextRange font1 (PointSize 12) "A complex " blackTexture + , TextRange font2 (PointSize 8) "text test" redTexture] coordinateSystem :: IO () coordinateSystem = do @@ -181,11 +200,8 @@ case fontErr of Left err -> putStrLn err Right font -> - writePng (outFolder "coordinate.png") - . renderDrawing 200 200 white - $ create font + produceDocImage (outFolder "coordinate.png") $ create font where - white = PixelRGBA8 255 255 255 255 black = PixelRGBA8 0 0 0 255 stroker = stroke 4 JoinRound (CapStraight 0, CapStraight 0) create font = withTexture (uniformTexture black) $ do @@ -247,7 +263,7 @@ main = do let addFolder (p, v) = (outFolder p, v) createDirectoryIfMissing True outFolder - moduleExample + moduleExample mapM_ (capTester . addFolder) [ ("cap_straight.png", CapStraight 0) , ("cap_straight_1.png", CapStraight 1) @@ -316,6 +332,8 @@ | y <- [5 :: Int, 17 .. 200] , let yf = fromIntegral y ] + {-produceDocImage (outFolder "clip_compose.png") $-} + produceDocImage (outFolder "stroke_line.png") $ stroke 17 JoinRound (CapRound, CapRound) $ line (V2 10 10) (V2 180 170) @@ -467,6 +485,15 @@ withTexture frontTexture . fill $ circle (V2 70 100) 60 withTexture accentTexture . fill $ circle (V2 120 100) 60 + produceDocImage (outFolder "pattern_texture.png") $ + let pattern = + patternTexture 40 40 96 accent2Color . + withTexture frontTexture $ + fill $ circle (V2 20 20) 13 + in + withTexture pattern $ + fill $ roundedRectangle (V2 20 20) 160 160 20 20 + produceDocImage (outFolder "item_opacity.png") $ do withTexture accent2Texture $ stroke 3 JoinRound (CapRound, CapRound) $ @@ -478,7 +505,7 @@ fill $ circle (V2 120 100) 60 textExample - textMultipleExample + textMultipleExample coordinateSystem textOnPathExample geometryOnPath diff --git a/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs --- a/src/Graphics/Rasterific.hs +++ b/src/Graphics/Rasterific.hs @@ -66,6 +66,8 @@ , RenderablePixel , renderDrawing , renderDrawingAtDpi + , renderDrawingAtDpiToPDF + , renderOrdersAtDpiToPdf , pathToPrimitives -- * Rasterization types @@ -151,15 +153,16 @@ import Data.Maybe( fromMaybe ) import Codec.Picture.Types( Image( .. ) , Pixel( .. ) - , unpackPixel + , PixelRGBA8 , pixelMapXY ) -import qualified Data.Vector.Unboxed as VU +import qualified Data.ByteString.Lazy as LB import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^), (^*) ) +import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^-^) ) import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Shading +import Graphics.Rasterific.MicroPdf +{-import Graphics.Rasterific.Texture-} +import Graphics.Rasterific.ComplexPrimitive import Graphics.Rasterific.Types import Graphics.Rasterific.Line import Graphics.Rasterific.QuadraticBezier @@ -175,7 +178,7 @@ import Graphics.Text.TrueType( Font , Dpi , PointSize( .. ) - , getStringCurveAtPoint ) + ) {-import Debug.Trace-} {-import Text.Printf-} @@ -408,6 +411,30 @@ -> Image px renderDrawing width height = renderDrawingAtDpi width height 96 +renderOrdersAtDpiToPdf + :: Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> [DrawOrder PixelRGBA8] -- ^ Drawing Orders + -> LB.ByteString +renderOrdersAtDpiToPdf w h dpi = + renderOrdersToPdf renderer w h dpi + where + renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px] + renderer = drawOrdersOfDrawing w h dpi emptyPx + +renderDrawingAtDpiToPDF + :: Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> Dpi -- ^ Current DPI used for text rendering. + -> Drawing PixelRGBA8 () -- ^ Rendering action + -> LB.ByteString +renderDrawingAtDpiToPDF w h dpi = + renderDrawingToPdf renderer w h dpi + where + renderer :: forall px . RenderablePixel px => Drawing px () -> [DrawOrder px] + renderer = drawOrdersOfDrawing w h dpi emptyPx + -- | Function to call in order to start the image creation. -- Tested pixels type are PixelRGBA8 and Pixel8, pixel types -- in other colorspace will probably produce weird results. @@ -424,10 +451,6 @@ $ mapM_ fillOrder $ drawOrdersOfDrawing width height dpi background drawing -emptyPx :: (RenderablePixel px) => px --- | Really need a "builder" function for pixel -emptyPx = colorMap (const emptyValue) $ unpackPixel 0 - cacheOrders :: forall px. (RenderablePixel px) => Maybe (Image px -> ImageTransformer px) -> [DrawOrder px] -> Drawing px () cacheOrders imageFilter orders = case imageFilter of @@ -443,7 +466,7 @@ shiftOrder order@DrawOrder { _orderPrimitives = prims } = order { _orderPrimitives = fmap (transform (^-^ cornerUpperLeft)) <$> prims , _orderTexture = - transformTexture (translate cornerUpperLeft) $ _orderTexture order + WithTextureTransform (translate cornerUpperLeft) $ _orderTexture order } resultImage = @@ -485,18 +508,23 @@ clipRender = renderDrawing width height clipBackground - . withTexture (uniformTexture clipForeground) + . withTexture (SolidTexture clipForeground) textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } = - transformTexture t $ currentTexture ctxt + WithTextureTransform t $ currentTexture ctxt textureOf ctxt = currentTexture ctxt + geometryOf :: Transformable a => RenderContext px -> a -> a geometryOf RenderContext { currentTransformation = Just (trans, _) } = transform (applyTransformation trans) geometryOf _ = id + geometryOfO RenderContext { currentTransformation = Just (trans, _) } = + transformOrder (applyTransformation trans) + geometryOfO _ = id + stupidDefaultTexture = - uniformTexture $ colorMap (const clipBackground) background + SolidTexture $ colorMap (const clipBackground) background go :: RenderContext px -> Free (DrawCommand px) () -> [DrawOrder px] -> [DrawOrder px] @@ -521,11 +549,9 @@ final = orders <> go ctxt next rest images = go ctxt (fromF sub) [] - drawer trans _ order = modify $ \lst -> finalOrder : lst - where - toFinalPos = transform $ applyTransformation trans - finalOrder = - order { _orderPrimitives = toFinalPos $ _orderPrimitives order } + drawer trans _ order = + modify (transformOrder (applyTransformation trans) order :) + orders = reverse $ execState (drawOrdersOnPath drawer 0 base path images) [] go ctxt (Free (WithTransform trans sub next)) rest = final where @@ -562,29 +588,9 @@ recurse sub = go ctxt (liftF $ Fill FillWinding sub ()) - go ctxt (Free (TextFill (V2 x y) descriptions next)) rest = - go ctxt (sequence_ drawCalls) $ go ctxt next rest - where - floatCurves = - getStringCurveAtPoint dpi (x, y) - [(_textFont d, _textSize d, _text d) | d <- descriptions] - - linearDescriptions = - concat [map (const d) $ _text d | d <- descriptions] - - drawCalls = - [texturize d $ beziersOfChar curve - | (curve, d) <- zip floatCurves linearDescriptions] - - texturize descr sub = case _textTexture descr of - Nothing -> fromF sub - Just t -> liftF $ SetTexture t sub () - - beziersOfChar curves = liftF $ Fill FillWinding bezierCurves () - where - bezierCurves = concat - [map BezierPrim . bezierFromPath . map (uncurry V2) - $ VU.toList c | c <- curves] + go ctxt (Free (TextFill p descriptions next)) rest = calls <> go ctxt next rest where + calls = + geometryOfO ctxt <$> textToDrawOrders dpi (currentTexture ctxt) p descriptions go ctxt (Free (WithCliping clipPath path next)) rest = go (ctxt { currentClip = newModuler }) (fromF path) $ @@ -597,7 +603,7 @@ subModuler Nothing = modulationTexture subModuler (Just v) = - modulateTexture v modulationTexture + ModulateTexture v modulationTexture -- | With stroke geometry with a given stroke width, using -- a dash pattern. @@ -640,32 +646,6 @@ dashedStrokeWithOffset offset dashing width join caping prims = liftF $ DashedStroke offset dashing width join caping (toPrimitives prims) () --- | Generate a list of primitive representing a circle. --- --- > fill $ circle (V2 100 100) 75 --- --- <> --- -circle :: Point -- ^ Circle center in pixels - -> Float -- ^ Circle radius in pixels - -> [Primitive] -circle center radius = - CubicBezierPrim . transform mv <$> cubicBezierCircle - where - mv p = (p ^* radius) ^+^ center - --- | Generate a list of primitive representing an ellipse. --- --- > fill $ ellipse (V2 100 100) 75 30 --- --- <> --- -ellipse :: Point -> Float -> Float -> [Primitive] -ellipse center rx ry = - CubicBezierPrim . transform mv <$> cubicBezierCircle - where - mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center - -- | Generate a strokable line out of points list. -- Just an helper around `lineFromPath`. -- @@ -691,21 +671,6 @@ polygon [_,_] = [] polygon lst@(p:_) = polyline $ lst ++ [p] --- | Generate a list of primitive representing a --- rectangle --- --- > fill $ rectangle (V2 30 30) 150 100 --- --- <> --- -rectangle :: Point -- ^ Corner upper left - -> Float -- ^ Width in pixel - -> Float -- ^ Height in pixel - -> [Primitive] -rectangle p@(V2 px py) w h = - LinePrim <$> lineFromPath - [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ] - -- | Simply draw an image into the canvas. Take into account -- any previous transformation performed on the geometry. -- @@ -738,10 +703,10 @@ reqWidth reqHeight | borderSize <= 0 = withTransformation (translate p <> scale scaleX scaleY) . - withTexture (sampledImageTexture img) $ fill rect + withTexture (SampledTexture img) $ fill rect | otherwise = do withTransformation (translate p <> scale scaleX scaleY) $ - withTexture (sampledImageTexture img) $ fill rect + withTexture (SampledTexture img) $ fill rect stroke (borderSize / 2) (JoinMiter 0) (CapStraight 0, CapStraight 0) rect' where @@ -755,41 +720,6 @@ scaleY | reqHeight == 0 = 1 | otherwise = reqHeight / rh - --- | Generate a list of primitive representing a rectangle --- with rounded corner. --- --- > fill $ roundedRectangle (V2 10 10) 150 150 20 10 --- --- <> --- -roundedRectangle :: Point -- ^ Corner upper left - -> Float -- ^ Width in pixel - -> Float -- ^ Height in pixel. - -> Float -- ^ Radius along the x axis of the rounded corner. In pixel. - -> Float -- ^ Radius along the y axis of the rounded corner. In pixel. - -> [Primitive] -roundedRectangle (V2 px py) w h rx ry = - [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR - , LinePrim $ Line (V2 xFar py) (V2 xNear py) - , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL - , LinePrim $ Line (V2 px yNear) (V2 px yFar) - , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL - , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h)) - , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR - , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear) - ] - where - xNear = px + rx - xFar = px + w - rx - - yNear = py + ry - yFar = py + h - ry - - (cornerBottomR : - cornerTopR : - cornerTopL : - cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle -- | Return a simple line ready to be stroked. -- diff --git a/src/Graphics/Rasterific/Command.hs b/src/Graphics/Rasterific/Command.hs --- a/src/Graphics/Rasterific/Command.hs +++ b/src/Graphics/Rasterific/Command.hs @@ -8,6 +8,11 @@ , DrawCommand( .. ) , TextRange( .. ) , dumpDrawing + , Texture( .. ) + , Gradient + , ShaderFunction + , ImageTransformer + , dumpTexture ) where #if !MIN_VERSION_base(4,8,0) @@ -19,9 +24,7 @@ import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 ) import Graphics.Rasterific.Types -import Graphics.Rasterific.Texture import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Shading import Graphics.Text.TrueType( Font, PointSize ) @@ -38,19 +41,48 @@ , _textTexture :: Maybe (Texture px) } +type ShaderFunction px = Float -> Float -> px + +type ImageTransformer px = Int -> Int -> 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)] + +-- | 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)) + | PatternTexture !Int !Int !px (Drawing px ()) (Image px) + + data DrawCommand px next - = Fill FillMethod [Primitive] next - | Stroke Float Join (Cap, Cap) [Primitive] next - | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next - | TextFill Point [TextRange px] next - | SetTexture (Texture px) - (Drawing px ()) next - | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next - | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next - | WithCliping (forall innerPixel. Drawing innerPixel ()) - (Drawing px ()) next - | WithTransform Transformation (Drawing px ()) next - | WithPathOrientation Path Float (Drawing px ()) next + = Fill FillMethod [Primitive] next + | Stroke Float Join (Cap, Cap) [Primitive] next + | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next + | TextFill Point [TextRange px] next + | SetTexture (Texture px) + (Drawing px ()) next + | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next + | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next + | WithCliping (forall innerPixel. Drawing innerPixel ()) + (Drawing px ()) next + | WithTransform Transformation (Drawing px ()) next + | WithPathOrientation Path Float (Drawing px ()) next -- | This function will spit out drawing instructions to -- help debugging. @@ -110,9 +142,36 @@ ++ ")\n" ++ " (" ++ go (fromF draw) ++ ")\n >>= " ++ go next - where clipTexture = uniformTexture (0xFF :: Pixel8) + where clipTexture = SolidTexture (0xFF :: Pixel8) withTexture texture subActions = liftF $ SetTexture texture subActions () + +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 ++ ")" +dumpTexture (PatternTexture w h px sub _) = + "patternTexture " ++ show w ++ " " ++ show h ++ " " ++ show px + ++ " (" ++ dumpDrawing sub ++ ")" instance Functor (DrawCommand px) where diff --git a/src/Graphics/Rasterific/ComplexPrimitive.hs b/src/Graphics/Rasterific/ComplexPrimitive.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/ComplexPrimitive.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} +-- | Provide definition for some higher level objects (only slightly) +module Graphics.Rasterific.ComplexPrimitive( rectangle + , roundedRectangle + , circle + , ellipse + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^*) ) +import Graphics.Rasterific.Line +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Types + +-- | Generate a list of primitive representing a circle. +-- +-- > fill $ circle (V2 100 100) 75 +-- +-- <> +-- +circle :: Point -- ^ Circle center in pixels + -> Float -- ^ Circle radius in pixels + -> [Primitive] +circle center radius = + CubicBezierPrim . transform mv <$> cubicBezierCircle + where + mv p = (p ^* radius) ^+^ center + +-- | Generate a list of primitive representing an ellipse. +-- +-- > fill $ ellipse (V2 100 100) 75 30 +-- +-- <> +-- +ellipse :: Point -> Float -> Float -> [Primitive] +ellipse center rx ry = + CubicBezierPrim . transform mv <$> cubicBezierCircle + where + mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center + +-- | Generate a list of primitive representing a +-- rectangle +-- +-- > fill $ rectangle (V2 30 30) 150 100 +-- +-- <> +-- +rectangle :: Point -- ^ Corner upper left + -> Float -- ^ Width in pixel + -> Float -- ^ Height in pixel + -> [Primitive] +rectangle p@(V2 px py) w h = + LinePrim <$> lineFromPath + [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ] + +-- | Generate a list of primitive representing a rectangle +-- with rounded corner. +-- +-- > fill $ roundedRectangle (V2 10 10) 150 150 20 10 +-- +-- <> +-- +roundedRectangle :: Point -- ^ Corner upper left + -> Float -- ^ Width in pixel + -> Float -- ^ Height in pixel. + -> Float -- ^ Radius along the x axis of the rounded corner. In pixel. + -> Float -- ^ Radius along the y axis of the rounded corner. In pixel. + -> [Primitive] +roundedRectangle (V2 px py) w h rx ry = + [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR + , LinePrim $ Line (V2 xFar py) (V2 xNear py) + , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL + , LinePrim $ Line (V2 px yNear) (V2 px yFar) + , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL + , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h)) + , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR + , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear) + ] + where + xNear = px + rx + xFar = px + w - rx + + yNear = py + ry + yFar = py + h - ry + + (cornerBottomR : + cornerTopR : + cornerTopL : + cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle + 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 @@ -11,6 +11,7 @@ , RenderablePixel , compositionDestination , compositionAlpha + , emptyPx ) where import Foreign.Storable( Storable ) @@ -150,4 +151,8 @@ `modiv` alphaOut in mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top + +emptyPx :: (RenderablePixel px) => px +-- | Really need a "builder" function for pixel +emptyPx = colorMap (const emptyValue) $ unpackPixel 0 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 @@ -14,6 +14,8 @@ , flattenCubicBezier , cubicBezierLengthApproximation , cubicBezierBounds + , cubicFromQuadraticBezier + , isCubicBezierPoint ) where import Prelude hiding( or ) @@ -330,6 +332,11 @@ where !mini = fromIntegral (floor abbcbccdy :: Int) !maxi = fromIntegral (ceiling abbcbccdy :: Int) +isCubicBezierPoint :: CubicBezier -> Bool +isCubicBezierPoint (CubicBezier a b c d) = + not $ a `isDistingableFrom` b || + b `isDistingableFrom` c || + c `isDistingableFrom` d sanitizeCubicBezier :: CubicBezier -> Container Primitive sanitizeCubicBezier bezier@(CubicBezier a b c d) @@ -346,4 +353,9 @@ | otherwise = mempty where ac = a `midPoint` c bd = a `midPoint` d + +cubicFromQuadraticBezier :: Bezier -> CubicBezier +cubicFromQuadraticBezier (Bezier p0 p1 p2) = CubicBezier p0 pa pb p2 where + pa = p0 ^+^ (p1 ^-^ p0) ^* (2 / 3) + pb = p2 ^+^ (p1 ^-^ p2) ^* (2 / 3) diff --git a/src/Graphics/Rasterific/Immediate.hs b/src/Graphics/Rasterific/Immediate.hs --- a/src/Graphics/Rasterific/Immediate.hs +++ b/src/Graphics/Rasterific/Immediate.hs @@ -25,12 +25,17 @@ , fillWithTextureAndMask , fillWithTexture , fillOrder + + , textToDrawOrders + , transformOrder ) where #if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) import Data.Foldable( foldMap ) #endif +import Data.Maybe( fromMaybe ) import qualified Data.Foldable as F import Control.Monad.Free( liftF ) import Control.Monad.State( StateT, execStateT, get, lift ) @@ -46,12 +51,15 @@ import Graphics.Rasterific.Compositor import Graphics.Rasterific.Linear( V2( .. ) ) import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture import Graphics.Rasterific.Shading +import Graphics.Rasterific.QuadraticBezier import Graphics.Rasterific.Types import Graphics.Rasterific.Command import Graphics.Rasterific.PlaneBoundable +import qualified Data.Vector.Unboxed as VU +import Graphics.Text.TrueType( Dpi, getStringCurveAtPoint ) + -- | Monad used to describe the drawing context. type DrawContext m px = StateT (MutableImage (PrimState m) px) m @@ -70,9 +78,16 @@ } instance PlaneBoundable (DrawOrder px) where - planeBounds = - foldMap (foldMap planeBounds) . _orderPrimitives + planeBounds = + foldMap (foldMap planeBounds) . _orderPrimitives +transformOrder :: (Point -> Point) -> DrawOrder px -> DrawOrder px +transformOrder f order = + order { _orderPrimitives = transform f $ _orderPrimitives order } + +instance Transformable (DrawOrder px) where + transform = transformOrder + -- | Transform back a low level drawing order to a more -- high level Drawing orderToDrawing :: DrawOrder px -> Drawing px () @@ -189,6 +204,33 @@ !maxi = V2 (fromIntegral width) (fromIntegral height) spans = rasterize fillMethod $ foldMap (clip mini maxi) els !shader = primToPrim - . transformTextureToFiller (modulateTexture texture mask) img + . transformTextureToFiller (ModulateTexture texture mask) img lift . mapM_ shader $ filter (isCoverageDrawable img) spans + +-- | Helper function transforming text range to draw order. +textToDrawOrders :: Dpi -- ^ Current output device resolution + -> Texture px -- ^ Texture to use if no texture is defined in the range + -> Point -- ^ Baseline position + -> [TextRange px] -- ^ Text description. + -> [DrawOrder px] +textToDrawOrders dpi defaultTexture (V2 x y) descriptions = + toOrder <$> zip floatCurves linearDescriptions where + + toOrder (curve, d) = DrawOrder + { _orderPrimitives = [beziersOfChar curve] + , _orderFillMethod = FillWinding + , _orderMask = Nothing + , _orderTexture = fromMaybe defaultTexture $ _textTexture d + } + + floatCurves = + getStringCurveAtPoint dpi (x, y) + [(_textFont d, _textSize d, _text d) | d <- descriptions] + + linearDescriptions = + concat [map (const d) $ _text d | d <- descriptions] + + beziersOfChar curves = concat + [fmap BezierPrim . bezierFromPath . fmap (uncurry V2) $ VU.toList c | c <- curves] + 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 @@ -10,6 +10,8 @@ , flattenLine , lineLength , offsetLine + , isLinePoint + , extendLine ) where #if !MIN_VERSION_base(4,8,0) @@ -39,6 +41,9 @@ lineFromPath lst@(_:rest) = uncurry Line <$> zip lst rest +isLinePoint :: Line -> Bool +isLinePoint (Line a b) = not $ a `isDistingableFrom` b + lineLength :: Line -> Float lineLength (Line a b) = norm (b ^-^ a) @@ -160,4 +165,15 @@ | otherwise = aby where !mini = fromIntegral (floor aby :: Int) !maxi = fromIntegral (ceiling aby :: Int) + +-- | Extend a line by two coefficient, giving a line that's a +-- linear extension of the original line. +-- +-- law: extendLine 0 1 = id +extendLine :: Float -- ^ Begin extension coefficient + -> Float -- ^ End extension coefficient + -> Line -- ^ Line to transform + -> Line +extendLine beg end (Line p1 p2) = + Line (lerp beg p1 p2) (lerp end p1 p2) diff --git a/src/Graphics/Rasterific/MicroPdf.hs b/src/Graphics/Rasterific/MicroPdf.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/MicroPdf.hs @@ -0,0 +1,1069 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} +module Graphics.Rasterific.MicroPdf( renderDrawingToPdf + , renderOrdersToPdf + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable( Foldable, foldMap ) +import Data.Monoid( mempty ) +import Control.Applicative( (<$>), (<*>), pure ) +#endif + +import Control.Monad.Free( liftF, Free( .. ) ) +import Control.Monad.Free.Church( fromF ) +import Control.Monad.State( StateT, get, put, runStateT, modify, execState ) +import Control.Monad.Reader( Reader, local, asks, runReader ) + +import Numeric( showFFloat ) +import Data.Monoid( (<>) ) +import qualified Data.Foldable as F +import Data.ByteString.Builder( byteString + , intDec + , toLazyByteString + , Builder ) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Codec.Picture( PixelRGBA8( PixelRGBA8 ) + , Pixel8 + , Pixel + , PixelBaseComponent + , pixelOpacity + , mixWithAlpha + ) + +import Graphics.Rasterific.MiniLens( Lens', use, (.^), (.=), (+=), (%=) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.Linear +import Graphics.Rasterific.Compositor +import Graphics.Rasterific.Command +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Line +import Graphics.Rasterific.Immediate +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.PathWalker +import Graphics.Rasterific.ComplexPrimitive +import Graphics.Text.TrueType( Dpi ) +import Text.Printf +{-import Debug.Trace-} + +#if !MIN_VERSION_base(4,8,0) +glength :: Foldable f => f a -> Int +glength = F.foldl' (\acc _ -> acc + 1) 0 +#else +glength :: Foldable f => f a -> Int +glength = F.length +#endif + +type PdfCommand = B.ByteString +type PdfId = Int + +data PdfObject = PdfObject + { _pdfId :: !PdfId + , _pdfRevision :: !PdfId + , _pdfAnnot :: !Resources + , _pdfStream :: !B.ByteString + } + +instance Eq PdfObject where + obj1 == obj2 = + (_pdfAnnot obj1, _pdfStream obj1) == (_pdfAnnot obj2, _pdfStream obj2) + +instance Ord PdfObject where + compare obj1 obj2 = + compare (_pdfAnnot obj1, _pdfStream obj1) (_pdfAnnot obj2, _pdfStream obj2) + +type InnerRenderer = + forall px . PdfColorable px => Drawing px () -> [DrawOrder px] + +data PdfConfiguration = PdfConfiguration + { _pdfConfDpi :: !Dpi + , _pdfWidth :: !Int + , _pdfHeight :: !Int + , _pdfConfToOrder :: InnerRenderer + } + +domainOfCircle :: Point -> Float -> (Point, Point) -> Domain +domainOfCircle center radius (mini, maxi) = (0, max d1 d2 / radius) + where + d1 = distance maxi center + d2 = distance mini center + +domainOfLinearGradient :: Line -> (Point, Point) -> (Float, Float) +domainOfLinearGradient (Line p1 p2) (mini, maxi) = + (t0 + xxAdd + yxAdd, t0 + xyAdd + yyAdd) + where + {- + * Linear gradients are othrogonal to the line passing through + * their extremes. Because of convexity, the parameter range can + * be computed as the convex hull (one the real line) of the + * parameter values of the 4 corners of the box. + * + * The parameter value t for a point (x,y) can be computed as: + * + * t = (p2 - p1) . (x,y) / |p2 - p1|^2 + * + * t0 is the t value for the top left corner + * tdx is the difference between left and right corners + * tdy is the difference between top and bottom corners + -} + delta = p2 ^-^ p1 + invSquareNorm = 1 / quadrance delta + + normDelta = delta ^* invSquareNorm + + t0 = (mini ^-^ p1) `dot` normDelta + V2 tdx tdy = (maxi ^-^ mini) * normDelta + + (xxAdd, xyAdd) | tdx < 0 = (tdx, 0) + | otherwise = (0, tdx) + (yxAdd, yyAdd) | tdy < 0 = (tdy, 0) + | otherwise = (0, tdy) + +-------------------------------------------------- +---- Monadic generation types +-------------------------------------------------- +type PdfEnv = StateT PdfContext (Reader PdfConfiguration) + +runPdfEnv :: PdfConfiguration -> PdfId -> PdfEnv a -> (a, PdfContext) +runPdfEnv conf firstFreeId producer = + runReader (runStateT producer $ emptyContext firstFreeId) conf + +type Resources = [(B.ByteString, B.ByteString)] + +data PdfResourceAssoc = PdfResourceAssoc + { _resFreeIndex :: !Int + , _resAssoc :: !Resources + } + +resFreeIndex :: Lens' PdfResourceAssoc Int +resFreeIndex f v = setter <$> f (_resFreeIndex v) where + setter new = v { _resFreeIndex = new } + +resAssoc :: Lens' PdfResourceAssoc Resources +resAssoc f v = setter <$> f (_resAssoc v) where + setter new = v { _resAssoc = new } + +data PdfContext = PdfContext + { _pdfFreeIndex :: !Int + , _generatedPdfObjects :: ![PdfObject] + , _pdfPatterns :: !PdfResourceAssoc + , _pdfShadings :: !PdfResourceAssoc + , _pdfGraphicStates :: !PdfResourceAssoc + , _pdfXObjects :: !PdfResourceAssoc + } + +pdfXObjects :: Lens' PdfContext PdfResourceAssoc +pdfXObjects f v = setter <$> f (_pdfXObjects v) where + setter new = v { _pdfXObjects = new } + +pdfPatterns :: Lens' PdfContext PdfResourceAssoc +pdfPatterns f v = setter <$> f (_pdfPatterns v) where + setter new = v { _pdfPatterns = new } + +pdfShadings :: Lens' PdfContext PdfResourceAssoc +pdfShadings f v = setter <$> f (_pdfShadings v) where + setter new = v { _pdfShadings = new } + +pdfGraphicStates :: Lens' PdfContext PdfResourceAssoc +pdfGraphicStates f v = setter <$> f (_pdfGraphicStates v) where + setter new = v { _pdfGraphicStates = new } + +isPixelTransparent :: (Modulable (PixelBaseComponent px), Pixel px) => px -> Bool +isPixelTransparent p = pixelOpacity p < fullValue + +isGradientTransparent :: (Modulable (PixelBaseComponent px), Pixel px) => Gradient px -> Bool +isGradientTransparent = F.any (isPixelTransparent . snd) + +toAlphaGradient :: Pixel px => Gradient px -> Gradient (PixelBaseComponent px) +toAlphaGradient = fmap extractOpacity where + extractOpacity (o, p) = (o, pixelOpacity p) + +toOpaqueGradient :: RenderablePixel px => Gradient px -> Gradient px +toOpaqueGradient = fmap (\(o, p) -> (o, mixWithAlpha pxId pxOpaq p p)) where + pxId _ _ v = v + pxOpaq _ _ = fullValue + +withLocalSubcontext :: PdfEnv a -> PdfEnv (a, PdfId) +withLocalSubcontext sub = do + oldShadings <- reset (pdfShadings.resAssoc) [] + oldPatterns <- reset (pdfPatterns.resAssoc) [] + oldStates <- reset (pdfGraphicStates.resAssoc) [] + oldXObjects <- reset (pdfXObjects.resAssoc) [] + + result <- sub + + newShadings <- reset (pdfShadings.resAssoc) oldShadings + newStates <- reset (pdfGraphicStates.resAssoc) oldStates + newPatterns <- reset (pdfPatterns.resAssoc) oldPatterns + newXObjects <- reset (pdfXObjects.resAssoc) oldXObjects + + (result,) <$> generateObject (resourceObject newShadings newStates newPatterns newXObjects) + where + reset :: Lens' PdfContext a -> a -> PdfEnv a + reset l old = do + v <- use l + l .= old + return v + +nameObject :: B.ByteString -> Lens' PdfContext PdfResourceAssoc -> B.ByteString -> PdfEnv Builder +nameObject prefix lens info = do + idx <- use (lens.resFreeIndex) + lens.resFreeIndex += 1 + let key = buildToStrict $ tp prefix <> intDec idx + lens.resAssoc %= ((key, info) :) + return . tp $ "/" <> key + +nameStateObject :: PdfId -> PdfEnv Builder +nameStateObject = nameObject "gs" pdfGraphicStates . refOf + +nameOpacityObject :: Float -> PdfEnv Builder +nameOpacityObject opa = nameObject "gs" pdfGraphicStates opac where + opb = toPdf opa + opac = buildToStrict $ "<< /ca " <> opb <> " /CA " <> opb <> ">> " + +nameXObject :: PdfId -> PdfEnv Builder +nameXObject = nameObject "x" pdfXObjects . refOf + +{-nameShadingObject :: PdfId -> PdfEnv Builder-} +{-nameShadingObject = nameObject "Sh" pdfShadings . refOf-} + +namePatternObject :: B.ByteString -> PdfEnv Builder +namePatternObject = nameObject "P" pdfPatterns + +generateObject :: (PdfId -> PdfObject) -> PdfEnv PdfId +generateObject f = do + ctxt <- get + let idx = _pdfFreeIndex ctxt + put $ ctxt + { _pdfFreeIndex = idx + 1 + , _generatedPdfObjects = f idx : _generatedPdfObjects ctxt + } + return idx + +emptyContext :: PdfId -> PdfContext +emptyContext idx = PdfContext + { _pdfFreeIndex = idx + , _generatedPdfObjects = mempty + , _pdfPatterns = emptyAssoc + , _pdfShadings = emptyAssoc + , _pdfGraphicStates = emptyAssoc + , _pdfXObjects = emptyAssoc + } + where + emptyAssoc = PdfResourceAssoc + { _resFreeIndex = 1 + , _resAssoc = mempty + } + + + +-------------------------------------------------- +---- ToPdf class & instances +-------------------------------------------------- +class ToPdf a where + toPdf :: a -> Builder + +instance ToPdf Float where + toPdf v = toPdf . B.pack $ showFFloat (Just 4) v "" + +instance ToPdf B.ByteString where + toPdf = byteString + +newtype Matrix = Matrix Transformation + +instance ToPdf Transformation where + toPdf (Transformation a c e b d f) = + foldMap t [a, b, c, d, e, f] <> tp " cm\n" + where + t v = toPdf v <> tp " " + +instance ToPdf Matrix where + toPdf (Matrix (Transformation a c e b d f)) = + arrayOf $ foldMap t [a, b, c, d, e, f] + where + t v = toPdf v <> tp " " + +instance ToPdf Resources where + toPdf [] = mempty + toPdf dic = tp "<< " <> foldMap dicToPdf dic <> tp ">> " + where + dicToPdf (_, el) | B.null el = mempty + dicToPdf (k, el) = + tp "/" <> toPdf k <> tp " " <> toPdf el <> tp "\n" + +instance ToPdf PdfObject where + toPdf obj = intDec (_pdfId obj) + <> tp " " + <> intDec (_pdfRevision obj) + <> tp " obj\n" + <> toPdf dic <> tp "\n" + <> stream + <> tp "endobj\n" + where + bSize = buildToStrict . intDec . B.length $ _pdfStream obj + hasntStream = B.null $ _pdfStream obj + + dic + | hasntStream = _pdfAnnot obj + | otherwise = _pdfAnnot obj <> [("Length", bSize)] + + stream + | hasntStream = mempty + | otherwise = tp "stream\n" + <> toPdf (_pdfStream obj) + <> tp "\nendstream\n" + +instance ToPdf Point where + toPdf (V2 x y) = toPdf x <> tp " " <> toPdf y + +instance ToPdf Bezier where + toPdf = toPdf . cubicFromQuadraticBezier + +instance ToPdf CubicBezier where + toPdf (CubicBezier _p0 p1 p2 p3) = + toPdf p1 <> tp " " <> toPdf p2 <> tp " " <> toPdf p3 <> tp " c\n" + +instance ToPdf Line where + toPdf (Line _p0 p1) = toPdf p1 <> tp " l\n" + +instance ToPdf Primitive where + toPdf p = case p of + LinePrim l -> toPdf l + BezierPrim b -> toPdf b + CubicBezierPrim c -> toPdf c + + +-------------------------------------------------- +---- Helper functions +-------------------------------------------------- +buildToStrict :: Builder -> B.ByteString +buildToStrict = LB.toStrict . toLazyByteString + +tp :: B.ByteString -> Builder +tp = toPdf + +pdfSignature :: B.ByteString +pdfSignature = "%PDF-1.4\n%\xBF\xF7\xA2\xFE\n" + +refOf :: PdfId -> B.ByteString +refOf i = buildToStrict $ intDec i <> " 0 R" + +arrayOf :: Builder -> Builder +arrayOf a = tp "[ " <> a <> tp " ]" + +localGraphicState :: Builder -> Builder +localGraphicState sub = tp "q\n" <> sub <> tp "Q\n" + +dicObj :: [(B.ByteString, B.ByteString)] -> PdfId -> PdfObject +dicObj annots pid = PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfAnnot = annots + , _pdfStream = mempty + } + +-------------------------------------------------- +---- PDF object helper +-------------------------------------------------- +outlinesObject :: Foldable f => f PdfCommand -> PdfId -> PdfObject +outlinesObject outlines = dicObj + [ ("Type", "/Outlines") + , ("Count", buildToStrict . intDec $ glength outlines) + ] + +pagesObject :: Foldable f => f PdfId -> PdfId -> PdfObject +pagesObject pages = dicObj + [ ("Type", "/Pages") + , ("Kids", buildToStrict . arrayOf $ foldMap (toPdf . refOf) pages) + , ("Count", buildToStrict . intDec $ glength pages) + ] + + +catalogObject :: PdfId -> PdfId -> PdfId -> PdfObject +catalogObject pagesId outlineId = dicObj + [ ("Type", "/Catalog") + , ("Outlines", refOf outlineId) + , ("Pages", refOf pagesId) + ] + +pageObject :: PdfColorable px + => Proxy px -> Int -> Int -> PdfId -> PdfId -> PdfId -> PdfId -> PdfObject +pageObject px width height parentId contentId resourceId = dicObj + [ ("Type", "/Page") + , ("Parent", refOf parentId) + , ("MediaBox", buildToStrict box) + , ("Contents", refOf contentId) + , ("Resources", refOf resourceId) + , ("Group", buildToStrict . toPdf $ groupDic px) + ] + where + box = tp "[0 0 " <> intDec width <> tp " " <> intDec height <> tp "]" + +gradientPatternObject :: Transformation -> PdfId -> PdfId -> PdfObject +gradientPatternObject trans gradientId = dicObj + [ ("Type", "/Pattern") + , ("PatternType", "2") + , ("Matrix", it) + , ("Shading", refOf gradientId) + ] + where + it = buildToStrict . toPdf $ Matrix trans + +linearGradientObject :: Line -> Domain -> B.ByteString -> PdfId -> PdfId -> PdfObject +linearGradientObject (Line p1 p2) (beg, end) colorSpace funId = dicObj + [ ("ShadingType", "2") + , ("ColorSpace", colorSpace) + , ("Coords", buildToStrict coords) + , ("Function", refOf funId) + , ("Domain", buildToStrict . arrayOf $ toPdf beg <> tp " " <> toPdf end) + , ("Extend", "[true true]") + ] + where + coords = arrayOf $ toPdf p1 <> tp " " <> toPdf p2 + +radialGradientObject :: Domain -> Point -> Point -> Float -> B.ByteString -> PdfId + -> PdfId -> PdfObject +radialGradientObject (beg, end) center focus radius colorSpace funId = dicObj + [ ("ShadingType", "3") + , ("ColorSpace", colorSpace) + , ("Coords", buildToStrict coords) + , ("Function", refOf funId) + , ("Domain", buildToStrict . arrayOf $ toPdf beg <> tp " " <> toPdf end) + , ("Extend", "[true true]") + ] + where + coords = arrayOf $ toPdf center <> tp " " <> toPdf radius + <> " " <> toPdf focus <> tp " 0" + +contentObject :: B.ByteString -> PdfId -> PdfObject +contentObject content pid = PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfAnnot = [] + , _pdfStream = content + } + +pathToPdf :: [Primitive] -> Builder +pathToPdf ps = case ps of + [] -> mempty + p:_ -> + toPdf (firstPointOf p) <> tp " m\n" <> foldMap toPdf ps <> "\n" + +class RenderablePixel px => PdfColorable px where + pdfColorSpace :: Proxy px -> B.ByteString + colorToPdf :: px -> Builder + +instance PdfColorable Pixel8 where + pdfColorSpace _ = "/DeviceGray" + colorToPdf c = toPdf (fromIntegral c / 255 :: Float) + +instance PdfColorable PixelRGBA8 where + pdfColorSpace _ = "/DeviceRGB" + colorToPdf (PixelRGBA8 r g b _a) = + colorToPdf r <> tp " " <> colorToPdf g <> tp " " <> colorToPdf b + + +maskObject :: PdfId -> PdfId -> PdfObject +maskObject maskId = dicObj + [ ("Type", "/Mask") + , ("S", "/Luminosity") + , ("G", refOf maskId) + ] + +alphaMaskObject :: PdfId -> PdfId -> PdfObject +alphaMaskObject maskId = dicObj + [ ("Type", "/Mask") + , ("S", "/Alpha") + , ("G", refOf maskId) + ] + + +opaState :: Float -> PdfId -> PdfObject +opaState opa = dicObj + [ ("Type", "/ExtGState") + , ("ca", v) + , ("CA", v) + ] + where v = buildToStrict $ toPdf opa + +maskState :: PdfId -> PdfId -> PdfObject +maskState maskObj = dicObj + [ ("Type", "/ExtGState") + , ("SMask", refOf maskObj) + , ("ca", "1") + , ("CA", "1") + , ("AIS", "false") + ] + +colorInterpolationFunction :: PdfColorable px => px -> px -> PdfId -> PdfObject +colorInterpolationFunction c0 c1 = dicObj + [ ("FunctionType", "2") + , ("Domain", "[ 0 1 ]") + , ("C0", buildToStrict . arrayOf $ colorToPdf c0) + , ("C1", buildToStrict . arrayOf $ colorToPdf c1) + , ("N", "1") + ] + +resourceObject :: Resources -> Resources -> Resources -> Resources + -> PdfId -> PdfObject +resourceObject shadings extStates patterns xobjects= dicObj $ + ("ProcSet", buildToStrict . arrayOf $ tp "/PDF /Text") : + genExt "ExtGState" (("ao", "<< /ca 1 /CA 1 >>") : extStates) + <> genExt "Pattern" patterns + <> genExt "Shading" shadings + <> genExt "XObject" xobjects + where + genExt _ [] = [] + genExt k lst = [(k, buildToStrict $ toPdf lst)] + +stitchingFunction :: [PdfId] -> [(Float, Float)] -> PdfId -> PdfObject +stitchingFunction interpolations bounds = dicObj + [ ("FunctionType", "3") + , ("Domain", "[ 0 1 ]") + , ("Functions", buildToStrict interpIds) + , ("Bounds", buildToStrict boundsId) + , ("Encode", buildToStrict . arrayOf . F.fold $ map (const $ tp "0 1 ") interpolations) + ] + where + interpIds = + arrayOf $ foldMap (\i -> toPdf (refOf i) <> tp " ") interpolations + boundsId = arrayOf . foldMap ((<> " ") . toPdf . snd) $ init bounds + +repeatingFunction :: Bool -> Float -> Float -> PdfId -> PdfId -> PdfObject +repeatingFunction reflect begin end fun = dicObj + [ ("FunctionType", "3") + , ("Domain", buildToStrict . arrayOf $ intDec ibegin <> tp " " <> intDec iend) + , ("Functions", buildToStrict interpIds) + , ("Bounds", buildToStrict $ arrayOf boundsIds) + , ("Encode", buildToStrict . arrayOf $ foldMap encoding [ibegin .. iend - 1]) + ] + where + ibegin = floor begin + iend = ceiling end + interpIds = + arrayOf $ foldMap (\_ -> toPdf (refOf fun) <> tp " ") [ibegin .. iend - 1] + boundsIds = + foldMap ((<> tp " ") . intDec) [ibegin + 1 .. iend - 1] + encoding i | i `mod` 2 /= 0 && reflect = tp "1 0 " + | otherwise = tp "0 1 " + +tillingPattern :: Transformation -> Int -> Int -> Builder -> PdfId -> PdfId -> PdfObject +tillingPattern trans w h content res pid = PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfStream = buildToStrict content + , _pdfAnnot = + [ ("Type", "/Pattern") + , ("PatternType", "1") + , ("PaintType", "1") + , ("TilingType", "1") + , ("BBox", buildToStrict $ "[0 0 " <> intDec w <> tp " " <> intDec h <> "]") + , ("XStep", buildToStrict $ intDec w) + , ("YStep", buildToStrict $ intDec h) + , ("Resources", refOf res) + , ("Matrix", buildToStrict . toPdf $ Matrix trans) + ] + } + +groupDic :: PdfColorable px => Proxy px -> [(B.ByteString, B.ByteString)] +groupDic px = + [ ("Type", "/Group") + , ("S", "/Transparency") + , ("I", "true") + , ("CS", pdfColorSpace px) + ] + + +formObject :: PdfColorable px + => Resources -> Proxy px -> B.ByteString -> PdfId + -> PdfEnv (PdfId -> PdfObject) +formObject aditionalAttributes px content res = do + width <- intDec <$> asks _pdfWidth + height <- intDec <$> asks _pdfHeight + pure $ \pid -> PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfStream = content + , _pdfAnnot = + [ ("Type", "/XObject") + , ("Subtype", "/Form") + , ("BBox", buildToStrict $ "[0 0 " <> width <> tp " " <> height <> "]") + , ("XStep", buildToStrict width) + , ("YStep", buildToStrict height) + , ("Resources", refOf res) + , ("Group", buildToStrict . toPdf $ groupDic px) + ] <> aditionalAttributes + } + +gradientToPdf :: PdfColorable px => Gradient px -> PdfEnv PdfId +gradientToPdf [] = return 0 +gradientToPdf [(_, a), (_, b)] = generateObject (colorInterpolationFunction a b) +gradientToPdf lst@(_:rest) = do + interpolations <- + mapM generateObject [colorInterpolationFunction a b + | ((_, a), (_, b)) <- zip lst rest] + let bounds = zip (map fst lst) (map fst rest) + generateObject (stitchingFunction interpolations bounds) + +repeatFunction :: SamplerRepeat -> Float -> Float -> PdfId -> PdfEnv PdfId +repeatFunction sampler beg end fun = case sampler of + SamplerPad -> pure fun + _ | abs (ceiling end - floor beg) <= (1 :: Int) -> pure fun + SamplerRepeat -> generateObject $ repeatingFunction False beg end fun + SamplerReflect -> generateObject $ repeatingFunction True beg end fun + +type Domain = (Float, Float) + +createGradientFunction :: PdfColorable px + => Transformation -> Domain -> SamplerRepeat -> Gradient px + -> (PdfId -> PdfId -> PdfObject) + -> PdfEnv PdfId +createGradientFunction trans (beg, end) sampler grad generator = do + shaderId <- gradientToPdf grad + stitched <- repeatFunction sampler beg end shaderId + gradId <- generateObject (generator stitched) + generateObject (gradientPatternObject trans gradId) + +type PdfBaseColorable px = + ( PdfColorable px + , PdfColorable (PixelBaseComponent px) + , Integral (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px)) + +fullPageFill :: PdfEnv Builder +fullPageFill = do + w <- asks _pdfWidth + h <- asks _pdfHeight + pure $ "0 0 " <> intDec w <> " " <> intDec h <> " re f\n" + +{- ++------------+ +| Color {c}|<---------\ +| interp n | | ++------------+ | + | + * * * | + | ++------------+ +-+---------+ +------------+ +------------+ /-------------\ +| Color {c}|<-------+ Stitching |<---+ Repeat {c}|<---+ Gradient |<----+ Page {r}| +| interp n | | fun {c}| | function | | {c}| | resources | ++------------+ +-----------+ +------------+ +------------+ \-----+-------/ + | + v + Gradient with alpha PDF generation +-------------+ + (yes this is quite complex) | ExtGState | + | SMask {a}| + +-----+-------+ + | + v + +-------------+ + | Mask | + | {a}| + +-----+-------+ + | + v ++------------+ +-----------+ +------------+ +------------+ +--------------+ +| Color {a}|<-------+ Stitching |<---+ Repeat {a}|<---+ Gradient |<----+ Form with | +| interp 0 | | fun {a}| | function | | {a}| | transparency | ++------------+ +-+---------+ +------------+ +------------+ | group {a}| + | +--------------+ + * * * | + | ++------------+ | +| Color {a}|<---------/ +| interp n | ++------------+ + +::: .a { fill: white; } +::: .r { fill: rgb(128, 200, 128); } +-} +gradientObjectGenerator :: forall px. PdfBaseColorable px + => Builder -> Transformation + -> Domain -> SamplerRepeat -> Gradient px + -> (B.ByteString -> PdfId -> PdfId -> PdfObject) + -> PdfEnv (Either String Builder) +gradientObjectGenerator inner rootTrans dom sampler rootGrad generator + | isGradientTransparent rootGrad = goAlpha rootGrad + | otherwise = go rootTrans rootGrad + where + alphaPxProxy = Proxy :: Proxy (PixelBaseComponent px) + alphaColorspace = pdfColorSpace alphaPxProxy + pxFullProxy = Proxy :: Proxy px + colorSpace = pdfColorSpace pxFullProxy + + go trans grad = do + patternId <- createGradientFunction trans dom sampler grad $ generator colorSpace + pat <- namePatternObject $ refOf patternId + pure . pure $ + "/Pattern cs\n" <> pat <> " scn\n" <> + "/Pattern CS\n" <> pat <> " SCN\n" <> inner + + goAlpha grad = do + let alphaGrad = toAlphaGradient grad + (colorGradCom, xObjectRes) <- + withLocalSubcontext . go mempty $ toOpaqueGradient grad + alphaId <- createGradientFunction mempty dom sampler alphaGrad $ generator alphaColorspace + + (command, resourceId) <- withLocalSubcontext $ do + alphaShadingName <- namePatternObject $ refOf alphaId + opaDicId <- generateObject $ opaState 1 + gsName <- nameStateObject opaDicId + fullFill <- fullPageFill + pure . buildToStrict $ gsName <> " gs /Pattern cs " <> alphaShadingName <> " scn\n" + <> fullFill + let subInfo = either (const mempty) buildToStrict colorGradCom + formId <- generateObject =<< formObject [("FormType", "1")] alphaPxProxy command resourceId + xObjectGenerator <- formObject [] pxFullProxy subInfo xObjectRes + xObjName <- nameXObject =<< generateObject xObjectGenerator + maskId <- generateObject $ maskObject formId + maskGraphicStateId <- generateObject $ maskState maskId + stateName <- nameStateObject maskGraphicStateId + pure . pure . localGraphicState $ stateName <> " gs\n" <> xObjName <> " Do\n" + +alphaLayerGenerator :: forall px. PdfBaseColorable px + => Proxy px -> (Builder, PdfId) -> Float -> PdfEnv Builder +alphaLayerGenerator pxFullProxy (inner, innerResource) alpha = go where + generateFill = withLocalSubcontext $do + fill <- fullPageFill + shade <- nameOpacityObject alpha + let co = colorToPdf (emptyPx :: px) + pure . buildToStrict $ co <> " rg\n" <> co <> " RG\n" <> shade <> " gs " <> fill <> " " + + go = do + (transpCall, layerRes) <- generateFill + formId <- generateObject =<< formObject mempty pxFullProxy transpCall layerRes + maskId <- generateObject $ alphaMaskObject formId + maskName <- nameStateObject =<< generateObject (maskState maskId) + + xObjId <- generateObject =<< formObject [] pxFullProxy (buildToStrict inner) innerResource + xObjName <- nameXObject xObjId + pure . localGraphicState $ maskName <> tp " gs\n" <> xObjName <> tp " Do\n" + +sampledDomainOf :: SamplerRepeat -> Domain -> Domain +sampledDomainOf _ (beg, end) | abs (beg - end) <= 1 = (0, 1) +sampledDomainOf sampler (beg, end) = case sampler of + SamplerPad -> (0, 1) + SamplerRepeat -> (beg, end) + SamplerReflect -> (beg, end) + +currentViewBox :: Transformation -> PdfEnv (Point, Point) +currentViewBox trans = do + width <- asks $ fromIntegral . _pdfWidth + height <- asks $ fromIntegral . _pdfHeight + let pMin = V2 0 0 + pMax = V2 width height + fitBounds t = (applyTransformation t pMin, applyTransformation t pMax) + pure . maybe (pMin, pMax) fitBounds $ inverseTransformation trans + +createLinearGradient :: forall px. PdfBaseColorable px + => Builder -> Transformation -> SamplerRepeat -> Gradient px -> Line + -> PdfEnv (Either String Builder) +createLinearGradient inner trans sampler grad line = do + baseDomain <- domainOfLinearGradient line <$> currentViewBox trans + let dom@(beg, end) = sampledDomainOf sampler baseDomain + sampledLine = extendLine beg end line + gradientObjectGenerator inner trans dom sampler grad $ + linearGradientObject sampledLine dom + +createRadialGradient :: forall px. PdfBaseColorable px + => Builder -> Transformation -> SamplerRepeat -> Gradient px + -> Point -> Point -> Float + -> PdfEnv (Either String Builder) +createRadialGradient inner trans sampler grad center focus radius = do + baseDomain <- domainOfCircle center radius <$> currentViewBox trans + let dom@(beg, end) = sampledDomainOf sampler baseDomain + radius' = radius * max (abs beg) (abs end) + gradientObjectGenerator inner trans dom sampler grad $ + radialGradientObject dom center focus radius' + +opacityToPdf :: forall n. (Integral n, Modulable n) => n -> Float +opacityToPdf comp = fromIntegral comp / fromIntegral fv where + fv = fullValue :: n + +textureToPdf :: forall px. PdfBaseColorable px + => Transformation -> Builder -> Texture px + -> PdfEnv (Either String Builder) +textureToPdf rootTrans inner = go rootTrans SamplerPad where + go currTrans sampler tex = case tex of + SampledTexture _img -> return $ Left "Unsupported raw image in PDF output." + ShaderTexture _f -> return $ Left "Unsupported shader function in PDF output." + ModulateTexture _tx _modulation -> return $ Left "Unsupported modulation in PDF output." + RawTexture img -> go currTrans sampler (SampledTexture img) + WithSampler newSampler tx -> go currTrans newSampler tx + SolidTexture px | isPixelTransparent px -> do + localState <- nameOpacityObject . opacityToPdf $ pixelOpacity px + pure . pure . localGraphicState $ + localState <> " gs\n" <> co <> " rg\n" <> co <> " RG\n" <> inner + where co = colorToPdf px + SolidTexture px -> + pure . pure $ "/ao gs " <> co <> " rg\n" <> co <> " RG\n" <> inner + where co = colorToPdf px + LinearGradientTexture grad line -> createLinearGradient inner currTrans sampler grad line + RadialGradientTexture grad center radius -> + go currTrans sampler $ RadialGradientWithFocusTexture grad center radius center + RadialGradientWithFocusTexture grad center rad focus -> do + let invGrad = reverse [(1 - o, c) | (o, c) <- grad] + createRadialGradient inner currTrans sampler invGrad center focus rad + WithTextureTransform trans tx -> + go tt sampler tx + where tt = case inverseTransformation trans of + Nothing -> currTrans + Just v -> currTrans <> v + PatternTexture w h px draw _img -> do + let withPatternSize conf = conf { _pdfWidth = w, _pdfHeight = h } + baseTexture = SolidTexture px + backRect = rectangle (V2 0 0) (fromIntegral w) (fromIntegral h) + backDraw = + liftF $ SetTexture baseTexture + (liftF $ Fill FillWinding backRect ()) () + (content, resId) <- + local withPatternSize . withLocalSubcontext $ pdfProducer baseTexture (backDraw >> draw) + tillingId <- generateObject $ tillingPattern rootTrans w h (content) resId + pat <- namePatternObject $ refOf tillingId + return . Right $ "/Pattern cs\n" <> pat <> " scn\n" <> inner + +reClose :: [Primitive] -> Builder +reClose [] = mempty +reClose lst@(x:_) + | lastPointOf (last lst) `isDistingableFrom` firstPointOf x = mempty + | otherwise = tp " h\n" + +fillCommandOf :: FillMethod -> Builder +fillCommandOf m = tp $ case m of + FillWinding -> "f\n" + FillEvenOdd -> "f*\n" + +clipCommandOf :: FillMethod -> Builder +clipCommandOf m = tp $ case m of + FillWinding -> "W n\n" + FillEvenOdd -> "W* n\n" + +lineCapOf :: Cap -> Builder +lineCapOf c = tp $ case c of + CapStraight 0 -> "0 J " + CapStraight _g -> "2 J " + CapRound -> "1 J " + +lineJoinOf :: Join -> Builder +lineJoinOf j = case j of + JoinRound -> tp "1 j " + JoinMiter 0 -> tp "8 M 0 j " + JoinMiter n -> toPdf n <> tp " M 0 j " + +orderToPdf :: PdfBaseColorable px => Transformation -> DrawOrder px + -> PdfEnv Builder +orderToPdf trans order = do + let processPath = foldMap pathToPdf . resplit -- . removeDegeneratePrimitive + geometryCode = foldMap processPath $ _orderPrimitives order + etx <- textureToPdf trans geometryCode $ _orderTexture order + case etx of + Left _ -> pure mempty + Right tx -> pure $ tx <> geometryCode <> fillCommandOf (_orderFillMethod order) + +buildXRefTable :: [Int] -> Builder +buildXRefTable lst = tp "xref\n0 " <> intDec (glength lst) <> tp "\n" + <> foldMap build lst where + build 0 = "0000000000 65535 f \n" + build ix = toPdf . B.pack $ printf "%010d 00000 n \n" ix + +buildTrailer :: Foldable f => f a -> PdfId -> Builder +buildTrailer objs startId = tp "trailer\n" <> toPdf + [("Size" :: B.ByteString, buildToStrict . intDec $ glength objs + 1) + ,("Root", refOf startId) + ] + +toPdfSpace :: Float -> Transformation +toPdfSpace h = translate (V2 0 h) <> scale 1 (-1) + +pdfFromProducer :: PdfBaseColorable px + => Proxy px -> PdfConfiguration -> PdfEnv Builder -> LB.ByteString +pdfFromProducer px conf producer = toLazyByteString $ + foldMap byteString objs + <> xref + <> buildTrailer objects catalogId + <> xrefPosition + <> tp "%%EOF" + where + height = _pdfHeight conf + (catalogId : outlineId : pagesId : pageId : contentId : endObjId : firstFreeId : _) = [1..] + (content, endContext) = runPdfEnv conf firstFreeId producer + initialTransform = toPdf . toPdfSpace $ fromIntegral height + + objects = + [ catalogObject pagesId outlineId catalogId + , outlinesObject [] outlineId + , pagesObject [pageId] pagesId + , pageObject px (_pdfWidth conf) height pagesId contentId endObjId pageId + , contentObject (buildToStrict $ initialTransform <> content) contentId + , resourceObject + (endContext .^ pdfShadings.resAssoc) + (endContext .^ pdfGraphicStates.resAssoc) + (endContext .^ pdfPatterns.resAssoc) + (endContext .^ pdfXObjects.resAssoc) + endObjId + ] + <> reverse (_generatedPdfObjects endContext) + + (indexes, objs) = unzip $ prepareObjects objects + lastIndex = last indexes + xrefIndex = lastIndex + B.length (last objs) + + xrefPosition = "startxref\n" <> intDec xrefIndex <> tp "\n" + + xref = buildXRefTable indexes + +renderDrawingToPdf :: (forall px . PdfColorable px => Drawing px () -> [DrawOrder px]) + -> Int -> Int -> Dpi -> Drawing PixelRGBA8 () + -> LB.ByteString +renderDrawingToPdf toOrders width height dpi = + pdfFromProducer px conf . pdfProducer baseTexture + where + px = Proxy :: Proxy PixelRGBA8 + baseTexture = SolidTexture emptyPx + conf = PdfConfiguration + { _pdfConfDpi = dpi + , _pdfWidth = width + , _pdfHeight = height + , _pdfConfToOrder = toOrders + } + +pdfProducer :: forall pixel . PdfBaseColorable pixel + => Texture pixel -> Drawing pixel () -> PdfEnv Builder +pdfProducer baseTexture draw = do + initTrans <- asks (toPdfSpace . fromIntegral . _pdfHeight) + goNext False initTrans fillCommandOf baseTexture $ fromF draw where + + goNext :: forall px. PdfBaseColorable px + => Bool -> Transformation -> (FillMethod -> Builder) -> Texture px + -> Free (DrawCommand px) () + -> PdfEnv Builder + goNext forceInverse activeTrans filler prevTexture f = case f of + Free c -> go forceInverse activeTrans filler prevTexture c + Pure () -> pure mempty + + go :: forall px. PdfBaseColorable px + => Bool -> Transformation -> (FillMethod -> Builder) -> Texture px + -> DrawCommand px (Free (DrawCommand px) ()) -> PdfEnv Builder + go forceInverse activeTrans filler prevTexture com = case com of + Fill method prims next -> do + after <- recurse next + pure $ foldMap pathToPdf (resplit prims) + <> filler method + <> after + Stroke w j (c, _) prims next -> do + after <- recurse next + let output p = pathToPdf p <> reClose p + pure $ toPdf w <> tp " w " + <> lineJoinOf j + <> lineCapOf c <> "\n" + <> foldMap output (resplit prims) + <> tp "S\n" + <> after + + DashedStroke o pat w j (c, _) prims next -> do + sub <- go forceInverse activeTrans filler prevTexture $ Stroke w j (c, c) prims (Pure ()) + after <- recurse next + pure $ arrayOf (foldMap coords pat) + <> toPdf o <> tp " d " + <> sub + <> "[] 0 d " + <> after + where + coords co = toPdf co <> tp " " + + -- Opacity is ignored for now + WithGlobalOpacity opacity sub next | opacity >= fullValue -> + (<>) <$> recurse (fromF sub) <*> recurse next + WithGlobalOpacity opacity sub next -> do + inner <- withLocalSubcontext . recurse $ fromF sub + after <- recurse next + let alpha = opacityToPdf opacity + proxy = Proxy :: Proxy px + (<> after) <$> alphaLayerGenerator proxy inner alpha + + WithImageEffect _f sub next -> + (<>) <$> recurse (fromF sub) <*> recurse next + + WithTransform trans sub next | forceInverse -> do + after <- recurse next + let subTrans = (activeTrans <> trans) + inner <- goNext forceInverse subTrans filler prevTexture $ fromF sub + let inv = foldMap toPdf $ inverseTransformation trans + pure $ toPdf trans <> inner <> inv <> after + + WithTransform trans sub next -> do + after <- recurse next + let subTrans = activeTrans <> trans + inner <- goNext forceInverse subTrans filler prevTexture $ fromF sub + pure $ localGraphicState (toPdf trans <> inner) <> after + + SetTexture tx sub next -> do + innerCode <- goNext forceInverse activeTrans filler tx $ fromF sub + after <- recurse next + tex <- textureToPdf activeTrans innerCode tx + pure $ case tex of + Left _ -> innerCode <> after + Right texCode -> localGraphicState texCode <> after + + WithCliping clipping sub next -> do + after <- recurse next + let draw8 = clipping :: Drawing px () + localClip | forceInverse = id + | otherwise = localGraphicState + clipPath <- goNext True activeTrans clipCommandOf prevTexture $ fromF draw8 + drawing <- recurse (fromF sub) + pure $ localClip (clipPath <> tp "\n" <> drawing) + <> after + + TextFill p ranges next -> do + dpi <- asks _pdfConfDpi + after <- recurse next + let orders = textToDrawOrders dpi prevTexture p ranges + textPrint <- mapM (orderToPdf activeTrans) orders + pure $ F.fold textPrint <> after + + WithPathOrientation path base subDrawings next -> do + toOrders <- asks _pdfConfToOrder + let orders :: [DrawOrder px] + orders = toOrders . liftF $ SetTexture prevTexture subDrawings () + + drawer trans _ order = + modify (liftF (WithTransform trans (orderToDrawing order) ()) :) + + placedDrawings :: [Drawing px ()] + placedDrawings = + reverse $ execState (drawOrdersOnPath drawer 0 base path orders) [] + after <- recurse next + this <- recurse . fromF $ F.fold placedDrawings + pure $ this <> after + + where + recurse = goNext forceInverse activeTrans filler prevTexture + +renderOrdersToPdf :: InnerRenderer -> Int -> Int -> Dpi -> [DrawOrder PixelRGBA8] + -> LB.ByteString +renderOrdersToPdf toOrders width height dpi orders = + pdfFromProducer (Proxy :: Proxy PixelRGBA8) conf $ + F.fold <$> mapM (orderToPdf rootTrans) orders + where + rootTrans = toPdfSpace $ fromIntegral height + conf = PdfConfiguration + { _pdfConfDpi = dpi + , _pdfWidth = width + , _pdfHeight = height + , _pdfConfToOrder = toOrders + } + +prepareObjects :: [PdfObject] -> [(Int, B.ByteString)] +prepareObjects = scanl go (0, pdfSignature) where + go (ix, prev) obj = (ix + B.length prev, buildToStrict $ toPdf obj) + diff --git a/src/Graphics/Rasterific/MiniLens.hs b/src/Graphics/Rasterific/MiniLens.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/MiniLens.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE RankNTypes #-} +module Graphics.Rasterific.MiniLens + ( -- * Types + Lens + , Lens' + , Traversal + , Traversal' + + -- * Getter + , (.^) + , use + + -- * Setter + , (.~) + , (.=) + , (%=) + , (+=) + ) where + +import Control.Monad.Identity +import Control.Applicative +import Control.Monad.State as State + +infixl 8 .^ +infixr 4 .~ +infix 4 .=,%=,+= + +-- | Does it look familiar? yes it's the official +-- Lens type. +type Lens s t a b = + forall f. Functor f => (a -> f b) -> s -> f t + +-- | Try to match the Lens' type alias. +type Lens' s a = Lens s s a a + +-- | Traversal type, matched to the one of the lens +-- package. +type Traversal s t a b = + forall f. Applicative f => (a -> f b) -> s -> f t + +type Traversal' s a = Traversal s s a a + + +(.^) :: s -> Lens s t a b -> a +{-# INLINE (.^) #-} +(.^) v l = getConst (l Const v) + +(.~) :: s -> Lens' s a -> a -> s +{-# INLINE (.~) #-} +(.~) v l new = runIdentity $ l (\_ -> Identity new) v + +(.=) :: MonadState s m => Lens' s a -> a -> m () +{-# INLINE (.=) #-} +(.=) l v = State.modify $ \s -> (s .~ l) v + +(%=) :: MonadState s m => Lens' s a -> (a -> a) -> m () +{-# INLINE (%=) #-} +(%=) l f = State.modify $ \s -> (s .~ l) $ f (s .^ l) + +(+=) :: (Num a, MonadState s m) => Lens' s a -> a -> m () +{-# INLINE (+=) #-} +(+=) l n = l %= (+ n) + +use :: MonadState s m => Lens s t a b -> m a +{-# INLINE use #-} +use l = State.gets (.^ l) + 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 @@ -2,8 +2,9 @@ -- | Module providing basic helper functions to help -- build vector/point calculations. module Graphics.Rasterific.Operators - ( -- * Lifted operators - (^&&^) + ( Point + -- * Lifted operators + , (^&&^) , (^||^) , (^==^) , (^/=^) @@ -42,11 +43,12 @@ , normalize ) -import Graphics.Rasterific.Types - infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ infixr 3 ^&&^ infixr 2 ^||^ + +-- | Represent a point +type Point = V2 Float -- | Pairwise boolean and operator (^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool 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,291 +1,297 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} --- | Module handling math regarding the handling of quadratic --- and cubic bezier curve. -module Graphics.Rasterific.QuadraticBezier - ( -- * Helper functions - straightLine - , bezierFromPath - , decomposeBeziers - , clipBezier - , sanitizeBezier - , offsetBezier - , flattenBezier - , bezierBreakAt - , bezierLengthApproximation - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( Monoid( mempty ) ) -#endif -import Graphics.Rasterific.Linear - ( V2( .. ) - , (^-^) - , (^+^) - , (^*) - , dot - , norm - , lerp - ) - -import Data.Monoid( (<>) ) -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types - --- | Create a list of bezier patch from a list of points, --- --- > bezierFromPath [a, b, c, d, e] == [Bezier a b c, Bezier c d e] --- > bezierFromPath [a, b, c, d, e, f] == [Bezier a b c, Bezier c d e] --- > bezierFromPath [a, b, c, d, e, f, g] == --- > [Bezier a b c, Bezier c d e, Bezier e f g] --- -bezierFromPath :: [Point] -> [Bezier] -bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest -bezierFromPath _ = [] - --- | Only work if the quadratic bezier curve --- is nearly flat -bezierLengthApproximation :: Bezier -> Float -bezierLengthApproximation (Bezier a _ c) = - norm $ c ^-^ a - -decomposeBeziers :: Bezier -> Producer EdgeSample -decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) = - go aRx aRy bRx bRy cRx cRy where - go ax ay _bx _by cx cy cont - | insideX && insideY = - let !px = fromIntegral $ min floorAx floorCx - !py = fromIntegral $ min floorAy floorCy - !w = px + 1 - cx `middle` ax - !h = cy - ay - in - EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont - where - floorAx, floorAy :: Int - !floorAx = floor ax - !floorAy = floor ay - - !floorCx = floor cx - !floorCy = floor cy - - !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int) - !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int) - - - go !ax !ay !bx !by !cx !cy cont = - go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont - where - !abx = ax `middle` bx - !aby = ay `middle` by - - !bcx = bx `middle` cx - !bcy = by `middle` cy - - !abbcx = abx `middle` bcx - !abbcy = aby `middle` bcy - - !mx | abs (abbcx - mini) < 0.1 = mini - | abs (abbcx - maxi) < 0.1 = maxi - | otherwise = abbcx - where !mini = fromIntegral (floor abbcx :: Int) - !maxi = fromIntegral (ceiling abbcx :: Int) - - !my | abs (abbcy - mini) < 0.1 = mini - | abs (abbcy - maxi) < 0.1 = maxi - | otherwise = abbcy - where !mini = fromIntegral (floor abbcy :: Int) - !maxi = fromIntegral (ceiling abbcy :: Int) - - --- | Create a quadratic bezier curve representing --- a straight line. -straightLine :: Point -> Point -> Bezier -straightLine a c = Bezier a (a `midPoint` c) c - --- | Clamp the bezier curve inside a rectangle --- given in parameter. -clipBezier :: Point -- ^ Point representing the "minimal" point for cliping - -> Point -- ^ Point representing the "maximal" point for cliping - -> Bezier -- ^ The quadratic bezier curve to be clamped - -> Container Primitive -clipBezier mini maxi bezier@(Bezier a b c) - -- If we are in the range bound, return the curve - -- unaltered - | insideX && insideY = pure $ BezierPrim bezier - -- If one of the component is outside, clamp - -- the components on the boundaries and output a - -- straight line on this boundary. Useful for the - -- filing case, to clamp the polygon drawing on - -- the edge - | outsideX || outsideY = - pure . BezierPrim $ clampedA `straightLine` clampedC - -- Not completly inside nor outside, just divide - -- and conquer. - | otherwise = - recurse (Bezier a ab m) <> - recurse (Bezier m bc c) - where -- Minimal & maximal dimension of the bezier curve - bmin = vmin a $ vmin b c - bmax = vmax a $ vmax b c - - recurse = clipBezier mini maxi - - clamper = clampPoint mini maxi - clampedA = clamper a - clampedC = clamper c - - V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi - V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin - - -- - -- X B - -- / \ - -- / \ - -- ab X--X--X bc - -- / abbc \ - -- / \ - -- A X X C - -- - (ab, bc, abbc) = splitBezier bezier - - -- mini - -- +-------------+ - -- | | - -- | | - -- | | - -- +-------------+ - -- maxi - -- the edgeSeparator vector encode which edge - -- is te nearest to the midpoint. - -- if True then it's the 'min' edges which are - -- the nearest, otherwise it's the maximum edge - edgeSeparator = - vabs (abbc ^-^ mini) ^<^ vabs (abbc ^-^ maxi) - - -- So here we 'solidify' the nearest edge position - -- in an edge vector. - edge = vpartition edgeSeparator mini maxi - - -- If we're near an edge, snap the component to the - -- edge. - m = vpartition (vabs (abbc ^-^ edge) ^< 0.1) edge abbc - - --- | Rewrite the bezier curve to avoid degenerate cases. -sanitizeBezier :: Bezier -> Container Primitive -sanitizeBezier bezier@(Bezier a b c) - -- If the two normals vector are far apart (cos nearly -1) - -- - -- u v - -- <---------- ------------> - -- because u dot v = ||u|| * ||v|| * cos(uv) - -- - -- This imply that AB and BC are nearly parallel - | u `dot` v < -0.9999 = - -- divide in to halves with - sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <> - sanitizeBezier (Bezier abbc (abbc `midPoint` c) c) - - -- b is far enough of b and c, (it's not a point) - | a `isDistingableFrom` b && b `isDistingableFrom` c = - pure . BezierPrim $ bezier - - -- if b is to nearby a or c, take the midpoint as new reference. - | ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c) - | otherwise = mempty - where u = a `normal` b - v = b `normal` c - ac = a `midPoint` c - abbc = (a `midPoint` b) `midPoint` (b `midPoint` c) - -bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier) -bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c) - where - -- X B - -- / \ - -- / \ - -- ab X--X--X bc - -- / abbc \ - -- / \ - -- A X X C - ab = lerp t a b - bc = lerp t b c - abbc = lerp t ab bc - -splitBezier :: Bezier -> (Point, Point, Point) -{-# INLINE splitBezier #-} -splitBezier (Bezier a b c) = (ab, bc, abbc) - where - -- - -- X B - -- / \ - -- / \ - -- ab X--X--X bc - -- / abbc \ - -- / \ - -- A X X C - -- - ab = a `midPoint` b - bc = b `midPoint` c - abbc = ab `midPoint` bc - -flattenBezier :: Bezier -> Container Primitive -flattenBezier bezier@(Bezier a b c) - -- If the spline is not too curvy, just return the - -- shifted component - | u `dot` v >= 0.9 = pure $ BezierPrim bezier - -- Otherwise, divide and conquer - | a /= b && b /= c = - flattenBezier (Bezier a ab abbc) <> - flattenBezier (Bezier abbc bc c) - | otherwise = mempty - where -- - -- X B - -- ^ /^\ ^ - -- u \ /w| \ / v - -- X-----X - -- / \ - -- / \ - -- A X X C - -- - u = a `normal` b - v = b `normal` c - - (ab, bc, abbc) = splitBezier bezier - --- | Move the bezier to a new position with an offset. -offsetBezier :: Float -> Bezier -> Container Primitive -offsetBezier offset bezier@(Bezier a b c) - -- If the spline is not too curvy, just return the - -- shifted component - | u `dot` v >= 0.9 = - pure . BezierPrim $ Bezier shiftedA mergedB shiftedC - -- Otherwise, divide and conquer - | a /= b && b /= c = - offsetBezier offset (Bezier a ab abbc) <> - offsetBezier offset (Bezier abbc bc c) - | otherwise = mempty - where -- - -- X B - -- ^ /^\ ^ - -- u \ /w| \ / v - -- X-----X - -- / \ - -- / \ - -- A X X C - -- - u = a `normal` b - v = b `normal` c - w = ab `normal` bc - - (ab, bc, abbc) = splitBezier bezier - - shiftedA = a ^+^ (u ^* offset) - shiftedC = c ^+^ (v ^* offset) - shiftedABBC = abbc ^+^ (w ^* offset) - mergedB = - (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC) - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +-- | Module handling math regarding the handling of quadratic +-- and cubic bezier curve. +module Graphics.Rasterific.QuadraticBezier + ( -- * Helper functions + straightLine + , bezierFromPath + , decomposeBeziers + , clipBezier + , sanitizeBezier + , offsetBezier + , flattenBezier + , bezierBreakAt + , bezierLengthApproximation + , isBezierPoint + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure ) +import Data.Monoid( Monoid( mempty ) ) +#endif +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , dot + , norm + , lerp + ) + +import Data.Monoid( (<>) ) +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types + +-- | Create a list of bezier patch from a list of points, +-- +-- > bezierFromPath [a, b, c, d, e] == [Bezier a b c, Bezier c d e] +-- > bezierFromPath [a, b, c, d, e, f] == [Bezier a b c, Bezier c d e] +-- > bezierFromPath [a, b, c, d, e, f, g] == +-- > [Bezier a b c, Bezier c d e, Bezier e f g] +-- +bezierFromPath :: [Point] -> [Bezier] +bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest +bezierFromPath _ = [] + +isBezierPoint :: Bezier -> Bool +isBezierPoint (Bezier a b c) = + not $ a `isDistingableFrom` b || + b `isDistingableFrom` c + +-- | Only work if the quadratic bezier curve +-- is nearly flat +bezierLengthApproximation :: Bezier -> Float +bezierLengthApproximation (Bezier a _ c) = + norm $ c ^-^ a + +decomposeBeziers :: Bezier -> Producer EdgeSample +decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) = + go aRx aRy bRx bRy cRx cRy where + go ax ay _bx _by cx cy cont + | insideX && insideY = + let !px = fromIntegral $ min floorAx floorCx + !py = fromIntegral $ min floorAy floorCy + !w = px + 1 - cx `middle` ax + !h = cy - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont + where + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay + + !floorCx = floor cx + !floorCy = floor cy + + !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int) + !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int) + + + go !ax !ay !bx !by !cx !cy cont = + go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont + where + !abx = ax `middle` bx + !aby = ay `middle` by + + !bcx = bx `middle` cx + !bcy = by `middle` cy + + !abbcx = abx `middle` bcx + !abbcy = aby `middle` bcy + + !mx | abs (abbcx - mini) < 0.1 = mini + | abs (abbcx - maxi) < 0.1 = maxi + | otherwise = abbcx + where !mini = fromIntegral (floor abbcx :: Int) + !maxi = fromIntegral (ceiling abbcx :: Int) + + !my | abs (abbcy - mini) < 0.1 = mini + | abs (abbcy - maxi) < 0.1 = maxi + | otherwise = abbcy + where !mini = fromIntegral (floor abbcy :: Int) + !maxi = fromIntegral (ceiling abbcy :: Int) + + +-- | Create a quadratic bezier curve representing +-- a straight line. +straightLine :: Point -> Point -> Bezier +straightLine a c = Bezier a (a `midPoint` c) c + +-- | Clamp the bezier curve inside a rectangle +-- given in parameter. +clipBezier :: Point -- ^ Point representing the "minimal" point for cliping + -> Point -- ^ Point representing the "maximal" point for cliping + -> Bezier -- ^ The quadratic bezier curve to be clamped + -> Container Primitive +clipBezier mini maxi bezier@(Bezier a b c) + -- If we are in the range bound, return the curve + -- unaltered + | insideX && insideY = pure $ BezierPrim bezier + -- If one of the component is outside, clamp + -- the components on the boundaries and output a + -- straight line on this boundary. Useful for the + -- filing case, to clamp the polygon drawing on + -- the edge + | outsideX || outsideY = + pure . BezierPrim $ clampedA `straightLine` clampedC + -- Not completly inside nor outside, just divide + -- and conquer. + | otherwise = + recurse (Bezier a ab m) <> + recurse (Bezier m bc c) + where -- Minimal & maximal dimension of the bezier curve + bmin = vmin a $ vmin b c + bmax = vmax a $ vmax b c + + recurse = clipBezier mini maxi + + clamper = clampPoint mini maxi + clampedA = clamper a + clampedC = clamper c + + V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi + V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin + + -- + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + -- + (ab, bc, abbc) = splitBezier bezier + + -- mini + -- +-------------+ + -- | | + -- | | + -- | | + -- +-------------+ + -- maxi + -- the edgeSeparator vector encode which edge + -- is te nearest to the midpoint. + -- if True then it's the 'min' edges which are + -- the nearest, otherwise it's the maximum edge + edgeSeparator = + vabs (abbc ^-^ mini) ^<^ vabs (abbc ^-^ maxi) + + -- So here we 'solidify' the nearest edge position + -- in an edge vector. + edge = vpartition edgeSeparator mini maxi + + -- If we're near an edge, snap the component to the + -- edge. + m = vpartition (vabs (abbc ^-^ edge) ^< 0.1) edge abbc + + +-- | Rewrite the bezier curve to avoid degenerate cases. +sanitizeBezier :: Bezier -> Container Primitive +sanitizeBezier bezier@(Bezier a b c) + -- If the two normals vector are far apart (cos nearly -1) + -- + -- u v + -- <---------- ------------> + -- because u dot v = ||u|| * ||v|| * cos(uv) + -- + -- This imply that AB and BC are nearly parallel + | u `dot` v < -0.9999 = + -- divide in to halves with + sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <> + sanitizeBezier (Bezier abbc (abbc `midPoint` c) c) + + -- b is far enough of b and c, (it's not a point) + | a `isDistingableFrom` b && b `isDistingableFrom` c = + pure . BezierPrim $ bezier + + -- if b is to nearby a or c, take the midpoint as new reference. + | ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c) + | otherwise = mempty + where u = a `normal` b + v = b `normal` c + ac = a `midPoint` c + abbc = (a `midPoint` b) `midPoint` (b `midPoint` c) + +bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier) +bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c) + where + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + ab = lerp t a b + bc = lerp t b c + abbc = lerp t ab bc + +splitBezier :: Bezier -> (Point, Point, Point) +{-# INLINE splitBezier #-} +splitBezier (Bezier a b c) = (ab, bc, abbc) + where + -- + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + -- + ab = a `midPoint` b + bc = b `midPoint` c + abbc = ab `midPoint` bc + +flattenBezier :: Bezier -> Container Primitive +flattenBezier bezier@(Bezier a b c) + -- If the spline is not too curvy, just return the + -- shifted component + | u `dot` v >= 0.9 = pure $ BezierPrim bezier + -- Otherwise, divide and conquer + | a /= b && b /= c = + flattenBezier (Bezier a ab abbc) <> + flattenBezier (Bezier abbc bc c) + | otherwise = mempty + where -- + -- X B + -- ^ /^\ ^ + -- u \ /w| \ / v + -- X-----X + -- / \ + -- / \ + -- A X X C + -- + u = a `normal` b + v = b `normal` c + + (ab, bc, abbc) = splitBezier bezier + +-- | Move the bezier to a new position with an offset. +offsetBezier :: Float -> Bezier -> Container Primitive +offsetBezier offset bezier@(Bezier a b c) + -- If the spline is not too curvy, just return the + -- shifted component + | u `dot` v >= 0.9 = + pure . BezierPrim $ Bezier shiftedA mergedB shiftedC + -- Otherwise, divide and conquer + | a /= b && b /= c = + offsetBezier offset (Bezier a ab abbc) <> + offsetBezier offset (Bezier abbc bc c) + | otherwise = mempty + where -- + -- X B + -- ^ /^\ ^ + -- u \ /w| \ / v + -- X-----X + -- / \ + -- / \ + -- A X X C + -- + u = a `normal` b + v = b `normal` c + w = ab `normal` bc + + (ab, bc, abbc) = splitBezier bezier + + shiftedA = a ^+^ (u ^* offset) + shiftedC = c ^+^ (v ^* offset) + shiftedABBC = abbc ^+^ (w ^* offset) + mergedB = + (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC) + diff --git a/src/Graphics/Rasterific/QuadraticFormula.hs b/src/Graphics/Rasterific/QuadraticFormula.hs --- a/src/Graphics/Rasterific/QuadraticFormula.hs +++ b/src/Graphics/Rasterific/QuadraticFormula.hs @@ -1,56 +1,54 @@ -{-# LANGUAGE CPP #-} -module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. ) - , discriminant - , formulaRoots - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( Applicative( .. ) ) -#endif - --- | 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) - +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. ) + , discriminant + , formulaRoots + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( Applicative( .. ) ) +#endif + +-- | 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/Shading.hs b/src/Graphics/Rasterific/Shading.hs --- a/src/Graphics/Rasterific/Shading.hs +++ b/src/Graphics/Rasterific/Shading.hs @@ -3,14 +3,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} -module Graphics.Rasterific.Shading - ( Texture( .. ) - , Gradient - , ShaderFunction - , ImageTransformer - , transformTextureToFiller - , dumpTexture - ) where +module Graphics.Rasterific.Shading( transformTextureToFiller ) where import Control.Monad.Primitive( PrimState -- one day (GHC >= 7.10 ?) @@ -18,6 +11,7 @@ ) import Data.Fixed( mod' ) import Data.Monoid( (<>) ) +import Graphics.Rasterific.Command import Graphics.Rasterific.Linear ( V2( .. ) , (^-^) @@ -51,48 +45,7 @@ , RenderablePixel , compositionAlpha ) -type ShaderFunction px = Float -> Float -> px -type ImageTransformer px = Int -> Int -> px -> px - --- | Reification of texture type -data Texture px - = SolidTexture !px - | LinearGradientTexture !(Gradient px) !Line - | RadialGradientTexture !(Gradient px) !Point !Float - | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point - | WithSampler !SamplerRepeat (Texture px) - | WithTextureTransform !Transformation (Texture px) - | SampledTexture !(Image px) - | RawTexture !(Image px) - | ShaderTexture !(ShaderFunction px) - | ModulateTexture (Texture px) (Texture (PixelBaseComponent px)) - -dumpTexture :: ( Show px - , Show (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ (PixelBaseComponent px) - ) => Texture px -> String -dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px++ ")" -dumpTexture (LinearGradientTexture grad (Line a b)) = - "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")" -dumpTexture (RadialGradientTexture grad p rad) = - "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad -dumpTexture (RadialGradientWithFocusTexture grad center rad focus) = - "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center - ++ ") " ++ show rad ++ " (" ++ show focus ++ ")" -dumpTexture (WithSampler sampler sub) = - "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")" -dumpTexture (WithTextureTransform trans sub) = - "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")" -dumpTexture (SampledTexture _) = "sampledImageTexture " -dumpTexture (RawTexture _) = "" -dumpTexture (ShaderTexture _) = "shaderFunction " -dumpTexture (ModulateTexture sub mask) = - "modulateTexture (" ++ dumpTexture sub ++ ") (" - ++ dumpTexture mask ++ ")" - - data TextureSpaceInfo = TextureSpaceInfo { _tsStart :: {-# UNPACK #-} !Point , _tsDelta :: {-# UNPACK #-} !Vector @@ -245,6 +198,8 @@ withTrans trans func shaderOfTexture trans _ (RawTexture img) = withTrans trans $ imageShader img +shaderOfTexture trans _sampling (PatternTexture _ _ _ _ img) = + shaderOfTexture trans SamplerRepeat $ SampledTexture img shaderOfTexture trans sampling (ModulateTexture texture modulation) = modulateTexture (shaderOfTexture trans sampling texture) (shaderOfTexture trans sampling modulation) @@ -267,15 +222,6 @@ \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 diff --git a/src/Graphics/Rasterific/StrokeInternal.hs b/src/Graphics/Rasterific/StrokeInternal.hs --- a/src/Graphics/Rasterific/StrokeInternal.hs +++ b/src/Graphics/Rasterific/StrokeInternal.hs @@ -6,6 +6,7 @@ , dashedStrokize , splitPrimitiveUntil , approximatePathLength + , isPrimitivePoint ) where #if !MIN_VERSION_base(4,8,0) @@ -45,6 +46,12 @@ firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b) firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) +isPrimitivePoint :: Primitive -> Bool +isPrimitivePoint p = case p of + LinePrim l -> isLinePoint l + BezierPrim b -> isBezierPoint b + CubicBezierPrim c -> isCubicBezierPoint c + reversePrimitive :: Primitive -> Primitive reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a) reversePrimitive (BezierPrim (Bezier a b c)) = @@ -125,7 +132,7 @@ -> Container Primitive miterJoin offset l point u v | uDotW > l / max 1 l && uDotW > 0.01 = - pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) + pure (a `lineFromTo` m) <> pure (m `lineFromTo` c) -- A simple straight junction | otherwise = pure $ a `lineFromTo` c where -- X m @@ -172,10 +179,10 @@ (firstPoint, _) = firstPointAndNormal firstShape go prev [] - | firstPoint `isNearby` lastPoint prev = joiner prev firstShape <> offseter prev + | firstPoint `isNearby` lastPoint prev = offseter prev <> joiner prev firstShape | otherwise = offseter prev <> cap offset caping prev go prev (x:xs) = - joiner prev x <> offseter prev <> go x xs + offseter prev <> joiner prev x <> go x xs approximateLength :: Primitive -> Float approximateLength (LinePrim l) = lineLength l @@ -191,12 +198,12 @@ strokize :: Geometry geom => StrokeWidth -> Join -> (Cap, Cap) -> geom -> Container Primitive -strokize width join (capStart, capEnd) geom = - offseter capEnd sanitized <> - offseter capStart (reverse $ reversePrimitive <$> sanitized) +strokize width join (capStart, capEnd) geom = foldMap pathOffseter sanitized where - sanitized = foldMap (listOfContainer . sanitize) $ toPrimitives geom - offseter = offsetAndJoin (width / 2) join + sanitized = foldMap (listOfContainer . sanitize) <$> resplit (toPrimitives geom) + offseter = offsetAndJoin (width / 2) join + pathOffseter v = + offseter capEnd v <> offseter capStart (reverse $ reversePrimitive <$> v) flattenPrimitive :: Primitive -> Container Primitive flattenPrimitive (BezierPrim bezier) = flattenBezier bezier 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 @@ -1,147 +1,173 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Module describing the various filling method of the --- geometric primitives. --- --- All points coordinate given in this module are expressed --- final image pixel coordinates. -module Graphics.Rasterific.Texture - ( Texture - , Gradient - , withSampler - , uniformTexture - -- * Texture kind - , linearGradientTexture - , radialGradientTexture - , radialGradientWithFocusTexture - , sampledImageTexture - - -- * Texture manipulation - , modulateTexture - , transformTexture - ) where - - -import Codec.Picture.Types( Pixel( .. ) - , Image( .. ) - ) -import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ), Line( .. ) ) -import Graphics.Rasterific.Shading -import Graphics.Rasterific.Transformations - --- | Set the repeat pattern of the texture (if any). --- With padding: --- --- > withTexture (sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- --- With repeat: --- --- > withTexture (withSampler SamplerRepeat $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- --- With reflect: --- --- > withTexture (withSampler SamplerReflect $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- -withSampler :: SamplerRepeat -> Texture px -> Texture px -withSampler = WithSampler - --- | Transform the coordinates used for texture before applying --- it, allow interesting transformations. --- --- > withTexture (withSampler SamplerRepeat $ --- > transformTexture (rotateCenter 1 (V2 0 0) <> --- > scale 0.5 0.25) --- > $ sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- -transformTexture :: Transformation -> Texture px -> Texture px -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 = SolidTexture - --- | Linear gradient texture. --- --- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) --- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) --- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in --- > withTexture (linearGradientTexture SamplerPad gradDef --- > (V2 40 40) (V2 130 130)) $ --- > fill $ circle (V2 100 100) 100 --- --- <> --- -linearGradientTexture :: Gradient px -- ^ Gradient description. - -> Point -- ^ Linear gradient start point. - -> Point -- ^ Linear gradient end point. - -> Texture px -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 :: 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 gradDef --- > (V2 100 100) 75) $ --- > fill $ circle (V2 100 100) 100 --- --- <> --- -radialGradientTexture :: Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Texture px -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 gradDef --- > (V2 100 100) 75 (V2 70 70) ) $ --- > fill $ circle (V2 100 100) 100 --- --- <> --- -radialGradientWithFocusTexture - :: Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Point -- ^ Radial gradient focus point - -> Texture px -radialGradientWithFocusTexture = RadialGradientWithFocusTexture - --- | Perform a multiplication operation between a full color texture --- and a greyscale one, used for clip-path implementation. -modulateTexture :: (Pixel px) - => Texture px -- ^ The full blown texture. - -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. - -> Texture px -- ^ The resulting texture. -modulateTexture = ModulateTexture - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +-- | Module describing the various filling method of the +-- geometric primitives. +-- +-- All points coordinate given in this module are expressed +-- final image pixel coordinates. +module Graphics.Rasterific.Texture + ( Texture + , Gradient + , withSampler + , uniformTexture + -- * Texture kind + , linearGradientTexture + , radialGradientTexture + , radialGradientWithFocusTexture + , sampledImageTexture + , patternTexture + + -- * Texture manipulation + , modulateTexture + , transformTexture + ) where + + +import Codec.Picture.Types( Pixel( .. ), Image( .. ) ) +import Graphics.Text.TrueType( Dpi ) +import Graphics.Rasterific +import Graphics.Rasterific.Command +import Graphics.Rasterific.Transformations + +-- | Set the repeat pattern of the texture (if any). +-- With padding: +-- +-- > withTexture (sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +-- With repeat: +-- +-- > withTexture (withSampler SamplerRepeat $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +-- With reflect: +-- +-- > withTexture (withSampler SamplerReflect $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +withSampler :: SamplerRepeat -> Texture px -> Texture px +withSampler = WithSampler + +-- | Transform the coordinates used for texture before applying +-- it, allow interesting transformations. +-- +-- > withTexture (withSampler SamplerRepeat $ +-- > transformTexture (rotateCenter 1 (V2 0 0) <> +-- > scale 0.5 0.25) +-- > $ sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +transformTexture :: Transformation -> Texture px -> Texture px +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 = SolidTexture + +-- | Linear gradient texture. +-- +-- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) +-- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) +-- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in +-- > withTexture (linearGradientTexture SamplerPad gradDef +-- > (V2 40 40) (V2 130 130)) $ +-- > fill $ circle (V2 100 100) 100 +-- +-- <> +-- +linearGradientTexture :: Gradient px -- ^ Gradient description. + -> Point -- ^ Linear gradient start point. + -> Point -- ^ Linear gradient end point. + -> Texture px +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 :: 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 gradDef +-- > (V2 100 100) 75) $ +-- > fill $ circle (V2 100 100) 100 +-- +-- <> +-- +radialGradientTexture :: Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Texture px +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 gradDef +-- > (V2 100 100) 75 (V2 70 70) ) $ +-- > fill $ circle (V2 100 100) 100 +-- +-- <> +-- +radialGradientWithFocusTexture + :: Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Point -- ^ Radial gradient focus point + -> Texture px +radialGradientWithFocusTexture = RadialGradientWithFocusTexture + +-- | Perform a multiplication operation between a full color texture +-- and a greyscale one, used for clip-path implementation. +modulateTexture :: (Pixel px) + => Texture px -- ^ The full blown texture. + -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. + -> Texture px -- ^ The resulting texture. +modulateTexture = ModulateTexture + + +-- | Use a drawing as a repeating background pattern. +-- +-- > let pattern = +-- > patternTexture 40 40 96 (PixelRGBA8 0xFF 0x53 0x73 255) . +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ +-- > fill $ circle (V2 20 20) 13 +-- > in +-- > withTexture pattern $ +-- > fill $ roundedRectangle (V2 20 20) 160 160 20 20 +-- +-- <> +-- +patternTexture :: RenderablePixel px + => Int -- ^ Width + -> Int -- ^ Height + -> Dpi -- ^ Dpi if text is present in pattern + -> px -- ^ Pattern background color + -> Drawing px () -- ^ Drawing defining the pattern + -> Texture px +patternTexture w h dpi back drawing = + PatternTexture w h back drawing $ + renderDrawingAtDpi w h dpi back drawing + 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 @@ -1,551 +1,560 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE CPP #-} --- | Gather all the types used in the rasterization engine. -module Graphics.Rasterific.Types - ( -- * Geometry description - Vector - , Point - , Line( .. ) - , Bezier( .. ) - , CubicBezier( .. ) - , Primitive( .. ) - - , Primitivable( .. ) - , Geometry( .. ) - - , Producer - , Container - , containerOfList - , listOfContainer - , containerOfFunction - , PathCommand( .. ) - , Path( .. ) - , Transformable( .. ) - , PointFoldable( .. ) - - -- * Rasterization control types - , Cap( .. ) - , Join( .. ) - , FillMethod( .. ) - , SamplerRepeat( .. ) - , DashPattern - , StrokeWidth - - -- * Internal type - , EdgeSample( .. ) - , pathToPrimitives - - -- * Little geometry helpers - , firstTangeantOf - , lastTangeantOf - , firstPointOf - , lastPointOf - - ) where - -import Data.DList( DList, fromList ) - -#if !MIN_VERSION_base(4,8,0) -import Data.Foldable( Foldable ) -#endif -import Data.Foldable( foldl', toList ) -import qualified Data.Foldable as F -import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero ) - -import Foreign.Ptr( castPtr ) -import Foreign.Storable( Storable( sizeOf - , alignment - , peek - , poke - , peekElemOff - , pokeElemOff ) ) - --- | Represent a vector -type Vector = V2 Float - --- | Represent a point -type Point = V2 Float - --- | Type alias just to get more meaningful --- type signatures -type StrokeWidth = Float - --- | Dash pattern to use -type DashPattern = [Float] - --- | Describe how we will "finish" the stroking --- that don't loop. -data Cap - -- | Create a straight caping on the stroke. - -- Cap value should be positive and represent - -- the distance from the end of curve to the actual cap - -- - -- * cap straight with param 0 : <> - -- - -- * cap straight with param 1 : <> - -- - = CapStraight Float - - -- | Create a rounded caping on the stroke. - -- <> - | CapRound - deriving (Eq, Show) - --- | Describe how to display the join of broken lines --- while stroking. -data Join - -- | Make a curved join. - -- <> - = JoinRound - -- | Make a mitter join. Value must be positive or null. - -- Seems to make sense in [0;1] only - -- - -- * Miter join with 0 : <> - -- - -- * Miter join with 5 : <> - -- - | JoinMiter Float - deriving (Eq, Show) - --- | Tell how to fill complex shapes when there is self --- intersections. If the filling mode is not specified, --- then it's the `FillWinding` method which is used. --- --- The examples used are produced with the following --- function: --- --- --- > fillingSample :: FillMethod -> Drawing px () --- > fillingSample fillMethod = fillWithMethod fillMethod geometry where --- > geometry = transform (applyTransformation $ scale 0.35 0.4 --- > <> translate (V2 (-80) (-180))) --- > [ Path (V2 484 499) True --- > [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) --- > , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) --- > ] --- > , Path (V2 136 377) True --- > [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) --- > , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) --- > ] --- > , Path (V2 340 265) True --- > [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) --- > , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) --- > , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) --- > ] --- > ] -data FillMethod - -- | Also known as nonzero rule. - -- To determine if a point falls inside the curve, you draw - -- an imaginary line through that point. Next you will count - -- how many times that line crosses the curve before it reaches - -- that point. For every clockwise rotation, you subtract 1 and - -- for every counter-clockwise rotation you add 1. - -- - -- <> - = FillWinding - - -- | This rule determines the insideness of a point on - -- the canvas by drawing a ray from that point to infinity - -- in any direction and counting the number of path segments - -- from the given shape that the ray crosses. If this number - -- is odd, the point is inside; if even, the point is outside. - -- - -- <> - | FillEvenOdd - deriving (Eq, Enum, Show) - --- | Describe the behaviour of samplers and texturers --- when they are out of the bounds of image and/or gradient. -data SamplerRepeat - -- | Will clamp (ie. repeat the last pixel) when - -- out of bound - -- <> - = SamplerPad - -- | Will loop on it's definition domain - -- <> - | SamplerRepeat - -- | Will loop inverting axises - -- <> - | SamplerReflect - deriving (Eq, Enum, Show) - --- | Represent a raster line -data EdgeSample = EdgeSample - { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position - , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position - , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha - , _sampleH :: {-# UNPACK #-} !Float -- ^ Height - } - deriving Show - --- | Just to get faster sorting -instance Storable EdgeSample where - sizeOf _ = 4 * sizeOf (0 :: Float) - alignment = sizeOf - - {-# INLINE peek #-} - peek ptr = do - let q = castPtr ptr - sx <- peekElemOff q 0 - sy <- peekElemOff q 1 - sa <- peekElemOff q 2 - sh <- peekElemOff q 3 - return $ EdgeSample sx sy sa sh - - {-# INLINE poke #-} - poke ptr (EdgeSample sx sy sa sh) = do - let q = castPtr ptr - pokeElemOff q 0 sx - pokeElemOff q 1 sy - pokeElemOff q 2 sa - pokeElemOff q 3 sh - --- | This typeclass is there to help transform the geometry, --- by applying a transformation on every point of a geometric --- element. -class Transformable a where - -- | Apply a transformation function for every - -- point in the element. - transform :: (Point -> Point) -> a -> a - --- | Typeclass helper gathering all the points of a given --- geometry. -class PointFoldable a where - -- | Fold an accumulator on all the points of - -- the primitive. - foldPoints :: (b -> Point -> b) -> b -> a -> b - --- | Just apply the function -instance Transformable Point where - {-# INLINE transform #-} - transform f = f - --- | Just apply the function -instance PointFoldable Point where - {-# INLINE foldPoints #-} - foldPoints f = f - --- | Describe a simple 2D line between two points. --- --- > fill [ Line (V2 10 10) (V2 190 10) --- > , Line (V2 190 10) (V2 95 170) --- > , Line (V2 95 170) (V2 10 10)] --- --- <> --- -data Line = Line - { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point - , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point - } - deriving Eq - -instance Show Line where - show (Line a b) = - "Line (" ++ show a ++ ") (" - ++ show b ++ ")" - -instance Transformable Line where - {-# INLINE transform #-} - transform f (Line a b) = Line (f a) $ f b - -instance PointFoldable Line where - {-# INLINE foldPoints #-} - foldPoints f acc (Line a b) = f (f acc b) a - --- | Describe a quadratic bezier spline, described --- using 3 points. --- --- > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100) --- > ,Bezier (V2 200 100) (V2 150 200) (V2 120 175) --- > ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)] --- --- <> --- -data Bezier = Bezier - { -- | Origin points, the spline will pass through it. - _bezierX0 :: {-# UNPACK #-} !Point - -- | Control point, the spline won't pass on it. - , _bezierX1 :: {-# UNPACK #-} !Point - -- | End point, the spline will pass through it. - , _bezierX2 :: {-# UNPACK #-} !Point - } - deriving Eq - -instance Show Bezier where - show (Bezier a b c) = - "Bezier (" ++ show a ++ ") (" - ++ show b ++ ") (" - ++ show c ++ ")" - -instance Transformable Bezier where - {-# INLINE transform #-} - transform f (Bezier a b c) = Bezier (f a) (f b) $ f c - -instance PointFoldable Bezier where - {-# INLINE foldPoints #-} - foldPoints f acc (Bezier a b c) = - foldl' f acc [a, b, c] - --- | Describe a cubic bezier spline, described --- using 4 points. --- --- > stroke 4 JoinRound (CapRound, CapRound) $ --- > CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35) --- --- <> --- -data CubicBezier = CubicBezier - { -- | Origin point, the spline will pass through it. - _cBezierX0 :: {-# UNPACK #-} !Point - -- | First control point of the cubic bezier curve. - , _cBezierX1 :: {-# UNPACK #-} !Point - -- | Second control point of the cubic bezier curve. - , _cBezierX2 :: {-# UNPACK #-} !Point - -- | End point of the cubic bezier curve - , _cBezierX3 :: {-# UNPACK #-} !Point - } - deriving Eq - -instance Show CubicBezier where - show (CubicBezier a b c d) = - "CubicBezier (" ++ show a ++ ") (" - ++ show b ++ ") (" - ++ show c ++ ") (" - ++ show d ++ ")" - -instance Transformable CubicBezier where - {-# INLINE transform #-} - transform f (CubicBezier a b c d) = - CubicBezier (f a) (f b) (f c) $ f d - -instance PointFoldable CubicBezier where - {-# INLINE foldPoints #-} - foldPoints f acc (CubicBezier a b c d) = - foldl' f acc [a, b, c, d] - --- | This datatype gather all the renderable primitives, --- they are kept separated otherwise to allow specialization --- on some specific algorithms. You can mix the different --- primitives in a single call : --- --- > fill [ toPrim $ CubicBezier (V2 50 20) (V2 90 60) --- > (V2 5 100) (V2 50 140) --- > , toPrim $ Line (V2 50 140) (V2 120 80) --- > , toPrim $ Line (V2 120 80) (V2 50 20) ] --- --- <> --- -data Primitive - = LinePrim !Line -- ^ Primitive used for lines - | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves - | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve - deriving (Eq, Show) - --- | Generalizing constructors of the `Primitive` type to work --- generically. -class Primitivable a where - toPrim :: a -> Primitive - --- | @toPrim = id@ -instance Primitivable Primitive where toPrim = id - --- | @toPrim = LinePrim@ -instance Primitivable Line where toPrim = LinePrim - --- | @toPrim = BezierPrim@ -instance Primitivable Bezier where toPrim = BezierPrim - --- | @toPrim = CubicBezierPrim@ -instance Primitivable CubicBezier where toPrim = CubicBezierPrim - --- | All the rasterization works on lists of primitives, --- in order to ease the use of the library, the Geometry --- type class provides conversion facility, which help --- generalising the geometry definition and avoid applying --- Primitive constructor. --- --- Also streamline the Path conversion. -class Geometry a where - -- | Convert an element to a list of primitives - -- to be rendered. - toPrimitives :: a -> [Primitive] - - -- | Helper method to avoid overlaping instances. - -- You shouldn't use it directly. - listToPrims :: (Foldable f) => f a -> [Primitive] - {-# INLINE listToPrims #-} - listToPrims = F.concatMap toPrimitives . F.toList - -instance Geometry Path where - {-# INLINE toPrimitives #-} - toPrimitives = pathToPrimitives - -instance Geometry Primitive where - toPrimitives e = [e] - {-# INLINE listToPrims #-} - listToPrims = F.toList -- Open question, is it optimised as `id`? - -instance Geometry Line where - {-# INLINE toPrimitives #-} - toPrimitives e = [toPrim e] - -instance Geometry Bezier where - {-# INLINE toPrimitives #-} - toPrimitives e = [toPrim e] - -instance Geometry CubicBezier where - {-# INLINE toPrimitives #-} - toPrimitives e = [toPrim e] - --- | Generalize the geometry to any foldable container, --- so you can throw any container to the the 'fill' or --- 'stroke' function. -instance (Foldable f, Geometry a) => Geometry (f a) where - {-# INLINE toPrimitives #-} - toPrimitives = listToPrims - - -instance Transformable Primitive where - {-# INLINE transform #-} - transform f (LinePrim l) = LinePrim $ transform f l - transform f (BezierPrim b) = BezierPrim $ transform f b - transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c - -instance PointFoldable Primitive where - {-# INLINE foldPoints #-} - foldPoints f acc = go - where go (LinePrim l) = foldPoints f acc l - go (BezierPrim b) = foldPoints f acc b - go (CubicBezierPrim c) = foldPoints f acc c - -instance (Functor f, Transformable a) - => Transformable (f a) where - transform f = fmap (transform f) - -instance (Foldable f, PointFoldable a) - => PointFoldable (f a) where - foldPoints f = foldl' (foldPoints f) - -type Producer a = [a] -> [a] - -type Container a = DList a - -containerOfFunction :: ([a] -> [a]) -> Container a -containerOfFunction f = fromList $ f [] - -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 --- it for the next "move" --- For example the example from Primitive could be rewritten: --- --- > fill $ Path (V2 50 20) True --- > [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) --- > , PathLineTo (V2 120 80) ] --- --- <> --- -data Path = Path - { -- | Origin of the point, equivalent to the - -- first "move" command. - _pathOriginPoint :: Point - -- | Tell if we must close the path. - , _pathClose :: Bool - -- | List of commands in the path - , _pathCommand :: [PathCommand] - } - deriving (Eq, Show) - -instance Transformable Path where - {-# INLINE transform #-} - transform f (Path orig close rest) = - Path (f orig) close (transform f rest) - -instance PointFoldable Path where - {-# INLINE foldPoints #-} - foldPoints f acc (Path o _ rest) = - foldPoints f (f acc o) rest - --- | Actions to create a path -data PathCommand - = -- | Draw a line from the current point to another point - PathLineTo Point - -- | Draw a quadratic bezier curve from the current point - -- through the control point to the end point. - | PathQuadraticBezierCurveTo Point Point - - -- | Draw a cubic bezier curve using 2 control points. - | PathCubicBezierCurveTo Point Point Point - deriving (Eq, Show) - -instance Transformable PathCommand where - transform f (PathLineTo p) = PathLineTo $ f p - transform f (PathQuadraticBezierCurveTo p1 p2) = - PathQuadraticBezierCurveTo (f p1) $ f p2 - transform f (PathCubicBezierCurveTo p1 p2 p3) = - PathCubicBezierCurveTo (f p1) (f p2) $ f p3 - -instance PointFoldable PathCommand where - foldPoints f acc (PathLineTo p) = f acc p - foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) = - f (f acc p1) p2 - foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) = - foldl' f acc [p1, p2, p3] - --- | Transform a path description into a list of renderable --- primitives. -pathToPrimitives :: Path -> [Primitive] -pathToPrimitives (Path origin needClosing commands) = go origin commands - where - go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin] - go _ [] = [] - go prev (PathLineTo to : xs) = - LinePrim (Line prev to) : go to xs - go prev (PathQuadraticBezierCurveTo c1 to : xs) = - BezierPrim (Bezier prev c1 to) : go to xs - go prev (PathCubicBezierCurveTo c1 c2 to : xs) = - CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs - --- | Gives the orientation vector for the start of the --- primitive. -firstTangeantOf :: Primitive -> Vector -firstTangeantOf p = case p of - LinePrim (Line p0 p1) -> p1 ^-^ p0 - BezierPrim (Bezier p0 p1 p2) -> - (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) - CubicBezierPrim (CubicBezier p0 p1 p2 _) -> - (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) - where - ifBigEnough a b | nearZero a = b - | otherwise = a - --- | Gives the orientation vector at the end of the --- primitive. -lastTangeantOf :: Primitive -> Vector -lastTangeantOf p = case p of - LinePrim (Line p0 p1) -> p1 ^-^ p0 - BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1 - CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2 - --- | Extract the first point of the primitive. -firstPointOf :: Primitive -> Point -firstPointOf p = case p of - LinePrim (Line p0 _) -> p0 - BezierPrim (Bezier p0 _ _) -> p0 - CubicBezierPrim (CubicBezier p0 _ _ _) -> p0 - --- | Return the last point of a given primitive. -lastPointOf :: Primitive -> Point -lastPointOf p = case p of - LinePrim (Line _ p0) -> p0 - BezierPrim (Bezier _ _ p0) -> p0 - CubicBezierPrim (CubicBezier _ _ _ p0) -> p0 - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +-- | Gather all the types used in the rasterization engine. +module Graphics.Rasterific.Types + ( -- * Geometry description + Vector + , Point + , Line( .. ) + , Bezier( .. ) + , CubicBezier( .. ) + , Primitive( .. ) + + , Primitivable( .. ) + , Geometry( .. ) + + , Producer + , Container + , containerOfList + , listOfContainer + , containerOfFunction + , PathCommand( .. ) + , Path( .. ) + , Transformable( .. ) + , PointFoldable( .. ) + + -- * Rasterization control types + , Cap( .. ) + , Join( .. ) + , FillMethod( .. ) + , SamplerRepeat( .. ) + , DashPattern + , StrokeWidth + + -- * Internal type + , EdgeSample( .. ) + , pathToPrimitives + + -- * Little geometry helpers + , firstTangeantOf + , lastTangeantOf + , firstPointOf + , lastPointOf + , resplit + + -- * RankNType helper + , Proxy( Proxy ) + ) where + +import Data.DList( DList, fromList ) + +#if !MIN_VERSION_base(4,8,0) +import Data.Foldable( Foldable ) +#endif +import Data.Foldable( foldl', toList ) +import qualified Data.Foldable as F +import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero ) +import Graphics.Rasterific.Operators +import Foreign.Ptr( castPtr ) +import Foreign.Storable( Storable( sizeOf + , alignment + , peek + , poke + , peekElemOff + , pokeElemOff ) ) + +-- | Represent a vector +type Vector = V2 Float + +-- | Type alias just to get more meaningful +-- type signatures +type StrokeWidth = Float + +-- | Dash pattern to use +type DashPattern = [Float] + +data Proxy p = Proxy + +-- | Describe how we will "finish" the stroking +-- that don't loop. +data Cap + -- | Create a straight caping on the stroke. + -- Cap value should be positive and represent + -- the distance from the end of curve to the actual cap + -- + -- * cap straight with param 0 : <> + -- + -- * cap straight with param 1 : <> + -- + = CapStraight Float + + -- | Create a rounded caping on the stroke. + -- <> + | CapRound + deriving (Eq, Show) + +-- | Describe how to display the join of broken lines +-- while stroking. +data Join + -- | Make a curved join. + -- <> + = JoinRound + -- | Make a mitter join. Value must be positive or null. + -- Seems to make sense in [0;1] only + -- + -- * Miter join with 0 : <> + -- + -- * Miter join with 5 : <> + -- + | JoinMiter Float + deriving (Eq, Show) + +-- | Tell how to fill complex shapes when there is self +-- intersections. If the filling mode is not specified, +-- then it's the `FillWinding` method which is used. +-- +-- The examples used are produced with the following +-- function: +-- +-- +-- > fillingSample :: FillMethod -> Drawing px () +-- > fillingSample fillMethod = fillWithMethod fillMethod geometry where +-- > geometry = transform (applyTransformation $ scale 0.35 0.4 +-- > <> translate (V2 (-80) (-180))) +-- > [ Path (V2 484 499) True +-- > [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) +-- > , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) +-- > ] +-- > , Path (V2 136 377) True +-- > [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) +-- > , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) +-- > ] +-- > , Path (V2 340 265) True +-- > [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) +-- > , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) +-- > , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) +-- > ] +-- > ] +data FillMethod + -- | Also known as nonzero rule. + -- To determine if a point falls inside the curve, you draw + -- an imaginary line through that point. Next you will count + -- how many times that line crosses the curve before it reaches + -- that point. For every clockwise rotation, you subtract 1 and + -- for every counter-clockwise rotation you add 1. + -- + -- <> + = FillWinding + + -- | This rule determines the insideness of a point on + -- the canvas by drawing a ray from that point to infinity + -- in any direction and counting the number of path segments + -- from the given shape that the ray crosses. If this number + -- is odd, the point is inside; if even, the point is outside. + -- + -- <> + | FillEvenOdd + deriving (Eq, Enum, Show) + +-- | Describe the behaviour of samplers and texturers +-- when they are out of the bounds of image and/or gradient. +data SamplerRepeat + -- | Will clamp (ie. repeat the last pixel) when + -- out of bound + -- <> + = SamplerPad + -- | Will loop on it's definition domain + -- <> + | SamplerRepeat + -- | Will loop inverting axises + -- <> + | SamplerReflect + deriving (Eq, Enum, Show) + +-- | Represent a raster line +data EdgeSample = EdgeSample + { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position + , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position + , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha + , _sampleH :: {-# UNPACK #-} !Float -- ^ Height + } + deriving Show + +-- | Just to get faster sorting +instance Storable EdgeSample where + sizeOf _ = 4 * sizeOf (0 :: Float) + alignment = sizeOf + + {-# INLINE peek #-} + peek ptr = do + let q = castPtr ptr + sx <- peekElemOff q 0 + sy <- peekElemOff q 1 + sa <- peekElemOff q 2 + sh <- peekElemOff q 3 + return $ EdgeSample sx sy sa sh + + {-# INLINE poke #-} + poke ptr (EdgeSample sx sy sa sh) = do + let q = castPtr ptr + pokeElemOff q 0 sx + pokeElemOff q 1 sy + pokeElemOff q 2 sa + pokeElemOff q 3 sh + +-- | This typeclass is there to help transform the geometry, +-- by applying a transformation on every point of a geometric +-- element. +class Transformable a where + -- | Apply a transformation function for every + -- point in the element. + transform :: (Point -> Point) -> a -> a + +-- | Typeclass helper gathering all the points of a given +-- geometry. +class PointFoldable a where + -- | Fold an accumulator on all the points of + -- the primitive. + foldPoints :: (b -> Point -> b) -> b -> a -> b + +-- | Just apply the function +instance Transformable Point where + {-# INLINE transform #-} + transform f = f + +-- | Just apply the function +instance PointFoldable Point where + {-# INLINE foldPoints #-} + foldPoints f = f + +-- | Describe a simple 2D line between two points. +-- +-- > fill [ Line (V2 10 10) (V2 190 10) +-- > , Line (V2 190 10) (V2 95 170) +-- > , Line (V2 95 170) (V2 10 10)] +-- +-- <> +-- +data Line = Line + { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point + , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point + } + deriving Eq + +instance Show Line where + show (Line a b) = + "Line (" ++ show a ++ ") (" + ++ show b ++ ")" + +instance Transformable Line where + {-# INLINE transform #-} + transform f (Line a b) = Line (f a) $ f b + +instance PointFoldable Line where + {-# INLINE foldPoints #-} + foldPoints f acc (Line a b) = f (f acc b) a + +-- | Describe a quadratic bezier spline, described +-- using 3 points. +-- +-- > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100) +-- > ,Bezier (V2 200 100) (V2 150 200) (V2 120 175) +-- > ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)] +-- +-- <> +-- +data Bezier = Bezier + { -- | Origin points, the spline will pass through it. + _bezierX0 :: {-# UNPACK #-} !Point + -- | Control point, the spline won't pass on it. + , _bezierX1 :: {-# UNPACK #-} !Point + -- | End point, the spline will pass through it. + , _bezierX2 :: {-# UNPACK #-} !Point + } + deriving Eq + +instance Show Bezier where + show (Bezier a b c) = + "Bezier (" ++ show a ++ ") (" + ++ show b ++ ") (" + ++ show c ++ ")" + +instance Transformable Bezier where + {-# INLINE transform #-} + transform f (Bezier a b c) = Bezier (f a) (f b) $ f c + +instance PointFoldable Bezier where + {-# INLINE foldPoints #-} + foldPoints f acc (Bezier a b c) = + foldl' f acc [a, b, c] + +-- | Describe a cubic bezier spline, described +-- using 4 points. +-- +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35) +-- +-- <> +-- +data CubicBezier = CubicBezier + { -- | Origin point, the spline will pass through it. + _cBezierX0 :: {-# UNPACK #-} !Point + -- | First control point of the cubic bezier curve. + , _cBezierX1 :: {-# UNPACK #-} !Point + -- | Second control point of the cubic bezier curve. + , _cBezierX2 :: {-# UNPACK #-} !Point + -- | End point of the cubic bezier curve + , _cBezierX3 :: {-# UNPACK #-} !Point + } + deriving Eq + +instance Show CubicBezier where + show (CubicBezier a b c d) = + "CubicBezier (" ++ show a ++ ") (" + ++ show b ++ ") (" + ++ show c ++ ") (" + ++ show d ++ ")" + +instance Transformable CubicBezier where + {-# INLINE transform #-} + transform f (CubicBezier a b c d) = + CubicBezier (f a) (f b) (f c) $ f d + +instance PointFoldable CubicBezier where + {-# INLINE foldPoints #-} + foldPoints f acc (CubicBezier a b c d) = + foldl' f acc [a, b, c, d] + +-- | This datatype gather all the renderable primitives, +-- they are kept separated otherwise to allow specialization +-- on some specific algorithms. You can mix the different +-- primitives in a single call : +-- +-- > fill [ toPrim $ CubicBezier (V2 50 20) (V2 90 60) +-- > (V2 5 100) (V2 50 140) +-- > , toPrim $ Line (V2 50 140) (V2 120 80) +-- > , toPrim $ Line (V2 120 80) (V2 50 20) ] +-- +-- <> +-- +data Primitive + = LinePrim !Line -- ^ Primitive used for lines + | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves + | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve + deriving (Eq, Show) + +-- | Generalizing constructors of the `Primitive` type to work +-- generically. +class Primitivable a where + toPrim :: a -> Primitive + +-- | @toPrim = id@ +instance Primitivable Primitive where toPrim = id + +-- | @toPrim = LinePrim@ +instance Primitivable Line where toPrim = LinePrim + +-- | @toPrim = BezierPrim@ +instance Primitivable Bezier where toPrim = BezierPrim + +-- | @toPrim = CubicBezierPrim@ +instance Primitivable CubicBezier where toPrim = CubicBezierPrim + +-- | All the rasterization works on lists of primitives, +-- in order to ease the use of the library, the Geometry +-- type class provides conversion facility, which help +-- generalising the geometry definition and avoid applying +-- Primitive constructor. +-- +-- Also streamline the Path conversion. +class Geometry a where + -- | Convert an element to a list of primitives + -- to be rendered. + toPrimitives :: a -> [Primitive] + + -- | Helper method to avoid overlaping instances. + -- You shouldn't use it directly. + listToPrims :: (Foldable f) => f a -> [Primitive] + {-# INLINE listToPrims #-} + listToPrims = F.concatMap toPrimitives . F.toList + +instance Geometry Path where + {-# INLINE toPrimitives #-} + toPrimitives = pathToPrimitives + +instance Geometry Primitive where + toPrimitives e = [e] + {-# INLINE listToPrims #-} + listToPrims = F.toList -- Open question, is it optimised as `id`? + +instance Geometry Line where + {-# INLINE toPrimitives #-} + toPrimitives e = [toPrim e] + +instance Geometry Bezier where + {-# INLINE toPrimitives #-} + toPrimitives e = [toPrim e] + +instance Geometry CubicBezier where + {-# INLINE toPrimitives #-} + toPrimitives e = [toPrim e] + +-- | Generalize the geometry to any foldable container, +-- so you can throw any container to the the 'fill' or +-- 'stroke' function. +instance (Foldable f, Geometry a) => Geometry (f a) where + {-# INLINE toPrimitives #-} + toPrimitives = listToPrims + + +instance Transformable Primitive where + {-# INLINE transform #-} + transform f (LinePrim l) = LinePrim $ transform f l + transform f (BezierPrim b) = BezierPrim $ transform f b + transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c + +instance PointFoldable Primitive where + {-# INLINE foldPoints #-} + foldPoints f acc = go + where go (LinePrim l) = foldPoints f acc l + go (BezierPrim b) = foldPoints f acc b + go (CubicBezierPrim c) = foldPoints f acc c + +instance (Functor f, Transformable a) + => Transformable (f a) where + transform f = fmap (transform f) + +instance (Foldable f, PointFoldable a) + => PointFoldable (f a) where + foldPoints f = foldl' (foldPoints f) + +type Producer a = [a] -> [a] + +type Container a = DList a + +containerOfFunction :: ([a] -> [a]) -> Container a +containerOfFunction f = fromList $ f [] + +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 +-- it for the next "move" +-- For example the example from Primitive could be rewritten: +-- +-- > fill $ Path (V2 50 20) True +-- > [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) +-- > , PathLineTo (V2 120 80) ] +-- +-- <> +-- +data Path = Path + { -- | Origin of the point, equivalent to the + -- first "move" command. + _pathOriginPoint :: Point + -- | Tell if we must close the path. + , _pathClose :: Bool + -- | List of commands in the path + , _pathCommand :: [PathCommand] + } + deriving (Eq, Show) + +instance Transformable Path where + {-# INLINE transform #-} + transform f (Path orig close rest) = + Path (f orig) close (transform f rest) + +instance PointFoldable Path where + {-# INLINE foldPoints #-} + foldPoints f acc (Path o _ rest) = + foldPoints f (f acc o) rest + +-- | Actions to create a path +data PathCommand + = -- | Draw a line from the current point to another point + PathLineTo Point + -- | Draw a quadratic bezier curve from the current point + -- through the control point to the end point. + | PathQuadraticBezierCurveTo Point Point + + -- | Draw a cubic bezier curve using 2 control points. + | PathCubicBezierCurveTo Point Point Point + deriving (Eq, Show) + +instance Transformable PathCommand where + transform f (PathLineTo p) = PathLineTo $ f p + transform f (PathQuadraticBezierCurveTo p1 p2) = + PathQuadraticBezierCurveTo (f p1) $ f p2 + transform f (PathCubicBezierCurveTo p1 p2 p3) = + PathCubicBezierCurveTo (f p1) (f p2) $ f p3 + +instance PointFoldable PathCommand where + foldPoints f acc (PathLineTo p) = f acc p + foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) = + f (f acc p1) p2 + foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) = + foldl' f acc [p1, p2, p3] + +-- | Transform a path description into a list of renderable +-- primitives. +pathToPrimitives :: Path -> [Primitive] +pathToPrimitives (Path origin needClosing commands) = go origin commands + where + go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin] + go _ [] = [] + go prev (PathLineTo to : xs) = + LinePrim (Line prev to) : go to xs + go prev (PathQuadraticBezierCurveTo c1 to : xs) = + BezierPrim (Bezier prev c1 to) : go to xs + go prev (PathCubicBezierCurveTo c1 c2 to : xs) = + CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs + +-- | Gives the orientation vector for the start of the +-- primitive. +firstTangeantOf :: Primitive -> Vector +firstTangeantOf p = case p of + LinePrim (Line p0 p1) -> p1 ^-^ p0 + BezierPrim (Bezier p0 p1 p2) -> + (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) + CubicBezierPrim (CubicBezier p0 p1 p2 _) -> + (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) + where + ifBigEnough a b | nearZero a = b + | otherwise = a + +-- | Gives the orientation vector at the end of the +-- primitive. +lastTangeantOf :: Primitive -> Vector +lastTangeantOf p = case p of + LinePrim (Line p0 p1) -> p1 ^-^ p0 + BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1 + CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2 + +-- | Extract the first point of the primitive. +firstPointOf :: Primitive -> Point +firstPointOf p = case p of + LinePrim (Line p0 _) -> p0 + BezierPrim (Bezier p0 _ _) -> p0 + CubicBezierPrim (CubicBezier p0 _ _ _) -> p0 + +-- | Return the last point of a given primitive. +lastPointOf :: Primitive -> Point +lastPointOf p = case p of + LinePrim (Line _ p0) -> p0 + BezierPrim (Bezier _ _ p0) -> p0 + CubicBezierPrim (CubicBezier _ _ _ p0) -> p0 + +resplit :: [Primitive] -> [[Primitive]] +resplit = uncurry (:) . go where + go [] = ([], []) + go (x:xs@(y:_)) | lastPointOf x `isDistingableFrom` firstPointOf y = + ([x], after:rest) where (after, rest) = go xs + go (x:xs) = (x:curr, rest) where (curr, rest) = go xs +