From 087a4bf794b39cbfd99eb032183101013386f475 Mon Sep 17 00:00:00 2001 From: Han-Wen Nienhuys Date: Mon, 31 Oct 2005 15:38:55 +0000 Subject: [PATCH] * 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. --- ChangeLog | 36 ++++ input/regression/beam-quant-standard.ly | 218 ++++++++++++------------ lily/beam-concave.cc | 12 +- lily/beam-quanting.cc | 23 +-- lily/beam.cc | 79 ++++----- lily/chained-callback.cc | 83 +++++++++ lily/context-property.cc | 7 +- lily/grob-property.cc | 18 +- lily/include/beam.hh | 13 +- lily/include/grob.hh | 3 + lily/include/lily-guile.hh | 2 + lily/lily-guile.cc | 12 +- ly/spanners-init.ly | 8 +- scm/define-grob-properties.scm | 3 - scm/define-grobs.scm | 15 +- scm/layout-beam.scm | 36 ++-- scm/lily.scm | 1 + 17 files changed, 362 insertions(+), 207 deletions(-) create mode 100644 lily/chained-callback.cc diff --git a/ChangeLog b/ChangeLog index ad9c7d89e2..a21300fa51 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,39 @@ +2005-10-31 Han-Wen Nienhuys + + * 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 * 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 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 (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 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 (qscores[best_idx].yl, - qscores[best_idx].yr))); + { + final_positions = Drul_array (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 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 pos = ly_scm2interval (me->get_property ("positions")); + Drul_array 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 (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 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 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 pos = ly_scm2realdrul (me->get_property ("positions")); + Drul_array 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 + +*/ + +#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 ("#", 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 const &stems, Array const &stem_infos, @@ -89,7 +91,6 @@ private: static Real calc_stem_y (Grob *, Grob *s, Grob **c, Real, Real, Drul_array 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 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 ;;;; -(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") -- 2.39.2