--- /dev/null
+\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 } }
+}
}
+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.) */
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}.")
--- /dev/null
+/*
+ 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;
+}
+