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