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