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