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