Run `make grand-replace'.

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

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 1e8fe97e477809c669338cb9072e8594a31adb16..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>
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


@@ -49,46 +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 <-> output hooks.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; parser <-> output hooks.

-
-;; 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)))

                
                

+(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)))


@@ -96,73 +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)))
-
-    (if (not (integer? count))
-       (set! count 0))
+       (base (ly:parser-output-name parser))
+       (output-suffix (ly:parser-lookup parser 'output-suffix)) )

 
 

-    (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))
-       (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))

+    (process-procedure book paper layout base)
+    ))

 
 

-    (if (not (ly:score-error? score))
-       (let*
-           ((header (ly:score-header score))
-            (output-defs (ly:score-output-defs score))
-            (layout-defs (filter  (lambda (d) (eq? #t (ly:output-def-lookup d 'is-layout)))
-                                 output-defs))
-            (midi-defs (filter (lambda (d)  (eq? #t (ly:output-def-lookup d 'is-midi)))
-                               output-defs))
-            (music (ly:score-music score))
-            (layout-def (if (null? layout-defs)
-                            (ly:parser-lookup parser '$defaultlayout)
-                            (car layout-defs))))
-
-         (if (not (module? header))
-             (set! header (ly:parser-lookup parser '$defaultheader)))
-            
-         (ly:render-music-as-systems
-          music layout-def paper header base)
-
-         (if (pair? midi-defs)
-             (ly:performance-write (ly:format-output (ly:run-translator music (car midi-defs)))
-                                   (format #f "~a.midi" 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


@@ -179,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."


@@ -249,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)


@@ -355,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) '()))


@@ -456,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)"
   


@@ -499,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")


@@ -510,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))


@@ -530,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,


@@ -592,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)))


@@ -647,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")))