extra/pdf/layout/layout.factor

   1 ! Copyright (C) 2011-2012 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: accessors assocs calendar combinators environment fonts
   4 formatting fry io io.streams.string kernel literals locals make
   5 math math.order ranges namespaces pdf.canvas pdf.values
   6 pdf.wrap sequences sequences.extras sorting splitting ui.text
   7 xml.entities ;
   8 FROM: pdf.canvas => draw-text ;
   9
  10 IN: pdf.layout
  11
  12 ! TODO: inset, image
  13 ! Insets:
  14 ! before:
  15 !   y += inset-height
  16 !   margin-left, margin-right += inset-width
  17 ! after:
  18 !   y += inset-height
  19 !   margin-left, margin-right -= inset-width
  20
  21 ! TUPLE: pre < p
  22 ! C: <pre> pre
  23
  24 ! TUPLE: spacer width height ;
  25 ! C: <spacer> spacer
  26
  27 ! TUPLE: image < span ;
  28 ! C: <image> image
  29
  30 ! Outlines (add to catalog):
  31 !   /Outlines 3 0 R
  32 !   /PageMode /UseOutlines
  33 ! Table of Contents
  34 ! Thumbnails
  35 ! Annotations
  36 ! Images
  37
  38 ! FIXME: spacing oddities if run multiple times
  39 ! FIXME: make sure highlights text "in order"
  40 ! FIXME: don't modify layout objects in pdf-render
  41 ! FIXME: make sure unicode "works"
  42 ! FIXME: only set style differences to reduce size?
  43 ! FIXME: gadget. to take a "screenshot" into a pdf?
  44 ! FIXME: compress each pdf object to reduce file size?
  45
  46
  47 GENERIC: pdf-render ( canvas obj -- remain/f )
  48
  49 M: f pdf-render 2drop f ;
  50
  51 GENERIC: pdf-width ( canvas obj -- n )
  52
  53 <PRIVATE
  54
  55 : (pdf-layout) ( page obj -- page )
  56     [ dup ] [
  57         dupd [ pdf-render ] with-string-writer
  58         '[ _ append ] [ change-stream ] curry dip
  59         [ [ , <canvas> ] when ] keep
  60     ] while drop ;
  61
  62 PRIVATE>
  63
  64 : pdf-layout ( seq -- pages )
  65     [ <canvas> ] dip [
  66         [ (pdf-layout) ] each
  67         dup stream>> empty? [ drop ] [ , ] if
  68     ] { } make ;
  69
  70
  71 TUPLE: div items style ;
  72
  73 C: <div> div
  74
  75 M: div pdf-render
  76     [ style>> set-style ] keep
  77     swap '[ _ pdf-render drop ] each f ;
  78
  79 M: div pdf-width
  80     [ style>> set-style ] keep
  81     items>> [ dupd pdf-width ] map nip supremum ;
  82
  83
  84 <PRIVATE
  85
  86 : convert-string ( str -- str' )
  87     {
  88         { CHAR: “    "\""   }
  89         { CHAR: ”    "\""   }
  90     } escape-string-by [ 256 < ] filter ;
  91
  92 PRIVATE>
  93
  94
  95 TUPLE: p string style ;
  96
  97 : <p> ( string style -- p )
  98     [ convert-string ] dip p boa ;
  99
 100 M: p pdf-render
 101     [ style>> set-style ] keep
 102     [
 103         over ?line-break
 104         over [ font>> ] [ avail-width ] bi visual-wrap
 105         over avail-lines short cut
 106         [ draw-text ] [ "" concat-as ] bi*
 107     ] change-string dup string>> empty? [ drop f ] when ;
 108
 109 M: p pdf-width
 110     [ style>> set-style ] keep
 111     [ font>> ] [ string>> ] bi* split-lines
 112     [ dupd text-width ] map nip supremum ;
 113
 114
 115 TUPLE: text string style ;
 116
 117 : <text> ( string style -- text )
 118     [ convert-string ] dip text boa ;
 119
 120 ! FIXME: need to make links clickable, render text first, draw
 121 ! box over text that is "link"
 122
 123 ! https://www.w3.org/WAI/WCAG21/Techniques/pdf/PDF11.html
 124
 125 M: text pdf-render
 126     [ style>> set-style ] keep
 127     [
 128         over x>> 0 > [
 129             2dup text-fits? [
 130                 over [ font>> ] [ avail-width ] bi visual-wrap
 131                 unclip [ "" concat-as ] dip
 132             ] [ over line-break f ] if
 133         ] [ f ] if
 134         [
 135             [ { } ] [ over [ font>> ] [ width ] bi visual-wrap ]
 136             if-empty
 137         ] dip [ prefix ] when*
 138         over avail-lines short cut
 139         [ draw-text ] [ "" concat-as ] bi*
 140     ] change-string dup string>> empty? [ drop f ] when ;
 141
 142 M: text pdf-width
 143     [ style>> set-style ] keep
 144     [ font>> ] [ string>> ] bi* split-lines
 145     [ dupd text-width ] map nip supremum ;
 146
 147
 148 TUPLE: hr width ;
 149
 150 C: <hr> hr
 151
 152 M: hr pdf-render
 153     [ f set-style ] dip
 154     [
 155         [ dup 0 > pick avail-lines 0 > and ] [
 156             over avail-width over min [ - ] keep [
 157                 overd [ draw-line ] [ inc-x ] 2bi
 158             ] unless-zero dup 0 > [ over line-break ] when
 159         ] while
 160     ] change-width nip dup width>> 0 > [ drop f ] unless ;
 161
 162 M: hr pdf-width
 163     nip width>> ;
 164
 165
 166 TUPLE: br ;
 167
 168 C: <br> br
 169
 170 M: br pdf-render
 171     [ f set-style ] dip
 172     over avail-lines 0 > [ drop ?break f ] [ nip ] if ;
 173
 174 M: br pdf-width
 175     2drop 0 ;
 176
 177
 178 TUPLE: pb used? ;
 179
 180 : <pb> ( -- pb ) f pb boa ;
 181
 182 M: pb pdf-render
 183     dup used?>> [ f >>used? drop f ] [ t >>used? ] if nip ;
 184
 185 M: pb pdf-width
 186     2drop 0 ;
 187
 188
 189
 190 CONSTANT: table-cell-padding 5
 191
 192 TUPLE: table-cell contents width ;
 193
 194 : <table-cell> ( contents -- table-cell )
 195     f table-cell boa ;
 196
 197 M: table-cell pdf-render
 198     {
 199         [ width>> >>col-width 0 >>x drop ]
 200         [
 201             [ [ dupd pdf-render ] map nip ] change-contents
 202             dup contents>> [ ] any? [ drop f ] unless
 203         ]
 204         [
 205             width>> table-cell-padding +
 206             swap margin>> [ + ] change-left drop
 207         ]
 208     } 2cleave ;
 209
 210 TUPLE: table-row cells ;
 211
 212 C: <table-row> table-row
 213
 214 ! save y before rendering each cell
 215 ! set y to max y after all renders
 216
 217 M: table-row pdf-render
 218     {
 219         [ drop ?line-break ]
 220         [
 221             [let
 222                 over y>> :> start-y
 223                 over y>> :> max-y!
 224                 [
 225                     [
 226                         [ start-y >>y ] dip
 227                         dupd pdf-render
 228                         over y>> max-y max max-y!
 229                     ] map swap max-y >>y drop
 230                 ] change-cells
 231
 232                 dup cells>> [ ] any? [ drop f ] unless
 233             ]
 234         ]
 235         [ drop margin>> 54 >>left drop ]
 236         [
 237             drop dup width>> >>col-width
 238             [ ?line-break ] [ table-cell-padding inc-y ] bi
 239         ]
 240     } 2cleave ;
 241
 242 : col-widths ( canvas cells -- widths )
 243     [
 244         [
 245             contents>> [ 0 ] [
 246                 [ [ dupd pdf-width ] [ 0 ] if* ] map supremum
 247             ] if-empty
 248         ] [ 0 ] if*
 249     ] map nip ;
 250
 251 :: max-col-widths ( canvas rows -- widths )
 252     H{ } clone :> widths
 253     rows [
 254         cells>> canvas swap col-widths
 255         [ widths [ 0 or max ] change-at ] each-index
 256     ] each widths >alist sort-keys values
 257
 258     dup sum dup 450 > [
 259
 260         over first 150 < [
 261             ! special-case small first column
 262             drop dup unclip-slice over sum swap
 263             450 swap - swap / [ * ] curry map! drop
 264         ] [
 265             ! size down all columns
 266             450 swap / [ * ] curry map
 267         ] if
 268
 269     ] [
 270         ! make last cell larger
 271         450 swap [-] [ + ] curry dupd
 272         sequences.extras:change-last
 273     ] if ;
 274
 275 : set-col-widths ( canvas rows -- )
 276     [ max-col-widths ] keep [
 277         dupd cells>> [
 278             [ swap >>width drop ] [ drop ] if*
 279         ] 2each
 280     ] each drop ;
 281
 282 TUPLE: table rows widths? ;
 283
 284 : <table> ( rows -- table )
 285     f table boa ;
 286
 287 M: table pdf-render
 288     {
 289         [
 290             dup widths?>> [ 2drop ] [
 291                 t >>widths? rows>> set-col-widths
 292             ] if
 293         ]
 294         [
 295             [
 296                 dup rows>> empty? [ t ] [
 297                     [ rows>> first dupd pdf-render ] keep swap
 298                 ] if
 299             ] [ [ rest ] change-rows ] until nip
 300             dup rows>> [ drop f ] [ drop ] if-empty
 301         ]
 302     } 2cleave ;
 303
 304 M: table pdf-width
 305     2drop 450 ; ! FIXME: hardcoded max-width
 306
 307
 308 : pdf-object ( str n -- str' )
 309     "%d 0 obj\n" sprintf "\nendobj" surround ;
 310
 311 : pdf-stream ( str -- str' )
 312     [ length 1 + "<<\n/Length %d\n>>" sprintf ]
 313     [ "\nstream\n" "\nendstream" surround ] bi append ;
 314
 315 : pdf-catalog ( -- str )
 316     {
 317         "<<"
 318         "/Type /Catalog"
 319         "/Pages 15 0 R"
 320         ">>"
 321     } join-lines ;
 322
 323 : pdf-pages ( n -- str )
 324     [
 325         "<<" ,
 326         "/Type /Pages" ,
 327         "/MediaBox [ 0 0 612 792 ]" ,
 328         [ "/Count %d" sprintf , ]
 329         [
 330             16 swap 2 range boa
 331             [ "%d 0 R " sprintf ] map concat
 332             "/Kids [ " "]" surround ,
 333         ] bi
 334         ">>" ,
 335     ] { } make join-lines ;
 336
 337 : pdf-page ( n -- page )
 338     [
 339         "<<" ,
 340         "/Type /Page" ,
 341         "/Parent 15 0 R" ,
 342         1 + "/Contents %d 0 R" sprintf ,
 343         "/Resources << /Font <<" ,
 344         "/F1 3 0 R /F2 4 0 R /F3 5 0 R" ,
 345         "/F4 6 0 R /F5 7 0 R /F6 8 0 R" ,
 346         "/F7 9 0 R /F8 10 0 R /F9 11 0 R" ,
 347         "/F10 12 0 R /F11 13 0 R /F12 14 0 R" ,
 348         ">> >>" ,
 349         ">>" ,
 350     ] { } make join-lines ;
 351
 352 : pdf-trailer ( objects -- str )
 353     [
 354         "xref" ,
 355         dup length 1 + "0 %d" sprintf ,
 356         "0000000000 65535 f" ,
 357         9 over [
 358             over "%010X 00000 n" sprintf , length 1 + +
 359         ] each drop
 360         "trailer" ,
 361         "<<" ,
 362         dup length 1 + "/Size %d" sprintf ,
 363         "/Info 1 0 R" ,
 364         "/Root 2 0 R" ,
 365         ">>" ,
 366         "startxref" ,
 367         [ length 1 + ] map-sum 9 + "%d" sprintf ,
 368         "%%EOF" ,
 369     ] { } make join-lines ;
 370
 371 SYMBOLS: pdf-producer pdf-author pdf-creator ;
 372
 373 TUPLE: pdf-info title timestamp producer author creator ;
 374
 375 : <pdf-info> ( -- pdf-info )
 376     pdf-info new
 377         now >>timestamp
 378         pdf-producer get >>producer
 379         pdf-author get >>author
 380         pdf-creator get >>creator ;
 381
 382 M: pdf-info pdf-value
 383     [
 384         "<<" print [
 385             [ timestamp>> [ "/CreationDate " write pdf-write nl ] when* ]
 386             [ producer>> [ "/Producer " write pdf-write nl ] when* ]
 387             [ author>> [ "/Author " write pdf-write nl ] when* ]
 388             [ title>> [ "/Title " write pdf-write nl ] when* ]
 389             [ creator>> [ "/Creator " write pdf-write nl ] when* ]
 390         ] cleave ">>" print
 391     ] with-string-writer ;
 392
 393
 394 TUPLE: pdf-ref object revision ;
 395
 396 C: <pdf-ref> pdf-ref
 397
 398 M: pdf-ref pdf-value
 399     [ object>> ] [ revision>> ] bi "%d %d R" sprintf ;
 400
 401
 402 TUPLE: pdf info pages fonts ;
 403
 404 : <pdf> ( -- pdf )
 405     pdf new
 406         <pdf-info> >>info
 407         V{ } clone >>pages
 408         V{ } clone >>fonts ;
 409
 410 :: pages>objects ( pdf -- objects )
 411     [
 412         pdf info>> pdf-value ,
 413         pdf-catalog ,
 414         { $ sans-serif-font $ serif-font $ monospace-font } {
 415             [ [ f >>bold? f >>italic? pdf-value , ] each ]
 416             [ [ t >>bold? f >>italic? pdf-value , ] each ]
 417             [ [ f >>bold? t >>italic? pdf-value , ] each ]
 418             [ [ t >>bold? t >>italic? pdf-value , ] each ]
 419         } cleave
 420         pdf pages>> length pdf-pages ,
 421         pdf pages>>
 422         dup length 16 swap 2 range boa zip
 423         [ pdf-page , , ] assoc-each
 424     ] { } make
 425     dup length [1..b] zip [ first2 pdf-object ] map ;
 426
 427 : objects>pdf ( objects -- str )
 428     [ join-lines "\n" append "%PDF-1.4\n" ]
 429     [ pdf-trailer ] bi surround ;
 430
 431 ! Rename to pdf>string, have it take a <pdf> object?
 432
 433 : pdf>string ( seq -- pdf )
 434     <pdf> swap pdf-layout  [
 435         stream>> pdf-stream over pages>> push
 436     ] each pages>objects objects>pdf ;
 437
 438 : write-pdf ( seq -- )
 439     pdf>string write ;