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