From: hanwen <hanwen>
Date: Mon, 31 Oct 2005 15:38:55 +0000 (+0000)
Subject: * input/regression/beam-quant-standard.ly: reindent, set
X-Git-Tag: release/2.7.16^2~30
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=ebdbda69aed6b34ab04125d2e3e98730f4a76725;p=lilypond.git
* input/regression/beam-quant-standard.ly: reindent, set
debug-beam-quanting to #t.
* lily/beam-concave.cc (calc_concaveness): set concaveness to
10000 if this is a "hard" concave beam.
* lily/beam.cc (calc_least_squares_positions): change from
calc_least_squares_dy
(set_stem_lengths): this is now a chained callback.
* lily/context-property.cc (execute_general_pushpop_property):
bugfix override with procedure should have effect.
* scm/define-grob-properties.scm (all-internal-grob-properties):
remove position-callbacks.
* scm/define-grobs.scm (all-grob-descriptions): use
ly:make-callback-chain for positions property.
* scm/layout-beam.scm (check-quant-callbacks): return list of
chained callbacks.
* scm/lily.scm (type-p-name-alist): add callback-chain
* lily/lily-guile.cc (type_check_assignment): type check failure
is warning not message.
* lily/grob-property.cc (try_callback): walk callback chain if
appropriate.
* lily/chained-callback.cc: new file. new smob type.
* lily/lily-guile.cc (procedure_arity): new function.
---
diff --git a/ChangeLog b/ChangeLog
index ad9c7d89e2..a21300fa51 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,39 @@
+2005-10-31 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * input/regression/beam-quant-standard.ly: reindent, set
+ debug-beam-quanting to #t.
+
+ * lily/beam-concave.cc (calc_concaveness): set concaveness to
+ 10000 if this is a "hard" concave beam.
+
+ * lily/beam.cc (calc_least_squares_positions): change from
+ calc_least_squares_dy
+ (set_stem_lengths): this is now a chained callback.
+
+ * lily/context-property.cc (execute_general_pushpop_property):
+ bugfix override with procedure should have effect.
+
+ * scm/define-grob-properties.scm (all-internal-grob-properties):
+ remove position-callbacks.
+
+ * scm/define-grobs.scm (all-grob-descriptions): use
+ ly:make-callback-chain for positions property.
+
+ * scm/layout-beam.scm (check-quant-callbacks): return list of
+ chained callbacks.
+
+ * scm/lily.scm (type-p-name-alist): add callback-chain
+
+ * lily/lily-guile.cc (type_check_assignment): type check failure
+ is warning not message.
+
+ * lily/grob-property.cc (try_callback): walk callback chain if
+ appropriate.
+
+ * lily/chained-callback.cc: new file. new smob type.
+
+ * lily/lily-guile.cc (procedure_arity): new function.
+
2005-10-28 Han-Wen Nienhuys <hanwen@xs4all.nl>
* Documentation/topdocs/INSTALL.texi (Top): add perl flex bison.
diff --git a/input/regression/beam-quant-standard.ly b/input/regression/beam-quant-standard.ly
index 3a2bf9a56d..e96236c2ac 100644
--- a/input/regression/beam-quant-standard.ly
+++ b/input/regression/beam-quant-standard.ly
@@ -1,144 +1,144 @@
\header {
- texidoc = "This file tests a few standard beam quants, taken from
+ texidoc = "This file tests a few standard beam quants, taken from
Ted Ross' book. If LilyPond finds another quant, the correct quant
is printed over the beam."
-
+
}
\version "2.7.13"
\layout {
- raggedright = ##t
-% #(define debug-beam-quanting #t)
+ raggedright = ##t
+ #(define debug-beam-quanting #t)
}
filler = \new Voice \relative {
- \hideNotes
- e4 e
+ \hideNotes
+ e4 e
}
-%
+ %
%%
%% Ross p108--112
primes = \relative {
- \time 3/4
- \assertBeamQuant #'(0 . 0) #'(0 . 0)
- c8[ c]
- \filler
- \assertBeamQuant #'(1 . -1) #'(1 . -1)
- d8[ d]
-
- \filler
-
- \assertBeamQuant #'(1 . 0) #'(1 . 0)
- e8[ e]
- \filler
-
-
- \assertBeamQuant #'(2 . -1) #'(2 . -1)
- f8[ f]
- \filler
-
-
- \assertBeamQuant #'(2 . 0) #'(2 . 0)
- g8[ g]
- \filler
-
-
- \assertBeamQuant #'(2 . 1) #'(2 . 1)
- a8[ a]
- \filler
-
+ \time 3/4
+ \assertBeamQuant #'(0 . 0) #'(0 . 0)
+ c8[ c]
+ \filler
+ \assertBeamQuant #'(1 . -1) #'(1 . -1)
+ d8[ d]
+
+ \filler
+
+ \assertBeamQuant #'(1 . 0) #'(1 . 0)
+ e8[ e]
+ \filler
+
+
+ \assertBeamQuant #'(2 . -1) #'(2 . -1)
+ f8[ f]
+ \filler
+
+
+ \assertBeamQuant #'(2 . 0) #'(2 . 0)
+ g8[ g]
+ \filler
+
+
+ \assertBeamQuant #'(2 . 1) #'(2 . 1)
+ a8[ a]
+ \filler
+
%{
- \once \override Beam #'inspect-quants = #'(2.2 . 2.2)
- \assertBeamQuant
- a8[ a]
- \filler
-
+ \once \override Beam #'inspect-quants = #'(2.2 . 2.2)
+ \assertBeamQuant
+ a8[ a]
+ \filler
+
%}
-
+
}
seconds = \relative {
-
- \assertBeamQuant #'(0 . 0) #'(0 . 1)
- a8[ b]
- \filler
-
+
+ \assertBeamQuant #'(0 . 0) #'(0 . 1)
+ a8[ b]
+ \filler
+
- \assertBeamQuant #'(0 . 0) #'(0 . 1)
- b8[ c]
- \filler
-
+ \assertBeamQuant #'(0 . 0) #'(0 . 1)
+ b8[ c]
+ \filler
+
- \assertBeamQuant #'(0 . 0) #'(0 . 1)
- c8[ d]
- \filler
-
- \assertBeamQuant #'(1 . -1) #'(1 . 0)
- d8[ e]
- \filler
-
-
- \assertBeamQuant #'(1 . 0) #'(1 . 1)
- e8[ f]
- \filler
-
-
- \assertBeamQuant #'(2 . -1) #'(2 . 0)
- f8[ g]
- \filler
-
-
- \assertBeamQuant #'(2 . 0) #'(2 . 1)
- g8[ a]
- \filler
+ \assertBeamQuant #'(0 . 0) #'(0 . 1)
+ c8[ d]
+ \filler
+
+ \assertBeamQuant #'(1 . -1) #'(1 . 0)
+ d8[ e]
+ \filler
+
+
+ \assertBeamQuant #'(1 . 0) #'(1 . 1)
+ e8[ f]
+ \filler
+
+
+ \assertBeamQuant #'(2 . -1) #'(2 . 0)
+ f8[ g]
+ \filler
+
+
+ \assertBeamQuant #'(2 . 0) #'(2 . 1)
+ g8[ a]
+ \filler
- \assertBeamQuant #'(3 . -1) #'(3 . 0)
- a8[ b]
- \filler
+ \assertBeamQuant #'(3 . -1) #'(3 . 0)
+ a8[ b]
+ \filler
}
filler = \new Voice \relative {
- \hideNotes
- e4 e4.
+ \hideNotes
+ e4 e4.
}
-% Ross, p122
+ % Ross, p122
primeSixteenths = \relative {
- \stemUp
- \assertBeamQuant #'(0 . -1) #'(0 . -1)
- g16[ g]
- \filler
- \assertBeamQuant #'(0 . -1) #'(0 . -1)
- a16[ a]
- \filler
- \assertBeamQuant #'(0 . -1) #'(0 . -1)
- b16[ b]
- \filler
- \assertBeamQuant #'(0 . 0) #'(0 . 0)
- c16[ c]
- \filler
- \assertBeamQuant #'(1 . -1) #'(1 . -1)
- d16[ d]
- \filler
- \assertBeamQuant #'(1 . 0) #'(1 . 0)
- e16[ e]
- \filler
- \assertBeamQuant #'(2 . -1) #'(2 . -1)
- f16[ f]
- \filler
- \assertBeamQuant #'(2 . 0) #'(2 . 0)
- g16[ g]
- \filler
- \assertBeamQuant #'(3 . -1) #'(3 . -1)
- a16[ a]
- \filler
- \assertBeamQuant #'(3 . 0) #'(3 . 0)
- b16[ b]
- \filler
+ \stemUp
+ \assertBeamQuant #'(0 . -1) #'(0 . -1)
+ g16[ g]
+ \filler
+ \assertBeamQuant #'(0 . -1) #'(0 . -1)
+ a16[ a]
+ \filler
+ \assertBeamQuant #'(0 . -1) #'(0 . -1)
+ b16[ b]
+ \filler
+ \assertBeamQuant #'(0 . 0) #'(0 . 0)
+ c16[ c]
+ \filler
+ \assertBeamQuant #'(1 . -1) #'(1 . -1)
+ d16[ d]
+ \filler
+ \assertBeamQuant #'(1 . 0) #'(1 . 0)
+ e16[ e]
+ \filler
+ \assertBeamQuant #'(2 . -1) #'(2 . -1)
+ f16[ f]
+ \filler
+ \assertBeamQuant #'(2 . 0) #'(2 . 0)
+ g16[ g]
+ \filler
+ \assertBeamQuant #'(3 . -1) #'(3 . -1)
+ a16[ a]
+ \filler
+ \assertBeamQuant #'(3 . 0) #'(3 . 0)
+ b16[ b]
+ \filler
}
\new Voice { \primes \seconds \primeSixteenths }
diff --git a/lily/beam-concave.cc b/lily/beam-concave.cc
index 7c38e96aa1..4eb2bab8fd 100644
--- a/lily/beam-concave.cc
+++ b/lily/beam-concave.cc
@@ -130,14 +130,7 @@ Beam::calc_concaveness (SCM smob)
if (is_concave_single_notes (far_positions, beam_dir))
{
- (void) me->get_property ("least-squares-dy"); // ugh. dependency handling.
-
- Drul_array<Real> pos = ly_scm2interval (me->get_property ("positions"));
- Real r = linear_combination (pos, 0.0);
-
- r /= Staff_symbol_referencer::staff_space (me);
- me->set_property ("positions", ly_interval2scm (Drul_array<Real> (r, r)));
- me->set_property ("least-squares-dy", scm_from_double (0));
+ concaveness = 10000;
}
else
{
@@ -147,3 +140,6 @@ Beam::calc_concaveness (SCM smob)
return scm_from_double (concaveness);
}
+
+
+
diff --git a/lily/beam-quanting.cc b/lily/beam-quanting.cc
index d0a09e9530..75e00fb93c 100644
--- a/lily/beam-quanting.cc
+++ b/lily/beam-quanting.cc
@@ -93,18 +93,17 @@ best_quant_score_idx (Array<Quant_score> const &qscores)
return best_idx;
}
-MAKE_SCHEME_CALLBACK (Beam, quanting, 1);
+MAKE_SCHEME_CALLBACK (Beam, quanting, 2);
SCM
-Beam::quanting (SCM smob)
+Beam::quanting (SCM smob, SCM posns)
{
Grob *me = unsmob_grob (smob);
Beam_quant_parameters parameters;
parameters.fill (me);
- SCM s = me->get_property ("positions");
- Real yl = scm_to_double (scm_car (s));
- Real yr = scm_to_double (scm_cdr (s));
+ Real yl = scm_to_double (scm_car (posns));
+ Real yr = scm_to_double (scm_cdr (posns));
/*
Calculations are relative to a unit-scaled staff, i.e. the quants are
@@ -300,15 +299,19 @@ Beam::quanting (SCM smob)
programming_error ("can't find quant");
}
#endif
+
+ Interval final_positions;
if (best_idx < 0)
{
warning (_ ("no feasible beam position"));
- me->set_property ("positions", ly_interval2scm (Interval (0, 0)));
+ final_positions = Interval (0, 0);
}
else
- me->set_property ("positions",
- ly_interval2scm (Drul_array<Real> (qscores[best_idx].yl,
- qscores[best_idx].yr)));
+ {
+ final_positions = Drul_array<Real> (qscores[best_idx].yl,
+ qscores[best_idx].yr);
+ }
+
#if DEBUG_QUANTING
if (best_idx >= 0
&& to_boolean (me->get_layout ()->lookup_variable (ly_symbol2scm ("debug-beam-quanting"))))
@@ -321,7 +324,7 @@ Beam::quanting (SCM smob)
}
#endif
- return SCM_UNSPECIFIED;
+ return ly_interval2scm (final_positions);
}
Real
diff --git a/lily/beam.cc b/lily/beam.cc
index acc4807492..9cd5793264 100644
--- a/lily/beam.cc
+++ b/lily/beam.cc
@@ -505,9 +505,11 @@ Beam::print (SCM grob)
Direction stem_dir = stems.size () ? to_dir (stems[0]->get_property ("direction")) : UP;
- Stencil tm = *unsmob_stencil (Text_interface::interpret_markup
+ Stencil score = *unsmob_stencil (Text_interface::interpret_markup
(me->get_layout ()->self_scm (), properties, quant_score));
- the_beam.add_at_edge (Y_AXIS, stem_dir, tm, 1.0, 0);
+
+ if (!score.is_empty ())
+ the_beam.add_at_edge (Y_AXIS, stem_dir, score, 1.0, 0);
}
#endif
@@ -738,14 +740,11 @@ Beam::calc_positions (SCM smob)
for (SCM i = callbacks; scm_is_pair (i); i = scm_cdr (i))
scm_call_1 (scm_car (i), me->self_scm ());
- /*
- TODO: move this in separate calc function.
- */
- set_stem_lengths (me);
return SCM_UNSPECIFIED;
}
+
void
set_minimum_dy (Grob *me, Real *dy)
{
@@ -771,21 +770,17 @@ set_minimum_dy (Grob *me, Real *dy)
/*
Compute a first approximation to the beam slope.
*/
-MAKE_SCHEME_CALLBACK (Beam, calc_least_squares_dy, 1);
+MAKE_SCHEME_CALLBACK (Beam, calc_least_squares_positions, 2);
SCM
-Beam::calc_least_squares_dy (SCM smob)
+Beam::calc_least_squares_positions (SCM smob, SCM posns)
{
+ (void) posns;
+
Grob *me = unsmob_grob (smob);
int count = visible_stem_count (me);
Interval pos (0, 0);
- if (count < 1)
- {
- me->set_property ("positions", ly_interval2scm (pos));
- return scm_from_double (0.0);
- }
-
Array<Real> x_posns;
extract_grob_set (me, "stems", stems);
Grob *commonx = common_refpoint_of_array (stems, me, X_AXIS);
@@ -873,9 +868,8 @@ Beam::calc_least_squares_dy (SCM smob)
*/
scale_drul (&pos, 1 / Staff_symbol_referencer::staff_space (me));
- me->set_property ("positions", ly_interval2scm (pos));
-
- return scm_from_double (ldy);
+ me->set_property ("least-squares-dy", scm_from_double (ldy));
+ return ly_interval2scm (pos);
}
/*
@@ -885,9 +879,9 @@ Beam::calc_least_squares_dy (SCM smob)
TODO: we should use the concaveness to control the amount of damping
applied.
*/
-MAKE_SCHEME_CALLBACK (Beam, shift_region_to_valid, 1);
+MAKE_SCHEME_CALLBACK (Beam, shift_region_to_valid, 2);
SCM
-Beam::shift_region_to_valid (SCM grob)
+Beam::shift_region_to_valid (SCM grob, SCM posns)
{
Grob *me = unsmob_grob (grob);
/*
@@ -901,7 +895,7 @@ Beam::shift_region_to_valid (SCM grob)
Grob *fvs = first_visible_stem (me);
if (!fvs)
- return SCM_UNSPECIFIED;
+ return posns;
Real x0 = fvs->relative_coordinate (commonx, X_AXIS);
for (int i = 0; i < stems.size (); i++)
@@ -914,11 +908,12 @@ Beam::shift_region_to_valid (SCM grob)
Grob *lvs = last_visible_stem (me);
if (!lvs)
- return SCM_UNSPECIFIED;
+ return posns;
Real dx = lvs->relative_coordinate (commonx, X_AXIS) - x0;
- Drul_array<Real> pos = ly_scm2interval (me->get_property ("positions"));
+ Drul_array<Real> pos = ly_scm2interval (posns);
+
scale_drul (&pos, Staff_symbol_referencer::staff_space (me));
@@ -975,33 +970,35 @@ Beam::shift_region_to_valid (SCM grob)
pos = Drul_array<Real> (y, (y + dy));
scale_drul (&pos, 1 / Staff_symbol_referencer::staff_space (me));
- me->set_property ("positions", ly_interval2scm (pos));
- return SCM_UNSPECIFIED;
+ return ly_interval2scm (pos);
}
/* This neat trick is by Werner Lemberg,
damped = tanh (slope)
corresponds with some tables in [Wanske] CHECKME */
-MAKE_SCHEME_CALLBACK (Beam, slope_damping, 1);
+MAKE_SCHEME_CALLBACK (Beam, slope_damping, 2);
SCM
-Beam::slope_damping (SCM smob)
+Beam::slope_damping (SCM smob, SCM posns)
{
Grob *me = unsmob_grob (smob);
+ Drul_array<Real> pos = ly_scm2interval (posns);
if (visible_stem_count (me) <= 1)
return SCM_UNSPECIFIED;
- /* trigger callback. */
- (void) me->get_property ("least-squares-dy");
SCM s = me->get_property ("damping");
Real damping = scm_to_double (s);
-
+ Real concaveness = robust_scm2double (me->get_property ("concaveness"), 0.0);
+ if (concaveness >= 10000)
+ {
+ pos[LEFT] = pos[RIGHT];
+ me->set_property ("least-squares-dy", scm_from_double (0));
+ damping = 0;
+ }
+
if (damping)
{
- Real concaveness = robust_scm2double (me->get_property ("concaveness"), 0.0);
-
- Drul_array<Real> pos = ly_scm2interval (me->get_property ("positions"));
scale_drul (&pos, Staff_symbol_referencer::staff_space (me));
Real dy = pos[RIGHT] - pos[LEFT];
@@ -1026,10 +1023,9 @@ Beam::slope_damping (SCM smob)
pos[RIGHT] -= (dy - damped_dy) / 2;
scale_drul (&pos, 1 / Staff_symbol_referencer::staff_space (me));
-
- me->set_property ("positions", ly_interval2scm (pos));
}
- return SCM_UNSPECIFIED;
+
+ return ly_interval2scm (pos);
}
/*
@@ -1095,18 +1091,21 @@ Beam::calc_stem_y (Grob *me, Grob *s, Grob ** common,
Hmm. At this time, beam position and slope are determined. Maybe,
stem directions and length should set to relative to the chord's
position of the beam. */
-void
-Beam::set_stem_lengths (Grob *me)
+MAKE_SCHEME_CALLBACK(Beam, set_stem_lengths, 2);
+SCM
+Beam::set_stem_lengths (SCM smob, SCM posns)
{
+ Grob *me = unsmob_grob (smob);
+
extract_grob_set (me, "stems", stems);
if (!stems.size ())
- return;
+ return posns;
Grob *common[2];
for (int a = 2; a--;)
common[a] = common_refpoint_of_array (stems, me, Axis (a));
- Drul_array<Real> pos = ly_scm2realdrul (me->get_property ("positions"));
+ Drul_array<Real> pos = ly_scm2realdrul (posns);
Real staff_space = Staff_symbol_referencer::staff_space (me);
scale_drul (&pos, staff_space);
@@ -1146,6 +1145,8 @@ Beam::set_stem_lengths (Grob *me)
Stem::set_stemend (s, 2 * stem_y / staff_space);
}
+
+ return posns;
}
void
diff --git a/lily/chained-callback.cc b/lily/chained-callback.cc
new file mode 100644
index 0000000000..646c7a4bc2
--- /dev/null
+++ b/lily/chained-callback.cc
@@ -0,0 +1,83 @@
+/*
+ chained-callback.cc -- chained callbacks.
+
+ source file of the GNU LilyPond music typesetter
+
+ (c) 2005 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+*/
+
+#include "lily-guile.hh"
+
+static scm_t_bits chain_tag;
+
+bool
+is_callback_chain (SCM s)
+{
+ return (SCM_NIMP (s) && SCM_CELL_TYPE (s) == chain_tag);
+}
+
+SCM
+callback_chain_extract_procedures (SCM chain_smob)
+{
+ assert (is_callback_chain (chain_smob));
+ return (SCM) SCM_CELL_WORD_1(chain_smob);
+}
+
+LY_DEFINE(ly_callback_chain_p, "ly:callback-chain?",
+ 1,0,0, (SCM chain),
+ "Type predicate.")
+{
+ return scm_from_bool (is_callback_chain (chain));
+}
+
+LY_DEFINE(ly_make_callback_chain, "ly:make-callback-chain",
+ 0, 0, 1, (SCM procedures),
+ "Make a grob callback chain. @var{procedures} should be a "
+ "list of procedures taking 2 arguments.")
+{
+ SCM z;
+
+ for (SCM s = procedures;
+ scm_is_pair (s); s = scm_cdr (s))
+ {
+ SCM proc = scm_car (s);
+ if (!ly_is_procedure (proc))
+ {
+ scm_misc_error ("Must be a procedure: ~a",
+ "ly:make-callback-chain",
+ proc);
+ }
+
+ if (procedure_arity (proc) != 2)
+ {
+ scm_misc_error ("Procedure should take 2 arguments: ~a",
+ "ly:make-callback-chain",
+ proc);
+ }
+ }
+
+ SCM_NEWSMOB(z, chain_tag, procedures);
+ return z;
+}
+
+int
+print_callback_chain (SCM s, SCM port, scm_print_state *)
+{
+ scm_puts ("#<callback-chain ", port);
+ scm_display (scm_cdr (s), port);
+ scm_puts (" >", port);
+ return 1;
+}
+
+
+void init_chained_callback ()
+{
+ chain_tag = scm_make_smob_type ("callback-chain", 0);
+ scm_set_smob_mark (chain_tag, scm_markcdr);
+ scm_set_smob_print (chain_tag, print_callback_chain);
+};
+
+
+
+ADD_SCM_INIT_FUNC(chain, init_chained_callback);
diff --git a/lily/context-property.cc b/lily/context-property.cc
index 2fc887300d..45dccdc05c 100644
--- a/lily/context-property.cc
+++ b/lily/context-property.cc
@@ -136,9 +136,10 @@ execute_general_pushpop_property (Context *context,
bool ok = true;
if (!scm_is_pair (scm_cdr (grob_property_path)))
{
- ok = !ly_is_procedure (new_value)
- && type_check_assignment (symbol, new_value,
- ly_symbol2scm ("backend-type?"));
+ if (!ly_is_procedure (new_value)
+ && !is_callback_chain (new_value))
+ ok = type_check_assignment (symbol, new_value,
+ ly_symbol2scm ("backend-type?"));
/*
tack onto alist. We can use set_car, since
diff --git a/lily/grob-property.cc b/lily/grob-property.cc
index 3c8a07db5c..e1d0446d7f 100644
--- a/lily/grob-property.cc
+++ b/lily/grob-property.cc
@@ -100,7 +100,7 @@ SCM
Grob::internal_get_property (SCM sym) const
{
SCM val = get_property_data (sym);
- if (ly_is_procedure (val))
+ if (ly_is_procedure (val) || is_callback_chain (val))
{
val = ((Grob*)this)->try_callback (sym, val);
}
@@ -129,7 +129,21 @@ Grob::try_callback (SCM sym, SCM proc)
if (debug_property_callbacks)
grob_property_callback_stack = scm_acons (sym, proc, grob_property_callback_stack);
#endif
- SCM value = scm_call_1 (proc, self_scm ());
+
+ SCM value = SCM_EOL;
+ if (ly_is_procedure (proc))
+ value = scm_call_1 (proc, self_scm ());
+ else if (is_callback_chain (proc))
+ {
+ for (SCM s = callback_chain_extract_procedures (proc);
+ scm_is_pair (s); s = scm_cdr (s))
+ {
+ value = scm_call_2 (scm_car (s), self_scm (), value);
+ }
+ }
+ else
+ assert (false);
+
#ifndef NDEBUG
if (debug_property_callbacks)
grob_property_callback_stack = scm_cdr (grob_property_callback_stack);
diff --git a/lily/include/beam.hh b/lily/include/beam.hh
index d688cacd36..83e2c591f7 100644
--- a/lily/include/beam.hh
+++ b/lily/include/beam.hh
@@ -59,14 +59,16 @@ public:
DECLARE_SCHEME_CALLBACK (print, (SCM));
DECLARE_SCHEME_CALLBACK (calc_direction, (SCM));
DECLARE_SCHEME_CALLBACK (calc_positions, (SCM));
- DECLARE_SCHEME_CALLBACK (calc_least_squares_dy, (SCM));
+ DECLARE_SCHEME_CALLBACK (calc_least_squares_positions, (SCM, SCM));
DECLARE_SCHEME_CALLBACK (calc_concaveness, (SCM));
/* position callbacks */
- DECLARE_SCHEME_CALLBACK (slope_damping, (SCM));
- DECLARE_SCHEME_CALLBACK (shift_region_to_valid, (SCM));
- DECLARE_SCHEME_CALLBACK (quanting, (SCM));
- static Real score_slopes_dy (Real, Real, Real, Real, Real, bool, Beam_quant_parameters const *);
+ DECLARE_SCHEME_CALLBACK (shift_region_to_valid, (SCM, SCM));
+ DECLARE_SCHEME_CALLBACK (slope_damping, (SCM, SCM));
+ DECLARE_SCHEME_CALLBACK (quanting, (SCM, SCM));
+ DECLARE_SCHEME_CALLBACK (set_stem_lengths, (SCM,SCM));
+
+static Real score_slopes_dy (Real, Real, Real, Real, Real, bool, Beam_quant_parameters const *);
static Real score_stem_lengths (Link_array<Grob> const &stems,
Array<Stem_info> const &stem_infos,
@@ -89,7 +91,6 @@ private:
static Real calc_stem_y (Grob *, Grob *s, Grob **c,
Real, Real,
Drul_array<Real> pos, bool french);
- static void set_stem_lengths (Grob *);
static int forced_stem_count (Grob *);
};
diff --git a/lily/include/grob.hh b/lily/include/grob.hh
index 6c08afeeec..211bf08d39 100644
--- a/lily/include/grob.hh
+++ b/lily/include/grob.hh
@@ -139,4 +139,7 @@ SCM ly_grobs2scm (Link_array<Grob> a);
Interval robust_relative_extent (Grob *, Grob *, Axis);
+bool is_callback_chain (SCM s);
+SCM callback_chain_extract_procedures (SCM chain_smob);
+
#endif /* GROB_HH */
diff --git a/lily/include/lily-guile.hh b/lily/include/lily-guile.hh
index 920f9968b9..93469b18a9 100644
--- a/lily/include/lily-guile.hh
+++ b/lily/include/lily-guile.hh
@@ -77,6 +77,8 @@ SCM alist_to_hashq (SCM);
SCM ly_alist_vals (SCM alist);
SCM ly_hash2alist (SCM tab);
+int procedure_arity (SCM);
+
/* inserts at front, removing dublicates */
inline SCM ly_assoc_front_x (SCM alist, SCM key, SCM val)
{
diff --git a/lily/lily-guile.cc b/lily/lily-guile.cc
index 681d1762c0..bbc3fa5b14 100644
--- a/lily/lily-guile.cc
+++ b/lily/lily-guile.cc
@@ -465,7 +465,7 @@ type_check_assignment (SCM sym, SCM val, SCM type_symbol)
SCM typefunc = ly_lily_module_constant ("type-name");
SCM type_name = scm_call_1 (typefunc, type);
- message (_f ("type check for `%s' failed; value `%s' must be of type `%s'",
+ warning (_f ("type check for `%s' failed; value `%s' must be of type `%s'",
ly_symbol2string (sym).to_str0 (),
print_scm_val (val),
ly_scm2string (type_name).to_str0 ()));
@@ -706,3 +706,13 @@ ly_hash2alist (SCM tab)
return scm_call_1 (func, tab);
}
+int
+procedure_arity (SCM proc)
+{
+ assert (ly_is_procedure (proc));
+ SCM arity = scm_procedure_property (proc,
+ ly_symbol2scm ("arity"));
+
+ SCM fixed = scm_car (arity);
+ return scm_to_int (fixed);
+}
diff --git a/ly/spanners-init.ly b/ly/spanners-init.ly
index 2a0ee17aef..56d0272bd5 100644
--- a/ly/spanners-init.ly
+++ b/ly/spanners-init.ly
@@ -96,13 +96,13 @@ sostenutoUp = #(make-span-event 'SostenutoEvent STOP)
% for regression testing purposes.
assertBeamQuant =
#(def-music-function (parser location l r) (pair? pair?)
- (make-grob-property-override 'Beam 'position-callbacks
- (check-quant-callbacks l r)))
+ (make-grob-property-override 'Beam 'positions
+ (apply ly:make-callback-chain (check-quant-callbacks l r))))
% for regression testing purposes.
assertBeamSlope =
#(def-music-function (parser location comp) (procedure?)
- (make-grob-property-override 'Beam 'position-callbacks
- (check-slope-callbacks comp)))
+ (make-grob-property-override 'Beam 'positions
+ (apply ly:make-callback-chain (check-slope-callbacks comp))))
diff --git a/scm/define-grob-properties.scm b/scm/define-grob-properties.scm
index aa88de25b1..2eb918263c 100644
--- a/scm/define-grob-properties.scm
+++ b/scm/define-grob-properties.scm
@@ -549,9 +549,6 @@ debugging")
(stem-info ,pair? "caching of stem parameters")
(note-columns ,pair? "list of NoteColumn grobs.")
- (position-callbacks ,list? "list of
-functions set spanner positions.")
-
;;; add-join would be enough if in Mensural_ligature::brew_ligature_primitive
;;; the next note could be seen
(join-right-amount ,number? "")
diff --git a/scm/define-grobs.scm b/scm/define-grobs.scm
index 189d9bdf9c..314c1e4921 100644
--- a/scm/define-grobs.scm
+++ b/scm/define-grobs.scm
@@ -285,16 +285,17 @@
;; todo: clean this up a bit: the list is getting
;; rather long.
(gap . 0.8)
-
- (position-callbacks . (,Beam::slope_damping
- ,Beam::shift_region_to_valid
- ,Beam::quanting))
- (least-squares-dy . ,Beam::calc_least_squares_dy)
+
+ (positions . ,(ly:make-callback-chain
+ Beam::calc_least_squares_positions
+ Beam::slope_damping
+ Beam::shift_region_to_valid
+ Beam::quanting
+ Beam::set_stem_lengths
+ ))
(concaveness . ,Beam::calc_concaveness)
- (positions . ,Beam::calc_positions)
(direction . ,Beam::calc_direction)
(stencil . ,Beam::print)
-
;; TODO: should be in SLT.
(thickness . 0.48) ; in staff-space
diff --git a/scm/layout-beam.scm b/scm/layout-beam.scm
index 29a7405223..051cc5f2af 100644
--- a/scm/layout-beam.scm
+++ b/scm/layout-beam.scm
@@ -6,13 +6,12 @@
;;;; (c) 2000--2005 Jan Nieuwenhuizen <janneke@gnu.org>
;;;;
-(define ((check-beam-quant posl posr) beam)
+(define ((check-beam-quant posl posr) beam posns)
"Check whether BEAM has POSL and POSR quants. POSL are (POSITION
. QUANT) pairs, where QUANT is -1 (hang), 0 (center), 1 (sit) or -2/ 2 (inter)
"
- (let* ((posns (ly:grob-property beam 'positions))
- (thick (ly:grob-property beam 'thickness))
+ (let* ((thick (ly:grob-property beam 'thickness))
(layout (ly:grob-layout beam))
(lthick (ly:output-def-lookup layout 'linethickness))
(staff-thick lthick) ; fixme.
@@ -31,12 +30,14 @@
want-l want-r posns)
(set! (ly:grob-property beam 'quant-score)
(format "(~S,~S)" want-l want-r)))
- (set! (ly:grob-property beam 'quant-score) ""))))
+ (set! (ly:grob-property beam 'quant-score) ""))
-(define ((check-beam-slope-sign comparison) beam)
+ posns
+ ))
+
+(define ((check-beam-slope-sign comparison) beam posns)
"Check whether the slope of BEAM is correct wrt. COMPARISON."
- (let* ((posns (ly:grob-property beam 'positions))
- (slope-sign (- (cdr posns) (car posns)))
+ (let* ((slope-sign (- (cdr posns) (car posns)))
(correct (comparison slope-sign 0)))
(if (not correct)
@@ -45,22 +46,27 @@
(procedure-name comparison) "0" slope-sign)
(set! (ly:grob-property beam 'quant-score)
(format "~S 0" (procedure-name comparison))))
- (set! (ly:grob-property beam 'quant-score) ""))))
+
+ (set! (ly:grob-property beam 'quant-score) ""))
+ posns))
+
(define-public (check-quant-callbacks l r)
- (list Beam::least_squares
- Beam::check_concave
+ (list Beam::calc_least_squares_positions
Beam::slope_damping
Beam::shift_region_to_valid
Beam::quanting
- (check-beam-quant l r)))
+ Beam::set_stem_lengths
+ (check-beam-quant l r)
+ ))
+
(define-public (check-slope-callbacks comparison)
- (list Beam::least_squares
- Beam::check_concave
+ (list Beam::calc_least_squares_positions
Beam::slope_damping
Beam::shift_region_to_valid
Beam::quanting
- (check-beam-slope-sign comparison)))
-
+ Beam::set_stem_lengths
+ (check-beam-slope-sign comparison)
+ ))
diff --git a/scm/lily.scm b/scm/lily.scm
index 197936b3e4..5b6912420a 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -281,6 +281,7 @@ The syntax is the same as `define*-public'."
(,ly:pitch? . "pitch")
(,ly:translator? . "translator")
(,ly:font-metric? . "font metric")
+ (,ly:callback-chain? . "callback chain")
(,markup-list? . "list of markups")
(,markup? . "markup")
(,ly:music-list? . "list of music")