Documentation/snippets/scheme-engraver-ambitus.ly

   1 % Do not edit this file; it is automatically
   2 % generated from Documentation/snippets/new
   3 % This file is in the public domain.
   4 %% Note: this file works from version 2.13.15
   5 \version "2.13.15"
   6
   7 \header {
   8
   9   lsrtags = "contexts-and-engravers"
  10
  11
  12   texidoc = "This example demonstrates how the ambitus engraver may be
  13   defined on the user side, with a Scheme engraver.
  14
  15   This is basically a rewrite in Scheme of the code from
  16   @file{lily/ambitus-engraver.cc}.
  17 "
  18
  19   doctitle = "Defining an engraver in Scheme: ambitus engraver"
  20 } % begin verbatim
  21
  22
  23 #(use-modules (oop goops))
  24
  25 %%%
  26 %%% Grob utilities
  27 %%%
  28 #(define (ly:event::in-event-class event class-name)
  29    (memq class-name (ly:make-event-class (ly:event-property event 'class))))
  30
  31 #(define (ly:separation-item::add-conditional-item grob grob-item)
  32    (ly:pointer-group-interface::add-grob grob 'conditional-elements grob-item))
  33
  34 #(define (ly:accidental-placement::accidental-pitch accidental-grob)
  35    (ly:event-property (ly:grob-property (ly:grob-parent accidental-grob Y) 'cause)
  36                       'pitch))
  37
  38 #(define (ly:accidental-placement::add-accidental grob accidental-grob)
  39    (let ((pitch (ly:accidental-placement::accidental-pitch accidental-grob)))
  40      (set! (ly:grob-parent accidental-grob X) grob)
  41      (set! (ly:grob-property accidental-grob 'X-offset)
  42            ly:grob::x-parent-positioning)
  43      (let* ((accidentals (ly:grob-object grob 'accidental-grobs))
  44             (handle (assq (ly:pitch-notename pitch) accidentals))
  45             (entry (if handle (cdr handle) '())))
  46        (set! (ly:grob-object grob 'accidental-grobs)
  47              (assq-set! accidentals (ly:pitch-notename pitch) (cons accidental-grob entry))))))
  48
  49 %%%
  50 %%% Ambitus data structure
  51 %%%
  52 #(define-class <ambitus> ()
  53    (ambitus-line #:accessor ambitus-line)
  54    (ambitus-group #:accessor ambitus-group)
  55    (ambitus-up-note #:getter ambitus-up-note
  56                     #:init-form (make <ambitus-note>))
  57    (ambitus-down-note #:getter ambitus-down-note
  58                       #:init-form (make <ambitus-note>))
  59    (is-typeset #:accessor ambitus-is-typeset
  60                #:init-value #f)
  61    (start-c0 #:accessor ambitus-start-c0
  62              #:init-value #f)
  63    (start-key-sig #:accessor ambitus-start-key-sig
  64                   #:init-value '()))
  65
  66 #(define-method (ambitus-note (ambitus <ambitus>) direction)
  67    (if (= direction UP)
  68        (ambitus-up-note ambitus)
  69        (ambitus-down-note ambitus)))
  70
  71 #(define-accessor ambitus-head)
  72 #(define-method (ambitus-head (ambitus <ambitus>) direction)
  73    (ambitus-note-head (ambitus-note ambitus direction)))
  74 #(define-method ((setter ambitus-head) (ambitus <ambitus>) direction head)
  75    (set! (ambitus-note-head (ambitus-note ambitus direction)) head))
  76
  77 #(define-accessor ambitus-accidental)
  78 #(define-method (ambitus-accidental (ambitus <ambitus>) direction)
  79    (ambitus-note-accidental (ambitus-note ambitus direction)))
  80 #(define-method ((setter ambitus-accidental) (ambitus <ambitus>) direction accidental)
  81    (set! (ambitus-note-accidental (ambitus-note ambitus direction)) accidental))
  82
  83 #(define-accessor ambitus-cause)
  84 #(define-method (ambitus-cause (ambitus <ambitus>) direction)
  85    (ambitus-note-cause (ambitus-note ambitus direction)))
  86 #(define-method ((setter ambitus-cause) (ambitus <ambitus>) direction cause)
  87    (set! (ambitus-note-cause (ambitus-note ambitus direction)) cause))
  88
  89 #(define-accessor ambitus-pitch)
  90 #(define-method (ambitus-pitch (ambitus <ambitus>) direction)
  91    (ambitus-note-pitch (ambitus-note ambitus direction)))
  92 #(define-method ((setter ambitus-pitch) (ambitus <ambitus>) direction pitch)
  93    (set! (ambitus-note-pitch (ambitus-note ambitus direction)) pitch))
  94
  95 #(define-class <ambitus-note> ()
  96    (head #:accessor ambitus-note-head
  97          #:init-value #f)
  98    (accidental #:accessor ambitus-note-accidental
  99                #:init-value #f)
 100    (cause #:accessor ambitus-note-cause
 101           #:init-value #f)
 102    (pitch #:accessor ambitus-note-pitch
 103           #:init-value #f))
 104
 105 %%%
 106 %%% Ambitus engraving logics
 107 %%%
 108 #(define (make-ambitus translator)
 109    (let ((ambitus (make <ambitus>)))
 110      (set! (ambitus-line ambitus) (ly:engraver-make-grob translator 'AmbitusLine '()))
 111      (set! (ambitus-group ambitus) (ly:engraver-make-grob translator 'Ambitus '()))
 112      (for-each (lambda (direction)
 113                  (let ((head (ly:engraver-make-grob translator 'AmbitusNoteHead '()))
 114                        (accidental (ly:engraver-make-grob translator 'AmbitusAccidental '()))
 115                        (group (ambitus-group ambitus)))
 116                    (set! (ly:grob-parent accidental Y) head)
 117                    (set! (ly:grob-object head 'accidental-grob) accidental)
 118                    (ly:axis-group-interface::add-element group head)
 119                    (ly:axis-group-interface::add-element group accidental)
 120                    (set! (ambitus-head ambitus direction) head)
 121                    (set! (ambitus-accidental ambitus direction) accidental)))
 122                (list DOWN UP))
 123      (set! (ly:grob-parent (ambitus-line ambitus) X) (ambitus-head ambitus DOWN))
 124      (ly:axis-group-interface::add-element (ambitus-group ambitus) (ambitus-line ambitus))
 125      (set! (ambitus-is-typeset ambitus) #f)
 126      ambitus))
 127
 128 #(define-method (typeset-ambitus (ambitus <ambitus>) translator)
 129    (if (not (ambitus-is-typeset ambitus))
 130        (begin
 131          (set! (ambitus-start-c0 ambitus)
 132                (ly:context-property (ly:translator-context translator)
 133                                     'middleCPosition
 134                                     0))
 135          (set! (ambitus-start-key-sig ambitus)
 136                (ly:context-property (ly:translator-context translator)
 137                                                               'keySignature))
 138          (set! (ambitus-is-typeset ambitus) #t))))
 139
 140 #(define-method (update-ambitus-notes (ambitus <ambitus>) note-grob)
 141    (let ((note-event (ly:grob-property note-grob 'cause)))
 142      (if (ly:event::in-event-class note-event 'note-event)
 143          (let ((pitch (ly:event-property note-event 'pitch)))
 144            (if (or (not (ambitus-pitch ambitus DOWN))
 145                    (ly:pitch<? pitch (ambitus-pitch ambitus DOWN)))
 146                (begin ;; update down pitch
 147                  (set! (ambitus-pitch ambitus DOWN) pitch)
 148                  (set! (ambitus-cause ambitus DOWN) note-event)))
 149            (if (or (not (ambitus-pitch ambitus UP))
 150                    (ly:pitch<? (ambitus-pitch ambitus UP) pitch))
 151                (begin ;; update up pitch
 152                  (set! (ambitus-pitch ambitus UP) pitch)
 153                  (set! (ambitus-cause ambitus UP) note-event)))))))
 154
 155 #(define-method (finalize-ambitus (ambitus <ambitus>) translator)
 156    (if (and (ambitus-pitch ambitus UP) (ambitus-pitch ambitus DOWN))
 157        (let ((accidental-placement (ly:engraver-make-grob translator
 158                                                           'AccidentalPlacement
 159                                                           (ambitus-accidental ambitus DOWN))))
 160          (for-each (lambda (direction)
 161                      (let ((pitch (ambitus-pitch ambitus direction)))
 162                        (set! (ly:grob-property (ambitus-head ambitus direction) 'cause)
 163                              (ambitus-cause ambitus direction))
 164                        (set! (ly:grob-property (ambitus-head ambitus direction) 'staff-position)
 165                              (+ (ambitus-start-c0 ambitus)
 166                                 (ly:pitch-steps pitch)))
 167                        (let* ((handle (or (assoc (cons (ly:pitch-octave pitch)
 168                                                        (ly:pitch-notename pitch))
 169                                                  (ambitus-start-key-sig ambitus))
 170                                           (assoc (ly:pitch-notename pitch)
 171                                                  (ambitus-start-key-sig ambitus))))
 172                               (sig-alter (if handle (cdr handle) 0)))
 173                          (cond ((= (ly:pitch-alteration pitch) sig-alter)
 174                                 (ly:grob-suicide! (ambitus-accidental ambitus direction))
 175                                 (set! (ly:grob-object (ambitus-head ambitus direction)
 176                                                       'accidental-grob)
 177                                       '()))
 178                                (else
 179                                 (set! (ly:grob-property (ambitus-accidental ambitus direction)
 180                                                         'alteration)
 181                                       (ly:pitch-alteration pitch)))))
 182                        (ly:separation-item::add-conditional-item (ambitus-head ambitus direction)
 183                                                                  accidental-placement)
 184                        (ly:accidental-placement::add-accidental accidental-placement
 185                                                                 (ambitus-accidental ambitus direction))
 186                        (ly:pointer-group-interface::add-grob (ambitus-line ambitus)
 187                                                              'note-heads
 188                                                              (ambitus-head ambitus direction))))
 189                    (list DOWN UP))
 190          (ly:axis-group-interface::add-element (ambitus-group ambitus) accidental-placement))
 191        (begin ;; no pitch ==> suicide all grobs
 192          (for-each (lambda (direction)
 193                      (ly:grob-suicide! (ambitus-accidental ambitus direction))
 194                      (ly:grob-suicide! (ambitus-head ambitus direction)))
 195                    (list DOWN UP))
 196          (ly:grob-suicide! ambitus-line))))
 197
 198 %%%
 199 %%% Ambitus engraver definition
 200 %%%
 201 #(define ambitus-engraver
 202    (lambda (context)
 203      (let ((ambitus #f))
 204        `((process-music . ,(lambda (translator)
 205                              (if (not ambitus)
 206                                  (set! ambitus (make-ambitus translator)))))
 207          (stop-translation-timestep . ,(lambda (translator)
 208                                          (if ambitus
 209                                              (typeset-ambitus ambitus translator))))
 210          (acknowledgers
 211           (note-head-interface . ,(lambda (engraver grob source-engraver)
 212                                     (if ambitus
 213                                         (update-ambitus-notes ambitus grob)))))
 214          (finalize . ,(lambda (translator)
 215                         (if ambitus
 216                             (finalize-ambitus ambitus translator))))))))
 217
 218 %%%
 219 %%% Example
 220 %%%
 221
 222 \score {
 223   \new StaffGroup <<
 224     \new Staff { c'4 des' e' fis' gis' }
 225     \new Staff { \clef "bass" c4 des ~ des ees b, }
 226   >>
 227   \layout { \context { \Staff \consists #ambitus-engraver } }
 228 }