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

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