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