From 5758fa63add68276fd012fac73a240f40332a320 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Sat, 6 Nov 2004 22:11:48 +0000 Subject: [PATCH] * scm/define-music-properties.scm (all-music-properties): add quoted-context-type, quoted-context-id. * scm/lily.scm (type-check-list): new function. * scm/lily-library.scm: new file. Generic library routines. * lily/parser.yy (Generic_prefix_music): move typechecking out of parser. * ly/music-functions-init.ly: add quoteDuring function. * lily/include/music-iterator.hh (class Music_iterator): rename set_translator -> set_context * lily/parser.yy (Generic_prefix_music_scm): add MUSIC_FUNCTION_SCM_SCM_MUSIC * scm/lily.scm (sanitize-command-option): new function. (backportme) --- ChangeLog | 15 + input/regression/quote-during.ly | 44 +++ lily/auto-change-iterator.cc | 10 +- lily/chord-tremolo-iterator.cc | 2 +- ...on-context-handle.cc => context-handle.cc} | 4 +- lily/context-specced-music-iterator.cc | 2 +- lily/event-chord-iterator.cc | 2 +- lily/include/interpretation-context-handle.hh | 6 +- lily/include/music-iterator.hh | 2 +- lily/music-iterator.cc | 10 +- lily/new-quote-iterator.cc | 217 ++++++++++++ lily/parser.yy | 26 +- lily/part-combine-iterator.cc | 28 +- lily/percent-repeat-iterator.cc | 2 +- lily/quote-iterator.cc | 2 +- lily/simultaneous-music-iterator.cc | 2 +- lily/time-scaled-music-iterator.cc | 2 +- ly/music-functions-init.ly | 49 ++- scm/define-music-properties.scm | 3 + scm/define-music-types.scm | 3 +- scm/lily-library.scm | 310 ++++++++++++++++ scm/lily.scm | 335 ++---------------- 22 files changed, 705 insertions(+), 371 deletions(-) create mode 100644 input/regression/quote-during.ly rename lily/{interpretation-context-handle.cc => context-handle.cc} (94%) create mode 100644 lily/new-quote-iterator.cc create mode 100644 scm/lily-library.scm diff --git a/ChangeLog b/ChangeLog index 84be8c8dfb..15ffb3799a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,20 @@ 2004-11-06 Han-Wen Nienhuys + * scm/define-music-properties.scm (all-music-properties): add + quoted-context-type, quoted-context-id. + + * scm/lily.scm (type-check-list): new function. + + * scm/lily-library.scm: new file. Generic library routines. + + * lily/parser.yy (Generic_prefix_music): move typechecking out of + parser. + + * ly/music-functions-init.ly: add quoteDuring function. + + * lily/include/music-iterator.hh (class Music_iterator): rename + set_translator -> set_context + * lily/parser.yy (Generic_prefix_music_scm): add MUSIC_FUNCTION_SCM_SCM_MUSIC diff --git a/input/regression/quote-during.ly b/input/regression/quote-during.ly new file mode 100644 index 0000000000..9f9c376e91 --- /dev/null +++ b/input/regression/quote-during.ly @@ -0,0 +1,44 @@ +\header +{ + + texidoc = "With @code{\\quoteDuring}, fragments of previously +entered music may be quoted. @code{quotedEventTypes} will determines +what things are quoted. In this example, a 16th rests is not quoted, +since @code{rest-event} is not in @code{quotedEventTypes}." + +} +\version "2.4.0" +\layout { + raggedright = ##t +} + + +quoteMe = \relative c' { fis4 r16 a8.-> b4-\ff } + +\addquote quoteMe \quoteMe +original = \relative c'' { c8 d s2 es8 gis8 } + +<< + \new Staff { + \set Staff.instrument = "quoteMe" + \quoteMe + } + \new Staff { + \set Staff.instrument = "orig" + \original + } + \new Staff \relative c'' << + + % setup cue note layout. + \context Voice = cue { + \set fontSize = #-4 + \override Stem #'lengths = #'(2.5 2.5 3.0 3.0) + \skip 1 + } + + \set Staff.instrument = "orig+quote" + \set Staff.quotedEventTypes = #'(note-event articulation-event) + \original + { s4 \quoteDuring #"quoteMe" #1 { r2. } } + >> +>> diff --git a/lily/auto-change-iterator.cc b/lily/auto-change-iterator.cc index 656264706b..d162e32dfd 100644 --- a/lily/auto-change-iterator.cc +++ b/lily/auto-change-iterator.cc @@ -136,12 +136,12 @@ Auto_change_iterator::construct_children () Context *down = get_outlet()->find_create_context (ly_symbol2scm ("Staff"), "down", props); - up_.set_translator (up); - down_.set_translator (down); + up_.set_context (up); + down_.set_context (down); Context *voice = up->find_create_context (ly_symbol2scm ("Voice"), "", SCM_EOL); - set_translator (voice); + set_context (voice); Music_wrapper_iterator::construct_children (); } @@ -149,8 +149,8 @@ Auto_change_iterator::construct_children () void Auto_change_iterator::do_quit() { - up_.set_translator (0); - down_.set_translator (0); + up_.set_context (0); + down_.set_context (0); } IMPLEMENT_CTOR_CALLBACK (Auto_change_iterator); diff --git a/lily/chord-tremolo-iterator.cc b/lily/chord-tremolo-iterator.cc index d9bb1f3963..aa19347471 100644 --- a/lily/chord-tremolo-iterator.cc +++ b/lily/chord-tremolo-iterator.cc @@ -59,7 +59,7 @@ Chord_tremolo_iterator::process (Moment m) { Music_iterator *yeah = try_music (get_music ()); if (yeah) - set_translator (yeah->get_outlet ()); + set_context (yeah->get_outlet ()); else get_music ()->origin ()->warning (_ ("no one to print a tremolos")); } diff --git a/lily/interpretation-context-handle.cc b/lily/context-handle.cc similarity index 94% rename from lily/interpretation-context-handle.cc rename to lily/context-handle.cc index e7af7e85bf..b1e150a407 100644 --- a/lily/interpretation-context-handle.cc +++ b/lily/context-handle.cc @@ -67,11 +67,11 @@ Interpretation_context_handle::try_music (Music *m) void Interpretation_context_handle::operator = (Interpretation_context_handle const &s) { - set_translator (s.outlet_); + set_context (s.outlet_); } void -Interpretation_context_handle::set_translator (Context *trans) +Interpretation_context_handle::set_context (Context *trans) { if (outlet_ ==trans) return; diff --git a/lily/context-specced-music-iterator.cc b/lily/context-specced-music-iterator.cc index 6583f3c6fd..c5d917a330 100644 --- a/lily/context-specced-music-iterator.cc +++ b/lily/context-specced-music-iterator.cc @@ -38,7 +38,7 @@ Context_specced_music_iterator::construct_children () a = 0; if (a) - set_translator (a); + set_context (a); Music_wrapper_iterator::construct_children (); } diff --git a/lily/event-chord-iterator.cc b/lily/event-chord-iterator.cc index 21ec89cbff..ef045c427f 100644 --- a/lily/event-chord-iterator.cc +++ b/lily/event-chord-iterator.cc @@ -23,7 +23,7 @@ Event_chord_iterator::get_req_translator () if (get_outlet ()->is_bottom_context ()) return get_outlet (); - set_translator (get_outlet ()->get_default_interpreter ()); + set_context (get_outlet ()->get_default_interpreter ()); return get_outlet (); } diff --git a/lily/include/interpretation-context-handle.hh b/lily/include/interpretation-context-handle.hh index 3ba8ee5b4d..2a1a364128 100644 --- a/lily/include/interpretation-context-handle.hh +++ b/lily/include/interpretation-context-handle.hh @@ -11,13 +11,17 @@ #define INTERPRETATION_CONTEXT_HANDLE_HH #include "lily-proto.hh" +/* +RENAME ME to Context_handle. +*/ + class Interpretation_context_handle { public: ~Interpretation_context_handle (); Interpretation_context_handle (); - void set_translator (Context *); + void set_context (Context *); bool try_music (Music *); void operator = (Interpretation_context_handle const&); Interpretation_context_handle (Interpretation_context_handle const&); diff --git a/lily/include/music-iterator.hh b/lily/include/music-iterator.hh index 8d10fe5bf7..71de6e4810 100644 --- a/lily/include/music-iterator.hh +++ b/lily/include/music-iterator.hh @@ -76,7 +76,7 @@ public: */ Context * get_outlet () const; - void set_translator (Context *); + void set_context (Context *); /** Get an iterator matching the type of MUS, and use TRANS to find an accompanying translation unit diff --git a/lily/music-iterator.cc b/lily/music-iterator.cc index c4cf900dca..fce6412e7e 100644 --- a/lily/music-iterator.cc +++ b/lily/music-iterator.cc @@ -42,9 +42,9 @@ Music_iterator::get_outlet () const } void -Music_iterator::set_translator (Context *trans) +Music_iterator::set_context (Context *trans) { - handle_.set_translator (trans); + handle_.set_context (trans); } void @@ -121,14 +121,14 @@ Music_iterator::init_translator (Music *m, Context *report) music_ = m; assert (m); if (! get_outlet ()) - set_translator (report); + set_context (report); } void Music_iterator::substitute_outlet (Context *f, Context *t) { if (get_outlet () == f) - set_translator (t); + set_context (t); derived_substitute (f,t); } @@ -258,5 +258,5 @@ Music_iterator::descend_to_child (Context * child_report) { Context * me_report = get_outlet (); if (is_child_context (me_report, child_report)) - set_translator (child_report); + set_context (child_report); } diff --git a/lily/new-quote-iterator.cc b/lily/new-quote-iterator.cc new file mode 100644 index 0000000000..e3928cfcef --- /dev/null +++ b/lily/new-quote-iterator.cc @@ -0,0 +1,217 @@ +/* + quote-iterator.cc -- implement New_quote_iterator + + source file of the GNU LilyPond music typesetter + + (c) 2004 Han-Wen Nienhuys + +*/ + +#include "context.hh" +#include "event.hh" +#include "music-sequence.hh" +#include "lily-guile.hh" +#include "music-wrapper-iterator.hh" +#include "music.hh" +#include "input.hh" +#include "warn.hh" +#include "interpretation-context-handle.hh" + +class New_quote_iterator : public Music_wrapper_iterator +{ +public: + New_quote_iterator (); + Moment vector_moment (int idx) const; + Interpretation_context_handle quote_outlet_; + + Moment start_moment_; + SCM event_vector_; + int event_idx_; + int end_idx_ ; + + SCM transposed_musics_; + + DECLARE_SCHEME_CALLBACK (constructor, ()); + + bool accept_music_type (Music*) const; +protected: + virtual void derived_mark () const; + virtual void construct_children (); + virtual Moment pending_moment () const; + virtual void process (Moment); + virtual bool ok () const; +}; + +bool +New_quote_iterator::accept_music_type (Music *mus) const +{ + SCM accept = get_outlet()->get_property ("quotedEventTypes"); + for (SCM s = mus->get_property ("types"); + scm_is_pair (s); s = scm_cdr (s)) + { + if (scm_memq (scm_car (s), accept) != SCM_BOOL_F) + return true; + } + + return false; +} + + +void +New_quote_iterator::derived_mark () const +{ + scm_gc_mark (transposed_musics_ ); +} + +New_quote_iterator::New_quote_iterator () +{ + transposed_musics_ = SCM_EOL; + event_vector_ = SCM_EOL; + event_idx_ = 0; + end_idx_ = 0; +} + + +int +binsearch_scm_vector (SCM vec, SCM key, bool (*is_less)(SCM a,SCM b)) +{ + int lo = 0; + int hi = SCM_VECTOR_LENGTH (vec); + + /* binary search */ + do + { + int cmp = (lo + hi) / 2; + + SCM when = scm_caar (SCM_VECTOR_REF (vec, cmp)); + bool result = (*is_less) (key, when); + if (result) + hi = cmp; + else + lo = cmp; + } + while (hi - lo > 1); + + return lo; +} + + +void +New_quote_iterator::construct_children () +{ + Music_wrapper_iterator::construct_children (); + + SCM name = get_music ()->get_property ("quoted-context-type"); + SCM id = get_music ()->get_property ("quoted-context-id"); + + Context *cue_context = get_outlet()->find_create_context (name, + ly_scm2string (id), SCM_EOL); + quote_outlet_.set_context (cue_context); + + Moment now = get_outlet ()->now_mom (); + Moment stop = now + get_music()->get_length (); + + start_moment_ = now; + event_vector_ = get_music ()->get_property ("quoted-events"); + + if (ly_c_vector_p (event_vector_)) + { + event_idx_ = binsearch_scm_vector (event_vector_, now.smobbed_copy (), &moment_less); + end_idx_ = binsearch_scm_vector (event_vector_, stop.smobbed_copy (), &moment_less); + } + else + { + get_music ()->origin()->warning (_("No events found for \\quote")); + } +} + + +bool +New_quote_iterator::ok () const +{ + return + Music_wrapper_iterator::ok() + && ly_c_vector_p (event_vector_) && (event_idx_ <= end_idx_); +} + +Moment +New_quote_iterator::pending_moment () const +{ + return + Music_wrapper_iterator::pending_moment() + m) + return ; + + if (em == m) + break ; + + event_idx_++; + } + + if (event_idx_ <= end_idx_) + { + SCM entry = SCM_VECTOR_REF (event_vector_, event_idx_); + Pitch * quote_pitch = unsmob_pitch (scm_cdar (entry)); + + /* + The pitch that sounds like central C + */ + Pitch * me_pitch = unsmob_pitch (get_outlet ()->get_property ("instrumentTransposition")); + + for (SCM s = scm_cdr (entry); scm_is_pair (s); s = scm_cdr (s)) + { + SCM ev_acc = scm_car (s); + + Music * mus = unsmob_music (scm_car (ev_acc)); + if (!mus) + programming_error ("need music in quote."); + else if (accept_music_type (mus)) + { + if (quote_pitch || me_pitch) + { + Pitch qp, mp; + if (quote_pitch) + qp = *quote_pitch; + if (me_pitch) + mp = *me_pitch; + + Pitch diff = pitch_interval (qp, mp); + + SCM copy = ly_deep_mus_copy (mus->self_scm ()); + mus = unsmob_music (copy); + + transposed_musics_ = scm_cons (copy, transposed_musics_); + mus->transpose (diff); + } + + bool b = quote_outlet_.get_outlet ()->try_music (mus); + if (!b) + mus->origin ()->warning (_f ("In quotation: junking event %s", mus->name ())); + } + } + } + event_idx_ ++; +} + +IMPLEMENT_CTOR_CALLBACK (New_quote_iterator); diff --git a/lily/parser.yy b/lily/parser.yy index 0c3b76df01..a193206ffc 100644 --- a/lily/parser.yy +++ b/lily/parser.yy @@ -1063,28 +1063,26 @@ Generic_prefix_music: Input *loc = unsmob_input (scm_cadr ($1)); SCM args = scm_cddr ($1); SCM sig = scm_object_property (func, ly_symbol2scm ("music-function-signature")); - int k = 0; - bool ok = true; - for (SCM s = sig, t = args; - ok && scm_is_pair (s) && scm_is_pair (t); - s = scm_cdr (s), t = scm_cdr (t)) { - k++; - if (scm_call_1 (scm_car (s), scm_car (t)) != SCM_BOOL_T) - { - loc->error (_f ("Argument %d failed typecheck", k)); - THIS->error_level_ = 1; - ok = false; - } + + SCM type_check_proc = ly_scheme_function ("type-check-list"); + bool ok = true; + + if (!to_boolean (scm_call_3 (type_check_proc, scm_cadr ($1), sig, args))) + { + THIS->error_level_ = 1; + ok = false; } + SCM m = SCM_EOL; - if (ok) + if (ok) m = scm_apply_0 (func, scm_cdr ($1)); + if (unsmob_music (m)) { $$ = unsmob_music (m); scm_gc_protect_object (m); } - else + else { if (ok) loc->error (_ ("Music head function should return Music object.")); diff --git a/lily/part-combine-iterator.cc b/lily/part-combine-iterator.cc index c75bf3187d..95542d3c30 100644 --- a/lily/part-combine-iterator.cc +++ b/lily/part-combine-iterator.cc @@ -88,11 +88,11 @@ Part_combine_iterator::do_quit () if (second_iter_) second_iter_->quit (); - null_.set_translator (0); - one_ .set_translator (0); - two_.set_translator (0); - shared_.set_translator (0); - solo_.set_translator (0); + null_.set_context (0); + one_ .set_context (0); + two_.set_context (0); + shared_.set_context (0); + solo_.set_context (0); } @@ -323,18 +323,18 @@ Part_combine_iterator::construct_children () = get_outlet ()->find_create_context (ly_symbol2scm ("Voice"), "shared",props); - shared_.set_translator (tr); + shared_.set_context (tr); /* If we don't, we get a new staff for every Voice. */ - set_translator (tr); + set_context (tr); Context *solo_tr = get_outlet ()->find_create_context (ly_symbol2scm ("Voice"), "solo",props); - solo_ .set_translator (solo_tr); + solo_ .set_context (solo_tr); Context *null = get_outlet ()->find_create_context (ly_symbol2scm ("Devnull"), @@ -343,25 +343,25 @@ Part_combine_iterator::construct_children () if (!null) programming_error ("No Devnull found?"); - null_.set_translator (null); + null_.set_context (null); Context *one = tr->find_create_context (ly_symbol2scm ("Voice"), "one", props); - one_.set_translator (one); + one_.set_context (one); - set_translator (one); + set_context (one); first_iter_ = unsmob_iterator (get_iterator (unsmob_music (scm_car (lst)))); Context *two = tr->find_create_context (ly_symbol2scm ("Voice"), "two", props); - two_.set_translator (two); - set_translator (two); + two_.set_context (two); + set_context (two); second_iter_ = unsmob_iterator (get_iterator (unsmob_music (scm_cadr (lst)))); - set_translator (tr); + set_context (tr); char const * syms[] = { diff --git a/lily/percent-repeat-iterator.cc b/lily/percent-repeat-iterator.cc index bd7a36b9a0..86a1d33795 100644 --- a/lily/percent-repeat-iterator.cc +++ b/lily/percent-repeat-iterator.cc @@ -48,7 +48,7 @@ Percent_repeat_iterator::process (Moment m) { Music_iterator *yeah = try_music (get_music ()); if (yeah) - set_translator (yeah->get_outlet ()); + set_context (yeah->get_outlet ()); else get_music ()->origin ()->warning ( _ ("no one to print a percent")); } diff --git a/lily/quote-iterator.cc b/lily/quote-iterator.cc index 9e012104de..15f5a1aef9 100644 --- a/lily/quote-iterator.cc +++ b/lily/quote-iterator.cc @@ -81,7 +81,7 @@ Quote_iterator::construct_children () if (!unsmob_duration (dur)) return ; - set_translator (get_outlet ()->get_default_interpreter ()); + set_context (get_outlet ()->get_default_interpreter ()); Moment now = get_outlet ()->now_mom (); Moment stop = now + unsmob_duration (dur)->get_length (); diff --git a/lily/simultaneous-music-iterator.cc b/lily/simultaneous-music-iterator.cc index 31f591faf3..ad093ec93b 100644 --- a/lily/simultaneous-music-iterator.cc +++ b/lily/simultaneous-music-iterator.cc @@ -69,7 +69,7 @@ Simultaneous_music_iterator::construct_children () tail = SCM_CDRLOC (*tail); } else - mi->set_translator (0); + mi->set_context (0); } } diff --git a/lily/time-scaled-music-iterator.cc b/lily/time-scaled-music-iterator.cc index df703cbb33..4c7b577aa3 100644 --- a/lily/time-scaled-music-iterator.cc +++ b/lily/time-scaled-music-iterator.cc @@ -19,7 +19,7 @@ Time_scaled_music_iterator::process (Moment m) { Music_iterator *yeah = try_music (get_music ()); if (yeah) - set_translator (yeah->get_outlet ()); + set_context (yeah->get_outlet ()); else get_music ()->origin ()->warning (_ ("no one to print a tuplet start bracket")); } diff --git a/ly/music-functions-init.ly b/ly/music-functions-init.ly index 81129b7b0d..cd9914887a 100644 --- a/ly/music-functions-init.ly +++ b/ly/music-functions-init.ly @@ -73,18 +73,45 @@ keepWithTag = music)) - -quoteDuring = -#(def-music-function - (location what dir music) (string? ly:dir? ly:music?) +%% Todo: +%% doing +%% def-music-function in a .scm causes crash. + +quoteDuring = # +(def-music-function + (location what dir main-music) + (string? ly:dir? ly:music?) (let* - ((quote-music (make-music 'NewQuoteMusic - 'quoted-music-name what - 'element music - 'origin location) - )) - - quote-music)) + ((quote-music + (make-music 'NewQuoteMusic + 'quoted-context-type 'Voice + 'quoted-context-id "cue" + 'quoted-music-name what + 'origin location)) + (main-voice (if (= 1 dir) 2 1)) + (cue-voice (if (= 1 dir) 1 2)) + (return-value quote-music) + ) + + (if (not (= dir 0)) + (begin + (set! return-value + (make-sequential-music + (list + (context-spec-music (make-voice-props-set cue-voice) 'Voice "cue") + quote-music + (context-spec-music (make-voice-props-revert) 'Voice "cue")) + )) + + (set! main-music + (make-sequential-music + (list + (make-voice-props-set main-voice) + main-music + (make-voice-props-revert))) + ))) + (set! (ly:music-property quote-music 'element) main-music) + return-value)) %{ diff --git a/scm/define-music-properties.scm b/scm/define-music-properties.scm index f4d852363f..195b86c8ee 100644 --- a/scm/define-music-properties.scm +++ b/scm/define-music-properties.scm @@ -86,6 +86,9 @@ For chord inversions, this is negative.") (predicate ,procedure? "the predicate of a \\outputproperty.") (quoted-events ,vector? "A vector of with moment/event-list entries.") (quoted-music-name ,string? "The name of the voice to quote.") + (quoted-context-type ,symbol? "The name of the context to direct quotes to, eg., @code{Voice}.") + (quoted-context-id ,string? "The id of the context to direct quotes to, eg., @code{cue}.") + (type ,symbol? "The type of this music object. Determines iteration in some cases.") (types ,list? "The types of this music object; determines by what engraver this music expression is diff --git a/scm/define-music-types.scm b/scm/define-music-types.scm index fb7f565067..cd2629b851 100644 --- a/scm/define-music-types.scm +++ b/scm/define-music-types.scm @@ -412,7 +412,7 @@ goes down).") (NewQuoteMusic . ( (description . "Quote preprocessed snippets of music. ") - (internal-class-name . "Music") ;; so we get Event::get_length (). + (internal-class-name . "Music_wrapper") ;; so we get Event::get_length (). (iterator-ctor . ,New_quote_iterator::constructor) (types . (general-music)) )) @@ -426,7 +426,6 @@ goes down).") (RepeatedMusic . ( (description . "Repeat music in different ways") - (type . repeated-music) (types . (general-music repeated-music)) )) diff --git a/scm/lily-library.scm b/scm/lily-library.scm new file mode 100644 index 0000000000..94852eb3b9 --- /dev/null +++ b/scm/lily-library.scm @@ -0,0 +1,310 @@ + + +(define-public X 0) +(define-public Y 1) +(define-public START -1) +(define-public STOP 1) +(define-public LEFT -1) +(define-public RIGHT 1) +(define-public UP 1) +(define-public DOWN -1) +(define-public CENTER 0) + +(define-public DOUBLE-FLAT -4) +(define-public THREE-Q-FLAT -3) +(define-public FLAT -2) +(define-public SEMI-FLAT -1) +(define-public NATURAL 0) +(define-public SEMI-SHARP 1) +(define-public SHARP 2) +(define-public THREE-Q-SHARP 3) +(define-public DOUBLE-SHARP 4) +(define-public SEMI-TONE 2) + +(define-public ZERO-MOMENT (ly:make-moment 0 1)) + +(define-public (moment-min a b) + (if (ly:momentstring (car x)) + (symbol->string (car y)))) + +(define-public (chain-assoc x alist-list) + (if (null? alist-list) + #f + (let* ((handle (assoc x (car alist-list)))) + (if (pair? handle) + handle + (chain-assoc x (cdr alist-list)))))) + +(define-public (chain-assoc-get x alist-list . default) + "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not +found." + + (define (helper x alist-list default) + (if (null? alist-list) + default + (let* ((handle (assoc x (car alist-list)))) + (if (pair? handle) + (cdr handle) + (helper x (cdr alist-list) default))))) + + (helper x alist-list + (if (pair? default) (car default) #f))) + +(define (map-alist-vals func list) + "map FUNC over the vals of LIST, leaving the keys." + (if (null? list) + '() + (cons (cons (caar list) (func (cdar list))) + (map-alist-vals func (cdr list))) + )) + +(define (map-alist-keys func list) + "map FUNC over the keys of an alist LIST, leaving the vals. " + (if (null? list) + '() + (cons (cons (func (caar list)) (cdar list)) + (map-alist-keys func (cdr list))) + )) + +;;;;;;;;;;;;;;;; +;; hash + + + +(if (not (defined? 'hash-table?)) ; guile 1.6 compat + (begin + (define hash-table? vector?) + + (define-public (hash-table->alist t) + "Convert table t to list" + (apply append + (vector->list t) + ))) + + ;; native hashtabs. + (begin + (define-public (hash-table->alist t) + + (hash-fold (lambda (k v acc) (acons k v acc)) + '() t) + ) + )) + +;; todo: code dup with C++. +(define-public (alist->hash-table l) + "Convert alist to table" + (let + ((m (make-hash-table (length l)))) + + (map (lambda (k-v) + (hashq-set! m (car k-v) (cdr k-v))) + l) + + m)) + + + + +;;;;;;;;;;;;;;;; +; list + +(define (flatten-list lst) + "Unnest LST" + (if (null? lst) + '() + (if (pair? (car lst)) + (append (flatten-list (car lst)) (flatten-list (cdr lst))) + (cons (car lst) (flatten-list (cdr lst)))) + )) + +(define (list-minus a b) + "Return list of elements in A that are not in B." + (lset-difference eq? a b)) + + +;; TODO: use the srfi-1 partition function. +(define-public (uniq-list l) + + "Uniq LIST, assuming that it is sorted" + (define (helper acc l) + (if (null? l) + acc + (if (null? (cdr l)) + (cons (car l) acc) + (if (equal? (car l) (cadr l)) + (helper acc (cdr l)) + (helper (cons (car l) acc) (cdr l))) + ))) + (reverse! (helper '() l) '())) + + +(define (split-at-predicate 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-predicate (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-public (split-list l sep?) +" +(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) ) +=> +((a b c) (d e f) (g)) + +" +;; " KUT EMACS. + +(define (split-one sep? l acc) + "Split off the first parts before separator and return both parts." + (if (null? l) + (cons acc '()) + (if (sep? (car l)) + (cons acc (cdr l)) + (split-one sep? (cdr l) (cons (car l) acc)) + ) + )) + +(if (null? l) + '() + (let* ((c (split-one sep? l '()))) + (cons (reverse! (car c) '()) (split-list (cdr c) sep?)) + ))) + + +(define-public (interval-length x) + "Length of the number-pair X, when an interval" + (max 0 (- (cdr x) (car x))) + ) +(define-public interval-start car) +(define-public interval-end cdr) + +(define (other-axis a) + (remainder (+ a 1) 2)) + + +(define-public (interval-widen iv amount) + (cons (- (car iv) amount) + (+ (cdr iv) amount))) + +(define-public (interval-union i1 i2) + (cons (min (car i1) (car i2)) + (max (cdr i1) (cdr i2)))) + + +(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) + (cdr cell) + (car cell))) + +(define (cons-map f x) + "map F to contents of X" + (cons (f (car x)) (f (cdr x)))) + + +(define-public (list-insert-separator lst between) + "Create new list, inserting BETWEEN between elements of LIST" + (define (conc x y ) + (if (eq? y #f) + (list x) + (cons x (cons between y)) + )) + (fold-right conc #f lst)) + +;;;;;;;;;;;;;;;; +; other +(define (sign x) + (if (= x 0) + 0 + (if (< x 0) -1 1))) + +(define-public (symbolstring l) (symbol->string r))) + +(define-public (!= l r) + (not (= l r))) + + diff --git a/scm/lily.scm b/scm/lily.scm index 9a559b40df..dd86ef5021 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -70,321 +70,36 @@ (define-public _ gettext) (define-public _ ly:gettext)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-public X 0) -(define-public Y 1) -(define-public START -1) -(define-public STOP 1) -(define-public LEFT -1) -(define-public RIGHT 1) -(define-public UP 1) -(define-public DOWN -1) -(define-public CENTER 0) - -(define-public DOUBLE-FLAT -4) -(define-public THREE-Q-FLAT -3) -(define-public FLAT -2) -(define-public SEMI-FLAT -1) -(define-public NATURAL 0) -(define-public SEMI-SHARP 1) -(define-public SHARP 2) -(define-public THREE-Q-SHARP 3) -(define-public DOUBLE-SHARP 4) -(define-public SEMI-TONE 2) - -(define-public ZERO-MOMENT (ly:make-moment 0 1)) - -(define-public (moment-min a b) - (if (ly:momentstring (car x)) - (symbol->string (car y)))) - -(define-public (chain-assoc x alist-list) - (if (null? alist-list) - #f - (let* ((handle (assoc x (car alist-list)))) - (if (pair? handle) - handle - (chain-assoc x (cdr alist-list)))))) - -(define-public (chain-assoc-get x alist-list . default) - "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not -found." - - (define (helper x alist-list default) - (if (null? alist-list) - default - (let* ((handle (assoc x (car alist-list)))) - (if (pair? handle) - (cdr handle) - (helper x (cdr alist-list) default))))) - - (helper x alist-list - (if (pair? default) (car default) #f))) - -(define (map-alist-vals func list) - "map FUNC over the vals of LIST, leaving the keys." - (if (null? list) - '() - (cons (cons (caar list) (func (cdar list))) - (map-alist-vals func (cdr list))) - )) - -(define (map-alist-keys func list) - "map FUNC over the keys of an alist LIST, leaving the vals. " - (if (null? list) - '() - (cons (cons (func (caar list)) (cdar list)) - (map-alist-keys func (cdr list))) - )) - -;;;;;;;;;;;;;;;; -;; hash - - - -(if (not (defined? 'hash-table?)) ; guile 1.6 compat - (begin - (define hash-table? vector?) - - (define-public (hash-table->alist t) - "Convert table t to list" - (apply append - (vector->list t) - ))) - - ;; native hashtabs. - (begin - (define-public (hash-table->alist t) - - (hash-fold (lambda (k v acc) (acons k v acc)) - '() t) - ) - )) - -;; todo: code dup with C++. -(define-public (alist->hash-table l) - "Convert alist to table" - (let - ((m (make-hash-table (length l)))) - - (map (lambda (k-v) - (hashq-set! m (car k-v) (cdr k-v))) - l) - - m)) - - - -;;;;;;;;;;;;;;;; -; list - -(define (flatten-list lst) - "Unnest LST" - (if (null? lst) - '() - (if (pair? (car lst)) - (append (flatten-list (car lst)) (flatten-list (cdr lst))) - (cons (car lst) (flatten-list (cdr lst)))) - )) - -(define (list-minus a b) - "Return list of elements in A that are not in B." - (lset-difference eq? a b)) - - -;; TODO: use the srfi-1 partition function. -(define-public (uniq-list l) - - "Uniq LIST, assuming that it is sorted" - (define (helper acc l) - (if (null? l) - acc - (if (null? (cdr l)) - (cons (car l) acc) - (if (equal? (car l) (cadr l)) - (helper acc (cdr l)) - (helper (cons (car l) acc) (cdr l))) - ))) - (reverse! (helper '() l) '())) - - -(define (split-at-predicate 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-predicate (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-public (split-list l sep?) -" -(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) ) -=> -((a b c) (d e f) (g)) - -" -;; " KUT EMACS. - -(define (split-one sep? l acc) - "Split off the first parts before separator and return both parts." - (if (null? l) - (cons acc '()) - (if (sep? (car l)) - (cons acc (cdr l)) - (split-one sep? (cdr l) (cons (car l) acc)) - ) - )) - -(if (null? l) - '() - (let* ((c (split-one sep? l '()))) - (cons (reverse! (car c) '()) (split-list (cdr c) sep?)) - ))) - - -(define-public (interval-length x) - "Length of the number-pair X, when an interval" - (max 0 (- (cdr x) (car x))) - ) -(define-public interval-start car) -(define-public interval-end cdr) - -(define (other-axis a) - (remainder (+ a 1) 2)) - - -(define-public (interval-widen iv amount) - (cons (- (car iv) amount) - (+ (cdr iv) amount))) - -(define-public (interval-union i1 i2) - (cons (min (car i1) (car i2)) - (max (cdr i1) (cdr i2)))) - - -(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) - (cdr cell) - (car cell))) - -(define (cons-map f x) - "map F to contents of X" - (cons (f (car x)) (f (cdr x)))) - - -(define-public (list-insert-separator lst between) - "Create new list, inserting BETWEEN between elements of LIST" - (define (conc x y ) - (if (eq? y #f) - (list x) - (cons x (cons between y)) - )) - (fold-right conc #f lst)) - -;;;;;;;;;;;;;;;; -; other -(define (sign x) - (if (= x 0) - 0 - (if (< x 0) -1 1))) - -(define-public (symbolstring l) (symbol->string r))) - -(define-public (!= l r) - (not (= l r))) - (define-public (ly:load x) (let* ((fn (%search-load-path x))) (if (ly:get-option 'verbose) (format (current-error-port) "[~A]" fn)) (primitive-load fn))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (type-check-list location signature arguments) + "Typecheck a list of arguments against a list of type +predicates. Print a message at LOCATION if any predicate failed." + (define (recursion-helper signature arguments count) + (define (helper pred? arg count) + (if (not (pred? arg)) + + (begin + (ly:input-message location + (format #f + (_ "wrong type for argument ~a. Expecting ~a, found ~s") + count (type-name pred?) arg)) + #f) + #t)) + + (if (null? signature) + #t + (and (helper (car signature) (car arguments) count) + (recursion-helper (cdr signature) (cdr arguments) (1+ count))) + )) + (recursion-helper signature arguments 1)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; output @@ -446,7 +161,8 @@ possibly turned off." (for-each ly:load ;; load-from-path - '("define-music-types.scm" + '("lily-library.scm" + "define-music-types.scm" "output-lib.scm" "c++.scm" "chord-ignatzek-names.scm" @@ -637,3 +353,4 @@ possibly turned off." (exit 1)) (exit 0)))) + -- 2.39.5