1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2000--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25 ;; after Klaus Ignatzek, Die Jazzmethode fuer Klavier 1.
27 ;; The idea is: split chords into
29 ;; ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS
31 ;; and put that through a layout routine.
33 ;; the split is a procedural process, with lots of set!.
37 ;; todo: naming is confusing: steps (0 based) vs. steps (1 based).
38 (define (pitch-step p)
39 "Musicological notation for an interval. Eg. C to D is 2."
40 (+ 1 (ly:pitch-steps p)))
42 (define (get-step x ps)
43 "Does PS have the X step? Return that step if it does."
46 (if (= (- x 1) (ly:pitch-steps (car ps)))
48 (get-step x (cdr ps)))))
50 (define (replace-step p ps)
51 "Copy PS, but replace the step of P in PS."
54 (let* ((t (replace-step p (cdr ps))))
55 (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
59 (define (remove-step x ps)
60 "Copy PS, but leave out the Xth step."
63 (let* ((t (remove-step x (cdr ps))))
64 (if (= (- x 1) (ly:pitch-steps (car ps)))
69 (define-public (ignatzek-chord-names
70 in-pitches bass inversion
73 (define (remove-uptil-step x ps)
74 "Copy PS, but leave out everything below the Xth step."
77 (if (< (ly:pitch-steps (car ps)) (- x 1))
78 (remove-uptil-step x (cdr ps))
81 (define name-root (ly:context-property context 'chordRootNamer))
83 (let ((nn (ly:context-property context 'chordNoteNamer)))
85 ;; replacing the next line with name-root gives guile-error...? -rz
87 ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
88 (ly:context-property context 'chordRootNamer)
92 (define (is-natural-alteration? p)
93 (= (natural-chord-alteration p) (ly:pitch-alteration p)))
95 (define (ignatzek-format-chord-name
105 "Format for the given (lists of) pitches. This is actually more
106 work than classifying the pitches."
108 (define (filter-main-name p)
109 "The main name: don't print anything for natural 5 or 3."
111 (or (not (ly:pitch? p))
112 (and (is-natural-alteration? p)
113 (or (= (pitch-step p) 5)
114 (= (pitch-step p) 3))))
116 (list (name-step p))))
118 (define (glue-word-to-step word x)
121 (make-simple-markup word)
124 (define (suffix-modifier->markup mod)
125 (if (or (= 4 (pitch-step mod))
126 (= 2 (pitch-step mod)))
127 (glue-word-to-step "sus" mod)
128 (glue-word-to-step "huh" mod)))
130 (define (prefix-modifier->markup mod)
131 (if (and (= 3 (pitch-step mod))
132 (= FLAT (ly:pitch-alteration mod)))
135 (ly:context-property context 'minorChordModifier))
136 (make-simple-markup "huh")))
138 (define (filter-alterations alters)
139 "Filter out uninteresting (natural) pitches from ALTERS."
142 (not (is-natural-alteration? p)))
147 (let* ((lst (filter altered? alters))
148 (lp (last-pair alters)))
150 ;; we want the highest also if unaltered
151 (if (and (not (altered? (car lp)))
152 (> (pitch-step (car lp)) 5))
153 (append lst (last-pair alters))
156 (define (name-step pitch)
157 (define (step-alteration pitch)
158 (- (ly:pitch-alteration pitch)
159 (natural-chord-alteration pitch)))
161 (let* ((num-markup (make-simple-markup
162 (number->string (pitch-step pitch))))
163 (args (list num-markup))
164 (major-seven-symbol (ly:context-property context 'majorSevenSymbol))
166 (if (and (= (ly:pitch-alteration pitch) 0)
167 (= (pitch-step pitch) 7)
168 (markup? major-seven-symbol))
169 (list major-seven-symbol)
170 (cons (accidental->markup (step-alteration pitch)) args))))
172 (make-line-markup total)))
174 (let* ((sep (ly:context-property context 'chordNameSeparator))
175 (slashsep (ly:context-property context 'slashChordSeparator))
176 (root-markup (name-root root lowercase-root?))
177 (add-pitch-prefix (ly:context-property context 'additionalPitchPrefix))
178 (add-markups (map (lambda (x) (glue-word-to-step add-pitch-prefix x))
180 (filtered-alterations (filter-alterations alteration-pitches))
181 (alterations (map name-step filtered-alterations))
182 (suffixes (map suffix-modifier->markup suffix-modifiers))
183 (prefixes (map prefix-modifier->markup prefix-modifiers))
184 (main-markups (filter-main-name main-name))
185 (to-be-raised-stuff (markup-join
191 (base-stuff (if (ly:pitch? bass-pitch)
192 (list slashsep (name-note bass-pitch #f))
198 (conditional-kern-before (markup-join prefixes sep)
199 (and (not (null? prefixes))
200 (= (ly:pitch-alteration root) NATURAL))
201 (ly:context-property context 'chordPrefixSpacer))
202 (make-super-markup to-be-raised-stuff))
204 (make-line-markup base-stuff)))
206 (define (ignatzek-format-exception
214 ,(name-root root lowercase-root?)
217 ,(if (ly:pitch? bass-pitch)
218 (list (ly:context-property context 'slashChordSeparator)
219 (name-note bass-pitch #f))
222 (let* ((root (car in-pitches))
223 (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
225 (and (ly:context-property context 'chordNameLowercaseMinor)
226 (let ((third (get-step 3 pitches)))
227 (and third (= (ly:pitch-alteration third) FLAT)))))
228 (exceptions (ly:context-property context 'chordNameExceptions))
229 (exception (assoc-get pitches exceptions))
235 (if (ly:pitch? inversion)
241 (ignatzek-format-exception root exception bass-note lowercase-root?)
245 ;; handle sus4 and sus2 suffix: if there is a 3 together with
246 ;; sus2 or sus4, then we explicitly say add3.
249 (if (get-step j pitches)
251 (if (get-step 3 pitches)
253 (set! add-steps (cons (get-step 3 pitches) add-steps))
254 (set! pitches (remove-step 3 pitches))))
255 (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)) FLAT))
261 (set! prefixes (cons (get-step 3 pitches) prefixes)))
263 ;; lazy bum. Should write loop.
265 ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
266 ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
267 ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
268 ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
269 ((get-step 3 pitches) (set! main-name (get-step 3 pitches))))
271 (let* ((3-diff? (lambda (x y)
272 (= (- (pitch-step y) (pitch-step x)) 2)))
273 (split (split-at-predicate
274 3-diff? (remove-uptil-step 5 pitches))))
275 (set! alterations (append alterations (car split)))
276 (set! add-steps (append add-steps (cdr split)))
277 (set! alterations (delq main-name alterations))
278 (set! add-steps (delq main-name add-steps))
281 ;; chords with natural (5 7 9 11 13) or leading subsequence.
282 ;; etc. are named by the top pitch, without any further
285 (ly:pitch? main-name)
286 (= 7 (pitch-step main-name))
287 (is-natural-alteration? main-name)
288 (pair? (remove-uptil-step 7 alterations))
289 (every is-natural-alteration? alterations))
291 (set! main-name (last alterations))
292 (set! alterations '())))
294 (ignatzek-format-chord-name
295 root prefixes main-name alterations add-steps suffixes bass-note
296 lowercase-root?))))))