scm/pdf.scm

   1 ;;; pdf.scm -- implement Scheme output routines for PDF.
   2 ;;;
   3 ;;;  source file of the GNU LilyPond music typesetter
   4 ;;;
   5 ;;; (c) 2001 Stephen Peters <portnoy@portnoy.org>
   6
   7 ; currently no font commands; this is a helper for pdftex.scm.
   8
   9 (define (pdf-scm action-name)
  10   ; simple commands to store and update currentpoint.  This makes the
  11   ; other procedures simple rewrites of the PostScript code.
  12   (define currentpoint (cons 0 0))
  13   (define (showcp)
  14     (string-append (ly-number->string (car currentpoint)) " "
  15                    (ly-number->string (cdr currentpoint)) " "))
  16   (define (moveto x y)
  17     (set! currentpoint (cons x y))
  18     (string-append (showcp) "m "))
  19   (define (moveto-pair pair)
  20     (moveto (car pair) (cdr pair)))
  21   (define (rmoveto x y)
  22     (moveto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
  23   (define (lineto x y)
  24     (set! currentpoint (cons x y))
  25     (string-append (showcp) "l "))
  26   (define (lineto-pair pair)
  27     (lineto (car pair) (cdr pair)))
  28   (define (rlineto x y)
  29     (lineto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
  30   (define (curveto x1 y1 x2 y2 x y)
  31     (set! currentpoint (cons x y))
  32     (string-append (ly-number->string x1) (ly-number->string y1)
  33                    (ly-number->string x2) (ly-number->string y2)
  34                    (ly-number->string x) (ly-number->string y) "c "))
  35   (define (curveto-pairs pt1 pt2 pt)
  36     (curveto (car pt1) (cdr pt1) (car pt2) (cdr pt2) (car pt) (cdr pt)))
  37   (define (closefill) "h f ")
  38   (define (closestroke) "S ")
  39   (define (setlinewidth w) (string-append (ly-number->string w) "w "))
  40   (define (setgray g) (string-append (ly-number->string g) "g "))
  41   (define (setlineparams) "1 j 1 J ")
  42
  43   (define (beam width slope thick)
  44     (let ((ht (* slope width)))
  45       (string-append (moveto 0 (- (/ thick 2)))
  46                      (rlineto width ht)
  47                      (rlineto 0 thick)
  48                      (lineto 0 (/ thick 2))
  49                      (closefill))))
  50
  51   (define (comment s)
  52     (string-append "% " s "\n"))
  53
  54   (define (brack-traject pair ds alpha)
  55     (let ((alpha-rad (* alpha (/ 3.141592654 180))))
  56       (cons (+ (car pair) (* (cos alpha-rad) ds))
  57             (+ (cdr pair) (* (sin alpha-rad) ds)))))
  58
  59   (define (bracket arch_angle arch_width arch_height height arch_thick thick)
  60     (let* ((halfht (+ (/ height 2) thick))
  61            (farpt (cons (+ thick arch_height)
  62                         (+ (- halfht arch_thick) arch_width)))
  63            (halfbrack
  64             (string-append (moveto 0 0)
  65                            (lineto thick 0)
  66                            (lineto thick (- halfht arch_thick))
  67                            (curveto-pairs
  68                             (brack-traject (cons thick
  69                                                  (- halfht arch_thick))
  70                                            (* 0.4 arch_height) 0)
  71                             (brack-traject farpt
  72                                            (* -0.25 arch_height)
  73                                            arch_angle)
  74                             farpt)
  75                            (curveto-pairs
  76                             (brack-traject farpt
  77                                            (* -0.15 arch_height)
  78                                            arch_angle)
  79                             (brack-traject (cons (/ thick 2) halfht)
  80                                            (/ arch_height 2) 0)
  81                             (cons 0 halfht))
  82                            (lineto 0 0)
  83                            (closefill))))
  84       (string-append (setlinewidth (/ thick 2))
  85                      (setlineparams)
  86                      "q 1 0 0 -1 0 0 cm " ; flip coords
  87                      halfbrack
  88                      "Q " ; grestore
  89                      halfbrack)))
  90
  91   (define (char i)
  92     (invoke-char " show" i))
  93
  94   (define (hairpin thick width starth endh )
  95     (string-append (setlinewidth thick)
  96                    (moveto 0 starth)
  97                    (lineto width endh)
  98                    (moveto 0 (- starth))
  99                    (lineto width (- endh))
 100                    (closestroke)))
 101
 102   (define (dashed-slur thick dash l)
 103     (string-append (setlineparams)
 104                    "[ " (ly-number->string dash) " "
 105                    (ly-number->string (* 10 thick)) " ] 0 d "
 106                    (setlinewidth thick)
 107                    (moveto-pair (car l))
 108                    (apply curveto (cdr l))
 109                    (closestroke)))
 110
 111   (define (dashed-line thick on off dx dy)
 112     (string-append (setlineparams)
 113                    "[ " (ly-number->string on) " "
 114                    (ly-number->string off) " ] 0 d "
 115                    (setlinewidth thick)
 116                    (moveto 0 0)
 117                    (lineto dx dy)
 118                    (closestroke)))
 119
 120   (define (repeat-slash width slope beamthick)
 121     (let* ((height (/ beamthick slope))
 122            (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
 123       (string-append (moveto 0 0)
 124                      (rlineto xwid 0)
 125                      (rlineto width (* slope width))
 126                      (rlineto (- xwid) 0)
 127                      (closefill))))
 128
 129   (define (end-output) "")
 130
 131   (define (experimental-on) "")
 132
 133   (define (filledbox breadth width depth height)
 134     (string-append (ly-number->string (- breadth))
 135                    (ly-number->string (- depth))
 136                    (ly-number->string (+ breadth width))
 137                    (ly-number->string (+ depth height))
 138                    " re f "))
 139
 140   (define (font-def i s) "")
 141
 142   (define (font-switch i) "")
 143
 144   (define (header-end) "")
 145
 146   (define (lily-def key val) "")
 147
 148   (define (header creator generate) "")
 149
 150   (define (invoke-char s i)
 151     (string-append
 152      "(\\" (inexact->string i 8) ") " s " " ))
 153
 154   (define (placebox x y s) "")
 155
 156   (define (bezier-sandwich l thick)
 157     (string-append (setlinewidth thick)
 158                    (moveto-pair (list-ref l 7))
 159                    (curveto-pairs (list-ref l 4)
 160                                   (list-ref l 5)
 161                                   (list-ref l 6))
 162                    (lineto-pair (list-ref l 3))
 163                    (curveto-pairs (list-ref l 0)
 164                                   (list-ref l 1)
 165                                   (list-ref l 2))
 166                    "B "))
 167
 168   (define (start-line height) "")
 169
 170   (define (stem breadth width depth height)
 171     (filledbox breadth width depth height))
 172
 173   (define (stop-line) "")
 174
 175   (define (text s) "")
 176
 177   (define (volta h w thick vert_start vert_end)
 178     (string-append (setlinewidth thick)
 179                    (setlineparams)
 180                    (if (= vert_start 0)
 181                        (string-append (moveto 0 0)
 182                                       (lineto 0 h))
 183                        (moveto 0 h))
 184                    (lineto w h)
 185                    (if (= vert_end 0) (lineto w 0) "")
 186                    (closestroke)))
 187
 188   (define (tuplet ht gap dx dy thick dir)
 189     (let ((gapy (* (/ dy dx) gap)))
 190       (string-append (setlinewidth thick)
 191                      (setlineparams)
 192                      (moveto 0 (- (* ht dir)))
 193                      (lineto 0 0)
 194                      (lineto (/ (- dx gap) 2)
 195                              (/ (- dy gapy) 2))
 196                      (moveto (/ (+ dx gap) 2)
 197                              (/ (+ dy gapy) 2))
 198                      (lineto dx dy)
 199                      (lineto dx (- dy (* ht dir)))
 200                      (closestroke))))
 201
 202   (define (unknown) "\n unknown\n")
 203
 204   ; Problem here -- we're using /F18 for the font, but we don't know
 205   ; for sure that that will exist.
 206   (define (ez-ball ch letter-col ball-col)
 207     (let ((origin (cons 0.45 0)))
 208       (string-append (setgray 0)
 209                      (setlinewidth 1.1)
 210                      (moveto-pair origin) (lineto-pair origin)
 211                      (closestroke)
 212                      (setgray ball-col)
 213                      (setlinewidth 0.9)
 214                      (moveto-pair origin) (lineto-pair origin)
 215                      (closestroke)
 216                      (setgray letter-col)
 217                      (moveto-pair origin)
 218                      "BT "
 219                      "/F18 0.85 Tf "
 220                      "-0.28 -0.30 Td " ; move for text block
 221                      "[(" ch ")] TJ ET ")))
 222
 223   (define (define-origin a b c ) "")
 224   (define (no-origin) "")
 225
 226   ;; PS
 227   (cond ((eq? action-name 'all-definitions)
 228          `(begin
 229             (define beam ,beam)
 230             (define tuplet ,tuplet)
 231             (define bracket ,bracket)
 232             (define char ,char)
 233             (define volta ,volta)
 234             (define bezier-sandwich ,bezier-sandwich)
 235             (define dashed-line ,dashed-line)
 236             (define dashed-slur ,dashed-slur)
 237             (define hairpin ,hairpin)
 238             (define end-output ,end-output)
 239             (define experimental-on ,experimental-on)
 240             (define filledbox ,filledbox)
 241             (define font-def ,font-def)
 242             (define font-switch ,font-switch)
 243             (define header-end ,header-end)
 244             (define lily-def ,lily-def)
 245             (define font-load-command ,font-load-command)
 246             (define header ,header)
 247             (define invoke-char ,invoke-char)
 248
 249             (define placebox ,placebox)
 250             (define repeat-slash ,repeat-slash)
 251             (define select-font ,select-font)
 252             (define start-line ,start-line)
 253             (define stem ,stem)
 254             (define stop-line ,stop-line)
 255             (define stop-last-line ,stop-line)
 256             (define text ,text)
 257             (define no-origin ,no-origin)
 258             (define define-origin ,define-origin)
 259             (define ez-ball ,ez-ball)
 260             ))
 261         ((eq? action-name 'tuplet) tuplet)
 262         ((eq? action-name 'beam) beam)
 263         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 264         ((eq? action-name 'bracket) bracket)
 265         ((eq? action-name 'char) char)
 266         ((eq? action-name 'dashed-line) dashed-line)
 267         ((eq? action-name 'dashed-slur) dashed-slur)
 268         ((eq? action-name 'hairpin) hairpin)
 269         ((eq? action-name 'experimental-on) experimental-on)
 270         ((eq? action-name 'ez-ball) ez-ball)
 271         ((eq? action-name 'filledbox) filledbox)
 272         ((eq? action-name 'repeat-slash) repeat-slash)
 273         ((eq? action-name 'select-font) select-font)
 274         ((eq? action-name 'volta) volta)
 275         (else (error "unknown tag -- PDF-SCM " action-name))
 276         )
 277   )
 278
 279 (define (scm-pdf-output)
 280   (primitive-eval (pdf-scm 'all-definitions)))
 281
 282 ; Local Variables:
 283 ; scheme-program-name: "guile"
 284 ; End: