1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2003--2010 Jan Nieuwenhuizen <janneke@gnu.org>
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/>.
19 ;;;; NOTE: this is experimental code
20 ;;;; Base and inversion are ignored.
21 ;;;; Naming of the base chord (steps 1-5) is handled by exceptions only
22 ;;;; see input/test/chord-names-dpnj.ly
25 (define (default-note-namer pitch)
26 (note-name->markup pitch #f))
28 (define (markup-or-empty-markup markup)
29 "Return MARKUP if markup, else empty-markup"
30 (if (markup? markup) markup empty-markup))
32 (define (conditional-kern-before markup bool amount)
33 "Add AMOUNT of space before MARKUP if BOOL is true."
36 (list (make-hspace-markup amount)
40 (define-public (banter-chord-names pitches bass inversion context)
41 (ugh-compat-double-plus-new-chord->markup
42 'banter pitches bass inversion context '()))
44 (define-public (jazz-chord-names pitches bass inversion context)
45 (ugh-compat-double-plus-new-chord->markup
46 'jazz pitches bass inversion context '()))
48 (define-public (ugh-compat-double-plus-new-chord->markup
49 style pitches bass inversion context options)
50 "Entry point for New_chord_name_engraver.
52 FIXME: func, options/context have changed
54 double-plus-new-chord-name.scm for the signature of STYLE. PITCHES,
55 BASS and INVERSION are lily pitches. OPTIONS is an alist-alist (see
56 input/test/dpncnt.ly).
59 (define (step-nr pitch)
60 (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch))
61 (ly:pitch-notename pitch)))
62 (root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
63 (ly:pitch-notename (car pitches)))))
64 (+ 1 (- pitch-nr root-nr))))
66 (define (next-third pitch)
67 (ly:pitch-transpose pitch
68 (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
69 (= (step-nr pitch) 5))
72 (define (step-alteration pitch)
73 (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches)))
74 (normalized-pitch (ly:pitch-transpose pitch diff))
75 (alteration (ly:pitch-alteration normalized-pitch)))
76 (if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration)))
78 (define (pitch-unalter pitch)
79 (let ((alteration (step-alteration pitch)))
82 (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
83 (- (ly:pitch-alteration pitch) alteration)))))
85 (define (step-even-or-altered? pitch)
86 (let ((nr (step-nr pitch)))
87 (if (!= (modulo nr 2) 0)
88 (!= (step-alteration pitch) 0)
91 (define (step->markup-plusminus pitch)
94 (make-simple-markup (number->string (step-nr pitch)))
96 (case (step-alteration pitch)
101 ((DOUBLE-SHARP) "++"))))))
103 (define (step->markup-accidental pitch)
105 (list (accidental->markup (step-alteration pitch))
106 (make-simple-markup (number->string (step-nr pitch))))))
108 (define (step->markup-ignatzek pitch)
110 (if (and (= (step-nr pitch) 7)
111 (= (step-alteration pitch) 1))
112 (list (ly:context-property context 'majorSevenSymbol))
113 (list (accidental->markup (step-alteration pitch))
114 (make-simple-markup (number->string (step-nr pitch)))))))
117 (define (make-sub->markup step->markup)
119 (make-line-markup (list (make-simple-markup "no")
120 (step->markup pitch)))))
122 (define (step-based-sub->markup step->markup pitch)
123 (make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
125 (define (get-full-list pitch)
126 (if (<= (step-nr pitch) (step-nr (last pitches)))
127 (cons pitch (get-full-list (next-third pitch)))
130 (define (get-consecutive nr pitches)
132 (let* ((pitch-nr (step-nr (car pitches)))
133 (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
135 (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
139 (define (full-match exceptions)
140 (if (pair? exceptions)
141 (let* ((e (car exceptions))
143 (if (equal? e-pitches pitches)
145 (full-match (cdr exceptions))))
148 (define (partial-match exceptions)
149 (if (pair? exceptions)
150 (let* ((e (car exceptions))
152 (if (equal? e-pitches (take pitches (length e-pitches)))
154 (partial-match (cdr exceptions))))
158 (write-me "pitches: " pitches)))
159 (let* ((full-exceptions
160 (ly:context-property context 'chordNameExceptionsFull))
161 (full-exception (full-match full-exceptions))
162 (full-markup (if full-exception (cadr full-exception) '()))
164 (ly:context-property context 'chordNameExceptionsPartial))
165 (partial-exception (partial-match partial-exceptions))
166 (partial-pitches (if partial-exception (car partial-exception) '()))
167 (partial-markup-prefix
168 (if partial-exception (markup-or-empty-markup
169 (cadr partial-exception)) empty-markup))
170 (partial-markup-suffix
171 (if (and partial-exception (pair? (cddr partial-exception)))
172 (markup-or-empty-markup (caddr partial-exception)) empty-markup))
174 (full (get-full-list root))
175 ;; kludge alert: replace partial matched lower part of all with
176 ;; 'normal' pitches from full
178 (all (append (take full (length partial-pitches))
179 (drop pitches (length partial-pitches))))
182 (missing (list-minus full (map pitch-unalter all)))
183 (consecutive (get-consecutive 1 all))
184 (rest (list-minus all consecutive))
185 (altered (filter step-even-or-altered? all))
186 (cons-alt (filter step-even-or-altered? consecutive))
187 (base (list-minus consecutive altered)))
191 (write-me "full:" full)
192 ;; (write-me "partial-pitches:" partial-pitches)
193 (write-me "full-markup:" full-markup)
194 (write-me "partial-markup-perfix:" partial-markup-prefix)
195 (write-me "partial-markup-suffix:" partial-markup-suffix)
196 (write-me "all:" all)
197 (write-me "altered:" altered)
198 (write-me "missing:" missing)
199 (write-me "consecutive:" consecutive)
200 (write-me "rest:" rest)
201 (write-me "base:" base)))
206 ;; + steps:altered + (highest all -- if not altered)
209 (let* ((root->markup (assoc-get
210 'root->markup options default-note-namer))
211 (step->markup (assoc-get
212 'step->markup options step->markup-plusminus))
213 (sub->markup (assoc-get
216 (step-based-sub->markup step->markup x))))
218 'separator options (make-simple-markup "/"))))
222 (make-line-markup (list (root->markup root) full-markup))
227 partial-markup-prefix
228 (make-normal-size-super-markup
233 (if (and (> (step-nr highest) 5)
235 (step-even-or-altered? highest)))
236 (list highest) '())))
237 (list partial-markup-suffix)
238 (list (map sub->markup missing)))
244 ;; + steps:(highest base) + cons-alt
247 (let* ((root->markup (assoc-get
248 'root->markup options default-note-namer))
252 ;;'step->markup options step->markup-accidental))
253 'step->markup options step->markup-ignatzek))
255 'separator options (make-simple-markup " ")))
256 (add-prefix (assoc-get 'add-prefix options
257 (make-simple-markup " add"))))
261 (make-line-markup (list (root->markup root) full-markup))
266 partial-markup-prefix
267 (make-normal-size-super-markup
271 ;; kludge alert: omit <= 5
272 ;;(markup-join (map step->markup
273 ;; (cons (last base) cons-alt)) sep)
279 ;; c:6.9 C5 6add9 -> C6 add 9 (add?)
280 ;; ch = \chords { c c:2 c:3- c:6.9^7 }
281 (markup-join (map step->markup
282 (let ((tb (last base)))
283 (if (> (step-nr tb) 5)
290 (markup-join (map step->markup rest) sep)
291 partial-markup-suffix))))))))
293 (else empty-markup))))