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