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)
2004-11-06 Han-Wen Nienhuys <hanwen@xs4all.nl>
+ * 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
--- /dev/null
+\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. } }
+ >>
+>>
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 ();
}
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);
{
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"));
}
--- /dev/null
+/*
+ interpretation-context-handle.cc -- implement Interpretation_context_handle
+
+ source file of the GNU LilyPond music typesetter
+
+ (c) 1999--2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+ */
+
+#include "interpretation-context-handle.hh"
+#include "context.hh"
+
+Interpretation_context_handle::Interpretation_context_handle ()
+{
+ outlet_ =0;
+}
+
+Interpretation_context_handle::Interpretation_context_handle (Interpretation_context_handle const&s)
+{
+ outlet_ =0;
+ if (s.outlet_)
+ up (s.outlet_);
+}
+
+
+Interpretation_context_handle::~Interpretation_context_handle ()
+{
+ /*
+ Don't do
+
+ if (outlet_)
+ down ();
+
+ with GC, this is asynchronous.
+ */
+}
+
+void
+Interpretation_context_handle::up (Context *t)
+{
+ outlet_ = t;
+ t->iterator_count_ ++;
+}
+
+void
+Interpretation_context_handle::down ()
+{
+ outlet_->iterator_count_ --;
+ outlet_ = 0;
+}
+
+void
+Interpretation_context_handle::quit ()
+{
+ if (outlet_)
+ {
+ outlet_->iterator_count_ --;
+ outlet_ = 0;
+ }
+}
+
+bool
+Interpretation_context_handle::try_music (Music *m)
+{
+ return outlet_->try_music (m);
+}
+
+void
+Interpretation_context_handle::operator = (Interpretation_context_handle const &s)
+{
+ set_context (s.outlet_);
+}
+
+void
+Interpretation_context_handle::set_context (Context *trans)
+{
+ if (outlet_ ==trans)
+ return;
+ if (outlet_)
+ down ();
+ if (trans)
+ up (trans);
+}
+
+Context *
+Interpretation_context_handle::get_outlet () const
+{
+
+ return outlet_;
+}
+
+int
+Interpretation_context_handle::get_count () const
+{
+ return outlet_->iterator_count_ ;
+}
a = 0;
if (a)
- set_translator (a);
+ set_context (a);
Music_wrapper_iterator::construct_children ();
}
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 ();
}
#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&);
*/
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
+++ /dev/null
-/*
- interpretation-context-handle.cc -- implement Interpretation_context_handle
-
- source file of the GNU LilyPond music typesetter
-
- (c) 1999--2004 Han-Wen Nienhuys <hanwen@cs.uu.nl>
- */
-
-#include "interpretation-context-handle.hh"
-#include "context.hh"
-
-Interpretation_context_handle::Interpretation_context_handle ()
-{
- outlet_ =0;
-}
-
-Interpretation_context_handle::Interpretation_context_handle (Interpretation_context_handle const&s)
-{
- outlet_ =0;
- if (s.outlet_)
- up (s.outlet_);
-}
-
-
-Interpretation_context_handle::~Interpretation_context_handle ()
-{
- /*
- Don't do
-
- if (outlet_)
- down ();
-
- with GC, this is asynchronous.
- */
-}
-
-void
-Interpretation_context_handle::up (Context *t)
-{
- outlet_ = t;
- t->iterator_count_ ++;
-}
-
-void
-Interpretation_context_handle::down ()
-{
- outlet_->iterator_count_ --;
- outlet_ = 0;
-}
-
-void
-Interpretation_context_handle::quit ()
-{
- if (outlet_)
- {
- outlet_->iterator_count_ --;
- outlet_ = 0;
- }
-}
-
-bool
-Interpretation_context_handle::try_music (Music *m)
-{
- return outlet_->try_music (m);
-}
-
-void
-Interpretation_context_handle::operator = (Interpretation_context_handle const &s)
-{
- set_translator (s.outlet_);
-}
-
-void
-Interpretation_context_handle::set_translator (Context *trans)
-{
- if (outlet_ ==trans)
- return;
- if (outlet_)
- down ();
- if (trans)
- up (trans);
-}
-
-Context *
-Interpretation_context_handle::get_outlet () const
-{
-
- return outlet_;
-}
-
-int
-Interpretation_context_handle::get_count () const
-{
- return outlet_->iterator_count_ ;
-}
}
void
-Music_iterator::set_translator (Context *trans)
+Music_iterator::set_context (Context *trans)
{
- handle_.set_translator (trans);
+ handle_.set_context (trans);
}
void
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);
}
{
Context * me_report = get_outlet ();
if (is_child_context (me_report, child_report))
- set_translator (child_report);
+ set_context (child_report);
}
--- /dev/null
+/*
+ quote-iterator.cc -- implement New_quote_iterator
+
+ source file of the GNU LilyPond music typesetter
+
+ (c) 2004 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+*/
+
+#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()
+ <?
+ vector_moment (event_idx_) - start_moment_;
+}
+
+Moment
+New_quote_iterator::vector_moment (int idx) const
+{
+ SCM entry = SCM_VECTOR_REF (event_vector_, idx);
+ return *unsmob_moment (scm_caar (entry));
+}
+
+
+void
+New_quote_iterator::process (Moment m)
+{
+ Music_wrapper_iterator::process (m);
+
+ m += start_moment_;
+ while (event_idx_ <= end_idx_)
+ {
+ Moment em = vector_moment (event_idx_);
+ if (em > 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);
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."));
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);
}
= 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"),
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[] = {
{
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"));
}
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 ();
tail = SCM_CDRLOC (*tail);
}
else
- mi->set_translator (0);
+ mi->set_context (0);
}
}
{
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"));
}
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))
%{
(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
(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))
))
(RepeatedMusic
. (
(description . "Repeat music in different ways")
-
(type . repeated-music)
(types . (general-music repeated-music))
))
--- /dev/null
+
+
+(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:moment<? a b) a b))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; lily specific variables.
+
+(define-public default-script-alist '())
+
+
+;; parser stuff.
+(define-public (print-music-as-book parser music)
+ (let* ((head (ly:parser-lookup parser '$globalheader))
+ (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
+ head score)))
+ (ly:parser-print-book parser book)))
+
+(define-public (print-score-as-book parser score)
+ (let*
+ ((head (ly:parser-lookup parser '$globalheader))
+ (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
+ head score)))
+ (ly:parser-print-book parser book)))
+
+(define-public (print-score parser score)
+ (let* ((head (ly:parser-lookup parser '$globalheader))
+ (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
+ head score)))
+ (ly:parser-print-score parser book)))
+
+(define-public (collect-scores-for-book parser score)
+ (let*
+ ((oldval (ly:parser-lookup parser 'toplevel-scores)))
+ (ly:parser-define parser 'toplevel-scores (cons score oldval))
+ ))
+
+(define-public (collect-music-for-book parser music)
+ (collect-scores-for-book parser (ly:music-scorify music parser)))
+
+
+
+;;;;;;;;;;;;;;;;
+; alist
+(define-public assoc-get ly:assoc-get)
+
+(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))))
+
+(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 (symbol<? l r)
+ (string<? (symbol->string l) (symbol->string r)))
+
+(define-public (!= l r)
+ (not (= l r)))
+
+
(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:moment<? a b) a b))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; lily specific variables.
-
-(define-public default-script-alist '())
-
-
-;; parser stuff.
-(define-public (print-music-as-book parser music)
- (let* ((head (ly:parser-lookup parser '$globalheader))
- (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
- head score)))
- (ly:parser-print-book parser book)))
-
-(define-public (print-score-as-book parser score)
- (let*
- ((head (ly:parser-lookup parser '$globalheader))
- (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
- head score)))
- (ly:parser-print-book parser book)))
-
-(define-public (print-score parser score)
- (let* ((head (ly:parser-lookup parser '$globalheader))
- (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
- head score)))
- (ly:parser-print-score parser book)))
-
-(define-public (collect-scores-for-book parser score)
- (let*
- ((oldval (ly:parser-lookup parser 'toplevel-scores)))
- (ly:parser-define parser 'toplevel-scores (cons score oldval))
- ))
-
-(define-public (collect-music-for-book parser music)
- (collect-scores-for-book parser (ly:music-scorify music parser)))
-
-
-
-;;;;;;;;;;;;;;;;
-; alist
-(define-public assoc-get ly:assoc-get)
-
-(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))))
-
-(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 (symbol<? l r)
- (string<? (symbol->string 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
(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"
(exit 1))
(exit 0))))
+
projects / lilypond.git / commitdiff