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 (use-modules (ice-9 regex)
  15              (ice-9 safe)
  16              (oop goops)
  17              (srfi srfi-1)  ; lists
  18              (srfi srfi-13)) ; strings
  19
  20 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
  21
  22 ;;; General settings
  23 ;;; debugging evaluator is slower.  This should
  24 ;;; have a more sensible default.
  25
  26 (if (ly:get-option 'verbose)
  27     (begin
  28       (debug-enable 'debug)
  29       (debug-enable 'backtrace)
  30       (read-enable 'positions)))
  31
  32 (define-public (line-column-location file line col)
  33   "Print an input location, including column number ."
  34   (string-append (number->string line) ":"
  35                  (number->string col) " " file))
  36
  37 (define-public (line-location  file line col)
  38   "Print an input location, without column number ."
  39   (string-append (number->string line) " " file))
  40
  41 (define-public point-and-click #f)
  42
  43 (define-public parser #f)
  44
  45 (define-public (lilypond-version)
  46   (string-join
  47    (map (lambda (x) (if (symbol? x)
  48                         (symbol->string x)
  49                         (number->string x)))
  50                 (ly:version))
  51    "."))
  52
  53
  54
  55 ;; cpp hack to get useful error message
  56 (define ifdef "First run this through cpp.")
  57 (define ifndef "First run this through cpp.")
  58
  59
  60
  61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62
  63 (define-public X 0)
  64 (define-public Y 1)
  65 (define-public START -1)
  66 (define-public STOP 1)
  67 (define-public LEFT -1)
  68 (define-public RIGHT 1)
  69 (define-public UP 1)
  70 (define-public DOWN -1)
  71 (define-public CENTER 0)
  72
  73 (define-public DOUBLE-FLAT -4)
  74 (define-public THREE-Q-FLAT -3)
  75 (define-public FLAT -2)
  76 (define-public SEMI-FLAT -1)
  77 (define-public NATURAL 0)
  78 (define-public SEMI-SHARP 1)
  79 (define-public SHARP 2)
  80 (define-public THREE-Q-SHARP 3)
  81 (define-public DOUBLE-SHARP 4)
  82 (define-public SEMI-TONE 2)
  83
  84 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  85
  86 (define-public (moment-min a b)
  87   (if (ly:moment<? a b) a b))
  88
  89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90 ;; lily specific variables.
  91
  92 (define-public default-script-alist '())
  93
  94
  95 ;; parser stuff.
  96 (define-public (print-music-as-book parser music)
  97   (let* ((head  (ly:parser-lookup parser '$globalheader))
  98          (book (ly:make-book (ly:parser-lookup parser $defaultbookpaper)
  99                              head score)))
 100     (ly:parser-print-book parser book)))
 101
 102 (define-public (print-score-as-book parser score)
 103   (let*
 104       ((head  (ly:parser-lookup parser '$globalheader))
 105        (book (ly:make-book (ly:parser-lookup parser $defaultbookpaper)
 106                            head score)))
 107     (ly:parser-print-book parser book)))
 108
 109 (define-public (print-score parser score)
 110   (let* ((head  (ly:parser-lookup parser '$globalheader))
 111          (book (ly:make-book (ly:parser-lookup parser $defaultbookpaper)
 112                              head score)))
 113     (ly:parser-print-score parser book)))
 114
 115 (define-public (collect-scores-for-book  parser score)
 116   (let*
 117       ((oldval (ly:parser-lookup parser 'toplevel-scores)))
 118     (ly:parser-define parser 'toplevel-scores (cons score oldval))
 119     ))
 120
 121 (define-public (collect-music-for-book parser music)
 122   (collect-scores-for-book parser (ly:music-scorify music)))
 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 ;;(define-public (output-framework) (write "hello\n"))
 382
 383 (define output-tex-module
 384   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 385 (define output-ps-module
 386   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 387
 388 (define-public (ps-output-expression expr port)
 389   (display (eval expr output-ps-module) port))
 390
 391 ;; TODO: generate this list by registering the stencil expressions
 392 ;;       stencil expressions should have docstrings.
 393 (define-public (ly:all-stencil-expressions)
 394   "Return list of stencil expressions."
 395   '(
 396     beam
 397     bezier-sandwich
 398     blank
 399     bracket
 400     char
 401     dashed-line
 402     dashed-slur
 403     dot
 404     draw-line
 405     ez-ball
 406     filledbox
 407     horizontal-line
 408     polygon
 409     repeat-slash
 410     round-filled-box
 411     symmetric-x-triangle
 412     text
 413     tuplet
 414     white-dot
 415     zigzag-line
 416     ))
 417
 418 ;; TODO:
 419 ;;  - generate this list by registering the output-backend-commands
 420 ;;    output-backend-commands should have docstrings.
 421 ;;  - remove hard copies in output-ps output-tex
 422 (define-public (ly:all-output-backend-commands)
 423   "Return list of output backend commands."
 424   '(
 425     comment
 426     grob-cause
 427     no-origin
 428     placebox
 429     unknown
 430     ))
 431
 432 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 433 ;; other files.
 434
 435 (for-each ly:load
 436      ;; load-from-path
 437      '("define-music-types.scm"
 438        "output-lib.scm"
 439        "c++.scm"
 440        "chord-ignatzek-names.scm"
 441        "chord-entry.scm"
 442        "chord-generic-names.scm"
 443        "stencil.scm"
 444        "new-markup.scm"
 445        "bass-figure.scm"
 446        "music-functions.scm"
 447        "part-combiner.scm"
 448        "define-music-properties.scm"
 449        "auto-beam.scm"
 450        "chord-name.scm"
 451
 452        "ly-from-scheme.scm"
 453
 454        "define-context-properties.scm"
 455        "translation-functions.scm"
 456        "script.scm"
 457        "midi.scm"
 458        "beam.scm"
 459        "clef.scm"
 460        "slur.scm"
 461        "font.scm"
 462        "encoding.scm"
 463
 464        "fret-diagrams.scm"
 465        "define-markup-commands.scm"
 466        "define-grob-properties.scm"
 467        "define-grobs.scm"
 468        "define-grob-interfaces.scm"
 469        "page-layout.scm"
 470        "titling.scm"
 471
 472        "paper.scm"
 473
 474        ; last:
 475        "safe-lily.scm"
 476        ))
 477
 478
 479 (set! type-p-name-alist
 480   `(
 481    (,boolean-or-symbol? . "boolean or symbol")
 482    (,boolean? . "boolean")
 483    (,char? . "char")
 484    (,grob-list? . "list of grobs")
 485    (,hash-table? . "hash table")
 486    (,input-port? . "input port")
 487    (,integer? . "integer")
 488    (,list? . "list")
 489    (,ly:context? . "context")
 490    (,ly:dimension? . "dimension, in staff space")
 491    (,ly:dir? . "direction")
 492    (,ly:duration? . "duration")
 493    (,ly:grob? . "layout object")
 494    (,ly:input-location? . "input location")
 495    (,ly:moment? . "moment")
 496    (,ly:music? . "music")
 497    (,ly:pitch? . "pitch")
 498    (,ly:translator? . "translator")
 499    (,ly:font-metric? . "font metric")
 500    (,markup-list? . "list of markups")
 501    (,markup? . "markup")
 502    (,ly:music-list? . "list of music")
 503    (,number-or-grob? . "number or grob")
 504    (,number-or-string? . "number or string")
 505    (,number-pair? . "pair of numbers")
 506    (,number? . "number")
 507    (,output-port? . "output port")
 508    (,pair? . "pair")
 509    (,procedure? . "procedure")
 510    (,scheme? . "any type")
 511    (,string? . "string")
 512    (,symbol? . "symbol")
 513    (,vector? . "vector")
 514    ))
 515
 516
 517 ;; debug mem leaks
 518
 519 (define gc-protect-stat-count 0)
 520 (define-public (dump-gc-protects)
 521   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 522   (let*
 523       ((protects (sort
 524            (hash-table->alist (ly:protects))
 525            (lambda (a b)
 526              (< (object-address (car a))
 527                 (object-address (car b))))))
 528        (outfile    (open-file (string-append
 529                "gcstat-" (number->string gc-protect-stat-count)
 530                ".scm"
 531                ) "w"))
 532        )
 533
 534     (display "DUMPING...\n")
 535     (display
 536      (filter
 537       (lambda (x) (not (symbol? x)))
 538       (map (lambda (y)
 539              (let
 540                  ((x (car y))
 541                   (c (cdr y)))
 542
 543                (string-append
 544                 (string-join
 545                  (map object->string (list (object-address x) c x))
 546                  " ")
 547                 "\n")))
 548            protects))
 549      outfile)))
 550
 551
 552 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 553
 554 (define-public (lilypond-main files)
 555   "Entry point for LilyPond."
 556   (let* ((failed '())
 557          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 558     (for-each
 559      (lambda (f) (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler))
 560      files)
 561
 562     (if (pair? failed)
 563         (begin
 564           (display
 565            (string-append "\n *** Failed files: " (string-join failed) "\n"))
 566           (exit 1))
 567         (exit 0))))
 568