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   (if (symbol? style)
 399       (case style
 400         ;; "default" style is directly handled in note-head.cc as a
 401         ;; special case (HW says, mainly for performance reasons).
 402         ;; Therefore, style "default" does not appear in this case
 403         ;; statement.  -- jr
 404         ;; Though we not to care if style is '(), see below.  -- harm
 405         ((xcircle) "2xcircle")
 406         ((harmonic) "0harmonic")
 407         ((harmonic-black) "2harmonic")
 408         ((harmonic-mixed) (if (<= log 1) "0harmonic"
 409                               "2harmonic"))
 410         ((baroque)
 411          ;; Oops, I actually would not call this "baroque", but, for
 412          ;; backwards compatibility to 1.4, this is supposed to take
 413          ;; brevis, longa and maxima from the neo-mensural font and all
 414          ;; other note heads from the default font.  -- jr
 415          (if (< log 0)
 416              (string-append (number->string log) "neomensural")
 417              (number->string log)))
 418         ((altdefault)
 419          ;; Like default, but brevis is drawn with double vertical lines
 420          (if (= log -1)
 421              (string-append (number->string log) "double")
 422              (number->string log)))
 423         ((mensural)
 424          (string-append (number->string log) (symbol->string style)))
 425         ((petrucci)
 426          (if (< log 0)
 427              (string-append (number->string log) "mensural")
 428              (string-append (number->string log) (symbol->string style))))
 429         ((blackpetrucci)
 430          (if (< log 0)
 431              (string-append (number->string log) "blackmensural")
 432              (string-append (number->string log) (symbol->string style))))
 433         ((semipetrucci)
 434          (if (< log 0)
 435              (string-append (number->string log) "semimensural")
 436              (string-append (number->string log) "petrucci")))
 437         ((neomensural)
 438          (string-append (number->string log) (symbol->string style)))
 439         ((kievan)
 440          (string-append (number->string log) "kievan"))
 441         (else
 442          (if (string-match "vaticana*|hufnagel*|medicaea*"
 443                            (symbol->string style))
 444              (symbol->string style)
 445              (string-append (number->string (max 0 log))
 446                             (symbol->string style)))))
 447       ;; 'vaticana-ligature-interface has a 'glyph-name-property for NoteHead.
 448       ;; Probably best to return an empty list here, if called in a context
 449       ;; without setting 'style, i.e. 'style is '(), to avoid a scheme-error.
 450       '()))
 451
 452 (define-public (note-head::calc-glyph-name grob)
 453   (let* ((style (ly:grob-property grob 'style))
 454          (log (if (and (symbol? style)
 455                        (string-match "kievan*" (symbol->string style)))
 456                   (min 3 (ly:grob-property grob 'duration-log))
 457                   (min 2 (ly:grob-property grob 'duration-log)))))
 458     (select-head-glyph style log)))
 459
 460 (define-public (note-head::brew-ez-stencil grob)
 461   (let* ((log (ly:grob-property grob 'duration-log))
 462          (pitch (ly:event-property (event-cause grob) 'pitch))
 463          (pitch-index (ly:pitch-notename pitch))
 464          (note-names (ly:grob-property grob 'note-names))
 465          (pitch-string (if (and (vector? note-names)
 466                                 (> (vector-length note-names) pitch-index))
 467                            (vector-ref note-names pitch-index)
 468                            (string
 469                             (integer->char
 470                              (+ (modulo (+ pitch-index 2) 7)
 471                                 (char->integer #\A))))))
 472          (staff-space (ly:staff-symbol-staff-space grob))
 473          (line-thickness (ly:staff-symbol-line-thickness grob))
 474          (stem (ly:grob-object grob 'stem))
 475          (stem-thickness (* (if (ly:grob? stem)
 476                                 (ly:grob-property stem 'thickness)
 477                                 1.3)
 478                             line-thickness))
 479          (radius (/ (+ staff-space line-thickness) 2))
 480          (letter (make-center-align-markup (make-vcenter-markup pitch-string)))
 481          (filled-circle (make-draw-circle-markup radius 0 #t)))
 482
 483     (ly:stencil-translate-axis
 484      (grob-interpret-markup
 485       grob
 486       (if (>= log 2)
 487           (make-combine-markup
 488            filled-circle
 489            (make-with-color-markup white letter))
 490           (make-combine-markup
 491            (make-combine-markup
 492             filled-circle
 493             (make-with-color-markup white (make-draw-circle-markup
 494                                            (- radius stem-thickness) 0 #t)))
 495            letter)))
 496      radius X)))
 497
 498 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 499 ;; clipping
 500
 501 (define-public (make-rhythmic-location bar-num num den)
 502   (cons
 503    bar-num (ly:make-moment num den)))
 504
 505 (define-public (rhythmic-location? a)
 506   (and (pair? a)
 507        (integer? (car a))
 508        (ly:moment? (cdr a))))
 509
 510 (define-public (make-graceless-rhythmic-location loc)
 511   (make-rhythmic-location
 512    (car loc)
 513    (ly:moment-main-numerator (rhythmic-location-measure-position loc))
 514    (ly:moment-main-denominator (rhythmic-location-measure-position loc))))
 515
 516 (define-public rhythmic-location-measure-position cdr)
 517 (define-public rhythmic-location-bar-number car)
 518
 519 (define-public (rhythmic-location<? a b)
 520   (cond
 521    ((< (car a) (car b)) #t)
 522    ((> (car a) (car b)) #f)
 523    (else
 524     (ly:moment<? (cdr a) (cdr b)))))
 525
 526 (define-public (rhythmic-location<=? a b)
 527   (not (rhythmic-location<? b a)))
 528 (define-public (rhythmic-location>=? a b)
 529   (not (rhythmic-location<? a b)))
 530 (define-public (rhythmic-location>? a b)
 531   (rhythmic-location<? b a))
 532
 533 (define-public (rhythmic-location=? a b)
 534   (and (rhythmic-location<=? a b)
 535        (rhythmic-location<=? b a)))
 536
 537 (define-public (rhythmic-location->file-string a)
 538   (ly:format "~a.~a.~a"
 539              (car a)
 540              (ly:moment-main-numerator (cdr a))
 541              (ly:moment-main-denominator (cdr a))))
 542
 543 (define-public (rhythmic-location->string a)
 544   (ly:format "bar ~a ~a"
 545              (car a)
 546              (ly:moment->string (cdr a))))
 547
 548 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 549 ;; break visibility
 550
 551 (define-public all-visible             #(#t #t #t))
 552 (define-public begin-of-line-invisible #(#t #t #f))
 553 (define-public center-invisible        #(#t #f #t))
 554 (define-public end-of-line-invisible   #(#f #t #t))
 555 (define-public begin-of-line-visible   #(#f #f #t))
 556 (define-public center-visible          #(#f #t #f))
 557 (define-public end-of-line-visible     #(#t #f #f))
 558 (define-public all-invisible           #(#f #f #f))
 559
 560 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 561 ;; neighbor-interface routines
 562
 563
 564 (define-public (shift-right-at-line-begin g)
 565   "Shift an item to the right, but only at the start of the line."
 566   (if (and (ly:item? g)
 567            (equal? (ly:item-break-dir g) RIGHT))
 568       (ly:grob-translate-axis! g 3.5 X)))
 569
 570 (define-public (pure-from-neighbor-interface::extra-spacing-height-at-beginning-of-line grob)
 571   (if (= 1 (ly:item-break-dir grob))
 572       (pure-from-neighbor-interface::extra-spacing-height grob)
 573       (cons -0.1 0.1)))
 574
 575 (define-public (pure-from-neighbor-interface::extra-spacing-height grob)
 576   (let* ((height (ly:grob-pure-height grob grob 0 INFINITY-INT))
 577          (from-neighbors (interval-union
 578                           height
 579                           (ly:axis-group-interface::pure-height
 580                            grob
 581                            0
 582                            INFINITY-INT))))
 583     (coord-operation - from-neighbors height)))
 584
 585 ;; If there are neighbors, we place the height at their midpoint
 586 ;; to avoid protrusion of this pure height out of the vertical
 587 ;; axis group on either side.  This will minimize the impact of the
 588 ;; grob on pure minimum translations.
 589
 590 ;; TODO - there is a double call to axis-group-interface::pure-height
 591 ;; here and then in the extra-spacing-height function above. Can/should this
 592 ;; be rolled into one?
 593 (define-public (pure-from-neighbor-interface::pure-height grob beg end)
 594   (let* ((height (ly:axis-group-interface::pure-height
 595                   grob
 596                   0
 597                   INFINITY-INT))
 598          (c (interval-center height)))
 599     (if (interval-empty? height) empty-interval (cons c c))))
 600
 601 ;; Minimizes the impact of the height on vertical spacing while allowing
 602 ;; it to appear in horizontal skylines of paper columns if necessary.
 603 (define-public pure-from-neighbor-interface::height-if-pure
 604   (ly:make-unpure-pure-container #f pure-from-neighbor-interface::pure-height))
 605
 606 (define-public (pure-from-neighbor-interface::account-for-span-bar grob)
 607   (let* ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
 608          (hsb (ly:grob-property grob 'has-span-bar))
 609          (ii (interval-intersection esh (cons -1.01 1.01))))
 610     (if (pair? hsb)
 611         (cons (car (if (and (car hsb)
 612                             (ly:grob-property grob 'allow-span-bar))
 613                        esh ii))
 614               (cdr (if (cdr hsb) esh ii)))
 615         ii)))
 616
 617 (define-public (pure-from-neighbor-interface::extra-spacing-height-including-staff grob)
 618   (let ((esh (pure-from-neighbor-interface::extra-spacing-height grob))
 619         (to-staff (coord-operation -
 620                                    (interval-widen
 621                                     '(0 . 0)
 622                                     (ly:staff-symbol-staff-radius grob))
 623                                    (ly:grob::stencil-height grob))))
 624     (interval-union esh to-staff)))
 625
 626
 627 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 628 ;; Tuplets
 629
 630 (define-public (tuplet-number::calc-direction grob)
 631   (ly:tuplet-bracket::calc-direction (ly:grob-object grob 'bracket)))
 632
 633 (define-public (tuplet-number::calc-denominator-text grob)
 634   (number->string (ly:event-property (event-cause grob) 'denominator)))
 635
 636 (define-public (tuplet-number::calc-fraction-text grob)
 637   (let ((ev (event-cause grob)))
 638
 639     (format #f "~a:~a"
 640             (ly:event-property ev 'denominator)
 641             (ly:event-property ev 'numerator))))
 642
 643 ;; a formatter function, which is simply a wrapper around an existing
 644 ;; tuplet formatter function. It takes the value returned by the given
 645 ;; function and appends a note of given length.
 646 (define ((tuplet-number::append-note-wrapper function note) grob)
 647   (let ((txt (and function (function grob))))
 648
 649     (if txt
 650         (make-line-markup
 651          (list txt (make-fontsize-markup -5 (make-note-markup note UP))))
 652         (make-fontsize-markup -5 (make-note-markup note UP)))))
 653 (export tuplet-number::append-note-wrapper)
 654
 655 ;; Print a tuplet denominator with a different number than the one derived from
 656 ;; the actual tuplet fraction
 657 (define ((tuplet-number::non-default-tuplet-denominator-text denominator)
 658                 grob)
 659   (number->string (if denominator
 660                       denominator
 661                       (ly:event-property (event-cause grob) 'denominator))))
 662 (export tuplet-number::non-default-tuplet-denominator-text)
 663
 664 ;; Print a tuplet fraction with different numbers than the ones derived from
 665 ;; the actual tuplet fraction
 666 (define ((tuplet-number::non-default-tuplet-fraction-text
 667                  denominator numerator) grob)
 668   (let* ((ev (event-cause grob))
 669          (den (if denominator denominator (ly:event-property ev 'denominator)))
 670          (num (if numerator numerator (ly:event-property ev 'numerator))))
 671
 672     (format #f "~a:~a" den num)))
 673 (export tuplet-number::non-default-tuplet-fraction-text)
 674
 675 ;; Print a tuplet fraction with note durations appended to the numerator and the
 676 ;; denominator
 677 (define ((tuplet-number::fraction-with-notes
 678                  denominatornote numeratornote) grob)
 679   (let* ((ev (event-cause grob))
 680          (denominator (ly:event-property ev 'denominator))
 681          (numerator (ly:event-property ev 'numerator)))
 682
 683     ((tuplet-number::non-default-fraction-with-notes
 684       denominator denominatornote numerator numeratornote) grob)))
 685 (export tuplet-number::fraction-with-notes)
 686
 687 ;; Print a tuplet fraction with note durations appended to the numerator and the
 688 ;; denominator
 689 (define ((tuplet-number::non-default-fraction-with-notes
 690                  denominator denominatornote numerator numeratornote) grob)
 691   (let* ((ev (event-cause grob))
 692          (den (if denominator denominator (ly:event-property ev 'denominator)))
 693          (num (if numerator numerator (ly:event-property ev 'numerator))))
 694
 695     (make-concat-markup (list
 696                          (make-simple-markup (format #f "~a" den))
 697                          (make-fontsize-markup -5 (make-note-markup denominatornote UP))
 698                          (make-simple-markup " : ")
 699                          (make-simple-markup (format #f "~a" num))
 700                          (make-fontsize-markup -5 (make-note-markup numeratornote UP))))))
 701 (export tuplet-number::non-default-fraction-with-notes)
 702
 703
 704 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 705 ;; Color
 706
 707 (define-public (color? x)
 708   (and (list? x)
 709        (= 3 (length x))
 710        (every number? x)
 711        (every (lambda (y) (<= 0 y 1)) x)))
 712
 713 (define-public (rgb-color r g b) (list r g b))
 714
 715 ;; predefined colors
 716 (define-public black       '(0.0 0.0 0.0))
 717 (define-public white       '(1.0 1.0 1.0))
 718 (define-public red         '(1.0 0.0 0.0))
 719 (define-public green       '(0.0 1.0 0.0))
 720 (define-public blue        '(0.0 0.0 1.0))
 721 (define-public cyan        '(0.0 1.0 1.0))
 722 (define-public magenta     '(1.0 0.0 1.0))
 723 (define-public yellow      '(1.0 1.0 0.0))
 724
 725 (define-public grey        '(0.5 0.5 0.5))
 726 (define-public darkred     '(0.5 0.0 0.0))
 727 (define-public darkgreen   '(0.0 0.5 0.0))
 728 (define-public darkblue    '(0.0 0.0 0.5))
 729 (define-public darkcyan    '(0.0 0.5 0.5))
 730 (define-public darkmagenta '(0.5 0.0 0.5))
 731 (define-public darkyellow  '(0.5 0.5 0.0))
 732
 733
 734 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 735 ;; key signature
 736
 737 (define-public (key-signature-interface::alteration-positions
 738                 entry c0-position grob)
 739   (let ((step (car entry))
 740         (alter (cdr entry)))
 741     (if (pair? step)
 742         (list (+ (cdr step) (* (car step) 7) c0-position))
 743         (let* ((c-position (modulo c0-position 7))
 744                (positions
 745                 (if (< alter 0)
 746                     ;; See (flat|sharp)-positions in define-grob-properties.scm
 747                     (ly:grob-property grob 'flat-positions '(3))
 748                     (ly:grob-property grob 'sharp-positions '(3))))
 749                (p (list-ref positions
 750                             (if (< c-position (length positions))
 751                                 c-position 0)))
 752                (max-position (if (pair? p) (cdr p) p))
 753                (min-position (if (pair? p) (car p) (- max-position 6)))
 754                (first-position (+ (modulo (- (+ c-position step)
 755                                              min-position)
 756                                           7)
 757                                   min-position)))
 758           (define (prepend x l) (if (> x max-position)
 759                                     l
 760                                     (prepend (+ x 7) (cons x l))))
 761           (prepend first-position '())))))
 762
 763 (define-public (key-signature-interface::alteration-position
 764                 step alter c0-position)
 765 ;; Deprecated.  Not a documented interface, and no longer used in LilyPond,
 766 ;; but needed for a popular file, LilyJAZZ.ily for version 2.16
 767   (if (pair? step)
 768     (+ (cdr step) (* (car step) 7) c0-position)
 769     (let* ((c-pos (modulo c0-position 7))
 770            (hi (list-ref
 771                  (if (< alter 0)
 772                    '(2 3 4 2 1 2 1) ; position of highest flat
 773                    '(4 5 4 2 3 2 3)); position of highest sharp
 774                  c-pos)))
 775       (- hi (modulo (- hi (+ c-pos step)) 7)))))
 776
 777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 778 ;; annotations
 779
 780 (define-public (numbered-footnotes int)
 781   (make-tiny-markup (number->string (+ 1 int))))
 782
 783 (define-public (symbol-footnotes int)
 784   (define (helper symbols out idx n)
 785     (if (< n 1)
 786         out
 787         (helper symbols
 788                 (string-append out (list-ref symbols idx))
 789                 idx
 790                 (- n 1))))
 791   (make-tiny-markup (helper '("*" "†" "‡" "§" "¶")
 792                             ""
 793                             (remainder int 5)
 794                             (+ 1 (quotient int 5)))))
 795
 796 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 797 ;; accidentals
 798
 799 (define-public (accidental-interface::calc-alteration grob)
 800   (ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch)))
 801
 802 (define-public (accidental-interface::glyph-name grob)
 803   (assoc-get (ly:grob-property grob 'alteration)
 804              standard-alteration-glyph-name-alist))
 805
 806 (define-public accidental-interface::height
 807   (ly:make-unpure-pure-container
 808    ly:accidental-interface::height))
 809
 810 (define-public cancellation-glyph-name-alist
 811   '((0 . "accidentals.natural")))
 812
 813 (define-public standard-alteration-glyph-name-alist
 814   '(
 815     ;; ordered for optimal performance.
 816     (0 . "accidentals.natural")
 817     (-1/2 . "accidentals.flat")
 818     (1/2 . "accidentals.sharp")
 819
 820     (1 . "accidentals.doublesharp")
 821     (-1 . "accidentals.flatflat")
 822
 823     (3/4 . "accidentals.sharp.slashslash.stemstemstem")
 824     (1/4 . "accidentals.sharp.slashslash.stem")
 825     (-1/4 . "accidentals.mirroredflat")
 826     (-3/4 . "accidentals.mirroredflat.flat")))
 827
 828 ;; FIXME: standard vs default, alteration-FOO vs FOO-alteration
 829 (define-public alteration-default-glyph-name-alist
 830   standard-alteration-glyph-name-alist)
 831
 832 (define-public makam-alteration-glyph-name-alist
 833   '((1 . "accidentals.doublesharp")
 834     (8/9 . "accidentals.sharp.slashslashslash.stemstem")
 835     (5/9 . "accidentals.sharp.slashslashslash.stem")
 836     (4/9 . "accidentals.sharp")
 837     (1/9 . "accidentals.sharp.slashslash.stem")
 838     (0 . "accidentals.natural")
 839     (-1/9 . "accidentals.mirroredflat")
 840     (-4/9 . "accidentals.flat.slash")
 841     (-5/9 . "accidentals.flat")
 842     (-8/9 . "accidentals.flat.slashslash")
 843     (-1 . "accidentals.flatflat")))
 844
 845 (define-public alteration-hufnagel-glyph-name-alist
 846   '((-1/2 . "accidentals.hufnagelM1")
 847     (0 . "accidentals.vaticana0")
 848     (1/2 . "accidentals.mensural1")))
 849
 850 (define-public alteration-medicaea-glyph-name-alist
 851   '((-1/2 . "accidentals.medicaeaM1")
 852     (0 . "accidentals.vaticana0")
 853     (1/2 . "accidentals.mensural1")))
 854
 855 (define-public alteration-vaticana-glyph-name-alist
 856   '((-1/2 . "accidentals.vaticanaM1")
 857     (0 . "accidentals.vaticana0")
 858     (1/2 . "accidentals.mensural1")))
 859
 860 (define-public alteration-mensural-glyph-name-alist
 861   '((-1/2 . "accidentals.mensuralM1")
 862     (0 . "accidentals.vaticana0")
 863     (1/2 . "accidentals.mensural1")))
 864
 865 (define-public alteration-kievan-glyph-name-alist
 866   '((-1/2 . "accidentals.kievanM1")
 867     (1/2 . "accidentals.kievan1")))
 868
 869 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 870 ;; * Pitch Trill Heads
 871 ;; * Parentheses
 872
 873 (define-public (parentheses-item::calc-parenthesis-stencils grob)
 874   (let* ((font (ly:grob-default-font grob))
 875          (lp (ly:font-get-glyph font "accidentals.leftparen"))
 876          (rp (ly:font-get-glyph font "accidentals.rightparen")))
 877
 878     (list lp rp)))
 879
 880 (define-public (parentheses-item::calc-angled-bracket-stencils grob)
 881   (let* ((parent (ly:grob-parent grob Y))
 882          (y-extent (ly:grob-extent parent parent Y))
 883          (half-thickness 0.05) ; should it be a property?
 884          (width 0.5) ; should it be a property?
 885          (angularity 1.5)  ; makes angle brackets
 886          (white-padding 0.1) ; should it be a property?
 887          (lp (ly:stencil-aligned-to
 888               (ly:stencil-aligned-to
 889                (make-parenthesis-stencil y-extent
 890                                          half-thickness
 891                                          width
 892                                          angularity
 893                                          -1)
 894                Y CENTER)
 895               X RIGHT))
 896          (lp-x-extent
 897           (interval-widen (ly:stencil-extent lp X) white-padding))
 898          (rp (ly:stencil-aligned-to
 899               (ly:stencil-aligned-to
 900                (make-parenthesis-stencil y-extent
 901                                          half-thickness
 902                                          width
 903                                          angularity
 904                                          1)
 905                Y CENTER)
 906               X LEFT))
 907          (rp-x-extent
 908           (interval-widen (ly:stencil-extent rp X) white-padding)))
 909     (set! lp (ly:make-stencil (ly:stencil-expr lp)
 910                               lp-x-extent
 911                               (ly:stencil-extent lp Y)))
 912     (set! rp (ly:make-stencil (ly:stencil-expr rp)
 913                               rp-x-extent
 914                               (ly:stencil-extent rp Y)))
 915     (list (stencil-whiteout-box lp)
 916           (stencil-whiteout-box rp))))
 917
 918 (define-public (parentheses-item::y-extent grob) (ly:grob::stencil-height grob))
 919
 920 (define (parenthesize-elements grob . rest)
 921   (let* ((refp (if (null? rest)
 922                    grob
 923                    (car rest)))
 924          (elts (ly:grob-array->list (ly:grob-object grob 'elements)))
 925          (get-friends
 926            (lambda (g)
 927              (let ((syms (ly:grob-property g 'parenthesis-friends '()))
 928                    (get-friend (lambda (s)
 929                                  (let ((f (ly:grob-object g s)))
 930                                    (cond
 931                                      ((ly:grob? f) (list f))
 932                                      ((ly:grob-array? f) (ly:grob-array->list f))
 933                                      (else '()))))))
 934                (apply append (map get-friend syms)))))
 935          (friends (apply append elts (map get-friends elts)))
 936          (x-ext (ly:relative-group-extent friends refp X))
 937          (stencils (ly:grob-property grob 'stencils))
 938          (lp (car stencils))
 939          (rp (cadr stencils))
 940          (padding (ly:grob-property grob 'padding 0.1)))
 941
 942     (ly:stencil-add
 943      (ly:stencil-translate-axis lp (- (car x-ext) padding) X)
 944      (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X))))
 945
 946
 947 (define-public (parentheses-item::print me)
 948   (let* ((elts (ly:grob-object me 'elements))
 949          (y-ref (ly:grob-common-refpoint-of-array me elts Y))
 950          (x-ref (ly:grob-common-refpoint-of-array me elts X))
 951          (stencil (parenthesize-elements me x-ref))
 952          (elt-y-ext (ly:relative-group-extent elts y-ref Y))
 953          (y-center (interval-center elt-y-ext)))
 954
 955     (ly:stencil-translate
 956      stencil
 957      (cons
 958       (- (ly:grob-relative-coordinate me x-ref X))
 959       (- y-center (ly:grob-relative-coordinate me y-ref Y))))))
 960
 961
 962 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 963 ;; offset callbacks
 964
 965 (define-public (pure-chain-offset-callback grob start end prev-offset)
 966   "Sometimes, a chained offset callback is unpure and there is
 967    no way to write a pure function that estimates its behavior.
 968    In this case, we use a pure equivalent that will simply pass
 969    the previous calculated offset value."
 970   prev-offset)
 971
 972 (define-public (scale-by-font-size x)
 973   (ly:make-unpure-pure-container
 974     (lambda (grob)
 975       (* x (magstep (ly:grob-property grob 'font-size 0))))))
 976
 977 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 978 ;;
 979
 980 (define-public (grob::compose-function func data)
 981   "This creates a callback entity to be stored in a grob property,
 982 based on the grob property data @var{data} (which can be plain data, a
 983 callback itself, or an unpure-pure-container).
 984
 985 Function or unpure-pure-container @var{func} accepts a grob and a
 986 value and returns another value.  Depending on the type of @var{data},
 987 @var{func} is used for building a grob callback or an
 988 unpure-pure-container."
 989   (if (or (ly:unpure-pure-container? func)
 990           (ly:unpure-pure-container? data))
 991       (ly:make-unpure-pure-container
 992        (lambda (grob) (ly:unpure-call func grob (ly:unpure-call data grob)))
 993        (lambda (grob start end)
 994          (ly:pure-call func grob start end
 995                        (ly:pure-call data grob start end))))
 996       (lambda (grob) (ly:unpure-call func grob (ly:unpure-call data grob)))))
 997
 998 (define*-public (grob::offset-function func data
 999                                        #:optional (plus +))
1000   "This creates a callback entity to be stored in a grob property,
1001 based on the grob property data @var{data} (which can be plain data, a
1002 callback itself, or an unpure-pure-container).
1003
1004 Function @var{func} accepts a grob and returns a value that is added
1005 to the value resulting from @var{data}.  Optional argument @var{plus}
1006 defaults to @code{+} but may be changed to allow for using a different
1007 underlying accumulation.
1008
1009 If @var{data} is @code{#f} or @code{'()}, it is not included in the sum."
1010   (cond ((or (not data) (null? data))
1011          func)
1012         ((or (ly:unpure-pure-container? func)
1013              (ly:unpure-pure-container? data))
1014          (ly:make-unpure-pure-container
1015           (lambda rest
1016             (plus (apply ly:unpure-call func rest)
1017                   (apply ly:unpure-call data rest)))
1018           (lambda rest
1019             (plus (apply ly:pure-call func rest)
1020                   (apply ly:pure-call data rest)))))
1021         ((or (procedure? func)
1022              (procedure? data))
1023          (lambda rest
1024            (plus (apply ly:unpure-call func rest)
1025                  (apply ly:unpure-call data rest))))
1026         (else (plus func data))))
1027
1028 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1029 ;; falls/doits
1030
1031 (define-public (bend::print spanner)
1032   (define (close  a b)
1033     (< (abs (- a b)) 0.01))
1034
1035   (let* ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position)))
1036          (left-span (ly:spanner-bound spanner LEFT))
1037          (dots (if (and (grob::has-interface left-span 'note-head-interface)
1038                         (ly:grob? (ly:grob-object left-span 'dot)))
1039                    (ly:grob-object left-span 'dot) #f))
1040
1041          (right-span (ly:spanner-bound spanner RIGHT))
1042          (thickness (* (ly:grob-property spanner 'thickness)
1043                        (ly:output-def-lookup (ly:grob-layout spanner)
1044                                              'line-thickness)))
1045          (padding (ly:grob-property spanner 'padding 0.5))
1046          (common (ly:grob-common-refpoint right-span
1047                                           (ly:grob-common-refpoint spanner
1048                                                                    left-span X)
1049                                           X))
1050          (common-y (ly:grob-common-refpoint spanner left-span Y))
1051          (minimum-length (ly:grob-property spanner 'minimum-length 0.5))
1052
1053          (left-x (+ padding
1054                     (max
1055                      (interval-end (ly:generic-bound-extent
1056                                     left-span common))
1057                      (if
1058                       (and dots
1059                            (close
1060                             (ly:grob-relative-coordinate dots common-y Y)
1061                             (ly:grob-relative-coordinate spanner common-y Y)))
1062                       (interval-end
1063                        (ly:grob-robust-relative-extent dots common X))
1064                       (- INFINITY-INT)))))
1065          (right-x (max (- (interval-start
1066                            (ly:generic-bound-extent right-span common))
1067                           padding)
1068                        (+ left-x minimum-length)))
1069          (self-x (ly:grob-relative-coordinate spanner common X))
1070          (dx (- right-x left-x))
1071          (exp (list 'path thickness
1072                     `(quote
1073                       (rmoveto
1074                        ,(- left-x self-x) 0
1075
1076                        rcurveto
1077                        ,(/ dx 3)
1078                        0
1079                        ,dx ,(* 0.66 delta-y)
1080                        ,dx ,delta-y)))))
1081
1082     (ly:make-stencil
1083      exp
1084      (cons (- left-x self-x) (- right-x self-x))
1085      (cons (min 0 delta-y)
1086            (max 0 delta-y)))))
1087
1088
1089 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1090 ;; grace spacing
1091
1092 (define-public (grace-spacing::calc-shortest-duration grob)
1093   (let* ((cols (ly:grob-object grob 'columns))
1094          (get-difference
1095           (lambda (idx)
1096             (ly:moment-sub (ly:grob-property
1097                             (ly:grob-array-ref cols (1+ idx)) 'when)
1098                            (ly:grob-property
1099                             (ly:grob-array-ref cols idx) 'when))))
1100
1101          (moment-min (lambda (x y)
1102                        (cond
1103                         ((and x y)
1104                          (if (ly:moment<? x y)
1105                              x
1106                              y))
1107                         (x x)
1108                         (y y)))))
1109
1110     (fold moment-min #f (map get-difference
1111                              (iota (1- (ly:grob-array-length cols)))))))
1112
1113
1114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1115 ;; fingering
1116
1117 (define-public (fingering::calc-text grob)
1118   (let ((event (event-cause grob)))
1119     (or (ly:event-property event 'text #f)
1120         (number->string (ly:event-property event 'digit) 10))))
1121
1122 (define-public (string-number::calc-text grob)
1123   (let ((event (event-cause grob)))
1124     (or (ly:event-property event 'text #f)
1125         (number-format
1126          (ly:grob-property grob 'number-type)
1127          (ly:event-property event 'string-number)))))
1128
1129 (define-public (stroke-finger::calc-text grob)
1130   (let ((event (event-cause grob)))
1131     (or (ly:event-property event 'text #f)
1132         (let ((digit-names (ly:grob-property grob 'digit-names)))
1133           (vector-ref digit-names
1134                       (1- (max 1
1135                                (min (vector-length digit-names)
1136                                     (ly:event-property event 'digit)))))))))
1137
1138
1139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1140 ;; dynamics
1141
1142 (define-public (hairpin::calc-grow-direction grob)
1143   (if (ly:in-event-class? (event-cause grob) 'decrescendo-event)
1144       START
1145       STOP))
1146
1147 (define-public (dynamic-text-spanner::before-line-breaking grob)
1148   "Monitor left bound of @code{DynamicTextSpanner} for absolute dynamics.
1149 If found, ensure @code{DynamicText} does not collide with spanner text by
1150 changing @code{'attach-dir} and @code{'padding}.  Reads the
1151 @code{'right-padding} property of @code{DynamicText} to fine tune space
1152 between the two text elements."
1153   (let ((left-bound (ly:spanner-bound grob LEFT)))
1154     (if (grob::has-interface left-bound 'dynamic-text-interface)
1155         (let* ((details (ly:grob-property grob 'bound-details))
1156                (left-details (ly:assoc-get 'left details))
1157                (my-padding (ly:assoc-get 'padding left-details))
1158                (script-padding (ly:grob-property left-bound 'right-padding 0)))
1159
1160           (and (number? my-padding)
1161                (ly:grob-set-nested-property! grob
1162                                              '(bound-details left attach-dir)
1163                                              RIGHT)
1164                (ly:grob-set-nested-property! grob
1165                                              '(bound-details left padding)
1166                                              (+ my-padding script-padding)))))))
1167
1168 (define ((elbowed-hairpin coords mirrored?) grob)
1169   "Create hairpin based on a list of @var{coords} in @code{(cons x y)}
1170 form.  @code{x} is the portion of the width consumed for a given line
1171 and @code{y} is the portion of the height.  For example,
1172 @code{'((0.3 . 0.7) (0.8 . 0.9) (1.0 . 1.0))} means that at the point
1173 where the hairpin has consumed 30% of its width, it must
1174 be at 70% of its height.  Once it is to 80% width, it
1175 must be at 90% height.  It finishes at
1176 100% width and 100% height.  @var{mirrored?} indicates if the hairpin
1177 is mirrored over the Y-axis or if just the upper part is drawn.
1178 Returns a function that accepts a hairpin grob as an argument
1179 and draws the stencil based on its coordinates.
1180 @lilypond[verbatim,quote]
1181 #(define simple-hairpin
1182   (elbowed-hairpin '((1.0 . 1.0)) #t))
1183
1184 \\relative c' {
1185   \\override Hairpin #'stencil = #simple-hairpin
1186   a\\p\\< a a a\\f
1187 }
1188 @end lilypond
1189 "
1190   (define (pair-to-list pair)
1191     (list (car pair) (cdr pair)))
1192   (define (normalize-coords goods x y)
1193     (map
1194      (lambda (coord)
1195        (cons (* x (car coord)) (* y (cdr coord))))
1196      goods))
1197   (define (my-c-p-s points thick decresc?)
1198     (make-connected-path-stencil
1199      points
1200      thick
1201      (if decresc? -1.0 1.0)
1202      1.0
1203      #f
1204      #f))
1205   ;; outer let to trigger suicide
1206   (let ((sten (ly:hairpin::print grob)))
1207     (if (grob::is-live? grob)
1208         (let* ((decresc? (eqv? (ly:grob-property grob 'grow-direction) LEFT))
1209                (thick (ly:grob-property grob 'thickness 0.1))
1210                (thick (* thick (layout-line-thickness grob)))
1211                (xex (ly:stencil-extent sten X))
1212                (lenx (interval-length xex))
1213                (yex (ly:stencil-extent sten Y))
1214                (leny (interval-length yex))
1215                (xtrans (+ (car xex) (if decresc? lenx 0)))
1216                (ytrans (car yex))
1217                (uplist (map pair-to-list
1218                             (normalize-coords coords lenx (/ leny 2))))
1219                (downlist (map pair-to-list
1220                               (normalize-coords coords lenx (/ leny -2)))))
1221           (ly:stencil-translate
1222            (ly:stencil-add
1223             (my-c-p-s uplist thick decresc?)
1224             (if mirrored? (my-c-p-s downlist thick decresc?) empty-stencil))
1225            (cons xtrans ytrans)))
1226         '())))
1227 (export elbowed-hairpin)
1228
1229 (define-public flared-hairpin
1230   (elbowed-hairpin '((0.95 . 0.4) (1.0 . 1.0)) #t))
1231
1232 (define-public constante-hairpin
1233   (elbowed-hairpin '((1.0 . 0.0) (1.0 . 1.0)) #f))
1234
1235 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1236 ;; lyrics
1237
1238 (define-public (lyric-text::print grob)
1239   "Allow interpretation of tildes as lyric tieing marks."
1240
1241   (let ((text (ly:grob-property grob 'text)))
1242
1243     (grob-interpret-markup grob (if (string? text)
1244                                     (make-tied-lyric-markup text)
1245                                     text))))
1246
1247 (define ((grob::calc-property-by-copy prop) grob)
1248   (ly:event-property (event-cause grob) prop))
1249 (export grob::calc-property-by-copy)
1250
1251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1252 ;; general inheritance
1253
1254 (define ((grob::inherit-parent-property axis property . default) grob)
1255   "@var{grob} callback generator for inheriting a @var{property} from
1256 an @var{axis} parent, defaulting to @var{default} if there is no
1257 parent or the parent has no setting."
1258   (let ((parent (ly:grob-parent grob axis)))
1259     (cond
1260      ((ly:grob? parent)
1261       (apply ly:grob-property parent property default))
1262      ((pair? default) (car default))
1263      (else '()))))
1264 (export grob::inherit-parent-property)
1265
1266 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1267 ;; fret boards
1268
1269 (define-public (fret-board::calc-stencil grob)
1270   (grob-interpret-markup
1271    grob
1272    (make-fret-diagram-verbose-markup
1273     (ly:grob-property grob 'dot-placement-list))))
1274
1275
1276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1277 ;; slurs
1278
1279 (define-public slur::height
1280   (ly:make-unpure-pure-container
1281    ly:slur::height
1282    ly:slur::pure-height))
1283
1284 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1285 ;; scripts
1286
1287 (define-public (script-interface::calc-x-offset grob)
1288   (ly:grob-property grob 'positioning-done)
1289   (let* ((shift-when-alone (ly:grob-property grob 'toward-stem-shift 0.0))
1290          (shift-in-column (ly:grob-property grob 'toward-stem-shift-in-column))
1291          (script-column (ly:grob-object grob 'script-column))
1292          (shift
1293            (if (and (ly:grob? script-column)
1294                     (number? shift-in-column)
1295                     ;; ScriptColumn can contain grobs other than Script.
1296                     ;; These should not result in a shift.
1297                     (any (lambda (s)
1298                            (and (not (eq? s grob))
1299                                 (grob::has-interface s 'script-interface)
1300                                 (not (grob::has-interface s
1301                                        'accidental-suggestion-interface))))
1302                          (ly:grob-array->list
1303                            (ly:grob-object script-column 'scripts))))
1304                shift-in-column shift-when-alone))
1305          (note-head-location
1306           (ly:self-alignment-interface::aligned-on-x-parent grob))
1307          (note-head-grob (ly:grob-parent grob X))
1308          (stem-grob (ly:grob-object note-head-grob 'stem)))
1309
1310     (+ note-head-location
1311        ;; If the script has the same direction as the stem, move the script
1312        ;; in accordance with the value of 'shift'.  Since scripts can also be
1313        ;; over skips, we need to check whether the grob has a stem at all.
1314        (if (ly:grob? stem-grob)
1315            (let ((dir1 (ly:grob-property grob 'direction))
1316                  (dir2 (ly:grob-property stem-grob 'direction)))
1317              (if (equal? dir1 dir2)
1318                  (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
1319                         (stem-location
1320                          (ly:grob-relative-coordinate stem-grob common-refp X)))
1321                    (* shift (- stem-location note-head-location)))
1322                  0.0))
1323            0.0))))
1324
1325
1326 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1327 ;; instrument names
1328
1329 (define-public (system-start-text::print grob)
1330   (let* ((left-bound (ly:spanner-bound grob LEFT))
1331          (left-mom (ly:grob-property left-bound 'when))
1332          (name (if (moment<=? left-mom ZERO-MOMENT)
1333                    (ly:grob-property grob 'long-text)
1334                    (ly:grob-property grob 'text))))
1335
1336     (if (and (markup? name)
1337              (!= (ly:item-break-dir left-bound) CENTER))
1338
1339         (grob-interpret-markup grob name)
1340         (ly:grob-suicide! grob))))
1341
1342 (define-public (system-start-text::calc-x-offset grob)
1343   (let* ((left-bound (ly:spanner-bound grob LEFT))
1344          (left-mom (ly:grob-property left-bound 'when))
1345          (layout (ly:grob-layout grob))
1346          (indent (ly:output-def-lookup layout
1347                                        (if (moment<=? left-mom ZERO-MOMENT)
1348                                            'indent
1349                                            'short-indent)
1350                                        0.0))
1351          (system (ly:grob-system grob))
1352          (my-extent (ly:grob-extent grob system X))
1353          (elements (ly:grob-object system 'elements))
1354          (common (ly:grob-common-refpoint-of-array system elements X))
1355          (total-ext empty-interval)
1356          (align-x (ly:grob-property grob 'self-alignment-X 0))
1357          (padding (min 0 (- (interval-length my-extent) indent)))
1358          (right-padding (- padding
1359                            (/ (* padding (1+ align-x)) 2))))
1360
1361     ;; compensate for the variation in delimiter extents by
1362     ;; calculating an X-offset correction based on united extents
1363     ;; of all delimiters in this system
1364     (let unite-delims ((l (ly:grob-array-length elements)))
1365       (if (> l 0)
1366           (let ((elt (ly:grob-array-ref elements (1- l))))
1367
1368             (if (grob::has-interface elt 'system-start-delimiter-interface)
1369                 (let ((dims (ly:grob-extent elt common X)))
1370                   (if (interval-sane? dims)
1371                       (set! total-ext (interval-union total-ext dims)))))
1372             (unite-delims (1- l)))))
1373
1374     (+
1375      (ly:side-position-interface::x-aligned-side grob)
1376      right-padding
1377      (- (interval-length total-ext)))))
1378
1379 (define-public (system-start-text::calc-y-offset grob)
1380
1381   (define (live-elements-list me)
1382     (let ((elements (ly:grob-object me 'elements)))
1383
1384       (filter! grob::is-live?
1385                (ly:grob-array->list elements))))
1386
1387   (let* ((left-bound (ly:spanner-bound grob LEFT))
1388          (live-elts (live-elements-list grob))
1389          (system (ly:grob-system grob))
1390          (extent empty-interval))
1391
1392     (if (and (pair? live-elts)
1393              (interval-sane? (ly:grob-extent grob system Y)))
1394         (let get-extent ((lst live-elts))
1395           (if (pair? lst)
1396               (let ((axis-group (car lst)))
1397
1398                 (if (and (ly:spanner? axis-group)
1399                          (equal? (ly:spanner-bound axis-group LEFT)
1400                                  left-bound))
1401                     (set! extent (add-point extent
1402                                             (ly:grob-relative-coordinate
1403                                              axis-group system Y))))
1404                 (get-extent (cdr lst)))))
1405         ;; no live axis group(s) for this instrument name -> remove from system
1406         (ly:grob-suicide! grob))
1407
1408     (+
1409      (ly:self-alignment-interface::y-aligned-on-self grob)
1410      (interval-center extent))))
1411
1412
1413 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1414 ;; axis group interface
1415
1416 (define-public axis-group-interface::height
1417   (ly:make-unpure-pure-container
1418    ly:axis-group-interface::height
1419    ly:axis-group-interface::pure-height))
1420
1421 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1422 ;; ambitus
1423
1424 ;; Calculate the gaps between ambitus heads and ends of ambitus line.
1425 ;; Start by determining desired length of the ambitus line (based on
1426 ;; length-fraction property), calc gap from that and make sure that
1427 ;; it doesn't exceed maximum allowed value.
1428
1429 (define-public (ambitus-line::calc-gap grob)
1430   (let ((heads (ly:grob-object grob 'note-heads)))
1431
1432   (if (and (ly:grob-array? heads)
1433              (= (ly:grob-array-length heads) 2))
1434       (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1435               (head-down (ly:grob-array-ref heads 0))
1436               (head-up (ly:grob-array-ref heads 1))
1437               (fraction (ly:grob-property grob 'length-fraction 0.7))
1438               (max-gap (ly:grob-property grob 'maximum-gap 0.45))
1439               ;; distance between noteheads:
1440               (distance (- (interval-start (ly:grob-extent head-up common Y))
1441                           (interval-end (ly:grob-extent head-down common Y))))
1442               (gap (* 0.5 distance (- 1 fraction))))
1443
1444          (min gap max-gap))
1445       0)))
1446
1447 ;; Print a line connecting ambitus heads:
1448
1449 (define-public (ambitus::print grob)
1450   (let ((heads (ly:grob-object grob 'note-heads)))
1451
1452     (if (and (ly:grob-array? heads)
1453              (= (ly:grob-array-length heads) 2))
1454         (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1455                (head-down (ly:grob-array-ref heads 0))
1456                (head-up (ly:grob-array-ref heads 1))
1457                ;; The value used when 'gap' property cannot be read is small
1458                ;; to make sure that ambitus of a fifth will have a visible line.
1459                (gap (ly:grob-property grob 'gap 0.25))
1460                (point-min (+ (interval-end (ly:grob-extent head-down common Y))
1461                              gap))
1462                (point-max (- (interval-start (ly:grob-extent head-up common Y))
1463                              gap)))
1464
1465           (if (< (+ point-min 0.1) point-max) ; don't print lines shorter than 0.1ss
1466               (let* ((layout (ly:grob-layout grob))
1467                      (line-thick (ly:output-def-lookup layout 'line-thickness))
1468                      (blot (ly:output-def-lookup layout 'blot-diameter))
1469                      (grob-thick (ly:grob-property grob 'thickness 2))
1470                      (width (* line-thick grob-thick))
1471                      (x-ext (symmetric-interval (/ width 2)))
1472                      (y-ext (cons point-min point-max))
1473                      (line (ly:round-filled-box x-ext y-ext blot))
1474                      (y-coord (ly:grob-relative-coordinate grob common Y)))
1475
1476                 (ly:stencil-translate-axis line (- y-coord) Y))
1477               empty-stencil))
1478         (begin
1479           (ly:grob-suicide! grob)
1480           (list)))))
1481
1482 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1483 ;;  laissez-vibrer tie
1484 ;;
1485 ;;  needed so we can make laissez-vibrer a pure print
1486 ;;
1487 (define-public (laissez-vibrer::print grob)
1488   (ly:tie::print grob))
1489
1490 (define-public (semi-tie::calc-cross-staff grob)
1491   (let* ((note-head (ly:grob-object grob 'note-head))
1492          (stem (ly:grob-object note-head 'stem)))
1493     (and (ly:grob? stem)
1494          (ly:grob-property stem 'cross-staff #f))))
1495
1496 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1497 ;; volta-bracket
1498
1499 (define-public (volta-bracket-interface::pure-height grob start end)
1500   (let ((edge-height (ly:grob-property grob 'edge-height)))
1501     (if (number-pair? edge-height)
1502         (let ((smaller (min (car edge-height) (cdr edge-height)))
1503               (larger (max (car edge-height) (cdr edge-height))))
1504           (interval-union '(0 . 0) (cons smaller larger)))
1505         '(0 . 0))))
1506
1507 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1508 ;; measure counter
1509
1510 (define-public (measure-counter-stencil grob)
1511   "Print a number for a measure count.  The number is centered using
1512 the extents of @code{BreakAlignment} grobs associated with the left and
1513 right bounds of a @code{MeasureCounter} spanner.  Broken measures are
1514 numbered in parentheses."
1515   (let* ((num (make-simple-markup
1516                (number->string (ly:grob-property grob 'count-from))))
1517          (orig (ly:grob-original grob))
1518          (siblings (ly:spanner-broken-into orig)) ; have we been split?
1519          (num
1520           (if (or (null? siblings)
1521                   (eq? grob (car siblings)))
1522               num
1523               (make-parenthesize-markup num)))
1524          (num (grob-interpret-markup grob num))
1525          (num (ly:stencil-aligned-to num X (ly:grob-property grob 'self-alignment-X)))
1526          (left-bound (ly:spanner-bound grob LEFT))
1527          (right-bound (ly:spanner-bound grob RIGHT))
1528          (elts-L (ly:grob-array->list (ly:grob-object left-bound 'elements)))
1529          (elts-R (ly:grob-array->list (ly:grob-object right-bound 'elements)))
1530          (break-alignment-L
1531            (filter
1532              (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
1533              elts-L))
1534          (break-alignment-R
1535            (filter
1536              (lambda (elt) (grob::has-interface elt 'break-alignment-interface))
1537              elts-R))
1538          (refp (ly:grob-system grob))
1539          (break-alignment-L-ext (ly:grob-extent (car break-alignment-L) refp X))
1540          (break-alignment-R-ext (ly:grob-extent (car break-alignment-R) refp X))
1541          (num
1542            (ly:stencil-translate-axis
1543              num
1544              (+ (interval-length break-alignment-L-ext)
1545                 (* 0.5
1546                    (- (car break-alignment-R-ext)
1547                       (cdr break-alignment-L-ext))))
1548              X)))
1549     num))
1550
1551 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1552 ;; HorizontalBracketText
1553
1554 (define-public (ly:horizontal-bracket-text::print grob)
1555   (let ((text (ly:grob-property grob 'text)))
1556     (if (or (null? text)
1557             (equal? text "")
1558             (equal? text empty-markup))
1559         (begin
1560           (ly:grob-suicide! grob)
1561           '())
1562         (let* ((orig (ly:grob-original grob))
1563                (siblings (ly:spanner-broken-into orig))
1564                (text
1565                  (if (or (null? siblings)
1566                          (eq? grob (car siblings)))
1567                      text
1568                      (if (string? text)
1569                          (string-append "(" text ")")
1570                          (make-parenthesize-markup text)))))
1571           (grob-interpret-markup grob text)))))
1572
1573 (define-public (ly:horizontal-bracket-text::calc-direction grob)
1574   (let* ((bracket (ly:grob-object grob 'bracket))
1575          (bracket-dir (ly:grob-property bracket 'direction DOWN)))
1576     bracket-dir))
1577
1578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1579 ;; make-engraver helper macro
1580
1581 (defmacro-public make-engraver forms
1582   "Helper macro for creating Scheme engravers.
1583
1584 The usual form for an engraver is an association list (or alist)
1585 mapping symbols to either anonymous functions or to another such
1586 alist.
1587
1588 @code{make-engraver} accepts forms where the first element is either
1589 an argument list starting with the respective symbol, followed by the
1590 function body (comparable to the way @code{define} is used for
1591 defining functions), or a single symbol followed by subordinate forms
1592 in the same manner.  You can also just make an alist pair
1593 literally (the @samp{car} is quoted automatically) as long as the
1594 unevaluated @samp{cdr} is not a pair.  This is useful if you already
1595 have defined your engraver functions separately.
1596
1597 Symbols mapping to a function would be @code{initialize},
1598 @code{start-translation-timestep}, @code{process-music},
1599 @code{process-acknowledged}, @code{stop-translation-timestep}, and
1600 @code{finalize}.  Symbols mapping to another alist specified in the
1601 same manner are @code{listeners} with the subordinate symbols being
1602 event classes, and @code{acknowledgers} and @code{end-acknowledgers}
1603 with the subordinate symbols being interfaces."
1604   (let loop ((forms forms))
1605     (if (or (null? forms) (pair? forms))
1606         `(list
1607           ,@(map (lambda (form)
1608                    (if (pair? (car form))
1609                        `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
1610                        `(cons ',(car form) ,(loop (cdr form)))))
1611                  forms))
1612         forms)))