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