+ (make-apply-context
+ (lambda (c)
+ (revert-property-setting
+ c
+ 'timeSignatureSettings
+ time-signature)))
+ 'Timing))
+
+
+
+
+;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+;;; Formatting of complex/compound time signatures
+
+; There ought to be a \join-line sep {...} command
+(define (insert-markups l m)
+ (let ((ll (reverse l)))
+ (let join-markups ((markups (list (car ll)))
+ (remaining (cdr ll)))
+ (if (pair? remaining)
+ (join-markups (cons (car remaining) (cons m markups)) (cdr remaining))
+ markups))))
+
+;;; Use a centered-column inside a left-column, because the centered column
+;;; moves its reference point to the center, which the left-column undoes.
+(define (format-time-fraction time-sig-fraction)
+ (let* ((revargs (reverse (map number->string time-sig-fraction)))
+ (den (car revargs))
+ (nums (reverse (cdr revargs))))
+ (make-override-markup '(baseline-skip . 0)
+ (make-left-column-markup
+ (list (make-center-column-markup
+ (list (make-line-markup (insert-markups nums "+"))
+ den)))))))
+
+(define (format-time-numerator time-sig)
+ (make-vcenter-markup (number->string (car time-sig))))
+
+(define (format-time-element time-sig)
+ (cond ((number-pair? time-sig)
+ (format-time-fraction (list (car time-sig) (cdr time-sig))))
+ ((pair? (cdr time-sig))
+ (format-time-fraction time-sig))
+ (else
+ (format-time-numerator time-sig))))
+
+(define (format-time-list time-sig)
+ (make-override-markup '(baseline-skip . 0)
+ (make-line-markup
+ (insert-markups (map format-time-element time-sig)
+ (make-vcenter-markup "+")))))
+
+(define (format-compound-time time-sig)
+ (make-number-markup
+ (cond
+ ((number? time-sig) (format-time-element (list time-sig)))
+ ((number-pair? time-sig)
+ (format-time-element (list (car time-sig) (cdr time-sig))))
+ ((pair? (car time-sig)) (format-time-list time-sig))
+ (else (format-time-element time-sig)))))
+
+(define-markup-command (compound-meter layout props time-sig)
+ (number-or-pair?)
+ #:category music
+ "Draw a numeric time signature.
+
+@lilypond[verbatim,quote]
+\\markup {
+ \\column {
+ \\line { Single number: \\compound-meter #3 }
+ \\line { Conventional: \\compound-meter #'(4 . 4)
+ or \\compound-meter #'(4 4) }
+ \\line { Compound: \\compound-meter #'(2 3 8) }
+ \\line { Single-number compound: \\compound-meter #'((2) (3)) }
+ \\line { Complex compound: \\compound-meter #'((2 3 8) (3 4)) }
+ }
+}
+@end lilypond
+"
+ (interpret-markup layout props (format-compound-time time-sig)))
+
+(add-simple-time-signature-style 'numbered make-compound-meter-markup)
+
+(add-simple-time-signature-style 'single-digit
+ (lambda (fraction) (make-compound-meter-markup (car fraction))))
+
+;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+;;; Formatting of symbolic time signatures
+
+(define-public (make-glyph-time-signature-markup style fraction)
+ "Make markup for a symbolic time signature. If the music font does not have a glyph for the requested style and fraction, issue a warning and make a numbered time signature instead."
+ (make-first-visible-markup
+ (list (make-musicglyph-markup (string-append
+ "timesig."
+ (symbol->string style)
+ (number->string (car fraction))
+ (number->string (cdr fraction))))
+ (make-compound-meter-markup fraction))))
+
+(define-public (make-c-time-signature-markup fraction)
+ "Make markup for the `C' time signature style."
+ (let ((n (car fraction))
+ (d (cdr fraction)))
+ ; check specific fractions to avoid warnings when no glyph exists
+ (if (or (and (= n 2) (= d 2))
+ (and (= n 4) (= d 4)))
+ (make-glyph-time-signature-markup 'C fraction)
+ (make-compound-meter-markup fraction))))
+
+(add-simple-time-signature-style 'C make-c-time-signature-markup)
+(add-simple-time-signature-style 'default make-c-time-signature-markup)
+
+(define-public (make-single-c-time-signature-markup fraction)
+ "Make markup for the `single-C' time signature style."
+ (let ((n (car fraction)))
+ (if (or (= n 2) (= n 4)) ; numerator only
+ (make-glyph-time-signature-markup 'C (cons n n))
+ (make-compound-meter-markup n))))
+
+(add-simple-time-signature-style 'single-C make-single-c-time-signature-markup)
+
+;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+;;; Measure length calculation of (possibly complex) compound time signatures
+
+(define (calculate-time-fraction time-sig-fraction)
+ (let* ((revargs (reverse time-sig-fraction))
+ (den (car revargs))
+ (num (apply + (cdr revargs))))
+ (ly:make-moment num den)))
+
+(define (calculate-complex-compound-time time-sig)
+ (let add-moment ((moment ZERO-MOMENT)
+ (remaining (map calculate-time-fraction time-sig)))
+ (if (pair? remaining)
+ (add-moment (ly:moment-add moment (car remaining)) (cdr remaining))
+ moment)))
+
+(define-public (calculate-compound-measure-length time-sig)
+ (cond
+ ((not (pair? time-sig)) (ly:make-moment 4 4))
+ ((pair? (car time-sig)) (calculate-complex-compound-time time-sig))
+ (else (calculate-time-fraction time-sig))))
+
+
+;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+;;; Base beat length: Use the smallest denominator from all fraction
+
+(define (calculate-compound-base-beat-full time-sig)
+ (apply max (map last time-sig)))
+
+(define-public (calculate-compound-base-beat time-sig)
+ (ly:make-moment 1
+ (cond
+ ((not (pair? time-sig)) 4)
+ ((pair? (car time-sig)) (calculate-compound-base-beat-full time-sig))
+ (else (calculate-compound-base-beat-full (list time-sig))))))
+
+
+;;;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+;;; Beat Grouping
+
+(define (normalize-fraction frac beat)
+ (let* ((thisbeat (car (reverse frac)))
+ (factor (/ beat thisbeat)))
+ (map (lambda (f) (* factor f)) frac)))
+
+(define (beat-grouping-internal time-sig)
+ ;; Normalize to given beat, extract the beats and join them to one list
+ (let* ((beat (calculate-compound-base-beat-full time-sig))
+ (normalized (map (lambda (f) (normalize-fraction f beat)) time-sig))
+ (beats (map (lambda (f) (drop-right f 1)) normalized)))
+ (concatenate beats)))
+
+(define-public (calculate-compound-beat-grouping time-sig)
+ (cond
+ ((not (pair? time-sig)) '(2 . 2))
+ ((pair? (car time-sig)) (beat-grouping-internal time-sig))
+ (else (beat-grouping-internal (list time-sig)))))