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