scm/output-lib.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2014 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->string (ly:event-property event 'string-number) 10))))
 999
1000 (define-public (stroke-finger::calc-text grob)
1001   (let ((event (event-cause grob)))
1002     (or (ly:event-property event 'text #f)
1003         (vector-ref (ly:grob-property grob 'digit-names)
1004                     (1- (max 1
1005                              (min 5 (ly:event-property event 'digit))))))))
1006
1007
1008 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1009 ;; dynamics
1010
1011 (define-public (hairpin::calc-grow-direction grob)
1012   (if (ly:in-event-class? (event-cause grob) 'decrescendo-event)
1013       START
1014       STOP))
1015
1016 (define-public (dynamic-text-spanner::before-line-breaking grob)
1017   "Monitor left bound of @code{DynamicTextSpanner} for absolute dynamics.
1018 If found, ensure @code{DynamicText} does not collide with spanner text by
1019 changing @code{'attach-dir} and @code{'padding}.  Reads the
1020 @code{'right-padding} property of @code{DynamicText} to fine tune space
1021 between the two text elements."
1022   (let ((left-bound (ly:spanner-bound grob LEFT)))
1023     (if (grob::has-interface left-bound 'dynamic-text-interface)
1024         (let* ((details (ly:grob-property grob 'bound-details))
1025                (left-details (ly:assoc-get 'left details))
1026                (my-padding (ly:assoc-get 'padding left-details))
1027                (script-padding (ly:grob-property left-bound 'right-padding 0)))
1028
1029           (and (number? my-padding)
1030                (ly:grob-set-nested-property! grob
1031                                              '(bound-details left attach-dir)
1032                                              RIGHT)
1033                (ly:grob-set-nested-property! grob
1034                                              '(bound-details left padding)
1035                                              (+ my-padding script-padding)))))))
1036
1037 (define ((elbowed-hairpin coords mirrored?) grob)
1038   "Create hairpin based on a list of @var{coords} in @code{(cons x y)}
1039 form.  @code{x} is the portion of the width consumed for a given line
1040 and @code{y} is the portion of the height.  For example,
1041 @code{'((0.3 . 0.7) (0.8 . 0.9) (1.0 . 1.0))} means that at the point
1042 where the hairpin has consumed 30% of its width, it must
1043 be at 70% of its height.  Once it is to 80% width, it
1044 must be at 90% height.  It finishes at
1045 100% width and 100% height.  @var{mirrored?} indicates if the hairpin
1046 is mirrored over the Y-axis or if just the upper part is drawn.
1047 Returns a function that accepts a hairpin grob as an argument
1048 and draws the stencil based on its coordinates.
1049 @lilypond[verbatim,quote]
1050 #(define simple-hairpin
1051   (elbowed-hairpin '((1.0 . 1.0)) #t))
1052
1053 \\relative c' {
1054   \\override Hairpin #'stencil = #simple-hairpin
1055   a\\p\\< a a a\\f
1056 }
1057 @end lilypond
1058 "
1059   (define (pair-to-list pair)
1060     (list (car pair) (cdr pair)))
1061   (define (normalize-coords goods x y)
1062     (map
1063      (lambda (coord)
1064        (cons (* x (car coord)) (* y (cdr coord))))
1065      goods))
1066   (define (my-c-p-s points thick decresc?)
1067     (make-connected-path-stencil
1068      points
1069      thick
1070      (if decresc? -1.0 1.0)
1071      1.0
1072      #f
1073      #f))
1074   ;; outer let to trigger suicide
1075   (let ((sten (ly:hairpin::print grob)))
1076     (if (grob::is-live? grob)
1077         (let* ((decresc? (eq? (ly:grob-property grob 'grow-direction) LEFT))
1078                (thick (ly:grob-property grob 'thickness 0.1))
1079                (thick (* thick (layout-line-thickness grob)))
1080                (xex (ly:stencil-extent sten X))
1081                (lenx (interval-length xex))
1082                (yex (ly:stencil-extent sten Y))
1083                (leny (interval-length yex))
1084                (xtrans (+ (car xex) (if decresc? lenx 0)))
1085                (ytrans (car yex))
1086                (uplist (map pair-to-list
1087                             (normalize-coords coords lenx (/ leny 2))))
1088                (downlist (map pair-to-list
1089                               (normalize-coords coords lenx (/ leny -2)))))
1090           (ly:stencil-translate
1091            (ly:stencil-add
1092             (my-c-p-s uplist thick decresc?)
1093             (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil))
1094            (cons xtrans ytrans)))
1095         '())))
1096 (export elbowed-hairpin)
1097
1098 (define-public flared-hairpin
1099   (elbowed-hairpin '((0.95 . 0.4) (1.0 . 1.0)) #t))
1100
1101 (define-public constante-hairpin
1102   (elbowed-hairpin '((1.0 . 0.0) (1.0 . 1.0)) #f))
1103
1104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1105 ;; lyrics
1106
1107 (define-public (lyric-text::print grob)
1108   "Allow interpretation of tildes as lyric tieing marks."
1109
1110   (let ((text (ly:grob-property grob 'text)))
1111
1112     (grob-interpret-markup grob (if (string? text)
1113                                     (make-tied-lyric-markup text)
1114                                     text))))
1115
1116 (define ((grob::calc-property-by-copy prop) grob)
1117   (ly:event-property (event-cause grob) prop))
1118 (export grob::calc-property-by-copy)
1119
1120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1121 ;; general inheritance
1122
1123 (define ((grob::inherit-parent-property axis property . default) grob)
1124   "@var{grob} callback generator for inheriting a @var{property} from
1125 an @var{axis} parent, defaulting to @var{default} if there is no
1126 parent or the parent has no setting."
1127   (let ((parent (ly:grob-parent grob axis)))
1128     (cond
1129      ((ly:grob? parent)
1130       (apply ly:grob-property parent property default))
1131      ((pair? default) (car default))
1132      (else '()))))
1133 (export grob::inherit-parent-property)
1134
1135 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1136 ;; fret boards
1137
1138 (define-public (fret-board::calc-stencil grob)
1139   (grob-interpret-markup
1140    grob
1141    (make-fret-diagram-verbose-markup
1142     (ly:grob-property grob 'dot-placement-list))))
1143
1144
1145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1146 ;; slurs
1147
1148 (define-public slur::height
1149   (ly:make-unpure-pure-container
1150    ly:slur::height
1151    ly:slur::pure-height))
1152
1153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1154 ;; scripts
1155
1156 (define-public (script-interface::calc-x-offset grob)
1157   (ly:grob-property grob 'positioning-done)
1158   (let* ((shift (ly:grob-property grob 'toward-stem-shift 0.0))
1159          (note-head-location
1160           (ly:self-alignment-interface::aligned-on-x-parent grob))
1161          (note-head-grob (ly:grob-parent grob X))
1162          (stem-grob (ly:grob-object note-head-grob 'stem)))
1163
1164     (+ note-head-location
1165        ;; If the property 'toward-stem-shift is defined and the script
1166        ;; has the same direction as the stem, move the script accordingly.
1167        ;; Since scripts can also be over skips, we need to check whether
1168        ;; the grob has a stem at all.
1169        (if (ly:grob? stem-grob)
1170            (let ((dir1 (ly:grob-property grob 'direction))
1171                  (dir2 (ly:grob-property stem-grob 'direction)))
1172              (if (equal? dir1 dir2)
1173                  (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
1174                         (stem-location
1175                          (ly:grob-relative-coordinate stem-grob common-refp X)))
1176                    (* shift (- stem-location note-head-location)))
1177                  0.0))
1178            0.0))))
1179
1180
1181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1182 ;; instrument names
1183
1184 (define-public (system-start-text::print grob)
1185   (let* ((left-bound (ly:spanner-bound grob LEFT))
1186          (left-mom (ly:grob-property left-bound 'when))
1187          (name (if (moment<=? left-mom ZERO-MOMENT)
1188                    (ly:grob-property grob 'long-text)
1189                    (ly:grob-property grob 'text))))
1190
1191     (if (and (markup? name)
1192              (!= (ly:item-break-dir left-bound) CENTER))
1193
1194         (grob-interpret-markup grob name)
1195         (ly:grob-suicide! grob))))
1196
1197 (define-public (system-start-text::calc-x-offset grob)
1198   (let* ((left-bound (ly:spanner-bound grob LEFT))
1199          (left-mom (ly:grob-property left-bound 'when))
1200          (layout (ly:grob-layout grob))
1201          (indent (ly:output-def-lookup layout
1202                                        (if (moment<=? left-mom ZERO-MOMENT)
1203                                            'indent
1204                                            'short-indent)
1205                                        0.0))
1206          (system (ly:grob-system grob))
1207          (my-extent (ly:grob-extent grob system X))
1208          (elements (ly:grob-object system 'elements))
1209          (common (ly:grob-common-refpoint-of-array system elements X))
1210          (total-ext empty-interval)
1211          (align-x (ly:grob-property grob 'self-alignment-X 0))
1212          (padding (min 0 (- (interval-length my-extent) indent)))
1213          (right-padding (- padding
1214                            (/ (* padding (1+ align-x)) 2))))
1215
1216     ;; compensate for the variation in delimiter extents by
1217     ;; calculating an X-offset correction based on united extents
1218     ;; of all delimiters in this system
1219     (let unite-delims ((l (ly:grob-array-length elements)))
1220       (if (> l 0)
1221           (let ((elt (ly:grob-array-ref elements (1- l))))
1222
1223             (if (grob::has-interface elt 'system-start-delimiter-interface)
1224                 (let ((dims (ly:grob-extent elt common X)))
1225                   (if (interval-sane? dims)
1226                       (set! total-ext (interval-union total-ext dims)))))
1227             (unite-delims (1- l)))))
1228
1229     (+
1230      (ly:side-position-interface::x-aligned-side grob)
1231      right-padding
1232      (- (interval-length total-ext)))))
1233
1234 (define-public (system-start-text::calc-y-offset grob)
1235
1236   (define (live-elements-list me)
1237     (let ((elements (ly:grob-object me 'elements)))
1238
1239       (filter! grob::is-live?
1240                (ly:grob-array->list elements))))
1241
1242   (let* ((left-bound (ly:spanner-bound grob LEFT))
1243          (live-elts (live-elements-list grob))
1244          (system (ly:grob-system grob))
1245          (extent empty-interval))
1246
1247     (if (and (pair? live-elts)
1248              (interval-sane? (ly:grob-extent grob system Y)))
1249         (let get-extent ((lst live-elts))
1250           (if (pair? lst)
1251               (let ((axis-group (car lst)))
1252
1253                 (if (and (ly:spanner? axis-group)
1254                          (equal? (ly:spanner-bound axis-group LEFT)
1255                                  left-bound))
1256                     (set! extent (add-point extent
1257                                             (ly:grob-relative-coordinate
1258                                              axis-group system Y))))
1259                 (get-extent (cdr lst)))))
1260         ;; no live axis group(s) for this instrument name -> remove from system
1261         (ly:grob-suicide! grob))
1262
1263     (+
1264      (ly:self-alignment-interface::y-aligned-on-self grob)
1265      (interval-center extent))))
1266
1267
1268 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1269 ;; axis group interface
1270
1271 (define-public axis-group-interface::height
1272   (ly:make-unpure-pure-container
1273    ly:axis-group-interface::height
1274    ly:axis-group-interface::pure-height))
1275
1276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1277 ;; ambitus
1278
1279 ;; Calculate the gaps between ambitus heads and ends of ambitus line.
1280 ;; Start by determining desired length of the ambitus line (based on
1281 ;; length-fraction property), calc gap from that and make sure that
1282 ;; it doesn't exceed maximum allowed value.
1283
1284 (define-public (ambitus-line::calc-gap grob)
1285   (let ((heads (ly:grob-object grob 'note-heads)))
1286
1287   (if (and (ly:grob-array? heads)
1288              (= (ly:grob-array-length heads) 2))
1289       (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1290               (head-down (ly:grob-array-ref heads 0))
1291               (head-up (ly:grob-array-ref heads 1))
1292               (fraction (ly:grob-property grob 'length-fraction 0.7))
1293               (max-gap (ly:grob-property grob 'maximum-gap 0.45))
1294               ;; distance between noteheads:
1295               (distance (- (interval-start (ly:grob-extent head-up common Y))
1296                           (interval-end (ly:grob-extent head-down common Y))))
1297               (gap (* 0.5 distance (- 1 fraction))))
1298
1299          (min gap max-gap))
1300       0)))
1301
1302 ;; Print a line connecting ambitus heads:
1303
1304 (define-public (ambitus::print grob)
1305   (let ((heads (ly:grob-object grob 'note-heads)))
1306
1307     (if (and (ly:grob-array? heads)
1308              (= (ly:grob-array-length heads) 2))
1309         (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1310                (head-down (ly:grob-array-ref heads 0))
1311                (head-up (ly:grob-array-ref heads 1))
1312                ;; The value used when 'gap' property cannot be read is small
1313                ;; to make sure that ambitus of a fifth will have a visible line.
1314                (gap (ly:grob-property grob 'gap 0.25))
1315                (point-min (+ (interval-end (ly:grob-extent head-down common Y))
1316                              gap))
1317                (point-max (- (interval-start (ly:grob-extent head-up common Y))
1318                              gap)))
1319
1320           (if (< (+ point-min 0.1) point-max) ; don't print lines shorter than 0.1ss
1321               (let* ((layout (ly:grob-layout grob))
1322                      (line-thick (ly:output-def-lookup layout 'line-thickness))
1323                      (blot (ly:output-def-lookup layout 'blot-diameter))
1324                      (grob-thick (ly:grob-property grob 'thickness 2))
1325                      (width (* line-thick grob-thick))
1326                      (x-ext (symmetric-interval (/ width 2)))
1327                      (y-ext (cons point-min point-max))
1328                      (line (ly:round-filled-box x-ext y-ext blot))
1329                      (y-coord (ly:grob-relative-coordinate grob common Y)))
1330
1331                 (ly:stencil-translate-axis line (- y-coord) Y))
1332               empty-stencil))
1333         (begin
1334           (ly:grob-suicide! grob)
1335           (list)))))
1336
1337 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1338 ;;  laissez-vibrer tie
1339 ;;
1340 ;;  needed so we can make laissez-vibrer a pure print
1341 ;;
1342 (define-public (laissez-vibrer::print grob)
1343   (ly:tie::print grob))
1344
1345 (define-public (semi-tie::calc-cross-staff grob)
1346   (let* ((note-head (ly:grob-object grob 'note-head))
1347          (stem (ly:grob-object note-head 'stem)))
1348     (and (ly:grob? stem)
1349          (ly:grob-property stem 'cross-staff #f))))
1350
1351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1352 ;; volta-bracket
1353
1354 (define-public (volta-bracket-interface::pure-height grob start end)
1355   (let ((edge-height (ly:grob-property grob 'edge-height)))
1356     (if (number-pair? edge-height)
1357         (let ((smaller (min (car edge-height) (cdr edge-height)))
1358               (larger (max (car edge-height) (cdr edge-height))))
1359           (interval-union '(0 . 0) (cons smaller larger)))
1360         '(0 . 0))))
1361
1362 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1363 ;; make-engraver helper macro
1364
1365 (defmacro-public make-engraver forms
1366   "Helper macro for creating Scheme engravers.
1367
1368 The usual form for an engraver is an association list (or alist)
1369 mapping symbols to either anonymous functions or to another such
1370 alist.
1371
1372 @code{make-engraver} accepts forms where the first element is either
1373 an argument list starting with the respective symbol, followed by the
1374 function body (comparable to the way @code{define} is used for
1375 defining functions), or a single symbol followed by subordinate forms
1376 in the same manner.  You can also just make an alist pair
1377 literally (the @samp{car} is quoted automatically) as long as the
1378 unevaluated @samp{cdr} is not a pair.  This is useful if you already
1379 have defined your engraver functions separately.
1380
1381 Symbols mapping to a function would be @code{initialize},
1382 @code{start-translation-timestep}, @code{process-music},
1383 @code{process-acknowledged}, @code{stop-translation-timestep}, and
1384 @code{finalize}.  Symbols mapping to another alist specified in the
1385 same manner are @code{listeners} with the subordinate symbols being
1386 event classes, and @code{acknowledgers} and @code{end-acknowledgers}
1387 with the subordinate symbols being interfaces."
1388   (let loop ((forms forms))
1389     (if (or (null? forms) (pair? forms))
1390         `(list
1391           ,@(map (lambda (form)
1392                    (if (pair? (car form))
1393                        `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
1394                        `(cons ',(car form) ,(loop (cdr form)))))
1395                  forms))
1396         forms)))