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