)
-;; debugging.
-(define (mydisplay x) (display x) x)
+(define (write-me x)
+ "Write and return X. For debugging purposes. "
+ (write x) (newline) x)
+
+;(define (dbg x) (write-me x))
+(define (dbg x) x)
+
+;;(define (write-me x) (write x) (newline) x)
+;;(define (write-me-2 x y) (write "FOO") (write x) (write y) (newline) y)
"
TODO:
-- Use lilypond Pitch objects -- SCM pitch objects lead to
-duplication. LilyPond pitch objects force meaningful names
-(i.e. (ly:pitch-octave PITCH) )
+ * Use lilypond Pitch objects -- SCM pitch objects lead to
+ duplication. LilyPond pitch objects force meaningful names
+ (i.e. (ly:pitch-octave PITCH) )
-- Pitches are musical objects. The pitches -> markup step should
+ * Pitches are musical objects. The pitches -> markup step should
happen earlier (during interpreting), brew-molecule () should only
-dump reinterpret the markup as a molecule. " ; "
+dump reinterpret the markup as a molecule.
+ * chord:: prefix is a poor-man's namespace device.
+ We have a module system to prevent export to userland.
+ Nested functions can take care of many other clashes. --hwn.
-;; pitch = (octave notename alteration)
-;;
-;; note = (notename . alteration)
-;;
-;; text = scm markup text -- see font.scm and input/test/markup.ly
+ * 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)
-;; TODO
+ * clean split/merge of bass/banter/american stuff.
+ GET RID OF code duplication.
-;; Ugh : naming chord::... ; this is scheme not C++
-;;
-;; * 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
+ * fix FIXMEs
+
+ * doc strings
+
+"
+
+;; " hey Emacs: string has ended
+
+
+;; pitch = (octave notename alteration)
;;
-;; * clean split/merge of bass/banter/american stuff
+;; note = (notename . alteration)
;;
-;; * doc strings
+;; markup = markup text -- see font.scm and input/test/markup.ly
-(define chord::names-alist-banter
+
+(define-public chord::exception-alist-banter
`(
; C iso C.no3.no5
(((0 . 0)) . ,empty-markup)
; C iso C.no5
(((0 . 0) (2 . 0)) . ,empty-markup)
; Cm iso Cm.no5
- (((0 . 0) (2 . -1)) . (,simple-markup "m"))
+ (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
; C2 iso C2.no3
- (((0 . 0) (1 . 0) (4 . 0)) . (,super-markup (,simple-markup "2 ")))
+ (((0 . 0) (1 . 0) (4 . 0))
+ . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
; C4 iso C4.no3
- (((0 . 0) (3 . 0) (4 . 0)) . (,super-markup (,simple-markup "4 ")))
+ (((0 . 0) (3 . 0) (4 . 0))
+ . ,(make-normal-size-super-markup (make-simple-markup "4 ")))
;; Cdim iso Cm5-
- (((0 . 0) (2 . -1) (4 . -1)) . (,simple-markup "dim"))
+ (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim"))
; URG: Simply C:m5-/maj7 iso Cdim maj7
- (((0 . 0) (2 . -1) (4 . -1) (6 . 0)) . (,line-markup ((,simple-markup "m") (,super-markup (,simple-markup "5-/maj7 ")))))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . 0))
+ . ,(make-line-markup
+ (list
+ (make-simple-markup "m")
+ (make-normal-size-super-markup (make-simple-markup "5-/maj7 ")))))
; URG: Simply C:m5-/7 iso Cdim7
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (,line-markup ((,simple-markup "m") (,super-markup (,simple-markup "5-/7 ")))))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -1))
+ . ,(make-line-markup
+ (list
+ (make-simple-markup "m")
+ (make-normal-size-super-markup (make-simple-markup "5-/7 ")))))
; Co iso C:m5-/7-
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (,super-markup (,simple-markup "o ")))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -2))
+ . ,(make-super-markup (make-simple-markup "o")))
; Cdim9
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . (,line-markup ((,simple-markup "dim")
- (,simple-markup "9 "))))
+ (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1))
+ . ,(make-line-markup
+ (list (make-simple-markup "dim")
+ (make-normal-size-super-markup (make-simple-markup "9 ")))))
(((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
- . (,line-markup ((,simple-markup "dim")
- (,super-markup (,simple-markup "11 ")))))
+ . ,(make-line-markup
+ (list (make-simple-markup "dim")
+ (make-normal-size-super-markup
+ (make-simple-markup "11 ")))))
))
-;;;;;;;;;;
-
+; pitch->note-name: drops octave
(define (pitch->note-name pitch)
(cons (cadr pitch) (caddr pitch)))
-(define (accidental-markup acc)
+(define (accidental->markup acc)
"ACC is an int, return a markup making an accidental."
+ (if (= acc 0)
+ (make-line-markup (list empty-markup))
+ (make-smaller-markup (make-musicglyph-markup
+ (string-append "accidentals-"
+ (number->string acc))))))
+
+; unused.
+(define (accidental->markupp acc pos)
+
(if (= acc 0)
empty-markup
- `(,smaller-markup (,musicglyph-markup ,(string-append "accidentals-" (number->string acc))))
- ))
+ (let ((acc-markup (make-musicglyph-markup
+ (string-append "accidentals-"
+ (number->string acc)))))
+
+ (if (equal? pos 'columns)
+ (make-line-markup (list (make-smaller-markup acc-markup)))
+ (if (equal? pos 'super)
+ (make-line-markup (list (make-super-markup acc-markup)))
+ ;; not 'super or 'columns must be 'sub...
+ (make-line-markup (list (make-sub-markup acc-markup))))))))
+
+
+; unused.
+
+;; FIXME: possibly to be used for american/jazz style
+;; However, only pos == columns is used, which seems to do
+;; exactly what accidental->markup does...
+(define (amy-accidental->text acc) (accidental->textp acc 'columns))
+
+;; These not used
+;;;(define (accidental->text-super acc) (accidental->textp acc 'simple-super))
+;;(define (accidental->text-super acc) (accidental->textp acc 'super))
+;;(define (accidental->text-sub acc) (accidental->textp acc 'sub))
+
+
+;;
+;; TODO: invent sensible way to make note name tweaking possible?
+;;
(define (pitch->markup pitch)
- `(,line-markup
- (
- (,simple-markup
- ,(make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))))
- (,normal-size-superscript-markup
- ,(accidental-markup (caddr pitch))))))
+ (make-line-markup
+ (list
+ (make-simple-markup
+ (vector-ref #("C" "D" "E" "F" "G" "A" "B") (cadr pitch)))
+ (make-normal-size-super-markup
+ (accidental->markup (caddr pitch))))))
;;; Hooks to override chord names and note names,
;;; see input/tricks/german-chords.ly
((2) "++"))))
(define (step->markup-banter pitch)
- (list simple-markup
- (if (= (cadr pitch) 6)
- (case (caddr pitch)
- ((-2) "7-")
- ((-1) "7")
- ((0) "maj7")
- ((1) "7+")
- ((2) "7+"))
- (step->markup pitch))))
+ (make-simple-markup
+ (if (= (cadr pitch) 6)
+ (case (caddr pitch)
+ ((-2) "7-")
+ ((-1) "7")
+ ((0) "maj7")
+ ((1) "7+")
+ ((2) "7+"))
+ (step->markup pitch))))
+
+(define (step->markup-previously-alternate-jazz pitch)
+ (make-line-markup
+ (list
+ (accidental->markup (caddr pitch))
+ (make-simple-markup
+ (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
+
+(define (step->markup-previously-jazz pitch)
+ (if (= (cadr pitch) 6)
+ (case (caddr pitch)
+ ;; sharp 7 only included for completeness?
+ ((-2) (make-line-markup
+ (list
+ (accidental->markup -1)
+ (make-simple-markup "7"))))
+ ((-1) (make-simple-markup "7"))
+ ((0) (make-simple-markup "maj7"))
+ ;;((0) (make-line-markup
+ ;; (list (make-simple-markup "maj7"))))
+ ((1) (make-line-markup
+ (list
+ (accidental->markup 1) (make-simple-markup "7"))))
+ ((2) (make-line-markup
+ (list (accidental->markup 1)
+ (make-simple-markup "7")))))
+ (step->markup-previously-alternate-jazz pitch)))
+
(define pitch::semitone-vec #(0 2 4 5 7 9 11))
(define (pitch::note-pitch pitch)
(+ (* (car pitch) 7) (cadr pitch)))
-;; markup: list of word
-;; word: string + optional list of property
-;; property: axis, kern, font (?), size
-(define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
+; what's this?
+(define chord::minor-major-vec #(0 -1 -1 0 -1 -1 0))
;; FIXME: unLOOP
;; compute the relative-to-tonic pitch that goes with 'step'
(define (chord::additions->markup-banter additions subtractions)
(if (pair? additions)
- (list line-markup
- (list
- (let ((step (step->markup-banter (car additions))))
- (if (or (pair? (cdr additions))
- (pair? subtractions))
- (list line-markup
- (list step (list simple-markup "/")))
- step))
-
- (chord::additions->markup-banter (cdr additions) subtractions)))
- empty-markup
- ))
-
-(define (chord::subtractions->markup-banter subtractions)
+ (make-line-markup
+ (list
+ (let ((step (step->markup-banter (car additions))))
+ (if (or (pair? (cdr additions))
+ (pair? subtractions))
+ (make-line-markup
+ (list step (make-simple-markup "/")))
+ step))
+ (chord::additions->markup-banter (cdr additions) subtractions)))
+ empty-markup))
+
+(define (chord::subtractions->markup-banter subtractions)
(if (pair? subtractions)
- `(,line-markup
- ((,simple-markup "no")
- ,(let ((step (step->markup-jazz (car subtractions))))
- (if (pair? (cdr subtractions))
- `(,line-markup (,step (,simple-markup "/")))
- step))
- ,(chord::subtractions->markup-banter (cdr subtractions))))
- empty-markup
- ))
+ (make-line-markup
+ (list
+ (make-simple-markup "no")
+ (let ((step (step->markup-previously-jazz
+ (car subtractions))))
+ (if (pair? (cdr subtractions))
+ (make-line-markup
+ (list step (make-simple-markup "/")))
+ step))
+ (chord::subtractions->markup-banter (cdr subtractions))))
+ empty-markup))
(define (chord::bass-and-inversion->markup-banter bass-and-inversion)
(if (and (pair? bass-and-inversion)
(or (car bass-and-inversion)
(cdr bass-and-inversion)))
- `(,line-markup
- (
- (,simple-markup "/")
- ,(pitch->note-name-markup-banter
- (if (car bass-and-inversion)
- (car bass-and-inversion)
- (cdr bass-and-inversion)))
- ))
- empty-markup
- ))
+ (make-line-markup
+ (list
+ (make-simple-markup "/")
+ (pitch->note-name-markup-banter
+ (if (car bass-and-inversion)
+ (car bass-and-inversion)
+ (cdr bass-and-inversion)))))
+ empty-markup))
;; FIXME: merge this function with inner-name-jazz, -american
;; iso using chord::bass-and-inversion->markup-banter,
-;; call (chord::restyle 'chord::bass-and-inversion->markup- style)
;; See: chord::exceptions-lookup
(define (chord::inner-name-banter tonic exception-part additions subtractions
bass-and-inversion steps)
-
"
Banter style
"
(let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
- (except-markup
-
- ;; see below.
- (if exception-part exception-part `(,simple-markup "fixme")))
- (sep-markup (list simple-markup
- (if (and (string-match "super" (format "~s" except-markup))
- (or (pair? additions)
- (pair? subtractions)))
- "/" "")
- ))
+ (except-markup (if exception-part exception-part empty-markup))
+ ;; UGR. How do we know if we should add a separator or not?
+ ;; maybe just add extra column to exception list?
+ (sep-markup (if (and exception-part
+ (let ((s (format "~s" except-markup)))
+ (and
+ (string-match "super" s)
+ ;; ugh ugh
+ ;; python: `except_markup`[-5:] != '"o"))'
+ (not (equal?
+ "\"o\"))"
+ (substring s
+ (- (string-length s) 5))))))
+ (or (pair? additions)
+ (pair? subtractions)))
+ (make-super-markup (make-simple-markup "/"))
+ empty-markup))
(adds-markup (chord::additions->markup-banter additions subtractions))
(subs-markup (chord::subtractions->markup-banter subtractions))
- (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
+ (b+i-markup (chord::bass-and-inversion->markup-banter
+ bass-and-inversion)))
- `(,line-markup
- (,tonic-markup
- ,except-markup
- ,sep-markup
- (,raise-markup 0.3
- (,line-markup (,adds-markup ,subs-markup))
- )
- ,b+i-markup
- ))
- ))
+ (make-line-markup
+ (list
+ tonic-markup
+ except-markup
+ sep-markup
+ (make-normal-size-super-markup
+ (make-line-markup (list adds-markup subs-markup)))
+ b+i-markup))))
(define (c++-pitch->scm p)
(if (ly:pitch? p)
(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-module (current-module))
-(define (chord::restyle name style)
- ;; "UGGHGUGHUGHG"
- (eval
- (string->symbol
- (string-append (symbol->string name)
- (symbol->string style)))
- chord-module
- ))
-
-
-;; this is unintelligible.
-;;
-
-;
-; - what's a helper, and why isn't it inside another function?
-;
-; what is going out, what is coming in, howcome it produces #f
-; in some cases?
-;
-
-(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)
+ (let ((additions (chord::additions unmatched-steps))
+ (subtractions (chord::subtractions unmatched-steps)))
+
+ (chord::inner-name-banter tonic exception-part additions subtractions
+ bass-and-inversion 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)))
;; see above.
-
-(define (chord::exceptions-lookup style steps)
+(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
+ exception-alist try-steps unmatched-steps exception-part)
+ "
+
+ check exception-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))
+ exception-alist)))
+ (if entry
+ (chord::exceptions-lookup-helper
+ #f '() unmatched-steps (cdr entry))
+ (let ((r (reverse try-steps)))
+ (chord::exceptions-lookup-helper
+ exception-alist
+ (reverse (cdr r))
+ (cons (car r) unmatched-steps) #f))))
+ (cons exception-part unmatched-steps)))
(let* ((result (chord::exceptions-lookup-helper
- (chord::restyle 'chord::names-alist- style)
+ exceptions
steps '() #f))
(exception-part (car result))
(unmatched-steps (cdr result))
(list exception-part unmatched-with-1-3-5)))
-(define (chord::name->markup style tonic steps bass-and-inversion)
- (let* ((lookup (chord::exceptions-lookup style steps))
- (exception-part (car lookup))
- (unmatched-steps (cadr lookup))
- (func (chord::restyle 'chord::name- style))
- )
-
- (func 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-public (chord->markup 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->markup 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,
-;; such as maj7, maj9, etc.
-;;
;; See input/test/american-chords.ly
;;
-;; James Hammons, <jlhamm@pacificnet.net>
-;;
+;; 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)
+ (make-line-markup
+ (list
+ (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::exception-alist-american
+ `(
+ (((0 . 0)) . ,empty-markup)
+ (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
+
+ ;; these should probably be normal-size? --jcn
+ ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
+ ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
+
+ (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
+ (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-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 chord::names-alist-american
-
- `(
- (((0 . 0)) . ,empty-markup)
- (((0 . 0) (2 . 0)) . ,empty-markup)
- ;; Root-fifth chord
- (((0 . 0) (4 . 0)) . (,simple-markup "5"))
- ;; Common triads
- (((0 . 0) (2 . -1)) . (,simple-markup "m"))
- (((0 . 0) (3 . 0) (4 . 0)) . (,simple-markup "sus"))
- (((0 . 0) (2 . -1) (4 . -1)) . (,simple-markup "dim"))
-;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
- (((0 . 0) (2 . 0) (4 . 1)) . (,simple-markup "aug"))
-;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
- (((0 . 0) (1 . 0) (4 . 0)) . (,simple-markup "2"))
- ;; Common seventh chords
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .
- (,line-markup
- ((,super-markup (,simple-markup "o"))
- (,simple-markup " 7"))))
- (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (,simple-markup "maj7"))
- ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!!
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (,simple-markup "m7"))
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (,simple-markup "7"))
- (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (,simple-markup "m(maj7)"))
- ;jazz: the delta, see jazz-chords.ly
- ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super ((font-family . math) "N"))
- ;; slashed o
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) .
- (,line-markup
- ((,super-markup
- (,combine-markup (,simple-markup "o")
- (,simple-markup "/")))
- (,simple-markup " 7"))))
- (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . (,simple-markup "aug7"))
- (((0 . 0) (2 . 0) (4 . -1) (6 . 0))
- . (,line-markup
- ((,simple-markup "maj7")
- (,small-markup (,raise-markup 0.2 ,(accidental-markup -1)))
- (,simple-markup "5"))))
- (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) .
- (,line-markup
- ((,simple-markup "7")
- (,small-markup (,raise-markup 0.2 ,(accidental-markup -1)))
- (,simple-markup "5"))))
- (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . (,simple-markup "7sus4"))
- ;; Common ninth chords
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (,simple-markup "6/9")) ;; we don't want the '/no7'
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (,simple-markup "6"))
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (,simple-markup "m6"))
- (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (,simple-markup "add9"))
- (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . (,simple-markup "maj9"))
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (,simple-markup "9"))
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (,simple-markup "m9"))
-
- ))
-
-;; American style chordnames use no "no",
-;; but otherwise very similar to banter for now
-(define-public (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
-;;;
-
-
+(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))
+ ;; UGR. How do we know if we should add a separator or not?
+ ;; maybe just add extra column to exception list?
+ (sep-markup (if (and exception-part
+ (let ((s (format "~s" except-markup)))
+ (and
+ (string-match "super" s)
+ ;; ugh ugh
+ ;; python: `except_markup`[-7:] != '"o"))'
+ (not (equal?
+ "\"o\"))))"
+ (substring s
+ (- (string-length s) 7))))))
+ (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)))
+ (make-line-markup
+ (list
+ tonic-markup except-markup sep-markup
+ (make-normal-size-super-markup
+ (make-line-markup (list pref-markup suff-markup)))
+ b+i-markup))))
+
+(define (chord::additions-american steps)
+ (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
+ ;we let all the unevens pass for now, we'll fix that later.
+ (unevens
+ (filter-list (lambda (x)
+ (let ((n (cadr x)) (a (caddr x)))
+ (or (and (= 6 n) (!= -1 a))
+ (and (< 3 n)
+ (= 0 (modulo n 2))))))
+ steps))
+ (highest (let ((h (car (last-pair steps))))
+ (if (and (not (null? h))
+ (or (> 4 (cadr h))
+ (!= 0 (caddr h))))
+ (list (list h))
+ '()))))
+ (uniq-list (sort (apply append evens unevens highest)
+ pitch::<))))
+ ;; American style chordnames use no "no",
+ ;; but otherwise very similar to banter for now
+ (define-public (chord::name-american tonic exception-part unmatched-steps
+ bass-and-inversion steps)
+ (let ((additions (chord::additions-american unmatched-steps))
+ (subtractions (chord::subtractions unmatched-steps)))
+ (chord::inner-name-american 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 bass.
-;; Some defs take up more than one line,
-;; be carefull when messing with ;'s!!
-
-
-;; FIXME
-;;
-;; This is getting out-of hand? Only exceptional chord names that
-;; cannot be generated should be here.
-;; Maybe we should have inner-name-jazz and inner-name-american functions;
-;;
-;;
-;;
-;; DONT use non-ascii characters, even if ``it works'' in Windows
-
-(define mathm-markup-object `(,override-markup (font-family . math) (,simple-markup "M")))
-(define mraise-arg `(,line-markup
- ((,simple-markup "m")
- (,raise-markup 0.5 (,simple-markup arg)))))
-
-(define (raise-some-for-jazz arg-list)
- (define (do-one x)
- (case x
- ("@" `(,raise-markup 0.3 ,(accidental-markup -1)))
- ("#" `(,raise-markup 0.3 ,(accidental-markup 1)))
- (else `(,raise-markup 0.8 ,x))))
-
- `(line-markup ,(map do-one arg-list)))
-
-(define chord::names-alist-jazz
- (append
- '(
- ;; major chords
- ; major sixth chord = 6
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) .
- (,raise-markup 0.5 (,simple-markup "6")))
- ; major seventh chord = triangle
- ;; shouldn't this be a filled black triange, like this: ? --jcn
- ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
- (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .
- (,raise-markup
- 0.5
- ,mathm-markup-object
- ))
-
- ; major chord add nine = add9
- (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (,raise-markup 0.5 (,simple-markup "add9")))
- ; major sixth chord with nine = 6/9
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (,raise-markup 0.5 (,simple-markup "add9")))
-
- ;; minor chords
- ; minor sixth chord = m6
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) .
- ,(mraise-arg "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)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
- (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) .
- (,line-markup ((,simple-markup "m") ,mathm-markup-object)))
- ; minor seventh chord = m7
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ,(mraise-arg "7"))
- ; minor sixth nine chord = m6/9
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . ,(mraise-arg "6/9"))
-
- ; minor with added nine chord = madd9
- (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . ,(mraise-arg "madd9"))
-
- ; minor ninth chord = m9
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ,(mraise-arg "add9"))
-
- ;; dominant chords
- ; dominant seventh = 7
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (,raise-markup 0.5 (,simple-markup "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)) .
- (,line-markup ((,simple-markup "+")
- (,raise-markup 0.5 (,simple-markup "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)) . ,(raise-some-for-jazz '( "7(" "@" "5)" )))
-
- ; dominant 9 = 7(9)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) .
- ,(raise-some-for-jazz '("7(9)")))
- ; dominant flat 9 = 7(b9)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) .
- ,(raise-some-for-jazz '("7(" "@" "9)")))
-
- ; dominant sharp 9 = 7(#9)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) .
- ,(raise-some-for-jazz '("7(" "#" "9)")))
-
- ; dominant 13 = 7(13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) .
- ,(raise-some-for-jazz "7(13)"))
- ; dominant flat 13 = 7(b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) .
- ,(raise-some-for-jazz '( "7(" "@" "13)")))
-
- ; dominant 9, 13 = 7(9,13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) .
- ,(raise-some-for-jazz '("7(9, 13)")))
- ; dominant flat 9, 13 = 7(b9,13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) .
- ,(raise-some-for-jazz '("7(" "@" "9, 13)")))
-
- ; dominant sharp 9, 13 = 7(#9,13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) .
- ,(raise-some-for-jazz '("7(" "#" "9,13)")))
-
- ; dominant 9, flat 13 = 7(9,b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) .
- ,(raise-some-for-jazz "7(9, " "@" "13)"))
-
- ; dominant flat 9, flat 13 = 7(b9,b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) .
- ,(raise-some-for-jazz '("7(" "@" "9, " "@" "13)")))
-
- ; dominant sharp 9, flat 13 = 7(#9,b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) .
- ,(raise-some-for-jazz '("7(" "#" "9, " "@" "13)")))
-
- ;; diminished chord(s)
- ; diminished seventh chord = o
-
-
- ;; DONT use non-ascii characters, even if ``it works'' in Windows
-
- ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .
- (,super-markup (,simple-markup "o")))
-
- ;; 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)) .
- (,line-markup (,super-markup
- (,combine-markup (,simple-markup "o") (,simple-markup "/")))
- (,simple-markup " 7")))
- ; half diminished seventh chord with major 9 = slashed o cancelation 9
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) .
- ,(raise-some-for-jazz '("/o(" "!" "9)")))
-
-;; Missing jazz chord definitions go here (note new syntax: see american for hints)
-
- )
- chord::names-alist-american))
-
-(define (step->markup-alternate-jazz pitch)
- `(,line-markup
- (,(accidental-markup (caddr pitch))
- (,simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
+;; Complete rewrite by Amelie Zapf (amy@loueymoss.com)
+
+;; FIXME: identical to chord::exception-alist-american, apart from commented
+;; dim chord. should merge.
+(define-public chord::exception-alist-jazz
+ `(
+ (((0 . 0)) . ,empty-markup)
+ (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
+
+ ;; these should probably be normal-size? --jcn
+ ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
+ ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
+
+ (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
+ (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-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 (make-simple-markup "") (make-super-markup (make-simple-markup "o")))))
+ ))
+;; FIXME: rather similar to step->markup-american. should merge.
(define (step->markup-jazz pitch)
- (if (= (cadr pitch) 6)
- (case (caddr pitch)
- ;; sharp 7 only included for completeness?
- ((-2) `(,line-markup
- (
- (,(accidental-markup -1)
- (,simple-markup "7"))
- )))
- ((-1) `(,simple-markup "7"))
- ((0) `(,simple-markup "maj7"))
- ((1) `(,line-markup
- (,(accidental-markup 1)
- (,simple-markup "7"))))
- ((2) `(,line-markup
- (,(accidental-markup 1)
- (,simple-markup "7"))))
- )
- (step->markup-alternate-jazz pitch)))
-
-(define (xchord::additions->markup-jazz additions subtractions)
- (if (pair? additions)
- (list line-markup
- (let ((step (step->markup-jazz (car additions))))
- (if (or (pair? (cdr additions))
- (pair? subtractions))
- (list step (list simple-markup "/"))
- (list step)))
- (chord::additions->markup-jazz (cdr additions) subtractions))
- empty-markup
- ))
-
-(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 markup-construction printing phase
-;; we can just blindly create markup 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.
+ (case (cadr pitch)
+ ((6) (case (caddr pitch)
+ ((-2) (make-line-markup (list (accidental->markup -1) (make-simple-markup "7"))))
+ ((-1) (make-simple-markup "7"))
+ ;;Pick your favorite maj7
+ ((0) mathm-markup-object) ;;a white triangle
+ ;;((0) mathn-markup-object) ;;a black triangle
+ ;;((0) (make-simple-markup "maj7")) ;;good old 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)))))
+
+;; FIXME: identical to chord::additions->markup-american,
+;; except for -jazz / -american suffixes on calls
(define (chord::additions->markup-jazz additions subtractions)
- ;; FIXME
- `(,line-markup
- (
- ,(chord::additions<=5->markup-jazz (filter-out-list chord::>5? additions)
- (filter-out-list chord::>5? subtractions))
- ,(chord::additions>5->markup-jazz (filter-list chord::>5? additions)
- (filter-list chord::>5? subtractions)))))
-
-
-
-;; FIXME
-(define (chord::additions<=5->markup-jazz additions subtractions)
- (let ((sus (chord::sus-four-jazz additions)))
- (if (pair? sus)
- `(,line-markup ((,simple-markup "sus")
- ,(step->markup-jazz (car sus))))
- empty-markup)
- ))
-
+ (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-jazz (cdr additions) subtractions)
+ (make-line-markup
+ (list
+ (let ((step (step->markup-jazz (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-jazz (cdr additions) subtractions))))
+ empty-markup))
+
+;; FIXME: identical to chord::additions->markup-american.
+;; except for -jazz / -american suffixes on calls
+(define (chord::inner-name-jazz 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))
+ ;; UGR. How do we know if we should add a separator or not?
+ ;; maybe just add extra column to exception list?
+ (sep-markup (if (and exception-part
+ (let ((s (format "~s" except-markup)))
+ (and
+ (string-match "super" s)
+ ;; ugh ugh
+ ;; python: `except_markup`[-7:] != '"o"))'
+ (not (equal?
+ "\"o\"))))"
+ (substring s
+ (- (string-length s) 7))))))
+ (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-jazz prefixes relevant-subs))
+ (suff-markup (chord::additions->markup-jazz suffixes relevant-subs))
+ (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
+ (make-line-markup
+ (list
+ tonic-markup except-markup sep-markup
+ (make-normal-size-super-markup
+ (make-line-markup (list pref-markup suff-markup)))
+ b+i-markup))))
+
+(define (chord::name-jazz tonic exception-part unmatched-steps
+ bass-and-inversion steps)
+ (let ((additions (chord::additions-american unmatched-steps))
+ (subtractions (chord::subtractions unmatched-steps)))
+ (chord::inner-name-jazz tonic exception-part additions subtractions
+ bass-and-inversion steps)))
-(define (chord::additions>5->markup-jazz additions subtractions)
- "
-Compose markup 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
- "
-
- `(,line-markup
- (,(if (not (null? subtractions))
- `(,simple-markup "add")
- empty-markup)
- ,(if #t
- ;; FIXME
- `(,simple-markup "fixme")
- ;; this is totally incomprehensible. Fix me, and docme.
- (let
- ((radds (reverse additions)))
-
- (reverse (chord::additions>5->markup-jazz-helper
- radds
- subtractions
- (if (or (null? subtractions) (null? radds))
- #f (car radds)))))
-
- )
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- )))
-
-(define (chord::additions>5->markup-jazz-helper additions subtractions list-step)
- "
-Create markups 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->markup-jazz list-step)
- (chord::additions>5->markup-jazz-helper
- additions
- subtractions
- (chord::get-create-step additions
- (- (cadr list-step) 2))))
- (step->markup-jazz list-step))
- (chord::get-create-step additions (- (cadr list-step) 2)))
- (if (pair? additions)
- (let ((step (car additions)))
- (cons (step->markup-jazz step)
- (chord::additions>5->markup-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 (null? found)
- (if (!= i 6)
- (list 0 i 0)
- (list 0 6 -1))
- (car found))))
+(define-public (new-chord->markup func ly-pitches bass inversion exceptions)
+ "Entry point for New_chord_name_engraver. See chord-name.scm for the
+signature of FUNC. LY-PITCHES, BASS and INVERSION are lily
+pitches. EXCEPTIONS is an alist (see scm file).
+ "
-(define (chord::subtractions->markup-jazz subtractions)
- (if (pair? subtractions)
- `(,line-markup
- (,(if (= 5 (cadr (car subtractions)))
- `(,line-markup
- ((,simple-markup "omit")
-
- ,(let
- ((step (step->markup-jazz (car subtractions))))
- (if (pair? (cdr subtractions))
- `(,line-markup ( step (,simple-markup "/")))
- step))))
- empty-markup)
- ,(chord::subtractions->markup-jazz (cdr subtractions))))
- empty-markup))
-
-;; 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)
- `(,line-markup
- (
- ,(pitch->chord-name-markup-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 super-markup (list simple-markup "/"))
- empty-markup
-
- )
-
- (,super-markup
- (,line-markup
- (
- ,(chord::additions->markup-jazz additions subtractions)
- ,(chord::subtractions->markup-jazz subtractions))))
-
- ,(chord::bass-and-inversion->markup-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-public (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)))
+ (let* ((pitches (map c++-pitch->scm ly-pitches))
+ (bass-and-inversion
+ (cons (c++-pitch->scm bass)
+ (c++-pitch->scm inversion)))
+ (diff (pitch::diff '(0 0 0) (car pitches)))
+ (steps (if (cdr pitches) (map (lambda (x)
+ (pitch::transpose x diff))
+ (cdr pitches))
+ '()))
+ (lookup (dbg (chord::exceptions-lookup exceptions steps)))
+ (exception-part (dbg (car lookup)))
+ (unmatched-steps (cadr lookup))
+ (tonic (car pitches))
+ )
-;; wip (set! chord::names-alist-jazz
-(define chord::names-alist-jazz
- (append
- `(
- (((0 . 0) (2 . -1)) . (,simple-markup "m"))
-
- ;; some fixups -- jcn
- ; major seventh chord = triangle
- (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .
- (,raise-markup 0.5 ,mathm-markup-object))
-
- ;; minor major seventh chord = m triangle
- (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) .
- (,line-markup ((,simple-markup "m")
- (,raise-markup 0.5 ,mathm-markup-object))))
- ;; (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
-
- )
- ;; '()))
- chord::names-alist-american))
+ (func tonic exception-part unmatched-steps bass-and-inversion steps)
+ ))
+
+(define-public (chord->markup-jazz . args)
+ (apply new-chord->markup (cons chord::name-jazz args))
+ )
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define-public (chord->markup-american . args)
+ (apply new-chord->markup (cons chord::name-american args))
+ )
+(define-public (chord->markup-banter . args)
+ (apply new-chord->markup (cons chord::name-banter args))
+ )
(define-public (new-chord-name-brew-molecule grob)
(let*
(
- (style-prop (ly:get-grob-property grob 'style))
- (style (if (symbol? style-prop) style-prop 'banter))
- (chord (ly:get-grob-property grob 'chord))
- (chordf (ly:get-grob-property grob 'chord-name-function))
(ws (ly:get-grob-property grob 'word-space))
- (markup (chordf style chord))
+ (markup (ly:get-grob-property grob 'text))
(molecule (interpret-markup grob
(cons '((word-space . 0.0))
(Font_interface::get_property_alist_chain grob))
markup))
)
-
- ;;; TODO: BUG : word-space is in local staff-space (?)
+ ;;
+ ;; chord names aren't in staffs, so WS is in global staff space.
(if (number? ws)
- (ly:combine-molecule-at-edge molecule
+ (ly:combine-molecule-at-edge
+ molecule
X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
0.0)
molecule)
- ))
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (set-chord-name-style sym)
+ "Return music expressions that set the chord naming style. For
+inline use in .ly file"
+
+ (define (chord-name-style-setter function exceptions)
+ (context-spec-music
+ (make-sequential-music
+ (list (make-property-set 'chordNameFunction function)
+ (make-property-set 'chordNameExceptions exceptions)))
+ "ChordNames"
+ )
+ )
+
+ (ly:export
+ (case sym
+ ((jazz)
+ (chord-name-style-setter chord->markup-jazz
+ chord::exception-alist-jazz))
+ ((banter)
+ (chord-name-style-setter chord->markup-banter
+ chord::exception-alist-banter))
+ ((american)
+ (chord-name-style-setter chord->markup-american
+ chord::exception-alist-american))
+
+ ((ignatzek)
+ (chord-name-style-setter ignatzek-chord-names
+ '()))
+ ((double-plus-new-banter)
+ (chord-name-style-setter double-plus-new-chord->markup-banter
+ chord::exception-alist-banter))
+
+ ((double-plus-new-jazz)
+ (chord-name-style-setter double-plus-new-chord->markup-jazz
+ chord::exception-alist-jazz))
+ )))
+
+;; can't put this in double-plus-new-chord-name.scm, because we can't
+;; ly:load that very easily.
+(define-public (set-double-plus-new-chord-name-style style options)
+ "Return music expressions that set the chord naming style. For
+inline use in .ly file"
+
+ (define (chord-name-style-setter function)
+ (context-spec-music
+ (make-sequential-music
+ (list (make-property-set 'chordNameFunction function)
+
+ ;; urg , misuse of chordNameExceptions function.
+ (make-property-set 'chordNameExceptions options)))
+ "ChordNames"))
+
+ (ly:export
+ (case style
+ ((banter)
+ (chord-name-style-setter double-plus-new-chord->markup-banter))
+
+ ((jazz)
+ (chord-name-style-setter double-plus-new-chord->markup-jazz)))))
projects / lilypond.git / blobdiff