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