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