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,
 337 possibly turned off."
 338   (display message) (write x) (newline) x)
 339 ;;  x)
 340
 341 (define (index-cell cell dir)
 342   (if (equal? dir 1)
 343       (cdr cell)
 344       (car cell)))
 345
 346 (define (cons-map f x)
 347   "map F to contents of X"
 348   (cons (f (car x)) (f (cdr x))))
 349
 350
 351 (define-public (list-insert-separator lst between)
 352   "Create new list, inserting BETWEEN between elements of LIST"
 353   (define (conc x y )
 354     (if (eq? y #f)
 355         (list x)
 356         (cons x  (cons between y))
 357         ))
 358   (fold-right conc #f lst))
 359
 360 ;;;;;;;;;;;;;;;;
 361 ; other
 362 (define (sign x)
 363   (if (= x 0)
 364       0
 365       (if (< x 0) -1 1)))
 366
 367 (define-public (symbol<? l r)
 368   (string<? (symbol->string l) (symbol->string r)))
 369
 370 (define-public (!= l r)
 371   (not (= l r)))
 372
 373 (define-public (ly:load x)
 374   (let* ((fn (%search-load-path x)))
 375     (if (ly:get-option 'verbose)
 376         (format (current-error-port) "[~A]" fn))
 377     (primitive-load fn)))
 378
 379
 380 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 381 ;;  output
 382
 383
 384 ;;(define-public (output-framework) (write "hello\n"))
 385
 386 (define output-tex-module
 387   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 388 (define output-ps-module
 389   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 390
 391 (define-public (ps-output-expression expr port)
 392   (display (eval expr output-ps-module) port))
 393
 394 ;; TODO: generate this list by registering the stencil expressions
 395 ;;       stencil expressions should have docstrings.
 396 (define-public (ly:all-stencil-expressions)
 397   "Return list of stencil expressions."
 398   '(
 399     beam
 400     bezier-sandwich
 401     blank
 402     bracket
 403     char
 404     dashed-line
 405     dashed-slur
 406     dot
 407     draw-line
 408     ez-ball
 409     filledbox
 410     horizontal-line
 411     polygon
 412     repeat-slash
 413     round-filled-box
 414     symmetric-x-triangle
 415     text
 416     tuplet
 417     white-dot
 418     white-text
 419     zigzag-line
 420     ))
 421
 422 ;; TODO:
 423 ;;  - generate this list by registering the output-backend-commands
 424 ;;    output-backend-commands should have docstrings.
 425 ;;  - remove hard copies in output-ps output-tex
 426 (define-public (ly:all-output-backend-commands)
 427   "Return list of output backend commands."
 428   '(
 429     comment
 430     grob-cause
 431     no-origin
 432     placebox
 433     unknown
 434     ))
 435
 436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 437 ;; other files.
 438
 439 (for-each ly:load
 440      ;; load-from-path
 441      '("define-music-types.scm"
 442        "output-lib.scm"
 443        "c++.scm"
 444        "chord-ignatzek-names.scm"
 445        "chord-entry.scm"
 446        "chord-generic-names.scm"
 447        "stencil.scm"
 448        "new-markup.scm"
 449        "bass-figure.scm"
 450        "music-functions.scm"
 451        "part-combiner.scm"
 452        "define-music-properties.scm"
 453        "auto-beam.scm"
 454        "chord-name.scm"
 455
 456        "ly-from-scheme.scm"
 457
 458        "define-context-properties.scm"
 459        "translation-functions.scm"
 460        "script.scm"
 461        "midi.scm"
 462        "beam.scm"
 463        "clef.scm"
 464        "slur.scm"
 465        "font.scm"
 466        "encoding.scm"
 467
 468        "fret-diagrams.scm"
 469        "define-markup-commands.scm"
 470        "define-grob-properties.scm"
 471        "define-grobs.scm"
 472        "define-grob-interfaces.scm"
 473        "page-layout.scm"
 474        "titling.scm"
 475
 476        "paper.scm"
 477
 478        ; last:
 479        "safe-lily.scm"
 480        ))
 481
 482
 483 (set! type-p-name-alist
 484   `(
 485    (,boolean-or-symbol? . "boolean or symbol")
 486    (,boolean? . "boolean")
 487    (,char? . "char")
 488    (,grob-list? . "list of grobs")
 489    (,hash-table? . "hash table")
 490    (,input-port? . "input port")
 491    (,integer? . "integer")
 492    (,list? . "list")
 493    (,ly:context? . "context")
 494    (,ly:dimension? . "dimension, in staff space")
 495    (,ly:dir? . "direction")
 496    (,ly:duration? . "duration")
 497    (,ly:grob? . "layout object")
 498    (,ly:input-location? . "input location")
 499    (,ly:moment? . "moment")
 500    (,ly:music? . "music")
 501    (,ly:pitch? . "pitch")
 502    (,ly:translator? . "translator")
 503    (,ly:font-metric? . "font metric")
 504    (,markup-list? . "list of markups")
 505    (,markup? . "markup")
 506    (,ly:music-list? . "list of music")
 507    (,number-or-grob? . "number or grob")
 508    (,number-or-string? . "number or string")
 509    (,number-pair? . "pair of numbers")
 510    (,number? . "number")
 511    (,output-port? . "output port")
 512    (,pair? . "pair")
 513    (,procedure? . "procedure")
 514    (,scheme? . "any type")
 515    (,string? . "string")
 516    (,symbol? . "symbol")
 517    (,vector? . "vector")
 518    ))
 519
 520
 521 ;; debug mem leaks
 522
 523 (define gc-protect-stat-count 0)
 524 (define-public (dump-gc-protects)
 525   (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
 526   (let*
 527       ((protects (sort
 528            (hash-table->alist (ly:protects))
 529            (lambda (a b)
 530              (< (object-address (car a))
 531                 (object-address (car b))))))
 532        (outfile    (open-file (string-append
 533                "gcstat-" (number->string gc-protect-stat-count)
 534                ".scm"
 535                ) "w")))
 536
 537     (display "DUMPING...\n")
 538     (display
 539      (filter
 540       (lambda (x) (not (symbol? x)))
 541       (map (lambda (y)
 542              (let
 543                  ((x (car y))
 544                   (c (cdr y)))
 545
 546                (string-append
 547                 (string-join
 548                  (map object->string (list (object-address x) c x))
 549                  " ")
 550                 "\n")))
 551            protects))
 552      outfile)))
 553
 554
 555 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 556
 557 (define-public (postscript->pdf papersize name)
 558   (let* ((cmd (string-append "ps2pdf -sPAPERSIZE=" papersize " " name))
 559          (output-name
 560           (regexp-substitute/global #f "\\.ps" name 'pre ".pdf" 'post)))
 561
 562     (newline)
 563     ;; FIXME: user message: should be translated
 564     (display (format "Converting to ~s..." output-name))
 565     (newline)
 566
 567     (if (ly:get-option 'verbose)
 568         ;; FIXME: user message: should be translated
 569         (display (format "Invoking ~s..." cmd)))
 570
 571   (system cmd)))
 572
 573 (define-public (postscript->png resolution name)
 574   (let
 575       ((cmd (string-append
 576            "ps2png --resolution="
 577            (if (number? resolution)
 578                (number->string resolution)
 579                "90")
 580            (if (ly:get-option 'verbose)
 581                "--verbose "
 582                " ")
 583            name)))
 584     (if (ly:get-option 'verbose)
 585         ;; FIXME: user message: should be translated
 586         (begin
 587           (display (format "Invoking ~s..." cmd))
 588           (newline)))
 589     (system cmd)))
 590
 591 (define-public (lilypond-main files)
 592   "Entry point for LilyPond."
 593   (let* ((failed '())
 594          (handler (lambda (key arg) (set! failed (cons arg failed)))))
 595     (for-each
 596      (lambda (f)
 597        (catch 'ly-file-failed (lambda () (ly:parse-file f)) handler)
 598 ;       (dump-gc-protects)
 599        )
 600      files)
 601
 602     (if (pair? failed)
 603         (begin
 604           (display
 605            ;; FIXME: user message: should be translated
 606            (string-append "\n *** Failed files: " (string-join failed) "\n"))
 607           (exit 1))
 608         (exit 0))))