(* A typesetter for cpdf. A list of elements is manipulated zero or more times
to lay it out, paginate it, and so on. It is then typeset to produce a list
of pages.
For now, this is just an experiment for -table-of-contents and -typeset. To
be continued... *)
open Pdfutil
(* Main type *)
type element =
Text of char list (* charcodes 0..255 *)
| HGlue of float
| VGlue of float
| NewLine
| NewPage
| Font of string * Pdftext.font * float
| BeginDest of Pdfdest.t
| EndDest
| BeginDocument
| Tag of string * int
| EndTag
let to_string_elt = function
| Text t -> implode t
| HGlue len -> "HGLUE" ^ string_of_float len
| VGlue _ -> "VGLUE"
| NewLine -> "NewLine"
| NewPage -> "NewPage"
| Font _ -> "Font"
| BeginDest _ -> "BeginDest"
| EndDest -> "EndDest"
| BeginDocument -> "BeginDocument"
| Tag (s, i) -> "Tag " ^ s ^ " " ^ string_of_int i
| EndTag -> "EndTag"
let to_string es = fold_left (fun a b -> a ^ "\n" ^ b) "" (map to_string_elt es)
type t = element list
type state =
{mutable font : Pdftext.font option;
mutable fontid : string option;
mutable fontsize : float;
mutable width_table : float array; (* Widths for charcodes 0..255 *)
mutable xpos : float;
mutable ypos : float;
mutable dest : Pdfdest.t option}
let width_table_cache = null_hash ()
let initial_state () =
{font = None;
fontid = None;
fontsize = 0.;
width_table = [||];
xpos = 0.;
ypos = 0.;
dest = None}
(* Mark as an artifact anything not already marked. *)
let add_artifacts ops =
let content = ref false in
let artifact = ref false in
let rec loop a = function
| [] ->
(* The end. Must end artifact if in artifact. *)
if !artifact then rev (Pdfops.Op_EMC::a) else rev a
| Pdfops.Op_BMC "/BeginArtifact"::t ->
(* Convert back-channel artifact beginning. *)
set artifact;
loop (Pdfops.Op_BMC "/Artifact"::a) t
| Pdfops.Op_BMC "/EndArtifact"::t ->
(* Convert back-channel artifact ending. *)
clear artifact;
loop (Pdfops.Op_EMC::a) t
| Pdfops.Op_BDC _ as h::t ->
(* Entering content. If in artifact, must end artifact. *)
let a' = if !artifact then h::Pdfops.Op_EMC::a else h::a in
set content; clear artifact; loop a' t
| Pdfops.Op_EMC as h::t ->
(* Exiting content. *)
clear content;
loop (h::a) t
| h::t ->
(* A normal operation. If not in content or artifact must start artifact. *)
let a' =
if not (!content || !artifact) then (set artifact; h::Pdfops.Op_BMC "/Artifact"::a) else h::a
in
loop a' t
in
loop [] ops
let font_widths id f fontsize =
match Hashtbl.find width_table_cache (id, fontsize) with
| x -> x
| exception Not_found ->
let newtable =
match f with
| Pdftext.StandardFont (sf, encoding) ->
Array.init
256
(fun x ->
fontsize
*. float_of_int
(Pdfstandard14.textwidth false encoding sf (string_of_char (char_of_int x)))
/. 1000.)
| Pdftext.SimpleFont {fontmetrics = Some m} ->
Array.map (fun x -> fontsize *. x /. 1000. ) m
| _ -> raise (Pdf.PDFError "Cpdftype: Unsupported font")
in
Hashtbl.add width_table_cache (id, fontsize) newtable;
newtable
let width_of_string ws s =
let w = ref 0. in
iter (fun s -> w := !w +. ws.(int_of_char s)) s;
!w
(* For now, split each text element into words, and lay them out ragged right
on one long page. Words longer than a whole line just fall off the margin.
Turn text newlines into real newlines. *)
(* Split into words on spaces. Find how many words (at least one, to make
progress) fit into the available space. We set needs_newline if the next
word would overflow. Return (text, needs_newline, remaining_text) *)
let split_text space_left widths t =
let chars = ref t in
let words = ref [] in
let space_left = ref space_left in
let return needs_newline =
(flatten (rev !words), needs_newline, !chars)
in
try
while !chars <> [] do
let word, rest = cleavewhile (neq ' ') !chars in
let w = width_of_string widths word in
if !words = [] || w < !space_left
then
let is_last_word = rest = [] in
let new_word = if is_last_word then word else word @ [' '] in
begin
words := new_word::!words;
space_left := !space_left -. w -. (if is_last_word then 0. else width_of_string widths [' '])
end
else raise Exit;
chars := if rest = [] then [] else tl rest;
done;
return false
with
Exit -> return true
let layout lmargin rmargin papersize i =
let width = Pdfunits.points (Pdfpaper.width papersize) (Pdfpaper.unit papersize) in
let o = ref [] in
let s = initial_state () in
let xpos_max = width -. lmargin in
s.xpos <- lmargin;
let rec layout_element = function
| Font (id, f, fontsize) ->
s.width_table <- font_widths id f fontsize;
o := Font (id, f, fontsize) :: !o
| Text text ->
if text = [] then () else
begin
let this_line, needs_newline, remaining_text =
split_text (xpos_max -. s.xpos) s.width_table text
in
o := Text this_line :: !o;
s.xpos <- s.xpos +. width_of_string s.width_table this_line;
if needs_newline then layout_element NewLine;
if remaining_text <> [] then layout_element (Text remaining_text)
end
| HGlue len as glue ->
s.xpos <- s.xpos +. len;
o := glue :: !o;
if s.xpos >= xpos_max then layout_element NewLine
| NewLine ->
s.xpos <- lmargin;
o := NewLine :: !o
| x ->
o := x :: !o
in
iter layout_element i;
rev !o
(* Paginate, simply line-based. When ypos + lineheight exceeds max_ypos, we
insert a page break. In addition, we re-write any paragraph tag/endtag to
make sure they appear on both pages. *)
let paginate tmargin bmargin papersize i =
let height = Pdfunits.points (Pdfpaper.height papersize) (Pdfpaper.unit papersize) in
let o = ref [] in
let s = initial_state () in
s.ypos <- tmargin;
let max_ypos = height -. bmargin in
let tag = ref None in
let rec process = function
| VGlue len as glue ->
s.ypos <- s.ypos +. len;
o := glue :: !o;
if s.ypos > max_ypos then process NewPage
| NewLine ->
s.ypos <- s.ypos +. s.fontsize *. 1.3;
o := NewLine::!o;
if s.ypos > max_ypos then process NewPage
| Font (id, f, fs) ->
s.font <- Some f;
s.fontid <- Some id;
s.fontsize <- fs;
o := Font (id, f, fs)::!o
| NewPage ->
s.ypos <- tmargin +. s.fontsize;
begin match !tag with Some (s, i) -> o := EndTag::!o | None -> () end;
o := NewPage::!o;
begin match !tag with Some (s, i) -> o := Tag (s, i)::!o | None -> () end
| BeginDocument ->
s.ypos <- tmargin +. s.fontsize;
o := BeginDocument::!o
| Tag (s, i) ->
tag := Some (s, i);
o := Tag (s, i)::!o
| EndTag ->
tag := None;
o := EndTag::!o
| x -> o := x::!o
in
iter process i;
rev !o
let make_resources fontobjnums =
Pdf.Dictionary
[("/Font", Pdf.Dictionary (map (fun fo -> ("/F" ^ string_of_int fo, Pdf.Indirect fo)) (setify fontobjnums)))]
let make_annotations pdf annots =
if annots = [] then Pdf.Dictionary [] else
Pdf.Dictionary ["/Annots", Pdf.Array (map (function a -> Pdf.Indirect (Pdf.addobj pdf a)) annots)]
let rec number_tags n = function
| Tag (s, _)::t -> Tag (s, n)::number_tags (n + 1) t
| h::t -> h::number_tags n t
| [] -> []
(* At this stage, just Font and Text and HGlue 0. and VGlue 0. and Newline and
NewPage elements. Split on NewPages, typeset each page, add font
dictionaries. New page only creates a page when that page has content. *)
let typeset ~process_struct_tree lmargin rmargin tmargin bmargin papersize pdf i =
Hashtbl.clear width_table_cache;
let debug = false in
if debug then (print_endline "***input:\n\n"; print_endline (to_string i));
let i = number_tags 0 i in
let i = layout lmargin rmargin papersize i in
if debug then (print_endline "***after layout:\n\n"; print_endline (to_string i));
let i = paginate tmargin bmargin papersize i in
if debug then (print_endline "***after pagination:\n\n"; print_endline (to_string i));
let height = Pdfunits.points (Pdfpaper.height papersize) (Pdfpaper.unit papersize) in
let s = initial_state () in
s.xpos <- lmargin;
s.ypos <- tmargin;
let mcidr = ref ~-1 in
let mcid () = incr mcidr; !mcidr in
let ops = ref [] in
let fonts = ref [] in
let thispagefontnums = ref [] in
let thispageannotations = ref [] in
let thisdestrectangles = ref [] in
let pages = ref [] in
let tags = ref [] in
let tagsout = ref [] in
let write_page () =
let ops = if process_struct_tree then add_artifacts (rev !ops) else rev !ops in
let page =
{Pdfpage.content = if ops = [] then [] else [Pdfops.stream_of_ops ops];
Pdfpage.mediabox = Pdfpage.rectangle_of_paper papersize;
Pdfpage.resources = make_resources !thispagefontnums;
Pdfpage.rotate = Pdfpage.Rotate0;
Pdfpage.rest = make_annotations pdf !thispageannotations}
in
pages := page::!pages;
tagsout := rev !tags::!tagsout;
tags := []
in
let rec typeset_element = function
| Text cps ->
ops :=
Pdfops.Op_Q
::Pdfops.Op_ET
::Pdfops.Op_Tj (implode cps)
::Pdfops.Op_BT
::Pdfops.Op_cm (Pdftransform.mktranslate s.xpos (height -. s.ypos))
::Pdfops.Op_q
::!ops;
(* If a destination, add the rectangle to the pile of rectangles for this annotation. *)
if s.dest <> None then
begin
let minx, miny = s.xpos, height -. s.ypos in
thisdestrectangles := (minx, miny, minx +. width_of_string s.width_table cps, miny +. s.fontsize)::!thisdestrectangles
end;
s.xpos <- s.xpos +. width_of_string s.width_table cps
| Font (id, f, fontsize) ->
let name, objnum =
match List.assoc_opt id !fonts with
| Some objnum -> ("/F" ^ string_of_int objnum, objnum)
| None ->
let num = Pdftext.write_font pdf f in
let n = "/F" ^ string_of_int num in
fonts := (id, num) :: !fonts;
(n, num)
in
s.width_table <- font_widths id f fontsize;
s.font <- Some f;
s.fontid <- Some id;
s.fontsize <- fontsize;
thispagefontnums := objnum :: !thispagefontnums;
ops := Pdfops.Op_Tf (name, fontsize)::!ops
| HGlue len ->
s.xpos <- s.xpos +. len
| VGlue len ->
s.ypos <- s.ypos +. len
| NewLine ->
s.xpos <- lmargin;
typeset_element (VGlue (s.fontsize *. 1.3))
| NewPage ->
write_page ();
thispagefontnums := [];
thispageannotations := [];
ops := [];
mcidr := -1;
if s.font <> None && s.fontid <> None then typeset_element (Font (unopt s.fontid, unopt s.font, s.fontsize));
s.xpos <- lmargin;
s.ypos <- tmargin +. s.fontsize
| BeginDocument ->
s.ypos <- tmargin +. s.fontsize
| BeginDest dest ->
s.dest <- Some dest
| EndDest ->
if !thisdestrectangles <> [] && s.dest <> None then
let annot (minx, miny, maxx, maxy) =
Pdf.Dictionary
[("/Type", Pdf.Name "/Annot");
("/Subtype", Pdf.Name "/Link");
("/Border", Pdf.Array [Pdf.Real 0.; Pdf.Real 0.; Pdf.Real 0.]);
("/Rect", Pdf.Array [Pdf.Real minx; Pdf.Real miny; Pdf.Real maxx; Pdf.Real maxy]);
("/Dest", Pdfdest.pdfobject_of_destination (unopt s.dest))]
in
thispageannotations := map annot !thisdestrectangles @ !thispageannotations;
s.dest <- None;
thisdestrectangles := []
| Tag (s, i) ->
tags := (s, i)::!tags;
ops := Pdfops.Op_BDC ("/" ^ s, Pdf.Dictionary [("/MCID", Pdf.Integer (mcid ()))])::!ops
| EndTag -> ops := Pdfops.Op_EMC::!ops
in
iter typeset_element i;
write_page ();
(rev !pages, rev !tagsout)