X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fmusic-functions.scm;h=325da29dd575a147e82998a0547d9b3a5fd723c8;hb=49b253c37b3129d6c2e69c7133495213419e5dbd;hp=1b679a7228ab964d4cd2bb1de76ccc5aef4c8bc6;hpb=1dbadfcf82a2cfb2a9cccada47faf449ddf896ed;p=lilypond.git

diff --git a/scm/music-functions.scm b/scm/music-functions.scm
index 1b679a7228..325da29dd5 100644
--- a/scm/music-functions.scm
+++ b/scm/music-functions.scm
@@ -35,6 +35,14 @@
   "Does @code{mus} belong to the music class @code{type}?"
   (memq type (ly:music-property mus 'types)))
 
+(define-safe-public (music-type-predicate types)
+  "Returns a predicate function that can be used for checking
+music to have one of the types listed in @var{types}."
+   (if (cheap-list? types)
+       (lambda (m)
+         (any (lambda (t) (music-is-of-type? m t)) types))
+       (lambda (m) (music-is-of-type? m types))))
+
 ;; TODO move this
 (define-public ly:grob-property
   (make-procedure-with-setter ly:grob-property
@@ -229,14 +237,13 @@ which often can be read back in order to generate an equivalent expression."
 (use-modules (srfi srfi-39)
              (scm display-lily))
 
-(define*-public (display-lily-music expr parser #:optional (port (current-output-port))
+(define*-public (display-lily-music expr #: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 (music->lily-string expr parser) port)
+                 (*omit-duration* #f))
+                (display (music->lily-string expr) port)
                 (newline port)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -286,8 +293,9 @@ depth-first through MUSIC."
          (body (ly:music-property tremolo 'element))
          (children (if (music-is-of-type? body 'sequential-music)
                        ;; \repeat tremolo n { ... }
-                       (length (extract-named-music body '(EventChord
-                                                           NoteEvent)))
+                       (count duration-of-note ; do not count empty <>
+                              (extract-named-music body
+                                                   '(EventChord NoteEvent)))
                        ;; \repeat tremolo n c4
                        1))
          (tremolo-type (if (positive? children)
@@ -406,7 +414,7 @@ beats to be distinguished."
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; property setting music objs.
 
-(define-safe-public (check-grob-path path #:optional parser location
+(define-safe-public (check-grob-path path #:optional location
                                      #:key
                                      (start 0)
                                      default
@@ -475,16 +483,63 @@ respectively."
                    (<= min (length res))))
           res
           (begin
-            (if parser
-                (ly:parser-error parser
-                                 (format #f (_ "bad grob property path ~a")
-                                         path)
-                                 location))
+            (ly:parser-error
+             (format #f (_ "bad grob property path ~a")
+                     path)
+             location)
             #f)))))
 
+(define-safe-public (check-context-path path #:optional location)
+  "Check a context property path specification @var{path}, a symbol
+list (or a single symbol), for validity and possibly complete it.
+Returns the completed specification, or @code{#f} when rising an
+error (using optionally @code{location})."
+  (let* ((path (if (symbol? path) (list path) path)))
+    ;; A Guile 1.x bug specific to optargs precludes moving the
+    ;; defines out of the let
+    (define (property? s)
+      (object-property s 'translation-type?))
+    (define (unspecial? s)
+      (not (property? s)))
+    (define (check c p) (c p))
+    (or (case (length path)
+          ((1) (and (property? (car path)) (cons 'Bottom path)))
+          ((2) (and (unspecial? (car path)) (property? (cadr path)) path))
+          (else #f))
+        (begin
+          (ly:parser-error
+           (format #f (_ "bad context property ~a")
+                   path)
+           location)
+          #f))))
+
+(define-safe-public (check-music-path path #:optional location #:key default)
+  "Check a music property path specification @var{path}, a symbol
+list (or a single symbol), for validity and possibly complete it.
+Returns the completed specification, or @code{#f} when rising an
+error (using optionally @code{location})."
+  (let* ((path (if (symbol? path) (list path) path)))
+    ;; A Guile 1.x bug specific to optargs precludes moving the
+    ;; defines out of the let
+    (define (property? s)
+      (object-property s 'music-type?))
+    (define (unspecial? s)
+      (not (property? s)))
+    (or (case (length path)
+          ((1) (and (property? (car path)) (cons default path)))
+          ((2) (and (unspecial? (car path)) (property? (cadr path)) path))
+          (else #f))
+        (begin
+          (ly:parser-error
+           (format #f (_ "bad music property ~a")
+                   path)
+           location)
+          #f))))
+
 (define-public (make-grob-property-set grob gprop val)
-  "Make a @code{Music} expression that sets @var{gprop} to @var{val} in
-@var{grob}.  Does a pop first, i.e., this is not an override."
+  "Make a @code{Music} expression that overrides a @var{gprop} to
+@var{val} in @var{grob}.  Does a pop first, i.e. this is not a
+@code{\\temporary \\override}."
   (make-music 'OverrideProperty
               'symbol grob
               'grob-property gprop
@@ -492,8 +547,9 @@ respectively."
               'pop-first #t))
 
 (define-public (make-grob-property-override grob gprop val)
-  "Make a @code{Music} expression that overrides @var{gprop} to @var{val}
-in @var{grob}."
+  "Make a @code{Music} expression that overrides @var{gprop} to
+@var{val} in @var{grob}.  This is a @code{\\temporary \\override},
+making it possible to @code{\\revert} to any previous value afterwards."
   (make-music 'OverrideProperty
               'symbol grob
               'grob-property gprop
@@ -546,6 +602,14 @@ in @var{grob}."
       (Voice Slur direction ,DOWN))
     general-grace-settings))
 
+;; Getting a unique context id name
+
+(define-session unique-counter -1)
+(define-safe-public (get-next-unique-voice-name)
+  (set! unique-counter (1+ unique-counter))
+  (format #f "uniqueContext~s" unique-counter))
+
+
 (define-safe-public (make-voice-props-set n)
   (make-sequential-music
    (append
@@ -575,18 +639,23 @@ in @var{grob}."
           (make-grob-property-revert 'NoteColumn 'horizontal-shift)))))
 
 
-(define-safe-public (context-spec-music m context #:optional id)
-  "Add \\context CONTEXT = ID to M."
+(define-safe-public (context-spec-music m context #:optional id mods)
+  "Add \\context @var{context} = @var{id} \\with @var{mods} to @var{m}."
   (let ((cm (make-music 'ContextSpeccedMusic
                         'element m
                         'context-type context)))
     (if (string? id)
         (set! (ly:music-property cm 'context-id) id))
+    (if mods
+        (set! (ly:music-property cm 'property-operations)
+              (if (ly:context-mod? mods)
+                  (ly:get-context-mods mods)
+                  mods)))
     cm))
 
-(define-public (descend-to-context m context)
+(define-safe-public (descend-to-context m context #:optional id mods)
   "Like @code{context-spec-music}, but only descending."
-  (let ((cm (context-spec-music m context)))
+  (let ((cm (context-spec-music m context id mods)))
     (ly:music-set-property! cm 'descend-only #t)
     cm))
 
@@ -708,14 +777,7 @@ duration is replaced with the specified @var{duration}."
   ;; articulations on individual events since they can't actually get
   ;; into a repeat chord given its input syntax.
 
-  (define (keep-element? m)
-    (any (lambda (t) (music-is-of-type? m t))
-         event-types))
-  (define origin (ly:music-property repeat-chord 'origin #f))
-  (define (set-origin! l)
-    (if origin
-        (for-each (lambda (m) (set! (ly:music-property m 'origin) origin)) l))
-    l)
+  (define keep-element? (music-type-predicate event-types))
 
   (for-each
    (lambda (field)
@@ -729,16 +791,17 @@ duration is replaced with the specified @var{duration}."
   ;; now treat the elements
   (set! (ly:music-property repeat-chord 'elements)
         (let ((elts
-               (set-origin! (ly:music-deep-copy
-                             (filter keep-element?
-                                     (ly:music-property original-chord
-                                                        'elements))))))
+               (ly:music-deep-copy (filter keep-element?
+                                           (ly:music-property original-chord
+                                                              'elements))
+                                   repeat-chord)))
           (for-each
            (lambda (m)
              (let ((arts (ly:music-property m 'articulations)))
                (if (pair? arts)
                    (set! (ly:music-property m 'articulations)
-                         (set-origin! (filter! keep-element? arts))))
+                         (ly:set-origin! (filter! keep-element? arts)
+                                         repeat-chord)))
                (if (ly:duration? (ly:music-property m 'duration))
                    (set! (ly:music-property m 'duration) duration))
                (if (ly:music-property m 'cautionary #f)
@@ -753,7 +816,7 @@ duration is replaced with the specified @var{duration}."
     (if (pair? arts)
         (set! (ly:music-property repeat-chord 'articulations)
               (append!
-               (set-origin! (ly:music-deep-copy arts))
+               (ly:music-deep-copy arts repeat-chord)
                (ly:music-property repeat-chord 'articulations)))))
   repeat-chord)
 
@@ -926,9 +989,6 @@ NUMBER is 0-base, i.e., Voice=1 (upstems) has number 0.
        mus))
 
 
-(define-public (music-has-type music type)
-  (memq type (ly:music-property music 'types)))
-
 (define-public (music-clone music . music-properties)
   "Clone @var{music} and set properties according to
 @var{music-properties}, a list of alternating property symbols and
@@ -1040,10 +1100,9 @@ actually fully cloned."
 
 (defmacro-public def-grace-function (start stop . docstring)
   "Helper macro for defining grace music"
-  `(define-music-function (parser location music) (ly:music?)
+  `(define-music-function (music) (ly:music?)
      ,@docstring
      (make-music 'GraceMusic
-                 'origin location
                  'element (make-music 'SequentialMusic
                                       'elements (list (ly:music-deep-copy ,start)
                                                       music
@@ -1052,7 +1111,7 @@ actually fully cloned."
 (defmacro-public define-syntax-function (type args signature . body)
   "Helper macro for `ly:make-music-function'.
 Syntax:
-  (define-syntax-function result-type? (parser location arg1 arg2 ...) (arg1-type arg2-type ...)
+  (define-syntax-function result-type? (arg1 arg2 ...) (arg1-type arg2-type ...)
     ...function body...)
 
 argX-type can take one of the forms @code{predicate?} for mandatory
@@ -1067,21 +1126,28 @@ parameter of different type.
 predicates, to be used in case of a type error in arguments or
 result."
 
+  (define (has-parser/location? arg where)
+    (let loop ((arg arg))
+      (if (list? arg)
+          (any loop arg)
+          (memq arg where))))
   (define (currying-lambda args doc-string? body)
     (if (and (pair? args)
              (pair? (car args)))
         (currying-lambda (car args) doc-string?
                          `((lambda ,(cdr args) ,@body)))
-        `(lambda ,args
-           ,(format #f "~a\n~a" (cddr args) (or doc-string? ""))
-           ,@body)))
-
-  (set! signature (map (lambda (pred)
-                         (if (pair? pred)
-                             `(cons ,(car pred)
-                                    ,(and (pair? (cdr pred)) (cadr pred)))
-                             pred))
-                       (cons type signature)))
+        (let* ((compatibility? (if (list? args)
+                                   (= (length args) (+ 2 (length signature)))
+                                   (and (pair? args) (pair? (cdr args))
+                                        (eq? (car args) 'parser))))
+               (realargs (if compatibility? (cddr args) args)))
+          `(lambda ,realargs
+             ,(format #f "~a\n~a" realargs (or doc-string? ""))
+             ,@(if (and compatibility?
+                        (has-parser/location? body (take args 2)))
+                   `((let ((,(car args) (*parser*)) (,(cadr args) (*location*)))
+                       ,@body))
+                   body)))))
 
   (let ((docstring
          (and (pair? body) (pair? (cdr body))
@@ -1096,13 +1162,18 @@ result."
     ;; When the music function definition contains an i10n doc string,
     ;; (_i "doc string"), keep the literal string only
     `(ly:make-music-function
-      (list ,@signature)
+      (list ,@(map (lambda (pred)
+                     (if (pair? pred)
+                         `(cons ,(car pred)
+                                ,(and (pair? (cdr pred)) (cadr pred)))
+                         pred))
+                   (cons type signature)))
       ,(currying-lambda args docstring (if docstring (cdr body) body)))))
 
 (defmacro-public define-music-function rest
   "Defining macro returning music functions.
 Syntax:
-  (define-music-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...)
+  (define-music-function (arg1 arg2 ...) (arg1-type? arg2-type? ...)
     ...function body...)
 
 argX-type can take one of the forms @code{predicate?} for mandatory
@@ -1122,7 +1193,7 @@ set to the @code{location} parameter."
 (defmacro-public define-scheme-function rest
   "Defining macro returning Scheme functions.
 Syntax:
-  (define-scheme-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...)
+  (define-scheme-function (arg1 arg2 ...) (arg1-type? arg2-type? ...)
     ...function body...)
 
 argX-type can take one of the forms @code{predicate?} for mandatory
@@ -1150,7 +1221,7 @@ the return value."
 (defmacro-public define-event-function rest
   "Defining macro returning event functions.
 Syntax:
-  (define-event-function (parser location arg1 arg2 ...) (arg1-type? arg2-type? ...)
+  (define-event-function (arg1 arg2 ...) (arg1-type? arg2-type? ...)
     ...function body...)
 
 argX-type can take one of the forms @code{predicate?} for mandatory
@@ -1276,7 +1347,7 @@ then revert skipTypesetting."
     (context-spec-music (make-property-set 'skipTypesetting (not bool))
                         'Score))))
 
-(define (skip-as-needed music parser)
+(define (skip-as-needed music)
   "Replace MUSIC by
  << {  \\set skipTypesetting = ##f
  LENGTHOF(\\showFirstLength)
@@ -1289,8 +1360,8 @@ then revert skipTypesetting."
  the 'length property of the music is
  overridden to speed up compiling."
   (let*
-      ((show-last (ly:parser-lookup parser 'showLastLength))
-       (show-first (ly:parser-lookup parser 'showFirstLength))
+      ((show-last (ly:parser-lookup 'showLastLength))
+       (show-first (ly:parser-lookup 'showFirstLength))
        (show-last-length (and (ly:music? show-last)
                               (ly:music-length show-last)))
        (show-first-length (and (ly:music? show-first)
@@ -1340,24 +1411,21 @@ then revert skipTypesetting."
 
 (define-session-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) (expand-repeat-notes! 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)
-
-     (music-map (quote-substitute (ly:parser-lookup parser 'musicQuotes))  music))
+   (lambda (music) (expand-repeat-chords!
+                    (cons 'rhythmic-event
+                          (ly:parser-lookup '$chord-repeat-events))
+                    music))
+   expand-repeat-notes!
+   voicify-music
+   (lambda (x) (music-map music-check-error x))
+   (lambda (x) (music-map precompute-music-length x))
+   (lambda (music)
+     (music-map (quote-substitute (ly:parser-lookup 'musicQuotes))  music))
 
    ;; switch-on-debugging
-   (lambda (x parser) (music-map cue-substitute x))
+   (lambda (x) (music-map cue-substitute x))
 
-   (lambda (x parser)
-     (skip-as-needed x parser)
-     )))
+   skip-as-needed))
 
 ;;;;;;;;;;
 ;;; general purpose music functions
@@ -1873,7 +1941,7 @@ Entries that conform with the current key signature are not invalidated."
 
 (define-public (pitch-of-note event-chord)
   (let ((evs (filter (lambda (x)
-                       (music-has-type x 'note-event))
+                       (music-is-of-type? x 'note-event))
                      (ly:music-property event-chord 'elements))))
 
     (and (pair? evs)
@@ -1966,19 +2034,12 @@ not recursing into matches themselves."
   "Return a flat list of all music with @var{type} (either a single
 type symbol or a list of alternatives) inside of @var{music}, not
 recursing into matches themselves."
-  (extract-music
-   music
-   (if (cheap-list? type)
-       (lambda (m)
-         (any (lambda (t) (music-is-of-type? m t)) type))
-       (lambda (m) (music-is-of-type? m type)))))
+  (extract-music music (music-type-predicate type)))
 
-(define*-public (event-chord-wrap! music #:optional parser)
+(define-public (event-chord-wrap! music)
   "Wrap isolated rhythmic events and non-postevent events in
-@var{music} inside of an @code{EventChord}.  If the optional
-@var{parser} argument is given, chord repeats @samp{q} are expanded
-using the default settings.  Otherwise, you need to cater for them
-yourself."
+@var{music} inside of an @code{EventChord}.  Chord repeats @samp{q}
+are expanded using the default settings of the parser."
   (map-some-music
    (lambda (m)
      (cond ((music-is-of-type? m 'event-chord)
@@ -1995,12 +2056,11 @@ yourself."
                   (set! (ly:music-property m 'articulations) '()))
               (make-event-chord (cons m arts))))
            (else #f)))
-   (if parser
-       (expand-repeat-chords!
-        (cons 'rhythmic-event
-              (ly:parser-lookup parser '$chord-repeat-events))
-        music)
-       music)))
+   (expand-repeat-notes!
+    (expand-repeat-chords!
+     (cons 'rhythmic-event
+           (ly:parser-lookup '$chord-repeat-events))
+     music))))
 
 (define-public (event-chord-notes event-chord)
   "Return a list of all notes from @var{event-chord}."
@@ -2013,6 +2073,21 @@ yourself."
   (map (lambda (x) (ly:music-property x 'pitch))
        (event-chord-notes event-chord)))
 
+(define-public (music-pitches music)
+  "Return a list of all pitches from @var{music}."
+  ;; Opencoded for efficiency.
+  (reverse!
+   (let loop ((music music) (pitches '()))
+     (let ((p (ly:music-property music 'pitch)))
+       (if (ly:pitch? p)
+           (cons p pitches)
+           (let ((elt (ly:music-property music 'element)))
+             (fold loop
+                   (if (ly:music? elt)
+                       (loop elt pitches)
+                       pitches)
+                   (ly:music-property music 'elements))))))))
+
 (define-public (event-chord-reduce music)
   "Reduces event chords in @var{music} to their first note event,
 retaining only the chord articulations.  Returns the modified music."
@@ -2259,33 +2334,62 @@ list or if there is a type-mismatch, @var{arg} will be returned."
        arg offsets))
     (else arg)))
 
+(define-public (grob-transformer property func)
+  "Create an override value good for applying @var{func} to either
+pure or unpure values.  @var{func} is called with the respective grob
+as first argument and the default value (after resolving all callbacks)
+as the second."
+  (define (worker self container-part grob . rest)
+    (let* ((immutable (ly:grob-basic-properties grob))
+           ;; We need to search the basic-properties alist for our
+           ;; property to obtain values to offset.  Our search is
+           ;; complicated by the fact that calling the music function
+           ;; `offset' as an override conses a pair to the head of the
+           ;; alist.  This pair must be discounted.  The closure it
+           ;; contains is named `self' so it can be easily recognized.
+           ;; If `offset' is called as a tweak, the basic-property
+           ;; alist is unaffected.
+           (target (find-value-to-offset property self immutable))
+           ;; if target is a procedure, we need to apply it to our
+           ;; grob to calculate values to offset.
+           (vals (cond ((procedure? target) (target grob))
+                       ;; Argument lists for a pure procedure pulled
+                       ;; from an unpure-pure-container may be
+                       ;; different from a normal procedure, so we
+                       ;; need a different code path and calling
+                       ;; convention for procedures pulled from an
+                       ;; container as opposed to from the property
+                       ((ly:unpure-pure-container? target)
+                        (let ((part (container-part target)))
+                          (if (procedure? part)
+                              (apply part grob rest)
+                              part)))
+                       (else target))))
+      (func grob vals)))
+  ;; return the container named `self'.  The container self-reference
+  ;; seems like chasing its own tail but gets dissolved by
+  ;; define/lambda separating binding and referencing of "self".
+  (define self (ly:make-unpure-pure-container
+                (lambda (grob)
+                  (worker self ly:unpure-pure-container-unpure-part grob))
+                (lambda (grob . rest)
+                  (apply worker self ly:unpure-pure-container-pure-part
+                         grob rest))))
+  self)
+
 (define-public (offsetter property offsets)
   "Apply @var{offsets} to the default values of @var{property} of @var{grob}.
 Offsets are restricted to immutable properties and values of type @code{number},
 @code{number-pair}, or @code{number-pair-list}."
-  (define (self grob)
-    (let* ((immutable (ly:grob-basic-properties grob))
-           ; We need to search the basic-properties alist for our property to
-           ; obtain values to offset.  Our search is complicated by the fact that
-           ; calling the music function `offset' as an override conses a pair to
-           ; the head of the alist.  This pair must be discounted.  The closure it
-           ; contains is named `self' so it can be easily recognized.  If `offset'
-           ; is called as a tweak, the basic-property alist is unaffected.
-           (target (find-value-to-offset property self immutable))
-           ; if target is a procedure, we need to apply it to our grob to calculate
-           ; values to offset.
-           (vals
-             (if (procedure? target)
-                 (target grob)
-                 target))
-           (can-type-be-offset?
-             (or (number? vals)
-                 (number-pair? vals)
-                 (number-pair-list? vals))))
-
+  (define (offset-fun grob vals)
+    (let ((can-type-be-offset?
+           (or (number? vals)
+               (number-pair? vals)
+               (number-pair-list? vals))))
       (if can-type-be-offset?
-          ; '(+inf.0 . -inf.0) would offset to itself.  This will be confusing to a
-          ; user unaware of the default value of the property, so issue a warning.
+          ;; '(+inf.0 . -inf.0) would offset to itself.  This will be
+          ;; confusing to a user unaware of the default value of the
+          ;; property, so issue a warning.
           (if (equal? empty-interval vals)
               (ly:warning "default '~a of ~a is ~a and can't be offset"
                 property grob vals)
@@ -2295,8 +2399,8 @@ Offsets are restricted to immutable properties and values of type @code{number},
                            (ly:spanner-broken-into orig)
                            '()))
                      (total-found (length siblings))
-                     ; Since there is some flexibility in input syntax,
-                     ; structure of `offsets' is normalized.
+                     ;; Since there is some flexibility in input
+                     ;; syntax, structure of `offsets' is normalized.
                      (offsets
                        (if (or (not (pair? offsets))
                                (number-pair? offsets)
@@ -2306,7 +2410,7 @@ Offsets are restricted to immutable properties and values of type @code{number},
                            offsets)))
 
                 (define (helper sibs offs)
-                  ; apply offsets to the siblings of broken spanners
+                  ;; apply offsets to the siblings of broken spanners
                   (if (pair? offs)
                       (if (eq? (car sibs) grob)
                           (offset-multiple-types vals (car offs))
@@ -2317,12 +2421,10 @@ Offsets are restricted to immutable properties and values of type @code{number},
                     (helper siblings offsets)
                     (offset-multiple-types vals (car offsets)))))
 
-              (begin
-                (ly:warning "the property '~a of ~a cannot be offset" property grob)
-                vals))))
-    ; return the closure named `self'
-    self)
-
+          (begin
+            (ly:warning "the property '~a of ~a cannot be offset" property grob)
+            vals))))
+  (grob-transformer property offset-fun))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; \magnifyMusic and \magnifyStaff