-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
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.
("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<SCM> 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<Musical_pitch> pitch_arr, Chord_mol* name_p) const
-{
- Array<Musical_pitch> 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<Musical_pitch> pitch_arr, Chord_mol* name_p) const
-{
- Array<Musical_pitch> add_arr;
- Array<Musical_pitch> sub_arr;
- Chord::find_additions_and_subtractions (pitch_arr, &add_arr, &sub_arr);
-
- Array<Musical_pitch> 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<Musical_pitch> 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<Musical_pitch> 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);
}
return i;
}
+/*
+ JUNKME.
+ do something smarter.
+ */
Array<Musical_pitch>
Chord::missing_thirds_pitch_arr (Array<Musical_pitch> const* pitch_arr_p)
{
return pitch_arr;
}
-void
-Chord::find_additions_and_subtractions (Array<Musical_pitch> pitch_arr, Array<Musical_pitch>* add_arr_p, Array<Musical_pitch>* sub_arr_p)
-{
- Musical_pitch tonic = pitch_arr[0];
- /*
- construct an array of thirds for a normal chord
- */
- Array<Musical_pitch> 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 <? all_arr.size () - 1];
- Musical_pitch p = pitch_arr[j <? pitch_arr.size () - 1];
- /*
- this pitch is present: do nothing, check next
- */
- if (a == p)
- {
- i++;
- j++;
- last_extra = tonic;
- }
- /*
- found an extra pitch: chord addition
- */
- else if ((p < a) || (p.notename_i_ == a.notename_i_))
- {
- add_arr_p->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
<e g c'> should produce: C.
#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
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<Musical_pitch> pitch_arr, Chord_mol* name_p) const;
- void banter (Array<Musical_pitch> pitch_arr, Chord_mol* name_p) const;
protected:
virtual Molecule do_brew_molecule () const;
{
public:
static Array<Musical_pitch> base_arr (Musical_pitch p);
- static void find_additions_and_subtractions(Array<Musical_pitch> pitch_arr, Array<Musical_pitch>* add_arr_p, Array<Musical_pitch>* sub_arr_p);
static int find_tonic_i (Array<Musical_pitch> const*);
static int find_pitch_i (Array<Musical_pitch> const*, Musical_pitch p);
static int find_notename_i (Array<Musical_pitch> const*, Musical_pitch p);
-;; 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" . "\12")))
-
- ; C-p/C-r current feta chars for sharp/flat
- ; don't use them: ly2dvi breaks (inputenc package)
- ;((0 . 1) . ("C" ("feta-1" . "\10")))
- ;((0 . -1) . ("C" ("feta-1" . "\12")))
- )
- 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))))
(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
projects / lilypond.git / commitdiff