+(define (recent-enough? bar-number alteration-def laziness)
+ (or (number? alteration-def)
+ (equal? laziness #t)
+ (<= bar-number (+ (cadr alteration-def) laziness))))
+
+(define (accidental-invalid? alteration-def)
+ "Checks an alteration entry for being invalid.
+
+Non-key alterations are invalidated when tying into the next bar or
+when there is a clef change, since neither repetition nor cancellation
+can be omitted when the same note occurs again.
+
+Returns @code{#f} or the reason for the invalidation, a symbol."
+ (let* ((def (if (pair? alteration-def)
+ (car alteration-def)
+ alteration-def)))
+ (and (symbol? def) def)))
+
+(define (extract-alteration alteration-def)
+ (cond ((number? alteration-def)
+ alteration-def)
+ ((pair? alteration-def)
+ (car alteration-def))
+ (else 0)))
+
+(define (check-pitch-against-signature context pitch barnum laziness octaveness all-naturals)
+ "Checks the need for an accidental and a @q{restore} accidental against
+@code{localAlterations} and @code{keyAlterations}.
+The @var{laziness} is the number of measures
+for which reminder accidentals are used (i.e., if @var{laziness} is zero,
+only cancel accidentals in the same measure; if @var{laziness} is three,
+we cancel accidentals up to three measures after they first appear.
+@var{octaveness} is either @code{'same-octave} or @code{'any-octave} and
+specifies whether accidentals should be canceled in different octaves.
+If @var{all-naturals} is ##t, notes that do not occur in @code{keyAlterations}
+also get an accidental."
+ (let* ((ignore-octave (cond ((equal? octaveness 'any-octave) #t)
+ ((equal? octaveness 'same-octave) #f)
+ (else
+ (ly:warning (_ "Unknown octaveness type: ~S ") octaveness)
+ (ly:warning (_ "Defaulting to 'any-octave."))
+ #t)))
+ (key (ly:context-property context 'keyAlterations))
+ (local (ly:context-property context 'localAlterations))
+ (notename (ly:pitch-notename pitch))
+ (octave (ly:pitch-octave pitch))
+ (pitch-handle (cons octave notename))
+ (need-restore #f)
+ (need-accidental #f)
+ (previous-alteration #f)
+ (from-other-octaves #f)
+ (from-same-octave (assoc-get pitch-handle local))
+ (from-key-sig (or (assoc-get notename local)
+
+ ;; If no notename match is found from localAlterations, we may have a custom
+ ;; type with octave-specific entries of the form ((octave . pitch) alteration)
+ ;; instead of (pitch . alteration). Since this type cannot coexist with entries in
+ ;; localAlterations, try extracting from keyAlterations instead.
+ (assoc-get pitch-handle key))))
+
+ ;; loop through localAlterations to search for a notename match from other octaves
+ (let loop ((l local))
+ (if (pair? l)
+ (let ((entry (car l)))
+ (if (and (pair? (car entry))
+ (= (cdar entry) notename))
+ (set! from-other-octaves (cdr entry))
+ (loop (cdr l))))))
+
+ ;; find previous alteration-def for comparison with pitch
+ (cond
+ ;; from same octave?
+ ((and (not ignore-octave)
+ from-same-octave
+ (recent-enough? barnum from-same-octave laziness))
+ (set! previous-alteration from-same-octave))
+
+ ;; from any octave?
+ ((and ignore-octave
+ from-other-octaves
+ (recent-enough? barnum from-other-octaves laziness))
+ (set! previous-alteration from-other-octaves))
+
+ ;; not recent enough, extract from key signature/local key signature
+ (from-key-sig
+ (set! previous-alteration from-key-sig)))
+
+ (if (accidental-invalid? previous-alteration)
+ (set! need-accidental #t)
+
+ (let* ((prev-alt (extract-alteration previous-alteration))
+ (this-alt (ly:pitch-alteration pitch)))
+
+ (if (or (and all-naturals (eq? #f previous-alteration)) (not (= this-alt prev-alt)))
+ (begin
+ (set! need-accidental #t)
+ (if (and (not (= this-alt 0))
+ (and (< (abs this-alt) (abs prev-alt))
+ (> (* prev-alt this-alt) 0)))
+ (set! need-restore #t))))))
+
+ (cons need-restore need-accidental)))
+
+(define ((make-accidental-rule octaveness laziness) context pitch barnum measurepos)
+ "Create an accidental rule that makes its decision based on the octave of
+the note and a laziness value.
+
+@var{octaveness} is either @code{'same-octave} or @code{'any-octave} and
+defines whether the rule should respond to accidental changes in other
+octaves than the current. @code{'same-octave} is the normal way to typeset
+accidentals -- an accidental is made if the alteration is different from the
+last active pitch in the same octave. @code{'any-octave} looks at the last
+active pitch in any octave.
+
+@var{laziness} states over how many bars an accidental should be remembered.
+@code{0}@tie{}is the default -- accidental lasts over 0@tie{}bar lines, that
+is, to the end of current measure. A positive integer means that the
+accidental lasts over that many bar lines. @w{@code{-1}} is `forget
+immediately', that is, only look at key signature. @code{#t} is `forever'."
+
+ (check-pitch-against-signature context pitch barnum laziness octaveness #f))
+(export make-accidental-rule)
+
+(define ((make-accidental-dodecaphonic-rule octaveness laziness) context pitch barnum measurepos)
+ "Variation on function make-accidental-rule that creates an dodecaphonic
+accidental rule."
+
+ (check-pitch-against-signature context pitch barnum laziness octaveness #t))
+(export make-accidental-dodecaphonic-rule)
+
+(define (key-entry-notename entry)
+ "Return the pitch of an @var{entry} in @code{localAlterations}.
+The @samp{car} of the entry is either of the form @code{notename} or
+of the form @code{(octave . notename)}. The latter form is used for special
+key signatures or to indicate an explicit accidental.
+
+The @samp{cdr} of the entry is either a rational @code{alter} indicating
+a key signature alteration, or of the form
+@code{(alter . (barnum . measurepos))} indicating an alteration caused by
+an accidental in music."
+ (if (pair? (car entry))
+ (cdar entry)
+ (car entry)))
+
+(define (key-entry-octave entry)
+ "Return the octave of an entry in @code{localAlterations}
+or @code{#f} if the entry does not have an octave.
+See @code{key-entry-notename} for details."
+ (and (pair? (car entry)) (caar entry)))
+
+(define (key-entry-bar-number entry)
+ "Return the bar number of an entry in @code{localAlterations}
+or @code {#f} if the entry does not have a bar number.
+See @code{key-entry-notename} for details."
+ (and (pair? (cdr entry)) (caddr entry)))
+
+(define (key-entry-measure-position entry)
+ "Return the measure position of an entry in @code{localAlterations}
+or @code {#f} if the entry does not have a measure position.
+See @code{key-entry-notename} for details."
+ (and (pair? (cdr entry)) (cdddr entry)))
+
+(define (key-entry-alteration entry)
+ "Return the alteration of an entry in localAlterations
+
+For convenience, returns @code{0} if entry is @code{#f}."
+ (if entry
+ (if (number? (cdr entry))
+ (cdr entry)
+ (cadr entry))
+ 0))
+
+(define-public (find-pitch-entry keysig pitch accept-global accept-local)
+ "Return the first entry in @var{keysig} that matches @var{pitch}
+by notename and octave. Alteration is not considered.
+@var{accept-global} states whether key signature entries should be included.
+@var{accept-local} states whether local accidentals should be included.
+If no matching entry is found, @var{#f} is returned."
+ (and (pair? keysig)
+ (let* ((entry (car keysig))
+ (entryoct (key-entry-octave entry))
+ (entrynn (key-entry-notename entry))
+ (nn (ly:pitch-notename pitch)))
+ (if (and (equal? nn entrynn)
+ (or (not entryoct)
+ (= entryoct (ly:pitch-octave pitch)))
+ (if (key-entry-bar-number entry)
+ accept-local
+ accept-global))
+ entry
+ (find-pitch-entry (cdr keysig) pitch accept-global accept-local)))))
+
+(define-public (neo-modern-accidental-rule context pitch barnum measurepos)
+ "An accidental rule that typesets an accidental if it differs from the
+key signature @emph{and} does not directly follow a note on the same
+staff line. This rule should not be used alone because it does neither
+look at bar lines nor different accidentals at the same note name."
+ (let* ((keysig (ly:context-property context 'localAlterations))
+ (entry (find-pitch-entry keysig pitch #t #t)))
+ (if (not entry)
+ (cons #f #f)
+ (let* ((global-entry (find-pitch-entry keysig pitch #t #f))
+ (key-acc (key-entry-alteration global-entry))
+ (acc (ly:pitch-alteration pitch))
+ (entrymp (key-entry-measure-position entry))
+ (entrybn (key-entry-bar-number entry)))
+ (cons #f (not (or (equal? acc key-acc)
+ (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))))
+
+(define-public (dodecaphonic-no-repeat-rule context pitch barnum measurepos)
+ "An accidental rule that typesets an accidental before every
+note (just as in the dodecaphonic accidental style) @emph{except} if
+the note is immediately preceded by a note with the same pitch. This
+is a common accidental style in contemporary notation."
+ (let* ((keysig (ly:context-property context 'localAlterations))
+ (entry (find-pitch-entry keysig pitch #f #t)))
+ (if (not entry)
+ (cons #f #t)
+ (let ((entrymp (key-entry-measure-position entry))
+ (entrybn (key-entry-bar-number entry))
+ (entryalt (key-entry-alteration entry))
+ (alt (ly:pitch-alteration pitch)))
+ (cons #t
+ (not (and (equal? entrybn barnum)
+ (or (equal? measurepos entrymp)
+ (ly:moment<? measurepos entrymp))
+ (equal? entryalt alt))))))))
+
+(define-public (teaching-accidental-rule context pitch barnum measurepos)
+ "An accidental rule that typesets a cautionary accidental if it is
+included in the key signature @emph{and} does not directly follow a note
+on the same staff line."
+ (let* ((keysig (ly:context-property context 'localAlterations))
+ (entry (find-pitch-entry keysig pitch #t #t)))
+ (if (not entry)
+ (cons #f #f)
+ (let* ((global-entry (find-pitch-entry keysig pitch #f #f))
+ (key-acc (key-entry-alteration global-entry))
+ (acc (ly:pitch-alteration pitch))
+ (entrymp (key-entry-measure-position entry))
+ (entrybn (key-entry-bar-number entry)))
+ (cons #f (not (or (equal? acc key-acc)
+ (and (equal? entrybn barnum) (equal? entrymp measurepos)))))))))
+
+(define-session-public accidental-styles
+ ;; An alist containing specification for all accidental styles.
+ ;; Each accidental style needs three entries for the context properties
+ ;; extraNatural, autoAccidentals and autoCautionaries.
+ ;; An optional fourth entry may specify a default context for the accidental
+ ;; style, for use with the piano styles.
+ `(
+ ;; accidentals as they were common in the 18th century.
+ (default #t
+ (Staff ,(make-accidental-rule 'same-octave 0))
+ ())
+ ;; accidentals from one voice do NOT get canceled in other voices
+ (voice #t
+ (Voice ,(make-accidental-rule 'same-octave 0))
+ ())
+ ;; accidentals as suggested by Kurt Stone in
+ ;; ‘Music Notation in the 20th century’.
+ ;; This includes all the default accidentals, but accidentals also need
+ ;; canceling in other octaves and in the next measure.
+ (modern #f
+ (Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ ())
+ ;; the accidentals that Stone adds to the old standard as cautionaries
+ (modern-cautionary #f
+ (Staff ,(make-accidental-rule 'same-octave 0))
+ (Staff ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)))
+ ;; same as modern, but accidentals different from the key signature are
+ ;; always typeset - unless they directly follow a note of the same pitch.
+ (neo-modern #f
+ (Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule)
+ ())
+ (neo-modern-cautionary #f
+ (Staff ,(make-accidental-rule 'same-octave 0))
+ (Staff ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule))
+ (neo-modern-voice #f
+ (Voice ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule
+ Staff
+ ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule)
+ ())
+ (neo-modern-voice-cautionary #f
+ (Voice ,(make-accidental-rule 'same-octave 0))
+ (Voice ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule
+ Staff
+ ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ,neo-modern-accidental-rule))
+
+ ;; Accidentals as they were common in dodecaphonic music with no tonality.
+ ;; Each note gets one accidental.
+ (dodecaphonic #f
+ (Staff ,(lambda (c p bn mp) '(#f . #t)))
+ ())
+ ;; As in dodecaphonic style with the exception that immediately
+ ;; repeated notes (in the same voice) don't get an accidental
+ (dodecaphonic-no-repeat #f
+ (Staff ,dodecaphonic-no-repeat-rule)
+ ())
+ ;; Variety of the dodecaphonic style. Each note gets an accidental,
+ ;; except notes that were already handled in the same measure.
+ (dodecaphonic-first #f
+ (Staff ,(make-accidental-dodecaphonic-rule 'same-octave 0))
+ ())
+
+ ;; 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 canceled across voices.
+ (modern-voice #f
+ (Voice ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ Staff
+ ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ ())
+ ;; same as modernVoiceAccidental except that all special accidentals
+ ;; are typeset as cautionaries
+ (modern-voice-cautionary #f
+ (Voice ,(make-accidental-rule 'same-octave 0))
+ (Voice ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ Staff
+ ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)))
+
+ ;; Stone's suggestions for accidentals on grand staff.
+ ;; Accidentals are canceled across the staves
+ ;; in the same grand staff as well
+ (piano #f
+ (Staff ,(make-accidental-rule 'same-octave 0)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ GrandStaff
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ ()
+ GrandStaff)
+ (piano-cautionary #f
+ (Staff ,(make-accidental-rule 'same-octave 0))
+ (Staff ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ GrandStaff
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ GrandStaff)
+
+ ;; Accidentals on a choir staff for simultaneous reading of the
+ ;; own voice and the surrounding choir. Similar to piano, except
+ ;; that the first alteration within a voice is always printed.
+ (choral #f
+ (Voice ,(make-accidental-rule 'same-octave 0)
+ Staff
+ ,(make-accidental-rule 'same-octave 1)
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ChoirStaff
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ ()
+ ChoirStaff)
+ (choral-cautionary #f
+ (Voice ,(make-accidental-rule 'same-octave 0)
+ Staff
+ ,(make-accidental-rule 'same-octave 0))
+ (Staff ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1)
+ ChoirStaff
+ ,(make-accidental-rule 'any-octave 0)
+ ,(make-accidental-rule 'same-octave 1))
+ ChoirStaff)
+
+ ;; same as modern, but cautionary accidentals are printed for all
+ ;; non-natural tones specified by the key signature.
+ (teaching #f
+ (Staff ,(make-accidental-rule 'same-octave 0))
+ (Staff ,(make-accidental-rule 'same-octave 1)
+ ,teaching-accidental-rule))
+
+ ;; do not set localAlterations when a note alterated differently from
+ ;; localAlterations is found.
+ ;; Causes accidentals to be printed at every note instead of
+ ;; remembered for the duration of a measure.
+ ;; accidentals not being remembered, causing accidentals always to
+ ;; be typeset relative to the time signature
+ (forget ()
+ (Staff ,(make-accidental-rule 'same-octave -1))
+ ())
+ ;; Do not reset the key at the start of a measure. Accidentals will be
+ ;; printed only once and are in effect until overridden, possibly many
+ ;; measures later.
+ (no-reset ()
+ (Staff ,(make-accidental-rule 'same-octave #t))
+ ())
+ ))