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