scm/lily.scm

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