Hi all,

I have attached a prototype pdf generator pdf.l.  It can be used to
generate pdf files directly without going through @lib/ps.l.  It is
still experimental version.  It can be used as follows:

(afmDir "fonts") # load & parse font metric files

(pdf "/tmp/A.pdf" # generate sample pdf file
   (pdfWr (pdfO 1 0 (pdfM '/Type '/Page
                          '/Parent '(5 0 R)
                          '/Resources '(3 0 R)
                          '/Contents '(2 0 R) ) ) )
   (pdfWr (pdfO 2 0 (pdfS NIL "BT
  /F1 24 Tf
  1 0 0 1 260 254 Tm
  (Hello World)Tj
  ET
  0 0 1 rg
 4 0 0 4 315 204 cm
    0 5.5 m
  -4 -5.5 l
    6 1     l
  -6 1      l
    4 -5.5 l
  f" ) ) )
   (pdfWr (pdfO 3 0 (pdfM '/ProcSet (pdfV '/PDF '/Text)
                          '/Font (pdfM '/F1 '(4 0 R)) ) ) )
   (pdfWr (pdfO 4 0 (pdfM '/Type '/Font
                          '/Subtype '/Type1
                          '/Name '/F1
                          '/BaseFont '/Helvetica ) ) )
   (pdfWr (pdfO 5 0 (pdfM '/Type '/Pages
                          '/Kids (pdfV '(1 0 R))
                          '/Count 1
                          '/MediaBox (pdfV 0 0 612 446) ) ) )
   (pdfWr (pdfO 6 0 (pdfM '/Type '/Catalog
                          '/Pages '(5 0 R) ) ) )
   (setq *PdfX (pdfM '/Root '(6 0 R) '/Size 6)) )

(pdfUpdate "/tmp/A.pdf" "/tmp/A3.pdf" # incremental update
   (pdfWr (pdfO 7 0 (pdfS NIL
      (pdfDraw
         (q (BT (Tf "/F1" 24)
                (Tm 1 0 0 1 160 154)
                (Tj "H£ll0 W€rld Ťitěrňoučká řeřiščička")
                (let S "hello Minime"
                   (pdfDraw
                      (Tm 1 0 0 1 160 174)
                      (Tj S 'left)
                      (Tm 1 0 0 1 160 194)
                      (Tj S 'center)
                      (Tm 1 0 0 1 160 214)
                      (Tj S 'right) ) ) ) ) ) )))
   (pdfWr (pdfO 1 0 (pdfM '/Type '/Page
                          '/Parent '(5 0 R)
                          '/Resources '(3 0 R)
                          '/Contents (pdfV '(7 0 R 2 0 R)) ) ) )
   (setq *PdfX (pdfM '/Prev *Fpos)) ) #'/Root '(6 0 R)

Unicode does not work and incremental updates do not generate correct
updated xref section.  Also, it expects a "fonts/" directory with afm
files and glyphs:

   Courier.afm
   Courier-Bold.afm
   Courier-BoldOblique.afm
   Courier-Oblique.afm
   Helvetica.afm
   Helvetica-Bold.afm
   Helvetica-BoldOblique.afm
   Helvetica-Oblique.afm
   Symbol.afm
   Times-Bold.afm
   Times-BoldItalic.afm
   Times-Italic.afm
   Times-Roman.afm
   ZapfDingbats.afm
   glyphlist.txt


Alex, I need to call 'lseek' function.  How could I get hold of the
current input and output file descriptors?  I want to feed it to the
following function 'fpos':

(gcc "pdf" NIL 'fpos)

#include <sys/types.h>
#include <unistd.h>

any fpos(any ex) {
   int fd = evCnt(ex, cdr(ex));
   off_t offset = evCnt(ex, cddr(ex));
   int whence = evCnt(ex, cdddr(ex));
   whence = whence == 1 ? SEEK_CUR : (whence == 2 ? SEEK_END : SEEK_SET);
   off_t z = lseek(fd, offset, whence);
   return boxCnt(z);
}
/**/

and use it something like:

(in "/tmp/file"
   (fpos (ifd) 123) # set current position to 123rd byte from start of the file
   (fpos (ifd) 0 1) # get current position
..

and similar for 'out'.

Thank you,

Tomas

# requires iconv for utf-16be conversion

# *Glyph *Codepoint
# *Afm
# *Fpos *PdfO *PdfOa *PdfOut *PdfX *PdfDraw *Fnm *Fsz

### glyphs

(in "fonts/glyphlist.txt" #(appDir "fonts/glyphlist.txt")
   (use (L N)
      (while (setq L (line))
         (unless (= '"#" (car L))
            (setq L (split L '";") N (pack (car L)))
            (for C (mapcar '((X) (char (hex (pack X)))) (split (cadr L) " "))
               (if (idx '*Glyph C)
                  (push (car @) N)
                  (set C (list N))
                  (idx '*Glyph C T) )
               (if (idx '*Codepoint N)
                  (push (car @) C)
                  (set N (list C))
                  (idx '*Codepoint N T) ) ) ) ) ) )

(de glyph (C)
   (val (car (idx '*Glyph C))) )

(de codepoint (C)
   (val (car (idx '*Codepoint C))) )

(====)

### afm

(class +Afm)
# nm c kpx

(dm charWidth> (C)
   (setq C (pack (if (num? C) C (char C))))
   (format (cadr (assoc "WX" (find '((X) (= C (cadr (assoc "C" X)))) (: c))))) )

(dm charGlyph> (C)
   (setq C (pack (if (num? C) C (char C))))
   (cadr (assoc "N" (find '((X) (= C (cadr (assoc "C" X)))) (: c)))) )

(dm glyphChar> (G)
   (format (cadr (assoc "C" (find '((X) (= G (cadr (assoc "N" X)))) (: c))))) )

(dm strWidth> (S) # TODO kerning?
   (apply + (mapcar '((C) (charWidth> This C)) (chop (pack S)))) )

(de afmFile (F)
   (in F
      (let (This (new '(+Afm)) C NIL K NIL P NIL L NIL @A NIL)
         (while (setq L (line))
            (cond
               ((match '("F" "o" "n" "t" "N" "a" "m" "e" " " @A) L)
                  (=: nm (pack @A)) )
               ((head '("K" "P" "X" " ") L)
                  (push 'K (mapcar pack (split L " "))) )
               ((= ";" (last L))
                  (let? X (clip (split (mapcar pack (split L " ")) ";"))
                     (when (gt0 (format (cadr (assoc "C" X))))
                        (push 'C X) ) ) ) ) )
         (=: c C)
         (=: kpx K)
         This ) ) )
#                ((match '("C" "o" "m" "m" "e" "n" "t" " " @A) L)
#                   (push 'P (list "Comment" (pack @A))) )
#                (T
#                   (push 'P (mapcar pack (split L " "))) ) ) )
#         (=: p P)

(de afmDir (D)
   (for F (dir D)
      (when (tail '("." "a" "f" "m") (chop F))
         (let? This (afmFile (pack D "/" F))
            (push '*Afm (cons (: nm) This)) ) ) ) )

(de strWidth (Fnm S)
   (when (cdr (assoc Fnm *Afm))
      (strWidth> @ S) ) )

### pdf

(de pdfOut (App . Prg)
   (if (and App (info *PdfOut))
      (let *Fpos (car @)
         (out (pack "+" *PdfOut)
            (run Prg 1 '(*Fpos)) ) )
      (let *Fpos 0
         (out *PdfOut
            (run Prg 1 '(*Fpos)) ) ) ) )

(de pdfWrL (L)
   (let S NIL
      (while L
         (and S (prin " "))
         (on S)
         (pdfWr (pop 'L)) ) )
   L )

(de pdfWr (Any)
   (cond
      ((isa '+pdf Any) (wr> Any))
      ((pair Any) (pdfWrL Any))
      (T (prin Any)) )
   Any )

(class +pdf)
   
(class +PdfT +pdf) # text
# val

(dm T (Val Utf)
   (=: val Val)
   (=: utf Utf) )

(de pdfT (Val Utf)
   (new '(+PdfT) Val Utf) )

(dm wr> ()
   (prin "<")
   (when (: utf) # utf-16be marker
      (prin "FEFF") )
   (let (I (tmp "pdf.tmp") O (if (: utf) (tmp "pdf.utf") I))
      (out I
         (prin (: val)) )
      (when (: utf)
         (call "iconv" "-f" "utf-8" "-t" "utf-16be" I "-o" O) )
      (in O
         (use B
            (while (setq B (rd 1))
               (prin (when (< B 16) "0") (hex B)) ) ) ) )
   (prin ">") )

(class +PdfM +pdf) # map
# val

(dm T (Val)
   (=: val Val) )

(de pdfM @
   (new '(+PdfM) (rest)) )

(dm wr> ()
   (prin "<<")
   (pdfWrL (: val))
   (prin ">>") )

(class +PdfV +pdf) # vector
# val

(dm T (Val)
   (=: val Val) )

(de pdfV @
   (new '(+PdfV) (rest)) )

(dm wr> ()
   (prin "[")
   (pdfWrL (: val))
   (prin "]") )

(class +PdfS +pdf) # stream
# map str

(dm T (Map Str)
   (=: map Map)
   (=: str Str) )

(de pdfS (Map Str)
   (new '(+PdfS) Map Str) )

(dm wr> ()
   (let F (tmp "pdf.tmp")
      (out F
         (pdfWr (: str)) )
      (let N (car (info F))
         (if (: map val)
            (push @ '/Length N)
            (=: map (pdfM '/Length N)) ) )
      (pdfWr (: map))
      (prinl)
      (prinl "stream")
      (in F
         (echo) )
      (prinl)
      (prinl "endstream") ) )

(class +PdfO +pdf) # object
# nr ver val

(dm T (Nr Ver Val)
   (=: nr (if (=T Nr) (inc '*PdfOa) Nr))
   (=: ver Ver)
   (=: val Val) )

(de pdfO (Nr Ver Val)
   (new '(+PdfO) Nr Ver Val) )

(dm wr> ()
   (pdfOut T
      (push '*PdfO (cons (: nr) *Fpos))
      (pdfWr (: nr))
      (prin " ")
      (pdfWr (: ver))
      (prinl " obj")
      (pdfWr (: val))
      (prinl)
      (prinl "endobj") ) )

(class +PdfX +pdf) # xref
# map

(dm T (Map)
   (=: map Map) )

(de pdfX (Map)
   (new '(+PdfX) Map) )

(dm wrG> (I L)
   (pdfWr I)
   (prinl " " (length L))
   (for X L
      (prinl (pad 10 (car X)) " " (pad 5 (cadr X)) " " (caddr X)) ) )

(dm wr> ()
   (pdfOut T
      (prinl "xref")
      (let (L (sort *PdfO)
            I 0 J I G (list (list 0 65535 "f")) )
         (while L
            (let (X (pop 'L) N (car X) P (cdr X))
               (unless (<= N (inc 'J))
                  (wrG> This I (flip G))
                  (setq I N J I G NIL) )
               (push 'G (list P 0 "n")) ) )
         (wrG> This I (flip G)) )
      (when (: map)
         (prinl "trailer")
         (pdfWr @)
         (prinl) )
      (prinl "startxref")
      (prinl *Fpos) ) )

(de pdf (*PdfOut . Prg)
   (let (*Fpos 0 *PdfO NIL *PdfOa 0 *PdfX NIL)
      (pdfOut NIL
         (prinl "%PDF-1.2") # TODO use newer version?
         (prinl "%" (char 130) (char 131) (char 132) (char 133)) ) # bin marker
      (run Prg)
      (pdfOut T
         (pdfWr (pdfX *PdfX))
         (prinl "%%EOF") ) ) )

(de pdfUpdate (I *PdfOut . Prg)
   (when (info I)
      (let (*Fpos (car @) *PdfO NIL *PdfOa 0 *PdfX NIL)
         (out *PdfOut (in I (echo)))
         (run Prg)
         (pdfOut T
            (pdfWr (pdfX *PdfX)) # TODO updated xref /Prev calc etc.
            (prinl "%%EOF") ) ) ) )

(de pdfDraw Prg # TODO more drawing functions
   (if *PdfDraw
      (run Prg)
      (let (*PdfDraw T
            *X 0
            *Y 0
            *Fnm *Fnm
            *Fsz *Fsz
            q '(Prg (link 'q) (run Prg) (link 'Q))
            BT '(Prg (link 'BT) (run Prg) (link ET))
            Tf '((Fnm Fsz) (link (setq *Fnm Fnm) (setq *Fsz Fsz) 'Tf))
            Tm '((A B C D X Y) (link A B C D (setq *X X) (setq *Y Y) 'Tm))
            Tj '((Str Align)
                  (case Align
                     # TODO /Font => /BaseFont lookup real name for afm:-(
                     (center
                        (let (*X *X W (strWidth "Helvetica" Str))
                           (pdfDraw (Tm 1 0 0 1 (- *X (*/ W *Fsz 2000)) *Y))
                           (link (pdfT Str) 'Tj)) )
                     (right
                        (let (*X *X W (strWidth "Helvetica" Str))
                           (pdfDraw (Tm 1 0 0 1 (- *X (*/ W *Fsz 1000)) *Y))
                           (link (pdfT Str) 'Tj)) )
                     (T (link (pdfT Str) 'Tj)) ) ) )
         (make
            (run Prg) ) ) ) )

Reply via email to