]> git.donarmstrong.com Git - lilypond.git/blob - scm/chord-generic-names.scm
Third phase of tutorial rewrite.
[lilypond.git] / scm / chord-generic-names.scm
1 ;;;; chord-generic-names.scm -- Compile chord names
2 ;;;;
3 ;;;;  source file of the GNU LilyPond music typesetter
4 ;;;;
5 ;;;; (c) 2003--2006 Jan Nieuwenhuizen <janneke@gnu.org>
6
7
8 ;;;; NOTE: this is experimental code
9 ;;;; Base and inversion are ignored.
10 ;;;; Naming of the base chord (steps 1-5) is handled by exceptions only
11 ;;;; see input/test/chord-names-dpnj.ly
12
13 (define (markup-or-empty-markup markup)
14   "Return MARKUP if markup, else empty-markup"
15   (if (markup? markup) markup empty-markup))
16
17 (define (conditional-kern-before markup bool amount)
18   "Add AMOUNT of space before MARKUP if BOOL is true."
19   (if bool
20       (make-line-markup
21        (list (make-hspace-markup amount)
22              markup))
23       markup))
24
25 (define-public (banter-chord-names pitches bass inversion context)
26   (ugh-compat-double-plus-new-chord->markup
27    'banter pitches bass inversion context '()))
28
29 (define-public (jazz-chord-names pitches bass inversion context)
30   (ugh-compat-double-plus-new-chord->markup
31    'jazz pitches bass inversion context '()))
32
33 (define-public (ugh-compat-double-plus-new-chord->markup
34                 style pitches bass inversion context options)
35   "Entry point for New_chord_name_engraver.
36
37 FIXME: func, options/context have changed
38  See
39 double-plus-new-chord-name.scm for the signature of STYLE.  PITCHES,
40 BASS and INVERSION are lily pitches.  OPTIONS is an alist-alist (see
41 input/test/dpncnt.ly).
42  "
43
44   (define (step-nr pitch)
45     (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch))
46                         (ly:pitch-notename pitch)))
47            (root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
48                         (ly:pitch-notename (car pitches)))))
49       (+ 1 (- pitch-nr root-nr))))
50
51   (define (next-third pitch)
52     (ly:pitch-transpose pitch
53                         (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
54                                                    (= (step-nr pitch) 5))
55                                                FLAT 0))))
56
57   (define (step-alteration pitch)
58     (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches)))
59            (normalized-pitch (ly:pitch-transpose pitch diff))
60            (alteration (ly:pitch-alteration normalized-pitch)))
61       (if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration)))
62
63   (define (pitch-unalter pitch)
64     (let ((alteration (step-alteration pitch)))
65       (if (= alteration 0)
66           pitch
67           (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
68                          (- (ly:pitch-alteration pitch) alteration)))))
69
70   (define (step-even-or-altered? pitch)
71     (let ((nr (step-nr pitch)))
72       (if (!= (modulo nr 2) 0)
73           (!= (step-alteration pitch) 0)
74           #t)))
75
76   (define (step->markup-plusminus pitch)
77     (make-line-markup
78      (list
79       (make-simple-markup (number->string (step-nr pitch)))
80       (make-simple-markup
81        (case (step-alteration pitch)
82          ((DOUBLE-FLAT) "--")
83          ((FLAT) "-")
84          ((NATURAL) "")
85          ((SHARP) "+")
86          ((DOUBLE-SHARP) "++"))))))
87
88   (define (step->markup-accidental pitch)
89     (make-line-markup
90      (list (accidental->markup (step-alteration pitch))
91            (make-simple-markup (number->string (step-nr pitch))))))
92
93   (define (step->markup-ignatzek pitch)
94     (make-line-markup
95      (if (and (= (step-nr pitch) 7)
96               (= (step-alteration pitch) 1))
97          (list (ly:context-property context 'majorSevenSymbol))
98          (list (accidental->markup (step-alteration pitch))
99                (make-simple-markup (number->string (step-nr pitch)))))))
100         
101   ;; tja, kennok
102   (define (make-sub->markup step->markup)
103     (lambda (pitch)
104       (make-line-markup (list (make-simple-markup "no")
105                               (step->markup pitch)))))
106                         
107   (define (step-based-sub->markup step->markup pitch)
108     (make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
109                         
110   (define (get-full-list pitch)
111     (if (<= (step-nr pitch) (step-nr (last pitches)))
112         (cons pitch (get-full-list (next-third pitch)))
113         '()))
114
115   (define (get-consecutive nr pitches)
116     (if (pair? pitches)
117         (let* ((pitch-nr (step-nr (car pitches)))
118                (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
119           (if (<= pitch-nr nr)
120               (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
121               '()))
122         '()))
123
124   (define (full-match exceptions)
125     (if (pair? exceptions)
126         (let* ((e (car exceptions))
127                (e-pitches (car e)))
128           (if (equal? e-pitches pitches)
129               e
130               (full-match (cdr exceptions))))
131         #f))
132
133   (define (partial-match exceptions)
134     (if (pair? exceptions)
135         (let* ((e (car exceptions))
136                (e-pitches (car e)))
137           (if (equal? e-pitches (take pitches (length e-pitches)))
138               e
139               (partial-match (cdr exceptions))))
140         #f))
141
142   (if #f (begin
143            (write-me "pitches: " pitches)))
144   (let* ((full-exceptions
145           (ly:context-property context 'chordNameExceptionsFull))
146          (full-exception (full-match full-exceptions))
147          (full-markup (if full-exception (cadr full-exception) '()))
148          (partial-exceptions
149           (ly:context-property context 'chordNameExceptionsPartial))
150          (partial-exception (partial-match partial-exceptions))
151          (partial-pitches (if partial-exception (car partial-exception) '()))
152          (partial-markup-prefix
153           (if partial-exception (markup-or-empty-markup
154                                  (cadr partial-exception)) empty-markup))
155          (partial-markup-suffix
156           (if (and partial-exception (pair? (cddr partial-exception)))
157               (markup-or-empty-markup (caddr partial-exception)) empty-markup))
158          (root (car pitches))
159          (full (get-full-list root))
160          ;; kludge alert: replace partial matched lower part of all with
161          ;; 'normal' pitches from full
162          ;; (all pitches)
163          (all (append (take full (length partial-pitches))
164                       (drop pitches (length partial-pitches))))
165         
166          (highest (last all))
167          (missing (list-minus full (map pitch-unalter all)))
168          (consecutive (get-consecutive 1 all))
169          (rest (list-minus all consecutive))
170          (altered (filter step-even-or-altered? all))
171          (cons-alt (filter step-even-or-altered? consecutive))
172          (base (list-minus consecutive altered)))
173         
174
175     (if #f (begin
176              (write-me "full:" full)
177               ;; (write-me "partial-pitches:" partial-pitches)
178               (write-me "full-markup:" full-markup)
179               (write-me "partial-markup-perfix:" partial-markup-prefix)
180               (write-me "partial-markup-suffix:" partial-markup-suffix)
181               (write-me "all:" all)
182               (write-me "altered:" altered)
183               (write-me "missing:" missing)
184               (write-me "consecutive:" consecutive)
185               (write-me "rest:" rest)
186               (write-me "base:" base)))
187
188     (case style
189       ((banter)
190        ;;    root
191        ;;    + steps:altered + (highest all -- if not altered)
192        ;;    + subs:missing
193
194        (let* ((root->markup (assoc-get
195                               'root->markup options note-name->markup))
196               (step->markup (assoc-get
197                              'step->markup options step->markup-plusminus))
198               (sub->markup (assoc-get
199                             'sub->markup options
200                             (lambda (x)
201                               (step-based-sub->markup step->markup x))))
202               (sep (assoc-get
203                     'separator options (make-simple-markup "/"))))
204         
205          (if
206           (pair? full-markup)
207           (make-line-markup (list (root->markup root) full-markup))
208         
209           (make-line-markup
210            (list
211             (root->markup root)
212             partial-markup-prefix
213             (make-normal-size-super-markup
214              (markup-join
215               (apply append
216                      (map step->markup
217                           (append altered
218                                   (if (and (> (step-nr highest) 5)
219                                            (not
220                                             (step-even-or-altered? highest)))
221                                       (list highest) '())))
222                       (list partial-markup-suffix)
223                      (list (map sub->markup missing)))
224               sep)))))))
225
226
227       ((jazz)
228        ;;    root
229        ;;    + steps:(highest base) + cons-alt
230        ;;    + 'add'
231        ;;    + steps:rest
232        (let* ((root->markup (assoc-get
233                               'root->markup options note-name->markup))
234               (step->markup
235                (assoc-get
236                 ;; FIXME: ignatzek
237                 ;;'step->markup options step->markup-accidental))
238                 'step->markup options step->markup-ignatzek))
239               (sep (assoc-get
240                     'separator options (make-simple-markup " ")))
241               (add-prefix (assoc-get 'add-prefix options
242                                              (make-simple-markup " add"))))
243         
244          (if
245           (pair? full-markup)
246           (make-line-markup (list (root->markup root) full-markup))
247         
248           (make-line-markup
249            (list
250             (root->markup root)
251             partial-markup-prefix
252             (make-normal-size-super-markup
253              (make-line-markup
254               (list
255         
256                ;; kludge alert: omit <= 5
257                ;;(markup-join (map step->markup
258                ;;                        (cons (last base) cons-alt)) sep)
259         
260                ;; This fixes:
261                ;;  c     C5       -> C
262                ;;  c:2   C5 2     -> C2
263                ;;  c:3-  Cm5      -> Cm
264                ;;  c:6.9 C5 6add9 -> C6 add 9 (add?)
265                ;;  ch = \chords { c c:2 c:3- c:6.9^7 }
266                (markup-join (map step->markup
267                                  (let ((tb (last base)))
268                                    (if (> (step-nr tb) 5)
269                                        (cons tb cons-alt)
270                                        cons-alt))) sep)
271         
272                (if (pair? rest)
273                    add-prefix
274                    empty-markup)
275                (markup-join (map step->markup rest) sep)
276                partial-markup-suffix))))))))
277
278        (else empty-markup))))