[scm]: Use two spaces after full stop in doc strings.

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

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index 7a1141d8f4e284af472aa6d6ae0331587d283784..6fb605b25066d01dc24ce490058846caa6f773f6 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -1,10 +1,23 @@
+;;;; This file is part of LilyPond, the GNU music typesetter.

 ;;;;
 ;;;;

-;;;; lily-library.scm -- utilities
-;;;;
-;;;;  source file of the GNU LilyPond music typesetter
-;;;; 
-;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen <janneke@gnu.org>

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

+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
+
+; for take, drop, take-while, list-index, and find-tail:
+(use-modules (srfi srfi-1))

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


@@ -44,11 +57,24 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; moments
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; moments
 

-(define-public ZERO-MOMENT (ly:make-moment 0 1)) 
+(define-public ZERO-MOMENT (ly:make-moment 0 1))

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

+(define-public (moment<=? a b)
+  (or (equal? a b)
+      (ly:moment<? a b)))
+
+(define-public (fraction->moment fraction)
+  (if (null? fraction)
+      ZERO-MOMENT
+      (ly:make-moment (car fraction) (cdr fraction))))
+
+(define-public (moment->fraction moment)
+  (cons (ly:moment-main-numerator moment)
+        (ly:moment-main-denominator moment)))
+

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; arithmetic
 (define-public (average x . lst)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; arithmetic
 (define-public (average x . lst)


@@ -57,30 +83,48 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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 (collect-music-aux score-handler parser music)
+(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)
   (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
-        (for-each (lambda (symbol)
-                    (let ((permission (music-property symbol)))
-                      (if (symbol? permission)
-                          (score-handler
-                           (ly:make-page-marker symbol
-                                                (if (eqv? 'forbid permission)
-                                                    '()
-                                                    permission))))))
-                  (list 'line-break-permission 'page-break-permission
-                        'page-turn-permission)))
+        ;; 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
        ((not (music-property 'void))
         ;; a regular music expression: make a score with this music
         ;; void music is discarded


@@ -102,31 +146,68 @@
 
 (define-public (scorify-music music parser)
   "Preprocess MUSIC."
 
 (define-public (scorify-music music parser)
   "Preprocess MUSIC."

-  
+

   (for-each (lambda (func)
              (set! music (func music parser)))
            toplevel-music-functions)
 
   (ly:make-score music))
 
   (for-each (lambda (func)
              (set! music (func music parser)))
            toplevel-music-functions)
 
   (ly:make-score music))
 

-(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))
-       (base (ly:parser-output-name parser)))

 
 

-    ;; must be careful: output-count is under user control.
-    (if (not (integer? count))
-       (set! count 0))
+(define (get-current-filename parser)
+  "return any suffix value for output filename allowing for settings by
+calls to bookOutputName function"
+  (let ((book-filename (ly:parser-lookup parser 'book-filename)))
+    (if (not book-filename)
+       (ly:parser-output-name parser)
+       book-filename)))
+
+(define (get-current-suffix parser)
+  "return any suffix value for output filename allowing for settings by calls to
+bookoutput function"
+  (let ((book-output-suffix (ly:parser-lookup parser 'book-output-suffix)))
+    (if (not (string? book-output-suffix))
+       (ly:parser-lookup parser 'output-suffix)
+       book-output-suffix)))
+
+(define-public current-outfile-name #f)  ; for use by regression tests
+
+(define (get-outfile-name parser)
+  "return current filename for generating backend output files"
+  ;; user can now override the base file name, so we have to use
+  ;; the file-name concatenated with any potential output-suffix value
+  ;; as the key to out internal a-list
+  (let* ((base-name (get-current-filename parser))
+        (output-suffix (get-current-suffix parser))
+        (alist-key (format "~a~a" base-name output-suffix))
+        (counter-alist (ly:parser-lookup parser 'counter-alist))
+        (output-count (assoc-get alist-key counter-alist 0))
+        (result base-name))
+    ;; Allow all ASCII alphanumerics, including accents
+    (if (string? output-suffix)
+        (set! result
+              (format "~a-~a"
+                      result
+                      (string-regexp-substitute
+                       "[^-[:alnum:]]"
+                       "_"
+                       output-suffix))))
+
+    ;; assoc-get call will always have returned a number
+    (if (> output-count 0)
+        (set! result (format #f "~a-~a" result output-count)))
+
+    (ly:parser-define!
+     parser 'counter-alist
+     (assoc-set! counter-alist alist-key (1+ output-count)))
+    (set! current-outfile-name result)
+    result))

 
 

-    (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)
-    ))
+(define (print-book-with parser book process-procedure)
+  (let* ((paper (ly:parser-lookup parser '$defaultpaper))
+        (layout (ly:parser-lookup parser '$defaultlayout))
+        (outfile-name (get-outfile-name parser)))
+    (process-procedure book paper layout outfile-name)))

 
 (define-public (print-book-with-defaults parser book)
   (print-book-with parser book ly:book-process))
 
 (define-public (print-book-with-defaults parser book)
   (print-book-with parser book ly:book-process))


@@ -134,11 +215,35 @@
 (define-public (print-book-with-defaults-as-systems parser book)
   (print-book-with parser book ly:book-process-to-systems))
 
 (define-public (print-book-with-defaults-as-systems parser book)
   (print-book-with parser book ly:book-process-to-systems))
 

+;; Add a score to the current bookpart, book or toplevel
+(define-public (add-score parser score)
+    (cond
+      ((ly:parser-lookup parser '$current-bookpart)
+          ((ly:parser-lookup parser 'bookpart-score-handler)
+               (ly:parser-lookup parser '$current-bookpart) score))
+      ((ly:parser-lookup parser '$current-book)
+          ((ly:parser-lookup parser 'book-score-handler)
+               (ly:parser-lookup parser '$current-book) score))
+      (else
+          ((ly:parser-lookup parser 'toplevel-score-handler) parser score))))
+
+(define-public (add-text parser text)
+  (add-score parser (list text)))
+
+(define-public (add-music parser music)
+  (collect-music-aux (lambda (score)
+                      (add-score parser score))
+                     parser
+                    music))
+
+

 ;;;;;;;;;;;;;;;;
 ;; alist
 
 (define-public assoc-get ly:assoc-get)
 
 ;;;;;;;;;;;;;;;;
 ;; alist
 
 (define-public assoc-get ly:assoc-get)
 

+(define-public chain-assoc-get ly:chain-assoc-get)
+

 (define-public (uniqued-alist alist acc)
   (if (null? alist) acc
       (if (assoc (caar alist) acc)
 (define-public (uniqued-alist alist acc)
   (if (null? alist) acc
       (if (assoc (caar alist) acc)


@@ -149,21 +254,6 @@
   (string<? (symbol->string (car x))
            (symbol->string (car y))))
 
   (string<? (symbol->string (car x))
            (symbol->string (car y))))
 

-(define-public (chain-assoc-get x alist-list . default)
-  "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
-found."
-
-  (define (helper x alist-list default)
-    (if (null? alist-list)
-       default
-       (let* ((handle (assoc x (car alist-list))))
-         (if (pair? handle)
-             (cdr handle)
-             (helper x (cdr alist-list) default)))))
-
-  (helper x alist-list
-         (if (pair? default) (car default) #f)))
-

 (define (map-alist-vals func list)
   "map FUNC over the vals of  LIST, leaving the keys."
   (if (null?  list)
 (define (map-alist-vals func list)
   "map FUNC over the vals of  LIST, leaving the keys."
   (if (null?  list)


@@ -172,7 +262,7 @@ found."
            (map-alist-vals func (cdr list)))))
 
 (define (map-alist-keys func list)
            (map-alist-vals func (cdr list)))))
 
 (define (map-alist-keys func list)

-  "map FUNC over the keys of an alist LIST, leaving the vals. "
+  "map FUNC over the keys of an alist LIST, leaving the vals."

   (if (null?  list)
       '()
       (cons (cons (func (caar list)) (cdar list))
   (if (null?  list)
       '()
       (cons (cons (func (caar list)) (cdar list))


@@ -199,6 +289,36 @@ found."
            (cons (cdar alist)
                  (flatten-alist (cdr alist))))))
 
            (cons (cdar alist)
                  (flatten-alist (cdr alist))))))
 

+(define (assoc-remove key alist)
+  "Remove key (and its corresponding value) from an alist.
+   Different than assoc-remove! because it is non-destructive."
+  (define (assoc-crawler key l r)
+    (if (null? r)
+        l
+        (if (equal? (caar r) key)
+            (append l (cdr r))
+            (assoc-crawler key (append l `(,(car r))) (cdr r)))))
+  (assoc-crawler key '() alist))
+
+(define-public (map-selected-alist-keys function keys alist)
+  "Returns alist with function applied to all of the values in list keys.
+   For example:
+   @code{guile> (map-selected-alist-keys - '(a b) '((a . 1) (b . -2) (c . 3) (d . 4)))}
+   @code{((a . -1) (b . 2) (c . 3) (d . 4))}"
+   (define (map-selected-alist-keys-helper function key alist)
+     (map
+     (lambda (pair)
+       (if (equal? key (car pair))
+           (cons key (function (cdr pair)))
+           pair))
+     alist))
+   (if (null? keys)
+       alist
+       (map-selected-alist-keys
+         function
+         (cdr keys)
+         (map-selected-alist-keys-helper function (car keys) alist))))
+

 ;;;;;;;;;;;;;;;;
 ;; vector
 
 ;;;;;;;;;;;;;;;;
 ;; vector
 


@@ -215,7 +335,7 @@ found."
   (hash-fold (lambda (k v acc) (acons  k v  acc))
             '() t))
 
   (hash-fold (lambda (k v acc) (acons  k v  acc))
             '() t))
 

-;; todo: code dup with C++. 
+;; todo: code dup with C++.

 (define-safe-public (alist->hash-table lst)
   "Convert alist to table"
   (let ((m (make-hash-table (length lst))))
 (define-safe-public (alist->hash-table lst)
   "Convert alist to table"
   (let ((m (make-hash-table (length lst))))


@@ -228,7 +348,7 @@ found."
 (define (functional-or . rest)
   (if (pair? rest)
       (or (car rest)
 (define (functional-or . rest)
   (if (pair? rest)
       (or (car rest)

-          (apply functional-and (cdr rest)))
+          (apply functional-or (cdr rest)))

       #f))
 
 (define (functional-and . rest)
       #f))
 
 (define (functional-and . rest)


@@ -239,14 +359,14 @@ found."
 
 (define (split-list lst n)
   "Split LST in N equal sized parts"
 
 (define (split-list lst n)
   "Split LST in N equal sized parts"

-  
+

   (define (helper todo acc-vector k)
     (if (null? todo)
        acc-vector
        (begin
          (if (< k 0)
              (set! k (+ n k)))
   (define (helper todo acc-vector k)
     (if (null? todo)
        acc-vector
        (begin
          (if (< k 0)
              (set! k (+ n k)))

-           
+

          (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
          (helper (cdr todo) acc-vector (1- k)))))
 
          (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
          (helper (cdr todo) acc-vector (1- k)))))
 


@@ -263,7 +383,7 @@ found."
   (helper lst 0))
 
 (define-public (count-list lst)
   (helper lst 0))
 
 (define-public (count-list lst)

-  "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
+  "Given lst (E1 E2 .. ), return ((E1 . 1) (E2 . 2) ... )."

 
   (define (helper l acc count)
     (if (pair? l)
 
   (define (helper l acc count)
     (if (pair? l)


@@ -272,7 +392,7 @@ found."
 
 
   (reverse (helper lst '() 1)))
 
 
   (reverse (helper lst '() 1)))

-  
+

 (define-public (list-join lst intermediate)
   "put INTERMEDIATE  between all elts of LST."
 
 (define-public (list-join lst intermediate)
   "put INTERMEDIATE  between all elts of LST."
 


@@ -288,82 +408,58 @@ found."
    (lambda (x) x)
    (map proc lst)))
 
    (lambda (x) x)
    (map proc lst)))
 

-
-(define (flatten-list lst)
-  "Unnest LST" 
-  (if (null? lst)
-      '()
-      (if (pair? (car lst))
-         (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
-         (cons (car lst) (flatten-list (cdr lst))))))
+(define-public (flatten-list x)
+  "Unnest list."
+  (cond ((null? x) '())
+        ((not (pair? x)) (list x))
+        (else (append (flatten-list (car x))
+                      (flatten-list (cdr x))))))

 
 (define (list-minus a b)
   "Return list of elements in A that are not in B."
   (lset-difference eq? a b))
 
 (define-public (uniq-list lst)
 
 (define (list-minus a b)
   "Return list of elements in A that are not in B."
   (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! 
+  (reverse!

    (fold (lambda (x acc)
           (if (null? acc)
               (list x)
    (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 (lambda (x y) (not (pred x y)))
+                          lst
+                          (cdr 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))

-       (+ (cdr a) (cdr b)))) 
+       (+ (cdr a) (cdr b))))

 
 (define-public (offset-flip-y o)
   (cons (car o) (- (cdr o))))
 
 (define-public (offset-flip-y o)
   (cons (car o) (- (cdr o))))


@@ -379,36 +475,27 @@ found."
            (ly:list->offsets accum (cddr coords)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            (ly:list->offsets accum (cddr coords)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-;; numbers
+;; intervals

 
 

-(if (not (defined? 'nan?)) ;; guile 1.6 compat
-    (define-public (nan? x) (not (or (< 0.0 x)
-                                    (> 0.0 x)
-                                    (= 0.0 x)))))
+(define-public empty-interval '(+inf.0 . -inf.0))

 
 

-(if (not (defined? 'inf?))
-    (define-public (inf? x) (= (/ 1.0 x) 0.0)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; intervals
+(define-public (symmetric-interval expr)
+  (cons (- expr) expr))

 
 (define-public (interval-length x)
   "Length of the number-pair X, when an interval"
   (max 0 (- (cdr x) (car x))))
 
 
 (define-public (interval-length x)
   "Length of the number-pair X, when an interval"
   (max 0 (- (cdr x) (car x))))
 

-(define-public interval-start car)

 (define-public (ordered-cons a b)
   (cons (min a b)
        (max a b)))
 
 (define-public (ordered-cons a b)
   (cons (min a b)
        (max a b)))
 

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

-  
+

   (* (+  (interval-start interval) (interval-end interval)
         (* dir (- (interval-end interval) (interval-start interval))))
      0.5))
   (* (+  (interval-start interval) (interval-end interval)
         (* dir (- (interval-end interval) (interval-start interval))))
      0.5))


@@ -420,25 +507,28 @@ found."
       (/ (+ (car x) (cdr x)) 2)))
 
 (define-public interval-start car)
       (/ (+ (car x) (cdr x)) 2)))
 
 (define-public interval-start car)

+

 (define-public interval-end cdr)
 (define-public interval-end cdr)

-(define-public (interval-translate iv amount)
-  (cons (+ amount (car iv))
-       (+ amount (cdr iv))))

 
 (define (other-axis a)
   (remainder (+ a 1) 2))
 
 (define-public (interval-widen iv amount)
 
 (define (other-axis a)
   (remainder (+ a 1) 2))
 
 (define-public (interval-widen iv amount)

-   (cons (- (car iv) amount)
-         (+ (cdr iv) amount)))
-
+  (cons (- (car iv) amount)
+    (+ (cdr iv) amount)))

 
 (define-public (interval-empty? iv)
    (> (car iv) (cdr iv)))
 
 (define-public (interval-union i1 i2)
 
 (define-public (interval-empty? iv)
    (> (car iv) (cdr iv)))
 
 (define-public (interval-union i1 i2)

-   (cons (min (car i1) (car i2))
-        (max (cdr i1) (cdr i2))))
+  (cons
+    (min (car i1) (car i2))
+    (max (cdr i1) (cdr i2))))
+
+(define-public (interval-intersection i1 i2)
+   (cons
+     (max (car i1) (car i2))
+     (min (cdr i1) (cdr i2))))

 
 (define-public (interval-sane? i)
   (not (or  (nan? (car i))
 
 (define-public (interval-sane? i)
   (not (or  (nan? (car i))


@@ -447,6 +537,107 @@ found."
            (inf? (cdr i))
            (> (car i) (cdr i)))))
 
            (inf? (cdr i))
            (> (car i) (cdr i)))))
 

+(define-public (add-point interval p)
+  (cons (min (interval-start interval) p)
+        (max (interval-end interval) p)))
+
+(define-public (reverse-interval iv)
+  (cons (cdr iv) (car iv)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; coordinates
+
+(define coord-x car)
+(define coord-y cdr)
+
+(define (coord-operation operator operand coordinate)
+  (if (pair? operand)
+    (cons (operator (coord-x operand) (coord-x coordinate))
+          (operator (coord-y operand) (coord-y coordinate)))
+    (cons (operator operand (coord-x coordinate))
+          (operator operand (coord-y coordinate)))))
+
+(define (coord-apply function coordinate)
+  (if (pair? function)
+    (cons
+      ((coord-x function) (coord-x coordinate))
+      ((coord-y function) (coord-y coordinate)))
+    (cons
+      (function (coord-x coordinate))
+      (function (coord-y coordinate)))))
+
+(define-public (coord-translate coordinate amount)
+  (coord-operation + amount coordinate))
+
+(define-public (coord-scale coordinate amount)
+  (coord-operation * amount coordinate))
+
+(define-public (coord-rotate coordinate degrees-in-radians)
+  (let*
+    ((coordinate
+      (cons
+        (exact->inexact (coord-x coordinate))
+        (exact->inexact (coord-y coordinate))))
+     (radius
+      (sqrt
+        (+ (* (coord-x coordinate) (coord-x coordinate))
+           (* (coord-y coordinate) (coord-y coordinate)))))
+    (angle (angle-0-2pi (atan (coord-y coordinate) (coord-x coordinate)))))
+   (cons
+     (* radius (cos (+ angle degrees-in-radians)))
+     (* radius (sin (+ angle degrees-in-radians))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; trig
+
+(define-public PI (* 4 (atan 1)))
+
+(define-public TWO-PI (* 2 PI))
+
+(define-public PI-OVER-TWO (/ PI 2))
+
+(define-public THREE-PI-OVER-TWO (* 3 PI-OVER-TWO))
+
+(define-public (cyclic-base-value value cycle)
+  "Takes a value and modulo-maps it between 0 and base."
+  (if (< value 0)
+      (cyclic-base-value (+ value cycle) cycle)
+      (if (>= value cycle)
+          (cyclic-base-value (- value cycle) cycle)
+          value)))
+
+(define-public (angle-0-2pi angle)
+  "Takes an angle in radians and maps it between 0 and 2pi."
+  (cyclic-base-value angle TWO-PI))
+
+(define-public (angle-0-360 angle)
+  "Takes an angle in radians and maps it between 0 and 2pi."
+  (cyclic-base-value angle 360.0))
+
+(define-public PI-OVER-180  (/ PI 180))
+
+(define-public (degrees->radians angle-degrees)
+  "Convert the given angle from degrees to radians"
+  (* angle-degrees PI-OVER-180))
+
+(define-public (ellipse-radius x-radius y-radius angle)
+  (/
+    (* x-radius y-radius)
+    (sqrt
+      (+ (* (expt y-radius 2)
+            (* (cos angle) (cos angle)))
+        (* (expt x-radius 2)
+           (* (sin angle) (sin angle)))))))
+
+(define-public (polar->rectangular radius angle-in-degrees)
+  "Convert polar coordinate @code{radius} and @code{angle-in-degrees}
+   to (x-length . y-length)"
+  (let ((complex (make-polar
+                    radius
+                    (degrees->radians angle-in-degrees))))
+     (cons
+       (real-part complex)
+       (imag-part complex))))

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; string
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; string


@@ -455,10 +646,10 @@ found."
   (equal? suffix (substring s
                            (max 0 (- (string-length s) (string-length suffix)))
                            (string-length s))))
   (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)))))

-            
+

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


@@ -484,6 +675,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,7 +713,7 @@ possibly turned off."
   (fold-right conc #f lst))
 
 (define-public (string-regexp-substitute a b str)
   (fold-right conc #f lst))
 
 (define-public (string-regexp-substitute a b str)

-  (regexp-substitute/global #f a str 'pre b 'post)) 
+  (regexp-substitute/global #f a str 'pre b 'post))

 
 (define (regexp-split str regex)
   (define matches '())
 
 (define (regexp-split str regex)
   (define matches '())


@@ -540,31 +736,80 @@ 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 (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 (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-key<? lst r)
   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 
 (define-public (symbol<? lst r)
   (string<? (symbol->string lst) (symbol->string r)))
 
 (define-public (symbol-key<? lst r)
   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 

+(define-public (eval-carefully symbol module . default)
+  "Check if all symbols in expr SYMBOL are reachable
+in module MODULE.  In that case evaluate, otherwise
+print a warning and set an optional DEFAULT."
+  (let* ((unavailable? (lambda (sym)
+                         (not (module-defined? module sym))))
+        (sym-unavailable (if (pair? symbol)
+                             (filter
+                               unavailable?
+                               (filter symbol? (flatten-list symbol)))
+                             (if (unavailable? symbol)
+                                  #t
+                                  '()))))
+    (if (null? sym-unavailable)
+        (eval symbol module)
+        (let* ((def (and (pair? default) (car default))))
+          (ly:programming-error
+            "cannot evaluate ~S in module ~S, setting to ~S"
+            (object->string symbol)
+            (object->string module)
+            (object->string def))
+          def))))
+
+;;
+;; don't confuse users with #<procedure .. > syntax.

 ;;
 ;;

-;; don't confuse users with #<procedure .. > syntax. 
-;; 

 (define-public (scm->string val)
 (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)))


@@ -580,17 +825,11 @@ 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.
+  (if (string? font)
+      (string-downcase 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))))
+         (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))


@@ -603,16 +842,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")))