scm/lily.scm

   1 ; lily.scm -- implement Scheme output routines for TeX and PostScript
   2 ;
   3 ;  source file of the GNU LilyPond music typesetter
   4 ;
   5 ; (c) 1998 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7
   8 (debug-enable 'backtrace)
   9
  10 ;;; library funtions
  11 (define
  12   (xnumbers->string l)
  13   (string-append
  14    (map (lambda (n) (string-append (number->string n ) " ")) l)))
  15
  16 (define
  17   (numbers->string l)
  18   (apply string-append
  19          (map (lambda (n) (string-append (number->string n) " ")) l)))
  20
  21 (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
  22
  23 (define (number->octal-string x)
  24   (let* ((n (inexact->exact x))
  25          (n64 (quotient n 64))
  26          (n8 (quotient (- n (* n64 64)) 8)))
  27     (string-append
  28      (number->string n64)
  29      (number->string n8)
  30      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
  31
  32 (define (inexact->string x radix)
  33   (let ((n (inexact->exact x)))
  34     (number->string n radix)))
  35
  36
  37 (define
  38   (control->string c)
  39   (string-append
  40    (string-append (number->string (car c)) " ")
  41    (string-append (number->string (cadr c)) " ")))
  42
  43
  44 (define
  45   (font i)
  46   (string-append
  47    "font"
  48    (make-string 1 (integer->char (+ (char->integer #\A) i)))
  49    ))
  50
  51
  52
  53 (define (scm-scm action-name)
  54   1)
  55
  56 (define security-paranoia #f)
  57
  58
  59 ;; See documentation of Item::visibility_lambda_
  60 (define (postbreak_only_visibility d) (if (= d 1) '(#f . #f) '(#t . #t)))
  61 (define (non_postbreak_visibility d) (if (= d -1) '(#t . #t) '(#f . #f)))
  62 (define (spanbar_non_postbreak_visibility d) (if (= d -1) '(#t . #t) '(#f . #f)))
  63 (define (spanbar_postbreak_only_visibility d) (if (= d 1) '(#f . #f) '(#t . #t)))
  64
  65
  66 ;;;;;;;; TeX
  67
  68 (define (tex-scm action-name)
  69
  70   (define (unknown)
  71     "%\n\\unknown%\n")
  72
  73   (define font-alist '())
  74   (define font-count 0)
  75   (define current-font "")
  76   (define (clear-fontcache)
  77     (begin
  78       (set! font-alist '())
  79       (set! font-count 0)
  80       (set! current-font "")))
  81
  82   (define (cached-fontname i)
  83     (string-append
  84      "\\lilyfont"
  85      (make-string 1 (integer->char (+ 65 i)))
  86      )
  87     )
  88
  89   (define (select-font font-name)
  90       (if (not (equal? font-name current-font))
  91           (begin
  92             (set! current-font font-name)
  93             (define font-cmd (assoc font-name font-alist))
  94             (if (eq? font-cmd #f)
  95                 (begin
  96                   (set! font-cmd (cached-fontname font-count))
  97                   (set! font-alist (acons font-name font-cmd font-alist))
  98                   (set! font-count (+ 1 font-count))
  99                   (string-append "\\font" font-cmd "=" font-name font-cmd)
 100                   )
 101                 (cdr font-cmd))
 102             )
 103
 104           ""                            ;no switch needed
 105
 106           )
 107
 108       )
 109
 110
 111
 112   (define (beam width slope thick)
 113     (embedded-ps ((ps-scm 'beam) width slope thick)))
 114
 115   (define (bracket h)
 116     (embedded-ps ((ps-scm 'bracket) h)))
 117
 118   (define (dashed-slur thick dash l)
 119     (embedded-ps ((ps-scm 'dashed-slur)  thick dash l)))
 120
 121   (define (crescendo w h cont)
 122     (embedded-ps ((ps-scm 'crescendo) w h cont)))
 123
 124   (define (decrescendo w h cont)
 125     (embedded-ps ((ps-scm 'decrescendo) w h cont)))
 126
 127
 128   (define (embedded-ps s)
 129     (string-append "\\embeddedps{" s "}"))
 130
 131   (define (end-output)
 132     "\n\\EndLilyPondOutput")
 133
 134   (define (experimental-on) "\\turnOnExperimentalFeatures")
 135
 136
 137
 138
 139
 140   (define (font-switch i)
 141     (string-append
 142      "\\" (font i) "\n"))
 143
 144   (define (font-def i s)
 145     (string-append
 146      "\\font" (font-switch i) "=" s "\n"))
 147
 148   (define (generalmeter num den)
 149     (string-append
 150      "\\generalmeter{" (number->string (inexact->exact num)) "}{" (number->string (inexact->exact den)) "}"))
 151
 152   (define (header-end) "\\turnOnPostScript")
 153
 154   (define (header creator generate)
 155     (string-append
 156      "%created by: " creator generate "\n"))
 157
 158   (define (invoke-char s i)
 159     (string-append
 160      "\n\\" s "{" (inexact->string i 10) "}" ))
 161   (define (char i)
 162     (string-append "\\show{" (inexact->string i 10) "}"))
 163
 164   (define (invoke-dim1 s d)
 165     (string-append
 166      "\n\\" s "{" (number->dim d) "}"))
 167   (define (pt->sp x)
 168     (* 65536 x))
 169
 170   ;;
 171   ;; need to do something to make this really safe.
 172   ;;
 173   (if security-paranoia
 174       (define (output-tex-string s)
 175         (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post))
 176       (define (output-tex-string s)    s))
 177
 178   (define (lily-def key val)
 179     (string-append
 180      "\\def\\" (output-tex-string key) "{" (output-tex-string val) "}\n"))
 181
 182   (define (number->dim x)
 183     (string-append
 184      (number->string  (chop-decimal x)) "pt "))
 185
 186   (define (placebox x y s)
 187     (string-append
 188      "\\placebox{"
 189      (number->dim y) "}{" (number->dim x) "}{" s "}"))
 190
 191   (define (pianobrace y)
 192     (define step 1.0)
 193     (define minht (* 2 mudelapaperstaffheight))
 194     (define maxht (* 7 minht))
 195     (string-append
 196      "{\\bracefont " (char  (/  (- (min y (- maxht step)) minht)   step)) "}"))
 197
 198
 199
 200   (define (rulesym h w)
 201     (string-append
 202      "\\vrule height " (number->dim (/ h 2))
 203      " depth " (number->dim (/ h 2))
 204      " width " (number->dim w)
 205      )
 206     )
 207
 208   (define (bezier-sandwich l)
 209     (embedded-ps ((ps-scm 'bezier-sandwich) l)))
 210
 211
 212   (define (start-line)
 213     (begin
 214       (clear-fontcache)
 215       "\\hbox{%\n")
 216     )
 217
 218   (define (filledbox breapth width depth height)
 219     (string-append
 220      "\\kern" (number->dim (- breapth))
 221      "\\vrule width " (number->dim (+ breapth width))
 222      "depth " (number->dim depth)
 223      "height " (number->dim height) " "))
 224
 225   (define (stop-line)
 226     "}\\interscoreline")
 227
 228
 229   (define (text s)
 230     (string-append "\\hbox{" (output-tex-string s) "}"))
 231
 232   (define (tuplet dx dy thick dir)
 233     (embedded-ps ((ps-scm 'tuplet) dx dy thick dir)))
 234
 235   (define (volta w thick last)
 236     (embedded-ps ((ps-scm 'volta) w thick last)))
 237
 238
 239   ;; The procedures listed below form the public interface of TeX-scm.
 240   ;; (should merge the 2 lists)
 241   (cond ((eq? action-name 'all-definitions)
 242          `(begin
 243             (define beam ,beam)
 244             (define tuplet ,tuplet)
 245             (define bracket ,bracket)
 246             (define crescendo ,crescendo)
 247             (define dashed-slur ,dashed-slur)
 248             (define decrescendo ,decrescendo)
 249             (define end-output ,end-output)
 250             (define font-def ,font-def)
 251             (define font-switch ,font-switch)
 252             (define generalmeter ,generalmeter)
 253             (define header-end ,header-end)
 254             (define lily-def ,lily-def)
 255             (define header ,header)
 256             (define invoke-char ,invoke-char)
 257             (define invoke-dim1 ,invoke-dim1)
 258             (define placebox ,placebox)
 259             (define rulesym ,rulesym)
 260             (define bezier-sandwich ,bezier-sandwich)
 261             (define select-font ,select-font)
 262             (define start-line ,start-line)
 263             (define filledbox ,filledbox)
 264             (define stop-line ,stop-line)
 265             (define text ,text)
 266             (define experimental-on  ,experimental-on)
 267             (define char  ,char)
 268             (define pianobrace ,pianobrace)
 269             (define volta ,volta)
 270             ))
 271
 272         ((eq? action-name 'experimental-on) experimental-on)
 273         ((eq? action-name 'beam) beam)
 274         ((eq? action-name 'tuplet) tuplet)
 275         ((eq? action-name 'bracket) bracket)
 276         ((eq? action-name 'crescendo) crescendo)
 277         ((eq? action-name 'dashed-slur) dashed-slur)
 278         ((eq? action-name 'decrescendo) decrescendo)
 279         ((eq? action-name 'end-output) end-output)
 280         ((eq? action-name 'font-def) font-def)
 281         ((eq? action-name 'font-switch) font-switch)
 282         ((eq? action-name 'generalmeter) generalmeter)
 283         ((eq? action-name 'header-end) header-end)
 284         ((eq? action-name 'lily-def) lily-def)
 285         ((eq? action-name 'header) header)
 286         ((eq? action-name 'invoke-char) invoke-char)
 287         ((eq? action-name 'invoke-dim1) invoke-dim1)
 288         ((eq? action-name 'placebox) placebox)
 289         ((eq? action-name 'rulesym) rulesym)
 290         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 291         ((eq? action-name 'start-line) start-line)
 292         ((eq? action-name 'stem) stem)
 293         ((eq? action-name 'stop-line) stop-line)
 294         ((eq? action-name 'volta) volta)
 295         (else (error "unknown tag -- PS-TEX " action-name))
 296         )
 297   )
 298
 299 ;;;;;;;;;;;; PS
 300 (define (ps-scm action-name)
 301   (define (beam width slope thick)
 302     (string-append
 303      (numbers->string (list width slope thick)) " draw_beam " ))
 304
 305   (define (bracket h)
 306     (invoke-dim1 "draw_bracket" h))
 307
 308   (define (crescendo w h cont)
 309     (string-append
 310      (numbers->string (list w h (inexact->exact cont)))
 311      "draw_crescendo"))
 312
 313   (define (dashed-slur thick dash l)
 314     (string-append
 315      (apply string-append (map control->string l))
 316      (number->string thick)
 317      " [ "
 318      (if (> 1 dash) (number->string (- (* thick dash) thick)) "0") " "
 319      (number->string (* 2 thick))
 320      " ] 0 draw_dashed_slur"))
 321
 322   (define (decrescendo w h cont)
 323     (string-append
 324      (numbers->string (list w h (inexact->exact cont)))
 325      "draw_decrescendo"))
 326
 327
 328   (define (end-output)
 329     "\nshowpage\n")
 330
 331   (define (experimental-on) "")
 332
 333   (define (font-def i s)
 334     (string-append
 335      "\n/" (font i) " {/"
 336      (substring s 0 (- (string-length s) 4))
 337      " findfont 12 scalefont setfont} bind def\n"))
 338
 339   (define (font-switch i)
 340     (string-append (font i) " "))
 341
 342   (define (generalmeter num den)
 343     (string-append (number->string (inexact->exact num)) " " (number->string (inexact->exact den)) " generalmeter "))
 344
 345   (define (header-end) "")
 346   (define (lily-def key val)
 347     (string-append
 348      "/" key " {" val "} bind def\n"))
 349
 350   (define (header creator generate)
 351     (string-append
 352      "%!PS-Adobe-3.0\n"
 353      "%%Creator: " creator generate "\n"))
 354
 355   (define (invoke-char s i)
 356     (string-append
 357      "(\\" (inexact->string i 8) ") " s " " ))
 358
 359   (define (invoke-dim1 s d)
 360     (string-append
 361      (number->string (* d  (/ 72.27 72))) " " s ))
 362
 363   (define (placebox x y s)
 364     (string-append
 365      (number->string x) " " (number->string y) " {" s "} placebox "))
 366
 367   (define (rulesym x y)
 368     (string-append
 369      (number->string x) " "
 370      (number->string y) " "
 371      "rulesym"))
 372
 373   (define (bezier-sandwich l)
 374     (string-append
 375      (apply string-append (map control->string l))
 376      " draw_bezier_sandwich"))
 377
 378   (define (start-line)
 379     (begin
 380       (clear-fontcache)
 381       "\nstart_line {\n"))
 382
 383   (define (stem kern width height depth)
 384     (string-append (numbers->string (list kern width height depth))
 385                    "draw_stem" ))
 386
 387   (define (stop-line)
 388       "}\nstop_line\n")
 389
 390   (define (text f s)
 391     (string-append "(" s ") set" f " "))
 392
 393
 394   (define (volta w thick last)
 395     (string-append
 396      (numbers->string (list w thick (inexact->exact last)))
 397      "draw_volta"))
 398
 399   (define (tuplet dx dy thick dir)
 400     (string-append
 401      (numbers->string (list dx dy thick (inexact->exact dir)))
 402      "draw_tuplet"))
 403
 404
 405   (define (unknown)
 406     "\n unknown\n")
 407
 408
 409   ; dispatch on action-name
 410   (cond ((eq? action-name 'all-definitions)
 411          `(begin
 412             (define beam ,beam)
 413             (define tuplet ,tuplet)
 414             (define bracket ,bracket)
 415             (define crescendo ,crescendo)
 416             (define volta ,volta)
 417             (define bezier-sandwich ,bezier-sandwich)
 418             (define dashed-slur ,dashed-slur)
 419             (define decrescendo ,decrescendo)
 420
 421             (define end-output ,end-output)
 422             (define font-def ,font-def)
 423             (define font-switch ,font-switch)
 424             (define generalmeter ,generalmeter)
 425             (define header-end ,header-end)
 426             (define lily-def ,lily-def)
 427             (define header ,header)
 428             (define invoke-char ,invoke-char)
 429             (define invoke-dim1 ,invoke-dim1)
 430             (define placebox ,placebox)
 431             (define rulesym ,rulesym)
 432             (define start-line ,start-line)
 433             (define stem ,stem)
 434             (define stop-line ,stop-line)
 435             (define text ,text)
 436             ))
 437         ((eq? action-name 'tuplet) tuplet)
 438         ((eq? action-name 'beam) beam)
 439         ((eq? action-name 'bracket) bracket)
 440         ((eq? action-name 'crescendo) crescendo)
 441         ((eq? action-name 'volta) volta)
 442         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 443         ((eq? action-name 'dashed-slur) dashed-slur)
 444         ((eq? action-name 'decrescendo) decrescendo)
 445         (else (error "unknown tag -- PS-SCM " action-name))
 446         )
 447   )
 448
 449
 450 ;
 451 ; Russ McManus, <mcmanus@IDT.NET>
 452 ;
 453 ; I use the following, which should definitely be provided somewhere
 454 ; in guile, but isn't, AFAIK:
 455 ;
 456 ;
 457
 458 (define (hash-table-for-each fn ht)
 459   (do ((i 0 (+ 1 i)))
 460       ((= i (vector-length ht)))
 461     (do ((alist (vector-ref ht i) (cdr alist)))
 462         ((null? alist) #t)
 463       (fn (car (car alist)) (cdr (car alist))))))
 464
 465 (define (hash-table-map fn ht)
 466   (do ((i 0 (+ 1 i))
 467        (ret-ls '()))
 468       ((= i (vector-length ht)) (reverse ret-ls))
 469     (do ((alist (vector-ref ht i) (cdr alist)))
 470         ((null? alist) #t)
 471       (set! ret-ls (cons (fn (car (car alist)) (cdr (car alist))) ret-ls)))))
 472