2 ;;; chord-name.scm -- chord name utility functions
4 ;;; source file of the GNU LilyPond music typesetter
6 ;;; (c) 2000--2003 Han-Wen Nienhuys
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
14 ;; after Klaus Ignatzek, Die Jazzmethode fuer Klavier 1.
16 ;; The idea is: split chords into
18 ;; ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS
20 ;; and put that through a layout routine.
22 ;; the split is a procedural process, with lots of set!.
26 ;; todo: naming is confusing: steps (0 based) vs. steps (1 based).
27 (define (pitch-step p)
28 "Musicological notation for an interval. Eg. C to D is 2."
29 (+ 1 (ly:pitch-steps p)))
31 (define (get-step x ps)
32 "Does PS have the X step? Return that step if it does."
35 (if (= (- x 1) (ly:pitch-steps (car ps)))
37 (get-step x (cdr ps)))
40 (define (replace-step p ps)
41 "Copy PS, but replace the step of P in PS."
46 (t (replace-step p (cdr ps)))
49 (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
55 (define (remove-step x ps)
56 "Copy PS, but leave out the Xth step."
61 (t (remove-step x (cdr ps)))
64 (if (= (- x 1) (ly:pitch-steps (car ps)))
71 (define-public (ignatzek-chord-names
72 in-pitches bass inversion
75 (define (remove-uptil-step x ps)
76 "Copy PS, but leave out everything below the Xth step."
79 (if (< (ly:pitch-steps (car ps)) (- x 1))
80 (remove-uptil-step x (cdr ps))
84 (define name-root (ly:get-context-property context 'chordRootNamer))
86 (let ((nn (ly:get-context-property context 'chordNoteNamer)))
88 ; replacing the next line with name-root gives guile-error...? -rz
90 ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
91 (ly:get-context-property context 'chordRootNamer)
95 (define (is-natural-alteration? p)
96 (= (natural-chord-alteration p) (ly:pitch-alteration p))
100 (define (ignatzek-format-chord-name
110 "Format for the given (lists of) pitches. This is actually more
111 work than classifying the pitches."
113 (define (filter-main-name p)
114 "The main name: don't print anything for natural 5 or 3."
116 (or (not (ly:pitch? p))
117 (and (is-natural-alteration? p)
118 (or (= (pitch-step p) 5)
119 (= (pitch-step p) 3))))
124 (define (glue-word-to-step word x)
127 (make-simple-markup word)
131 (define (suffix-modifier->markup mod)
132 (if (or (= 4 (pitch-step mod))
133 (= 2 (pitch-step mod)))
134 (glue-word-to-step "sus" mod)
135 (glue-word-to-step "huh" mod)
138 (define (prefix-modifier->markup mod)
139 (if (and (= 3 (pitch-step mod))
140 (= -1 (ly:pitch-alteration mod)))
141 (make-simple-markup "m")
142 (make-simple-markup "huh")
145 (define (filter-alterations alters)
146 "Filter out uninteresting (natural) pitches from ALTERS."
149 (not (is-natural-alteration? p)))
156 (l (filter-list altered? alters))
157 (lp (last-pair alters))
160 ;; we want the highest also if unaltered
161 (if (and (not (altered? (car lp)))
162 (> (pitch-step (car lp)) 5))
163 (append l (last-pair alters))
167 (define (name-step pitch)
168 (define (step-alteration pitch)
169 (- (ly:pitch-alteration pitch)
170 (natural-chord-alteration pitch)
175 (num-markup (make-simple-markup
176 (number->string (pitch-step pitch))))
177 (args (list num-markup))
178 (total (if (= (ly:pitch-alteration pitch) 0)
179 (if (= (pitch-step pitch) 7)
180 (list (ly:get-context-property context 'majorSevenSymbol))
182 (cons (accidental->markup (step-alteration pitch)) args)
186 (make-line-markup total)))
190 (sep (ly:get-context-property context 'chordNameSeparator))
191 (root-markup (name-root root))
192 (add-markups (map (lambda (x)
193 (glue-word-to-step "add" x))
195 (filtered-alterations (filter-alterations alteration-pitches))
196 (alterations (map name-step filtered-alterations))
197 (suffixes (map suffix-modifier->markup suffix-modifiers))
198 (prefixes (map prefix-modifier->markup prefix-modifiers))
199 (main-markups (filter-main-name main-name))
200 (to-be-raised-stuff (markup-join
206 (base-stuff (if bass-pitch
207 (list sep (name-note bass-pitch))
214 (markup-join prefixes sep)
215 (make-super-markup to-be-raised-stuff))
217 (make-line-markup base-stuff)
223 (root (car in-pitches))
224 (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
225 (exceptions (ly:get-context-property context 'chordNameExceptions))
226 (exception (assoc-get-default pitches exceptions #f))
238 (list (name-root root) exception))
240 (begin ; no exception.
242 ; handle sus4 and sus2 suffix: if there is a 3 together with
243 ; sus2 or sus4, then we explicitly say add3.
246 (if (get-step j pitches)
248 (if (get-step 3 pitches)
250 (set! add-steps (cons (get-step 3 pitches) add-steps))
251 (set! pitches (remove-step 3 pitches))
253 (set! suffixes (cons (get-step j pitches) suffixes))
258 ;; do minor-3rd modifier.
259 (if (and (get-step 3 pitches)
260 (= (ly:pitch-alteration (get-step 3 pitches)) -1))
261 (set! prefixes (cons (get-step 3 pitches) prefixes))
264 ;; lazy bum. Should write loop.
266 ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
267 ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
268 ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
269 ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
270 ((get-step 3 pitches) (set! main-name (get-step 3 pitches)))
275 (3-diff? (lambda (x y)
276 (= (- (pitch-step y) (pitch-step x)) 2)))
277 (split (split-at 3-diff? (remove-uptil-step 5 pitches)))
279 (set! alterations (append alterations (car split)))
280 (set! add-steps (append add-steps (cdr split)))
281 (set! alterations (delq main-name alterations))
282 (set! add-steps (delq main-name add-steps))
284 (if (ly:pitch? inversion)
285 (set! bass-note inversion)
289 (set! bass-note bass)
292 ;; chords with natural (5 7 9 11 13) or leading subsequence.
293 ;; etc. are named by the top pitch, without any further
296 (ly:pitch? main-name)
297 (= 7 (pitch-step main-name))
298 (is-natural-alteration? main-name)
299 (pair? (remove-uptil-step 7 alterations))
300 (reduce (lambda (x y) (and x y))
301 (map is-natural-alteration? alterations)))
303 (set! main-name (tail alterations))
304 (set! alterations '())
307 (ignatzek-format-chord-name root prefixes main-name alterations add-steps suffixes bass-note)