+2005-10-09 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * scm/parser-ly-from-scheme.scm: rename from ly-from-scheme.scm
+
+ * scm/parser-clef.scm (supported-clefs): rename from clef.scm
+
+ * scm/layout-slur.scm: rename from slur.scm
+
+ * scm/layout-page-layout.scm: rename from page-layout.scm
+
+ * scm/layout-beam.scm: rename from beam.scm
+
+ * scm/define-grob-interfaces.scm (bass-figure-interface): add
+ bass-figure-interface
+
+ * lily/new-figured-bass-engraver.cc (process_music): add
+ implicitBassFigures property.
+
+ * scm/define-markup-commands.scm (pad-x): new markup.
+
+ * ly/engraver-init.ly (AncientRemoveEmptyStaffContext): set
+ minimumVerticalExtent on FiguredBass context.
+
+ * lily/figured-bass-continuation.cc (center_on_figures): kludge in
+ case the continuation crosses a line break.
+
2005-10-09 Jan Nieuwenhuizen <janneke@gnu.org>
* flower/file-name.cc (dos_to_posix)[__CYGWIN__]: Return
2005-10-07 Han-Wen Nienhuys <hanwen@xs4all.nl>
+ * VERSION (PACKAGE_NAME): release 2.7.12
+
* input/regression/figured-bass-continuation-center.ly: new file.
* input/regression/beam-outside-beamlets.ly: new file.
PACKAGE_NAME=LilyPond
MAJOR_VERSION=2
MINOR_VERSION=7
-PATCH_LEVEL=12
+PATCH_LEVEL=13
MY_PATCH_LEVEL=
--- /dev/null
+
+\header
+{
+
+ texidoc = "Implicit bass figures are not printed, but they do get extenders."
+}
+
+
+\version "2.7.13"
+\paper
+{
+ raggedright = ##t
+}
+
+<<
+ \relative c'' \new Voice {
+ c^"normal" c c c^"extenders" c c c_"implicit" c
+ }
+ \figures {
+ <3 6!>
+ <3 4+>
+ r
+ \set useBassFigureExtenders = ##t
+ <3 6!>
+ <3 4+>
+ r
+ \set useBassFigureExtenders = ##t
+ \set implicitBassFigures = #'(3)
+ <3 6!>
+ <3 4+>
+ }
+>>
+
(void) axis;
extract_grob_set (me, "figures", figures);
+ if (figures.is_empty ())
+ return scm_from_double (0.0);
Grob *common = common_refpoint_of_array (figures, me, Y_AXIS);
Interval ext = Axis_group_interface::relative_group_extent (figures, common, Y_AXIS);
-
+ if (ext.is_empty ())
+ return scm_from_double (0.0);
return scm_from_double (ext.center () - me->relative_coordinate (common, Y_AXIS));
}
X_AXIS);
do
{
+ Item *bound = me->get_bound (d);
+ Direction extdir =
+ (d == LEFT && to_boolean (bound->get_property ("implicit")))
+ ? LEFT : RIGHT;
+
spanned[d]
- = robust_relative_extent (me->get_bound (d), common, X_AXIS)[RIGHT]
+ = robust_relative_extent (bound, common, X_AXIS)[extdir]
- me->relative_coordinate (common, X_AXIS);
}
while (flip (&d) != LEFT);
if (!new_music_found_)
return ;
+
new_music_found_ = false;
/*
{
clear_spanners ();
}
-
int k = 0;
for (int i = 0; i < new_musics_.size (); i++)
Array<int> junk_continuations;
for (int i = 0; i < groups_.size(); i++)
{
- if (groups_[i].is_continuation ())
+ Figure_group &group = groups_[i];
+
+ if (group.is_continuation ())
{
- if (!groups_[i].continuation_line_)
+ if (!group.continuation_line_)
{
Spanner * line = make_spanner ("BassFigureContinuation", SCM_EOL);
- Item * item = groups_[i].figure_item_;
- groups_[i].continuation_line_ = line;
+ Item * item = group.figure_item_;
+ group.continuation_line_ = line;
line->set_bound (LEFT, item);
/*
Don't add as child. This will cache the wrong
(pre-break) stencil when callbacks are triggered.
*/
- line->set_parent (groups_[i].group_, Y_AXIS);
+ line->set_parent (group.group_, Y_AXIS);
Pointer_group_interface::add_grob (line, ly_symbol2scm ("figures"), item);
-
- groups_[i].figure_item_ = 0;
+
+ group.figure_item_ = 0;
}
}
- else if (groups_[i].continuation_line_)
+ else if (group.continuation_line_)
junk_continuations.push (i);
}
= make_item ("NewBassFigure",
group.current_music_->self_scm ());
+
SCM fig = group.current_music_->get_property ("figure");
if (!group.group_)
{
Align_interface::alignment_callback_proc);
}
+ if (scm_memq (fig, get_property ("implicitBassFigures")) != SCM_BOOL_F)
+ {
+ item->set_property ("transparent", SCM_BOOL_T);
+ item->set_property ("implicit", SCM_BOOL_T);
+ }
group.number_ = fig;
group.alteration_ = group.current_music_->get_property ("alteration");
"bass-figure-event rest-event",
/* read */
+ "implicitBassFigures "
+ "newFiguredBassFormatter "
+ "figuredBassAlterationDirection "
"useBassFigureExtenders",
/* write */
tablatureFormat = #fret-number-tablature-format
%%
- bassFigureFormatFunction = #format-bass-figure
newFiguredBassFormatter = #format-new-bass-figure
metronomeMarkFormatter = #format-metronome-markup
graceSettings = #`(
\context {
\type "Engraver_group"
- \name FiguredBass
+ \name "FiguredBass"
%% \consists "Figured_bass_engraver"
\consists "New_figured_bass_engraver"
\consists "Separating_line_group_engraver"
\consists "Hara_kiri_engraver"
\override RemoveEmptyVerticalGroup #'remove-first = ##t
+ minimumVerticalExtent = #'(-0.5 . 2.5)
}
\context {
+++ /dev/null
-;;;; bass-figure.scm -- implement Scheme output routines for TeX
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 1998--2005 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
-
-
-(ly:add-interface
- 'bass-figure-interface
- "A bass figure, including bracket"
- '())
-
-
-(define-public (format-new-bass-figure figure event context)
- (let* ((fig (ly:music-property event 'figure))
- (fig-markup (if (number? figure)
- (markup #:number (number->string figure 10))
- #f
- ))
-
- (alt (ly:music-property event 'alteration))
- (alt-markup
- (if (number? alt)
- (markup
- #:general-align Y DOWN #:smaller #:smaller
- (alteration->text-accidental-markup alt))
-
- #f))
- (alt-dir (ly:context-property context 'figuredBassAlterationDirection))
- )
-
- (if (and (not fig-markup) alt-markup)
- (begin
- (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup))
- (set! alt-markup #f)))
-
-
- ;; hmm, how to get figures centered between note, and
- ;; lone accidentals too?
-
- ;; (if (markup? fig-markup)
- ;; (set!
- ;; fig-markup (markup #:translate (cons 1.0 0)
- ;; #:hcenter fig-markup)))
-
- (if alt-markup
- (set! fig-markup
- (markup #:put-adjacent
- fig-markup X
- (if (number? alt-dir)
- alt-dir
- LEFT)
- #:pad-around 0.2 alt-markup
- )))
-
- (if (markup? fig-markup)
- fig-markup
- empty-markup)))
-
-(define-public (format-bass-figure figures context grob)
- ;; TODO: support slashed numerals here.
- (define (fig-to-markup fig-music)
- (let* ((align-accs
- (eq? #t (ly:context-property context 'alignBassFigureAccidentals)))
- (fig (ly:music-property fig-music 'figure))
- (acc (ly:music-property fig-music 'alteration))
- (acc-markup #f)
- (fig-markup
- (if (markup? fig)
- fig
- (if align-accs (make-simple-markup " ")
- (if (not (eq? acc '()))
- (make-simple-markup "")
- (make-strut-markup))))))
-
- (if (number? acc)
- (make-line-markup (list fig-markup
- (alteration->text-accidental-markup acc)))
- fig-markup)))
-
- (define (filter-brackets i figs acc)
- (cond
- ((null? figs) acc)
- (else
- (filter-brackets (1+ i) (cdr figs)
-
- (append
- (if (eq? (ly:music-property (car figs) 'bracket-start) #t)
- (list i)
- '())
- (if (eq? (ly:music-property (car figs) 'bracket-stop) #t)
- (list i)
- '())
-
- acc)))))
-
- (set! (ly:grob-property grob 'text)
- (make-bracketed-y-column-markup
- (sort (filter-brackets 0 figures '()) <)
- (map fig-to-markup figures))))
+++ /dev/null
-;;;;
-;;;; beam.scm -- Beam scheme stuff
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2000--2005 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;;
-
-;;
-;; width in staff space.
-;;
-(define (beam-flag-width-function type)
- (cond
- ((eq? type 1) 1.98)
- ((eq? type 1) 1.65) ;; FIXME: check what this should be and why
- (else 1.32)))
-
-;; There are several ways to calculate the direction of a beam
-;;
-;; * majority: number count of up or down notes
-;; * mean : mean centre distance of all notes
-;; * median : mean centre distance weighted per note
-;;
-;; [Ross] states that the majority of the notes dictates the
-;; direction (and not the mean of "center distance")
-;;
-;; But is that because it really looks better, or because he wants
-;; to provide some real simple hands-on rules?
-;;
-;; We have our doubts, so we simply provide all sensible alternatives.
-
-
-;;
-;; DOCME: what goes into this func, what comes out.
-(define (dir-compare up down)
- (sign (- up down)))
-
-;; arguments are in the form (up . down)
-(define-public (beam-dir-majority count total)
- (dir-compare (car count) (cdr count)))
-
-(define-public (beam-dir-majority-median count total)
- "First try majority. If that doesn't work, try median."
- (let ((maj (dir-compare (car count) (cdr count))))
- (if (not (= maj 0))
- maj
- (beam-dir-median count total))))
-
-(define-public (beam-dir-mean count total)
- (dir-compare (car total) (cdr total)))
-
-(define-public (beam-dir-median count total)
- (if (and (> (car count) 0)
- (> (cdr count) 0))
- (dir-compare (/ (car total) (car count)) (/ (cdr total) (cdr count)))
- (dir-compare (car count) (cdr count))))
-
-(define ((check-beam-quant posl posr) beam)
- "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))
- (layout (ly:grob-layout beam))
- (lthick (ly:output-def-lookup layout 'linethickness))
- (staff-thick lthick) ; fixme.
- (quant->coord (lambda (p q)
- (if (= 2 (abs q))
- (+ p (/ q 4.0))
- (+ p (- (* 0.5 q thick) (* 0.5 q lthick))))))
- (want-l (quant->coord (car posl) (cdr posl)))
- (want-r (quant->coord (car posr) (cdr posr)))
- (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3))))
-
- (if (or (not (almost-equal want-l (car posns)))
- (not (almost-equal want-r (cdr posns))))
- (begin
- (ly:warning (_ "Error in beam quanting. Expected (~S,~S) found ~S.")
- 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) ""))))
-
-(define ((check-beam-slope-sign comparison) beam)
- "Check whether the slope of BEAM is correct wrt. COMPARISON."
- (let* ((posns (ly:grob-property beam 'positions))
- (slope-sign (- (cdr posns) (car posns)))
- (correct (comparison slope-sign 0)))
-
- (if (not correct)
- (begin
- (ly:warning (_ "Error in beam quanting. Expected ~S 0, found ~S.")
- (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) ""))))
-
-(define-public (check-quant-callbacks l r)
- (list Beam::least_squares
- Beam::check_concave
- Beam::slope_damping
- Beam::shift_region_to_valid
- Beam::quanting
- (check-beam-quant l r)))
-
-
-(define-public (check-slope-callbacks comparison)
- (list Beam::least_squares
- Beam::check_concave
- Beam::slope_damping
- Beam::shift_region_to_valid
- Beam::quanting
- (check-beam-slope-sign comparison)))
-
+++ /dev/null
-;;;; clef.scm -- Clef settings
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2004--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
-
-
-;; (name . (glyph clef-position octavation))
-;;
-;; -- the name clefOctavation is misleading. The value 7 is 1 octave,
-;; not 7 Octaves.
-(define-public supported-clefs
- '(("treble" . ("clefs.G" -2 0))
- ("violin" . ("clefs.G" -2 0))
- ("G" . ("clefs.G" -2 0))
- ("G2" . ("clefs.G" -2 0))
- ("french" . ("clefs.G" -4 0))
- ("soprano" . ("clefs.C" -4 0))
- ("mezzosoprano" . ("clefs.C" -2 0))
- ("alto" . ("clefs.C" 0 0))
- ("C" . ("clefs.C" 0 0))
- ("tenor" . ("clefs.C" 2 0))
- ("baritone" . ("clefs.C" 4 0))
- ("varbaritone" . ("clefs.F" 0 0))
- ("bass" . ("clefs.F" 2 0))
- ("F" . ("clefs.F" 2 0))
- ("subbass" . ("clefs.F" 4 0))
- ("percussion" . ("clefs.percussion" 0 0))
- ("tab" . ("clefs.tab" 0 0))
-
- ;; should move mensural stuff to separate file?
- ("vaticana-do1" . ("clefs.vaticana.do" -1 0))
- ("vaticana-do2" . ("clefs.vaticana.do" 1 0))
- ("vaticana-do3" . ("clefs.vaticana.do" 3 0))
- ("vaticana-fa1" . ("clefs.vaticana.fa" -1 0))
- ("vaticana-fa2" . ("clefs.vaticana.fa" 1 0))
- ("medicaea-do1" . ("clefs.medicaea.do" -1 0))
- ("medicaea-do2" . ("clefs.medicaea.do" 1 0))
- ("medicaea-do3" . ("clefs.medicaea.do" 3 0))
- ("medicaea-fa1" . ("clefs.medicaea.fa" -1 0))
- ("medicaea-fa2" . ("clefs.medicaea.fa" 1 0))
- ("hufnagel-do1" . ("clefs.hufnagel.do" -1 0))
- ("hufnagel-do2" . ("clefs.hufnagel.do" 1 0))
- ("hufnagel-do3" . ("clefs.hufnagel.do" 3 0))
- ("hufnagel-fa1" . ("clefs.hufnagel.fa" -1 0))
- ("hufnagel-fa2" . ("clefs.hufnagel.fa" 1 0))
- ("hufnagel-do-fa" . ("clefs.hufnagel.do.fa" 4 0))
- ("mensural-c1" . ("clefs.mensural.c" -2 0))
- ("mensural-c2" . ("clefs.mensural.c" 0 0))
- ("mensural-c3" . ("clefs.mensural.c" 2 0))
- ("mensural-c4" . ("clefs.mensural.c" 4 0))
- ("mensural-f" . ("clefs.mensural.f" 2 0))
- ("mensural-g" . ("clefs.mensural.g" -2 0))
- ("neomensural-c1" . ("clefs.neomensural.c" -4 0))
- ("neomensural-c2" . ("clefs.neomensural.c" -2 0))
- ("neomensural-c3" . ("clefs.neomensural.c" 0 0))
- ("neomensural-c4" . ("clefs.neomensural.c" 2 0))
- ("petrucci-c1" . ("clefs.petrucci.c1" -4 0))
- ("petrucci-c2" . ("clefs.petrucci.c2" -2 0))
- ("petrucci-c3" . ("clefs.petrucci.c3" 0 0))
- ("petrucci-c4" . ("clefs.petrucci.c4" 2 0))
- ("petrucci-c5" . ("clefs.petrucci.c5" 4 0))
- ("petrucci-f" . ("clefs.petrucci.f" 2 0))
- ("petrucci-g" . ("clefs.petrucci.g" -2 0))))
-
-;; "an alist mapping GLYPHNAME to the position of the middle C for
-;; that symbol"
-(define c0-pitch-alist
- '(("clefs.G" . -4)
- ("clefs.C" . 0)
- ("clefs.F" . 4)
- ("clefs.percussion" . 0)
- ("clefs.tab" . 0 )
- ("clefs.vaticana.do" . 0)
- ("clefs.vaticana.fa" . 4)
- ("clefs.medicaea.do" . 0)
- ("clefs.medicaea.fa" . 4)
- ("clefs.hufnagel.do" . 0)
- ("clefs.hufnagel.fa" . 4)
- ("clefs.hufnagel.do.fa" . 0)
- ("clefs.mensural.c" . 0)
- ("clefs.mensural.f" . 4)
- ("clefs.mensural.g" . -4)
- ("clefs.neomensural.c" . 0)
- ("clefs.petrucci.c1" . 0)
- ("clefs.petrucci.c2" . 0)
- ("clefs.petrucci.c3" . 0)
- ("clefs.petrucci.c4" . 0)
- ("clefs.petrucci.c5" . 0)
- ("clefs.petrucci.f" . 4)
- ("clefs.petrucci.g" . -4)))
-
-(define-public (make-clef-set clef-name)
- "Generate the clef setting commands for a clef with name CLEF-NAME."
- (define (make-prop-set props)
- (let ((m (make-music 'PropertySet)))
- (map (lambda (x) (set! (ly:music-property m (car x)) (cdr x))) props)
- m))
- (let ((e '())
- (c0 0)
- (oct 0)
- (match (string-match "^(.*)([_^])([0-9]+)$" clef-name)))
- (if match
- (begin
- (set! clef-name (match:substring match 1))
- (set! oct
- (* (if (equal? (match:substring match 2) "^") -1 1)
- (- (string->number (match:substring match 3)) 1)))))
- (set! e (assoc clef-name supported-clefs))
- (if (pair? e)
- (let* ((musics (map make-prop-set
- `(((symbol . clefGlyph) (value . ,(cadr e)))
- ((symbol . middleCPosition)
- (value . ,(+ oct
- (caddr e)
- (cdr (assoc (cadr e) c0-pitch-alist)))))
- ((symbol . clefPosition) (value . ,(caddr e)))
- ((symbol . clefOctavation) (value . ,(- oct))))))
- (seq (make-music 'SequentialMusic
- 'elements musics))
- (csp (make-music 'ContextSpeccedMusic)))
- (context-spec-music seq 'Staff))
- (begin
- (ly:warning (_ "unknown clef type `~a'") clef-name)
- (ly:warning (_ "see scm/clef.scm for supported clefs"))
- (make-music 'Music)))))
-
(ignoreBarChecks ,boolean? "Ignore bar checks")
(ignoreMelismata ,boolean? "Ignore melismata for this @internalsref{Lyrics} line.")
+
+ (implicitBassFigures ,list? "List of bass figures that are not
+printed as numbers, but only as extender lines.")
+
(instr ,markup? "See @code{instrument}")
(instrument ,markup? "The name to print left of a staff. The
"A stanza number, to be put in from of a lyrics line"
'())
+(ly:add-interface
+ 'bass-figure-interface
+ "A bass figure text"
+ '(implicit))
+
;;; todo: this is not typesetting info. Move to interpretation.
(ly:add-interface
'tablature-interface
and slur ignore eachother.")
(inspect-quants ,number-pair? "If debugging is set,
set beam quant to this position, and print the respective scores.")
-
+ (implicit ,boolean? "Is this an implicit bass figure?")
(keep-inside-line ,boolean? "If set, this column cannot have
things sticking into the margin.")
(kern ,ly:dimension? "Amount of extra white space to add. For
(interval-widen x amount)
(interval-widen y amount))
))
+
+
+(def-markup-command (pad-x layout props amount arg) (number? markup?)
+
+ "Add padding @var{amount} around @var{arg} in the X-direction. "
+ (let*
+ ((m (interpret-markup layout props arg))
+ (x (ly:stencil-extent m X))
+ (y (ly:stencil-extent m Y)))
+
+
+ (ly:make-stencil (ly:stencil-expr m)
+ (interval-widen x amount)
+ y)
+ ))
+
+
(def-markup-command (put-adjacent layout props arg1 axis dir arg2) (markup? integer? ly:dir? markup?)
"Put @var{arg2} next to @var{arg1}, without moving @var{arg1}. "
(ly:stencil-combine-at-edge m1 axis dir m2 0.0 0.0)
))
+(def-markup-command (transparent layout props arg) (markup?)
+ "Make the argument transparent"
+ (let*
+ ((m (interpret-markup layout props arg))
+ (x (ly:stencil-extent m X))
+ (y (ly:stencil-extent m Y)))
+
+
+
+ (ly:make-stencil ""
+ x y)))
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; property
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /dev/null
+;;;;
+;;;; beam.scm -- Beam scheme stuff
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2000--2005 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;;
+
+;;
+;; width in staff space.
+;;
+(define (beam-flag-width-function type)
+ (cond
+ ((eq? type 1) 1.98)
+ ((eq? type 1) 1.65) ;; FIXME: check what this should be and why
+ (else 1.32)))
+
+;; There are several ways to calculate the direction of a beam
+;;
+;; * majority: number count of up or down notes
+;; * mean : mean centre distance of all notes
+;; * median : mean centre distance weighted per note
+;;
+;; [Ross] states that the majority of the notes dictates the
+;; direction (and not the mean of "center distance")
+;;
+;; But is that because it really looks better, or because he wants
+;; to provide some real simple hands-on rules?
+;;
+;; We have our doubts, so we simply provide all sensible alternatives.
+
+
+;;
+;; DOCME: what goes into this func, what comes out.
+(define (dir-compare up down)
+ (sign (- up down)))
+
+;; arguments are in the form (up . down)
+(define-public (beam-dir-majority count total)
+ (dir-compare (car count) (cdr count)))
+
+(define-public (beam-dir-majority-median count total)
+ "First try majority. If that doesn't work, try median."
+ (let ((maj (dir-compare (car count) (cdr count))))
+ (if (not (= maj 0))
+ maj
+ (beam-dir-median count total))))
+
+(define-public (beam-dir-mean count total)
+ (dir-compare (car total) (cdr total)))
+
+(define-public (beam-dir-median count total)
+ (if (and (> (car count) 0)
+ (> (cdr count) 0))
+ (dir-compare (/ (car total) (car count)) (/ (cdr total) (cdr count)))
+ (dir-compare (car count) (cdr count))))
+
+(define ((check-beam-quant posl posr) beam)
+ "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))
+ (layout (ly:grob-layout beam))
+ (lthick (ly:output-def-lookup layout 'linethickness))
+ (staff-thick lthick) ; fixme.
+ (quant->coord (lambda (p q)
+ (if (= 2 (abs q))
+ (+ p (/ q 4.0))
+ (+ p (- (* 0.5 q thick) (* 0.5 q lthick))))))
+ (want-l (quant->coord (car posl) (cdr posl)))
+ (want-r (quant->coord (car posr) (cdr posr)))
+ (almost-equal (lambda (x y) (< (abs (- x y)) 1e-3))))
+
+ (if (or (not (almost-equal want-l (car posns)))
+ (not (almost-equal want-r (cdr posns))))
+ (begin
+ (ly:warning (_ "Error in beam quanting. Expected (~S,~S) found ~S.")
+ 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) ""))))
+
+(define ((check-beam-slope-sign comparison) beam)
+ "Check whether the slope of BEAM is correct wrt. COMPARISON."
+ (let* ((posns (ly:grob-property beam 'positions))
+ (slope-sign (- (cdr posns) (car posns)))
+ (correct (comparison slope-sign 0)))
+
+ (if (not correct)
+ (begin
+ (ly:warning (_ "Error in beam quanting. Expected ~S 0, found ~S.")
+ (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) ""))))
+
+(define-public (check-quant-callbacks l r)
+ (list Beam::least_squares
+ Beam::check_concave
+ Beam::slope_damping
+ Beam::shift_region_to_valid
+ Beam::quanting
+ (check-beam-quant l r)))
+
+
+(define-public (check-slope-callbacks comparison)
+ (list Beam::least_squares
+ Beam::check_concave
+ Beam::slope_damping
+ Beam::shift_region_to_valid
+ Beam::quanting
+ (check-beam-slope-sign comparison)))
+
--- /dev/null
+;;;; page-layout.scm -- page breaking and page layout
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2004--2005 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+(use-modules (oop goops describe)
+ (oop goops))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-class <optimally-broken-page-node> ()
+ (prev #:init-value '() #:accessor node-prev #:init-keyword #:prev)
+ (page #:init-value 0 #:accessor node-page-number #:init-keyword #:pageno)
+ (force #:init-value 0 #:accessor node-force #:init-keyword #:force)
+ (penalty #:init-value 0 #:accessor node-penalty #:init-keyword #:penalty)
+ (configuration #:init-value '() #:accessor node-configuration #:init-keyword #:configuration)
+ (lines #:init-value 0 #:accessor node-lines #:init-keyword #:lines))
+
+(define-method (display (node <optimally-broken-page-node>) port)
+ (map (lambda (x) (display x port))
+ (list
+ "Page " (node-page-number node)
+ " Lines: " (node-lines node)
+ " Penalty " (node-penalty node)
+ "\n")))
+
+(define-method (node-system-numbers (node <optimally-broken-page-node>))
+ (map (lambda (ps) (ly:paper-system-property ps 'number))
+ (node-lines node)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (annotate? layout)
+ (eq? #t (ly:output-def-lookup layout 'annotatespacing)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (paper-system-staff-extents ps)
+ (ly:paper-system-property ps 'refpoint-Y-extent '(0 . 0)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ANNOTATIONS
+;;
+;; annotations are arrows indicating the numerical value of
+;; spacing variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (annotate-y-interval layout name extent is-length?)
+ ;; do something sensible for 0,0 intervals.
+ (set! extent (interval-widen extent 0.001))
+ (let*
+ ((text-props (cons
+ '((font-size . -3)
+ (font-family . typewriter))
+ (layout-extract-page-properties layout)))
+ (annotation (interpret-markup
+ layout text-props
+ (make-column-markup
+ (list
+ (make-whiteout-markup (make-simple-markup name))
+ (make-whiteout-markup
+ (make-simple-markup
+ (if is-length?
+ (format "~$" (interval-length extent))
+ (format "(~$,~$)" (car extent)
+ (cdr extent)))))))))
+ (arrows
+ (ly:stencil-translate-axis
+ (dimension-arrows (cons 0 (interval-length extent)))
+ (interval-start extent) Y)))
+
+ (set! annotation
+ (ly:stencil-aligned-to annotation Y CENTER))
+
+ (set! annotation (ly:stencil-translate annotation
+ (cons 0 (interval-center extent))))
+
+ (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0)
+ ))
+
+(define (paper-system-annotate-last system layout)
+ (let*
+ ((bottomspace (ly:paper-system-property system 'bottom-space))
+ (y-extent (paper-system-extent system Y))
+ (x-extent (paper-system-extent system X))
+ (stencil (ly:paper-system-property system 'stencil))
+
+ (arrow (if (number? bottomspace)
+ (annotate-y-interval layout
+ "bottom-space"
+ (cons (- (car y-extent) bottomspace)
+ (car y-extent))
+ #t)
+ #f)))
+
+ (if arrow
+ (set! stencil
+ (ly:stencil-add stencil arrow)))
+
+ (set! (ly:paper-system-property system 'stencil)
+ stencil)
+ ))
+
+(define (paper-system-annotate system layout)
+ "Add arrows and texts to indicate which lengths are set."
+ (let*
+ ((annotations (ly:make-stencil '() (cons 0 2) (cons 0 0)))
+ (append-stencil
+ (lambda (a b)
+ (ly:stencil-combine-at-edge a X RIGHT b 0.5 0)))
+
+ (annotate-property
+ (lambda (name extent is-length?)
+ (set! annotations
+ (append-stencil annotations
+ (annotate-y-interval layout
+ name extent is-length?)))))
+
+ (bbox-extent (paper-system-extent system Y))
+ (refp-extent (ly:paper-system-property system 'refpoint-Y-extent))
+ (next-space (ly:paper-system-property system 'next-space
+ (ly:output-def-lookup layout 'betweensystemspace)
+ ))
+ (next-padding (ly:paper-system-property system 'next-padding
+ (ly:output-def-lookup layout 'betweensystempadding)
+ ))
+
+ )
+
+ (if (number-pair? bbox-extent)
+ (begin
+ (annotate-property "Y-extent"
+ bbox-extent #f)
+ (annotate-property "next-padding"
+ (interval-translate (cons (- next-padding) 0) (car bbox-extent))
+ #t)))
+
+ ;; titles don't have a refpoint-Y-extent.
+ (if (number-pair? refp-extent)
+ (begin
+ (annotate-property "refpoint-Y-extent"
+ refp-extent #f)
+
+ (annotate-property "next-space"
+ (interval-translate (cons (- next-space) 0) (car refp-extent))
+ #t)))
+
+
+
+ (set! (ly:paper-system-property system 'stencil)
+ (ly:stencil-add
+ (ly:paper-system-property system 'stencil)
+ (ly:make-stencil
+ (ly:stencil-expr annotations)
+ (ly:stencil-extent empty-stencil X)
+ (ly:stencil-extent empty-stencil Y)
+ )))
+
+ ))
+
+(define (annotate-page layout stencil)
+ (let*
+ ((topmargin (ly:output-def-lookup layout 'topmargin))
+ (vsize (ly:output-def-lookup layout 'vsize))
+ (bottommargin (ly:output-def-lookup layout 'bottommargin))
+ (add-stencil (lambda (y)
+ (set! stencil
+ (ly:stencil-add stencil y))
+ )))
+
+ (add-stencil
+ (ly:stencil-translate-axis
+ (annotate-y-interval layout "vsize"
+ (cons (- vsize) 0)
+ #t)
+ 1 X))
+
+ (add-stencil
+ (ly:stencil-translate-axis
+ (annotate-y-interval layout "topmargin"
+ (cons (- topmargin) 0)
+ #t)
+ 2 X))
+
+ (add-stencil
+ (ly:stencil-translate-axis
+ (annotate-y-interval layout "bottommargin"
+ (cons (- vsize) (- bottommargin vsize))
+ #t)
+ 2 X))
+
+ stencil))
+
+(define (annotate-space-left page-stencil layout bottom-edge)
+ (let*
+ ((arrow (annotate-y-interval layout
+ "space left"
+ (cons (- bottom-edge) (car (ly:stencil-extent page-stencil Y)))
+ #t)))
+
+ (set! arrow (ly:stencil-translate-axis arrow 8 X))
+ (ly:stencil-add page-stencil arrow)))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define (page-headfoot layout scopes number
+ sym separation-symbol dir last?)
+ "Create a stencil including separating space."
+
+ (let* ((header-proc (ly:output-def-lookup layout sym))
+ (sep (ly:output-def-lookup layout separation-symbol))
+ (stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
+ (head-stencil
+ (if (procedure? header-proc)
+ (header-proc layout scopes number last?)
+ #f))
+ )
+
+ (if (and (number? sep)
+ (ly:stencil? head-stencil)
+ (not (ly:stencil-empty? head-stencil)))
+
+ (begin
+ (set! head-stencil
+ (ly:stencil-combine-at-edge
+ stencil Y dir head-stencil
+ sep 0.0))
+
+
+ ;; add arrow markers
+ (if (annotate? layout)
+ (set! head-stencil
+ (ly:stencil-add
+ (ly:stencil-translate-axis
+ (annotate-y-interval layout
+ (symbol->string separation-symbol)
+ (cons (min 0 (* dir sep))
+ (max 0 (* dir sep)))
+ #t)
+ (/ (ly:output-def-lookup layout 'linewidth) 2)
+ X)
+ head-stencil
+ ))
+ )))
+
+ head-stencil))
+
+(define-public (default-page-music-height layout scopes number last?)
+ "Printable area for music and titles; matches default-page-make-stencil."
+ (let* ((h (- (ly:output-def-lookup layout 'vsize)
+ (ly:output-def-lookup layout 'topmargin)
+ (ly:output-def-lookup layout 'bottommargin)))
+
+ (head (page-headfoot layout scopes number 'make-header 'headsep UP last?))
+ (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?))
+ (available
+ (- h (if (ly:stencil? head)
+ (interval-length (ly:stencil-extent head Y))
+ 0)
+ (if (ly:stencil? foot)
+ (interval-length (ly:stencil-extent foot Y))
+ 0))))
+
+ ;; (display (list "\n available" available head foot))
+ available))
+
+(define-public (default-page-make-stencil
+ lines offsets layout scopes number last?)
+ "Construct a stencil representing the page from LINES.
+
+ Offsets is a list of increasing numbers. They must be negated to
+create offsets.
+ "
+
+ (let* ((topmargin (ly:output-def-lookup layout 'topmargin))
+
+ ;; TODO: naming vsize/hsize not analogous to TeX.
+
+ (vsize (ly:output-def-lookup layout 'vsize))
+ (hsize (ly:output-def-lookup layout 'hsize))
+
+ (system-xoffset (ly:output-def-lookup layout 'horizontalshift 0.0))
+ (system-separator-markup (ly:output-def-lookup layout 'systemSeparatorMarkup))
+ (system-separator-stencil (if (markup? system-separator-markup)
+ (interpret-markup layout
+ (layout-extract-page-properties layout)
+ system-separator-markup)
+ #f))
+ (lmargin (ly:output-def-lookup layout 'leftmargin))
+ (leftmargin (if lmargin
+ lmargin
+ (/ (- hsize
+ (ly:output-def-lookup layout 'linewidth)) 2)))
+
+ (rightmargin (ly:output-def-lookup layout 'rightmargin))
+ (bottom-edge (- vsize
+ (ly:output-def-lookup layout 'bottommargin)))
+
+ (head (page-headfoot layout scopes number 'make-header 'headsep UP last?))
+ (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?))
+
+ (head-height (if (ly:stencil? head)
+ (interval-length (ly:stencil-extent head Y))
+ 0.0))
+
+ (height-proc (ly:output-def-lookup layout 'page-music-height))
+
+ (page-stencil (ly:make-stencil '()
+ (cons leftmargin hsize)
+ (cons (- topmargin) 0)))
+ (last-system #f)
+ (last-y 0.0)
+ (add-to-page (lambda (stencil y)
+ (set! page-stencil
+ (ly:stencil-add page-stencil
+ (ly:stencil-translate stencil
+ (cons
+ system-xoffset
+ (- 0 head-height y topmargin))
+
+ )))))
+ (add-system
+ (lambda (stencil-position)
+ (let* ((system (car stencil-position))
+ (stencil (paper-system-stencil system))
+ (y (cadr stencil-position))
+ (is-title (paper-system-title?
+ (car stencil-position))))
+ (add-to-page stencil y)
+ (if (and (ly:stencil? system-separator-stencil)
+ last-system
+ (not (paper-system-title? system))
+ (not (paper-system-title? last-system)))
+ (add-to-page
+ system-separator-stencil
+ (average (- last-y
+ (car (paper-system-staff-extents last-system)))
+ (- y
+ (cdr (paper-system-staff-extents system))))))
+ (set! last-system system)
+ (set! last-y y))))
+ )
+
+
+ (if (annotate? layout)
+ (begin
+ (for-each (lambda (sys) (paper-system-annotate sys layout))
+ lines)
+ (paper-system-annotate-last (car (last-pair lines)) layout)))
+
+
+ (if #f
+ (display (list
+ "leftmargin " leftmargin "rightmargin " rightmargin
+ )))
+
+ (set! page-stencil (ly:stencil-combine-at-edge
+ page-stencil Y DOWN
+ (if (and
+ (ly:stencil? head)
+ (not (ly:stencil-empty? head)))
+ head
+ (ly:make-stencil "" (cons 0 0) (cons 0 0)))
+ 0. 0.))
+
+ (map add-system (zip lines offsets))
+
+ (if (annotate? layout)
+ (set!
+ page-stencil
+ (annotate-space-left page-stencil layout
+ (- bottom-edge
+ (if (ly:stencil? foot)
+ (interval-length (ly:stencil-extent foot Y))
+ 0)))
+ ))
+
+
+ (if (and (ly:stencil? foot)
+ (not (ly:stencil-empty? foot)))
+ (set! page-stencil
+ (ly:stencil-add
+ page-stencil
+ (ly:stencil-translate
+ foot
+ (cons 0
+ (+ (- bottom-edge)
+ (- (car (ly:stencil-extent foot Y)))))))))
+
+ (set! page-stencil
+ (ly:stencil-translate page-stencil (cons leftmargin 0)))
+
+ ;; annotation.
+ (if (annotate? layout)
+ (set! page-stencil (annotate-page layout page-stencil)))
+
+
+ page-stencil))
+
+;;; optimal page breaking
+
+;;; This is not optimal page breaking, this is optimal distribution of
+;;; lines over pages; line breaks are a given.
+
+;; TODO:
+;;
+;; - density scoring
+;; - separate function for word-wrap style breaking?
+;; - raggedbottom? raggedlastbottom?
+
+(define-public (optimal-page-breaks lines paper-book)
+ "Return pages as a list starting with 1st page. Each page is a list
+of lines. "
+
+ (define MAXPENALTY 1e9)
+ (define paper (ly:paper-book-paper paper-book))
+ (define scopes (ly:paper-book-scopes paper-book))
+ (define force-equalization-factor #f)
+
+ (define (page-height page-number last?)
+ (let ((p (ly:output-def-lookup paper 'page-music-height)))
+
+ (if (procedure? p)
+ (p paper scopes page-number last?)
+ 10000)))
+
+ (define (get-path node done)
+ "Follow NODE.PREV, and return as an ascending list of pages. DONE
+is what have collected so far, and has ascending page numbers."
+
+ (if (is-a? node <optimally-broken-page-node>)
+ (get-path (node-prev node) (cons node done))
+ done))
+
+ (define (combine-penalties force user best-paths)
+ (let* ((prev-force (if (null? best-paths)
+ 0.0
+ (node-force (car best-paths))))
+ (prev-penalty (if (null? best-paths)
+ 0.0
+ (node-penalty (car best-paths))))
+ (inter-system-space (ly:output-def-lookup paper 'betweensystemspace))
+ (relative-force (/ force inter-system-space))
+ (abs-relative-force (abs relative-force)))
+
+
+ (+ (* abs-relative-force (+ abs-relative-force 1))
+ prev-penalty
+ (* force-equalization-factor (/ (abs (- prev-force force))
+ inter-system-space))
+ user)))
+
+ (define (space-systems page-height lines ragged?)
+ (let* ((global-inter-system-space
+ (ly:output-def-lookup paper 'betweensystemspace))
+ (top-space
+ (ly:output-def-lookup paper 'pagetopspace))
+ (global-fixed-dist (ly:output-def-lookup paper 'betweensystempadding))
+
+ (system-vector (list->vector
+ (append lines
+ (if (= (length lines) 1)
+ '(#f)
+ '()))))
+ (staff-extents
+ (list->vector
+ (append (map paper-system-staff-extents lines)
+ (if (= (length lines) 1)
+ '((0 . 0))
+ '()))))
+
+ (real-extents
+ (list->vector
+ (append
+ (map
+ (lambda (sys) (paper-system-extent sys Y)) lines)
+ (if (= (length lines) 1)
+ '((0 . 0))
+ '()))))
+
+ (system-count (vector-length real-extents))
+ (topskip (max
+ (+
+ top-space
+ (interval-end (vector-ref staff-extents 0)))
+ (interval-end (vector-ref real-extents 0))
+ ))
+ (last-system (vector-ref system-vector (1- system-count)))
+ (bottom-space (if (ly:paper-system? last-system)
+ (ly:paper-system-property last-system 'bottom-space 0.0)
+ 0.0))
+ (space-left (- page-height
+ bottom-space
+ (apply + (map interval-length
+ (vector->list real-extents)))))
+
+ (space (- page-height
+ topskip
+ bottom-space
+ (- (interval-start
+ (vector-ref real-extents (1- system-count))))))
+
+ (calc-spring
+ (lambda (idx)
+ (let* (
+ (upper-system (vector-ref system-vector idx))
+ (between-space (ly:paper-system-property upper-system 'next-space
+ global-inter-system-space))
+ (fixed-dist (ly:paper-system-property upper-system 'next-padding
+ global-fixed-dist))
+
+ (this-system-ext (vector-ref staff-extents idx))
+ (next-system-ext (vector-ref staff-extents (1+ idx)))
+ (fixed (max 0 (- (+ (interval-end next-system-ext)
+ fixed-dist)
+ (interval-start this-system-ext))))
+ (title1? (and (vector-ref system-vector idx)
+ (paper-system-title? (vector-ref system-vector idx)
+ )))
+ (title2? (and
+ (vector-ref system-vector (1+ idx))
+ (paper-system-title? (vector-ref system-vector (1+ idx)))))
+ (ideal (+
+ (cond
+ ((and title2? title1?)
+ (ly:output-def-lookup paper 'betweentitlespace))
+ (title1?
+ (ly:output-def-lookup paper 'aftertitlespace))
+ (title2?
+ (ly:output-def-lookup paper 'beforetitlespace))
+ (else between-space))
+ fixed))
+ (hooke (/ 1 (- ideal fixed))))
+ (list ideal hooke))))
+
+ (springs (map calc-spring (iota (1- system-count))))
+ (calc-rod
+ (lambda (idx)
+ (let* (
+ (upper-system (vector-ref system-vector idx))
+ (fixed-dist (ly:paper-system-property upper-system 'next-padding
+ global-fixed-dist))
+ (this-system-ext (vector-ref real-extents idx))
+ (next-system-ext (vector-ref real-extents (1+ idx)))
+
+ (distance (max (- (+ (interval-end next-system-ext)
+ fixed-dist)
+ (interval-start this-system-ext)
+ ) 0))
+ (entry (list idx (1+ idx) distance)))
+ entry)))
+ (rods (map calc-rod (iota (1- system-count))))
+
+ ;; we don't set ragged based on amount space left.
+ ;; raggedbottomlast = ##T is much more predictable
+ (result (ly:solve-spring-rod-problem
+ springs rods space
+ ragged?))
+
+ (force (car result))
+ (positions
+ (map (lambda (y)
+ (+ y topskip))
+ (cdr result))))
+
+ (if #f ;; debug.
+ (begin
+ (display (list "\n# systems: " system-count
+ "\nreal-ext" real-extents "\nstaff-ext" staff-extents
+ "\ninterscore" global-inter-system-space
+ "\nspace-left" space-left
+ "\nspring,rod" springs rods
+ "\ntopskip " topskip
+ " space " space
+ "\npage-height" page-height
+ "\nragged" ragged?
+ "\nforce" force
+ "\nres" (cdr result)
+ "\npositions" positions "\n"))))
+
+ (cons force positions)))
+
+ (define (walk-paths done-lines best-paths current-lines last? current-best)
+ "Return the best optimal-page-break-node that contains
+CURRENT-LINES. DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
+ascending range of lines, and BEST-PATHS contains the optimal breaks
+corresponding to DONE-LINES.
+
+CURRENT-BEST is the best result sofar, or #f."
+
+
+ (let* ((this-page-num (if (null? best-paths)
+ (ly:output-def-lookup paper 'firstpagenumber)
+ (1+ (node-page-number (car best-paths)))))
+
+ (ragged-all? (eq? #t (ly:output-def-lookup paper 'raggedbottom)))
+ (ragged-last? (eq? #t (ly:output-def-lookup paper 'raggedlastbottom)))
+ (ragged? (or ragged-all?
+ (and ragged-last?
+ last?)))
+ (page-height (page-height this-page-num last?))
+ (vertical-spacing (space-systems page-height current-lines ragged?))
+ (satisfied-constraints (car vertical-spacing))
+ (force (if satisfied-constraints
+ (if (and last? ragged-last?)
+ 0.0
+ satisfied-constraints)
+ 10000))
+ (positions (cdr vertical-spacing))
+ (get-break-penalty (lambda (sys)
+ (ly:paper-system-property sys 'penalty 0.0)))
+ (user-nobreak-penalties
+ (-
+ (apply + (filter negative?
+ (map get-break-penalty
+ (cdr current-lines))))))
+ (user-penalty
+ (+
+ (max (get-break-penalty (car current-lines)) 0.0)
+ user-nobreak-penalties))
+
+ (total-penalty (combine-penalties
+ force user-penalty
+ best-paths))
+
+ (better? (or
+ (not current-best)
+ (< total-penalty (node-penalty current-best))))
+ (new-best (if better?
+ (make <optimally-broken-page-node>
+ #:prev (if (null? best-paths)
+ #f
+ (car best-paths))
+ #:lines current-lines
+ #:pageno this-page-num
+ #:force force
+ #:configuration positions
+ #:penalty total-penalty)
+ current-best)))
+
+;; (display total-penalty) (newline)
+ (if #f ;; debug
+ (display
+ (list
+ "\nuser pen " user-penalty
+ "\nsatisfied-constraints" satisfied-constraints
+ "\nlast? " last? "ragged?" ragged?
+ "\nbetter? " better? " total-penalty " total-penalty "\n"
+ "\nconfig " positions
+ "\nforce " force
+ "\nlines: " current-lines "\n")))
+
+ (if #f ; debug
+ (display (list "\nnew-best is " (node-lines new-best)
+ "\ncontinuation of "
+ (if (null? best-paths)
+ "start"
+ (node-lines (car best-paths))))))
+
+ (if (and (pair? done-lines)
+ ;; if this page is too full, adding another line won't help
+ satisfied-constraints)
+ (walk-paths (cdr done-lines) (cdr best-paths)
+ (cons (car done-lines) current-lines)
+ last? new-best)
+ new-best)))
+
+ (define (walk-lines done best-paths todo)
+ "Return the best page breaking as a single
+<optimal-page-break-node> for optimally breaking TODO ++
+DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
+DONE."
+
+ (if (null? todo)
+ (car best-paths)
+ (let* ((this-line (car todo))
+ (last? (null? (cdr todo)))
+ (next (walk-paths done best-paths (list this-line) last? #f)))
+
+ ;; (display "\n***************")
+ (walk-lines (cons this-line done)
+ (cons next best-paths)
+ (cdr todo)))))
+
+ (define (line-number node)
+ (ly:paper-system-property (car (node-lines node)) 'number))
+
+ (ly:message (_ "Calculating page breaks..."))
+ (set! force-equalization-factor
+ (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
+
+ (let* ((best-break-node (walk-lines '() '() lines))
+ (break-nodes (get-path best-break-node '()))
+ (last-node (car (last-pair break-nodes))))
+
+ (define (node->page-stencil node)
+ (if (not (eq? node last-node))
+ (ly:progress "["))
+ (let ((stencil
+ ((ly:output-def-lookup paper 'page-make-stencil)
+ (node-lines node)
+ (node-configuration node)
+ paper
+ scopes
+ (node-page-number node)
+ (eq? node best-break-node))))
+ (if (not (eq? node last-node))
+ (begin
+ (ly:progress (number->string
+ (car (last-pair (node-system-numbers node)))))
+ (ly:progress "]")))
+ stencil))
+
+ (if #f; (ly:get-option 'verbose)
+ (begin
+ (display (list
+ "\nbreaks: " (map line-number break-nodes))
+ "\nsystems " (map node-lines break-nodes)
+ "\npenalties " (map node-penalty break-nodes)
+ "\nconfigs " (map node-configuration break-nodes))))
+
+ (let ((stencils (map node->page-stencil break-nodes)))
+ (ly:progress "\n")
+ stencils)))
--- /dev/null
+;;;; slur.scm -- Slur scheme stuff
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2000--2005 Jan Nieuwenhuizen <janneke@gnu.org>
+ ;
+; this is put into the slur-details property of Slur and PhrasingSlur
+(define default-slur-details
+ '((region-size . 4)
+ (head-encompass-penalty . 1000.0)
+ (stem-encompass-penalty . 30.0)
+ (closeness-factor . 10)
+ (edge-attraction-factor . 4)
+ (same-slope-penalty . 20)
+ (steeper-slope-factor . 50)
+ (non-horizontal-penalty . 15)
+ (max-slope . 1.1)
+ (max-slope-factor . 10)
+ (free-head-distance . 0.3)
+ (free-slur-distance . 0.8)
+ (extra-object-collision . 50)
+ (accidental-collision . 3)
+ (extra-encompass-free-distance . 0.3)
+ (head-slur-distance-max-ratio . 3)
+ (head-slur-distance-factor . 10)
+ (absolute-closeness-measure . 0.3)
+ (edge-slope-exponent . 1.7)
+ ))
"chord-generic-names.scm"
"stencil.scm"
"markup.scm"
- "bass-figure.scm"
"music-functions.scm"
"part-combiner.scm"
"autochange.scm"
"auto-beam.scm"
"chord-name.scm"
- "ly-from-scheme.scm"
+ "parser-ly-from-scheme.scm"
"define-context-properties.scm"
"translation-functions.scm"
"script.scm"
"midi.scm"
- "beam.scm"
- "clef.scm"
- "slur.scm"
+ "layout-beam.scm"
+ "parser-clef.scm"
+ "layout-slur.scm"
"font.scm"
"encoding.scm"
"define-grobs.scm"
"define-grob-interfaces.scm"
"define-stencil-commands.scm"
- "page-layout.scm"
+ "layout-page-layout.scm"
"titling.scm"
"paper.scm"
+++ /dev/null
-;;;; ly-from-scheme.scm -- parsing LilyPond music expressions from scheme
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2004--2005 Nicolas Sceaux <nicolas.sceaux@free.fr>
-;;;; Jan Nieuwenhuizen <janneke@gnu.org>
-
-(define gen-lily-sym
- ;; Generate a lilyvartmpXX symbol, that may be (hopefully) unique.
- (let ((var-idx -1))
- (lambda ()
- (set! var-idx (1+ var-idx))
- (string->symbol (format #f "lilyvartmp~a"
- (list->string (map (lambda (chr)
- (integer->char (+ (char->integer #\a) (- (char->integer chr)
- (char->integer #\0)))))
- (string->list (number->string var-idx)))))))))
-
-(define-public (ly:parse-string-result str parser)
- "Parse `str', which is supposed to contain a music expression."
- (let ((music-sym (gen-lily-sym)))
- (ly:parser-parse-string
- parser
- (format #f "parseStringResult = { ~a }" str))
-
- (ly:parser-lookup parser 'parseStringResult)))
-
-(define-public (read-lily-expression chr port)
- "Read a #{ lily music expression #} from port and return
-the scheme music expression. The $ character may be used to introduce
-scheme forms, typically symbols. $$ may be used to simply write a `$'
-character."
- (let ((bindings '()))
-
- (define (create-binding! val)
- "Create a new symbol, bind it to `val' and return it."
- (let ((tmp-symbol (gen-lily-sym)))
-
- (set! bindings (cons (cons tmp-symbol val) bindings))
- tmp-symbol))
-
- (define (remove-dollars! form)
- "Generate a form where `$variable' and `$ value' mottos are replaced
- by new symbols, which are binded to the adequate values."
- (cond (;; $variable
- (and (symbol? form)
- (string=? (substring (symbol->string form) 0 1) "$")
- (not (and (<= 2 (string-length (symbol->string form)))
- (string=? (substring (symbol->string form) 1 2) "$"))))
- (create-binding! (string->symbol (substring (symbol->string form) 1))))
- (;; atom
- (not (pair? form)) form)
- (;; ($ value ...)
- (eqv? (car form) '$)
- (cons (create-binding! (cadr form)) (remove-dollars! (cddr form))))
- (else ;; (something ...)
- (cons (remove-dollars! (car form)) (remove-dollars! (cdr form))))))
- (let*
- ((lily-string (call-with-output-string
- (lambda (out)
- (do ((c (read-char port) (read-char port)))
- ((and (char=? c #\#)
- (char=? (peek-char port) #\})) ;; we stop when #} is encoutered
- (read-char port))
- (cond
- ;; a $form expression
- ((and (char=? c #\$) (not (char=? (peek-char port) #\$)))
- (format out "\\~a" (create-binding! (read port))))
- ;; just a $ character
- ((and (char=? c #\$) (char=? (peek-char port) #\$))
- ;; pop the second $
- (display (read-char port) out))
- ;; a #scheme expression
- ((char=? c #\#)
- (let ((expr (read port)))
- (format out "#~s" (if (eq? '$ expr)
- (create-binding! (read port))
- (remove-dollars! expr)))))
- ;; other caracters
- (else
- (display c out)))))))
-
- (result
- `(let ((parser-clone (ly:clone-parser parser)))
- ,@(map (lambda (binding)
- `(ly:parser-define! parser-clone ',(car binding) ,(cdr binding)))
- (reverse bindings))
- (ly:parse-string-result ,lily-string parser-clone))
- ))
-
-
-
- result
- )))
-
-(read-hash-extend #\{ read-lily-expression)
+++ /dev/null
-;;;; page-layout.scm -- page breaking and page layout
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2004--2005 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
-
-(use-modules (oop goops describe)
- (oop goops))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-class <optimally-broken-page-node> ()
- (prev #:init-value '() #:accessor node-prev #:init-keyword #:prev)
- (page #:init-value 0 #:accessor node-page-number #:init-keyword #:pageno)
- (force #:init-value 0 #:accessor node-force #:init-keyword #:force)
- (penalty #:init-value 0 #:accessor node-penalty #:init-keyword #:penalty)
- (configuration #:init-value '() #:accessor node-configuration #:init-keyword #:configuration)
- (lines #:init-value 0 #:accessor node-lines #:init-keyword #:lines))
-
-(define-method (display (node <optimally-broken-page-node>) port)
- (map (lambda (x) (display x port))
- (list
- "Page " (node-page-number node)
- " Lines: " (node-lines node)
- " Penalty " (node-penalty node)
- "\n")))
-
-(define-method (node-system-numbers (node <optimally-broken-page-node>))
- (map (lambda (ps) (ly:paper-system-property ps 'number))
- (node-lines node)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (annotate? layout)
- (eq? #t (ly:output-def-lookup layout 'annotatespacing)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define-public (paper-system-staff-extents ps)
- (ly:paper-system-property ps 'refpoint-Y-extent '(0 . 0)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ANNOTATIONS
-;;
-;; annotations are arrows indicating the numerical value of
-;; spacing variables
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (annotate-y-interval layout name extent is-length?)
- ;; do something sensible for 0,0 intervals.
- (set! extent (interval-widen extent 0.001))
- (let*
- ((text-props (cons
- '((font-size . -3)
- (font-family . typewriter))
- (layout-extract-page-properties layout)))
- (annotation (interpret-markup
- layout text-props
- (make-column-markup
- (list
- (make-whiteout-markup (make-simple-markup name))
- (make-whiteout-markup
- (make-simple-markup
- (if is-length?
- (format "~$" (interval-length extent))
- (format "(~$,~$)" (car extent)
- (cdr extent)))))))))
- (arrows
- (ly:stencil-translate-axis
- (dimension-arrows (cons 0 (interval-length extent)))
- (interval-start extent) Y)))
-
- (set! annotation
- (ly:stencil-aligned-to annotation Y CENTER))
-
- (set! annotation (ly:stencil-translate annotation
- (cons 0 (interval-center extent))))
-
- (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0)
- ))
-
-(define (paper-system-annotate-last system layout)
- (let*
- ((bottomspace (ly:paper-system-property system 'bottom-space))
- (y-extent (paper-system-extent system Y))
- (x-extent (paper-system-extent system X))
- (stencil (ly:paper-system-property system 'stencil))
-
- (arrow (if (number? bottomspace)
- (annotate-y-interval layout
- "bottom-space"
- (cons (- (car y-extent) bottomspace)
- (car y-extent))
- #t)
- #f)))
-
- (if arrow
- (set! stencil
- (ly:stencil-add stencil arrow)))
-
- (set! (ly:paper-system-property system 'stencil)
- stencil)
- ))
-
-(define (paper-system-annotate system layout)
- "Add arrows and texts to indicate which lengths are set."
- (let*
- ((annotations (ly:make-stencil '() (cons 0 2) (cons 0 0)))
- (append-stencil
- (lambda (a b)
- (ly:stencil-combine-at-edge a X RIGHT b 0.5 0)))
-
- (annotate-property
- (lambda (name extent is-length?)
- (set! annotations
- (append-stencil annotations
- (annotate-y-interval layout
- name extent is-length?)))))
-
- (bbox-extent (paper-system-extent system Y))
- (refp-extent (ly:paper-system-property system 'refpoint-Y-extent))
- (next-space (ly:paper-system-property system 'next-space
- (ly:output-def-lookup layout 'betweensystemspace)
- ))
- (next-padding (ly:paper-system-property system 'next-padding
- (ly:output-def-lookup layout 'betweensystempadding)
- ))
-
- )
-
- (if (number-pair? bbox-extent)
- (begin
- (annotate-property "Y-extent"
- bbox-extent #f)
- (annotate-property "next-padding"
- (interval-translate (cons (- next-padding) 0) (car bbox-extent))
- #t)))
-
- ;; titles don't have a refpoint-Y-extent.
- (if (number-pair? refp-extent)
- (begin
- (annotate-property "refpoint-Y-extent"
- refp-extent #f)
-
- (annotate-property "next-space"
- (interval-translate (cons (- next-space) 0) (car refp-extent))
- #t)))
-
-
-
- (set! (ly:paper-system-property system 'stencil)
- (ly:stencil-add
- (ly:paper-system-property system 'stencil)
- (ly:make-stencil
- (ly:stencil-expr annotations)
- (ly:stencil-extent empty-stencil X)
- (ly:stencil-extent empty-stencil Y)
- )))
-
- ))
-
-(define (annotate-page layout stencil)
- (let*
- ((topmargin (ly:output-def-lookup layout 'topmargin))
- (vsize (ly:output-def-lookup layout 'vsize))
- (bottommargin (ly:output-def-lookup layout 'bottommargin))
- (add-stencil (lambda (y)
- (set! stencil
- (ly:stencil-add stencil y))
- )))
-
- (add-stencil
- (ly:stencil-translate-axis
- (annotate-y-interval layout "vsize"
- (cons (- vsize) 0)
- #t)
- 1 X))
-
- (add-stencil
- (ly:stencil-translate-axis
- (annotate-y-interval layout "topmargin"
- (cons (- topmargin) 0)
- #t)
- 2 X))
-
- (add-stencil
- (ly:stencil-translate-axis
- (annotate-y-interval layout "bottommargin"
- (cons (- vsize) (- bottommargin vsize))
- #t)
- 2 X))
-
- stencil))
-
-(define (annotate-space-left page-stencil layout bottom-edge)
- (let*
- ((arrow (annotate-y-interval layout
- "space left"
- (cons (- bottom-edge) (car (ly:stencil-extent page-stencil Y)))
- #t)))
-
- (set! arrow (ly:stencil-translate-axis arrow 8 X))
- (ly:stencil-add page-stencil arrow)))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(define (page-headfoot layout scopes number
- sym separation-symbol dir last?)
- "Create a stencil including separating space."
-
- (let* ((header-proc (ly:output-def-lookup layout sym))
- (sep (ly:output-def-lookup layout separation-symbol))
- (stencil (ly:make-stencil "" '(0 . 0) '(0 . 0)))
- (head-stencil
- (if (procedure? header-proc)
- (header-proc layout scopes number last?)
- #f))
- )
-
- (if (and (number? sep)
- (ly:stencil? head-stencil)
- (not (ly:stencil-empty? head-stencil)))
-
- (begin
- (set! head-stencil
- (ly:stencil-combine-at-edge
- stencil Y dir head-stencil
- sep 0.0))
-
-
- ;; add arrow markers
- (if (annotate? layout)
- (set! head-stencil
- (ly:stencil-add
- (ly:stencil-translate-axis
- (annotate-y-interval layout
- (symbol->string separation-symbol)
- (cons (min 0 (* dir sep))
- (max 0 (* dir sep)))
- #t)
- (/ (ly:output-def-lookup layout 'linewidth) 2)
- X)
- head-stencil
- ))
- )))
-
- head-stencil))
-
-(define-public (default-page-music-height layout scopes number last?)
- "Printable area for music and titles; matches default-page-make-stencil."
- (let* ((h (- (ly:output-def-lookup layout 'vsize)
- (ly:output-def-lookup layout 'topmargin)
- (ly:output-def-lookup layout 'bottommargin)))
-
- (head (page-headfoot layout scopes number 'make-header 'headsep UP last?))
- (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?))
- (available
- (- h (if (ly:stencil? head)
- (interval-length (ly:stencil-extent head Y))
- 0)
- (if (ly:stencil? foot)
- (interval-length (ly:stencil-extent foot Y))
- 0))))
-
- ;; (display (list "\n available" available head foot))
- available))
-
-(define-public (default-page-make-stencil
- lines offsets layout scopes number last?)
- "Construct a stencil representing the page from LINES.
-
- Offsets is a list of increasing numbers. They must be negated to
-create offsets.
- "
-
- (let* ((topmargin (ly:output-def-lookup layout 'topmargin))
-
- ;; TODO: naming vsize/hsize not analogous to TeX.
-
- (vsize (ly:output-def-lookup layout 'vsize))
- (hsize (ly:output-def-lookup layout 'hsize))
-
- (system-xoffset (ly:output-def-lookup layout 'horizontalshift 0.0))
- (system-separator-markup (ly:output-def-lookup layout 'systemSeparatorMarkup))
- (system-separator-stencil (if (markup? system-separator-markup)
- (interpret-markup layout
- (layout-extract-page-properties layout)
- system-separator-markup)
- #f))
- (lmargin (ly:output-def-lookup layout 'leftmargin))
- (leftmargin (if lmargin
- lmargin
- (/ (- hsize
- (ly:output-def-lookup layout 'linewidth)) 2)))
-
- (rightmargin (ly:output-def-lookup layout 'rightmargin))
- (bottom-edge (- vsize
- (ly:output-def-lookup layout 'bottommargin)))
-
- (head (page-headfoot layout scopes number 'make-header 'headsep UP last?))
- (foot (page-headfoot layout scopes number 'make-footer 'footsep DOWN last?))
-
- (head-height (if (ly:stencil? head)
- (interval-length (ly:stencil-extent head Y))
- 0.0))
-
- (height-proc (ly:output-def-lookup layout 'page-music-height))
-
- (page-stencil (ly:make-stencil '()
- (cons leftmargin hsize)
- (cons (- topmargin) 0)))
- (last-system #f)
- (last-y 0.0)
- (add-to-page (lambda (stencil y)
- (set! page-stencil
- (ly:stencil-add page-stencil
- (ly:stencil-translate stencil
- (cons
- system-xoffset
- (- 0 head-height y topmargin))
-
- )))))
- (add-system
- (lambda (stencil-position)
- (let* ((system (car stencil-position))
- (stencil (paper-system-stencil system))
- (y (cadr stencil-position))
- (is-title (paper-system-title?
- (car stencil-position))))
- (add-to-page stencil y)
- (if (and (ly:stencil? system-separator-stencil)
- last-system
- (not (paper-system-title? system))
- (not (paper-system-title? last-system)))
- (add-to-page
- system-separator-stencil
- (average (- last-y
- (car (paper-system-staff-extents last-system)))
- (- y
- (cdr (paper-system-staff-extents system))))))
- (set! last-system system)
- (set! last-y y))))
- )
-
-
- (if (annotate? layout)
- (begin
- (for-each (lambda (sys) (paper-system-annotate sys layout))
- lines)
- (paper-system-annotate-last (car (last-pair lines)) layout)))
-
-
- (if #f
- (display (list
- "leftmargin " leftmargin "rightmargin " rightmargin
- )))
-
- (set! page-stencil (ly:stencil-combine-at-edge
- page-stencil Y DOWN
- (if (and
- (ly:stencil? head)
- (not (ly:stencil-empty? head)))
- head
- (ly:make-stencil "" (cons 0 0) (cons 0 0)))
- 0. 0.))
-
- (map add-system (zip lines offsets))
-
- (if (annotate? layout)
- (set!
- page-stencil
- (annotate-space-left page-stencil layout
- (- bottom-edge
- (if (ly:stencil? foot)
- (interval-length (ly:stencil-extent foot Y))
- 0)))
- ))
-
-
- (if (and (ly:stencil? foot)
- (not (ly:stencil-empty? foot)))
- (set! page-stencil
- (ly:stencil-add
- page-stencil
- (ly:stencil-translate
- foot
- (cons 0
- (+ (- bottom-edge)
- (- (car (ly:stencil-extent foot Y)))))))))
-
- (set! page-stencil
- (ly:stencil-translate page-stencil (cons leftmargin 0)))
-
- ;; annotation.
- (if (annotate? layout)
- (set! page-stencil (annotate-page layout page-stencil)))
-
-
- page-stencil))
-
-;;; optimal page breaking
-
-;;; This is not optimal page breaking, this is optimal distribution of
-;;; lines over pages; line breaks are a given.
-
-;; TODO:
-;;
-;; - density scoring
-;; - separate function for word-wrap style breaking?
-;; - raggedbottom? raggedlastbottom?
-
-(define-public (optimal-page-breaks lines paper-book)
- "Return pages as a list starting with 1st page. Each page is a list
-of lines. "
-
- (define MAXPENALTY 1e9)
- (define paper (ly:paper-book-paper paper-book))
- (define scopes (ly:paper-book-scopes paper-book))
- (define force-equalization-factor #f)
-
- (define (page-height page-number last?)
- (let ((p (ly:output-def-lookup paper 'page-music-height)))
-
- (if (procedure? p)
- (p paper scopes page-number last?)
- 10000)))
-
- (define (get-path node done)
- "Follow NODE.PREV, and return as an ascending list of pages. DONE
-is what have collected so far, and has ascending page numbers."
-
- (if (is-a? node <optimally-broken-page-node>)
- (get-path (node-prev node) (cons node done))
- done))
-
- (define (combine-penalties force user best-paths)
- (let* ((prev-force (if (null? best-paths)
- 0.0
- (node-force (car best-paths))))
- (prev-penalty (if (null? best-paths)
- 0.0
- (node-penalty (car best-paths))))
- (inter-system-space (ly:output-def-lookup paper 'betweensystemspace))
- (relative-force (/ force inter-system-space))
- (abs-relative-force (abs relative-force)))
-
-
- (+ (* abs-relative-force (+ abs-relative-force 1))
- prev-penalty
- (* force-equalization-factor (/ (abs (- prev-force force))
- inter-system-space))
- user)))
-
- (define (space-systems page-height lines ragged?)
- (let* ((global-inter-system-space
- (ly:output-def-lookup paper 'betweensystemspace))
- (top-space
- (ly:output-def-lookup paper 'pagetopspace))
- (global-fixed-dist (ly:output-def-lookup paper 'betweensystempadding))
-
- (system-vector (list->vector
- (append lines
- (if (= (length lines) 1)
- '(#f)
- '()))))
- (staff-extents
- (list->vector
- (append (map paper-system-staff-extents lines)
- (if (= (length lines) 1)
- '((0 . 0))
- '()))))
-
- (real-extents
- (list->vector
- (append
- (map
- (lambda (sys) (paper-system-extent sys Y)) lines)
- (if (= (length lines) 1)
- '((0 . 0))
- '()))))
-
- (system-count (vector-length real-extents))
- (topskip (max
- (+
- top-space
- (interval-end (vector-ref staff-extents 0)))
- (interval-end (vector-ref real-extents 0))
- ))
- (last-system (vector-ref system-vector (1- system-count)))
- (bottom-space (if (ly:paper-system? last-system)
- (ly:paper-system-property last-system 'bottom-space 0.0)
- 0.0))
- (space-left (- page-height
- bottom-space
- (apply + (map interval-length
- (vector->list real-extents)))))
-
- (space (- page-height
- topskip
- bottom-space
- (- (interval-start
- (vector-ref real-extents (1- system-count))))))
-
- (calc-spring
- (lambda (idx)
- (let* (
- (upper-system (vector-ref system-vector idx))
- (between-space (ly:paper-system-property upper-system 'next-space
- global-inter-system-space))
- (fixed-dist (ly:paper-system-property upper-system 'next-padding
- global-fixed-dist))
-
- (this-system-ext (vector-ref staff-extents idx))
- (next-system-ext (vector-ref staff-extents (1+ idx)))
- (fixed (max 0 (- (+ (interval-end next-system-ext)
- fixed-dist)
- (interval-start this-system-ext))))
- (title1? (and (vector-ref system-vector idx)
- (paper-system-title? (vector-ref system-vector idx)
- )))
- (title2? (and
- (vector-ref system-vector (1+ idx))
- (paper-system-title? (vector-ref system-vector (1+ idx)))))
- (ideal (+
- (cond
- ((and title2? title1?)
- (ly:output-def-lookup paper 'betweentitlespace))
- (title1?
- (ly:output-def-lookup paper 'aftertitlespace))
- (title2?
- (ly:output-def-lookup paper 'beforetitlespace))
- (else between-space))
- fixed))
- (hooke (/ 1 (- ideal fixed))))
- (list ideal hooke))))
-
- (springs (map calc-spring (iota (1- system-count))))
- (calc-rod
- (lambda (idx)
- (let* (
- (upper-system (vector-ref system-vector idx))
- (fixed-dist (ly:paper-system-property upper-system 'next-padding
- global-fixed-dist))
- (this-system-ext (vector-ref real-extents idx))
- (next-system-ext (vector-ref real-extents (1+ idx)))
-
- (distance (max (- (+ (interval-end next-system-ext)
- fixed-dist)
- (interval-start this-system-ext)
- ) 0))
- (entry (list idx (1+ idx) distance)))
- entry)))
- (rods (map calc-rod (iota (1- system-count))))
-
- ;; we don't set ragged based on amount space left.
- ;; raggedbottomlast = ##T is much more predictable
- (result (ly:solve-spring-rod-problem
- springs rods space
- ragged?))
-
- (force (car result))
- (positions
- (map (lambda (y)
- (+ y topskip))
- (cdr result))))
-
- (if #f ;; debug.
- (begin
- (display (list "\n# systems: " system-count
- "\nreal-ext" real-extents "\nstaff-ext" staff-extents
- "\ninterscore" global-inter-system-space
- "\nspace-left" space-left
- "\nspring,rod" springs rods
- "\ntopskip " topskip
- " space " space
- "\npage-height" page-height
- "\nragged" ragged?
- "\nforce" force
- "\nres" (cdr result)
- "\npositions" positions "\n"))))
-
- (cons force positions)))
-
- (define (walk-paths done-lines best-paths current-lines last? current-best)
- "Return the best optimal-page-break-node that contains
-CURRENT-LINES. DONE-LINES.reversed ++ CURRENT-LINES is a consecutive
-ascending range of lines, and BEST-PATHS contains the optimal breaks
-corresponding to DONE-LINES.
-
-CURRENT-BEST is the best result sofar, or #f."
-
-
- (let* ((this-page-num (if (null? best-paths)
- (ly:output-def-lookup paper 'firstpagenumber)
- (1+ (node-page-number (car best-paths)))))
-
- (ragged-all? (eq? #t (ly:output-def-lookup paper 'raggedbottom)))
- (ragged-last? (eq? #t (ly:output-def-lookup paper 'raggedlastbottom)))
- (ragged? (or ragged-all?
- (and ragged-last?
- last?)))
- (page-height (page-height this-page-num last?))
- (vertical-spacing (space-systems page-height current-lines ragged?))
- (satisfied-constraints (car vertical-spacing))
- (force (if satisfied-constraints
- (if (and last? ragged-last?)
- 0.0
- satisfied-constraints)
- 10000))
- (positions (cdr vertical-spacing))
- (get-break-penalty (lambda (sys)
- (ly:paper-system-property sys 'penalty 0.0)))
- (user-nobreak-penalties
- (-
- (apply + (filter negative?
- (map get-break-penalty
- (cdr current-lines))))))
- (user-penalty
- (+
- (max (get-break-penalty (car current-lines)) 0.0)
- user-nobreak-penalties))
-
- (total-penalty (combine-penalties
- force user-penalty
- best-paths))
-
- (better? (or
- (not current-best)
- (< total-penalty (node-penalty current-best))))
- (new-best (if better?
- (make <optimally-broken-page-node>
- #:prev (if (null? best-paths)
- #f
- (car best-paths))
- #:lines current-lines
- #:pageno this-page-num
- #:force force
- #:configuration positions
- #:penalty total-penalty)
- current-best)))
-
-;; (display total-penalty) (newline)
- (if #f ;; debug
- (display
- (list
- "\nuser pen " user-penalty
- "\nsatisfied-constraints" satisfied-constraints
- "\nlast? " last? "ragged?" ragged?
- "\nbetter? " better? " total-penalty " total-penalty "\n"
- "\nconfig " positions
- "\nforce " force
- "\nlines: " current-lines "\n")))
-
- (if #f ; debug
- (display (list "\nnew-best is " (node-lines new-best)
- "\ncontinuation of "
- (if (null? best-paths)
- "start"
- (node-lines (car best-paths))))))
-
- (if (and (pair? done-lines)
- ;; if this page is too full, adding another line won't help
- satisfied-constraints)
- (walk-paths (cdr done-lines) (cdr best-paths)
- (cons (car done-lines) current-lines)
- last? new-best)
- new-best)))
-
- (define (walk-lines done best-paths todo)
- "Return the best page breaking as a single
-<optimal-page-break-node> for optimally breaking TODO ++
-DONE.reversed. BEST-PATHS is a list of break nodes corresponding to
-DONE."
-
- (if (null? todo)
- (car best-paths)
- (let* ((this-line (car todo))
- (last? (null? (cdr todo)))
- (next (walk-paths done best-paths (list this-line) last? #f)))
-
- ;; (display "\n***************")
- (walk-lines (cons this-line done)
- (cons next best-paths)
- (cdr todo)))))
-
- (define (line-number node)
- (ly:paper-system-property (car (node-lines node)) 'number))
-
- (ly:message (_ "Calculating page breaks..."))
- (set! force-equalization-factor
- (ly:output-def-lookup paper 'verticalequalizationfactor 0.3))
-
- (let* ((best-break-node (walk-lines '() '() lines))
- (break-nodes (get-path best-break-node '()))
- (last-node (car (last-pair break-nodes))))
-
- (define (node->page-stencil node)
- (if (not (eq? node last-node))
- (ly:progress "["))
- (let ((stencil
- ((ly:output-def-lookup paper 'page-make-stencil)
- (node-lines node)
- (node-configuration node)
- paper
- scopes
- (node-page-number node)
- (eq? node best-break-node))))
- (if (not (eq? node last-node))
- (begin
- (ly:progress (number->string
- (car (last-pair (node-system-numbers node)))))
- (ly:progress "]")))
- stencil))
-
- (if #f; (ly:get-option 'verbose)
- (begin
- (display (list
- "\nbreaks: " (map line-number break-nodes))
- "\nsystems " (map node-lines break-nodes)
- "\npenalties " (map node-penalty break-nodes)
- "\nconfigs " (map node-configuration break-nodes))))
-
- (let ((stencils (map node->page-stencil break-nodes)))
- (ly:progress "\n")
- stencils)))
--- /dev/null
+;;;; clef.scm -- Clef settings
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2004--2005 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+
+;; (name . (glyph clef-position octavation))
+;;
+;; -- the name clefOctavation is misleading. The value 7 is 1 octave,
+;; not 7 Octaves.
+(define-public supported-clefs
+ '(("treble" . ("clefs.G" -2 0))
+ ("violin" . ("clefs.G" -2 0))
+ ("G" . ("clefs.G" -2 0))
+ ("G2" . ("clefs.G" -2 0))
+ ("french" . ("clefs.G" -4 0))
+ ("soprano" . ("clefs.C" -4 0))
+ ("mezzosoprano" . ("clefs.C" -2 0))
+ ("alto" . ("clefs.C" 0 0))
+ ("C" . ("clefs.C" 0 0))
+ ("tenor" . ("clefs.C" 2 0))
+ ("baritone" . ("clefs.C" 4 0))
+ ("varbaritone" . ("clefs.F" 0 0))
+ ("bass" . ("clefs.F" 2 0))
+ ("F" . ("clefs.F" 2 0))
+ ("subbass" . ("clefs.F" 4 0))
+ ("percussion" . ("clefs.percussion" 0 0))
+ ("tab" . ("clefs.tab" 0 0))
+
+ ;; should move mensural stuff to separate file?
+ ("vaticana-do1" . ("clefs.vaticana.do" -1 0))
+ ("vaticana-do2" . ("clefs.vaticana.do" 1 0))
+ ("vaticana-do3" . ("clefs.vaticana.do" 3 0))
+ ("vaticana-fa1" . ("clefs.vaticana.fa" -1 0))
+ ("vaticana-fa2" . ("clefs.vaticana.fa" 1 0))
+ ("medicaea-do1" . ("clefs.medicaea.do" -1 0))
+ ("medicaea-do2" . ("clefs.medicaea.do" 1 0))
+ ("medicaea-do3" . ("clefs.medicaea.do" 3 0))
+ ("medicaea-fa1" . ("clefs.medicaea.fa" -1 0))
+ ("medicaea-fa2" . ("clefs.medicaea.fa" 1 0))
+ ("hufnagel-do1" . ("clefs.hufnagel.do" -1 0))
+ ("hufnagel-do2" . ("clefs.hufnagel.do" 1 0))
+ ("hufnagel-do3" . ("clefs.hufnagel.do" 3 0))
+ ("hufnagel-fa1" . ("clefs.hufnagel.fa" -1 0))
+ ("hufnagel-fa2" . ("clefs.hufnagel.fa" 1 0))
+ ("hufnagel-do-fa" . ("clefs.hufnagel.do.fa" 4 0))
+ ("mensural-c1" . ("clefs.mensural.c" -2 0))
+ ("mensural-c2" . ("clefs.mensural.c" 0 0))
+ ("mensural-c3" . ("clefs.mensural.c" 2 0))
+ ("mensural-c4" . ("clefs.mensural.c" 4 0))
+ ("mensural-f" . ("clefs.mensural.f" 2 0))
+ ("mensural-g" . ("clefs.mensural.g" -2 0))
+ ("neomensural-c1" . ("clefs.neomensural.c" -4 0))
+ ("neomensural-c2" . ("clefs.neomensural.c" -2 0))
+ ("neomensural-c3" . ("clefs.neomensural.c" 0 0))
+ ("neomensural-c4" . ("clefs.neomensural.c" 2 0))
+ ("petrucci-c1" . ("clefs.petrucci.c1" -4 0))
+ ("petrucci-c2" . ("clefs.petrucci.c2" -2 0))
+ ("petrucci-c3" . ("clefs.petrucci.c3" 0 0))
+ ("petrucci-c4" . ("clefs.petrucci.c4" 2 0))
+ ("petrucci-c5" . ("clefs.petrucci.c5" 4 0))
+ ("petrucci-f" . ("clefs.petrucci.f" 2 0))
+ ("petrucci-g" . ("clefs.petrucci.g" -2 0))))
+
+;; "an alist mapping GLYPHNAME to the position of the middle C for
+;; that symbol"
+(define c0-pitch-alist
+ '(("clefs.G" . -4)
+ ("clefs.C" . 0)
+ ("clefs.F" . 4)
+ ("clefs.percussion" . 0)
+ ("clefs.tab" . 0 )
+ ("clefs.vaticana.do" . 0)
+ ("clefs.vaticana.fa" . 4)
+ ("clefs.medicaea.do" . 0)
+ ("clefs.medicaea.fa" . 4)
+ ("clefs.hufnagel.do" . 0)
+ ("clefs.hufnagel.fa" . 4)
+ ("clefs.hufnagel.do.fa" . 0)
+ ("clefs.mensural.c" . 0)
+ ("clefs.mensural.f" . 4)
+ ("clefs.mensural.g" . -4)
+ ("clefs.neomensural.c" . 0)
+ ("clefs.petrucci.c1" . 0)
+ ("clefs.petrucci.c2" . 0)
+ ("clefs.petrucci.c3" . 0)
+ ("clefs.petrucci.c4" . 0)
+ ("clefs.petrucci.c5" . 0)
+ ("clefs.petrucci.f" . 4)
+ ("clefs.petrucci.g" . -4)))
+
+(define-public (make-clef-set clef-name)
+ "Generate the clef setting commands for a clef with name CLEF-NAME."
+ (define (make-prop-set props)
+ (let ((m (make-music 'PropertySet)))
+ (map (lambda (x) (set! (ly:music-property m (car x)) (cdr x))) props)
+ m))
+ (let ((e '())
+ (c0 0)
+ (oct 0)
+ (match (string-match "^(.*)([_^])([0-9]+)$" clef-name)))
+ (if match
+ (begin
+ (set! clef-name (match:substring match 1))
+ (set! oct
+ (* (if (equal? (match:substring match 2) "^") -1 1)
+ (- (string->number (match:substring match 3)) 1)))))
+ (set! e (assoc clef-name supported-clefs))
+ (if (pair? e)
+ (let* ((musics (map make-prop-set
+ `(((symbol . clefGlyph) (value . ,(cadr e)))
+ ((symbol . middleCPosition)
+ (value . ,(+ oct
+ (caddr e)
+ (cdr (assoc (cadr e) c0-pitch-alist)))))
+ ((symbol . clefPosition) (value . ,(caddr e)))
+ ((symbol . clefOctavation) (value . ,(- oct))))))
+ (seq (make-music 'SequentialMusic
+ 'elements musics))
+ (csp (make-music 'ContextSpeccedMusic)))
+ (context-spec-music seq 'Staff))
+ (begin
+ (ly:warning (_ "unknown clef type `~a'") clef-name)
+ (ly:warning (_ "see scm/clef.scm for supported clefs"))
+ (make-music 'Music)))))
+
--- /dev/null
+;;;; ly-from-scheme.scm -- parsing LilyPond music expressions from scheme
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; (c) 2004--2005 Nicolas Sceaux <nicolas.sceaux@free.fr>
+;;;; Jan Nieuwenhuizen <janneke@gnu.org>
+
+(define gen-lily-sym
+ ;; Generate a lilyvartmpXX symbol, that may be (hopefully) unique.
+ (let ((var-idx -1))
+ (lambda ()
+ (set! var-idx (1+ var-idx))
+ (string->symbol (format #f "lilyvartmp~a"
+ (list->string (map (lambda (chr)
+ (integer->char (+ (char->integer #\a) (- (char->integer chr)
+ (char->integer #\0)))))
+ (string->list (number->string var-idx)))))))))
+
+(define-public (ly:parse-string-result str parser)
+ "Parse `str', which is supposed to contain a music expression."
+ (let ((music-sym (gen-lily-sym)))
+ (ly:parser-parse-string
+ parser
+ (format #f "parseStringResult = { ~a }" str))
+
+ (ly:parser-lookup parser 'parseStringResult)))
+
+(define-public (read-lily-expression chr port)
+ "Read a #{ lily music expression #} from port and return
+the scheme music expression. The $ character may be used to introduce
+scheme forms, typically symbols. $$ may be used to simply write a `$'
+character."
+ (let ((bindings '()))
+
+ (define (create-binding! val)
+ "Create a new symbol, bind it to `val' and return it."
+ (let ((tmp-symbol (gen-lily-sym)))
+
+ (set! bindings (cons (cons tmp-symbol val) bindings))
+ tmp-symbol))
+
+ (define (remove-dollars! form)
+ "Generate a form where `$variable' and `$ value' mottos are replaced
+ by new symbols, which are binded to the adequate values."
+ (cond (;; $variable
+ (and (symbol? form)
+ (string=? (substring (symbol->string form) 0 1) "$")
+ (not (and (<= 2 (string-length (symbol->string form)))
+ (string=? (substring (symbol->string form) 1 2) "$"))))
+ (create-binding! (string->symbol (substring (symbol->string form) 1))))
+ (;; atom
+ (not (pair? form)) form)
+ (;; ($ value ...)
+ (eqv? (car form) '$)
+ (cons (create-binding! (cadr form)) (remove-dollars! (cddr form))))
+ (else ;; (something ...)
+ (cons (remove-dollars! (car form)) (remove-dollars! (cdr form))))))
+ (let*
+ ((lily-string (call-with-output-string
+ (lambda (out)
+ (do ((c (read-char port) (read-char port)))
+ ((and (char=? c #\#)
+ (char=? (peek-char port) #\})) ;; we stop when #} is encoutered
+ (read-char port))
+ (cond
+ ;; a $form expression
+ ((and (char=? c #\$) (not (char=? (peek-char port) #\$)))
+ (format out "\\~a" (create-binding! (read port))))
+ ;; just a $ character
+ ((and (char=? c #\$) (char=? (peek-char port) #\$))
+ ;; pop the second $
+ (display (read-char port) out))
+ ;; a #scheme expression
+ ((char=? c #\#)
+ (let ((expr (read port)))
+ (format out "#~s" (if (eq? '$ expr)
+ (create-binding! (read port))
+ (remove-dollars! expr)))))
+ ;; other caracters
+ (else
+ (display c out)))))))
+
+ (result
+ `(let ((parser-clone (ly:clone-parser parser)))
+ ,@(map (lambda (binding)
+ `(ly:parser-define! parser-clone ',(car binding) ,(cdr binding)))
+ (reverse bindings))
+ (ly:parse-string-result ,lily-string parser-clone))
+ ))
+
+
+
+ result
+ )))
+
+(read-hash-extend #\{ read-lily-expression)
+++ /dev/null
-;;;; slur.scm -- Slur scheme stuff
-;;;;
-;;;; source file of the GNU LilyPond music typesetter
-;;;;
-;;;; (c) 2000--2005 Jan Nieuwenhuizen <janneke@gnu.org>
- ;
-; this is put into the slur-details property of Slur and PhrasingSlur
-(define default-slur-details
- '((region-size . 4)
- (head-encompass-penalty . 1000.0)
- (stem-encompass-penalty . 30.0)
- (closeness-factor . 10)
- (edge-attraction-factor . 4)
- (same-slope-penalty . 20)
- (steeper-slope-factor . 50)
- (non-horizontal-penalty . 15)
- (max-slope . 1.1)
- (max-slope-factor . 10)
- (free-head-distance . 0.3)
- (free-slur-distance . 0.8)
- (extra-object-collision . 50)
- (accidental-collision . 3)
- (extra-encompass-free-distance . 0.3)
- (head-slur-distance-max-ratio . 3)
- (head-slur-distance-factor . 10)
- (absolute-closeness-measure . 0.3)
- (edge-slope-exponent . 1.7)
- ))
(define-public (format-mark-box-barnumbers mark context)
(make-bold-markup (make-box-markup
(number->string (ly:context-property context 'currentBarNumber)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Bass figures.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-public (format-new-bass-figure figure event context)
+ (let* ((fig (ly:music-property event 'figure))
+ (fig-markup (if (number? figure)
+ (markup #:number (number->string figure 10))
+ #f
+ ))
+ (alt (ly:music-property event 'alteration))
+ (alt-markup
+ (if (number? alt)
+ (markup
+ #:general-align Y DOWN #:smaller #:smaller
+ (alteration->text-accidental-markup alt))
+
+ #f))
+ (alt-dir (ly:context-property context 'figuredBassAlterationDirection))
+ )
+
+ (if (and (not fig-markup) alt-markup)
+ (begin
+ (set! fig-markup (markup #:left-align #:pad-around 0.3 alt-markup))
+ (set! alt-markup #f)))
+
+
+ ;; hmm, how to get figures centered between note, and
+ ;; lone accidentals too?
+
+ ;; (if (markup? fig-markup)
+ ;; (set!
+ ;; fig-markup (markup #:translate (cons 1.0 0)
+ ;; #:hcenter fig-markup)))
+
+ (if alt-markup
+ (set! fig-markup
+ (markup #:put-adjacent
+ fig-markup X
+ (if (number? alt-dir)
+ alt-dir
+ LEFT)
+ #:pad-x 0.2 alt-markup
+ )))
+
+ (if (markup? fig-markup)
+ fig-markup
+ empty-markup)))
+
projects / lilypond.git / commitdiff