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
  14 (define this-module (current-module))
  15
  16 (use-modules
  17  (guile)
  18  )
  19
  20
  21
  22                                         ; simple commands to store and update currentpoint.  This makes the
  23                                         ; other procedures simple rewrites of the PostScript code.
  24 (define currentpoint (cons 0 0))
  25 (define (showcp)
  26   (string-append (ly-number->string (car currentpoint)) " "
  27                  (ly-number->string (cdr 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 ;; TODO:
 146 ;;
 147 ;;(define (dot x y diam)
 148 ;;  (let (radius (/ diam 2))
 149 ;;    (string-append (ly-number->string (x))
 150 ;;                   (ly-number->string (y))
 151 ;;                   (ly-number->string (radius))
 152 ;;                   " ??? "))) ;; how to draw a circle in PDF?
 153 ;;
 154 ;;(define (roundfilledbox x width y height blotdiam)
 155 ;;  (string-append " "
 156 ;;    (dot x y blotdiam)
 157 ;;    (dot (+ x width) y blotdiam)
 158 ;;    (dot (+ x width) (+ y height) blotdiam)
 159 ;;    (dot x (+ y height) blotdiam)
 160 ;;    (filledbox (+ x (/ blotdiam 2)) (+ width (/ blotdiam 2)) y height)
 161 ;;    (filledbox x width (+ y (/ blotdiam 2)) (+ height (/ blotdiam 2)))))
 162 ;;
 163 ;;
 164 ;; WORKAROUND:
 165 ;;
 166 (define (roundfilledbox breadth width depth height)
 167   (filledbox breadth width depth height))
 168 ;;
 169
 170 (define (font-def i s) "")
 171
 172 (define (font-switch i) "")
 173
 174 (define (header-end) "")
 175
 176 (define (lily-def key val) "")
 177
 178 (define (header creator generate) "")
 179
 180 (define (invoke-char s i)
 181   (string-append
 182    "(\\" (inexact->string i 8) ") " s " " ))
 183
 184 (define (placebox x y s) "")
 185
 186 (define (bezier-sandwich l thick)
 187   (string-append (setlinewidth thick)
 188                  (moveto-pair (list-ref l 7))
 189                  (curveto-pairs (list-ref l 4)
 190                                 (list-ref l 5)
 191                                 (list-ref l 6))
 192                  (lineto-pair (list-ref l 3))
 193                  (curveto-pairs (list-ref l 0)
 194                                 (list-ref l 1)
 195                                 (list-ref l 2))
 196                  "B "))
 197
 198 (define (start-system height) "")
 199
 200 (define (stem breadth width depth height)
 201   (filledbox breadth width depth height))
 202
 203 (define (stop-system) "")
 204
 205 (define (text s) "")
 206
 207
 208 (define (unknown) "\n unknown\n")
 209
 210                                         ; Problem here -- we're using /F18 for the font, but we don't know
 211                                         ; for sure that that will exist.
 212 (define (ez-ball ch letter-col ball-col)
 213   (let ((origin (cons 0.45 0)))
 214     (string-append (setgray 0)
 215                    (setlinewidth 1.1)
 216                    (moveto-pair origin) (lineto-pair origin)
 217                    (closestroke)
 218                    (setgray ball-col)
 219                    (setlinewidth 0.9)
 220                    (moveto-pair origin) (lineto-pair origin)
 221                    (closestroke)
 222                    (setgray letter-col)
 223                    (moveto-pair origin)
 224                    "BT "
 225                    "/F18 0.85 Tf "
 226                    "-0.28 -0.30 Td " ; move for text block
 227                    "[(" ch ")] TJ ET ")))
 228
 229 (define (define-origin a b c ) "")
 230 (define (no-origin) "")
 231
 232
 233 (define (scm-pdf-output)
 234   (primitive-eval (pdf-scm 'all-definitions)))
 235
 236 ; Local Variables:
 237 ; scheme-program-name: "guile"
 238 ; End: