common/side-ornementations.ily

   1 \version "2.17.24"
   2
   3 %%%
   4 %%% Utilities for defining new grobs, grob properties and music event types
   5 %%% (there should be built-in commands to do that in LilyPond)
   6 %%%
   7 #(define (define-grob-definition grob-name grob-entry)
   8    "Define a new grob and add it to `all-grob-definitions', after
   9 scm/define-grobs.scm fashion.
  10 After grob definitions are added, use:
  11
  12 \\layout {
  13   \\context {
  14     \\Global
  15     \\grobdescriptions #all-grob-descriptions
  16   }
  17 }
  18
  19 to register them."
  20    (let* ((meta-entry   (assoc-get 'meta grob-entry))
  21           (class        (assoc-get 'class meta-entry))
  22           (ifaces-entry (assoc-get 'interfaces meta-entry)))
  23      (set-object-property! grob-name 'translation-type? list?)
  24      (set-object-property! grob-name 'is-grob? #t)
  25      (set! ifaces-entry (append (case class
  26                                   ((Item) '(item-interface))
  27                                   ((Spanner) '(spanner-interface))
  28                                   ((Paper_column) '((item-interface
  29                                                      paper-column-interface)))
  30                                   ((System) '((system-interface
  31                                                spanner-interface)))
  32                                   (else '(unknown-interface)))
  33                                 ifaces-entry))
  34      (set! ifaces-entry (uniq-list (sort ifaces-entry symbol<?)))
  35      (set! ifaces-entry (cons 'grob-interface ifaces-entry))
  36      (set! meta-entry (assoc-set! meta-entry 'name grob-name))
  37      (set! meta-entry (assoc-set! meta-entry 'interfaces
  38                                   ifaces-entry))
  39      (set! grob-entry (assoc-set! grob-entry 'meta meta-entry))
  40      (set! all-grob-descriptions
  41            (cons (cons grob-name grob-entry)
  42                  all-grob-descriptions))))
  43
  44 #(define-public (define-grob-property symbol type? description)
  45    "Define a new grob property.
  46 `symbol': the property name
  47 `type?': the type predicate for this property
  48 `description': the type documentation"
  49   (set-object-property! symbol 'backend-type? type?)
  50   (set-object-property! symbol 'backend-doc description)
  51   symbol)
  52
  53 #(define-public (define-music-type type-name properties)
  54    "Add a new music type description to `music-descriptions'
  55 and `music-name-to-property-table'."
  56    (set-object-property! type-name
  57                          'music-description
  58                          (cdr (assq 'description properties)))
  59    (let ((properties (list-copy properties)))
  60      (set! properties (assoc-set! properties 'name type-name))
  61      (set! properties (assq-remove! properties 'description))
  62      (hashq-set! music-name-to-property-table type-name properties)
  63      (set! music-descriptions
  64            (cons (cons type-name properties)
  65                  music-descriptions))))
  66
  67 %%%
  68 %%% HeadOrnementation grob type
  69 %%%
  70 #(define (head-ornementation::print me)
  71    "Prints a HeadOrnementation grob (at a note head side)"
  72    (let* ((notes (ly:grob-object me 'elements))
  73           (staff-pos (ly:grob-staff-position (ly:grob-array-ref notes 0)))
  74           (y-ref (ly:grob-common-refpoint-of-array me notes Y))
  75           (x-ref (ly:grob-common-refpoint-of-array me notes X))
  76           (x-ext (ly:relative-group-extent notes x-ref X))
  77           (y-ext (ly:relative-group-extent notes y-ref Y))
  78           (y-coord (+ (interval-center y-ext)
  79                       (if (and (eq? (ly:grob-property me 'shift-when-on-line) #t)
  80                                (memq staff-pos '(-2 0 2)))
  81                           0.5
  82                           0)))
  83           (padding (ly:grob-property me 'padding 0.1))
  84           (direction (ly:grob-property me 'direction LEFT))
  85           (text (ly:text-interface::print me))
  86           (width (/ (interval-length (ly:stencil-extent text X)) 2.0))
  87           (x-coord (if (= direction LEFT)
  88                        (- (car x-ext) width padding)
  89                        (+ (cdr x-ext) width padding))))
  90      (ly:stencil-translate
  91       text
  92       (cons
  93        (- x-coord (ly:grob-relative-coordinate me x-ref X))
  94        (- y-coord (ly:grob-relative-coordinate me y-ref Y))))))
  95
  96 %% a new grob property (used to shift an ornementation when the
  97 %% note head is on a staff line)
  98 #(define-grob-property 'shift-when-on-line boolean?
  99    "If true, then the ornementation is vertically shifted when
 100 the note head is on a staff line.")
 101
 102 %% HeadOrnemenation grob definition:
 103 %% a piece of text attached to a note head side.
 104 #(define-grob-definition
 105   'HeadOrnementation
 106   `((font-size . 0)
 107     (padding . 0.1)
 108     (shift-when-on-line . #f)
 109     (stencil . ,head-ornementation::print)
 110     (meta . ((class . Item)
 111              (interfaces . (font-interface))))))
 112
 113 \layout {
 114   \context {
 115     \Global
 116     \grobdescriptions #all-grob-descriptions
 117   }
 118 }
 119
 120 %%% Head-ornementation Engraver
 121 %%%
 122 #(define (make-head-ornementation
 123           engraver note-grob markp direction is-inside shift-on-line)
 124    "Creates a HeadOrnementation grob attached to a note head.
 125
 126 `note-grob': the note head the ornementation is attached to
 127 `markp': the ornementation markup
 128 `direction': where the ornementation should be printed (LEFT or RIGHT of the note head)
 129 `is-inside': if true, then the ornemenation is printed between accidental
 130    or dots and the note head (in this case the accidental or dots are shifted
 131    to the outside); otherwise it is printed outside dots or accidentals.
 132 `shift-on-line': if true, and when the note head is on a staff line, then the
 133    ornementation is vertically shifted."
 134    (let ((ornementation (ly:engraver-make-grob engraver
 135                                                'HeadOrnementation
 136                                                note-grob)))
 137      (set! (ly:grob-property ornementation 'direction) direction)
 138      (set! (ly:grob-property ornementation 'text) markp)
 139      (set! (ly:grob-property ornementation 'shift-when-on-line) shift-on-line)
 140      (ly:pointer-group-interface::add-grob ornementation 'elements note-grob)
 141      (set! (ly:grob-parent ornementation Y) note-grob)
 142      (set! (ly:grob-property ornementation 'font-size)
 143            (+ (ly:grob-property ornementation 'font-size 0.0)
 144            (ly:grob-property note-grob 'font-size 0.0)))
 145      (let* ((orn-stencil (ly:text-interface::print ornementation))
 146             (orn-width (interval-length (ly:stencil-extent orn-stencil X)))
 147             (note-column (ly:grob-object note-grob 'axis-group-parent-X))
 148             (accidentals (ly:note-column-accidentals note-column))
 149             (dot-column (ly:note-column-dot-column note-column)))
 150        (cond ((and (= direction LEFT) (ly:grob? accidentals) is-inside)
 151               ;; if ornementation on the left side of the note is "inside",
 152               ;; then shift the accidental to the left to make room for
 153               ;; the ornementation
 154               (set! (ly:grob-property accidentals 'padding)
 155                     (+ orn-width (* 2 (ly:grob-property ornementation 'padding)))))
 156              ((and (= direction RIGHT) (ly:grob? dot-column) is-inside)
 157               ;; if ornementation on the right side of the note is "inside",
 158               ;; then shift the dots to the right to make room for
 159               ;; the ornementation
 160               (set! (ly:grob-property dot-column 'positioning-done)
 161                     (lambda (grob)
 162                       (ly:dot-column::calc-positioning-done grob)
 163                       (ly:grob-translate-axis! grob orn-width X))))))))
 164
 165 #(define (head-ornementation-engraver-acknowledge-note-head
 166           engraver note-grob source-engraver)
 167    "Note head acknowledge method for the head ornementation engraver.
 168 When the note head event attached to the note head grob has ornementation
 169 events among its articulations, then create a HeadOrnementation grob"
 170    (let* ((note-event (ly:grob-property note-grob 'cause)))
 171      (for-each (lambda (articulation)
 172                  (if (memq 'head-ornementation-event
 173                             (ly:event-property articulation 'class))
 174                      (begin
 175                        (if (markup? (ly:event-property articulation 'text-left))
 176                            (make-head-ornementation
 177                             engraver
 178                             note-grob
 179                             (ly:event-property articulation 'text-left)
 180                             LEFT
 181                             (ly:event-property articulation 'is-inside)
 182                             (ly:event-property articulation 'shift-when-on-line)))
 183                        (if (markup? (ly:event-property articulation 'text-right))
 184                            (make-head-ornementation
 185                             engraver
 186                             note-grob
 187                             (ly:event-property articulation 'text-right)
 188                             RIGHT
 189                             (ly:event-property articulation 'is-inside)
 190                             (ly:event-property articulation 'shift-when-on-line))))))
 191                (ly:event-property note-event 'articulations))))
 192
 193 %% The head-ornementation engraver, with its note-head acknowledger
 194 %% (which creates the HeadOrnementation grobs)
 195 #(define head-ornementation-engraver
 196    `((acknowledgers
 197       (note-head-interface
 198        . ,head-ornementation-engraver-acknowledge-note-head))))
 199
 200 \layout {
 201   \context {
 202     \Score
 203     \consists #head-ornementation-engraver
 204   }
 205 }
 206
 207 %%%
 208 %%% HeadOrnementationEvent definition
 209 %%%
 210
 211 #(define-event-class 'head-ornementation-event 'music-event)
 212 %% a post script event for ornementations attached to note heads
 213 #(define-music-type 'HeadOrnementationEvent
 214    '((description . "Print an ornementation at a note head side")
 215      (types . (general-music post-event event head-ornementation-event))))
 216
 217 %%%
 218 %%% Head ornementation music functions
 219 %%%
 220
 221 %% Helper music function for defining head-ornementation events
 222 #(define (make-head-ornementation-event text-left text-right is-inside shift-on-line)
 223    "Makes a head ornementation"
 224    (make-music 'HeadOrnementationEvent
 225                'text-left text-left
 226                'text-right text-right
 227                'is-inside is-inside
 228                'shift-when-on-line shift-on-line))
 229
 230 #(define (make-left-head-ornementation-event text is-inside shift-on-line)
 231    "Makes a head ornementation"
 232    (make-head-ornementation-event text #f is-inside shift-on-line))
 233
 234 #(define (make-right-head-ornementation-event text is-inside shift-on-line)
 235    "Makes a head ornementation"
 236    (make-head-ornementation-event #f text is-inside shift-on-line))
 237
 238 %%%
 239 %%% Ornementation definitions
 240 %%%
 241
 242 %% Parenthesis before note head
 243 parb = #(make-left-head-ornementation-event
 244          (markup #:fontsize -4 #:musicglyph "accidentals.leftparen")
 245          #t #f)
 246
 247 %% Parenthesis after note head
 248 para = #(make-right-head-ornementation-event
 249          (markup #:fontsize -4 #:musicglyph "accidentals.rightparen")
 250          #t #f)
 251
 252 %% Parenthesis before and after note head
 253 parc = #(make-head-ornementation-event
 254          (markup #:fontsize -4 #:musicglyph "accidentals.leftparen")
 255          (markup #:fontsize -4 #:musicglyph "accidentals.rightparen")
 256          #t #f)
 257
 258 %% Prall after note head
 259 pralla = #(make-right-head-ornementation-event
 260            (markup #:concat (#:hspace 0.2 #:musicglyph "scripts.prall"))
 261            #t #t)
 262
 263 %% Prall before note head
 264 prallb = #(make-left-head-ornementation-event
 265            (markup #:concat (#:musicglyph "scripts.prall" #:hspace 0.2))
 266            #t #t)
 267
 268 %% ^ sign after note head
 269 circA = #(make-right-head-ornementation-event
 270           (markup #:concat (#:hspace 1 #:raise 0.5 #:musicglyph "scripts.umarcato"))
 271           #f #f)
 272