Doc-ca: corrected this file as to email by Phil Holmes

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

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index b334517de1dbefdcb52e4db3ca64accf2e96ddbf..9008831c722316ad8b45ed8835c0457548d66a69 100644 (file)
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;

-;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2014 Jan Nieuwenhuizen <janneke@gnu.org>

 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify


@@ -22,6 +22,8 @@
 ;; for define-safe-public when byte-compiling using Guile V2
 (use-modules (scm safe-utility-defs))
 
 ;; for define-safe-public when byte-compiling using Guile V2
 (use-modules (scm safe-utility-defs))
 

+(use-modules (ice-9 pretty-print))
+

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


@@ -80,6 +82,11 @@
   (cons (ly:moment-main-numerator moment)
         (ly:moment-main-denominator moment)))
 
   (cons (ly:moment-main-numerator moment)
         (ly:moment-main-denominator moment)))
 

+(define-public (seconds->moment s context)
+  "Return a moment equivalent to s seconds at the current tempo."
+  (ly:moment-mul (ly:context-property context 'tempoWholesPerMinute)
+                 (ly:make-moment (/ s 60))))
+

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; durations
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; durations
 


@@ -100,9 +107,9 @@ the numeric factor by which they increase the duration."
   (- 2 (/ (ash 1 dotcount))))
 
 (define-public (duration-length dur)
   (- 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.)"
+  "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)
   (ly:moment-main (ly:duration-length dur)))
 
 (define-public (duration-visual dur)


@@ -116,6 +123,16 @@ non-visual scale factor 1."
 duration (base note length and dot count), as a number of whole notes."
   (duration-length (duration-visual dur)))
 
 duration (base note length and dot count), as a number of whole notes."
   (duration-length (duration-visual dur)))
 

+(define-public (unity-if-multimeasure context dur)
+  "Given a context and a duration, return @code{1} if the duration is
+longer than the @code{measureLength} in that context, and @code{#f} otherwise.
+This supports historic use of @code{Completion_heads_engraver} to split
+@code{c1*3} into three whole notes."
+  (if (ly:moment<? (ly:context-property context 'measureLength)
+                   (ly:duration-length dur))
+    1
+    #f))
+

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


@@ -424,7 +441,7 @@ bookoutput function"
             (symbol->string (car y))))
 
 (define (map-alist-vals func list)
             (symbol->string (car y))))
 
 (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)))


@@ -453,17 +470,6 @@ bookoutput function"
             (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)
   "Return @var{alist} with @var{function} applied to all of the values
 in list @var{keys}.
 (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}.


@@ -473,19 +479,14 @@ 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)}
 @end 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 function key alist)
+  (define (map-selected-alist-keys-helper key alist)

     (map
      (lambda (pair)
        (if (equal? key (car pair))
            (cons key (function (cdr pair)))
            pair))
      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))))
+  (fold map-selected-alist-keys-helper alist keys))

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


@@ -551,17 +552,14 @@ For example:
          (list elem)))
    '() lst))
 
          (list elem)))
    '() lst))
 

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

 
 (define-public (flatten-list x)
   "Unnest list."
 
 (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))))))
+  (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."
 
 (define (list-minus a b)
   "Return list of elements in A that are not in B."


@@ -844,12 +842,12 @@ Handy for debugging, possibly turned off."
 ;;  x)
 
 (define-public (stderr string . rest)
 ;;  x)
 
 (define-public (stderr string . rest)

-  (apply format (cons (current-error-port) (cons string rest)))
+  (apply format (current-error-port) string rest)

   (force-output (current-error-port)))
 
 (define-public (debugf string . rest)
   (if #f
   (force-output (current-error-port)))
 
 (define-public (debugf string . rest)
   (if #f

-      (apply stderr (cons string rest))))
+      (apply stderr string rest)))

 
 (define (index-cell cell dir)
   (if (equal? dir 1)
 
 (define (index-cell cell dir)
   (if (equal? dir 1)


@@ -891,6 +889,26 @@ Handy for debugging, possibly turned off."
 
   (reverse matches))
 
 
   (reverse matches))
 

+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; numbering styles
+
+(define-public (number-format number-type num . custom-format)
+  "Print NUM accordingly to the requested NUMBER-TYPE.
+Choices include @code{roman-lower} (by default),
+@code{roman-upper}, @code{arabic} and @code{custom}.
+In the latter case, CUSTOM-FORMAT must be supplied
+and will be applied to NUM."
+ (cond
+   ((equal? number-type 'roman-lower)
+    (fancy-format #f "~(~@r~)" num))
+   ((equal? number-type 'roman-upper)
+    (fancy-format #f "~@r" num))
+   ((equal? number-type 'arabic)
+    (fancy-format #f "~d" num))
+   ((equal? number-type 'custom)
+    (fancy-format #f (car custom-format) num))
+   (else (fancy-format #f "~(~@r~)" num))))
+

 ;;;;;;;;;;;;;;;;
 ;; other
 
 ;;;;;;;;;;;;;;;;
 ;; other
 


@@ -946,23 +964,46 @@ print a warning and set an optional @var{default}."
            (object->string def))
           def))))
 
            (object->string def))
           def))))
 

-;;
-;; don't confuse users with #<procedure .. > syntax.
-;;
+(define (self-evaluating? x)
+  (or (number? x) (string? x) (procedure? x) (boolean? x)))
+
+(define (ly-type? x)
+  (any (lambda (p) ((car p) x)) lilypond-exported-predicates))
+
+(define-public (pretty-printable? val)
+  (and (not (self-evaluating? val))
+       (not (symbol? val))
+       (not (hash-table? val))
+       (not (ly-type? val))))
+

 (define-public (scm->string val)
 (define-public (scm->string val)

-  (if (and (procedure? val)
-           (symbol? (procedure-name val)))
-      (symbol->string (procedure-name val))
-      (string-append
-       (if (self-evaluating? val)
-           (if (string? val)
-               "\""
-               "")
-           "'")
-       (call-with-output-string (lambda (port) (display val port)))
-       (if (string? val)
-           "\""
-           ""))))
+  (let* ((quote-style (if (string? val)
+                        'double
+                        (if (or (null? val) ; (ly-type? '()) => #t
+                                (and (not (self-evaluating? val))
+                                     (not (vector? val))
+                                     (not (hash-table? val))
+                                     (not (ly-type? val))))
+                          'single
+                          'none)))
+         ; don't confuse users with #<procedure ...> syntax
+         (str (if (and (procedure? val)
+                       (symbol? (procedure-name val)))
+                (symbol->string (procedure-name val))
+                (call-with-output-string
+                  (if (pretty-printable? val)
+                    ; property values in PDF hit margin after 64 columns
+                    (lambda (port)
+                      (pretty-print val port #:width (case quote-style
+                                                       ((single) 63)
+                                                       (else 64))))
+                    (lambda (port) (display val port)))))))
+    (case quote-style
+      ((single) (string-append
+                  "'"
+                  (string-regexp-substitute "\n " "\n  " str)))
+      ((double) (string-append "\"" str "\""))
+      (else str))))

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