Doc: typo

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

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index ede65ff5e2a54b88d303e0a2429e3980384c7022..d87bca208ac8e370679f35d622c5bef5d8d906ca 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--2011 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2012 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


@@ -19,6 +19,9 @@
 ; for take, drop, take-while, list-index, and find-tail:
 (use-modules (srfi srfi-1))
 
 ; 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.
 


@@ -54,6 +57,8 @@
 (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
 


@@ -75,6 +80,42 @@
   (cons (ly:moment-main-numerator moment)
         (ly:moment-main-denominator 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)


@@ -105,27 +146,23 @@
 
 (define-public (collect-music-aux score-handler parser music)
   (define (music-property symbol)
 
 (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)))
+    (ly:music-property music symbol #f))

   (cond ((music-property 'page-marker)
         ;; a page marker: set page break/turn permissions or label
   (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))
+         (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)))))
         ;; a regular music expression: make a score with this music
         ;; void music is discarded
         (score-handler (scorify-music music parser)))))


@@ -146,39 +183,34 @@
 
 (define-public (scorify-music music parser)
   "Preprocess @var{music}."
 
 (define-public (scorify-music music parser)
   "Preprocess @var{music}."

+  (ly:make-score
+   (fold (lambda (f m) (f m parser)) 
+         music
+         toplevel-music-functions)))

 
 

-  (for-each (lambda (func)
-             (set! music (func music parser)))
-           toplevel-music-functions)
-
-  (ly:make-score music))
-
-
-(define (get-current-filename parser)
+(define (get-current-filename parser book)

   "return any suffix value for output filename allowing for settings by
 calls to bookOutputName function"
   "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)))
+  (or (paper-variable parser book 'output-filename)
+      (ly:parser-output-name parser)))

 
 

-(define (get-current-suffix parser)
+(define (get-current-suffix parser book)

   "return any suffix value for output filename allowing for settings by calls to
 bookoutput function"
   "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)))
+  (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
 
     (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)
+(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
   "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))
+  (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))
         (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))


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

     (process-procedure book paper layout outfile-name)))
 
 (define-public (print-book-with-defaults parser book)
     (process-procedure book paper layout outfile-name)))
 
 (define-public (print-book-with-defaults parser book)


@@ -227,6 +259,24 @@ bookoutput function"
       (else
           ((ly:parser-lookup parser 'toplevel-score-handler) parser 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-text parser text)
   (add-score parser (list text)))
 


@@ -236,6 +286,125 @@ bookoutput function"
                      parser
                     music))
 
                      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
 
 ;;;;;;;;;;;;;;;;
 ;; alist


@@ -271,17 +440,11 @@ bookoutput function"
 (define-public (first-member members lst)
   "Return first successful member (of member) from @var{members} in
 @var{lst}."
 (define-public (first-member members lst)
   "Return first successful member (of member) from @var{members} in
 @var{lst}."

-  (if (null? members)
-      #f
-      (let ((m (member (car members) lst)))
-       (if m m (first-member (cdr members) lst)))))
+  (any (lambda (m) (member m lst)) members))

 
 (define-public (first-assoc keys lst)
   "Return first successful assoc of key from @var{keys} in @var{lst}."
 
 (define-public (first-assoc keys lst)
   "Return first successful assoc of key from @var{keys} in @var{lst}."

-  (if (null? keys)
-      #f
-      (let ((k (assoc (car keys) lst)))
-       (if k k (first-assoc (cdr keys) lst)))))
+  (any (lambda (k) (assoc k lst)) keys))

 
 (define-public (flatten-alist alist)
   (if (null? alist)
 
 (define-public (flatten-alist alist)
   (if (null? alist)


@@ -337,30 +500,23 @@ For example:
 ;; 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++.
 (define-safe-public (alist->hash-table lst)
   "Convert alist to table"
   (let ((m (make-hash-table (length lst))))
 
 ;; todo: code dup with C++.
 (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-or (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"


@@ -378,26 +534,12 @@ For example:
   (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)
   "Given @var{lst} as @code{(E1 E2 .. )}, return
 @code{((E1 . 1) (E2 . 2) ... )}."
 
 (define-public (count-list lst)
   "Given @var{lst} as @code{(E1 E2 .. )}, return
 @code{((E1 . 1) (E2 . 2) ... )}."

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

 
 (define-public (list-join lst intermediate)
   "Put @var{intermediate} between all elts of @var{lst}."
 
 (define-public (list-join lst intermediate)
   "Put @var{intermediate} between all elts of @var{lst}."


@@ -442,28 +584,27 @@ for comparisons."
   "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))"
   "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)))))
+  (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))}."
 
 (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))}."

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


@@ -522,6 +663,10 @@ right (@var{dir}=+1)."
 (define (other-axis a)
   (remainder (+ a 1) 2))
 
 (define (other-axis a)
   (remainder (+ a 1) 2))
 

+(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-widen iv amount)
   (cons (- (car iv) amount)
     (+ (cdr iv) amount)))


@@ -852,17 +997,7 @@ print a warning and set an optional @var{default}."
     scaling))
 
 (define-public (version-not-seen-message input-file-name)
     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))))