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 ;(debug-enable 'backtrace)
   9
  10 ;;; library funtions
  11 (define
  12   (xnumbers->string l)
  13   (string-append
  14    (map (lambda (n) (string-append (number->string n ) " ")) l)))
  15
  16 (define
  17   (numbers->string l)
  18   (apply string-append
  19          (map (lambda (n) (string-append (number->string n) " ")) l)))
  20
  21 (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
  22
  23 (define (number->octal-string x)
  24   (let* ((n (inexact->exact x))
  25          (n64 (quotient n 64))
  26          (n8 (quotient (- n (* n64 64)) 8)))
  27     (string-append
  28      (number->string n64)
  29      (number->string n8)
  30      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
  31
  32 (define (inexact->string x radix)
  33   (let ((n (inexact->exact x)))
  34     (number->string n radix)))
  35
  36
  37 (define
  38   (control->string c)
  39   (string-append
  40    (string-append (number->string (car c)) " ")
  41    (string-append (number->string (cadr c)) " ")))
  42
  43
  44 (define
  45   (font i)
  46   (string-append
  47    "font"
  48    (make-string 1 (integer->char (+ (char->integer #\A) i)))
  49    ))
  50
  51
  52
  53 (define (scm-scm action-name)
  54   1)
  55
  56 (define security-paranoia #f)
  57
  58
  59 ;; See documentation of Item::visibility_lambda_
  60 (define (postbreak_only_visibility d) (if (= d 1) '(#f . #f) '(#t . #t)))
  61 (define (non_postbreak_visibility d) (if (= d -1) '(#t . #t) '(#f . #f)))
  62 (define (spanbar_non_postbreak_visibility d) (if (= d -1) '(#t . #t) '(#f . #f)))
  63
  64 ;; Score_span_bars are only visible at start of line
  65 ;; i.e. if break_dir == RIGHT == 1
  66 (define Span_score_bar_visibility postbreak_only_visibility)
  67 (define Piano_bar_visibility postbreak_only_visibility)
  68 (define Staff_group_bar_visibility postbreak_only_visibility)
  69
  70
  71
  72
  73 ;;;;;;;; TeX
  74
  75 (define (tex-scm action-name)
  76
  77   (define (unknown)
  78     "%\n\\unknown%\n")
  79
  80   (define font-alist '())
  81   (define font-count 0)
  82   (define current-font "")
  83   (define (clear-fontcache)
  84     (begin
  85       (set! font-alist '())
  86       (set! font-count 0)
  87       (set! current-font "")))
  88
  89   (define (cached-fontname i)
  90     (string-append
  91      "\\lilyfont"
  92      (make-string 1 (integer->char (+ 65 i)))))
  93
  94   (define (select-font font-name)
  95       (if (not (equal? font-name current-font))
  96           (begin
  97             (set! current-font font-name)
  98             (define font-cmd (assoc font-name font-alist))
  99             (if (eq? font-cmd #f)
 100                 (begin
 101                   (set! font-cmd (cached-fontname font-count))
 102                   (set! font-alist (acons font-name font-cmd font-alist))
 103                   (set! font-count (+ 1 font-count))
 104                   (string-append "\\font" font-cmd "=" font-name font-cmd))
 105                 (cdr font-cmd)))
 106           ""                            ;no switch needed
 107           ))
 108
 109   (define (beam width slope thick)
 110     (embedded-ps ((ps-scm 'beam) width slope thick)))
 111
 112   (define (bracket h)
 113     (embedded-ps ((ps-scm 'bracket) h)))
 114
 115   (define (dashed-slur thick dash l)
 116     (embedded-ps ((ps-scm 'dashed-slur)  thick dash l)))
 117
 118   (define (crescendo w h cont)
 119     (embedded-ps ((ps-scm 'crescendo) w h cont)))
 120
 121   (define (char i)
 122     (string-append "\\show{" (inexact->string i 10) "}"))
 123
 124   (define (decrescendo w h cont)
 125     (embedded-ps ((ps-scm 'decrescendo) w h cont)))
 126
 127   (define (embedded-ps s)
 128     (string-append "\\embeddedps{" s "}"))
 129
 130   (define (end-output)
 131     "\n\\EndLilyPondOutput")
 132
 133   (define (experimental-on)
 134     "\\turnOnExperimentalFeatures")
 135
 136   (define (font-switch i)
 137     (string-append
 138      "\\" (font i) "\n"))
 139
 140   (define (font-def i s)
 141     (string-append
 142      "\\font" (font-switch i) "=" s "\n"))
 143
 144   (define (generalmeter num den)
 145     (string-append
 146      "\\generalmeter{" (number->string (inexact->exact num)) "}{" (number->string (inexact->exact den)) "}"))
 147
 148   (define (header-end) "\\turnOnPostScript")
 149
 150   (define (header creator generate)
 151     (string-append
 152      "%created by: " creator generate "\n"))
 153
 154   (define (invoke-char s i)
 155     (string-append
 156      "\n\\" s "{" (inexact->string i 10) "}" ))
 157
 158   (define (invoke-dim1 s d)
 159     (string-append
 160      "\n\\" s "{" (number->dim d) "}"))
 161   (define (pt->sp x)
 162     (* 65536 x))
 163
 164   ;;
 165   ;; need to do something to make this really safe.
 166   ;;
 167   (if security-paranoia
 168       (define (output-tex-string s)
 169         (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post))
 170       (define (output-tex-string s)    s))
 171
 172   (define (lily-def key val)
 173     (string-append
 174      "\\def\\" (output-tex-string key) "{" (output-tex-string val) "}\n"))
 175
 176   (define (number->dim x)
 177     (string-append
 178      (number->string  (chop-decimal x)) "pt "))
 179
 180   (define (placebox x y s)
 181     (string-append
 182      "\\placebox{"
 183      (number->dim y) "}{" (number->dim x) "}{" s "}"))
 184
 185   (define (pianobrace y)
 186     (define step 1.0)
 187     (define minht (* 2 mudelapaperstaffheight))
 188     (define maxht (* 7 minht))
 189     (string-append
 190      "{\\bracefont " (char (max
 191                             0
 192                             (/  (- (min y (- maxht step)) minht) step))) "}"))
 193
 194
 195
 196   (define (rulesym h w)
 197     (string-append
 198      "\\vrule height " (number->dim (/ h 2))
 199      " depth " (number->dim (/ h 2))
 200      " width " (number->dim w)
 201      )
 202     )
 203
 204   (define (bezier-sandwich l)
 205     (embedded-ps ((ps-scm 'bezier-sandwich) l)))
 206
 207
 208   (define (start-line)
 209     (begin
 210       (clear-fontcache)
 211       "\\hbox{%\n")
 212     )
 213
 214   (define (filledbox breapth width depth height)
 215     (string-append
 216      "\\kern" (number->dim (- breapth))
 217      "\\vrule width " (number->dim (+ breapth width))
 218      "depth " (number->dim depth)
 219      "height " (number->dim height) " "))
 220
 221   (define (stop-line)
 222     "}\\interscoreline")
 223
 224
 225   (define (text s)
 226     (string-append "\\hbox{" (output-tex-string s) "}"))
 227
 228   (define (tuplet dx dy thick dir)
 229     (embedded-ps ((ps-scm 'tuplet) dx dy thick dir)))
 230
 231   (define (volta w thick last)
 232     (embedded-ps ((ps-scm 'volta) w thick last)))
 233
 234   ;; TeX
 235   ;; The procedures listed below form the public interface of TeX-scm.
 236   ;; (should merge the 2 lists)
 237   (cond ((eq? action-name 'all-definitions)
 238          `(begin
 239             (define beam ,beam)
 240             (define bezier-sandwich ,bezier-sandwich)
 241             (define bracket ,bracket)
 242             (define char ,char)
 243             (define crescendo ,crescendo)
 244             (define dashed-slur ,dashed-slur)
 245             (define decrescendo ,decrescendo)
 246             (define end-output ,end-output)
 247             (define experimental-on ,experimental-on)
 248             (define filledbox ,filledbox)
 249             (define font-def ,font-def)
 250             (define font-switch ,font-switch)
 251             (define generalmeter ,generalmeter)
 252             (define header-end ,header-end)
 253             (define lily-def ,lily-def)
 254             (define header ,header)
 255             (define invoke-char ,invoke-char)
 256             (define invoke-dim1 ,invoke-dim1)
 257             (define pianobrace ,pianobrace)
 258             (define placebox ,placebox)
 259             (define rulesym ,rulesym)
 260             (define select-font ,select-font)
 261             (define start-line ,start-line)
 262             (define stop-line ,stop-line)
 263             (define text ,text)
 264             (define tuplet ,tuplet)
 265             (define volta ,volta)
 266             ))
 267
 268         ((eq? action-name 'beam) beam)
 269         ((eq? action-name 'tuplet) tuplet)
 270         ((eq? action-name 'bracket) bracket)
 271         ((eq? action-name 'crescendo) crescendo)
 272         ((eq? action-name 'dashed-slur) dashed-slur)
 273         ((eq? action-name 'decrescendo) decrescendo)
 274         ((eq? action-name 'end-output) end-output)
 275         ((eq? action-name 'experimental-on) experimental-on)
 276         ((eq? action-name 'font-def) font-def)
 277         ((eq? action-name 'font-switch) font-switch)
 278         ((eq? action-name 'generalmeter) generalmeter)
 279         ((eq? action-name 'header-end) header-end)
 280         ((eq? action-name 'lily-def) lily-def)
 281         ((eq? action-name 'header) header)
 282         ((eq? action-name 'invoke-char) invoke-char)
 283         ((eq? action-name 'invoke-dim1) invoke-dim1)
 284         ((eq? action-name 'placebox) placebox)
 285         ((eq? action-name 'rulesym) rulesym)
 286         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 287         ((eq? action-name 'start-line) start-line)
 288         ((eq? action-name 'stem) stem)
 289         ((eq? action-name 'stop-line) stop-line)
 290         ((eq? action-name 'volta) volta)
 291         (else (error "unknown tag -- PS-TEX " action-name))
 292         )
 293   )
 294
 295 ;;;;;;;;;;;; PS
 296 (define (ps-scm action-name)
 297
 298   (define font-alist '())
 299   (define font-count 0)
 300   (define current-font "")
 301   (define (clear-fontcache)
 302     (begin
 303       (set! font-alist '())
 304       (set! font-count 0)
 305       (set! current-font "")))
 306
 307   (define (cached-fontname i)
 308     (string-append
 309      "lilyfont"
 310      (make-string 1 (integer->char (+ 65 i)))))
 311
 312   (define (select-font font-name)
 313       (if (not (equal? font-name current-font))
 314           (begin
 315             (set! current-font font-name)
 316             (define font-cmd (assoc font-name font-alist))
 317             (if (eq? font-cmd #f)
 318                 (begin
 319                   (set! font-cmd (cached-fontname font-count))
 320                   (set! font-alist (acons font-name font-cmd font-alist))
 321                   (set! font-count (+ 1 font-count))
 322                   (string-append "\n/" font-cmd " {/"
 323                                  font-name
 324                                  " findfont 12 scalefont setfont} bind def\n"
 325                                  font-cmd "\n"))
 326                 (cdr font-cmd)))
 327           ""                            ;no switch needed
 328           ))
 329
 330   (define (beam width slope thick)
 331     (string-append
 332      (numbers->string (list width slope thick)) " draw_beam " ))
 333
 334   (define (bracket h)
 335     (invoke-dim1 "draw_bracket" h))
 336
 337   (define (char i)
 338     (invoke-char "show" i))
 339
 340   (define (crescendo w h cont)
 341     (string-append
 342      (numbers->string (list w h (inexact->exact cont)))
 343      "draw_crescendo"))
 344
 345   (define (dashed-slur thick dash l)
 346     (string-append
 347      (apply string-append (map control->string l))
 348      (number->string thick)
 349      " [ "
 350      (if (> 1 dash) (number->string (- (* thick dash) thick)) "0") " "
 351      (number->string (* 2 thick))
 352      " ] 0 draw_dashed_slur"))
 353
 354   (define (decrescendo w h cont)
 355     (string-append
 356      (numbers->string (list w h (inexact->exact cont)))
 357      "draw_decrescendo"))
 358
 359
 360   (define (end-output)
 361     "\nshowpage\n")
 362
 363   (define (experimental-on) "")
 364
 365   (define (filledbox kern width height depth)
 366     (string-append (numbers->string (list kern width height depth))
 367                    "draw_stem" ))
 368
 369   ;; obsolete?
 370   (define (font-def i s)
 371     (string-append
 372      "\n/" (font i) " {/"
 373      (substring s 0 (- (string-length s) 4))
 374      " findfont 12 scalefont setfont} bind def\n"))
 375
 376   (define (font-switch i)
 377     (string-append (font i) " "))
 378
 379   (define (generalmeter num den)
 380     (string-append (number->string (inexact->exact num)) " " (number->string (inexact->exact den)) " generalmeter "))
 381
 382   (define (header-end) "")
 383   (define (lily-def key val)
 384     (string-append
 385      "/" key " {" val "} bind def\n"))
 386
 387   (define (header creator generate)
 388     (string-append
 389      "%!PS-Adobe-3.0\n"
 390      "%%Creator: " creator generate "\n"))
 391
 392   (define (invoke-char s i)
 393     (string-append
 394      "(\\" (inexact->string i 8) ") " s " " ))
 395
 396   (define (invoke-dim1 s d)
 397     (string-append
 398      (number->string (* d  (/ 72.27 72))) " " s ))
 399
 400   (define (placebox x y s)
 401     (string-append
 402      (number->string x) " " (number->string y) " {" s "} placebox "))
 403
 404   (define (rulesym x y)
 405     (string-append
 406      (number->string x) " "
 407      (number->string y) " "
 408      "rulesym"))
 409
 410   (define (bezier-sandwich l)
 411     (string-append
 412      (apply string-append (map control->string l))
 413      " draw_bezier_sandwich"))
 414
 415   (define (start-line)
 416     (begin
 417       (clear-fontcache)
 418       "\nstart_line {\n"))
 419
 420   (define (stem kern width height depth)
 421     (string-append (numbers->string (list kern width height depth))
 422                    "draw_stem" ))
 423
 424   (define (stop-line)
 425       "}\nstop_line\n")
 426
 427   (define (text f s)
 428     (string-append "(" s ") set" f " "))
 429
 430
 431   (define (volta w thick last)
 432     (string-append
 433      (numbers->string (list w thick (inexact->exact last)))
 434      "draw_volta"))
 435
 436   (define (tuplet dx dy thick dir)
 437     (string-append
 438      (numbers->string (list dx dy thick (inexact->exact dir)))
 439      "draw_tuplet"))
 440
 441
 442   (define (unknown)
 443     "\n unknown\n")
 444
 445
 446   ;; PS
 447   (cond ((eq? action-name 'all-definitions)
 448          `(begin
 449             (define beam ,beam)
 450             (define tuplet ,tuplet)
 451             (define bracket ,bracket)
 452             (define char ,char)
 453             (define crescendo ,crescendo)
 454             (define volta ,volta)
 455             (define bezier-sandwich ,bezier-sandwich)
 456             (define dashed-slur ,dashed-slur)
 457             (define decrescendo ,decrescendo)
 458             (define end-output ,end-output)
 459             (define experimental-on ,experimental-on)
 460             (define filledbox ,filledbox)
 461             (define font-def ,font-def)
 462             (define font-switch ,font-switch)
 463             (define generalmeter ,generalmeter)
 464             (define header-end ,header-end)
 465             (define lily-def ,lily-def)
 466             (define header ,header)
 467             (define invoke-char ,invoke-char)
 468             (define invoke-dim1 ,invoke-dim1)
 469             (define placebox ,placebox)
 470             (define rulesym ,rulesym)
 471             (define select-font ,select-font)
 472             (define start-line ,start-line)
 473             (define stem ,stem)
 474             (define stop-line ,stop-line)
 475             (define text ,text)
 476             ))
 477         ((eq? action-name 'tuplet) tuplet)
 478         ((eq? action-name 'beam) beam)
 479         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 480         ((eq? action-name 'bracket) bracket)
 481         ((eq? action-name 'char) char)
 482         ((eq? action-name 'crescendo) crescendo)
 483         ((eq? action-name 'dashed-slur) dashed-slur)
 484         ((eq? action-name 'decrescendo) decrescendo)
 485         ((eq? action-name 'experimental-on) experimental-on)
 486         ((eq? action-name 'filledbox) filledbox)
 487         ((eq? action-name 'select-font) select-font)
 488         ((eq? action-name 'volta) volta)
 489         (else (error "unknown tag -- PS-SCM " action-name))
 490         )
 491   )
 492
 493
 494 ;
 495 ; Russ McManus, <mcmanus@IDT.NET>
 496 ;
 497 ; I use the following, which should definitely be provided somewhere
 498 ; in guile, but isn't, AFAIK:
 499 ;
 500 ;
 501
 502 (define (hash-table-for-each fn ht)
 503   (do ((i 0 (+ 1 i)))
 504       ((= i (vector-length ht)))
 505     (do ((alist (vector-ref ht i) (cdr alist)))
 506         ((null? alist) #t)
 507       (fn (car (car alist)) (cdr (car alist))))))
 508
 509 (define (hash-table-map fn ht)
 510   (do ((i 0 (+ 1 i))
 511        (ret-ls '()))
 512       ((= i (vector-length ht)) (reverse ret-ls))
 513     (do ((alist (vector-ref ht i) (cdr alist)))
 514         ((null? alist) #t)
 515       (set! ret-ls (cons (fn (car (car alist)) (cdr (car alist))) ret-ls)))))
 516