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-public (make-connected-line points grob)
1169   "Takes a list of points, @var{points}.
1170 Returns a line connecting @var{points}, using @code{ly:line-interface::line},
1171 gets layout information from @var{grob}"
1172   (define (connected-points grob ls pts)
1173     (if (not (pair? (cdr pts)))
1174         (reduce ly:stencil-add empty-stencil ls)
1175         (connected-points
1176           grob
1177           (cons
1178             (ly:line-interface::line
1179               grob
1180               (car (first pts))
1181               (cdr (first pts))
1182               (car (second pts))
1183               (cdr (second pts)))
1184             ls)
1185           (cdr pts))))
1186   (if (< (length points) 2)
1187       (begin
1188         (ly:warning
1189           "´make-connected-line´ needs at least two points: ~a"
1190           points)
1191         empty-stencil)
1192       (connected-points grob '() points)))
1193
1194 (define ((elbowed-hairpin coords mirrored?) grob)
1195   "Create hairpin based on a list of @var{coords} in @code{(cons x y)}
1196 form.  @code{x} is the portion of the width consumed for a given line
1197 and @code{y} is the portion of the height.  For example,
1198 @code{'((0 . 0) (0.3 . 0.7) (0.8 . 0.9) (1.0 . 1.0))} means that at the point
1199 where the hairpin has consumed 30% of its width, it must
1200 be at 70% of its height.  Once it is to 80% width, it
1201 must be at 90% height.  It finishes at 100% width and 100% height.
1202 If @var{coords} does not begin with @code{'(0 . 0)} the final hairpin may have
1203 an open tip.  For example '(0 . 0.5) will cause an open end of 50% of the usual
1204 height.
1205 @var{mirrored?} indicates if the hairpin is mirrored over the Y-axis or if
1206 just the upper part is drawn.
1207 Returns a function that accepts a hairpin grob as an argument
1208 and draws the stencil based on its coordinates.
1209
1210 @lilypond[verbatim,quote]
1211 #(define simple-hairpin
1212   (elbowed-hairpin '((0 . 0)(1.0 . 1.0)) #t))
1213
1214 \\relative c' {
1215   \\override Hairpin #'stencil = #simple-hairpin
1216   a\\p\\< a a a\\f
1217 }
1218 @end lilypond
1219 "
1220   (define (scale-coords coords-list x y)
1221     (map
1222       (lambda (coord) (cons (* x (car coord)) (* y (cdr coord))))
1223       coords-list))
1224
1225   (define (hairpin::print-part points decresc? me)
1226     (let ((stil (make-connected-line points me)))
1227       (if decresc? (ly:stencil-scale stil -1 1) stil)))
1228
1229   ;; outer let to trigger suicide
1230   (let ((sten (ly:hairpin::print grob)))
1231     (if (grob::is-live? grob)
1232         (let* ((decresc? (eqv? (ly:grob-property grob 'grow-direction) LEFT))
1233                (xex (ly:stencil-extent sten X))
1234                (lenx (interval-length xex))
1235                (yex (ly:stencil-extent sten Y))
1236                (leny (interval-length yex))
1237                (xtrans (+ (car xex) (if decresc? lenx 0)))
1238                (ytrans (car yex))
1239                (uplist (scale-coords coords lenx (/ leny 2)))
1240                (downlist (scale-coords coords lenx (/ leny -2)))
1241                (stil
1242                  (ly:stencil-aligned-to
1243                    (ly:stencil-translate
1244                      (ly:stencil-add
1245                        (hairpin::print-part uplist decresc? grob)
1246                        (if mirrored?
1247                            (hairpin::print-part downlist decresc? grob)
1248                            empty-stencil))
1249                      (cons xtrans ytrans))
1250                    Y CENTER))
1251                (stil-y-extent (ly:stencil-extent stil Y)))
1252         ;; Return a final stencil properly aligned in Y-axis direction and with
1253         ;; proper extents. Otherwise stencil-operations like 'box-stencil' will
1254         ;; return badly. Extent in X-axis direction is taken from the original,
1255         ;; in Y-axis direction from the new stencil.
1256         (ly:make-stencil (ly:stencil-expr stil) xex stil-y-extent))
1257         ;; return empty, if no Hairpin.stencil present.
1258         '())))
1259 (export elbowed-hairpin)
1260
1261 (define-public flared-hairpin
1262   (elbowed-hairpin '((0 . 0) (0.95 . 0.4) (1.0 . 1.0)) #t))
1263
1264 (define-public constante-hairpin
1265   (elbowed-hairpin '((0 . 0) (1.0 . 0.0) (1.0 . 1.0)) #f))
1266
1267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1268 ;; lyrics
1269
1270 (define-public (lyric-text::print grob)
1271   "Allow interpretation of tildes as lyric tieing marks."
1272
1273   (let ((text (ly:grob-property grob 'text)))
1274
1275     (grob-interpret-markup grob (if (string? text)
1276                                     (make-tied-lyric-markup text)
1277                                     text))))
1278
1279 (define ((grob::calc-property-by-copy prop) grob)
1280   (ly:event-property (event-cause grob) prop))
1281 (export grob::calc-property-by-copy)
1282
1283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1284 ;; general inheritance
1285
1286 (define ((grob::inherit-parent-property axis property . default) grob)
1287   "@var{grob} callback generator for inheriting a @var{property} from
1288 an @var{axis} parent, defaulting to @var{default} if there is no
1289 parent or the parent has no setting."
1290   (let ((parent (ly:grob-parent grob axis)))
1291     (cond
1292      ((ly:grob? parent)
1293       (apply ly:grob-property parent property default))
1294      ((pair? default) (car default))
1295      (else '()))))
1296 (export grob::inherit-parent-property)
1297
1298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1299 ;; fret boards
1300
1301 (define-public (fret-board::calc-stencil grob)
1302   (grob-interpret-markup
1303    grob
1304    (make-fret-diagram-verbose-markup
1305     (ly:grob-property grob 'dot-placement-list))))
1306
1307
1308 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1309 ;; slurs
1310
1311 (define-public slur::height
1312   (ly:make-unpure-pure-container
1313    ly:slur::height
1314    ly:slur::pure-height))
1315
1316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1317 ;; scripts
1318
1319 (define-public (script-interface::calc-x-offset grob)
1320   (ly:grob-property grob 'positioning-done)
1321   (let* ((shift-when-alone (ly:grob-property grob 'toward-stem-shift 0.0))
1322          (shift-in-column (ly:grob-property grob 'toward-stem-shift-in-column))
1323          (script-column (ly:grob-object grob 'script-column))
1324          (shift
1325            (if (and (ly:grob? script-column)
1326                     (number? shift-in-column)
1327                     ;; ScriptColumn can contain grobs other than Script.
1328                     ;; These should not result in a shift.
1329                     (any (lambda (s)
1330                            (and (not (eq? s grob))
1331                                 (grob::has-interface s 'script-interface)
1332                                 (not (grob::has-interface s
1333                                        'accidental-suggestion-interface))))
1334                          (ly:grob-array->list
1335                            (ly:grob-object script-column 'scripts))))
1336                shift-in-column shift-when-alone))
1337          (note-head-location
1338           (ly:self-alignment-interface::aligned-on-x-parent grob))
1339          (note-head-grob (ly:grob-parent grob X))
1340          (stem-grob (ly:grob-object note-head-grob 'stem)))
1341
1342     (+ note-head-location
1343        ;; If the script has the same direction as the stem, move the script
1344        ;; in accordance with the value of 'shift'.  Since scripts can also be
1345        ;; over skips, we need to check whether the grob has a stem at all.
1346        (if (ly:grob? stem-grob)
1347            (let ((dir1 (ly:grob-property grob 'direction))
1348                  (dir2 (ly:grob-property stem-grob 'direction)))
1349              (if (equal? dir1 dir2)
1350                  (let* ((common-refp (ly:grob-common-refpoint grob stem-grob X))
1351                         (stem-location
1352                          (ly:grob-relative-coordinate stem-grob common-refp X)))
1353                    (* shift (- stem-location note-head-location)))
1354                  0.0))
1355            0.0))))
1356
1357
1358 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1359 ;; instrument names
1360
1361 (define-public (system-start-text::print grob)
1362   (let* ((left-bound (ly:spanner-bound grob LEFT))
1363          (left-mom (ly:grob-property left-bound 'when))
1364          (name (if (moment<=? left-mom ZERO-MOMENT)
1365                    (ly:grob-property grob 'long-text)
1366                    (ly:grob-property grob 'text))))
1367
1368     (if (and (markup? name)
1369              (!= (ly:item-break-dir left-bound) CENTER))
1370
1371         (grob-interpret-markup grob name)
1372         (ly:grob-suicide! grob))))
1373
1374 (define-public (system-start-text::calc-x-offset grob)
1375   (let* ((left-bound (ly:spanner-bound grob LEFT))
1376          (left-mom (ly:grob-property left-bound 'when))
1377          (layout (ly:grob-layout grob))
1378          (indent (ly:output-def-lookup layout
1379                                        (if (moment<=? left-mom ZERO-MOMENT)
1380                                            'indent
1381                                            'short-indent)
1382                                        0.0))
1383          (system (ly:grob-system grob))
1384          (my-extent (ly:grob-extent grob system X))
1385          (elements (ly:grob-object system 'elements))
1386          (common (ly:grob-common-refpoint-of-array system elements X))
1387          (total-ext empty-interval)
1388          (align-x (ly:grob-property grob 'self-alignment-X 0))
1389          (padding (min 0 (- (interval-length my-extent) indent)))
1390          (right-padding (- padding
1391                            (/ (* padding (1+ align-x)) 2))))
1392
1393     ;; compensate for the variation in delimiter extents by
1394     ;; calculating an X-offset correction based on united extents
1395     ;; of all delimiters in this system
1396     (let unite-delims ((l (ly:grob-array-length elements)))
1397       (if (> l 0)
1398           (let ((elt (ly:grob-array-ref elements (1- l))))
1399
1400             (if (grob::has-interface elt 'system-start-delimiter-interface)
1401                 (let ((dims (ly:grob-extent elt common X)))
1402                   (if (interval-sane? dims)
1403                       (set! total-ext (interval-union total-ext dims)))))
1404             (unite-delims (1- l)))))
1405
1406     (+
1407      (ly:side-position-interface::x-aligned-side grob)
1408      right-padding
1409      (- (interval-length total-ext)))))
1410
1411 (define-public (system-start-text::calc-y-offset grob)
1412
1413   (define (live-elements-list me)
1414     (let ((elements (ly:grob-object me 'elements)))
1415
1416       (filter! grob::is-live?
1417                (ly:grob-array->list elements))))
1418
1419   (let* ((left-bound (ly:spanner-bound grob LEFT))
1420          (live-elts (live-elements-list grob))
1421          (system (ly:grob-system grob))
1422          (extent empty-interval))
1423
1424     (if (and (pair? live-elts)
1425              (interval-sane? (ly:grob-extent grob system Y)))
1426         (let get-extent ((lst live-elts))
1427           (if (pair? lst)
1428               (let ((axis-group (car lst)))
1429
1430                 (if (and (ly:spanner? axis-group)
1431                          (equal? (ly:spanner-bound axis-group LEFT)
1432                                  left-bound))
1433                     (set! extent (add-point extent
1434                                             (ly:grob-relative-coordinate
1435                                              axis-group system Y))))
1436                 (get-extent (cdr lst)))))
1437         ;; no live axis group(s) for this instrument name -> remove from system
1438         (ly:grob-suicide! grob))
1439
1440     (+
1441      (ly:self-alignment-interface::y-aligned-on-self grob)
1442      (interval-center extent))))
1443
1444
1445 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1446 ;; axis group interface
1447
1448 (define-public axis-group-interface::height
1449   (ly:make-unpure-pure-container
1450    ly:axis-group-interface::height
1451    ly:axis-group-interface::pure-height))
1452
1453 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1454 ;; ambitus
1455
1456 ;; Calculate the gaps between ambitus heads and ends of ambitus line.
1457 ;; Start by determining desired length of the ambitus line (based on
1458 ;; length-fraction property), calc gap from that and make sure that
1459 ;; it doesn't exceed maximum allowed value.
1460
1461 (define-public (ambitus-line::calc-gap grob)
1462   (let ((heads (ly:grob-object grob 'note-heads)))
1463
1464   (if (and (ly:grob-array? heads)
1465              (= (ly:grob-array-length heads) 2))
1466       (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1467               (head-down (ly:grob-array-ref heads 0))
1468               (head-up (ly:grob-array-ref heads 1))
1469               (fraction (ly:grob-property grob 'length-fraction 0.7))
1470               (max-gap (ly:grob-property grob 'maximum-gap 0.45))
1471               ;; distance between noteheads:
1472               (distance (- (interval-start (ly:grob-extent head-up common Y))
1473                           (interval-end (ly:grob-extent head-down common Y))))
1474               (gap (* 0.5 distance (- 1 fraction))))
1475
1476          (min gap max-gap))
1477       0)))
1478
1479 ;; Print a line connecting ambitus heads:
1480
1481 (define-public (ambitus::print grob)
1482   (let ((heads (ly:grob-object grob 'note-heads)))
1483
1484     (if (and (ly:grob-array? heads)
1485              (= (ly:grob-array-length heads) 2))
1486         (let* ((common (ly:grob-common-refpoint-of-array grob heads Y))
1487                (head-down (ly:grob-array-ref heads 0))
1488                (head-up (ly:grob-array-ref heads 1))
1489                ;; The value used when 'gap' property cannot be read is small
1490                ;; to make sure that ambitus of a fifth will have a visible line.
1491                (gap (ly:grob-property grob 'gap 0.25))
1492                (point-min (+ (interval-end (ly:grob-extent head-down common Y))
1493                              gap))
1494                (point-max (- (interval-start (ly:grob-extent head-up common Y))
1495                              gap)))
1496
1497           (if (< (+ point-min 0.1) point-max) ; don't print lines shorter than 0.1ss
1498               (let* ((layout (ly:grob-layout grob))
1499                      (line-thick (ly:output-def-lookup layout 'line-thickness))
1500                      (blot (ly:output-def-lookup layout 'blot-diameter))
1501                      (grob-thick (ly:grob-property grob 'thickness 2))
1502                      (width (* line-thick grob-thick))
1503                      (x-ext (symmetric-interval (/ width 2)))
1504                      (y-ext (cons point-min point-max))
1505                      (line (ly:round-filled-box x-ext y-ext blot))
1506                      (y-coord (ly:grob-relative-coordinate grob common Y)))
1507
1508                 (ly:stencil-translate-axis line (- y-coord) Y))
1509               empty-stencil))
1510         (begin
1511           (ly:grob-suicide! grob)
1512           (list)))))
1513
1514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1515 ;;  laissez-vibrer tie
1516 ;;
1517 ;;  needed so we can make laissez-vibrer a pure print
1518 ;;
1519 (define-public (laissez-vibrer::print grob)
1520   (ly:tie::print grob))
1521
1522 (define-public (semi-tie::calc-cross-staff grob)
1523   (let* ((note-head (ly:grob-object grob 'note-head))
1524          (stem (ly:grob-object note-head 'stem)))
1525     (and (ly:grob? stem)
1526          (ly:grob-property stem 'cross-staff #f))))
1527
1528 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1529 ;; volta-bracket
1530
1531 (define-public (volta-bracket-interface::pure-height grob start end)
1532   (let ((edge-height (ly:grob-property grob 'edge-height)))
1533     (if (number-pair? edge-height)
1534         (let ((smaller (min (car edge-height) (cdr edge-height)))
1535               (larger (max (car edge-height) (cdr edge-height))))
1536           (interval-union '(0 . 0) (cons smaller larger)))
1537         '(0 . 0))))
1538
1539 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1540 ;; measure counter
1541
1542 (define-public (measure-counter-stencil grob)
1543   "Print a number for a measure count.  Broken measures are numbered in
1544 parentheses."
1545   (let* ((num (make-simple-markup
1546                 (number->string (ly:grob-property grob 'count-from))))
1547          (orig (ly:grob-original grob))
1548          (siblings (ly:spanner-broken-into orig)) ; have we been split?
1549          (num
1550            (if (or (null? siblings)
1551                    (eq? grob (car siblings)))
1552               num
1553               (make-parenthesize-markup num)))
1554          (num (grob-interpret-markup grob num))
1555          (num (ly:stencil-aligned-to
1556                 num X (ly:grob-property grob 'self-alignment-X)))
1557          (left-bound (ly:spanner-bound grob LEFT))
1558          (right-bound (ly:spanner-bound grob RIGHT))
1559          (refp (ly:grob-common-refpoint left-bound right-bound X))
1560          (spacing-pair
1561            (ly:grob-property grob
1562                              'spacing-pair
1563                              '(break-alignment . break-alignment)))
1564          (ext-L (ly:paper-column::break-align-width left-bound
1565                                                     (car spacing-pair)))
1566          (ext-R (ly:paper-column::break-align-width right-bound
1567                                                     (cdr spacing-pair)))
1568          (num
1569            (ly:stencil-translate-axis
1570              num
1571              (+ (* 0.5 (- (car ext-R)
1572                           (cdr ext-L)))
1573                 (- (cdr ext-L)
1574                    (ly:grob-relative-coordinate grob refp X)))
1575              X)))
1576     num))
1577
1578 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1579 ;; HorizontalBracketText
1580
1581 (define-public (ly:horizontal-bracket-text::print grob)
1582   (let ((text (ly:grob-property grob 'text)))
1583     (if (or (null? text)
1584             (equal? text "")
1585             (equal? text empty-markup))
1586         (begin
1587           (ly:grob-suicide! grob)
1588           '())
1589         (let* ((orig (ly:grob-original grob))
1590                (siblings (ly:spanner-broken-into orig))
1591                (text
1592                  (if (or (null? siblings)
1593                          (eq? grob (car siblings)))
1594                      text
1595                      (if (string? text)
1596                          (string-append "(" text ")")
1597                          (make-parenthesize-markup text)))))
1598           (grob-interpret-markup grob text)))))
1599
1600 (define-public (ly:horizontal-bracket-text::calc-direction grob)
1601   (let* ((bracket (ly:grob-object grob 'bracket))
1602          (bracket-dir (ly:grob-property bracket 'direction DOWN)))
1603     bracket-dir))
1604
1605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1606 ;; make-engraver helper macro
1607
1608 (defmacro-public make-engraver forms
1609   "Helper macro for creating Scheme engravers.
1610
1611 The usual form for an engraver is an association list (or alist)
1612 mapping symbols to either anonymous functions or to another such
1613 alist.
1614
1615 @code{make-engraver} accepts forms where the first element is either
1616 an argument list starting with the respective symbol, followed by the
1617 function body (comparable to the way @code{define} is used for
1618 defining functions), or a single symbol followed by subordinate forms
1619 in the same manner.  You can also just make an alist pair
1620 literally (the @samp{car} is quoted automatically) as long as the
1621 unevaluated @samp{cdr} is not a pair.  This is useful if you already
1622 have defined your engraver functions separately.
1623
1624 Symbols mapping to a function would be @code{initialize},
1625 @code{start-translation-timestep}, @code{process-music},
1626 @code{process-acknowledged}, @code{stop-translation-timestep}, and
1627 @code{finalize}.  Symbols mapping to another alist specified in the
1628 same manner are @code{listeners} with the subordinate symbols being
1629 event classes, and @code{acknowledgers} and @code{end-acknowledgers}
1630 with the subordinate symbols being interfaces."
1631   (let loop ((forms forms))
1632     (if (or (null? forms) (pair? forms))
1633         `(list
1634           ,@(map (lambda (form)
1635                    (if (pair? (car form))
1636                        `(cons ',(caar form) (lambda ,(cdar form) ,@(cdr form)))
1637                        `(cons ',(car form) ,(loop (cdr form)))))
1638                  forms))
1639         forms)))