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* (
 373          (fn (%search-load-path x))
 374
 375          )
 376     (if (ly:get-option 'verbose)
 377         (format (current-error-port) "[~A]" fn))
 378     (primitive-load fn)))
 379
 380
 381 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 382 ;;  output
 383 (use-modules (scm framework-tex)
 384              (scm framework-ps)
 385              )
 386
 387
 388
 389 (define output-tex-module
 390   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 391 (define output-ps-module
 392   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 393 (define-public (tex-output-expression expr port)
 394   (display (eval expr output-tex-module) port))
 395 (define-public (ps-output-expression expr port)
 396   (display (eval expr output-ps-module) port))
 397
 398
 399 (define output-alist
 400   `(
 401     ("tex" . ("TeX output. The default output form." ,tex-output-expression))
 402     ("scm" . ("Scheme dump: debug scheme stencil expressions" ,write))
 403 ;    ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
 404 ;    ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
 405 ;    ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
 406     ))
 407
 408
 409 (define (document-format-dumpers)
 410   (map
 411    (lambda (x)
 412      (display (string-append  (pad-string-to 5 (car x)) (cadr x) "\n"))
 413      output-alist)
 414    ))
 415
 416 (define-public (find-dumper format)
 417   (let ((d (assoc format output-alist)))
 418     (if (pair? d)
 419         (caddr d)
 420         (scm-error "Could not find dumper for format ~s" format))))
 421
 422
 423
 424 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 425 ;; other files.
 426
 427 (for-each ly:load
 428      ;; load-from-path
 429      '("define-music-types.scm"
 430        "output-lib.scm"
 431        "c++.scm"
 432        "chord-ignatzek-names.scm"
 433        "chord-entry.scm"
 434        "chord-generic-names.scm"
 435        "stencil.scm"
 436        "new-markup.scm"
 437        "bass-figure.scm"
 438        "music-functions.scm"
 439        "part-combiner.scm"
 440        "define-music-properties.scm"
 441        "auto-beam.scm"
 442        "chord-name.scm"
 443
 444        "ly-from-scheme.scm"
 445
 446        "define-context-properties.scm"
 447        "translation-functions.scm"
 448        "script.scm"
 449        "midi.scm"
 450        "beam.scm"
 451        "clef.scm"
 452        "slur.scm"
 453        "font.scm"
 454        "encoding.scm"
 455
 456        "fret-diagrams.scm"
 457        "define-markup-commands.scm"
 458        "define-grob-properties.scm"
 459        "define-grobs.scm"
 460        "define-grob-interfaces.scm"
 461        "page-layout.scm"
 462
 463        "paper.scm"
 464
 465        ; last:
 466        "safe-lily.scm"
 467        ))
 468
 469
 470 (set! type-p-name-alist
 471   `(
 472    (,boolean-or-symbol? . "boolean or symbol")
 473    (,boolean? . "boolean")
 474    (,char? . "char")
 475    (,grob-list? . "list of grobs")
 476    (,hash-table? . "hash table")
 477    (,input-port? . "input port")
 478    (,integer? . "integer")
 479    (,list? . "list")
 480    (,ly:context? . "context")
 481    (,ly:dimension? . "dimension, in staff space")
 482    (,ly:dir? . "direction")
 483    (,ly:duration? . "duration")
 484    (,ly:grob? . "layout object")
 485    (,ly:input-location? . "input location")
 486    (,ly:moment? . "moment")
 487    (,ly:music? . "music")
 488    (,ly:pitch? . "pitch")
 489    (,ly:translator? . "translator")
 490    (,ly:font-metric? . "font metric")
 491    (,markup-list? . "list of markups")
 492    (,markup? . "markup")
 493    (,ly:music-list? . "list of music")
 494    (,number-or-grob? . "number or grob")
 495    (,number-or-string? . "number or string")
 496    (,number-pair? . "pair of numbers")
 497    (,number? . "number")
 498    (,output-port? . "output port")
 499    (,pair? . "pair")
 500    (,procedure? . "procedure")
 501    (,scheme? . "any type")
 502    (,string? . "string")
 503    (,symbol? . "symbol")
 504    (,vector? . "vector")
 505    ))
 506
 507
 508 ;; debug mem leaks
 509
 510 (define gc-protect-stat-count 0)
 511 (define-public (dump-gc-protects)
 512   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 513   (let*
 514       ((protects (sort
 515            (hash-table->alist (ly:protects))
 516            (lambda (a b)
 517              (< (object-address (car a))
 518                 (object-address (car b))))))
 519        (outfile    (open-file (string-append
 520                "gcstat-" (number->string gc-protect-stat-count)
 521                ".scm"
 522                ) "w"))
 523        )
 524
 525     (display "DUMPING...\n")
 526     (display
 527      (filter
 528       (lambda (x) (not (symbol? x)))
 529       (map (lambda (y)
 530              (let
 531                  ((x (car y))
 532                   (c (cdr y)))
 533
 534                (string-append
 535                 (string-join
 536                  (map object->string (list (object-address x) c x))
 537                  " ")
 538                 "\n")))
 539            protects))
 540      outfile)
 541
 542     ))
 543
 544 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 545
 546 (define-public (lilypond-main files)
 547   "Entry point for Lilypond"
 548   (let*
 549       ((failed '())
 550        (handler (lambda (key arg)
 551                   (set! failed (cons arg failed))))
 552        )
 553
 554     (for-each
 555      (lambda (fn)
 556         (catch 'ly-file-failed
 557               (lambda () (ly:parse-file fn))
 558               handler))
 559
 560         files)
 561
 562     (if (pair? failed)
 563         (begin
 564           (display (string-append "\n *** Failed files: " (string-join failed) "\n" ))
 565           (exit 1))
 566         (exit 0))
 567
 568     ))
 569
 570