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   :export (ps-output-expression)
  12   :no-backtrace
  13   )
  14
  15 (define this-module (current-module))
  16
  17 (define (ps-output-expression expr port)
  18   (display (eval expr this-module) port)
  19   )
  20
  21
  22 (use-modules
  23  (guile)
  24  (guile-user))
  25
  26
  27
  28 ;;;;;;;;
  29 ;;;;;;;; DOCUMENT ME!
  30 ;;;;;;;;
  31 (define (tex-encoded-fontswitch name-mag)
  32   (let* ((iname-mag (car name-mag))
  33          (ename-mag (cdr name-mag)))
  34     (cons iname-mag
  35           (cons ename-mag
  36                 (string-append  "magfont"
  37                           (string-encode-integer
  38                            (hashq (car ename-mag) 1000000))
  39                           "m"
  40                           (string-encode-integer
  41                            (inexact->exact (* 1000 (cdr ename-mag)))))))))
  42
  43 (define (fontify name-mag-pair exp)
  44   (string-append (select-font name-mag-pair)
  45                  exp))
  46
  47
  48 (define (define-fonts internal-external-name-mag-pairs)
  49   (set! font-name-alist (map tex-encoded-fontswitch
  50                              internal-external-name-mag-pairs))
  51   (apply string-append
  52          (map (lambda (x)
  53                 (font-load-command (car x) (cdr x)))
  54               (map cdr font-name-alist))))
  55
  56
  57
  58 ;; alist containing fontname -> fontcommand assoc (both strings)
  59 (define font-alist '())
  60 (define font-count 0)
  61 (define current-font "")
  62
  63 (define (select-font name-mag-pair)
  64   (let*
  65       (
  66        (c (assoc name-mag-pair font-name-alist))
  67        )
  68
  69     (if (eq? c #f)
  70         (begin
  71           (display "FAILED\n")
  72           (display (object-type (car name-mag-pair)))
  73           (display (object-type (caaar font-name-alist)))
  74
  75           (ly-warn (string-append
  76                     "Programming error: No such font known "
  77                     (car name-mag-pair) " "
  78                     (ly-number->string (cdr name-mag-pair))
  79                     ))
  80
  81           "") ; issue no command
  82         (string-append " " (cddr c) " "))
  83     ))
  84
  85 (define (font-load-command name-mag command)
  86   (string-append
  87    "/" command
  88    " { /"
  89    (car name-mag)
  90    " findfont "
  91    "12 " (ly-number->string (cdr name-mag)) " mul "
  92    "lilypondpaperoutputscale div scalefont setfont } bind def "
  93    "\n"))
  94
  95 (define (beam width slope thick)
  96   (string-append
  97    (numbers->string (list slope width thick)) " draw_beam" ))
  98
  99 (define (comment s)
 100   (string-append "% " s "\n"))
 101
 102 (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
 103   (string-append
 104    (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
 105
 106 (define (char i)
 107   (invoke-char " show" i))
 108
 109
 110 (define (hairpin thick width starth endh )
 111   (string-append
 112    (numbers->string (list width starth endh thick))
 113    " draw_hairpin"))
 114
 115 ;; what the heck is this interface ?
 116 (define (dashed-slur thick dash l)
 117   (string-append
 118    (apply string-append (map control->string l))
 119    (ly-number->string thick)
 120    " [ "
 121    (ly-number->string dash)
 122    " "
 123    (ly-number->string (* 10 thick))     ;UGH.  10 ?
 124    " ] 0 draw_dashed_slur"))
 125
 126 (define (dashed-line thick on off dx dy)
 127   (string-append
 128    (ly-number->string dx)
 129    " "
 130    (ly-number->string dy)
 131    " "
 132    (ly-number->string thick)
 133    " [ "
 134    (ly-number->string on)
 135    " "
 136    (ly-number->string off)
 137    " ] 0 draw_dashed_line"))
 138
 139 (define (repeat-slash wid slope thick)
 140   (string-append (numbers->string (list wid slope thick))
 141                  " draw_repeat_slash"))
 142
 143 (define (end-output)
 144   "\nend-lilypond-output\n")
 145
 146 (define (experimental-on) "")
 147
 148 (define (filledbox breapth width depth height)
 149   (string-append (numbers->string (list breapth width depth height))
 150                  " draw_box" ))
 151
 152 ;; obsolete?
 153 (define (font-def i s)
 154   (string-append
 155    "\n/" (font i) " {/"
 156    (substring s 0 (- (string-length s) 4))
 157    " findfont 12 scalefont setfont} bind def \n"))
 158
 159 (define (font-switch i)
 160   (string-append (font i) " "))
 161
 162 (define (header-end)
 163   (string-append
 164    ;; URG: now we can't use scm output without Lily
 165    (ly-gulp-file "lilyponddefs.ps")
 166    " {exch pop //systemdict /run get exec} "
 167    (ly-gulp-file "music-drawing-routines.ps")
 168    "{ exch pop //systemdict /run get exec } "
 169    (if (defined? 'ps-testing) "\n /testing true def" "")
 170    ))
 171
 172 (define (lily-def key val)
 173
 174   (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 175       (string-append "/" key " {" val "} bind def\n")
 176       (string-append "/" key " (" val ") def\n")
 177       )
 178   )
 179
 180 (define (header creator generate)
 181   (string-append
 182    "%!PS-Adobe-3.0\n"
 183    "%%Creator: " creator generate "\n"))
 184
 185 (define (invoke-char s i)
 186   (string-append
 187    "(\\" (inexact->string i 8) ") " s " " ))
 188
 189 (define (invoke-dim1 s d)
 190   (string-append
 191    (ly-number->string (* d  (/ 72.27 72))) " " s ))
 192
 193 (define (placebox x y s)
 194   (string-append
 195    (ly-number->string x) " " (ly-number->string y) " {" s "} place-box\n"))
 196
 197 (define (bezier-sandwich l thick)
 198   (string-append
 199    (apply string-append (map control->string l))
 200    (ly-number->string  thick)
 201    " draw_bezier_sandwich"))
 202
 203                                         ; TODO: use HEIGHT argument
 204 (define (start-line height)
 205   (string-append
 206    "\n"
 207    (ly-number->string height)
 208    " start-line {
 209 lilypondpaperoutputscale lilypondpaperoutputscale scale
 210 "))
 211
 212 (define (stem breapth width depth height)
 213   (string-append (numbers->string (list breapth width depth height))
 214                  " draw_box" ))
 215
 216 (define (stop-line)
 217   "}\nstop-line\n")
 218
 219 (define (stop-last-line)
 220   "}\nstop-line\n")
 221
 222 (define (text s)
 223   (string-append "(" s ") show  "))
 224
 225
 226 (define (volta h w thick vert_start vert_end)
 227   (string-append
 228    (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 229    " draw_volta"))
 230
 231 (define (tuplet ht gap dx dy thick dir)
 232   (string-append
 233    (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 234    " draw_tuplet"))
 235
 236
 237 (define (unknown)
 238   "\n unknown\n")
 239
 240 (define (ez-ball ch letter-col ball-col)
 241   (string-append
 242    " (" ch ") "
 243    (numbers->string (list letter-col ball-col))
 244    " /Helvetica-Bold " ;; ugh
 245    " draw_ez_ball"))
 246
 247 (define (define-origin a b c ) "")
 248 (define (no-origin) "")
 249
 250