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