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