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