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