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