(ice-9 string-fun)
)
+;; pitch = (octave notename accidental)
;;
-;; (octave notename accidental)
+;; note = (notename . accidental)
;;
+;; text = scm markup text -- see font.scm and input/test/markup.ly
-;;
-;; text: scm markup text -- see font.scm and input/test/markup.ly
-;;
;; TODO
;;
-;; * clean split of base/banter/american stuff
-;; * text definition is rather ad-hoc
-;; * do without format module
-;; * finish and check american names
-;; * make notename (tonic) configurable from lilypond
-;; * fix append/cons stuff in inner-name-banter
-;; * doc strings.
-
-;;;;;;;;;
+;; * fix FIXMEs
+;; * clean split/merge of bass/banter/american stuff
+;; * handy, documented hooks for user-override of:
+;; - tonic (chord) name
+;; -
+;; * doc strings
+
(define chord::names-alist-banter '())
(set! chord::names-alist-banter
(append
; Cm iso Cm.no5
(((0 . 0) (2 . -1)) . ("m"))
; C2 iso C2.no3
- (((0 . 0) (1 . 0) (4 . 0)) . (super "2"))
+ (((0 . 0) (1 . 0) (4 . 0)) . ("" (super "2")))
; C4 iso C4.no3
- (((0 . 0) (3 . 0) (4 . 0)) . (super "4"))
- ; Cdim iso Cm5-
+ (((0 . 0) (3 . 0) (4 . 0)) . ("" (super "4")))
+ ;; Cdim iso Cm5-
(((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
; Co iso Cm5-7-
- ; urg
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super "o"))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
; Cdim9
(((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9")))
(((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11")))
)
chord::names-alist-banter))
+;;;;;;;;;;
+
+
+;; FIXME
+(define (accidental->text acc)
+ (if (= acc 0)
+ '()
+ (list '(music (font-relative-size . -2))
+ (string-append "accidentals-" (number->string acc)))))
+
+(define (accidental->text-super acc)
+ (if (= acc 0)
+ '()
+ (cons 'super (list (accidental->text acc)))))
+
+(define (accidental->text-sub acc)
+ (if (= acc 0)
+ '()
+ (cons sub (list accidental->text acc))))
+
+
+;; these look nice, but don't work together with current inner-name-jazz
+;; (inner-name-jazz is a bit broken: apply append etc)
+(define (xaccidental->textp acc pos)
+ (if (= acc 0)
+ '()
+ (list (list '(music (font-relative-size . -2))
+ (list pos (string-append "accidentals-" (number->string acc))))))
+)
+
+(define (xaccidental->text acc) (accidental->textp acc 'rows))
+(define (xaccidental->text-super acc) (accidental->textp acc 'super))
+(define (xaccidental->text-sub acc) (accidental->textp acc 'sub))
+
+(define (pitch->note-name pitch)
+ (cons (cadr pitch) (caddr pitch)))
+
+;; FIXME: see german-chords.ly
+(define (pitch->text pitch)
+ (cons
+ (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
+ (accidental->text-super (caddr pitch))))
+
+
+;;; Hooks to override chord names and note names,
+;;; see input/tricks/german-chords.ly
+
+(define (pitch->text-banter pitch)
+ (pitch->text pitch))
+
+;; We need also steps, to allow for Cc name override,
+;; see input/test/Cc-chords.ly
+(define (pitch->chord-name-text-banter pitch steps)
+ (pitch->text-banter pitch))
+
+(define (pitch->note-name-text-banter pitch)
+ (pitch->text-banter pitch))
+
+(define (step->text pitch)
+ (list (string-append
+ (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
+ (case (caddr pitch)
+ ((-2) "--")
+ ((-1) "-")
+ ((0) "")
+ ((1) "+")
+ ((2) "++")))))
+
+(define (step->text-banter pitch)
+ (if (= (cadr pitch) 6)
+ (case (caddr pitch)
+ ((-2) '("7-"))
+ ((-1) '("7"))
+ ((0) '("maj7"))
+ ((1) '("7+"))
+ ((2) '("7+")))
+ (step->text pitch)))
+
+(define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
+
+(define (pitch::semitone pitch)
+ (+ (* (car pitch) 12)
+ (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
+ (caddr pitch)))
+
+(define (pitch::< l r)
+ (< (pitch::semitone l) (pitch::semitone r)))
+
+(define (pitch::transpose pitch delta)
+ (let ((simple-octave (+ (car pitch) (car delta)))
+ (simple-notename (+ (cadr pitch) (cadr delta))))
+ (let ((octave (+ simple-octave (quotient simple-notename 7)))
+ (notename (modulo simple-notename 7)))
+ (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
+ (pitch::semitone `(,octave ,notename 0)))))
+ `(,octave ,notename ,accidental)))))
+
+(define (pitch::diff pitch tonic)
+ (let ((simple-octave (- (car pitch) (car tonic)))
+ (simple-notename (- (cadr pitch) (cadr tonic))))
+ (let ((octave (+ simple-octave (quotient simple-notename 7)
+ (if (< simple-notename 0) -1 0)))
+ (notename (modulo simple-notename 7)))
+ (let ((accidental (- (pitch::semitone pitch)
+ (pitch::semitone tonic)
+ (pitch::semitone `(,octave ,notename 0)))))
+ `(,octave ,notename ,accidental)))))
+
+(define (pitch::note-pitch pitch)
+ (+ (* (car pitch) 7) (cadr pitch)))
+
+(define (chord::text? text)
+ (not (or (not text) (empty? text) (unspecified? text))))
+
+(define (chord::text-cleanup dirty)
+ "
+ Recursively remove '() #f, and #<unspecified> from markup text tree.
+ This allows us to leave else parts of (if # #) off.
+ Otherwise, you'd have to do (if # # '()), and you'd have to
+ filter-out the '() anyway.
+ "
+ (if (pair? dirty)
+ (let ((r (car dirty)))
+ (if (chord::text? r)
+ (cons (if (pair? r) (chord::text-cleanup r) r)
+ (chord::text-cleanup (cdr dirty)))
+ (chord::text-cleanup (cdr dirty))))
+ (if (chord::text? dirty)
+ dirty
+ '())))
+
+(define (chord::text-append l . r)
+ (if (not (chord::text? r))
+ l
+ (if (not (chord::text? l))
+ r
+ (cons l r))))
+
+(define (chord::step tonic pitch)
+ (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
+
+;; text: list of word
+;; word: string + optional list of property
+;; property: align, kern, font (?), size
+
+(define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
+
+;; FIXME: unLOOP
+;; compute the relative-to-tonic pitch that goes with 'step'
+(define (chord::step-pitch tonic step)
+ ;; urg, we only do this for thirds
+ (if (= (modulo step 2) 0)
+ '(0 0 0)
+ (let loop ((i 1) (pitch tonic))
+ (if (= i step) pitch
+ (loop (+ i 2)
+ (pitch::transpose
+ pitch `(0 2 ,(vector-ref chord::minor-major-vec
+ ;; -1 (step=1 -> vector=0) + 7 = 6
+ (modulo (+ i 6) 7)))))))))
+
+(define (chord::additions steps)
+ " Return:
+ * any even step (2, 4, 6)
+ * any uneven step that is chromatically altered,
+ (where 7-- == -1, 7- == 0, 7 == +1)
+ * highest step
+
+and you need also:
+
+ * TODO: any uneven step that's lower than an uneven step which is
+ chromatically altered
+ "
+ (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
+ (altered-unevens
+ (filter-list (lambda (x)
+ (let ((n (cadr x)) (a (caddr x)))
+ (or (and (= 6 n) (!= -1 a))
+ (and (!= 6 n)
+ (= 0 (modulo n 2))
+ (!= 0 a)))))
+ steps))
+ (highest (let ((h (car (last-pair steps))))
+ (if (and (not (empty? h))
+ (or (> 4 (cadr h))
+ (!= 0 (caddr h))))
+ (list (list h))
+ '()))))
+ ;; Hmm, what if we have a step twice, can we ignore that?
+ (uniq-list (sort (apply append evens altered-unevens highest)
+ pitch::<))))
+
+
+;; FIXME: unLOOP, see ::additions
+;; find the pitches that are missing from `normal' chord
+(define (chord::subtractions chord-pitches)
+ (let ((tonic (car chord-pitches)))
+ (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
+ (if (pair? pitches)
+ (let* ((pitch (car pitches))
+ (p-step (+ (- (pitch::note-pitch pitch)
+ (pitch::note-pitch tonic))
+ 1)))
+ ;; pitch is an subtraction if
+ ;; a step is missing or
+ (if (> p-step step)
+ (loop (+ step 2) pitches
+ (cons (chord::step-pitch tonic step) subtractions))
+ ;; there are no pitches left, but base thirds are not yet done and
+ (if (and (<= step 5)
+ (= (length pitches) 1))
+ ;; present pitch is not missing step
+ (if (= p-step step)
+ (loop (+ step 2) pitches subtractions)
+ (loop (+ step 2) pitches
+ (cons (chord::step-pitch tonic step) subtractions)))
+ (if (= p-step step)
+ (loop (+ step 2) (cdr pitches) subtractions)
+ (loop step (cdr pitches) subtractions)))))
+ (reverse subtractions)))))
+
+(define (chord::additions->text-banter additions subtractions)
+ (if (pair? additions)
+ (cons (apply append
+ (chord::text-cleanup
+ (list
+ (cons 'super (step->text-banter (car additions)))
+ (if (or (pair? (cdr additions))
+ (pair? subtractions))
+ '(super "/")))))
+ (chord::additions->text-banter (cdr additions) subtractions))))
+
+(define (chord::subtractions->text-banter subtractions)
+ (if (pair? subtractions)
+ (cons (apply append
+ (chord::text-cleanup
+ (list
+ '(super "no")
+ (cons 'super (step->text-banter (car subtractions)))
+ (if (pair? (cdr subtractions))
+ '(super "/")))))
+ (chord::subtractions->text-banter (cdr subtractions)))))
+
+(define (chord::bass-and-inversion->text-banter bass-and-inversion)
+ (if (and (pair? bass-and-inversion)
+ (or (car bass-and-inversion)
+ (cdr bass-and-inversion)))
+ (list "/" (if (car bass-and-inversion)
+ (pitch->note-name-text-banter
+ (car bass-and-inversion))
+ (pitch->note-name-text-banter
+ (cdr bass-and-inversion))))))
+
+;; FIXME: merge this function with inner-name-jazz, -american
+;; iso using chord::bass-and-inversion->text-banter,
+;; call (chord::restyle 'chord::bass-and-inversion->text- style)
+;; See: chord::exceptions-lookup
+;;
+;; Banter style
+;; Combine tonic, exception-part of chord name,
+;; additions, subtractions and bass or inversion into chord name
+(define (chord::inner-name-banter tonic exception-part additions subtractions
+ bass-and-inversion steps)
+ (let ((tonic-text (pitch->chord-name-text-banter tonic steps))
+ (except-text exception-part)
+ (sep-text (if (and (string-match "super" (format "~s" exception-part))
+ (or (pair? additions)
+ (pair? subtractions)))
+ '((super "/"))))
+ (adds-text (chord::additions->text-banter additions subtractions))
+ (subs-text (chord::subtractions->text-banter subtractions))
+ (b+i-text (chord::bass-and-inversion->text-banter bass-and-inversion)))
+ (apply append
+ (map chord::text-cleanup
+ (list
+ '(rows) tonic-text except-text sep-text adds-text subs-text
+ b+i-text)))))
+
+(define (chord::name-banter tonic exception-part unmatched-steps
+ bass-and-inversion steps)
+ (let ((additions (chord::additions unmatched-steps))
+ (subtractions (chord::subtractions unmatched-steps)))
+ (chord::inner-name-banter tonic exception-part additions subtractions
+ bass-and-inversion steps)))
+
+
+(define (c++-pitch->scm p)
+ (if (pitch? p)
+ (list (pitch-octave p) (pitch-notename p) (pitch-alteration p))
+ #f))
+
+(define (chord::name-banter tonic exception-part unmatched-steps
+ bass-and-inversion steps)
+ (let ((additions (chord::additions unmatched-steps))
+ (subtractions (chord::subtractions unmatched-steps)))
+ (chord::inner-name-banter tonic exception-part additions subtractions
+ bass-and-inversion steps)))
+
+(define (chord::restyle name style)
+ (ly-eval (string->symbol
+ (string-append (symbol->string name)
+ (symbol->string style)))))
+
+;; check exceptions-alist for biggest matching part of try-steps
+;; return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
+(define (chord::exceptions-lookup-helper
+ exceptions-alist try-steps unmatched-steps exception-part)
+ (if (pair? try-steps)
+ ;; FIXME: junk '(0 . 0) from exceptions lists?
+ ;; if so: how to handle first '((0 . 0) . #f) entry?
+ ;;
+ ;; FIXME: either format exceptions list as real pitches, ie,
+ ;; including octave '((0 2 -1) ..), or drop octave
+ ;; from rest of calculations,
+ (let ((entry (assoc
+ (map (lambda (x) (pitch->note-name x))
+ (append '((0 0 0)) try-steps))
+ exceptions-alist)))
+ (if entry
+ (chord::exceptions-lookup-helper
+ #f '() unmatched-steps (cdr entry))
+ (let ((r (reverse try-steps)))
+ (chord::exceptions-lookup-helper
+ exceptions-alist
+ (reverse (cdr r))
+ (cons (car r) unmatched-steps) #f))))
+ (cons exception-part unmatched-steps)))
+
+;; return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
+;; BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
+(define (chord::exceptions-lookup style steps)
+ (let* ((result (chord::exceptions-lookup-helper
+ (chord::restyle 'chord::names-alist- style)
+ steps '() #f))
+ (exception-part (car result))
+ (unmatched-steps (cdr result))
+ (matched-steps (if (= (length unmatched-steps) 0)
+ 3
+ (+ 1 (- (length steps)
+ (length unmatched-steps)))))
+ (unmatched-with-1-3-5
+ (append (do ((i matched-steps (- i 1))
+ (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
+ ((= i 0) base)
+ ())
+ unmatched-steps)))
+ (list exception-part unmatched-with-1-3-5)))
+
+
+(define (chord::name->text style tonic steps bass-and-inversion)
+ (let* ((lookup (chord::exceptions-lookup style steps))
+ (exception-part (car lookup))
+ (unmatched-steps (cadr lookup)))
+ ((chord::restyle 'chord::name- style)
+ tonic exception-part unmatched-steps bass-and-inversion steps)))
+
+;; C++ entry point
+;;
+;; Check for each subset of chord, full chord first, if there's a
+;; user-override. Split the chord into user-overridden and to-be-done
+;; parts, complete the missing user-override matched part with normal
+;; chord to be name-calculated.
+;;
+;; CHORD: (pitches (bass . inversion))
+(define (default-chord-name-function style chord)
+ (let* ((pitches (map c++-pitch->scm (car chord)))
+ (modifiers (cdr chord))
+ (bass-and-inversion (if (pair? modifiers)
+ (cons (c++-pitch->scm (car modifiers))
+ (c++-pitch->scm (cdr modifiers)))
+ '(() . ())))
+ (diff (pitch::diff '(0 0 0) (car pitches)))
+ (steps (if (cdr pitches) (map (lambda (x)
+ (pitch::transpose x diff))
+ (cdr pitches))
+ '())))
+ (chord::name->text style (car pitches) steps bass-and-inversion)))
+
+
+
+;;;
+;;; American style
+;;;
+
;; NOTE: Duplicates of chord names defined elsewhere occur in this list
;; in order to prevent spurious superscripting of various chord names,
(((0 . 0) (2 . -1)) . ("m"))
(((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
(((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
-;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ((super "o")))
+;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
(((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
(((0 . 0) (1 . 0) (4 . 0)) . ("2"))
;; Common seventh chords
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (rows (super "o") "7"))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o") "7"))
(((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
+ ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!!
(((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
(((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
;jazz: the delta, see jazz-chords.ly
;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super ((font-family . math) "N"))
;; ugh, kludge slashed o
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows ((raise . 1) "o") ((kern . -0.85) ((raise . 0.57) ((font-relative-size . -3) "/"))) "7")) ; slashed o
+ ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows ((raise . 1) "o") ((kern . -0.85) ((raise . 0.57) ((font-relative-size . -3) "/"))) "7")) ; slashed o
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows ((raise . 1) "o") (((kern . -0.85) (raise . 1.1) (font-relative-size . -2)) "/") "7")) ; slashed o
+
(((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
(((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (rows "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
(((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
)
chord::names-alist-american))
+
+;; American style chordnames use no "no",
+;; but otherwise very similar to banter for now
+(define (chord::name-american tonic exception-part unmatched-steps
+ bass-and-inversion steps)
+ (let ((additions (chord::additions unmatched-steps))
+ (subtractions #f))
+ (chord::inner-name-banter tonic exception-part additions subtractions
+ bass-and-inversion steps)))
+
+
+
+;;;
+;;; Jazz style
+;;;
+
+
+
;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
-;; NBs: This uses the american list as a base.
+;; NBs: This uses the american list as a bass.
;; Some defs take up more than one line,
;; be carefull when messing with ;'s!!
;; DONT use non-ascii characters, even if ``it works'' in Windows
- ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (((raise . 0.8)"o"))); works, but "o" is a little big
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
+ ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
;; half diminshed chords
- ; half diminished seventh chord = slashed o
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8)"/o")))
+ ;; half diminished seventh chord = slashed o
+ ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8) "/o")))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows ((raise . 1) "o") (((kern . -0.85) (raise . 1.1) (font-relative-size . -2)) "/") "7")) ; slashed o
+
; half diminished seventh chord with major 9 = slashed o cancelation 9
(((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
((raise . 0.8)"/o(")
)
chord::names-alist-american))
-;;;;;;;;;;
-
-
-(define (pitch->note-name pitch)
- (cons (cadr pitch) (caddr pitch)))
-
-(define (accidental->text acc)
- (if (= acc 0)
- '()
- (list
- (append '(music)
- (list
- (append '(named)
- (list
- (append '((font-relative-size . -2))
- (list (append '((raise . 0.6))
- (list
- (string-append "accidentals-"
- (number->string acc))))))))))))
-)
-
-(define (pitch->text pitch)
+(define (step->text-alternate-jazz pitch)
(cons
- (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
- (accidental->text (caddr pitch))
- )
-)
+ (accidental->text (caddr pitch))
+ (list (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8))))))
-;;; Hooks to override chord names and note names,
-;;; see input/tricks/german-chords.ly
-
-(define (pitch->text-banter pitch)
- (pitch->text pitch))
-
-(define (pitch->chord-name-text-banter pitch)
- (pitch->text-banter pitch))
-
-(define (pitch->note-name-text-banter pitch)
- (pitch->text-banter pitch))
-
-(define (step->text pitch)
- (string-append
- (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
- (case (caddr pitch)
- ((-2) "--")
- ((-1) "-")
- ((0) "")
- ((1) "+")
- ((2) "++"))))
-
-(define (step->text-banter pitch)
+(define (step->text-jazz pitch)
(if (= (cadr pitch) 6)
(case (caddr pitch)
- ((-2) "7-")
- ((-1) "7")
- ((0) "maj7")
- ((1) "7+")
- ((2) "7+"))
- (step->text pitch)))
-
-(define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
-
-(define (pitch::semitone pitch)
- (+ (* (car pitch) 12)
- (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
- (caddr pitch)))
-
-(define (pitch::transpose pitch delta)
- (let ((simple-octave (+ (car pitch) (car delta)))
- (simple-notename (+ (cadr pitch) (cadr delta))))
- (let ((octave (+ simple-octave (quotient simple-notename 7)))
- (notename (modulo simple-notename 7)))
- (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
- (pitch::semitone `(,octave ,notename 0)))))
- `(,octave ,notename ,accidental)))))
-
-(define (pitch::diff pitch tonic)
- (let ((simple-octave (- (car pitch) (car tonic)))
- (simple-notename (- (cadr pitch) (cadr tonic))))
- (let ((octave (+ simple-octave (quotient simple-notename 7)
- (if (< simple-notename 0) -1 0)))
- (notename (modulo simple-notename 7)))
- (let ((accidental (- (pitch::semitone pitch)
- (pitch::semitone tonic)
- (pitch::semitone `(,octave ,notename 0)))))
- `(,octave ,notename ,accidental)))))
-
-(define (pitch::note-pitch pitch)
- (+ (* (car pitch) 7) (cadr pitch)))
-
-(define (chord::step tonic pitch)
- (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
-
-;; text: list of word
-;; word: string + optional list of property
-;; property: align, kern, font (?), size
-
-(define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
-
-;; compute the relative-to-tonic pitch that goes with 'step'
-(define (chord::step-pitch tonic step)
- ;; urg, we only do this for thirds
- (if (= (modulo step 2) 0)
- '(0 0 0)
- (let loop ((i 1) (pitch tonic))
- (if (= i step) pitch
- (loop (+ i 2)
- (pitch::transpose
- pitch `(0 2 ,(vector-ref chord::minor-major-vec
- ;; -1 (step=1 -> vector=0) + 7 = 6
- (modulo (+ i 6) 7)))))))))
-
-;; find the pitches that are not part of `normal' chord
-(define (chord::additions chord-pitches)
- (let ((tonic (car chord-pitches)))
- ;; walk the chord steps: 1, 3, 5
- (let loop ((step 1) (pitches chord-pitches) (additions '()))
- (if (pair? pitches)
- (let* ((pitch (car pitches))
- (p-step (+ (- (pitch::note-pitch pitch)
- (pitch::note-pitch tonic))
- 1)))
- ;; pitch is an addition if
- (if (or
- ;; it comes before this step or
- (< p-step step)
- ;; its step is even or
- (= (modulo p-step 2) 0)
- ;; has same step, but different accidental or
- (and (= p-step step)
- (not (equal? pitch (chord::step-pitch tonic step))))
- ;; is the last of the chord and not one of base thirds
- (and (> p-step 5)
- (= (length pitches) 1)))
- (loop step (cdr pitches) (cons pitch additions))
- (if (= p-step step)
- (loop step (cdr pitches) additions)
- (loop (+ step 2) pitches additions))))
- (reverse additions)))))
-
-;; find the pitches that are missing from `normal' chord
-(define (chord::subtractions chord-pitches)
- (let ((tonic (car chord-pitches)))
- (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
- (if (pair? pitches)
- (let* ((pitch (car pitches))
- (p-step (+ (- (pitch::note-pitch pitch)
- (pitch::note-pitch tonic))
- 1)))
- ;; pitch is an subtraction if
- ;; a step is missing or
- (if (> p-step step)
- (loop (+ step 2) pitches
- (cons (chord::step-pitch tonic step) subtractions))
- ;; there are no pitches left, but base thirds are not yet done and
- (if (and (<= step 5)
- (= (length pitches) 1))
- ;; present pitch is not missing step
- (if (= p-step step)
- (loop (+ step 2) pitches subtractions)
- (loop (+ step 2) pitches
- (cons (chord::step-pitch tonic step) subtractions)))
- (if (= p-step step)
- (loop (+ step 2) (cdr pitches) subtractions)
- (loop step (cdr pitches) subtractions)))))
- (reverse subtractions)))))
-
-;; combine tonic, user-specified chordname,
-;; additions, subtractions and base or inversion to chord name
-;;
-(define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
- (apply append
- '(rows)
- (pitch->chord-name-text-banter tonic)
- (if user-name user-name '())
- ;; why does list->string not work, format seems only hope...
- (if (and (string-match "super" (format "~s" user-name))
- (or (pair? additions)
- (pair? subtractions)))
- '((super "/"))
- '())
- (let loop ((from additions) (to '()))
- (if (pair? from)
- (let ((p (car from)))
- (loop (cdr from)
- (append to
- (cons
- (list 'super (step->text-banter p))
- (if (or (pair? (cdr from))
- (pair? subtractions))
- '((super "/"))
- '())))))
- to))
- (let loop ((from subtractions) (to '()))
- (if (pair? from)
- (let ((p (car from)))
- (loop (cdr from)
- (append to
- (cons '(super "no")
- (cons
- (list 'super (step->text-banter p))
- (if (pair? (cdr from))
- '((super "/"))
- '())))))) ; nesting?
- to))
- (if (and (pair? base-and-inversion)
- (or (car base-and-inversion)
- (cdr base-and-inversion)))
- (cons "/" (append
- (if (car base-and-inversion)
- (pitch->note-name-text-banter
- (car base-and-inversion))
- (pitch->note-name-text-banter
- (cdr base-and-inversion)))
- '()))
- '())
- '()))
-
-(define (chord::name-banter tonic user-name pitches base-and-inversion)
- (let ((additions (chord::additions pitches))
- (subtractions (chord::subtractions pitches)))
- (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
-
-;; american chordnames use no "no",
-;; but otherwise very similar to banter for now
-(define (chord::name-american tonic user-name pitches base-and-inversion)
- (let ((additions (chord::additions pitches))
- (subtractions #f))
- (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
+ ;; sharp 7 only included for completeness?
+ ((-2) (cons (accidental->text -1) '("7")))
+ ((-1) '("7"))
+ ((0) '("maj7"))
+ ((1) (cons (accidental->text-super 1) '("7")))
+ ((2) (cons (accidental->text-super 2) '("7"))))
+ (step->text-alternate-jazz pitch)))
+
+(define (chord::additions->text-jazz additions subtractions)
+ (if (pair? additions)
+ (cons (apply append
+ (chord::text-cleanup
+ (list
+ (cons 'super (step->text-jazz (car additions)))
+ (if (or (pair? (cdr additions))
+ (pair? subtractions))
+ '(super "/")))))
+ (chord::additions->text-jazz (cdr additions) subtractions))
+ '()))
+
+(define (chord::subtractions->text-jazz subtractions)
+ (if (pair? subtractions)
+ (cons (apply append
+ (chord::text-cleanup
+ (list
+ '(super "omit")
+ (cons 'super (step->text-jazz (car subtractions)))
+ (if (pair? (cdr subtractions))
+ '(super "/")))))
+ (chord::subtractions->text-jazz (cdr subtractions)))
+ '()))
+
+
+;; TODO: maybe merge with inner-name-banter
+;; Combine tonic, exception-part of chord name,
+;; additions, subtractions and bass or inversion into chord name
+(define (chord::inner-name-jazz tonic exception-part additions subtractions
+ bass-and-inversion steps)
+
+ ;; ugh
+ (apply
+ append
+
+ (chord::text-cleanup
+ (list '(rows)
+ (pitch->chord-name-text-banter tonic steps)
+ exception-part
+ ;; why does list->string not work, format seems only hope...
+ (if (and (string-match "super" (format "~s" exception-part))
+ (or (pair? additions)
+ (pair? subtractions)))
+ '((super "/")))
+ (chord::additions->text-jazz additions subtractions)
+ (chord::subtractions->text-jazz subtractions)
+ (chord::bass-and-inversion->text-banter bass-and-inversion)))))
;; Jazz style--basically similar to american with minor changes
-(define (chord::name-jazz tonic user-name pitches base-and-inversion)
- (let ((additions (chord::additions pitches))
- (subtractions #f))
- (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
-
-(define (new-to-old-pitch p)
- (if (pitch? p)
- (list (pitch-octave p) (pitch-notename p) (pitch-alteration p))
- #f
- ))
-
-
-
-;; C++ entry point
-;;
-;; Check for each subset of chord, full chord first, if there's a
-;; user-override. Split the chord into user-overridden and to-be-done
-;; parts, complete the missing user-override matched part with normal
-;; chord to be name-calculated.
;;
-;; CHORD: (pitches (base . inversion))
-(define (default-chord-name-function style chord)
- (let* ((style-string (symbol->string style))
- (pitches (map new-to-old-pitch (car chord)))
- (modifiers (cdr chord))
- (base-and-inversion (if (pair? modifiers)
- (cons (new-to-old-pitch (car modifiers))
- (new-to-old-pitch (cdr modifiers)))
- '(() . ())))
- (diff (pitch::diff '(0 0 0) (car pitches)))
- (name-func
- (ly-eval (string->symbol (string-append "chord::name-" style-string))))
- (names-alist
- (ly-eval (string->symbol (string-append "chord::names-alist-" style-string)))))
- (let loop ((note-names (reverse pitches))
- (chord '())
- (user-name #f))
- (if (pair? note-names)
- (let ((entry (assoc
- (reverse
- (map (lambda (x)
- (pitch->note-name (pitch::transpose x diff)))
- note-names))
- names-alist)))
- (if entry
- ;; urg? found: break loop
- (loop '() chord (cdr entry))
- (loop (cdr note-names) (cons (car note-names) chord) #f)))
- (let* ((transposed (if pitches
- (map (lambda (x) (pitch::transpose x diff)) chord)
- '()))
- (matched (if (= (length chord) 0)
- 3
- (- (length pitches) (length chord))))
- (completed
- (append (do ((i matched (- i 1))
- (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
- ((= i 0) base)
- ())
- transposed)))
- (name-func (car pitches) user-name completed base-and-inversion))))))
-
-
+;; Consider Dm6. When we get here:
+;; tonic = '(0 1 0) (note d=2)
+;; steps = '((0 0 0) '(0 2 -1) (0 4 0) (0 5 0))
+;; steps are transposed for tonic c, octave 0,
+;; so (car steps) is always (0 0 0)
+;; except = ("m")
+;; assuming that the exceptions-alist has an entry
+;; '(((0 . 0) (2 . -1)) . ("m"))
+;; (and NOT the full chord, like std jazz list, ugh)
+;; unmatch = '((0 0 0) (0 2 0) (0 4 0) (0 5 0))
+;; subtract= '()
+;;
+;; You can look very easily what happens, if you add some write-me calls,
+;; and run lilypond on a simple file, eg, containing only the chord c:m6:
+;;
+;; (let ((additions (write-me "adds: "
+;; (chord::additions (write-me "unmatched:"
+;; unmatched-steps))))
+;;
+;; If you set subtract #f, the chord::inner-name-jazz does not see any
+;; subtractions, ever, so they don't turn up in the chord name.
+;;
+(define (chord::name-jazz tonic exception-part unmatched-steps
+ bass-and-inversion steps)
+ (let ((additions (chord::additions unmatched-steps))
+ ;; get no 'omit' or 'no'
+ ;; (subtractions #f))
+ (subtractions (chord::subtractions unmatched-steps)))
+ (chord::inner-name-jazz tonic exception-part additions subtractions
+ bass-and-inversion steps)))
+
+;; wip (set! chord::names-alist-jazz
+(define chord::names-alist-jazz
+ (append
+ '(
+ (((0 . 0) (2 . -1)) . ("m"))
+ )
+ '()))
+ ;;chord::names-alist-american))
projects / lilypond.git / blobdiff