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