(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 bass/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.
-
-;;;;;;;;;
+;; * easier tweakability:
+;; - split chord::names-alists up into logical bits,
+;; such as chord::exceptions-delta, exceptions-oslash
+;; - iso just the 'style parameter, use a list, eg:
+;; \property ChordNames.ChordName \set
+;; #'style = #'(jazz delta oslash german-tonic german-Bb)
+;;
+;; * fix FIXMEs
+;;
+;; * clean split/merge of bass/banter/american stuff
+;;
+;; * 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")))
+ (((0 . 0) (3 . 0) (4 . 0)) . ("" (super "4") " " ))
;; Cdim iso Cm5-
(((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
- ; Co iso Cm5-7-
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
+ ; URG: Simply C:m5-/maj7 iso Cdim maj7
+ (((0 . 0) (2 . -1) (4 . -1) (6 . 0)) . ("m" (super "5-/maj7" " ")))
+ ; URG: Simply C:m5-/7 iso Cdim7
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . ("m" (super "5-/7" " ")))
+ ; Co iso C:m5-/7-
+ (((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")))
+ (((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))
;;;;;;;;;;
+(define simple-super
+;; duh, no docstrings for
+;; "No real superscript, just raised and small"
+ '((raise . 1) (font-relative-size . -2)))
-
-(define (accidental->text acc)
+(define (accidental->textp acc pos)
(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))))
+ (list '(music (font-relative-size . -2))
+ (list pos (string-append "accidentals-" (number->string acc))))))
+(define (accidental->text acc) (accidental->textp acc 'columns))
+(define (accidental->text-super acc) (accidental->textp acc 'simple-super))
+(define (accidental->text-sub acc) (accidental->textp acc 'sub))
(define (pitch->note-name pitch)
(cons (cadr pitch) (caddr pitch)))
(define (pitch->text pitch)
- (cons
- (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
+ (text-append
+ (list
+ '(font-relative-size . 2)
+ (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))))
(accidental->text-super (caddr pitch))))
(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))))
(define (pitch::note-pitch pitch)
(+ (* (car pitch) 7) (cadr pitch)))
-
-(define (write-me n x)
- (display n)
- (write x)
- (newline)
- x)
-
-(define (empty? x)
- (equal? x '()))
-
(define (chord::text? text)
(not (or (not text) (empty? text) (unspecified? text))))
-;; recursively remove '() #f, and #<unspecified> from 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)
(if (chord::text? dirty)
dirty
'())))
-
-(define (chord::text-append l . r)
+
+(define (text-append l . r)
(if (not (chord::text? r))
l
(if (not (chord::text? l))
r
- (cons l r))))
-
+ (if (empty? (cdr r))
+ (list 'columns l (car r))
+ (text-append (list 'columns l (car r)) (cdr r))))))
+
(define (chord::step tonic pitch)
(- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
(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
;; -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)))))
-
+(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 jazz needs 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)))
(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))
- '()))
+ (text-append
+ (let ((step (step->text-banter (car additions))))
+ (if (or (pair? (cdr additions))
+ (pair? subtractions))
+ (text-append step "/")
+ step))
+ (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)))
- '()))
-
+ (text-append
+ '("no")
+ (let ((step (step->text-jazz (car subtractions))))
+ (if (pair? (cdr subtractions))
+ (text-append step "/")
+ step))
+ (chord::subtractions->text-banter (cdr subtractions)))
+ '()))
(define (chord::bass-and-inversion->text-banter bass-and-inversion)
(if (and (pair? bass-and-inversion)
(pitch->note-name-text-banter
(car bass-and-inversion))
(pitch->note-name-text-banter
- (cdr bass-and-inversion)))
- '())
- '()))
+ (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)
- ;; 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-banter additions subtractions)
- (chord::subtractions->text-banter subtractions)
- (chord::bass-and-inversion->text-banter bass-and-inversion)))))
+ (let* ((tonic-text (pitch->chord-name-text-banter tonic steps))
+ (except-text exception-part)
+ (sep-text (if (and (string-match "super" (format "~s" except-text))
+ (or (pair? additions)
+ (pair? subtractions)))
+ (list simple-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)))
+ (text-append
+ tonic-text except-text " " sep-text
+ ;;(list (list simple-super) adds-text subs-text)
+ (list (list '((raise . 1) (font-relative-size . -1))) adds-text subs-text)
+ b+i-text)))
(define (chord::name-banter tonic exception-part unmatched-steps
bass-and-inversion steps)
bass-and-inversion steps)))
(define (chord::restyle name style)
- (ly-eval (string->symbol
+ (primitive-eval (string->symbol
(string-append (symbol->string name)
(symbol->string style)))))
(define (chord::exceptions-lookup-helper
exceptions-alist try-steps unmatched-steps exception-part)
(if (pair? try-steps)
- ;; FIXME: junk '(0 . 0) from exceptions lists
+ ;; 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
'())))
(chord::name->text style (car pitches) steps bass-and-inversion)))
-
-
;;;
;;; American style
;;;
;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)) . ("" (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 . -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 . 1.1) (font-relative-size . -2)) "/") "7")) ; slashed o
+ ;; slashed o
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") " " "7"))
(((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"))
+ (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (columns "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
+ (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
(((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
;; Common ninth chords
(((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
;;
;; This is getting out-of hand? Only exceptional chord names that
;; cannot be generated should be here.
-;; Maybe we should have inner-jazz-name and inner-american-name functions;
+;; Maybe we should have inner-name-jazz and inner-name-american functions;
;;
;;
;;
;; minor chords
; minor sixth chord = m6
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (rows("m")((raise . 0.5) "6")))
+ (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (columns("m")((raise . 0.5) "6")))
;; minor major seventh chord = m triangle
;; shouldn't this be a filled black triange, like this: ? --jcn
- ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (rows ("m") ((raise . 0.5)((font-family . math) "N"))))
- (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (rows ("m") ((raise . 0.5)((font-family . math) "M"))))
+ ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
+ (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
; minor seventh chord = m7
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (rows("m")((raise . 0.5) "7")))
+ (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (columns("m")((raise . 0.5) "7")))
; minor sixth nine chord = m6/9
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "6/9")))
+ (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "6/9")))
; minor with added nine chord = madd9
- (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "add9")))
+ (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "add9")))
; minor ninth chord = m9
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (rows("m")((raise . 0.5) "9")))
+ (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (columns("m")((raise . 0.5) "9")))
;; dominant chords
; dominant seventh = 7
(((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (((raise . 0.5) "7")))
; augmented dominant = +7
;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised
- (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (rows("+")((raise . 0.5) "7"))) ; +7 with 7 raised
- ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (rows((raise . 0.5) "7(")
+ (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns("+")((raise . 0.5) "7"))) ; +7 with 7 raised
+ ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns((raise . 0.5) "7(")
; ((raise . 0.3)(music (named ("accidentals-1"))))
; ((raise . 0.5) "5)"))); 7(#5)
; dominant flat 5 = 7(b5)
- (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows((raise . 0.5) "7(")
+ (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns((raise . 0.5) "7(")
((raise . 0.3)(music (named ("accidentals--1"))))
((raise . 0.5) "5)")))
; dominant 9 = 7(9)
;; half diminshed chords
;; 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
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") " " "7")) ; slashed o
; half diminished seventh chord with major 9 = slashed o cancelation 9
(((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
chord::names-alist-american))
(define (step->text-alternate-jazz pitch)
- (cons
+ (text-append
(accidental->text (caddr pitch))
- (list (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8))))))
+ (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))
(define (step->text-jazz pitch)
(if (= (cadr pitch) 6)
(case (caddr pitch)
;; sharp 7 only included for completeness?
- ((-2) (cons (accidental->text -1) '("7")))
+ ((-2) (text-append (accidental->text -1) '("7")))
((-1) '("7"))
((0) '("maj7"))
- ((1) (cons (accidental->text-super 1) '("7")))
- ((2) (cons (accidental->text-super 2) '("7"))))
+ ((1) (text-append (accidental->text-super 1) '("7")))
+ ((2) (text-append (accidental->text-super 2) '("7"))))
(step->text-alternate-jazz pitch)))
-(define (chord::additions->text-jazz additions subtractions)
+(define (xchord::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))
- '()))
+ (text-append
+ (let ((step (step->text-jazz (car additions))))
+ (if (or (pair? (cdr additions))
+ (pair? subtractions))
+ (text-append step "/")
+ step))
+ (chord::additions->text-jazz (cdr additions) subtractions))
+ '()))
+
+(define (chord::>5? x)
+ (or (> (car x) 0)
+ (> (cadr x) 4)))
+
+
+;; FIXME:
+;; Perhaps all logic like this should be done earlier,
+;; so that in this text-construction printing phase
+;; we can just blindly create text from all additions.
+;;
+;; This depends maybe on the fact of code sharing,
+;; in this layout, we can share the functions chord::additions
+;; and chord::subtractions with banter.
+(define (chord::additions->text-jazz additions subtractions)
+ (text-append
+ (chord::additions<=5->text-jazz (filter-out-list chord::>5? additions)
+ (filter-out-list chord::>5? subtractions))
+ (chord::additions>5->text-jazz (filter-list chord::>5? additions)
+ (filter-list chord::>5? subtractions))))
+
+;; FIXME
+(define (chord::additions<=5->text-jazz additions subtractions)
+ (let ((sus (chord::sus-four-jazz additions)))
+ (if (pair? sus)
+ (text-append '("sus") (step->text-jazz (car sus)))
+ '())))
+
+(define (chord::additions>5->text-jazz additions subtractions)
+ "
+Compose text of all additions
+
+ * if there's a subtraction:
+ - add `add'
+ - list all up to highest
+ * list all steps that are below an chromatically altered step
+ "
+ (text-append
+ (if (not (empty? subtractions)) "add" '())
+ (let ((radds (reverse additions)))
+ (reverse (chord::additions>5->text-jazz-helper
+ radds
+ subtractions
+ (if (or (empty? subtractions) (empty? radds))
+ #f (car radds)))))))
+
+(define (chord::additions>5->text-jazz-helper additions subtractions list-step)
+ "
+Create texts for all additions
+If list-step != #f, list all steps down to 5
+If we encounter a chromatically altered step, turn on list-step
+"
+
+ (if list-step
+ (if (not (member list-step subtractions))
+ (if (> 5 (cadr list-step))
+ (cons (step->text-jazz list-step)
+ (chord::additions>5->text-jazz-helper
+ additions
+ subtractions
+ (chord::get-create-step additions
+ (- (cadr list-step) 2))))
+ (step->text-jazz list-step))
+ (chord::get-create-step additions (- (cadr list-step) 2)))
+ (if (pair? additions)
+ (let ((step (car additions)))
+ (cons (step->text-jazz step)
+ (chord::additions>5->text-jazz-helper
+ (cdr additions)
+ subtractions
+ (if (or (and (!= 6 (cadr step)) (!= 0 (caddr step)))
+ (and (= 6 (cadr step)) (!= -1 (caddr step))))
+ (chord::get-create-step additions (- (cadr step) 2))
+ #f))))
+ '())))
+(define (chord::sus-four-jazz chord-pitches)
+ "List of pitches that are step 2 or step 4"
+ (filter-list (lambda (x)
+ (and (= 0 (car x))
+ (or (= 1 (cadr x)) (= 3 (cadr x))))) chord-pitches))
+
+(define (chord::get-create-step steps n)
+ (let* ((i (if (< n 0) (+ n 7) n))
+ (found (filter-list (lambda (x) (= i (cadr x))) steps)))
+ (if (empty? found)
+ (if (!= i 6)
+ (list 0 i 0)
+ (list 0 6 -1))
+ (car found))))
+
(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)))
- '()))
+ (text-append
+ (if (= 5 (cadr (car subtractions)))
+ (text-append
+ '("omit")
+ (let ((step (step->text-jazz (car subtractions))))
+ (if (pair? (cdr subtractions))
+ (text-append step "/")
+ step)))
+ '())
+ (chord::subtractions->text-jazz (cdr subtractions)))
+ '()))
;; TODO: maybe merge with inner-name-banter
;; 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)))))
+ (text-append
+ (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)))
+ (list simple-super "/"))
+
+ (list `(,simple-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
+;;
+;; 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))
bass-and-inversion steps)))
;; wip (set! chord::names-alist-jazz
-(define amy-chord::names-alist-jazz
+(define chord::names-alist-jazz
(append
'(
(((0 . 0) (2 . -1)) . ("m"))
+
+ ;; some fixups -- jcn
+ ; major seventh chord = triangle
+ (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
+ ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "M"))))
+
+ ;; minor major seventh chord = m triangle
+ (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
+ ;; (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
+
)
+ ;; '()))
chord::names-alist-american))
projects / lilypond.git / blobdiff