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 ; TODO
   8 ;   - naming
   9 ;   - ready ps code (draw_bracket) vs tex/ps macros/calls (pianobrace),
  10 ;     all preparations from ps,tex to scm
  11
  12 ;;; library funtions
  13 (define
  14   (xnumbers->string l)
  15   (string-append
  16    (map (lambda (n) (string-append (number->string n ) " ")) l)))
  17
  18 (define
  19   (numbers->string l)
  20   (apply string-append
  21          (map (lambda (n) (string-append (number->string n) " ")) l)))
  22
  23 (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
  24
  25 (define (number->octal-string x)
  26   (let* ((n (inexact->exact x))
  27          (n64 (quotient n 64))
  28          (n8 (quotient (- n (* n64 64)) 8)))
  29     (string-append
  30      (number->string n64)
  31      (number->string n8)
  32      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
  33
  34 (define (inexact->string x radix)
  35   (let ((n (inexact->exact x)))
  36     (number->string n radix)))
  37
  38
  39 (define
  40   (control->string c)
  41   (string-append
  42    (string-append (number->string (car c)) " ")
  43    (string-append (number->string (cadr c)) " ")))
  44
  45
  46 (define
  47   (font i)
  48   (string-append
  49    "font"
  50    (make-string 1 (integer->char (+ (char->integer #\A) i)))
  51    ))
  52
  53
  54
  55 (define (scm-scm action-name)
  56   1)
  57
  58 (define security-paranoia #f)
  59
  60
  61 ;;;;;;;;
  62 ;;; UGH.  THESE SUCK!
  63
  64 (define (empty)
  65   "")
  66
  67 (define (empty1 a)
  68   "")
  69
  70 (define (empty2 a b )
  71   "")
  72
  73 (define emptybar empty1)
  74
  75 ;;; and these suck as well.
  76 (define (setdynamic s) (text "dynamic" (string-append "\\" s)))
  77 (define (settext s) (text "text" s))
  78 (define (settypewriter s) (text "typewriter" s))
  79 (define (setnumber s) (text "number" s))
  80 (define (setbold s) (text "bold" s))
  81 (define (setfinger s) (text "finger" s))
  82 (define (setitalic s) (text "italic" s))
  83 (define (setnumber-1 s) (text "numberj" s))
  84
  85
  86
  87 ;;;;;;;; TeX
  88
  89 (define (tex-scm action-name)
  90
  91   (define (unknown)
  92     "%\n\\unknown%\n")
  93
  94   (define (beam width slope thick)
  95     (embedded-ps ((ps-scm 'beam) width slope thick)))
  96
  97   (define (bracket h)
  98     (embedded-ps ((ps-scm 'bracket) h)))
  99
 100   (define (dashed-slur thick dash l)
 101     (embedded-ps ((ps-scm 'dashed-slur)  thick dash l)))
 102
 103   (define (crescendo w h cont)
 104     (embedded-ps ((ps-scm 'crescendo) w h cont)))
 105
 106   (define (decrescendo w h cont)
 107     (embedded-ps ((ps-scm 'decrescendo) w h cont)))
 108
 109   (define
 110     (doublebar h)
 111     (invoke-dim1  "doublebar" h))
 112
 113   (define (embedded-ps s)
 114     (string-append "\\embeddedps{" s "}"))
 115
 116   (define (end-output)
 117     "\n\\EndLilyPondOutput")
 118
 119   (define (experimental-on) "\\turnOnExperimentalFeatures")
 120
 121   (define (extender h)
 122     (invoke-dim1 "extender" h))
 123
 124   (define
 125     (fatdoublebar h)
 126     (invoke-dim1  "fatdoublebar" h))
 127
 128   (define
 129     (finishbar h)
 130     (invoke-dim1  "finishbar" h))
 131
 132   (define (font-switch i)
 133     (string-append
 134      "\\" (font i) "\n"))
 135
 136   (define (font-def i s)
 137     (string-append
 138      "\\font" (font-switch i) "=" s "\n"))
 139
 140   (define (generalmeter num den)
 141     (string-append
 142      "\\generalmeter{" (number->string (inexact->exact num)) "}{" (number->string (inexact->exact den)) "}"))
 143
 144   (define (header-end) "\\turnOnPostScript")
 145
 146   (define (header creator generate)
 147     (string-append
 148      "%created by: " creator generate "\n"))
 149
 150   (define (invoke-char s i)
 151     (string-append
 152      "\n\\" s "{" (inexact->string i 10) "}" ))
 153   (define (char i)
 154     (string-append "\\show{" (inexact->string i 10) "}"))
 155
 156   (define (invoke-dim1 s d)
 157     (string-append
 158      "\n\\" s "{" (number->dim d) "}"))
 159
 160   ;;
 161   ;; need to do something to make this really safe.
 162   ;;
 163   (if security-paranoia
 164       (define (output-tex-string s)
 165         (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post))
 166       (define (output-tex-string s)    s))
 167
 168   (define (lily-def key val)
 169     (string-append
 170      "\\def\\" (output-tex-string key) "{" (output-tex-string val) "}\n"))
 171
 172   (define (number->dim x)
 173     (string-append
 174      (number->string (chop-decimal x)) "pt "))
 175
 176   (define (placebox x y s)
 177     (string-append
 178      "\\placebox{"
 179      (number->dim y) "}{" (number->dim x) "}{" s "}"))
 180
 181   (define (pianobrace y)
 182     (define step 1.0)
 183     (define minht mudelapaperstaffheight)
 184     (define maxht (* 6 minht))
 185     (string-append
 186      "{\\bracefont " (char  (/  (- (min y (- maxht step)) minht)   step)) "}"))
 187
 188   (define
 189     (repeatbar h)
 190     (invoke-dim1  "repeatbar" h))
 191
 192   (define
 193     (repeatbarstartrepeat h)
 194     (invoke-dim1  "repeatbarstartrepeat" h))
 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 (slur l)
 205     (embedded-ps ((ps-scm 'slur) l)))
 206
 207   (define
 208     (startbar h)
 209     (invoke-dim1  "startbar" h))
 210
 211   (define
 212     (startrepeat h)
 213     (invoke-dim1  "startrepeat" h))
 214
 215   (define (start-line)
 216     (string-append
 217      "\\hbox{%\n")
 218     )
 219
 220   (define (stem kern width height depth)
 221     (string-append
 222      "\\kern" (number->dim kern)
 223      "\\vrule width " (number->dim width)
 224      "depth " (number->dim depth)
 225      "height " (number->dim height) " "))
 226
 227   (define (stop-line)
 228     "}\\interscoreline")
 229
 230   (define
 231     (stoprepeat h)
 232     (invoke-dim1 "stoprepeat" h))
 233
 234   (define (text f s)
 235     (string-append "\\set" f "{" (output-tex-string s) "}"))
 236
 237   (define (tuplet dx dy dir)
 238     (embedded-ps ((ps-scm 'tuplet) dx dy dir)))
 239
 240   (define (volta w last)
 241     (embedded-ps ((ps-scm 'volta)  w last)))
 242
 243   (define (maatstreep h)
 244     (string-append "\\maatstreep{" (number->dim h) "}"))
 245
 246   ; urg: generate me
 247   (cond ((eq? action-name 'all-definitions)
 248          `(begin
 249             (define beam ,beam)
 250             (define tuplet ,tuplet)
 251             (define bracket ,bracket)
 252             (define crescendo ,crescendo)
 253             (define dashed-slur ,dashed-slur)
 254             (define doublebar ,doublebar)
 255             (define emptybar ,emptybar)
 256             (define decrescendo ,decrescendo)
 257             (define empty ,empty)
 258             (define end-output ,end-output)
 259             (define extender ,extender)
 260             (define fatdoublebar ,fatdoublebar)
 261             (define finishbar ,finishbar)
 262             (define font-def ,font-def)
 263             (define font-switch ,font-switch)
 264             (define generalmeter ,generalmeter)
 265             (define header-end ,header-end)
 266             (define lily-def ,lily-def)
 267             (define header ,header)
 268             (define invoke-char ,invoke-char)
 269             (define invoke-dim1 ,invoke-dim1)
 270             (define placebox ,placebox)
 271             (define repeatbar ,repeatbar)
 272             (define repeatbarstartrepeat ,repeatbarstartrepeat)
 273             (define rulesym ,rulesym)
 274             (define slur ,slur)
 275             (define startbar ,startbar)
 276             (define startrepeat ,startrepeat)
 277             (define stoprepeat ,stoprepeat)
 278             (define start-line ,start-line)
 279             (define stem ,stem)
 280             (define stop-line ,stop-line)
 281             (define text ,text)
 282             (define experimental-on  ,experimental-on)
 283             (define char  ,char)
 284             (define maatstreep ,maatstreep)
 285             (define pianobrace ,pianobrace)
 286             (define volta ,volta)
 287             ))
 288
 289         ((eq? action-name 'experimental-on) experimental-on)
 290         ((eq? action-name 'beam) beam)
 291         ((eq? action-name 'tuplet) tuplet)
 292         ((eq? action-name 'bracket) bracket)
 293         ((eq? action-name 'crescendo) crescendo)
 294         ((eq? action-name 'dashed-slur) dashed-slur)
 295         ((eq? action-name 'doublebar) doublebar)
 296         ((eq? action-name 'decrescendo) decrescendo)
 297         ((eq? action-name 'empty) empty)
 298         ((eq? action-name 'end-output) end-output)
 299         ((eq? action-name 'extender) extender)
 300         ((eq? action-name 'fatdoublebar) fatdoublebar)
 301         ((eq? action-name 'finishbar) finishbar)
 302         ((eq? action-name 'font-def) font-def)
 303         ((eq? action-name 'font-switch) font-switch)
 304         ((eq? action-name 'generalmeter) generalmeter)
 305         ((eq? action-name 'header-end) header-end)
 306         ((eq? action-name 'lily-def) lily-def)
 307         ((eq? action-name 'header) header)
 308         ((eq? action-name 'invoke-char) invoke-char)
 309         ((eq? action-name 'invoke-dim1) invoke-dim1)
 310         ((eq? action-name 'placebox) placebox)
 311         ((eq? action-name 'repeatbar) repeatbar)
 312         ((eq? action-name 'repeatbarstartrepeat) repeatbarstartrepeat)
 313         ((eq? action-name 'rulesym) rulesym)
 314         ((eq? action-name 'slur) slur)
 315         ((eq? action-name 'startbar) startbar)
 316         ((eq? action-name 'startrepeat) startrepeat)
 317         ((eq? action-name 'stoprepeat) stoprepeat)
 318         ((eq? action-name 'start-line) start-line)
 319         ((eq? action-name 'stem) stem)
 320         ((eq? action-name 'stop-line) stop-line)
 321         ((eq? action-name 'volta) volta)
 322         (else (error "unknown tag -- PS-TEX " action-name))
 323         )
 324   )
 325
 326 ;;;;;;;;;;;; PS
 327 (define (ps-scm action-name)
 328   (define (beam width slope thick)
 329     (string-append
 330      (numbers->string (list width slope thick)) " draw_beam " ))
 331
 332   (define (bracket h)
 333     (invoke-dim1 "draw_bracket" h))
 334
 335   (define (crescendo w h cont)
 336     (string-append
 337      (numbers->string (list w h (inexact->exact cont)))
 338      "draw_crescendo"))
 339
 340   (define (dashed-slur thick dash l)
 341     (string-append
 342      (apply string-append (map control->string l))
 343      (number->string thick)
 344      " [ "
 345      (if (> 1 dash) (number->string (- (* thick dash) thick)) "0") " "
 346      (number->string (* 2 thick))
 347      " ] 0 draw_dashed_slur"))
 348
 349   (define (decrescendo w h cont)
 350     (string-append
 351      (numbers->string (list w h (inexact->exact cont)))
 352      "draw_decrescendo"))
 353
 354   (define (empty)
 355     "\n empty\n")
 356
 357   (define (end-output)
 358     "\nshowpage\n")
 359
 360   (define (experimental-on) "")
 361
 362   (define (font-def i s)
 363     (string-append
 364      "\n/" (font i) " {/"
 365      (substring s 0 (- (string-length s) 4))
 366      " findfont 12 scalefont setfont} bind def\n"))
 367
 368   (define (font-switch i)
 369     (string-append (font i) " "))
 370
 371   (define (generalmeter num den)
 372     (string-append (number->string (inexact->exact num)) " " (number->string (inexact->exact den)) " generalmeter "))
 373
 374   (define (header-end) "")
 375   (define (lily-def key val)
 376     (string-append
 377      "/" key " {" val "} bind def\n"))
 378
 379   (define (header creator generate)
 380     (string-append
 381      "%!PS-Adobe-3.0\n"
 382      "%%Creator: " creator generate "\n"))
 383
 384   (define (invoke-char s i)
 385     (string-append
 386      "(\\" (inexact->string i 8) ") " s " " ))
 387
 388   (define (invoke-dim1 s d)
 389     (string-append
 390      (number->string d) " " s ))
 391
 392   (define (placebox x y s)
 393     (string-append
 394      (number->string x) " " (number->string y) " {" s "} placebox "))
 395
 396   (define (rulesym x y)
 397     (string-append
 398      (number->string x) " "
 399      (number->string y) " "
 400      "rulesym"))
 401
 402   (define (slur l)
 403     (string-append
 404      (apply string-append (map control->string l))
 405      " draw_slur"))
 406
 407   (define (start-line)
 408     "\nstart_line {\n")
 409
 410   (define (stem kern width height depth)
 411     (string-append (numbers->string (list kern width height depth))
 412                    "draw_stem" ))
 413
 414   (define (stop-line)
 415     "}\nstop_line\n")
 416
 417   (define (text f s)
 418     (string-append "(" s ") set" f " "))
 419
 420
 421   (define (volta w last)
 422     (string-append
 423      (numbers->string (list w (inexact->exact last)))
 424      "draw_volta"))
 425   (define   (tuplet dx dy dir)
 426     (string-append
 427      (numbers->string (list dx dy (inexact->exact dir)))
 428      "draw_tuplet"))
 429
 430
 431   (define (unknown)
 432     "\n unknown\n")
 433
 434
 435   ; dispatch on action-name
 436   (cond ((eq? action-name 'all-definitions)
 437          `(begin
 438             (define beam ,beam)
 439             (define tuplet ,tuplet)
 440             (define bracket ,bracket)
 441             (define crescendo ,crescendo)
 442             (define volta ,volta)
 443             (define slur ,slur)
 444             (define dashed-slur ,dashed-slur)
 445             (define decrescendo ,decrescendo)
 446             (define empty ,empty)
 447             (define end-output ,end-output)
 448             (define font-def ,font-def)
 449             (define font-switch ,font-switch)
 450             (define generalmeter ,generalmeter)
 451             (define header-end ,header-end)
 452             (define lily-def ,lily-def)
 453             (define header ,header)
 454             (define invoke-char ,invoke-char)
 455             (define invoke-dim1 ,invoke-dim1)
 456             (define placebox ,placebox)
 457             (define rulesym ,rulesym)
 458             (define start-line ,start-line)
 459             (define stem ,stem)
 460             (define stop-line ,stop-line)
 461             (define text ,text)
 462             ))
 463         ((eq? action-name 'tuplet) tuplet)
 464         ((eq? action-name 'beam) beam)
 465         ((eq? action-name 'bracket) bracket)
 466         ((eq? action-name 'crescendo) crescendo)
 467         ((eq? action-name 'volta) volta)
 468         ((eq? action-name 'slur) slur)
 469         ((eq? action-name 'dashed-slur) dashed-slur)
 470         ((eq? action-name 'decrescendo) decrescendo)
 471         (else (error "unknown tag -- PS-SCM " action-name))
 472         )
 473   )
 474
 475
 476
 477