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--2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8 ;;; Library functions
   9
  10
  11 (if (defined? 'set-debug-cell-accesses!)
  12     (set-debug-cell-accesses! #f))
  13
  14 ;(set-debug-cell-accesses! 5000)
  15
  16 (use-modules (ice-9 regex)
  17              (ice-9 safe)
  18              (oop goops)
  19              (srfi srfi-1)  ; lists
  20              (srfi srfi-13)) ; strings
  21
  22 ; my display
  23
  24 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
  25
  26 (define-public (print . args)
  27   (apply format (cons (current-output-port) args)))
  28
  29
  30 ;;; General settings
  31 ;;; debugging evaluator is slower.  This should
  32 ;;; have a more sensible default.
  33
  34 (if (ly:get-option 'verbose)
  35     (begin
  36       (debug-enable 'debug)
  37       (debug-enable 'backtrace)
  38       (read-enable 'positions)))
  39
  40 (define-public (line-column-location file line col)
  41   "Print an input location, including column number ."
  42   (string-append (number->string line) ":"
  43                  (number->string col) " " file))
  44
  45 (define-public (line-location  file line col)
  46   "Print an input location, without column number ."
  47   (string-append (number->string line) " " file))
  48
  49 (define-public point-and-click #f)
  50
  51 (define-public parser #f)
  52
  53 (define-public (lilypond-version)
  54   (string-join
  55    (map (lambda (x) (if (symbol? x)
  56                         (symbol->string x)
  57                         (number->string x)))
  58                 (ly:version))
  59    "."))
  60
  61
  62
  63 ;; cpp hack to get useful error message
  64 (define ifdef "First run this through cpp.")
  65 (define ifndef "First run this through cpp.")
  66
  67 ;; gettext wrapper for guile < 1.7.2
  68 (if (defined? 'gettext)
  69     (define-public _ gettext)
  70     (define-public _ ly:gettext))
  71
  72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73
  74 (define-public X 0)
  75 (define-public Y 1)
  76 (define-public START -1)
  77 (define-public STOP 1)
  78 (define-public LEFT -1)
  79 (define-public RIGHT 1)
  80 (define-public UP 1)
  81 (define-public DOWN -1)
  82 (define-public CENTER 0)
  83
  84 (define-public DOUBLE-FLAT -4)
  85 (define-public THREE-Q-FLAT -3)
  86 (define-public FLAT -2)
  87 (define-public SEMI-FLAT -1)
  88 (define-public NATURAL 0)
  89 (define-public SEMI-SHARP 1)
  90 (define-public SHARP 2)
  91 (define-public THREE-Q-SHARP 3)
  92 (define-public DOUBLE-SHARP 4)
  93 (define-public SEMI-TONE 2)
  94
  95 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  96
  97 (define-public (moment-min a b)
  98   (if (ly:moment<? a b) a b))
  99
 100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 101 ;; lily specific variables.
 102
 103 (define-public default-script-alist '())
 104
 105
 106 ;; parser stuff.
 107 (define-public (print-music-as-book parser music)
 108   (let* ((head  (ly:parser-lookup parser '$globalheader))
 109          (book (ly:make-book (ly:parser-lookup parser $defaultbookpaper)
 110                              head score)))
 111     (ly:parser-print-book parser book)))
 112
 113 (define-public (print-score-as-book parser score)
 114   (let*
 115       ((head  (ly:parser-lookup parser '$globalheader))
 116        (book (ly:make-book (ly:parser-lookup parser $defaultbookpaper)
 117                            head score)))
 118     (ly:parser-print-book parser book)))
 119
 120 (define-public (print-score parser score)
 121   (let* ((head  (ly:parser-lookup parser '$globalheader))
 122          (book (ly:make-book (ly:parser-lookup parser $defaultbookpaper)
 123                              head score)))
 124     (ly:parser-print-score parser book)))
 125
 126 (define-public (collect-scores-for-book  parser score)
 127   (let*
 128       ((oldval (ly:parser-lookup parser 'toplevel-scores)))
 129     (ly:parser-define parser 'toplevel-scores (cons score oldval))
 130     ))
 131
 132 (define-public (collect-music-for-book parser music)
 133   (collect-scores-for-book parser (ly:music-scorify music parser)))
 134
 135
 136
 137 ;;;;;;;;;;;;;;;;
 138 ; alist
 139 (define-public assoc-get ly:assoc-get)
 140
 141 (define-public (uniqued-alist alist acc)
 142   (if (null? alist) acc
 143       (if (assoc (caar alist) acc)
 144           (uniqued-alist (cdr alist) acc)
 145           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 146
 147 (define-public (alist<? x y)
 148   (string<? (symbol->string (car x))
 149             (symbol->string (car y))))
 150
 151 (define-public (chain-assoc x alist-list)
 152   (if (null? alist-list)
 153       #f
 154       (let* ((handle (assoc x (car alist-list))))
 155         (if (pair? handle)
 156             handle
 157             (chain-assoc x (cdr alist-list))))))
 158
 159 (define-public (chain-assoc-get x alist-list . default)
 160   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
 161 found."
 162
 163   (define (helper x alist-list default)
 164     (if (null? alist-list)
 165         default
 166         (let* ((handle (assoc x (car alist-list))))
 167           (if (pair? handle)
 168               (cdr handle)
 169               (helper x (cdr alist-list) default)))))
 170
 171   (helper x alist-list
 172           (if (pair? default) (car default) #f)))
 173
 174 (define (map-alist-vals func list)
 175   "map FUNC over the vals of  LIST, leaving the keys."
 176   (if (null?  list)
 177       '()
 178       (cons (cons  (caar list) (func (cdar list)))
 179             (map-alist-vals func (cdr list)))
 180       ))
 181
 182 (define (map-alist-keys func list)
 183   "map FUNC over the keys of an alist LIST, leaving the vals. "
 184   (if (null?  list)
 185       '()
 186       (cons (cons (func (caar list)) (cdar list))
 187             (map-alist-keys func (cdr list)))
 188       ))
 189
 190 ;;;;;;;;;;;;;;;;
 191 ;; hash
 192
 193
 194
 195 (if (not (defined? 'hash-table?))       ; guile 1.6 compat
 196     (begin
 197       (define hash-table? vector?)
 198
 199       (define-public (hash-table->alist t)
 200         "Convert table t to list"
 201         (apply append
 202                (vector->list t)
 203                )))
 204
 205     ;; native hashtabs.
 206     (begin
 207       (define-public (hash-table->alist t)
 208
 209         (hash-fold (lambda (k v acc) (acons  k v  acc))
 210                    '() t)
 211         )
 212       ))
 213
 214 ;; todo: code dup with C++.
 215 (define-public (alist->hash-table l)
 216   "Convert alist to table"
 217   (let
 218       ((m (make-hash-table (length l))))
 219
 220     (map (lambda (k-v)
 221            (hashq-set! m (car k-v) (cdr k-v)))
 222          l)
 223
 224     m))
 225
 226
 227
 228 ;;;;;;;;;;;;;;;;
 229 ; list
 230
 231 (define (flatten-list lst)
 232   "Unnest LST"
 233   (if (null? lst)
 234       '()
 235       (if (pair? (car lst))
 236           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 237           (cons (car lst) (flatten-list (cdr lst))))
 238   ))
 239
 240 (define (list-minus a b)
 241   "Return list of elements in A that are not in B."
 242   (lset-difference eq? a b))
 243
 244
 245 ;; TODO: use the srfi-1 partition function.
 246 (define-public (uniq-list l)
 247
 248   "Uniq LIST, assuming that it is sorted"
 249   (define (helper acc l)
 250     (if (null? l)
 251         acc
 252         (if (null? (cdr l))
 253             (cons (car l) acc)
 254             (if (equal? (car l) (cadr l))
 255                 (helper acc (cdr l))
 256                 (helper (cons (car l) acc)  (cdr l)))
 257             )))
 258   (reverse! (helper '() l) '()))
 259
 260
 261 (define (split-at-predicate predicate l)
 262  "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
 263 into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
 264 Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
 265 L1 is copied, L2 not.
 266
 267 (split-at-predicate (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
 268 ;; "
 269
 270 ;; KUT EMACS MODE.
 271
 272   (define (inner-split predicate l acc)
 273   (cond
 274    ((null? l) acc)
 275    ((null? (cdr l))
 276     (set-car! acc (cons (car l) (car acc)))
 277     acc)
 278    ((predicate (car l) (cadr l))
 279     (set-car! acc (cons (car l) (car acc)))
 280     (inner-split predicate (cdr l) acc))
 281    (else
 282     (set-car! acc (cons (car l) (car acc)))
 283     (set-cdr! acc (cdr l))
 284     acc)
 285
 286   ))
 287  (let*
 288     ((c (cons '() '()))
 289      )
 290   (inner-split predicate l  c)
 291   (set-car! c (reverse! (car c)))
 292   c)
 293 )
 294
 295
 296 (define-public (split-list l sep?)
 297 "
 298 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
 299 =>
 300 ((a b c) (d e f) (g))
 301
 302 "
 303 ;; " KUT EMACS.
 304
 305 (define (split-one sep?  l acc)
 306   "Split off the first parts before separator and return both parts."
 307   (if (null? l)
 308       (cons acc '())
 309       (if (sep? (car l))
 310           (cons acc (cdr l))
 311           (split-one sep? (cdr l) (cons (car l) acc))
 312           )
 313       ))
 314
 315 (if (null? l)
 316     '()
 317     (let* ((c (split-one sep? l '())))
 318       (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
 319       )))
 320
 321
 322 (define-public (interval-length x)
 323   "Length of the number-pair X, when an interval"
 324   (max 0 (- (cdr x) (car x)))
 325   )
 326
 327
 328 (define (other-axis a)
 329   (remainder (+ a 1) 2))
 330
 331
 332 (define-public (interval-widen iv amount)
 333    (cons (- (car iv) amount)
 334          (+ (cdr iv) amount)))
 335
 336 (define-public (interval-union i1 i2)
 337    (cons (min (car i1) (car i2))
 338          (max (cdr i1) (cdr i2))))
 339
 340
 341 (define-public (write-me message x)
 342   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 343 possibly turned off."
 344   (display message) (write x) (newline) x)
 345 ;;  x)
 346
 347 (define (index-cell cell dir)
 348   (if (equal? dir 1)
 349       (cdr cell)
 350       (car cell)))
 351
 352 (define (cons-map f x)
 353   "map F to contents of X"
 354   (cons (f (car x)) (f (cdr x))))
 355
 356
 357 (define-public (list-insert-separator lst between)
 358   "Create new list, inserting BETWEEN between elements of LIST"
 359   (define (conc x y )
 360     (if (eq? y #f)
 361         (list x)
 362         (cons x  (cons between y))
 363         ))
 364   (fold-right conc #f lst))
 365
 366 ;;;;;;;;;;;;;;;;
 367 ; other
 368 (define (sign x)
 369   (if (= x 0)
 370       0
 371       (if (< x 0) -1 1)))
 372
 373 (define-public (symbol<? l r)
 374   (string<? (symbol->string l) (symbol->string r)))
 375
 376 (define-public (!= l r)
 377   (not (= l r)))
 378
 379 (define-public (ly:load x)
 380   (let* ((fn (%search-load-path x)))
 381     (if (ly:get-option 'verbose)
 382         (format (current-error-port) "[~A]" fn))
 383     (primitive-load fn)))
 384
 385
 386 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 387 ;;  output
 388
 389
 390 ;;(define-public (output-framework) (write "hello\n"))
 391
 392 (define output-tex-module
 393   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 394 (define output-ps-module
 395   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 396
 397 (define-public (ps-output-expression expr port)
 398   (display (eval expr output-ps-module) port))
 399
 400 ;; TODO: generate this list by registering the stencil expressions
 401 ;;       stencil expressions should have docstrings.
 402 (define-public (ly:all-stencil-expressions)
 403   "Return list of stencil expressions."
 404   '(
 405     beam
 406     bezier-sandwich
 407     blank
 408     bracket
 409     char
 410     dashed-line
 411     dashed-slur
 412     dot
 413     draw-line
 414     ez-ball
 415     filledbox
 416     horizontal-line
 417     polygon
 418     repeat-slash
 419     round-filled-box
 420     symmetric-x-triangle
 421     text
 422     tuplet
 423     white-dot
 424     white-text
 425     zigzag-line
 426     ))
 427
 428 ;; TODO:
 429 ;;  - generate this list by registering the output-backend-commands
 430 ;;    output-backend-commands should have docstrings.
 431 ;;  - remove hard copies in output-ps output-tex
 432 (define-public (ly:all-output-backend-commands)
 433   "Return list of output backend commands."
 434   '(
 435     comment
 436     grob-cause
 437     no-origin
 438     placebox
 439     unknown
 440     ))
 441
 442 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 443 ;; other files.
 444
 445 (for-each ly:load
 446      ;; load-from-path
 447      '("define-music-types.scm"
 448        "output-lib.scm"
 449        "c++.scm"
 450        "chord-ignatzek-names.scm"
 451        "chord-entry.scm"
 452        "chord-generic-names.scm"
 453        "stencil.scm"
 454        "new-markup.scm"
 455        "bass-figure.scm"
 456        "music-functions.scm"
 457        "part-combiner.scm"
 458        "define-music-properties.scm"
 459        "auto-beam.scm"
 460        "chord-name.scm"
 461
 462        "ly-from-scheme.scm"
 463
 464        "define-context-properties.scm"
 465        "translation-functions.scm"
 466        "script.scm"
 467        "midi.scm"
 468        "beam.scm"
 469        "clef.scm"
 470        "slur.scm"
 471        "font.scm"
 472        "encoding.scm"
 473
 474        "fret-diagrams.scm"
 475        "define-markup-commands.scm"
 476        "define-grob-properties.scm"
 477        "define-grobs.scm"
 478        "define-grob-interfaces.scm"
 479        "page-layout.scm"
 480        "titling.scm"
 481
 482        "paper.scm"
 483
 484        ; last:
 485        "safe-lily.scm"
 486        ))
 487
 488
 489 (set! type-p-name-alist
 490   `(
 491    (,boolean-or-symbol? . "boolean or symbol")
 492    (,boolean? . "boolean")
 493    (,char? . "char")
 494    (,grob-list? . "list of grobs")
 495    (,hash-table? . "hash table")
 496    (,input-port? . "input port")
 497    (,integer? . "integer")
 498    (,list? . "list")
 499    (,ly:context? . "context")
 500    (,ly:dimension? . "dimension, in staff space")
 501    (,ly:dir? . "direction")
 502    (,ly:duration? . "duration")
 503    (,ly:grob? . "layout object")
 504    (,ly:input-location? . "input location")
 505    (,ly:moment? . "moment")
 506    (,ly:music? . "music")
 507    (,ly:pitch? . "pitch")
 508    (,ly:translator? . "translator")
 509    (,ly:font-metric? . "font metric")
 510    (,markup-list? . "list of markups")
 511    (,markup? . "markup")
 512    (,ly:music-list? . "list of music")
 513    (,number-or-grob? . "number or grob")
 514    (,number-or-string? . "number or string")
 515    (,number-pair? . "pair of numbers")
 516    (,number? . "number")
 517    (,output-port? . "output port")
 518    (,pair? . "pair")
 519    (,procedure? . "procedure")
 520    (,scheme? . "any type")
 521    (,string? . "string")
 522    (,symbol? . "symbol")
 523    (,vector? . "vector")
 524    ))
 525
 526
 527 ;; debug mem leaks
 528
 529 (define gc-protect-stat-count 0)
 530 (define-public (dump-gc-protects)
 531   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 532   (let*
 533       ((protects (sort
 534            (hash-table->alist (ly:protects))
 535            (lambda (a b)
 536              (< (object-address (car a))
 537                 (object-address (car b))))))
 538        (outfile    (open-file (string-append
 539                "gcstat-" (number->string gc-protect-stat-count)
 540                ".scm"
 541                ) "w")))
 542
 543     (display "DUMPING...\n")
 544     (display
 545      (filter
 546       (lambda (x) (not (symbol? x)))
 547       (map (lambda (y)
 548              (let
 549                  ((x (car y))
 550                   (c (cdr y)))
 551
 552                (string-append
 553                 (string-join
 554                  (map object->string (list (object-address x) c x))
 555                  " ")
 556                 "\n")))
 557            protects))
 558      outfile)))
 559
 560
 561 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 562
 563 (define-public (postscript->pdf papersize name)
 564   (let* ((cmd (string-append "ps2pdf -sPAPERSIZE=" papersize " " name))
 565          (output-name
 566           (regexp-substitute/global #f "\\.ps" name 'pre ".pdf" 'post)))
 567
 568     (newline (current-error-port))
 569     (display (format (_ "Converting to `~a'...") output-name)
 570              (current-error-port))
 571     (newline (current-error-port))
 572
 573     (if (ly:get-option 'verbose)
 574         (display (format (_"Invoking `~a'...") cmd) (current-error-port)))
 575
 576   (system cmd)))
 577
 578 (define-public (postscript->png resolution name)
 579   (let
 580       ((cmd (string-append
 581            "ps2png --resolution="
 582            (if (number? resolution)
 583                (number->string resolution)
 584                "90")
 585            (if (ly:get-option 'verbose)
 586                "--verbose "
 587                " ")
 588            name)))
 589     (if (ly:get-option 'verbose)
 590         (begin
 591           (display (format (_ "Invoking `~a'...") cmd) (current-error-port))
 592           (newline (current-error-port))))
 593     (system cmd)))
 594
 595 (define-public (lilypond-main files)
 596   "Entry point for LilyPond."
 597   (let* ((failed '())
 598          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 599     (for-each
 600      (lambda (f)
 601        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 602 ;;;       (dump-gc-protects)
 603        )
 604      files)
 605
 606     (if (pair? failed)
 607         (begin
 608           (newline (current-error-port))
 609           (display (_ "error: failed files: ") (current-error-port))
 610           (display (string-join failed) (current-error-port))
 611           (newline (current-error-port))
 612           (newline (current-error-port))
 613           (exit 1))
 614         (exit 0))))