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
 122 ;; what the heck is this interface ?
 123 (define (dashed-slur thick dash l)
 124   (string-append
 125    (apply string-append (map control->string l))
 126    (ly-number->string thick)
 127    " [ "
 128    (ly-number->string dash)
 129    " "
 130    (ly-number->string (* 10 thick))     ;UGH.  10 ?
 131    " ] 0 draw_dashed_slur"))
 132
 133 (define (dashed-line thick on off dx dy)
 134   (string-append
 135    (ly-number->string dx)
 136    " "
 137    (ly-number->string dy)
 138    " "
 139    (ly-number->string thick)
 140    " [ "
 141    (ly-number->string on)
 142    " "
 143    (ly-number->string off)
 144    " ] 0 draw_dashed_line"))
 145
 146 (define (draw-line thick x1 y1 x2 y2)
 147
 148   (string-append
 149   "     1 setlinecap
 150         1 setlinejoin "
 151   (ly-number->string thick)
 152         " setlinewidth "
 153    (ly-number->string x1)
 154    " "
 155    (ly-number->string y1)
 156    " moveto "
 157    (ly-number->string x2)
 158    " "
 159    (ly-number->string y2)
 160    " lineto stroke"
 161
 162   ))
 163
 164 (define (repeat-slash wid slope thick)
 165   (string-append (numbers->string (list wid slope thick))
 166                  " draw_repeat_slash"))
 167
 168 (define (end-output)
 169   "\nend-lilypond-output\n")
 170
 171 (define (experimental-on) "")
 172
 173 (define (filledbox breapth width depth height)
 174   (string-append (numbers->string (list breapth width depth height))
 175                  " draw_box" ))
 176
 177 (define (roundfilledbox x width y height blotdiam)
 178    (string-append " "
 179       (numbers->string
 180          (list x width y height blotdiam)) " draw_round_box"))
 181
 182 (define (dot x y radius)
 183     (string-append " "
 184      (numbers->string
 185       (list x y radius)) " draw_dot"))
 186
 187 ;; obsolete?
 188 (define (font-def i s)
 189   (string-append
 190    "\n/" (font i) " {/"
 191    (substring s 0 (- (string-length s) 4))
 192    " findfont 12 scalefont setfont} bind def \n"))
 193
 194 (define (font-switch i)
 195   (string-append (font i) " "))
 196
 197 (define (header-end)
 198   (string-append
 199    ;; URG: now we can't use scm output without Lily
 200    (ly-gulp-file "lilyponddefs.ps")
 201    " {exch pop //systemdict /run get exec} "
 202    (ly-gulp-file "music-drawing-routines.ps")
 203    "{ exch pop //systemdict /run get exec } "
 204 ;; ps-testing is broken: global module
 205    (if (defined? 'ps-testing) "\n /testing true def" "")
 206 ;;   "\n /testing true def"
 207    ))
 208
 209 (define (lily-def key val)
 210
 211   (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 212       (string-append "/" key " {" val "} bind def\n")
 213       (string-append "/" key " (" val ") def\n")
 214       )
 215   )
 216
 217 (define (header creator generate)
 218   (string-append
 219    "%!PS-Adobe-3.0\n"
 220    "%%Creator: " creator generate "\n"))
 221
 222 (define (invoke-char s i)
 223   (string-append
 224    "(\\" (inexact->string i 8) ") " s " " ))
 225
 226
 227 (define (placebox x y s)
 228   (string-append
 229    (ly-number->string x) " " (ly-number->string y) " {" s "} place-box\n"))
 230
 231 (define (bezier-sandwich l thick)
 232   (string-append
 233    (apply string-append (map control->string l))
 234    (ly-number->string thick)
 235    " draw_bezier_sandwich "
 236    (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
 237    (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
 238
 239 (define (bezier-ending z0 z1 z2)
 240   (let ((x0 (car z0))
 241         (y0 (cdr z0))
 242         (x1 (car z1))
 243         (y1 (cdr z1))
 244         (x2 (car z2))
 245         (y2 (cdr z2)))
 246     (string-append " "
 247      (numbers->string
 248       (list x0 y0
 249             (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
 250      " draw_dot")))
 251
 252                                         ; TODO: use HEIGHT argument
 253
 254   (define (start-system height)
 255   (string-append
 256    "\n"
 257    (ly-number->string height)
 258    " start-system {
 259 set-ps-scale-to-lily-scale
 260
 261 "))
 262
 263 (define (stem breapth width depth height)
 264   (string-append (numbers->string (list breapth width depth height))
 265                  " draw_box" ))
 266
 267 (define (stop-system)
 268   "}\nstop-system\n")
 269
 270 (define (stop-last-system)
 271   "}\nstop-system\n")
 272
 273 (define (text s)
 274   (string-append "(" s ") show  "))
 275
 276
 277 (define (unknown)
 278   "\n unknown\n")
 279
 280 (define (ez-ball ch letter-col ball-col)
 281   (string-append
 282    " (" ch ") "
 283    (numbers->string (list letter-col ball-col))
 284    " /Helvetica-Bold " ;; ugh
 285    " draw_ez_ball"))
 286
 287 (define (define-origin a b c ) "")
 288 (define (no-origin) "")
 289
 290