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