Instanciable scheme engravers

A scheme engraver definition may be a one argument procedure,
taking the context where it is defined as an argument, and
evaluating to an a-list scheme engraver definition.
This allows to define instance slots for a scheme engraver.

This patch also defines some scheme callbacks for grob related
functions, and add an example snippet showing how an existing
C++ engraver may be defined in Scheme: the ambitus engraver.

8 files changed, 352 insertions, 1 deletions

diff --git a/Documentation/snippets/new/scheme-engraver-ambitus.ly b/Documentation/snippets/new/scheme-engraver-ambitus.ly
new file mode 100644
index 0000000000..2a382e63fa
--- /dev/null
+++ b/Documentation/snippets/new/scheme-engraver-ambitus.ly
@@ -0,0 +1,223 @@
+\version "2.13.15"
+
+\header {
+
+  lsrtags = "contexts-and-engravers"
+  
+  
+  texidoc = "This example demonstrates how the ambitus engraver may be
+  defined on the user side, with a Scheme engraver.
+
+  This is basically a rewrite in Scheme of the code from
+  @file{lily/ambitus-engraver.cc}.
+"
+
+  doctitle = "Defining an engraver in Scheme: ambitus engraver"
+}
+
+#(use-modules (oop goops))
+
+%%%
+%%% Grob utilities
+%%%
+#(define (ly:event::in-event-class event class-name)
+   (memq class-name (ly:make-event-class (ly:event-property event 'class))))
+
+#(define (ly:separation-item::add-conditional-item grob grob-item)
+   (ly:pointer-group-interface::add-grob grob 'conditional-elements grob-item))
+
+#(define (ly:accidental-placement::accidental-pitch accidental-grob)
+   (ly:event-property (ly:grob-property (ly:grob-parent accidental-grob Y) 'cause)
+                      'pitch))
+
+#(define (ly:accidental-placement::add-accidental grob accidental-grob)
+   (let ((pitch (ly:accidental-placement::accidental-pitch accidental-grob)))
+     (set! (ly:grob-parent accidental-grob X) grob)
+     (set! (ly:grob-property accidental-grob 'X-offset)
+           ly:grob::x-parent-positioning)
+     (let* ((accidentals (ly:grob-object grob 'accidental-grobs))
+            (handle (assq (ly:pitch-notename pitch) accidentals))
+            (entry (if handle (cdr handle) '())))
+       (set! (ly:grob-object grob 'accidental-grobs)
+             (assq-set! accidentals (ly:pitch-notename pitch) (cons accidental-grob entry))))))
+
+%%%
+%%% Ambitus data structure
+%%%
+#(define-class <ambitus> ()
+   (ambitus-line #:accessor ambitus-line)
+   (ambitus-group #:accessor ambitus-group)
+   (ambitus-up-note #:getter ambitus-up-note
+                    #:init-form (make <ambitus-note>))
+   (ambitus-down-note #:getter ambitus-down-note
+                      #:init-form (make <ambitus-note>))
+   (is-typeset #:accessor ambitus-is-typeset
+               #:init-value #f)
+   (start-c0 #:accessor ambitus-start-c0
+             #:init-value #f)
+   (start-key-sig #:accessor ambitus-start-key-sig
+                  #:init-value '()))
+
+#(define-method (ambitus-note (ambitus <ambitus>) direction)
+   (if (= direction UP)
+       (ambitus-up-note ambitus)
+       (ambitus-down-note ambitus)))
+
+#(define-accessor ambitus-head)
+#(define-method (ambitus-head (ambitus <ambitus>) direction)
+   (ambitus-note-head (ambitus-note ambitus direction)))
+#(define-method ((setter ambitus-head) (ambitus <ambitus>) direction head)
+   (set! (ambitus-note-head (ambitus-note ambitus direction)) head))
+
+#(define-accessor ambitus-accidental)
+#(define-method (ambitus-accidental (ambitus <ambitus>) direction)
+   (ambitus-note-accidental (ambitus-note ambitus direction)))
+#(define-method ((setter ambitus-accidental) (ambitus <ambitus>) direction accidental)
+   (set! (ambitus-note-accidental (ambitus-note ambitus direction)) accidental))
+
+#(define-accessor ambitus-cause)
+#(define-method (ambitus-cause (ambitus <ambitus>) direction)
+   (ambitus-note-cause (ambitus-note ambitus direction)))
+#(define-method ((setter ambitus-cause) (ambitus <ambitus>) direction cause)
+   (set! (ambitus-note-cause (ambitus-note ambitus direction)) cause))
+
+#(define-accessor ambitus-pitch)
+#(define-method (ambitus-pitch (ambitus <ambitus>) direction)
+   (ambitus-note-pitch (ambitus-note ambitus direction)))
+#(define-method ((setter ambitus-pitch) (ambitus <ambitus>) direction pitch)
+   (set! (ambitus-note-pitch (ambitus-note ambitus direction)) pitch))
+
+#(define-class <ambitus-note> ()
+   (head #:accessor ambitus-note-head
+         #:init-value #f)
+   (accidental #:accessor ambitus-note-accidental
+               #:init-value #f)
+   (cause #:accessor ambitus-note-cause
+          #:init-value #f)
+   (pitch #:accessor ambitus-note-pitch
+          #:init-value #f))
+
+%%%
+%%% Ambitus engraving logics
+%%%
+#(define (make-ambitus translator)
+   (let ((ambitus (make <ambitus>)))
+     (set! (ambitus-line ambitus) (ly:engraver-make-grob translator 'AmbitusLine '()))
+     (set! (ambitus-group ambitus) (ly:engraver-make-grob translator 'Ambitus '()))
+     (for-each (lambda (direction)
+                 (let ((head (ly:engraver-make-grob translator 'AmbitusNoteHead '()))
+                       (accidental (ly:engraver-make-grob translator 'AmbitusAccidental '()))
+                       (group (ambitus-group ambitus)))
+                   (set! (ly:grob-parent accidental Y) head)
+                   (set! (ly:grob-object head 'accidental-grob) accidental)
+                   (ly:axis-group-interface::add-element group head)
+                   (ly:axis-group-interface::add-element group accidental)
+                   (set! (ambitus-head ambitus direction) head)
+                   (set! (ambitus-accidental ambitus direction) accidental)))
+               (list DOWN UP))
+     (set! (ly:grob-parent (ambitus-line ambitus) X) (ambitus-head ambitus DOWN))
+     (ly:axis-group-interface::add-element (ambitus-group ambitus) (ambitus-line ambitus))
+     (set! (ambitus-is-typeset ambitus) #f)
+     ambitus))
+
+#(define-method (typeset-ambitus (ambitus <ambitus>) translator)
+   (if (not (ambitus-is-typeset ambitus))
+       (begin
+         (set! (ambitus-start-c0 ambitus)
+               (ly:context-property (ly:translator-context translator)
+                                    'middleCPosition
+                                    0))
+         (set! (ambitus-start-key-sig ambitus)
+               (ly:context-property (ly:translator-context translator)
+                                                              'keySignature))
+         (set! (ambitus-is-typeset ambitus) #t))))
+
+#(define-method (update-ambitus-notes (ambitus <ambitus>) note-grob)
+   (let ((note-event (ly:grob-property note-grob 'cause)))
+     (if (ly:event::in-event-class note-event 'note-event)
+         (let ((pitch (ly:event-property note-event 'pitch)))
+           (if (or (not (ambitus-pitch ambitus DOWN))
+                   (ly:pitch<? pitch (ambitus-pitch ambitus DOWN)))
+               (begin ;; update down pitch
+                 (set! (ambitus-pitch ambitus DOWN) pitch)
+                 (set! (ambitus-cause ambitus DOWN) note-event)))
+           (if (or (not (ambitus-pitch ambitus UP))
+                   (ly:pitch<? (ambitus-pitch ambitus UP) pitch))
+               (begin ;; update up pitch
+                 (set! (ambitus-pitch ambitus UP) pitch)
+                 (set! (ambitus-cause ambitus UP) note-event)))))))
+
+#(define-method (finalize-ambitus (ambitus <ambitus>) translator)
+   (if (and (ambitus-pitch ambitus UP) (ambitus-pitch ambitus DOWN))
+       (let ((accidental-placement (ly:engraver-make-grob translator
+                                                          'AccidentalPlacement
+                                                          (ambitus-accidental ambitus DOWN))))
+         (for-each (lambda (direction)
+                     (let ((pitch (ambitus-pitch ambitus direction)))
+                       (set! (ly:grob-property (ambitus-head ambitus direction) 'cause)
+                             (ambitus-cause ambitus direction))
+                       (set! (ly:grob-property (ambitus-head ambitus direction) 'staff-position)
+                             (+ (ambitus-start-c0 ambitus)
+                                (ly:pitch-steps pitch)))
+                       (let* ((handle (or (assoc (cons (ly:pitch-octave pitch)
+                                                       (ly:pitch-notename pitch))
+                                                 (ambitus-start-key-sig ambitus))
+                                          (assoc (ly:pitch-notename pitch)
+                                                 (ambitus-start-key-sig ambitus))))
+                              (sig-alter (if handle (cdr handle) 0)))
+                         (cond ((= (ly:pitch-alteration pitch) sig-alter)
+                                (ly:grob-suicide! (ambitus-accidental ambitus direction))
+                                (set! (ly:grob-object (ambitus-head ambitus direction)
+                                                      'accidental-grob)
+                                      '()))
+                               (else
+                                (set! (ly:grob-property (ambitus-accidental ambitus direction)
+                                                        'alteration)
+                                      (ly:pitch-alteration pitch)))))
+                       (ly:separation-item::add-conditional-item (ambitus-head ambitus direction)
+                                                                 accidental-placement)
+                       (ly:accidental-placement::add-accidental accidental-placement
+                                                                (ambitus-accidental ambitus direction))
+                       (ly:pointer-group-interface::add-grob (ambitus-line ambitus)
+                                                             'note-heads
+                                                             (ambitus-head ambitus direction))))
+                   (list DOWN UP))
+         (ly:axis-group-interface::add-element (ambitus-group ambitus) accidental-placement))
+       (begin ;; no pitch ==> suicide all grobs
+         (for-each (lambda (direction)
+                     (ly:grob-suicide! (ambitus-accidental ambitus direction))
+                     (ly:grob-suicide! (ambitus-head ambitus direction)))
+                   (list DOWN UP))
+         (ly:grob-suicide! ambitus-line))))
+
+%%%
+%%% Ambitus engraver definition
+%%%
+#(define ambitus-engraver
+   (lambda (context)
+     (let ((ambitus #f))
+       `((process-music . ,(lambda (translator)
+                             (if (not ambitus)
+                                 (set! ambitus (make-ambitus translator)))))
+         (stop-translation-timestep . ,(lambda (translator)
+                                         (if ambitus
+                                             (typeset-ambitus ambitus translator))))
+         (acknowledgers
+          (note-head-interface . ,(lambda (engraver grob source-engraver)
+                                    (if ambitus
+                                        (update-ambitus-notes ambitus grob)))))
+         (finalize . ,(lambda (translator)
+                        (if ambitus
+                            (finalize-ambitus ambitus translator))))))))
+
+%%%
+%%% Example
+%%%
+
+\score {
+  \new StaffGroup <<
+    \new Staff { c'4 des' e' fis' gis' }
+    \new Staff { \clef "bass" c4 des ~ des ees b, }
+  >>
+  \layout { \context { \Staff \consists #ambitus-engraver } }
+}
diff --git a/input/regression/scheme-engraver-instance.ly b/input/regression/scheme-engraver-instance.ly
new file mode 100644
index 0000000000..4393881b7c
--- /dev/null
+++ b/input/regression/scheme-engraver-instance.ly
@@ -0,0 +1,36 @@
+\header {
+
+  texidoc = "Scheme engravers may be instantiated, with
+  instance-scoped slots, by defining a 1 argument procedure which
+  shall return the engraver definition as an alist, with the private
+  slots defined in a closure.  The argument procedure argument is the
+  context where the engraver is instantiated."
+
+}
+
+\version "2.13.15"
+
+\layout {
+  \context {
+    \Voice
+    \consists
+    #(let ((instance-counter 0))
+       (lambda (context)
+         (set! instance-counter (1+ instance-counter))
+         (let ((instance-id instance-counter)
+               (private-note-counter 0))
+           `((listeners
+              (note-event
+               . ,(lambda (engraver event)
+                    (set! private-note-counter (1+ private-note-counter))
+                    (let ((text (ly:engraver-make-grob engraver 'TextScript event)))
+                      (ly:grob-set-property! text 'text
+                                             (format "~a.~a" instance-id
+                                                     private-note-counter))))))))))
+  }
+}
+
+<<
+  \relative c'' { c4 d e f }
+  \\ \relative c' { c4 d e f }
+>>
\ No newline at end of file
diff --git a/lily/axis-group-interface-scheme.cc b/lily/axis-group-interface-scheme.cc
index 3bba3e80c6..37a7ed3238 100644
--- a/lily/axis-group-interface-scheme.cc
+++ b/lily/axis-group-interface-scheme.cc
@@ -46,3 +46,13 @@ LY_DEFINE (ly_relative_group_extent, "ly:relative-group-extent",
   return ly_interval2scm (ext);
 }
 
+LY_DEFINE (ly_axis_group_interface__add_element, "ly:axis-group-interface::add-element",
+	   2, 0, 0, (SCM grob, SCM grob_element),
+	   "Set @var{grob} the parent of @var{grob-element} on all axes of"
+	   "@var{grob}.")
+{
+  LY_ASSERT_SMOB (Grob, grob, 1);
+  LY_ASSERT_SMOB (Grob, grob_element, 2);
+  Axis_group_interface::add_element (unsmob_grob (grob), unsmob_grob (grob_element));
+  return SCM_UNSPECIFIED;
+}
diff --git a/lily/engraver.cc b/lily/engraver.cc
index 4e0ea65433..38b43dc098 100644
--- a/lily/engraver.cc
+++ b/lily/engraver.cc
@@ -191,7 +191,7 @@ unsmob_engraver (SCM eng)
 bool
 ly_is_grob_cause (SCM obj)
 {
-  return unsmob_grob (obj) || unsmob_stream_event (obj);
+  return unsmob_grob (obj) || unsmob_stream_event (obj) || (obj == SCM_EOL);
 }
 
 #include "translator.icc"
diff --git a/lily/grob-scheme.cc b/lily/grob-scheme.cc
index bfe79da7c0..fca9b57ac4 100644
--- a/lily/grob-scheme.cc
+++ b/lily/grob-scheme.cc
@@ -124,6 +124,18 @@ LY_DEFINE (ly_grob_object, "ly:grob-object",
 }
 
 
+LY_DEFINE (ly_grob_set_object_x, "ly:grob-set-object!",
+	   3, 0, 0, (SCM grob, SCM sym, SCM val),
+	   "Set @var{sym} in grob @var{grob} to value @var{val}.")
+{
+  Grob *sc = unsmob_grob (grob);
+ 
+  LY_ASSERT_SMOB (Grob, grob, 1);
+  LY_ASSERT_TYPE (ly_is_symbol, sym, 2);
+
+  sc->set_object (sym, val);
+  return SCM_UNSPECIFIED;
+}
 
 /* TODO: make difference between scaled and unscalead variable in
    calling (i.e different funcs.) */
@@ -246,6 +258,22 @@ LY_DEFINE (ly_grob_parent, "ly:grob-parent",
   return par ? par->self_scm () : SCM_EOL;
 }
 
+LY_DEFINE (ly_grob_set_parent_x, "ly:grob-set-parent!",
+	   3, 0, 0, (SCM grob, SCM axis, SCM parent_grob),
+	   "Set @var{parent_grob} the parent of grob @var{grob} in axis @var{axis}.")
+{
+  Grob *gr = unsmob_grob (grob);
+  Grob *parent = unsmob_grob (parent_grob);
+
+  LY_ASSERT_SMOB (Grob, grob, 1);
+  LY_ASSERT_TYPE (is_axis, axis, 2);
+  LY_ASSERT_SMOB (Grob, parent_grob, 3);
+
+  Axis a = Axis (scm_to_int (axis));
+  gr->set_parent (parent, a);
+  return SCM_UNSPECIFIED;
+}
+
 LY_DEFINE (ly_grob_properties, "ly:grob-properties",
 	   1, 0, 0, (SCM grob),
 	   "Get the mutable properties of @var{grob}.")
diff --git a/lily/pointer-group-interface-scheme.cc b/lily/pointer-group-interface-scheme.cc
new file mode 100644
index 0000000000..5dff2aa6c6
--- /dev/null
+++ b/lily/pointer-group-interface-scheme.cc
@@ -0,0 +1,36 @@
+/*
+  This file is part of LilyPond, the GNU music typesetter.
+
+  Copyright (C) 2010 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+  LilyPond is free software: you can redistribute it and/or modify
+  it under the terms of the GNU General Public License as published by
+  the Free Software Foundation, either version 3 of the License, or
+  (at your option) any later version.
+
+  LilyPond is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+  GNU General Public License for more details.
+
+  You should have received a copy of the GNU General Public License
+  along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
+*/
+
+#include "pointer-group-interface.hh"
+#include "grob.hh"
+
+LY_DEFINE (ly_pointer_group_interface__add_grob, "ly:pointer-group-interface::add-grob",
+	   3, 0, 0, (SCM grob, SCM sym, SCM grob_element),
+	   "Add @var{grob-element} to @var{grob}'s @var{sym} grob array.")
+{
+  LY_ASSERT_TYPE (unsmob_grob, grob, 1);
+  LY_ASSERT_TYPE (ly_is_symbol, sym, 2);
+  LY_ASSERT_TYPE (unsmob_grob, grob_element, 3);
+
+  Pointer_group_interface::add_grob (unsmob_grob (grob),
+				     sym,
+				     unsmob_grob (grob_element));
+  return SCM_UNSPECIFIED;
+}
+
diff --git a/lily/translator-group.cc b/lily/translator-group.cc
index 44b4e1fe0a..dc2b772428 100644
--- a/lily/translator-group.cc
+++ b/lily/translator-group.cc
@@ -167,6 +167,16 @@ Translator_group::create_child_translator (SCM sev)
 	  instance = type->clone ();
 	  dynamic_cast<Scheme_engraver*> (instance)->init_from_scheme (definition);
 	}
+      else if (ly_is_procedure (definition))
+	{
+	  // `definition' is a procedure, which takes the context as
+	  // an argument and evaluates to an a-list scheme engraver
+	  // definition.
+	  SCM def = scm_call_1 (definition, cs);
+	  type = get_translator (ly_symbol2scm ("Scheme_engraver"));
+	  instance = type->clone ();
+	  dynamic_cast<Scheme_engraver*> (instance)->init_from_scheme (def);
+	}
 	 
       if (!type)
 	warning (_f ("cannot find: `%s'", ly_symbol2string (scm_car (s)).c_str ()));
diff --git a/scm/music-functions.scm b/scm/music-functions.scm
index 9001907868..2db08bd4a1 100644
--- a/scm/music-functions.scm
+++ b/scm/music-functions.scm
@@ -36,6 +36,14 @@
   (make-procedure-with-setter ly:grob-property
 			      ly:grob-set-property!))
 
+(define-public ly:grob-object
+  (make-procedure-with-setter ly:grob-object
+			      ly:grob-set-object!))
+
+(define-public ly:grob-parent
+  (make-procedure-with-setter ly:grob-parent
+			      ly:grob-set-parent!))
+
 (define-public ly:prob-property
   (make-procedure-with-setter ly:prob-property
 			      ly:prob-set-property!))