Qtask Markup Language - PDF emitter

〈Overview〉 ≡

#include %pdf-maker.r

pdf-emitter: context [
 out: none
 
 〈The parse rules that generate the document〉
 〈The PDF template〉
 
 generate: func [qml-doc [block!]] [
  out: make block! 1024
  output: reduce [out none]
  spc: str: shr: 0 pen: none
  parse qml-doc qml-rule
  ;write clipboard:// mold/only out
  layout-pdf template
 ]
]

〈The parse rules that generate the document〉 ≡

qml-rule: ['qml some block-level]
block-level: [
 〈Block level rules〉
]

〈Block level rules〉 ≡

;here: (print ["block-level:" copy/part trim/lines mold here 80])
into [
 'para opts [
  end (emit-space val: cur-para/cur-font/size / 0.846 val * 0.1 val * 6E-2 para-indent?: no)
  |
  (
   flush-space
   new-para/set-opts []
   manual-indent?: no
   option? [indent:] [para-indent?: no manual-indent?: yes]
   if all [para-indent? cur-para/alignment = [justify]] [
    emit compose [space (cur-para/cur-font/size / 0.52875)]
   ]
  )
  some inline-level
  (end-para para-indent?: not manual-indent?)
 ]
 |
 'hrule to end (
  para-indent?: no
  emit-penalty +infty
  emit-space 3 2 2
  flush-space
  emit [
   vbox 4 [line width 0.7 cap butt dash [3] 0 255.153.0 xbl ybl + 2 xtr ybl + 2]
  ]
  emit-penalty -200
  emit-space 3 2 2
 )
 |
 ['header1 | 'header1*] opts (start-header 1) any inline-level (end-header 1)
 |
 ['header2 | 'header2*] opts (start-header 2) any inline-level (end-header 2)
 |
 ['header3 | 'header3*] opts (start-header 3) any inline-level (end-header 3)
 |
 'header4 opts (start-header 4) any inline-level (end-header 4)
 |
 'header5 opts (start-header 5) any inline-level (end-header 5)
 |
 'header6 opts (start-header 6) any inline-level (end-header 6)
 |
 'bullets (pre-list) any bullets (post-list)
 |
 'enum (pre-enum) any enum-items (post-enum)
 |
 'checks (pre-list) any checks (post-list)
 |
 'definitions (pre-def) any definitions (post-def)
 |
 'box opts (
  emit-space 1 1 1
  flush-space
  emit compose/deep [table [(cur-para/width - 20)]]
  start-block
  emit [
   top padding 1
   bottom padding 1
   left margin 5
   left padding 5
   right padding 5
   break penalty 10000
  ]
  option? [shadow:] [if value [emit [right margin 5 bottom margin 2]]]
  emit-box-decor
  loop 2 [start-block]
  new-para/set-opts [width: width - 20]
 ) opt [
  into [
   'title opts (start-header/box 2) any inline-level (end-header 2)
  ]
 ] (para-indent?: no) any block-level (
  end-para
  emit-penalty +infty
  flush-space
  loop 3 [end-block]
  emit-space 3 1 1
  para-indent?: no
 )
 |
 'section opt [
  into [
   'toc
   opt [into ['title opts (start-header 1) any inline-level (end-header 1)]]
   any toc-headers
  ]
 ] any block-level
 |
 'table opts val: to end (make-table options val)
 |
 'center opts (new-para/set-opts [alignment: [center]]) any block-level (end-para)
 |
 'left opts (new-para/set-opts [alignment: [left align]]) any block-level (end-para)
 |
 'right opts (new-para/set-opts [alignment: [right align]]) any block-level (end-para)
 |
 'justify opts (new-para/set-opts [alignment: [justify]]) any block-level (end-para)
 |
 'escape string! set val string! to end (
  emit-space 3 2 2
  new-para/margins/font [alignment: [left align]] [0 0 10 0] 'courier none
  foreach line parse/all val "^/" [
   either empty? line [
    emit-space tmp: cur-para/cur-font/size / 0.846 tmp * 0.1 tmp * 6E-2
   ] [
    flush-space
    emit compose [(line) vpenalty 300]
   ]
  ]
  emit-space 3 2 2
  end-para
 )
 |
 'command copy val [string! skip]
]
|
error

〈The parse rules that generate the document〉 +≡

emit: func [value] [
 append output/1 value
]
start-block: does [
 append/only output/1 make block! 256
 output: reduce [last output/1 output]
]
end-block: does [
 output: output/2
]
output: reduce [out none]
val: none
tmp: none
para-indent?: no
manual-indent?: no
spc: str: shr: 0
emit-space: func [a b c] [
 spc: spc + a
 str: add* str b
 shr: shr + c
]
pen: none
emit-penalty: func [a] [
 either pen [
  pen: max* pen a
 ] [
  pen: a
 ]
]
flush-space: does [
 if pen [
  emit compose/only [vpenalty (pen)]
  pen: none
 ]
 unless all [zero? spc eq* str 0 zero? shr] [
  emit compose/only [vglue (spc) (str) (shr)]
  spc: str: shr: 0
 ]
]

〈The parse rules that generate the document〉 +≡

fnode!: context [
 name:
 bold:
 italic:
 times:
 helvetica:
 courier: none
 fixed: no
]
mkfnode: func [spec] [
 make fnode! spec
]
fonts-graph: context [
 times: mkfnode [
  name: 'Times-Roman
  bold: mkfnode [
   name: 'Times-Bold
   bold: self
   italic: mkfnode [
    name: 'Times-BoldItalic
    bold: self
    italic: self
    times: self
    helvetica: 'helvetica/bold/italic
    courier: 'courier/bold/italic
   ]
   times: self
   helvetica: 'helvetica/bold
   courier: 'courier/bold
  ]
  italic: mkfnode [
   name: 'Times-Italic
   bold: 'times/bold/italic
   italic: self
   times: self
   helvetica: 'helvetica/italic
   courier: 'courier/italic
  ]
  times: self
  helvetica: 'helvetica
  courier: 'courier
 ]
 helvetica: mkfnode [
  name: 'Helvetica
  bold: mkfnode [
   name: 'Helvetica-Bold
   bold: self
   italic: mkfnode [
    name: 'Helvetica-BoldOblique
    bold: self
    italic: self
    times: 'times/bold/italic
    helvetica: self
    courier: 'courier/bold/italic
   ]
   times: 'times/bold
   helvetica: self
   courier: 'courier/bold
  ]
  italic: mkfnode [
   name: 'Helvetica-Oblique
   bold: 'helvetica/bold/italic
   italic: self
   times: 'times/italic
   helvetica: self
   courier: 'courier/italic
  ]
  times: 'times
  helvetica: self
  courier: 'courier
 ]
 courier: mkfnode [
  name: 'Courier
  bold: mkfnode [
   name: 'Courier-Bold
   bold: self
   italic: mkfnode [
    name: 'Courier-BoldOblique
    bold: self
    italic: self
    times: 'times/bold/italic
    helvetica: 'helvetica/bold/italic
    courier: self
   ]
   times: 'times/bold
   helvetica: 'helvetica/bold
   courier: self
  ]
  italic: mkfnode [
   name: 'Courier-Oblique
   bold: 'courier/bold/italic
   italic: self
   times: 'times/italic
   helvetica: 'helvetica/italic
   courier: self
  ]
  times: 'times
  helvetica: 'helvetica
  courier: self
 ]
]
fix-node: func [fnode /local val] [
 fnode/fixed: yes
 foreach word [bold italic times helvetica courier] [
  val: get word: in fnode word
  case [
   word? val [
    set word val: get in fonts-graph val
   ]
   path? val [
    val/1: in fonts-graph val/1
    set word val: do val
   ]
  ]
  unless any [fnode = val val/fixed] [fix-node val]
 ]
]
foreach node [times helvetica courier] [
 fix-node get in fonts-graph node
]
change-font: func [new-path new-size /color new-color] [
 case [
  word? new-path [
   new-path: get in cur-para/cur-font/fnode new-path
  ]
  path? new-path [
   new-path/1: in cur-para/cur-font/fnode new-path/1
   new-path: do new-path
  ]
 ]
 cur-para/cur-font: make cur-para/cur-font [
  prev: cur-para/cur-font
  fnode: new-path
  size: new-size
  color: any [new-color color]
 ]
 emit-font
]
emit-font: does [
 emit compose [font (cur-para/cur-font/fnode/name) (cur-para/cur-font/size) (cur-para/cur-font/color)]
]
reset-font: does [
 cur-para/cur-font: cur-para/cur-font/prev
 emit-font
]

〈The parse rules that generate the document〉 +≡

paragraph!: context [
 alignment: [justify]
 margins: [0 0]
 width: 150
 cur-font: context [
  fnode: fonts-graph/helvetica
  size: 3.52
  prev: self
  color: black
 ]
 prev: self
]
cur-para: make paragraph! [ ]
new-para: func [spec /margins mgs /set-opts /font path size] [
 spec: make cur-para spec
 spec/prev: cur-para
 cur-para: spec
 cur-para/margins: copy cur-para/margins
 if margins [increase-margins mgs]
 if all [set-opts options] [set-para-options]
 emit compose/deep [
  (cur-para/alignment) with margins [(cur-para/margins)] with tolerance 3
 ]
 either font [change-font path any [size cur-para/cur-font/size]] [emit-font]
]
end-para: does [
 cur-para: cur-para/prev
 emit [p]
]

〈The parse rules that generate the document〉 +≡

set-para-options: has [fpath fsize fcolor app] [
 app: func [word] [
  either fpath [
   append fpath word
  ] [
   fpath: make path! reduce [word]
  ]
 ]
 foreach [word value] options [
  switch word [
   indent: [increase-margins [value * 20 0]]
   bold: [if value [app 'bold]]
   fontsize: [fsize: value / 2.84]
   italic: [if value [app 'italic]]
   typeface: [if word? value [app value]]
   color: [fcolor: to-color value]
  ]
 ]
 if any [fpath fsize fcolor] [
  fpath: any [fpath 'self]
  fsize: any [fsize cur-para/cur-font/size]
  change-font/color fpath fsize fcolor
 ]
]
set-font-options: has [fpath fsize fcolor] [
 if options [
  fpath: make path! [self]
  foreach [word value] options [
   switch word [
    bold: [if value [append fpath 'bold]]
    fontsize: [fsize: value / 2.84]
    italic: [if value [append fpath 'italic]]
    typeface: [if word? value [append fpath value]]
    color: [fcolor: to-color value]
   ]
  ]
  change-font/color fpath any [fsize cur-para/cur-font/size] fcolor
 ]
]
increase-margins: func [new-margins /local para-margins diff] [
 new-margins: reduce new-margins
 para-margins: cur-para/margins
 diff: subtract length? para-margins length? new-margins
 case [
  diff < 0 [
   insert/dup tail para-margins copy skip tail para-margins -2 diff / -2
  ]
  diff > 0 [
   insert/dup tail new-margins copy skip tail new-margins -2 diff / 2
  ]
 ]
 forall para-margins [
  para-margins/1: para-margins/1 + new-margins/1
  new-margins: next new-margins
 ]
]
option?: func [value code] [
 if all [options value: select options value] [do bind code 'value]
]

〈The parse rules that generate the document〉 +≡

start-header: func [level /box] [
 do pick [
  [unless box [emit-penalty -500] emit-space 3 2 2]
  [unless box [emit-penalty -200] emit-space 3 2 2]
  [unless box [emit-penalty -100] emit-space 0 2 0]
  [emit-space 0 2 0]
  [emit-space 0 1 0]
  [emit-space 0 1 0]
 ] level
 flush-space
 new-para [ ]
 change-font/color 'bold pick [
  7 6.34 5.63 4.93 4.23 3.52
 ] level 255.153.0
 new-para/set-opts []
 option? [number:] [emit value]
]
end-header: func [level] [
 loop 2 [end-para]
 if level < 3 [
  emit compose/deep [
   vbox 1 [
    line width (pick [0.7 0.4] level) cap round
     dash [1E-3 (pick [1.4 0.8] level)] (pick [0.8 0.5] level) 255.153.0
     xbl ybl + 0.5 xtr ybl + 0.5
   ]
  ]
 ]
 emit-penalty +infty
 do pick [
  [emit-space 3 2 2]
  [emit-space 3 2 2]
  [emit-space 1 2 0]
  [emit-space 1 1 0]
  [emit-space 0 1 0]
  [emit-space 0 1 0]
 ] level
 para-indent?: no
]

〈The parse rules that generate the document〉 +≡

pre-list: does [
 emit-space 3 2 2
]
post-list: does [
 emit-space 2 1 2
 para-indent?: no
]
pre-enum: func [/only] [
 unless only [
  emit-space 3 2 2
  flush-space
 ]
 emit compose/deep [
  table [8 (cur-para/width - 10)]
 ]
 start-block
 emit [
  top margin 0
  bottom margin 1 stretch 1
  top padding 0
  bottom padding 0
 ]
]
post-enum: func [/only] [
 end-block
 unless only [emit-space 3 2 2]
]
pre-def: does [
 emit-space 3 2 2
 flush-space
 emit compose/deep [
  table [20 (cur-para/width - 22)]
 ]
 start-block
 emit [
  bottom margin 1 stretch 1
 ]
]
post-def: does [
 end-block
 emit-space 3 2 2
]

〈The parse rules that generate the document〉 +≡

emit-box-decor: has [bgcol olcol shadow? olstyle] [
 either options [
  bgcol: yellow
  shadow?: no
  foreach [word value] options [
   switch word [
    background: [bgcol: to-color value]
    outline-color: [olcol: to-color value]
    shadow: [shadow?: value]
    outline-style: [olstyle: value]
   ]
  ]
  if olcol [olstyle: any [olstyle 'solid]]
  if olstyle [olcol: any [olcol black]]
  either olstyle = 'rounded [
   emit compose/deep [
    decor [
     (either shadow? [
      [set-fill color gray rounded-box-fill xbl + 2 ybl - 2 xtr + 2 ytr - 2]
     ] [[ ]])
     set-fill (bgcol)
     rounded-box-fill xbl ybl xtr ytr
    ]
   ]
  ] [
   either olstyle [
    olstyle: switch olstyle [
     solid [[edge width 0.2]]
     dashed [[edge width 0.2 edge dash [3] 0]]
     dotted [[edge width 0.2 edge dash [0.5] 0]]
    ]
    emit compose/deep [
     decor [
      (either shadow? [
       [fill color gray [box xbl + 2 ybl - 2 xtr - xbl ytr - ybl]]
      ] [[ ]])
      solid box edge (olcol) (olstyle) (bgcol) xbl ybl xtr - xbl ytr - ybl
     ]
    ]
   ] [
    emit compose/deep [
     decor [
      (either shadow? [
       [fill color gray [box xbl + 2 ybl - 2 xtr - xbl ytr - ybl]]
      ] [[ ]])
      fill (bgcol) [box xbl ybl xtr - xbl ytr - ybl]
     ]
    ]
   ]
  ]
 ] [
  emit [
   decor [
    fill color yellow [box xbl ybl xtr - xbl ytr - ybl]
   ]
  ]
 ]
]

〈The parse rules that generate the document〉 +≡

to-color: func [value] [
 switch type?/word value [
  issue! [to tuple! debase/base value 16]
  refinement! [select color-names value]
  tuple! [value]
 ]
]
color-names: [
 /Maroon 128.0.0 /Red 255.0.0 /Orange 255.165.0
 /Yellow 255.255.0 /Olive 128.128.0 /Purple 128.0.128
 /Fuchsia 255.0.255 /White 255.255.255 /Lime 0.255.0
 /Green 0.128.0 /Navy 0.0.128 /Blue 0.0.255
 /Aqua 0.255.255 /Teal 0.128.128 /Black 0.0.0
 /Silver 192.192.192 /Gray 128.128.128 /AliceBlue 240.248.255
 /AntiqueWhite 250.235.215 /Aquamarine 127.255.212 /Azure 240.255.255
 /Beige 245.245.220 /Bisque 255.228.196 /BlanchedAlmond 255.235.205
 /BlueViolet 138.43.226 /Brown 165.42.42 /BurlyWood 222.184.135
 /CadetBlue 95.158.160 /Chartreuse 127.255.0 /Chocolate 210.105.30
 /Coral 255.127.80 /CornflowerBlue 100.149.237 /Cornsilk 255.248.220
 /Crimson 220.20.60 /Cyan 0.255.255 /DarkBlue 0.0.139
 /DarkCyan 0.139.139 /DarkGoldenRod 184.134.11 /DarkGray 169.169.169
 /DarkGreen 0.100.0 /DarkKhaki 189.183.107 /DarkMagenta 139.0.139
 /DarkOliveGreen 85.107.47 /Darkorange 255.140.0 /DarkOrchid 153.50.204
 /DarkRed 139.0.0 /DarkSalmon 233.150.122 /DarkSeaGreen 143.188.143
 /DarkSlateBlue 72.61.139 /DarkSlateGray 47.79.79 /DarkTurquoise 0.206.209
 /DarkViolet 148.0.211 /DeepPink 255.20.147 /DeepSkyBlue 0.191.255
 /DimGray 105.105.105 /DodgerBlue 30.144.255 /Feldspar 209.146.117
 /FireBrick 178.34.34 /FloralWhite 255.250.240 /ForestGreen 34.139.34
 /Gainsboro 220.220.220 /GhostWhite 248.248.255 /Gold 255.215.0
 /GoldenRod 218.165.32 /GreenYellow 173.255.47 /HoneyDew 240.255.240
 /HotPink 255.105.180 /IndianRed 205.92.92 /Indigo 75.0.130
 /Ivory 255.255.240 /Khaki 240.230.140 /Lavender 230.230.250
 /LavenderBlush 255.240.245 /LawnGreen 124.252.0 /LemonChiffon 255.250.205
 /LightBlue 173.216.230 /LightCoral 240.128.128 /LightCyan 224.255.255
 /LightGoldenRodYellow 250.250.210 /LightGrey 211.211.211 /LightGreen 144.238.144
 /LightPink 255.182.193 /LightSalmon 255.160.122 /LightSeaGreen 32.178.170
 /LightSkyBlue 135.206.250 /LightSlateBlue 132.112.255 /LightSlateGray 119.136.153
 /LightSteelBlue 176.196.222 /LightYellow 255.255.224 /LimeGreen 50.205.50
 /Linen 250.240.230 /Magenta 255.0.255 /MediumAquaMarine 102.205.170
 /MediumBlue 0.0.205 /MediumOrchid 186.85.211 /MediumPurple 147.112.216
 /MediumSeaGreen 60.179.113 /MediumSlateBlue 123.104.238 /MediumSpringGreen 0.250.154
 /MediumTurquoise 72.209.204 /MediumVioletRed 199.21.133 /MidnightBlue 25.25.112
 /MintCream 245.255.250 /MistyRose 255.228.225 /Moccasin 255.228.181
 /NavajoWhite 255.222.173 /OldLace 253.245.230 /OliveDrab 107.142.35
 /OrangeRed 255.69.0 /Orchid 218.112.214 /PaleGoldenRod 238.232.170
 /PaleGreen 152.251.152 /PaleTurquoise 175.238.238 /PaleVioletRed 216.112.147
 /PapayaWhip 255.239.213 /PeachPuff 255.218.185 /Peru 205.133.63
 /Pink 255.192.203 /Plum 221.160.221 /PowderBlue 176.224.230
 /RosyBrown 188.143.143 /RoyalBlue 65.105.225 /SaddleBrown 139.69.19
 /Salmon 250.128.114 /SandyBrown 244.164.96 /SeaGreen 46.139.87
 /SeaShell 255.245.238 /Sienna 160.82.45 /SkyBlue 135.206.235
 /SlateBlue 106.90.205 /SlateGray 112.128.144 /Snow 255.250.250
 /SpringGreen 0.255.127 /SteelBlue 70.130.180 /Tan 210.180.140
 /Thistle 216.191.216 /Tomato 255.99.71 /Turquoise 64.224.208
 /Violet 238.130.238 /VioletRed 208.32.144 /Wheat 245.222.179
 /WhiteSmoke 245.245.245 /YellowGreen 154.205.50
]

〈The parse rules that generate the document〉 +≡

opts: [
 'opts set val block! (options: val) | (options: none)
]
options: none

〈The parse rules that generate the document〉 +≡

inline-level: [
 〈Inline level rules〉
]

〈The parse rules that generate the document〉 +≡

error: [here: skip (print ["error" copy/part trim/lines mold here 80])]
blevel: 1
ilevel: 0
bullets: [
 into [
  'item opts (
   flush-space
   new-para/margins/set-opts [width: width - 10] [5 + ilevel 0 10 + ilevel 0]
   emit compose [bullet (blevel) (cur-para/cur-font/size)]
  ) any inline-level (end-para emit-space 1 1 0)
 ]
 |
 into ['bullets (ilevel: ilevel + 10 blevel: blevel + 1) any bullets (blevel: blevel - 1 ilevel: ilevel - 10)]
 |
 into ['enum (blevel: blevel + 1 pre-enum/only) any enum-items (blevel: blevel - 1 post-enum/only)]
 |
 error
]
enum-items: [
 into [
  'item opts (
   start-block
   start-block
   emit [
    right padding 2
   ]
   new-para/set-opts [alignment: [right align]]
   option? [number:] [emit value]
   emit "."
   end-para
   end-block
   start-block
   new-para/set-opts [width: width - 10]
  ) any inline-level (end-para loop 2 [end-block])
 ]
 |
 into ['bullets (
  start-block
  emit [[right padding 2]]
  start-block
  new-para [width: width - 10]
 ) any bullets (end-para loop 2 [end-block])]
 |
 into ['enum (
  start-block
  emit [[right padding 2]]
  start-block
  new-para [width: width - 10]
  pre-enum/only
 ) any enum-items (post-enum/only end-para loop 2 [end-block])]
 |
 error
]
checks: [
 into [
  'check opts (
   new-para/margins/set-opts [width: width - 10] [5 0 10 0]
   option? [checked:] [val: value]
   flush-space
   emit compose [check (val) (cur-para/cur-font/fnode/name) (cur-para/cur-font/size)]
  ) any inline-level (end-para emit-space 1 1 0)
 ]
 |
 error
]
definitions: [
 ; one or more terms followed by one or more descriptions
 into [
  'term opts (
   loop 2 [start-block]
   emit [right padding 2]
   new-para/set-opts/font [alignment: [left align]] 'bold cur-para/cur-font/size
  ) any inline-level (end-para)
 ]
 any [
  into [
   'term opts (
    new-para/set-opts/font [alignment: [left align]] 'bold cur-para/cur-font/size
   ) any inline-level (end-para)
  ]
 ]
 into [
  'desc opts (
   end-block
   start-block
   new-para/set-opts [ ]
  ) any inline-level (end-para)
 ]
 any [into ['desc opts (new-para/set-opts [ ]) any inline-level (end-para)]]
 (loop 2 [end-block])
 |
 error
]
toc-headers: [
 into [
  'header1 opts (
   flush-space
   new-para/set-opts [ ]
   option? [number:] [emit value]
  ) any inline-level (end-para)
 ]
 |
 into [
  'header2 opts (
   flush-space
   new-para/set-opts/margins [ ] [10 0]
   option? [number:] [emit value]
  ) any inline-level (end-para)
 ]
 |
 into [
  'header3 opts (
   flush-space
   new-para/set-opts/margins [ ] [20 0]
   option? [number:] [emit value]
  ) any inline-level (end-para)
 ]
]

〈Inline level rules〉 ≡

;here: (print ["inline-level:" copy/part trim/lines mold here 80])
set val string! (emit val)
|
into [
 'bold (change-font 'bold cur-para/cur-font/size) any inline-level (reset-font)
 |
 'italic (change-font 'italic cur-para/cur-font/size) any inline-level (reset-font)
 |
 'strike any inline-level
 |
 'link opts (set-font-options) any inline-level (reset-font)
 |
 'alink opts (set-font-options) any inline-level (reset-font)
 |
 'font opts (set-font-options) any inline-level (reset-font)
 |
 'image opts (
  option? [src:] [
   if image? value: attempt [load value] [
    emit compose/deep [
     box (value/size/x / 5.334) (value/size/y / 5.334) 0 [
      image xbl ybl xtr - xbl ytr - ybl (value)
     ]
    ]
   ]
  ]
 )
 |
 'anchor opts (set-font-options) any inline-level (reset-font)
 |
 'command copy val [string! skip]
]
|
error

〈The parse rules that generate the document〉 +≡

make-table: func [table-options contents /local columns rows col rh ch w n cell] [
 columns: make block! 16
 rows: make block! 32
 col: 1 rh: ch: no
 parse contents [
  opt [
   into [
    'columns any [
     into [
      'column opts (
       option? [width:] [
        if col > length? columns [
         insert/dup tail columns none col - length? columns
        ]
        poke columns col max any [pick columns col 0] value / 5.334
       ]
       col: col + 1
      )
     ]
    ]
   ]
  ]
  any [
   into [
    'row opts (
     col: 1
     append/only rows make block! 16
    ) ['header (rh: yes) | (rh: no)]
    any [
     into [
      cell:
      'cell
      opts
      opt ['span pair!]
      ['header (ch: yes) | (ch: no)]
      (
       if col > length? columns [
        insert/dup tail columns none col - length? columns
       ]
       option? [width:] [
        poke columns col max any [pick columns col 0] value / 5.334
       ]
       insert/only insert tail last rows ch or rh cell
       col: col + 1
      )
      to end
     ]
     |
     error
    ]
   ]
   |
   error
  ]
 ]
 w: 0 n: 0
 foreach col columns [
  either col [
   w: w + col
  ] [
   n: n + 1
  ]
 ]
 if n > 0 [
  w: max 10 cur-para/width - w / n
  forall columns [
   if not columns/1 [columns/1: w]
   columns/1: columns/1 - 2
  ]
 ]
 flush-space
 emit reduce ['table columns]
 start-block
 emit [
  top padding 1 stretch 1 shrink 0.5
  bottom padding 1 stretch 1 shrink 0.5
  left padding 1
  right padding 1
 ]
 foreach row rows [
  col: 1 start-block
  foreach [header? cell] row [
   start-block
   parse cell [
    'cell opts opt ['span pair!] opt 'header (
     emit-cell-decor header?
     new-para/set-opts/font [
      width: pick columns col
      if header? [
       alignment: [center]
      ]
     ] either header? ['bold] ['self] cur-para/cur-font/size
     para-indent?: no
    )
    [
     some block-level
     |
     end (
      if find table-options [force-space:] [
       emit reduce ['vspace (cur-para/cur-font/size)]
      ]
     )
    ]
   ]
   end-para
   end-block
   col: col + 1
  ]
  end-block
  ;if foreach cell last output/1 [if cell <> [p] [break/return false] true] [
  ; remove back tail output/1
  ;]
 ]
 end-block
]
emit-cell-decor: func [header? /local bgcol olcol olstyle] [
 either options [
  if header? [bgcol: 157.182.255]
  foreach [word value] options [
   switch word [
    background: [bgcol: to-color value]
    outline-color: [olcol: to-color value]
    outline-style: [olstyle: value]
   ]
  ]
  if olcol [olstyle: any [olstyle 'solid]]
  if olstyle [olcol: any [olcol black]]
  either all [olstyle olstyle <> 'borderless] [
   olstyle: switch olstyle [
    solid [[edge width 0.2 edge dash solid]]
    dashed [[edge width 0.2 edge dash [3] 0]]
    dotted [[edge width 0.2 edge dash [0.5] 0]]
   ]
   emit compose/deep either bgcol [[
    decor [
     solid box edge (olcol) (olstyle) (bgcol) xbl ybl xtr - xbl ytr - ybl
    ]
   ]] [[
    decor [
     box (olcol) (replace/all copy olstyle 'edge 'line) xbl ybl xtr - xbl ytr - ybl
    ]
   ]]
  ] [
   if bgcol [
    emit compose/deep [
     decor [
      fill (bgcol) [box xbl ybl xtr - xbl ytr - ybl]
     ]
    ]
   ]
  ]
 ] [
  emit either header? [[
   decor [
    solid box 157.182.255 edge width 0.2 edge dash solid edge color black xbl ybl xtr - xbl ytr - ybl
   ]
  ]] [[
   decor [
    box line width 0.2 line dash solid color black xbl ybl xtr - xbl ytr - ybl
   ]
  ]]
 ]
]

〈The PDF template〉 ≡

check-chars: "o3"
template: [
 define-func 'bullet [level size] [
  box size * 0.4 size * 0.5 size * -0.1 compose [
   fill (pick [127.76.0 120.120.0] level) [box xbl + 0.1 ybl - 0.1 xtr - xbl ytr - ybl]
   fill (pick [255.153.0 240.240.0] level) [box xbl ybl xtr - xbl ytr - ybl]
  ] space size * -0.4 + 5
 ]
 define-func 'check [checked 'font size /local chinf1 chinf2] [
  font ZapfDingbats size
  (chinf1: pdfm/get-char-whd 'ZapfDingbats size check-chars/1 none)
  check-chars/1 space negate chinf1/width
  if checked [
   height 0 rise size / 7.05 space size / 21.15
   (chinf2: pdfm/get-char-whd 'ZapfDingbats size check-chars/2 none)
   check-chars/2 space size / -21.15 - chinf2/width
   height none rise 0
  ]
  space 5 font* font size
 ]
 define-func 'rounded-box-fill [xbl ybl xtr ytr] [
  fill [
   xtr - 3 ybl
   bezier xtr - 1.344 ybl xtr ybl + 1.344 xtr ybl + 3
   xtr ytr - 3
   bezier xtr ytr - 1.344 xtr - 1.344 ytr xtr - 3 ytr
   xbl + 3 ytr
   bezier xbl + 1.656 ytr xbl ytr - 1.344 xbl ytr - 3
   xbl ybl + 3
   bezier xbl ybl + 1.656 xbl + 1.656 ybl xbl + 3 ybl
   close
  ]
 ]
 text main out
 any [
  textbox 30 30 150 247 from main
 ]
]