Moves stem-length to C++.

Makes Kievan notation more modular.

8 files changed, 199 insertions, 185 deletions

diff --git a/input/regression/kievan-notation.ly b/input/regression/kievan-notation.ly
new file mode 100644
index 0000000000..fe78032044
--- /dev/null
+++ b/input/regression/kievan-notation.ly
@@ -0,0 +1,19 @@
+\version "2.17.4"
+
+\header {
+  texidoc = "LilyPond typesets Kievan notation.
+"
+}
+
+\score {
+  <<
+    \new KievanVoice = "melody" \transpose c c' {
+      \cadenzaOn
+        c4 c8 c8[ d8] c4 c2 b,\longa
+	\bar "k"
+    }
+    \new Lyrics \lyricsto "melody" {
+      Го -- спо -- ди по -- ми -- луй.
+    }
+  >>
+}
diff --git a/input/regression/note-head-style.ly b/input/regression/note-head-style.ly
index b60b2e4600..987b312feb 100644
--- a/input/regression/note-head-style.ly
+++ b/input/regression/note-head-style.ly
@@ -16,94 +16,67 @@ dimensions.
   ragged-right = ##t
 }
 
-pattern = <<
-  \new Voice {
+pattern =
+#(define-music-function (parser location name style) (markup? ly:context-mod?)
+#{ <<
+  s1^#name
+  \new Voice \with #style {
     \override Stem.direction = #UP
     e'4 e'2. e'1 e'\breve*1/2 e'\longa*1/4
   }
-  \new Voice {
+  \new Voice \with #style {
     \override Stem.direction = #DOWN
     g4 g2. g1 g\breve*1/2 g\longa*1/4
   }
->>
+>> #})
 
+patternStyle =
+#(define-music-function (parser location style) (symbol?)
+  #{
+     \pattern #(symbol->string style) \with {
+       \override NoteHead.style = #style
+     }
+  #})
 
 \transpose c c {
   \clef C
 
-  \override Staff.NoteHead.style = #'default
-  s1*0^\markup { "default" }
-  \pattern
-
-  \override Staff.NoteHead.style = #'altdefault
-  s1*0^\markup { "altdefault" }
-  \pattern
+  \patternStyle default
+  \patternStyle altdefault
 
   \break
 
-  \override Staff.NoteHead.style = #'baroque
-  s1*0^\markup { "baroque" }
-  \pattern
-
-  \override Staff.NoteHead.style = #'neomensural
-  s1*0^\markup { "neomensural" }
-  \pattern
+  \patternStyle baroque
+  \patternStyle neomensural
 
   \break
 
-  \override Staff.NoteHead.style = #'mensural
-  s1*0^\markup { "mensural" }
-  \pattern
-
-  \override Staff.NoteHead.style = #'petrucci
-  s1*0^\markup { "petrucci" }
-  \pattern
+  \patternStyle mensural
+  \patternStyle petrucci
 
   \break
 
-  \override Staff.NoteHead.style = #'harmonic
-  s1*0^\markup { "harmonic" }
-  \pattern
-
-  \override Staff.NoteHead.style = #'harmonic-black
-  s1*0^\markup { "harmonic-black" }
-  \pattern
+  \patternStyle harmonic
+  \patternStyle harmonic-black
 
   \break
 
-  \override Staff.NoteHead.style = #'harmonic-mixed
-  s1*0^\markup { "harmonic-mixed" }
-  \pattern
-
-  \override Staff.NoteHead.style = #'diamond
-  s1*0^\markup { "diamond" }
-  \pattern
+  \patternStyle harmonic-mixed
+  \patternStyle diamond
 
   \break
 
-  \override Staff.NoteHead.style = #'cross
-  s1*0^\markup { "cross" }
-  \pattern
-
-  \override Staff.NoteHead.style = #'xcircle
-  s1*0^\markup { "xcircle" }
-  \pattern
+  \patternStyle cross
+  \patternStyle xcircle
 
   \break
 
-  \override Staff.NoteHead.style = #'triangle
-  s1*0^\markup { "triangle" }
-  \pattern
-
-  \override Staff.NoteHead.style = #'slash
-  s1*0^\markup { "slash" }
-  \pattern
+  \patternStyle triangle
+  \patternStyle slash
 
   \break
 
-  \override Staff.NoteHead.style = #'kievan
-  s1*0^\markup { "kievan" }
-  \pattern
+  \pattern "kievan" \with { \kievanOn }
 
 }
 
diff --git a/lily/include/stem.hh b/lily/include/stem.hh
index de1b7d6c9a..101c00341a 100644
--- a/lily/include/stem.hh
+++ b/lily/include/stem.hh
@@ -67,6 +67,8 @@ public:
   DECLARE_SCHEME_CALLBACK (offset_callback, (SCM element));
   DECLARE_SCHEME_CALLBACK (calc_direction, (SCM));
   DECLARE_SCHEME_CALLBACK (calc_beaming, (SCM));
+  DECLARE_SCHEME_CALLBACK (calc_length, (SCM));
+  DECLARE_SCHEME_CALLBACK (pure_calc_length, (SCM, SCM, SCM));
   DECLARE_SCHEME_CALLBACK (calc_stem_begin_position, (SCM));
   DECLARE_SCHEME_CALLBACK (pure_calc_stem_begin_position, (SCM, SCM, SCM));
   DECLARE_SCHEME_CALLBACK (calc_stem_end_position, (SCM));
diff --git a/lily/stem.cc b/lily/stem.cc
index 4d5b7746b5..5f072fac6a 100644
--- a/lily/stem.cc
+++ b/lily/stem.cc
@@ -289,9 +289,7 @@ Stem::is_normal_stem (Grob *me)
   if (!head_count (me))
     return false;
 
-  extract_grob_set (me, "note-heads", heads);
-  SCM style = heads[0]->get_property ("style");
-  return style != ly_symbol2scm ("kievan") && scm_to_int (me->get_property ("duration-log")) >= 1;
+  return scm_to_int (me->get_property ("duration-log")) >= 1;
 }
 
 MAKE_SCHEME_CALLBACK (Stem, pure_height, 3)
@@ -805,6 +803,33 @@ Stem::internal_calc_stem_begin_position (Grob *me, bool calc_beam)
   return pos;
 }
 
+
+MAKE_SCHEME_CALLBACK (Stem, pure_calc_length, 3);
+SCM
+Stem::pure_calc_length (SCM smob, SCM /*start*/, SCM /*end*/)
+{
+  Grob *me = unsmob_grob (smob);
+  Real beg = robust_scm2double (me->get_pure_property ("stem-begin-position", 0, INT_MAX), 0.0);
+  Real res = fabs (internal_calc_stem_end_position (me, false) - beg);
+  return scm_from_double (res);
+}
+
+MAKE_SCHEME_CALLBACK (Stem, calc_length, 1);
+SCM
+Stem::calc_length (SCM smob)
+{
+  Grob *me = unsmob_grob (smob);
+  if (unsmob_grob (me->get_object ("beam")))
+    {
+      me->programming_error ("ly:stem::calc-length called but will not be used for beamed stem.");
+      return scm_from_double (0.0);
+    }
+
+  Real beg = robust_scm2double (me->get_property ("stem-begin-position"), 0.0);
+  Real res = fabs (internal_calc_stem_end_position (me, true) - beg);
+  return scm_from_double (res);
+}
+
 bool
 Stem::is_valid_stem (Grob *me)
 {
diff --git a/ly/engraver-init.ly b/ly/engraver-init.ly
index 16913705ca..5698011076 100644
--- a/ly/engraver-init.ly
+++ b/ly/engraver-init.ly
@@ -1143,10 +1143,17 @@ accommodated for typesetting a piece in Kievan style."
 
  %% Set glyph styles.
  \override NoteHead.style = #'kievan
+ \override Stem.X-offset = #stem::kievan-offset-callback
+ \override Stem.stencil = ##f
+ \override Flag.stencil = ##f
  \override Rest.style = #'mensural
  \override Accidental.glyph-name-alist = #alteration-kievan-glyph-name-alist
  \override Dots.style = #'kievan
  \override Slur.stencil = ##f
+ \override Stem.length = #0.0
+ \override Beam.positions = #beam::get-kievan-positions
+ \override Beam.quantized-positions = #beam::get-kievan-quantized-positions
+ \override NoteHead.duration-log = #note-head::calc-kievan-duration-log
 
  %% There are beams in Kievan notation, but they are invoked manually
  autoBeaming = ##f
diff --git a/ly/property-init.ly b/ly/property-init.ly
index 81ef69d3ef..7bd237b333 100644
--- a/ly/property-init.ly
+++ b/ly/property-init.ly
@@ -298,6 +298,35 @@ improvisationOff = {
   \revert AccidentalCautionary.stencil
 }
 
+%% kievan
+kievanOn = {
+ \override NoteHead.style = #'kievan
+ \override Stem.X-offset = #stem::kievan-offset-callback
+ \override Stem.stencil = ##f
+ \override Flag.stencil = ##f
+ \override Rest.style = #'mensural
+ \override Accidental.glyph-name-alist = #alteration-kievan-glyph-name-alist
+ \override Dots.style = #'kievan
+ \override Slur.stencil = ##f
+ \override Stem.length = #0.0
+ \override Beam.positions = #beam::get-kievan-positions
+ \override Beam.quantized-positions = #beam::get-kievan-quantized-positions
+ \override NoteHead.duration-log = #note-head::calc-kievan-duration-log
+}
+kievanOff = {
+ \revert NoteHead.style
+ \revert Stem.X-offset
+ \revert Stem.stencil
+ \revert Rest.style
+ \revert Accidental.glyph-name-alist
+ \revert Dots.style
+ \revert Slur.stencil
+ \revert Flag.stencil
+ \revert Stem.length
+ \revert Beam.positions
+ \revert Beam.quantized-positions
+ \revert NoteHead.duration-log
+}
 
 %% merging
 
diff --git a/scm/define-grobs.scm b/scm/define-grobs.scm
index 68d1fcdafd..85b4e78867 100644
--- a/scm/define-grobs.scm
+++ b/scm/define-grobs.scm
@@ -394,12 +394,12 @@
 	(beam-gap . ,ly:beam::calc-beam-gap)
 	(minimum-length . ,ly:beam::calc-minimum-length)
 	(neutral-direction . ,DOWN)
-	(positions . ,beam::get-positions)
+	(positions . ,beam::place-broken-parts-individually)
 	(springs-and-rods . ,ly:beam::calc-springs-and-rods)
 	(X-positions . ,ly:beam::calc-x-positions)
 
 	;; this is a hack to set stem lengths, if positions is set.
-	(quantized-positions . ,beam::get-quantized-positions)
+	(quantized-positions . ,ly:beam::set-stem-lengths)
 
 	(shorten . ,ly:beam::calc-stem-shorten)
 	(vertical-skylines . ,ly:grob::vertical-skylines-from-stencil)
@@ -2025,7 +2025,7 @@
 
 	(direction . ,ly:stem::calc-direction)
 	(duration-log . ,stem::calc-duration-log)
-        (length . ,stem::length)
+        (length . ,ly:stem::calc-length)
 	(neutral-direction . ,DOWN)
 	(positioning-done . ,ly:stem::calc-positioning-done)
 	(stem-info . ,ly:stem::calc-stem-info)
@@ -2786,7 +2786,7 @@
     (,ly:slur::outside-slur-callback . ,ly:slur::pure-outside-slur-callback)
     (,ly:stem::calc-stem-begin-position . ,ly:stem::pure-calc-stem-begin-position)
     (,ly:stem::calc-stem-end-position . ,ly:stem::pure-calc-stem-end-position)
-    (,stem::length . ,stem::pure-length)
+    (,ly:stem::calc-length . ,ly:stem::pure-calc-length)
     (,ly:stem::height . ,ly:stem::pure-height)
     (,ly:stem-tremolo::calc-y-offset . ,ly:stem-tremolo::pure-calc-y-offset)
     (,ly:system::height . ,ly:system::calc-pure-height)))
diff --git a/scm/output-lib.scm b/scm/output-lib.scm
index 8f81340e6d..c6ed83e6e0 100644
--- a/scm/output-lib.scm
+++ b/scm/output-lib.scm
@@ -61,92 +61,80 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; beam slope
 
+;; even though kievan noteheads do not have stems, their
+;; invisible stems help with beam placement
+;; this assures that invisible stems for kievan notes are aligned
+;; to the center of kievan noteheads. that is thus where the beams'
+;; x extrema will fall
+(define-public (stem::kievan-offset-callback grob)
+  (let* ((note-heads (ly:grob-object grob 'note-heads))
+         (note-heads-grobs (if (not (null? note-heads))
+                               (ly:grob-array->list note-heads)
+                               '()))
+         (first-note-head (if (not (null? note-heads-grobs))
+                              (car note-heads-grobs)
+                              '()))
+         (note-head-w (if (not (null? first-note-head))
+                          (ly:grob-extent first-note-head first-note-head X)
+                          '(0 . 0))))
+    (interval-center note-head-w)))
+
+
 ;; sets position of beams for Kievan notation
-(define-public (beam::get-positions grob)
-    (let* ((stems (ly:grob-object grob 'stems))
-           (stems-grobs (if (not (null? stems))
-                            (ly:grob-array->list stems)
-                            '()))
-           (first-stem (if (not (null? stems-grobs))
-			   (car stems-grobs)
-			   '()))
-           (note-heads (if (not (null? first-stem))
-			   (ly:grob-object first-stem 'note-heads)
-			   '()))
-           (note-heads-grobs (if (not (null? note-heads))
-				 (ly:grob-array->list note-heads)
-				 '()))
-           (first-note-head (if (not (null? note-heads-grobs))
-				(car note-heads-grobs)
-				'()))
-           (style (if (not (null? first-note-head))
-		      (ly:grob-property first-note-head 'style)
-		      '())))
-          (if (and (symbol? style) (string-match "kievan*" (symbol->string style)))
-              (let* ((next-stem (cadr stems-grobs))
-                     (next-note-heads (if (not (null? next-stem))
-					  (ly:grob-object next-stem 'note-heads)
-					  '()))
-                     (next-note-heads-grobs (if (not (null? next-note-heads))
-						(ly:grob-array->list next-note-heads)
-						'()))
-                     (next-note-head (if (not (null? next-note-heads-grobs))
-					 (car next-note-heads-grobs)
-					 '()))
-                     (left-pos (ly:grob-property first-note-head 'Y-offset))
-                     (right-pos (ly:grob-property next-note-head 'Y-offset))
-                     (direction (ly:grob-property grob 'direction))
-                     (left-height (if (= direction DOWN)
-				      (+ (car (ly:grob::stencil-height first-note-head)) 0.75)
-                                      (- (cdr (ly:grob::stencil-height first-note-head)) 0.75)))
-                     (right-height (if (= direction DOWN)
-				       (+ (car (ly:grob::stencil-height next-note-head)) 0.75)
-                                       (- (cdr (ly:grob::stencil-height next-note-head)) 0.75))))
-                    (cons (+ left-pos left-height) (+ right-pos right-height)))
-              (beam::place-broken-parts-individually grob))))
-
-(define-public (beam::get-quantized-positions grob)
-    (let* ((stems (ly:grob-object grob 'stems))
-           (stems-grobs (if (not (null? stems))
-                            (ly:grob-array->list stems)
-                            '()))
-           (first-stem (if (not (null? stems-grobs))
-			   (car stems-grobs)
-			   '()))
-           (note-heads (if (not (null? first-stem))
-			   (ly:grob-object first-stem 'note-heads)
-			   '()))
-           (note-heads-grobs (if (not (null? note-heads))
-				 (ly:grob-array->list note-heads)
-				 '()))
-           (first-note-head (if (not (null? note-heads-grobs))
-				(car note-heads-grobs)
-				'()))
-           (style (if (not (null? first-note-head))
-		      (ly:grob-property first-note-head 'style)
-		      '())))
-          (if (and (symbol? style) (string-match "kievan*" (symbol->string style)))
-              (let* ((next-stem (cadr stems-grobs))
-                     (next-note-heads (if (not (null? next-stem))
-					  (ly:grob-object next-stem 'note-heads)
-					  '()))
-                     (next-note-heads-grobs (if (not (null? next-note-heads))
-						(ly:grob-array->list next-note-heads)
-						'()))
-                     (next-note-head (if (not (null? next-note-heads-grobs))
-					 (car next-note-heads-grobs)
-					 '()))
-                     (left-pos (ly:grob-property first-note-head 'Y-offset))
-                     (right-pos (ly:grob-property next-note-head 'Y-offset))
-                     (direction (ly:grob-property grob 'direction))
-                     (left-height (if (= direction DOWN)
-				      (+ (car (ly:grob::stencil-height first-note-head)) 0.75)
-                                      (- (cdr (ly:grob::stencil-height first-note-head)) 0.75)))
-                     (right-height (if (= direction DOWN)
-				       (+ (car (ly:grob::stencil-height next-note-head)) 0.75)
-                                       (- (cdr (ly:grob::stencil-height next-note-head)) 0.75))))
-                    (cons (+ left-pos left-height) (+ right-pos right-height)))
-              (ly:beam::set-stem-lengths grob))))
+(define-public (beam::get-kievan-positions grob)
+  (let* ((stems (ly:grob-object grob 'stems))
+         (stems-grobs (if (not (null? stems))
+                          (ly:grob-array->list stems)
+                          '()))
+         (first-stem (if (not (null? stems-grobs))
+                         (car stems-grobs)
+                         '()))
+         (note-heads (if (not (null? first-stem))
+                         (ly:grob-object first-stem 'note-heads)
+                         '()))
+         (note-heads-grobs (if (not (null? note-heads))
+                               (ly:grob-array->list note-heads)
+                               '()))
+         (first-note-head (if (not (null? note-heads-grobs))
+                              (car note-heads-grobs)
+                              '()))
+         (next-stem (if (not (null? stems))
+                        (cadr stems-grobs)
+                        '()))
+         (next-note-heads (if (not (null? next-stem))
+                              (ly:grob-object next-stem 'note-heads)
+                              '()))
+         (next-note-heads-grobs (if (not (null? next-note-heads))
+                                    (ly:grob-array->list next-note-heads)
+                                    '()))
+         (next-note-head (if (not (null? next-note-heads-grobs))
+                             (car next-note-heads-grobs)
+                             '()))
+         (left-pos (ly:grob-property first-note-head 'Y-offset))
+         (right-pos (ly:grob-property next-note-head 'Y-offset))
+         (direction (ly:grob-property grob 'direction))
+         (first-nh-height (ly:grob::stencil-height first-note-head))
+         (next-nh-height (ly:grob::stencil-height next-note-head))
+         (left-height (if (= direction DOWN)
+                          (+ (car first-nh-height) 0.75)
+                          (- (cdr first-nh-height) 0.75)))
+         (right-height (if (= direction DOWN)
+                           (+ (car next-nh-height) 0.75)
+                           (- (cdr next-nh-height) 0.75))))
+    (cons (+ left-pos left-height) (+ right-pos right-height))))
+
+(define-public (beam::get-kievan-quantized-positions grob)
+  (let* ((pos (ly:grob-property grob 'positions))
+         (stems (ly:grob-object grob 'stems))
+         (stems-grobs (if (not (null? stems))
+                          (ly:grob-array->list stems)
+                          '())))
+    (for-each
+      (lambda (g)
+        (ly:grob-set-property! g 'stem-begin-position 0)
+        (ly:grob-set-property! g 'length 0))
+      stems-grobs)
+    pos))
 
 ;; calculates each slope of a broken beam individually
 (define-public (beam::place-broken-parts-individually grob)
@@ -203,34 +191,6 @@
   (ly:duration-log
    (ly:event-property (event-cause grob) 'duration)))
 
-(define-public (stem::length grob)
-  (let* ((ss (ly:staff-symbol-staff-space grob))
-         (beg (ly:grob-property grob 'stem-begin-position))
-         (beam (ly:grob-object grob 'beam))
-         (note-heads (ly:grob-object grob 'note-heads))
-         (note-heads-grobs (if (not (null? note-heads))
-			       (ly:grob-array->list note-heads)
-			       '()))
-         (first-note-head (if (not (null? note-heads-grobs))
-			      (car note-heads-grobs)
-			      '()))
-         (style (if (not (null? first-note-head))
-                    (ly:grob-property first-note-head 'style)
-		    '())))
-    (cond
-      ((and (symbol? style) (string-match "kievan*" (symbol->string style))) 0.0)
-      ((null? beam) (abs (- (ly:stem::calc-stem-end-position grob) beg)))
-      (else
-        (begin
-          (ly:programming-error
-            "stem::length called but will not be used for beamed stem.")
-          0.0)))))
-
-(define-public (stem::pure-length grob beg end)
-  (let* ((ss (ly:staff-symbol-staff-space grob))
-         (beg (ly:grob-pure-property grob 'stem-begin-position 0 1000)))
-    (abs (- (ly:stem::pure-calc-stem-end-position grob 0 2147483646) beg))))
-
 (define (stem-stub::do-calculations grob)
   (and (ly:grob-property (ly:grob-parent grob X) 'cross-staff)
        (not (ly:grob-property (ly:grob-parent grob X) 'transparent))))
@@ -258,16 +218,15 @@
         (if (interval-empty? (interval-intersection stem_ph my_ph)) #f (coord-translate stem_ph dist)))
       #f))
 
-;; FIXME: NEED TO FIND A BETTER WAY TO HANDLE KIEVAN NOTATION
+(define-public (note-head::calc-kievan-duration-log grob)
+  (min 3
+       (ly:duration-log
+         (ly:event-property (event-cause grob) 'duration))))
+
 (define-public (note-head::calc-duration-log grob)
-  (let ((style (ly:grob-property grob 'style)))
-    (if (and (symbol? style) (string-match "kievan*" (symbol->string style)))
-      (min 3
-        (ly:duration-log
-	(ly:event-property (event-cause grob) 'duration)))
-      (min 2
-	(ly:duration-log
-	(ly:event-property (event-cause grob) 'duration))))))
+  (min 2
+       (ly:duration-log
+         (ly:event-property (event-cause grob) 'duration))))
 
 (define-public (dots::calc-dot-count grob)
   (ly:duration-dot-count