(* Structured Graphics *) open Pdfutil open Pdfio type fpoint = float * float type winding_rule = EvenOdd | NonZero type segment = | Straight of fpoint * fpoint | Bezier of fpoint * fpoint * fpoint * fpoint (* Each segment list may be marked as a hole or not. *) type hole = Hole | Not_hole (* A [subpath] is either closed or open. *) type closure = Closed | Open (* A [subpath] is the pair of a hole and a list of segments. *) type subpath = hole * closure * segment list (* A path is made from a number of subpaths. *) type path = winding_rule * subpath list type tiling = Tiling type function_shading = {funshading_domain : float * float * float * float; funshading_matrix : Pdftransform.transform_matrix; funshading_function : Pdffun.t} type radial_shading = {radialshading_coords : float * float * float * float * float * float; radialshading_domain : float * float; radialshading_function : Pdffun.t list; radialshading_extend : bool * bool} type axial_shading = {axialshading_coords : float * float * float * float; axialshading_domain : float * float; axialshading_function : Pdffun.t list; axialshading_extend : bool * bool} type shading_kind = | FunctionShading of function_shading | AxialShading of axial_shading | RadialShading of radial_shading | FreeFormGouraudShading | LatticeFormGouraudShading | CoonsPatchMesh | TensorProductPatchMesh type shading = {shading_colourspace : Pdf.pdfobject; shading_background : Pdf.pdfobject option; shading_bbox : Pdf.pdfobject option; shading_antialias : bool; shading_matrix : Pdftransform.transform_matrix; shading_extgstate : Pdf.pdfobject; shading : shading_kind} type pattern = | ColouredTilingPattern of tiling | UncolouredTilingPattern of tiling | ShadingPattern of shading type colvals = | Floats of float list | Named of (string * float list) | Pattern of pattern let rec string_of_colvals = function | Floats fs -> "Floats " ^ fold_left ( ^ ) "" (map (function x -> string_of_float x ^ " ") fs) | Named (n, fs) -> "Named " ^ n ^ " " ^ string_of_colvals (Floats fs) | Pattern p -> "Pattern" type objectclass = | PathObject | TextObject | ClippingPathObject | PageDescriptionLevel | ShadingObject | InlineImageObject | ExternalObject let string_of_objectclass = function | PathObject -> "PathObject" | TextObject -> "TextObject" | ClippingPathObject -> "ClippingPathObject" | PageDescriptionLevel -> "PageDescriptionLevel" | ShadingObject -> "ShadingObject" | InlineImageObject -> "InlineImageObject" | ExternalObject -> "ExternalObject" type transparency_attributes = {fill_transparency : float; line_transparency : float} type path_attributes = {path_transform : Pdftransform.transform_matrix; path_fill : (Pdfspace.t * colvals) option; path_line : (Pdfspace.t * colvals) option; path_linewidth : float; path_joinstyle : int; path_capstyle : int; path_dash : float list * float; path_mitrelimit : float; path_transparency : transparency_attributes; path_intent : string} type text_attributes = {textmode : int} type textblock_attributes = {textblock_transform : Pdftransform.transform_matrix} type textblock = text_attributes * Pdfops.t type softmask_subtype = Alpha | Luminosity type transparency_group = {tr_group_colourspace : Pdf.pdfobject option; (* FIXME: This should be colourspace *) isolated : bool; knockout : bool; tr_graphic : t} and softmask = {softmask_subtype : softmask_subtype; transparency_group : transparency_group; softmask_bbox : float * float * float * float; backdrop : float list option; softmask_transfer : Pdffun.t option} and image_attributes = {image_transform : Pdftransform.transform_matrix; image_transparency : float; (* The /ca value *) image_softmask : softmask option} and fontname = string * Pdf.pdfobject (*r Name, font *) (* The main type for a graphic. It must be kept paired with the PDF it comes from, since it will reference objects (fonts, images etc) in that PDF. *) and graphic_elt = | Path of (path * path_attributes) | Text of textblock list * textblock_attributes | MCPoint of string | MCPointProperties of string * Pdf.pdfobject | MCSection of string * graphic_elt list | MCSectionProperties of string * Pdf.pdfobject * graphic_elt list | Image of image_attributes * int (* object number *) | GraphicInlineImage of Pdf.pdfobject * bytes * Pdftransform.transform_matrix | Clip of path * graphic_elt list | Shading of path option * shading * Pdftransform.transform_matrix and t = {elements : graphic_elt list; (* Page content *) fonts : fontname list; (* Fonts *) resources : Pdf.pdfobject} (* Anything else in /Resources *) (* Calculate the bounding box (xmin, xmax, ymin, ymax) of a graphic. *) let bbox_of_segment = function | Straight ((x1, y1), (x2, y2)) -> fmin x1 x2, fmax x1 x2, fmin y1 y2, fmax y1 y2 | Bezier ((x1, y1), (x2, y2), (x3, y3), (x4, y4)) -> fmin (fmin x1 x2) (fmin x3 x4), fmax (fmax x1 x2) (fmax x3 x4), fmin (fmin y1 y2) (fmin y3 y4), fmax (fmax y1 y2) (fmax y3 y4) let bbox_of_path (_, subpaths) = let segments = flatten (map (function (_, _, l) -> l) subpaths) in fold_left box_union_float (max_float, min_float, max_float, min_float) (map bbox_of_segment segments) let rec bbox_of_graphic_inner (xmin, xmax, ymin, ymax) = function | [] -> xmin, xmax, ymin, ymax | (Path (p, _) | Clip (p, _))::t -> bbox_of_graphic_inner (box_union_float (xmin, xmax, ymin, ymax) (bbox_of_path p)) t | h::t -> bbox_of_graphic_inner (xmin, xmax, ymin, ymax) t let bbox_of_graphic graphic = bbox_of_graphic_inner (max_float, min_float, max_float, min_float) graphic.elements (* For debug purposes, build a string of a graphic. *) let string_of_segment = function | Straight ((ax, ay), (bx, by)) -> Printf.sprintf "Straight line: (%f, %f) --> (%f, %f)\n" ax ay bx by | Bezier ((ax, ay), (bx, by), (cx, cy), (dx, dy)) -> Printf.sprintf "Bezier curve: (%f, %f) --> (%f, %f) --> (%f, %f) --> (%f, %f)\n" ax ay bx by cx cy dx dy let string_of_subpath (h, o ,segments) = Printf.sprintf "Hole: %b, Open: %b, segments:%s\n" (h = Hole) (o = Open) (fold_left ( ^ ) "" (map string_of_segment segments)) let string_of_path (windingrule, subpaths) = Printf.sprintf "%s %s" (match windingrule with | EvenOdd -> "Even-odd\n" | NonZero -> "Non-zero\n") (fold_left ( ^ ) "" (map string_of_subpath subpaths)) let string_of_textblock (st, op) = "TEXTPIECE: " ^ Pdfops.string_of_op op ^ "\n" let string_of_font (f, i) = f ^ " " ^ Pdfwrite.string_of_pdf i ^ "\n" let string_of_colvals = function | Floats l -> Printf.sprintf "Floats (%i)" (length l) | Named (s, fl) -> Printf.sprintf "Named %s, Floats (%i)" s (length fl) | Pattern _ -> Printf.sprintf "Pattern" let string_of_attributes a = let line = match a.path_line with | None -> "none" | Some (cs, vals) -> Printf.sprintf "line colourspace is %s, %s vals" (Pdfspace.string_of_colourspace cs) (string_of_colvals vals) and fill = match a.path_fill with | None -> "none" | Some (cs, vals) -> Printf.sprintf "fill colourspace is %s, %s vals" (Pdfspace.string_of_colourspace cs) (string_of_colvals vals) in line ^ "\n" ^ fill ^ "\n" let rec string_of_graphic_elt = function | MCSection (n, g) -> Printf.sprintf "Marked content section %s...\n" n ^ "BEGIN\n" ^ (fold_left ( ^ ) "" (map string_of_graphic_elt g)) ^ "\nEND Marked content section\n" | MCSectionProperties (n, d, g) -> Printf.sprintf "Marked content section %s with properties %s...\n" n (Pdfwrite.string_of_pdf d) ^ "BEGIN\n" ^ (fold_left ( ^ ) "" (map string_of_graphic_elt g)) ^ "\nEND Marked content section\n" | MCPoint n -> Printf.sprintf "Marked content point %s...\n" n | MCPointProperties (n, d) -> Printf.sprintf "Marked content point %s with properties %s...\n" n (Pdfwrite.string_of_pdf d) | Path (p, attributes) -> Printf.sprintf "Path: %s\nAttributes\n%s\n" (string_of_path p) (string_of_attributes attributes) | Text (ts, attr) -> "-----BEGIN TEXT - fonts:\n" ^ fold_left ( ^ ) "" (map string_of_textblock ts) ^ "-----END TEXT\n" | Image (tr, x) -> "Image " ^ string_of_int x ^ "\n" | GraphicInlineImage _ -> "Inline image\n" | Clip (p, g) -> "Clipview: path = " ^ string_of_path p ^ "\ngraphic is " ^ fold_left ( ^ ) "" (map string_of_graphic_elt g) | Shading (clip, shading, tr) -> "Shading\n" and string_of_graphic g = "Elements:\n" ^ fold_left ( ^ ) "" (map string_of_graphic_elt g.elements) ^ "Fonts:\n" ^ fold_left ( ^ ) "" (map (fun (name, obj) -> name ^ " " ^ Pdfwrite.string_of_pdf obj) g.fonts) ^ "Resources:\n" ^ Pdfwrite.string_of_pdf g.resources type state = {mutable objectclass : objectclass; (*r Not strictly part of the state, but fits here. *) mutable clip : path option; (*r Ditto - stores a clipping path which is to be invoked on the next path operation. *) mutable intent : string; mutable fill : colvals; mutable linewidth : float; mutable line : colvals; mutable mitrelimit : float; mutable joinstyle : int; mutable capstyle : int; mutable colourspace_stroke : Pdfspace.t; mutable colourspace_nonstroke : Pdfspace.t; mutable dash : float list * float; mutable flatness : int; mutable transform : Pdftransform.transform_matrix; mutable extra_transform : Pdftransform.transform_matrix; mutable text_transform : Pdftransform.transform_matrix; mutable text_line_transform : Pdftransform.transform_matrix; mutable opacity_stroke : float; mutable opacity_nonstroke : float; mutable character_spacing : float; mutable word_spacing : float; mutable scale : float; mutable leading : float; mutable font_and_size : (string * float) option; mutable font_render : int; mutable font_rise : float; mutable blendmode : int; mutable softmask : softmask option; mutable in_xobject : int; mutable opdo_matrix : Pdftransform.transform_matrix} let default_state () = {objectclass = PageDescriptionLevel; clip = None; intent = "/RelativeColorimetric"; fill = Floats [1.]; linewidth = 1.; line = Floats [1.]; mitrelimit = 10.; joinstyle = 0; capstyle = 0; colourspace_stroke = Pdfspace.DeviceGray; colourspace_nonstroke = Pdfspace.DeviceGray; dash = [], 0.; flatness = 0; transform = Pdftransform.i_matrix; extra_transform = Pdftransform.i_matrix; text_transform = Pdftransform.i_matrix; text_line_transform = Pdftransform.i_matrix; opacity_stroke = 1.; opacity_nonstroke = 1.; character_spacing = 0.; word_spacing = 0.; scale = 100.; leading = 0.; font_and_size = None; (*r No initial value. *) font_render = 0; font_rise = 0.; blendmode = 1; softmask = None; in_xobject = 0; opdo_matrix = Pdftransform.i_matrix} let state = ref (default_state ()) let string_of_state s = (*i "Object class: " ^ string_of_objectclass s.objectclass ^ "\n" ^ i*) "Stroke Colourspace: " ^ Pdfspace.string_of_colourspace s.colourspace_stroke ^ "\n" ^ "Nonstroke Colourspace: " ^ Pdfspace.string_of_colourspace s.colourspace_nonstroke ^ "\n" ^ "Stroke colours: " ^ string_of_colvals s.line ^ "\n" ^ "NonStroke colours: " ^ string_of_colvals s.fill ^ "\n" let path_attributes_fill_and_stroke () = {path_transform = (!state).transform; path_fill = Some ((!state).colourspace_nonstroke, (!state).fill); path_line = Some ((!state).colourspace_stroke, (!state).line); path_linewidth = (!state).linewidth; path_joinstyle = (!state).joinstyle; path_capstyle = (!state).capstyle; path_dash = (!state).dash; path_mitrelimit = (!state).mitrelimit; path_transparency = {fill_transparency = (!state).opacity_nonstroke; line_transparency = (!state).opacity_stroke}; path_intent = (!state).intent} let path_attributes_fill () = {path_transform = (!state).transform; path_fill = Some ((!state).colourspace_nonstroke, (!state).fill); path_line = None; path_linewidth = (!state).linewidth; path_joinstyle = (!state).joinstyle; path_capstyle = (!state).capstyle; path_dash = (!state).dash; path_mitrelimit = (!state).mitrelimit; path_transparency = {fill_transparency = (!state).opacity_nonstroke; line_transparency = 1.}; path_intent = (!state).intent} let path_attributes_stroke () = {path_transform = (!state).transform; path_fill = None; path_line = Some ((!state).colourspace_stroke, (!state).line); path_linewidth = (!state).linewidth; path_joinstyle = (!state).joinstyle; path_capstyle = (!state).capstyle; path_dash = (!state).dash; path_mitrelimit = (!state).mitrelimit; path_transparency = {fill_transparency = 1.; line_transparency = (!state).opacity_stroke}; path_intent = (!state).intent} let textstate () = {textmode = 0} let nonzero = EvenOdd let rec initial_colour pdf resources = function | Pdf.Name "/DeviceGray" | Pdf.Array (Pdf.Name "/CalGray"::_) -> Floats [0.] | Pdf.Name "/DeviceRGB" | Pdf.Array (Pdf.Name "/CalRGB"::_) -> Floats [0.; 0.; 0.] | Pdf.Name "/DeviceCMYK" -> Floats [0.; 0.; 0.; 1.] | Pdf.Name "/Pattern" | Pdf.Array [Pdf.Name "/Pattern"] -> Floats [0.] | Pdf.Array elts as cs -> begin match elts with | [Pdf.Name "/ICCBased"; iccstream] -> begin match Pdf.lookup_direct pdf "/Alternate" iccstream with | Some space -> initial_colour pdf resources space | None -> begin match Pdf.lookup_direct pdf "/N" iccstream with | Some (Pdf.Integer 1) -> Floats [0.] | Some (Pdf.Integer 3) -> Floats [0.; 0.; 0.] | Some (Pdf.Integer 4) -> Floats [0.; 0.; 0.; 0.] | _ -> raise (Pdf.PDFError "Bad ICCBased Alternate") end end | Pdf.Name "/DeviceN"::_::alternate::_ | [Pdf.Name "/Separation"; _; alternate; _] -> initial_colour pdf resources alternate | [Pdf.Name "/Pattern"; alternate] -> initial_colour pdf resources alternate | _ -> Pdfe.log (Printf.sprintf "%s\n" (Pdfwrite.string_of_pdf cs)); raise (Pdf.PDFError "Unknown colourspace A") end | Pdf.Indirect _ as indirect -> initial_colour pdf resources (Pdf.direct pdf indirect) | _ -> raise (Pdf.PDFError "Unknown colourspace B") (* PartialPath (sp, cp, p, s) is starting point [sp], current point [cp] the partial segment list [p], subpath [s] and graphic [g]. *) type partial = | NoPartial | PartialText of textblock list | PartialPath of fpoint * fpoint * segment list * subpath list (* g is a [group_transparency] xobject *) let rec read_transparency_group pdf g = let group = match Pdf.lookup_direct pdf "/Group" g with | Some gr -> gr | None -> raise (Pdf.PDFError "Pdfgraphics.read_transparency_group: no /Group found") in let colourspace = Pdf.lookup_direct pdf "/CS" group and isolated = match Pdf.lookup_direct pdf "/I" group with | Some (Pdf.Boolean b) -> b | _ -> false and knockout = match Pdf.lookup_direct pdf "/K" group with | Some (Pdf.Boolean b) -> b | _ -> false and graphic = let fakepage = let resources = match Pdf.lookup_direct pdf "/Resources" g with | Some (Pdf.Dictionary d) -> Pdf.Dictionary d | _ -> Pdf.Dictionary [] and contents = [g] in {Pdfpage.content = contents; Pdfpage.mediabox = Pdf.Null; Pdfpage.resources = resources; Pdfpage.rotate = Pdfpage.Rotate0; Pdfpage.rest = Pdf.Dictionary []} in graphic_of_page pdf fakepage and a, b, c, d = Pdf.parse_rectangle pdf (Pdf.lookup_fail "no bbox" pdf "/BBox" g) in {tr_group_colourspace = colourspace; isolated = isolated; knockout = knockout; tr_graphic = graphic}, a, b, c, d and read_soft_mask pdf mask = match match Pdf.lookup_direct pdf "/S" mask with | Some (Pdf.Name "/Alpha") -> Some Alpha | Some (Pdf.Name "/Luminosity") -> Some Luminosity | _ -> None with | None -> None | Some subtype -> let transparency_group, a, b, c, d = match Pdf.lookup_direct pdf "/G" mask with | Some g -> read_transparency_group pdf g | None -> raise (Pdf.PDFError "Pdfgraphics.transparency group not found in soft mask") and backdrop = match Pdf.lookup_direct pdf "/BC" mask with | Some (Pdf.Array nums) -> Some (map (Pdf.getnum pdf) nums) | _ -> None and transfer = match Pdf.lookup_direct pdf "/TR" mask with | Some (Pdf.Dictionary d) -> Some (Pdffun.parse_function pdf (Pdf.Dictionary d)) | _ -> None in Some {softmask_subtype = subtype; transparency_group = transparency_group; backdrop = backdrop; softmask_transfer = transfer; softmask_bbox = (a, b, c, d)} and update_graphics_state_from_dict pdf resources gdict = begin match Pdf.lookup_direct pdf "/SMask" gdict with | Some softmask -> (!state).softmask <- read_soft_mask pdf softmask | None -> () end; begin match Pdf.lookup_direct pdf "/CA" gdict with | Some (Pdf.Real o) -> (!state).opacity_stroke <- o | _ -> () end; begin match Pdf.lookup_direct pdf "/ca" gdict with | Some (Pdf.Real o) -> (!state).opacity_nonstroke <- o | _ -> () end; begin match Pdf.lookup_direct pdf "/BM" gdict with | Some (Pdf.Name n) | Some (Pdf.Array (Pdf.Name n::_)) -> (!state).blendmode <- 0 (* FIXME: Do properly *) | _ -> () end; begin match Pdf.lookup_direct pdf "/LW" gdict with | Some (Pdf.Integer width) -> (!state).linewidth <- float width | Some (Pdf.Real width) -> (!state).linewidth <- width | _ -> () end; begin match Pdf.lookup_direct pdf "/LC" gdict with | Some (Pdf.Integer style) -> (!state).capstyle <- style | _ -> () end; begin match Pdf.lookup_direct pdf "/LC" gdict with | Some (Pdf.Integer join) -> (!state).joinstyle <- join | _ -> () end; begin match Pdf.lookup_direct pdf "/ML" gdict with | Some (Pdf.Integer limit) -> (!state).mitrelimit <- float limit | Some (Pdf.Real limit) -> (!state).mitrelimit <- limit | _ -> () end; begin match Pdf.lookup_direct pdf "/D" gdict with | Some (Pdf.Array [Pdf.Array dashes; phase]) -> let dashnums, phase = map (function | (Pdf.Integer n) -> float n | (Pdf.Real n) -> n | _ -> raise (Pdf.PDFError "Malformed dash.")) dashes, match phase with | Pdf.Integer phase -> float phase | Pdf.Real phase -> phase | _ -> raise (Pdf.PDFError "Malformed dash phase.") in (!state).dash <- dashnums, phase | _ -> () end and statestack : state list ref = ref [] and copystate () = {!state with fill = (!state).fill} and push_statestack () = (*i Printf.printf "push_statestack\n"; i*) statestack =| copystate () and pop_statestack () = (*i Printf.printf "pop_statestack: %i items in stack before pop\n" (length !statestack); Printf.printf "Before pop_statestack, line and fill spaces are %s and %s\n" (Pdfspace.string_of_colourspace (!state).colourspace_stroke) (Pdfspace.string_of_colourspace (!state).colourspace_nonstroke); I*) begin match !statestack with | [] -> raise (Pdf.PDFError "Unbalanced q/Q Ops") | h::t -> statestack := t; state := h end(*i ; Printf.printf "After pop_statestack, line and fill spaces are %s and %s\n" (Pdfspace.string_of_colourspace (!state).colourspace_stroke) (Pdfspace.string_of_colourspace (!state).colourspace_nonstroke) i*) and read_tiling_pattern _ = ColouredTilingPattern Tiling and read_function_shading pdf shading = let domain = match Pdf.lookup_direct pdf "/Domain" shading with | Some (Pdf.Array [a; b; c; d]) -> Pdf.getnum pdf a, Pdf.getnum pdf b, Pdf.getnum pdf c, Pdf.getnum pdf d | _ -> 0., 1., 0., 1. and matrix = Pdf.parse_matrix pdf "/Matrix" shading and func = Pdf.lookup_fail "No function found" pdf "/Function" shading in FunctionShading {funshading_domain = domain; funshading_matrix = matrix; funshading_function = Pdffun.parse_function pdf func} and read_radial_shading pdf shading = let coords = match Pdf.lookup_direct pdf "/Coords" shading with | Some (Pdf.Array [a; b; c; d; e; f]) -> Pdf.getnum pdf a, Pdf.getnum pdf b, Pdf.getnum pdf c, Pdf.getnum pdf d, Pdf.getnum pdf e, Pdf.getnum pdf f | _ -> raise (Pdf.PDFError "Pdfgraphics.read_radial_shading: no coords in radial shading") and domain = match Pdf.lookup_direct pdf "/Domain" shading with | Some (Pdf.Array [a; b]) -> Pdf.getnum pdf a, Pdf.getnum pdf b | _ -> 0., 1. and func = match Pdf.lookup_direct pdf "/Function" shading with | Some (Pdf.Array fs) -> map (Pdffun.parse_function pdf) fs | Some f -> [Pdffun.parse_function pdf f] | _ -> raise (Pdf.PDFError "Pdfgraphics.read_radial_shading: no function in radial shading") and extend = match Pdf.lookup_direct pdf "/Extend" shading with | Some (Pdf.Array [Pdf.Boolean a; Pdf.Boolean b]) -> a, b | _ -> false, false in RadialShading {radialshading_coords = coords; radialshading_domain = domain; radialshading_function = func; radialshading_extend = extend} and read_axial_shading pdf shading = let coords = match Pdf.lookup_direct pdf "/Coords" shading with | Some (Pdf.Array [a; b; c; d]) -> Pdf.getnum pdf a, Pdf.getnum pdf b, Pdf.getnum pdf c, Pdf.getnum pdf d | _ -> raise (Pdf.PDFError "Pdfgraphics.read_axial_shading: no coords in radial shading") and domain = match Pdf.lookup_direct pdf "/Domain" shading with | Some (Pdf.Array [a; b]) -> Pdf.getnum pdf a, Pdf.getnum pdf b | _ -> 0., 1. and func = match Pdf.lookup_direct pdf "/Function" shading with | Some (Pdf.Array fs) -> map (Pdffun.parse_function pdf) fs | Some f -> [Pdffun.parse_function pdf f] | _ -> raise (Pdf.PDFError "Pdfgraphics.read_axial_shading: no function in radial shading") and extend = match Pdf.lookup_direct pdf "/Extend" shading with | Some (Pdf.Array [Pdf.Boolean a; Pdf.Boolean b]) -> a, b | _ -> false, false in AxialShading {axialshading_coords = coords; axialshading_domain = domain; axialshading_function = func; axialshading_extend = extend} (* Read a shading pattern *) and read_shading pdf matrix extgstate shading = let colourspace = Pdf.lookup_fail "No colourspace in shading" pdf "/ColorSpace" shading and background = Pdf.lookup_direct pdf "/Background" shading and bbox = Pdf.lookup_direct pdf "/BBox" shading and antialias = match Pdf.lookup_direct pdf "/BBox" shading with | Some (Pdf.Boolean true) -> true | _ -> false in let shading = match Pdf.lookup_fail "no /ShadingType" pdf "/ShadingType" shading with | Pdf.Integer 1 -> read_function_shading pdf shading | Pdf.Integer 3 -> read_radial_shading pdf shading | Pdf.Integer 2 -> read_axial_shading pdf shading | Pdf.Integer 4 -> FreeFormGouraudShading | Pdf.Integer 5 -> LatticeFormGouraudShading | Pdf.Integer 6 -> CoonsPatchMesh | Pdf.Integer 7 -> TensorProductPatchMesh | _ -> raise (Pdf.PDFError "Pdfgraphics.unknown shadingtype") in {shading_colourspace = colourspace; shading_background = background; shading_bbox = bbox; shading_antialias = antialias; shading_matrix = matrix; shading_extgstate = extgstate; shading = shading} and read_shading_pattern pdf p = let matrix = Pdf.parse_matrix pdf "/Matrix" p and extgstate = match Pdf.lookup_direct pdf "/ExtGState" p with | Some (Pdf.Dictionary _ as d) -> d | _ -> Pdf.Dictionary [] in match Pdf.lookup_direct pdf "/Shading" p with | Some shading -> ShadingPattern (read_shading pdf matrix extgstate shading) | _ -> raise (Pdf.PDFError "No shading dictionary") and read_pattern pdf page name = match Pdf.lookup_direct pdf "/Pattern" page.Pdfpage.resources with | None -> raise (Pdf.PDFError "No pattern dictionary") | Some patterndict -> match Pdf.lookup_direct pdf name patterndict with | None -> raise (Pdf.PDFError "Pattern not found") | Some pattern -> match Pdf.lookup_direct pdf "/PatternType" pattern with | Some (Pdf.Integer 1) -> read_tiling_pattern pattern | Some (Pdf.Integer 2) -> read_shading_pattern pdf pattern | _ -> raise (Pdf.PDFError "unknown pattern") and process_op pdf page (partial, graphic) op = let ret = (partial, graphic) in (*i flprint (string_of_state !state); *) (*i flprint (Pdfpages.string_of_op op ^ "\n"); i*) match op with | Pdfops.Op_W -> (* Move the current partial path into Clip, and return *) begin match partial with | PartialPath (_, _, segments, subpaths) -> if segments = [] && subpaths = [] then ret else let path = if segments <> [] then (Not_hole, Closed, rev segments)::subpaths else subpaths in (!state).clip <- Some (NonZero, path); ret | _ -> ret end (* FIXME: In NextClip needs to support possibly several clips, since we can do W n W n W n f, for instance? *) | Pdfops.Op_W' -> begin match partial with | PartialPath (_, _, segments, subpaths) -> if segments = [] && subpaths = [] then ret else let path = if segments <> [] then (Not_hole, Closed, rev segments)::subpaths else subpaths in (!state).clip <- Some (EvenOdd, path); ret | _ -> ret end | Pdfops.InlineImage (dict, data) -> (NoPartial, GraphicInlineImage (dict, data, (!state).transform)::graphic) | Pdfops.Op_MP name -> begin match (!state).objectclass with | PageDescriptionLevel -> (NoPartial, MCPoint name::graphic) | TextObject -> ret (* FIXME -- Add it to the text partial. *) | _ -> ret (* Invalid, silently drop *) end | Pdfops.Op_DP (name, properties) -> begin match (!state).objectclass with | PageDescriptionLevel -> (NoPartial, MCPointProperties (name, properties)::graphic) | TextObject -> ret (* FIXME -- Add it to the text partial. *) | _ -> ret (* Invalid, silently drop *) end | Pdfops.Op_BX | Pdfops.Op_EX -> ret | Pdfops.Op_ri n -> (!state).intent <- n; ret | Pdfops.Op_j j -> (!state).joinstyle <- j; ret | Pdfops.Op_J c -> (!state).capstyle <- c; ret | Pdfops.Op_w w -> (!state).linewidth <- w; ret | Pdfops.Op_M m -> (!state).mitrelimit <- m; ret | Pdfops.Op_q -> (*i flprint "Op_q\n"; i*) push_statestack (); ret | Pdfops.Op_Q -> (*i flprint "Op_Q\n"; i*) pop_statestack (); ret | Pdfops.Op_SC vals | Pdfops.Op_SCN vals -> (!state).line <- Floats vals; ret | Pdfops.Op_sc vals | Pdfops.Op_scn vals -> (!state).fill <- Floats vals; ret | Pdfops.Op_scnName (name, vals) -> begin match (!state).colourspace_nonstroke with | Pdfspace.Pattern | Pdfspace.PatternWithBaseColourspace _ -> begin try (!state).fill <- Pattern (read_pattern pdf page name); ret with _ -> ret end | _ -> (!state).fill <- Named (name, vals); ret end | Pdfops.Op_SCNName (name, vals) -> begin match (!state).colourspace_stroke with | Pdfspace.Pattern | Pdfspace.PatternWithBaseColourspace _ -> begin try (!state).line <- Pattern (read_pattern pdf page name); ret with _ -> ret end | _ -> (!state).line <- Named (name, vals); ret end | Pdfops.Op_CS c -> (*i Printf.printf "Op_CS: %s\n" c; *) (!state).colourspace_nonstroke <- Pdfspace.read_colourspace pdf page.Pdfpage.resources (Pdf.Name c); ret | Pdfops.Op_cs c -> (*i flprint "Op_cs\n"; Printf.printf "Pdfgraphics: Op_cs: %s\n" c; i*) (!state).colourspace_nonstroke <- Pdfspace.read_colourspace pdf page.Pdfpage.resources (Pdf.Name c); ret | Pdfops.Op_G gv -> (*i flprint "Op_G\n"; i*) (!state).colourspace_stroke <- Pdfspace.DeviceGray; (!state).line <- Floats [gv]; ret | Pdfops.Op_g gv -> (*i flprint "Op_g\n"; i*) (!state).colourspace_nonstroke <- Pdfspace.DeviceGray; (!state).fill <- Floats [gv]; ret | Pdfops.Op_RG (rv, gv, bv) -> (!state).colourspace_stroke <- Pdfspace.DeviceRGB; (!state).line <- Floats [rv; gv; bv]; ret | Pdfops.Op_rg (rv, gv, bv) -> (!state).colourspace_nonstroke <- Pdfspace.DeviceRGB; (!state).fill <- Floats [rv; gv; bv]; ret | Pdfops.Op_K (c, m, y, k) -> (!state).colourspace_stroke <- Pdfspace.DeviceCMYK; (!state).line <- Floats [c; y; m; k]; ret | Pdfops.Op_k (c, m, y, k) -> (!state).colourspace_nonstroke <- Pdfspace.DeviceCMYK; (!state).fill <- Floats [c; y; m; k]; ret | Pdfops.Op_gs name -> let ext_state_dict = Pdf.lookup_fail "Bad Op_gs" pdf "/ExtGState" page.Pdfpage.resources in let gdict = Pdf.lookup_fail "Bad Op_gs" pdf name ext_state_dict in update_graphics_state_from_dict pdf page.Pdfpage.resources gdict; ret | Pdfops.Op_m (x, y) -> (* Begin a new subpath. Get into path mode if not already there. If the last op was an [Op_m], it should have no effect. *) (!state).objectclass <- PathObject; begin match partial with | PartialPath (sp, cp, segs, subpaths) -> if segs = [] then PartialPath ((x, y), (x, y), [], subpaths), graphic else PartialPath ((x, y), (x, y), [], (Not_hole, Open, rev segs)::subpaths), graphic | _ -> PartialPath ((x, y), (x, y), [], []), graphic end | Pdfops.Op_l (x, y) -> if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_l"); begin match partial with | PartialPath (sp, cp, segs, subpaths) -> PartialPath (sp, (x, y), Straight (cp, (x, y))::segs, subpaths), graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_l") end | Pdfops.Op_c (a, b, c, d, e, f) -> if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_c"); begin match partial with | PartialPath (sp, cp, segs, subpaths) -> let ep = (e, f) in let curve = Bezier (cp, (a, b), (c, d), ep) in PartialPath (sp, ep, curve::segs, subpaths), graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_c") end | Pdfops.Op_v (a, b, c, d) -> if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_v"); begin match partial with | PartialPath (sp, cp, segs, subpaths) -> let ep = (c, d) in let curve = Bezier (cp, cp, (a, b), ep) in PartialPath (sp, ep, curve::segs, subpaths), graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_v") end | Pdfops.Op_y (a, b, c, d) -> if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_y"); begin match partial with | PartialPath (sp, cp, segs, subpaths) -> let ep = (c, d) in let curve = Bezier (cp, (a, b), ep, ep) in PartialPath (sp, ep, curve::segs, subpaths), graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_y") end | Pdfops.Op_h -> if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_h - not in PathObject"); begin match partial with | PartialPath (sp, cp, segs, subpaths) -> PartialPath (sp, cp, [], (Not_hole, Closed, rev segs)::subpaths), graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_h - not a partial path") end | Pdfops.Op_s -> (* Close and stroke. Equivalent to h S *) process_ops pdf page ret [Pdfops.Op_h; Pdfops.Op_S] | Pdfops.Op_b -> (* Close, fill, stroke, nonzero. Equivalent to h B *) process_ops pdf page ret [Pdfops.Op_h; Pdfops.Op_B] | Pdfops.Op_b' -> (* Close, fill, stroke, evenodd. Equivalent to h B* *) process_ops pdf page ret [Pdfops.Op_h; Pdfops.Op_B'] | Pdfops.Op_f | Pdfops.Op_F -> (* Close and Fill non-zero *) if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_f"); let partial, graphic = process_op pdf page (partial, graphic) Pdfops.Op_h in (!state).objectclass <- PageDescriptionLevel; begin match partial with | PartialPath (sp, cp, segs, subpaths) -> (* segs is empty, due to [Op_h] *) PartialPath (sp, cp, [], []), Path ((NonZero, rev subpaths), path_attributes_fill ())::graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_f") end | Pdfops.Op_S -> (* Stroke *) if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_S"); (!state).objectclass <- PageDescriptionLevel; begin match partial with | PartialPath (sp, cp, segs, subpaths) -> if segs = [] then PartialPath (sp, cp, [], []), Path ((EvenOdd, rev subpaths), path_attributes_stroke ())::graphic else PartialPath (sp, cp, [], []), Path ((EvenOdd, rev ((Not_hole, Open, rev segs)::subpaths)), path_attributes_stroke ())::graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_S") end | Pdfops.Op_B -> (* Fill and stroke, non-zero. *) if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_B"); (!state).objectclass <- PageDescriptionLevel; begin match partial with | PartialPath (sp, cp, segs, subpaths) -> if segs = [] then PartialPath (sp, cp, [], []), Path ((NonZero, rev subpaths), path_attributes_fill_and_stroke ())::graphic else PartialPath (sp, cp, [], []), Path ((NonZero, rev ((Not_hole, Open, rev segs)::subpaths)), path_attributes_fill_and_stroke ()) ::graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_B") end | Pdfops.Op_B' -> (* Fill and stroke, even-odd. *) if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_B*"); let partial, graphic = process_op pdf page (partial, graphic) Pdfops.Op_h in (!state).objectclass <- PageDescriptionLevel; begin match partial with | PartialPath (sp, cp, segs, subpaths) -> if segs = [] then PartialPath (sp, cp, [], []), Path ((EvenOdd, rev subpaths), path_attributes_fill_and_stroke ())::graphic else PartialPath (sp, cp, [], []), Path ((EvenOdd, rev ((Not_hole, Open, rev segs)::subpaths)), path_attributes_fill_and_stroke ()) ::graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_B*") end | Pdfops.Op_f' -> (* Fill, even-odd *) if (!state).objectclass <> PathObject then raise (Pdf.PDFError "Pdfgraphics: Op_f*"); (!state).objectclass <- PageDescriptionLevel; begin match partial with | PartialPath (sp, cp, segs, subpaths) -> if segs = [] then PartialPath (sp, cp, [], []), Path ((EvenOdd, rev subpaths), path_attributes_fill ())::graphic else PartialPath (sp, cp, [], []), Path ((EvenOdd, rev ((Not_hole, Open, rev segs)::subpaths)), path_attributes_fill ()) ::graphic | _ -> raise (Pdf.PDFError "Pdfgraphics: Op_f*") end | Pdfops.Op_n -> (* no-op *) (!state).objectclass <- PageDescriptionLevel; (* for now, until we support clipviews, clean up the polygon *) (NoPartial, graphic) | Pdfops.Op_re (x, y, w, h) -> (* Rectangle. *) let ops = [Pdfops.Op_m (x, y); Pdfops.Op_l (x +. w, y); Pdfops.Op_l (x +. w, y +. h); Pdfops.Op_l (x, y +. h); Pdfops.Op_h] in process_ops pdf page (partial, graphic) ops | Pdfops.Op_Do name -> begin match Pdf.lookup_direct pdf "/XObject" page.Pdfpage.resources with | Some d -> begin match Pdf.lookup_direct pdf name d with | Some xobj -> begin match Pdf.lookup_direct pdf "/Subtype" xobj with | Some (Pdf.Name "/Image") -> let objnum = match Pdf.find_indirect name d with | None -> raise (Pdf.PDFError "image not found") | Some i -> i in partial, Image ({image_transform = (!state).transform; image_transparency = (!state).opacity_nonstroke; image_softmask = (!state).softmask} , objnum)::graphic | Some (Pdf.Name "/Form") -> let elts = read_form_xobject pdf page xobj in partial, rev elts @ graphic | _ -> raise (Pdf.PDFError "Unknown kind of xobject") end | _ -> raise (Pdf.PDFError "Unknown xobject") end | None -> raise (Pdf.PDFError "xobject not found") end | Pdfops.Op_cm tr -> (!state).transform <- Pdftransform.matrix_compose (!state).transform tr; ret | ( Pdfops.Op_Tc _ | Pdfops.Op_Tw _ | Pdfops.Op_Tz _ | Pdfops.Op_TL _ | Pdfops.Op_Tf _ | Pdfops.Op_Tr _ | Pdfops.Op_Ts _ | Pdfops.Op_Td _ | Pdfops.Op_TD _ | Pdfops.Op_Tm _ | Pdfops.Op_T' | Pdfops.Op_Tj _ | Pdfops.Op_TJ _ | Pdfops.Op_' _ | Pdfops.Op_'' _ | Pdfops.Op_d0 _ | Pdfops.Op_d1 _) as op -> begin match partial with | PartialText t -> let st = textstate () in PartialText ((st, op)::t), graphic | _ -> (* If there's no partial text, this is an op affecting the text state but not in a text section. Such ops are allowed. FIXME: Deal with them properly - by ops altering the text state so this can be reflected in the initial state at the start of a text section *) ret end | Pdfops.Op_sh n -> let shading = let shadingdict = Pdf.lookup_fail "no /Shading" pdf "/Shading" page.Pdfpage.resources in let shading = Pdf.lookup_fail "named shading not found" pdf n shadingdict in read_shading pdf Pdftransform.i_matrix Pdf.Null shading and currentclip = (!state).clip in partial, Shading (currentclip, shading, (!state).transform)::graphic | Pdfops.Op_i flatness -> if flatness >= 0 && flatness <= 100 then (!state).flatness <- flatness; ret | Pdfops.Op_d (spec, phase) -> (!state).dash <- spec, phase; ret | Pdfops.Op_Unknown _ -> ret | _ -> Pdfe.log "Operator shouldn't appear at this place"; ret and getuntil_matching_emc level prev = function | (Pdfops.Op_BMC _ | Pdfops.Op_BDC (_, _)) as h::t -> getuntil_matching_emc (level + 1) (h::prev) t | Pdfops.Op_EMC::t -> if level < 0 then raise (Pdf.PDFError "Too many EMCs\n") else if level = 0 then rev prev, t else getuntil_matching_emc (level - 1) (Pdfops.Op_EMC::prev) t | h::t -> getuntil_matching_emc level (h::prev) t | [] -> raise (Pdf.PDFError "Missing EMC\n") and getuntil_matching_Q level prev = function | Pdfops.Op_q::t -> getuntil_matching_Q (level + 1) (Pdfops.Op_q::prev) t | Pdfops.Op_Q::t -> if level = 0 then rev prev, Pdfops.Op_Q::t else getuntil_matching_Q (level - 1) (Pdfops.Op_Q::prev) t | [] -> rev prev, [] | h::t -> getuntil_matching_Q level (h::prev) t and process_ops pdf page (partial, graphic) ops = match ops with | [] -> partial, rev graphic | Pdfops.Op_n::t -> (* If there's a NextClip, select all operators within the scope of this clip. That is, all operators until an [Op_Q] which puts the stack level below the current level or the end of the stream, whichever comes first.*) begin match (!state).clip with | None -> process_ops pdf page (partial, graphic) t | Some path -> (* We process the operators concerned, putting them inside a Clip, and then proceed with the remaining operators (including any [Op_Q]). However, to deal with the case of overlapping pairs of marked content sections and q/Q pairs (which is allowed). Currently just chuck BDC we don't understand. *) let toq, rest = getuntil_matching_Q 0 [] t in let _, elts = process_ops pdf page (NoPartial, []) toq in process_ops pdf page (NoPartial, Clip (path, elts)::graphic) rest end | Pdfops.Op_BMC n::t -> (* FIXME: Marked content regions / q/Q pairs overlapping problem *) begin try let ops, rest = getuntil_matching_emc 0 [] t in let partial, graphic' = process_ops pdf page (partial, []) ops in process_ops pdf page (partial, MCSection (n, graphic')::graphic) rest with _ -> process_ops pdf page (partial, graphic) t end | Pdfops.Op_BDC (n, d)::t -> (* FIXME: Marked content regions / q/Q pairs overlapping problem *) begin try let ops, rest = getuntil_matching_emc 0 [] t in let partial, graphic' = process_ops pdf page (partial, []) ops in process_ops pdf page (partial, MCSectionProperties (n, d, graphic')::graphic) rest with _ -> process_ops pdf page (partial, graphic) t end | Pdfops.Op_BT::t -> (* Can't nest text sections, so just get to ET *) let textops, rest = cleavewhile (neq Pdfops.Op_ET) t in begin match rest with | Pdfops.Op_ET::_ | [] -> (* We allow blank in case of wrongly nested EMC / ET etc *) let more = tail_no_fail rest in (* We need to process the ops, and capture the text operations, but state changes inside text sections (e.g colour changes) have global effect, so need to keep the state *) (!state).objectclass <- TextObject; let partial, _ = process_ops pdf page (PartialText [], graphic) textops in begin match partial with | PartialText t -> let textblock = Text (rev t, {textblock_transform = (!state).transform}) in process_ops pdf page (partial, textblock::graphic) (Pdfops.Op_ET::more) | _ -> raise (Pdf.PDFError "Bad operations in text block") end | _ -> (*i Printf.printf "textops: %s\n\n" (Pdfops.string_of_ops textops); Printf.printf "rest: %s\n\n" (Pdfops.string_of_ops rest); i*) raise (Pdf.PDFError "No Matching Op_ET") end | Pdfops.Op_ET::t -> (!state).objectclass <- PageDescriptionLevel; process_ops pdf page (partial, graphic) t | h::t -> process_ops pdf page (process_op pdf page (partial, graphic) h) t (* Load the fonts as (name, pdfobject) pairs *) and fonts_of_page pdf page = match Pdf.lookup_direct pdf "/Font" page.Pdfpage.resources with | Some (Pdf.Dictionary fs) -> fs | _ -> [] (* Find the operations of a form xobject. *) and read_form_xobject pdf page pdfobject = let content = [Pdf.direct pdf pdfobject] in let pagedict = match Pdf.direct pdf page.Pdfpage.resources with | Pdf.Dictionary rs -> rs | _ -> [] and xobjdict = match Pdf.direct pdf pdfobject with | Pdf.Stream {contents = (dict, _)} -> begin match Pdf.lookup_direct pdf "/Resources" dict with | Some (Pdf.Dictionary rs) -> rs | _ -> [] end | _ -> raise (Pdf.PDFError "bad stream in read_form_xobject") in let total_resources = Pdf.Dictionary (mergedict pagedict xobjdict) in let fake_page = {Pdfpage.content = []; Pdfpage.mediabox = Pdf.Null; Pdfpage.resources = total_resources; Pdfpage.rotate = Pdfpage.Rotate0; Pdfpage.rest = Pdf.Dictionary []} in let _, graphic_elts = (process_ops pdf fake_page (NoPartial, []) (Pdfops.parse_operators pdf total_resources content)) in graphic_elts (* Main function - build a graphic from a page *) and graphic_of_page pdf page = statestack := []; state := default_state (); if Pdfcrypt.is_encrypted pdf then raise (Pdf.PDFError "Pdfgraphics: File is encrypted") else begin let _, elts = let ops = Pdfops.parse_operators pdf page.Pdfpage.resources page.Pdfpage.content in process_ops pdf page (NoPartial, []) ops in {elements = elts; fonts = fonts_of_page pdf page; resources = page.Pdfpage.resources} end let graphic_of_ops ops = graphic_of_page (Pdf.empty ()) {(Pdfpage.blankpage Pdfpaper.a4) with Pdfpage.content = [Pdf.Stream {contents = (Pdf.Dictionary [], Pdf.Got (bytes_of_string (Pdfops.string_of_ops ops)))}]} (* \section{Building a page from a graphic} *) let int_of_shading_kind = function | FunctionShading _ -> 1 | AxialShading _ -> 2 | RadialShading _ -> 3 | FreeFormGouraudShading -> 4 | LatticeFormGouraudShading -> 5 | CoonsPatchMesh -> 6 | TensorProductPatchMesh -> 7 let entries_of_shading pdf s = match s.shading with | RadialShading r -> let coords = let a, b, c, d, e, f = r.radialshading_coords in Pdf.Array [Pdf.Real a; Pdf.Real b; Pdf.Real c; Pdf.Real d; Pdf.Real e; Pdf.Real f] and domain = let a, b = r.radialshading_domain in Pdf.Array [Pdf.Real a; Pdf.Real b] and funcnum = match r.radialshading_function with | [f] -> Pdf.addobj pdf (Pdffun.pdfobject_of_function pdf f) | funs -> Pdf.addobj pdf (Pdf.Array (map (Pdffun.pdfobject_of_function pdf) funs)) and extend = Pdf.Array [Pdf.Boolean (fst r.radialshading_extend); Pdf.Boolean (snd r.radialshading_extend)] in ["/Coords", coords; "/Domain", domain; "/Function", Pdf.Indirect funcnum; "/Extend", extend] | AxialShading a -> let coords = let a, b, c, d = a.axialshading_coords in Pdf.Array [Pdf.Real a; Pdf.Real b; Pdf.Real c; Pdf.Real d] and domain = let a, b = a.axialshading_domain in Pdf.Array [Pdf.Real a; Pdf.Real b] and funcnum = match a.axialshading_function with | [f] -> Pdf.addobj pdf (Pdffun.pdfobject_of_function pdf f) | funs -> Pdf.addobj pdf (Pdf.Array (map (Pdffun.pdfobject_of_function pdf) funs)) and extend = Pdf.Array [Pdf.Boolean (fst a.axialshading_extend); Pdf.Boolean (snd a.axialshading_extend)] in ["/Coords", coords; "/Domain", domain; "/Function", Pdf.Indirect funcnum; "/Extend", extend] | _ -> [] let shading_object_of_shading pdf s = let background = match s.shading_background with | None -> [] | Some b -> ["/Background", b] and bbox = match s.shading_bbox with | None -> [] | Some b -> ["/BBox", b] in Pdf.Dictionary (["/ShadingType", Pdf.Integer (int_of_shading_kind s.shading); "/ColorSpace", s.shading_colourspace; "/AntiAlias", Pdf.Boolean s.shading_antialias] @ background @ bbox @ entries_of_shading pdf s) let pattern_object_of_pattern xobject_level opdo_matrix pdf = function | ShadingPattern s -> begin try let shading_matrix = if xobject_level > 0 then let inverted = Pdftransform.matrix_invert opdo_matrix in Pdftransform.matrix_compose inverted s.shading_matrix else s.shading_matrix in Pdf.Dictionary ["/Type", Pdf.Name "/Pattern"; "/PatternType", Pdf.Integer 2; "/Shading", shading_object_of_shading pdf s; "/Matrix", Pdf.make_matrix shading_matrix] with Pdftransform.NonInvertable -> raise (Pdf.PDFError "Pdfgraphics.Bad pattern") end | _ -> Pdfe.log "Unknown pattern\n"; Pdf.Dictionary [] (* Output a move and line/curve ops. *) let ops_of_segs segs closure = let raw_seg_ops = map (function | Straight (_, (x, y)) -> Pdfops.Op_l (x, y) | Bezier (_, (bx, by), (cx, cy), (dx, dy)) -> Pdfops.Op_c (bx, by, cx, cy, dx, dy)) segs and get_move = function | Straight ((x, y), _) | Bezier ((x, y), _, _, _) -> Pdfops.Op_m (x, y) in (* Predicate: Do we need to close this subpath? *) match segs with | [] -> [] | h::_ -> get_move h::raw_seg_ops @ (if closure = Closed then [Pdfops.Op_h] else []) let protect ops = [Pdfops.Op_q] @ ops @ [Pdfops.Op_Q] let attribute_ops_of_path (_, a) = [Pdfops.Op_w a.path_linewidth; Pdfops.Op_J a.path_capstyle; Pdfops.Op_j a.path_joinstyle; begin match a.path_dash with (x, y) -> Pdfops.Op_d (x, y) end; Pdfops.Op_M a.path_mitrelimit; Pdfops.Op_ri a.path_intent] let transform_ops_of_path (_, a) = [Pdfops.Op_cm a.path_transform] let stroke_ops_of_path ((winding, _), a) = match winding, a.path_fill, a.path_line with | _, None, None -> Pdfops.Op_n | EvenOdd, Some _, Some _ -> Pdfops.Op_B' | EvenOdd, Some _, None -> Pdfops.Op_f' | NonZero, Some _, Some _ -> Pdfops.Op_B | NonZero, Some _, None -> Pdfops.Op_f | _, None, Some _ -> Pdfops.Op_S let path_ops_of_path (_, subpaths) = flatten (map (fun (_, closure, segs) -> ops_of_segs segs closure) subpaths) let ops_of_path pdf page (((winding, subpaths), a) as p) = (* Add a colourspace returning new resources and a new name, or return the name it's already held under. *) let name_of_colourspace cs resources = match cs with (*i | Pdf.Name (("/DeviceGray" | "/DeviceRGB" | "/DeviceCMYK" | "/Pattern") as str) -> resources, str i*) | Pdfspace.DeviceGray | Pdfspace.DeviceRGB | Pdfspace.DeviceCMYK | Pdfspace.Pattern -> resources, Pdfspace.string_of_colourspace cs | _ -> let existing_colourspacedict = match Pdf.lookup_direct pdf "/ColorSpace" resources with | Some ((Pdf.Dictionary _) as d) -> d | _ -> Pdf.Dictionary [] in (* FIXME: For now, we just always create a new one. Must search to see if it's already there for efficiency. *) let name = Pdf.unique_key "cs" existing_colourspacedict in let newcolourspacedict = Pdf.add_dict_entry existing_colourspacedict name (Pdfspace.write_colourspace pdf cs) in Pdf.add_dict_entry resources "/ColorSpace" newcolourspacedict, name in let resources = page.Pdfpage.resources in let attribute_ops = attribute_ops_of_path p and transform = transform_ops_of_path p and stroke_op = stroke_ops_of_path p in let colours_stroke, resources = match a.path_line with | Some (cs, Floats vals) -> let resources', name = name_of_colourspace cs resources in [Pdfops.Op_CS name; Pdfops.Op_SCN vals], resources | Some (cs, Named (n, vals)) -> let resources', name = name_of_colourspace cs resources in [Pdfops.Op_CS name; Pdfops.Op_SCNName (n, vals)], resources' | _ -> [], resources in let colours_nonstroke, resources = match a.path_fill with | Some (cs, Floats vals) -> let resources', name = name_of_colourspace cs resources in [Pdfops.Op_cs name; Pdfops.Op_scn vals], resources' | Some (cs, Named (n, vals)) -> let resources', name = name_of_colourspace cs resources in [Pdfops.Op_cs name; Pdfops.Op_scnName (n, vals)], resources' | Some (_, Pattern p) -> (* Build /Pattern cs and reference to pattern, having built the pattern in the pattern dictionary *) let pattern = pattern_object_of_pattern (!state).in_xobject (!state).opdo_matrix pdf p in let resources, name = let existing_patterndict = match Pdf.lookup_direct pdf "/Pattern" resources with | Some ((Pdf.Dictionary _) as d) -> d | _ -> Pdf.Dictionary [] in let name = Pdf.unique_key "pt" existing_patterndict in let newpatterndict = Pdf.add_dict_entry existing_patterndict name pattern in Pdf.add_dict_entry page.Pdfpage.resources "/Pattern" newpatterndict, name in [Pdfops.Op_cs "/Pattern"; Pdfops.Op_scnName (name, [])], resources | _ -> [], resources in let gs, resources = if a.path_transparency.fill_transparency < 1. || a.path_transparency.line_transparency < 1. then let resources, name = let existing_extgstate = match Pdf.lookup_direct pdf "/ExtGState" resources with | Some ((Pdf.Dictionary _) as d) -> d | _ -> Pdf.Dictionary [] in let name = Pdf.unique_key "gs" existing_extgstate and gsdict = Pdf.Dictionary [("/ca", Pdf.Real a.path_transparency.fill_transparency); ("/CA", Pdf.Real a.path_transparency.line_transparency)] in let new_extgstate = Pdf.add_dict_entry existing_extgstate name gsdict in Pdf.add_dict_entry page.Pdfpage.resources "/ExtGState" new_extgstate, name in [Pdfops.Op_gs name], resources else [], resources in let path_ops = path_ops_of_path (winding, subpaths) in protect (gs @ transform @ attribute_ops @ colours_stroke @ colours_nonstroke @ path_ops @ [stroke_op]), resources let ops_of_textstate st = [] let ops_of_textpiece (st, op) = ops_of_textstate st @ [op] (* Upon entry to this, the transformation matrix is identity *) let ops_of_text tr ops = protect ([Pdfops.Op_cm tr; Pdfops.Op_BT] @ (flatten <| map ops_of_textpiece ops) @ [Pdfops.Op_ET]) (* Transform a bounding box by a given matrix *) let extreme_of_4 f a b c d = hd <| sort f [a; b; c; d] let min_of_4 = extreme_of_4 compare let max_of_4 = extreme_of_4 (fun a b -> ~-(compare a b)) let transform_bbox tr l b r t = let (x0, y0) = Pdftransform.transform_matrix tr (l, t) and (x1, y1) = Pdftransform.transform_matrix tr (l, b) and (x2, y2) = Pdftransform.transform_matrix tr (r, t) and (x3, y3) = Pdftransform.transform_matrix tr (r, b) in min_of_4 x0 x1 x2 x3, min_of_4 y0 y1 y2 y3, max_of_4 x0 x1 x2 x3, max_of_4 y0 y1 y2 y3 (* Build a transparency group xobject, add it to the pdf and return its object number *) let rec pdfobject_of_transparency_group (a, b, c, d) pdf t = (!state).in_xobject <- (!state).in_xobject + 1; let r = let page = page_of_graphic pdf (0., 0., 0., 0.) t.tr_graphic and group_attributes = let cs = match t.tr_group_colourspace with | None -> [] | Some pdfobject -> ["/CS", pdfobject] in Pdf.Dictionary (["/Type", Pdf.Name "/Group"; "/S", Pdf.Name "/Transparency"; "/I", Pdf.Boolean t.isolated; "/K", Pdf.Boolean t.knockout] @ cs) in let extras = ["/Type", Pdf.Name "/XObject"; "/Subtype", Pdf.Name "/Form"; "/BBox", Pdf.Array [Pdf.Real a; Pdf.Real b; Pdf.Real c; Pdf.Real d]; "/Resources", page.Pdfpage.resources; "/Group", group_attributes] in match page.Pdfpage.content with | Pdf.Stream ({contents = Pdf.Dictionary dict, Pdf.Got data})::_ -> Pdf.addobj pdf (Pdf.Stream ({contents = Pdf.Dictionary (extras @ dict), Pdf.Got data})) | _ -> raise (Pdf.PDFError "Pdfgraphics: Bad page content") in (!state).in_xobject <- (!state).in_xobject - 1; r and pdfobject_of_softmask pdf m = let bc = match m.backdrop with | None -> [] | Some fs -> ["/BC", Pdf.Array (map (function x -> Pdf.Real x) fs)] and tr = match m.softmask_transfer with | None -> [] | Some f -> ["/TR", Pdffun.pdfobject_of_function pdf f] in Pdf.addobj pdf (Pdf.Dictionary (["/Type", Pdf.Name "/Mask"; "/S", Pdf.Name (match m.softmask_subtype with Alpha -> "/Alpha" | Luminosity -> "/Luminosity"); "/G", Pdf.Indirect (pdfobject_of_transparency_group m.softmask_bbox pdf m.transparency_group)] @ bc @ tr)) and ops_of_image pdf page (a, i) = (!state).opdo_matrix <- a.image_transform; let resources = page.Pdfpage.resources in let ops, resources = let opgs, resources = if a.image_transparency < 1. || a.image_softmask <> None then let resources, name = let existing_extgstate = match Pdf.lookup_direct pdf "/ExtGState" page.Pdfpage.resources with | Some ((Pdf.Dictionary _) as d) -> d | _ -> Pdf.Dictionary [] in let name = Pdf.unique_key "gs" existing_extgstate and gsdict = let softmask = match a.image_softmask with | None -> [] | Some m -> ["/SMask", Pdf.Indirect (pdfobject_of_softmask pdf m)] in Pdf.Dictionary ([("/ca", Pdf.Real a.image_transparency)] @ softmask) in let new_extgstate = Pdf.add_dict_entry existing_extgstate name gsdict in Pdf.add_dict_entry resources "/ExtGState" new_extgstate, name in [Pdfops.Op_gs name], resources else [], resources in [Pdfops.Op_cm a.image_transform] @ opgs @ [Pdfops.Op_Do ("/Im" ^ string_of_int i)], resources in protect ops, resources and ops_of_shading pdf page path shading transform = let resources', name = (* Add new entry to shading dictionary, return its name, new resources *) let existing_shadingdict = match Pdf.lookup_direct pdf "/Shading" page.Pdfpage.resources with | Some ((Pdf.Dictionary _) as d) -> d | _ -> Pdf.Dictionary [] in let name = Pdf.unique_key "sh" existing_shadingdict and objnum = Pdf.addobj pdf (shading_object_of_shading pdf shading) in let shadingref = Pdf.Indirect objnum in let new_shadingdict = Pdf.add_dict_entry existing_shadingdict name shadingref in let r = Pdf.add_dict_entry page.Pdfpage.resources "/Shading" new_shadingdict in r, name in let ops = let pathops, clipops = match path with | None -> [], [] | Some p -> path_ops_of_path p, [Pdfops.Op_W; Pdfops.Op_n] (* FIXME: Even-odd vs Non-Zero *) in pathops @ clipops @ [Pdfops.Op_cm transform; Pdfops.Op_sh name] in protect ops, resources' and ops_of_graphic_acc pdf page oplists = function | [] -> flatten (rev oplists), page | Path p::t -> let ops, resources' = ops_of_path pdf page p in let page' = {page with Pdfpage.resources = resources'} in ops_of_graphic_acc pdf page' (ops::oplists) t | Image (attr, i)::t -> let ops, resources' = ops_of_image pdf page (attr, i) in let page' = {page with Pdfpage.resources = resources'} in ops_of_graphic_acc pdf page' (ops::oplists) t | Text (ts, {textblock_transform = tr})::t -> let ops = ops_of_text tr ts in ops_of_graphic_acc pdf page (ops::oplists) t | MCSection (n, graphic)::t -> let oplist, page' = ops_of_graphic_acc pdf page [] graphic in ops_of_graphic_acc pdf page' (([Pdfops.Op_BMC n] @ oplist @ [Pdfops.Op_EMC])::oplists) t | MCSectionProperties (n, d, graphic)::t -> let oplist, page' = ops_of_graphic_acc pdf page [] graphic in ops_of_graphic_acc pdf page' (([Pdfops.Op_BDC (n, d)] @ oplist @ [Pdfops.Op_EMC])::oplists) t | MCPoint n::t -> ops_of_graphic_acc pdf page ([Pdfops.Op_MP n]::oplists) t | MCPointProperties (n, d)::t -> ops_of_graphic_acc pdf page ([Pdfops.Op_DP (n, d)]::oplists) t | GraphicInlineImage (dict, data, tr)::t -> ops_of_graphic_acc pdf page (protect [Pdfops.Op_cm tr; Pdfops.InlineImage (dict, data)]::oplists) t | Clip ((w, _) as p, elts)::t -> let ops, page' = let path_ops = [Pdfops.Op_cm (!state).transform] @ path_ops_of_path p and clipviewops = [if w = NonZero then Pdfops.Op_W else Pdfops.Op_W'; Pdfops.Op_n] and insideclipops, page' = ops_of_graphic_acc pdf page [] elts in protect (path_ops @ clipviewops @ insideclipops), page' in ops_of_graphic_acc pdf page' (ops::oplists) t | Shading (path, shading, transform)::t -> let ops, resources' = ops_of_shading pdf page path shading transform in let oplists'= protect ops::oplists and page' = {page with Pdfpage.resources = resources'} in ops_of_graphic_acc pdf page' oplists' t (* Build a page from a graphic in the same PDF. *) and image_numbers_of_elts prev = function | Image (_, i)::t -> image_numbers_of_elts (i::prev) t | MCSection (_, elts)::t | MCSectionProperties (_, _, elts)::t | Clip (_, elts)::t -> let these = image_numbers_of_elts [] elts in image_numbers_of_elts (these @ prev) t | _::t -> image_numbers_of_elts prev t | [] -> prev and make_xobjects pdf elts = let numbers = image_numbers_of_elts [] elts in setify <| map (function n -> ("/Im" ^ string_of_int n), Pdf.Indirect n) numbers and make_resources pdf g page' = let resources = match g.resources with | Pdf.Dictionary rs -> rs | _ -> [] and fontdict = Pdf.Dictionary g.fonts and xobjdict = let objs = make_xobjects pdf g.elements in Pdf.Dictionary objs and resources_frompage = match page'.Pdfpage.resources with | Pdf.Dictionary d -> d | _ -> raise (Pdf.PDFError "bad resources in page in make_resources") in let resources = remove "/Shading" resources in let resources = remove "/Pattern" resources in let resources = remove "/ExtGState" resources in let resources = remove "/ColorSpace" resources in (* [fold_right] so that entries overwrite *) Pdf.Dictionary (fold_right (fun (k, v) d -> add k v d) ["/Font", fontdict; "/XObject", xobjdict] (resources_frompage @ resources)) and page_of_graphic pdf (xmin, ymin, xmax, ymax) graphic = let page = Pdfpage.custompage (Pdf.Array [Pdf.Real xmin; Pdf.Real ymin; Pdf.Real xmax; Pdf.Real ymax]) in let ops, page' = ops_of_graphic_acc pdf page [] graphic.elements in (* We're not including the ExtGState because it's in the page', so need to merge with resources *) let resources = make_resources pdf graphic page' in {page' with Pdfpage.content = [Pdfops.stream_of_ops ops]; Pdfpage.resources = resources} let ops_of_simple_graphic graphic = fst (ops_of_graphic_acc (Pdf.empty ()) (Pdfpage.blankpage Pdfpaper.a4) [] graphic.elements) (* FIXME Add in here a function to copy a page/graphic from one document to another *) let streams_of_simple_graphic g = (page_of_graphic (Pdf.empty ()) (0., 0., 600., 400.) g).Pdfpage.content (* Transforming a graphic *) let transform_segment tr s = let f = Pdftransform.transform_matrix tr in match s with | Straight (x, y) -> Straight (f x, f y) | Bezier (a, b, c, d) -> Bezier (f a, f b, f c, f d) let transform_subpath tr (h, c, segments) = (h, c, map (transform_segment tr) segments) let transform_path tr (w, subpaths) = (w, map (transform_subpath tr) subpaths) let transform_element tr = function | Path (pth, attr) -> Path (transform_path tr pth, attr) | x -> x (* FIXME: Add rest of elements. *) let transform_graphic tr g = {g with elements = map (transform_element tr) g.elements}