Rasterific 0.5.2.1 → 0.6
raw patch · 23 files changed
+2671/−1291 lines, 23 filesdep +bytestringdep +containersbinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring, containers
API changes (from Hackage documentation)
+ Graphics.Rasterific: renderDrawingAtDpiToPDF :: Int -> Int -> Dpi -> Drawing PixelRGBA8 () -> ByteString
+ Graphics.Rasterific: renderOrdersAtDpiToPdf :: Int -> Int -> Dpi -> [DrawOrder PixelRGBA8] -> ByteString
+ Graphics.Rasterific.Immediate: instance Transformable (DrawOrder px)
+ Graphics.Rasterific.Immediate: textToDrawOrders :: Dpi -> Texture px -> Point -> [TextRange px] -> [DrawOrder px]
+ Graphics.Rasterific.Immediate: transformOrder :: (Point -> Point) -> DrawOrder px -> DrawOrder px
+ Graphics.Rasterific.Texture: patternTexture :: RenderablePixel px => Int -> Int -> Dpi -> px -> Drawing px () -> Texture px
Files
- README.md +27/−0
- Rasterific.cabal +11/−3
- changelog +32/−1
- docimages/image_resize.png binary
- docimages/pattern_texture.png binary
- docimages/sampled_texture_reflect.png binary
- exec-src/docImageGenerator.hs +59/−32
- src/Graphics/Rasterific.hs +51/−121
- src/Graphics/Rasterific/Command.hs +74/−15
- src/Graphics/Rasterific/ComplexPrimitive.hs +93/−0
- src/Graphics/Rasterific/Compositor.hs +5/−0
- src/Graphics/Rasterific/CubicBezier.hs +12/−0
- src/Graphics/Rasterific/Immediate.hs +46/−4
- src/Graphics/Rasterific/Line.hs +16/−0
- src/Graphics/Rasterific/MicroPdf.hs +1069/−0
- src/Graphics/Rasterific/MiniLens.hs +67/−0
- src/Graphics/Rasterific/Operators.hs +6/−4
- src/Graphics/Rasterific/QuadraticBezier.hs +297/−291
- src/Graphics/Rasterific/QuadraticFormula.hs +54/−56
- src/Graphics/Rasterific/Shading.hs +4/−58
- src/Graphics/Rasterific/StrokeInternal.hs +15/−8
- src/Graphics/Rasterific/Texture.hs +173/−147
- src/Graphics/Rasterific/Types.hs +560/−551
+ README.md view
@@ -0,0 +1,27 @@+Rasterific+==========++++[](https://travis-ci.org/Twinside/Rasterific)+[](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.+
Rasterific.cabal view
@@ -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: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAMAAACahl6sAAAA7VBMVEUBhsECh8EFiMIIisMLi8QMjMQOjcQSj8UTj8YVkMYZkscakscbk8ghlskmmMozns02oM44oc86os9CpdFEptJXr9Zbsdddsthes9hhtNljtdlsudtxvNx+wuB/wuCAw+CCxOGDxOGExeGHxuKVzeWb0Oed0Oek1Omm1emo1uqp1uqr1+ux2uyy2uy02+223O294O/J5fLK5vLM5/PN5/PY7PbZ7fbj8vjk8vjl8/nm8/np9frq9frr9vrs9vru9/vw+Pv2+/33+/37/f6g0ug8otBNq9S63u6Jx+IEiMJfs9hzvd3f8Pcqmsv///+OsMg+AAAFP0lEQVR4XuzPSQ0AIAwAQcT15PIvhy8OaMiOg2n7E0TeI0KECJH6iBAhQoQIESJEiEyXGN10ZbvkUusjxGf9yGHvjhpRW8Iwjj+oIIQQlh0FgBARiEIs7eb7f5xzdW5m9j5nzbPe1rwX/b7B343VzDszD+f1yvIs/tfscqV+/qAz5PlksJqHl/zq4ORZVUjnaHMepPnNo46OkNbeElJa2muFDrmvDSFiWLsPF9I7LkNQ+bgXJOSlOgNhM9WXzEPa2znIQ267nWnIUzSJEZmMnjIL6dYKGKFCrZtNSGMBI7bQyCDkbR0ZWH8bdcjFHDIxdzHSkG40gYxMRN3RhbRLyFCpPaqQZhGZKjZHE3KWQ8ZyZ6MI2Y+RuXhfPmQXQewSIXzHVKlSPby8ef03+vXm8rBaKU2JlMiG7ONvCmsHLfMXrYO1AtLalww5i/FHizvX7+Y/vV/vLCKV+EwupJnDn5SvTCJXZaSRa0qFtItwxRu3JrHbjRi8YlsmpFuCq39nvNz1wSt1RUIiOKZPjbfTadAiiZCLCdhWHg3hcQWsiYv0IW9zsG31DKW3BdbcW+qQddh+GdovsNbThjS4DvmSRrqQ7gIsWyaVLZAWuqlCarCs9EwqvRWQamlCngpWx/SjSelxGpzCU4qQCJZTk9opSBEf0rbXE/tGQB+cyTYdsm11xHdGwF0MzjYb8pKzQjaMiA1wci9kSBWWWyPiFqQqF9Kz9z/KRkgZnJkeFXIMy5URcgXSMRHi/t0WjZhFcMpMyD0sO0bMDkj3REgNlmsj5hqkGhEytDoK70bMewGcoX9IC5Y1I2gNpJZ3yB4sB0bQAUh73iFL7t9CUAukJd+QDixTRtQUSB3PkCNYSkZUCaQjz5BNWCpGVAWkTc+QeViqRlQVpHm/kGfYDo2oQ7CevUJOYLs0oi7BOvEKGcB2Y0TdgDXwClmF7dWIegVr1SskD5sRBlbeJ+QBekPw4BFyrjnk3COkrjmk7hFS0RxS8QhZ1hyy7BEyqzlk1iMEmkOQPOQ3oPcfIvA7ccgXoPcTBfhKHPIB6P1oBD4Sh3wDej/jge/EIQM45H9Y8QaJQ37gkP+py/tJHNKHQ37xgddPHPIJh/xyEO8zccgQDvkFOt4wcUgMh/ySKS9OHAJL2EVsFxGiaFuBD1G20cOHaNt640OUbYbyIdq2p/kQZQMDfIi2EQ4+JORQjXyI/JhToBD5wbOgIfKjgDzmozH8cKYrZj7jw4/LuobUD6vgA8yuT+qnbvCRclefW3wIPeTv+iGXgwIfu3AN2AW6sAdhXN/skmnYo0muD3oRO+hhMdcXv60Q9vgev61g4JA/UMlLtfUmfsSVN5tqM5Q/dCxuOd32dIBj4ALb03UoVidGOFQ6J4ZqVHogxpw0yhODZyqtEqOAKg2I4UyVTohxWZWeiQFmjeaJkXKVNokhf5WOiGMXKnWIgzAaLRFHk1TaIw6LqdRiju8pNKQOVCpUo464KnTPHTpWp0weA1fnmD2Yrwl/MN9UoUyVv7xCldwLf52IKtsCF7wEIHnBi4mgSCRwCVIA7CVI+r9TagIXhWmw0BW4uk2DhsBlehqsS1xvqMDcm8iFkwGQF05q/2cSSV3KGlipK3ZNblDFtuDFxQHlmqJXSQcTn8le7h3MvvR164Hsji/A1/UkwfiRCF3PdowfUtH1tM34sSFVzz+NH+RS9UTa+NE6Tc8Ijh921PTU5vjxU8XP0Y4fCB4/2cw/ov1Pe3cgAwAAACDM3zqOtmdwgmzNjeZBQEA+gYCAgICAgICAgIAETuKXxaAVTVgAAAAASUVORK5CYII=>> . Rasterific is a vector drawing library (a rasterizer)- implemented in pure haskell+ 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
changelog view
@@ -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.
docimages/image_resize.png view
binary file changed (40755 → 40580 bytes)
+ docimages/pattern_texture.png view
binary file changed (absent → 2932 bytes)
docimages/sampled_texture_reflect.png view
binary file changed (65251 → 65351 bytes)
exec-src/docImageGenerator.hs view
@@ -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
src/Graphics/Rasterific.hs view
@@ -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------ <<docimages/fill_circle.png>>----circle :: Point -- ^ Circle center in pixels- -> Float -- ^ Circle radius in pixels- -> [Primitive]-circle center radius =- CubicBezierPrim . transform mv <$> cubicBezierCircle- where- mv p = (p ^* radius) ^+^ center---- | Generate a list of primitive representing an ellipse.------ > fill $ ellipse (V2 100 100) 75 30------ <<docimages/fill_ellipse.png>>----ellipse :: Point -> Float -> Float -> [Primitive]-ellipse center rx ry =- CubicBezierPrim . transform mv <$> cubicBezierCircle- where- mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center- -- | Generate a strokable line out of points list. -- Just an helper around `lineFromPath`. --@@ -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------ <<docimages/fill_rect.png>>----rectangle :: Point -- ^ Corner upper left- -> Float -- ^ Width in pixel- -> Float -- ^ Height in pixel- -> [Primitive]-rectangle p@(V2 px py) w h =- LinePrim <$> lineFromPath- [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ]- -- | Simply draw an image into the canvas. Take into account -- any previous transformation performed on the geometry. --@@ -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------ <<docimages/fill_roundedRectangle.png>>----roundedRectangle :: Point -- ^ Corner upper left- -> Float -- ^ Width in pixel- -> Float -- ^ Height in pixel.- -> Float -- ^ Radius along the x axis of the rounded corner. In pixel.- -> Float -- ^ Radius along the y axis of the rounded corner. In pixel.- -> [Primitive]-roundedRectangle (V2 px py) w h rx ry =- [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR- , LinePrim $ Line (V2 xFar py) (V2 xNear py)- , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL- , LinePrim $ Line (V2 px yNear) (V2 px yFar)- , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL- , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h))- , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR- , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear)- ]- where- xNear = px + rx- xFar = px + w - rx-- yNear = py + ry- yFar = py + h - ry-- (cornerBottomR :- cornerTopR :- cornerTopL :- cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle -- | Return a simple line ready to be stroked. --
src/Graphics/Rasterific/Command.hs view
@@ -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 <IMG>"+dumpTexture (RawTexture _) = "<RAWTEXTURE>"+dumpTexture (ShaderTexture _) = "shaderFunction <FUNCTION>"+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
+ src/Graphics/Rasterific/ComplexPrimitive.hs view
@@ -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+--+-- <<docimages/fill_circle.png>>+--+circle :: Point -- ^ Circle center in pixels+ -> Float -- ^ Circle radius in pixels+ -> [Primitive]+circle center radius =+ CubicBezierPrim . transform mv <$> cubicBezierCircle+ where+ mv p = (p ^* radius) ^+^ center++-- | Generate a list of primitive representing an ellipse.+--+-- > fill $ ellipse (V2 100 100) 75 30+--+-- <<docimages/fill_ellipse.png>>+--+ellipse :: Point -> Float -> Float -> [Primitive]+ellipse center rx ry =+ CubicBezierPrim . transform mv <$> cubicBezierCircle+ where+ mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center++-- | Generate a list of primitive representing a+-- rectangle+--+-- > fill $ rectangle (V2 30 30) 150 100+--+-- <<docimages/fill_rect.png>>+--+rectangle :: Point -- ^ Corner upper left+ -> Float -- ^ Width in pixel+ -> Float -- ^ Height in pixel+ -> [Primitive]+rectangle p@(V2 px py) w h =+ LinePrim <$> lineFromPath+ [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ]++-- | Generate a list of primitive representing a rectangle+-- with rounded corner.+--+-- > fill $ roundedRectangle (V2 10 10) 150 150 20 10+--+-- <<docimages/fill_roundedRectangle.png>>+--+roundedRectangle :: Point -- ^ Corner upper left+ -> Float -- ^ Width in pixel+ -> Float -- ^ Height in pixel.+ -> Float -- ^ Radius along the x axis of the rounded corner. In pixel.+ -> Float -- ^ Radius along the y axis of the rounded corner. In pixel.+ -> [Primitive]+roundedRectangle (V2 px py) w h rx ry =+ [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR+ , LinePrim $ Line (V2 xFar py) (V2 xNear py)+ , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL+ , LinePrim $ Line (V2 px yNear) (V2 px yFar)+ , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL+ , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h))+ , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR+ , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear)+ ]+ where+ xNear = px + rx+ xFar = px + w - rx++ yNear = py + ry+ yFar = py + h - ry++ (cornerBottomR :+ cornerTopR :+ cornerTopL :+ cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle+
src/Graphics/Rasterific/Compositor.hs view
@@ -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
src/Graphics/Rasterific/CubicBezier.hs view
@@ -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)
src/Graphics/Rasterific/Immediate.hs view
@@ -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]+
src/Graphics/Rasterific/Line.hs view
@@ -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)
+ src/Graphics/Rasterific/MicroPdf.hs view
@@ -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)+
+ src/Graphics/Rasterific/MiniLens.hs view
@@ -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)+
src/Graphics/Rasterific/Operators.hs view
@@ -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
src/Graphics/Rasterific/QuadraticBezier.hs view
@@ -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)+
src/Graphics/Rasterific/QuadraticFormula.hs view
@@ -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)+
src/Graphics/Rasterific/Shading.hs view
@@ -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 <IMG>"-dumpTexture (RawTexture _) = "<RAWTEXTURE>"-dumpTexture (ShaderTexture _) = "shaderFunction <FUNCTION>"-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
src/Graphics/Rasterific/StrokeInternal.hs view
@@ -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
src/Graphics/Rasterific/Texture.hs view
@@ -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 --- --- <<docimages/sampled_texture_pad.png>> --- --- With repeat: --- --- > withTexture (withSampler SamplerRepeat $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <<docimages/sampled_texture_repeat.png>> --- --- With reflect: --- --- > withTexture (withSampler SamplerReflect $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <<docimages/sampled_texture_reflect.png>> --- -withSampler :: SamplerRepeat -> Texture px -> Texture px -withSampler = 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 --- --- <<docimages/sampled_texture_scaled.png>> --- -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 --- --- <<docimages/linear_gradient.png>> --- -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 --- --- <<docimages/radial_gradient.png>> --- -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 --- --- <<docimages/radial_gradient_focus.png>> --- -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+--+-- <<docimages/sampled_texture_pad.png>>+--+-- With repeat:+--+-- > withTexture (withSampler SamplerRepeat $+-- > sampledImageTexture textureImage) $+-- > fill $ rectangle (V2 0 0) 200 200+--+-- <<docimages/sampled_texture_repeat.png>>+--+-- With reflect:+--+-- > withTexture (withSampler SamplerReflect $+-- > sampledImageTexture textureImage) $+-- > fill $ rectangle (V2 0 0) 200 200+--+-- <<docimages/sampled_texture_reflect.png>>+--+withSampler :: SamplerRepeat -> Texture px -> Texture px+withSampler = 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+--+-- <<docimages/sampled_texture_scaled.png>>+--+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+--+-- <<docimages/linear_gradient.png>>+--+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+--+-- <<docimages/radial_gradient.png>>+--+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+--+-- <<docimages/radial_gradient_focus.png>>+--+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+--+-- <<docimages/pattern_texture.png>>+--+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+
src/Graphics/Rasterific/Types.hs view
@@ -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 : <<docimages/cap_straight.png>> - -- - -- * cap straight with param 1 : <<docimages/cap_straight_1.png>> - -- - = CapStraight Float - - -- | Create a rounded caping on the stroke. - -- <<docimages/cap_round.png>> - | CapRound - deriving (Eq, Show) - --- | Describe how to display the join of broken lines --- while stroking. -data Join - -- | Make a curved join. - -- <<docimages/join_round.png>> - = JoinRound - -- | Make a mitter join. Value must be positive or null. - -- Seems to make sense in [0;1] only - -- - -- * Miter join with 0 : <<docimages/join_miter.png>> - -- - -- * Miter join with 5 : <<docimages/join_miter_5.png>> - -- - | JoinMiter Float - deriving (Eq, Show) - --- | Tell how to fill complex shapes when there is self --- intersections. If the filling mode is not specified, --- then it's the `FillWinding` method which is used. --- --- The examples used are produced with the following --- function: --- --- --- > fillingSample :: FillMethod -> Drawing px () --- > fillingSample fillMethod = fillWithMethod fillMethod geometry where --- > geometry = transform (applyTransformation $ scale 0.35 0.4 --- > <> translate (V2 (-80) (-180))) --- > [ Path (V2 484 499) True --- > [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) --- > , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) --- > ] --- > , Path (V2 136 377) True --- > [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) --- > , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) --- > ] --- > , Path (V2 340 265) True --- > [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) --- > , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) --- > , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) --- > ] --- > ] -data FillMethod - -- | Also known as nonzero rule. - -- To determine if a point falls inside the curve, you draw - -- an imaginary line through that point. Next you will count - -- how many times that line crosses the curve before it reaches - -- that point. For every clockwise rotation, you subtract 1 and - -- for every counter-clockwise rotation you add 1. - -- - -- <<docimages/fill_winding.png>> - = FillWinding - - -- | This rule determines the insideness of a point on - -- the canvas by drawing a ray from that point to infinity - -- in any direction and counting the number of path segments - -- from the given shape that the ray crosses. If this number - -- is odd, the point is inside; if even, the point is outside. - -- - -- <<docimages/fill_evenodd.png>> - | FillEvenOdd - deriving (Eq, Enum, Show) - --- | Describe the behaviour of samplers and texturers --- when they are out of the bounds of image and/or gradient. -data SamplerRepeat - -- | Will clamp (ie. repeat the last pixel) when - -- out of bound - -- <<docimages/sampler_pad.png>> - = SamplerPad - -- | Will loop on it's definition domain - -- <<docimages/sampler_repeat.png>> - | SamplerRepeat - -- | Will loop inverting axises - -- <<docimages/sampler_reflect.png>> - | SamplerReflect - deriving (Eq, Enum, Show) - --- | Represent a raster line -data EdgeSample = EdgeSample - { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position - , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position - , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha - , _sampleH :: {-# UNPACK #-} !Float -- ^ Height - } - deriving Show - --- | 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)] --- --- <<docimages/simple_line.png>> --- -data Line = Line - { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point - , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point - } - deriving Eq - -instance Show Line where - show (Line a b) = - "Line (" ++ show a ++ ") (" - ++ show b ++ ")" - -instance Transformable Line where - {-# INLINE transform #-} - transform f (Line a b) = Line (f a) $ f b - -instance PointFoldable Line where - {-# INLINE foldPoints #-} - foldPoints f acc (Line a b) = f (f acc b) a - --- | Describe a quadratic bezier spline, described --- using 3 points. --- --- > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100) --- > ,Bezier (V2 200 100) (V2 150 200) (V2 120 175) --- > ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)] --- --- <<docimages/quadratic_bezier.png>> --- -data Bezier = Bezier - { -- | Origin points, the spline will pass through it. - _bezierX0 :: {-# UNPACK #-} !Point - -- | Control point, the spline won't pass on it. - , _bezierX1 :: {-# UNPACK #-} !Point - -- | End point, the spline will pass through it. - , _bezierX2 :: {-# UNPACK #-} !Point - } - deriving Eq - -instance Show Bezier where - show (Bezier a b c) = - "Bezier (" ++ show a ++ ") (" - ++ show b ++ ") (" - ++ show c ++ ")" - -instance Transformable Bezier where - {-# INLINE transform #-} - transform f (Bezier a b c) = Bezier (f a) (f b) $ f c - -instance PointFoldable Bezier where - {-# INLINE foldPoints #-} - foldPoints f acc (Bezier a b c) = - foldl' f acc [a, b, c] - --- | Describe a cubic bezier spline, described --- using 4 points. --- --- > stroke 4 JoinRound (CapRound, CapRound) $ --- > CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35) --- --- <<docimages/cubic_bezier.png>> --- -data CubicBezier = CubicBezier - { -- | Origin point, the spline will pass through it. - _cBezierX0 :: {-# UNPACK #-} !Point - -- | First control point of the cubic bezier curve. - , _cBezierX1 :: {-# UNPACK #-} !Point - -- | Second control point of the cubic bezier curve. - , _cBezierX2 :: {-# UNPACK #-} !Point - -- | End point of the cubic bezier curve - , _cBezierX3 :: {-# UNPACK #-} !Point - } - deriving Eq - -instance Show CubicBezier where - show (CubicBezier a b c d) = - "CubicBezier (" ++ show a ++ ") (" - ++ show b ++ ") (" - ++ show c ++ ") (" - ++ show d ++ ")" - -instance Transformable CubicBezier where - {-# INLINE transform #-} - transform f (CubicBezier a b c d) = - CubicBezier (f a) (f b) (f c) $ f d - -instance PointFoldable CubicBezier where - {-# INLINE foldPoints #-} - foldPoints f acc (CubicBezier a b c d) = - foldl' f acc [a, b, c, d] - --- | This datatype gather all the renderable primitives, --- they are kept separated otherwise to allow specialization --- on some specific algorithms. You can mix the different --- primitives in a single call : --- --- > fill [ 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) ] --- --- <<docimages/primitive_mixed.png>> --- -data Primitive - = LinePrim !Line -- ^ Primitive used for lines - | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves - | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve - deriving (Eq, Show) - --- | 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) ] --- --- <<docimages/path_example.png>> --- -data Path = Path - { -- | Origin of the point, equivalent to the - -- first "move" command. - _pathOriginPoint :: Point - -- | Tell if we must close the path. - , _pathClose :: Bool - -- | List of commands in the path - , _pathCommand :: [PathCommand] - } - deriving (Eq, Show) - -instance Transformable Path where - {-# INLINE transform #-} - transform f (Path orig close rest) = - Path (f orig) close (transform f rest) - -instance PointFoldable Path where - {-# INLINE foldPoints #-} - foldPoints f acc (Path o _ rest) = - foldPoints f (f acc o) rest - --- | Actions to create a path -data PathCommand - = -- | Draw a line from the current point to another point - PathLineTo Point - -- | Draw a quadratic bezier curve from the current point - -- through the control point to the end point. - | PathQuadraticBezierCurveTo Point Point - - -- | Draw a cubic bezier curve using 2 control points. - | PathCubicBezierCurveTo Point Point Point - deriving (Eq, Show) - -instance Transformable PathCommand where - transform f (PathLineTo p) = PathLineTo $ f p - transform f (PathQuadraticBezierCurveTo p1 p2) = - PathQuadraticBezierCurveTo (f p1) $ f p2 - transform f (PathCubicBezierCurveTo p1 p2 p3) = - PathCubicBezierCurveTo (f p1) (f p2) $ f p3 - -instance PointFoldable PathCommand where - foldPoints f acc (PathLineTo p) = f acc p - foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) = - f (f acc p1) p2 - foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) = - foldl' f acc [p1, p2, p3] - --- | Transform a path description into a list of renderable --- primitives. -pathToPrimitives :: Path -> [Primitive] -pathToPrimitives (Path origin needClosing commands) = go origin commands - where - go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin] - go _ [] = [] - go prev (PathLineTo to : xs) = - LinePrim (Line prev to) : go to xs - go prev (PathQuadraticBezierCurveTo c1 to : xs) = - BezierPrim (Bezier prev c1 to) : go to xs - go prev (PathCubicBezierCurveTo c1 c2 to : xs) = - CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs - --- | 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 : <<docimages/cap_straight.png>>+ --+ -- * cap straight with param 1 : <<docimages/cap_straight_1.png>>+ --+ = CapStraight Float++ -- | Create a rounded caping on the stroke.+ -- <<docimages/cap_round.png>>+ | CapRound+ deriving (Eq, Show)++-- | Describe how to display the join of broken lines+-- while stroking.+data Join+ -- | Make a curved join.+ -- <<docimages/join_round.png>>+ = JoinRound+ -- | Make a mitter join. Value must be positive or null.+ -- Seems to make sense in [0;1] only+ --+ -- * Miter join with 0 : <<docimages/join_miter.png>>+ --+ -- * Miter join with 5 : <<docimages/join_miter_5.png>>+ --+ | JoinMiter Float+ deriving (Eq, Show)++-- | Tell how to fill complex shapes when there is self +-- intersections. If the filling mode is not specified,+-- then it's the `FillWinding` method which is used.+--+-- The examples used are produced with the following+-- function:+--+--+-- > fillingSample :: FillMethod -> Drawing px ()+-- > fillingSample fillMethod = fillWithMethod fillMethod geometry where+-- > geometry = transform (applyTransformation $ scale 0.35 0.4+-- > <> translate (V2 (-80) (-180)))+-- > [ Path (V2 484 499) True+-- > [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314)+-- > , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499)+-- > ]+-- > , Path (V2 136 377) True+-- > [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489)+-- > , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377)+-- > ]+-- > , Path (V2 340 265) True+-- > [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536)+-- > , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575)+-- > , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265)+-- > ]+-- > ]+data FillMethod+ -- | Also known as nonzero rule.+ -- To determine if a point falls inside the curve, you draw + -- an imaginary line through that point. Next you will count+ -- how many times that line crosses the curve before it reaches+ -- that point. For every clockwise rotation, you subtract 1 and+ -- for every counter-clockwise rotation you add 1.+ --+ -- <<docimages/fill_winding.png>>+ = FillWinding++ -- | This rule determines the insideness of a point on + -- the canvas by drawing a ray from that point to infinity+ -- in any direction and counting the number of path segments+ -- from the given shape that the ray crosses. If this number+ -- is odd, the point is inside; if even, the point is outside.+ --+ -- <<docimages/fill_evenodd.png>>+ | FillEvenOdd+ deriving (Eq, Enum, Show)++-- | Describe the behaviour of samplers and texturers+-- when they are out of the bounds of image and/or gradient.+data SamplerRepeat+ -- | Will clamp (ie. repeat the last pixel) when+ -- out of bound+ -- <<docimages/sampler_pad.png>>+ = SamplerPad+ -- | Will loop on it's definition domain+ -- <<docimages/sampler_repeat.png>>+ | SamplerRepeat+ -- | Will loop inverting axises+ -- <<docimages/sampler_reflect.png>>+ | SamplerReflect+ deriving (Eq, Enum, Show)++-- | Represent a raster line+data EdgeSample = EdgeSample+ { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position+ , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position+ , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha+ , _sampleH :: {-# UNPACK #-} !Float -- ^ Height+ }+ deriving Show++-- | 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)]+--+-- <<docimages/simple_line.png>>+--+data Line = Line+ { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point+ , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point+ }+ deriving Eq++instance Show Line where+ show (Line a b) =+ "Line (" ++ show a ++ ") ("+ ++ show b ++ ")"++instance Transformable Line where+ {-# INLINE transform #-}+ transform f (Line a b) = Line (f a) $ f b++instance PointFoldable Line where+ {-# INLINE foldPoints #-}+ foldPoints f acc (Line a b) = f (f acc b) a++-- | Describe a quadratic bezier spline, described+-- using 3 points.+--+-- > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100)+-- > ,Bezier (V2 200 100) (V2 150 200) (V2 120 175)+-- > ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)]+--+-- <<docimages/quadratic_bezier.png>>+--+data Bezier = Bezier+ { -- | Origin points, the spline will pass through it.+ _bezierX0 :: {-# UNPACK #-} !Point+ -- | Control point, the spline won't pass on it.+ , _bezierX1 :: {-# UNPACK #-} !Point+ -- | End point, the spline will pass through it.+ , _bezierX2 :: {-# UNPACK #-} !Point+ }+ deriving Eq++instance Show Bezier where+ show (Bezier a b c) =+ "Bezier (" ++ show a ++ ") ("+ ++ show b ++ ") ("+ ++ show c ++ ")"++instance Transformable Bezier where+ {-# INLINE transform #-}+ transform f (Bezier a b c) = Bezier (f a) (f b) $ f c++instance PointFoldable Bezier where+ {-# INLINE foldPoints #-}+ foldPoints f acc (Bezier a b c) =+ foldl' f acc [a, b, c]++-- | Describe a cubic bezier spline, described+-- using 4 points.+--+-- > stroke 4 JoinRound (CapRound, CapRound) $+-- > CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35)+--+-- <<docimages/cubic_bezier.png>>+--+data CubicBezier = CubicBezier+ { -- | Origin point, the spline will pass through it.+ _cBezierX0 :: {-# UNPACK #-} !Point+ -- | First control point of the cubic bezier curve.+ , _cBezierX1 :: {-# UNPACK #-} !Point+ -- | Second control point of the cubic bezier curve.+ , _cBezierX2 :: {-# UNPACK #-} !Point+ -- | End point of the cubic bezier curve+ , _cBezierX3 :: {-# UNPACK #-} !Point+ }+ deriving Eq++instance Show CubicBezier where+ show (CubicBezier a b c d) =+ "CubicBezier (" ++ show a ++ ") ("+ ++ show b ++ ") ("+ ++ show c ++ ") ("+ ++ show d ++ ")"++instance Transformable CubicBezier where+ {-# INLINE transform #-}+ transform f (CubicBezier a b c d) =+ CubicBezier (f a) (f b) (f c) $ f d++instance PointFoldable CubicBezier where+ {-# INLINE foldPoints #-}+ foldPoints f acc (CubicBezier a b c d) =+ foldl' f acc [a, b, c, d]++-- | This datatype gather all the renderable primitives,+-- they are kept separated otherwise to allow specialization+-- on some specific algorithms. You can mix the different+-- primitives in a single call :+--+-- > fill [ 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) ]+--+-- <<docimages/primitive_mixed.png>>+--+data Primitive+ = LinePrim !Line -- ^ Primitive used for lines+ | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves+ | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve+ deriving (Eq, Show)++-- | 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) ]+--+-- <<docimages/path_example.png>>+--+data Path = Path+ { -- | Origin of the point, equivalent to the+ -- first "move" command.+ _pathOriginPoint :: Point+ -- | Tell if we must close the path.+ , _pathClose :: Bool+ -- | List of commands in the path+ , _pathCommand :: [PathCommand]+ }+ deriving (Eq, Show)++instance Transformable Path where+ {-# INLINE transform #-}+ transform f (Path orig close rest) =+ Path (f orig) close (transform f rest)++instance PointFoldable Path where+ {-# INLINE foldPoints #-}+ foldPoints f acc (Path o _ rest) =+ foldPoints f (f acc o) rest++-- | Actions to create a path+data PathCommand+ = -- | Draw a line from the current point to another point+ PathLineTo Point+ -- | Draw a quadratic bezier curve from the current point+ -- through the control point to the end point.+ | PathQuadraticBezierCurveTo Point Point++ -- | Draw a cubic bezier curve using 2 control points.+ | PathCubicBezierCurveTo Point Point Point+ deriving (Eq, Show)++instance Transformable PathCommand where+ transform f (PathLineTo p) = PathLineTo $ f p+ transform f (PathQuadraticBezierCurveTo p1 p2) =+ PathQuadraticBezierCurveTo (f p1) $ f p2+ transform f (PathCubicBezierCurveTo p1 p2 p3) =+ PathCubicBezierCurveTo (f p1) (f p2) $ f p3++instance PointFoldable PathCommand where+ foldPoints f acc (PathLineTo p) = f acc p+ foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) =+ f (f acc p1) p2+ foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) =+ foldl' f acc [p1, p2, p3]++-- | Transform a path description into a list of renderable+-- primitives.+pathToPrimitives :: Path -> [Primitive]+pathToPrimitives (Path origin needClosing commands) = go origin commands+ where+ go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin]+ go _ [] = []+ go prev (PathLineTo to : xs) =+ LinePrim (Line prev to) : go to xs+ go prev (PathQuadraticBezierCurveTo c1 to : xs) =+ BezierPrim (Bezier prev c1 to) : go to xs+ go prev (PathCubicBezierCurveTo c1 c2 to : xs) =+ CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs++-- | 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+