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 (setroman 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   (define (pt->sp x)
 163     (* 65536 x))
 164
 165   ;;
 166   ;; need to do something to make this really safe.
 167   ;;
 168   (if security-paranoia
 169       (define (output-tex-string s)
 170         (regexp-substitute/global #f "\\\\" s 'pre "$\\backslash$" 'post))
 171       (define (output-tex-string s)    s))
 172
 173   (define (lily-def key val)
 174     (string-append
 175      "\\def\\" (output-tex-string key) "{" (output-tex-string val) "}\n"))
 176
 177   (define (number->dim x)
 178     (string-append
 179      (number->string  (chop-decimal x)) "pt "))
 180
 181   (define (placebox x y s)
 182     (string-append
 183      "\\placebox{"
 184      (number->dim y) "}{" (number->dim x) "}{" s "}"))
 185
 186   (define (pianobrace y)
 187     (define step 1.0)
 188     (define minht (* 2 mudelapaperstaffheight))
 189     (define maxht (* 7 minht))
 190     (string-append
 191      "{\\bracefont " (char  (/  (- (min y (- maxht step)) minht)   step)) "}"))
 192
 193   (define
 194     (repeatbar h)
 195     (invoke-dim1  "repeatbar" h))
 196
 197   (define
 198     (repeatbarstartrepeat h)
 199     (invoke-dim1  "repeatbarstartrepeat" h))
 200
 201   (define (rulesym h w)
 202     (string-append
 203      "\\vrule height " (number->dim (/ h 2))
 204      " depth " (number->dim (/ h 2))
 205      " width " (number->dim w)
 206      )
 207     )
 208
 209   (define (slur l)
 210     (embedded-ps ((ps-scm 'slur) l)))
 211
 212   (define
 213     (startbar h)
 214     (invoke-dim1  "startbar" h))
 215
 216   (define
 217     (startrepeat h)
 218     (invoke-dim1  "startrepeat" h))
 219
 220   (define (start-line)
 221     (string-append
 222      "\\hbox{%\n")
 223     )
 224
 225   (define (filledbox breapth width height depth)
 226     (string-append
 227      "\\kern" (number->dim (- breapth))
 228      "\\vrule width " (number->dim (+ breapth width))
 229      "depth " (number->dim depth)
 230      "height " (number->dim height) " "))
 231
 232   (define (stop-line)
 233     "}\\interscoreline")
 234
 235   (define
 236     (stoprepeat h)
 237     (invoke-dim1 "stoprepeat" h))
 238
 239   (define (text f s)
 240     (string-append "\\set" f "{" (output-tex-string s) "}"))
 241
 242   (define (tuplet dx dy thick dir)
 243     (embedded-ps ((ps-scm 'tuplet) dx dy thick dir)))
 244
 245   (define (volta w thick last)
 246     (embedded-ps ((ps-scm 'volta) w thick last)))
 247
 248   (define (maatstreep h)
 249     (string-append "\\maatstreep{" (number->dim h) "}"))
 250
 251   ; urg: generate me
 252   (cond ((eq? action-name 'all-definitions)
 253          `(begin
 254             (define beam ,beam)
 255             (define tuplet ,tuplet)
 256             (define bracket ,bracket)
 257             (define crescendo ,crescendo)
 258             (define dashed-slur ,dashed-slur)
 259             (define doublebar ,doublebar)
 260             (define emptybar ,emptybar)
 261             (define decrescendo ,decrescendo)
 262             (define empty ,empty)
 263             (define end-output ,end-output)
 264             (define extender ,extender)
 265             (define fatdoublebar ,fatdoublebar)
 266             (define finishbar ,finishbar)
 267             (define font-def ,font-def)
 268             (define font-switch ,font-switch)
 269             (define generalmeter ,generalmeter)
 270             (define header-end ,header-end)
 271             (define lily-def ,lily-def)
 272             (define header ,header)
 273             (define invoke-char ,invoke-char)
 274             (define invoke-dim1 ,invoke-dim1)
 275             (define placebox ,placebox)
 276             (define repeatbar ,repeatbar)
 277             (define repeatbarstartrepeat ,repeatbarstartrepeat)
 278             (define rulesym ,rulesym)
 279             (define slur ,slur)
 280             (define startbar ,startbar)
 281             (define startrepeat ,startrepeat)
 282             (define stoprepeat ,stoprepeat)
 283             (define start-line ,start-line)
 284             (define filledbox ,filledbox)
 285             (define stop-line ,stop-line)
 286             (define text ,text)
 287             (define experimental-on  ,experimental-on)
 288             (define char  ,char)
 289             (define maatstreep ,maatstreep)
 290             (define pianobrace ,pianobrace)
 291             (define volta ,volta)
 292             ))
 293
 294         ((eq? action-name 'experimental-on) experimental-on)
 295         ((eq? action-name 'beam) beam)
 296         ((eq? action-name 'tuplet) tuplet)
 297         ((eq? action-name 'bracket) bracket)
 298         ((eq? action-name 'crescendo) crescendo)
 299         ((eq? action-name 'dashed-slur) dashed-slur)
 300         ((eq? action-name 'doublebar) doublebar)
 301         ((eq? action-name 'decrescendo) decrescendo)
 302         ((eq? action-name 'empty) empty)
 303         ((eq? action-name 'end-output) end-output)
 304         ((eq? action-name 'extender) extender)
 305         ((eq? action-name 'fatdoublebar) fatdoublebar)
 306         ((eq? action-name 'finishbar) finishbar)
 307         ((eq? action-name 'font-def) font-def)
 308         ((eq? action-name 'font-switch) font-switch)
 309         ((eq? action-name 'generalmeter) generalmeter)
 310         ((eq? action-name 'header-end) header-end)
 311         ((eq? action-name 'lily-def) lily-def)
 312         ((eq? action-name 'header) header)
 313         ((eq? action-name 'invoke-char) invoke-char)
 314         ((eq? action-name 'invoke-dim1) invoke-dim1)
 315         ((eq? action-name 'placebox) placebox)
 316         ((eq? action-name 'repeatbar) repeatbar)
 317         ((eq? action-name 'repeatbarstartrepeat) repeatbarstartrepeat)
 318         ((eq? action-name 'rulesym) rulesym)
 319         ((eq? action-name 'slur) slur)
 320         ((eq? action-name 'startbar) startbar)
 321         ((eq? action-name 'startrepeat) startrepeat)
 322         ((eq? action-name 'stoprepeat) stoprepeat)
 323         ((eq? action-name 'start-line) start-line)
 324         ((eq? action-name 'stem) stem)
 325         ((eq? action-name 'stop-line) stop-line)
 326         ((eq? action-name 'volta) volta)
 327         (else (error "unknown tag -- PS-TEX " action-name))
 328         )
 329   )
 330
 331 ;;;;;;;;;;;; PS
 332 (define (ps-scm action-name)
 333   (define (beam width slope thick)
 334     (string-append
 335      (numbers->string (list width slope thick)) " draw_beam " ))
 336
 337   (define (bracket h)
 338     (invoke-dim1 "draw_bracket" h))
 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   (define (empty)
 360     "\n empty\n")
 361
 362   (define (end-output)
 363     "\nshowpage\n")
 364
 365   (define (experimental-on) "")
 366
 367   (define (font-def i s)
 368     (string-append
 369      "\n/" (font i) " {/"
 370      (substring s 0 (- (string-length s) 4))
 371      " findfont 12 scalefont setfont} bind def\n"))
 372
 373   (define (font-switch i)
 374     (string-append (font i) " "))
 375
 376   (define (generalmeter num den)
 377     (string-append (number->string (inexact->exact num)) " " (number->string (inexact->exact den)) " generalmeter "))
 378
 379   (define (header-end) "")
 380   (define (lily-def key val)
 381     (string-append
 382      "/" key " {" val "} bind def\n"))
 383
 384   (define (header creator generate)
 385     (string-append
 386      "%!PS-Adobe-3.0\n"
 387      "%%Creator: " creator generate "\n"))
 388
 389   (define (invoke-char s i)
 390     (string-append
 391      "(\\" (inexact->string i 8) ") " s " " ))
 392
 393   (define (invoke-dim1 s d)
 394     (string-append
 395      (number->string (* d  (/ 72.27 72))) " " s ))
 396
 397   (define (placebox x y s)
 398     (string-append
 399      (number->string x) " " (number->string y) " {" s "} placebox "))
 400
 401   (define (rulesym x y)
 402     (string-append
 403      (number->string x) " "
 404      (number->string y) " "
 405      "rulesym"))
 406
 407   (define (slur l)
 408     (string-append
 409      (apply string-append (map control->string l))
 410      " draw_slur"))
 411
 412   (define (start-line)
 413     "\nstart_line {\n")
 414
 415   (define (stem kern width height depth)
 416     (string-append (numbers->string (list kern width height depth))
 417                    "draw_stem" ))
 418
 419   (define (stop-line)
 420     "}\nstop_line\n")
 421
 422   (define (text f s)
 423     (string-append "(" s ") set" f " "))
 424
 425
 426   (define (volta w thick last)
 427     (string-append
 428      (numbers->string (list w thick (inexact->exact last)))
 429      "draw_volta"))
 430
 431   (define (tuplet dx dy thick dir)
 432     (string-append
 433      (numbers->string (list dx dy thick (inexact->exact dir)))
 434      "draw_tuplet"))
 435
 436
 437   (define (unknown)
 438     "\n unknown\n")
 439
 440
 441   ; dispatch on action-name
 442   (cond ((eq? action-name 'all-definitions)
 443          `(begin
 444             (define beam ,beam)
 445             (define tuplet ,tuplet)
 446             (define bracket ,bracket)
 447             (define crescendo ,crescendo)
 448             (define volta ,volta)
 449             (define slur ,slur)
 450             (define dashed-slur ,dashed-slur)
 451             (define decrescendo ,decrescendo)
 452             (define empty ,empty)
 453             (define end-output ,end-output)
 454             (define font-def ,font-def)
 455             (define font-switch ,font-switch)
 456             (define generalmeter ,generalmeter)
 457             (define header-end ,header-end)
 458             (define lily-def ,lily-def)
 459             (define header ,header)
 460             (define invoke-char ,invoke-char)
 461             (define invoke-dim1 ,invoke-dim1)
 462             (define placebox ,placebox)
 463             (define rulesym ,rulesym)
 464             (define start-line ,start-line)
 465             (define stem ,stem)
 466             (define stop-line ,stop-line)
 467             (define text ,text)
 468             ))
 469         ((eq? action-name 'tuplet) tuplet)
 470         ((eq? action-name 'beam) beam)
 471         ((eq? action-name 'bracket) bracket)
 472         ((eq? action-name 'crescendo) crescendo)
 473         ((eq? action-name 'volta) volta)
 474         ((eq? action-name 'slur) slur)
 475         ((eq? action-name 'dashed-slur) dashed-slur)
 476         ((eq? action-name 'decrescendo) decrescendo)
 477         (else (error "unknown tag -- PS-SCM " action-name))
 478         )
 479   )
 480
 481
 482
 483