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 math.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* string-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 M: text pdf-render
 121     [ style>> set-style ] keep
 122     [
 123         over x>> 0 > [
 124             2dup text-fits? [
 125                 over [ font>> ] [ avail-width ] bi visual-wrap
 126                 unclip [ "" concat-as ] dip
 127             ] [ over line-break f ] if
 128         ] [ f ] if
 129         [
 130             [ { } ] [ over [ font>> ] [ width ] bi visual-wrap ]
 131             if-empty
 132         ] dip [ prefix ] when*
 133         over avail-lines short cut
 134         [ draw-text ] [ "" concat-as ] bi*
 135     ] change-string dup string>> empty? [ drop f ] when ;
 136
 137 M: text pdf-width
 138     [ style>> set-style ] keep
 139     [ font>> ] [ string>> ] bi* string-lines
 140     [ dupd text-width ] map nip supremum ;
 141
 142
 143 TUPLE: hr width ;
 144
 145 C: <hr> hr
 146
 147 M: hr pdf-render
 148     [ f set-style ] dip
 149     [
 150         [ dup 0 > pick avail-lines 0 > and ] [
 151             over avail-width over min [ - ] keep [
 152                 [ over ] dip [ draw-line ] [ inc-x ] 2bi
 153             ] unless-zero dup 0 > [ over line-break ] when
 154         ] while
 155     ] change-width nip dup width>> 0 > [ drop f ] unless ;
 156
 157 M: hr pdf-width
 158     nip width>> ;
 159
 160
 161 TUPLE: br ;
 162
 163 C: <br> br
 164
 165 M: br pdf-render
 166     [ f set-style ] dip
 167     over avail-lines 0 > [ drop ?break f ] [ nip ] if ;
 168
 169 M: br pdf-width
 170     2drop 0 ;
 171
 172
 173 TUPLE: pb used? ;
 174
 175 : <pb> ( -- pb ) f pb boa ;
 176
 177 M: pb pdf-render
 178     dup used?>> [ f >>used? drop f ] [ t >>used? ] if nip ;
 179
 180 M: pb pdf-width
 181     2drop 0 ;
 182
 183
 184
 185 CONSTANT: table-cell-padding 5
 186
 187 TUPLE: table-cell contents width ;
 188
 189 : <table-cell> ( contents -- table-cell )
 190     f table-cell boa ;
 191
 192 M: table-cell pdf-render
 193     {
 194         [ width>> >>col-width 0 >>x drop ]
 195         [
 196             [ [ dupd pdf-render ] map nip ] change-contents
 197             dup contents>> [ ] any? [ drop f ] unless
 198         ]
 199         [
 200             width>> table-cell-padding +
 201             swap margin>> [ + ] change-left drop
 202         ]
 203     } 2cleave ;
 204
 205 TUPLE: table-row cells ;
 206
 207 C: <table-row> table-row
 208
 209 ! save y before rendering each cell
 210 ! set y to max y after all renders
 211
 212 M: table-row pdf-render
 213     {
 214         [ drop ?line-break ]
 215         [
 216             [let
 217                 over y>> :> start-y
 218                 over y>> :> max-y!
 219                 [
 220                     [
 221                         [ start-y >>y ] dip
 222                         dupd pdf-render
 223                         over y>> max-y max max-y!
 224                     ] map swap max-y >>y drop
 225                 ] change-cells
 226
 227                 dup cells>> [ ] any? [ drop f ] unless
 228             ]
 229         ]
 230         [ drop margin>> 54 >>left drop ]
 231         [
 232             drop dup width>> >>col-width
 233             [ ?line-break ] [ table-cell-padding inc-y ] bi
 234         ]
 235     } 2cleave ;
 236
 237 : col-widths ( canvas cells -- widths )
 238     [
 239         [
 240             contents>> [ 0 ] [
 241                 [ [ dupd pdf-width ] [ 0 ] if* ] map supremum
 242             ] if-empty
 243         ] [ 0 ] if*
 244     ] map nip ;
 245
 246 :: max-col-widths ( canvas rows -- widths )
 247     H{ } clone :> widths
 248     rows [
 249         cells>> canvas swap col-widths
 250         [ widths [ 0 or max ] change-at ] each-index
 251     ] each widths >alist sort-keys values
 252
 253     ! make last cell larger
 254     dup sum 400 swap [-] [ + ] curry dupd sequences.extras:change-last
 255
 256     ! size down each column
 257     dup sum dup 400 > [ 400 swap / [ * ] curry map ] [ drop ] if ;
 258
 259 : set-col-widths ( canvas rows -- )
 260     [ max-col-widths ] keep [
 261         dupd cells>> [
 262             [ swap >>width drop ] [ drop ] if*
 263         ] 2each
 264     ] each drop ;
 265
 266 TUPLE: table rows widths? ;
 267
 268 : <table> ( rows -- table )
 269     f table boa ;
 270
 271 M: table pdf-render
 272     {
 273         [
 274             dup widths?>> [ 2drop ] [
 275                 t >>widths? rows>> set-col-widths
 276             ] if
 277         ]
 278         [
 279             [
 280                 dup rows>> empty? [ t ] [
 281                     [ rows>> first dupd pdf-render ] keep swap
 282                 ] if
 283             ] [ [ rest ] change-rows ] until nip
 284             dup rows>> [ drop f ] [ drop ] if-empty
 285         ]
 286     } 2cleave ;
 287
 288 M: table pdf-width
 289     2drop 400 ; ! FIXME: hardcoded max-width
 290
 291
 292 : pdf-object ( str n -- str' )
 293     "%d 0 obj\n" sprintf "\nendobj" surround ;
 294
 295 : pdf-stream ( str -- str' )
 296     [ length 1 + "<<\n/Length %d\n>>" sprintf ]
 297     [ "\nstream\n" "\nendstream" surround ] bi append ;
 298
 299 : pdf-catalog ( -- str )
 300     {
 301         "<<"
 302         "/Type /Catalog"
 303         "/Pages 15 0 R"
 304         ">>"
 305     } "\n" join ;
 306
 307 : pdf-pages ( n -- str )
 308     [
 309         "<<" ,
 310         "/Type /Pages" ,
 311         "/MediaBox [ 0 0 612 792 ]" ,
 312         [ "/Count %d" sprintf , ]
 313         [
 314             16 swap 2 range boa
 315             [ "%d 0 R " sprintf ] map concat
 316             "/Kids [ " "]" surround ,
 317         ] bi
 318         ">>" ,
 319     ] { } make "\n" join ;
 320
 321 : pdf-page ( n -- page )
 322     [
 323         "<<" ,
 324         "/Type /Page" ,
 325         "/Parent 15 0 R" ,
 326         1 + "/Contents %d 0 R" sprintf ,
 327         "/Resources << /Font <<" ,
 328         "/F1 3 0 R /F2 4 0 R /F3 5 0 R" ,
 329         "/F4 6 0 R /F5 7 0 R /F6 8 0 R" ,
 330         "/F7 9 0 R /F8 10 0 R /F9 11 0 R" ,
 331         "/F10 12 0 R /F11 13 0 R /F12 14 0 R" ,
 332         ">> >>" ,
 333         ">>" ,
 334     ] { } make "\n" join ;
 335
 336 : pdf-trailer ( objects -- str )
 337     [
 338         "xref" ,
 339         dup length 1 + "0 %d" sprintf ,
 340         "0000000000 65535 f" ,
 341         9 over [
 342             over "%010X 00000 n" sprintf , length 1 + +
 343         ] each drop
 344         "trailer" ,
 345         "<<" ,
 346         dup length 1 + "/Size %d" sprintf ,
 347         "/Info 1 0 R" ,
 348         "/Root 2 0 R" ,
 349         ">>" ,
 350         "startxref" ,
 351         [ length 1 + ] map-sum 9 + "%d" sprintf ,
 352         "%%EOF" ,
 353     ] { } make "\n" join ;
 354
 355 SYMBOLS: pdf-producer pdf-author pdf-creator ;
 356
 357 TUPLE: pdf-info title timestamp producer author creator ;
 358
 359 : <pdf-info> ( -- pdf-info )
 360     pdf-info new
 361         now >>timestamp
 362         pdf-producer get >>producer
 363         pdf-author get >>author
 364         pdf-creator get >>creator ;
 365
 366 M: pdf-info pdf-value
 367     [
 368         "<<" print [
 369             [ timestamp>> [ "/CreationDate " write pdf-write nl ] when* ]
 370             [ producer>> [ "/Producer " write pdf-write nl ] when* ]
 371             [ author>> [ "/Author " write pdf-write nl ] when* ]
 372             [ title>> [ "/Title " write pdf-write nl ] when* ]
 373             [ creator>> [ "/Creator " write pdf-write nl ] when* ]
 374         ] cleave ">>" print
 375     ] with-string-writer ;
 376
 377
 378 TUPLE: pdf-ref object revision ;
 379
 380 C: <pdf-ref> pdf-ref
 381
 382 M: pdf-ref pdf-value
 383     [ object>> ] [ revision>> ] bi "%d %d R" sprintf ;
 384
 385
 386 TUPLE: pdf info pages fonts ;
 387
 388 : <pdf> ( -- pdf )
 389     pdf new
 390         <pdf-info> >>info
 391         V{ } clone >>pages
 392         V{ } clone >>fonts ;
 393
 394 :: pages>objects ( pdf -- objects )
 395     [
 396         pdf info>> pdf-value ,
 397         pdf-catalog ,
 398         { $ sans-serif-font $ serif-font $ monospace-font } {
 399             [ [ f >>bold? f >>italic? pdf-value , ] each ]
 400             [ [ t >>bold? f >>italic? pdf-value , ] each ]
 401             [ [ f >>bold? t >>italic? pdf-value , ] each ]
 402             [ [ t >>bold? t >>italic? pdf-value , ] each ]
 403         } cleave
 404         pdf pages>> length pdf-pages ,
 405         pdf pages>>
 406         dup length 16 swap 2 range boa zip
 407         [ pdf-page , , ] assoc-each
 408     ] { } make
 409     dup length [1,b] zip [ first2 pdf-object ] map ;
 410
 411 : objects>pdf ( objects -- str )
 412     [ "\n" join "\n" append "%PDF-1.4\n" ]
 413     [ pdf-trailer ] bi surround ;
 414
 415 ! Rename to pdf>string, have it take a <pdf> object?
 416
 417 : pdf>string ( seq -- pdf )
 418     <pdf> swap pdf-layout  [
 419         stream>> pdf-stream over pages>> push
 420     ] each pages>objects objects>pdf ;
 421
 422 : write-pdf ( seq -- )
 423     pdf>string write ;