Documentation/snippets/new/scheme-engraver-ambitus.ly

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