{-# 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)