Hi Paul,
On Thu, Aug 20, 2015 at 9:26 PM, Paul Morris <p...@paulwmorris.com> wrote:
> Hi David,
>
> > On Aug 19, 2015, at 10:27 PM, David Nalesnik <david.nales...@gmail.com>
> wrote:
> >
> > Thanks for doing this! (I should have thought to write it this way in
> the first place!)
>
> Glad to! Thanks for leading the way on how to convert these C++ functions
> to Scheme.
>
> > By the way, later in the thread I posted a correction of the version
> you're commenting, which makes the spacing of naturals tally with the
> original. There's a parens error: should be an extra parens in line 136 to
> close the inner loop and one fewer in line 191. (I also moved a variable
> into a named let, but that's just cosmetic.)
>
> Got it. I’ve attached a new version that fixes this.
>
> > By the way, I've also recoded hairpin::print in Scheme, and I'm
> attaching that to this email in case you're interested. Hairpins are
> another popular candidate for customizations and this should make it
> easier--changing the size of the circled-tip, some sort of "shorten-pair,"
> easy addition of circles to Ferneyhough hairpins, etc.
>
> Thanks for this!
You're welcome. Just for kicks, I've attached a .cc file which you could
drop into the lily subdirectory and build. It makes Line_interface::line
available to Scheme. You'd just need to replace the two instances in the
hairpin function with calls to ly:line-interface:line. So, lines 405-10
become
(set! mol (ly:line-interface::line grob x starth width
endh))
(set! mol
(ly:stencil-add
mol
(ly:line-interface::line grob x (- starth) width (-
endh))))
This enables drawing of the different line styles (dashed, zigzag, etc),
based on overrides of Hairpin. AFAICT this makes the Scheme stencil
callback have all the same functionality as the C++ original. So
\override Hairpin.style = #'zigzag
will work.
You can also override dash-definition, and the like.
(I will put this new line function forward as a patch for review when the
system is over the upcoming bump.)
> Seeing how you’ve done these is giving me some confidence that I might be
> able to do the same for the ledger line print function.
>
I looked at this briefly, enough to see that it will be more involved!
You'll need to track down the data structures used there and see if there's
a convenient Scheme alternative But pretty complicated things are
possible--see the Scheme rewrite of the ambitus engraver in the snippets.
>
> I made a “commented c++” version of your hairpin code. This time I used
> somewhat larger blocks of code which works better than line by line. I
> ended up also redoing the key signature file that way while I was at it —
> and made the paren correction. Both attached.
>
Thanks! The larger blocks of code are a good idea, especially when the
translation becomes less line-for-line. (I kept pretty literal in my
adaptation, though.)
I found an error in the hairpin code rewrite--we need to exit the entire
function when a bad grow-direction is found, so everything after line 44
needs to be a clause of the if-structure beginning in 41. Simple removal
of the parenthesis in 44 and addition of one at the end fixes this. I went
ahead and attached the correction with the indentation redone. In this
connection, I'm noticing is that it's easy to get very nested structures in
Scheme when the C++ original exits at a number of points through returns.
Maybe there's an easy way to avoid this but I don't know of it.
Best,
David
\version "2.19.23"
#(define broken-right-neighbor
(lambda (grob)
(let* ((pieces (ly:spanner-broken-into (ly:grob-original grob)))
(me-list (member grob pieces)))
(if (> (length me-list) 1)
(cadr me-list)
'()))))
#(define (interval-dir-set i val dir)
(cond ((= dir LEFT) (set-car! i val))
((= dir RIGHT) (set-cdr! i val))
(else (ly:error "dir must be LEFT or RIGHT"))))
#(define (other-dir dir) (- dir))
%{
;; C++ is from lily/hairpin.cc
;;
;; MAKE_SCHEME_CALLBACK (Hairpin, print, 1);
;; SCM
;; Hairpin::print (SCM smob)
;; {
;; Spanner *me = unsmob<Spanner> (smob);
%}
#(define hairpin::print-scheme
(lambda (grob)
;; SCM s = me->get_property ("grow-direction");
(let ((grow-dir (ly:grob-property grob 'grow-direction)))
;; if (!is_direction (s))
;; {
;; me->suicide ();
;; return SCM_EOL;
;; }
(if (not (ly:dir? grow-dir))
(begin
(ly:grob-suicide! grob)
'())
;; Direction grow_dir = to_dir (s);
;; Real padding = robust_scm2double (me->get_property ("bound-padding"), 0.5);
;;
;; Drul_array<bool> broken;
;; Drul_array<Item *> bounds;
;; for (LEFT_and_RIGHT (d))
;; {
;; bounds[d] = me->get_bound (d);
;; broken[d] = bounds[d]->break_status_dir () != CENTER;
;; }
(let* ((padding (ly:grob-property grob 'bound-padding 0.5))
(bounds (cons (ly:spanner-bound grob LEFT)
(ly:spanner-bound grob RIGHT)))
(broken (cons
(not (= (ly:item-break-dir (car bounds)) CENTER))
(not (= (ly:item-break-dir (cdr bounds)) CENTER)))))
;; if (broken[RIGHT])
;; {
;; Spanner *next = me->broken_neighbor (RIGHT);
;; // Hairpin-parts suicide in after-line-breaking if they need not be drawn
;; if (next)
;; {
;; (void) next->get_property ("after-line-breaking");
;; broken[RIGHT] = next->is_live ();
;; }
;; else
;; broken[RIGHT] = false;
;; }
(if (cdr broken)
(let ((next (broken-right-neighbor grob)))
(if (ly:spanner? next)
(begin
(ly:grob-property next 'after-line-breaking)
(set-cdr! broken (grob::is-live? next)))
(set-cdr! broken #f))))
;; Grob *common = bounds[LEFT]->common_refpoint (bounds[RIGHT], X_AXIS);
;; Drul_array<Real> x_points;
;;
;; /*
;; Use the height and thickness of the hairpin when making a circled tip
;; */
;; bool circled_tip = ly_scm2bool (me->get_property ("circled-tip"));
;; Real height = robust_scm2double (me->get_property ("height"), 0.2)
;; * Staff_symbol_referencer::staff_space (me);
;; /*
;; FIXME: 0.525 is still just a guess...
;; */
;; Real rad = height * 0.525;
;; Real thick = 1.0;
;; if (circled_tip)
;; thick = robust_scm2double (me->get_property ("thickness"), 1.0)
;; * Staff_symbol_referencer::line_thickness (me);
(let* ((common
(ly:grob-common-refpoint (car bounds) (cdr bounds) X))
(x-points (cons 0 0))
(circled-tip (ly:grob-property grob 'circled-tip))
(height (* (ly:grob-property grob 'height 0.2)
(ly:staff-symbol-staff-space grob)))
(rad (* 0.525 height))
; commented out is directly from C++, but it leads to thick lines when
; no circled tip!
;(thick 1.0)
;(thick (if circled-tip
;(* (ly:grob-property grob 'thickness 1.0)
;(ly:staff-symbol-line-thickness grob))
;thick))
(thick (* (ly:grob-property grob 'thickness 1.0)
(ly:staff-symbol-line-thickness grob))))
;; for (LEFT_and_RIGHT (d))
;; {
;; Item *b = bounds[d];
;; Interval e = Axis_group_interface::generic_bound_extent (b, common, X_AXIS);
;;
;; x_points[d] = b->relative_coordinate (common, X_AXIS);
(define (inner dir)
(let* ((b (interval-bound bounds dir))
(e (ly:generic-bound-extent b common))) ; X-AXIS assumed
(interval-dir-set
x-points (ly:grob-relative-coordinate b common X) dir)
;; if (broken [d])
;; {
;; if (d == LEFT)
;; x_points[d] = e[-d];
(if (interval-bound broken dir)
(if (= dir LEFT)
(interval-dir-set
x-points (interval-bound e (other-dir dir)) dir)
;; else
;; {
;; Real broken_bound_padding
;; = robust_scm2double (me->get_property ("broken-bound-padding"), 0.0);
;; extract_grob_set (me, "concurrent-hairpins", chp);
(let* ((broken-bound-padding
(ly:grob-property grob 'broken-bound-padding 0.0))
(chp (ly:grob-object grob 'concurrent-hairpins)))
;; for (vsize i = 0; i < chp.size (); i++)
;; {
;; Spanner *span_elt = dynamic_cast<Spanner *> (chp[i]);
;; if (span_elt->get_bound (RIGHT)->break_status_dir () == LEFT)
;; broken_bound_padding = max (broken_bound_padding,
;; robust_scm2double (span_elt->get_property ("broken-bound-padding"), 0.0));
;; }
(let loop ((i 0))
(if (and (ly:grob-array? chp) ; hmm...why no test in C++ needed?
(< i (ly:grob-array-length chp)))
(let ((span-elt (ly:grob-array-ref chp i)))
(if (= (ly:item-break-dir (ly:spanner-bound span-elt RIGHT))
LEFT)
(set! broken-bound-padding
(max broken-bound-padding
(ly:grob-property span-elt 'broken-bound-padding 0.0))))
(loop (1+ i)))))
;; x_points[d] -= d * broken_bound_padding;
;; }
;; }
(interval-dir-set
x-points
(- (interval-bound x-points dir)
(* dir broken-bound-padding))
dir)))
;; else
;; {
;; if (Text_interface::has_interface (b))
;; {
;; if (!e.is_empty ())
;; x_points[d] = e[-d] - d * padding;
;; }
(if (grob::has-interface b 'text-interface)
(if (not (interval-empty? e))
(interval-dir-set x-points
(- (interval-bound e (other-dir dir))
(* dir padding))
dir))
;; else
;; {
;; bool neighbor_found = false;
;; Spanner *adjacent = NULL;
;; extract_grob_set (me, "adjacent-spanners", neighbors);
(let* ((neighbor-found #f)
(adjacent '()) ; spanner
(neighbors (ly:grob-object grob 'adjacent-spanners))
(neighbors-len (if (ly:grob-array? neighbors)
(ly:grob-array-length neighbors)
0))) ; this shouldn't be necessary -- see comment above
;; for (vsize i = 0; i < neighbors.size (); i++)
;; {
;; /*
;; FIXME: this will f*ck up in case of polyphonic
;; notes in other voices. Need to look at note-columns
;; in the current staff/voice.
;; */
;; adjacent = dynamic_cast<Spanner *> (neighbors[i]);
;; if (adjacent
;; && (adjacent->get_bound (-d)->get_column ()
;; == b->get_column ()))
;; {
;; neighbor_found = true;
;; break;
;; }
;; }
(let inner-two ((i 0))
(if (and (< i neighbors-len)
(not neighbor-found))
(begin
(set! adjacent (ly:grob-array-ref neighbors i))
(if (and (ly:spanner? adjacent)
(eq? (ly:item-get-column (ly:spanner-bound adjacent (other-dir dir)))
(ly:item-get-column b)))
(set! neighbor-found #t))
(inner-two (1+ i)))))
;; if (neighbor_found)
;; {
;; if (Hairpin::has_interface (adjacent))
;; {
;; /*
;; Handle back-to-back hairpins with a circle in the middle
;; */
;; if (circled_tip && (grow_dir != d))
;; x_points[d] = e.center () + d * (rad - thick / 2.0);
;; /*
;; If we're hung on a paper column, that means we're not
;; adjacent to a text-dynamic, and we may move closer. We
;; make the padding a little smaller, here.
;; */
;; else
;; x_points[d] = e.center () - d * padding / 3;
;; }
;; // Our neighbor is a dynamic text spanner.
;; // If we end on the text, pad as for text dynamics
;; else if (d == RIGHT)
;; x_points[d] = e[-d] - d * padding;
;; }
(if neighbor-found
(if (grob::has-interface adjacent 'hairpin-interface)
(if (and circled-tip (not (eq? grow-dir dir)))
(interval-dir-set x-points
(+ (interval-center e)
(* dir
(- rad (/ thick 2.0))))
dir)
(interval-dir-set x-points
(- (interval-center e)
(/ (* dir padding) 3.0))
dir))
(if (= dir RIGHT)
(interval-dir-set x-points
(- (interval-bound e (other-dir dir))
(* dir padding))
dir)))
;; else
;; {
;; if (d == RIGHT // end at the left edge of a rest
;; && Note_column::has_interface (b)
;; && Note_column::has_rests (b))
;; x_points[d] = e[-d];
;; else
;; x_points[d] = e[d];
(begin
(if (and (= dir RIGHT)
(grob::has-interface b 'note-column-interface)
(ly:grob-array? (ly:grob-object b 'rest)))
(interval-dir-set x-points
(interval-bound e (other-dir dir))
dir)
(interval-dir-set x-points
(interval-bound e dir)
dir))
;; if (Item::is_non_musical (b))
;; x_points[d] -= d * padding;
;; }
;; }
;; }
;; }
(if (eq? (ly:grob-property b 'non-musical) #t)
(interval-dir-set x-points
(- (interval-bound x-points dir)
(* dir padding))
dir)))))))))
(inner LEFT)
(inner RIGHT)
;; Real width = x_points[RIGHT] - x_points[LEFT];
;;
;; if (width < 0)
;; {
;; me->warning (_ ((grow_dir < 0) ? "decrescendo too small"
;; : "crescendo too small"));
;; width = 0;
;; }
(let* ((width (- (interval-bound x-points RIGHT)
(interval-bound x-points LEFT)))
(width (if (< width 0)
(begin
(ly:warning
(if (< grow-dir 0)
"decrescendo too small"
"crescendo too small"))
0)
width))
;; bool continued = broken[Direction (-grow_dir)];
;; bool continuing = broken[Direction (grow_dir)];
(continued (interval-bound broken (other-dir grow-dir)))
(continuing (interval-bound broken grow-dir))
;; Real starth = 0;
;; Real endh = 0;
;; if (grow_dir < 0)
;; {
;; starth = continuing ? 2 * height / 3 : height;
;; endh = continued ? height / 3 : 0.0;
;; }
;; else
;; {
;; starth = continued ? height / 3 : 0.0;
;; endh = continuing ? 2 * height / 3 : height;
;; }
(starth (if (< grow-dir 0)
(if continuing
(* 2 (/ height 3))
height)
(if continued
(/ height 3)
0.0)))
(endh (if (< grow-dir 0)
(if continued
(/ height 3)
0.0)
(if continuing
(* 2 (/ height 3))
height)))
;; /*
;; should do relative to staff-symbol staff-space?
;; */
;; Stencil mol;
;; Real x = 0.0;
;;
;; /*
;; Compensate for size of circle
;; */
;; Direction tip_dir = -grow_dir;
(mol empty-stencil)
(x 0.0)
(tip-dir (other-dir grow-dir)))
;; if (circled_tip && !broken[tip_dir])
;; {
;; if (grow_dir > 0)
;; x = rad * 2.0;
;; else if (grow_dir < 0)
;; width -= rad * 2.0;
;; }
(if (and circled-tip
(not (interval-bound broken tip-dir)))
(if (> grow-dir 0)
(set! x (* rad 2.0))
(if (< grow-dir 0)
(set! width (- width (* rad 2.0))))))
;; mol = Line_interface::line (me, Offset (x, starth), Offset (width, endh));
;; mol.add_stencil (Line_interface::line (me,
;; Offset (x, -starth),
;; Offset (width, -endh)));
(set! mol (make-line-stencil thick x starth width endh))
(set! mol
(ly:stencil-add
mol
(make-line-stencil thick x (- starth) width (- endh))))
;; /*
;; Support al/del niente notation by putting a circle at the
;; tip of the (de)crescendo.
;; */
;; if (circled_tip)
;; {
;; Box extent (Interval (-rad, rad), Interval (-rad, rad));
;;
;; /* Hmmm, perhaps we should have a Lookup::circle () method? */
;; Stencil circle (extent,
;; scm_list_4 (ly_symbol2scm ("circle"),
;; scm_from_double (rad),
;; scm_from_double (thick),
;; SCM_BOOL_F));
(if circled-tip
(let ((circle (make-circle-stencil rad thick #f)))
;; /*
;; don't add another circle if the hairpin is broken
;; */
;; if (!broken[tip_dir])
;; mol.add_at_edge (X_AXIS, tip_dir, Stencil (circle), 0);
;; }
(if (not (interval-bound broken tip-dir))
(set! mol
(ly:stencil-combine-at-edge mol X tip-dir circle 0)))))
;; mol.translate_axis (x_points[LEFT]
;; - bounds[LEFT]->relative_coordinate (common, X_AXIS),
;; X_AXIS);
;; return mol.smobbed_copy ();
;; }
(set! mol
(ly:stencil-translate-axis mol
(- (interval-bound x-points LEFT)
(ly:grob-relative-coordinate (interval-bound bounds LEFT) common X))
X))
mol)))))))
music =
{
c'1\<
c'2\! c'2~\>
c'2~ c'2\!
c'2\> c'2\< c'1
c''1\<
c''4 a' c''\< a'
c''4 a' c''\! a'\<
c''4 a' c'' a'\!
c''1~\<
c''1~
\break
c''1\!
c'1\!\<
\break
c'1
\break
c'2 c'2\!
c''1\<
c''4 a' c''\mf a'
c''1\<
c''4 a' c''\ffff a'
c''4\< c''\! d''\> e''\!
<<
f''1
{ s4 s4\< s4\> s4\! }
>>
\override Hairpin.to-barline = ##f
c''1\<
c''1\!
}
\markup \huge \bold "DEFAULT"
{
\music
\override Hairpin.circled-tip = ##t
\music
}
\markup \huge \bold "SCHEME REWRITE"
{
\override Hairpin.stencil = #hairpin::print-scheme
\music
\override Hairpin.circled-tip = ##t
\music
}
\layout {
ragged-right = ##t
}/*
This file is part of LilyPond, the GNU music typesetter.
Copyright (C) 2010--2015 Han-Wen Nienhuys <han...@xs4all.nl>
LilyPond is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
LilyPond is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
*/
#include "line-interface.hh"
#include "stencil.hh"
#include "grob.hh"
LY_DEFINE (ly_line_interface__line, "ly:line-interface::line",
5, 0, 0, (SCM grob, SCM startx, SCM starty, SCM endx, SCM endy),
"Make a line using layout information from grob @var{grob}.")
{
LY_ASSERT_SMOB (Grob, grob, 1);
Grob *me = unsmob<Grob> (grob);
LY_ASSERT_TYPE (scm_is_number, startx, 2);
LY_ASSERT_TYPE (scm_is_number, starty, 3);
LY_ASSERT_TYPE (scm_is_number, endx, 4);
LY_ASSERT_TYPE (scm_is_number, endy, 5);
Offset from = Offset (scm_to_double (startx), scm_to_double (starty));
Offset to = Offset (scm_to_double (endx), scm_to_double (endy));
Stencil stil = Line_interface::line (me, from, to);
return stil.smobbed_copy ();
}
_______________________________________________
lilypond-user mailing list
lilypond-user@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-user
