From f26384366ad0f8715db53a7a78f3971f1233012d Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sat, 4 Jan 2003 02:22:14 +0000 Subject: [PATCH] * scm/chord-name.scm (set-chord-name-style): new function. (new-chord-name-brew-molecule): revise to interpret markup only (new-chord->markup): cleanuppish rewrite. To be called from the new engraver. * lily/new-chord-name-engraver.cc: new engraver: call Chord -> Markup earlier, during interpreting. * input/test/{banter,jazz,american}-chords.ly (scheme): update style settings. Rename to chord-names-*.ly --- ChangeLog | 16 +- input/test/american-chords.ly | 65 -- input/test/banter-chords.ly | 90 -- input/test/jazz-chords.ly | 69 -- lily/new-chord-name-engraver.cc | 129 +++ ly/engraver-init.ly | 9 +- scm/chord-name.scm | 1053 ++++++++++------------- scm/grob-description.scm | 2 +- scm/grob-property-description.scm | 1 - scm/translator-property-description.scm | 6 + 10 files changed, 586 insertions(+), 854 deletions(-) delete mode 100644 input/test/american-chords.ly delete mode 100644 input/test/banter-chords.ly delete mode 100644 input/test/jazz-chords.ly create mode 100644 lily/new-chord-name-engraver.cc diff --git a/ChangeLog b/ChangeLog index 6872ada4eb..9cd6beae4d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,6 +1,18 @@ -2002-12-30 Jan Nieuwenhuizen +2003-01-04 Han-Wen Nienhuys - * test. + * scripts/convert-ly.py (FatalConversionError.conv): add style + covnersion rule. + + * scm/chord-name.scm (set-chord-name-style): new function. + (new-chord-name-brew-molecule): revise to interpret markup only + (new-chord->markup): cleanuppish rewrite. To be called from the + new engraver. + + * lily/new-chord-name-engraver.cc: new engraver: call Chord -> + Markup earlier, during interpreting. + + * input/test/{banter,jazz,american}-chords.ly (scheme): update + style settings. Rename to chord-names-*.ly 2002-12-30 Juergen Reuter diff --git a/input/test/american-chords.ly b/input/test/american-chords.ly deleted file mode 100644 index 287066c091..0000000000 --- a/input/test/american-chords.ly +++ /dev/null @@ -1,65 +0,0 @@ -\version "1.7.6" -\header { - texidoc = "Chord names in american styles, according to one of our users. - - -FIXME - -" -} - -\include "english.ly" - - -%%FIXME: - -% DON'T do this in the test file, it messes up all other files in the directory. - -% #(set! chord::names-alist-american -% (append -% '( -% ;; any changes here, see scm/chord-name.scm -% ) -% chord::names-alist-american)) - -scheme = \chords { - c % Major triad - cs:m % Minor triad - df:m5- % Diminished triad - c:5^3 % Root-fifth chord - c:4^3 % Suspended fourth triad - c:5+ % Augmented triad - c:2^3 % "2" chord - c:m5-.7- % Diminished seventh - c:7+ % Major seventh - c:7.4^3 % Dominant seventh suspended fourth - c:5+.7 % Augmented dominant seventh - c:m5-.7 % "Half" diminished seventh - c:5-.7 % Dominant seventh flat fifth - c:5-.7+ % Major seventh flat fifth - c:m7+ % Minor-major seventh - c:m7 % Minor seventh - c:7 % Dominant seventh - c:6 % Major sixth - c:m6 % Minor sixth - c:9^7 % Major triad w/added ninth - c:6.9^7 % Six/Nine chord - c:9 % Dominant ninth - c:7+.9 % Major ninth - c:m7.9 % Minor ninth -} - -\score { - \notes < - \context ChordNames \scheme - \context Staff \transpose c c' \scheme - > - \paper { - \translator { - \ChordNamesContext - ChordName \override #'word-space = #1 - ChordName \override #'style = #'american - } - } -} -%% new-chords-done %% diff --git a/input/test/banter-chords.ly b/input/test/banter-chords.ly deleted file mode 100644 index 51539b3087..0000000000 --- a/input/test/banter-chords.ly +++ /dev/null @@ -1,90 +0,0 @@ -\version "1.7.6" - - -\header{ -texidoc = "banter chords - - -FIXME - -" -} - -% test German (Banter) naming -% for more conventional naming, comment scm stuff out - -% urg, -% this shows a serious shortcoming with our guile approach: -% we can't (easily) display banter/non banter chords alongside -% eachother. These guile lists are fixed in the guile environment -% when this file has been parsed... - -%{ - - -%% FIXME: - -#;(define chord::names-alist-banter '()) -#(set! chord::names-alist-banter - (append - '( - (((0 . 0) (2 . -1) (4 . -1)) . (("m" ("5-" . (type . "super"))))) - Co iso Cm5-7- - (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("o" (type "super"))) - ))) - -% German note names: -% Urg, this will break again, in time -% Is this correct, anyway? - -#(define (pitch->text pitch) - (if (and (= (modulo (cadr pitch) 7) 6) - (= (caddr pitch) -1)) - (cons (make-string 1 (integer->char 66)) '()) - (cons - (if (= (modulo (cadr pitch) 7) 6) - (make-string 1 (integer->char 72)) - (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))) - (if (= (caddr pitch) 0) - '() - (list (list (string-append "accidentals-" - (number->string (caddr pitch))) - '(font . "feta"))))))) - -%} - -chord = \notes\transpose c' c''\chords{ - % dim modifier means: lower all implicit additions - c:dim9 - c:dim - c:dim7 - % explicit additions are taken as entered: - c:m5-.7- - % note that 7 is a special case: it's always lowered by 1... - c:dim7-.9 - c:dim9-.11 - - % test German names - b:dim7 - bes:m5- - - \break - - c:sus2 %? - c:sus4 - c^3 - c^3.5 - c:2.6^5 - c:dim^5- - c:dim7^5- - cis:m5- -} - -\score{ - < - \context ChordNames \chord - \context Staff \chord - > -} - -%% new-chords-done %% diff --git a/input/test/jazz-chords.ly b/input/test/jazz-chords.ly deleted file mode 100644 index 7c6db2ad30..0000000000 --- a/input/test/jazz-chords.ly +++ /dev/null @@ -1,69 +0,0 @@ -\version "1.7.6" - - - -%% This should only be necessary if your kpathsea setup is broken -% -% Make sure the correct msamxx.tfm is where lily can find it -% (ie cwd or lily's tfm dir). -% -% For normal (20pt) paper, do -% -% cp locate `msam9.tfm` LILYPONDPREFIXxtfm -% - -scheme = \chords { - % major chords - c - c:6 % 6 = major triad with added sixth - c:maj % triangle = maj - c:6.9^7 % 6/9 - c:9^7 % add9 - - % minor chords - c:m % m = minor triad - c:m.6 % m6 = minor triad with added sixth - c:m.7+ % m triangle = minor major seventh chord - c:3-.6.9^7 % m6/9 - c:m.7 % m7 - c:3-.9 % m9 - c:3-.9^7 % madd9 - - % dominant chords - c:7 % 7 = dominant - c:7.5+ % +7 = augmented dominant - c:7.5- % 7b5 = hard diminished dominant - c:9 % 7(9) - c:9- % 7(b9) - c:9+ % 7(#9) - c:13^9.11 % 7(13) - c:13-^9.11 % 7(b13) - c:13^11 % 7(9,13) - c:13.9-^11 % 7(b9,13) - c:13.9+^11 % 7(#9,13) - c:13-^11 % 7(9,b13) - c:13-.9-^11 % 7(b9,b13) - c:13-.9+^11 % 7(#9,b13) - - % half diminished chords - c:m5-.7 % slashed o = m7b5 - c:9.3-.5- % o/7(pure 9) - - % diminished chords - c:m5-.7- % o = diminished seventh chord -} - -\score { - \notes < - \context ChordNames \scheme - \context Staff \transpose c c' \scheme - > - \paper { - \translator { - \ChordNamesContext - ChordName \override #'word-space = #1 - ChordName \override #'style = #'jazz - } - } -} -%% new-chords-done %% diff --git a/lily/new-chord-name-engraver.cc b/lily/new-chord-name-engraver.cc new file mode 100644 index 0000000000..e0be6ccf72 --- /dev/null +++ b/lily/new-chord-name-engraver.cc @@ -0,0 +1,129 @@ +/* + chord-name-engraver.cc -- implement New_chord_name_engraver + + source file of the GNU LilyPond music typesetter + + (c) 1998--2002 Jan Nieuwenhuizen +*/ + +#include "engraver.hh" +#include "chord-name.hh" +#include "chord.hh" +#include "event.hh" +#include "paper-def.hh" +#include "font-interface.hh" +#include "paper-def.hh" +#include "main.hh" +#include "dimensions.hh" +#include "item.hh" +#include "pitch.hh" +#include "protected-scm.hh" + +class New_chord_name_engraver : public Engraver +{ + TRANSLATOR_DECLARATIONS( New_chord_name_engraver); +protected: + virtual void stop_translation_timestep (); + virtual void process_music (); + virtual bool try_music (Music *); + +private: + void add_note (Music *); + + Item* chord_name_; + Link_array notes_; + + Protected_scm last_chord_; +}; + + + +New_chord_name_engraver::New_chord_name_engraver () +{ + chord_name_ = 0; + last_chord_ = SCM_EOL; +} + +void +New_chord_name_engraver::add_note (Music * n) +{ + notes_.push (n); +} + +void +New_chord_name_engraver::process_music () +{ + if (!notes_.size() ) + return; + + SCM bass = SCM_EOL; + SCM inversion = SCM_EOL; + SCM pitches = SCM_EOL; + + for (int i =0 ; i < notes_.size (); i++) + { + Music *n = notes_[i]; + SCM p = n->get_mus_property ("pitch");; + if (n->get_mus_property ("inversion") == SCM_BOOL_T) + inversion = p; + else if (n->get_mus_property ("bass") == SCM_BOOL_T) + bass = p; + else + pitches = gh_cons (p, pitches); + } + + pitches = scm_sort_list (pitches, Pitch::less_p_proc); + + SCM name_proc = get_property ("chordNameFunction"); + SCM exceptions = get_property ("chordNameExceptions"); + SCM markup = scm_call_4 (name_proc, pitches, bass, inversion, exceptions); + + /* + Ugh. + */ + SCM chord_as_scm = gh_cons (pitches, gh_cons (bass, inversion)); + + chord_name_ = new Item (get_property ("ChordName")); + chord_name_->set_grob_property("text", markup); + announce_grob(chord_name_, SCM_EOL); + SCM s = get_property ("chordChanges"); + if (to_boolean (s) && ly_car (last_chord_) != SCM_EOL + && gh_equal_p (chord_as_scm, last_chord_)) + chord_name_->set_grob_property ("begin-of-line-visible", SCM_BOOL_T); + + last_chord_ = chord_as_scm; +} + +bool +New_chord_name_engraver::try_music (Music* m) +{ + /* + hmm. Should check? + */ + if (m->is_mus_type ("note-event")) + { + add_note (m); + return true; + } + return false; +} + +void +New_chord_name_engraver::stop_translation_timestep () +{ + if (chord_name_) + { + typeset_grob (chord_name_); + } + chord_name_ = 0; + notes_.clear (); +} + +ENTER_DESCRIPTION(New_chord_name_engraver, +/* descr */ "Catch note-events " +"and generate the appropriate chordname.", +/* creats*/ "ChordName", +/* accepts */ "note-event", +/* acks */ "", +/* reads */ "chordChanges chordNameExceptions chordNameFunction", +/* write */ ""); diff --git a/ly/engraver-init.ly b/ly/engraver-init.ly index 7058c1de07..0ed7f41b04 100644 --- a/ly/engraver-init.ly +++ b/ly/engraver-init.ly @@ -298,12 +298,9 @@ ChordNamesContext = \translator { \type "Engraver_group_engraver" \name ChordNames - - - \consists "Output_property_engraver" \consists "Separating_line_group_engraver" - \consists "Chord_name_engraver" + \consists "New_chord_name_engraver" \consists "Skip_req_swallow_translator" \consistsend "Axis_group_engraver" minimumVerticalExtent = ##f @@ -445,6 +442,8 @@ ScoreContext = \translator { custos ) barCheckSynchronize = ##t + chordNameFunction = #chord->markup-banter + chordNameExceptions = #chord::names-alist-banter \grobdescriptions #all-grob-descriptions } @@ -519,5 +518,7 @@ TabStaffContext = \translator { \remove Key_engraver stringTunings = #guitar-tunings tablatureFormat = #fret-number-tablature-format + + } diff --git a/scm/chord-name.scm b/scm/chord-name.scm index 803b693f5a..ac8ffa7c44 100644 --- a/scm/chord-name.scm +++ b/scm/chord-name.scm @@ -15,9 +15,13 @@ ) -;; debugging. -;;(define (write-me x) (write x) (newline) x) -(define (write-me x) x) +(define-public (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) @@ -38,7 +42,7 @@ dump reinterpret the markup as a molecule. " ; " ;; ;; note = (notename . alteration) ;; -;; text = scm markup text -- see font.scm and input/test/markup.ly +;; markup = markup text -- see font.scm and input/test/markup.ly ;; TODO @@ -58,7 +62,7 @@ dump reinterpret the markup as a molecule. " ; " ;; ;; * doc strings -(define chord::names-alist-banter +(define-public chord::names-alist-banter `( ; C iso C.no3.no5 (((0 . 0)) . ,empty-markup) @@ -84,8 +88,8 @@ dump reinterpret the markup as a molecule. " ; " (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . ,(make-line-markup (list - (make-simple-markup "m") - (make-super-markup (make-simple-markup "5-/7 "))))) + (make-simple-markup "m") + (make-super-markup (make-simple-markup "5-/7 "))))) ; Co iso C:m5-/7- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-super-markup (make-simple-markup "o "))) @@ -93,7 +97,7 @@ dump reinterpret the markup as a molecule. " ; " (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ,(make-line-markup (list (make-simple-markup "dim") - (make-simple-markup "9 ")))) + (make-super-markup (make-simple-markup "9 "))))) (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ,(make-line-markup (list (make-simple-markup "dim") @@ -102,8 +106,23 @@ dump reinterpret the markup as a molecule. " ; " )) -;;;;;;;;;; - +(define (accidental->textp acc pos) + (if (= acc 0) + '() + (if (equal? pos 'columns) + (list '(music (font-relative-size . -1)) + (list (string-append "accidentals-" (number->string acc)))) + (if (equal? pos 'super) + (list '(music (raise . 2) (font-relative-size . -1)) + (list (string-append "accidentals-" (number->string acc)))) + (list '(music (raise . -1) (font-relative-size . -1)) + (list (string-append "accidentals-" (number->string acc)))))))) + +(define (accidental->text acc) (accidental->textp acc 'columns)) +(define (accidental->text-super acc) (accidental->textp acc 'super)) +(define (accidental->text-sub acc) (accidental->textp acc 'sub)) + +; pitch->note-name: drops octave (define (pitch->note-name pitch) (cons (cadr pitch) (caddr pitch))) @@ -115,11 +134,14 @@ dump reinterpret the markup as a molecule. " ; " (string-append "accidentals-" (number->string acc)))))) +;; +;; TODO: invent sensible way to make note name tweaking possible? +;; (define (pitch->markup pitch) (make-line-markup (list (make-simple-markup - (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))) + (vector-ref #("C" "D" "E" "F" "G" "A" "B") (cadr pitch))) ;; undefined? ;; (make-normal-size-superscript-markup (make-super-markup @@ -191,11 +213,9 @@ dump reinterpret the markup as a molecule. " ; " (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' @@ -312,11 +332,9 @@ dump reinterpret the markup as a molecule. " ; " ;; 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 @@ -347,7 +365,7 @@ dump reinterpret the markup as a molecule. " ; " (make-raise-markup 0.3 (make-line-markup (list adds-markup subs-markup))) - b+i-markup)))) + b+i-markup)))) (define (c++-pitch->scm p) (if (ly:pitch? p) @@ -356,74 +374,53 @@ dump reinterpret the markup as a molecule. " ; " (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 - )) + (let ((additions (chord::additions unmatched-steps)) + (subtractions (chord::subtractions unmatched-steps))) + + (chord::inner-name-banter tonic exception-part additions subtractions + bass-and-inversion steps))) -;; 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? -; +;; 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) -(define (chord::exceptions-lookup-helper - exceptions-alist try-steps unmatched-steps exception-part) - " +" + ;; 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))) + (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 - exceptions-alist - (reverse (cdr r)) - (cons (car r) unmatched-steps) #f)))) - (cons exception-part unmatched-steps))) - -;; see above. - -(define (chord::exceptions-lookup style steps) - " - return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS) - BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5) - -" + #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 - (chord::restyle 'chord::names-alist- style) + exceptions steps '() #f)) (exception-part (car result)) (unmatched-steps (cdr result)) @@ -440,597 +437,409 @@ dump reinterpret the markup as a molecule. " ; " (list exception-part unmatched-with-1-3-5))) -(define (chord::name->markup style tonic steps bass-and-inversion) - (write-me tonic) - (write-me steps) - (let* ((lookup (write-me (chord::exceptions-lookup style steps))) - (exception-part (write-me (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, -;; +;; Original Version by James Hammons, +;; Complete rewrite by Amelie Zapf, ;; DONT use non-ascii characters, even if ``it works'' in Windows - - -(define chord::names-alist-american - - `( - (((0 . 0)) . ,empty-markup) - (((0 . 0) (2 . 0)) . ,empty-markup) - ;; Root-fifth chord - (((0 . 0) (4 . 0)) . ,(make-simple-markup "5")) - ;; Common triads - (((0 . 0) (2 . -1)) . ,(make-simple-markup "m")) - (((0 . 0) (3 . 0) (4 . 0)) . ,(make-simple-markup "sus")) - (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim")) -;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o"))) - (((0 . 0) (2 . 0) (4 . 1)) . ,(make-simple-markup "aug")) -;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+")) - (((0 . 0) (1 . 0) (4 . 0)) . ,(make-simple-markup "2")) - ;; Common seventh chords - (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . - ,(make-line-markup - (list - (make-super-markup (make-simple-markup "o")) - (make-simple-markup " 7")))) - (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ,(make-simple-markup "maj7")) - ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!! - (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ,(make-simple-markup "m7")) - (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ,(make-simple-markup "7")) - (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ,(make-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)) . - ,(make-line-markup - (list - (make-super-markup - (make-combine-markup (make-simple-markup "o") - (make-simple-markup "/"))) - (make-simple-markup " 7")))) - (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ,(make-simple-markup "aug7")) - (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) - . ,(make-line-markup - (list - (make-simple-markup "maj7") - (make-small-markup - (make-raise-markup 0.2 (accidental-markup -1))) - (make-simple-markup "5")))) - (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . - ,(make-line-markup - (list - (make-simple-markup "7") - (make-small-markup (make-raise-markup 0.2 (accidental-markup -1))) - (make-simple-markup "5")))) - (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ,(make-simple-markup "7sus4")) - ;; Common ninth chords - (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) - . ,(make-simple-markup "6/9")) ;; we don't want the '/no7' - (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ,(make-simple-markup "6")) - (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ,(make-simple-markup "m6")) - (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ,(make-simple-markup "add9")) - (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) - . ,(make-simple-markup "maj9")) - (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) - . ,(make-simple-markup "9")) - (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) - . ,(make-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 -;;; - - - -;; Jazz chords, by Atte Andr'e Jensen -;; 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 +;;a white triangle (define mathm-markup-object (make-override-markup '(font-family . math) (make-simple-markup "M"))) -(define mraise-arg `(make-line-markup - (list - ,(make-simple-markup "m") - (make-raise-markup 0.5 (make-simple-markup arg))))) - -(define (raise-some-for-jazz arg-list) - (define (do-one x) - (case x - ("@" (make-raise-markup 0.3 ,(accidental-markup -1))) - ("#" (make-raise-markup 0.3 ,(accidental-markup 1))) - (else (make-raise-markup 0.8 ,x)))) - - (make-line-markup - (list (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)) . - ,(make-raise-markup 0.5 (make-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)) . - ,(make-raise-markup 0.5 mathm-markup-object)) - - ; major chord add nine = add9 - (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) - . ,(make-raise-markup 0.5 (make-simple-markup "add9"))) - ; major sixth chord with nine = 6/9 - (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) - . ,(make-raise-markup 0.5 (make-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)) . - ,(make-line-markup - (list ((make-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)) - . ,(make-raise-markup 0.5 (make-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)) . - ,(make-line-markup - (list - (make-simple-markup "+") - ;; +7 with 7 raised - (make-raise-markup 0.5 (make-simple-markup "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)"))); 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)"))) +;a black triangle +(define mathn-markup-object + (make-override-markup '(font-family . math) (make-simple-markup "N"))) + +(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-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 (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)) ;;(make-simple-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))) + (make-line-markup + (list + tonic-markup except-markup sep-markup + (make-raise-markup + 0.3 + (make-line-markup + (list pref-markup suff-markup))) + b+i-markup)))) - ; 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)"))) +(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::<)))) - ;; diminished chord(s) - ; diminished seventh chord = o + ;; 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 +;; Complete rewrite by Amelie Zapf (amy@loueymoss.com) +(define-public chord::names-alist-jazz + `( + (((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 (make-simple-markup "") (make-super-markup (make-simple-markup "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)) . - ,(make-super-markup (make-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)) . - ,(make-line-markup - (list - (make-super-markup - (make-combine-markup - (make-simple-markup "o") (make-simple-markup "/"))) - (make-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) - (make-line-markup - (list - (accidental-markup (caddr pitch)) - (make-simple-markup - (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8))))))) (define (step->markup-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-alternate-jazz pitch))) - -;; removeme ? -(define (xchord::additions->markup-jazz additions subtractions) - (if (pair? additions) - (make-line-markup - (list - (let ((step (step->markup-jazz (car additions)))) - (if (or (pair? (cdr additions)) - (pair? subtractions)) - (make-line-markup (list step (make-simple-markup "/"))) - step)) - (chord::additions->markup-jazz (cdr additions) subtractions))) - empty-markup)) - -(define (chord::>5? x) - (or (> (car x) 0) - (> (cadr x) 4))) - + (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) '("-5")) + ((-1) (make-line-markup (list (accidental-markup -1) (make-simple-markup "5")))) + ((0) (make-simple-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: -;; 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. (define (chord::additions->markup-jazz additions subtractions) - ;; FIXME - (make-line-markup - (list - (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) - (make-line-markup - (list (make-simple-markup "sus") - (step->markup-jazz (car sus)))) - empty-markup))) - - -(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 - " - - (make-line-markup - (list - (if (not (null? subtractions)) - (make-simple-markup "add") - empty-markup) - ;; this is totally incomprehensible. Fix me, and docme. - - ;; The function >5markup-jazz-helper cdrs through the list - ;; of additions in reverse order, ie, for c 7 9+: - ;; (1 1 1), (0 6 0), done - - ;; For each step, it creates a markup, if necessary, and - ;; cons's it to the list. - - ;; The list is reversed. - (let* ((radds (reverse additions)) - (rmarkups (chord::additions>5->markup-jazz-helper - radds - subtractions - (if (or (null? subtractions) (null? radds)) - #f (car radds))))) - (if (null? rmarkups) - empty-markup - (make-line-markup (reverse rmarkups))))))) - - - -(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)))) - - (list (step->markup-jazz list-step))) - - '()) - - (if (pair? additions) - (let ((step (car additions))) - (cons - (step->markup-jazz step) - - (chord::additions>5->markup-jazz-helper - (cdr additions) - subtractions - (if ;;; possible fix --jcn - (and list-step - (or (and (!= 6 (cadr step)) (!= 0 (caddr step))) - (and (= 6 (cadr step)) (!= -1 (caddr step)))) - ) ;;; possible fix --jcn - (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 (chord::subtractions->markup-jazz subtractions) - (if (pair? subtractions) - (make-line-markup - (list - (if (= 5 (cadr (car subtractions))) - (make-line-markup - (list - (make-simple-markup "omit") - (let ((step (step->markup-jazz (car subtractions)))) - (if (pair? (cdr subtractions)) - (make-line-markup - (list (step (make-simple-markup "/")))) - step)))) - empty-markup) - (chord::subtractions->markup-jazz (cdr 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-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-line-markup (list step (make-simple-markup " ")))) + step)) + (chord::additions->markup-jazz (cdr additions) 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) - (make-line-markup - (list - (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))) - (make-super-markup (make-simple-markup "/")) - empty-markup) - - (make-super-markup - (make-line-markup - (list - (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))) + bass-and-inversion steps) + (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps)) + (except-markup (if exception-part exception-part empty-markup)) ;;(make-simple-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-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-raise-markup + 0.33 + (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))) + bass-and-inversion steps))) -;; wip (set! chord::names-alist-jazz -(define chord::names-alist-jazz - (append - `( - (((0 . 0) (2 . -1)) . ,(make-simple-markup "m")) - ;; some fixups -- jcn - ; major seventh chord = triangle - (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) - . ,(make-raise-markup 0.5 mathm-markup-object)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + - ;; minor major seventh chord = m triangle - (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) - . ,(make-line-markup - (list - (make-simple-markup "m") - (make-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)) +(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). + " + + (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)) + ) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (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::names-alist-jazz)) + ((banter) + (chord-name-style-setter chord->markup-banter chord::names-alist-banter)) + ((american) + (chord-name-style-setter chord->markup-american chord::names-alist-american)) + ))) + diff --git a/scm/grob-description.scm b/scm/grob-description.scm index e208d4eb9d..3fad39566d 100644 --- a/scm/grob-description.scm +++ b/scm/grob-description.scm @@ -246,7 +246,7 @@ . ( (molecule-callback . ,new-chord-name-brew-molecule) (after-line-breaking-callback . ,Chord_name::after_line_breaking) - (chord-name-function . ,chord->markup) + (word-space . 1.0) (font-family . roman) (meta . ((interfaces . (font-interface text-interface chord-name-interface item-interface )))) )) diff --git a/scm/grob-property-description.scm b/scm/grob-property-description.scm index e2d176375f..f7034298fd 100644 --- a/scm/grob-property-description.scm +++ b/scm/grob-property-description.scm @@ -605,7 +605,6 @@ functions set spanner positions.") (grob-property-description 'delta-pitch number? "DOCME") (grob-property-description 'head-width number? "DOCME") (grob-property-description 'primitive number? "DOCME") -(grob-property-description 'chord-name-function procedure? "DOCME") (grob-property-description 'minimum-beam-collision-distance number? "Minimum distance to beam for a rest collision.") diff --git a/scm/translator-property-description.scm b/scm/translator-property-description.scm index a560876d72..861fe5917e 100644 --- a/scm/translator-property-description.scm +++ b/scm/translator-property-description.scm @@ -165,6 +165,12 @@ part-combining. Usually unset or zero when combining threads into one voice, and 1 (or the duration of one measure) when combining voices into one staff.") +(translator-property-description + 'chordNameFunction procedure? + "The function that converts lists of pitches to chord names.") +(translator-property-description + 'chordNameExceptions list? + "Alist of chord exceptions. Contains (CHORD . MARKUP) entries.") (translator-property-description 'chordChanges boolean? "Only show changes in chords scheme?") (translator-property-description 'clefGlyph string? "Name of the symbol within the music font") (translator-property-description 'clefOctavation integer? "Add -- 2.39.5