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