scm/output-lib.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2015 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;; general
  22
  23 (define-public (grob::has-interface grob iface)
  24   (memq iface (ly:grob-interfaces grob)))
  25
  26 (define-public (grob::is-live? grob)
  27   (pair? (ly:grob-basic-properties grob)))
  28
  29 (define-public (grob::name grob)
  30   "Return the name of the grob @var{grob} as a symbol."
  31   (assq-ref (ly:grob-property grob 'meta) 'name))
  32
  33 (define-public (grob::rhythmic-location grob)
  34   "Return a pair consisting of the measure number and moment within
  35    the measure of grob @var{grob}."
  36   (let* (; all grobs support either spanner- or item-interface
  37          (item (if (grob::has-interface grob 'spanner-interface)
  38                    (ly:spanner-bound grob LEFT)
  39                    grob))
  40          (col (ly:item-get-column item)))
  41     (if (ly:grob? col)
  42         (ly:grob-property col 'rhythmic-location)
  43         '())))
  44
  45 (define-public (grob::when grob)
  46   "Return the global timestep (a moment) of grob @var{grob}."
  47   (let* (; all grobs support either spanner- or item-interface
  48          (item (if (grob::has-interface grob 'spanner-interface)
  49                    (ly:spanner-bound grob LEFT)
  50                    grob))
  51          (col (ly:item-get-column item)))
  52     (if (ly:grob? col)
  53         (ly:grob-property col 'when)
  54         '())))
  55
  56 (define-public (make-stencil-boxer thickness padding callback)
  57   "Return function that adds a box around the grob passed as argument."
  58   (lambda (grob)
  59     (box-stencil (callback grob) thickness padding)))
  60
  61 (define-public (make-stencil-circler thickness padding callback)
  62   "Return function that adds a circle around the grob passed as argument."
  63   (lambda (grob)
  64     (circle-stencil (callback grob) thickness padding)))
  65
  66 (define-public (print-circled-text-callback grob)
  67   (grob-interpret-markup grob (make-circle-markup
  68                                (ly:grob-property grob 'text))))
  69
  70 (define-public (event-cause grob)
  71   (let ((cause (ly:grob-property  grob 'cause)))
  72
  73     (cond
  74      ((ly:stream-event? cause) cause)
  75      ((ly:grob? cause) (event-cause cause))
  76      (else #f))))
  77
  78 (define-public (grob-interpret-markup grob text)
  79   (let* ((layout (ly:grob-layout grob))
  80          (defs (ly:output-def-lookup layout 'text-font-defaults))
  81          (props (ly:grob-alist-chain grob defs)))
  82
  83     (ly:text-interface::interpret-markup layout props text)))
  84
  85 (define-public (grob::unpure-Y-extent-from-stencil pure-function)
  86   "The unpure height will come from a stencil whereas the pure
  87    height will come from @code{pure-function}."
  88   (ly:make-unpure-pure-container ly:grob::stencil-height pure-function))
  89
  90 (define-public grob::unpure-horizontal-skylines-from-stencil
  91   (ly:make-unpure-pure-container
  92    ly:grob::horizontal-skylines-from-stencil
  93    ly:grob::pure-simple-horizontal-skylines-from-extents))
  94
  95 (define-public grob::always-horizontal-skylines-from-stencil
  96   (ly:make-unpure-pure-container
  97    ly:grob::horizontal-skylines-from-stencil))
  98
  99 (define-public grob::unpure-vertical-skylines-from-stencil
 100   (ly:make-unpure-pure-container
 101    ly:grob::vertical-skylines-from-stencil
 102    ly:grob::pure-simple-vertical-skylines-from-extents))
 103
 104 (define-public grob::always-vertical-skylines-from-stencil
 105   (ly:make-unpure-pure-container
 106    ly:grob::vertical-skylines-from-stencil))
 107
 108 (define-public grob::always-vertical-skylines-from-element-stencils
 109   (ly:make-unpure-pure-container
 110    ly:grob::vertical-skylines-from-element-stencils
 111    ly:grob::pure-vertical-skylines-from-element-stencils))
 112
 113 (define-public grob::always-horizontal-skylines-from-element-stencils
 114   (ly:make-unpure-pure-container
 115    ly:grob::horizontal-skylines-from-element-stencils
 116    ly:grob::pure-horizontal-skylines-from-element-stencils))
 117
 118 ;; Using this as a callback for a grob's Y-extent promises
 119 ;; that the grob's stencil does not depend on line-spacing.
 120 ;; We use this promise to figure the space required by Clefs
 121 ;; and such at the note-spacing stage.
 122
 123 (define-public grob::always-Y-extent-from-stencil
 124   (ly:make-unpure-pure-container ly:grob::stencil-height))
 125
 126 (define-public (layout-line-thickness grob)
 127   "Get the line thickness of the @var{grob}'s corresponding layout."
 128   (let* ((layout (ly:grob-layout grob))
 129          (line-thickness (ly:output-def-lookup layout 'line-thickness)))
 130
 131     line-thickness))
 132
 133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 134 ;; beam slope
 135
 136 ;; even though kievan noteheads do not have stems, their
 137 ;; invisible stems help with beam placement
 138 ;; this assures that invisible stems for kievan notes are aligned
 139 ;; to the center of kievan noteheads. that is thus where the beams'
 140 ;; x extrema will fall
 141 (define-public (stem::kievan-offset-callback grob)
 142   (let* ((note-heads (ly:grob-object grob 'note-heads))
 143          (note-heads-grobs (if (not (null? note-heads))
 144                                (ly:grob-array->list note-heads)
 145                                '()))
 146          (first-note-head (if (not (null? note-heads-grobs))
 147                               (car note-heads-grobs)
 148                               '()))
 149          (note-head-w (if (not (null? first-note-head))
 150                           (ly:grob-extent first-note-head first-note-head X)
 151                           '(0 . 0))))
 152     (interval-center note-head-w)))
 153
 154
 155 ;; sets position of beams for Kievan notation
 156 (define-public (beam::get-kievan-positions grob)
 157   (let* ((stems (ly:grob-object grob 'stems))
 158          (stems-grobs (if (not (null? stems))
 159                           (ly:grob-array->list stems)
 160                           '()))
 161          (first-stem (if (not (null? stems-grobs))
 162                          (car stems-grobs)
 163                          '()))
 164          (note-heads (if (not (null? first-stem))
 165                          (ly:grob-object first-stem 'note-heads)
 166                          '()))
 167          (note-heads-grobs (if (not (null? note-heads))
 168                                (ly:grob-array->list note-heads)
 169                                '()))
 170          (first-note-head (if (not (null? note-heads-grobs))
 171                               (car note-heads-grobs)
 172                               '()))
 173          (next-stem (if (not (null? stems))
 174                         (cadr stems-grobs)
 175                         '()))
 176          (next-note-heads (if (not (null? next-stem))
 177                               (ly:grob-object next-stem 'note-heads)
 178                               '()))
 179          (next-note-heads-grobs (if (not (null? next-note-heads))
 180                                     (ly:grob-array->list next-note-heads)
 181                                     '()))
 182          (next-note-head (if (not (null? next-note-heads-grobs))
 183                              (car next-note-heads-grobs)
 184                              '()))
 185          (left-pos (ly:grob-property first-note-head 'Y-offset))
 186          (right-pos (ly:grob-property next-note-head 'Y-offset))
 187          (direction (ly:grob-property grob 'direction))
 188          (first-nh-height (ly:grob::stencil-height first-note-head))
 189          (next-nh-height (ly:grob::stencil-height next-note-head))
 190          (left-height (if (= direction DOWN)
 191                           (+ (car first-nh-height) 0.75)
 192                           (- (cdr first-nh-height) 0.75)))
 193          (right-height (if (= direction DOWN)
 194                            (+ (car next-nh-height) 0.75)
 195                            (- (cdr next-nh-height) 0.75))))
 196     (cons (+ left-pos left-height) (+ right-pos right-height))))
 197
 198 (define-public (beam::get-kievan-quantized-positions grob)
 199   (let* ((pos (ly:grob-property grob 'positions))
 200          (stems (ly:grob-object grob 'stems))
 201          (stems-grobs (if (not (null? stems))
 202                           (ly:grob-array->list stems)
 203                           '())))
 204     (for-each
 205      (lambda (g)
 206        (ly:grob-set-property! g 'stem-begin-position 0)
 207        (ly:grob-set-property! g 'length 0))
 208      stems-grobs)
 209     pos))
 210
 211 ;; calculates each slope of a broken beam individually
 212 (define-public (beam::place-broken-parts-individually grob)
 213   (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
 214
 215 ;; calculates the slope of a beam as a single unit,
 216 ;; even if it is broken.  this assures that the beam
 217 ;; will pick up where it left off after a line break
 218 (define-public (beam::align-with-broken-parts grob)
 219   (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
 220
 221 ;; uses the broken beam style from edition peters combines the
 222 ;; values of place-broken-parts-individually and align-with-broken-parts above,
 223 ;; favoring place-broken-parts-individually when the beam naturally has a steeper
 224 ;; incline and align-with-broken-parts when the beam is flat
 225 (define-public (beam::slope-like-broken-parts grob)
 226   (define (slope y x)
 227     (/ (- (cdr y) (car y)) (- (cdr x) (car x))))
 228   (let* ((quant1 (ly:beam::quanting grob '(+inf.0 . -inf.0) #t))
 229          (original (ly:grob-original grob))
 230          (siblings (if (ly:grob? original)
 231                        (ly:spanner-broken-into original)
 232                        '())))
 233     (if (null? siblings)
 234         quant1
 235         (let* ((quant2 (ly:beam::quanting grob '(+inf.0 . -inf.0) #f))
 236                (x-span (ly:grob-property grob 'X-positions))
 237                (slope1 (slope quant1 x-span))
 238                (slope2 (slope quant2 x-span))
 239                (quant2 (if (not (= (sign slope1) (sign slope2)))
 240                            '(0 . 0)
 241                            quant2))
 242                (factor (/ (atan (abs slope1)) PI-OVER-TWO))
 243                (base (cons-map
 244                       (lambda (x)
 245                         (+ (* (x quant1) (- 1 factor))
 246                            (* (x quant2) factor)))
 247                       (cons car cdr))))
 248           (ly:beam::quanting grob base #f)))))
 249
 250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 251 ;; cross-staff stuff
 252
 253 (define-public (script-or-side-position-cross-staff g)
 254   (or
 255    (ly:script-interface::calc-cross-staff g)
 256    (ly:side-position-interface::calc-cross-staff g)))
 257
 258
 259 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 260 ;; side-position stuff
 261
 262 (define-public (only-if-beamed g)
 263   (any (lambda (x) (ly:grob? (ly:grob-object x 'beam)))
 264        (ly:grob-array->list (ly:grob-object g 'side-support-elements))))
 265
 266 (define-public side-position-interface::y-aligned-side
 267   (ly:make-unpure-pure-container
 268    ly:side-position-interface::y-aligned-side
 269    ly:side-position-interface::pure-y-aligned-side))
 270
 271 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 272 ;; self-alignment stuff
 273
 274 (define-public self-alignment-interface::y-aligned-on-self
 275   (ly:make-unpure-pure-container
 276    ly:self-alignment-interface::y-aligned-on-self
 277    ly:self-alignment-interface::pure-y-aligned-on-self))
 278
 279 (define-public (self-alignment-interface::self-aligned-on-breakable grob)
 280   "Return the @code{X-offset} that places @var{grob} according to its
 281    @code{self-alignment-X} over the reference point defined by the
 282    @code{break-align-anchor-alignment} of a @code{break-aligned} item
 283    such as a @code{Clef}."
 284   (+ (ly:break-alignable-interface::self-align-callback grob)
 285      (ly:self-alignment-interface::x-aligned-on-self grob)))
 286
 287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 288 ;; staff symbol
 289
 290 (define staff-symbol-referencer::callback
 291   (ly:make-unpure-pure-container ly:staff-symbol-referencer::callback))
 292
 293 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 294 ;; note heads
 295
 296 (define-public (stem::calc-duration-log grob)
 297   (ly:duration-log
 298    (ly:event-property (event-cause grob) 'duration)))
 299
 300 (define (stem-stub::do-calculations grob)
 301   (and (ly:grob-property (ly:grob-parent grob X) 'cross-staff)
 302        (not (ly:grob-property (ly:grob-parent grob X) 'transparent))))
 303
 304 (define-public (stem-stub::pure-height grob beg end)
 305   (if (stem-stub::do-calculations grob)
 306       '(0 . 0)
 307       '(+inf.0 . -inf.0)))
 308
 309 (define-public (stem-stub::width grob)
 310   (if (stem-stub::do-calculations grob)
 311       (grob::x-parent-width grob)
 312       '(+inf.0 . -inf.0)))
 313
 314 (define-public (stem-stub::extra-spacing-height grob)
 315   (if (stem-stub::do-calculations grob)
 316       (let* ((dad (ly:grob-parent grob X))
 317              (refp (ly:grob-common-refpoint grob dad Y))
 318              (stem_ph (ly:grob-pure-height dad refp 0 INFINITY-INT))
 319              (my_ph (ly:grob-pure-height grob refp 0 INFINITY-INT))
 320              ;; only account for distance if stem is on different staff than stub
 321              (dist (if (grob::has-interface refp 'hara-kiri-group-spanner-interface)
 322                        0
 323                        (- (car my_ph) (car stem_ph)))))
 324         (if (interval-empty? (interval-intersection stem_ph my_ph)) #f (coord-translate stem_ph dist)))
 325       #f))
 326
 327 (define-public (note-head::calc-kievan-duration-log grob)
 328   (min 3
 329        (ly:duration-log
 330         (ly:event-property (event-cause grob) 'duration))))
 331
 332 (define-public (note-head::calc-duration-log grob)
 333   (min 2
 334        (ly:duration-log
 335         (ly:event-property (event-cause grob) 'duration))))
 336
 337 (define-public (dots::calc-dot-count grob)
 338   (ly:duration-dot-count
 339    (ly:event-property (event-cause grob) 'duration)))
 340
 341 (define-public (dots::calc-staff-position grob)
 342   (let* ((head (ly:grob-parent grob Y))
 343          (log (ly:grob-property head 'duration-log)))
 344
 345     (cond
 346      ((or (not (grob::has-interface head 'rest-interface))
 347           (not (integer? log))) 0)
 348      ((= log 7) 4)
 349      ((> log 4) 3)
 350      ((= log 0) -1)
 351      ((= log 1) 1)
 352      ((= log -1) 1)
 353      (else 0))))
 354
 355 ;; Kept separate from note-head::calc-glyph-name to allow use by
 356 ;; markup commands \note and \note-by-number
 357 (define-public (select-head-glyph style log)
 358   "Select a note head glyph string based on note head style @var{style}
 359 and duration-log @var{log}."
 360   (case style
 361     ;; "default" style is directly handled in note-head.cc as a
 362     ;; special case (HW says, mainly for performance reasons).
 363     ;; Therefore, style "default" does not appear in this case
 364     ;; statement.  -- jr
 365     ((xcircle) "2xcircle")
 366     ((harmonic) "0harmonic")
 367     ((harmonic-black) "2harmonic")
 368     ((harmonic-mixed) (if (<= log 1) "0harmonic"
 369                           "2harmonic"))
 370     ((baroque)
 371      ;; Oops, I actually would not call this "baroque", but, for
 372      ;; backwards compatibility to 1.4, this is supposed to take
 373      ;; brevis, longa and maxima from the neo-mensural font and all
 374      ;; other note heads from the default font.  -- jr
 375      (if (< log 0)
 376          (string-append (number->string log) "neomensural")
 377          (number->string log)))
 378     ((altdefault)
 379      ;; Like default, but brevis is drawn with double vertical lines
 380      (if (= log -1)
 381          (string-append (number->string log) "double")
 382          (number->string log)))
 383     ((mensural)
 384      (string-append (number->string log) (symbol->string style)))
 385     ((petrucci)
 386      (if (< log 0)
 387          (string-append (number->string log) "mensural")
 388          (string-append (number->string log) (symbol->string style))))
 389     ((blackpetrucci)
 390      (if (< log 0)
 391          (string-append (number->string log) "blackmensural")
 392          (string-append (number->string log) (symbol->string style))))
 393     ((semipetrucci)
 394      (if (< log 0)
 395          (string-append (number->string log) "semimensural")
 396          (string-append (number->string log) "petrucci")))
 397     ((neomensural)
 398      (string-append (number->string log) (symbol->string style)))
 399     ((kievan)
 400      (string-append (number->string log) "kievan"))
 401     (else
 402      (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style))
 403          (symbol->string style)
 404          (string-append (number->string (max 0 log))
 405                         (symbol->string style))))))
 406
 407 (define-public (note-head::calc-glyph-name grob)
 408   (let* ((style (ly:grob-property grob 'style))
 409          (log (if (string-match "kievan*" (symbol->string style))
 410                   (min 3 (ly:grob-property grob 'duration-log))
 411                   (min 2 (ly:grob-property grob 'duration-log)))))
 412     (select-head-glyph style log)))
 413
 414 (define-public (note-head::brew-ez-stencil grob)
 415   (let* ((log (ly:grob-property grob 'duration-log))
 416          (pitch (ly:event-property (event-cause grob) 'pitch))
 417          (pitch-index (ly:pitch-notename pitch))
 418          (note-names (ly:grob-property grob 'note-names))
 419          (pitch-string (if (and (vector? note-names)
 420                                 (> (vector-length note-names) pitch-index))
 421                            (vector-ref note-names pitch-index)
 422                            (string
 423                             (integer->char
 424                              (+ (modulo (+ pitch-index 2) 7)
 425                                 (char->integer #\A))))))
 426          (staff-space (ly:staff-symbol-staff-space grob))
 427          (line-thickness (ly:staff-symbol-line-thickness grob))
 428          (stem (ly:grob-object grob 'stem))
 429          (stem-thickness (* (if (ly:grob? stem)
 430                                 (ly:grob-property stem 'thickness)
 431                                 1.3)
 432                             line-thickness))
 433          (radius (/ (+ staff-space line-thickness) 2))
 434          (letter (make-center-align-markup (make-vcenter-markup pitch-string)))
 435          (filled-circle (make-draw-circle-markup radius 0 #t)))
 436
 437     (ly:stencil-translate-axis
 438      (grob-interpret-markup
 439       grob
 440       (if (>= log 2)
 441           (make-combine-markup
 442            filled-circle
 443            (make-with-color-markup white letter))
 444           (make-combine-markup
 445            (make-combine-markup
 446             filled-circle
 447             (make-with-color-markup white (make-draw-circle-markup
 448                                            (- radius stem-thickness) 0 #t)))
 449            letter)))
 450      radius X)))
 451
 452 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 453 ;; clipping
 454
 455 (define-public (make-rhythmic-location bar-num num den)
 456   (cons
 457    bar-num (ly:make-moment num den)))
 458
 459 (define-public (rhythmic-location? a)
 460   (and (pair? a)
 461        (integer? (car a))
 462        (ly:moment? (cdr a))))
 463
 464 (define-public (make-graceless-rhythmic-location loc)
 465   (make-rhythmic-location
 466    (car loc)
 467    (ly:moment-main-numerator (rhythmic-location-measure-position loc))
 468    (ly:moment-main-denominator (rhythmic-location-measure-position loc))))
 469
 470 (define-public rhythmic-location-measure-position cdr)
 471 (define-public rhythmic-location-bar-number car)
 472
 473 (define-public (rhythmic-location<? a b)
 474   (cond
 475    ((< (car a) (car b)) #t)
 476    ((> (car a) (car b)) #f)
 477    (else
 478     (ly:moment<? (cdr a) (cdr b)))))
 479
 480 (define-public (rhythmic-location<=? a b)
 481   (not (rhythmic-location<? b a)))
 482 (define-public (rhythmic-location>=? a b)
 483   (not (rhythmic-location<? a b)))
 484 (define-public (rhythmic-location>? a b)
 485   (rhythmic-location<? b a))
 486
 487 (define-public (rhythmic-location=? a b)
 488   (and (rhythmic-location<=? a b)
 489        (rhythmic-location<=? b a)))
 490
 491 (define-public (rhythmic-location->file-string a)
 492   (ly:format "~a.~a.~a"
 493              (car a)
 494              (ly:moment-main-numerator (cdr a))
 495              (ly:moment-main-denominator (cdr a))))
 496
 497 (define-public (rhythmic-location->string a)
 498   (ly:format "bar ~a ~a"
 499              (car a)
 500              (ly:moment->string (cdr a))))
 501
 502 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 503 ;; break visibility
 504
 505 (define-public all-visible             #(#t #t #t))
 506 (define-public begin-of-line-invisible #(#t #t #f))
 507 (define-public center-invisible        #(#t #f #t))
 508 (define-public end-of-line-invisible   #(#f #t #t))
 509 (define-public begin-of-line-visible   #(#f #f #t))
 510 (define-public center-visible          #(#f #t #f))
 511 (define-public end-of-line-visible     #(#t #f #f))
 512 (define-public all-invisible           #(#f #f #f))
 513
 514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 515 ;; neighbor-interface routines
 516
 517
 518 (define-public (shift-right-at-line-begin g)
 519   "Shift an item to the right, but only at the start of the line."
 520   (if (and (ly:item? g)
 521            (equal? (ly:item-break-dir g) RIGHT))
 522       (ly:grob-translate-axis! g 3.5 X)))
 523
 524 (define-public (pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line grob)
 525   (if (= 1 (ly:item-break-dir grob))
 526       (pure-from-neighbor-interface::extra-spacing-height grob)
 527       (cons -0.1 0.1)))
 528
 529 (define-public (pure-from-neighbor-interface::extra-spacing-height grob)
 530   (let* ((height (ly:grob-pure-height grob grob 0 INFINITY-INT))
 531          (from-neighbors (interval-union
 532                           height
 533                           (ly:axis-group-interface::pure-height
 534                            grob
 535                            0
 536                            INFINITY-INT))))
 537     (coord-operation - from-neighbors height)))
 538
 539 ;; If there are neighbors, we place the height at their midpoint
 540 ;; to avoid protrusion of this pure height out of the vertical
 541 ;; axis group on either side.  This will minimize the impact of the
 542 ;; grob on pure minimum translations.
 543
 544 ;; TODO - there is a double call to axis-group-interface::pure-height
 545 ;; here and then in the extra-spacing-height function above. Can/should this
 546 ;; be rolled into one?
 547 (define-public (pure-from-neighbor-interface::pure-height grob beg end)
 548   (let* ((height (ly:axis-group-interface::pure-height
 549                   grob
 550                   0
 551                   INFINITY-INT))
 552          (c (interval-center height)))
 553     (if (interval-empty? height) empty-interval (cons c c))))
 554
 555 ;; Minimizes the impact of the height on vertical spacing while allowing
 556 ;; it to appear in horizontal skylines of paper columns if necessary.
 557 (define-public pure-from-neighbor-interface::height-if-pure
 558   (ly:make-unpure-pure-container #f pure-from-neighbor-interface::pure-height))
 559
 560 (define-public (pure-from-neighbor-interface::account-for-span-bar grob)
 561   (let* ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
 562          (hsb (ly:grob-property grob 'has-span-bar))
 563          (ii (interval-intersection esh (cons -1.01 1.01))))
 564     (if (pair? hsb)
 565         (cons (car (if (and (car hsb)
 566                             (ly:grob-property grob 'allow-span-bar))
 567                        esh ii))
 568               (cdr (if (cdr hsb) esh ii)))
 569         ii)))
 570
 571 (define-public (pure-from-neighbor-interface::extra-spacing-height-including-staff grob)
 572   (let ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
 573         (to-staff (coord-operation -
 574                                    (interval-widen
 575                                     '(0 . 0)
 576                                     (ly:staff-symbol-staff-radius grob))
 577                                    (ly:grob::stencil-height grob))))
 578     (interval-union esh to-staff)))
 579
 580
 581 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 582 ;; Tuplets
 583
 584 (define-public (tuplet-number::calc-direction grob)
 585   (ly:tuplet-bracket::calc-direction (ly:grob-object grob 'bracket)))
 586
 587 (define-public (tuplet-number::calc-denominator-text grob)
 588   (number->string (ly:event-property (event-cause grob) 'denominator)))
 589
 590 (define-public (tuplet-number::calc-fraction-text grob)
 591   (let ((ev (event-cause grob)))
 592
 593     (format #f "~a:~a"
 594             (ly:event-property ev 'denominator)
 595             (ly:event-property ev 'numerator))))
 596
 597 ;; a formatter function, which is simply a wrapper around an existing
 598 ;; tuplet formatter function. It takes the value returned by the given
 599 ;; function and appends a note of given length.
 600 (define ((tuplet-number::append-note-wrapper function note) grob)
 601   (let ((txt (and function (function grob))))
 602
 603     (if txt
 604         (make-line-markup
 605          (list txt (make-fontsize-markup -5 (make-note-markup note UP))))
 606         (make-fontsize-markup -5 (make-note-markup note UP)))))
 607 (export tuplet-number::append-note-wrapper)
 608
 609 ;; Print a tuplet denominator with a different number than the one derived from
 610 ;; the actual tuplet fraction
 611 (define ((tuplet-number::non-default-tuplet-denominator-text denominator)
 612                 grob)
 613   (number->string (if denominator
 614                       denominator
 615                       (ly:event-property (event-cause grob) 'denominator))))
 616 (export tuplet-number::non-default-tuplet-denominator-text)
 617
 618 ;; Print a tuplet fraction with different numbers than the ones derived from
 619 ;; the actual tuplet fraction
 620 (define ((tuplet-number::non-default-tuplet-fraction-text
 621                  denominator numerator) grob)
 622   (let* ((ev (event-cause grob))
 623          (den (if denominator denominator (ly:event-property ev 'denominator)))
 624          (num (if numerator numerator (ly:event-property ev 'numerator))))
 625
 626     (format #f "~a:~a" den num)))
 627 (export tuplet-number::non-default-tuplet-fraction-text)
 628
 629 ;; Print a tuplet fraction with note durations appended to the numerator and the
 630 ;; denominator
 631 (define ((tuplet-number::fraction-with-notes
 632                  denominatornote numeratornote) grob)
 633   (let* ((ev (event-cause grob))
 634          (denominator (ly:event-property ev 'denominator))
 635          (numerator (ly:event-property ev 'numerator)))
 636
 637     ((tuplet-number::non-default-fraction-with-notes
 638       denominator denominatornote numerator numeratornote) grob)))
 639 (export tuplet-number::fraction-with-notes)
 640
 641 ;; Print a tuplet fraction with note durations appended to the numerator and the
 642 ;; denominator
 643 (define ((tuplet-number::non-default-fraction-with-notes
 644                  denominator denominatornote numerator numeratornote) grob)
 645   (let* ((ev (event-cause grob))
 646          (den (if denominator denominator (ly:event-property ev 'denominator)))
 647          (num (if numerator numerator (ly:event-property ev 'numerator))))
 648
 649     (make-concat-markup (list
 650                          (make-simple-markup (format #f "~a" den))
 651                          (make-fontsize-markup -5 (make-note-markup denominatornote UP))
 652                          (make-simple-markup " : ")
 653                          (make-simple-markup (format #f "~a" num))
 654                          (make-fontsize-markup -5 (make-note-markup numeratornote UP))))))
 655 (export tuplet-number::non-default-fraction-with-notes)
 656
 657
 658 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 659 ;; Color
 660
 661 (define-public (color? x)
 662   (and (list? x)
 663        (= 3 (length x))
 664        (every number? x)
 665        (every (lambda (y) (<= 0 y 1)) x)))
 666
 667 (define-public (rgb-color r g b) (list r g b))
 668
 669 ;; predefined colors
 670 (define-public black       '(0.0 0.0 0.0))
 671 (define-public white       '(1.0 1.0 1.0))
 672 (define-public red         '(1.0 0.0 0.0))
 673 (define-public green       '(0.0 1.0 0.0))
 674 (define-public blue        '(0.0 0.0 1.0))
 675 (define-public cyan        '(0.0 1.0 1.0))
 676 (define-public magenta     '(1.0 0.0 1.0))
 677 (define-public yellow      '(1.0 1.0 0.0))
 678
 679 (define-public grey        '(0.5 0.5 0.5))
 680 (define-public darkred     '(0.5 0.0 0.0))
 681 (define-public darkgreen   '(0.0 0.5 0.0))
 682 (define-public darkblue    '(0.0 0.0 0.5))
 683 (define-public darkcyan    '(0.0 0.5 0.5))
 684 (define-public darkmagenta '(0.5 0.0 0.5))
 685 (define-public darkyellow  '(0.5 0.5 0.0))
 686
 687
 688 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 689 ;; key signature
 690
 691 (define-public (key-signature-interface::alteration-positions
 692                 entry c0-position grob)
 693   (let ((step (car entry))
 694         (alter (cdr entry)))
 695     (if (pair? step)
 696         (list (+ (cdr step) (* (car step) 7) c0-position))
 697         (let* ((c-position (modulo c0-position 7))
 698                (positions
 699                 (if (< alter 0)
 700                     ;; See (flat|sharp)-positions in define-grob-properties.scm
 701                     (ly:grob-property grob 'flat-positions '(3))
 702                     (ly:grob-property grob 'sharp-positions '(3))))
 703                (p (list-ref positions
 704                             (if (< c-position (length positions))
 705                                 c-position 0)))
 706                (max-position (if (pair? p) (cdr p) p))
 707                (min-position (if (pair? p) (car p) (- max-position 6)))
 708                (first-position (+ (modulo (- (+ c-position step)
 709                                              min-position)
 710                                           7)
 711                                   min-position)))
 712           (define (prepend x l) (if (> x max-position)
 713                                     l
 714                                     (prepend (+ x 7) (cons x l))))
 715           (prepend first-position '())))))
 716
 717 (define-public (key-signature-interface::alteration-position
 718                 step alter c0-position)
 719 ;; Deprecated.  Not a documented interface, and no longer used in LilyPond,
 720 ;; but needed for a popular file, LilyJAZZ.ily for version 2.16
 721   (if (pair? step)
 722     (+ (cdr step) (* (car step) 7) c0-position)
 723     (let* ((c-pos (modulo c0-position 7))
 724            (hi (list-ref
 725                  (if (< alter 0)
 726                    '(2 3 4 2 1 2 1) ; position of highest flat
 727                    '(4 5 4 2 3 2 3)); position of highest sharp
 728                  c-pos)))
 729       (- hi (modulo (- hi (+ c-pos step)) 7)))))
 730
 731 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 732 ;; annotations
 733
 734 (define-public (numbered-footnotes int)
 735   (make-tiny-markup (number->string (+ 1 int))))
 736
 737 (define-public (symbol-footnotes int)
 738   (define (helper symbols out idx n)
 739     (if (< n 1)
 740         out
 741         (helper symbols
 742                 (string-append out (list-ref symbols idx))
 743                 idx
 744                 (- n 1))))
 745   (make-tiny-markup (helper '("*" "†" "‡" "§" "¶")
 746                             ""
 747                             (remainder int 5)
 748                             (+ 1 (quotient int 5)))))
 749
 750 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 751 ;; accidentals
 752
 753 (define-public (accidental-interface::calc-alteration grob)
 754   (ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch)))
 755
 756 (define-public (accidental-interface::glyph-name grob)
 757   (assoc-get (ly:grob-property grob 'alteration)
 758              standard-alteration-glyph-name-alist))
 759
 760 (define-public accidental-interface::height
 761   (ly:make-unpure-pure-container
 762    ly:accidental-interface::height))
 763
 764 (define-public cancellation-glyph-name-alist
 765   '((0 . "accidentals.natural")))
 766
 767 (define-public standard-alteration-glyph-name-alist
 768   '(
 769     ;; ordered for optimal performance.
 770     (0 . "accidentals.natural")
 771     (-1/2 . "accidentals.flat")
 772     (1/2 . "accidentals.sharp")
 773
 774     (1 . "accidentals.doublesharp")
 775     (-1 . "accidentals.flatflat")
 776
 777     (3/4 . "accidentals.sharp.slashslash.stemstemstem")
 778     (1/4 . "accidentals.sharp.slashslash.stem")
 779     (-1/4 . "accidentals.mirroredflat")
 780     (-3/4 . "accidentals.mirroredflat.flat")))
 781
 782 ;; FIXME: standard vs default, alteration-FOO vs FOO-alteration
 783 (define-public alteration-default-glyph-name-alist
 784   standard-alteration-glyph-name-alist)
 785
 786 (define-public makam-alteration-glyph-name-alist
 787   '((1 . "accidentals.doublesharp")
 788     (8/9 . "accidentals.sharp.slashslashslash.stemstem")
 789     (5/9 . "accidentals.sharp.slashslashslash.stem")
 790     (4/9 . "accidentals.sharp")
 791     (1/9 . "accidentals.sharp.slashslash.stem")
 792     (0 . "accidentals.natural")
 793     (-1/9 . "accidentals.mirroredflat")
 794     (-4/9 . "accidentals.flat.slash")
 795     (-5/9 . "accidentals.flat")
 796     (-8/9 . "accidentals.flat.slashslash")
 797     (-1 . "accidentals.flatflat")))
 798
 799 (define-public alteration-hufnagel-glyph-name-alist
 800   '((-1/2 . "accidentals.hufnagelM1")
 801     (0 . "accidentals.vaticana0")
 802     (1/2 . "accidentals.mensural1")))
 803
 804 (define-public alteration-medicaea-glyph-name-alist
 805   '((-1/2 . "accidentals.medicaeaM1")
 806     (0 . "accidentals.vaticana0")
 807     (1/2 . "accidentals.mensural1")))
 808
 809 (define-public alteration-vaticana-glyph-name-alist
 810   '((-1/2 . "accidentals.vaticanaM1")
 811     (0 . "accidentals.vaticana0")
 812     (1/2 . "accidentals.mensural1")))
 813
 814 (define-public alteration-mensural-glyph-name-alist
 815   '((-1/2 . "accidentals.mensuralM1")
 816     (0 . "accidentals.vaticana0")
 817     (1/2 . "accidentals.mensural1")))
 818
 819 (define-public alteration-kievan-glyph-name-alist
 820   '((-1/2 . "accidentals.kievanM1")
 821     (1/2 . "accidentals.kievan1")))
 822
 823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 824 ;; * Pitch Trill Heads
 825 ;; * Parentheses
 826
 827 (define-public (parentheses-item::calc-parenthesis-stencils grob)
 828   (let* ((font (ly:grob-default-font grob))
 829          (lp (ly:font-get-glyph font "accidentals.leftparen"))
 830          (rp (ly:font-get-glyph font "accidentals.rightparen")))
 831
 832     (list lp rp)))
 833
 834 (define-public (parentheses-item::calc-angled-bracket-stencils grob)
 835   (let* ((parent (ly:grob-parent grob Y))
 836          (y-extent (ly:grob-extent parent parent Y))
 837          (half-thickness 0.05) ; should it be a property?
 838          (width 0.5) ; should it be a property?
 839          (angularity 1.5)  ; makes angle brackets
 840          (white-padding 0.1) ; should it be a property?
 841          (lp (ly:stencil-aligned-to
 842               (ly:stencil-aligned-to
 843                (make-parenthesis-stencil y-extent
 844                                          half-thickness
 845                                          (- width)
 846                                          angularity)
 847                Y CENTER)
 848               X RIGHT))
 849          (lp-x-extent
 850           (interval-widen (ly:stencil-extent lp X) white-padding))
 851          (rp (ly:stencil-aligned-to
 852               (ly:stencil-aligned-to
 853                (make-parenthesis-stencil y-extent
 854                                          half-thickness
 855                                          width
 856                                          angularity)
 857                Y CENTER)
 858               X LEFT))
 859          (rp-x-extent
 860           (interval-widen (ly:stencil-extent rp X) white-padding)))
 861     (set! lp (ly:make-stencil (ly:stencil-expr lp)
 862                               lp-x-extent
 863                               (ly:stencil-extent lp Y)))
 864     (set! rp (ly:make-stencil (ly:stencil-expr rp)
 865                               rp-x-extent
 866                               (ly:stencil-extent rp Y)))
 867     (list (stencil-whiteout lp)
 868           (stencil-whiteout rp))))
 869
 870 (define (parenthesize-elements grob . rest)
 871   (let* ((refp (if (null? rest)
 872                    grob
 873                    (car rest)))
 874          (elts (ly:grob-object grob 'elements))
 875          (x-ext (ly:relative-group-extent elts refp X))
 876          (stencils (ly:grob-property grob 'stencils))
 877          (lp (car stencils))
 878          (rp (cadr stencils))
 879          (padding (ly:grob-property grob 'padding 0.1)))
 880
 881     (ly:stencil-add
 882      (ly:stencil-translate-axis lp (- (car x-ext) padding) X)
 883      (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X))))
 884
 885
 886 (define-public (parentheses-item::print me)
 887   (let* ((elts (ly:grob-object me 'elements))
 888          (y-ref (ly:grob-common-refpoint-of-array me elts Y))
 889          (x-ref (ly:grob-common-refpoint-of-array me elts X))
 890          (stencil (parenthesize-elements me x-ref))
 891          (elt-y-ext (ly:relative-group-extent elts y-ref Y))
 892          (y-center (interval-center elt-y-ext)))
 893
 894     (ly:stencil-translate
 895      stencil
 896      (cons
 897       (- (ly:grob-relative-coordinate me x-ref X))
 898       (- y-center (ly:grob-relative-coordinate me y-ref Y))))))
 899
 900
 901 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 902 ;; offset callbacks
 903
 904 (define-public (pure-chain-offset-callback grob start end prev-offset)
 905   "Sometimes, a chained offset callback is unpure and there is
 906    no way to write a pure function that estimates its behavior.
 907    In this case, we use a pure equivalent that will simply pass
 908    the previous calculated offset value."
 909   prev-offset)
 910
 911 (define-public (scale-by-font-size x)
 912   (ly:make-unpure-pure-container
 913     (lambda (grob)
 914       (* x (magstep (ly:grob-property grob 'font-size 0))))))
 915
 916 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 917 ;;
 918
 919 (define-public (chain-grob-member-functions grob value . funcs)
 920   (for-each
 921    (lambda (func)
 922      (set! value (func grob value)))
 923    funcs)
 924
 925   value)
 926
 927
 928 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 929 ;; falls/doits
 930
 931 (define-public (bend::print spanner)
 932   (define (close  a b)
 933     (< (abs (- a b)) 0.01))
 934
 935   (let* ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position)))
 936          (left-span (ly:spanner-bound spanner LEFT))
 937          (dots (if (and (grob::has-interface left-span 'note-head-interface)
 938                         (ly:grob? (ly:grob-object left-span 'dot)))
 939                    (ly:grob-object left-span 'dot) #f))
 940
 941          (right-span (ly:spanner-bound spanner RIGHT))
 942          (thickness (* (ly:grob-property spanner 'thickness)
 943                        (ly:output-def-lookup (ly:grob-layout spanner)
 944                                              'line-thickness)))
 945          (padding (ly:grob-property spanner 'padding 0.5))
 946          (common (ly:grob-common-refpoint right-span
 947                                           (ly:grob-common-refpoint spanner
 948                                                                    left-span X)
 949                                           X))
 950          (common-y (ly:grob-common-refpoint spanner left-span Y))
 951          (minimum-length (ly:grob-property spanner 'minimum-length 0.5))
 952
 953          (left-x (+ padding
 954                     (max
 955                      (interval-end (ly:generic-bound-extent
 956                                     left-span common))
 957                      (if
 958                       (and dots
 959                            (close
 960                             (ly:grob-relative-coordinate dots common-y Y)
 961                             (ly:grob-relative-coordinate spanner common-y Y)))
 962                       (interval-end
 963                        (ly:grob-robust-relative-extent dots common X))
 964                       (- INFINITY-INT)))))
 965          (right-x (max (- (interval-start
 966                            (ly:generic-bound-extent right-span common))
 967                           padding)
 968                        (+ left-x minimum-length)))
 969          (self-x (ly:grob-relative-coordinate spanner common X))
 970          (dx (- right-x left-x))
 971          (exp (list 'path thickness
 972                     `(quote
 973                       (rmoveto
 974                        ,(- left-x self-x) 0
 975
 976                        rcurveto
 977                        ,(/ dx 3)
 978                        0
 979                        ,dx ,(* 0.66 delta-y)
 980                        ,dx ,delta-y)))))
 981
 982     (ly:make-stencil
 983      exp
 984      (cons (- left-x self-x) (- right-x self-x))
 985      (cons (min 0 delta-y)
 986            (max 0 delta-y)))))
 987
 988
 989 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 990 ;; grace spacing
 991
 992 (define-public (grace-spacing::calc-shortest-duration grob)
 993   (let* ((cols (ly:grob-object grob 'columns))
 994          (get-difference
 995           (lambda (idx)
 996             (ly:moment-sub (ly:grob-property
 997                             (ly:grob-array-ref cols (1+ idx)) 'when)
 998                            (ly:grob-property
 999                             (ly:grob-array-ref cols idx) 'when))))
1000
1001          (moment-min (lambda (x y)
1002                        (cond
1003                         ((and x y)
1004                          (if (ly:moment<? x y)
1005                              x
1006                              y))
1007                         (x x)
1008                         (y y)))))
1009
1010     (fold moment-min #f (map get-difference
1011                              (iota (1- (ly:grob-array-length cols)))))))
1012
1013
1014 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1015 ;; fingering
1016
1017 (define-public (fingering::calc-text grob)
1018   (let ((event (event-cause grob)))
1019     (or (ly:event-property event 'text #f)
1020         (number->string (ly:event-property event 'digit) 10))))
1021
1022 (define-public (string-number::calc-text grob)
1023   (let ((event (event-cause grob)))
1024     (or (ly:event-property event 'text #f)
1025         (number-format
1026          (ly:grob-property grob 'number-type)
1027          (ly:event-property event 'string-number)))))
1028
1029 (define-public (stroke-finger::calc-text grob)
1030   (let ((event (event-cause grob)))
1031     (or (ly:event-property event 'text #f)
1032         (vector-ref (ly:grob-property grob 'digit-names)
1033                     (1- (max 1
1034                              (min 5 (ly:event-property event 'digit))))))))
1035
1036
1037 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1038 ;; dynamics
1039
1040 (define-public (hairpin::calc-grow-direction grob)
1041   (if (ly:in-event-class? (event-cause grob) 'decrescendo-event)
1042       START
1043       STOP))
1044
1045 (define-public (dynamic-text-spanner::before-line-breaking grob)
1046   "Monitor left bound of @code{DynamicTextSpanner} for absolute dynamics.
1047 If found, ensure @code{DynamicText} does not collide with spanner text by
1048 changing @code{'attach-dir} and @code{'padding}.  Reads the
1049 @code{'right-padding} property of @code{DynamicText} to fine tune space
1050 between the two text elements."
1051   (let ((left-bound (ly:spanner-bound grob LEFT)))
1052     (if (grob::has-interface left-bound 'dynamic-text-interface)
1053         (let* ((details (ly:grob-property grob 'bound-details))
1054                (left-details (ly:assoc-get 'left details))
1055                (my-padding (ly:assoc-get 'padding left-details))
1056                (script-padding (ly:grob-property left-bound 'right-padding 0)))
1057
1058           (and (number? my-padding)
1059                (ly:grob-set-nested-property! grob
1060                                              '(bound-details left attach-dir)
1061                                              RIGHT)
1062                (ly:grob-set-nested-property! grob
1063                                              '(bound-details left padding)
1064                                              (+ my-padding script-padding)))))))
1065
1066 (define ((elbowed-hairpin coords mirrored?) grob)
1067   "Create hairpin based on a list of @var{coords} in @code{(cons x y)}
1068 form.  @code{x} is the portion of the width consumed for a given line
1069 and @code{y} is the portion of the height.  For example,
1070 @code{'((0.3 . 0.7) (0.8 . 0.9) (1.0 . 1.0))} means that at the point
1071 where the hairpin has consumed 30% of its width, it must
1072 be at 70% of its height.  Once it is to 80% width, it
1073 must be at 90% height.  It finishes at
1074 100% width and 100% height.  @var{mirrored?} indicates if the hairpin
1075 is mirrored over the Y-axis or if just the upper part is drawn.
1076 Returns a function that accepts a hairpin grob as an argument
1077 and draws the stencil based on its coordinates.
1078 @lilypond[verbatim,quote]
1079 #(define simple-hairpin
1080   (elbowed-hairpin '((1.0 . 1.0)) #t))
1081
1082 \\relative c' {
1083   \\override Hairpin #'stencil = #simple-hairpin
1084   a\\p\\< a a a\\f
1085 }
1086 @end lilypond
1087 "
1088   (define (pair-to-list pair)
1089     (list (car pair) (cdr pair)))
1090   (define (normalize-coords goods x y)
1091     (map
1092      (lambda (coord)
1093        (cons (* x (car coord)) (* y (cdr coord))))
1094      goods))
1095   (define (my-c-p-s points thick decresc?)
1096     (make-connected-path-stencil
1097      points
1098      thick
1099      (if decresc? -1.0 1.0)
1100      1.0
1101      #f
1102      #f))
1103   ;; outer let to trigger suicide
1104   (let ((sten (ly:hairpin::print grob)))
1105     (if (grob::is-live? grob)
1106         (let* ((decresc? (eq? (ly:grob-property grob 'grow-direction) LEFT))
1107                (thick (ly:grob-property grob 'thickness 0.1))
1108                (thick (* thick (layout-line-thickness grob)))
1109                (xex (ly:stencil-extent sten X))
1110                (lenx (interval-length xex))
1111                (yex (ly:stencil-extent sten Y))
1112                (leny (interval-length yex))
1113                (xtrans (+ (car xex) (if decresc? lenx 0)))
1114                (ytrans (car yex))
1115                (uplist (map pair-to-list
1116                             (normalize-coords coords lenx (/ leny 2))))
1117                (downlist (map pair-to-list
1118                               (normalize-coords coords lenx (/ leny -2)))))
1119           (ly:stencil-translate
1120            (ly:stencil-add
1121             (my-c-p-s uplist thick decresc?)
1122             (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil))
1123            (cons xtrans ytrans)))
1124         '())))
1125 (export elbowed-hairpin)
1126
1127 (define-public flared-hairpin
1128   (elbowed-hairpin '((0.95 . 0.4) (1.0 . 1.0)) #t))
1129
1130 (define-public constante-hairpin
1131   (elbowed-hairpin '((1.0 . 0.0) (1.0 . 1.0)) #f))
1132
1133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1134 ;; lyrics
1135
1136 (define-public (lyric-text::print grob)
1137   "Allow interpretation of tildes as lyric tieing marks."
1138
1139   (let ((text (ly:grob-property grob 'text)))
1140
1141     (grob-interpret-markup grob (if (string? text)
1142                                     (make-tied-lyric-markup text)
1143                                     text))))
1144
1145 (define ((grob::calc-property-by-copy prop) grob)
1146   (ly:event-property (event-cause grob) prop))
1147 (export grob::calc-property-by-copy)
1148
1149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1150 ;; general inheritance
1151
1152 (define ((grob::inherit-parent-property axis property . default) grob)
1153   "@var{grob} callback generator for inheriting a @var{property} from
1154 an @var{axis} parent, defaulting to @var{default} if there is no
1155 parent or the parent has no setting."
1156   (let ((parent (ly:grob-parent grob axis)))
1157     (cond
1158      ((ly:grob? parent)
1159       (apply ly:grob-property parent property default))
1160      ((pair? default) (car default))
1161      (else '()))))
1162 (export grob::inherit-parent-property)
1163
1164 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1165 ;; fret boards
1166
1167 (define-public (fret-board::calc-stencil grob)
1168   (grob-interpret-markup
1169    grob
1170    (make-fret-diagram-verbose-markup
1171     (ly:grob-property grob 'dot-placement-list))))
1172
1173
1174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1175 ;; slurs
1176
1177 (define-public slur::height
1178   (ly:make-unpure-pure-container
1179    ly:slur::height
1180    ly:slur::pure-height))
1181
1182 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1183 ;; scripts
1184
1185 (define-public (script-interface::calc-x-offset grob)
1186   (ly:grob-property grob 'positioning-done)
1187   (let* ((shift-when-alone (ly:grob-property grob 'toward-stem-shift 0.0))
1188          (shift-in-column (ly:grob-property grob 'toward-stem-shift-in-column))
1189          (script-column (ly:grob-object grob 'script-column))
1190          (shift
1191            (if (and (ly:grob? script-column)
1192                     (number? shift-in-column)
1193                     ;; ScriptColumn can contain grobs other than Script.
1194                     ;; These should not result in a shift.
1195                     (any (lambda (s)
1196                            (and (not (eq? s grob))
1197                                 (grob::has-interface s 'script-interface)
1198                                 (not (grob::has-interface s
1199                                        'accidental-suggestion-interface))))
1200                          (ly:grob-array->list
1201                            (ly:grob-object script-column 'scripts))))
1202                shift-in-column shift-when-alone))
1203          (note-head-location
1204           (ly:self-alignment-interface::aligned-on-x-parent grob))
1205          (note-head-grob (ly:grob-parent grob X))
1206          (stem-grob (ly:grob-object note-head-grob 'stem)))
1207
1208     (+ note-head-location
1209        ;; If the script has the same direction as the stem, move the script
1210        ;; in accordance with the value of 'shift'.  Since scripts can also be
1211        ;; over skips, we need to check whether the grob has a stem at all.
1212        (if (ly:grob? stem-grob)
1213            (let ((dir1 (ly:grob-property grob 'direction))
1214                  (dir2 (ly:grob-property stem-grob 'direction)))
1215              (if (equal? dir1 dir2)
1216                  (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
1217                         (stem-location
1218                          (ly:grob-relative-coordinate stem-grob common-refp X)))
1219                    (* shift (- stem-location note-head-location)))
1220                  0.0))
1221            0.0))))
1222
1223
1224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1225 ;; instrument names
1226
1227 (define-public (system-start-text::print grob)
1228   (let* ((left-bound (ly:spanner-bound grob LEFT))
1229          (left-mom (ly:grob-property left-bound 'when))
1230          (name (if (moment<=? left-mom ZERO-MOMENT)
1231                    (ly:grob-property grob 'long-text)
1232                    (ly:grob-property grob 'text))))
1233
1234     (if (and (markup? name)
1235              (!= (ly:item-break-dir left-bound) CENTER))
1236
1237         (grob-interpret-markup grob name)
1238         (ly:grob-suicide! grob))))
1239
1240 (define-public (system-start-text::calc-x-offset grob)
1241   (let* ((left-bound (ly:spanner-bound grob LEFT))
1242          (left-mom (ly:grob-property left-bound 'when))
1243          (layout (ly:grob-layout grob))
1244          (indent (ly:output-def-lookup layout
1245                                        (if (moment<=? left-mom ZERO-MOMENT)
1246                                            'indent
1247                                            'short-indent)
1248                                        0.0))
1249          (system (ly:grob-system grob))
1250          (my-extent (ly:grob-extent grob system X))
1251          (elements (ly:grob-object system 'elements))
1252          (common (ly:grob-common-refpoint-of-array system elements X))
1253          (total-ext empty-interval)
1254          (align-x (ly:grob-property grob 'self-alignment-X 0))
1255          (padding (min 0 (- (interval-length my-extent) indent)))
1256          (right-padding (- padding
1257                            (/ (* padding (1+ align-x)) 2))))
1258
1259     ;; compensate for the variation in delimiter extents by
1260     ;; calculating an X-offset correction based on united extents
1261     ;; of all delimiters in this system
1262     (let unite-delims ((l (ly:grob-array-length elements)))
1263       (if (> l 0)
1264           (let ((elt (ly:grob-array-ref elements (1- l))))
1265
1266             (if (grob::has-interface elt 'system-start-delimiter-interface)
1267                 (let ((dims (ly:grob-extent elt common X)))
1268                   (if (interval-sane? dims)
1269                       (set! total-ext (interval-union total-ext dims)))))
1270             (unite-delims (1- l)))))
1271
1272     (+
1273      (ly:side-position-interface::x-aligned-side grob)
1274      right-padding
1275      (- (interval-length total-ext)))))
1276
1277 (define-public (system-start-text::calc-y-offset grob)
1278
1279   (define (live-elements-list me)
1280     (let ((elements (ly:grob-object me 'elements)))
1281
1282       (filter! grob::is-live?
1283                (ly:grob-array->list elements))))
1284
1285   (let* ((left-bound (ly:spanner-bound grob LEFT))
1286          (live-elts (live-elements-list grob))
1287          (system (ly:grob-system grob))
1288          (extent empty-interval))
1289
1290     (if (and (pair? live-elts)
1291              (interval-sane? (ly:grob-extent grob system Y)))
1292         (let get-extent ((lst live-elts))
1293           (if (pair? lst)
1294               (let ((axis-group (car lst)))
1295
1296                 (if (and (ly:spanner? axis-group)
1297                          (equal? (ly:spanner-bound axis-group LEFT)
1298                                  left-bound))
1299                     (set! extent (add-point extent
1300                                             (ly:grob-relative-coordinate
1301                                              axis-group system Y))))
1302                 (get-extent (cdr lst)))))
1303         ;; no live axis group(s) for this instrument name -> remove from system
1304         (ly:grob-suicide! grob))
1305
1306     (+
1307      (ly:self-alignment-interface::y-aligned-on-self grob)
1308      (interval-center extent))))
1309
1310
1311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1312 ;; axis group interface
1313
1314 (define-public axis-group-interface::height
1315   (ly:make-unpure-pure-container
1316    ly:axis-group-interface::height
1317    ly:axis-group-interface::pure-height))
1318
1319 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1320 ;; ambitus
1321
1322 ;; Calculate the gaps between ambitus heads and ends of ambitus line.
1323 ;; Start by determining desired length of the ambitus line (based on
1324 ;; length-fraction property), calc gap from that and make sure that
1325 ;; it doesn't exceed maximum allowed value.
1326
1327 (define-public (ambitus-line::calc-gap grob)
1328   (let ((heads (ly:grob-object grob 'note-heads)))
1329
1330   (if (and (ly:grob-array? heads)
1331              (= (ly:grob-array-length heads) 2))
1332       (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1333               (head-down (ly:grob-array-ref heads 0))
1334               (head-up (ly:grob-array-ref heads 1))
1335               (fraction (ly:grob-property grob 'length-fraction 0.7))
1336               (max-gap (ly:grob-property grob 'maximum-gap 0.45))
1337               ;; distance between noteheads:
1338               (distance (- (interval-start (ly:grob-extent head-up common Y))
1339                           (interval-end (ly:grob-extent head-down common Y))))
1340               (gap (* 0.5 distance (- 1 fraction))))
1341
1342          (min gap max-gap))
1343       0)))
1344
1345 ;; Print a line connecting ambitus heads:
1346
1347 (define-public (ambitus::print grob)
1348   (let ((heads (ly:grob-object grob 'note-heads)))
1349
1350     (if (and (ly:grob-array? heads)
1351              (= (ly:grob-array-length heads) 2))
1352         (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1353                (head-down (ly:grob-array-ref heads 0))
1354                (head-up (ly:grob-array-ref heads 1))
1355                ;; The value used when 'gap' property cannot be read is small
1356                ;; to make sure that ambitus of a fifth will have a visible line.
1357                (gap (ly:grob-property grob 'gap 0.25))
1358                (point-min (+ (interval-end (ly:grob-extent head-down common Y))
1359                              gap))
1360                (point-max (- (interval-start (ly:grob-extent head-up common Y))
1361                              gap)))
1362
1363           (if (< (+ point-min 0.1) point-max) ; don't print lines shorter than 0.1ss
1364               (let* ((layout (ly:grob-layout grob))
1365                      (line-thick (ly:output-def-lookup layout 'line-thickness))
1366                      (blot (ly:output-def-lookup layout 'blot-diameter))
1367                      (grob-thick (ly:grob-property grob 'thickness 2))
1368                      (width (* line-thick grob-thick))
1369                      (x-ext (symmetric-interval (/ width 2)))
1370                      (y-ext (cons point-min point-max))
1371                      (line (ly:round-filled-box x-ext y-ext blot))
1372                      (y-coord (ly:grob-relative-coordinate grob common Y)))
1373
1374                 (ly:stencil-translate-axis line (- y-coord) Y))
1375               empty-stencil))
1376         (begin
1377           (ly:grob-suicide! grob)
1378           (list)))))
1379
1380 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1381 ;;  laissez-vibrer tie
1382 ;;
1383 ;;  needed so we can make laissez-vibrer a pure print
1384 ;;
1385 (define-public (laissez-vibrer::print grob)
1386   (ly:tie::print grob))
1387
1388 (define-public (semi-tie::calc-cross-staff grob)
1389   (let* ((note-head (ly:grob-object grob 'note-head))
1390          (stem (ly:grob-object note-head 'stem)))
1391     (and (ly:grob? stem)
1392          (ly:grob-property stem 'cross-staff #f))))
1393
1394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1395 ;; volta-bracket
1396
1397 (define-public (volta-bracket-interface::pure-height grob start end)
1398   (let ((edge-height (ly:grob-property grob 'edge-height)))
1399     (if (number-pair? edge-height)
1400         (let ((smaller (min (car edge-height) (cdr edge-height)))
1401               (larger (max (car edge-height) (cdr edge-height))))
1402           (interval-union '(0 . 0) (cons smaller larger)))
1403         '(0 . 0))))
1404
1405 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1406 ;; measure counter
1407
1408 (define-public (measure-counter-stencil grob)
1409   "Print a number for a measure count.  The number is centered using
1410 the extents of @code{BreakAlignment} grobs associated with the left and
1411 right bounds of a @code{MeasureCounter} spanner.  Broken measures are
1412 numbered in parentheses."
1413   (let* ((num (markup (number->string (ly:grob-property grob 'count-from))))
1414          (orig (ly:grob-original grob))
1415          (siblings (ly:spanner-broken-into orig)) ; have we been split?
1416          (num
1417           (if (or (null? siblings)
1418                   (eq? grob (car siblings)))
1419               num
1420               (make-parenthesize-markup num)))
1421          (num (grob-interpret-markup grob num))
1422          (num (ly:stencil-aligned-to num X (ly:grob-property grob 'self-alignment-X)))
1423          (left-bound (ly:spanner-bound grob LEFT))
1424          (right-bound (ly:spanner-bound grob RIGHT))
1425          (elts-L (ly:grob-array->list (ly:grob-object left-bound 'elements)))
1426          (elts-R (ly:grob-array->list (ly:grob-object right-bound 'elements)))
1427          (break-alignment-L
1428            (filter
1429              (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
1430              elts-L))
1431          (break-alignment-R
1432            (filter
1433              (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
1434              elts-R))
1435          (refp (ly:grob-system grob))
1436          (break-alignment-L-ext (ly:grob-extent (car break-alignment-L) refp X))
1437          (break-alignment-R-ext (ly:grob-extent (car break-alignment-R) refp X))
1438          (num
1439            (ly:stencil-translate-axis
1440              num
1441              (+ (interval-length break-alignment-L-ext)
1442                 (* 0.5
1443                    (- (car break-alignment-R-ext)
1444                       (cdr break-alignment-L-ext))))
1445              X)))
1446     num))
1447
1448 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1449 ;; make-engraver helper macro
1450
1451 (defmacro-public make-engraver forms
1452   "Helper macro for creating Scheme engravers.
1453
1454 The usual form for an engraver is an association list (or alist)
1455 mapping symbols to either anonymous functions or to another such
1456 alist.
1457
1458 @code{make-engraver} accepts forms where the first element is either
1459 an argument list starting with the respective symbol, followed by the
1460 function body (comparable to the way @code{define} is used for
1461 defining functions), or a single symbol followed by subordinate forms
1462 in the same manner.  You can also just make an alist pair
1463 literally (the @samp{car} is quoted automatically) as long as the
1464 unevaluated @samp{cdr} is not a pair.  This is useful if you already
1465 have defined your engraver functions separately.
1466
1467 Symbols mapping to a function would be @code{initialize},
1468 @code{start-translation-timestep}, @code{process-music},
1469 @code{process-acknowledged}, @code{stop-translation-timestep}, and
1470 @code{finalize}.  Symbols mapping to another alist specified in the
1471 same manner are @code{listeners} with the subordinate symbols being
1472 event classes, and @code{acknowledgers} and @code{end-acknowledgers}
1473 with the subordinate symbols being interfaces."
1474   (let loop ((forms forms))
1475     (if (or (null? forms) (pair? forms))
1476         `(list
1477           ,@(map (lambda (form)
1478                    (if (pair? (car form))
1479                        `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
1480                        `(cons ',(car form) ,(loop (cdr form)))))
1481                  forms))
1482         forms)))