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