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