From 42a9b7a38ecd88df8e89a4266a951e0525328615 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 6 Jan 2003 22:34:00 +0000 Subject: [PATCH] * input/test/dpncnt.ly: New file. * lily/my-lily-lexer.cc: Add chordnames keyword. * lily/parser.yy (chordnames_block): Parse chord name exception lists, see input/test/dpncnt.ly. * scm/chord-name.scm (set-double-plus-new-chord-name-style): New function. * scm/lily.scm (filter-out-list): Bugfix: filter rest using filter-out too. * lily/pitch.cc (ly_pitch_transpose): Scheme name now ly:pitch-transpose (was ly:transpose-pitch), in conformance with pitch functions (except for ly:make-pitch, but that's apparently some sort of scheme naming standard?). * scm/lily.scm (!=): define-public. * scm/new-markup.scm (make-markup-maker): define-public make-markups. --- ChangeLog | 29 ++++ input/test/dpncnt.ly | 65 ++++++++ lily/my-lily-lexer.cc | 1 + lily/parser.yy | 33 ++++ lily/pitch.cc | 2 +- scm/chord-name.scm | 27 ++++ scm/double-plus-new-chord-name.scm | 243 +++++++++++++++++++++++++++++ scm/grob-property-description.scm | 1 + scm/lily.scm | 16 +- scm/new-markup.scm | 2 +- 10 files changed, 410 insertions(+), 9 deletions(-) create mode 100644 input/test/dpncnt.ly create mode 100644 scm/double-plus-new-chord-name.scm diff --git a/ChangeLog b/ChangeLog index 2465cf07f4..9ee7a8b9d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,32 @@ +2003-01-06 Jan Nieuwenhuizen + + * input/test/dpncnt.ly: New file. + + * lily/my-lily-lexer.cc: Add chordnames keyword. + + * lily/parser.yy (chordnames_block): Parse chord name exception + lists, see input/test/dpncnt.ly. + + * scm/chord-name.scm (set-double-plus-new-chord-name-style): New + function. + + * scm/lily.scm (filter-out-list): Bugfix: filter rest using + filter-out too. + + * lily/pitch.cc (ly_pitch_transpose): Scheme name now + ly:pitch-transpose (was ly:transpose-pitch), in conformance with + pitch functions (except for ly:make-pitch, but that's apparently + some sort of scheme naming standard?). + + * scm/lily.scm (!=): define-public. + + * scm/new-markup.scm (make-markup-maker): define-public make-markups. + +2003-01-05 Jan Nieuwenhuizen + + * scm/double-plus-new-chord-name.scm + (double-plus-new-chord-name->markup): New file. + 2003-01-05 Han-Wen Nienhuys * python/lilylib.py (make_preview): don't suppress progress for diff --git a/input/test/dpncnt.ly b/input/test/dpncnt.ly new file mode 100644 index 0000000000..fbdf2696b1 --- /dev/null +++ b/input/test/dpncnt.ly @@ -0,0 +1,65 @@ + +efull = \chordnames { + c:3-.5-.7- = \markup { \super "didem" } + c:7+ = \markup { \super "maj7" } +} + +epartial = \chordnames { + c:3- = \markup { "dim" } +} + +xch = \chords { c:7+.9-^3.5 c:dim } + +xch = \chords { c:13-.9+^11 } +ch = \chords { c:7.9- } +ch = \chords { c:7.9+.11+ } +ch = \chords { c:7.9+ } +ch = \chords { c:3-.9^7 } % madd9 + +ch = \chords { c:3-.6.9^7 } % m6/9 + +ch = \chords { c:dim9 } + +ch = \chords { c:1^5 } + +ch = \chords { c:m5-.7- } % o = diminished seventh chord + +ch = \chords { c:7- } +%ch = \chords { c:3.11- } + +%ch = \chords { c:7.11.13 } + +% ch = \chords { c:7.11.15.17.19.21 } +ch = \chords { c c:m c:7 c:7.9 c:7+.9 c:7.9+ c:9^7 c:3.11^7 } + +%ch = \chords { c:9^7 c:5^3} + + +\score{ + < + \context ChordNames { + % #(set-chord-name-style 'jazz) + % #(set-chord-name-style 'double-plus-new-banter) + % #(set-chord-name-style 'double-plus-new-jazz) + + #(set-double-plus-new-chord-name-style 'banter + `((separator . ,(make-simple-markup ":")) + (full-exceptions . ,efull) + (partial-exceptions . ,epartial))) + + %#(set-double-plus-new-chord-name-style 'jazz + % `((separator . ,(make-simple-markup ":")) + % (full-exceptions . ,efull) + % (partial-exceptions . ,epartial))) + + \ch + } + \context Staff \notes \transpose c c' \ch + > + \paper{ + \translator { + \ChordNamesContext + ChordName \override #'word-space = #1 + } + } +} diff --git a/lily/my-lily-lexer.cc b/lily/my-lily-lexer.cc index 2c1faf4cfb..4ff5298864 100644 --- a/lily/my-lily-lexer.cc +++ b/lily/my-lily-lexer.cc @@ -37,6 +37,7 @@ static Keyword_ent the_key_tab[]={ {"bar", BAR}, {"breathe", BREATHE}, {"chordmodifiers", CHORDMODIFIERS}, + {"chordnames", CHORDNAMES}, {"chords", CHORDS}, {"clef", CLEF}, {"consists", CONSISTS}, diff --git a/lily/parser.yy b/lily/parser.yy index 0b15451298..d5a3d3f4b0 100644 --- a/lily/parser.yy +++ b/lily/parser.yy @@ -262,6 +262,8 @@ yylex (YYSTYPE *s, void * v) %token DURATION_IDENTIFIER %token FRACTION %token IDENTIFIER +%token CHORDNAMES CHORDNAMES_IDENTIFIER +%type chordnames_block chordnames_list chord_scm %token SCORE_IDENTIFIER @@ -494,8 +496,39 @@ 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 '}' { diff --git a/lily/pitch.cc b/lily/pitch.cc index 2f7747848e..7b26e85d50 100644 --- a/lily/pitch.cc +++ b/lily/pitch.cc @@ -230,7 +230,7 @@ Pitch::down_to (int notename) } LY_DEFINE(ly_pitch_transpose, - "ly:transpose-pitch", 2, 0, 0, + "ly:pitch-transpose", 2, 0, 0, (SCM p, SCM delta), "Transpose @var{p} by the amount @var{delta}, where @var{delta} is the " " pitch that central C is transposed to.") diff --git a/scm/chord-name.scm b/scm/chord-name.scm index 88b2b458a6..3f48cc88b5 100644 --- a/scm/chord-name.scm +++ b/scm/chord-name.scm @@ -939,6 +939,33 @@ inline use in .ly file" ((american) (chord-name-style-setter chord->markup-american chord::exception-alist-american)) + + ((double-plus-new-banter) + (chord-name-style-setter double-plus-new-chord->markup-banter + chord::exception-alist-banter)) + + ((double-plus-new-jazz) + (chord-name-style-setter double-plus-new-chord->markup-jazz + chord::exception-alist-jazz)) ))) +;; can't put this in double-plus-new-chord-name.scm, because we can't +;; ly:load that very easily. +(define-public (set-double-plus-new-chord-name-style style options) + "Return music expressions that set the chord naming style. For +inline use in .ly file" + + (define (chord-name-style-setter function) + (context-spec-music + (make-sequential-music + (list (make-property-set 'chordNameFunction function) + (make-property-set 'chordNameExceptions options))) + "ChordNames")) + (ly:export + (case style + ((banter) + (chord-name-style-setter double-plus-new-chord->markup-banter)) + + ((jazz) + (chord-name-style-setter double-plus-new-chord->markup-jazz))))) diff --git a/scm/double-plus-new-chord-name.scm b/scm/double-plus-new-chord-name.scm new file mode 100644 index 0000000000..703f02ed42 --- /dev/null +++ b/scm/double-plus-new-chord-name.scm @@ -0,0 +1,243 @@ +;;;; double-plus-new-chord-name.scm -- Compile chord names +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2003 Jan Nieuwenhuizen + +;;;; NOTE: this is experimental code +;;;; It only handles naming for steps 5 and up +;;;; There's no code for naming the base chord (steps 1-5) +;;;; or exceptions. + + +(define-module (scm double-plus-new-chord-name)) +(debug-enable 'backtrace) +(use-modules (ice-9 regex) + (ice-9 string-fun) + (ice-9 format) + (guile) + (lily)) + +(define this-module (current-module)) + +(define (tail x) + (car (reverse x))) + +(define (list-minus a b) + (if (pair? a) + (if (pair? b) + (if (member (car a) b) + (list-minus (cdr a) b) + (cons (car a) (list-minus (cdr a) b))) + a) + '())) + +(define (assoc-default key alist default) + (let ((value (assoc key alist))) + (if value (cdr value) default))) + +(define (markup-join markups sep) + "Return line-markup of MARKUPS, joining them with markup SEP" + (if (pair? markups) + (make-line-markup (reduce-list markups sep)) + empty-markup)) + +(define (ly:pitch-diff pitch tonic) + (let ((simple-octave (- (ly:pitch-octave pitch) (ly:pitch-octave tonic))) + (simple-notename + (- (ly:pitch-notename pitch) (ly:pitch-notename tonic)))) + (let ((octave (+ simple-octave (quotient simple-notename 7) + (if (< simple-notename 0) -1 0))) + (notename (modulo simple-notename 7))) + (let ((alteration + (- (ly:pitch-semitones pitch) + (ly:pitch-semitones tonic) + (ly:pitch-semitones (ly:make-pitch octave notename 0))))) + (ly:make-pitch octave notename alteration))))) + +(define (accidental->markup alteration) + "Return accidental markup for ALTERATION." + (if (= alteration 0) + (make-line-markup (list empty-markup)) + (make-smaller-markup + (make-musicglyph-markup + (string-append "accidentals-" (number->string alteration)))))) + +(define (pitch->markup pitch) + (make-line-markup + (list + (make-simple-markup + (vector-ref #("C" "D" "E" "F" "G" "A" "B") (ly:pitch-notename pitch))) + (make-normal-size-super-markup + (accidental->markup (ly:pitch-alteration pitch)))))) + +(define-public (write-me message x) + (write message) (write x) (newline) x) + +(define-public (double-plus-new-chord->markup-banter . args) + (apply double-plus-new-chord->markup (cons 'banter args))) + +(define-public (double-plus-new-chord->markup-jazz . args) + (apply double-plus-new-chord->markup (cons 'jazz args))) + +(define-public (double-plus-new-chord->markup + func pitches bass inversion options) + "Entry point for New_chord_name_engraver. See +double-plus-new-chord-name.scm for the signature of FUNC. PITCHES, +BASS and INVERSION are lily pitches. OPTIONS is an alist-alist (see +input/test/dpncnt.ly). + " + + + (define (step-nr pitch) + (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch)) + (ly:pitch-notename pitch))) + (tonic-nr (+ (* 7 (ly:pitch-octave (car pitches))) + (ly:pitch-notename (car pitches))))) + (+ 1 (- pitch-nr tonic-nr)))) + + (define (next-third pitch) + (ly:pitch-transpose pitch + (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3) + (= (step-nr pitch) 5)) + -1 0)))) + + (define (step-alteration pitch) + (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches))) + (normalized-pitch (ly:pitch-transpose pitch diff)) + (alteration (ly:pitch-alteration normalized-pitch))) + (if (= (step-nr pitch) 7) (+ alteration 1) alteration))) + + (define (pitch-unalter pitch) + (let ((alteration (step-alteration pitch))) + (if (= alteration 0) + pitch + (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch) + (- (ly:pitch-alteration pitch) alteration))))) + + (define (step-even-or-altered? pitch) + (let ((nr (step-nr pitch))) + (if (!= (modulo nr 2) 0) + (!= (step-alteration pitch) 0) + #t))) + + (define (step->markup-plusminus pitch) + (make-line-markup + (list + (make-simple-markup (number->string (step-nr pitch))) + (make-simple-markup + (case (step-alteration pitch) + ((-2) "--") + ((-1) "-") + ((0) "") + ((1) "+") + ((2) "++")))))) + + (define (step->markup-accidental pitch) + (make-line-markup + (list + (accidental->markup (step-alteration pitch)) + (make-simple-markup (number->string (step-nr pitch)))))) + + (define (sub->markup pitch) + ;;(make-line-markup (list (make-simple-markup "no") (step->markup pitch)))) + ;; urg + (make-line-markup (list (make-simple-markup "no") + (step->markup-plusminus pitch)))) + + + (define (get-full-list pitch) + (if (< (step-nr pitch) (step-nr (tail pitches))) + (cons pitch (get-full-list (next-third pitch))) + '())) + + (define (get-consecutive nr pitches) + (if (pair? pitches) + (let* ((pitch-nr (step-nr (car pitches))) + (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr))) + (if (<= pitch-nr nr) + (cons (car pitches) (get-consecutive next-nr (cdr pitches))) + '())) + '())) + + (let* ((all pitches) + (highest (tail all)) + (full (get-full-list (car all))) + (missing (list-minus full (map pitch-unalter all))) + (consecutive (get-consecutive 1 all)) + (rest (list-minus all consecutive)) + (altered (filter-list step-even-or-altered? all)) + (cons-alt (filter-list step-even-or-altered? consecutive)) + (base (list-minus consecutive altered)) + + (full-exceptions (assoc 'full-exceptions options)) + (partial-exceptions (assoc 'partial-exceptions options))) + + ;;(newline) + ;;(write-me "pitches" pitches) + ;;(write-me "altered:" altered) + ;;(write-me "missing:" missing) + ;;(write-me "consecutive:" consecutive) + ;;(write-me "rest:" rest) + + (case func + ((banter) + ;; tonic + ;; + steps:altered + (highest all -- if not altered) + ;; + subs:missing + + (let* ((tonic->markup + (assoc-default 'tonic->markup options pitch->markup)) + (step->markup + (assoc-default 'step->markup options step->markup-plusminus)) + (sep + (assoc-default 'separator options (make-simple-markup "/")))) + + (make-line-markup + (list + (tonic->markup (car pitches)) + + (make-normal-size-super-markup + (markup-join + (apply append + (map step->markup + (append altered + (if (and (> (step-nr highest) 5) + (not + (step-even-or-altered? highest))) + (list highest) '()))) + + (list (map sub->markup missing))) + sep)))))) + + + ((jazz) + ;; tonic + ;; + steps:(highest base) + cons-alt + ;; + 'add' + ;; + steps:rest + (let* ((tonic->markup + (assoc-default 'tonic->markup options pitch->markup)) + (step->markup + (assoc-default 'step->markup options step->markup-accidental)) + (sep + (assoc-default 'separator options (make-simple-markup " "))) + (add-prefix + (assoc-default 'add-prefix options + (make-simple-markup " add")))) + + (make-line-markup + (list + (tonic->markup (car pitches)) + + (make-normal-size-super-markup + (make-line-markup + (list + (markup-join (map step->markup (cons (tail base) cons-alt)) sep) + (if (pair? rest) + add-prefix + empty-markup) + (markup-join (map step->markup rest) sep)))))))) + + (else empty-markup)))) + diff --git a/scm/grob-property-description.scm b/scm/grob-property-description.scm index f7034298fd..08f0ced821 100644 --- a/scm/grob-property-description.scm +++ b/scm/grob-property-description.scm @@ -585,6 +585,7 @@ staff in a row more often, when the heights of the notes vary. (grob-property-description 'causes list? "list of cause objects; these can be music objects or grobs.") (grob-property-description 'flag-count number? "") +(grob-property-description 'chord-name-function procedure? "DOCME") (grob-property-description 'chord-tremolo boolean? "if set, this beam is a tremolo. TODO: use interface for this!") (grob-property-description 'chord pair? "?") (grob-property-description 'begin-of-line-visible boolean? "?") diff --git a/scm/lily.scm b/scm/lily.scm index fde3b90e19..2d957ae64d 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -110,7 +110,7 @@ is the first to satisfy CRIT ) )) - +;; rare naam. voorstel: reduce-add-infix (define-public (reduce-list list between) "Create new list, inserting BETWEEN between elements of LIST" (if (null? list) @@ -139,22 +139,23 @@ is the first to satisfy CRIT (newline) x) -(define (!= l r) +(define-public (!= l r) (not (= l r))) +;; why -list suffix (see reduce-list) (define-public (filter-list pred? list) "return that part of LIST for which PRED is true." (if (null? list) '() - (let* ((rest (filter-list pred? (cdr list)))) - (if (pred? (car list)) + (let* ((rest (filter-list pred? (cdr list)))) + (if (pred? (car list)) (cons (car list) rest) rest)))) (define-public (filter-out-list pred? list) - "return that part of LIST for which PRED is true." + "return that part of LIST for which PRED is false." (if (null? list) '() - (let* ((rest (filter-list pred? (cdr list)))) - (if (not (pred? (car list))) + (let* ((rest (filter-out-list pred? (cdr list)))) + (if (not (pred? (car list))) (cons (car list) rest) rest)))) @@ -199,6 +200,7 @@ is the first to satisfy CRIT (scm sketch) (scm sodipodi) (scm pdftex) + (scm double-plus-new-chord-name) ) (define output-alist diff --git a/scm/new-markup.scm b/scm/new-markup.scm index f20fdf806a..e2cded650b 100644 --- a/scm/new-markup.scm +++ b/scm/new-markup.scm @@ -499,7 +499,7 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function. (signature (object-property (car entry) 'markup-signature)) ) - `(define (,(string->symbol make-name) . args) + `(define-public (,(string->symbol make-name) . args) (make-markup ,(car entry) ,make-name ,(cons 'list signature) args) )) ) -- 2.39.2