extra/text-to-pdf/text-to-pdf.factor

   1 ! Copyright (C) 2010 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: assocs calendar combinators environment formatting
   5 grouping io io.files kernel make math math.ranges sequences
   6 splitting xml.entities ;
   7
   8 IN: text-to-pdf
   9
  10 <PRIVATE
  11
  12 : pdf-string ( str -- str' )
  13     H{
  14         { 0x08    "\\b"  }
  15         { 0x0c    "\\f"  }
  16         { CHAR: \n   "\\n"  }
  17         { CHAR: \r   "\\r"  }
  18         { CHAR: \t   "\\t"  }
  19         { CHAR: \\   "\\\\" }
  20         { CHAR: (    "\\("  }
  21         { CHAR: )    "\\)"  }
  22     } escape-string-by "(" ")" surround ;
  23
  24 : pdf-object ( str n -- str' )
  25     "%d 0 obj\n" sprintf "\nendobj" surround ;
  26
  27 : pdf-stream ( str -- str' )
  28     [ length 1 + "<<\n/Length %d\n>>" sprintf ]
  29     [ "\nstream\n" "\nendstream" surround ] bi append ;
  30
  31 : pdf-info ( -- str )
  32     [
  33         "<<" ,
  34         "/CreationDate D:" now "%Y%m%d%H%M%S" strftime append ,
  35         "/Producer (Factor)" ,
  36         "/Author " "USER" os-env "unknown" or pdf-string append ,
  37         "/Creator (created with Factor)" ,
  38         ">>" ,
  39     ] { } make join-lines ;
  40
  41 : pdf-catalog ( -- str )
  42     {
  43         "<<"
  44         "/Type /Catalog"
  45         "/Pages 4 0 R"
  46         ">>"
  47     } join-lines ;
  48
  49 : pdf-font ( -- str )
  50     {
  51         "<<"
  52         "/Type /Font"
  53         "/Subtype /Type1"
  54         "/BaseFont /Courier"
  55         ">>"
  56     } join-lines ;
  57
  58 : pdf-pages ( n -- str )
  59     [
  60         "<<" ,
  61         "/Type /Pages" ,
  62         "/MediaBox [ 0 0 612 792 ]" ,
  63         [ "/Count %d" sprintf , ]
  64         [
  65             5 swap 2 range boa
  66             [ "%d 0 R " sprintf ] map concat
  67             "/Kids [ " "]" surround ,
  68         ] bi
  69         ">>" ,
  70     ] { } make join-lines ;
  71
  72 : pdf-text ( lines -- str )
  73     [
  74         "BT" ,
  75         "54 738 Td" ,
  76         "/F1 10 Tf" ,
  77         "12 TL" ,
  78         [ pdf-string "'" append , ] each
  79         "ET" ,
  80     ] { } make join-lines pdf-stream ;
  81
  82 : pdf-page ( n -- page )
  83     [
  84         "<<" ,
  85         "/Type /Page" ,
  86         "/Parent 4 0 R" ,
  87         1 + "/Contents %d 0 R" sprintf ,
  88         "/Resources << /Font << /F1 3 0 R >> >>" ,
  89         ">>" ,
  90     ] { } make join-lines ;
  91
  92 : pdf-trailer ( objects -- str )
  93     [
  94         "xref" ,
  95         dup length 1 + "0 %d" sprintf ,
  96         "0000000000 65535 f" ,
  97         9 over [
  98             over "%010X 00000 n" sprintf , length 1 + +
  99         ] each drop
 100         "trailer" ,
 101         "<<" ,
 102         dup length 1 + "/Size %d" sprintf ,
 103         "/Info 1 0 R" ,
 104         "/Root 2 0 R" ,
 105         ">>" ,
 106         "startxref" ,
 107         [ length 1 + ] map-sum 9 + "%d" sprintf ,
 108         "%%EOF" ,
 109     ] { } make join-lines ;
 110
 111 : string>lines ( str -- lines )
 112     "\t" split "    " join split-lines
 113     [ [ " " ] when-empty ] map ;
 114
 115 : lines>pages ( lines -- pages )
 116     [ 84 <groups> ] map concat 57 <groups> ;
 117
 118 : pages>objects ( pages -- objects )
 119     [
 120         pdf-info ,
 121         pdf-catalog ,
 122         pdf-font ,
 123         dup length pdf-pages ,
 124         dup length 5 swap 2 range boa zip
 125         [ pdf-page , pdf-text , ] assoc-each
 126     ] { } make
 127     dup length [1..b] zip [ first2 pdf-object ] map ;
 128
 129 : objects>pdf ( objects -- str )
 130     [ join-lines "\n" append "%PDF-1.4\n" ]
 131     [ pdf-trailer ] bi surround ;
 132
 133 PRIVATE>
 134
 135 : text-to-pdf ( str -- str' )
 136     string>lines lines>pages pages>objects objects>pdf ;
 137
 138 : file-to-pdf ( path encoding -- )
 139     [ file-contents text-to-pdf ]
 140     [ [ ".pdf" append ] dip set-file-contents ] 2bi ;