Contents:

1. Introduction

The PDF Maker is a dialect that creates PDF (Adobe's Portable Document Format) files. It does not support the full range of features of PDF, but it has the most important features. You can create anything from a simple invoice to a complete book.

2. Overview

This program uses the compile-rules function (allows extending parse rules) and the high quality text typesetter from %typesetter.r.

The dialect parser uses the most advanced features of compile-rules, so that the dialect automatically evaluates values when needed (i.e., you don't need to use compose), and provides the usual looping and flow control functions (i.e., you can write loop 3 [textbox ...] to create three textboxes). A user-oriented documentation of the dialect will be provided in a separate document.

We export only one function (but note, %compile-rules.r and %typesetter.r export others), layout-pdf. It takes a block as an argument, and returns a binary! (that you can, for e.g., write to a file) which is a document in PDF format. In the simplest case, the block contains a number of sub-blocks, one block for each page in the document.

It is also possible to use the pdfm/get-char-whd and pdfm/get-font-info functions; the former returns an object with width, height and depth being set to the respective values for the given character in the given font at the given size; the latter returns an object with full-name, family-name, max-height and max-depth.

〈Overview〉 ≡

#include %compile-rules.r
#include %typesetter.r

pdfm: context [
 〈The PDF Maker〉

 layout-pdf: func [
  "Layout a PDF document (based on the given spec)"
  spec [block!] "The document, see documentation for details"

  /local 〈layout-pdf's locals〉
 ] [
  〈Layout a PDF document〉
 ]
 get-char-whd: func [
  "Get metrics info for a character"
  font-name [word!] "Name of the font"
  font-size [number!] "Size of the font (in mm.)"
  char [char!]
 ] [
  〈Get metrics data for the character char〉
 ]
 get-font-info: func [
  "Get informations about a font"
  font-name [word!] "Name of the font"
  font-size [number!] "Size of the font (in mm.)"
 ] [
  〈Get informations on the font with name font-name〉
 ]
]

layout-pdf: get in pdfm 'layout-pdf

3. The dialect rules

This section discusses the parse rules for the dialect.

〈The dialect rules〉 ≡

〈Rules local words〉
〈The text rule〉
〈The table rule〉
〈The page rule〉
〈The document rule〉

3.1 The document rule

The compiled rule (result of compile-rules dr) is the main rule used by layout-pdf to parse the block given as an argument. This block describes the pages in the document.

Other than creating pages, document-rule allows creating named table and text streams. A named stream is independent from the pages, and can be used in the specification from a page; basically, you can flow a named stream into any number of pages.

The any pages [...] command creates zero or more pages in the document, just enough to show all the text in the streams used in the given page template. (A page template is the same as a normal page specification.) You can use any pages even [...] odd [...] to use different templates for even and odd pages.

The if even [...] command creates a page if it will be even (otherwise it does not create any pages). For example, you could use it to add a filler page if a chapter ended up in an odd page, so that the next one does not start on an even page.

〈The document rule〉 ≡

document-rule: [
 'text set val1 word! do val2 block! (new-text-stream val1 val2) ; text stream
 |
 'table set val1 word! (val5: [none]) ;opt ['with 'default borders-rule]
  do val6 [into [some number!]] ; column spec
  do val2 block! ; header rows
  do val3 block! ; table rows
  do val4 block! ; footer rows
  (new-table-stream val1 val2 val3 val4 val5 val6) ; multi-page table
 |
 'any opt 'pages 'even do val1 block! 'odd do val2 block! (any-new-page-even-odd val1 val2)
  ; repeat any number of times, as needed; use different layouts for even and odd pages
 |
 'any opt 'pages do val1 block! (any-new-page val1) ; repeat any number of times, as needed
 |
 'if 'even do val1 block! (new-page-if-even val1) ; insert page only if even
]

compiled: compile-rules dr: [
 throw "Error parsing document" [
  some [document-rule | interpret with dr | end break | do val1 [block! (new-page val1) | skip]]
 ]
]

3.1.1 Rules local words

〈Rules local words〉 ≡

val1: val2: val3: val4: val5: val6: none

3.2 The text rule

The compiled-tr rule is used to parse text streams. Any value, except the ones parsed by the text-rule rule, is converted to string and considered text.

The newline keyword insert a forced break in the paragraph. (Don't use it if you don't know what you are doing.)

〈The text rule〉 ≡

〈Text subrules〉
text-rule: [
 'newline (emit-forced-break) | font-def | vspace | end-para |
 set-para-rule | set-wrappers | set-para-skip |
 penalty | kern | mark | insertion | inline-gfx | inline-table | hspace |
 set-global-value | discret-break | set-hdr | 'newpage (emit-vpenalty -infty) |
 vpenalty
]
compiled-tr: compile-rules tr: [
 throw "Error parsing text stream" [
  some [
   text-rule
   |
   interpret with tr
   |
   end break
   |
   do val1 skip (if all [value? 'val1 not none? :val1] [
    either tuple? :val1 [
     cur-stream/cur-color: val1
    ] [
     emit-text form :val1
    ]
   ])
  ]
 ]
]

3.2.1 Text subrules

Most of the subrules are not implemented yet. vfill inserts space up to the end of the page (there are also the vfil and vfilll variants, that create respectively a lower or higher level of infinity for the space stretchability); vertical space x or vspace x inserts x millimeters of vertical space; vertical glue x y z or vglue x y z is like glue x y z but in the vertical direction; note that any vertical space ends the current paragraph; height h forces the height of the following text to be h (if h is none, then the following text will have normal height); depth d forces the depth of the followind text to be d (none means normal); rise r sets the text rise (i.e. for superscripts or subscripts) to r; font name size sets the current font name and size (name must evaluate to a word!, while size must evaluate to a number!); end paragraph (or the short version p) ends the current paragraph; penalty x inserts a break point with a penalty of x (penalty -infty is equivalent to newline; penalty +infty disallows breaks, i.e. followed by a space it is equivalent to a non-breakable space); -- inserts a soft hyphen; kern x inserts a fixed space of x millimeters (can be negative too), which cannot be a breakpoint (unless it is followed by a normal space); hfill inserts space up to the end of the line (there are also the hfil and hfilll variants, that create respectively a lower or higher level of infinity for the space stretchability); space x inserts a fixed space of x millimeters (can be negative, if you know what you are doing) which can be a breakpoint; glue x y z inserts a generic space, whose natural width is x, and that can grow at a rate determined by y, and can shrink up to x - z.

TODO

  1. Implement missing subrules
  2. Allow setting of hypen penalty
  3. Should add a way to create an empty box, for special effects?

〈Text subrules〉 ≡

set-wrappers: set-para-skip:
mark: insertion: set-global-value: discret-break:
 ['not-implemented-yet]

inline-gfx: [
 'box do val1 number! do val2 number! do val3 number! do val4 block! (
  emit-box val1 val2 val3 val4
 )
 |
 'vbox do val1 number! do val2 block! (emit-vbox val1 val2)
]
inline-table: [
 'table do val1 [into [any [number! | 'none | none!]]]
 [
  set val3 'center
  |
  set val3 'right
  |
  'align* do val3 ['left | 'center | 'right]
  |
  none (val3: 'left)
 ]
 do val2 block! (new-inline-table val1 val2 val3)
]
set-para-rule: [
 [
  set val1 ['justify | 'left 'align | 'right 'align | 'center]
  |
  'alignment do val1 ['justify | 'left | 'right | 'center]
 ] (
  end-paragraph
  cur-stream/cur-align: val1
 )
 any [
  'with [
   'interline-glue do val1 number! do val2 number! do val3 number! (
    cur-stream/interline-glue: make-text-list-node [
     type: 'glue
     width: val1
     stretch: val2
     shrink: val3
    ]
    if cur-para [cur-para/interline-glue: cur-stream/interline-glue]
   )
   |
   'tolerance do val1 number! (
    cur-stream/tolerance: val1
    if cur-para [cur-para/tolerance: val1]
   )
   |
   'looseness do val1 integer! (
    if not cur-para [new-para]
    cur-para/looseness: val1
   )
   |
   'left 'margin do val1 number! (
    foreach line-margin cur-stream/cur-margins [
     line-margin/1: val1
    ]
    if cur-para [cur-para/margins: copy/deep cur-stream/cur-margins]
   )
   |
   'right 'margin do val1 number! (
    foreach line-margin cur-stream/cur-margins [
     line-margin/2: val1
    ]
    if cur-para [cur-para/margins: copy/deep cur-stream/cur-margins]
   )
   |
   'margins [
    (val3: copy [ ])
    into [
     some [end break | do val1 number! do val2 number! (append/only val3 reduce [val1 val2])]
    ]
    |
    do val1 block! (
     foreach [l r] val1 [append/only val3 reduce [l r]]
    )
   ] (
    cur-stream/cur-margins: val3
    if cur-para [cur-para/margings: copy/deep cur-stream/cur-margins]
   )
  ]
 ]
]
vpenalty: [
 ['vertical 'penalty | 'vpenalty] do val1 [number! | block!] (emit-vpenalty val1)
]
vspace: [
 'vfil (emit-vspace 0 +infty 0)
 |
 'vfill (emit-vspace 0 +infty2 0)
 |
 'vfilll (emit-vspace 0 +infty3 0)
 |
 ['vertical 'space | 'vspace] do val1 number! (emit-vspace val1 0 0)
 |
 ['vertical 'glue | 'vglue] do val1 number! do val2 [number! | block!] do val3 number! (emit-vspace val1 val2 val3)
]
set-hdr: [
 'height do val1 [number! | none!] (cur-stream/fix-height: val1)
 |
 'depth do val1 [number! | none!] (cur-stream/fix-depth: val1)
 |
 'rise do val1 number! (cur-stream/rise: val1)
]
font-def: [
 'font [set val1 word! | do val1 word!] do val2 number! (use-font val1 val2)
 |
 'font* do val1 word! do val2 number! (use-font val1 val2)
]
end-para: [opt 'end ['p | 'paragraph] (end-paragraph)]
penalty: [
 'penalty do val1 [number! | block!] (emit-penalty val1)
 |
 '-- (
  val1: pick cur-stream/cur-metrics 46
  emit-penalty/with 150 #"-" txt2mm val1/1 txt2mm val1/2/4 txt2mm negate val1/2/2
 )
]
kern: ['kern do val1 number! (emit-kern val1)]
hspace: [
 'hfil (emit-glue 0 +infty 0)
 |
 'hfill (emit-glue 0 +infty2 0)
 |
 'hfilll (emit-glue 0 +infty3 0)
 |
 'space do val1 number! (emit-glue val1 0 0)
 |
 'glue do val1 number do val2 [number! | block!] do val3 number! (emit-glue val1 val2 val3)
]

3.3 The table rule

The table dialect has not been finalized yet.

TODO:

  1. Finalize the table dialect.

〈The table rule〉 ≡

cell-margins: [
 set val1 ['left | 'right] set val2 ['margin | 'padding] do val3 number!
]
cell-align: [
 opt 'vertical 'alignment set val1 ['top | 'middle | 'bottom]
 |
 'alignment* do val1 ['top | 'middle | 'bottom]
]
row-margins: [
 set val1 ['top | 'bottom] set val2 ['margin | 'padding] do val3 number!
 (val4: val5: 0) any ['stretch do val4 [number! | block!] | 'shrink do val5 number!]
]
row-break-penalty: [
 'break 'penalty do val1 [block! | number!]
]
cell-decor: [
 'decor do val1 block!
]
cell-options: [
 any [
  cell-margins (
   switch val1 switch val2 [
    margin [[
     left [
      if cur-stream/width [
       cur-stream/width: cur-stream/width + cur-stream/margins/1 - val3
      ]
      cur-stream/margins/1: val3
     ]
     right [
      if cur-stream/width [
       cur-stream/width: cur-stream/width + cur-stream/margins/2 - val3
      ]
      cur-stream/margins/2: val3
     ]
    ]]
    padding [[
     left [
      if cur-stream/width [
       cur-stream/width: cur-stream/width + cur-stream/padding/1 - val3
      ]
      cur-stream/padding/1: val3
     ]
     right [
      if cur-stream/width [
       cur-stream/width: cur-stream/width + cur-stream/padding/2 - val3
      ]
      cur-stream/padding/2: val3
     ]
    ]]
   ]
  )
  |
  cell-align (cur-stream/valign: val1)
  |
  'width do val1 number! (cur-stream/width: val1)
  |
  cell-decor (cur-stream/decor: val1)
 ]
]
cell-rule: [
 (
  append cur-row/contents cur-stream: make cell! [
   width: pick cur-table-stream/columns 1 + length? cur-row/contents
   margins: copy cur-row/def-cell-margins
   padding: copy cur-row/def-cell-padding
   if width [
    width: width - margins/1 - margins/2 - padding/1 - padding/2
   ]
   valign: cur-row/def-cell-valign
   decor: cur-row/def-cell-decor
  ]
 )
 cell-options
 [end | tr]
 (end-paragraph)
]
new-row: [
 (append cur-table-stream/rows cur-row: make row! [
  top-margin: cur-table-stream/def-row-top-margin
  top-padding: cur-table-stream/def-row-top-padding
  bottom-padding: cur-table-stream/def-row-bottom-padding
  bottom-margin: cur-table-stream/def-row-bottom-margin
  break-penalty: cur-table-stream/def-row-break-penalty
  def-cell-margins: copy cur-table-stream/def-cell-margins
  def-cell-padding: copy cur-table-stream/def-cell-padding
  def-cell-valign: cur-table-stream/def-cell-valign
  def-cell-decor: cur-table-stream/def-cell-decor
 ])
 row-rule
]
row-options: [
 any [
  row-margins (
   switch val1 switch val2 [
    margin [[
     top [
      cur-row/top-margin: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'top-margin
      ]
     ]
     bottom [
      cur-row/bottom-margin: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'bottom-margin
      ]
     ]
    ]]
    padding [[
     top [
      cur-row/top-padding: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'top-padding
      ]
     ]
     bottom [
      cur-row/bottom-padding: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'bottom-padding
      ]
     ]
    ]]
   ]
  )
  |
  row-break-penalty (cur-row/break-penalty: val1)
  |
  cell-margins (
   switch val1 switch val2 [
    margin [[
     left [cur-row/def-cell-margins/1: val3]
     right [cur-row/def-cell-margins/2: val3]
    ]]
    padding [[
     left [cur-row/def-cell-padding/1: val3]
     right [cur-row/def-cell-padding/2: val3]
    ]]
   ]
  )
  |
  cell-align (cur-row/def-cell-valign: val1)
  |
  cell-decor (cur-row/def-cell-decor: val1)
 ]
]
row-rule: [
 row-options
 some [
  into cell-rule
  |
  interpret with row-rule
  |
  end break
  |
  do val1 skip
 ]
]
table-options: [
 any [
  row-margins (
   switch val1 switch val2 [
    margin [[
     top [
      cur-table-stream/def-row-top-margin: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'top-margin
      ]
     ]
     bottom [
      cur-table-stream/def-row-bottom-margin: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'bottom-margin
      ]
     ]
    ]]
    padding [[
     top [
      cur-table-stream/def-row-top-padding: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'top-padding
      ]
     ]
     bottom [
      cur-table-stream/def-row-bottom-padding: make-text-list-node [
       type: 'glue
       width: val3
       stretch: val4
       shrink: val5
       ref: 'bottom-padding
      ]
     ]
    ]]
   ]
  )
  |
  row-break-penalty (cur-table-stream/def-row-break-penalty: val1)
  |
  cell-margins (
   switch val1 switch val2 [
    margin [[
     left [cur-table-stream/def-cell-margins/1: val3]
     right [cur-table-stream/def-cell-margins/2: val3]
    ]]
    padding [[
     left [cur-table-stream/def-cell-padding/1: val3]
     right [cur-table-stream/def-cell-padding/2: val3]
    ]]
   ]
  )
  |
  cell-align (cur-table-stream/def-cell-valign: val1)
  |
  cell-decor (cur-table-stream/def-cell-decor: val1)
 ]
]
compiled-tabr: compile-rules tabr: [
 throw "Error parsing table" [
  table-options
  some [
   into new-row
   |
   interpret with tabr
   |
   end break
   |
   do val1 skip
  ]
 ]
]

3.4 The page rule

Currently only text boxes are implemented, so a page can only contain text boxes. (A simple form of tables is now available too.) A text box can be specified as:

  1. textbox from named-stream, that creates a textbox with default size and position and text coming from the stream named named-stream;
  2. textbox left bottom width height from named-stream, that creates a textbox left millimeters from the left side of the page, bottom millimeters from the bottom, width millimeters wide and height millimeters high, with text coming from the stream named named-stream;
  3. textbox [...], that creates a textbox with default size and position and containing the text found in the given block;
  4. textbox left bottom width height [...], that creates a textbox in the given position and with the given size, containing the text in the given block.

TODO

  1. Finish tables
  2. Document all the rules

〈The page rule〉 ≡

page-rule: [
 'textbox (end-gfx) [
  'from set val1 word! (new-textbox-from-stream val1)
 | do val1 [block! (new-textbox val1) | number!] if (number? val1) full-textbox-rule
 ]
 |
 'table (end-gfx) 'from set val1 word! (new-table-from-stream val1)
 |
 'apply (end-gfx start-space) any [
  'translation do val1 number! do val2 number! (cur-space/translate: reduce [val1 val2])
  |
  'rotation do val1 number! (cur-space/rotate: val1)
  |
  'scaling do val1 number! do val2 number! (cur-space/scale: reduce [val1 val2])
  |
  'skew do val1 number! do val2 number! (cur-space/skew: reduce [val1 val2])
 ] into page-rule (end-space)
 |
 gfx-command
]
full-textbox-rule: [
 do val2 number! do val3 number! do val4 number! [
  'from set val6 word! (new-textbox-from-stream/with val6 val1 val2 val3 val4)
 | do val6 block! (new-textbox/with val6 val1 val2 val3 val4)
 ]
]
〈The graphic commands rules〉

compiled-pr: compile-rules pr: [
 throw "Error parsing page" [
  opt ['page any [
   'size do val1 number! do val2 number! (cur-page/size: reduce [val1 val2])
   |
   'rotation do val1 integer! (cur-page/rotation: val1)
   |
   'offset do val1 number! do val2 number! (cur-page/offset reduce [val1 val2])
  ]]
  some [page-rule | interpret with pr | end break | do val1 skip]
 ]
]

3.5 The graphic commands rules

〈The graphic commands rules〉 ≡

gfx-command: [
 'set-line lineopt-rule
 |
 'set-fill fc-rule
 |
 'line lineopt-rule do val1 number! do val2 number! do val3 number! do val4 number! (
  gfx-emit [val1 val2 'm val3 val4 'l 'S]
 )
 |
 'bezier lineopt-rule (val1: clear [ ]) 8 [do val2 number! (append val1 val2)] (
  gfx-emit [
   val1/1 val1/2 'm
   val1/3 val1/4 val1/5 val1/6 val1/7 val1/8 'c 'S
  ]
 )
 |
 'box boxopt-rule box-rule (gfx-emit ['S])
 |
 'solid 'box sboxopt-rule box-rule (gfx-emit ['B])
 |
 'circle boxopt-rule circle-rule (gfx-emit ['S])
 |
 'solid 'circle sboxopt-rule circle-rule (gfx-emit ['B])
 |
 'stroke boxopt-rule do val1 [into path-rule] (gfx-emit ['S])
 |
 'fill (cmd: 'f) any [fc-rule | 'even-odd (cmd: 'f*)]
  do val1 [into path-rule] (gfx-emit [cmd])
 |
 'paint (cmd: 'B) any [
  'edge gfxstate-rule | 'edge sc-rule | fc-rule | 'even-odd (cmd: 'B*)
 ] do val1 [into path-rule] (gfx-emit [cmd])
 |
 'clip opt 'to (cmd: 'W) opt ['even-odd (cmd: 'W*)]
 do val1 [into path-rule] (gfx-emit [cmd 'n])
 |
 'image opt 'at do val1 number! do val2 number! opt 'size do val3 number! do val4 number!
 do val5 image! (
  insert insert tail cur-page/used-images val6: join "Img" img-count val5
  img-count: img-count + 1
  gfx-emit [
   'q
   val3 0 0 val4 val1 val2 'cm
   to refinement! val6 'Do
   'Q
  ]
 )
]
cmd: none
gfxstate-words: context [
 butt: 0 round: 1 square: 2
 miter: 0 bevel: 2
]
gfxstate-rule: [
 'width do val1 number! (gfx-emit [val1 'w])
 |
 [
  'cap set val1 ['butt | 'round | 'square]
  |
  'cap* do val1 ['butt | 'round | 'square]
 ] (
  gfx-emit [get in gfxstate-words val1 'J]
 )
 |
 [
  'join set val1 ['miter | 'round | 'bevel]
  |
  'join* do val1 ['miter | 'round | 'bevel]
 ] (
  gfx-emit [get in gfxstate-words val1 'j]
 )
 |
 'miter 'limit do val1 number! (gfx-emit [val1 'M])
 |
 'dash [
  'solid (gfx-emit [[] 0 'd])
  |
  do val1 [into [some number!]] do val2 number! (gfx-emit [val1 val2 'd])
 ]
]
color-rule: [
 [set val1 tuple! | 'color do val1 tuple!] (gfx-emit [c2d val1/1 c2d val1/2 c2d val1/3])
]
sc-rule: [color-rule (gfx-emit ['RG])]
fc-rule: [color-rule (gfx-emit ['rg])]
box-rule: [
 do val1 number! do val2 number! do val3 number! do val4 number! (
  gfx-emit [val1 val2 val3 val4 're]
 )
]
lineopt-rule: [any [gfxstate-rule | sc-rule]]
boxopt-rule: [any ['line gfxstate-rule | sc-rule]]
sboxopt-rule: [any ['edge gfxstate-rule | 'edge sc-rule | fc-rule]]
circle-rule: [
 do val1 number! do val2 number! do val3 number! (
  ; approximates a circle
  gfx-emit [
   val1 + val3 val2 'm
   val1 + val3 val3 * 0.5522847498 + val2
   val3 * 0.5522847498 + val1 val2 + val3
   val1 val2 + val3 'c
   -0.5522847498 * val3 + val1 val2 + val3
   val1 - val3 val3 * 0.5522847498 + val2
   val1 - val3 val2 'c
   val1 - val3 -0.5522847498 * val3 + val2
   -0.5522847498 * val3 + val1 val2 - val3
   val1 val2 - val3 'c
   0.5522847498 * val3 + val1 val2 - val3
   val1 + val3 -0.5522847498 * val3 + val2
   val1 + val3 val2 'c 'h
  ]
 )
]
move-to: ['move opt 'to]
line-to: ['line opt 'to]
boxpath-rule: ['box box-rule]
path-rule: [some [boxpath-rule | 'circle circle-rule | end break | shape-rule]]
shape-rule: [
 opt move-to do val1 number! do val2 number! (gfx-emit [val1 val2 'm]) some [
  move-to do val1 number! do val2 number! (gfx-emit [val1 val2 'm])
  |
  'bezier 'to (val1: clear [ ]) 4 [do val2 number! (append val1 val2)] (
   gfx-emit [val1/1 val1/2 val1/3 val1/4 'v]
  )
  |
  'bezier 'from (val1: clear [ ]) 4 [do val2 number! (append val1 val2)] (
   gfx-emit [val1/1 val1/2 val1/3 val1/4 'y]
  )
  |
  'bezier (val1: clear [ ]) 6 [do val2 number! (append val1 val2)] (
   gfx-emit [val1/1 val1/2 val1/3 val1/4 val1/5 val1/6 'c]
  )
  |
  'close (gfx-emit ['h])
  |
  end break
  |
  opt line-to do val1 number! do val2 number! (gfx-emit [val1 val2 'l])
 ]
]

compiled-gc: compile-rules gc: [
 some [gfx-command | interpret with gc | end break | do val1 skip]
]

4. The dialect actions

Here we define the functions used in the dialect rules.

The text dialect needs the metrics data for the 14 default PostScript fonts; it is loaded from an external %metrics.bin file, unless that was already included setting the default-fonts-metrics word (i.e. when encapping). (We also try to download it from the net if the file is not found.) The get-metrics function returns the metrics data, given the font name (as a word!). (Currently, only the 14 default fonts are supported.)

TODO

  1. Add support for external (TTF) fonts

〈The dialect actions〉 ≡

if not value? 'default-fonts-metrics [
 default-fonts-metrics: load decompress read/binary
  either exists? %metrics.bin [%metrics.bin] [http://www.colellachiara.com/soft/PDFM2/metrics.bin]
]
get-metrics: func [font-name] [
 get in default-fonts-metrics font-name
]

The new-text-stream function creates a new text stream with given name (word!) and contents.

〈The dialect actions〉 +≡

new-text-stream: func [name contents] [
 if find text-streams name [make error! "A text stream with this name already exists."]
 insert insert tail text-streams name cur-stream: make text-stream! []
 parse contents compiled-tr
 end-paragraph
]

The function uses a text-stream block to hold all the streams, and the text-stream! prototype for text stream objects. (The fields of text stream objects will be explained later.) It also sets cur-stream to the current text stream (this is used by the actions in the compiled-tr rule to know where to add the text to).

〈The dialect actions〉 +≡

text-streams: [ ]
text-stream!: context [
 contents: [ ]
 columns: [ ]
 repeat-columns: [ ]
 output: none
 cur-font: [Times-Roman 4.23]
 cur-metrics: get-metrics cur-font/1
 fix-height: fix-depth: none
 rise: 0
 cur-align: 'justify
 interline-glue: make-text-list-node [type: 'glue]
 tolerance: 1.26
 cur-margins: [[0 0]]
 cur-color: none
 min-width: 0
 max-width: 0
]
cur-stream: none

The new-table-stream function is only partially implemented.

TODO

  1. Finish the implementation of table streams.

〈The dialect actions〉 +≡

new-table-stream: func [
 name header table footer defborders columns'
] [
 if find table-streams name [make error! "A table stream with this name already exists."]
 insert insert tail table-streams name cur-table-stream: make table-stream! [
  columns: columns'
  def-cell-margins: copy def-cell-margins
  def-cell-padding: copy def-cell-padding
 ]
 parse table compiled-tabr
 ;compute-column-widths cur-table-stream
]

The function uses:

〈The dialect actions〉 +≡

table-streams: [ ]
table-stream!: context [
 rows: [ ]
 columns: [ ]
 pages: [ ]
 repeat-pages: [ ]
 output: none
 def-cell-margins: [0 0]
 def-cell-padding: [0 0]
 def-cell-valign: 'top
 def-cell-decor: [ ]
 def-row-top-margin: make-text-list-node [type: 'glue ref: 'top-margin]
 def-row-top-padding: make-text-list-node [type: 'glue width: 0 stretch: 3 shrink: 0 ref: 'top-padding]
 def-row-bottom-padding: make-text-list-node [type: 'glue width: 0 stretch: 3 shrink: 0 ref: 'bottom-padding]
 def-row-bottom-margin: make-text-list-node [type: 'glue ref: 'bottom-margin]
 def-row-break-penalty: 1000
 min-width: 0
 max-width: 0
 col-maxw: [ ]
 col-minw: [ ]
 align: 'left
]
cur-table-stream: none

The new-page function creates a new document page. It appends the result of the prep-page function (see below) to the pages block.

〈The dialect actions〉 +≡

new-page: func [contents] [
 append pages prep-page contents
]
pages: [ ]

The new-page-if-even function only creates the new page if it would be an even page.

〈The dialect actions〉 +≡

new-page-if-even: func [contents] [
 if odd? length? pages [
  append pages prep-page contents
 ]
]

any-new-page and any-new-page-even-odd call generate-pages to generate a sequence of pages, with the results of prep-page/any as templates.

〈The dialect actions〉 +≡

any-new-page: func [contents] [
 generate-pages reduce [prep-page/any contents]
]
any-new-page-even-odd: func [even odd] [
 either odd? length? pages [
  generate-pages reduce [prep-page/any even prep-page/any odd]
 ] [
  generate-pages reduce [prep-page/any odd prep-page/any even]
 ]
]

The prep-page function creates a new page using the page! prototype object, sets the repeat-columns? flag (used by the actions in compiled-pr) based on the /any refinement, and cur-page to the created page, which is then returned.

〈The dialect actions〉 +≡

prep-page: func [contents /any] [
 repeat-columns?: any
 end-gfx
 cur-page: make page! [ ]
 parse contents compiled-pr
 cur-page
]

So we need to define page! (explained later), repeat-columns? and cur-page.

〈The dialect actions〉 +≡

page!: context [
 contents: [ ]
 size: [210 297] ; mm. (ISO A4)
 offset: [0 0]
 rotation: 0
 used-images: []
 prev: none
]
repeat-columns?: no
cur-page: none

The generate-pages function creates as many pages as needed to consume all the text streams that appear in them; the templates in the rpages blocks are used, in cycle, for the generated pages.

First, it typesets all the streams that appear in the repeated pages; these streams have the repeat-columns block non empty (see below for an explanation). The stream-to-columns function typesets the text in the stream and turns it into a series of columns.

Then, each element in previous pages is finalized, if possible. The finalize action will, for example, for a textbox object, grab from the columns in the stream the one that needs to go in the textbox itself (if the stream has been typeset already).

To explain this better, let's consider an example. Imagine calling layout-pdf with the code [textbox from named-stream] any [textbox from named-stream]; this would first call new-page to create the first page, containing one textbox (not finalized) with text from the stream named-stream; then, it would call any-new-page, which in turn calls generate-pages with the rpages block containing one page containing one textbox (again not finalized yet) with text from the stream named-stream. Since the latter textbox is a repeated column (see below for more on this), the named-stream stream will have a non-empty repeat-columns block, and thus it will be typeset by generate-pages by calling stream-to-columns. Now, we want to have the first column of the stream to go to the first (non repeated) page (which is contained in the pages block), and the following columns to generate the required number of pages. To do the former we must finalize the textbox in the first page (we can do this now, because the stream has been typeset; if there were other textboxes in that page, whose stream was not typeset yet, they would not be finalized - see the description of the finalize action below), then we can proceed generating the pages.

The until loop creates new pages until all streams have been consumed. Each page template in the rpages block is cloned (all the objects in page/contents must be cloned too), and each element of the page is finalized; the finalize action returns true if this should be the last page (i.e. for a textbox, its stream has been consumed), and we also use the has-contents? action to verify if the page is ending up empty (this extra check is necessary because, referring to the earlier example, we must generate zero pages if the stream was consumed by the first page). So we add the generated page to the pages block, unless it was empty, and if it was the last page, we return true and thus end the until loop. Otherwise we return false and continue generating pages.

〈The dialect actions〉 +≡

generate-pages: func [rpages /local contents last-page? empty-page?] [
 foreach [name stream] text-streams [
  if all [not empty? stream/repeat-columns not stream/output] [
   stream-to-columns stream
  ]
 ]
 foreach [name stream] table-streams [
  if all [not empty? stream/repeat-pages not stream/output] [
   table-stream-to-pages stream
  ]
 ]
 foreach page pages [
  foreach element page/contents [element/actions/finalize element]
 ]
 until [
  foreach page rpages [
   page: make page [ ]
   contents: page/contents
   last-page?: yes
   empty-page?: yes
   forall contents [
    contents/1: make contents/1 [ ]
    last-page?: last-page? and contents/1/actions/finalize contents/1
    if contents/1/actions/has-contents? contents/1 [empty-page?: no]
   ]
   unless empty-page? [append pages page]
   if last-page? [break/return true]
   false
  ]
 ]
]

The stream-to-columns function just uses the typeset-columns function from %typesetter.r to typeset the stream into columns, as specified by stream/columns and stream/repeat-columns. (This is for text streams.)

〈The dialect actions〉 +≡

stream-to-columns: func [stream /local ww] [
 foreach [w h] join stream/columns stream/repeat-columns [
  either ww [ww: min w ww] [ww: w]
 ]
 foreach element stream/contents [
  if element/type = 'table [
   finalize-column-widths element ww
  ]
 ]
 stream/output: typeset-columns stream/contents stream/columns stream/repeat-columns
]

The table-stream-to-pages function just uses the typeset-table function from %typesetter.r to typeset the table into pages, as specified by stream/pages and stream/repeat-pages.

〈The dialect actions〉 +≡

table-stream-to-pages: func [stream] [
 ;finalize-column-widths stream ??
 stream/output: typeset-table stream/rows stream/pages stream/repeat-pages
]

4.1 The page dialect actions: textboxes

The new-textbox-from-stream function creates a new textbox that shows text from the given named stream. The textbox is added to cur-page/contents. If the /with refinement was used, the position and the size of the textbox is set as well. If the repeat-columns? flag is set (see above), then the width and height of this textbox are appendend to the repeat-columns block of the stream, otherwise they are appended to the columns block. (These two blocks are used to typeset the stream into columns, as seen above.)

〈The dialect actions〉 +≡

new-textbox-from-stream: func [name /with l b w h] [
 append cur-page/contents make textbox! [
  if with [left: l bottom: b width: w height: h]
  if not stream: select text-streams name [
   make error! "The named stream does not exist"
  ]
  insert insert tail either repeat-columns? [stream/repeat-columns] [stream/columns] width height
 ]
]

The new-textbox function is similar to the previous function, but instead of using a named text stream, it is passed the text stream dialect directly; so it creates the stream and then adds the textbox to cur-page/contents.

〈The dialect actions〉 +≡

new-textbox: func [contents /with l b w h] [
 insert insert tail text-streams none cur-stream: make text-stream! []
 parse contents compiled-tr
 end-paragraph
 append cur-page/contents make textbox! [
  if with [left: l bottom: b width: w height: h]
  stream: cur-stream
  insert insert tail either repeat-columns? [stream/repeat-columns] [stream/columns] width height
 ]
]

The above two functions use the textbox! prototype object to make textboxes. It contains informations on the position and size of the textbox, a reference to the text stream that the textbox will show, a contents field that is set when the textbox is finalized (see the finalize action below), and a reference to the action functions for textboxes.

〈The dialect actions〉 +≡

textbox-actions: context [
 〈Textbox object actions〉
]
textbox!: context [
 left: 10
 bottom: 17
 width: 190
 height: 263
 stream: none
 contents: none
 actions: textbox-actions
]

4.1.1 Textbox object actions

The finalize action for textboxes checks if the stream has been typeset, and if so finalizes the textbox by pulling a column from the stream (stream/output, once the stream has been typeset, is a block of blocks, each block being a column of text). Since the textboxes are finalized in order, each gets the correct column. true is returned if this was the last column in the stream.

〈Textbox object actions〉 ≡

finalize: func [textbox] [
 ; should always be there if this was a repeat
 if all [not textbox/contents textbox/stream/output] [
  textbox/contents: pick textbox/stream/output 1
  tail? textbox/stream/output: next textbox/stream/output
 ]
]

The has-contents? action returns true if the textbox is not empty (note that finalize sets textbox/contents to none if textbox/stream/output is empty).

〈Textbox object actions〉 +≡

has-contents?: func [textbox] [
 found? textbox/contents
]

The to-pdf action translates the textbox to PDF commands. (The discussion of PDF commands is out of the scope of this document. Please refer to Adobe's PDF Reference documentation.) textbox/contents is a block of lines (blocks) and vertical skips (numbers); each line in the textbox contains its width, height and depth, then a sequence of strings (for text), numbers (for spaces and kerning - they need to be converted to text units and their signs need to be changed for use with the TJ command), and font setting commands; we convert the lines to a sequence of PDF text commands with parse. Then we create commands to push the state, display the text, and pop the state back.

〈Textbox object actions〉 +≡

text-lines-to-pdf: func [
 lines cx cy fy
 /local text w h d f s m font-name font-size text-rise color val
  x ww hh dd gfx
] [
 text-rise: 0
 text: make block! 1024
 gfx: make block! 64
 parse lines [
  some [
   into [
    'box set w number! set h number! set val block! (
     cy: cy - h
     val: bind/copy val context [
      xbl: cx
      ybl: cy
      xtr: cx + w
      ytr: cy + h
     ]
     append text compose [
      ET
      (gfx-to-pdf val)
      BT
      (cx) (cy) Td
     ]
     ; reset state
     font-name: font-size: text-rise: color: none
    )
   ]
   |
   into [
    set w number! set h number! set d number! set m number!
    (repend text [0 negate h 'Td] cy: cy - h)
    some [
     [set val string! | set val number! (val: val * -1000 / font-size)] (
      either 'TJ = last text [
       append pick tail text -2 val
      ] [
       val: either m [reduce [m * -1000 / font-size val]] [reduce [val]]
       m: none
       repend text [val 'TJ]
      ]
     )
     |
     'font set f word! set s number! (
      if any [f <> font-name s <> font-size] [
       font-name: f font-size: s
       repend text [to refinement! font-name font-size 'Tf]
      ]
     )
     |
     'rise set s number! (
      if s <> text-rise [
       text-rise: s
       repend text [text-rise 'Ts]
      ]
     )
     |
     'color set s tuple! (
      if s <> color [
       color: s
       repend text [c2d s/1 c2d s/2 c2d s/3 'rg]
      ]
     )
     |
     'box set x number! set ww number! set hh number! set dd number! set val block! (
      either 'TJ = last text [
       append pick tail text -2 ww * -1000 / font-size
      ] [
       either m [
        repend text [reduce [ww + m * -1000 / font-size] 'TJ]
        x: x + m
        m: none
       ] [
        repend text [reduce [ww * -1000 / font-size] 'TJ]
       ]
      ]
      append gfx bind/copy val context [
       xbl: cx + x
       ybl: cy - dd
       xtr: xbl + ww
       ytr: ybl + dd + hh
      ]
     )
    ]
   ]
   (
    cy: cy - d
    either empty? gfx [
     repend text [0 negate d 'Td]
    ] [
     append text compose [
      ET
      (gfx-to-pdf gfx)
      BT
      (cx) (cy) Td
     ]
     clear gfx
     ; reset state
     font-name: font-size: text-rise: color: none
    ]
   )
   |
   set h number! (repend text [0 negate h 'Td] cy: cy - h)
   |
   'table set val block! (
    append text table-actions/table-to-pdf val cx cy 'cy
    ; reset state
    font-name: font-size: text-rise: color: none
   )
  ]
 ]
 if fy [set fy cy]
 text
]
to-pdf: func [textbox] [
 either textbox/contents [
  compose [
   q
   ;(textbox/left) (textbox/bottom)
   ;(textbox/width) (textbox/height) re W n
   BT (textbox/left) (textbox/bottom + textbox/height) Td
   (text-lines-to-pdf textbox/contents textbox/left textbox/bottom + textbox/height none)
   ET
   Q
  ]
 ] [
  [ ]
 ]
]

The c2d function is used to convert a value in the range 0-255 to a value in the range 0.0-1.0.

〈The dialect actions〉 +≡

c2d: func [val] [divide any [val 0] 255]

4.2 The page dialect actions: tables

The new-table-from-stream function creates a table from a table stream.

〈The dialect actions〉 +≡

new-table-from-stream: func [name] [
 append cur-page/contents make table! [
  if not stream: select table-streams name [
   make error! "The named stream does not exist"
  ]
  insert tail either repeat-columns? [stream/repeat-pages] [stream/pages] height
 ]
]

The above function uses the table! prototype:

〈The dialect actions〉 +≡

table-actions: context [
 〈Table object actions〉
]
table!: context [
 left: 10
 bottom: 17
 height: 263
 stream: none
 contents: none
 actions: table-actions
]

4.2.1 Table object actions

finalize and has-contents? are the same as for textboxes.

〈Table object actions〉 ≡

finalize: get in textbox-actions 'finalize
has-contents?: get in textbox-actions 'has-contents?

The to-pdf action renders the table using PDF commands.

〈Table object actions〉 +≡

table-to-pdf: func [table cx cy fy /local text x y dx dy cell xtr ytr xbl ybl b] [
 text: make block! 1024
 parse table [
  some [
   'box set xbl number! set ybl number! set xtr number! set ytr number! set b block! (
    append text compose [
     ET
     q
     1 0 0 1 (cx) (cy) cm
     ;(xbl) (ybl)
     ;(xtr - xbl) (ytr - ybl) re W n
     (gfx-to-pdf b)
     Q
     BT
     (cx) (cy) Td
    ]
   )
   |
   (dx: dy: 0) some [set x number! set y number! (dx: dx + x dy: dy + y)] (
    repend text [dx negate dy 'Td]
    cx: cx + dx
    cy: cy - dy
   )
   |
   set cell block! (append text textbox-actions/text-lines-to-pdf cell cx cy 'cy)
  ]
 ]
 if fy [set fy cy]
 text
]
to-pdf: func [table] [
 either table/contents [
  compose [
   q
   BT (table/left) (table/bottom + table/height) Td
   (table-to-pdf table/contents table/left table/bottom + table/height none)
   ET
   Q
  ]
 ] [
  [ ]
 ]
]

4.3 The page dialect actions: spaces

〈The dialect actions〉 +≡

start-space: does [
 append cur-page/contents cur-space: make space! [
  prev: cur-page
 ]
 cur-page: cur-space
]
end-space: does [
 append cur-page/prev/used-images cur-page/used-images
 cur-page: cur-page/prev
]
cur-space: none
space-actions: context [
 〈Space object actions〉
]
space!: context [
 contents: [ ]
 translate: scale: rotate: skew: none
 actions: space-actions
 used-images: [ ]
]

4.3.1 Space object actions

〈Space object actions〉 ≡

finalize: func [space /local] [
 local: true
 foreach object space/contents [
  local: local and object/actions/finalize object
 ]
 local
]
has-contents?: func [space /local] [
 local: false
 foreach object space/contents [
  local: local or object/actions/has-contents? object
 ]
 local
]
to-pdf: func [space /local result] [
 result: make block! 256
 insert result 'q
 if space/translate [
  repend result [1 0 0 1 space/translate/1 space/translate/2 'cm]
 ]
 if space/rotate [
  repend result [
   cosine space/rotate sine space/rotate
   negate sine space/rotate cosine space/rotate 0 0 'cm
  ]
 ]
 if space/scale [
  repend result [space/scale/1 0 0 space/scale/2 0 0 'cm]
 ]
 if space/skew [
  repend result [1 tangent space/skew/1 tangent space/skew/2 1 0 0 'cm]
 ]
 cur-page: space
 while [cur-page/prev] [
  cur-page: cur-page/prev
 ]
 foreach object space/contents [
  append result object/actions/to-pdf object
 ]
 append result 'Q
]

4.4 The page dialect actions: graphic elements

〈The dialect actions〉 +≡

gfx-to-pdf: func [block] [
 cur-gfx: make gfx! [ ]
 parse block compiled-gc
 block: cur-gfx/pdf
 cur-gfx: none
 block
]
end-gfx: does [
 cur-gfx: none
]
new-gfx: does [
 append cur-page/contents cur-gfx: make gfx! [ ]
]
gfx!: context [
 pdf: [ ]
 actions: context [
  〈Graphic object actions〉
 ]
]
cur-gfx: none
gfx-emit: func [value] [
 if not cur-gfx [new-gfx]
 repend cur-gfx/pdf value
]

4.4.1 Graphic object actions

〈Graphic object actions〉 ≡

finalize: func [gfx] [true]
has-contents?: func [gfx] [false]
to-pdf: func [gfx] [gfx/pdf]

4.5 The text dialect actions

The new-para function creates a new paragraph, appending it to cur-stream/contents. It also sets cur-para, which is used by the other actions. The paragraph object holds the text (translated to boxes and glues, etc., as required by the break-lines function) in contents, while prev-char is used for pair kerning purposes; output will hold the lines once text has been typeset.

〈The dialect actions〉 +≡

new-para: does [
 append cur-stream/contents cur-para: make paragraph! [
  align: cur-stream/cur-align
  interline-glue: cur-stream/interline-glue
  tolerance: cur-stream/tolerance
  margins: copy/deep cur-stream/cur-margins
  unless align = 'justify [tolerance: tolerance * 2 extra-stretch: 0.1]
 ]
]
paragraph!: context [
 type: 'paragraph
 contents: [ ]
 prev-char: none
 active-font: none
 cur-rise: 0
 interline-glue: make-text-list-node [type: 'glue]
 align: 'justify
 tolerance: 1.26
 extra-stretch: 0
 looseness: 0
 margins: [[0 0]]
 active-color: none
 width: 0
 min-width: 0
 max-width: 0
 ww: 0
]
cur-para: none

The emit-text function takes care of converting text strings into a sequence of boxes, glue, etc., using the metrics data for the active font. Font changes need to be added to the text list too, and used fonts need to be added to the used-fonts block.

A sequence of space character is converted into a glue item, with the width of the space character for the active font, stretching half its width and shrinking one third its width. The width of a space after one of ".?!" is increased to two times the normal width, while the width after ";" or ":" is increased 1.5 times. A character is converted into a box item, using the width from the metrics data; if the char is a "wrapper", then a penalty item is added after it.

Note that we are using the font bounding box and not the character bounding box for all characters; this is because we don't really need the actual character size here, while we want all lines to have the same height and depth (unless the font is changed).

〈The dialect actions〉 +≡

emit-text: func [text /local chw bbox lig kern char chid] [
 if empty? text [exit]
 if not cur-para [new-para]
 if cur-para/active-font <> cur-stream/cur-font [
  cur-para/active-font: cur-stream/cur-font
  used-fonts: union used-fonts reduce [cur-stream/cur-font/1]
  append cur-para/contents make-text-list-node [
   type: 'cmd
   ref: compose [font (cur-stream/cur-font)]
  ]
 ]
 if cur-para/cur-rise <> cur-stream/rise [
  cur-para/cur-rise: cur-stream/rise
  append cur-para/contents make-text-list-node [
   type: 'cmd
   ref: compose [rise (cur-stream/rise)]
  ]
 ]
 if cur-para/active-color <> cur-stream/cur-color [
  cur-para/active-color: cur-stream/cur-color
  append cur-para/contents make-text-list-node [
   type: 'cmd
   ref: compose [color (cur-stream/cur-color)]
  ]
 ]
 parse/all text [
  some [
   some space (
    set [chw bbox lig kern] pick cur-stream/cur-metrics 33
    ; para should not start with space
    if all [cur-para/prev-char <> 33 not empty? cur-para/contents] [
     pair-kerning kern
     chw: txt2mm chw
     ; increase space after .?! and ;:
     if find [34 47 64] cur-para/prev-char [chw: chw * 2]
     if find [59 60] cur-para/prev-char [chw: chw * 1.5]
     append cur-para/contents make-text-list-node [
      type: 'glue
      width: chw
      stretch: chw / 2
      shrink: chw / 3
     ]
     cur-para/prev-char: 33
     cur-para/width: cur-para/width + chw
     cur-para/min-width: max cur-para/ww cur-para/min-width
     cur-para/ww: 0
    ]
   )
   |
   char: skip (
    char: char/1
    chid: 1 + to integer! char
    if chw: pick cur-stream/cur-metrics chid [
     set [chw bbox lig kern] chw
     ; use font bbox, not char bbox
     unless cur-stream/rise <> 0 [
      bbox: third pick cur-stream/cur-metrics 257
     ]
     pair-kerning kern
     chw: txt2mm chw
     append cur-para/contents make-text-list-node [
      type: 'box
      width: chw
      ref: char
      height: cur-stream/rise + any [cur-stream/fix-height txt2mm bbox/4]
      depth: subtract any [cur-stream/fix-depth txt2mm negate bbox/2] cur-stream/rise
     ]
     cur-para/prev-char: chid
     cur-para/width: cur-para/width + chw
     cur-para/ww: cur-para/ww + chw
     if find wrapper char [
      emit-penalty/flag 150
      cur-para/min-width: max cur-para/ww cur-para/min-width
      cur-para/ww: 0
     ]
    ]
   )
  ]
 ]
]

The emit-text function uses the space and wrapper charsets, as well as the pair-kerning and txt2mm functions. The former emits a kern item if pair kerning is defined between the previous and the current character; the latter converts a value in text units to a value in millimeters.

〈The dialect actions〉 +≡

space: charset " ^/^-"
wrapper: charset "-+\/"
pair-kerning: func [kern] [
 if all [kern cur-para/prev-char kern: find/skip kern cur-para/prev-char 2] [
  append cur-para/contents make-text-list-node [
   type: 'kern
   width: txt2mm kern/2
  ]
 ]
]
txt2mm: func [val] [val * cur-stream/cur-font/2 / 1000]

The emit-forced-break function emits a forced break, i.e. a penalty item with a value of -infty.

〈The dialect actions〉 +≡

emit-forced-break: does [
 if not cur-para [exit]
 append cur-para/contents make-text-list-node [
  type: 'penalty
  penalty: -infty
 ]
 cur-para/max-width: max cur-para/width cur-para/max-width
 cur-para/min-width: max cur-para/ww cur-para/min-width
 cur-para/width: cur-para/ww: 0
 cur-para/prev-char: none
]

The end-paragraph function ends the current paragraph. Glue items at the end are removed (penalty items are not removed since they can't get there by mistake; however users should not have penalty items at the end of the paragraph unless they know what they're doing); then the end sequence of penalty and glue is added (its effect is disabling justification for the last line of text, and ensuring a forced break at the end of the paragraph).

〈The dialect actions〉 +≡

end-paragraph: does [
 if cur-para [
  cur-para/max-width: max cur-para/width cur-para/max-width
  cur-para/min-width: max cur-para/ww cur-para/min-width
  cur-stream/max-width: max cur-para/max-width cur-stream/max-width
  cur-stream/min-width: max cur-para/min-width cur-stream/min-width
  cur-para/contents: tail cur-para/contents
  while [〈the last item in cur-para/contents is glue〉] [
   cur-para/contents: skip cur-para/contents negate text-list-node-size
  ]
  cur-para/contents: head clear cur-para/contents
  insert insert insert tail cur-para/contents
   make-text-list-node [type: 'penalty penalty: +infty]
   make-text-list-node [type: 'glue stretch: +infty]
   make-text-list-node [type: 'penalty penalty: -infty]
 ]
 cur-para: none
]

The emit-penalty function emits a penalty item. If /flag is used, a flagged penalty will be emitted; if /with is used, a flagged penalty with the given character and width will be emitted (e.g. for hyphens).

〈The dialect actions〉 +≡

emit-penalty: func [penalty' /flag /with char chw h d /local f] [
 if not cur-para [exit]
 f: either flag [1] [0]
 either with [
  f: 1
 ] [
  chw: h: d: 0
 ]
 append cur-para/contents make-text-list-node [
  type: 'penalty
  width: chw
  height: h
  depth: d
  penalty: penalty'
  flag: f
  ref: char
 ]
 cur-para/min-width: max cur-para/ww cur-para/min-width
 cur-para/ww: 0
]

The emit-kern function emits a kern item, while the emit-glue function emits a generic glue item. In case of emit-glue, we need to emit a font command first if the text list is empty, as a text list must always begin with a font command.

〈The dialect actions〉 +≡

emit-kern: func [value] [
 if not cur-para [exit]
 append cur-para/contents make-text-list-node [type: 'kern width: value]
 cur-para/prev-char: none
 cur-para/width: cur-para/width + value
 cur-para/ww: cur-para/ww + value
]
emit-glue: func [width' stretch' shrink'] [
 if not cur-para [new-para]
 if empty? cur-para/contents [
  append cur-para/contents make-text-list-node [
   type: 'cmd
   ref: compose [font (cur-stream/cur-font)]
  ]
 ]
 append cur-para/contents make-text-list-node [
  type: 'glue
  width: width'
  stretch: stretch'
  shrink: shrink'
 ]
 cur-para/prev-char: none
 cur-para/width: cur-para/width + width'
 cur-para/min-width: max cur-para/ww cur-para/min-width
 cur-para/ww: 0
]

The emit-box function:

〈The dialect actions〉 +≡

emit-box: func [w h d gfx] [
 if not cur-para [new-para]
 if empty? cur-para/contents [
  append cur-para/contents make-text-list-node [
   type: 'cmd
   ref: compose [font (cur-stream/cur-font)]
  ]
 ]
 append cur-para/contents make-text-list-node [
  type: 'box
  width: w height: h depth: d
  ref: gfx
 ]
 cur-para/prev-char: none
 cur-para/width: cur-para/width + w
 cur-para/ww: cur-para/ww + w
]

The emit-vspace functions emits glue in the vertical direction (also ends the current paragraph).

〈The dialect actions〉 +≡

emit-vspace: func [height' stretch' shrink'] [
 end-paragraph
 append cur-stream/contents make vspace! [
  height: height'
  stretch: stretch'
  shrink: shrink'
 ]
]
vspace!: context [
 type: 'vspace
 height: stretch: shrink: 0
]

The emit-vpenalty function emits a page breaking penalty (a forced page break if p is -infty).

〈The dialect actions〉 +≡

emit-vpenalty: func [p] [
 end-paragraph
 append cur-stream/contents context [
  type: 'vpenalty
  penalty: p
 ]
]

The emit-vbox function:

〈The dialect actions〉 +≡

emit-vbox: func [h gfx] [
 end-paragraph
 append cur-stream/contents context [
  type: 'vbox
  height: h
  contents: gfx
 ]
]

The use-font function sets the current font for the text.

〈The dialect actions〉 +≡

use-font: func [name size] [
 cur-stream/cur-font: reduce [name size]
 cur-stream/cur-metrics: get-metrics name
]

The new-inline-table function adds an embedded table to the current text stream.

〈The dialect actions〉 +≡

new-inline-table: func [columns' table align' /local saved] [
 end-paragraph
 saved: reduce [cur-stream cur-table-stream]
 append cur-stream/contents cur-table-stream: make table-stream! [
  type: 'table
  columns: reduce columns'
  align: align'
  def-cell-margins: copy def-cell-margins
  def-cell-padding: copy def-cell-padding
 ]
 parse table compiled-tabr
 compute-column-widths cur-table-stream
 cur-stream: first saved
 cur-stream/max-width: max cur-table-stream/max-width cur-stream/max-width
 cur-stream/min-width: max cur-table-stream/min-width cur-stream/min-width
 cur-table-stream: second saved
]

4.5.1 the last item in cur-para/contents is glue

〈the last item in cur-para/contents is glue〉 ≡

'glue = pick cur-para/contents text-list-node!/type - text-list-node-size - 1

4.6 The table dialect actions

A cell! is also a text stream.

〈The dialect actions〉 +≡

cur-row: none
row!: context [
 top-margin:
 top-padding:
 bottom-padding:
 bottom-margin: none
 break-penalty: 1000
 contents: [ ]
 pages: none
 def-cell-margins: [0 0]
 def-cell-padding: [0 0]
 def-cell-valign: 'top
 def-cell-decor: [ ]
]
cell!: make text-stream! [
 width: 50
 valign: 'top
 height: none
 margins: [0 0] ; left right
 padding: [0 0] ; left right
 breakpoints: [ ]
 decor: [ ]
]

The compute-column-widths function:

〈The dialect actions〉 +≡

compute-column-widths: func [table-stream /local row-minw row-maxw col cwmin cwmax] [
 foreach row table-stream/rows [
  row-minw: row-maxw: 0
  col: 1
  foreach cell row/contents [
   row-minw: row-minw + cwmin: cell/margins/1 + cell/padding/1
    + cell/padding/2 + cell/margins/2 + any [cell/width cell/min-width]
   row-maxw: row-maxw + cwmax: cell/margins/1 + cell/padding/1
    + cell/padding/2 + cell/margins/2 + any [cell/width cell/max-width]
   either col > length? table-stream/col-minw [
    insert tail table-stream/col-minw cwmin
    insert tail table-stream/col-maxw cwmax
   ] [
    poke table-stream/col-minw col max cwmin pick table-stream/col-minw col
    poke table-stream/col-maxw col max cwmax pick table-stream/col-maxw col
   ]
   col: col + 1
  ]
  table-stream/max-width: max table-stream/max-width row-maxw
  table-stream/min-width: max table-stream/min-width row-minw
 ]
]
finalize-column-widths: func [table-stream max-width /local maxw tw shrink cmaxw cminw cw totshr r pos cell] [
 shrink: make block! 16
 maxw: make block! 16
 repeat i length? table-stream/col-maxw [
  either cw: pick table-stream/columns i [
   max-width: max-width - cw
  ] [
   cmaxw: pick table-stream/col-maxw i
   cminw: pick table-stream/col-minw i
   append maxw cmaxw
   append shrink cmaxw - cminw
  ]
 ]
 tw: 0
 foreach w maxw [tw: tw + w]
 if tw > max-width [
  totshr: 0
  forall shrink [
   shrink/1: shrink/1 * shfactor shrink/1 / max-width
   totshr: totshr + shrink/1
  ]
  if totshr > 0 [
   r: tw - max-width / totshr
   repeat i length? maxw [
    poke maxw i subtract pick maxw i r * pick shrink i
   ]
  ]
 ]
 foreach w maxw [
  pos: any [find table-stream/columns none tail table-stream/columns]
  change pos w
 ]
 foreach row table-stream/rows [
  pos: 1
  foreach cell row/contents [
   cw: pick table-stream/columns pos
   unless cell/width [
    cell/width: cw - cell/margins/1 - cell/margins/2 - cell/padding/1 - cell/padding/2
   ]
   foreach element cell/contents [
    if element/type = 'table [
     finalize-column-widths element cell/width
    ]
   ]
   pos: pos + 1
  ]
 ]
 if all [tw < max-width table-stream/align <> 'left] [
  cw: max-width - tw
  if table-stream/align = 'center [cw: cw / 2]
  foreach row table-stream/rows [
   if cell: pick row/contents 1 [
    cell/margins/1: cell/margins/1 + cw
   ]
  ]
 ]
]
shfactor: func [x] [
 subtract 1 divide 1 add multiply x x 1
]

5. Layout a PDF document

Creating a PDF document means parsing the given spec, so that text streams and pages are generated as described above. Then, we typeset any stream that hasn't been typeset yet, and so finalize any element that hasn't been finalized yet.

At this point, everything is ready: we can create the objects that make up the PDF document; the make-docroot, make-pages, make-images and make-fonts functions are used for this. Then, calling make-pdf creates the actual PDF binary data from the object specification.

〈Layout a PDF document〉 ≡

〈Initialize values〉
parse spec compiled
foreach [name stream] text-streams [
 if not stream/output [
  stream-to-columns stream
 ]
]
foreach page pages [
 foreach element page/contents [element/actions/finalize element]
]
make-pages make-fonts
make-docroot
make-pdf pdf-spec

5.1 layout-pdf's locals

〈layout-pdf's locals〉 ≡

i

5.2 Initialize values

〈Initialize values〉 ≡

clear text-streams
cur-stream: none
clear table-streams
cur-table-stream: none
cur-row: none
clear pages
cur-para: none
clear used-fonts
clear pdf-spec

6. Get metrics data for the character char

〈Get metrics data for the character char〉 ≡

char: pick get-metrics font-name 1 + to integer! char
context [
 width: char/1 * font-size / 1000
 height: char/2/4 * font-size / 1000
 depth: negate char/2/2 * font-size / 1000
]

7. Get informations on the font with name font-name

〈Get informations on the font with name font-name〉 ≡

font-name: pick get-metrics font-name 257
context [
 full-name: font-name/1
 family-name: font-name/2
 max-height: font-name/3/4 * font-size / 1000
 max-depth: negate font-name/3/2 * font-size / 1000
]

8. PDF document emitter

This section contains all the functions that create the actual binary string in PDF format.

〈PDF document emitter〉 ≡

pdf-spec: [ ]
mm2pt: func [mm] compose [mm * (72 / 25.4)]
make-docroot: does [
 insert tail pdf-spec compose/deep [
  obj 1 [
   #<< /Type /Catalog
    /Version /1.4
    /Outlines 2 0 R
    /Pages 4 0 R
   #>>
  ]

  obj 2 [
   #<< /Type /Outlines
    /Count 0
   #>>
  ]

  obj 3 [ ; ProcSet to use in pages
   [/PDF /Text /ImageC]
  ]
 ]
]
make-pages: func [i /local kids mediabox stream] [
 kids: clear []
 foreach page pages [
  mediabox: reduce [0 0 mm2pt page/size/1 mm2pt page/size/2]
  stream: clear []
  insert tail stream compose [(mm2pt 1) 0 0 (mm2pt 1) (mm2pt page/offset/1) (mm2pt page/offset/2) cm]
  cur-page: page
  foreach object page/contents [
   insert tail stream object/actions/to-pdf object
  ]
  i: make-images page/used-images i
  insert tail kids reduce [i 0 'R]
  insert tail pdf-spec compose/deep [
   obj (i) [
    #<< /Type /Page
     /Parent 4 0 R
     /MediaBox [(mediabox)]
     /Rotate (page/rotation)
     /Contents (i + 1) 0 R
     /Resources #<<
      /ProcSet 3 0 R
      (either empty? font-resources [] [compose [/Font #<< (font-resources) #>>]])
      (either empty? image-resources [] [compose [/XObject #<< (image-resources) #>>]])
     #>>
    #>>
   ]

   stream (i + 1) [
    (stream)
   ]
  ]
  i: i + 2
 ]
 insert tail pdf-spec compose/deep [
  obj 4 [
   #<< /Type /Pages
    /Kids [(kids)]
    /Count (length? pages)
   #>>
  ]
 ]
 i
]
image-resources: []
img-count: 1
; this creates the Image XObjects in the PDF file
; need to optimize image-resources
make-images: func [used-images i] [
 clear image-resources
 foreach [name image] used-images [
  insert tail image-resources reduce [to-refinement name i 0 'R]
  insert tail pdf-spec compose/deep [
   image (i) (i + 1) (image)
  ]
  i: i + 2
 ]
 i
]
; this creates the font objects in the PDF file
; only the 14 standard PDF fonts supported currently
used-fonts: []
font-resources: []
make-fonts: has [i] [
 i: 5
 clear font-resources
 foreach font used-fonts [
  insert tail font-resources reduce [to-refinement font i 0 'R]
  insert tail pdf-spec compose/deep [
   obj (i) [
    #<< /Type /Font
     /Subtype /Type1
     /BaseFont (to-refinement font)
     /Encoding /WinAnsiEncoding
    #>>
   ]
  ]
  i: i + 1
 ]
 i
]

Here is the lowlevel code that emits binary data:

〈PDF document emitter〉 +≡

; note: we will actually emit a 1.4 version PDF file, tough
; we'll use the key in the root catalog to state the real version;
; this way we should stay compatible with 1.3 (i.e. Acrobat 4)
pdf-start: "%PDF-1.3^/"
pdf-end: "%%EOF"
; form a decimal value avoiding scientific format etc.
form-decimal: func [
 "Form a decimal number"
 num [number!]
 /local str sign float ip fp
] [
 if zero? num [return copy "0"]
 sign: either negative? num [
  num: abs num
  "-"
 ] [""]
 str: make string! 20
 num: form multiply power 10 negate float: to-integer log-10 num to-decimal num
 ip: first num
 fp: copy skip num 2
 ; understanding this is left as an exercise to the reader. >:->
 insert/dup
  insert/part
   insert
    insert/dup
     insert
      insert str sign
      either float < 0 ["0."] [""]
     #"0"
     -1 - float
    ip
   fp
   either float < 0 [tail fp] [float]
  #"0"
  float - length? fp
 if all [float >= 0 float < length? fp] [
  insert insert tail str #"." skip fp float
 ]
 str
]
; valid characters in strings
pdf-string-valid: complement charset "()\"
; this converts REBOL values to PDF values; it's way from perfect but works.
pdf-form: func ["REBOL to PDF" value /only /local result mrk1 mrk2] [
 result: make string! 256
 if block? :value [
  if empty? value [return copy "[]"]
  if only [insert result "["]
  foreach element value [
   insert insert tail result pdf-form/only element #" "
  ]
  either only [change back tail result "]"] [remove back tail result]
  return result
 ]
 if char? :value [
  return head insert result reduce [
   #"("
   either find pdf-string-valid value [""] [#"\"] value
   #")"
  ]
 ]
 if string? :value [
  insert result "("
  parse/all value [
   some [
    mrk1: some pdf-string-valid mrk2: (
     insert/part tail result mrk1 mrk2
    )
   | mrk1: skip (
     insert insert tail result #"\" mrk1/1
    )
   ]
  ]
  insert tail result ")"
  return result
 ]
 if decimal? :value [return form-decimal value]
 ; issues are used for tricks. ;-)
 if issue? :value [return form value]
 ; other values simply molded currently.
 mold :value
]
; this will hold the document's xref table
xref: []
; this will hold the document itself
contents: #{}

; LOWLEVEL PDF DIALECT
; (this is what people on the ml were looking for. :)
pdf-words: context [
 ; creates an object
 obj: func [
  id "Object id (generation will always be 0)"
  data "A block of data (will use PDF-FORM above)"
 ] [
  insert tail xref compose/deep [(id) [(-1 + index? tail contents)]]
  insert tail contents reduce [
   id " 0 obj^/" pdf-form data "^/endobj^/"
  ]
 ]
 ; creates a stream
 stream: func [
  id "Object id (generation will always be 0)"
  data "Block (will use PDF-FORM) or any-string"
 ] [
  insert tail xref compose/deep [(id) [(-1 + index? tail contents)]]
  if block? data [data: pdf-form data]
  insert tail contents reduce [
   id " 0 obj^/"
   pdf-form compose [
    #<< /Length (length? data) #>>
   ]
   "^/stream^/"
   data
   "^/endstream^/endobj^/"
  ]
 ]
 ; creates an Image XObject
 ; now has full support for the alpha channel (PDF 1.4)
 ; you are required to supply the ID for the SoftMask
 image: func [
  id {Object id for the image (generation will always be 0)}
  aid {Object id for the SoftMask (generation will always be 0)}
  img [image!] "Image data"
  /local rgb alpha
 ] [
  insert tail xref compose/deep [(id) [(-1 + index? tail contents)]]
  ; requires View 1.3
  rgb: img/rgb
  alpha: img/alpha
  insert tail contents reduce [
   id " 0 obj^/"
   pdf-form compose [
    #<< /Type /XObject
     /Subtype /Image
     /Width (img/size/x)
     /Height (img/size/y)
     /ColorSpace /DeviceRGB
     /BitsPerComponent 8
     /Interpolate true
     /SMask (aid) 0 R
     /Length (length? rgb)
    #>>
   ]
   "^/stream^/"
   rgb
   "^/endstream^/endobj^/"
  ]
  insert tail xref compose/deep [(aid) [(-1 + index? tail contents)]]
  ; NOTE: I'm not using the Matte key, i.e. I'm assuming that the image
  ; is not preblended. handling all that would go far beyond the scope of
  ; the PDF Maker. if you need to use preblended images you could apply the
  ; inverse formula on the image before passing it to the PDF Maker, or you could
  ; hack it here adding /Matte for your own purpose... :)
  insert tail contents reduce [
   aid " 0 obj^/"
   pdf-form compose [
    #<< /Type /XObject
     /Subtype /Image
     /Width (img/size/x)
     /Height (img/size/y)
     /ColorSpace /DeviceGray
     /BitsPerComponent 8
     /Interpolate true
     ; REBOL's alpha channel is inverted with respect to PDF's
     /Decode [1 0]
     /Length (length? alpha)
    #>>
   ]
   "^/stream^/"
   alpha
   "^/endstream^/endobj^/"
  ]
 ]
]

; guess what's this? :)
zero-padded: func [val n] [
 val: form val
 head insert insert/dup make string! n #"0" n - length? val val
]
; makes the xref table for the document
make-xref: has [pos xref' lastfree firstfree cur] [
 pos: tail contents
 sort/skip xref 2
 xref': clear []
 firstfree: lastfree: 0
 repeat i pick tail xref -2 [
  either cur: select xref i [
   insert/only tail xref' reduce [cur/1 'n]
  ] [
   either firstfree = 0 [firstfree: i] [xref'/:lastfree/1: i]
   lastfree: i
   insert/only tail xref' copy [0 f]
  ]
 ]
 insert pos reduce [
  "xref^/0 " 1 + length? xref' "^/" zero-padded firstfree 10 " 65535 f ^/"
 ]
 foreach item xref' [
  insert tail pos reduce [
   zero-padded item/1 10 " 00000 " item/2 " ^/"
  ]
 ]
 insert tail pos reduce [
  "trailer^/"
  pdf-form compose [
   #<< /Size (1 + length? xref')
    /Root 1 0 R ; this assumes root will always be 1
   #>>
  ]
  "^/startxref^/"
  -1 + index? pos newline
 ]
]
; THIS IS THE LOWLEVEL FUNCTION
; use this to make a PDF file using the three lowlevel commands defined above
; (OBJ, STREAM and IMAGE)
make-pdf: func [spec [block!]] [
 clear xref
 clear contents
 insert contents pdf-start
 do bind spec in pdf-words 'self
 make-xref
 copy head insert tail contents pdf-end
]

9. The PDF Maker

〈The PDF Maker〉 ≡

〈The dialect actions〉
〈The dialect rules〉
〈PDF document emitter〉