Add Documentation/pictures to lilypond-book include path

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

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 47e1bcd3cad5f3d5497b70717e5d368bdc285092..adb2bdfdc8ccde720798cb57a8d572885a221afc 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -3,9 +3,12 @@
 ;;;;
 ;;;;  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--2009 Jan Nieuwenhuizen <janneke@gnu.org>

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

+; for take, drop, take-while, list-index, and find-tail:
+(use-modules (srfi srfi-1))
+

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; constants.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; constants.
 


@@ -56,18 +59,67 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; parser <-> output hooks.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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)
 (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)))))
+  "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)
   "Preprocess MUSIC."
 
 (define-public (scorify-music music parser)
   "Preprocess MUSIC."


@@ -82,9 +134,13 @@
   (let*
       ((paper (ly:parser-lookup parser '$defaultpaper))
        (layout (ly:parser-lookup parser '$defaultlayout))
   (let*
       ((paper (ly:parser-lookup parser '$defaultpaper))
        (layout (ly:parser-lookup parser '$defaultlayout))

-

        (count (ly:parser-lookup parser 'output-count))
        (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 (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))
 
     ;; must be careful: output-count is under user control.
     (if (not (integer? count))


@@ -92,7 +148,6 @@
 
     (if (> count 0)
        (set! base (format #f "~a-~a" base count)))
 
     (if (> count 0)
        (set! base (format #f "~a-~a" base count)))

-

     (ly:parser-define! parser 'output-count (1+ count))
     (process-procedure book paper layout base)
     ))
     (ly:parser-define! parser 'output-count (1+ count))
     (process-procedure book paper layout base)
     ))


@@ -118,14 +173,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."


@@ -279,64 +326,40 @@ 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) '()))
 

-(define (split-at-predicate predicate lst)
- "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
-  into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) 
-  Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
-  L1 is copied, L2 not.
-
-  (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
- 
- ;; " Emacs is broken
-
- (define (inner-split predicate lst acc)
-   (cond
-    ((null? lst) acc)
-    ((null? (cdr lst))
-     (set-car! acc (cons (car lst) (car acc)))
-     acc)
-    ((predicate (car lst) (cadr lst))
-     (set-car! acc (cons (car lst) (car acc)))
-     (inner-split predicate (cdr lst) acc))
-    (else
-     (set-car! acc (cons (car lst) (car acc)))
-     (set-cdr! acc (cdr lst))
-     acc)))
- 
- (let* ((c (cons '() '())))
-   (inner-split predicate lst  c)
-   (set-car! c (reverse! (car c)))
-   c))
-
-(define-public (split-list-by-separator lst sep?)
-   "(display (split-list-by-separator '(a b c / d e f / g) (lambda (x) (equal? x '/))))
-   =>
-   ((a b c) (d e f) (g))
-  "
-   ;; " Emacs is broken
-   (define (split-one sep?  lst acc)
-     "Split off the first parts before separator and return both parts."
-     (if (null? lst)
-        (cons acc '())
-        (if (sep? (car lst))
-            (cons acc (cdr lst))
-            (split-one sep? (cdr lst) (cons (car lst) acc)))))
-   
-   (if (null? lst)
-       '()
-       (let* ((c (split-one sep? lst '())))
-        (cons (reverse! (car c) '()) (split-list-by-separator (cdr c) sep?)))))
+(define (split-at-predicate pred lst)
+  "Split LST into two lists at the first element that returns #f for
+  (PRED previous_element element). Return the two parts as a pair.
+  Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
+  (if (null? lst)
+      (list lst)
+      (let ((i (list-index pred (cdr lst) lst)))
+        (if i
+            (cons (take lst (1+ i)) (drop lst (1+ i)))
+            (list lst)))))
+
+(define-public (split-list-by-separator lst pred)
+  "Split LST at each element that satisfies PRED, and return the parts
+  (with the separators removed) as a list of lists. Example:
+  (split-list-by-separator '(a 0 b c 1 d) number?) ==> ((a) (b c) (d))"
+  (let loop ((result '()) (lst lst))
+    (if (and lst (not (null? lst)))
+        (loop
+          (append result
+                  (list (take-while (lambda (x) (not (pred x))) lst)))
+          (let ((tail (find-tail pred lst)))
+            (if tail (cdr tail) #f)))
+       result)))

 
 (define-public (offset-add a b)
   (cons (+ (car a) (car b))
 
 (define-public (offset-add a b)
   (cons (+ (car a) (car b))


@@ -380,6 +403,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)"
   


@@ -426,9 +452,9 @@ found."
 ;; string
 
 (define-public (string-endswith s suffix)
 ;; string
 
 (define-public (string-endswith s suffix)

-  (equal? prefix (substring s
-                           (max 0 (- (string-length s))
-                                (min (string-length s) (string-length prefix))))))
+  (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-startswith s prefix)
   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))


@@ -441,9 +467,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))


@@ -461,6 +484,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,


@@ -517,19 +545,30 @@ possibly turned off."
    (reverse matches))
 
 ;;;;;;;;;;;;;;;;
    (reverse matches))
 
 ;;;;;;;;;;;;;;;;

-; other
+;; other
+

 (define (sign x)
   (if (= x 0)
       0
       (if (< x 0) -1 1)))
 
 (define (sign x)
   (if (= x 0)
       0
       (if (< x 0) -1 1)))
 

-(define-public (round2 num)
-  (/ (round (* 100 num)) 100))
-
-(define-public (round4 num)
-  (/ (round (* 10000 num)) 10000))
-
-(define-public (car< a b) (< (car a) (car b)))
+(define-public (binary-search start end getter target-val)
+  (_i "Find the index between @var{start} and @var{end} (an integer)
+which will produce the closest match to @var{target-val} when
+applied to function @var{getter}.")
+  (if (<= end start)
+      start
+      (let* ((compare (quotient (+ start end) 2))
+            (get-val (getter compare)))
+       (cond
+        ((< target-val get-val)
+         (set! end (1- compare)))
+        ((< get-val target-val)
+         (set! start (1+ compare))))
+       (binary-search start end getter target-val))))
+
+(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)))


@@ -541,11 +580,19 @@ possibly turned off."
 ;; don't confuse users with #<procedure .. > syntax. 
 ;; 
 (define-public (scm->string val)
 ;; don't confuse users with #<procedure .. > syntax. 
 ;; 
 (define-public (scm->string val)

-  (if (and (procedure? val) (symbol? (procedure-name val)))
+  (if (and (procedure? val)
+          (symbol? (procedure-name val)))

       (symbol->string (procedure-name val))
       (string-append
       (symbol->string (procedure-name val))
       (string-append

-       (if (self-evaluating? val) "" "'")
-       (call-with-output-string (lambda (port) (display val port))))))
+       (if (self-evaluating? val)
+          (if (string? val)
+              "\""
+              "")
+          "'")
+       (call-with-output-string (lambda (port) (display val port)))
+       (if (string? val)
+          "\""
+          ""))))

 
 (define-public (!= lst r)
   (not (= lst r)))
 
 (define-public (!= lst r)
   (not (= lst r)))


@@ -561,17 +608,19 @@ possibly turned off."
 
 ;;; FONT may be font smob, or pango font string...
 (define-public (font-name-style font)
 
 ;;; FONT may be font smob, or pango font string...
 (define-public (font-name-style font)

-      ;; FIXME: ughr, (ly:font-name) sometimes also has Style appended.
+  ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
+  (if (and (string? font)
+          (string-prefix? "feta-alphabet" font))
+      (string-append "emmentaler"
+                    "-"
+                    (substring font
+                               (string-length "feta-alphabet")
+                               (string-length font)))

       (let* ((font-name (ly:font-name font))
       (let* ((font-name (ly:font-name font))

-            (full-name (if font-name font-name (ly:font-file-name font)))
-            (name-style (string-split full-name #\-)))
-       ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
-       (if (string-prefix? "feta-alphabet" full-name)
-           (list "emmentaler"
-                 (substring  full-name (string-length "feta-alphabet")))
-           (if (not (null? (cdr name-style)))
-           name-style
-           (append name-style '("Regular"))))))
+            (full-name (if font-name font-name (ly:font-file-name font))))
+       (if (string-prefix? "Aybabtu" full-name)
+           "aybabtu"
+           (string-downcase full-name)))))

 
 (define-public (modified-font-metric-font-scaling font)
   (let* ((designsize (ly:font-design-size font))
 
 (define-public (modified-font-metric-font-scaling font)
   (let* ((designsize (ly:font-design-size font))


@@ -584,16 +633,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

-   "~a:0: ~a: ~a" 
+   "~a:0: ~a ~a" 

     input-file-name
     input-file-name

-    (_ "warning: ")
+    (_ "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
     (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

-   "~a:0: ~a: ~a" 
+   "~a:0: ~a ~a" 

     input-file-name
     input-file-name

-    (_ "warning: ")
+    (_ "warning:")

     (_ "old relative compatibility not used")))
     (_ "old relative compatibility not used")))