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--2000 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9 ;;;
  10 ;;; This file contains various routines in Scheme that are easier to
  11 ;;; do here than in C++.  At present it is an unorganised mess. Sorry.
  12
  13
  14 ;;; We should repartition the entire scm side of lily in a
  15 ;;; more sane way, using namesspaces/modules?
  16
  17 (debug-enable 'backtrace)
  18
  19
  20 (define point-and-click #f)
  21
  22 ;;; library funtions
  23
  24 (use-modules (ice-9 regex))
  25
  26 (define (number-pair?  x)
  27   (and (pair? x) (number? (car x)) (number? (cdr x))))
  28 (define (boolean-or-symbol? x) (or boolean? x) (or symbol? x))
  29 (define (number-or-string? x) (or (number? x) (string? x)))
  30 (define markup?
  31   (lambda (x) (or (string? x) (list? x))))
  32
  33
  34
  35 ;; ugh: code dup ; merge.
  36 (define (object-type obj)
  37   (cond
  38    ((dir? obj) "direction")
  39    ((number-pair? obj) "pair of numbers")
  40    ((ly-input-location? obj) "input location")
  41    ((ly-grob? obj) "graphic element")
  42    ((pair? obj) "pair")
  43    ((integer? obj) "integer")
  44    ((list? obj) "list")
  45    ((symbol? obj) "symbol")
  46    ((string? obj) "string")
  47    ((boolean? obj) "boolean")
  48    ((moment? obj) "moment")
  49    ((number? obj) "number")
  50    ((char? obj) "char")
  51    ((input-port? obj) "input port")
  52    ((output-port? obj) "output port")
  53    ((vector? obj) "vector")
  54    ((procedure? obj) "procedure")
  55    (else "unknown type")
  56   ))
  57
  58
  59 (define (type-name  predicate)
  60   (cond
  61    ((eq? predicate dir?) "direction")
  62    ((eq? predicate number-pair?) "pair of numbers")
  63    ((eq? predicate ly-input-location?) "input location")
  64    ((eq? predicate ly-grob?) "graphic element")
  65    ((eq? predicate pair?) "pair")
  66    ((eq? predicate integer?) "integer")
  67    ((eq? predicate list?) "list")
  68    ((eq? predicate symbol?) "symbol")
  69    ((eq? predicate string?) "string")
  70    ((eq? predicate boolean?) "boolean")
  71    ((eq? predicate moment?) "moment")
  72    ((eq? predicate number?) "number")
  73    ((eq? predicate char?) "char")
  74    ((eq? predicate input-port?) "input port")
  75    ((eq? predicate output-port?) "output port")
  76    ((eq? predicate vector?) "vector")
  77    ((eq? predicate procedure?) "procedure")
  78    (else "unknown type")
  79   ))
  80
  81
  82 (define (uniqued-alist  alist acc)
  83   (if (null? alist) acc
  84       (if (assoc (caar alist) acc)
  85           (uniqued-alist (cdr alist) acc)
  86           (uniqued-alist (cdr alist) (cons (car alist) acc)
  87   ))))
  88
  89
  90 ;; The regex module may not be available, or may be broken.
  91 (define use-regex
  92   (let ((os (string-downcase (vector-ref (uname) 0))))
  93     (not (equal? "cygwin" (substring os 0 (min 6 (string-length os)))))))
  94
  95 ;; If you have trouble with regex, define #f
  96 (define use-regex #t)
  97 ;;(define use-regex #f)
  98
  99 ;; do nothing in .scm output
 100 (define (comment s) "")
 101
 102 ;; URG guile-1.3/1.4 compatibility
 103 (define (ly-eval x) (eval2 x #f))
 104
 105 (define (comment s) "")
 106
 107 (define (mm-to-pt x)
 108   (* (/ 72.27 25.40) x)
 109   )
 110
 111 (define (cons-map f x)
 112   (cons (f (car x)) (f (cdr x))))
 113
 114 (define (reduce operator list)
 115       (if (null? (cdr list)) (car list)
 116           (operator (car list) (reduce operator (cdr list)))
 117           )
 118       )
 119
 120
 121 (define (numbers->string l)
 122   (apply string-append (map ly-number->string l)))
 123
 124 ; (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
 125
 126 (define (number->octal-string x)
 127   (let* ((n (inexact->exact x))
 128          (n64 (quotient n 64))
 129          (n8 (quotient (- n (* n64 64)) 8)))
 130     (string-append
 131      (number->string n64)
 132      (number->string n8)
 133      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 134
 135 (define (inexact->string x radix)
 136   (let ((n (inexact->exact x)))
 137     (number->string n radix)))
 138
 139
 140 (define (control->string c)
 141   (string-append (number->string (car c)) " "
 142                  (number->string (cdr c)) " "))
 143
 144 (define (font i)
 145   (string-append
 146    "font"
 147    (make-string 1 (integer->char (+ (char->integer #\A) i)))
 148    ))
 149
 150 (define (scm-scm action-name)
 151   1)
 152
 153 (define security-paranoia #f)
 154
 155
 156 ;; silly, use alist?
 157 (define (find-notehead-symbol duration style)
 158   (case style
 159    ((cross) "2cross")
 160    ((harmonic) "0mensural")
 161    ((baroque)
 162     (string-append (number->string duration)
 163                    (if (< duration 0) "mensural" "")))
 164    ((default) (number->string duration))
 165    (else
 166     (string-append (number->string duration) (symbol->string style))))
 167   )
 168
 169
 170 ;;;;;;;; TeX
 171
 172 (define (string-encode-integer i)
 173   (cond
 174    ((= i  0) "o")
 175    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 176    (else (string-append
 177           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 178           (string-encode-integer (quotient i 26))
 179           ))
 180    )
 181   )
 182
 183 (define default-script-alist '())
 184
 185 (define font-name-alist  '())
 186 (define (tex-encoded-fontswitch name-mag)
 187   (let* (
 188          (iname-mag (car name-mag))
 189          (ename-mag (cdr name-mag))
 190          )
 191     (cons iname-mag
 192           (cons ename-mag
 193                 (string-append  "magfont"
 194                           (string-encode-integer
 195                            (hashq (car ename-mag) 1000000))
 196                           "m"
 197                           (string-encode-integer
 198                            (inexact->exact (* 1000 (cdr ename-mag))))
 199
 200                           )
 201                 )
 202     )))
 203
 204 (define (define-fonts internal-external-name-mag-pairs)
 205   (set! font-name-alist (map tex-encoded-fontswitch
 206                              internal-external-name-mag-pairs))
 207   (apply string-append
 208          (map (lambda (x)
 209                 (font-load-command (car x) (cdr x)))
 210               (map cdr font-name-alist)
 211
 212   )))
 213
 214 (define (fontify name-mag-pair exp)
 215   (string-append (select-font name-mag-pair)
 216                  exp)
 217   )
 218
 219 ;;;;;;;;;;;;;;;;;;;;
 220
 221
 222 ; Make a function that checks score element for being of a specific type.
 223 (define (make-type-checker symbol)
 224   (lambda (elt)
 225     ;;(display  symbol)
 226     ;;(eq? #t (ly-get-elt-property elt symbol))
 227     (not (eq? #f (memq symbol (ly-get-elt-property elt 'interfaces))))
 228     ))
 229
 230 ;;;;;;;;;;;;;;;;;;; TeX output
 231 (define (tex-scm action-name)
 232   (define (unknown)
 233     "%\n\\unknown%\n")
 234
 235
 236   (define (select-font name-mag-pair)
 237     (let*
 238         (
 239          (c (assoc name-mag-pair font-name-alist))
 240          )
 241
 242       (if (eq? c #f)
 243           (begin
 244             (display "FAILED\n")
 245             (display (object-type (car name-mag-pair)))
 246             (display (object-type (caaar font-name-alist)))
 247
 248             (ly-warn (string-append
 249                       "Programming error: No such font known "
 250                       (car name-mag-pair) " "
 251                       (number->string (cdr name-mag-pair))
 252                       ))
 253             "") ; issue no command
 254           (string-append "\\" (cddr c)))
 255
 256
 257       ))
 258
 259   (define (beam width slope thick)
 260     (embedded-ps ((ps-scm 'beam) width slope thick)))
 261
 262   (define (bracket arch_angle arch_width arch_height width height arch_thick thick)
 263     (embedded-ps ((ps-scm 'bracket) arch_angle arch_width arch_height width height arch_thick thick)))
 264
 265   (define (dashed-slur thick dash l)
 266     (embedded-ps ((ps-scm 'dashed-slur)  thick dash l)))
 267
 268   (define (crescendo thick w h cont)
 269     (embedded-ps ((ps-scm 'crescendo) thick w h cont)))
 270
 271   (define (char i)
 272     (string-append "\\char" (inexact->string i 10) " "))
 273
 274   (define (dashed-line thick on off dx dy)
 275     (embedded-ps ((ps-scm 'dashed-line) thick on off dx dy)))
 276
 277   (define (decrescendo thick w h cont)
 278     (embedded-ps ((ps-scm 'decrescendo) thick w h cont)))
 279
 280   (define (font-load-command name-mag command)
 281     (string-append
 282      "\\font\\" command "="
 283      (car name-mag)
 284      " scaled "
 285      (number->string (inexact->exact (* 1000  (cdr name-mag))))
 286      "\n"))
 287
 288   (define (embedded-ps s)
 289     (string-append "\\embeddedps{" s "}"))
 290
 291   (define (comment s)
 292     (string-append "% " s))
 293
 294   (define (end-output)
 295         (begin
 296 ; uncomment for some stats about lily memory
 297 ;               (display (gc-stats))
 298     (string-append "\n\\EndLilyPondOutput"
 299                    ; Put GC stats here.
 300                    )))
 301
 302   (define (experimental-on)
 303     "")
 304
 305   (define (font-switch i)
 306     (string-append
 307      "\\" (font i) "\n"))
 308
 309   (define (font-def i s)
 310     (string-append
 311      "\\font" (font-switch i) "=" s "\n"))
 312
 313   (define (header-end)
 314     (string-append
 315      "\\special{! "
 316
 317      ;; URG: ly-gulp-file: now we can't use scm output without Lily
 318      (if use-regex
 319          ;; fixed in 1.3.4 for powerpc -- broken on Windows
 320          (regexp-substitute/global #f "\n"
 321                                    (ly-gulp-file "lily.ps") 'pre " %\n" 'post)
 322          (ly-gulp-file "lily.ps"))
 323      "}"
 324      "\\input lilyponddefs\\newdimen\\outputscale \\outputscale=\\lilypondpaperoutputscale pt\\turnOnPostScript"))
 325
 326   (define (header creator generate)
 327     (string-append
 328      "%created by: " creator generate "\n"))
 329
 330   (define (invoke-char s i)
 331     (string-append
 332      "\n\\" s "{" (inexact->string i 10) "}" ))
 333
 334   (define (invoke-dim1 s d)
 335     (string-append
 336      "\n\\" s "{" (number->dim d) "}"))
 337   (define (pt->sp x)
 338     (* 65536 x))
 339
 340   ;;
 341   ;; need to do something to make this really safe.
 342   ;;
 343   (define (output-tex-string s)
 344       (if security-paranoia
 345           (if use-regex
 346               (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post)
 347               (begin (display "warning: not paranoid") (newline) s))
 348           s))
 349
 350   (define (lily-def key val)
 351     (string-append
 352      "\\def\\"
 353      (if use-regex
 354          ;; fixed in 1.3.4 for powerpc -- broken on Windows
 355          (regexp-substitute/global #f "_"
 356                                    (output-tex-string key) 'pre "X" 'post)
 357          (output-tex-string key))
 358      "{" (output-tex-string val) "}\n"))
 359
 360   (define (number->dim x)
 361     (string-append
 362      (ly-number->string x) " \\outputscale "))
 363
 364   (define (placebox x y s)
 365     (string-append
 366      "\\placebox{"
 367      (number->dim y) "}{" (number->dim x) "}{" s "}\n"))
 368
 369   (define (bezier-sandwich l thick)
 370     (embedded-ps ((ps-scm 'bezier-sandwich) l thick)))
 371
 372   (define (start-line ht)
 373       (string-append"\\vbox to " (number->dim ht) "{\\hbox{%\n"))
 374
 375   (define (stop-line)
 376     "}\\vss}\\interscoreline\n")
 377   (define (stop-last-line)
 378     "}\\vss}")
 379   (define (filledbox breapth width depth height)
 380     (string-append
 381      "\\kern" (number->dim (- breapth))
 382      "\\vrule width " (number->dim (+ breapth width))
 383      "depth " (number->dim depth)
 384      "height " (number->dim height) " "))
 385
 386   (define (text s)
 387     (string-append "\\hbox{" (output-tex-string s) "}"))
 388
 389   (define (tuplet ht gapx dx dy thick dir)
 390     (embedded-ps ((ps-scm 'tuplet) ht gapx dx dy thick dir)))
 391
 392   (define (volta h w thick vert_start vert_end)
 393     (embedded-ps ((ps-scm 'volta) h w thick vert_start vert_end)))
 394
 395   (define (define-origin file line col)
 396     ; use this for column positions
 397     (if point-and-click
 398      (string-append "\\special{src:" (number->string line) ":"
 399         (number->string col) " " file "}"
 400          ;; arg, the clueless take over the mailing list...
 401 ;        "\\special{-****-These-warnings-are-harmless-***}"
 402 ;        "\\special{-****-PLEASE-read-http://appel.lilypond.org/wiki/index.php3?PostProcessing-****}"
 403         )
 404      "")
 405
 406      ; line numbers only:
 407     ;(string-append "\\special{src:" (number->string line) " " file "}")
 408 )
 409
 410   ; no-origin not yet supported by Xdvi
 411   (define (no-origin) "")
 412
 413   ;; TeX
 414   ;; The procedures listed below form the public interface of TeX-scm.
 415   ;; (should merge the 2 lists)
 416   (cond ((eq? action-name 'all-definitions)
 417          `(begin
 418             (define font-load-command ,font-load-command)
 419             (define beam ,beam)
 420             (define bezier-sandwich ,bezier-sandwich)
 421             (define bracket ,bracket)
 422             (define char ,char)
 423             (define crescendo ,crescendo)
 424             (define dashed-line ,dashed-line)
 425             (define dashed-slur ,dashed-slur)
 426             (define decrescendo ,decrescendo)
 427             (define end-output ,end-output)
 428             (define experimental-on ,experimental-on)
 429             (define filledbox ,filledbox)
 430             (define font-def ,font-def)
 431             (define font-switch ,font-switch)
 432             (define header-end ,header-end)
 433             (define lily-def ,lily-def)
 434             (define header ,header)
 435             (define invoke-char ,invoke-char)
 436             (define invoke-dim1 ,invoke-dim1)
 437             (define placebox ,placebox)
 438             (define select-font ,select-font)
 439             (define start-line ,start-line)
 440             (define stop-line ,stop-line)
 441             (define stop-last-line ,stop-last-line)
 442             (define text ,text)
 443             (define tuplet ,tuplet)
 444             (define volta ,volta)
 445             (define define-origin ,define-origin)
 446             (define no-origin ,no-origin)
 447             ))
 448
 449         ((eq? action-name 'beam) beam)
 450         ((eq? action-name 'tuplet) tuplet)
 451         ((eq? action-name 'bracket) bracket)
 452         ((eq? action-name 'crescendo) crescendo)
 453         ((eq? action-name 'dashed-line) dashed-line)
 454         ((eq? action-name 'dashed-slur) dashed-slur)
 455         ((eq? action-name 'decrescendo) decrescendo)
 456         ((eq? action-name 'end-output) end-output)
 457         ((eq? action-name 'experimental-on) experimental-on)
 458         ((eq? action-name 'font-def) font-def)
 459         ((eq? action-name 'font-switch) font-switch)
 460         ((eq? action-name 'header-end) header-end)
 461         ((eq? action-name 'lily-def) lily-def)
 462         ((eq? action-name 'header) header)
 463         ((eq? action-name 'invoke-char) invoke-char)
 464         ((eq? action-name 'invoke-dim1) invoke-dim1)
 465         ((eq? action-name 'placebox) placebox)
 466         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 467         ((eq? action-name 'start-line) start-line)
 468         ((eq? action-name 'stem) stem)
 469         ((eq? action-name 'stop-line) stop-line)
 470         ((eq? action-name 'stop-last-line) stop-last-line)
 471         ((eq? action-name 'volta) volta)
 472         (else (error "unknown tag -- PS-TEX " action-name))
 473         )
 474   )
 475
 476
 477 ;;;;;;;;;;;; PS
 478 (define (ps-scm action-name)
 479
 480   ;; alist containing fontname -> fontcommand assoc (both strings)
 481   (define font-alist '())
 482   (define font-count 0)
 483   (define current-font "")
 484
 485
 486   (define (cached-fontname i)
 487     (string-append
 488      "lilyfont"
 489      (make-string 1 (integer->char (+ 65 i)))))
 490
 491
 492   (define (select-font name-mag-pair)
 493     (let*
 494         (
 495          (c (assoc name-mag-pair font-name-alist))
 496          )
 497
 498       (if (eq? c #f)
 499           (begin
 500             (display name-mag-pair)
 501             (display font-name-alist)
 502             (ly-warn (string-append
 503                       "Programming error: No such font known " (car name-mag-pair))
 504                      (number->string (cdr name-mag-pair))
 505                      )
 506
 507             "")                         ; issue no command
 508           (string-append " " (cdr c) " "))
 509       ))
 510
 511     (define (font-load-command name-mag command)
 512       (string-append
 513        "/" command
 514        " { /"
 515        (symbol->string (car name-mag))
 516        " findfont "
 517        (number->string (cdr name-mag))
 518        " 1000 div 12 mul  scalefont setfont } bind def "
 519        "\n"))
 520
 521
 522   (define (beam width slope thick)
 523     (string-append
 524      (numbers->string (list width slope thick)) " draw_beam" ))
 525
 526   (define (comment s)
 527     (string-append "% " s))
 528
 529   (define (bracket arch_angle arch_width arch_height width height arch_thick thick)
 530     (string-append
 531      (numbers->string (list arch_angle arch_width arch_height width height arch_thick thick)) " draw_bracket" ))
 532
 533   (define (char i)
 534     (invoke-char " show" i))
 535
 536   (define (crescendo thick w h cont )
 537     (string-append
 538      (numbers->string (list w h (inexact->exact cont) thick))
 539      " draw_crescendo"))
 540
 541   ;; what the heck is this interface ?
 542   (define (dashed-slur thick dash l)
 543     (string-append
 544      (apply string-append (map control->string l))
 545      (number->string thick)
 546      " [ "
 547      (number->string dash)
 548      " "
 549      (number->string (* 10 thick))      ;UGH.  10 ?
 550      " ] 0 draw_dashed_slur"))
 551
 552   (define (dashed-line thick on off dx dy)
 553     (string-append
 554      (number->string dx)
 555      " "
 556      (number->string dy)
 557      " "
 558      (number->string thick)
 559      " [ "
 560      (number->string on)
 561      " "
 562      (number->string off)
 563      " ] 0 draw_dashed_line"))
 564
 565   (define (decrescendo thick w h cont)
 566     (string-append
 567      (numbers->string (list w h (inexact->exact cont) thick))
 568      " draw_decrescendo"))
 569
 570
 571   (define (end-output)
 572     "\nshowpage\n")
 573
 574   (define (experimental-on) "")
 575
 576   (define (filledbox breapth width depth height)
 577     (string-append (numbers->string (list breapth width depth height))
 578                    " draw_box" ))
 579
 580   ;; obsolete?
 581   (define (font-def i s)
 582     (string-append
 583      "\n/" (font i) " {/"
 584      (substring s 0 (- (string-length s) 4))
 585      " findfont 12 scalefont setfont} bind def \n"))
 586
 587   (define (font-switch i)
 588     (string-append (font i) " "))
 589
 590   (define (header-end)
 591     (string-append
 592      ;; URG: now we can't use scm output without Lily
 593      (ly-gulp-file "lilyponddefs.ps")
 594      " {exch pop //systemdict /run get exec} "
 595      (ly-gulp-file "lily.ps")
 596      "{ exch pop //systemdict /run get exec } "
 597     ))
 598
 599   (define (lily-def key val)
 600
 601      (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
 602          (string-append "/" key " {" val "} bind def\n")
 603          (string-append "/" key " (" val ") def\n")
 604          )
 605      )
 606
 607   (define (header creator generate)
 608     (string-append
 609      "%!PS-Adobe-3.0\n"
 610      "%%Creator: " creator generate "\n"))
 611
 612   (define (invoke-char s i)
 613     (string-append
 614      "(\\" (inexact->string i 8) ") " s " " ))
 615
 616   (define (invoke-dim1 s d)
 617     (string-append
 618      (number->string (* d  (/ 72.27 72))) " " s ))
 619
 620   (define (placebox x y s)
 621     (string-append
 622      (number->string x) " " (number->string y) " {" s "} placebox "))
 623
 624   (define (bezier-sandwich l thick)
 625     (string-append
 626      (apply string-append (map control->string l))
 627      (number->string  thick)
 628      " draw_bezier_sandwich"))
 629
 630   (define (start-line height)
 631           "\nstart_line {\n")
 632
 633   (define (stem breapth width depth height)
 634     (string-append (numbers->string (list breapth width depth height))
 635                    " draw_box" ))
 636
 637   (define (stop-line)
 638       "}\nstop_line\n")
 639
 640   (define (text s)
 641     (string-append "(" s ") show  "))
 642
 643
 644   (define (volta h w thick vert_start vert_end)
 645     (string-append
 646      (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 647      " draw_volta"))
 648
 649   (define (tuplet ht gap dx dy thick dir)
 650     (string-append
 651      (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 652      " draw_tuplet"))
 653
 654
 655   (define (unknown)
 656     "\n unknown\n")
 657
 658
 659   (define (define-origin a b c ) "")
 660   (define (no-origin) "")
 661
 662   ;; PS
 663   (cond ((eq? action-name 'all-definitions)
 664          `(begin
 665             (define beam ,beam)
 666             (define tuplet ,tuplet)
 667             (define bracket ,bracket)
 668             (define char ,char)
 669             (define crescendo ,crescendo)
 670             (define volta ,volta)
 671             (define bezier-sandwich ,bezier-sandwich)
 672             (define dashed-line ,dashed-line)
 673             (define dashed-slur ,dashed-slur)
 674             (define decrescendo ,decrescendo)
 675             (define end-output ,end-output)
 676             (define experimental-on ,experimental-on)
 677             (define filledbox ,filledbox)
 678             (define font-def ,font-def)
 679             (define font-switch ,font-switch)
 680             (define header-end ,header-end)
 681             (define lily-def ,lily-def)
 682             (define font-load-command ,font-load-command)
 683             (define header ,header)
 684             (define invoke-char ,invoke-char)
 685             (define invoke-dim1 ,invoke-dim1)
 686             (define placebox ,placebox)
 687             (define select-font ,select-font)
 688             (define start-line ,start-line)
 689             (define stem ,stem)
 690             (define stop-line ,stop-line)
 691             (define stop-last-line ,stop-line)
 692             (define text ,text)
 693             (define no-origin ,no-origin)
 694             (define define-origin ,define-origin)
 695             ))
 696         ((eq? action-name 'tuplet) tuplet)
 697         ((eq? action-name 'beam) beam)
 698         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 699         ((eq? action-name 'bracket) bracket)
 700         ((eq? action-name 'char) char)
 701         ((eq? action-name 'crescendo) crescendo)
 702         ((eq? action-name 'dashed-line) dashed-line)
 703         ((eq? action-name 'dashed-slur) dashed-slur)
 704         ((eq? action-name 'decrescendo) decrescendo)
 705         ((eq? action-name 'experimental-on) experimental-on)
 706         ((eq? action-name 'filledbox) filledbox)
 707         ((eq? action-name 'select-font) select-font)
 708         ((eq? action-name 'volta) volta)
 709         (else (error "unknown tag -- PS-SCM " action-name))
 710         )
 711   )
 712
 713
 714 (define (arg->string arg)
 715   (cond ((number? arg) (inexact->string arg 10))
 716         ((string? arg) (string-append "\"" arg "\""))
 717         ((symbol? arg) (string-append "\"" (symbol->string arg) "\""))))
 718
 719 ; ugh: naming.
 720 (define (func name . args)
 721   (string-append
 722    "(" name
 723    (if (null? args)
 724        ""
 725        (apply string-append
 726               (map (lambda (x) (string-append " " (arg->string x))) args)))
 727    ")\n"))
 728
 729 (define (sign x)
 730   (if (= x 0)
 731       1
 732       (if (< x 0) -1 1)))
 733
 734 (define (gulp-file name)
 735   (let* ((file (open-input-file name))
 736          (text (read-delimited "" file)))
 737     (close file)
 738     text))
 739
 740 ;; urg: Use when standalone, do:
 741 ;; (define ly-gulp-file scm-gulp-file)
 742 (define (scm-gulp-file name)
 743   (set! %load-path
 744         (cons (string-append (getenv 'LILYPONDPREFIX) "/ly")
 745               (cons (string-append (getenv 'LILYPONDPREFIX) "/ps")
 746                     %load-path)))
 747   (let ((path (%search-load-path name)))
 748        (if path
 749            (gulp-file path)
 750            (gulp-file name))))
 751
 752 (define (scm-tex-output)
 753   (ly-eval (tex-scm 'all-definitions)))
 754
 755 (define (scm-ps-output)
 756   (ly-eval (ps-scm 'all-definitions)))
 757
 758 (define (scm-as-output)
 759   (ly-eval (as-scm 'all-definitions)))
 760
 761 (define (index-cell cell dir)
 762   (if (equal? dir 1)
 763       (cdr cell)
 764       (car cell)))
 765
 766 (define major-scale
 767   '(
 768     (0 . 0)
 769     (1 . 0)
 770     (2 . 0)
 771     (3 . 0)
 772     (4 . 0)
 773     (5 . 0)
 774     (6 . 0)
 775     )
 776   )
 777
 778
 779
 780 ;;
 781 ;; (name . (glyph clef-position octavation))
 782 ;; -- the name clefOctavation is misleading the value 7 is 1 octave not 7 Octaves.
 783 ;;
 784 (define supported-clefs '(
 785           ("treble" . ("clefs-G" -2 0))
 786           ("violin" . ("clefs-G" -2 0))
 787           ("G" . ("clefs-G" -2 0))
 788           ("G2" . ("clefs-G" -2 0))
 789           ("french" . ("clefs-G" -4  0))
 790           ("soprano" . ("clefs-C" -4  0))
 791           ("mezzosoprano" . ("clefs-C" -2  0))
 792           ("alto" . ("clefs-C" 0 0))
 793           ("tenor" . ("clefs-C" 2 0))
 794           ("baritone" . ("clefs-C" 4  0))
 795           ("varbaritone"  . ("clefs-F" 0 0))
 796           ("bass" . ("clefs-F" 2  0))
 797           ("F" . ( "clefs-F" 2 0))
 798           ("subbass" . ("clefs-F" 4 0))
 799
 800           ;; should move mensural stuff to separate file?
 801           ("vaticana_do1" . ("clefs-vaticana_do" -1 0))
 802           ("vaticana_do2" . ("clefs-vaticana_do" 1 0))
 803           ("vaticana_do3" . ("clefs-vaticana_do" 3 0))
 804           ("vaticana_fa1" . ("clefs-vaticana_fa" -1 0))
 805           ("vaticana_fa2" . ("clefs-vaticana_fa" 1 0))
 806           ("medicaea_do1" . ("clefs-medicaea_do" -1 0))
 807           ("medicaea_do2" . ("clefs-medicaea_do" 1 0))
 808           ("medicaea_do3" . ("clefs-medicaea_do" 3 0))
 809           ("medicaea_fa1" . ("clefs-medicaea_fa" -1 0))
 810           ("medicaea_fa2" . ("clefs-medicaea_fa" 1 0))
 811           ("hufnagel_do1" . ("clefs-hufnagel_do" -1 0))
 812           ("hufnagel_do2" . ("clefs-hufnagel_do" 1 0))
 813           ("hufnagel_do3" . ("clefs-hufnagel_do" 3 0))
 814           ("hufnagel_fa1" . ("clefs-hufnagel_fa" -1 0))
 815           ("hufnagel_fa2" . ("clefs-hufnagel_fa" 1 0))
 816           ("hufnagel" . ("clefs-hufnagel_do_fa" 4 0))
 817           ("mensural1_c1" . ("clefs-mensural1_c" -4 0))
 818           ("mensural1_c2" . ("clefs-mensural1_c" -2 0))
 819           ("mensural1_c3" . ("clefs-mensural1_c" 0 0))
 820           ("mensural1_c4" . ("clefs-mensural1_c" 2 0))
 821           ("mensural2_c1" . ("clefs-mensural2_c" -4 0))
 822           ("mensural2_c2" . ("clefs-mensural2_c" -2 0))
 823           ("mensural2_c3" . ("clefs-mensural2_c" 0 0))
 824           ("mensural2_c4" . ("clefs-mensural2_c" 2 0))
 825           ("mensural2_c5" . ("clefs-mensural2_c" 4 0))
 826           ("mensural3_c1" . ("clefs-mensural3_c" -2 0))
 827           ("mensural3_c2" . ("clefs-mensural3_c" 0 0))
 828           ("mensural3_c3" . ("clefs-mensural3_c" 2 0))
 829           ("mensural3_c4" . ("clefs-mensural3_c" 4 0))
 830           ("mensural_f" . ("clefs-mensural_f" 2 0))
 831         )
 832 )
 833
 834 (define (clef-name-to-properties cl)
 835   (let ((e '())
 836         (oct 0)
 837         (l (string-length cl))
 838         )
 839
 840     ;; ugh. cleanme
 841     (if (equal? "8" (substring cl (- l 1) l))
 842         (begin
 843         (if (equal? "^" (substring cl (- l 2) (- l 1)))
 844             (set! oct 7)
 845             (set! oct -7))
 846
 847         (set! cl (substring cl 0 (- l 2)))))
 848
 849
 850     (set! e  (assoc cl supported-clefs))
 851     (if (pair? e)
 852         `(((symbol . clefGlyph)
 853            (iterator-ctor . ,Property_iterator::constructor)
 854            (value . ,(cadr e))
 855            )
 856           ((symbol . clefPosition)
 857            (iterator-ctor . ,Property_iterator::constructor)
 858            (value . ,(caddr e))
 859            )
 860           ,(if (not (equal? oct 0))
 861                `((symbol . clefOctavation)
 862                  (iterator-ctor . ,Property_iterator::constructor)
 863                  (value . ,oct)
 864                ))
 865           )
 866         (begin
 867           (ly-warn (string-append "Unknown clef type `" cl "'\nSee scm/lily.scm for supported clefs"))
 868           '())
 869     )))
 870
 871
 872
 873 (define (repeat-name-to-ctor name)
 874   (let*
 875       ((supported-reps
 876         `(("volta" . ((iterator-ctor . ,Volta_repeat_iterator::constructor)
 877                       (length . ,Repeated_music::volta_music_length)
 878                       ))
 879           ("unfold" . ((iterator-ctor . ,Unfolded_repeat_iterator::constructor)
 880                        (length . ,Repeated_music::unfolded_music_length)
 881                        ))
 882           ("fold" . ((iterator-ctor  . ,Folded_repeat_iterator::constructor)
 883                       (length . ,Repeated_music::folded_music_length)
 884                       ))
 885           ("tremolo" . ((iterator-ctor . ,Chord_tremolo_iterator::constructor)
 886                         (length . ,Repeated_music::unfolded_music_length)
 887                         ))
 888           ))
 889
 890        (handle (assoc name supported-reps))
 891        )
 892
 893     (if (pair? handle)
 894         (cdr handle)
 895         (begin
 896           (ly-warn
 897            (string-append "Unknown repeat type `" name "'\nSee scm/lily.scm for supported repeats")
 898            )
 899           '(type . 'repeated-music))
 900         )
 901   ))
 902
 903
 904 (map (lambda (x)   (eval-string (ly-gulp-file x)))
 905
 906    '("backend-property.scm"
 907  "translator-properties.scm"
 908  "interface.scm"
 909  "beam.scm"
 910  "slur.scm"
 911  "font.scm"
 912  "auto-beam.scm"
 913  "generic-property.scm"
 914  "basic-properties.scm"
 915  "chord-name.scm"
 916  "element-descriptions.scm"
 917  ))