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    (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 (/ 72 72.27)))
 133    " "
 134    (ly-number->string dy)
 135    " "
 136    (ly-number->string (* thick (/ 72 72.27)))
 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 ;; ps-testing is broken: global module
 174    (if (defined? 'ps-testing) "\n /testing true def" "")
 175 ;;   "\n /testing true def"
 176    ))
 177
 178 (define (lily-def key val)
 179
 180   (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 181       (string-append "/" key " {" val "} bind def\n")
 182       (string-append "/" key " (" val ") def\n")
 183       )
 184   )
 185
 186 (define (header creator generate)
 187   (string-append
 188    "%!PS-Adobe-3.0\n"
 189    "%%Creator: " creator generate "\n"))
 190
 191 (define (invoke-char s i)
 192   (string-append
 193    "(\\" (inexact->string i 8) ") " s " " ))
 194
 195 (define (invoke-dim1 s d)
 196   (string-append
 197    (ly-number->string (* d  (/ 72.27 72))) " " s ))
 198
 199 (define (placebox x y s)
 200   (string-append
 201    (ly-number->string x) " " (ly-number->string y) " {" s "} place-box\n"))
 202
 203 (define (bezier-sandwich l thick)
 204   (string-append
 205    (apply string-append (map control->string l))
 206    (ly-number->string thick)
 207    " draw_bezier_sandwich "
 208    (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
 209    (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
 210
 211 (define (bezier-ending z0 z1 z2)
 212   (let ((x0 (car z0))
 213         (y0 (cdr z0))
 214         (x1 (car z1))
 215         (y1 (cdr z1))
 216         (x2 (car z2))
 217         (y2 (cdr z2)))
 218     (string-append " "
 219      (numbers->string
 220       (list x0 y0
 221             (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
 222      " draw_dot")))
 223
 224                                         ; TODO: use HEIGHT argument
 225 (define (start-line height)
 226   (string-append
 227    "\n"
 228    (ly-number->string height)
 229    " start-line {
 230 lilypondpaperoutputscale lilypondpaperoutputscale scale
 231 "))
 232
 233 (define (stem breapth width depth height)
 234   (string-append (numbers->string (list breapth width depth height))
 235                  " draw_box" ))
 236
 237 (define (stop-line)
 238   "}\nstop-line\n")
 239
 240 (define (stop-last-line)
 241   "}\nstop-line\n")
 242
 243 (define (text s)
 244   (string-append "(" s ") show  "))
 245
 246
 247 (define (volta h w thick vert_start vert_end)
 248   (string-append
 249    (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 250    " draw_volta"))
 251
 252 (define (tuplet ht gap dx dy thick dir)
 253   (string-append
 254    (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 255    " draw_tuplet"))
 256
 257
 258 (define (unknown)
 259   "\n unknown\n")
 260
 261 (define (ez-ball ch letter-col ball-col)
 262   (string-append
 263    " (" ch ") "
 264    (numbers->string (list letter-col ball-col))
 265    " /Helvetica-Bold " ;; ugh
 266    " draw_ez_ball"))
 267
 268 (define (define-origin a b c ) "")
 269 (define (no-origin) "")
 270
 271