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