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