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