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