From: Jan Nieuwenhuizen Date: Mon, 8 May 2000 19:10:30 +0000 (+0200) Subject: patch::: 1.3.47.jcn3 X-Git-Tag: release/1.3.48~1 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=41e82f1eed38b69f60f74221c52ce14692318d6d;p=lilypond.git patch::: 1.3.47.jcn3 1.3.47.jcn3 --- Generated by janneke@gnu.org, From = lilypond-1.3.47.jcn2, To = lilypond-1.3.47.jcn3 usage cd lilypond-source-dir; patch -E -p1 < lilypond-1.3.47.jcn3.diff Patches do not contain automatically generated files or (urg) empty directories, i.e., you should rerun autoconf, configure --- diff --git a/CHANGES b/CHANGES index ab9660cfbf..78cb362076 100644 --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,14 @@ -1.3.47.mb2 +--- ../lilypond-1.3.47.jcn2/CHANGES Wed May 3 09:20:44 2000 +++ b/CHANGES Mon May 8 21:10:30 2000 +@@ -1,5 +1,7 @@ +-1.3.47.jcn2 +1.3.47.jcn3 + =========== + +* Rewrite of chord-name production in scheme. + + 1.3.47.mb3 + ===========1.3.47.mb2 =========== * Corrected glossary.tely diff --git a/VERSION b/VERSION index 2a559e647a..7160434da2 100644 --- a/VERSION +++ b/VERSION @@ -2,7 +2,7 @@ PACKAGE_NAME=LilyPond MAJOR_VERSION=1 MINOR_VERSION=3 PATCH_LEVEL=47 -MY_PATCH_LEVEL=mb3 +MY_PATCH_LEVEL=jcn3 # use the above to send patches: MY_PATCH_LEVEL is always empty for a # released version. diff --git a/lily/chord-name.cc b/lily/chord-name.cc index 75a16226c9..bb6fbbc1ea 100644 --- a/lily/chord-name.cc +++ b/lily/chord-name.cc @@ -26,298 +26,126 @@ ("style" . "text") */ Molecule -Chord_name::ly_word2molecule (SCM scm) const +Chord_name::ly_word2molecule (SCM word) const { - String style; - if (gh_pair_p (scm)) + Dictionary option_dict; + if (gh_pair_p (word)) { - SCM s = gh_car (scm); - if (gh_string_p (s)) - style = ly_scm2string (s); - scm = gh_cdr (scm); + SCM options = gh_cdr (word); + word = gh_car (word); + while (gh_pair_p (options)) + { + SCM option = gh_car (options); + if (option != SCM_UNDEFINED && option != SCM_BOOL_F + && gh_pair_p (option)) + { + SCM key = gh_car (option); + SCM val = gh_cdr (option); + String k; + if (gh_symbol_p (key)) + k = ly_symbol2string (key); + else if (gh_string_p (key)) + k = ly_scm2string (key); + else + continue; + option_dict[k] = val; + } + options = gh_cdr (options); + } + } + Real ex = lookup_l ()->text ("", "x", paper_l ()).extent + ()[Y_AXIS].length (); + if (gh_string_p (word)) + { + String w = ly_scm2string (word); + Molecule mol; + Offset offset; + + int size = 0; + if (option_dict.elem_b ("size")) + size = gh_scm2int (option_dict["size"]); + + String style; + if (option_dict.elem_b ("style")) + style = ly_scm2string (option_dict["style"]); + + if (option_dict.elem_b ("type") + && ly_scm2string (option_dict["type"]) == "super") + { + Real super_y = ex / 2; + //super_y += -acc.extent ()[Y_AXIS][MIN]; + offset = Offset (0, super_y); + if (!size) + size = -2; + } + if (option_dict.elem_b ("offset")) + { + // hmm + SCM s = option_dict["offset"]; + if (gh_pair_p (s)) + offset = Offset (gh_scm2double (gh_car (s)), + gh_scm2double (gh_cdr (s))) * ex; + } + if (option_dict.elem_b ("font") + && ly_scm2string (option_dict["font"]) == "feta") + mol = paper_l ()->lookup_l (size)->afm_find (w); + else + mol = paper_l ()->lookup_l (size)->text (style, w, paper_l ()); + + mol.translate (offset); + return mol; } - if (gh_string_p (scm)) - return lookup_l ()->text (style, ly_scm2string (scm), paper_l ()); return Molecule (); } /* - scm is word or list of words: - word - (word word) + ;; text: list of word + ;; word: string + optional list of property + ;; property: align, kern, font (?), size */ Molecule -Chord_name::ly_text2molecule (SCM scm) const +Chord_name::ly_text2molecule (SCM text) const { Molecule mol; - if (gh_list_p (scm)) + if (gh_list_p (text)) { - while (gh_cdr (scm) != SCM_EOL) + while (gh_cdr (text) != SCM_EOL) { - Molecule m = ly_word2molecule (gh_car (scm)); + Molecule m = ly_word2molecule (gh_car (text)); if (!m.empty_b ()) mol.add_at_edge (X_AXIS, RIGHT, m, 0); - scm = gh_cdr (scm); + text = gh_cdr (text); } - scm = gh_car (scm); + text = gh_car (text); } - Molecule m = ly_word2molecule (scm); + Molecule m = ly_word2molecule (text); if (!m.empty_b ()) mol.add_at_edge (X_AXIS, RIGHT, m, 0); return mol; } -Molecule -Chord_name::pitch2molecule (Musical_pitch p) const -{ - SCM name = scm_eval (gh_list (ly_symbol2scm ("user-pitch-name"), - ly_quote_scm (p.to_scm ()), - SCM_UNDEFINED)); - - if (name != SCM_UNSPECIFIED) - { - return ly_text2molecule (name); - } - - Molecule mol = lookup_l ()->text ("", p.str ().left_str (1).upper_str (), paper_l ()); - - /* - We want the smaller size, even if we're big ourselves. - */ - if (p.accidental_i_) - { - Molecule acc = paper_l ()->lookup_l (-3)->afm_find - (String ("accidentals-") + to_str (p.accidental_i_)); - // urg, howto get a good superscript_y? - Real super_y = lookup_l ()->text ("", "x", paper_l ()).extent - ()[Y_AXIS].length () / 2; - super_y += -acc.extent ()[Y_AXIS][MIN]; - acc.translate_axis (super_y, Y_AXIS); - mol.add_at_edge (X_AXIS, RIGHT, acc, 0.0); - } - - return mol; -} - -Musical_pitch -diff_pitch (Musical_pitch tonic, Musical_pitch p) -{ - Musical_pitch diff (p.notename_i_ - tonic.notename_i_, - p.accidental_i_ - tonic.accidental_i_, - p.octave_i_ - tonic.octave_i_); - - while (diff.notename_i_ >= 7) - { - diff.notename_i_ -= 7; - diff.octave_i_ ++; - } - while (diff.notename_i_ < 0) - { - diff.notename_i_ += 7; - diff.octave_i_ --; - } - - diff.accidental_i_ -= (tonic.semitone_pitch () + diff.semitone_pitch ()) - - p.semitone_pitch (); - - return diff; -} - -/* - JUNKME - */ -bool -Chord_name::user_chord_name (Array pitch_arr, Chord_mol* name_p) const -{ - Array chord_type = pitch_arr; - Chord::rebuild_transpose (&chord_type, diff_pitch (pitch_arr[0], Musical_pitch (0)), false); - - SCM chord = SCM_EOL; - for (int i= chord_type.size (); i--; ) - chord = gh_cons (chord_type[i].to_scm (), chord); - - - SCM name = scm_eval (gh_list (ly_symbol2scm ("user-chord-name"), - ly_quote_scm (chord), - SCM_UNDEFINED)); - if (gh_pair_p (name)) - { - name_p->modifier_mol = ly_text2molecule (gh_car (name)); - name_p->addition_mol = ly_text2molecule (gh_cdr (name)); - return true; - } - return false; -} - -void -Chord_name::banter (Array pitch_arr, Chord_mol* name_p) const -{ - Array add_arr; - Array sub_arr; - Chord::find_additions_and_subtractions (pitch_arr, &add_arr, &sub_arr); - - Array scale; - for (int i=0; i < 7; i++) - scale.push (Musical_pitch (i)); - - Musical_pitch tonic = pitch_arr[0]; - Chord::rebuild_transpose (&scale, tonic, true); - - /* - Does chord include this step? -1 if flat - */ - int has[16]; - for (int i=0; i<16; i++) - has[i] = 0; - - String mod_str; - String add_str; - String sep_str; - for (int i = 0; i < add_arr.size (); i++) - { - Musical_pitch p = add_arr[i]; - int step = Chord::step_i (tonic, p); - int accidental = p.accidental_i_ - scale[(step - 1) % 7].accidental_i_; - if ((step < 16) && (has[step] != -1)) - has[step] = accidental == -1 ? -1 : 1; - // only from guile table ? - if ((step == 3) && (accidental == -1)) - { - mod_str = "m"; - } - else if (accidental - || (!(step % 2) - || ((i == add_arr.size () - 1) && (step > 5)))) - { - add_str += sep_str; - sep_str = "/"; - if ((step == 7) && (accidental == 1)) - { - add_str += "maj7"; - } - else - { - add_str += to_str (step); - if (accidental) - add_str += accidental < 0 ? "-" : "+"; - } - } - } - - for (int i = 0; i < sub_arr.size (); i++) - { - Musical_pitch p = sub_arr[i]; - int step = Chord::step_i (tonic, p); - /* - if additions include 2 or 4, assume sus2/4 and don't display 'no3' - */ - if (!((step == 3) && (has[2] || has[4]))) - { - add_str += sep_str + "no" + to_str (step); - sep_str = "/"; - } - } - - if (mod_str.length_i ()) - name_p->modifier_mol.add_at_edge (X_AXIS, RIGHT, - lookup_l ()->text ("roman", mod_str, paper_l ()), 0); - if (add_str.length_i ()) - { - if (!name_p->addition_mol.empty_b ()) - add_str = "/" + add_str; - name_p->addition_mol.add_at_edge (X_AXIS, RIGHT, - lookup_l ()->text ("script", add_str, paper_l ()), 0); - } -} - -/* - TODO: - fix silly to-and-fro scm conversions - */ Molecule Chord_name::do_brew_molecule () const { - Array pitch_arr; - - for (SCM s = get_elt_property ("pitches"); s != SCM_EOL; s = gh_cdr (s)) - pitch_arr.push (Musical_pitch (gh_car (s))); - - Musical_pitch tonic = pitch_arr[0]; - - Chord_mol name; - name.tonic_mol = pitch2molecule (tonic); - - /* - if user has explicitely listed chord name, use that - - TODO - urg - maybe we should check all sub-lists of pitches, not - just full list and base triad? - */ - if (!user_chord_name (pitch_arr, &name)) - { - /* - else, check if user has listed base triad - use user base name and add banter for remaining part - */ - if ((pitch_arr.size () > 2) - && user_chord_name (pitch_arr.slice (0, 3), &name)) - { - Array base = Chord::base_arr (tonic); - base.concat (pitch_arr.slice (3, pitch_arr.size ())); - banter (base, &name); - } - /* - else, use pure banter - */ - else - { - banter (pitch_arr, &name); - } - } + SCM style = get_elt_property ("style"); + if (style == SCM_UNDEFINED) + style = ly_str02scm ("banter"); - SCM s = get_elt_property ("inversion"); - if (s != SCM_UNDEFINED) - { - name.inversion_mol = lookup_l ()->text ("", "/", paper_l ()); - Musical_pitch p (s); + SCM inversion = get_elt_property ("inversion"); + if (inversion == SCM_UNDEFINED) + inversion = SCM_BOOL_F; - Molecule mol = pitch2molecule (p); - name.inversion_mol.add_at_edge (X_AXIS, RIGHT, mol, 0); - } + SCM bass = get_elt_property ("bass"); + if (bass == SCM_UNDEFINED) + bass = SCM_BOOL_F; - s = get_elt_property ("bass"); - if (s != SCM_UNDEFINED) - { - name.bass_mol = lookup_l ()->text ("", "/", paper_l ()); - Musical_pitch p (s); - Molecule mol = pitch2molecule (p); - name.bass_mol.add_at_edge (X_AXIS, RIGHT, mol, 0); - } - - // urg, howto get a good superscript_y? - Real super_y = lookup_l ()->text ("", "x", paper_l ()).extent - ()[Y_AXIS].length () / 2; - if (!name.addition_mol.empty_b ()) - name.addition_mol.translate (Offset (0, super_y)); - - Molecule mol; - mol.add_at_edge (X_AXIS, RIGHT, name.tonic_mol, 0); - // huh? - if (!name.modifier_mol.empty_b ()) - mol.add_at_edge (X_AXIS, RIGHT, name.modifier_mol, 0); - if (!name.addition_mol.empty_b ()) - mol.add_at_edge (X_AXIS, RIGHT, name.addition_mol, 0); - if (!name.inversion_mol.empty_b ()) - mol.add_at_edge (X_AXIS, RIGHT, name.inversion_mol, 0); - if (!name.bass_mol.empty_b ()) - mol.add_at_edge (X_AXIS, RIGHT, name.bass_mol, 0); + SCM pitches = get_elt_property ("pitches"); - s = get_elt_property ("word-space"); - if (gh_number_p (s)) - mol.dim_.interval_a_[X_AXIS][RIGHT] += gh_scm2double (s) - * staff_symbol_referencer (this).staff_space (); + SCM text = scm_eval (gh_list (ly_symbol2scm ("chord::user-name"), + style, + ly_quote_scm (pitches), + ly_quote_scm (gh_cons (inversion, bass)), + SCM_UNDEFINED)); - return mol; + return ly_text2molecule (text); } diff --git a/lily/chord.cc b/lily/chord.cc index e188062f0e..8a524f0110 100644 --- a/lily/chord.cc +++ b/lily/chord.cc @@ -295,6 +295,10 @@ Chord::step_i (Musical_pitch tonic, Musical_pitch p) return i; } +/* + JUNKME. + do something smarter. + */ Array Chord::missing_thirds_pitch_arr (Array const* pitch_arr_p) { @@ -377,76 +381,6 @@ Chord::to_pitch_arr () const return pitch_arr; } -void -Chord::find_additions_and_subtractions (Array pitch_arr, Array* add_arr_p, Array* sub_arr_p) -{ - Musical_pitch tonic = pitch_arr[0]; - /* - construct an array of thirds for a normal chord - */ - Array all_arr; - all_arr.push (tonic); - if (step_i (tonic, pitch_arr.top ()) >= 5) - all_arr.push (pitch_arr.top ()); - else - all_arr.push (base_arr (tonic).top ()); - all_arr.concat (missing_thirds_pitch_arr (&all_arr)); - all_arr.sort (Musical_pitch::compare); - - int i = 0; - int j = 0; - Musical_pitch last_extra = tonic; - while ((i < all_arr.size ()) || (j < pitch_arr.size ())) - { - Musical_pitch a = all_arr [i push (p); - last_extra = p; - (j < pitch_arr.size ()) ? j++ : i++; - } - /* - a third is missing: chord subtraction - */ - else - { - if (last_extra.notename_i_ != a.notename_i_) - sub_arr_p->push (a); - (i < all_arr.size ()) ? i++ : j++; - last_extra = tonic; - } - } - - /* add missing basic steps */ - if (step_i (tonic, pitch_arr.top ()) < 3) - sub_arr_p->push (base_arr (tonic)[1]); - if (step_i (tonic, pitch_arr.top ()) < 5) - sub_arr_p->push (base_arr (tonic).top ()); - - /* - add highest addition, because it names chord, if greater than 5 - or non-standard - (1, 3 and) 5 not additions: part of normal chord - */ - if ((step_i (tonic, pitch_arr.top ()) > 5) - || pitch_arr.top ().accidental_i_) - add_arr_p->push (pitch_arr.top ()); -} - - /* This routine tries to guess tonic in a possibly inversed chord, ie should produce: C. diff --git a/lily/include/chord-name.hh b/lily/include/chord-name.hh index fa9cba3a87..3bdf747a0b 100644 --- a/lily/include/chord-name.hh +++ b/lily/include/chord-name.hh @@ -13,16 +13,6 @@ #include "item.hh" #include "molecule.hh" -class Chord_mol -{ -public: - Molecule tonic_mol; - Molecule modifier_mol; - Molecule addition_mol; - Molecule inversion_mol; - Molecule bass_mol; -}; - /** elt_properties: pitches: list of musical-pitch @@ -35,9 +25,6 @@ public: VIRTUAL_COPY_CONS (Score_element); Molecule ly_word2molecule (SCM scm) const; Molecule ly_text2molecule (SCM scm) const; - Molecule pitch2molecule (Musical_pitch p) const; - bool user_chord_name (Array pitch_arr, Chord_mol* name_p) const; - void banter (Array pitch_arr, Chord_mol* name_p) const; protected: virtual Molecule do_brew_molecule () const; diff --git a/lily/include/chord.hh b/lily/include/chord.hh index 2d13e75deb..ce85501bf8 100644 --- a/lily/include/chord.hh +++ b/lily/include/chord.hh @@ -22,7 +22,6 @@ class Chord { public: static Array base_arr (Musical_pitch p); - static void find_additions_and_subtractions(Array pitch_arr, Array* add_arr_p, Array* sub_arr_p); static int find_tonic_i (Array const*); static int find_pitch_i (Array const*, Musical_pitch p); static int find_notename_i (Array const*, Musical_pitch p); diff --git a/scm/chord-names.scm b/scm/chord-names.scm index 7a8777fbc7..e6d72a9059 100644 --- a/scm/chord-names.scm +++ b/scm/chord-names.scm @@ -1,56 +1,325 @@ -;; note-name: (note . accidental) -;; list: (list-of-pitches . (modifier-string . addition-subtraction-string)) +;;; chord.scm -- to be included in/to replace chord-name.scm +;;; 2000 janneke@gnu.org +;;; -;; if a complete chord is found, use name -;; if a chord's base triad is found (c e g), use name +(use-modules + (ice-9 debug)) -(define note-names-alist '()) -(set! note-names-alist - (append - '( - ; use these for German naming - ;((6 . 0) . ("H" "")) - ;((6 . -1) . ("B" ("feta-1" . ""))) - - ; C-p/C-r current feta chars for sharp/flat - ; don't use them: ly2dvi breaks (inputenc package) - ;((0 . 1) . ("C" ("feta-1" . ""))) - ;((0 . -1) . ("C" ("feta-1" . ""))) - ) - note-names-alist)) +;; +;; (octave notename accidental) +;; -(define (pitch->note-name pitch) - (cons (cadr pitch) (caddr pitch))) - -(define (user-pitch-name pitch) - (let ((entry (assoc (pitch->note-name pitch) note-names-alist))) - (if entry - (cdr entry)))) +;; +;; text: list of word +;; word: string + optional list of property +;; property: size, style, font, super, offset +;; -(define chord-names-alist '()) -(set! chord-names-alist +;; TODO +;; +;; * clean split of base/banter/american stuff +;; * text definition is rather ad-hoc. +;; * finish and check american names +;; * make notename (tonic) configurable from mudela +;; * fix append/cons stuff in inner-name-banter +;; + + +;;;;;;;;; +(define chord::names-alist-banter '()) +(set! chord::names-alist-banter (append - '( + '( ; C iso C.no3.no5 - (((0 . 0)) . (#f . #f)) + (((0 . 0)) . #f) ; C iso C.no5 - (((0 . 0) (2 . 0)) . (#f . #f)) + (((0 . 0) (2 . 0)) . #f) ; Cm iso Cm.no5 - (((0 . 0) (2 . -1)) . ("m" . #f)) + (((0 . 0) (2 . -1)) . ("m")) + ; C2 iso C2.no3 + (((0 . 0) (1 . 0) (4 . 0)) . (("2" (type . "super")))) + ; C4 iso C4.no3 + (((0 . 0) (3 . 0) (4 . 0)) . (("4" (type . "super")))) ; Cdim iso Cm5- - (((0 . 0) (2 . -1) (4 . -1)) . ("dim" . #f)) + (((0 . 0) (2 . -1) (4 . -1)) . ("dim")) ; Co iso Cm5-7- ; urg - ; (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" . ("feta-1" . "."))) - (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (#f . ("script" . "o"))) + (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (("o" (type . "super")))) ; Cdim9 - (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" . ("script" . "9"))) - (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" . ("script" . "11"))) + (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" ("9" (type . "super")))) + (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" ("11" (type . "super")))) ) - chord-names-alist)) + chord::names-alist-banter)) + + +(define chord::names-alist-american '()) +(set! chord::names-alist-american + (append + '( + (((0 . 0)) . #f) + (((0 . 0) (2 . 0)) . #f) + (((0 . 0) (2 . -1)) . ("m")) + (((0 . 0) (2 . -1) (4 . -1)) . ("dim")) + (((0 . 0) (4 . 0)) . (("5" (type . "super")))) + (((0 . 0) (3 . 0) (4 . 0)) . ("sus")) + (((0 . 0) (2 . -1) (4 . -1)) . (("o" (type . "super")))) + (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (("o7" (type . "super")))) + (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (("x7" (type . "super")))) + + (((0 . 0) (2 . 0) (4 . 1)) . ("aug")) + (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . (("aug" ("7" (type . "super"))))) + + (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (("maj7" (type . "super")) ("accidentals--1" (font . "feta") (type . "super")) ("5" (type . "super")))) + + (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . (("7sus4" (type . "super")))) + + (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (("maj6" (type . "super")))) + ;; dont need this? + ;(((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6" . "")) + + ;; c = 0, d = 1 + ;;(((0 . 0) (2 . 0) (4 . 0) (8 . 0)) . ("add9" . "")) + ;;(((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("" . (("script" . "add9")))) + + ;; we don't want the '/no7' + ;;(((0 . 0) (2 . 0) (4 . 0) (5 . 0) (8 . 0)) . ("6/9" . "")) + ;;(((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (("script" . "6/9")))) + + ;;already have this? + ;;(((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9" . "")) + + ) + chord::names-alist-american)) + +;;;;;;;;;; + + +(define (pitch->note-name pitch) + (cons (cadr pitch) (caddr pitch))) + +(define (pitch->text pitch) + (cons + (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))) + (if (= (caddr pitch) 0) + '() + (list (list (string-append "accidentals-" + (number->string (caddr pitch))) + '(font . "feta")))))) + +(define (step->text pitch) + (string-append + (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8))) + (case (caddr pitch) + ((-2) "--") + ((-1) "-") + ((0) "") + ((1) "+") + ((2) "++")))) + +(define (pitch->text-banter pitch) + (pitch->text pitch)) + +(define (step->text-banter pitch) + (if (= (cadr pitch) 6) + (case (caddr pitch) + ((-2) "7-") + ((-1) "7") + ((0) "maj7") + ((1) "7+") + ((2) "7+")) + (step->text pitch))) + +(define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11))) + +(define (pitch::semitone pitch) + (+ (* (car pitch) 12) + (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7)) + (caddr pitch))) + +(define (pitch::transpose pitch delta) + (let ((simple-octave (+ (car pitch) (car delta))) + (simple-notename (+ (cadr pitch) (cadr delta)))) + (let ((octave (+ simple-octave (quotient simple-notename 7))) + (notename (modulo simple-notename 7))) + (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta)) + (pitch::semitone `(,octave ,notename 0))))) + `(,octave ,notename ,accidental))))) + +(define (pitch::diff pitch tonic) + (let ((simple-octave (- (car pitch) (car tonic))) + (simple-notename (- (cadr pitch) (cadr tonic)))) + (let ((octave (+ simple-octave (quotient simple-notename 7) + (if (< simple-notename 0) -1 0))) + (notename (modulo simple-notename 7))) + (let ((accidental (- (pitch::semitone pitch) + (pitch::semitone tonic) + (pitch::semitone `(,octave ,notename 0))))) + `(,octave ,notename ,accidental))))) + +(define (pitch::note-pitch pitch) + (+ (* (car pitch) 7) (cadr pitch))) + +(define (chord::step tonic pitch) + (- (pitch::note-pitch pitch) (pitch::note-pitch tonic))) + +;; text: list of word +;; word: string + optional list of property +;; property: align, kern, font (?), size + +;;(define chord::minor-major-vec (list->vector '(0 -1 -1 0 0 -1 -1))) +(define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0))) + +(define (chord::step-pitch tonic step) + ;; urg, we only do this for thirds + (if (= (modulo step 2) 0) + '(0 0 0) + (let loop ((i 1) (pitch tonic)) + (if (= i step) pitch + (loop (+ i 2) + (pitch::transpose + pitch `(0 2 ,(vector-ref chord::minor-major-vec + ;; -1 (step=1 -> vector=0) + 7 = 6 + (modulo (+ i 6) 7))))))))) + +;; find the pitches that are not part of `normal' chord +(define (chord::additions chord-pitches) + (let ((tonic (car chord-pitches))) + ;; walk the chord steps: 1, 3, 5 + (let loop ((step 1) (pitches chord-pitches) (additions '())) + (if (pair? pitches) + (let* ((pitch (car pitches)) + (p-step (+ (- (pitch::note-pitch pitch) + (pitch::note-pitch tonic)) + 1))) + ;; pitch is an addition if + (if (or + ;; it comes before this step or + (< p-step step) + ;; its step is even or + (= (modulo p-step 2) 0) + ;; has same step, but different accidental or + (and (= p-step step) + (not (equal? pitch (chord::step-pitch tonic step)))) + ;; is the last of the chord and not one of base thirds + (and (> p-step 5) + (= (length pitches) 1))) + (loop step (cdr pitches) (cons pitch additions)) + (if (= p-step step) + (loop step (cdr pitches) additions) + (loop (+ step 2) pitches additions)))) + (reverse additions))))) + +;; find the pitches that are missing from `normal' chord +(define (chord::subtractions chord-pitches) + (let ((tonic (car chord-pitches))) + (let loop ((step 1) (pitches chord-pitches) (subtractions '())) + (if (pair? pitches) + (let* ((pitch (car pitches)) + (p-step (+ (- (pitch::note-pitch pitch) + (pitch::note-pitch tonic)) + 1))) + ;; pitch is an subtraction if + ;; a step is missing or + (if (> p-step step) + (loop (+ step 2) pitches + (cons (chord::step-pitch tonic step) subtractions)) + ;; there are no pitches left, but base thirds are not yet done and + (if (and (<= step 5) + (= (length pitches) 1)) + ;; present pitch is not missing step + (if (= p-step step) + (loop (+ step 2) pitches subtractions) + (loop (+ step 2) pitches + (cons (chord::step-pitch tonic step) subtractions))) + (if (= p-step step) + (loop (+ step 2) (cdr pitches) subtractions) + (loop step (cdr pitches) subtractions))))) + (reverse subtractions))))) + +(define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion) + (apply append (pitch->text-banter tonic) + (if user-name user-name '()) + (let loop ((from additions) (to '())) + (if (pair? from) + (let ((p (car from))) + (loop (cdr from) + (append to + (cons + (cons (step->text-banter p) '((type . "super"))) + (if (or (pair? (cdr from)) + (pair? subtractions)) + '(("/" (type . "super"))) + '()))))) + to)) + (let loop ((from subtractions) (to '())) + (if (pair? from) + (let ((p (car from))) + (loop (cdr from) + (append to + (cons '("no" (type . "super")) + (cons + (cons (step->text-banter p) '((type . "super"))) + (if (pair? (cdr from)) + '(("/" (type . "super"))) + '())))))) + to)) + (if (and (pair? base-and-inversion) + (or (car base-and-inversion) + (cdr base-and-inversion))) + (cons "/" (append + (if (car base-and-inversion) + (pitch->text + (car base-and-inversion)) + (pitch->text + (cdr base-and-inversion))) + '())) + '()) + '())) + +(define (chord::name-banter tonic user-name pitches base-and-inversion) + (let ((additions (chord::additions pitches)) + (subtractions (chord::subtractions pitches))) + (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion))) + +(define (chord::name-american tonic user-name pitches base-and-inversion) + (let ((additions (chord::additions pitches)) + (subtractions #f)) + (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion))) + +(define (chord::user-name style pitches base-and-inversion) + ;(display "pitches:") (display pitches) (newline) + ;(display "style:") (display style) (newline) + ;(display "b&i:") (display base-and-inversion) (newline) + (let ((diff (pitch::diff '(0 0 0) (car pitches))) + (name-func + (eval (string->symbol (string-append "chord::name-" style)))) + (names-alist + (eval (string->symbol (string-append "chord::names-alist-" style))))) + (let loop ((note-names (reverse pitches)) + (chord '()) + (user-name #f)) + (if (pair? note-names) + (let ((entry (assoc + (reverse + (map (lambda (x) + (pitch->note-name (pitch::transpose x diff))) + note-names)) + names-alist))) + (if entry + ;; urg? found: break loop + (loop '() chord (cdr entry)) + (loop (cdr note-names) (cons (car note-names) chord) #f))) + (let* ((transposed (if pitches + (map (lambda (x) (pitch::transpose x diff)) chord) + '())) + (matched (if (= (length chord) 0) + 3 + (- (length pitches) (length chord)))) + (completed + (append (do ((i matched (- i 1)) + (base '() (cons `(0 ,(* (- i 1) 2) 0) base))) + ((= i 0) base) + ()) + transposed))) + (name-func (car pitches) user-name completed base-and-inversion)))))) -(define (user-chord-name chord) - (let ((entry (assoc (map (lambda (x) (pitch->note-name x)) chord) - chord-names-alist))) - (if entry - (cdr entry)))) diff --git a/scm/generic-property.scm b/scm/generic-property.scm index 3145084cc7..1506982fb6 100644 --- a/scm/generic-property.scm +++ b/scm/generic-property.scm @@ -76,7 +76,8 @@ (define generic-chord-name-properties (cons "Chord_name" (list (list 'textScriptWordSpace number? 'word-space) - (list 'chordNameWordSpace number? 'word-space)))) + (list 'chordNameWordSpace number? 'word-space) + (list 'chordNameStyle string? 'style)))) (define generic-crescendo-properties (cons "Crescendo" (list