Left: | ||
Right: |
LEFT | RIGHT |
---|---|
1 ;;;; This file is part of LilyPond, the GNU music typesetter. | 1 ;;;; This file is part of LilyPond, the GNU music typesetter. |
2 ;;;; | 2 ;;;; |
3 ;;;; Copyright (C) 2004--2015 Han-Wen Nienhuys <hanwen@xs4all.nl> | 3 ;;;; Copyright (C) 2004--2015 Han-Wen Nienhuys <hanwen@xs4all.nl> |
4 ;;;; | 4 ;;;; |
5 ;;;; LilyPond is free software: you can redistribute it and/or modify | 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 | 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 | 7 ;;;; the Free Software Foundation, either version 3 of the License, or |
8 ;;;; (at your option) any later version. | 8 ;;;; (at your option) any later version. |
9 ;;;; | 9 ;;;; |
10 ;;;; LilyPond is distributed in the hope that it will be useful, | 10 ;;;; LilyPond is distributed in the hope that it will be useful, |
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | 11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
13 ;;;; GNU General Public License for more details. | 13 ;;;; GNU General Public License for more details. |
14 ;;;; | 14 ;;;; |
15 ;;;; You should have received a copy of the GNU General Public License | 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/>. | 16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>. |
17 | 17 |
18 ;; for define-safe-public when byte-compiling using Guile V2 | 18 ;; for define-safe-public when byte-compiling using Guile V2 |
19 (use-modules (scm safe-utility-defs) (ice-9 receive)) | 19 (use-modules (scm safe-utility-defs) (ice-9 receive)) |
20 | 20 |
21 (define-session-public chordmodifiers '()) | 21 (define-session-public chordmodifiers '()) |
22 | 22 |
23 | 23 |
pwm
2018/11/10 05:44:22
Unnecessary new line.
| |
24 (define-public (construct-chord-elements root duration modifications) | 24 (define-public (construct-chord-elements root duration modifications) |
25 "Build a chord on root using modifiers in @var{modifications}. | 25 "Build a chord on root using modifiers in @var{modifications}. |
26 @code{NoteEvents} have duration @var{duration}. | 26 @code{NoteEvents} have duration @var{duration}. |
27 | 27 |
28 Notes: Natural 11 is left from chord if not explicitly specified. | 28 Notes: Natural 11 is left from chord if not explicitly specified. |
29 | 29 |
30 Entry point for the parser." | 30 Entry point for the parser." |
31 (let* ((flat-mods (flatten-list modifications)) | 31 (let* ((flat-mods (flatten-list modifications)) |
32 (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord)) | 32 (base-chord (stack-thirds (ly:make-pitch 0 4 0) the-canonical-chord)) |
33 (complete-chord '()) | 33 (complete-chord '()) |
(...skipping 31 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... | |
65 | 65 |
66 (define (interpret-removals chord-entries mods chord-semantics) | 66 (define (interpret-removals chord-entries mods chord-semantics) |
67 (define (inner-interpret chord-entries mods chord-semantics) | 67 (define (inner-interpret chord-entries mods chord-semantics) |
68 (if (and (pair? mods) (ly:pitch? (car mods))) | 68 (if (and (pair? mods) (ly:pitch? (car mods))) |
69 (begin (update-chord-semantics chord-semantics | 69 (begin (update-chord-semantics chord-semantics |
70 'removals | 70 'removals |
71 (cons (car mods) | 71 (cons (car mods) |
72 (get-chord-semantics chord-sema ntics 'removals))) | 72 (get-chord-semantics chord-sema ntics 'removals))) |
73 (inner-interpret (remove-step-chord-entries (+ 1 (ly:pitch-s teps (car mods))) chord-entries) | 73 (inner-interpret (remove-step-chord-entries (+ 1 (ly:pitch-s teps (car mods))) chord-entries) |
74 (cdr mods) | 74 (cdr mods) |
75 chord-semantics)) | 75 chord-semantics)) |
pwm
2018/11/10 05:44:22
It's hard to read this code because of the way it'
| |
76 (interpret-inversion chord-entries mods chord-semantics))) | 76 (interpret-inversion chord-entries mods chord-semantics))) |
77 (if (and (pair? mods) (eq? (car mods) 'chord-caret)) | 77 (if (and (pair? mods) (eq? (car mods) 'chord-caret)) |
78 (inner-interpret chord-entries (cdr mods) chord-semantics) | 78 (inner-interpret chord-entries (cdr mods) chord-semantics) |
79 (interpret-inversion chord-entries mods chord-semantics))) | 79 (interpret-inversion chord-entries mods chord-semantics))) |
80 | 80 |
81 (define (interpret-additions chord-entries mods chord-semantics) | 81 (define (interpret-additions chord-entries mods chord-semantics) |
82 "Interpret additions. TODO: should restrict modifier use?" | 82 "Interpret additions. TODO: should restrict modifier use?" |
83 (cond ((null? mods) chord-entries) | 83 (cond ((null? mods) chord-entries) |
84 ((ly:pitch? (car mods)) | 84 ((ly:pitch? (car mods)) |
85 (case (pitch-step (car mods)) | 85 (case (pitch-step (car mods)) |
(...skipping 113 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... | |
199 (begin | 199 (begin |
200 (set! complete-chord (remove-step-chord-entries 3 complete-chord)))) | 200 (set! complete-chord (remove-step-chord-entries 3 complete-chord)))) |
201 ;; must do before processing inversion/bass, since they are | 201 ;; must do before processing inversion/bass, since they are |
202 ;; not relative to the root. | 202 ;; not relative to the root. |
203 (set! complete-chord (map (lambda (x) (chord-pitch-transpose x root)) | 203 (set! complete-chord (map (lambda (x) (chord-pitch-transpose x root)) |
204 complete-chord)) | 204 complete-chord)) |
205 (if inversion···· | 205 (if inversion···· |
206 (set! complete-chord (process-inversion complete-chord chord-semantics)) ) | 206 (set! complete-chord (process-inversion complete-chord chord-semantics)) ) |
207 (if bass | 207 (if bass |
208 (begin | 208 (begin |
209 (set! bass (make-chord-entry (pitch-octavated-strictly-below bass root ) 'bass)) | 209 (set! bass (make-chord-entry-from-pitch (pitch-octavated-strictly-belo w bass root))) |
210 (update-chord-semantics chord-semantics 'bass (entry-pitch bass)))) | 210 (update-chord-semantics chord-semantics 'bass (entry-pitch bass)))) |
211 (sort-chord-semantics chord-semantics) | 211 (sort-chord-semantics chord-semantics) |
212 ;; DEBUG STATEMENT | 212 ;; DEBUG STATEMENT |
213 (if #f | 213 (if #f |
214 (begin | 214 (begin |
215 (write-me "\n*******\n" flat-mods) | 215 (write-me "\n*******\n" flat-mods) |
216 (write-me "root: " root) | 216 (write-me "root: " root) |
217 (write-me "base chord: " base-chord) | 217 (write-me "base chord: " base-chord) |
218 (write-me "complete chord: " complete-chord) | 218 (write-me "complete chord: " complete-chord) |
219 (write-me "inversion: " inversion) | 219 (write-me "inversion: " inversion) |
220 (write-me "bass: " bass))) | 220 (write-me "bass: " bass))) |
221 (if inversion | 221 (if inversion |
222 (make-chord-elements (cdr complete-chord) bass duration (car complete-ch ord) | 222 (make-chord-elements (cdr complete-chord) bass duration (car complete-ch ord) |
223 inversion chord-semantics) | 223 inversion chord-semantics) |
224 (make-chord-elements complete-chord bass duration #f #f chord-semantics) ))) | 224 (make-chord-elements complete-chord bass duration #f #f chord-semantics) ))) |
225 | 225 |
226 | 226 |
227 (define (make-chord-elements chord-entries bass duration inversion original-inv- pitch chord-semantics) | 227 (define (make-chord-elements chord-entries bass duration inversion original-inv- pitch chord-semantics) |
228 "Make EventChord with notes corresponding to PITCHES, DURATION | 228 "Make EventChord with notes corresponding to PITCHES, DURATION |
229 CHORD-STEP, and SEMANTICS." | 229 CHORD-STEP, and SEMANTICS." |
230 (define (make-note-ev chord-entry . rest) | 230 (define (make-note-ev chord-entry . rest) |
231 (apply make-music 'NoteEvent | 231 (apply make-music 'NoteEvent |
232 'chord-step (entry-chord-step chord-entry) | 232 'chord-step (entry-chord-step chord-entry) |
233 'duration duration | 233 'duration duration |
234 'pitch (entry-pitch chord-entry) | 234 'pitch (entry-pitch chord-entry) |
235 rest)) | 235 rest)) |
236 (define (make-chord-semantics-ev chord-semantics) | 236 (define (make-chord-semantics-ev chord-semantics) |
237 (make-music 'ChordSemanticsEvent | 237 (make-music 'ChordSemanticsEvent |
238 'chord-semantics chord-semantics)) | 238 'chord-semantics chord-semantics)) |
pwm
2018/11/10 05:44:22
Hmm, so there's a single 'chord-semantics property
| |
239 (define (make-elements note-events chord-semantics) | 239 (define (make-elements note-events chord-semantics) |
240 (cons (make-chord-semantics-ev chord-semantics) note-events)) | 240 (cons (make-chord-semantics-ev chord-semantics) note-events)) |
241 (cond (inversion | 241 (cond (inversion |
242 (let* ((octavation (- (ly:pitch-octave inversion) | 242 (let* ((octavation (- (ly:pitch-octave inversion) |
243 (ly:pitch-octave (entry-pitch original-inv-pitch) ))) | 243 (ly:pitch-octave (entry-pitch original-inv-pitch) ))) |
pwm
2018/11/10 05:44:22
Would be more clear and consistent if original-inv
| |
244 (down (ly:make-pitch octavation 0 0)) | 244 (down (ly:make-pitch octavation 0 0)) |
245 (inv-semantics (entry-chord-step original-inv-pitch))) | 245 (inv-semantics (entry-chord-step original-inv-pitch))) |
246 (define (invert-chord-entry p) | 246 (define (invert-chord-entry p) |
247 (make-chord-entry (ly:pitch-transpose down (entry-pitch p)) | 247 (make-chord-entry (ly:pitch-transpose down (entry-pitch p)) |
248 (entry-chord-step p))) | 248 (entry-chord-step p))) |
249 (define (make-inverted p . rest) | 249 (define (make-inverted p . rest) |
250 (apply make-note-ev (invert-chord-entry p) 'octavation octavation r est)) | 250 (apply make-note-ev (invert-chord-entry p) 'octavation octavation r est)) |
251 (receive (uninverted high) | 251 (receive (uninverted high) |
252 (span (lambda (p) (ly:pitch<? (entry-pitch p) | 252 (span (lambda (p) (ly:pitch<? (entry-pitch p) |
253 (entry-pitch original-inv-pitc h))) | 253 (entry-pitch original-inv-pitc h))) |
254 chord-entries) | 254 chord-entries) |
255 (receive (invertible rest) | 255 (receive (invertible rest) |
256 (if (null? uninverted) | 256 (if (null? uninverted) |
257 ;; The following line caters for | 257 ;; the following line caters for |
258 ;; inversions "on the root", turning | 258 ;; inversions "on the root", turning |
259 ;; f/f into <f a' c''> rather than <f a c'> | 259 ;; f/f into <f a' c''> rather than <f a c'> |
260 ;; or <f' a' c''> | 260 ;; or <f' a' c''> |
261 (values '() high) | 261 (values '() high) |
262 (span (lambda (p) | 262 (span (lambda (p) |
263 (ly:pitch<? (entry-pitch (invert-chord- entry p)) | 263 (ly:pitch<? (entry-pitch (invert-chord- entry p)) |
264 (entry-pitch (car uninverte d)))) | 264 (entry-pitch (car uninverte d)))) |
265 high)) | 265 high)) |
266 (make-elements (cons (make-inverted original-inv-pi tch 'inversion #t) | 266 (make-elements (cons (make-inverted original-inv-pi tch 'inversion #t) |
267 (append (if bass (list (make-n ote-ev bass 'bass #t)) '()) | 267 (append (if bass (write-me "ba se3: " bass) (list (make-note-ev bass 'bass #t)) '()) |
pwm
2018/11/10 05:44:22
This write-me looks like a debugging statement tha
| |
268 (map make-inverted inv ertible) | 268 (map make-inverted inv ertible) |
269 (map make-note-ev unin verted) | 269 (map make-note-ev unin verted) |
270 (map make-note-ev rest ))) | 270 (map make-note-ev rest ))) |
271 chord-semantics))))) | 271 chord-semantics))))) |
272 (bass (make-elements (cons (make-note-ev bass 'bass #t) | 272 (bass (make-elements (cons (make-note-ev bass 'bass (cons #t #t)) |
pwm
2018/11/10 05:44:22
Hmm, this (cons #t #t) looks like it could be rela
| |
273 (map make-note-ev chord-entries)) | 273 (map make-note-ev chord-entries)) |
274 chord-semantics)) | 274 chord-semantics)) |
275 (else (make-elements (map make-note-ev chord-entries) chord-semantics))) ) | 275 (else (make-elements (map make-note-ev chord-entries) chord-semantics))) ) |
276 | 276 |
277 ;;;;;;;;;;;;;;;; | 277 ;;;;;;;;;;;;;;;; |
278 | 278 |
279 ;; get symbol from modifier | 279 ;; get symbol from modifier |
280 (define (mod-symbol lead-mod) | 280 (define (mod-symbol lead-mod) |
281 (cond ((eq? lead-mod aug-modifier) 'aug) | 281 (cond ((eq? lead-mod aug-modifier) 'aug) |
282 ((eq? lead-mod minor-modifier) 'min) | 282 ((eq? lead-mod minor-modifier) 'min) |
(...skipping 13 matching lines...) Expand all Loading... | |
296 (define (sort-chord-semantics chord-semantics) | 296 (define (sort-chord-semantics chord-semantics) |
297 (update-chord-semantics chord-semantics | 297 (update-chord-semantics chord-semantics |
298 'additions | 298 'additions |
299 (sort (get-chord-semantics chord-semantics 'additions) ly:pitch<?)) | 299 (sort (get-chord-semantics chord-semantics 'additions) ly:pitch<?)) |
300 (update-chord-semantics chord-semantics | 300 (update-chord-semantics chord-semantics |
301 'removals | 301 'removals |
302 (sort (get-chord-semantics chord-semantics 'removals) ly:pitch<?))) | 302 (sort (get-chord-semantics chord-semantics 'removals) ly:pitch<?))) |
303 | 303 |
304 ;; get value from key in chord-semantics | 304 ;; get value from key in chord-semantics |
305 (define (get-chord-semantics semantics-list key) | 305 (define (get-chord-semantics semantics-list key) |
306 (assoc-ref semantics-list key)) | 306 (assoc-ref semantics-list key)) |
pwm
2018/11/10 05:44:22
This is defined twice, see line 292 above.
| |
307 | 307 |
308 ;; chord modifiers change the pitch list. | 308 ;; chord modifiers change the pitch list. |
309 (define (aug-modifier chord-entries) | 309 (define (aug-modifier chord-entries) |
310 (set! chord-entries (replace-step (make-chord-entry (ly:make-pitch 0 4 SHARP) | 310 (set! chord-entries (replace-step (make-chord-entry (ly:make-pitch 0 4 SHARP) |
311 (make-chord-step 5 'aug)) | 311 (make-chord-step 5 'aug)) |
312 chord-entries)) | 312 chord-entries)) |
313 (replace-step (make-chord-entry (ly:make-pitch 0 2 0) | 313 (replace-step (make-chord-entry (ly:make-pitch 0 2 0) |
314 (make-chord-step 3 'maj)) | 314 (make-chord-step 3 'maj)) |
315 chord-entries)) | 315 chord-entries)) |
316 | 316 |
(...skipping 72 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... | |
389 (cond ((= alteration 0) (set! quality 'perfect)) | 389 (cond ((= alteration 0) (set! quality 'perfect)) |
390 ((= alteration SHARP) (set! quality 'aug)) | 390 ((= alteration SHARP) (set! quality 'aug)) |
391 ((= alteration FLAT) (set! quality 'dim)))) | 391 ((= alteration FLAT) (set! quality 'dim)))) |
392 ((or (= step-number 6) (= step-number 13)) | 392 ((or (= step-number 6) (= step-number 13)) |
393 (cond ((= alteration SHARP) (set! quality 'aug)) | 393 (cond ((= alteration SHARP) (set! quality 'aug)) |
394 ((= alteration FLAT) (set! quality 'min)) | 394 ((= alteration FLAT) (set! quality 'min)) |
395 ((= alteration DOUBLE-FLAT) (set! quality 'dim)))) | 395 ((= alteration DOUBLE-FLAT) (set! quality 'dim)))) |
396 ((or (= step-number 1) (= step-number 8)) ;; TODO: define this better. .. | 396 ((or (= step-number 1) (= step-number 8)) ;; TODO: define this better. .. |
397 (cond ((= alteration 0) (set! quality 'perfect)) | 397 (cond ((= alteration 0) (set! quality 'perfect)) |
398 ((= alteration SHARP) (set! quality 'aug)) | 398 ((= alteration SHARP) (set! quality 'aug)) |
399 ((= alteration FLAT) (set! quality 'dim))))) | 399 ((= alteration FLAT) (set! quality 'dim))))) |
pwm
2018/11/10 05:44:22
Instead of all of these (set! quality ...) why not
| |
400 (make-chord-entry pitch (make-chord-step step-number quality)))) | 400 (make-chord-entry pitch (make-chord-step step-number quality)))) |
401 | 401 |
402 ;; Make single chord-step | 402 ;; Make single chord-step |
403 (define (make-chord-step number quality) | 403 (define (make-chord-step number quality) |
404 (list (cons 'step-number number) (cons 'step-quality quality))) | 404 (list (cons 'step-number number) (cons 'step-quality quality))) |
405 | 405 |
406 ;; make chord-step list used in canonical 13 | 406 ;; make chord-step list used in canonical 13 |
407 (define (make-chord-step-list chord-step-list step-number) | 407 (define (make-chord-step-list chord-step-list step-number) |
408 (define quality 'major) | 408 (define quality 'major) |
409 (if (= step-number 1) (set! quality 'perfect)) | 409 (if (= step-number 1) (set! quality 'perfect)) |
410 (if (= step-number 5) (set! quality 'perfect)) | 410 (if (= step-number 5) (set! quality 'perfect)) |
411 (if (= step-number 7) (set! quality 'min)) | 411 (if (= step-number 7) (set! quality 'min)) |
pwm
2018/11/10 05:44:22
Defining quality using cond or case would be a mor
| |
412 (if (= step-number 15) (reverse chord-step-list) | 412 (if (= step-number 15) (reverse chord-step-list) |
413 (make-chord-step-list | 413 (make-chord-step-list |
414 (cons (list (cons 'step-number step-number) (cons 'step-quality qualit y)) chord-step-list) | 414 (cons (list (cons 'step-number step-number) (cons 'step-quality qualit y)) chord-step-list) |
pwm
2018/11/10 05:44:22
Why not use make-chord-step here to simplify this?
| |
415 (+ step-number 2)))) | 415 (+ step-number 2)))) |
416 | 416 |
417 ;; canonical 13 chord. | 417 ;; canonical 13 chord. |
418 (define the-canonical-chord | 418 (define the-canonical-chord |
419 (map (lambda (chord-step) | 419 (map (lambda (chord-step) |
420 (define (nca x) | 420 (define (nca x) |
421 (if (= x 7) FLAT 0)) | 421 (if (= x 7) FLAT 0)) |
422 (define n (assoc-ref chord-step 'step-number)) | 422 (define n (assoc-ref chord-step 'step-number)) |
423 (if (>= n 8) | 423 (if (>= n 8) |
424 (make-chord-entry (ly:make-pitch 1 (- n 8) (nca n)) chord-step) | 424 (make-chord-entry (ly:make-pitch 1 (- n 8) (nca n)) chord-step) |
425 (make-chord-entry (ly:make-pitch 0 (- n 1) (nca n)) chord-step))) | 425 (make-chord-entry (ly:make-pitch 0 (- n 1) (nca n)) chord-step))) |
pwm
2018/11/10 05:44:22
Here's a way to simplify this:
(map (lambda (cho
| |
426 (make-chord-step-list '() 1) | 426 (make-chord-step-list '() 1) |
427 )) | 427 )) |
428 · | 428 · |
429 (define (stack-thirds upper-step base) | 429 (define (stack-thirds upper-step base) |
430 "Stack thirds listed in BASE until we reach UPPER-STEP. Add | 430 "Stack thirds listed in BASE until we reach UPPER-STEP. Add |
431 UPPER-STEP separately." | 431 UPPER-STEP separately." |
432 (cond ((null? base) '()) | 432 (cond ((null? base) '()) |
433 ((> (ly:pitch-steps upper-step) (ly:pitch-steps (entry-pitch (car base)) )) | 433 ((> (ly:pitch-steps upper-step) (ly:pitch-steps (entry-pitch (car base)) )) |
434 (cons (car base) (stack-thirds upper-step (cdr base)))) | 434 (cons (car base) (stack-thirds upper-step (cdr base)))) |
435 ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (entry-pitch (car base) ))) | 435 ((<= (ly:pitch-steps upper-step) (ly:pitch-steps (entry-pitch (car base) ))) |
436 (list (make-chord-entry upper-step (entry-chord-step (car base))))) | 436 (list (make-chord-entry upper-step (entry-chord-step (car base))))) |
437 (else '()))) | 437 (else '()))) |
LEFT | RIGHT |