2003-02-15 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+ * 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<?): new function
+
* input/regression/chords-funky-ignatzek.ly: new file.
* scm/double-plus-new-chord-name.scm (ignatzek-chord-names):
address = {Miami, Florida},
}
-
-
@Book {read78,
note = {Sound (boring) review of the various hairy rhythmic notations used by avant-garde composers HWN},
year = {1978},
publisher = {Indiana University Press},
}
-
@Book {read-notation,
-
note = {This is as close to the ``standard''
reference work for music notation issues as one is likely to get.},
@Book {wanske,
-annote = {I. A very thorough overview of engraving practices of various
-craftsmen. It includes detailed specs of characters, dimensions
-etc. II. a thorough overview of a anonymous (by now antiquated)
-automated system. EDV Means e(lektronischen) D(aten)v(erarbeitung),
-electronic data processing HWN.},
+
+ annote = {I. A very thorough overview of engraving practices of various
+ craftsmen. It includes detailed specs of characters, dimensions
+ etc. II. a thorough overview of a anonymous (by now antiquated)
+ automated system. EDV Means e(lektronischen) D(aten)v(erarbeitung),
+ electronic data processing HWN.},
year = {1988},
- title = {Musiknotation --- Von der Syntax des Notenstichs zum EDV-gesteuerten Notensatz},
+ title = {Musiknotation --- Von der Syntax des
+ Notenstichs zum EDV-gesteuerten Notensatz},
author = {Helene Wanske},
publisher = {Schott-Verlag},
address = {Mainz},
\header {
-texidoc = "Jazz chords, following
-[Ignatzek1995], page 17 and 18."
+
+texidoc = "Jazz chords, following [Ignatzek1995], page 17 and 18."
+
}
-chs = \notes
+
+chs = \notes \transpose c' c'
{
-<<c e g>>1
-<<c es g>>
-<<c e gis>>
-<<c es ges>> \break
-<<c e g bes>>
-<<c es g bes>>
-<<c e g b>>
-<<c es ges beses>>
-<<c es ges b>> \break
-<<c e gis bes>>
-<<c es g b>>
-<<c e gis b>>
-<<c es ges bes>>\break
-<<c e g a>>
-<<c es g a>>
-<<c e g bes d'>> % ??
-<<c es g bes d'>> \break
-<<c es g bes d' f' a' >>
-<<c es g bes d' f' >>
-<<c es ges bes d' >>
-<<c e g bes des' >> \break
-<<c e g bes dis'>>
-<<c e g bes d' f'>>
-<<c e g bes d' fis'>>
-<<c e g bes d' f' a'>>\break
-<<c e g bes d' fis' as'>>
-<<c e gis bes dis'>>
-<<c e g bes dis' fis'>>
-<<c e g bes d' f' as'>>\break
-<<c e g bes des' f' as'>>
-<<c e g bes d' fis'>>
-<<c e g b d'>>
-<<c e g bes d' f' as'>>\break
-<<c e g bes des' f' as'>>
-<<c e g bes des' f' a'>>
-<<c e g b d'>>
-<<c e g b d' f' a'>>\break
-<<c e g b d' fis'>>
-<<c e g bes des' f ' a'>>
-<<c f g>>
-<<c f g bes>>\break
-<<c f g bes d'>>
-<<c e g d'>>
-<<c es g f'>>
+ <<c e g>>1
+ <<c es g>>
+ <<c e gis>>
+ <<c es ges>> \break
+ <<c e g bes>>
+ <<c es g bes>>
+ <<c e g b>>
+ <<c es ges beses>>
+ <<c es ges b>> \break
+ <<c e gis bes>>
+ <<c es g b>>
+ <<c e gis b>>
+ <<c es ges bes>>\break
+ <<c e g a>>
+ <<c es g a>>
+ <<c e g bes d'>> % ??
+ <<c es g bes d'>> \break
+ <<c es g bes d' f' a' >>
+ <<c es g bes d' f' >>
+ <<c es ges bes d' >>
+ <<c e g bes des' >> \break
+ <<c e g bes dis'>>
+ <<c e g bes d' f'>>
+ <<c e g bes d' fis'>>
+ <<c e g bes d' f' a'>>\break
+ <<c e g bes d' fis' as'>>
+ <<c e gis bes dis'>>
+ <<c e g bes dis' fis'>>
+ <<c e g bes d' f' as'>>\break
+ <<c e g bes des' f' as'>>
+ <<c e g bes d' fis'>>
+ <<c e g b d'>>
+ <<c e g bes d' f' as'>>\break
+ <<c e g bes des' f' as'>>
+ <<c e g bes des' f' a'>>
+ <<c e g b d'>>
+ <<c e g b d' f' a'>>\break
+ <<c e g b d' fis'>>
+ <<c e g bes des' f ' a'>>
+ <<c f g>>
+ <<c f g bes>>\break
+ <<c f g bes d'>>
+ <<c e g d'>>
+ <<c es g f'>>
}
-
\score{
<
- \context ChordNames {
- #(set-chord-name-style 'ignatzek)
- \chs
- }
+ \context ChordNames { \chs }
\context Staff \notes \transpose c c' { \chs }
>
\paper{
}
}
}
+
+
\header {
texidoc = "test file for new-new-chord names, ie, double-plus-new-chord-name"
}
}
-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'
+{
+ <<c e g>>1
+ <<c es g>>
+ <<c e gis>>
+ <<c es ges>> \break
+ <<c e g bes>>
+ <<c es g bes>>
+ <<c e g b>>
+ <<c es ges beses>>
+ <<c es ges b>> \break
+ <<c e gis bes>>
+ <<c es g b>>
+ <<c e gis b>>
+ <<c es ges bes>>\break
+ <<c e g a>>
+ <<c es g a>>
+ <<c e g bes d'>> % ??
+ <<c es g bes d'>> \break
+ <<c es g bes d' f' a' >>
+ <<c es g bes d' f' >>
+ <<c es ges bes d' >>
+ <<c e g bes des' >> \break
+ <<c e g bes dis'>>
+ <<c e g bes d' f'>>
+ <<c e g bes d' fis'>>
+ <<c e g bes d' f' a'>>\break
+ <<c e g bes d' fis' as'>>
+ <<c e gis bes dis'>>
+ <<c e g bes dis' fis'>>
+ <<c e g bes d' f' as'>>\break
+ <<c e g bes des' f' as'>>
+ <<c e g bes d' fis'>>
+ <<c e g b d'>>
+ <<c e g bes d' f' as'>>\break
+ <<c e g bes des' f' as'>>
+ <<c e g bes des' f' a'>>
+ <<c e g b d'>>
+ <<c e g b d' f' a'>>\break
+ <<c e g b d' fis'>>
+ <<c e g bes des' f ' a'>>
+ <<c f g>>
+ <<c f g bes>>\break
+ <<c f g bes d'>>
+ <<c e g d'>>
+ <<c es g f'>>
}
-%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{
<
return SCM_BOOL_F;
}
+LY_DEFINE(duration_less, "ly:duration<?", 2,0,0, (SCM p1, SCM p2),
+ "Is @var{p1} shorter than @var{p2}?")
+{
+ Duration *a = unsmob_duration (p1);
+ Duration *b = unsmob_duration (p2);
+
+ SCM_ASSERT_TYPE(a, p1, SCM_ARG1, __FUNCTION__, "Duration");
+ SCM_ASSERT_TYPE(b, p2, SCM_ARG2, __FUNCTION__, "Duration");
+
+ if (Duration::compare (*a, *b) < 0)
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
+}
+
+
LY_DEFINE(make_duration,
"ly:make-duration", 2, 2, 0, (SCM length, SCM dotcount,
SCM num, SCM den),
public:
void execute_single_pushpop_property (SCM prop, SCM sym, SCM val);
SCM internal_get_property (SCM name_sym) const;
-
+ SCM properties_as_alist () const;
+
void unset_property (SCM var_sym);
void internal_set_property (SCM var_sym, SCM value);
Translator_group *where_defined (SCM name_sym) const;
}
+
SCM
Moment::equal_p (SCM a, SCM b)
{
Music* m = unsmob_music (s);
scm_puts (classname (m),p);
- print_alist (m->mutable_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;
}
}
+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}.")
#include "item.hh"
#include "pitch.hh"
#include "protected-scm.hh"
+#include "translator-group.hh"
class New_chord_name_engraver : public Engraver
{
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.
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 ();
}
LY_DEFINE(pitch_less, "ly:pitch<?", 2,0,0, (SCM p1, SCM p2),
"Is @var{p1} lower than @var{p2}? This uses lexicographic ordening.")
{
- return Pitch::less_p (ly_car (p1), ly_car (p2));
-}
+ Pitch *a = unsmob_pitch (p1);
+ Pitch *b = unsmob_pitch (p2);
+
+ SCM_ASSERT_TYPE(a, p1, SCM_ARG1, __FUNCTION__, "Pitch");
+ SCM_ASSERT_TYPE(b, p2, SCM_ARG2, __FUNCTION__, "Pitch");
+ if (Pitch::compare (*a, *b) < 0)
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
+}
LY_DEFINE(ly_pitch_diff, "ly:pitch-diff", 2 ,0 ,0,
(SCM pitch, SCM root),
- "Return pitch with value DELTA = PITCH - ROOT, ie,
-ROOT == (ly:pitch-transpose root delta).")
+ "Return pitch with value DELTA = PITCH - ROOT, ie, "
+"ROOT == (ly:pitch-transpose root delta).")
{
Pitch *p = unsmob_pitch (pitch);
Pitch *r = unsmob_pitch (root);
SCM_ASSERT_TYPE(p, pitch, SCM_ARG1, __FUNCTION__, "Pitch");
SCM_ASSERT_TYPE(r, root, SCM_ARG2, __FUNCTION__, "Pitch");
- return interval (*p, *r ).smobbed_copy();
+ return interval (*r, *p).smobbed_copy();
}
}
return false;
}
+
+SCM
+Translator_group::properties_as_alist () const
+{
+ return properties_dict()->to_alist();
+}
+
+/*
+translator-scheme.cc -- implement
+
+source file of the GNU LilyPond music typesetter
+
+(c) 2002--2003 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ */
+
#include "translator.hh"
+#include "translator-def.hh"
#include "translator-group.hh"
#include "lily-guile.hh"
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<Translator_group*> (t);
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<Translator_group*> (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<Translator_group*> (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 ("#<Translator ", port);
+ if (Translator_def *d=unsmob_translator_def (sc->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;
+}
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 ("#<Translator ", port);
- 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;
-}
-
SCM
Translator::static_translator_description ()const
{
(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 {
+ <<c e gis>>1-\markup { "+" }
+ <<c es ges>>-\markup { \super "o" } % should be $\circ$ ?
+ <<c es ges bes>>-\markup { \super \combine "o" "/" }
+}
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
}
)
-(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)
;;
;; 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
;;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(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)))
--- /dev/null
+(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 <<a b c>>-\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:pitch<? ))
+ (root (car sorted))
+ (non-root (map (lambda (x) (ly:pitch-diff x root)) (cdr sorted)))
+ (texts (map
+ (lambda (x)
+ (ly:get-mus-property x 'text)
+ )
+
+ (filter-list
+ (lambda (y)
+ (memq 'text-script-event
+ (ly:get-mus-property y 'types))) elts)
+ ))
+ (text (if (null? texts)
+ #f
+ (car texts)))
+
+ )
+ (cons non-root text)
+ ))
+
+ (let*
+ (
+ (elts (filter-list is-req-chord? (ly:get-mus-property seq 'elements)))
+ (alist (map chord-to-exception-entry elts))
+ )
+ (filter-list (lambda (x) (cdr x)) alist)
+ ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; 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-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."
+ (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 (is-natural-alteration? p)
+ (= (natural-chord-alteration p) (ly:pitch-alteration p))
+ )
+
+
+ (define (ignatzek-format-chord-name
+ root
+ prefix-modifiers
+ main-name
+ alteration-pitches
+ addition-pitches
+ suffix-modifiers
+ )
+
+ "Format for the given (lists of) pitches. This is actually more
+work than classifying the pitches."
+
+ (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 (glue-word-to-step word x)
+ (make-line-markup
+ (list
+ (make-simple-markup word)
+ (name-step x)))
+ )
+
+ (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)
+ "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)
+ )
+ ))))
+
;;;; 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
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)))
;; 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))
(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))
(base (list-minus consecutive altered)))
+ (if #f (begin
(write-me "full:" full)
;; (write-me "partial-pitches:" partial-pitches)
(write-me "full-markup:" full-markup)
(write-me "missing:" missing)
(write-me "consecutive:" consecutive)
(write-me "rest:" rest)
- (write-me "base:" base)
+ (write-me "base:" base)))
(case func
((banter)
(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)
-
- )
-
- ))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 (alist<? x y)
+ (string<? (symbol->string (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))
(+ (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)
)
))
-;; 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)
)))
+;;;;;;;;;;;;;;;;
+; 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 (alist<? x y)
- (string<? (symbol->string (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))
(scm sketch)
(scm sodipodi)
(scm pdftex)
- (scm double-plus-new-chord-name)
)
(define output-alist
'("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"
(define-public (display-one-music music)
(display music)
+ (display (ly:get-mutable-properties music))
music
)
" ; "
-;; debugging.
-
-(define (mydisplay x) (display x) (newline) x)
-
(define-public (simple-markup grob props . rest)
(Text_item::text_to_molecule grob props (car rest))
)
)))
+;;;;;;;;;;;;;;;;
+;; 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
(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?
(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
projects / lilypond.git / commitdiff