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