Build: Generate info and pdf output from -book regtests.

[lilypond.git] / scm / music-functions.scm

diff --git a/scm/music-functions.scm b/scm/music-functions.scm
index 69d3029de3c48763989077c980c2c7ce6c75f3a7..8e9a7658de0c0ff4007f1cd16a692842bae6b473 100644 (file)
--- a/scm/music-functions.scm
+++ b/scm/music-functions.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,7 +19,7 @@
 ; 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 optargs))
+(use-modules (ice-9 optargs))

 
 ;;; ly:music-property with setter
 ;;; (ly:music-property my-music 'elements)
 
 ;;; ly:music-property with setter
 ;;; (ly:music-property my-music 'elements)


@@ -82,9 +82,12 @@ First it recurses over the children, then the function is applied to
                           (inner-music-filter pred? e)
                           e))
           (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es))))
                           (inner-music-filter pred? e)
                           e))
           (filtered-es (filter ly:music? (map (lambda (y) (inner-music-filter pred? y)) es))))

-      (set! (ly:music-property music 'element) filtered-e)
-      (set! (ly:music-property music 'elements) filtered-es)
-      (set! (ly:music-property music 'articulations) filtered-as)
+      (if (not (null? e))
+         (set! (ly:music-property music 'element) filtered-e))
+      (if (not (null? es))
+         (set! (ly:music-property music 'elements) filtered-es))
+      (if (not (null? as))
+         (set! (ly:music-property music 'articulations) filtered-as))

       ;; if filtering emptied the expression, we remove it completely.
       (if (or (not (pred? music))
              (and (eq? filtered-es '()) (not (ly:music? e))
       ;; if filtering emptied the expression, we remove it completely.
       (if (or (not (pred? music))
              (and (eq? filtered-es '()) (not (ly:music? e))


@@ -98,24 +101,23 @@ First it recurses over the children, then the function is applied to
       music
       (make-music 'Music)))      ;must return music.
 
       music
       (make-music 'Music)))      ;must return music.
 

-(define-public (display-music music)
+(define*-public (display-music music #:optional (port (current-output-port)))

   "Display music, not done with @code{music-map} for clarity of
 presentation."
   "Display music, not done with @code{music-map} for clarity of
 presentation."

-
-  (display music)
-  (display ": { ")
+  (display music port)
+  (display ": { " port)

   (let ((es (ly:music-property music 'elements))
        (e (ly:music-property music 'element)))
   (let ((es (ly:music-property music 'elements))
        (e (ly:music-property music 'element)))

-    (display (ly:music-mutable-properties music))
+    (display (ly:music-mutable-properties music) port)

     (if (pair? es)
     (if (pair? es)

-       (begin (display "\nElements: {\n")
-              (map display-music es)
-              (display "}\n")))
+       (begin (display "\nElements: {\n" port)
+              (for-each (lambda (m) (display-music m port)) es)
+              (display "}\n" port)))

     (if (ly:music? e)
        (begin
     (if (ly:music? e)
        (begin

-         (display "\nChild:")
-         (display-music e))))
-  (display " }\n")
+         (display "\nChild:" port)
+         (display-music e port))))
+  (display " }\n" port)

   music)
 
 ;;;
   music)
 
 ;;;


@@ -206,13 +208,9 @@ equivalent to @var{obj}, that is, for a music expression, a
 (use-modules (ice-9 pretty-print))
 (define*-public (display-scheme-music obj #:optional (port (current-output-port)))
   "Displays `obj', typically a music expression, in a friendly fashion,
 (use-modules (ice-9 pretty-print))
 (define*-public (display-scheme-music obj #:optional (port (current-output-port)))
   "Displays `obj', typically a music expression, in a friendly fashion,

-which often can be read back in order to generate an equivalent expression.
-
-Returns `obj'.
-"
+which often can be read back in order to generate an equivalent expression."

   (pretty-print (music->make-music obj) port)
   (pretty-print (music->make-music obj) port)

-  (newline)
-  obj)
+  (newline port))

 
 ;;;
 ;;; Scheme music expression --> Lily-syntax-using string translator
 
 ;;;
 ;;; Scheme music expression --> Lily-syntax-using string translator


@@ -220,28 +218,30 @@ Returns `obj'.
 (use-modules (srfi srfi-39)
              (scm display-lily))
 
 (use-modules (srfi srfi-39)
              (scm display-lily))
 

-(define*-public (display-lily-music expr parser #:key force-duration)
+(define*-public (display-lily-music expr parser #:optional (port (current-output-port))
+                                   #:key force-duration)

   "Display the music expression using LilyPond syntax"
   (memoize-clef-names supported-clefs)
   (parameterize ((*indent* 0)
                 (*previous-duration* (ly:make-duration 2))
                 (*force-duration* force-duration))
   "Display the music expression using LilyPond syntax"
   (memoize-clef-names supported-clefs)
   (parameterize ((*indent* 0)
                 (*previous-duration* (ly:make-duration 2))
                 (*force-duration* force-duration))

-    (display (music->lily-string expr parser))
-    (newline)))
+    (display (music->lily-string expr parser) port)
+    (newline port)))

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (shift-one-duration-log music shift dot)
   "Add @var{shift} to @code{duration-log} of @code{'duration} in
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (shift-one-duration-log music shift dot)
   "Add @var{shift} to @code{duration-log} of @code{'duration} in

-@var{music} and optionally @var{dot} to any note encountered.  This
-scales the music up by a factor `2^@var{shift} * (2 - (1/2)^@var{dot})'."
+@var{music} and optionally @var{dot} to any note encountered.
+The number of dots in the shifted music may not be less than zero."

   (let ((d (ly:music-property music 'duration)))
     (if (ly:duration? d)
        (let* ((cp (ly:duration-factor d))
   (let ((d (ly:music-property music 'duration)))
     (if (ly:duration? d)
        (let* ((cp (ly:duration-factor d))

-              (nd (ly:make-duration (+ shift (ly:duration-log d))
-                                    (+ dot (ly:duration-dot-count d))
-                                    (car cp)
-                                    (cdr cp))))
+              (nd (ly:make-duration
+                    (+ shift (ly:duration-log d))
+                    (max 0 (+ dot (ly:duration-dot-count d)))
+                   (car cp)
+                   (cdr cp))))

          (set! (ly:music-property music 'duration) nd)))
     music))
 
          (set! (ly:music-property music 'duration) nd)))
     music))
 


@@ -255,7 +255,9 @@ properly."
   (define (first-note-duration music)
     "Finds the duration of the first NoteEvent by searching depth-first
 through MUSIC."
   (define (first-note-duration music)
     "Finds the duration of the first NoteEvent by searching depth-first
 through MUSIC."

-    (if (memq 'note-event (ly:music-property music 'types))
+    ;; NoteEvent or a non-expanded chord-repetition
+    ;; We just take anything that actually sports an announced duration.
+    (if (ly:duration? (ly:music-property music 'duration))

        (ly:music-property music 'duration)
        (let loop ((elts (if (ly:music? (ly:music-property music 'element))
                             (list (ly:music-property music 'element))
        (ly:music-property music 'duration)
        (let loop ((elts (if (ly:music? (ly:music-property music 'element))
                             (list (ly:music-property music 'element))


@@ -276,12 +278,12 @@ through MUSIC."
     (set! (ly:music-property r 'repeat-count) (max times 1))
     (set! (ly:music-property r 'elements) talts)
     (if (and (equal? name "tremolo")
     (set! (ly:music-property r 'repeat-count) (max times 1))
     (set! (ly:music-property r 'elements) talts)
     (if (and (equal? name "tremolo")

-            (or (pair? (ly:music-property main 'elements))
-                (ly:music? (ly:music-property main 'element))))
+            (pair? (extract-named-music main '(EventChord NoteEvent))))

        ;; This works for single-note and multi-note tremolos!
        (let* ((children (if (music-is-of-type? main 'sequential-music)
                             ;; \repeat tremolo n { ... }
        ;; This works for single-note and multi-note tremolos!
        (let* ((children (if (music-is-of-type? main 'sequential-music)
                             ;; \repeat tremolo n { ... }

-                            (length (extract-named-music main 'EventChord))
+                            (length (extract-named-music main '(EventChord
+                                                                NoteEvent)))

                             ;; \repeat tremolo n c4
                             1))
               ;; # of dots is equal to the 1 in bitwise representation (minus 1)!
                             ;; \repeat tremolo n c4
                             1))
               ;; # of dots is equal to the 1 in bitwise representation (minus 1)!


@@ -311,7 +313,8 @@ if durations in @var{music} vary, allowing slash beats and double-percent
 beats to be distinguished."
   (let* ((durs (map (lambda (elt)
                      (duration-of-note elt))
 beats to be distinguished."
   (let* ((durs (map (lambda (elt)
                      (duration-of-note elt))

-                   (extract-named-music music 'EventChord)))
+                   (extract-named-music music '(EventChord NoteEvent
+                                                RestEvent SkipEvent))))

         (first-dur (car durs)))
 
     (if (every (lambda (d) (equal? d first-dur)) durs)
         (first-dur (car durs)))
 
     (if (every (lambda (d) (equal? d first-dur)) durs)


@@ -423,8 +426,8 @@ in @var{grob}."
 (define-safe-public (make-voice-props-set n)
   (make-sequential-music
    (append
 (define-safe-public (make-voice-props-set n)
   (make-sequential-music
    (append

-    (map (lambda (x) (make-grob-property-set x 'direction
-                                            (if (odd? n) -1 1)))
+    (map (lambda (x) (make-grob-property-override x 'direction
+                                                 (if (odd? n) -1 1)))

         direction-polyphonic-grobs)
     (list
      (make-property-set 'graceSettings
         direction-polyphonic-grobs)
     (list
      (make-property-set 'graceSettings


@@ -444,8 +447,8 @@ in @var{grob}."
                          (Voice Fingering font-size -8)
                          (Voice StringNumber font-size -8)))
 
                          (Voice Fingering font-size -8)
                          (Voice StringNumber font-size -8)))
 

-     (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2))
-     (make-grob-property-set 'MultiMeasureRest 'staff-position (if (odd? n) -4 4))))))
+     (make-grob-property-override 'NoteColumn 'horizontal-shift (quotient n 2))
+     (make-grob-property-override 'MultiMeasureRest 'staff-position (if (odd? n) -4 4))))))

 
 (define-safe-public (make-voice-props-revert)
   (make-sequential-music
 
 (define-safe-public (make-voice-props-revert)
   (make-sequential-music


@@ -577,6 +580,65 @@ inside of and outside of chord construct."
   (let ((ts (ly:music-property m 'types)))
     (memq 'separator ts)))
 
   (let ((ts (ly:music-property m 'types)))
     (memq 'separator ts)))
 

+;;; expanding repeat chords
+(define-public (copy-repeat-chord original-chord repeat-chord duration
+                                 event-types)
+  "Copies all events in @var{event-types} (be sure to include
+@code{rhythmic-events}) from @var{original-chord} over to
+@var{repeat-chord} with their articulations filtered as well.  Any
+duration is replaced with the specified @var{duration}."
+  ;; First remove everything from event-types that can already be
+  ;; found in the repeated chord.  We don't need to look for
+  ;; articulations on individual events since they can't actually get
+  ;; into a repeat chord given its input syntax.
+  (for-each (lambda (e)
+             (for-each (lambda (x)
+                         (set! event-types (delq x event-types)))
+                       (ly:music-property e 'types)))
+           (ly:music-property repeat-chord 'elements))
+  ;; now treat the elements
+  (set! (ly:music-property repeat-chord 'elements)
+       (append!
+        (filter-map
+         (lambda (m)
+           (and (any (lambda (t) (music-is-of-type? m t)) event-types)
+                (begin
+                  (set! m (ly:music-deep-copy m))
+                  (if (pair? (ly:music-property m 'articulations))
+                      (set! (ly:music-property m 'articulations)
+                            (filter
+                             (lambda (a)
+                               (any (lambda (t) (music-is-of-type? a t))
+                                    event-types))
+                             (ly:music-property m 'articulations))))
+                  (if (ly:duration? (ly:music-property m 'duration))
+                      (set! (ly:music-property m 'duration) duration))
+                  m)))
+         (ly:music-property original-chord 'elements))
+        (ly:music-property repeat-chord 'elements))))
+
+(define-public (expand-repeat-chords! event-types music)
+  "Walks through @var{music} and fills repeated chords (notable by
+having a duration in @code{duration}) with the notes from their
+respective predecessor chord."
+  (let loop ((music music) (last-chord #f))
+    (if (music-is-of-type? music 'event-chord)
+       (let ((chord-repeat (ly:music-property music 'duration)))
+         (cond
+          ((not (ly:duration? chord-repeat))
+           music)
+          (last-chord
+           (set! (ly:music-property music 'duration) '())
+           (copy-repeat-chord last-chord music chord-repeat event-types)
+           music)
+          (else
+           (ly:music-warning music (_ "Bad chord repetition"))
+           #f)))
+       (let ((elt (ly:music-property music 'element)))
+         (fold loop (if (ly:music? elt) (loop elt last-chord) last-chord)
+               (ly:music-property music 'elements)))))
+  music)
+

 ;;; splitting chords into voices.
 (define (voicify-list lst number)
   "Make a list of Musics.
 ;;; splitting chords into voices.
 (define (voicify-list lst number)
   "Make a list of Musics.


@@ -841,7 +903,7 @@ void return value (i.e., what most Guile functions with `unspecified'
 value return).  Use this when defining functions for executing actions
 rather than returning values, to keep Lilypond from trying to interpret
 the return value."
 value return).  Use this when defining functions for executing actions
 rather than returning values, to keep Lilypond from trying to interpret
 the return value."

-  `(define-syntax-function (void? (begin)) ,@rest #f (begin)))
+  `(define-syntax-function (void? *unspecified*) ,@rest *unspecified*))

 
 (defmacro-public define-event-function rest
   "Defining macro returning event functions.
 
 (defmacro-public define-event-function rest
   "Defining macro returning event functions.


@@ -1037,6 +1099,10 @@ then revert skipTypesetting."
 
 (define-public toplevel-music-functions
   (list
 
 (define-public toplevel-music-functions
   (list

+   (lambda (music parser) (expand-repeat-chords!
+                          (cons 'rhythmic-event
+                                (ly:parser-lookup parser '$chord-repeat-events))
+                          music))

    (lambda (music parser) (voicify-music music))
    (lambda (x parser) (music-map music-check-error x))
    (lambda (x parser) (music-map precompute-music-length x))
    (lambda (music parser) (voicify-music music))
    (lambda (x parser) (music-map music-check-error x))
    (lambda (x parser) (music-map precompute-music-length x))


@@ -1308,14 +1374,14 @@ as a context."
                                   `(Staff ,(make-accidental-rule 'same-octave 0))
                                   '()
                                   context))
                                   `(Staff ,(make-accidental-rule 'same-octave 0))
                                   '()
                                   context))

-      ;; accidentals from one voice do NOT get cancelled in other voices
+      ;; accidentals from one voice do NOT get canceled in other voices

       ((equal? style 'voice)
        (set-accidentals-properties #t
                                   `(Voice ,(make-accidental-rule 'same-octave 0))
                                   '()
                                   context))
       ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century.
       ((equal? style 'voice)
        (set-accidentals-properties #t
                                   `(Voice ,(make-accidental-rule 'same-octave 0))
                                   '()
                                   context))
       ;; accidentals as suggested by Kurt Stone, Music Notation in the 20th century.

-      ;; This includes all the default accidentals, but accidentals also needs cancelling
+      ;; This includes all the default accidentals, but accidentals also needs canceling

       ;; in other octaves and in the next measure.
       ((equal? style 'modern)
        (set-accidentals-properties #f
       ;; in other octaves and in the next measure.
       ((equal? style 'modern)
        (set-accidentals-properties #f


@@ -1380,7 +1446,7 @@ as a context."
                                   context))
       ;; Multivoice accidentals to be read both by musicians playing one voice
       ;; and musicians playing all voices.
                                   context))
       ;; Multivoice accidentals to be read both by musicians playing one voice
       ;; and musicians playing all voices.

-      ;; Accidentals are typeset for each voice, but they ARE cancelled across voices.
+      ;; Accidentals are typeset for each voice, but they ARE canceled across voices.

       ((equal? style 'modern-voice)
        (set-accidentals-properties  #f
                                    `(Voice ,(make-accidental-rule 'same-octave 0)
       ((equal? style 'modern-voice)
        (set-accidentals-properties  #f
                                    `(Voice ,(make-accidental-rule 'same-octave 0)


@@ -1403,7 +1469,7 @@ as a context."
                                           ,(make-accidental-rule 'same-octave 1))
                                   context))
       ;; stone's suggestions for accidentals on grand staff.
                                           ,(make-accidental-rule 'same-octave 1))
                                   context))
       ;; stone's suggestions for accidentals on grand staff.

-      ;; Accidentals are cancelled across the staves in the same grand staff as well
+      ;; Accidentals are canceled across the staves in the same grand staff as well

       ((equal? style 'piano)
        (set-accidentals-properties #f
                                   `(Staff ,(make-accidental-rule 'same-octave 0)
       ((equal? style 'piano)
        (set-accidentals-properties #f
                                   `(Staff ,(make-accidental-rule 'same-octave 0)


@@ -1485,7 +1551,7 @@ Entries that conform with the current key signature are not invalidated."
                   entry
                   (cons (car entry) (cons 'clef (cddr entry))))))
           (ly:context-property context 'localKeySignature)))))
                   entry
                   (cons (car entry) (cons 'clef (cddr entry))))))
           (ly:context-property context 'localKeySignature)))))

-                   
+

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (skip-of-length mus)
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (skip-of-length mus)


@@ -1515,32 +1581,48 @@ Entries that conform with the current key signature are not invalidated."
         (ly:music-property (car evs) 'pitch))))
 
 (define-public (duration-of-note event-chord)
         (ly:music-property (car evs) 'pitch))))
 
 (define-public (duration-of-note event-chord)

-  (let ((evs (filter (lambda (x)
-                      (music-has-type x 'rhythmic-event))
-                    (ly:music-property event-chord 'elements))))
-
-    (and (pair? evs)
-        (ly:music-property (car evs) 'duration))))
+  (cond
+   ((pair? event-chord)
+    (or (duration-of-note (car event-chord))
+       (duration-of-note (cdr event-chord))))
+   ((ly:music? event-chord)
+    (let ((dur (ly:music-property event-chord 'duration)))
+      (if (ly:duration? dur)
+         dur
+         (duration-of-note (ly:music-property event-chord 'elements)))))
+   (else #f)))

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (extract-named-music music music-name)
   "Return a flat list of all music named @var{music-name} from @var{music}."
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (extract-named-music music music-name)
   "Return a flat list of all music named @var{music-name} from @var{music}."

-   (let ((extracted-list
-          (if (ly:music? music)
-              (if (eq? (ly:music-property music 'name) music-name)
-                  (list music)
-                  (let ((elt (ly:music-property music 'element))
-                        (elts (ly:music-property music 'elements)))
-                    (if (ly:music? elt)
-                        (extract-named-music elt music-name)
-                        (if (null? elts)
-                            '()
-                            (map (lambda(x)
-                                    (extract-named-music x music-name ))
-                             elts)))))
-              '())))
-     (flatten-list extracted-list)))
+  (if (not (list? music-name))
+      (set! music-name (list music-name)))
+  (if (ly:music? music)
+      (if (memq (ly:music-property music 'name) music-name)
+         (list music)
+         (let ((arts (ly:music-property music 'articulations)))
+           (append-map!
+            (lambda (x) (extract-named-music x music-name))
+            (if (pair? arts)
+                arts
+                (cons (ly:music-property music 'element)
+                      (ly:music-property music 'elements))))))
+      '()))
+
+(define-public (extract-typed-music music type)
+  "Return a flat list of all music with @var{type} from @var{music}."
+  (if (ly:music? music)
+      (if (music-is-of-type? music type)
+         (list music)
+         (let ((arts (ly:music-property music 'articulations)))
+           (append-map!
+            (lambda (x) (extract-typed-music x type))
+            (if (pair? arts)
+                arts
+                (cons (ly:music-property music 'element)
+                      (ly:music-property music 'elements))))))
+      '()))

 
 (define-public (event-chord-notes event-chord)
   "Return a list of all notes from @var{event-chord}."
 
 (define-public (event-chord-notes event-chord)
   "Return a list of all notes from @var{event-chord}."