1 ;;;; double-plus-new-chord-name.scm -- Compile chord names
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2003 Jan Nieuwenhuizen <janneke@gnu.org>
7 ;;;; NOTE: this is experimental code
8 ;;;; Base and inversion are ignored.
9 ;;;; Naming of the base chord (steps 1-5) is handled by exceptions only
10 ;;;; see input/test/chord-names-dpnj.ly
12 (define (markup-or-empty-markup markup)
13 "Return MARKUP if markup, else empty-markup"
14 (if (markup? markup) markup empty-markup))
16 (define (conditional-kern-before markup bool amount)
17 "Add AMOUNT of space before MARKUP if BOOL is true."
20 (list (make-hspace-markup amount)
25 (define-public (double-plus-new-chord->markup-banter . args)
26 (apply double-plus-new-chord->markup (cons 'banter args)))
28 (define-public (double-plus-new-chord->markup-jazz . args)
29 (apply double-plus-new-chord->markup (cons 'jazz args)))
31 ;; FIXME: if/when double-plus-new-chord->markup get installed
32 ;; setting and calling can be done a bit handier.
33 (define-public (double-plus-new-chord->markup
34 func pitches bass inversion
36 "Entry point for New_chord_name_engraver. See
37 double-plus-new-chord-name.scm for the signature of FUNC. PITCHES,
38 BASS and INVERSION are lily pitches. OPTIONS is an alist-alist (see
39 input/test/dpncnt.ly).
41 (define options (ly:get-context-property context 'chordNameExceptions))
43 (define (step-nr pitch)
44 (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch))
45 (ly:pitch-notename pitch)))
46 (root-nr (+ (* 7 (ly:pitch-octave (car pitches)))
47 (ly:pitch-notename (car pitches)))))
48 (+ 1 (- pitch-nr root-nr))))
50 (define (next-third pitch)
51 (ly:pitch-transpose pitch
52 (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
53 (= (step-nr pitch) 5))
56 (define (step-alteration pitch)
57 (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches)))
58 (normalized-pitch (ly:pitch-transpose pitch diff))
59 (alteration (ly:pitch-alteration normalized-pitch)))
60 (if (= (step-nr pitch) 7) (+ alteration 1) alteration)))
62 (define (pitch-unalter pitch)
63 (let ((alteration (step-alteration pitch)))
66 (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
67 (- (ly:pitch-alteration pitch) alteration)))))
69 (define (step-even-or-altered? pitch)
70 (let ((nr (step-nr pitch)))
71 (if (!= (modulo nr 2) 0)
72 (!= (step-alteration pitch) 0)
75 (define (step->markup-plusminus pitch)
78 (make-simple-markup (number->string (step-nr pitch)))
80 (case (step-alteration pitch)
87 (define (step->markup-accidental pitch)
90 (accidental->markup (step-alteration pitch))
91 (make-simple-markup (number->string (step-nr pitch))))))
94 (define (make-sub->markup step->markup)
96 (make-line-markup (list (make-simple-markup "no")
97 (step->markup pitch)))))
99 (define (step-based-sub->markup step->markup pitch)
100 (make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
102 (define (get-full-list pitch)
103 (if (<= (step-nr pitch) (step-nr (tail pitches)))
104 (cons pitch (get-full-list (next-third pitch)))
107 (define (get-consecutive nr pitches)
109 (let* ((pitch-nr (step-nr (car pitches)))
110 (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
112 (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
116 (define (full-match exceptions)
117 (if (pair? exceptions)
118 (let* ((e (car exceptions))
120 (if (equal? e-pitches pitches)
122 (full-match (cdr exceptions))))
125 (define (partial-match exceptions)
126 (if (pair? exceptions)
127 (let* ((e (car exceptions))
129 (if (equal? e-pitches (first-n (length e-pitches) pitches))
131 (partial-match (cdr exceptions))))
135 (write-me "options: " options)
136 (write-me "pitches: " pitches)))
137 (let* ((full-exceptions (assoc-get 'full-exceptions options))
138 (full-exception (full-match full-exceptions))
139 (full-markup (cdr full-exception))
141 (partial-exceptions (assoc-get 'partial-exceptions options))
142 (partial-exception (partial-match partial-exceptions))
143 (partial-pitches (car partial-exception))
144 (partial-markup (markup-or-empty-markup (cdr partial-exception)))
147 (full (get-full-list root))
148 ;; kludge alert: replace partial matched lower part of all with
149 ;; 'normal' pitches from full
151 (all (append (first-n (length partial-pitches) full)
152 (butfirst-n (length partial-pitches) pitches)))
155 (missing (list-minus full (map pitch-unalter all)))
156 (consecutive (get-consecutive 1 all))
157 (rest (list-minus all consecutive))
158 (altered (filter-list step-even-or-altered? all))
159 (cons-alt (filter-list step-even-or-altered? consecutive))
160 (base (list-minus consecutive altered)))
164 (write-me "full:" full)
165 ;; (write-me "partial-pitches:" partial-pitches)
166 (write-me "full-markup:" full-markup)
167 (write-me "partial-markup:" partial-markup)
168 (write-me "all:" all)
169 (write-me "altered:" altered)
170 (write-me "missing:" missing)
171 (write-me "consecutive:" consecutive)
172 (write-me "rest:" rest)
173 (write-me "base:" base)))
178 ;; + steps:altered + (highest all -- if not altered)
181 (let* ((root->markup (assoc-get-default
182 'root->markup options pitch->markup))
183 (step->markup (assoc-get-default
184 'step->markup options step->markup-plusminus))
185 (sub->markup (assoc-get-default
188 (step-based-sub->markup step->markup x))))
189 (sep (assoc-get-default
190 'separator options (make-simple-markup "/"))))
194 (make-line-markup (list (root->markup root) full-markup))
200 (make-normal-size-super-markup
205 (if (and (> (step-nr highest) 5)
207 (step-even-or-altered? highest)))
208 (list highest) '())))
210 (list (map sub->markup missing)))
216 ;; + steps:(highest base) + cons-alt
219 (let* ((root->markup (assoc-get-default
220 'root->markup options pitch->markup))
221 (step->markup (assoc-get-default
222 'step->markup options step->markup-accidental))
223 (sep (assoc-get-default
224 'separator options (make-simple-markup " ")))
225 (add-prefix (assoc-get-default 'add-prefix options
226 (make-simple-markup " add"))))
230 (make-line-markup (list (root->markup root) full-markup))
236 (make-normal-size-super-markup
240 ;; kludge alert: omit <= 5
241 ;;(markup-join (map step->markup
242 ;; (cons (tail base) cons-alt)) sep)
248 ;; c:6.9 C5 6add9 -> C6 add 9 (add?)
249 ;; ch = \chords { c c:2 c:3- c:6.9^7 }
250 (markup-join (map step->markup
251 (let ((tb (tail base)))
252 (if (> (step-nr tb) 5)
259 (markup-join (map step->markup rest) sep)))))))))
261 (else empty-markup))))