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 ;; TODO:
 141 ;;
 142 ;;(define (dot x y diam)
 143 ;;  (let (radius (/ diam 2))
 144 ;;    (string-append (ly-number->string (x))
 145 ;;                   (ly-number->string (y))
 146 ;;                   (ly-number->string (radius))
 147 ;;                   " ??? "))) ;; how to draw a circle in PDF?
 148 ;;
 149 ;;(define (roundfilledbox x width y height blotdiam)
 150 ;;  (string-append " "
 151 ;;    (dot x y blotdiam)
 152 ;;    (dot (+ x width) y blotdiam)
 153 ;;    (dot (+ x width) (+ y height) blotdiam)
 154 ;;    (dot x (+ y height) blotdiam)
 155 ;;    (filledbox (+ x (/ blotdiam 2)) (+ width (/ blotdiam 2)) y height)
 156 ;;    (filledbox x width (+ y (/ blotdiam 2)) (+ height (/ blotdiam 2)))))
 157 ;;
 158 ;;
 159 ;; WORKAROUND:
 160 ;;
 161   (define (roundfilledbox breadth width depth height)
 162     (filledbox breadth width depth height))
 163 ;;
 164
 165   (define (font-def i s) "")
 166
 167   (define (font-switch i) "")
 168
 169   (define (header-end) "")
 170
 171   (define (lily-def key val) "")
 172
 173   (define (header creator generate) "")
 174
 175   (define (invoke-char s i)
 176     (string-append
 177      "(\\" (inexact->string i 8) ") " s " " ))
 178
 179   (define (placebox x y s) "")
 180
 181   (define (bezier-sandwich l thick)
 182     (string-append (setlinewidth thick)
 183                    (moveto-pair (list-ref l 7))
 184                    (curveto-pairs (list-ref l 4)
 185                                   (list-ref l 5)
 186                                   (list-ref l 6))
 187                    (lineto-pair (list-ref l 3))
 188                    (curveto-pairs (list-ref l 0)
 189                                   (list-ref l 1)
 190                                   (list-ref l 2))
 191                    "B "))
 192
 193   (define (start-line height) "")
 194
 195   (define (stem breadth width depth height)
 196     (filledbox breadth width depth height))
 197
 198   (define (stop-line) "")
 199
 200   (define (text s) "")
 201
 202   (define (volta h w thick vert_start vert_end)
 203     (string-append (setlinewidth thick)
 204                    (setlineparams)
 205                    (if (= vert_start 0)
 206                        (string-append (moveto 0 0)
 207                                       (lineto 0 h))
 208                        (moveto 0 h))
 209                    (lineto w h)
 210                    (if (= vert_end 0) (lineto w 0) "")
 211                    (closestroke)))
 212
 213   (define (tuplet ht gap dx dy thick dir)
 214     (let ((gapy (* (/ dy dx) gap)))
 215       (string-append (setlinewidth thick)
 216                      (setlineparams)
 217                      (moveto 0 (- (* ht dir)))
 218                      (lineto 0 0)
 219                      (lineto (/ (- dx gap) 2)
 220                              (/ (- dy gapy) 2))
 221                      (moveto (/ (+ dx gap) 2)
 222                              (/ (+ dy gapy) 2))
 223                      (lineto dx dy)
 224                      (lineto dx (- dy (* ht dir)))
 225                      (closestroke))))
 226
 227   (define (unknown) "\n unknown\n")
 228
 229   ; Problem here -- we're using /F18 for the font, but we don't know
 230   ; for sure that that will exist.
 231   (define (ez-ball ch letter-col ball-col)
 232     (let ((origin (cons 0.45 0)))
 233       (string-append (setgray 0)
 234                      (setlinewidth 1.1)
 235                      (moveto-pair origin) (lineto-pair origin)
 236                      (closestroke)
 237                      (setgray ball-col)
 238                      (setlinewidth 0.9)
 239                      (moveto-pair origin) (lineto-pair origin)
 240                      (closestroke)
 241                      (setgray letter-col)
 242                      (moveto-pair origin)
 243                      "BT "
 244                      "/F18 0.85 Tf "
 245                      "-0.28 -0.30 Td " ; move for text block
 246                      "[(" ch ")] TJ ET ")))
 247
 248   (define (define-origin a b c ) "")
 249   (define (no-origin) "")
 250
 251   ;; PS
 252   (cond ((eq? action-name 'all-definitions)
 253          `(begin
 254             (define beam ,beam)
 255             (define tuplet ,tuplet)
 256             (define bracket ,bracket)
 257             (define char ,char)
 258             (define volta ,volta)
 259             (define bezier-sandwich ,bezier-sandwich)
 260             (define dashed-line ,dashed-line)
 261             (define dashed-slur ,dashed-slur)
 262             (define hairpin ,hairpin)
 263             (define end-output ,end-output)
 264             (define experimental-on ,experimental-on)
 265             (define filledbox ,filledbox)
 266             (define roundfilledbox ,roundfilledbox)
 267             (define font-def ,font-def)
 268             (define font-switch ,font-switch)
 269             (define header-end ,header-end)
 270             (define lily-def ,lily-def)
 271             (define font-load-command ,font-load-command)
 272             (define header ,header)
 273             (define invoke-char ,invoke-char)
 274
 275             (define placebox ,placebox)
 276             (define repeat-slash ,repeat-slash)
 277             (define select-font ,select-font)
 278             (define start-line ,start-line)
 279             (define stem ,stem)
 280             (define stop-line ,stop-line)
 281             (define stop-last-line ,stop-line)
 282             (define text ,text)
 283             (define no-origin ,no-origin)
 284             (define define-origin ,define-origin)
 285             (define ez-ball ,ez-ball)
 286             ))
 287         ((eq? action-name 'tuplet) tuplet)
 288         ((eq? action-name 'beam) beam)
 289         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 290         ((eq? action-name 'bracket) bracket)
 291         ((eq? action-name 'char) char)
 292         ((eq? action-name 'dashed-line) dashed-line)
 293         ((eq? action-name 'dashed-slur) dashed-slur)
 294         ((eq? action-name 'hairpin) hairpin)
 295         ((eq? action-name 'experimental-on) experimental-on)
 296         ((eq? action-name 'ez-ball) ez-ball)
 297         ((eq? action-name 'filledbox) filledbox)
 298         ((eq? action-name 'roundfilledbox) roundfilledbox)
 299         ((eq? action-name 'repeat-slash) repeat-slash)
 300         ((eq? action-name 'select-font) select-font)
 301         ((eq? action-name 'volta) volta)
 302         (else (error "unknown tag -- PDF-SCM " action-name))
 303         )
 304   )
 305
 306 (define (scm-pdf-output)
 307   (primitive-eval (pdf-scm 'all-definitions)))
 308
 309 ; Local Variables:
 310 ; scheme-program-name: "guile"
 311 ; End: