Documentation/snippets/new/defining-an-engraver-in-scheme-ambitus-engraver.ly

   1 \version "2.14.0"
   2
   3 \header {
   4
   5   lsrtags = "contexts-and-engravers"
   6
   7
   8   texidoc = "This example demonstrates how the ambitus engraver may be
   9   defined on the user side, with a Scheme engraver.
  10
  11   This is basically a rewrite in Scheme of the code from
  12   @file{lily/ambitus-engraver.cc}.
  13 "
  14
  15   doctitle = "Defining an engraver in Scheme: ambitus engraver"
  16 }
  17
  18 #(use-modules (oop goops))
  19
  20 %%%
  21 %%% Grob utilities
  22 %%%
  23 %%% These are literal rewrites of some C++ methods used by the ambitus engraver.
  24 #(define (ly:event::in-event-class event class-name)
  25    "Check if @var{event} the given class.
  26 Rewrite of @code{Stream_event::internal_in_event_class} from @file{lily/stream-event.cc}."
  27    (memq class-name (ly:make-event-class (ly:event-property event 'class))))
  28
  29 #(define (ly:separation-item::add-conditional-item grob grob-item)
  30    "Add @var{grob-item} to the array of conditional elements of @var{grob}.
  31 Rewrite of @code{Separation_item::add_conditional_item} from @file{lily/separation-item.cc}."
  32    (ly:pointer-group-interface::add-grob grob 'conditional-elements grob-item))
  33
  34 #(define (ly:accidental-placement::accidental-pitch accidental-grob)
  35    "Get the pitch from the grob cause of @var{accidental-grob}.
  36 Rewrite of @code{accidental_pitch} from @file{lily/accidental-placement.cc}."
  37    (ly:event-property (ly:grob-property (ly:grob-parent accidental-grob Y) 'cause)
  38                       'pitch))
  39
  40 #(define (ly:accidental-placement::add-accidental grob accidental-grob)
  41    "Add @var{accidental-grob}, an @code{Accidental} grob, to the
  42 list of the accidental grobs of @var{grob}, an @code{AccidentalPlacement}
  43 grob.
  44 Rewrite of @code{Accidental_placement::add_accidental} from @file{lily/accidental-placement.cc}."
  45    (let ((pitch (ly:accidental-placement::accidental-pitch accidental-grob)))
  46      (set! (ly:grob-parent accidental-grob X) grob)
  47      (set! (ly:grob-property accidental-grob 'X-offset)
  48            ly:grob::x-parent-positioning)
  49      (let* ((accidentals (ly:grob-object grob 'accidental-grobs))
  50             (handle (assq (ly:pitch-notename pitch) accidentals))
  51             (entry (if handle (cdr handle) '())))
  52        (set! (ly:grob-object grob 'accidental-grobs)
  53              (assq-set! accidentals
  54                         (ly:pitch-notename pitch)
  55                         (cons accidental-grob entry))))))
  56
  57 %%%
  58 %%% Ambitus data structure
  59 %%%
  60
  61 %%% The <ambitus> class holds the various grobs that are created
  62 %%% to print an ambitus:
  63 %%% - ambitus-group: the grob that groups all the components of an ambitus
  64 %%% (Ambitus grob);
  65 %%% - ambitus-line: the vertical line between the upper and lower ambitus
  66 %%% notes (AmbitusLine grob);
  67 %%% - ambitus-up-note and ambitus-down-note: the note head and accidental
  68 %%% for the lower and upper note of the ambitus (see <ambitus-note> class
  69 %%% below).
  70 %%% The other slots define the key and clef context of the engraver:
  71 %%% - start-c0: position of middle c at the beginning of the piece.  It
  72 %%% is used to place the ambitus notes according to their pitch;
  73 %%% - start-key-sig: the key signature at the beginning of the piece.  It
  74 %%% is used to determine if accidentals shall be printed next to ambitus
  75 %%% notes.
  76
  77 #(define-class <ambitus> ()
  78    (ambitus-group #:accessor ambitus-group)
  79    (ambitus-line #:accessor ambitus-line)
  80    (ambitus-up-note #:getter ambitus-up-note
  81                     #:init-form (make <ambitus-note>))
  82    (ambitus-down-note #:getter ambitus-down-note
  83                       #:init-form (make <ambitus-note>))
  84    (start-c0 #:accessor ambitus-start-c0
  85              #:init-value #f)
  86    (start-key-sig #:accessor ambitus-start-key-sig
  87                   #:init-value '()))
  88
  89 %%% Accessor for the lower and upper note data of an ambitus
  90 #(define-method (ambitus-note (ambitus <ambitus>) direction)
  91    "If @var{direction} is @code{UP}, then return the upper ambitus note
  92 of @var{ambitus}, otherwise return the lower ambitus note."
  93    (if (= direction UP)
  94        (ambitus-up-note ambitus)
  95        (ambitus-down-note ambitus)))
  96
  97 %%% The <ambitus-note> class holds the grobs that are specific to ambitus
  98 %%% (lower and upper) notes:
  99 %%% - head: an AmbitusNoteHead grob;
 100 %%% - accidental: an AmbitusAccidental grob, to be possibly printed next
 101 %%% to the ambitus note head.
 102 %%% Moreover:
 103 %%% - pitch is the absolute pitch of the note
 104 %%% - cause is the note event that causes this ambitus note, i.e. the lower
 105 %%% or upper note of the considered music sequence.
 106
 107 #(define-class <ambitus-note> ()
 108    (head #:accessor ambitus-note-head
 109          #:init-value #f)
 110    (accidental #:accessor ambitus-note-accidental
 111                #:init-value #f)
 112    (cause #:accessor ambitus-note-cause
 113           #:init-value #f)
 114    (pitch #:accessor ambitus-note-pitch
 115           #:init-value #f))
 116
 117 %%%
 118 %%% Ambitus engraving logics
 119 %%%
 120 %%% Rewrite of the code from @file{lily/ambitus-engraver.cc}.
 121
 122 #(define (make-ambitus translator)
 123    "Build an ambitus object: initialize all the grobs and their relations.
 124
 125 The Ambitus grob contain all other grobs:
 126  Ambitus
 127   |- AmbitusLine
 128   |- AmbitusNoteHead   for upper note
 129   |- AmbitusAccidental for upper note
 130   |- AmbitusNoteHead   for lower note
 131   |- AmbitusAccidental for lower note
 132
 133 The parent of an accidental is the corresponding note head,
 134 and the accidental is set as the 'accidental-grob of the note head
 135 so that is printed by the function that prints notes."
 136    ;; make the ambitus object
 137    (let ((ambitus (make <ambitus>)))
 138      ;; build the Ambitus grob, which will contain all other grobs
 139      (set! (ambitus-group ambitus) (ly:engraver-make-grob translator 'Ambitus '()))
 140      ;; build the AmbitusLine grob (line between lower and upper note)
 141      (set! (ambitus-line ambitus) (ly:engraver-make-grob translator 'AmbitusLine '()))
 142      ;; build the upper and lower AmbitusNoteHead and AmbitusAccidental
 143      (for-each (lambda (direction)
 144                  (let ((head (ly:engraver-make-grob translator 'AmbitusNoteHead '()))
 145                        (accidental (ly:engraver-make-grob translator 'AmbitusAccidental '()))
 146                        (group (ambitus-group ambitus)))
 147                    ;; The parent of the AmbitusAccidental grob is the
 148                    ;; AmbitusNoteHead grob
 149                    (set! (ly:grob-parent accidental Y) head)
 150                    ;; The AmbitusAccidental grob is set as the accidental-grob
 151                    ;; object of the AmbitusNoteHead.  This is later used by the
 152                    ;; function that prints notes.
 153                    (set! (ly:grob-object head 'accidental-grob) accidental)
 154                    ;; both the note head and the accidental grobs are added
 155                    ;; to the main ambitus grob.
 156                    (ly:axis-group-interface::add-element group head)
 157                    (ly:axis-group-interface::add-element group accidental)
 158                    ;; the note head and the accidental grobs are added to the
 159                    ;; ambitus object
 160                    (set! (ambitus-note-head (ambitus-note ambitus direction))
 161                          head)
 162                    (set! (ambitus-note-accidental (ambitus-note ambitus direction))
 163                          accidental)))
 164                (list DOWN UP))
 165      ;; The parent of the ambitus line is the lower ambitus note head
 166      (set! (ly:grob-parent (ambitus-line ambitus) X)
 167            (ambitus-note-head (ambitus-note ambitus DOWN)))
 168      ;; the ambitus line is added to the ambitus main grob
 169      (ly:axis-group-interface::add-element (ambitus-group ambitus) (ambitus-line ambitus))
 170      ambitus))
 171
 172 #(define-method (initialize-ambitus-state (ambitus <ambitus>) translator)
 173    "Initialize the state of @var{ambitus}, by getting the starting
 174 position of middle C and key signature from @var{translator}'s context."
 175    (if (not (ambitus-start-c0 ambitus))
 176        (begin
 177          (set! (ambitus-start-c0 ambitus)
 178                (ly:context-property (ly:translator-context translator)
 179                                     'middleCPosition
 180                                     0))
 181          (set! (ambitus-start-key-sig ambitus)
 182                (ly:context-property (ly:translator-context translator)
 183                                     'keySignature)))))
 184
 185 #(define-method (update-ambitus-notes (ambitus <ambitus>) note-grob)
 186    "Update the upper and lower ambitus pithes of @var{ambitus}, using
 187 @var{note-grob}."
 188    ;; Get the event that caused the note-grob creation
 189    ;; and check that it is a note-event.
 190    (let ((note-event (ly:grob-property note-grob 'cause)))
 191      (if (ly:event::in-event-class note-event 'note-event)
 192          ;; get the pitch from the note event
 193          (let ((pitch (ly:event-property note-event 'pitch)))
 194            ;; if this pitch is lower than the current ambitus lower
 195            ;; note pitch (or it has not been initialized yet),
 196            ;; then this pitch is the new ambitus lower pitch,
 197            ;; and conversely for upper pitch.
 198            (for-each (lambda (direction pitch-compare)
 199                        (if (or (not (ambitus-note-pitch (ambitus-note ambitus direction)))
 200                                (pitch-compare pitch
 201                                               (ambitus-note-pitch (ambitus-note ambitus direction))))
 202                            (begin
 203                              (set! (ambitus-note-pitch (ambitus-note ambitus direction))
 204                                    pitch)
 205                              (set! (ambitus-note-cause (ambitus-note ambitus direction))
 206                                    note-event))))
 207                      (list DOWN UP)
 208                      (list ly:pitch<? (lambda (p1 p2)
 209                                         (ly:pitch<? p2 p1))))))))
 210
 211 #(define-method (typeset-ambitus (ambitus <ambitus>) translator)
 212    "Typeset the ambitus:
 213 - place the lower and upper ambitus notes according to their pitch and
 214   the position of the middle C;
 215 - typeset or delete the note accidentals, according to the key signature.
 216   An accidental, if it is to be printed, is added to an AccidentalPlacement
 217   grob (a grob dedicated to the placement of accidentals near a chord);
 218 - both note heads are added to the ambitus line grob, so that a line should
 219   be printed between them."
 220    ;; check if there are lower and upper pitches
 221    (if (and (ambitus-note-pitch (ambitus-note ambitus UP))
 222             (ambitus-note-pitch (ambitus-note ambitus DOWN)))
 223        ;; make an AccidentalPlacement grob, for placement of note accidentals
 224        (let ((accidental-placement (ly:engraver-make-grob
 225                                     translator
 226                                     'AccidentalPlacement
 227                                     (ambitus-note-accidental (ambitus-note ambitus DOWN)))))
 228          ;; For lower and upper ambitus notes:
 229          (for-each (lambda (direction)
 230                      (let ((pitch (ambitus-note-pitch (ambitus-note ambitus direction))))
 231                        ;; set the cause and the staff position of the ambitus note
 232                        ;; according to the associated pitch
 233                        (set! (ly:grob-property (ambitus-note-head (ambitus-note ambitus direction))
 234                                                'cause)
 235                              (ambitus-note-cause (ambitus-note ambitus direction)))
 236                        (set! (ly:grob-property (ambitus-note-head (ambitus-note ambitus direction))
 237                                                'staff-position)
 238                              (+ (ambitus-start-c0 ambitus)
 239                                 (ly:pitch-steps pitch)))
 240                        ;; determine if an accidental shall be printed for this note,
 241                        ;; according to the key signature
 242                        (let* ((handle (or (assoc (cons (ly:pitch-octave pitch)
 243                                                        (ly:pitch-notename pitch))
 244                                                  (ambitus-start-key-sig ambitus))
 245                                           (assoc (ly:pitch-notename pitch)
 246                                                  (ambitus-start-key-sig ambitus))))
 247                               (sig-alter (if handle (cdr handle) 0)))
 248                          (cond ((= (ly:pitch-alteration pitch) sig-alter)
 249                                 ;; the note alteration is in the key signature
 250                                 ;; => it does not have to be printed
 251                                 (ly:grob-suicide!
 252                                  (ambitus-note-accidental (ambitus-note ambitus direction)))
 253                                 (set! (ly:grob-object (ambitus-note-head (ambitus-note ambitus direction))
 254                                                       'accidental-grob)
 255                                       '()))
 256                                (else
 257                                 ;; otherwise, the accidental shall be printed
 258                                 (set! (ly:grob-property (ambitus-note-accidental
 259                                                          (ambitus-note ambitus direction))
 260                                                         'alteration)
 261                                       (ly:pitch-alteration pitch)))))
 262                        ;; add the AccidentalPlacement grob to the
 263                        ;; conditional items of the AmbitusNoteHead
 264                        (ly:separation-item::add-conditional-item
 265                         (ambitus-note-head (ambitus-note ambitus direction))
 266                         accidental-placement)
 267                        ;; add the AmbitusAccidental to the list of the
 268                        ;; AccidentalPlacement grob accidentals
 269                        (ly:accidental-placement::add-accidental
 270                         accidental-placement
 271                         (ambitus-note-accidental (ambitus-note ambitus direction)))
 272                        ;; add the AmbitusNoteHead grob to the AmbitusLine grob
 273                        (ly:pointer-group-interface::add-grob
 274                         (ambitus-line ambitus)
 275                         'note-heads
 276                         (ambitus-note-head (ambitus-note ambitus direction)))))
 277                    (list DOWN UP))
 278          ;; add the AccidentalPlacement grob to the main Ambitus grob
 279          (ly:axis-group-interface::add-element (ambitus-group ambitus) accidental-placement))
 280        ;; no notes ==> suicide the grobs
 281        (begin
 282          (for-each (lambda (direction)
 283                      (ly:grob-suicide! (ambitus-note-accidental (ambitus-note ambitus direction)))
 284                      (ly:grob-suicide! (ambitus-note-head (ambitus-note ambitus direction))))
 285                    (list DOWN UP))
 286          (ly:grob-suicide! ambitus-line))))
 287
 288 %%%
 289 %%% Ambitus engraver definition
 290 %%%
 291 #(define ambitus-engraver
 292    (lambda (context)
 293      (let ((ambitus #f))
 294        ;; when music is processed: make the ambitus object, if not already built
 295        `((process-music . ,(lambda (translator)
 296                              (if (not ambitus)
 297                                  (set! ambitus (make-ambitus translator)))))
 298          ;; set the ambitus clef and key signature state
 299          (stop-translation-timestep . ,(lambda (translator)
 300                                          (if ambitus
 301                                              (initialize-ambitus-state ambitus translator))))
 302          ;; when a note-head grob is built, update the ambitus notes
 303          (acknowledgers
 304           (note-head-interface . ,(lambda (engraver grob source-engraver)
 305                                     (if ambitus
 306                                         (update-ambitus-notes ambitus grob)))))
 307          ;; finally, typeset the ambitus according to its upper and lower notes
 308          ;; (if any).
 309          (finalize . ,(lambda (translator)
 310                         (if ambitus
 311                             (typeset-ambitus ambitus translator))))))))
 312
 313 %%%
 314 %%% Example
 315 %%%
 316
 317 \score {
 318   \new StaffGroup <<
 319     \new Staff { c'4 des' e' fis' gis' }
 320     \new Staff { \clef "bass" c4 des ~ des ees b, }
 321   >>
 322   \layout { \context { \Staff \consists #ambitus-engraver } }
 323 }