- tonic-markup
- except-markup
- sep-markup
- (make-raise-markup
- 0.3
- (make-line-markup (list adds-markup subs-markup)))
- b+i-markup))))
-
-(define (c++-pitch->scm p)
- (if (ly:pitch? p)
- (list (ly:pitch-octave p) (ly:pitch-notename p) (ly: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)))
-
-
-;; see above.
-(define (chord::exceptions-lookup exceptions steps)
- "
- return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
- BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
-
-"
- ;; this is unintelligible.
- ;;
- (define (chord::exceptions-lookup-helper
- exceptions-alist try-steps unmatched-steps exception-part)
- "
-
- check exceptions-alist for biggest matching part of try-steps
- return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
-
-"
- (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)))
-
- (let* ((result (chord::exceptions-lookup-helper
- exceptions
- 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)))
-
-
-
-;;; American style
-;;;
-
-;; See input/test/american-chords.ly
-;;
-;; Original Version by James Hammons, <jlhamm@pacificnet.net>
-;; Complete rewrite by Amelie Zapf, <amy@loueymoss.com>
-
-;; DONT use non-ascii characters, even if ``it works'' in Windows
-
-;;a white triangle
-(define mathm-markup-object
- (make-override-markup '(font-family . math) (make-simple-markup "M")))
-
-;a black triangle
-(define mathn-markup-object
- (make-override-markup '(font-family . math) (make-simple-markup "N")))
-
-(define (step->markup-accidental pitch)
- (case (caddr pitch)
- ((-2) (accidental->markup -2))
- ((-1) (accidental->markup -1))
- ((0) empty-markup)
- ((1) (accidental->markup 1))
- ((2) (accidental->markup 2)))
- (make-simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))
-
-(define-public chord::names-alist-american
- `(
- (((0 . 0)) . ,empty-markup)
- (((0 . 0)) . ,empty-markup)
- (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
- (((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
- (((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
- ;;choose your symbol for the fully diminished chord
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
- ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list empty-markup (make-super-markup (make-simple-markup "o")))))
- ))
-
-(define (step->markup-american pitch)
- (case (cadr pitch)
- ((6) (case (caddr pitch)
- ((-2) (make-line-markup (list (accidental->markup -1) (make-simple-markup "7"))))
- ((-1) (make-simple-markup "7"))
- ((0) (make-simple-markup "maj7"))
- ((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "7"))))
- ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "7"))))))
- ((4) (case (caddr pitch)
- ((-2) (make-line-markup (list (accidental->markup -2) (make-simple-markup "5"))))
- ;;choose your symbol for the diminished fifth
- ((-1) (make-simple-markup "-5"))
- ;;((-1) (make-line-markup (list (accidental->markup -1) (make-simple-markup "5")))))
- ((0) empty-markup)
- ;;choose your symbol for the augmented fifth
- ;;((1) (make-simple-markup "aug"))
- ;;((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "5")))))
- ((1) (make-simple-markup "+5"))
- ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "5"))))))
- (else (if (and (= (car pitch) 0)
- (= (cadr pitch) 3)
- (= (caddr pitch) 0))
- (make-simple-markup "sus4")
- (step->markup-accidental pitch)))))
-
-(define (chord::additions->markup-american additions subtractions)
- (if (pair? additions)
- ;; I don't like all this reasoning here, when we're actually typesetting.
- (if(and(pair? (cdr additions)) ;a further addition left over
- (or(and(= 0 (caddr(car additions))) ;this addition natural
- (not(= 6 (cadr(car additions)))))
- (and(= -1 (caddr(car additions)))
- (= 6 (cadr(car additions)))))
- (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
- (not(= 6 (cadr(cadr additions)))))
- (and(= -1 (caddr(cadr additions)))
- (= 6 (cadr(cadr additions)))))
- (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
- (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
- (and(= 1 (- (car(cadr additions)) (car(car additions))))
- (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
- (or(null? subtractions) ;this or clause protects the "adds"
- (and (pair? subtractions)
- (or (< (car(cadr additions)) (car(car subtractions)))
- (and(= (car(cadr additions)) (car(car subtractions)))
- (< (cadr(cadr additions)) (cadr(car subtractions))))))))
- (chord::additions->markup-american (cdr additions) subtractions)
- (make-line-markup
- (list
- (let ((step (step->markup-american (car additions))))
- (if (or (pair? (cdr additions))
- (pair? subtractions))
- (if (and (pair? (cdr additions))
- (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
- (and(< 0 (- (car(cadr additions)) (car(car additions))))
- (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
- (make-line-markup (list step (make-simple-markup " add")))
- ;; tweak your favorite separator here
- ;; (make-line-markup (list step (make-simple-markup "/")))
- (make-line-markup (list step (make-simple-markup " "))))
- step))
- (chord::additions->markup-american (cdr additions) subtractions))))
- empty-markup))
-
-(define (chord::inner-name-american tonic exception-part additions subtractions
- bass-and-inversion steps)
- (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
- (except-markup (if exception-part exception-part empty-markup))
- (sep-markup (if (and (string-match "super" (format "~s" except-markup))
- (or (pair? additions)
- (pair? subtractions)))
- (make-super-markup (make-simple-markup "/"))
- empty-markup))
- ;;this list contains all the additions that go "in line"
- (prefixes
- (filter-list
- (lambda (x)
- (let ((o (car x)) (n (cadr x)) (a (caddr x)))
- (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
- ;;change this if you want it differently
- (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
- (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
- additions))
- ;;this list contains all the additions that are patched onto the end
- ;;of the chord symbol, usually sus4 and altered 5ths.
- (suffixes
- ;;take out the reverse if it bothers you in a pathological chord
- (reverse
- (filter-list
- (lambda (x)
- (let ((o (car x)) (n (cadr x)) (a (caddr x)))
- (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
- ;;change this correspondingly
- (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
- (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
- additions)))
- (relevant-subs (filter-list
- (lambda (x) ;catches subtractions higher than 5th
- (let((o (car x)) (n (cadr x)))
- (or (> o 0)
- (> n 4))))
- subtractions))
- (pref-markup (chord::additions->markup-american prefixes relevant-subs))
- (suff-markup (chord::additions->markup-american suffixes relevant-subs))
- (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))