From: Han-Wen Nienhuys Date: Sat, 15 Feb 2003 20:36:17 +0000 (+0000) Subject: * scm/chords-ignatzek.scm: new file. X-Git-Tag: release/1.7.13~18 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=92b42d1e577d7c34248fe27534c3eefa1756233f;p=lilypond.git * scm/chords-ignatzek.scm: new file. * ly/chord-modifiers-init.ly (ignatzekExceptionMusic): define standard chord name exceptions. * scm/translator-property-description.scm (chordNameSeparator): add property. (majorSevenSymbol): add property * lily/translator-scheme.cc (ly:context-properties): new function (ly:context-parent): new function. (print_smob): print context name. * lily/music.cc (ly:get-music-length): new function (print_smob): don't print properties. * lily/duration.cc (duration + * scm/chords-ignatzek.scm: new file. + + * ly/chord-modifiers-init.ly (ignatzekExceptionMusic): define + standard chord name exceptions. + + * scm/translator-property-description.scm (chordNameSeparator): + add property. + (majorSevenSymbol): add property + + * lily/translator-scheme.cc (ly:context-properties): new function + (ly:context-parent): new function. + (print_smob): print context name. + + * lily/music.cc (ly:get-music-length): new function + (print_smob): don't print properties. + + * lily/duration.cc (duration>1 -<> -<> -<> \break -<> -<> -<> -<> -<> \break -<> -<> -<> -<>\break -<> -<> -<> % ?? -<> \break -<> -<> -<> -<> \break -<> -<> -<> -<>\break -<> -<> -<> -<>\break -<> -<> -<> -<>\break -<> -<> -<> -<>\break -<> -<> -<> -<>\break -<> -<> -<> + <>1 + <> + <> + <> \break + <> + <> + <> + <> + <> \break + <> + <> + <> + <>\break + <> + <> + <> % ?? + <> \break + <> + <> + <> + <> \break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> } - \score{ < - \context ChordNames { - #(set-chord-name-style 'ignatzek) - \chs - } + \context ChordNames { \chs } \context Staff \notes \transpose c c' { \chs } > \paper{ @@ -67,3 +65,4 @@ chs = \notes } } } + diff --git a/input/test/dpncnt.ly b/input/test/dpncnt.ly index 5ead5586f8..a89dc3de82 100644 --- a/input/test/dpncnt.ly +++ b/input/test/dpncnt.ly @@ -1,3 +1,4 @@ + \header { texidoc = "test file for new-new-chord names, ie, double-plus-new-chord-name" } @@ -33,37 +34,54 @@ epartial = \chordnames { } -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 = \notes \transpose c' c' +{ + <>1 + <> + <> + <> \break + <> + <> + <> + <> + <> \break + <> + <> + <> + <>\break + <> + <> + <> % ?? + <> \break + <> + <> + <> + <> \break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> + <>\break + <> + <> + <> } -%ch = \chords { c:9^7 c:5^3} -ch = \chords { c:3- c:3 c:2 c:7+ c:3-.5-.7- c:6.9^7 - c:4.7+^3 - r - -} \score{ < diff --git a/lily/duration.cc b/lily/duration.cc index 32a9febfee..87c6dcfd0c 100644 --- a/lily/duration.cc +++ b/lily/duration.cc @@ -134,6 +134,22 @@ Duration::less_p (SCM p1, SCM p2) return SCM_BOOL_F; } +LY_DEFINE(duration_less, "ly:durationmutable_property_alist_, p); - print_alist (m->immutable_property_alist_, p); - + /* + Printing these takes a lot of time, especially during backtraces. + For inspecting, it is better to explicitly use an inspection + function. + */ + scm_puts (">",p); return 1; } @@ -219,6 +222,15 @@ Music::~Music () } +LY_DEFINE(ly_get_music_length, + "ly:get-music-length", 1, 0, 0, (SCM mus), + "Get the length (in musical time) of music expression @var{mus}.") +{ + Music * sc = unsmob_music (mus); + SCM_ASSERT_TYPE(sc, mus, SCM_ARG1, __FUNCTION__, "music"); + return sc->get_length().smobbed_copy(); +} + LY_DEFINE(ly_get_mus_property, "ly:get-mus-property", 2, 0, 0, (SCM mus, SCM sym), "Get the property @var{sym} of music expression @var{mus}.") diff --git a/lily/new-chord-name-engraver.cc b/lily/new-chord-name-engraver.cc index d76e288fc4..bedd2220ab 100644 --- a/lily/new-chord-name-engraver.cc +++ b/lily/new-chord-name-engraver.cc @@ -18,6 +18,7 @@ #include "item.hh" #include "pitch.hh" #include "protected-scm.hh" +#include "translator-group.hh" class New_chord_name_engraver : public Engraver { @@ -74,10 +75,9 @@ New_chord_name_engraver::process_music () pitches = scm_sort_list (pitches, Pitch::less_p_proc); - SCM name_proc = get_property ("chordNameFunction"); - SCM exceptions = get_property ("chordNameExceptions"); - SCM markup = scm_call_4 (name_proc, pitches, bass, inversion, exceptions); + SCM markup = scm_call_4 (name_proc, pitches, bass, inversion, + daddy_trans_->self_scm()); /* Ugh. diff --git a/lily/pitch.cc b/lily/pitch.cc index 6b8bb17b7f..c3e2471c6c 100644 --- a/lily/pitch.cc +++ b/lily/pitch.cc @@ -18,15 +18,6 @@ Pitch::Pitch (int o, int n, int a) notename_ = n; alteration_ = a; octave_ = o; - - if (n < 0 || n >= 7 || - a < -2 || a > 2) - { - String s = _ ("Pitch arguments out of range"); - s += ": alteration = " + to_string (a); - s += ", notename = " + to_string (n); - warning (s); - } normalise (); } @@ -366,21 +357,29 @@ LY_DEFINE(pitch_semitones, "ly:pitch-semitones", 1, 0, 0, LY_DEFINE(pitch_less, "ly:pitchto_alist(); +} + diff --git a/lily/translator-scheme.cc b/lily/translator-scheme.cc index f43e6fea3f..7cf9b8ed71 100644 --- a/lily/translator-scheme.cc +++ b/lily/translator-scheme.cc @@ -1,4 +1,14 @@ +/* +translator-scheme.cc -- implement + +source file of the GNU LilyPond music typesetter + +(c) 2002--2003 Han-Wen Nienhuys + + */ + #include "translator.hh" +#include "translator-def.hh" #include "translator-group.hh" #include "lily-guile.hh" @@ -20,8 +30,7 @@ LY_DEFINE(ly_get_context_property, LY_DEFINE(ly_set_context_property, "ly:set-context-property", 3, 0, 0, (SCM context, SCM name, SCM val), - "set value of property @var{name} in context @var{context} to @var{val}. -") + "set value of property @var{name} in context @var{context} to @var{val}.") { Translator *t = unsmob_translator (context); Translator_group* tr= dynamic_cast (t); @@ -31,3 +40,84 @@ LY_DEFINE(ly_set_context_property, return SCM_UNSPECIFIED; } + + +LY_DEFINE(ly_context_parent, + "ly:context-parent", 1, 0, 0, + (SCM context), + "Return the parent of @var{context}, #f if none.") +{ + Translator *t = unsmob_translator (context); + Translator_group* tr= dynamic_cast (t); + + SCM_ASSERT_TYPE(tr, context, SCM_ARG1, __FUNCTION__, "Context"); + + tr = tr->daddy_trans_ ; + if (tr) + return tr->self_scm(); + else + return SCM_BOOL_F; +} + + + +LY_DEFINE(ly_context_properties, + "ly:context-properties", 1, 0, 0, + (SCM context), + "Return all properties of @var{context} in an alist.") +{ + Translator *t = unsmob_translator (context); + Translator_group* tr= dynamic_cast (t); + + SCM_ASSERT_TYPE(tr, context, SCM_ARG1, __FUNCTION__, "Context"); + + return tr->properties_as_alist (); +} + + + +LY_DEFINE(ly_translator_name, + "ly:translator-name", 1,0,0, (SCM trans), + "Return the type name of the translator @var{trans}.") +{ + Translator* tr = unsmob_translator (trans); + SCM_ASSERT_TYPE(tr, trans, SCM_ARG1, __FUNCTION__, "Context"); + + char const* nm = classname (tr); + return scm_makfrom0str (nm); +} + +LY_DEFINE(ly_translator_description, + "ly:translator-description", + 1,0,0, (SCM me), + "Return an alist of properties of translator @var{me}.") +{ + Translator *tr =unsmob_translator (me); + SCM_ASSERT_TYPE (tr, me, SCM_ARG1, __FUNCTION__, "Context"); + + return tr->translator_description (); +} + + +int +Translator::print_smob (SCM s, SCM port, scm_print_state *) +{ + Translator *sc = (Translator *) ly_cdr (s); + + scm_puts ("#definition_)) + { + scm_display (d->type_name_, port); + } + else + scm_display (ly_translator_name (s), port); + + scm_display (sc->simple_trans_list_, port); + + /* + don't try to print properties, that is too much hassle. + */ + scm_puts (" >", port); + + return 1; +} diff --git a/lily/translator.cc b/lily/translator.cc index 4191450809..477d2a111b 100644 --- a/lily/translator.cc +++ b/lily/translator.cc @@ -134,51 +134,12 @@ Translator::mark_smob (SCM sm) return me->properties_scm_; } -LY_DEFINE(ly_translator_name, - "ly:translator-name", 1,0,0, (SCM trans), - "Return the type name of the translator @var{trans}. -") -{ - Translator* tr = unsmob_translator (trans); - SCM_ASSERT_TYPE(tr, trans, SCM_ARG1, __FUNCTION__, "Context"); - - char const* nm = classname (tr); - return scm_makfrom0str (nm); -} - -LY_DEFINE(ly_translator_description, - "ly:translator-description", - 1,0,0, (SCM me), - "Return an alist of properties of translator @var{me}.") -{ - Translator *tr =unsmob_translator (me); - SCM_ASSERT_TYPE (tr, me, SCM_ARG1, __FUNCTION__, "Context"); - - return tr->translator_description (); -} - SCM Translator::translator_description () const { return SCM_EOL; } -int -Translator::print_smob (SCM s, SCM port, scm_print_state *) -{ - Translator *sc = (Translator *) ly_cdr (s); - - scm_puts ("#simple_trans_list_, port); - /* - don't try to print properties, that is too much hassle. - */ - scm_puts (" >", port); - - return 1; -} - SCM Translator::static_translator_description ()const { diff --git a/ly/chord-modifiers-init.ly b/ly/chord-modifiers-init.ly index 8ca7394237..36e7e03e13 100644 --- a/ly/chord-modifiers-init.ly +++ b/ly/chord-modifiers-init.ly @@ -15,3 +15,13 @@ (sus . ,(ly:make-pitch 0 3 0 )) ) + +whiteTriangleMarkup =#(make-override-markup '(font-family . math) (make-simple-markup "M")) + +blackTriangleMarkup = #(make-override-markup '(font-family . math) (make-simple-markup "N")) + +ignatzekExceptionMusic = \notes { + <>1-\markup { "+" } + <>-\markup { \super "o" } % should be $\circ$ ? + <>-\markup { \super \combine "o" "/" } +} diff --git a/ly/engraver-init.ly b/ly/engraver-init.ly index 13ebf89b1c..b02c481b6e 100644 --- a/ly/engraver-init.ly +++ b/ly/engraver-init.ly @@ -444,8 +444,12 @@ ScoreContext = \translator { custos ) barCheckSynchronize = ##t - chordNameFunction = #chord->markup-banter - chordNameExceptions = #chord::exception-alist-banter + + %% chord names: + chordNameFunction = #ignatzek-chord-names + majorSevenSymbol = #whiteTriangleMarkup + chordNameSeparator = #(make-simple-markup "/") + chordNameExceptions = #(sequential-music-to-chord-exceptions ignatzekExceptionMusic) \grobdescriptions #all-grob-descriptions } diff --git a/scm/chord-name.scm b/scm/chord-name.scm index 96ce0d276e..dc07f195ff 100644 --- a/scm/chord-name.scm +++ b/scm/chord-name.scm @@ -15,11 +15,8 @@ ) -(define (write-me x) - "Write and return X. For debugging purposes. " - (write x) (newline) x) -;(define (dbg x) (write-me x)) +;(define (dbg x) (write-me "" x)) (define (dbg x) x) ;;(define (write-me x) (write x) (newline) x) @@ -158,7 +155,7 @@ dump reinterpret the markup as a molecule. ;; ;; TODO: invent sensible way to make note name tweaking possible? ;; -(define (pitch->markup pitch) +(define (old-pitch->markup pitch) (make-line-markup (list (make-simple-markup @@ -169,14 +166,14 @@ dump reinterpret the markup as a molecule. ;;; Hooks to override chord names and note names, ;;; see input/tricks/german-chords.ly -(define pitch->markup-banter pitch->markup) +(define old-pitch->markup-banter old-pitch->markup) ;; We need also steps, to allow for Cc name override, ;; see input/test/Cc-chords.ly (define (pitch->chord-name-markup-banter pitch steps) - (pitch->markup-banter pitch)) + (old-pitch->markup-banter pitch)) -(define pitch->note-name-markup-banter pitch->markup-banter) +(define pitch->note-name-markup-banter old-pitch->markup-banter) (define (step->markup pitch) (string-append @@ -856,13 +853,14 @@ dump reinterpret the markup as a molecule. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-public (new-chord->markup func ly-pitches bass inversion exceptions) +(define-public (new-chord->markup func ly-pitches bass inversion context) "Entry point for New_chord_name_engraver. See chord-name.scm for the signature of FUNC. LY-PITCHES, BASS and INVERSION are lily pitches. EXCEPTIONS is an alist (see scm file). " (let* ((pitches (map c++-pitch->scm ly-pitches)) + (exceptions (ly:get-context-property context 'chordNameExceptions)) (bass-and-inversion (cons (c++-pitch->scm bass) (c++-pitch->scm inversion))) diff --git a/scm/chords-ignatzek.scm b/scm/chords-ignatzek.scm new file mode 100644 index 0000000000..b13952d47f --- /dev/null +++ b/scm/chords-ignatzek.scm @@ -0,0 +1,345 @@ +(define (natural-chord-alteration p) + "Return the natural alteration for step P." + (if (= (ly:pitch-steps p) 6) + -1 + 0)) + +(define (accidental->markup alteration) + "Return accidental markup for ALTERATION." + (if (= alteration 0) + (make-line-markup (list empty-markup)) + (conditional-kern-before + (make-smaller-markup + (make-raise-markup + (if (= alteration -1) + 0.3 + 0.6) + (make-musicglyph-markup + (string-append "accidentals-" (number->string alteration))))) + (= alteration -1) 0.2 + ))) + +(define (pitch->markup pitch) + "Return pitch markup for 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 (sequential-music-to-chord-exceptions seq) + "Transform sequential music of <>-\markup{ foobar } type to + (cons ABC-PITCHES FOOBAR-MARKUP) + " + + (define (is-req-chord? m) + (and + (memq 'event-chord (ly:get-mus-property m 'types)) + (not (equal? (ly:make-moment 0 1) (ly:get-music-length m))) + )) + + (define (chord-to-exception-entry m) + (let* + ( + (elts (ly:get-mus-property m 'elements)) + (pitches (map + (lambda (x) + (ly:get-mus-property x 'pitch) + ) + (filter-list + (lambda (y) (memq 'note-event (ly:get-mus-property y 'types))) + elts))) + (sorted (sort pitches ly:pitchmarkup mod) + (if (or (= 4 (pitch-step mod)) + (= 2 (pitch-step mod))) + (glue-word-to-step "sus" mod) + (glue-word-to-step "huh" mod) + )) + + (define (prefix-modifier->markup mod) + (if (and (= 3 (pitch-step mod)) + (= -1 (ly:pitch-alteration mod))) + (make-simple-markup "m") + (make-simple-markup "huh") + )) + + (define (filter-alterations alters) + "Filter out uninteresting (natural) pitches from ALTERS." + + (define (altered? p) + (not (is-natural-alteration? p))) + + (if + (null? alters) + '() + (let* + ( + (l (filter-list altered? alters)) + (lp (last-pair alters)) + ) + + ;; we want the highest also if unaltered + (if (and (not (altered? (car lp))) + (> (pitch-step (car lp)) 5)) + (append l (last-pair alters)) + l) + ))) + + (define (name-step pitch) + (define (step-alteration pitch) + (- (ly:pitch-alteration pitch) + (natural-chord-alteration pitch) + )) + + (let* + ( + (num-markup (make-simple-markup + (number->string (pitch-step pitch)))) + (args (list num-markup)) + (total (if (= (ly:pitch-alteration pitch) 0) + (if (= (pitch-step pitch) 7) + (list (ly:get-context-property context 'majorSevenSymbol)) + args) + (cons (accidental->markup (step-alteration pitch)) args) + )) + ) + + (make-line-markup total))) + + (let* + ( + (sep (ly:get-context-property context 'chordNameSeparator)) + (root-markup (pitch->markup root)) + (add-markups (map (lambda (x) + (glue-word-to-step "add" x)) + addition-pitches)) + (filtered-alterations (filter-alterations alteration-pitches)) + (alterations (map name-step filtered-alterations)) + (suffixes (map suffix-modifier->markup suffix-modifiers)) + (prefixes (map prefix-modifier->markup prefix-modifiers)) + (main-markups (filter-main-name main-name)) + (to-be-raised-stuff (markup-join + (append + main-markups + alterations + suffixes + add-markups) sep)) + ) + + (make-line-markup + (list + root-markup + (markup-join prefixes sep) + (make-super-markup to-be-raised-stuff)) + ))) + + (let* + ( + (root (car in-pitches)) + (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches))) + (exceptions (ly:get-context-property context 'chordNameExceptions)) + (exception (assoc-get-default pitches exceptions #f)) + (prefixes '()) + (suffixes '()) + (add-steps '()) + (main-name #f) + (alterations '()) + ) + + (if + exception + (make-line-markup + (list (pitch->markup root) exception)) + + (begin ; no exception. + + ; handle sus4 and sus2 suffix: if there is a 3 together with + ; sus2 or sus4, then we explicitly say add3. + (map + (lambda (j) + (if (get-step j pitches) + (begin + (if (get-step 3 pitches) + (begin + (set! add-steps (cons (get-step 3 pitches) add-steps)) + (set! pitches (remove-step 3 pitches)) + )) + (set! suffixes (cons (get-step j pitches) suffixes)) + ) + ) + ) '(2 4) ) + + ;; do minor-3rd modifier. + (if (and (get-step 3 pitches) + (= (ly:pitch-alteration (get-step 3 pitches)) -1)) + (set! prefixes (cons (get-step 3 pitches) prefixes)) + ) + + ;; lazy bum. Should write loop. + (cond + ((get-step 7 pitches) (set! main-name (get-step 7 pitches))) + ((get-step 6 pitches) (set! main-name (get-step 6 pitches))) + ((get-step 5 pitches) (set! main-name (get-step 5 pitches))) + ((get-step 4 pitches) (set! main-name (get-step 4 pitches))) + ((get-step 3 pitches) (set! main-name (get-step 3 pitches))) + ) + + (let* + ( + (3-diff? (lambda (x y) + (= (- (pitch-step y) (pitch-step x)) 2))) + (split (split-at 3-diff? (remove-uptil-step 5 pitches))) + ) + (set! alterations (append alterations (car split))) + (set! add-steps (append add-steps (cdr split))) + + (set! alterations (delq main-name alterations)) + (set! add-steps (delq main-name add-steps)) + + + ;; chords with natural (5 7 9 11 13) or leading subsequence. + ;; etc. are named by the top pitch, without any further + ;; alterations. + (if (and + (= 7 (pitch-step main-name)) + (is-natural-alteration? main-name) + (pair? (remove-uptil-step 7 alterations)) + (reduce (lambda (x y) (and x y)) + (map is-natural-alteration? alterations))) + (begin + (set! main-name (tail alterations)) + (set! alterations '()) + )) + + (ignatzek-format-chord-name root prefixes main-name alterations add-steps suffixes) + ) + )))) + diff --git a/scm/double-plus-new-chord-name.scm b/scm/double-plus-new-chord-name.scm index 1f317134a6..9dd77af9ee 100644 --- a/scm/double-plus-new-chord-name.scm +++ b/scm/double-plus-new-chord-name.scm @@ -9,134 +9,10 @@ ;;;; Naming of the base chord (steps 1-5) is handled by exceptions only ;;;; see input/test/chord-names-dpnj.ly - -(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)) - - -;; SCM utilily functions - -(define (write-me message x) - "Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off." -;; (display message) (write x) (newline) x) - x) - -(define (tail lst) - "Return tail element of LST." - (car (last-pair lst))) - -(define (list-minus a b) - "Return list of elements in A that are not in 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 (first-n n lst) - "Return first N elements of LST" - (if (and (pair? lst) - (> n 0)) - (cons (car lst) (first-n (- n 1) (cdr lst))) - '())) - -(define (butfirst-n n lst) - "Return all but first N entries of LST" - (if (pair? lst) - (if (> n 0) - (butfirst-n (- n 1) (cdr lst)) - lst) - '())) - -(define (assoc-get key alist) - "Return value if KEY in ALIST, else #f." - (let ((entry (assoc key alist))) - (if entry (cdr entry) #f))) - -(define (assoc-get-default key alist default) - "Return value if KEY in ALIST, else DEFAULT." - (let ((entry (assoc key alist))) - (if entry (cdr entry) default))) - - -(define (split-at predicate l) - "Split L = (a_1 a_2 ... a_k b_1 ... b_k) -into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) -Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1). -L1 is copied, L2 not. - -(split-at (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))" -;; " - -;; KUT EMACS MODE. - - (define (inner-split predicate l acc) - (cond - ((null? l) acc) - ((null? (cdr l)) - (set-car! acc (cons (car l) (car acc))) - acc) - ((predicate (car l) (cadr l)) - (set-car! acc (cons (car l) (car acc))) - (inner-split predicate (cdr l) acc)) - (else - (set-car! acc (cons (car l) (car acc))) - (set-cdr! acc (cdr l)) - acc) - - )) - (let* - ((c (cons '() '())) - ) - (inner-split predicate l c) - (set-car! c (reverse! (car c))) - c) -) - -;; MARKUP functions -(define (markup-join markups sep) - "Return line-markup of MARKUPS, joining them with markup SEP" - (if (pair? markups) - (make-line-markup (list-insert-separator markups sep)) - empty-markup)) - (define (markup-or-empty-markup markup) "Return MARKUP if markup, else empty-markup" (if (markup? markup) markup empty-markup)) - -;; Generic PITCH/MARKUP functions -(define (ly:pitch-diff pitch root) - "Return pitch with value DELTA = PITCH - ROOT, ie, -ROOT == (ly:pitch-transpose root delta)." - - - ;; kludgy. Do this in C++ ? --hwn - - (let ((simple-octave (- (ly:pitch-octave pitch) (ly:pitch-octave root))) - (simple-notename - (- (ly:pitch-notename pitch) (ly:pitch-notename root)))) - (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 root) - (ly:pitch-semitones (ly:make-pitch octave notename 0))))) - (ly:make-pitch octave notename alteration))))) - - (define (conditional-kern-before markup bool amount) "Add AMOUNT of space before MARKUP if BOOL is true." (if bool @@ -145,30 +21,6 @@ ROOT == (ly:pitch-transpose root delta)." markup)) markup )) - -(define (accidental->markup alteration) - "Return accidental markup for ALTERATION." - (if (= alteration 0) - (make-line-markup (list empty-markup)) - (conditional-kern-before - (make-smaller-markup - (make-raise-markup - (if (= alteration -1) - 0.3 - 0.6) - (make-musicglyph-markup - (string-append "accidentals-" (number->string alteration))))) - (= alteration -1) 0.2 - ))) - -(define (pitch->markup pitch) - "Return pitch markup for 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 (double-plus-new-chord->markup-banter . args) (apply double-plus-new-chord->markup (cons 'banter args))) @@ -179,13 +31,14 @@ ROOT == (ly:pitch-transpose root delta)." ;; FIXME: if/when double-plus-new-chord->markup get installed ;; setting and calling can be done a bit handier. (define-public (double-plus-new-chord->markup - func root-markup pitches bass inversion options) + func pitches bass inversion + context) "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 options (ly:get-context-property context 'chordNameExceptions)) (define (step-nr pitch) (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch)) @@ -278,8 +131,9 @@ input/test/dpncnt.ly). (partial-match (cdr exceptions)))) '(()))) + (if #f (begin (write-me "options: " options) - (write-me "pitches: " pitches) + (write-me "pitches: " pitches))) (let* ((full-exceptions (assoc-get 'full-exceptions options)) (full-exception (full-match full-exceptions)) (full-markup (cdr full-exception)) @@ -306,6 +160,7 @@ input/test/dpncnt.ly). (base (list-minus consecutive altered))) + (if #f (begin (write-me "full:" full) ;; (write-me "partial-pitches:" partial-pitches) (write-me "full-markup:" full-markup) @@ -315,7 +170,7 @@ input/test/dpncnt.ly). (write-me "missing:" missing) (write-me "consecutive:" consecutive) (write-me "rest:" rest) - (write-me "base:" base) + (write-me "base:" base))) (case func ((banter) @@ -406,285 +261,3 @@ input/test/dpncnt.ly). (else empty-markup)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; jazz-part 2 -;; -;; after Klaus Ignatzek, Die Jazzmethode fuer Klavier 1. -;; -;; The idea is: split chords into -;; -;; ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS -;; -;; and put that through a layout routine. -;; -;; the split is a procedural process , with lots of set!. -;; - -(define natural-chord-alterations - '( - (2 . 0) - (3 . 0) - (4 . 0) - (5 . 0) - (6 . 0) - - (7 . -1) - (9 . 0) - (11 . 0) - (13 . 0)) - ) - -(define natural-7-up-alterations - (butfirst-n 5 natural-chord-alterations) ) - - - -(define-public (ignatzek-chord-names - in-pitches bass inversion options) - - (define maj7-markup - (make-simple-markup "maj7") - ) - - (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 (name-step pitch) - (define (step-alteration pitch) - (- (ly:pitch-alteration pitch) - (assoc-get-default (+ 1 (ly:pitch-steps pitch)) natural-chord-alterations 0)) - ) - (let* - ( - (num-markup (make-simple-markup - (number->string (pitch-step pitch)))) - (args (list num-markup)) - (total (if (= (ly:pitch-alteration pitch) 0) - (if (= (pitch-step pitch) 7) - (list maj7-markup) - args) - (cons (accidental->markup (step-alteration pitch)) args) - )) - - ) - - (make-line-markup total))) - - (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." - (if (null? ps) - '() - (if (< (ly:pitch-steps (car ps)) (- x 1)) - (remove-uptil-step x (cdr ps)) - ps) - ) - ) - - (define (pitch-step p) - "Musicological notation for an interval. Eg. C to D is 2." - (+ 1 (ly:pitch-steps p))) - - (define (glue-word-to-step word x) - (make-line-markup - (list - (make-simple-markup word) - (name-step x))) - ) - - (define (is-natural-alteration? p) - (= (assoc-get-default (pitch-step p) natural-chord-alterations 0) (ly:pitch-alteration p)) - ) - - (define (filter-main-name p) - "The main name: don't print anything for natural 5 or 3." - (if - (and (is-natural-alteration? p) - (or (= (pitch-step p) 5) - (= (pitch-step p) 3))) - '() - (list (name-step p)) - )) - - - (define (ignatzek-format-chord-name - root - prefix-modifiers - main-name - alteration-pitches - addition-pitches - suffix-modifiers - ) - - - (define (suffix-modifier->markup mod) - (if (or (= 4 (pitch-step mod)) - (= 2 (pitch-step mod))) - (glue-word-to-step "sus" mod) - (glue-word-to-step "huh" mod) - )) - - (define (prefix-modifier->markup mod) - (if (and (= 3 (pitch-step mod)) - (= -1 (ly:pitch-alteration mod))) - (make-simple-markup "m") - (make-simple-markup "huh") - )) - - - (define (filter-alterations alters) - (define (altered? p) - (not (is-natural-alteration? p))) - - (if - (null? alters) - '() - (let* - ( - (l (filter-list altered? alters)) - (lp (last-pair alters)) - ) - - ;; we want the highest also if unaltered - (if (and (not (altered? (car lp))) - (> (pitch-step (car lp)) 5)) - (append l (last-pair alters)) - l) - ))) - - (let* - ( - (sep (make-simple-markup "/")) - (root-markup (pitch->markup root)) - (add-markups (map (lambda (x) - (glue-word-to-step "add" x)) - addition-pitches)) - (filtered-alterations (filter-alterations alteration-pitches)) - (alterations (map name-step filtered-alterations)) - (suffixes (map suffix-modifier->markup suffix-modifiers)) - (prefixes (map prefix-modifier->markup prefix-modifiers)) - (prefix-markup (markup-join prefixes sep)) - (main-markups (filter-main-name main-name)) - (to-be-raised-stuff (markup-join - (append - main-markups - alterations - suffixes - add-markups) sep)) - ) - (make-line-markup - (list - root-markup - prefix-markup - (make-super-markup to-be-raised-stuff)) - ))) - - - (let* - ( - (root (car in-pitches)) - (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches))) - (prefixes '()) - (suffixes '()) - (add-steps '()) - (main-name #f) - (alterations '()) - ) - - ;; handle sus4 suffix. - (if (get-step 4 pitches) - (begin - (if (get-step 3 pitches) - (begin - (set! add-steps (cons (get-step 3 pitches) add-steps)) - (set! pitches (remove-step 3 pitches)) - )) - (set! suffixes (cons (get-step 4 pitches) suffixes)) - ) - ) - - ;; handle sus2 suffix. - ;; ugh - dup, should use loop. - (if (get-step 2 pitches) - (begin - (if (get-step 3 pitches) - (begin - (set! add-steps (cons (get-step 3 pitches) add-steps)) - (set! pitches (remove-step 3 pitches)) - )) - (set! suffixes (cons (get-step 2 pitches) suffixes)) - ) - ) - - (if (and (get-step 3 pitches) - (= (ly:pitch-alteration (get-step 3 pitches)) -1)) - (set! prefixes (cons (get-step 3 pitches) prefixes)) - ) - - - ;; lazy bum. Should write loop. - (cond - ((get-step 7 pitches) (set! main-name (get-step 7 pitches))) - ((get-step 6 pitches) (set! main-name (get-step 6 pitches))) - ((get-step 5 pitches) (set! main-name (get-step 5 pitches))) - ((get-step 4 pitches) (set! main-name (get-step 4 pitches))) - ((get-step 3 pitches) (set! main-name (get-step 3 pitches))) - ) - - (let* - ( - (3-diff? (lambda (x y) - (= (- (pitch-step y) (pitch-step x)) 2))) - (split (split-at 3-diff? (remove-uptil-step 5 pitches))) - ) - (set! alterations (append alterations (car split))) - (set! add-steps (append add-steps (cdr split))) - - (set! alterations (delq main-name alterations)) - (set! add-steps (delq main-name add-steps)) - - - ;; natural 5 7 9 11 13 etc. are named by the top pitch, without - ;; any alterations. - (if (and - (= 7 (pitch-step main-name)) - (is-natural-alteration? main-name) - (pair? (remove-uptil-step 7 alterations)) - (reduce (lambda (x y) (and x y)) - (map is-natural-alteration? alterations))) - (begin - (set! main-name (tail alterations)) - (set! alterations '()) - )) - - - (ignatzek-format-chord-name root prefixes main-name alterations add-steps suffixes) - - ) - - )) - diff --git a/scm/lily.scm b/scm/lily.scm index 194c649bb3..67099c1337 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -59,12 +59,129 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Unassorted utility functions. + +;;;;;;;;;;;;;;;; +; alist (define (uniqued-alist alist acc) (if (null? alist) acc (if (assoc (caar alist) acc) (uniqued-alist (cdr alist) acc) (uniqued-alist (cdr alist) (cons (car alist) acc))))) + +(define (assoc-get key alist) + "Return value if KEY in ALIST, else #f." + (let ((entry (assoc key alist))) + (if entry (cdr entry) #f))) + +(define (assoc-get-default key alist default) + "Return value if KEY in ALIST, else DEFAULT." + (let ((entry (assoc key alist))) + (if entry (cdr entry) default))) + + +(define-public (uniqued-alist alist acc) + (if (null? alist) acc + (if (assoc (caar alist) acc) + (uniqued-alist (cdr alist) acc) + (uniqued-alist (cdr alist) (cons (car alist) acc))))) + +(define-public (aliststring (car x)) + (symbol->string (car y)))) + +;;;;;;;;;;;;;;;; +; list +(define (tail lst) + "Return tail element of LST." + (car (last-pair lst))) + +(define (list-minus a b) + "Return list of elements in A that are not in 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) + '())) + +;; 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)) + (cons (car list) rest) + rest)))) + +(define-public (filter-out-list pred? list) + "return that part of LIST for which PRED is false." + (if (null? list) '() + (let* ((rest (filter-out-list pred? (cdr list)))) + (if (not (pred? (car list))) + (cons (car list) rest) + rest)))) + + +(define (first-n n lst) + "Return first N elements of LST" + (if (and (pair? lst) + (> n 0)) + (cons (car lst) (first-n (- n 1) (cdr lst))) + '())) + +(define-public (uniq-list list) + (if (null? list) '() + (if (null? (cdr list)) + list + (if (equal? (car list) (cadr list)) + (uniq-list (cdr list)) + (cons (car list) (uniq-list (cdr list))))))) + +(define (butfirst-n n lst) + "Return all but first N entries of LST" + (if (pair? lst) + (if (> n 0) + (butfirst-n (- n 1) (cdr lst)) + lst) + '())) + +(define (split-at predicate l) + "Split L = (a_1 a_2 ... a_k b_1 ... b_k) +into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) +Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1). +L1 is copied, L2 not. + +(split-at (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))" +;; " + +;; KUT EMACS MODE. + + (define (inner-split predicate l acc) + (cond + ((null? l) acc) + ((null? (cdr l)) + (set-car! acc (cons (car l) (car acc))) + acc) + ((predicate (car l) (cadr l)) + (set-car! acc (cons (car l) (car acc))) + (inner-split predicate (cdr l) acc)) + (else + (set-car! acc (cons (car l) (car acc))) + (set-cdr! acc (cdr l)) + acc) + + )) + (let* + ((c (cons '() '())) + ) + (inner-split predicate l c) + (set-car! c (reverse! (car c))) + c) +) + + (define (other-axis a) (remainder (+ a 1) 2)) @@ -74,7 +191,10 @@ (+ (cdr iv) amount)) ) - +(define-public (write-me message x) + "Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off." + (display message) (write x) (newline) x) +;; x) (define (index-cell cell dir) (if (equal? dir 1) @@ -110,7 +230,6 @@ is the first to satisfy CRIT ) )) -;; rare naam. voorstel: reduce-add-infix (define-public (list-insert-separator list between) "Create new list, inserting BETWEEN between elements of LIST" (if (null? list) @@ -122,65 +241,28 @@ is the first to satisfy CRIT ))) +;;;;;;;;;;;;;;;; +; strings. + (define-public (string-join str-list sep) "append the list of strings in STR-LIST, joining them with SEP" (apply string-append (list-insert-separator str-list sep)) ) +(define-public (pad-string-to str wid) + (string-append str (make-string (max (- wid (string-length str)) 0) #\ )) + ) +;;;;;;;;;;;;;;;; +; other (define (sign x) (if (= x 0) 0 (if (< x 0) -1 1))) -(define (write-me n x) - (display n) - (write x) - (newline) - x) - (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)) - (cons (car list) rest) - rest)))) - -(define-public (filter-out-list pred? list) - "return that part of LIST for which PRED is false." - (if (null? list) '() - (let* ((rest (filter-out-list pred? (cdr list)))) - (if (not (pred? (car list))) - (cons (car list) rest) - rest)))) - -(define-public (uniqued-alist alist acc) - (if (null? alist) acc - (if (assoc (caar alist) acc) - (uniqued-alist (cdr alist) acc) - (uniqued-alist (cdr alist) (cons (car alist) acc))))) - -(define-public (uniq-list list) - (if (null? list) '() - (if (null? (cdr list)) - list - (if (equal? (car list) (cadr list)) - (uniq-list (cdr list)) - (cons (car list) (uniq-list (cdr list))))))) - -(define-public (aliststring (car x)) - (symbol->string (car y)))) - -(define-public (pad-string-to str wid) - (string-append str (make-string (max (- wid (string-length str)) 0) #\ )) - ) - (define-public (ly:load x) (let* ( (fn (%search-load-path x)) @@ -200,7 +282,6 @@ is the first to satisfy CRIT (scm sketch) (scm sodipodi) (scm pdftex) - (scm double-plus-new-chord-name) ) (define output-alist @@ -239,7 +320,8 @@ is the first to satisfy CRIT '("music-types.scm" "output-lib.scm" "c++.scm" - + "chords-ignatzek.scm" + "double-plus-new-chord-name.scm" "molecule.scm" "bass-figure.scm" "grob-property-description.scm" diff --git a/scm/music-functions.scm b/scm/music-functions.scm index 434a49f641..603a8d0738 100644 --- a/scm/music-functions.scm +++ b/scm/music-functions.scm @@ -27,6 +27,7 @@ (define-public (display-one-music music) (display music) + (display (ly:get-mutable-properties music)) music ) diff --git a/scm/new-markup.scm b/scm/new-markup.scm index e2cded650b..74d166f69e 100644 --- a/scm/new-markup.scm +++ b/scm/new-markup.scm @@ -45,10 +45,6 @@ for the reader. " ; " -;; debugging. - -(define (mydisplay x) (display x) (newline) x) - (define-public (simple-markup grob props . rest) (Text_item::text_to_molecule grob props (car rest)) ) @@ -543,6 +539,16 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function. ))) +;;;;;;;;;;;;;;;; +;; utility + +(define (markup-join markups sep) + "Return line-markup of MARKUPS, joining them with markup SEP" + (if (pair? markups) + (make-line-markup (list-insert-separator markups sep)) + empty-markup)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if #f diff --git a/scm/translator-property-description.scm b/scm/translator-property-description.scm index 364d58841b..137ff5bfdc 100644 --- a/scm/translator-property-description.scm +++ b/scm/translator-property-description.scm @@ -17,6 +17,11 @@ (translator-property-description 'extraVerticalExtent number-pair? "extra vertical extent, same format as MinimumVerticalExtent") + +(translator-property-description + 'majorSevenSymbol markup? + "How should the major7 be formatted in a chord name?") + (translator-property-description 'minimumVerticalExtent number-pair? "minimum vertical extent, same format as VerticalExtent") (translator-property-description 'verticalExtent number-pair? @@ -171,6 +176,11 @@ into one staff.") (translator-property-description 'chordNameExceptions list? "Alist of chord exceptions. Contains (CHORD . MARKUP) entries.") +(translator-property-description + 'chordNameSeparator markup? + "The markup object used to separate parts of a chord name.") + + (translator-property-description 'chordChanges boolean? "Only show changes in chords scheme?") (translator-property-description 'clefGlyph string? "Name of the symbol within the music font") (translator-property-description 'clefOctavation integer? "Add