+++ /dev/null
-/*
- key-performer.hh -- declare Key_performer
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1997--2000 Jan Nieuwenhuizen <janneke@gnu.org>
-*/
-
-#ifndef KEY_PERFOMER_HH
-#define KEY_PERFOMER_HH
-
-#include "lily-proto.hh"
-#include "performer.hh"
-
-class Key_performer : public Performer
-{
-public:
- VIRTUAL_COPY_CONS(Translator);
-
- Key_performer();
- ~Key_performer();
-
-protected:
- virtual bool do_try_music (Music* req_l);
- virtual void do_process_music ();
- virtual void do_pre_move_processing ();
-
-private:
- Key_change_req* key_req_l_;
- Audio_key* audio_p_;
-};
-
-#endif // KEY_PERFOMER_HH
+++ /dev/null
-/*
- lyric-performer.hh -- declare Lyric_performer
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1997--2000 Jan Nieuwenhuizen <janneke@gnu.org>
-*/
-
-
-#ifndef LYRIC_PERFOMER_HH
-#define LYRIC_PERFOMER_HH
-
-#include "lily-proto.hh"
-#include "performer.hh"
-#include "array.hh"
-
-class Lyric_performer : public Performer {
-public:
- VIRTUAL_COPY_CONS(Translator);
- Lyric_performer ();
-
-protected:
-
- virtual bool do_try_music (Music* req_l);
- virtual void do_process_music();
- virtual void do_pre_move_processing ();
-
-private:
- Link_array<Lyric_req> lreq_arr_;
- Audio_text* audio_p_;
-};
-
-#endif // LYRIC_PERFOMER_HH
+++ /dev/null
-/*
- note-performer.hh -- declare Note_performer
-
- (c) 1996--2000 Han-Wen Nienhuys <hanwen@cs.uu.nl>
- Jan Nieuwenhuizen <janneke@gnu.org>
- */
-
-#ifndef NOTE_PERFORMER_HH
-#define NOTE_PERFORMER_HH
-
-#include "performer.hh"
-
-/**
-Convert reqs to audio notes.
-*/
-class Note_performer : public Performer {
-public:
- VIRTUAL_COPY_CONS(Translator);
-
-
- Note_performer();
-
-protected:
- virtual void do_process_music ();
- virtual bool do_try_music (Music *req_l) ;
-
- virtual void do_pre_move_processing ();
- virtual void process_acknowledged ();
- Global_translator* global_translator_l ();
-
-private:
- Array<Note_req*> note_req_l_arr_;
- Array<Audio_note*> note_p_arr_;
- Array<Audio_note*> delayed_p_arr_;
-};
-
-#endif // NOTE_PERFORMER_HH
+++ /dev/null
-/*
- score-element-info.hh -- declare Score_element_info
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1997--2000 Han-Wen Nienhuys <hanwen@cs.uu.nl>
-*/
-
-
-#ifndef STAFFELEMINFO_HH
-#define STAFFELEMINFO_HH
-
-#include "lily-proto.hh"
-#include "parray.hh"
-
-/**
- Data container for broadcasts.
-
- TODO: Store this in element info!
- */
-struct Score_element_info {
- Translator * origin_trans_l_;
- friend Engraver;
-public:
- Link_array<Translator> origin_trans_l_arr (Translator*) const;
- Score_element * elem_l_;
- Music *req_l_;
-
-
- Score_element_info (Score_element*, Music*);
- Score_element_info();
-};
-
-
-#endif // STAFFELEMINFO_HH
+++ /dev/null
-/*
- score-element.hh -- declare Score_element
-
- (c) 1996-1999--2000 Han-Wen Nienhuys
-*/
-
-#ifndef STAFFELEM_HH
-#define STAFFELEM_HH
-
-#include "parray.hh"
-#include "virtual-methods.hh"
-#include "lily-guile.hh"
-#include "lily-proto.hh"
-#include "smobs.hh"
-#include "dimension-cache.hh"
-
-/**
- for administration of what was done already
- */
-enum Score_element_status {
- ORPHAN=0, // not yet added to Paper_score
- VIRGIN,
- PRECALCING,
- PRECALCED, // calcs before spacing done
- POSTCALCING, // busy calculating. This is used to trap cyclic deps.
- POSTCALCED, // after spacing calcs done
-};
-
-typedef void (Score_element::*Score_element_method_pointer) (void);
-
-/*
- Basic output object.
-*/
-class Score_element {
-public:
- SCM immutable_property_alist_;
- SCM mutable_property_alist_;
- Score_element *original_l_;
-
- /**
- Administration: Where are we?. This is mainly used by Super_element and
- Score_element::calcalute_dependencies ()
-
- 0 means ORPHAN,
- */
- char status_i_;
- String name () const;
-
- /*
- IDEA: make this a global variable. This is the same for all
- elements, I think it is safe to assume that we will not have
- scores being formatted multithreadedly.
- */
- Paper_score *pscore_l_;
-
- Score_element (SCM basic_props);
- Score_element (Score_element const&);
-
- /*
- properties
- */
- SCM get_elt_property (const char*) const;
- SCM get_elt_property (SCM) const;
- void set_elt_property (const char * , SCM val);
- void set_immutable_elt_property (const char * , SCM val);
- void set_immutable_elt_property (SCM key, SCM val);
- void set_elt_property (SCM , SCM val);
- void set_elt_pointer (const char*, SCM val);
- friend class Property_engraver; // UGHUGHUGH.
- SCM remove_elt_property (const char* nm);
-
- /*
- related classes.
- */
- Paper_def *paper_l () const;
-
- /**
- add a dependency. It may be the 0 pointer, in which case, it is ignored.
- */
- void add_dependency (Score_element*);
- virtual Line_of_score * line_l () const;
- bool linked_b () const;
-
-
- VIRTUAL_COPY_CONS(Score_element);
-
- /**
- Recursively track all dependencies of this Score_element. The
- status_i_ field is used as a mark-field. It is marked with
- #busy# during execution of this function, and marked with #final#
- when finished.
-
- #funcptr# is the function to call to update this element.
- */
- void calculate_dependencies (int final, int busy, SCM funcname);
- static SCM handle_broken_smobs (SCM, SCM criterion);
-
- virtual void do_break_processing ();
- virtual Score_element *find_broken_piece (Line_of_score*) const;
- virtual void discretionary_processing ();
- virtual SCM do_derived_mark ();
-
- Molecule * get_molecule () const;
- void suicide ();
-
- DECLARE_SCHEME_CALLBACK(preset_extent, (SCM smob, SCM axis));
- DECLARE_SCHEME_CALLBACK(point_dimension_callback, (SCM smob, SCM axis));
- DECLARE_SCHEME_CALLBACK(molecule_extent, (SCM smob, SCM axis));
-
-
- static SCM ly_set_elt_property (SCM, SCM,SCM);
- static SCM ly_get_elt_property (SCM, SCM);
-
- bool has_interface (SCM intf);
- void set_interface (SCM intf);
-
- virtual void handle_broken_dependencies ();
- virtual void handle_prebroken_dependencies ();
-
-
- DECLARE_SMOBS(Score_element,foo);
-
- void init ();
-
- Dimension_cache dim_cache_[NO_AXES];
-
-public:
- bool empty_b (Axis a) const;
-
- Interval extent (Score_element * refpoint, Axis) const;
-
- /**
- translate in one direction
- */
-
- void translate_axis (Real, Axis);
-
- /**
- Find the offset relative to D. If D equals THIS, then it is 0.
- Otherwise, it recursively defd as
-
- OFFSET_ + PARENT_L_->relative_coordinate (D)
- */
- Real relative_coordinate (Score_element const* refp, Axis) const;
- /**
- Find the group-element which has both #this# and #s#
- */
- Score_element*common_refpoint (Score_element const* s, Axis a) const;
- Score_element*common_refpoint (SCM elt_list, Axis a) const;
-
- // duh. slim down interface here. (todo)
- bool has_offset_callback_b (SCM callback, Axis)const;
- void add_offset_callback (SCM callback, Axis);
- bool has_extent_callback_b (SCM, Axis)const;
- void set_extent_callback (SCM , Axis);
- bool has_extent_callback_b (Axis) const;
-
-
- /**
- Invoke callbacks to get offset relative to parent.
- */
- Real get_offset (Axis a) const;
- /**
- Set the parent refpoint of THIS to E
- */
- void set_parent (Score_element* e, Axis);
-
- Score_element *parent_l (Axis a) const;
- DECLARE_SCHEME_CALLBACK(fixup_refpoint, (SCM));
-};
-
-Score_element * unsmob_element (SCM);
-
-#endif // STAFFELEM_HH
-
+++ /dev/null
-/*
- staff-performer.hh -- declare Staff_performer
-
- (c) 1996--2000 Han-Wen Nienhuys <hanwen@cs.uu.nl>
- Jan Nieuwenhuizen <janneke@gnu.org>
- */
-
-#ifndef STAFF_PERFORMER_HH
-#define STAFF_PERFORMER_HH
-
-#include "performer-group-performer.hh"
-
-/** Perform a staff. Individual notes should have their instrument
- (staff-wide) set, so we override play_element()
-
- */
-class Staff_performer : public Performer_group_performer
-{
-public:
- VIRTUAL_COPY_CONS(Translator);
-
-
- Staff_performer ();
- ~Staff_performer ();
-
- String new_instrument_str ();
- String instrument_str_;
-
-protected:
- virtual void play_element (Audio_element* p);
- virtual void do_removal_processing ();
- virtual void do_creation_processing ();
- virtual void do_process_music ();
- virtual void do_pre_move_processing ();
-
-private:
- Audio_staff* audio_staff_p_;
- Audio_instrument* instrument_p_;
- Audio_text* instrument_name_p_;
- Audio_text* name_p_;
- Audio_tempo* tempo_p_;
-};
-
-#endif // STAFF_PERFORMER_HH
+++ /dev/null
-/*
- tempo-performer.hh -- declare Tempo_performer
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1997--2000 Jan Nieuwenhuizen <janneke@gnu.org>
-*/
-
-#ifndef TEMPO_PERFORMER_HH
-#define TEMPO_PERFORMER_HH
-
-#include "lily-proto.hh"
-#include "performer.hh"
-
-class Tempo_performer : public Performer
-{
-public:
- VIRTUAL_COPY_CONS(Translator);
-
- Tempo_performer();
- ~Tempo_performer();
-
-protected:
-
- virtual bool do_try_music (Music* req_l);
- virtual void do_process_music();
- virtual void do_pre_move_processing ();
-
-private:
- Tempo_req* tempo_req_l_;
- Audio_tempo* audio_p_;
-};
-
-#endif // TEMPO_PERFORMER_HH
+++ /dev/null
-/*
- tie-performer.hh -- declare Tie_performer
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1999--2000 Jan Nieuwenhuizen <janneke@gnu.org>
-
- */
-
-#ifndef TIE_PERFORMER_HH
-#define TIE_PERFORMER_HH
-
-#include "pqueue.hh"
-#include "performer.hh"
-
-struct CNote_melodic_tuple {
- Melodic_req *req_l_ ;
- Audio_note *note_l_;
- Moment end_;
- CNote_melodic_tuple ();
- CNote_melodic_tuple (Audio_note*, Melodic_req*, Moment);
- static int pitch_compare (CNote_melodic_tuple const &, CNote_melodic_tuple const &);
- static int time_compare (CNote_melodic_tuple const &, CNote_melodic_tuple const &);
-};
-
-inline int compare (CNote_melodic_tuple const &a, CNote_melodic_tuple const &b)
-{
- return CNote_melodic_tuple::time_compare (a,b);
-}
-
-
-/**
- Manufacture ties. Acknowledge notes, and put them into a
- priority queue. If we have a Tie_req, connect the notes that finish
- just at this time, and note that start at this time.
-
- TODO: should share code with Tie_engraver ?
- */
-class Tie_performer : public Performer
-{
-public:
- VIRTUAL_COPY_CONS(Translator);
- Tie_performer ();
-
-private:
- PQueue<CNote_melodic_tuple> past_notes_pq_;
- Tie_req *req_l_;
- Array<CNote_melodic_tuple> now_notes_;
- Array<CNote_melodic_tuple> stopped_notes_;
- Link_array<Audio_tie> tie_p_arr_;
-
-protected:
- virtual void do_post_move_processing ();
- virtual void do_pre_move_processing ();
- virtual void acknowledge_element (Audio_element_info);
- virtual bool do_try_music (Music*);
- virtual void do_process_music ();
- virtual void process_acknowledged ();
-
-};
-
-
-#endif /* TIE_PERFORMER_HH */
-
+++ /dev/null
-/*
- time_signature-performer.hh -- declare Time_signature_performer
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1997--2000 Jan Nieuwenhuizen <janneke@gnu.org>
-*/
-
-#ifndef TIME_SIGNATURE_PERFORMER_HH
-#define TIME_SIGNATURE_PERFORMER_HH
-
-
-#endif // TIME_SIGNATURE_PERFORMER_HH
+++ /dev/null
-#if 0
-/*
- score-element-callback.cc -- implement Callback smob.
-
- source file of the GNU LilyPond music typesetter
-
- (c) 2000 Han-Wen Nienhuys <hanwen@cs.uu.nl>
-
- */
-
-#include "score-element-callback.hh"
-
-static SCM callback_tag;
-
-static
-SCM mark_smob (SCM)
-{
- return SCM_EOL;
-}
-
-static int
-print_smob (SCM, SCM port, scm_print_state *)
-{
- scm_puts ("#<Callback>", port);
- return 1;
-}
-
-static
-scm_sizet free_smob (SCM)
-{
- return 0;
-}
-
-static
-void start_callback_smobs()
-{
- callback_tag = scm_make_smob_type_mfpe ("callback", 0,
- mark_smob, free_smob,
- print_smob, 0);
-}
-
-
-SCM
-smobify_callback (Score_element_callback cb )
-{
- SCM z;
-
- SCM_NEWCELL(z);
- SCM_SETCDR (z, (SCM)cb);
- SCM_SETCAR (z, (SCM)callback_tag);
-
- return z;
-}
-
-ADD_SCM_INIT_FUNC(callback, start_callback_smobs);
-#endif
+++ /dev/null
-/*
- score-element-info.cc -- implement Score_element_info
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1997--2000 Han-Wen Nienhuys <hanwen@cs.uu.nl>
-*/
-
-#include "score-element-info.hh"
-#include "request.hh"
-#include "translator.hh"
-#include "translator-group.hh"
-
-Score_element_info::Score_element_info (Score_element*s_l, Music *r_l)
-{
- elem_l_ = s_l;
- req_l_ = r_l;
- origin_trans_l_ = 0;
-}
-
-
-Score_element_info::Score_element_info()
-{
- elem_l_ = 0;
- req_l_ = 0;
- origin_trans_l_ = 0;
-}
-
-
-Link_array<Translator>
-Score_element_info::origin_trans_l_arr (Translator* end) const
-{
- Translator * t = origin_trans_l_;
- Link_array<Translator> r;
- do {
- r.push (t);
- t = t->daddy_trans_l_;
- } while (t && t != end->daddy_trans_l_);
-
- return r;
-}
-
+++ /dev/null
-/*
- score-elem.cc -- implement Score_element
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1997--2000 Han-Wen Nienhuys <hanwen@cs.uu.nl>
-*/
-
-
-#include <string.h>
-#include <math.h>
-
-#include "input-smob.hh"
-#include "libc-extension.hh"
-#include "group-interface.hh"
-#include "misc.hh"
-#include "paper-score.hh"
-#include "paper-def.hh"
-#include "molecule.hh"
-#include "score-element.hh"
-#include "debug.hh"
-#include "spanner.hh"
-#include "line-of-score.hh"
-#include "item.hh"
-#include "paper-column.hh"
-#include "molecule.hh"
-#include "misc.hh"
-#include "paper-outputter.hh"
-#include "dimension-cache.hh"
-#include "side-position-interface.hh"
-#include "item.hh"
-
-#include "ly-smobs.icc"
-
-/*
-TODO:
-
-remove dynamic_cast<Spanner,Item> and put this code into respective
- subclass.
-*/
-
-
-#define INFINITY_MSG "Infinity or NaN encountered"
-
-Score_element::Score_element(SCM basicprops)
-{
- /*
- fixme: default should be no callback.
- */
-
- pscore_l_=0;
- status_i_ = 0;
- original_l_ = 0;
- immutable_property_alist_ = basicprops;
- mutable_property_alist_ = SCM_EOL;
-
- smobify_self ();
-
- char const*onames[] = {"X-offset-callbacks", "Y-offset-callbacks"};
- char const*enames[] = {"X-extent-callback", "Y-extent-callback"};
-
- for (int a = X_AXIS; a <= Y_AXIS; a++){
- SCM l = get_elt_property (onames[a]);
-
- if (scm_ilength (l) >=0)
- {
- dim_cache_[a].offset_callbacks_ = l;
- dim_cache_[a].offsets_left_ = scm_ilength (l);
- }
- else
- {
- programming_error ("[XY]-offset-callbacks must be a list");
- }
-
- SCM cb = get_elt_property (enames[a]);
-
- /*
- Should change default to be empty?
- */
- if (!gh_procedure_p (cb) && !gh_pair_p (cb))
- cb = molecule_extent_proc;
-
- dim_cache_[a].dimension_ = cb;
- }
-
- SCM meta = get_elt_property ("meta");
- SCM ifs = scm_assoc (ly_symbol2scm ("interfaces"), meta);
-
- set_elt_property ("interfaces",gh_cdr (ifs));
-}
-
-
-Score_element::Score_element (Score_element const&s)
- : dim_cache_ (s.dim_cache_)
-{
- original_l_ =(Score_element*) &s;
- immutable_property_alist_ = s.immutable_property_alist_;
- mutable_property_alist_ = SCM_EOL;
-
- status_i_ = s.status_i_;
- pscore_l_ = s.pscore_l_;
-
- smobify_self ();
-}
-
-Score_element::~Score_element()
-{
- /*
- do nothing scm-ish and no unprotecting here.
- */
-}
-
-
-SCM
-Score_element::get_elt_property (const char *nm) const
-{
- SCM sym = ly_symbol2scm (nm);
- return get_elt_property (sym);
-}
-
-SCM
-Score_element::get_elt_property (SCM sym) const
-{
- SCM s = scm_sloppy_assq(sym, mutable_property_alist_);
- if (s != SCM_BOOL_F)
- return gh_cdr (s);
-
- s = scm_sloppy_assq (sym, immutable_property_alist_);
- return (s == SCM_BOOL_F) ? SCM_EOL : gh_cdr (s);
-}
-
-/*
- Remove the value associated with KEY, and return it. The result is
- that a next call will yield SCM_UNDEFINED (and not the underlying
- `basic' property.
-*/
-SCM
-Score_element::remove_elt_property (const char* key)
-{
- SCM val = get_elt_property (key);
- if (val != SCM_EOL)
- set_elt_property (key, SCM_EOL);
- return val;
-}
-
-void
-Score_element::set_elt_property (const char* k, SCM v)
-{
- SCM s = ly_symbol2scm (k);
- set_elt_property (s, v);
-}
-
-/*
- Puts the k, v in the immutable_property_alist_, which is convenient for
- storing variables that are needed during the breaking process. (eg.
- Line_of_score::rank : int )
- */
-void
-Score_element::set_immutable_elt_property (const char*k, SCM v)
-{
- SCM s = ly_symbol2scm (k);
- set_immutable_elt_property (s, v);
-}
-
-void
-Score_element::set_immutable_elt_property (SCM s, SCM v)
-{
- immutable_property_alist_ = gh_cons (gh_cons (s,v), mutable_property_alist_);
- mutable_property_alist_ = scm_assq_remove_x (mutable_property_alist_, s);
-}
-void
-Score_element::set_elt_property (SCM s, SCM v)
-{
- mutable_property_alist_ = scm_assq_set_x (mutable_property_alist_, s, v);
-}
-
-
-MAKE_SCHEME_CALLBACK(Score_element,molecule_extent,2);
-SCM
-Score_element::molecule_extent (SCM element_smob, SCM scm_axis)
-{
- Score_element *s = unsmob_element (element_smob);
- Axis a = (Axis) gh_scm2int (scm_axis);
-
- Molecule *m = s->get_molecule ();
- Interval e ;
- if (m)
- e = m->extent(a);
- return ly_interval2scm ( e);
-}
-
-MAKE_SCHEME_CALLBACK(Score_element,preset_extent,2);
-
-SCM
-Score_element::preset_extent (SCM element_smob, SCM scm_axis)
-{
- Score_element *s = unsmob_element (element_smob);
- Axis a = (Axis) gh_scm2int (scm_axis);
-
- SCM ext = s->get_elt_property ((a == X_AXIS)
- ? "extent-X"
- : "extent-Y");
-
- if (gh_pair_p (ext))
- {
- Real l = gh_scm2double (gh_car (ext));
- Real r = gh_scm2double (gh_cdr (ext));
- return ly_interval2scm (Interval (l, r));
- }
-
- return ly_interval2scm ( Interval ());
-}
-
-
-
-Paper_def*
-Score_element::paper_l () const
-{
- return pscore_l_ ? pscore_l_->paper_l_ : 0;
-}
-
-void
-Score_element::calculate_dependencies (int final, int busy, SCM funcname)
-{
- assert (status_i_ >=0);
-
- if (status_i_ >= final)
- return;
-
- if (status_i_== busy)
- {
- programming_error ("Element is busy, come back later");
- return;
- }
-
- status_i_= busy;
-
- for (SCM d= get_elt_property ("dependencies"); gh_pair_p (d); d = gh_cdr (d))
- {
- unsmob_element (gh_car (d))
- ->calculate_dependencies (final, busy, funcname);
- }
-
- // ughugh.
- String s = ly_symbol2string (funcname);
- SCM proc = get_elt_property (s.ch_C());
- if (gh_procedure_p (proc))
- gh_call1 (proc, this->self_scm ());
-
- status_i_= final;
-
-}
-
-Molecule *
-Score_element::get_molecule () const
-{
- SCM mol = get_elt_property ("molecule");
- if (unsmob_molecule (mol))
- return unsmob_molecule (mol);
-
- SCM proc = get_elt_property ("molecule-callback");
-
- mol = SCM_EOL;
- if (gh_procedure_p (proc))
- mol = gh_apply (proc, gh_list (this->self_scm (), SCM_UNDEFINED));
-
-
- /*
- TODO: add option for not copying origin info.
- */
- SCM origin =get_elt_property ("origin");
- if (!unsmob_input (origin))
- origin =ly_symbol2scm ("no-origin");
-
- if (gh_pair_p (mol))
- {
- // ugr.
- mol = gh_cons (gh_list (origin, gh_car (mol), SCM_UNDEFINED), gh_cdr (mol));
- }
-
- Molecule *m = unsmob_molecule (mol);
-
-
- /*
- transparent retains dimensions of element.
- */
- if (m && to_boolean (get_elt_property ("transparent")))
- mol = Molecule (m->extent_box (), SCM_EOL).smobbed_copy ();
-
- Score_element *me = (Score_element*)this;
- me->set_elt_property ("molecule", mol);
-
- m = unsmob_molecule (mol);
- return m;
-}
-
-
-/*
-
- VIRTUAL STUBS
-
- */
-void
-Score_element::do_break_processing()
-{
-}
-
-
-
-
-
-
-Line_of_score *
-Score_element::line_l() const
-{
- return 0;
-}
-
-void
-Score_element::add_dependency (Score_element*e)
-{
- if (e)
- {
- Pointer_group_interface ::add_element (this, "dependencies",e);
-
- }
- else
- programming_error ("Null dependency added");
-}
-
-
-
-
-/**
- Do break substitution in S, using CRITERION. Return new value.
- CRITERION is either a SMOB pointer to the desired line, or a number
- representing the break direction. Do not modify SRC.
-*/
-SCM
-Score_element::handle_broken_smobs (SCM src, SCM criterion)
-{
- again:
- Score_element *sc = unsmob_element (src);
- if (sc)
- {
- if (gh_number_p (criterion))
- {
- Item * i = dynamic_cast<Item*> (sc);
- Direction d = to_dir (criterion);
- if (i && i->break_status_dir () != d)
- {
- Item *br = i->find_prebroken_piece (d);
- return (br) ? br->self_scm () : SCM_UNDEFINED;
- }
- }
- else
- {
- Line_of_score * line
- = dynamic_cast<Line_of_score*> (unsmob_element (criterion));
- if (sc->line_l () != line)
- {
- sc = sc->find_broken_piece (line);
-
- }
-
- /* now: !sc || (sc && sc->line_l () == line) */
- if (!sc)
- return SCM_UNDEFINED;
-
- /* now: sc && sc->line_l () == line */
- if (!line
- || (sc->common_refpoint (line, X_AXIS)
- && sc->common_refpoint (line, Y_AXIS)))
- {
- return sc->self_scm ();
- }
- return SCM_UNDEFINED;
- }
- }
- else if (gh_pair_p (src))
- {
- SCM oldcar =gh_car (src);
- /*
- UGH! breaks on circular lists.
- */
- SCM newcar = handle_broken_smobs (oldcar, criterion);
- SCM oldcdr = gh_cdr (src);
-
- if (newcar == SCM_UNDEFINED
- && (gh_pair_p (oldcdr) || oldcdr == SCM_EOL))
- {
- /*
- This is tail-recursion, ie.
-
- return handle_broken_smobs (cdr, criterion);
-
- We don't want to rely on the compiler to do this. Without
- tail-recursion, this easily crashes with a stack overflow. */
- src = oldcdr;
- goto again;
- }
-
- SCM newcdr = handle_broken_smobs (oldcdr, criterion);
- return gh_cons (newcar, newcdr);
- }
- else
- return src;
-
- return src;
-}
-
-void
-Score_element::handle_broken_dependencies()
-{
- Spanner * s= dynamic_cast<Spanner*> (this);
- if (original_l_ && s)
- return;
-
- if (s)
- {
- for (int i = 0; i< s->broken_into_l_arr_ .size (); i++)
- {
- Score_element * sc = s->broken_into_l_arr_[i];
- Line_of_score * l = sc->line_l ();
- sc->mutable_property_alist_ =
- handle_broken_smobs (mutable_property_alist_,
- l ? l->self_scm () : SCM_UNDEFINED);
- }
- }
-
-
- Line_of_score *line = line_l();
-
- if (line && common_refpoint (line, X_AXIS) && common_refpoint (line, Y_AXIS))
- {
- mutable_property_alist_
- = handle_broken_smobs (mutable_property_alist_,
- line ? line->self_scm () : SCM_UNDEFINED);
- }
- else if (dynamic_cast <Line_of_score*> (this))
- {
- mutable_property_alist_ = handle_broken_smobs (mutable_property_alist_,
- SCM_UNDEFINED);
- }
- else
- {
- /*
- This element is `invalid'; it has been removed from all
- dependencies, so let's junk the element itself.
-
- do not do this for Line_of_score, since that would remove
- references to the originals of score-elts, which get then GC'd
- (a bad thing.)
- */
- suicide();
- }
-}
-
-/*
- Note that we still want references to this element to be
- rearranged, and not silently thrown away, so we keep pointers
- like {broken_into_{drul,array}, original}
-*/
-void
-Score_element::suicide ()
-{
- mutable_property_alist_ = SCM_EOL;
- immutable_property_alist_ = SCM_EOL;
-
- set_extent_callback (SCM_EOL, Y_AXIS);
- set_extent_callback (SCM_EOL, X_AXIS);
-
- for (int a= X_AXIS; a <= Y_AXIS; a++)
- {
- dim_cache_[a].offset_callbacks_ = SCM_EOL;
- dim_cache_[a].offsets_left_ = 0;
- }
-}
-
-void
-Score_element::handle_prebroken_dependencies()
-{
-}
-
-Score_element*
-Score_element::find_broken_piece (Line_of_score*) const
-{
- return 0;
-}
-
-void
-Score_element::translate_axis (Real y, Axis a)
-{
- if (isinf (y) || isnan (y))
- programming_error (_(INFINITY_MSG));
- else
- {
- dim_cache_[a].offset_ += y;
- }
-}
-
-Real
-Score_element::relative_coordinate (Score_element const*refp, Axis a) const
-{
- if (refp == this)
- return 0.0;
-
- /*
- We catch PARENT_L_ == nil case with this, but we crash if we did
- not ask for the absolute coordinate (ie. REFP == nil.)
-
- */
- if (refp == dim_cache_[a].parent_l_)
- return get_offset (a);
- else
- return get_offset (a) + dim_cache_[a].parent_l_->relative_coordinate (refp, a);
-}
-
-Real
-Score_element::get_offset (Axis a) const
-{
- Score_element *me = (Score_element*) this;
- while (dim_cache_[a].offsets_left_)
- {
- int l = --me->dim_cache_[a].offsets_left_;
- SCM cb = scm_list_ref (dim_cache_[a].offset_callbacks_, gh_int2scm (l));
- SCM retval = gh_call2 (cb, self_scm (), gh_int2scm (a));
-
- Real r = gh_scm2double (retval);
- if (isinf (r) || isnan (r))
- {
- programming_error (INFINITY_MSG);
- r = 0.0;
- }
- me->dim_cache_[a].offset_ +=r;
- }
- return dim_cache_[a].offset_;
-}
-
-
-MAKE_SCHEME_CALLBACK(Score_element,point_dimension_callback,2);
-SCM
-Score_element::point_dimension_callback (SCM , SCM )
-{
- return ly_interval2scm ( Interval (0,0));
-}
-
-bool
-Score_element::empty_b (Axis a)const
-{
- return ! (gh_pair_p (dim_cache_[a].dimension_ ) ||
- gh_procedure_p (dim_cache_[a].dimension_ ));
-}
-
-/*
- TODO: add
-
- Score_element *refpoint
-
- to arguments?
- */
-Interval
-Score_element::extent (Score_element * refp, Axis a) const
-{
- Real x = relative_coordinate (refp, a);
-
-
- Dimension_cache * d = (Dimension_cache *)&dim_cache_[a];
- Interval ext ;
- if (gh_pair_p (d->dimension_))
- ;
- else if (gh_procedure_p (d->dimension_))
- {
- /*
- FIXME: add doco on types, and should typecheck maybe?
- */
- d->dimension_= gh_call2 (d->dimension_, self_scm(), gh_int2scm (a));
- }
- else
- return ext;
-
- if (!gh_pair_p (d->dimension_))
- return ext;
-
- ext = ly_scm2interval (d->dimension_);
-
- SCM extra = get_elt_property (a == X_AXIS
- ? "extra-extent-X"
- : "extra-extent-Y");
-
- /*
- signs ?
- */
- if (gh_pair_p (extra))
- {
- ext[BIGGER] += gh_scm2double (gh_cdr (extra));
- ext[SMALLER] += gh_scm2double (gh_car (extra));
- }
-
- extra = get_elt_property (a == X_AXIS
- ? "minimum-extent-X"
- : "minimum-extent-Y");
- if (gh_pair_p (extra))
- {
- ext.unite (Interval (gh_scm2double (gh_car (extra)),
- gh_scm2double (gh_cdr (extra))));
- }
-
- ext.translate (x);
-
- return ext;
-}
-
-
-Score_element*
-Score_element::parent_l (Axis a) const
-{
- return dim_cache_[a].parent_l_;
-}
-
-Score_element *
-Score_element::common_refpoint (Score_element const* s, Axis a) const
-{
- /*
- I don't like the quadratic aspect of this code, but I see no other
- way. The largest chain of parents might be 10 high or so, so
- it shouldn't be a real issue. */
- for (Score_element const *c = this; c; c = c->dim_cache_[a].parent_l_)
- for (Score_element const * d = s; d; d = d->dim_cache_[a].parent_l_)
- if (d == c)
- return (Score_element*)d;
-
- return 0;
-}
-
-
-Score_element *
-Score_element::common_refpoint (SCM elist, Axis a) const
-{
- Score_element * common = (Score_element*) this;
- for (; gh_pair_p (elist); elist = gh_cdr (elist))
- {
- Score_element * s = unsmob_element (gh_car (elist));
- if (s)
- common = common->common_refpoint (s, a);
- }
-
- return common;
-}
-
-String
-Score_element::name () const
-{
- SCM meta = get_elt_property ("meta");
- SCM nm = scm_assoc (ly_symbol2scm ("name"), meta);
- nm = (gh_pair_p (nm)) ? gh_cdr (nm) : SCM_EOL;
- return gh_string_p (nm) ?ly_scm2string (nm) : classname (this);
-}
-
-void
-Score_element::add_offset_callback (SCM cb, Axis a)
-{
- if (!has_offset_callback_b (cb, a))
- {
- dim_cache_[a].offset_callbacks_ = gh_cons (cb, dim_cache_[a].offset_callbacks_ );
- dim_cache_[a].offsets_left_ ++;
- }
-}
-
-bool
-Score_element::has_extent_callback_b (SCM cb, Axis a)const
-{
- return scm_equal_p (cb, dim_cache_[a].dimension_);
-}
-
-
-bool
-Score_element::has_extent_callback_b (Axis a) const
-{
- return gh_procedure_p (dim_cache_[a].dimension_);
-}
-
-bool
-Score_element::has_offset_callback_b (SCM cb, Axis a)const
-{
- return scm_memq (cb, dim_cache_[a].offset_callbacks_) != SCM_BOOL_F;
-}
-
-void
-Score_element::set_extent_callback (SCM dc, Axis a)
-{
- dim_cache_[a].dimension_ =dc;
-}
-
-void
-Score_element::set_parent (Score_element *g, Axis a)
-{
- dim_cache_[a].parent_l_ = g;
-}
-
-MAKE_SCHEME_CALLBACK(Score_element,fixup_refpoint,1);
-SCM
-Score_element::fixup_refpoint (SCM smob)
-{
- Score_element *me = unsmob_element (smob);
- for (int a = X_AXIS; a < NO_AXES; a ++)
- {
- Axis ax = (Axis)a;
- Score_element * parent = me->parent_l (ax);
-
- if (!parent)
- continue;
-
- if (parent->line_l () != me->line_l () && me->line_l ())
- {
- Score_element * newparent = parent->find_broken_piece (me->line_l ());
- me->set_parent (newparent, ax);
- }
-
- if (Item * i = dynamic_cast<Item*> (me))
- {
- Item *parenti = dynamic_cast<Item*> (parent);
-
- if (parenti && i)
- {
- Direction my_dir = i->break_status_dir () ;
- if (my_dir!= parenti->break_status_dir())
- {
- Item *newparent = parenti->find_prebroken_piece (my_dir);
- me->set_parent (newparent, ax);
- }
- }
- }
- }
- return smob;
-}
-
-
-
-/****************************************************
- SMOB funcs
- ****************************************************/
-
-
-IMPLEMENT_UNSMOB(Score_element, element);
-IMPLEMENT_SMOBS(Score_element);
-IMPLEMENT_DEFAULT_EQUAL_P(Score_element);
-
-SCM
-Score_element::mark_smob (SCM ses)
-{
- Score_element * s = (Score_element*) SCM_CELL_WORD_1(ses);
- scm_gc_mark (s->immutable_property_alist_);
- scm_gc_mark (s->mutable_property_alist_);
-
- for (int a =0 ; a < 2; a++)
- {
- scm_gc_mark (s->dim_cache_[a].offset_callbacks_);
- scm_gc_mark (s->dim_cache_[a].dimension_);
- }
-
- if (s->parent_l (Y_AXIS))
- scm_gc_mark (s->parent_l (Y_AXIS)->self_scm ());
- if (s->parent_l (X_AXIS))
- scm_gc_mark (s->parent_l (X_AXIS)->self_scm ());
-
- if (s->original_l_)
- scm_gc_mark (s->original_l_->self_scm ());
- return s->do_derived_mark ();
-}
-
-int
-Score_element::print_smob (SCM s, SCM port, scm_print_state *)
-{
- Score_element *sc = (Score_element *) gh_cdr (s);
-
- scm_puts ("#<Score_element ", port);
- scm_puts ((char *)sc->name ().ch_C(), port);
-
- /*
- don't try to print properties, that is too much hassle.
- */
- scm_puts (" >", port);
- return 1;
-}
-
-SCM
-Score_element::do_derived_mark ()
-{
- return SCM_EOL;
-}
-
-
-SCM
-ly_set_elt_property (SCM elt, SCM sym, SCM val)
-{
- Score_element * sc = unsmob_element (elt);
-
- if (!gh_symbol_p (sym))
- {
- error ("Not a symbol");
- ly_display_scm (sym);
- return SCM_UNSPECIFIED;
- }
-
- if (sc)
- {
- sc->set_elt_property (sym, val);
- }
- else
- {
- error ("Not a score element");
- ly_display_scm (elt);
- }
-
- return SCM_UNSPECIFIED;
-}
-
-
-SCM
-ly_get_elt_property (SCM elt, SCM sym)
-{
- Score_element * sc = unsmob_element (elt);
-
- if (sc)
- {
- return sc->get_elt_property (sym);
- }
- else
- {
- error ("Not a score element");
- ly_display_scm (elt);
- }
- return SCM_UNSPECIFIED;
-}
-
-
-void
-Score_element::discretionary_processing()
-{
-}
-
-
-
-SCM
-spanner_get_bound (SCM slur, SCM dir)
-{
- return dynamic_cast<Spanner*> (unsmob_element (slur))->get_bound (to_dir (dir))->self_scm ();
-}
-
-
-
-static SCM interfaces_sym;
-static void
-init_functions ()
-{
- interfaces_sym = scm_permanent_object (ly_symbol2scm ("interfaces"));
-
- scm_make_gsubr ("ly-get-elt-property", 2, 0, 0, (Scheme_function_unknown)ly_get_elt_property);
- scm_make_gsubr ("ly-set-elt-property", 3, 0, 0, (Scheme_function_unknown)ly_set_elt_property);
- scm_make_gsubr ("ly-get-spanner-bound", 2 , 0, 0, (Scheme_function_unknown) spanner_get_bound);
-}
-
-bool
-Score_element::has_interface (SCM k)
-{
- SCM ifs = get_elt_property (interfaces_sym);
-
- return scm_memq (k, ifs) != SCM_BOOL_F;
-}
-
-void
-Score_element::set_interface (SCM k)
-{
- if (has_interface (k))
- return ;
- else
- {
- set_elt_property (interfaces_sym,
- gh_cons (k, get_elt_property (interfaces_sym)));
- }
-}
-
-
-ADD_SCM_INIT_FUNC(scoreelt, init_functions);
-IMPLEMENT_TYPE_P(Score_element, "ly-element?");
+++ /dev/null
-;;; chord.scm -- to be included in/to replace chord-name.scm
-;;; 2000 janneke@gnu.org
-;;;
-
-(use-modules
- (ice-9 debug)
- ;; urg, these two only to guess if a '/' is needed to separate
- ;; user-chord-name and additions/subtractions
- (ice-9 format)
- (ice-9 regex)
- )
-
-;;
-;; (octave notename accidental)
-;;
-
-;;
-;; text: scm markup text -- see font.scm and input/test/markup.ly
-;;
-
-;; TODO
-;;
-;; * clean split of base/banter/american stuff
-;; * text definition is rather ad-hoc
-;; * do without format module
-;; * finish and check american names
-;; * make notename (tonic) configurable from lilypond
-;; * fix append/cons stuff in inner-name-banter
-;; * doc strings.
-
-
-;;;;;;;;;
-(define chord::names-alist-banter '())
-(set! chord::names-alist-banter
- (append
- '(
- ; C iso C.no3.no5
- (((0 . 0)) . #f)
- ; C iso C.no5
- (((0 . 0) (2 . 0)) . #f)
- ; Cm iso Cm.no5
- (((0 . 0) (2 . -1)) . ("m"))
- ; C2 iso C2.no3
- (((0 . 0) (1 . 0) (4 . 0)) . (super "2"))
- ; C4 iso C4.no3
- (((0 . 0) (3 . 0) (4 . 0)) . (super "4"))
- ; Cdim iso Cm5-
- (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
- ; Co iso Cm5-7-
- ; urg
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super "o"))
- ; Cdim9
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9")))
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11")))
- )
- chord::names-alist-banter))
-
-
-;; NOTE: Duplicates of chord names defined elsewhere occur in this list
-;; in order to prevent spurious superscripting of various chord names,
-;; such as maj7, maj9, etc.
-;;
-;; See input/test/american-chords.ly
-;;
-;; James Hammons, <jlhamm@pacificnet.net>
-;;
-
-;; DONT use non-ascii characters, even if ``it works'' in Windows
-
-(define chord::names-alist-american '())
-
-(set! chord::names-alist-american
- (append
- '(
- (((0 . 0)) . #f)
- (((0 . 0) (2 . 0)) . #f)
- ;; Root-fifth chord
- (((0 . 0) (4 . 0)) . ("5"))
- ;; Common triads
- (((0 . 0) (2 . -1)) . ("m"))
- (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
- (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
-;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ((super "o")))
- (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
-;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
- (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
- ;; Common seventh chords
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (rows (super "o") "7"))
- (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
- (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("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)) . (rows ((raise . 1) "o") ((raise . 0.5) ((kern . -0.5) ((font-relative-size . -3) "/"))) "7")) ; slashed o
- (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
- (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (rows "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
- (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
- (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
- ;; Common ninth chords
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6"))
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
- (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
- (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
-
- )
- chord::names-alist-american))
-
-;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
-;; NBs: This uses the american list as a base.
-;; 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-jazz-name and inner-american-name functions;
-;;
-;;
-;;
-;; DONT use non-ascii characters, even if ``it works'' in Windows
-
-(define chord::names-alist-jazz '())
-(set! chord::names-alist-jazz
- (append
- '(
- ;; major chords
- ; major sixth chord = 6
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (((raise . 0.5) "6")))
- ; major seventh chord = triangle
- (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . "math") "M"))))
- ; major chord add nine = add9
- (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (((raise . 0.5) "add9")))
- ; major sixth chord with nine = 6/9
- (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (((raise . 0.5) "6/9")))
-
- ;; minor chords
- ; minor sixth chord = m6
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (rows("m")((raise . 0.5) "6")))
- ; minor major seventh chord = m triangle
- (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (rows ("m") ((raise . 0.5)((font-family . "math") "M"))))
- ; minor seventh chord = m7
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (rows("m")((raise . 0.5) "7")))
- ; minor sixth nine chord = m6/9
- (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "6/9")))
- ; minor with added nine chord = madd9
- (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "add9")))
- ; minor ninth chord = m9
- (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (rows("m")((raise . 0.5) "9")))
-
- ;; dominant chords
- ; dominant seventh = 7
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (((raise . 0.5) "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)) . (rows("+")((raise . 0.5) "7"))) ; +7 with 7 raised
- ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (rows((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)) . (rows((raise . 0.5) "7(")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.5) "5)")))
- ; dominant 9 = 7(9)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (((raise . 0.8)"7(9)")))
- ; dominant flat 9 = 7(b9)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) . (
- ((raise . 0.8)"7(")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.8)"9)")))
- ; dominant sharp 9 = 7(#9)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) . (
- ((raise . 0.8)"7(")
- ((raise . 0.3)(music (named ("accidentals-1"))))
- ((raise . 0.8)"9)")))
- ; dominant 13 = 7(13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) . (((raise . 0.8)"7(13)")))
- ; dominant flat 13 = 7(b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) . (
- ((raise . 0.8)"7(")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.8)"13)")))
- ; dominant 9, 13 = 7(9,13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) . (((raise . 0.8)"7(9, 13)")))
- ; dominant flat 9, 13 = 7(b9,13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) . (
- ((raise . 0.8)"7(")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.8)"9, 13)")))
- ; dominant sharp 9, 13 = 7(#9,13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) . (
- ((raise . 0.8)"7(")
- ((raise . 0.3)(music (named ("accidentals-1"))))
- ((raise . 0.8)"9, 13)")))
- ; dominant 9, flat 13 = 7(9,b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) . (
- ((raise . 0.8)"7(9, ")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.8)"13)")))
- ; dominant flat 9, flat 13 = 7(b9,b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) . (
- ((raise . 0.8)"7(")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.8)"9, ")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.8)"13)")))
- ; dominant sharp 9, flat 13 = 7(#9,b13)
- (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) . (
- ((raise . 0.8)"7(")
- ((raise . 0.3)(music (named ("accidentals-1"))))
- ((raise . 0.8)"9, ")
- ((raise . 0.3)(music (named ("accidentals--1"))))
- ((raise . 0.8)"13)")))
-
- ;; diminished chord(s)
- ; diminished seventh chord = o
-
-
- ;; DONT use non-ascii characters, even if ``it works'' in Windows
-
- ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (((raise . 0.8)"o"))); works, but "o" is a little big
- (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
-
- ;; half diminshed chords
- ; half diminished seventh chord = slashed o
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8)"/o")))
- ; half diminished seventh chord with major 9 = slashed o cancelation 9
- (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
- ((raise . 0.8)"/o(")
- ((raise . 0.3)(music (named ("accidentals-0"))))
- ((raise . 0.8)"9)")));
-
-;; Missing jazz chord definitions go here (note new syntax: see american for hints)
-
- )
- 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
- (append '(music)
- (list
- (append '(named)
- (list
- (append '((font-relative-size . -2))
- (list (append '((raise . 0.6))
- (list
- (string-append "accidentals-"
- (number->string (caddr pitch)))))))))))))))
-
-(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 -1 -1 0)))
-
-;; compute the relative-to-tonic pitch that goes with 'step'
-(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)))))
-
-;; combine tonic, user-specified chordname,
-;; additions, subtractions and base or inversion to chord name
-;;
-(define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
- (apply append
- '(rows)
- (pitch->text-banter tonic)
- (if user-name user-name '())
- ;; why does list->string not work, format seems only hope...
- (if (and (string-match "super" (format "~s" user-name))
- (or (pair? additions)
- (pair? subtractions)))
- '((super "/"))
- '())
- (let loop ((from additions) (to '()))
- (if (pair? from)
- (let ((p (car from)))
- (loop (cdr from)
- (append to
- (cons
- (list 'super (step->text-banter p))
- (if (or (pair? (cdr from))
- (pair? subtractions))
- '((super "/"))
- '())))))
- to))
- (let loop ((from subtractions) (to '()))
- (if (pair? from)
- (let ((p (car from)))
- (loop (cdr from)
- (append to
- (cons '(super "no")
- (cons
- (list 'super (step->text-banter p))
- (if (pair? (cdr from))
- '((super "/"))
- '())))))) ; nesting?
- 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)))
-
-;; american chordnames use no "no",
-;; but otherwise very similar to banter for now
-(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)))
-
-;; Jazz style--basically similar to american with minor changes
-(define (chord::name-jazz 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 (new-to-old-pitch p)
- (if (pitch? p)
- (list (pitch-octave p) (pitch-notename p) (pitch-alteration p))
- #f
- ))
-
-
-
-;; 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.
-;;
-(define (default-chord-name-function style pitches base-and-inversion)
- ;(display "pitches:") (display pitches) (newline)
- ;(display "style:") (display style) (newline)
- ;(display "b&i:") (display base-and-inversion) (newline)
- (set! pitches (map new-to-old-pitch pitches))
- (set! base-and-inversion (cons (new-to-old-pitch (car base-and-inversion))
- (new-to-old-pitch (cdr base-and-inversion))))
-
- (let ((diff (pitch::diff '(0 0 0) (car pitches)))
- (name-func
- (ly-eval (string->symbol (string-append "chord::name-" style))))
- (names-alist
- (ly-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))))))
-
-
projects / lilypond.git / commitdiff