add missing Pre-Depends: ${misc:Pre-Depends} for dpkg-maintscript-helper symlink

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

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index f772d0527e931efa53cdf0917fcf359012e911bb..43b05e57c20d8fa6b5b9e784d434cb5c564d1c58 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -1,10 +1,26 @@
+;;;; This file is part of LilyPond, the GNU music typesetter.

 ;;;;
 ;;;;

-;;;; lily-library.scm -- utilities
-;;;;
-;;;;  source file of the GNU LilyPond music typesetter
-;;;; 
-;;;; (c) 1998--2007 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2012 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))
+
+;; for define-safe-public when byte-compiling using Guile V2
+(use-modules (scm safe-utility-defs))

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


@@ -41,14 +57,65 @@
 (define-safe-public DOUBLE-SHARP 1)
 (define-safe-public SEMI-TONE 1/2)
 
 (define-safe-public DOUBLE-SHARP 1)
 (define-safe-public SEMI-TONE 1/2)
 

+(define-safe-public INFINITY-INT 1000000)
+

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; durations
+
+(define-public (duration-log-factor lognum)
+  "Given a logarithmic duration number, return the length of the duration,
+as a number of whole notes."
+  (or (and (exact? lognum) (integer? lognum))
+      (scm-error 'wrong-type-arg "duration-log-factor" "Not an integer: ~S" (list lognum) #f))
+  (if (<= lognum 0)
+      (ash 1 (- lognum))
+      (/ (ash 1 lognum))))
+
+(define-public (duration-dot-factor dotcount)
+  "Given a count of the dots used to extend a musical duration, return
+the numeric factor by which they increase the duration."
+  (or (and (exact? dotcount) (integer? dotcount) (>= dotcount 0))
+      (scm-error 'wrong-type-arg "duration-dot-factor" "Not a count: ~S" (list dotcount) #f))
+  (- 2 (/ (ash 1 dotcount))))
+
+(define-public (duration-length dur)
+  "Return the overall length of a duration, as a number of whole
+notes.  (Not to be confused with ly:duration-length, which returns a
+less-useful moment object.)"
+  (ly:moment-main (ly:duration-length dur)))
+
+(define-public (duration-visual dur)
+  "Given a duration object, return the visual part of the duration (base
+note length and dot count), in the form of a duration object with
+non-visual scale factor 1."
+  (ly:make-duration (ly:duration-log dur) (ly:duration-dot-count dur) 1))
+
+(define-public (duration-visual-length dur)
+  "Given a duration object, return the length of the visual part of the
+duration (base note length and dot count), as a number of whole notes."
+  (duration-length (duration-visual dur)))
+

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


@@ -57,83 +124,122 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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)
   (define (music-property symbol)

-    (let ((value (ly:music-property music symbol)))
-      (if (not (null? value))
-         value
-         #f)))
+    (ly:music-property music symbol #f))

   (cond ((music-property 'page-marker)
   (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)))))
+         ;; a page marker: set page break/turn permissions or label
+         (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 (eq? 'forbid permission)
+                                                                '()
+                                                                permission))))))
+                   '(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)

-  "Top-level music handler"
+  "Top-level music handler."

   (collect-music-aux (lambda (score)
   (collect-music-aux (lambda (score)

-                      (collect-scores-for-book parser score))
+                       (collect-scores-for-book parser score))

                      parser
                      parser

-                    music))
+                     music))

 
 (define-public (collect-book-music-for-book parser book music)
 
 (define-public (collect-book-music-for-book parser book music)

-  "Book music handler"
+  "Book music handler."

   (collect-music-aux (lambda (score)
   (collect-music-aux (lambda (score)

-                      (ly:book-add-score! book score))
+                       (ly:book-add-score! book score))

                      parser
                      parser

-                    music))
+                     music))

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

-  "Preprocess 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))
-       (output-suffix (ly:parser-lookup parser 'output-suffix)) )
-
+  "Preprocess @var{music}."
+  (ly:make-score
+   (fold (lambda (f m) (f m parser))
+         music
+         toplevel-music-functions)))
+
+(define (get-current-filename parser book)
+  "return any suffix value for output filename allowing for settings by
+calls to bookOutputName function"
+  (or (paper-variable parser book 'output-filename)
+      (ly:parser-output-name parser)))
+
+(define (get-current-suffix parser book)
+  "return any suffix value for output filename allowing for settings by calls to
+bookoutput function"
+  (let ((book-output-suffix (paper-variable 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 book)
+  "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 book))
+         (output-suffix (get-current-suffix parser book))
+         (alist-key (format #f "~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)
     (if (string? output-suffix)

-       (set! base (format "~a-~a" base (string-regexp-substitute
-                                          "[^a-zA-Z0-9-]" "_" output-suffix))))
+        (set! result
+              (format #f "~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))

 
 

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


@@ -141,70 +247,229 @@
 (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 paper-variable
+  (let
+      ((get-papers
+        (lambda (parser book)
+          (append (if (and book (ly:output-def? (ly:book-paper book)))
+                      (list (ly:book-paper book))
+                      '())
+                  (ly:parser-lookup parser '$papers)
+                  (list (ly:parser-lookup parser '$defaultpaper))))))
+    (make-procedure-with-setter
+     (lambda (parser book symbol)
+       (any (lambda (p) (ly:output-def-lookup p symbol #f))
+            (get-papers parser book)))
+     (lambda (parser book symbol value)
+       (ly:output-def-set-variable!
+        (car (get-papers parser book))
+        symbol value)))))
+
+(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))
+
+(define-public (context-mod-from-music parser music)
+  (let ((warn #t) (mods (ly:make-context-mod)))
+    (let loop ((m music))
+      (if (music-is-of-type? m 'layout-instruction-event)
+          (let ((symbol (ly:music-property m 'symbol)))
+            (ly:add-context-mod
+             mods
+             (case (ly:music-property m 'name)
+               ((PropertySet)
+                (list 'assign
+                      symbol
+                      (ly:music-property m 'value)))
+               ((PropertyUnset)
+                (list 'unset symbol))
+               ((OverrideProperty)
+                (cons* 'push
+                       symbol
+                       (ly:music-property m 'grob-value)
+                       (cond
+                        ((ly:music-property m 'grob-property #f) => list)
+                        (else
+                         (ly:music-property m 'grob-property-path)))))
+               ((RevertProperty)
+                (cons* 'pop
+                       symbol
+                       (cond
+                        ((ly:music-property m 'grob-property #f) => list)
+                        (else
+                         (ly:music-property m 'grob-property-path))))))))
+          (case (ly:music-property m 'name)
+            ((ApplyContext)
+             (ly:add-context-mod mods
+                                 (list 'apply
+                                       (ly:music-property m 'procedure))))
+            ((ContextSpeccedMusic)
+             (loop (ly:music-property m 'element)))
+            (else
+             (let ((callback (ly:music-property m 'elements-callback)))
+               (if (procedure? callback)
+                   (for-each loop (callback m))
+                   (if (and warn (ly:duration? (ly:music-property m 'duration)))
+                       (begin
+                         (ly:music-warning
+                          music
+                          (_ "Music unsuitable for context-mod"))
+                         (set! warn #f)))))))))
+    mods))
+
+(define-public (context-defs-from-music parser output-def music)
+  (let ((warn #t))
+    (let loop ((m music) (mods #f))
+      ;; The parser turns all sets, overrides etc into something
+      ;; wrapped in ContextSpeccedMusic.  If we ever get a set,
+      ;; override etc that is not wrapped in ContextSpeccedMusic, the
+      ;; user has created it in Scheme himself without providing the
+      ;; required wrapping.  In that case, using #f in the place of a
+      ;; context modification results in a reasonably recognizable
+      ;; error.
+      (if (music-is-of-type? m 'layout-instruction-event)
+          (ly:add-context-mod
+           mods
+           (case (ly:music-property m 'name)
+             ((PropertySet)
+              (list 'assign
+                    (ly:music-property m 'symbol)
+                    (ly:music-property m 'value)))
+             ((PropertyUnset)
+              (list 'unset
+                    (ly:music-property m 'symbol)))
+             ((OverrideProperty)
+              (cons* 'push
+                     (ly:music-property m 'symbol)
+                     (ly:music-property m 'grob-value)
+                     (cond
+                      ((ly:music-property m 'grob-property #f) => list)
+                      (else
+                       (ly:music-property m 'grob-property-path)))))
+             ((RevertProperty)
+              (cons* 'pop
+                     (ly:music-property m 'symbol)
+                     (cond
+                      ((ly:music-property m 'grob-property #f) => list)
+                      (else
+                       (ly:music-property m 'grob-property-path)))))))
+          (case (ly:music-property m 'name)
+            ((ApplyContext)
+             (ly:add-context-mod mods
+                                 (list 'apply
+                                       (ly:music-property m 'procedure))))
+            ((ContextSpeccedMusic)
+             ;; Use let* here to let defs catch up with modifications
+             ;; to the context defs made in the recursion
+             (let* ((mods (loop (ly:music-property m 'element)
+                                (ly:make-context-mod)))
+                    (defs (ly:output-find-context-def
+                           output-def (ly:music-property m 'context-type))))
+               (if (null? defs)
+                   (ly:music-warning
+                    music
+                    (ly:format (_ "Cannot find context-def \\~a")
+                               (ly:music-property m 'context-type)))
+                   (for-each
+                    (lambda (entry)
+                      (ly:output-def-set-variable!
+                       output-def (car entry)
+                       (ly:context-def-modify (cdr entry) mods)))
+                    defs))))
+            (else
+             (let ((callback (ly:music-property m 'elements-callback)))
+               (if (procedure? callback)
+                   (fold loop mods (callback m))
+                   (if (and warn (ly:duration? (ly:music-property m 'duration)))
+                       (begin
+                         (ly:music-warning
+                          music
+                          (_ "Music unsuitable for output-def"))
+                         (set! warn #f))))))))
+      mods)))
+
+

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

-         (uniqued-alist (cdr alist) acc)
-         (uniqued-alist (cdr alist) (cons (car alist) acc)))))
+          (uniqued-alist (cdr alist) acc)
+          (uniqued-alist (cdr alist) (cons (car alist) acc)))))

 
 (define-public (alist<? x y)
   (string<? (symbol->string (car x))
 
 (define-public (alist<? x 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)))
+            (symbol->string (car y))))

 
 (define (map-alist-vals func list)
 
 (define (map-alist-vals func list)

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

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

-           (map-alist-vals func (cdr list)))))
+            (map-alist-vals func (cdr list)))))

 
 (define (map-alist-keys func 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))

-           (map-alist-keys func (cdr list)))))
+            (map-alist-keys func (cdr list)))))

 
 (define-public (first-member members lst)
 
 (define-public (first-member members lst)

-  "Return first successful MEMBER of member from MEMBERS in LST."
-  (if (null? members)
-      #f
-      (let ((m (member (car members) lst)))
-       (if m m (first-member (cdr members) lst)))))
+  "Return first successful member (of member) from @var{members} in
+@var{lst}."
+  (any (lambda (m) (member m lst)) members))

 
 (define-public (first-assoc keys lst)
 
 (define-public (first-assoc keys lst)

-  "Return first successful ASSOC of key from KEYS in LST."
-  (if (null? keys)
-      #f
-      (let ((k (assoc (car keys) lst)))
-       (if k k (first-assoc (cdr keys) lst)))))
+  "Return first successful assoc of key from @var{keys} in @var{lst}."
+  (any (lambda (k) (assoc k lst)) keys))

 
 (define-public (flatten-alist alist)
   (if (null? alist)
       '()
       (cons (caar alist)
 
 (define-public (flatten-alist alist)
   (if (null? alist)
       '()
       (cons (caar alist)

-           (cons (cdar alist)
-                 (flatten-alist (cdr alist))))))
+            (cons (cdar alist)
+                  (flatten-alist (cdr alist))))))
+
+(define-public (map-selected-alist-keys function keys alist)
+  "Return @var{alist} with @var{function} applied to all of the values
+in list @var{keys}.
+
+For example:
+@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)}
+@end example"
+  (define (map-selected-alist-keys-helper key alist)
+    (map
+     (lambda (pair)
+       (if (equal? key (car pair))
+           (cons key (function (cdr pair)))
+           pair))
+     alist))
+  (fold map-selected-alist-keys-helper alist keys))

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


@@ -219,260 +484,315 @@ found."
 ;; hash
 
 (define-public (hash-table->alist t)
 ;; hash
 
 (define-public (hash-table->alist t)

-  (hash-fold (lambda (k v acc) (acons  k v  acc))
-            '() t))
+  (hash-fold acons '() 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))))

-    (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
+    (for-each (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)

     m))
 
 ;;;;;;;;;;;;;;;;
 ;; list
 
 (define (functional-or . rest)
     m))
 
 ;;;;;;;;;;;;;;;;
 ;; list
 
 (define (functional-or . rest)

-  (if (pair? rest)
-      (or (car rest)
-          (apply functional-and (cdr rest)))
-      #f))
+  (any identity rest))

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

-  (if (pair? rest)
-      (and (car rest)
-          (apply functional-and (cdr rest)))
-      #t))
+  (every identity rest))

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

 
   (helper lst (make-vector n '()) (1- n)))
 
 (define (list-element-index lst x)
 
   (helper lst (make-vector n '()) (1- n)))
 
 (define (list-element-index lst x)

-  (define (helper todo k)
-    (cond
-     ((null? todo) #f)
-     ((equal? (car todo) x) k)
-     (else
-      (helper (cdr todo) (1+ k)))))
-
-  (helper lst 0))
+  (list-index (lambda (m) (equal? m x)) lst))

 
 (define-public (count-list lst)
 
 (define-public (count-list lst)

-  "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
+  "Given @var{lst} as @code{(E1 E2 .. )}, return
+@code{((E1 . 1) (E2 . 2) ... )}."
+  (map cons lst (iota (length lst) 1)))

 
 

-  (define (helper l acc count)
-    (if (pair? l)
-       (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
-       acc))
-
-
-  (reverse (helper lst '() 1)))
-  

 (define-public (list-join lst intermediate)
 (define-public (list-join lst intermediate)

-  "put INTERMEDIATE  between all elts of LST."
+  "Put @var{intermediate} between all elts of @var{lst}."

 
   (fold-right
    (lambda (elem prev)
 
   (fold-right
    (lambda (elem prev)

-           (if (pair? prev)
-               (cons  elem (cons intermediate prev))
-               (list elem)))
-         '() lst))
+     (if (pair? prev)
+         (cons  elem (cons intermediate prev))
+         (list elem)))
+   '() lst))

 
 

-(define-public (filtered-map proc lst)
-  (filter
-   (lambda (x) x)
-   (map proc lst)))
+(define-public filtered-map filter-map)

 
 

-
-(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."
+  (let loop ((x x) (tail '()))
+    (cond ((list? x) (fold-right loop tail x))
+          ((not (pair? x)) (cons x tail))
+          (else (loop (car x) (loop (cdr x) tail))))))

 
 (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. Uses equal? for comparisons."
+  "Uniq @var{lst}, assuming that it is sorted.  Uses @code{equal?}
+for comparisons."

 
 

-  (reverse! 
+  (reverse!

    (fold (lambda (x acc)
    (fold (lambda (x acc)

-          (if (null? acc)
-              (list x)
-              (if (equal? x (car acc))
-                  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?)))))
+           (if (null? acc)
+               (list x)
+               (if (equal? x (car acc))
+                   acc
+                   (cons x acc))))
+         '() lst) '()))
+
+(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))"
+  (let ((i (and (pair? lst)
+                (list-index (lambda (x y) (not (pred x y)))
+                            lst
+                            (cdr lst)))))
+    (if i
+        (call-with-values
+            (lambda () (split-at lst (1+ i)))
+          cons)
+        (list lst))))
+
+(define-public (split-list-by-separator lst pred)
+  "Split @var{lst} at each element that satisfies @var{pred}, and return
+the parts (with the separators removed) as a list of lists.  For example,
+executing @samp{(split-list-by-separator '(a 0 b c 1 d) number?)} returns
+@samp{((a) (b c) (d))}."
+  (call-with-values (lambda () (break pred lst))
+    (lambda (head tail)
+      (cons head
+            (if (null? tail)
+                tail
+                (split-list-by-separator (cdr tail) pred))))))

 
 (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-scale o scale)
   (cons (* (car o) scale)
 
 (define-public (offset-flip-y o)
   (cons (car o) (- (cdr o))))
 
 (define-public (offset-scale o scale)
   (cons (* (car o) scale)

-       (* (cdr o) scale)))
+        (* (cdr o) scale)))

 
 (define-public (ly:list->offsets accum coords)
   (if (null? coords)
       accum
       (cons (cons (car coords) (cadr coords))
 
 (define-public (ly:list->offsets accum coords)
   (if (null? coords)
       accum
       (cons (cons (car coords) (cadr coords))

-           (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)
 
 (define-public (interval-length x)

-  "Length of the number-pair X, when an interval"
+  "Length of the number-pair @var{x}, if an interval."

   (max 0 (- (cdr x) (car x))))
 
   (max 0 (- (cdr x) (car x))))
 

-(define-public interval-start car)

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

-       (max a b)))
-
-(define-public interval-end cdr)
+        (max a b)))

 
 (define-public (interval-bound interval dir)
   ((if (= dir RIGHT) cdr car) interval))
 
 (define-public (interval-index interval dir)
 
 (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)"
-  
+  "Interpolate @var{interval} between between left (@var{dir}=-1) and
+right (@var{dir}=+1)."
+

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

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

      0.5))
 
 (define-public (interval-center x)
      0.5))
 
 (define-public (interval-center x)

-  "Center the number-pair X, when an interval"
+  "Center the number-pair @var{x}, if an interval."

   (if (interval-empty? x)
       0.0
       (/ (+ (car x) (cdr x)) 2)))
 
 (define-public interval-start car)
   (if (interval-empty? x)
       0.0
       (/ (+ (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 (other-axis a)
   (remainder (+ a 1) 2))
 

-(define-public (interval-widen iv amount)
-   (cons (- (car iv) amount)
-         (+ (cdr iv) amount)))
+(define-public (interval-scale iv factor)
+  (cons (* (car iv) factor)
+        (* (cdr iv) factor)))

 
 

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

 
 (define-public (interval-empty? iv)
 
 (define-public (interval-empty? iv)

-   (> (car iv) (cdr iv)))
+  (> (car iv) (cdr iv)))

 
 (define-public (interval-union i1 i2)
 
 (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))

-           (inf? (car i))
-           (nan? (cdr i))
-           (inf? (cdr i))
-           (> (car i) (cdr i)))))
+            (inf? (car i))
+            (nan? (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)
+  "Take @var{value} and modulo-maps it between 0 and base @var{cycle}."
+  (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)
+  "Take @var{angle} (in radians) and maps it between 0 and 2pi."
+  (cyclic-base-value angle TWO-PI))
+
+(define-public (angle-0-360 angle)
+  "Take @var{angle} (in degrees) and maps it between 0 and 360 degrees."
+  (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)
+  "Return polar coordinates (@var{radius}, @var{angle-in-degrees})
+as rectangular coordinates @ode{(x-length . y-length)}."
+
+  (let ((complex (make-polar
+                  radius
+                  (degrees->radians angle-in-degrees))))
+    (cons
+     (real-part complex)
+     (imag-part complex))))

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; string
 
 (define-public (string-endswith s suffix)
   (equal? suffix (substring s
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; string
 
 (define-public (string-endswith s suffix)
   (equal? suffix (substring s

-                           (max 0 (- (string-length s) (string-length suffix)))
-                           (string-length 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")
    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
    (else (string-append
 (define-public (string-encode-integer i)
   (cond
    ((= i  0) "o")
    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
    (else (string-append

-         (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 (number->octal-string x)
   (let* ((n (inexact->exact x))
 
 (define (number->octal-string x)
   (let* ((n (inexact->exact x))


@@ -489,17 +809,18 @@ found."
 
 (define-public (ly:number-pair->string c)
   (string-append (ly:number->string (car c)) " "
 
 (define-public (ly:number-pair->string c)
   (string-append (ly:number->string (car c)) " "

-                (ly:number->string (cdr c))))
+                 (ly:number->string (cdr c))))

 
 (define-public (dir-basename file . rest)
 
 (define-public (dir-basename file . rest)

-  "Strip suffixes in REST, but leave directory component for FILE."
+  "Strip suffixes in @var{rest}, but leave directory component for
+@var{file}."

   (define (inverse-basename x y) (basename y x))
   (simple-format #f "~a/~a" (dirname file)
   (define (inverse-basename x y) (basename y x))
   (simple-format #f "~a/~a" (dirname file)

-                (fold inverse-basename file rest)))
+                 (fold inverse-basename file rest)))

 
 (define-public (write-me message x)
 
 (define-public (write-me message x)

-  "Return X.  Display MESSAGE and write X.  Handy for debugging,
-possibly turned off."
+  "Return @var{x}.  Display @var{message} and write @var{x}.
+Handy for debugging, possibly turned off."

   (display message) (write x) (newline) x)
 ;;  x)
 
   (display message) (write x) (newline) x)
 ;;  x)
 


@@ -521,15 +842,15 @@ possibly turned off."
   (cons (f (car x)) (f (cdr x))))
 
 (define-public (list-insert-separator lst between)
   (cons (f (car x)) (f (cdr x))))
 
 (define-public (list-insert-separator lst between)

-  "Create new list, inserting BETWEEN between elements of LIST"
+  "Create new list, inserting @var{between} between elements of @var{lst}."

   (define (conc x y )
     (if (eq? y #f)
   (define (conc x y )
     (if (eq? y #f)

-       (list x)
-       (cons x  (cons between y))))
+        (list x)
+        (cons x  (cons between y))))

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


@@ -537,9 +858,9 @@ possibly turned off."
   (define (notice match)
 
     (set! matches (cons (substring (match:string match)
   (define (notice match)
 
     (set! matches (cons (substring (match:string match)

-                                  end-of-prev-match
-                                  (match:start match))
-                       matches))
+                                   end-of-prev-match
+                                   (match:start match))
+                        matches))

     (set! end-of-prev-match (match:end match)))
 
   (regexp-substitute/global #f regex str notice 'post)
     (set! end-of-prev-match (match:end match)))
 
   (regexp-substitute/global #f regex str notice 'post)


@@ -549,34 +870,80 @@ possibly turned off."
        matches
        (cons (substring str end-of-prev-match (string-length str)) matches)))
 
        matches
        (cons (substring str end-of-prev-match (string-length str)) matches)))
 

-   (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 produces the closest match to @var{target-val} if
+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 whether all symbols in expr @var{symbol} are reachable
+in module @var{module}.  In that case evaluate, otherwise
+print a warning and set an optional @var{default}."
+  (let* ((unavailable? (lambda (sym)
+                         (not (module-defined? module sym))))
+         (sym-unavailable
+          (filter
+           unavailable?
+           (filter symbol? (flatten-list symbol)))))
+    (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)))


@@ -592,39 +959,23 @@ 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))

-        (magnification (* (ly:font-magnification font)))
-        (scaling (* magnification designsize)))
+         (magnification (* (ly:font-magnification font)))
+         (scaling (* magnification designsize)))

     (debugf "scaling:~S\n" scaling)
     (debugf "magnification:~S\n" magnification)
     (debugf "design:~S\n" designsize)
     scaling))
 
 (define-public (version-not-seen-message input-file-name)
     (debugf "scaling:~S\n" scaling)
     (debugf "magnification:~S\n" magnification)
     (debugf "design:~S\n" designsize)
     scaling))
 
 (define-public (version-not-seen-message input-file-name)

-  (ly:message
-   "~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
-   "~a:0: ~a: ~a" 
-    input-file-name
-    (_ "warning: ")
-    (_ "old relative compatibility not used")))
+  (ly:warning-located
+   (ly:format "~a:1" input-file-name)
+   (_ "no \\version statement found, please add~afor future compatibility")
+   (format #f "\n\n\\version ~s\n\n" (lilypond-version))))