Scheme.
* lily/parser.yy (new_chord): new setup for chord entry.
+2003-02-16 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * scm/chord-entry.scm (construct-chord): move chord construction
+ Scheme.
+
+ * lily/parser.yy (new_chord): new setup for chord entry.
+
2003-02-16 Heikki Junes <hjunes@cc.hut.fi>
* lilypond.words:
} else if ((pitch = scm_hashq_get_handle (chordmodifier_tab_, sym))!= SCM_BOOL_F)
{
yylval.scm = ly_cdr (pitch);
- return CHORDMODIFIER_PITCH;
+ return CHORD_MODIFIER;
}
}
}
+SCM
+make_chord_step (int step, int alter)
+{
+ if (step == 7)
+ alter--;
+
+ /* ugh: fucks up above 13 */
+ Pitch m(step > 7 ? 1 : 0,(step - 1) % 7, alter);
+ return m.smobbed_copy ();
+}
+
+
+SCM
+make_chord (SCM pitch, SCM dur, SCM modification_list)
+{
+ static SCM chord_ctor;
+ if (!chord_ctor)
+ chord_ctor= scm_c_eval_string ("construct-chord");
+ SCM ch= scm_call_3 (chord_ctor, pitch, dur, modification_list);
+ scm_gc_protect_object (ch);
+ return ch;
+}
+
+
Music*
set_property_music (SCM sym, SCM value)
%token ALTERNATIVE
%token BAR
%token BREATHE
-%token CHORDMODIFIERS
+%token CHORDMODIFIERS
%token CHORDS
%token CLEF
%token CONSISTS
%token <scm> FRACTION
%token <id> IDENTIFIER
%token <scm> CHORDNAMES CHORDNAMES_IDENTIFIER
-%type <scm> chordnames_block chordnames_list chord_scm
+%token <scm> CHORD_MODIFIER
%token <scm> SCORE_IDENTIFIER
%token <scm> MUSIC_OUTPUT_DEF_IDENTIFIER
%type <scm> steno_pitch pitch absolute_pitch pitch_also_in_chords
%type <scm> explicit_pitch steno_tonic_pitch
-%type <scm> chord_additions chord_subtractions chord_notes chord_step
-%type <music> chord
-%type <scm> chord_note chord_inversion chord_bass
+/* %type <scm> chord_additions chord_subtractions chord_notes chord_step */
+/* %type <music> chord */
+/* %type <scm> chord_note chord_inversion chord_bass */
%type <scm> duration_length fraction
+%type <scm> new_chord step_number chord_items chord_item chord_separator step_numbers
+
%type <scm> embedded_scm scalar
%type <music> Music Sequential_music Simultaneous_music
%type <music> relative_music re_rhythmed_music part_combined_music
SCM tab = scm_make_vector (gh_int2scm (i), SCM_EOL);
for (SCM s = $1; gh_pair_p (s); s = ly_cdr (s)) {
SCM pt = ly_cdar (s);
- if (!unsmob_pitch (pt))
- THIS->parser_error ("Need pitch object.");
- else
- scm_hashq_set_x (tab, ly_caar (s), pt);
+ scm_hashq_set_x (tab, ly_caar (s), pt);
}
$$ = tab;
}
| embedded_scm {
$$ = $1;
}
- | chordnames_block {
- $$ = $1;
- }
;
-chordnames_block:
- CHORDNAMES '{'
- { THIS->lexer_->push_chord_state (); }
- chordnames_list
- { THIS->lexer_->pop_state (); }
- '}'
- {
- $$ = $4;
- }
- ;
-
-chordnames_list:
- /* empty */ {
- $$ = SCM_EOL;
- }
- | CHORDNAMES_IDENTIFIER chordnames_list {
- $$ = scm_append (scm_list_2 ($1, $2));
- }
- | chord_scm '=' full_markup chordnames_list {
- $$ = scm_cons (scm_cons ($1, $3), $4);
- };
-
-chord_scm:
- steno_tonic_pitch optional_notemode_duration chord_additions chord_subtractions chord_inversion chord_bass {
- $$ = Chord::tonic_add_sub_to_pitches ($1, $3, $4);
- /* junk bass and inversion for now */
- };
-
translator_spec_block:
TRANSLATOR '{' translator_spec_body '}'
{
$$= velt;
}
- | chord {
+ | new_chord {
THIS->pop_spot ();
- if (!THIS->lexer_->chord_state_b ())
- THIS->parser_error (_ ("Have to be in Chord mode for chords"));
- $$ = $1;
+ if (!THIS->lexer_->chord_state_b ())
+ THIS->parser_error (_ ("Have to be in Chord mode for chords"));
+ $$ = unsmob_music ($1);
}
;
-
-chord:
- steno_tonic_pitch optional_notemode_duration chord_additions chord_subtractions chord_inversion chord_bass {
- $$ = Chord::get_chord ($1, $3, $4, $5, $6, $2);
- $$->set_spot (THIS->here_input ());
- };
-
-chord_additions:
- {
- $$ = SCM_EOL;
- }
- | CHORD_COLON chord_notes {
- $$ = $2;
+new_chord:
+ steno_tonic_pitch optional_notemode_duration {
+ $$ = make_chord ($1, $2, SCM_EOL)
+ }
+ | steno_tonic_pitch optional_notemode_duration chord_separator chord_items {
+ SCM its = scm_reverse_x ($4, SCM_EOL);
+ $$ = make_chord ($1, $2, gh_cons ($3, its));
}
;
-chord_notes:
- chord_step {
- $$ = $1;
+chord_items:
+ chord_item {
+ $$ = gh_cons ($1, SCM_EOL);
}
- | chord_notes '.' chord_step {
- $$ = gh_append2 ($$, $3);
+ | chord_items chord_item {
+ $$ = gh_cons ($2, $$);
}
;
-chord_subtractions:
- {
- $$ = SCM_EOL;
- }
- | CHORD_CARET chord_notes {
- $$ = $2;
+chord_separator:
+ CHORD_COLON {
+ $$ = ly_symbol2scm ("chord-colon");
}
- ;
-
-
-chord_inversion:
- {
- $$ = SCM_EOL;
+ | CHORD_CARET {
+ $$ = ly_symbol2scm ("chord-caret");
}
- | CHORD_SLASH steno_tonic_pitch {
- $$ = $2;
+ | CHORD_SLASH {
+ $$ = ly_symbol2scm ("chord-slash");
+ }
+ | CHORD_BASS {
+ $$ = ly_symbol2scm ("chord-bass");
}
;
-chord_bass:
- {
- $$ = SCM_EOL;
+chord_item:
+ chord_separator {
+ $$ = $1;
}
- | CHORD_BASS steno_tonic_pitch {
- $$ = $2;
+ | step_numbers {
+ $$ = scm_reverse_x ($1, SCM_EOL);
+ }
+ | CHORD_MODIFIER {
+ $$ = $1;
}
;
-chord_step:
- chord_note {
- $$ = scm_cons ($1, SCM_EOL);
- }
- | CHORDMODIFIER_PITCH {
- $$ = scm_cons (unsmob_pitch ($1)->smobbed_copy (), SCM_EOL);
- }
- | CHORDMODIFIER_PITCH chord_note { /* Ugh. */
- $$ = scm_list_n (unsmob_pitch ($1)->smobbed_copy (),
- $2, SCM_UNDEFINED);
+step_numbers:
+ step_number { $$ = gh_cons ($1, SCM_EOL); }
+ | step_numbers '.' step_number {
+ $$ = gh_cons ($3, $$);
}
;
-chord_note:
+step_number:
bare_unsigned {
- Pitch m($1 > 7 ? 1 : 0, ($1 - 1) % 7, 0);
-
- $$ = m.smobbed_copy ();
+ $$ = make_chord_step ($1, 0);
}
| bare_unsigned '+' {
- Pitch m( $1 > 7 ? 1 : 0,($1 - 1) % 7, 1);
-
- $$ = m.smobbed_copy ();
+ $$ = make_chord_step ($1, 1);
}
| bare_unsigned CHORD_MINUS {
- Pitch m( $1 > 7 ? 1 : 0,($1 - 1) % 7, -1);
-
- $$ = m.smobbed_copy ();
+ $$ = make_chord_step ($1,-1);
}
- ;
+ ;
/*
UTILITIES
\version "1.7.3"
-% urg!
-%
-\chordmodifiers #`(
- (m . ,(ly:make-pitch 0 2 -1 ))
- (min . ,(ly:make-pitch 0 2 -1 ))
- (aug . ,(ly:make-pitch 0 4 1 ))
- ;; (dim . ,(ly:make-pitch -100 4 -1 ))
- (dim . ,(ly:make-pitch -100 2 -1 ))
- ;; urg, not actually a chord-modifier, but it works
- ;; c7 -> <c bes>, c 7+ -> c b
- (maj . ,(ly:make-pitch 0 6 1 ))
- ;; sus4 should delete 2 too...
- (sus . ,(ly:make-pitch 0 3 0 ))
-)
+
+\chordmodifiers #default-chord-modifier-list
whiteTriangleMarkup =#(make-override-markup '(font-family . math) (make-simple-markup "M"))
<<c e gis>>1-\markup { "+" }
<<c es ges>>-\markup { \super "o" } % should be $\circ$ ?
<<c es ges bes>>-\markup { \super \combine "o" "/" }
+ <<c es ges beses>>-\markup { \super "o7" }
}
--- /dev/null
+
+
+(define (make-chord pitches bass duration)
+ "Make EventChord with notes corresponding to PITCHES, BASS and DURATION. "
+ (define (make-note-ev pitch)
+ (let*
+ (
+ (ev (make-music-by-name 'NoteEvent))
+ )
+
+ (ly:set-mus-property! ev 'duration duration)
+ (ly:set-mus-property! ev 'pitch pitch)
+ ev
+ ))
+
+ (let*
+ (
+ (nots (map make-note-ev pitches))
+ (bass-note (if bass (make-note-ev bass) #f))
+ )
+
+ (if bass-note
+ (begin
+ (ly:set-mus-property! bass-note 'bass #t)
+ (set! nots (cons bass-note nots))))
+
+ (make-event-chord nots)
+ ))
+
+
+(define (aug-modifier root pitches)
+ (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 4 1) root) pitches))
+ (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root) pitches)
+ )
+
+
+(define (minor-modifier root pitches)
+ (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 -1) root) pitches)
+ )
+
+(define (maj7-modifier root pitches)
+ (set! pitches (remove-step 7 pitches))
+ (cons (ly:pitch-transpose (ly:make-pitch 0 6 0) root) pitches)
+ )
+
+(define (dim-modifier root pitches)
+ (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 -1) root) pitches))
+ (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 4 -1) root) pitches))
+ (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 6 -2) root) pitches))
+ pitches
+ )
+
+
+(define (sus2-modifier root pitches)
+ (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root)) pitches))
+ (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 3 0) root)) pitches))
+ (cons (ly:pitch-transpose (ly:make-pitch 0 1 0) root) pitches)
+ )
+
+(define (sus4-modifier root pitches)
+ (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root)) pitches))
+ (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 3 0) root)) pitches))
+ (cons (ly:pitch-transpose (ly:make-pitch 0 3 0) root) pitches)
+ )
+
+(define-public default-chord-modifier-list
+ `((m . ,minor-modifier)
+ (min . ,minor-modifier)
+ (aug . , aug-modifier)
+ (dim . , dim-modifier)
+ (maj . , maj7-modifier)
+ (sus . , sus4-modifier)
+ ))
+
+(define (gobble-pitches lst)
+ (if (null? lst)
+ '()
+ (if (ly:pitch? (car lst))
+ (gobble-pitches (cdr lst))
+ lst
+ )))
+
+
+;; ? should remove 3 if sus2 or sus4 found?
+(define (add-pitches root pitches to-add)
+ (if
+ (or (null? to-add) (not (ly:pitch? (car to-add))))
+ pitches
+ (let*
+ (
+ (p (ly:pitch-transpose (car to-add) root))
+ (step (pitch-step p))
+ )
+ (if (get-step step pitches)
+ (set! pitches (remove-step step pitches)))
+ (add-pitches root (cons p pitches) (cdr to-add)))))
+
+(define (rm-pitches root pitches to-add)
+ (if
+ (or (null? to-add) (not (ly:pitch? (car to-add))))
+ pitches
+ (let*
+ (
+ (p (ly:pitch-transpose (car to-add) root))
+ (step (pitch-step p))
+ )
+ (rm-pitches root (remove-step step pitches) (cdr to-add)))))
+
+
+(define-public (construct-chord root duration modifications)
+ (let*
+ (
+ (flat-mods (flatten-list modifications))
+ (base-chord (list root
+ (ly:pitch-transpose (ly:make-pitch 0 2 0) root)
+ (ly:pitch-transpose (ly:make-pitch 0 4 0) root)))
+ (complete-chord '())
+ (bass #f)
+ (inversion #f)
+ )
+
+ (define (process-inversion note-evs inversion)
+
+ ;; TODO
+ ;; Transpose the inversion down, and remember its original octave.
+ note-evs
+ )
+
+ (define (interpret-chord root chord mods)
+ "Walk MODS, and apply each mod to CHORD in turn.
+
+Side-effect: set BASS and INVERSION in containing body
+"
+ ;; the recursion makes this into a loop. Perhaps its better to
+ ;; to do the different types of modifiers in order, so that
+ ;; addition _always_ precedes removal.
+ (if (null? mods)
+ chord
+ (let* (
+ (tag (car mods))
+ (tail (cdr mods))
+ )
+ (cond
+ ((procedure? tag)
+ (interpret-chord root
+ (tag root chord)
+ tail))
+ ((equal? tag 'chord-colon)
+ (interpret-chord root
+ (add-pitches root chord tail)
+ (gobble-pitches tail)))
+ ((equal? tag 'chord-caret)
+ (interpret-chord root
+ (rm-pitches root chord tail)
+ (gobble-pitches tail)))
+
+ ((equal? tag 'chord-slash)
+ (set! inversion (car tail))
+ (interpret-chord root
+ chord
+ (gobble-pitches tail)))
+ ((equal? tag 'chord-bass)
+ (set! bass (car tail))
+ (interpret-chord root
+ chord
+ (gobble-pitches tail)))
+
+ ;; ugh. Simply add isolated pitches. This will give
+ ;; unexpected results.
+ ((ly:pitch? tag)
+ (interpret-chord root
+ (add-pitches root chord tail)
+ (gobble-pitches tail)))
+ (else (scm-error 'chord-entry 'interpret-chord "Unknown chord instructions ~S." (list mods) #f))
+ )
+ )
+ ))
+
+ (write-me "*******\n" flat-mods)
+ (set! complete-chord (interpret-chord root base-chord flat-mods))
+ (write-me "pitches: " complete-chord)
+ (write-me "bass: " bass)
+ (process-inversion (make-chord complete-chord bass duration) inversion)
+
+ ))
;; the split is a procedural process, with lots of set!.
;;
+
+;; todo: naming is confusing: steps (0 based) vs. steps (1 based).
+(define (pitch-step p)
+ "Musicological notation for an interval. Eg. C to D is 2."
+ (+ 1 (ly:pitch-steps p)))
+
+(define (get-step x ps)
+ "Does PS have the X step? Return that step if it does."
+ (if (null? ps)
+ #f
+ (if (= (- x 1) (ly:pitch-steps (car ps)))
+ (car ps)
+ (get-step x (cdr ps)))
+ ))
+
+(define (replace-step p ps)
+ "Copy PS, but replace the step of P in PS."
+ (if (null? ps)
+ '()
+ (let*
+ (
+ (t (replace-step p (cdr ps)))
+ )
+
+ (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
+ (cons p t)
+ (cons (car ps) t)
+ ))
+ ))
+
+
+(define (remove-step x ps)
+ "Copy PS, but leave out the Xth step."
+ (if (null? ps)
+ '()
+ (let*
+ (
+ (t (remove-step x (cdr ps)))
+ )
+
+ (if (= (- x 1) (ly:pitch-steps (car ps)))
+ t
+ (cons (car ps) t)
+ ))
+ ))
+
+
(define-public (ignatzek-chord-names
in-pitches bass inversion
context)
- (define (get-step x ps)
- "Does PS have the X step? Return that step if it does."
- (if (null? ps)
- #f
- (if (= (- x 1) (ly:pitch-steps (car ps)))
- (car ps)
- (get-step x (cdr ps)))
- ))
-
-
- (define (remove-step x ps)
- "Copy PS, but leave out the Xth step."
- (if (null? ps)
- '()
- (let*
- (
- (t (remove-step x (cdr ps)))
- )
-
- (if (= (- x 1) (ly:pitch-steps (car ps)))
- t
- (cons (car ps) t)
- ))
- ))
(define (remove-uptil-step x ps)
"Copy PS, but leave out everything below the Xth step."
)
)
- (define (pitch-step p)
- "Musicological notation for an interval. Eg. C to D is 2."
- (+ 1 (ly:pitch-steps p)))
-
(define (is-natural-alteration? p)
(= (natural-chord-alteration p) (ly:pitch-alteration p))
"Return tail element of LST."
(car (last-pair lst)))
+
+(define (flatten-list lst)
+ "Unnest LST"
+ (if (null? lst)
+ '()
+ (if (pair? (car lst))
+ (append (flatten-list (car lst)) (flatten-list (cdr lst)))
+ (cons (car lst) (flatten-list (cdr lst))))
+ ))
+
(define (list-minus a b)
"Return list of elements in A that are not in B."
(if (pair? a)
"output-lib.scm"
"c++.scm"
"chords-ignatzek.scm"
+ "chord-entry.scm"
"double-plus-new-chord-name.scm"
"molecule.scm"
"bass-figure.scm"
(,symbol? . "symbol")
(,string? . "string")
(,boolean? . "boolean")
+ (,ly:pitch? . "pitch")
(,ly:moment? . "moment")
(,ly:input-location? . "input location")
(,music-list? . "list of music")
projects / lilypond.git / commitdiff