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