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

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