{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} module Graphics.Rasterific.MicroPdf( renderDrawingToPdf , renderDrawingsToPdf , renderOrdersToPdf ) where 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.List( sortOn ) import qualified Data.Foldable as F import Data.Word( Word32 ) import Data.ByteString.Builder( byteString , intDec , toLazyByteString , word32BE , word8 , 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.PlaneBoundable 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.Rasterific.Patch import Graphics.Rasterific.PatchTypes import Graphics.Rasterific.MeshPatch import Graphics.Text.TrueType( Dpi ) import Text.Printf {-import Debug.Trace-} glength :: Foldable f => f a -> Int glength = F.length 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) runPdfEnvs :: PdfConfiguration -> PdfId -> [PdfEnv a] -> ([a], PdfContext) runPdfEnvs conf firstFreeId producers = runReader (runStateT (sequence producers) $ 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 instance PdfColorable px => ToPdf (V2 Double, V2 Float, V2 Float, TensorPatch (ParametricValues px)) where toPdf (V2 sx sy, V2 dx dy, V2 _tx ty, patch) = word8 0 <> coords <> foldMap colorToBinaryPdf [c00, c03, c33, c30] where fx x = floor . max 0 . min maxi $ realToFrac (x + dx) * sx fy y = floor . max 0 . min maxi $ realToFrac (ty - (y + dy)) * sy maxi = fromIntegral (maxBound :: Word32) coords = foldMap word32BE [ fx x00, fy y00, fx x01, fy y01, fx x02, fy y02, fx x03, fy y03 , fx x13, fy y13, fx x23, fy y23, fx x33, fy y33, fx x32, fy y32 , fx x31, fy y31, fx x30, fy y30, fx x20, fy y20, fx x10, fy y10 , fx x11, fy y11, fx x12, fy y12, fx x22, fy y22, fx x21, fy y21 ] CubicBezier (V2 x00 y00) (V2 x10 y10) (V2 x20 y20) (V2 x30 y30) = _curve0 patch CubicBezier (V2 x01 y01) (V2 x11 y11) (V2 x21 y21) (V2 x31 y31) = _curve1 patch CubicBezier (V2 x02 y02) (V2 x12 y12) (V2 x22 y22) (V2 x32 y32) = _curve2 patch CubicBezier (V2 x03 y03) (V2 x13 y13) (V2 x23 y23) (V2 x33 y33) = _curve3 patch param = _tensorValues patch c00 = _northValue param c30 = _eastValue param c33 = _southValue param c03 = _westValue param -------------------------------------------------- ---- 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" meshGradientObject :: PdfColorable px => MeshPatch px -> Int -> PdfId -> PdfObject meshGradientObject mesh height pid = PdfObject { _pdfId = pid , _pdfRevision = 0 , _pdfAnnot = [ ("ShadingType", "7") , ("ColorSpace", "/DeviceRGB") , ("BitsPerComponent", "8") , ("BitsPerCoordinate", "32") , ("BitsPerFlag", "8") , ("Decode", B.pack $ printf "[%g %g %g %g 0 1 0 1 0 1]" x0 x1 (fromIntegral height - y1) (fromIntegral height - y0)) ] , _pdfStream = buildToStrict . foldMap (\patch -> toPdf (scal, transl, fullSize, patch)) $ tensorPatchesOf mesh } where maxi = fromIntegral (maxBound :: Word32) scaleOf :: Float -> Float -> Double scaleOf a b | nearZero $ a - b = 0 | otherwise = maxi / (realToFrac b - realToFrac a) fullSize = V2 (x1 - x0) (y1 - y0) transl = V2 (-x0) (-y0) scal = V2 (scaleOf x0 x1) (scaleOf y0 y1) PlaneBound (V2 x0 y0) (V2 x1 y1) = foldMeshPoints (\v -> mappend v . planeBounds) mempty mesh createMeshGradient :: forall px. PdfBaseColorable px => Builder -> MeshPatch px -> PdfEnv (Either String Builder) createMeshGradient inner mesh = do height <- asks _pdfHeight meshId <- generateObject $ meshGradientObject mesh height patId <- generateObject (gradientPatternObject mempty meshId) pat <- namePatternObject $ refOf patId pure . pure $ "/Pattern cs\n" <> pat <> " scn\n" <> "/Pattern CS\n" <> pat <> " SCN\n" <> inner 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 colorToBinaryPdf :: px -> Builder instance PdfColorable Pixel8 where pdfColorSpace _ = "/DeviceGray" colorToPdf c = toPdf (fromIntegral c / 255 :: Float) colorToBinaryPdf = word8 instance PdfColorable PixelRGBA8 where pdfColorSpace _ = "/DeviceRGB" colorToPdf (PixelRGBA8 r g b _a) = colorToPdf r <> tp " " <> colorToPdf g <> tp " " <> colorToPdf b colorToBinaryPdf (PixelRGBA8 r g b _a) = colorToBinaryPdf r <> colorToBinaryPdf g <> colorToBinaryPdf 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." AlphaModulateTexture _tx _modulation -> return $ Left "Unsupported alpha 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 MeshPatchTexture _ mesh -> createMeshGradient inner mesh 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 off = toPdf . B.pack $ printf "%010d 00000 n \n" off 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 = pdfFromProducers px conf [producer] pdfFromProducers :: PdfBaseColorable px => Proxy px -> PdfConfiguration -> [PdfEnv Builder] -> LB.ByteString pdfFromProducers px conf producers = toLazyByteString $ foldMap byteString objs <> xref <> buildTrailer objects catalogId <> xrefPosition <> tp "%%EOF" where height = _pdfHeight conf (catalogId : outlineId : pagesId : endObjId : remainingIds) = [1..] (pageIds, remainingIds') = splitAt (length producers) remainingIds (contentIds, remainingIds'') = splitAt (length producers) remainingIds' firstFreeId = head remainingIds'' (contents, endContext) = runPdfEnvs conf firstFreeId producers initialTransform = toPdf . toPdfSpace $ fromIntegral height objects = [ catalogObject pagesId outlineId catalogId , outlinesObject [] outlineId , pagesObject pageIds pagesId ] <> concatMap (\(contentId, pageId, content) -> [ pageObject px (_pdfWidth conf) height pagesId contentId endObjId pageId , contentObject (buildToStrict $ initialTransform <> content) contentId] ) (zip3 contentIds pageIds contents) <> [ resourceObject (endContext .^ pdfShadings.resAssoc) (endContext .^ pdfGraphicStates.resAssoc) (endContext .^ pdfPatterns.resAssoc) (endContext .^ pdfXObjects.resAssoc) endObjId ] <> reverse (_generatedPdfObjects endContext) (indexes, objs) = unzip $ prepareObjects objects (_, lastOffset) = last indexes xrefOffset = lastOffset + B.length (last objs) xrefPosition = "startxref\n" <> intDec xrefOffset <> tp "\n" offsets = map snd $ sortOn fst indexes xref = buildXRefTable offsets renderDrawingToPdf :: (forall px . PdfColorable px => Drawing px () -> [DrawOrder px]) -> Int -> Int -> Dpi -> Drawing PixelRGBA8 () -> LB.ByteString renderDrawingToPdf toOrders width height dpi d = renderDrawingsToPdf toOrders width height dpi [d] renderDrawingsToPdf :: (forall px . PdfColorable px => Drawing px () -> [DrawOrder px]) -> Int -> Int -> Dpi -> [Drawing PixelRGBA8 ()] -> LB.ByteString renderDrawingsToPdf toOrders width height dpi ds = pdfFromProducers px conf $ map (pdfProducer baseTexture) ds 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 CustomRender _mesh next -> recurse next MeshPatchRender i m next -> do w <- asks $ fromIntegral . _pdfWidth h <- asks $ fromIntegral . _pdfHeight let rect = rectangle (V2 0 0) w h go forceInverse activeTrans filler prevTexture $ SetTexture (MeshPatchTexture i m) (liftF $ Fill FillWinding rect ()) next 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 stroke = case w of 0 -> mempty _ -> toPdf w <> tp " w " <> lineJoinOf j <> lineCapOf c <> "\n" <> foldMap output (resplit prims) <> tp "S\n" pure $ stroke <> 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 (\r -> _pdfConfToOrder r) 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] -> [((PdfId, Int), B.ByteString)] prepareObjects = scanl go ((0, 0), pdfSignature) where go ((_, off), prev) obj = ((_pdfId obj, off + B.length prev), buildToStrict $ toPdf obj)