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