- (ignatzek-format-exception root exception bass-note lowercase-root?)
-
- (begin
- ;; no exception.
- ;; handle sus4 and sus2 suffix: if there is a 3 together with
- ;; sus2 or sus4, then we explicitly say add3.
- (map
- (lambda (j)
- (if (get-step j pitches)
- (begin
- (if (get-step 3 pitches)
- (begin
- (set! add-steps (cons (get-step 3 pitches) add-steps))
- (set! pitches (remove-step 3 pitches))))
- (set! suffixes (cons (get-step j pitches) suffixes)))))
- '(2 4))
-
- ;; do minor-3rd modifier.
- (if (and (get-step 3 pitches)
- (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
- (set! prefixes (cons (get-step 3 pitches) prefixes)))
-
- ;; lazy bum. Should write loop.
- (cond
- ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
- ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
- ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
- ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
- ((get-step 3 pitches) (set! main-name (get-step 3 pitches))))
-
- (let* ((3-diff? (lambda (x y)
- (= (- (pitch-step y) (pitch-step x)) 2)))
- (split (split-at-predicate
- 3-diff? (remove-uptil-step 5 pitches))))
- (set! alterations (append alterations (car split)))
- (set! add-steps (append add-steps (cdr split)))
- (set! alterations (delq main-name alterations))
- (set! add-steps (delq main-name add-steps))
-
-
- ;; chords with natural (5 7 9 11 13) or leading subsequence.
- ;; etc. are named by the top pitch, without any further
- ;; alterations.
- (if (and
- (ly:pitch? main-name)
- (= 7 (pitch-step main-name))
- (is-natural-alteration? main-name)
- (pair? (remove-uptil-step 7 alterations))
- (reduce (lambda (x y) (and x y)) #t
- (map is-natural-alteration? alterations)))
- (begin
- (set! main-name (last alterations))
- (set! alterations '())))
-
- (ignatzek-format-chord-name
- root prefixes main-name alterations add-steps suffixes bass-note
- lowercase-root?))))))
+ (ignatzek-format-exception root exception bass-note lowercase-root?)
+
+ (begin
+ ;; no exception.
+ ;; handle sus4 and sus2 suffix: if there is a 3 together with
+ ;; sus2 or sus4, then we explicitly say add3.
+ (for-each
+ (lambda (j)
+ (if (get-step j pitches)
+ (begin
+ (if (get-step 3 pitches)
+ (begin
+ (set! add-steps (cons (get-step 3 pitches) add-steps))
+ (set! pitches (remove-step 3 pitches))))
+ (set! suffixes (cons (get-step j pitches) suffixes)))))
+ '(2 4))
+
+ ;; do minor-3rd modifier.
+ (if (and (get-step 3 pitches)
+ (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
+ (set! prefixes (cons (get-step 3 pitches) prefixes)))
+
+ ;; lazy bum. Should write loop.
+ (cond
+ ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
+ ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
+ ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
+ ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
+ ((get-step 3 pitches) (set! main-name (get-step 3 pitches))))
+
+ (let* ((3-diff? (lambda (x y)
+ (= (- (pitch-step y) (pitch-step x)) 2)))
+ (split (split-at-predicate
+ 3-diff? (remove-uptil-step 5 pitches))))
+ (set! alterations (append alterations (car split)))
+ (set! add-steps (append add-steps (cdr split)))
+ (set! alterations (delq main-name alterations))
+ (set! add-steps (delq main-name add-steps))
+
+
+ ;; chords with natural (5 7 9 11 13) or leading subsequence.
+ ;; etc. are named by the top pitch, without any further
+ ;; alterations.
+ (if (and
+ (ly:pitch? main-name)
+ (= 7 (pitch-step main-name))
+ (is-natural-alteration? main-name)
+ (pair? (remove-uptil-step 7 alterations))
+ (every is-natural-alteration? alterations))
+ (begin
+ (set! main-name (last alterations))
+ (set! alterations '())))
+
+ (ignatzek-format-chord-name
+ root prefixes main-name alterations add-steps suffixes bass-note
+ lowercase-root?))))))