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]
  ) <