scm/output-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--2004 Stephen Peters <portnoy@portnoy.org>
   6
   7
   8 ;currently no font commands; this is a helper for pdftex.scm.
   9
  10 (define-module (scm output-pdf))
  11
  12
  13
  14 (define this-module (current-module))
  15
  16 (use-modules
  17  (guile)
  18  (lily))
  19
  20
  21
  22 ; simple commands to store and update currentpoint.  This makes the
  23 ; other procedures simple rewrites of the PostScript code.
  24
  25 (define currentpoint (cons 0 0))
  26 (define (showcp)
  27   (string-append (ly:number-pair->string currentpoint) " "))
  28 (define (moveto x y)
  29   (set! currentpoint (cons x y))
  30   (string-append (showcp) "m "))
  31 (define (moveto-pair pair)
  32   (moveto (car pair) (cdr pair)))
  33 (define (rmoveto x y)
  34   (moveto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
  35 (define (lineto x y)
  36   (set! currentpoint (cons x y))
  37   (string-append (showcp) "l "))
  38 (define (lineto-pair pair)
  39   (lineto (car pair) (cdr pair)))
  40 (define (rlineto x y)
  41   (lineto (+ x (car currentpoint)) (+ y (cdr currentpoint))))
  42 (define (curveto x1 y1 x2 y2 x y)
  43   (set! currentpoint (cons x y))
  44   (string-append (ly:number->string x1) " " (ly:number->string y1) " "
  45                  (ly:number->string x2) " " (ly:number->string y2) " "
  46                  (ly:number->string x) " " (ly:number->string y) " c "))
  47 (define (curveto-pairs pt1 pt2 pt)
  48   (curveto (car pt1) (cdr pt1) (car pt2) (cdr pt2) (car pt) (cdr pt)))
  49 (define (closefill) "h f ")
  50 (define (closestroke) "S ")
  51 (define (setlinewidth w) (string-append (ly:number->string w) " w "))
  52 (define (setgray g) (string-append (ly:number->string g) " g "))
  53 (define (setlineparams) "1 j 1 J ")
  54
  55 (define (beam width slope thick blot)
  56   (let ((ht (* slope width)))
  57     (string-append (moveto 0 (- (/ thick 2)))
  58                    (rlineto width ht)
  59                    (rlineto 0 thick)
  60                    (lineto 0 (/ thick 2))
  61                    (closefill))))
  62
  63 (define (brack-traject pair ds alpha)
  64   (let ((alpha-rad (* alpha (/ 3.141592654 180))))
  65     (cons (+ (car pair) (* (cos alpha-rad) ds))
  66           (+ (cdr pair) (* (sin alpha-rad) ds)))))
  67
  68 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
  69   (let* ((halfht (+ (/ height 2) thick))
  70          (farpt (cons (+ thick arch_height)
  71                       (+ (- halfht arch_thick) arch_width)))
  72          (halfbrack
  73           (string-append (moveto 0 0)
  74                          (lineto thick 0)
  75                          (lineto thick (- halfht arch_thick))
  76                          (curveto-pairs
  77                           (brack-traject (cons thick
  78                                                (- halfht arch_thick))
  79                                          (* 0.4 arch_height) 0)
  80                           (brack-traject farpt
  81                                          (* -0.25 arch_height)
  82                                          arch_angle)
  83                           farpt)
  84                          (curveto-pairs
  85                           (brack-traject farpt
  86                                          (* -0.15 arch_height)
  87                                          arch_angle)
  88                           (brack-traject (cons (/ thick 2) halfht)
  89                                          (/ arch_height 2) 0)
  90                           (cons 0 halfht))
  91                          (lineto 0 0)
  92                          (closefill))))
  93     (string-append (setlinewidth (/ thick 2))
  94                    (setlineparams)
  95                    "q 1 0 0 -1 0 0 cm " ; flip coords
  96                    halfbrack
  97                    "Q " ; grestore
  98                    halfbrack)))
  99
 100 (define (char i)
 101   (invoke-char " show" i))
 102
 103
 104 (define (dashed-slur thick dash lst)
 105   (string-append (setlineparams)
 106                  "[ " (ly:number->string dash) " "
 107                  (ly:number->string (* 10 thick)) " ] 0 d "
 108                  (setlinewidth thick)
 109                  (moveto-pair (car lst))
 110                  (apply curveto (cdr lst))
 111                  (closestroke)))
 112
 113 (define (dashed-line thick on off dx dy)
 114   (string-append (setlineparams)
 115                  "[ " (ly:number->string on) " "
 116                  (ly:number->string off) " ] 0 d "
 117                  (setlinewidth thick)
 118                  (moveto 0 0)
 119                  (lineto dx dy)
 120                  (closestroke)))
 121
 122 (define (repeat-slash width slope beamthick)
 123   (let* ((height (/ beamthick slope))
 124          (xwid (sqrt (+ (* beamthick beamthick) (* height height)))))
 125     (string-append (moveto 0 0)
 126                    (rlineto xwid 0)
 127                    (rlineto width (* slope width))
 128                    (rlineto (- xwid) 0)
 129                    (closefill))))
 130
 131
 132 (define (experimental-on) "")
 133
 134 (define (filledbox breadth width depth height)
 135   (string-append (ly:number->string (- breadth)) " "
 136                  (ly:number->string (- depth)) " "
 137                  (ly:number->string (+ breadth width)) " "
 138                  (ly:number->string (+ depth height))
 139                  " re f "))
 140
 141 (define (round-filled-box breadth width depth height blotdiam)
 142   (let* ((rad (/ blotdiam 2))
 143          (h (- height rad))
 144          (d (- depth rad))
 145          (w (- width rad))
 146          (b (- breadth rad)))
 147     (string-append " 0 J "
 148                    (setlinewidth blotdiam)
 149                    "1 j "
 150                    (moveto (- b) (- d))
 151                    (rlineto (+ b w) 0)
 152                    (rlineto 0 (+ d h))
 153                    (rlineto (- (+ b w)) 0)
 154                    (rlineto 0 (- (+ d h)))
 155                    "b ")))
 156
 157 ;; PDF doesn't have the nifty arc operator.  This uses a fast
 158 ;; approximation with two curves.  It bulges out a bit more than a
 159 ;; true circle should along the 45 degree axes, but most users won't
 160 ;; notice.
 161 (define (dot x y radius)
 162   (string-append (moveto (- x radius) y)
 163                  (curveto (- x radius) (+ y (* 1.3333 radius))
 164                           (+ x radius) (+ y (* 1.3333 radius))
 165                           (+ x radius) y)
 166                  (curveto (+ x radius) (- y (* 1.3333 radius))
 167                           (- x radius) (- y (* 1.3333 radius))
 168                           (- x radius) y)
 169                  "f "))
 170
 171
 172 (define (round-filled-box breadth width depth height blot)
 173   (filledbox breadth width depth height))
 174
 175 (define (font-def i s) "")
 176
 177 (define (font-switch i) "")
 178
 179 (define (header-end) "")
 180
 181 (define (lily-def key val) "")
 182
 183 (define (header creator generate) "")
 184
 185 (define (invoke-char s i)
 186   (string-append
 187    "(\\" (ly:inexact->string i 8) ") " s " " ))
 188
 189 (define (placebox x y s) "")
 190
 191 (define (bezier-sandwich lst thick)
 192   (string-append (setlinewidth thick)
 193                  (moveto-pair (list-ref lst 7))
 194                  (curveto-pairs (list-ref lst 4)
 195                                 (list-ref lst 5)
 196                                 (list-ref lst 6))
 197                  (lineto-pair (list-ref lst 3))
 198                  (curveto-pairs (list-ref lst 0)
 199                                 (list-ref lst 1)
 200                                 (list-ref lst 2))
 201                  "B "
 202                  (bezier-ending (list-ref lst 3) (list-ref lst 0) (list-ref lst 5))
 203                  (bezier-ending (list-ref lst 7) (list-ref lst 0) (list-ref lst 5))))
 204
 205 (define (bezier-ending z0 z1 z2)
 206   (let ((x0 (car z0))
 207         (y0 (cdr z0))
 208         (x1 (car z1))
 209         (y1 (cdr z1))
 210         (x2 (car z2))
 211         (y2 (cdr z2)))
 212     (dot x0 y0
 213          (/ (sqrt (+ (* (- x1 x2) (- x1 x2))
 214                      (* (- y1 y2) (- y1 y2)))) 2))))
 215
 216
 217 (define (start-system width height) "")
 218
 219 (define (stem breadth width depth height)
 220   (filledbox breadth width depth height))
 221
 222 (define (stop-system) "")
 223
 224 (define (text s) "")
 225
 226 (define (polygon points blotdiameter) "") ;; TODO
 227
 228 (define (draw-line thick fx fy tx ty)
 229   (string-append (setlineparams)
 230                  (setlinewidth thick)
 231                  (moveto fx fy)
 232                  (lineto tx ty)
 233                  "S "))
 234
 235 (define (unknown) "\n unknown\n")
 236
 237 ; Problem here -- we're using /F18 for the font, but we don't know
 238 ; for sure that that will exist.
 239
 240 (define (ez-ball ch letter-col ball-col)
 241   (let ((origin (cons 0.45 0)))
 242     (string-append (setgray 0)
 243                    (setlinewidth 1.1)
 244                    (moveto-pair origin) (lineto-pair origin)
 245                    (closestroke)
 246                    (setgray ball-col)
 247                    (setlinewidth 0.9)
 248                    (moveto-pair origin) (lineto-pair origin)
 249                    (closestroke)
 250                    (setgray letter-col)
 251                    (moveto-pair origin)
 252                    "BT "
 253                    "/F18 0.85 Tf "
 254                    "-0.28 -0.30 Td " ; move for text block
 255                    "[(" ch ")] TJ ET ")))
 256
 257 (define (define-origin a b c ) "")
 258 (define (no-origin) "")
 259
 260 (define-public (pdf-output-expression expr port)
 261   (display (eval expr this-module) port) )
 262
 263
 264 ; Local Variables:
 265 ; scheme-program-name: "guile"
 266 ; End: