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