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