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