+ (define (helper sibs arg)
+ (if (null? arg)
+ arg
+ (if (eq? (car sibs) grob)
+ (car arg)
+ (helper (cdr sibs) (cdr arg)))))
+
+ (if (>= (length siblings) 2)
+ (helper siblings arg)
+ (car arg))))
+(export value-for-spanner-piece)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The following are used by the \offset function
+
+(define (find-value-to-offset prop self alist)
+ "Return the first value of the property @var{prop} in the property
+alist @var{alist} -- after having found @var{self}. If @var{self} is
+not found, return the first value of @var{prop}."
+ (let ((segment (member (cons prop self) alist)))
+ (if (not segment)
+ (assoc-get prop alist)
+ (assoc-get prop (cdr segment)))))
+
+(define (offset-multiple-types arg offsets)
+ "Displace @var{arg} by @var{offsets} if @var{arg} is a number, a
+number pair, or a list of number pairs. If @var{offsets} is an empty
+list or if there is a type-mismatch, @var{arg} will be returned."
+ (cond
+ ((and (number? arg) (number? offsets))
+ (+ arg offsets))
+ ((and (number-pair? arg)
+ (or (number? offsets)
+ (number-pair? offsets)))
+ (coord-translate arg offsets))
+ ((and (number-pair-list? arg) (number-pair-list? offsets))
+ (map
+ (lambda (x y) (coord-translate x y))
+ arg offsets))
+ (else arg)))
+
+(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))))
+
+ (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.
+ (if (equal? empty-interval vals)
+ (ly:warning "default '~a of ~a is ~a and can't be offset"
+ property grob vals)
+ (let* ((orig (ly:grob-original grob))
+ (siblings
+ (if (ly:spanner? grob)
+ (ly:spanner-broken-into orig)
+ '()))
+ (total-found (length siblings))
+ ; Since there is some flexibility in input syntax,
+ ; structure of `offsets' is normalized.
+ (offsets
+ (if (or (not (pair? offsets))
+ (number-pair? offsets)
+ (and (number-pair-list? offsets)
+ (number-pair-list? vals)))
+ (list offsets)
+ offsets)))
+
+ (define (helper sibs offs)
+ ; apply offsets to the siblings of broken spanners
+ (if (pair? offs)
+ (if (eq? (car sibs) grob)
+ (offset-multiple-types vals (car offs))
+ (helper (cdr sibs) (cdr offs)))
+ vals))
+
+ (if (>= total-found 2)
+ (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)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; \magnifyMusic and \magnifyStaff
+
+;; defined as a function instead of a list because the
+;; all-grob-descriptions alist is not available yet
+(define-public (find-named-props prop-name grob-descriptions)
+ "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. When
+@var{grob-descriptions} is equal to the @code{all-grob-descriptions}
+alist (defined in @file{scm/define-grobs.scm}), this will find all grobs
+that can have a value for the @var{prop-name} property, and return them
+as a list in the following format:
+@example
+'((grob prop-name)
+ (grob prop-name)
+ ...)
+@end example"
+ (define (find-grobs-with-interface interface grob-descriptions)
+ (define (has-this-interface? grob-desc)
+ (let* ((meta (ly:assoc-get 'meta (cdr grob-desc)))
+ (interfaces (ly:assoc-get 'interfaces meta '())))
+ (memq interface interfaces)))
+ (let* ((grob-descriptions-with-this-interface
+ (filter has-this-interface? grob-descriptions))
+ (grob-names-with-this-interface
+ (map car grob-descriptions-with-this-interface)))
+ grob-names-with-this-interface))
+ (let* ((interface
+ (case prop-name
+ ((baseline-skip word-space) 'text-interface)
+ ((space-alist) 'break-aligned-interface)
+ (else (ly:programming-error
+ "find-named-props: no interface associated with ~s"
+ prop-name))))
+ (grobs-with-this-prop
+ (find-grobs-with-interface interface grob-descriptions)))
+ (map (lambda (x) (list x prop-name))
+ grobs-with-this-prop)))
+
+
+(define (magnifyStaff-is-set? context mag)
+ (let* ((Staff (ly:context-find context 'Staff))
+ (old-mag (ly:context-property Staff 'magnifyStaffValue)))
+ (not (null? old-mag))))
+
+(define (staff-magnification-is-changing? context mag)
+ (let* ((Staff (ly:context-find context 'Staff))
+ (old-mag (ly:context-property Staff 'magnifyStaffValue 1)))
+ (not (= old-mag mag))))
+
+(define-public (scale-fontSize func-name mag)
+ "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Look up the
+current @code{fontSize} in the appropriate context and scale it by the
+magnification factor @var{mag}. @var{func-name} is either
+@code{'magnifyMusic} or @code{'magnifyStaff}."
+ (make-apply-context
+ (lambda (context)
+ (if (or (eq? func-name 'magnifyMusic)
+ ;; for \magnifyStaff, only scale the fontSize
+ ;; if staff magnification is changing
+ ;; and does not equal 1
+ (and (staff-magnification-is-changing? context mag)
+ (not (= mag 1))))
+ (let* ((where (case func-name
+ ((magnifyMusic) context)
+ ((magnifyStaff) (ly:context-find context 'Staff))))
+ (fontSize (ly:context-property where 'fontSize 0))
+ (new-fontSize (+ fontSize (magnification->font-size mag))))
+ (ly:context-set-property! where 'fontSize new-fontSize))))))
+
+(define-public (revert-fontSize func-name mag)
+ "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Calculate
+the previous @code{fontSize} value (before scaling) by factoring out the
+magnification factor @var{mag} (if @var{func-name} is
+@code{'magnifyMusic}), or by factoring out the context property
+@code{magnifyStaffValue} (if @var{func-name} is @code{'magnifyStaff}).
+Revert the @code{fontSize} in the appropriate context accordingly.
+
+With @code{\\magnifyMusic}, the scaling is reverted after the music
+block it operates on. @code{\\magnifyStaff} does not operate on a music
+block, so the scaling from a previous call (if there is one) is reverted
+before the new scaling takes effect."
+ (make-apply-context
+ (lambda (context)
+ (if (or (eq? func-name 'magnifyMusic)
+ ;; for \magnifyStaff...
+ (and
+ ;; don't revert the user's fontSize choice
+ ;; the first time \magnifyStaff is called
+ (magnifyStaff-is-set? context mag)
+ ;; only revert the previous fontSize
+ ;; if staff magnification is changing
+ (staff-magnification-is-changing? context mag)))
+ (let* ((where
+ (case func-name
+ ((magnifyMusic) context)
+ ((magnifyStaff) (ly:context-find context 'Staff))))
+ (old-mag
+ (case func-name
+ ((magnifyMusic) mag)
+ ((magnifyStaff)
+ (ly:context-property where 'magnifyStaffValue 1))))
+ (fontSize (ly:context-property where 'fontSize 0))
+ (old-fontSize (- fontSize (magnification->font-size old-mag))))
+ (ly:context-set-property! where 'fontSize old-fontSize))))))
+
+(define-public (scale-props func-name mag allowed-to-shrink? props)
+ "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. For each
+prop in @var{props}, find the current value of the requested prop, scale
+it by the magnification factor @var{mag}, and do the equivalent of a
+@code{\\temporary@tie{}\\override} with the new value in the appropriate
+context. If @var{allowed-to-shrink?} is @code{#f}, don't let the new
+value be less than the current value. @var{func-name} is either
+@code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props} list is
+formatted like:
+@example
+'((Stem thickness)
+ (Slur line-thickness)
+ ...)
+@end example"
+ (make-apply-context
+ (lambda (context)
+ (define (scale-prop grob-prop-list)
+ (let* ((grob (car grob-prop-list))
+ (prop (cadr grob-prop-list))
+ (where (if (eq? grob 'SpacingSpanner)
+ (ly:context-find context 'Score)
+ (case func-name
+ ((magnifyMusic) context)
+ ((magnifyStaff) (ly:context-find context 'Staff)))))
+ (grob-def (ly:context-grob-definition where grob)))
+ (if (eq? prop 'space-alist)
+ (let* ((space-alist (ly:assoc-get prop grob-def))
+ (scale-spacing-tuple (lambda (x)
+ (cons (car x)
+ (cons (cadr x)
+ (* mag (cddr x))))))
+ (scaled-tuples (if space-alist
+ (map scale-spacing-tuple space-alist)
+ '()))
+ (new-alist (append scaled-tuples space-alist)))
+ (ly:context-pushpop-property where grob prop new-alist))
+ (let* ((val (ly:assoc-get prop grob-def (case prop
+ ((baseline-skip) 3)
+ ((word-space) 0.6)
+ (else 1))))
+ (proc (lambda (x)
+ (if allowed-to-shrink?
+ (* x mag)
+ (* x (max 1 mag)))))
+ (new-val (if (number-pair? val)
+ (cons (proc (car val))
+ (proc (cdr val)))
+ (proc val))))
+ (ly:context-pushpop-property where grob prop new-val)))))
+ (if (or (eq? func-name 'magnifyMusic)
+ ;; for \magnifyStaff, only scale the properties
+ ;; if staff magnification is changing
+ ;; and does not equal 1
+ (and (staff-magnification-is-changing? context mag)
+ (not (= mag 1))))
+ (for-each scale-prop props)))))
+
+(define-public (revert-props func-name mag props)
+ "Used by @code{\\magnifyMusic} and @code{\\magnifyStaff}. Revert each
+prop in @var{props} in the appropriate context. @var{func-name} is
+either @code{'magnifyMusic} or @code{'magnifyStaff}. The @var{props}
+list is formatted like:
+@example
+'((Stem thickness)
+ (Slur line-thickness)
+ ...)
+@end example"
+ (make-apply-context
+ (lambda (context)
+ (define (revert-prop grob-prop-list)
+ (let* ((grob (car grob-prop-list))
+ (prop (cadr grob-prop-list))
+ (where (if (eq? grob 'SpacingSpanner)
+ (ly:context-find context 'Score)
+ (case func-name
+ ((magnifyMusic) context)
+ ((magnifyStaff) (ly:context-find context 'Staff))))))
+ (ly:context-pushpop-property where grob prop)))
+ (if (or (eq? func-name 'magnifyMusic)
+ ;; for \magnifyStaff...
+ (and
+ ;; don't revert the user's property overrides
+ ;; the first time \magnifyStaff is called
+ (magnifyStaff-is-set? context mag)
+ ;; revert the overrides from the previous \magnifyStaff,
+ ;; but only if staff magnification is changing
+ (staff-magnification-is-changing? context mag)))
+ (for-each revert-prop props)))))
+
+;; \magnifyMusic only
+(define-public (scale-beam-thickness mag)
+ "Used by @code{\\magnifyMusic}. Scaling @code{Beam.beam-thickness}
+exactly to the @var{mag} value will not work. This uses two reference
+values for @code{beam-thickness} to determine an acceptable value when
+scaling, then does the equivalent of a
+@code{\\temporary@tie{}\\override} with the new value."
+ (make-apply-context
+ (lambda (context)
+ (let* ((grob-def (ly:context-grob-definition context 'Beam))
+ (val (ly:assoc-get 'beam-thickness grob-def 0.48))
+ (ratio-to-default (/ val 0.48))
+ ;; gives beam-thickness=0.48 when mag=1 (like default),
+ ;; gives beam-thickness=0.35 when mag=0.63 (like CueVoice)
+ (scaled-default (+ 119/925 (* mag 13/37)))
+ (new-val (* scaled-default ratio-to-default)))
+ (ly:context-pushpop-property context 'Beam 'beam-thickness new-val)))))
+
+;; tag management
+;;
+
+(define tag-groups (make-hash-table))
+(call-after-session (lambda () (hash-clear! tag-groups)))
+
+(define-public (define-tag-group tags)
+ "Define a tag-group consisting of the given @var{tags}, a@tie{}list
+of symbols. Returns @code{#f} if successful, and an error message if
+there is a conflicting tag group definition."
+ (cond ((not (symbol-list? tags)) (format #f (_ "not a symbol list: ~a") tags))
+ ((any (lambda (tag) (hashq-ref tag-groups tag)) tags)
+ => (lambda (group) (and (not (lset= eq? group tags))
+ (format #f (_ "conflicting tag group ~a") group))))
+ (else
+ (for-each
+ (lambda (elt) (hashq-set! tag-groups elt tags))
+ tags)
+ #f)))
projects / lilypond.git / blobdiff