5 lsrtags = "contexts-and-engravers"
8 texidoc = "This example demonstrates how the ambitus engraver may be
9 defined on the user side, with a Scheme engraver.
11 This is basically a rewrite in Scheme of the code from
12 @file{lily/ambitus-engraver.cc}.
15 doctitle = "Defining an engraver in Scheme: ambitus engraver"
18 #(use-modules (oop goops))
23 #(define (ly:event::in-event-class event class-name)
24 (memq class-name (ly:make-event-class (ly:event-property event 'class))))
26 #(define (ly:separation-item::add-conditional-item grob grob-item)
27 (ly:pointer-group-interface::add-grob grob 'conditional-elements grob-item))
29 #(define (ly:accidental-placement::accidental-pitch accidental-grob)
30 (ly:event-property (ly:grob-property (ly:grob-parent accidental-grob Y) 'cause)
33 #(define (ly:accidental-placement::add-accidental grob accidental-grob)
34 (let ((pitch (ly:accidental-placement::accidental-pitch accidental-grob)))
35 (set! (ly:grob-parent accidental-grob X) grob)
36 (set! (ly:grob-property accidental-grob 'X-offset)
37 ly:grob::x-parent-positioning)
38 (let* ((accidentals (ly:grob-object grob 'accidental-grobs))
39 (handle (assq (ly:pitch-notename pitch) accidentals))
40 (entry (if handle (cdr handle) '())))
41 (set! (ly:grob-object grob 'accidental-grobs)
42 (assq-set! accidentals (ly:pitch-notename pitch) (cons accidental-grob entry))))))
45 %%% Ambitus data structure
47 #(define-class <ambitus> ()
48 (ambitus-line #:accessor ambitus-line)
49 (ambitus-group #:accessor ambitus-group)
50 (ambitus-up-note #:getter ambitus-up-note
51 #:init-form (make <ambitus-note>))
52 (ambitus-down-note #:getter ambitus-down-note
53 #:init-form (make <ambitus-note>))
54 (is-typeset #:accessor ambitus-is-typeset
56 (start-c0 #:accessor ambitus-start-c0
58 (start-key-sig #:accessor ambitus-start-key-sig
61 #(define-method (ambitus-note (ambitus <ambitus>) direction)
63 (ambitus-up-note ambitus)
64 (ambitus-down-note ambitus)))
66 #(define-accessor ambitus-head)
67 #(define-method (ambitus-head (ambitus <ambitus>) direction)
68 (ambitus-note-head (ambitus-note ambitus direction)))
69 #(define-method ((setter ambitus-head) (ambitus <ambitus>) direction head)
70 (set! (ambitus-note-head (ambitus-note ambitus direction)) head))
72 #(define-accessor ambitus-accidental)
73 #(define-method (ambitus-accidental (ambitus <ambitus>) direction)
74 (ambitus-note-accidental (ambitus-note ambitus direction)))
75 #(define-method ((setter ambitus-accidental) (ambitus <ambitus>) direction accidental)
76 (set! (ambitus-note-accidental (ambitus-note ambitus direction)) accidental))
78 #(define-accessor ambitus-cause)
79 #(define-method (ambitus-cause (ambitus <ambitus>) direction)
80 (ambitus-note-cause (ambitus-note ambitus direction)))
81 #(define-method ((setter ambitus-cause) (ambitus <ambitus>) direction cause)
82 (set! (ambitus-note-cause (ambitus-note ambitus direction)) cause))
84 #(define-accessor ambitus-pitch)
85 #(define-method (ambitus-pitch (ambitus <ambitus>) direction)
86 (ambitus-note-pitch (ambitus-note ambitus direction)))
87 #(define-method ((setter ambitus-pitch) (ambitus <ambitus>) direction pitch)
88 (set! (ambitus-note-pitch (ambitus-note ambitus direction)) pitch))
90 #(define-class <ambitus-note> ()
91 (head #:accessor ambitus-note-head
93 (accidental #:accessor ambitus-note-accidental
95 (cause #:accessor ambitus-note-cause
97 (pitch #:accessor ambitus-note-pitch
101 %%% Ambitus engraving logics
103 #(define (make-ambitus translator)
104 (let ((ambitus (make <ambitus>)))
105 (set! (ambitus-line ambitus) (ly:engraver-make-grob translator 'AmbitusLine '()))
106 (set! (ambitus-group ambitus) (ly:engraver-make-grob translator 'Ambitus '()))
107 (for-each (lambda (direction)
108 (let ((head (ly:engraver-make-grob translator 'AmbitusNoteHead '()))
109 (accidental (ly:engraver-make-grob translator 'AmbitusAccidental '()))
110 (group (ambitus-group ambitus)))
111 (set! (ly:grob-parent accidental Y) head)
112 (set! (ly:grob-object head 'accidental-grob) accidental)
113 (ly:axis-group-interface::add-element group head)
114 (ly:axis-group-interface::add-element group accidental)
115 (set! (ambitus-head ambitus direction) head)
116 (set! (ambitus-accidental ambitus direction) accidental)))
118 (set! (ly:grob-parent (ambitus-line ambitus) X) (ambitus-head ambitus DOWN))
119 (ly:axis-group-interface::add-element (ambitus-group ambitus) (ambitus-line ambitus))
120 (set! (ambitus-is-typeset ambitus) #f)
123 #(define-method (typeset-ambitus (ambitus <ambitus>) translator)
124 (if (not (ambitus-is-typeset ambitus))
126 (set! (ambitus-start-c0 ambitus)
127 (ly:context-property (ly:translator-context translator)
130 (set! (ambitus-start-key-sig ambitus)
131 (ly:context-property (ly:translator-context translator)
133 (set! (ambitus-is-typeset ambitus) #t))))
135 #(define-method (update-ambitus-notes (ambitus <ambitus>) note-grob)
136 (let ((note-event (ly:grob-property note-grob 'cause)))
137 (if (ly:event::in-event-class note-event 'note-event)
138 (let ((pitch (ly:event-property note-event 'pitch)))
139 (if (or (not (ambitus-pitch ambitus DOWN))
140 (ly:pitch<? pitch (ambitus-pitch ambitus DOWN)))
141 (begin ;; update down pitch
142 (set! (ambitus-pitch ambitus DOWN) pitch)
143 (set! (ambitus-cause ambitus DOWN) note-event)))
144 (if (or (not (ambitus-pitch ambitus UP))
145 (ly:pitch<? (ambitus-pitch ambitus UP) pitch))
146 (begin ;; update up pitch
147 (set! (ambitus-pitch ambitus UP) pitch)
148 (set! (ambitus-cause ambitus UP) note-event)))))))
150 #(define-method (finalize-ambitus (ambitus <ambitus>) translator)
151 (if (and (ambitus-pitch ambitus UP) (ambitus-pitch ambitus DOWN))
152 (let ((accidental-placement (ly:engraver-make-grob translator
154 (ambitus-accidental ambitus DOWN))))
155 (for-each (lambda (direction)
156 (let ((pitch (ambitus-pitch ambitus direction)))
157 (set! (ly:grob-property (ambitus-head ambitus direction) 'cause)
158 (ambitus-cause ambitus direction))
159 (set! (ly:grob-property (ambitus-head ambitus direction) 'staff-position)
160 (+ (ambitus-start-c0 ambitus)
161 (ly:pitch-steps pitch)))
162 (let* ((handle (or (assoc (cons (ly:pitch-octave pitch)
163 (ly:pitch-notename pitch))
164 (ambitus-start-key-sig ambitus))
165 (assoc (ly:pitch-notename pitch)
166 (ambitus-start-key-sig ambitus))))
167 (sig-alter (if handle (cdr handle) 0)))
168 (cond ((= (ly:pitch-alteration pitch) sig-alter)
169 (ly:grob-suicide! (ambitus-accidental ambitus direction))
170 (set! (ly:grob-object (ambitus-head ambitus direction)
174 (set! (ly:grob-property (ambitus-accidental ambitus direction)
176 (ly:pitch-alteration pitch)))))
177 (ly:separation-item::add-conditional-item (ambitus-head ambitus direction)
178 accidental-placement)
179 (ly:accidental-placement::add-accidental accidental-placement
180 (ambitus-accidental ambitus direction))
181 (ly:pointer-group-interface::add-grob (ambitus-line ambitus)
183 (ambitus-head ambitus direction))))
185 (ly:axis-group-interface::add-element (ambitus-group ambitus) accidental-placement))
186 (begin ;; no pitch ==> suicide all grobs
187 (for-each (lambda (direction)
188 (ly:grob-suicide! (ambitus-accidental ambitus direction))
189 (ly:grob-suicide! (ambitus-head ambitus direction)))
191 (ly:grob-suicide! ambitus-line))))
194 %%% Ambitus engraver definition
196 #(define ambitus-engraver
199 `((process-music . ,(lambda (translator)
201 (set! ambitus (make-ambitus translator)))))
202 (stop-translation-timestep . ,(lambda (translator)
204 (typeset-ambitus ambitus translator))))
206 (note-head-interface . ,(lambda (engraver grob source-engraver)
208 (update-ambitus-notes ambitus grob)))))
209 (finalize . ,(lambda (translator)
211 (finalize-ambitus ambitus translator))))))))
219 \new Staff { c'4 des' e' fis' gis' }
220 \new Staff { \clef "bass" c4 des ~ des ees b, }
222 \layout { \context { \Staff \consists #ambitus-engraver } }