scm/ps.scm

   1 ;;; ps.scm -- implement Scheme output routines for PostScript
   2 ;;;
   3 ;;;  source file of the GNU LilyPond music typesetter
   4 ;;;
   5 ;;; (c) 1998--2001 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9
  10 (define-module (scm ps)
  11   )
  12
  13 (define this-module (current-module))
  14
  15 (debug-enable 'backtrace)
  16
  17 (if (or (equal? (minor-version) "4")
  18         (equal? (minor-version) "3.4"))
  19     (define-public (ps-output-expression expr port)
  20       (display (eval-in-module expr this-module) port))
  21
  22     (define-public (ps-output-expression expr port)
  23       (display (eval expr this-module) port)))
  24
  25
  26 (use-modules
  27  (guile)
  28 )
  29
  30
  31
  32 ;;;;;;;;
  33 ;;;;;;;; DOCUMENT ME!
  34 ;;;;;;;;
  35 (define (tex-encoded-fontswitch name-mag)
  36   (let* ((iname-mag (car name-mag))
  37          (ename-mag (cdr name-mag)))
  38     (cons iname-mag
  39           (cons ename-mag
  40                 (string-append  "magfont"
  41                           (string-encode-integer
  42                            (hashq (car ename-mag) 1000000))
  43                           "m"
  44                           (string-encode-integer
  45                            (inexact->exact (* 1000 (cdr ename-mag)))))))))
  46
  47 (define (fontify name-mag-pair exp)
  48   (string-append (select-font name-mag-pair)
  49                  exp))
  50
  51
  52 (define (define-fonts internal-external-name-mag-pairs)
  53   (set! font-name-alist (map tex-encoded-fontswitch
  54                              internal-external-name-mag-pairs))
  55   (apply string-append
  56          (map (lambda (x)
  57                 (font-load-command (car x) (cdr x)))
  58               (map cdr font-name-alist))))
  59
  60
  61
  62 ;; alist containing fontname -> fontcommand assoc (both strings)
  63 (define font-alist '())
  64 (define font-count 0)
  65 (define current-font "")
  66
  67 (define (select-font name-mag-pair)
  68   (let*
  69       (
  70        (c (assoc name-mag-pair font-name-alist))
  71        )
  72
  73     (if (eq? c #f)
  74         (begin
  75           (display "FAILED\n")
  76           (display (object-type (car name-mag-pair)))
  77           (display (object-type (caaar font-name-alist)))
  78
  79           (ly-warn (string-append
  80                     "Programming error: No such font known "
  81                     (car name-mag-pair) " "
  82                     (ly-number->string (cdr name-mag-pair))
  83                     ))
  84
  85           "") ; issue no command
  86         (string-append " " (cddr c) " "))
  87     ))
  88
  89 (define (font-load-command name-mag command)
  90   (string-append
  91    "/" command
  92    " { /"
  93    (capitalize-font-name (car name-mag))
  94    " findfont "
  95    "20 " (ly-number->string (cdr name-mag)) " mul "
  96    "output-scale div scalefont setfont } bind def "
  97    "\n"))
  98
  99 ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
 100 ;; postscript font names.
 101 (define (capitalize-font-name name)
 102   (if (equal? (substring name 0 2) "cm")
 103       (string-upcase name)
 104       name))
 105
 106 (define (beam width slope thick)
 107   (string-append
 108    (numbers->string (list slope width thick)) " draw_beam" ))
 109
 110 (define (comment s)
 111   (string-append "% " s "\n"))
 112
 113 (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
 114   (string-append
 115    (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
 116
 117 (define (char i)
 118   (invoke-char " show" i))
 119
 120
 121 (define (hairpin thick width starth endh )
 122   (string-append
 123    (numbers->string (list width starth endh thick))
 124    " draw_hairpin"))
 125
 126 ;; what the heck is this interface ?
 127 (define (dashed-slur thick dash l)
 128   (string-append
 129    (apply string-append (map control->string l))
 130    (ly-number->string thick)
 131    " [ "
 132    (ly-number->string dash)
 133    " "
 134    (ly-number->string (* 10 thick))     ;UGH.  10 ?
 135    " ] 0 draw_dashed_slur"))
 136
 137 (define (dashed-line thick on off dx dy)
 138   (string-append
 139    (ly-number->string dx)
 140    " "
 141    (ly-number->string dy)
 142    " "
 143    (ly-number->string thick)
 144    " [ "
 145    (ly-number->string on)
 146    " "
 147    (ly-number->string off)
 148    " ] 0 draw_dashed_line"))
 149
 150 (define (repeat-slash wid slope thick)
 151   (string-append (numbers->string (list wid slope thick))
 152                  " draw_repeat_slash"))
 153
 154 (define (end-output)
 155   "\nend-lilypond-output\n")
 156
 157 (define (experimental-on) "")
 158
 159 (define (filledbox breapth width depth height)
 160   (string-append (numbers->string (list breapth width depth height))
 161                  " draw_box" ))
 162
 163 (define (dot x y radius)
 164     (string-append " "
 165      (numbers->string
 166       (list x y radius)) " draw_dot"))
 167
 168 (define (roundfilledbox x width y height blotdiam)
 169    (string-append " "
 170       (dot (- 0 x) (- 0 y) (/ blotdiam 2))
 171       (dot width (- 0 y) (/ blotdiam 2))
 172       (dot width height (/ blotdiam 2))
 173       (dot (- 0 x) height (/ blotdiam 2))
 174       (filledbox (+ x (/ blotdiam 2)) (+ width (/ blotdiam 2)) y height)
 175       (filledbox x width (+ y (/ blotdiam 2)) (+ height (/ blotdiam 2)))))
 176
 177 ;; obsolete?
 178 (define (font-def i s)
 179   (string-append
 180    "\n/" (font i) " {/"
 181    (substring s 0 (- (string-length s) 4))
 182    " findfont 12 scalefont setfont} bind def \n"))
 183
 184 (define (font-switch i)
 185   (string-append (font i) " "))
 186
 187 (define (header-end)
 188   (string-append
 189    ;; URG: now we can't use scm output without Lily
 190    (ly-gulp-file "lilyponddefs.ps")
 191    " {exch pop //systemdict /run get exec} "
 192    (ly-gulp-file "music-drawing-routines.ps")
 193    "{ exch pop //systemdict /run get exec } "
 194 ;; ps-testing is broken: global module
 195    (if (defined? 'ps-testing) "\n /testing true def" "")
 196 ;;   "\n /testing true def"
 197    ))
 198
 199 (define (lily-def key val)
 200
 201   (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 202       (string-append "/" key " {" val "} bind def\n")
 203       (string-append "/" key " (" val ") def\n")
 204       )
 205   )
 206
 207 (define (header creator generate)
 208   (string-append
 209    "%!PS-Adobe-3.0\n"
 210    "%%Creator: " creator generate "\n"))
 211
 212 (define (invoke-char s i)
 213   (string-append
 214    "(\\" (inexact->string i 8) ") " s " " ))
 215
 216
 217 (define (placebox x y s)
 218   (string-append
 219    (ly-number->string x) " " (ly-number->string y) " {" s "} place-box\n"))
 220
 221 (define (bezier-sandwich l thick)
 222   (string-append
 223    (apply string-append (map control->string l))
 224    (ly-number->string thick)
 225    " draw_bezier_sandwich "
 226    (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
 227    (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
 228
 229 (define (bezier-ending z0 z1 z2)
 230   (let ((x0 (car z0))
 231         (y0 (cdr z0))
 232         (x1 (car z1))
 233         (y1 (cdr z1))
 234         (x2 (car z2))
 235         (y2 (cdr z2)))
 236     (string-append " "
 237      (numbers->string
 238       (list x0 y0
 239             (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
 240      " draw_dot")))
 241
 242                                         ; TODO: use HEIGHT argument
 243
 244   (define (start-line height)
 245   (string-append
 246    "\n"
 247    (ly-number->string height)
 248    " start-line {
 249 set-ps-scale-to-lily-scale
 250
 251 "))
 252
 253 (define (stem breapth width depth height)
 254   (string-append (numbers->string (list breapth width depth height))
 255                  " draw_box" ))
 256
 257 (define (stop-line)
 258   "}\nstop-line\n")
 259
 260 (define (stop-last-line)
 261   "}\nstop-line\n")
 262
 263 (define (text s)
 264   (string-append "(" s ") show  "))
 265
 266
 267 (define (volta h w thick vert_start vert_end)
 268   (string-append
 269    (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 270    " draw_volta"))
 271
 272 (define (tuplet ht gap dx dy thick dir)
 273   (string-append
 274    (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 275    " draw_tuplet"))
 276
 277
 278 (define (unknown)
 279   "\n unknown\n")
 280
 281 (define (ez-ball ch letter-col ball-col)
 282   (string-append
 283    " (" ch ") "
 284    (numbers->string (list letter-col ball-col))
 285    " /Helvetica-Bold " ;; ugh
 286    " draw_ez_ball"))
 287
 288 (define (define-origin a b c ) "")
 289 (define (no-origin) "")
 290
 291