Run `make grand-replace'.

[lilypond.git] / scm / lily-library.scm

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 0d09beae53b5c6f9e994c10cbc5dbe0cd192eb47..8176db1d7b66ee31ec1ebd4f881709e662cc8545 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -3,7 +3,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 

-;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; (c) 1998--2008 Jan Nieuwenhuizen <janneke@gnu.org>

 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


@@ -19,16 +19,27 @@
 (define-public DOWN -1)
 (define-public CENTER 0)
 
 (define-public DOWN -1)
 (define-public CENTER 0)
 

-(define-safe-public DOUBLE-FLAT -4)
-(define-safe-public THREE-Q-FLAT -3)
-(define-safe-public FLAT -2)
-(define-safe-public SEMI-FLAT -1)
+(define-safe-public DOUBLE-FLAT-QTS -4)
+(define-safe-public THREE-Q-FLAT-QTS -3)
+(define-safe-public FLAT-QTS -2)
+(define-safe-public SEMI-FLAT-QTS -1)
+(define-safe-public NATURAL-QTS 0)
+(define-safe-public SEMI-SHARP-QTS 1)
+(define-safe-public SHARP-QTS 2)
+(define-safe-public THREE-Q-SHARP-QTS 3)
+(define-safe-public DOUBLE-SHARP-QTS 4)
+(define-safe-public SEMI-TONE-QTS 2)
+
+(define-safe-public DOUBLE-FLAT  -1)
+(define-safe-public THREE-Q-FLAT -3/4)
+(define-safe-public FLAT -1/2)
+(define-safe-public SEMI-FLAT -1/4)

 (define-safe-public NATURAL 0)
 (define-safe-public NATURAL 0)

-(define-safe-public SEMI-SHARP 1)
-(define-safe-public SHARP 2)
-(define-safe-public THREE-Q-SHARP 3)
-(define-safe-public DOUBLE-SHARP 4)
-(define-safe-public SEMI-TONE 2)
+(define-safe-public SEMI-SHARP 1/4)
+(define-safe-public SHARP 1/2)
+(define-safe-public THREE-Q-SHARP 3/4)
+(define-safe-public DOUBLE-SHARP 1)
+(define-safe-public SEMI-TONE 1/2)

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; moments
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; moments


@@ -38,44 +49,77 @@
 (define-public (moment-min a b)
   (if (ly:moment<? a b) a b))
 
 (define-public (moment-min a b)
   (if (ly:moment<? a b) a b))
 

-

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; arithmetic
 (define-public (average x . lst)
   (/ (+ x (apply + lst)) (1+ (length lst))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; arithmetic
 (define-public (average x . lst)
   (/ (+ x (apply + lst)) (1+ (length lst))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-;; lily specific variables.
-
-(define-public default-script-alist '())
-
-
-;; parser stuff.
-(define-public (print-music-as-book parser music)
-  (let* ((head (ly:parser-lookup parser '$defaultheader))
-        (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
-                            head (scorify-music music parser))))
-    (print-book-with-defaults parser book)))
-
-(define-public (print-score-as-book parser score)
-  (let* ((head (ly:parser-lookup parser '$defaultheader))
-        (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
-                            head score)))
-    (print-book-with-defaults parser book)))
-
-(define-public (print-score parser score)
-  (let* ((head (ly:parser-lookup parser '$defaultheader))
-        (book (ly:make-book (ly:parser-lookup parser '$defaultpaper)
-                            head score)))
-    (ly:parser-print-score parser book)))
+;; parser <-> output hooks.

                
                

+(define-public (collect-bookpart-for-book parser book-part)
+  "Toplevel book-part handler"
+  (define (add-bookpart book-part)
+    (ly:parser-define!
+       parser 'toplevel-bookparts
+       (cons book-part (ly:parser-lookup parser 'toplevel-bookparts))))
+  ;; If toplevel scores have been found before this \bookpart,
+  ;; add them first to a dedicated bookpart
+  (if (pair? (ly:parser-lookup parser 'toplevel-scores))
+      (begin
+       (add-bookpart (ly:make-book-part
+                      (ly:parser-lookup parser 'toplevel-scores)))
+       (ly:parser-define! parser 'toplevel-scores (list))))
+  (add-bookpart book-part))
+

 (define-public (collect-scores-for-book parser score)
   (ly:parser-define!
    parser 'toplevel-scores
    (cons score (ly:parser-lookup parser 'toplevel-scores))))
 
 (define-public (collect-scores-for-book parser score)
   (ly:parser-define!
    parser 'toplevel-scores
    (cons score (ly:parser-lookup parser 'toplevel-scores))))
 

+(define-public (collect-music-aux score-handler parser music)
+  (define (music-property symbol)
+    (let ((value (ly:music-property music symbol)))
+      (if (not (null? value))
+         value
+         #f)))
+  (cond ((music-property 'page-marker)
+        ;; a page marker: set page break/turn permissions or label
+        (begin
+          (let ((label (music-property 'page-label)))
+            (if (symbol? label)
+                (score-handler (ly:make-page-label-marker label))))
+          (for-each (lambda (symbol)
+                      (let ((permission (music-property symbol)))
+                        (if (symbol? permission)
+                            (score-handler
+                             (ly:make-page-permission-marker symbol
+                                                             (if (eqv? 'forbid permission)
+                                                                 '()
+                                                                 permission))))))
+                    (list 'line-break-permission 'page-break-permission
+                          'page-turn-permission))))
+       ((not (music-property 'void))
+        ;; a regular music expression: make a score with this music
+        ;; void music is discarded
+        (score-handler (scorify-music music parser)))))
+
+(define-public (collect-music-for-book parser music)
+  "Top-level music handler"
+  (collect-music-aux (lambda (score)
+                      (collect-scores-for-book parser score))
+                     parser
+                    music))
+
+(define-public (collect-book-music-for-book parser book music)
+  "Book music handler"
+  (collect-music-aux (lambda (score)
+                      (ly:book-add-score! book score))
+                     parser
+                    music))

 
 (define-public (scorify-music music parser)
 
 (define-public (scorify-music music parser)

+  "Preprocess MUSIC."

   
   (for-each (lambda (func)
              (set! music (func music parser)))
   
   (for-each (lambda (func)
              (set! music (func music parser)))


@@ -83,48 +127,33 @@
 
   (ly:make-score music))
 
 
   (ly:make-score music))
 

-(define-public (collect-music-for-book parser music)
-  ;; discard music if its 'void property is true.
-  (let ((void-music (ly:music-property music 'void)))
-    (if (or (null? void-music) (not void-music))
-        (collect-scores-for-book parser (scorify-music music parser)))))
-
-
-(define-public (print-book-with-defaults parser book)
+(define (print-book-with parser book process-procedure)

   (let*
       ((paper (ly:parser-lookup parser '$defaultpaper))
        (layout (ly:parser-lookup parser '$defaultlayout))
        (count (ly:parser-lookup parser 'output-count))
   (let*
       ((paper (ly:parser-lookup parser '$defaultpaper))
        (layout (ly:parser-lookup parser '$defaultlayout))
        (count (ly:parser-lookup parser 'output-count))

-       (base (ly:parser-output-name parser)))
+       (base (ly:parser-output-name parser))
+       (output-suffix (ly:parser-lookup parser 'output-suffix)) )

 
 

-    (if (not (integer? count))
-       (set! count 0))
-
-    (if (> count 0)
-       (set! base (format #f "~a-~a" base count)))
-
-    (ly:parser-define! parser 'output-count (1+ count))
-    (ly:book-process book paper layout base)
-    ))
-
-(define-public (print-score-with-defaults parser score)
-  (let*
-      ((paper (ly:parser-lookup parser '$defaultpaper))
-       (layout (ly:parser-lookup parser '$defaultlayout))
-       (header (ly:parser-lookup parser '$defaultheader))
-       (count (ly:parser-lookup parser 'output-count))
-       (base (ly:parser-output-name parser)))
+    (if (string? output-suffix)
+       (set! base (format "~a-~a" base (string-regexp-substitute
+                                          "[^a-zA-Z0-9-]" "_" output-suffix))))

 
 

+    ;; must be careful: output-count is under user control.

     (if (not (integer? count))
        (set! count 0))
 
     (if (> count 0)
        (set! base (format #f "~a-~a" base count)))
     (if (not (integer? count))
        (set! count 0))
 
     (if (> count 0)
        (set! base (format #f "~a-~a" base count)))

-

     (ly:parser-define! parser 'output-count (1+ count))
     (ly:parser-define! parser 'output-count (1+ count))

-    (ly:score-process score header paper layout base)
+    (process-procedure book paper layout base)

     ))
 
     ))
 

+(define-public (print-book-with-defaults parser book)
+  (print-book-with parser book ly:book-process))
+
+(define-public (print-book-with-defaults-as-systems parser book)
+  (print-book-with parser book ly:book-process-to-systems))

 
 ;;;;;;;;;;;;;;;;
 ;; alist
 
 ;;;;;;;;;;;;;;;;
 ;; alist


@@ -141,14 +170,6 @@
   (string<? (symbol->string (car x))
            (symbol->string (car y))))
 
   (string<? (symbol->string (car x))
            (symbol->string (car y))))
 

-(define-public (chain-assoc x alist-list)
-  (if (null? alist-list)
-      #f
-      (let* ((handle (assoc x (car alist-list))))
-       (if (pair? handle)
-           handle
-           (chain-assoc x (cdr alist-list))))))
-

 (define-public (chain-assoc-get x alist-list . default)
   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
 found."
 (define-public (chain-assoc-get x alist-list . default)
   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
 found."


@@ -211,24 +232,9 @@ found."
 ;;;;;;;;;;;;;;;;
 ;; hash
 
 ;;;;;;;;;;;;;;;;
 ;; hash
 

-(if (not (defined? 'hash-table?)) ;; guile 1.6 compat
-    (begin
-      (define hash-table? vector?)
-      (define-public (hash-for-each proc tab)
-       (hash-fold (lambda (k v prior)
-                    (proc k v)
-                    #f)
-                  #f
-                  tab))
-      (define-public (hash-table->alist t)
-       "Convert table t to list"
-       (apply append (vector->list t))))
-
-    ;; native hashtabs.
-    (begin
-      (define-public (hash-table->alist t)
-       (hash-fold (lambda (k v acc) (acons  k v  acc))
-                  '() t))))
+(define-public (hash-table->alist t)
+  (hash-fold (lambda (k v acc) (acons  k v  acc))
+            '() t))

 
 ;; todo: code dup with C++. 
 (define-safe-public (alist->hash-table lst)
 
 ;; todo: code dup with C++. 
 (define-safe-public (alist->hash-table lst)


@@ -317,13 +323,13 @@ found."
   (lset-difference eq? a b))
 
 (define-public (uniq-list lst)
   (lset-difference eq? a b))
 
 (define-public (uniq-list lst)

-  "Uniq LST, assuming that it is sorted"
+  "Uniq LST, assuming that it is sorted. Uses equal? for comparisons."

 
   (reverse! 
    (fold (lambda (x acc)
           (if (null? acc)
               (list x)
 
   (reverse! 
    (fold (lambda (x acc)
           (if (null? acc)
               (list x)

-              (if (eq? x (car acc))
+              (if (equal? x (car acc))

                   acc
                   (cons x acc))))
         '() lst) '()))
                   acc
                   (cons x acc))))
         '() lst) '()))


@@ -418,6 +424,9 @@ found."
 
 (define-public interval-end cdr)
 
 
 (define-public interval-end cdr)
 

+(define-public (interval-bound interval dir)
+  ((if (= dir RIGHT) cdr car) interval))
+

 (define-public (interval-index interval dir)
   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
   
 (define-public (interval-index interval dir)
   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
   


@@ -461,9 +470,16 @@ found."
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-;;
-
-
+;; string
+
+(define-public (string-endswith s suffix)
+  (equal? suffix (substring s
+                           (max 0 (- (string-length s) (string-length suffix)))
+                           (string-length s))))
+            
+(define-public (string-startswith s prefix)
+  (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
+            

 (define-public (string-encode-integer i)
   (cond
    ((= i  0) "o")
 (define-public (string-encode-integer i)
   (cond
    ((= i  0) "o")


@@ -472,9 +488,6 @@ found."
          (make-string 1 (integer->char (+ 65 (modulo i 26))))
          (string-encode-integer (quotient i 26))))))
 
          (make-string 1 (integer->char (+ 65 (modulo i 26))))
          (string-encode-integer (quotient i 26))))))
 

-(define-public (ly:numbers->string lst)
-  (string-join (map ly:number->string lst) " "))
-

 (define (number->octal-string x)
   (let* ((n (inexact->exact x))
          (n64 (quotient n 64))
 (define (number->octal-string x)
   (let* ((n (inexact->exact x))
          (n64 (quotient n 64))


@@ -492,6 +505,11 @@ found."
   (string-append (ly:number->string (car c)) " "
                 (ly:number->string (cdr c))))
 
   (string-append (ly:number->string (car c)) " "
                 (ly:number->string (cdr c))))
 

+(define-public (dir-basename file . rest)
+  "Strip suffixes in REST, but leave directory component for FILE."
+  (define (inverse-basename x y) (basename y x))
+  (simple-format #f "~a/~a" (dirname file)
+                (fold inverse-basename file rest)))

 
 (define-public (write-me message x)
   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 
 (define-public (write-me message x)
   "Return X.  Display MESSAGE and write X.  Handy for debugging,


@@ -554,7 +572,9 @@ possibly turned off."
       0
       (if (< x 0) -1 1)))
 
       0
       (if (< x 0) -1 1)))
 

-(define-public (car< a b) (< (car a) (car b)))
+
+(define-public (car< a b)
+  (< (car a) (car b)))

 
 (define-public (symbol<? lst r)
   (string<? (symbol->string lst) (symbol->string r)))
 
 (define-public (symbol<? lst r)
   (string<? (symbol->string lst) (symbol->string r)))


@@ -609,14 +629,16 @@ possibly turned off."
 
 (define-public (version-not-seen-message input-file-name)
   (ly:message
 
 (define-public (version-not-seen-message input-file-name)
   (ly:message

-   (string-append
-    input-file-name ": 0: " (_ "warning: ")
-   (format #f
-          (_ "no \\version statement found, please add~afor future compatibility")
-          (format #f "\n\n\\version ~s\n\n" (lilypond-version))))))
+   "~a:0: ~a: ~a" 
+    input-file-name
+    (_ "warning: ")
+    (format #f
+           (_ "no \\version statement found, please add~afor future compatibility")
+           (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))

 
 (define-public (old-relative-not-used-message input-file-name)
   (ly:message
 
 (define-public (old-relative-not-used-message input-file-name)
   (ly:message

-   (string-append
-    input-file-name ": 0: " (_ "warning: ")
-    (_ "old relative compatibility not used"))))
+   "~a:0: ~a: ~a" 
+    input-file-name
+    (_ "warning: ")
+    (_ "old relative compatibility not used")))