extra/pdf/layout/layout.factor

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