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