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