From 23f2fd28f3ddbe88bbb16a27b068db2e9e31139b Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sun, 16 Feb 2003 01:52:28 +0000 Subject: [PATCH] * scm/chord-entry.scm (construct-chord): move chord construction Scheme. * lily/parser.yy (new_chord): new setup for chord entry. --- ChangeLog | 7 ++ lily/lexer.ll | 2 +- lily/parser.yy | 177 +++++++++++++++-------------------- ly/chord-modifiers-init.ly | 17 +--- scm/chord-entry.scm | 185 +++++++++++++++++++++++++++++++++++++ scm/chords-ignatzek.scm | 75 +++++++++------ scm/lily.scm | 12 +++ 7 files changed, 330 insertions(+), 145 deletions(-) create mode 100644 scm/chord-entry.scm diff --git a/ChangeLog b/ChangeLog index 028b005d17..92835edb57 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2003-02-16 Han-Wen Nienhuys + + * 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 * lilypond.words: diff --git a/lily/lexer.ll b/lily/lexer.ll index 01e4eeb665..a0fd1ed4a8 100644 --- a/lily/lexer.ll +++ b/lily/lexer.ll @@ -660,7 +660,7 @@ My_lily_lexer::scan_bare_word (String str) } else if ((pitch = scm_hashq_get_handle (chordmodifier_tab_, sym))!= SCM_BOOL_F) { yylval.scm = ly_cdr (pitch); - return CHORDMODIFIER_PITCH; + return CHORD_MODIFIER; } } diff --git a/lily/parser.yy b/lily/parser.yy index 1c7fb5b0d1..617e3bdb60 100644 --- a/lily/parser.yy +++ b/lily/parser.yy @@ -136,6 +136,30 @@ set_music_properties (Music *p, SCM a) } +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) @@ -188,7 +212,7 @@ yylex (YYSTYPE *s, void * v) %token ALTERNATIVE %token BAR %token BREATHE -%token CHORDMODIFIERS +%token CHORDMODIFIERS %token CHORDS %token CLEF %token CONSISTS @@ -264,8 +288,8 @@ yylex (YYSTYPE *s, void * v) %token FRACTION %token IDENTIFIER %token CHORDNAMES CHORDNAMES_IDENTIFIER -%type chordnames_block chordnames_list chord_scm +%token CHORD_MODIFIER %token SCORE_IDENTIFIER %token MUSIC_OUTPUT_DEF_IDENTIFIER @@ -313,11 +337,13 @@ yylex (YYSTYPE *s, void * v) %type steno_pitch pitch absolute_pitch pitch_also_in_chords %type explicit_pitch steno_tonic_pitch -%type chord_additions chord_subtractions chord_notes chord_step -%type chord -%type chord_note chord_inversion chord_bass +/* %type chord_additions chord_subtractions chord_notes chord_step */ +/* %type chord */ +/* %type chord_note chord_inversion chord_bass */ %type duration_length fraction +%type new_chord step_number chord_items chord_item chord_separator step_numbers + %type embedded_scm scalar %type Music Sequential_music Simultaneous_music %type relative_music re_rhythmed_music part_combined_music @@ -402,10 +428,7 @@ notenames_body: 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; } @@ -497,39 +520,8 @@ identifier_init: | 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 '}' { @@ -1990,98 +1982,79 @@ simple_element: $$= 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 diff --git a/ly/chord-modifiers-init.ly b/ly/chord-modifiers-init.ly index 36e7e03e13..f8266423c1 100644 --- a/ly/chord-modifiers-init.ly +++ b/ly/chord-modifiers-init.ly @@ -1,19 +1,7 @@ \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 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")) @@ -24,4 +12,5 @@ ignatzekExceptionMusic = \notes { <>1-\markup { "+" } <>-\markup { \super "o" } % should be $\circ$ ? <>-\markup { \super \combine "o" "/" } + <>-\markup { \super "o7" } } diff --git a/scm/chord-entry.scm b/scm/chord-entry.scm new file mode 100644 index 0000000000..792fd1a49d --- /dev/null +++ b/scm/chord-entry.scm @@ -0,0 +1,185 @@ + + +(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) + + )) diff --git a/scm/chords-ignatzek.scm b/scm/chords-ignatzek.scm index 5f91a2981d..36bdb5bbae 100644 --- a/scm/chords-ignatzek.scm +++ b/scm/chords-ignatzek.scm @@ -99,34 +99,57 @@ ;; 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." @@ -138,10 +161,6 @@ ) ) - (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)) diff --git a/scm/lily.scm b/scm/lily.scm index 67099c1337..2dbf44bab5 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -96,6 +96,16 @@ "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) @@ -321,6 +331,7 @@ is the first to satisfy CRIT "output-lib.scm" "c++.scm" "chords-ignatzek.scm" + "chord-entry.scm" "double-plus-new-chord-name.scm" "molecule.scm" "bass-figure.scm" @@ -363,6 +374,7 @@ is the first to satisfy CRIT (,symbol? . "symbol") (,string? . "string") (,boolean? . "boolean") + (,ly:pitch? . "pitch") (,ly:moment? . "moment") (,ly:input-location? . "input location") (,music-list? . "list of music") -- 2.39.2