scm/output-lib.scm

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