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