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)
  20       (display (eval-in-module expr this-module)))
  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    (car name-mag)
  94    " findfont "
  95    "20 " (ly-number->string (cdr name-mag)) " mul "
  96    "lilypondpaperoutputscale div scalefont setfont } bind def "
  97    "\n"))
  98
  99 (define (beam width slope thick)
 100   (string-append
 101    (numbers->string (list slope width thick)) " draw_beam" ))
 102
 103 (define (comment s)
 104   (string-append "% " s "\n"))
 105
 106 (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
 107   (string-append
 108    (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
 109
 110 (define (char i)
 111   (invoke-char " show" i))
 112
 113
 114 (define (hairpin thick width starth endh )
 115   (string-append
 116    (numbers->string (list width starth endh thick))
 117    " draw_hairpin"))
 118
 119 ;; what the heck is this interface ?
 120 (define (dashed-slur thick dash l)
 121   (string-append
 122    (apply string-append (map control->string l))
 123    (ly-number->string thick)
 124    " [ "
 125    (ly-number->string dash)
 126    " "
 127    (ly-number->string (* 10 thick))     ;UGH.  10 ?
 128    " ] 0 draw_dashed_slur"))
 129
 130 (define (dashed-line thick on off dx dy)
 131   (string-append
 132    (ly-number->string dx)
 133    " "
 134    (ly-number->string dy)
 135    " "
 136    (ly-number->string thick)
 137    " [ "
 138    (ly-number->string on)
 139    " "
 140    (ly-number->string off)
 141    " ] 0 draw_dashed_line"))
 142
 143 (define (repeat-slash wid slope thick)
 144   (string-append (numbers->string (list wid slope thick))
 145                  " draw_repeat_slash"))
 146
 147 (define (end-output)
 148   "\nend-lilypond-output\n")
 149
 150 (define (experimental-on) "")
 151
 152 (define (filledbox breapth width depth height)
 153   (string-append (numbers->string (list breapth width depth height))
 154                  " draw_box" ))
 155
 156 ;; obsolete?
 157 (define (font-def i s)
 158   (string-append
 159    "\n/" (font i) " {/"
 160    (substring s 0 (- (string-length s) 4))
 161    " findfont 12 scalefont setfont} bind def \n"))
 162
 163 (define (font-switch i)
 164   (string-append (font i) " "))
 165
 166 (define (header-end)
 167   (string-append
 168    ;; URG: now we can't use scm output without Lily
 169    (ly-gulp-file "lilyponddefs.ps")
 170    " {exch pop //systemdict /run get exec} "
 171    (ly-gulp-file "music-drawing-routines.ps")
 172    "{ exch pop //systemdict /run get exec } "
 173    (if (defined? 'ps-testing) "\n /testing true def" "")
 174    ))
 175
 176 (define (lily-def key val)
 177
 178   (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 179       (string-append "/" key " {" val "} bind def\n")
 180       (string-append "/" key " (" val ") def\n")
 181       )
 182   )
 183
 184 (define (header creator generate)
 185   (string-append
 186    "%!PS-Adobe-3.0\n"
 187    "%%Creator: " creator generate "\n"))
 188
 189 (define (invoke-char s i)
 190   (string-append
 191    "(\\" (inexact->string i 8) ") " s " " ))
 192
 193 (define (invoke-dim1 s d)
 194   (string-append
 195    (ly-number->string (* d  (/ 72.27 72))) " " s ))
 196
 197 (define (placebox x y s)
 198   (string-append
 199    (ly-number->string x) " " (ly-number->string y) " {" s "} place-box\n"))
 200
 201 (define (bezier-sandwich l thick)
 202   (string-append
 203    (apply string-append (map control->string l))
 204    (ly-number->string  thick)
 205    " draw_bezier_sandwich"))
 206
 207                                         ; TODO: use HEIGHT argument
 208 (define (start-line height)
 209   (string-append
 210    "\n"
 211    (ly-number->string height)
 212    " start-line {
 213 lilypondpaperoutputscale lilypondpaperoutputscale scale
 214 "))
 215
 216 (define (stem breapth width depth height)
 217   (string-append (numbers->string (list breapth width depth height))
 218                  " draw_box" ))
 219
 220 (define (stop-line)
 221   "}\nstop-line\n")
 222
 223 (define (stop-last-line)
 224   "}\nstop-line\n")
 225
 226 (define (text s)
 227   (string-append "(" s ") show  "))
 228
 229
 230 (define (volta h w thick vert_start vert_end)
 231   (string-append
 232    (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 233    " draw_volta"))
 234
 235 (define (tuplet ht gap dx dy thick dir)
 236   (string-append
 237    (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 238    " draw_tuplet"))
 239
 240
 241 (define (unknown)
 242   "\n unknown\n")
 243
 244 (define (ez-ball ch letter-col ball-col)
 245   (string-append
 246    " (" ch ") "
 247    (numbers->string (list letter-col ball-col))
 248    " /Helvetica-Bold " ;; ugh
 249    " draw_ez_ball"))
 250
 251 (define (define-origin a b c ) "")
 252 (define (no-origin) "")
 253
 254