scm/stencil.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (define (make-bezier-sandwich-stencil coords thick)
  19    (make-path-stencil
  20        `(moveto
  21            ,(car (list-ref coords 0))
  22            ,(cdr (list-ref coords 0))
  23          curveto
  24            ,(car (list-ref coords 1))
  25            ,(cdr (list-ref coords 1))
  26            ,(car (list-ref coords 2))
  27            ,(cdr (list-ref coords 2))
  28            ,(car (list-ref coords 3))
  29            ,(cdr (list-ref coords 3))
  30          curveto
  31            ,(car (list-ref coords 4))
  32            ,(cdr (list-ref coords 4))
  33            ,(car (list-ref coords 5))
  34            ,(cdr (list-ref coords 5))
  35            ,(car (list-ref coords 0))
  36            ,(cdr (list-ref coords 0))
  37          closepath)
  38        thick
  39        1
  40        1
  41        #t))
  42
  43 (define-public (make-bow-stencil
  44            start stop thickness angularity bow-height orientation)
  45   "Create a bow stencil.
  46 It starts at point @var{start}, ends at point @var{stop}.
  47 @var{thickness} is the thickness of the bow.
  48 The higher the value of number @var{angularity}, the more angular the shape of
  49 the bow.
  50 @var{bow-height} determines the height of the bow.
  51 @var{orientation} determines, whether the bow is concave or convex.
  52 Both variables are supplied to support independent usage.
  53
  54 Done by calculating a horizontal unit-bow first, then moving all control-points
  55 to the correct positions.
  56 Limitation: s-curves are currently not supported.
  57 "
  58
  59 ;;;; Coding steps:
  60 ;;;; (1) calculate control-points for a "unit"-bow from '(0 . 0) to '(1 . 0)
  61 ;;;;     user settable `bow-height' and `thickness' are scaled down.
  62 ;;;; (2) move control-points to match `start' and `stop'
  63
  64   (let* (;; we use a fixed line-width as border for different behaviour
  65          ;; for larger and (very) small lengths
  66          (line-width 0.1)
  67          ;; `start'-`stop' distances
  68          (dx (- (car stop) (car start)))
  69          (dy (- (cdr stop) (cdr start)))
  70          (length-to-print (magnitude (make-rectangular dx dy))))
  71
  72     (if (= 0 length-to-print)
  73         empty-stencil
  74         (let* (
  75           ;;;; (1) calculate control-points for the horizontal unit-bow,
  76                ;; y-values for 2nd/3rd control-points
  77                (outer-control
  78                  (* 4/3 (sign orientation) (/ bow-height length-to-print)))
  79                (inner-control
  80                  (* (sign orientation)
  81                     (- (abs outer-control) (/ thickness length-to-print))))
  82                ;; x-values for 2nd/3rd control-points depending on `angularity'
  83                (offset-index
  84                  (- (* 0.6 angularity) 0.8))
  85                (left-control
  86                  (+ 0.1 (* 0.3 angularity)))
  87                (right-control
  88                  (- 1 left-control))
  89                ;; defining 2nd and 3rd outer control-points
  90                (left-outer-control-point
  91                  (cons left-control outer-control))
  92                (right-outer-control-point
  93                  (cons right-control outer-control))
  94                ;; defining 2nd and 3rd inner control-points
  95                (left-inner-control-point
  96                  (cons left-control inner-control))
  97                (right-inner-control-point
  98                  (cons right-control inner-control))
  99                (coord-list
 100                  (list
 101                    '(0 . 0)
 102                    left-outer-control-point
 103                    right-outer-control-point
 104                    '(1 . 0)
 105                    right-inner-control-point
 106                    left-inner-control-point))
 107                ;;;; (2) move control-points to match `start' and `stop'
 108                (moved-coord-list
 109                  (map
 110                    (lambda (p)
 111                      (cons
 112                        (+ (car start) (- (* (car p) dx) (* (cdr p) dy)))
 113                        (+ (cdr start) (+ (* (car p) dy) (* (cdr p) dx)))))
 114                    coord-list)))
 115
 116           ;; final stencil
 117           (make-bezier-sandwich-stencil
 118             moved-coord-list
 119             (min (* 2 thickness) line-width))))))
 120
 121 (define-public (make-tie-stencil start stop thickness orientation)
 122   (let* (;; For usage in text we choose a little less `height-limit'
 123          ;; than the default for `Tie'
 124          (height-limit 0.7)
 125          (ratio 0.33)
 126          ;; taken from bezier-bow.cc
 127          (F0_1
 128            (lambda (x) (* (/ 2 PI) (atan (* PI x 0.5)))))
 129          (slur-height
 130            (lambda (w h_inf r_0) (F0_1 (* (/ (* w r_0) h_inf) h_inf))))
 131          (width (abs (- (car start) (car stop))))
 132          (angularity 0.5)
 133          (height (slur-height width height-limit ratio)))
 134     (make-bow-stencil start stop thickness angularity height orientation)))
 135
 136 (define-public (stack-stencils axis dir padding stils)
 137   "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
 138 @var{padding}."
 139   (reduce
 140    (lambda (next front)
 141      (ly:stencil-stack front axis dir next padding))
 142    empty-stencil
 143    stils))
 144
 145 (define-public (stack-stencils-padding-list axis dir paddings stils)
 146   "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
 147 a list of @var{paddings}."
 148   (if (null? stils)
 149       empty-stencil
 150       (fold
 151        (lambda (next padding front)
 152          (let ((offset (+ (- (interval-end (ly:stencil-extent front axis))
 153                              (interval-start (ly:stencil-extent next axis)))
 154                           padding)))
 155            (ly:stencil-add
 156              front
 157              (ly:stencil-translate-axis next offset axis))))
 158        (car stils)
 159        (cdr stils)
 160        paddings)))
 161
 162 (define-public (centered-stencil stencil)
 163   "Center stencil @var{stencil} in both the X and Y directions."
 164   (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
 165
 166 (define-public (stack-lines dir padding baseline stils)
 167   "Stack vertically with a baseline skip."
 168   (reduce-right
 169    (lambda (next back) (ly:stencil-stack next Y dir back padding baseline))
 170    empty-stencil
 171    (map
 172     (lambda (s)
 173       ;; X-empty stencils may add vertical space.  A stencil that is
 174       ;; merely Y-empty counts as horizontal spacing.  Since we want
 175       ;; those to register as lines of their own (is this a good
 176       ;; idea?), we make them a separately visible line.
 177       (if (and (ly:stencil-empty? s Y)
 178                (not (ly:stencil-empty? s X)))
 179           (ly:make-stencil (ly:stencil-expr s) (ly:stencil-extent s X) '(0 . 0))
 180           s))
 181     stils)))
 182
 183 (define-public (bracketify-stencil stil axis thick protrusion padding)
 184   "Add brackets around @var{stil}, producing a new stencil."
 185
 186   (let* ((ext (ly:stencil-extent stil axis))
 187          (lb (ly:bracket axis ext thick protrusion))
 188          (rb (ly:bracket axis ext thick (- protrusion))))
 189     (set! stil
 190           (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
 191     (set! stil
 192           (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding))
 193     stil))
 194
 195 (define (make-parenthesis-stencil
 196          y-extent thickness width angularity orientation)
 197   "Create a parenthesis stencil.
 198 @var{y-extent} is the Y extent of the markup inside the parenthesis.
 199 @var{half-thickness} is the half thickness of the parenthesis.
 200 @var{width} is the width of a parenthesis.
 201 @var{orientation} is the orientation of a parenthesis.
 202 The higher the value of number @var{angularity},
 203 the more angular the shape of the parenthesis."
 204   (let* ((start (cons 0 (car y-extent)))
 205          (stop (cons 0 (cdr y-extent)))
 206          (line-width 0.1)
 207          (bow-stil
 208            (make-bow-stencil
 209              start stop thickness angularity width orientation))
 210          (x-extent (ly:stencil-extent bow-stil X)))
 211     (ly:make-stencil
 212       (ly:stencil-expr bow-stil)
 213       (interval-widen x-extent (/ line-width 2))
 214       (interval-widen y-extent (/ line-width 2)))))
 215
 216 (define-public (parenthesize-stencil
 217                 stencil half-thickness width angularity padding)
 218   "Add parentheses around @var{stencil}, returning a new stencil."
 219   (let* ((y-extent (ly:stencil-extent stencil Y))
 220          (lp (make-parenthesis-stencil
 221               y-extent half-thickness width angularity 1))
 222          (rp (make-parenthesis-stencil
 223               y-extent half-thickness width angularity -1)))
 224     (set! stencil (ly:stencil-combine-at-edge stencil X LEFT lp padding))
 225     (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
 226     stencil))
 227
 228 (define-public (make-line-stencil width startx starty endx endy)
 229   "Make a line stencil of given linewidth and set its extents accordingly."
 230   (let ((xext (cons (min startx endx) (max startx endx)))
 231         (yext (cons (min starty endy) (max starty endy))))
 232     (ly:make-stencil
 233      (list 'draw-line width startx starty endx endy)
 234      ;; Since the line has rounded edges, we have to / can safely add half the
 235      ;; width to all coordinates!
 236      (interval-widen xext (/ width 2))
 237      (interval-widen yext (/ width 2)))))
 238
 239 (define-public (make-transparent-box-stencil xext yext)
 240   "Make a transparent box."
 241   (ly:stencil-outline empty-stencil (make-filled-box-stencil xext yext)))
 242
 243 (define-public (make-filled-box-stencil xext yext)
 244   "Make a filled box."
 245
 246   (ly:make-stencil
 247    (list 'round-filled-box (- (car xext)) (cdr xext)
 248          (- (car yext)) (cdr yext) 0.0)
 249    xext yext))
 250
 251 (define-public (make-circle-stencil radius thickness fill)
 252   "Make a circle of radius @var{radius} and thickness @var{thickness}."
 253   (let*
 254       ((out-radius (+ radius (/ thickness 2.0))))
 255
 256     (ly:make-stencil
 257      (list 'circle radius thickness fill)
 258      (cons (- out-radius) out-radius)
 259      (cons (- out-radius) out-radius))))
 260
 261 (define-public (make-oval-stencil x-radius y-radius thickness fill)
 262   "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
 263 y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
 264 defined by @code{fill}."
 265   (let*
 266       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 267        (y-out-radius (+ y-radius (/ thickness 2.0)))
 268        (x-max x-radius)
 269        (x-min (- x-radius))
 270        (y-max y-radius)
 271        (y-min (- y-radius))
 272        (commands `(,(list 'moveto x-max 0)
 273                    ,(list 'curveto x-max y-max x-min y-max x-min 0)
 274                    ,(list 'curveto x-min y-min x-max y-min x-max 0)
 275                    ,(list 'closepath)))
 276        (command-list (fold-right append '() commands)))
 277     (ly:make-stencil
 278      `(path ,thickness `(,@',command-list) 'round 'round ,fill)
 279      (cons (- x-out-radius) x-out-radius)
 280      (cons (- y-out-radius) y-out-radius))))
 281
 282 (define-public
 283   (make-partial-ellipse-stencil
 284    x-radius y-radius start-angle end-angle thick connect fill)
 285   "Create an elliptical arc
 286 @var{x-radius} is the X radius of the arc.
 287 @var{y-radius} is the Y radius of the arc.
 288 @var{start-angle} is the starting angle of the arc in degrees.
 289 @var{end-angle} is the ending angle of the arc in degrees.
 290 @var{thick} is the thickness of the line.
 291 @var{connect} is a boolean flag indicating if the end should
 292 be connected to the start by a line.
 293 @var{fill} is a boolean flag indicating if the shape should be filled."
 294   (define (make-radius-list x-radius y-radius)
 295     "Makes a list of angle/radius pairs at intervals of PI/2 for
 296 the partial ellipse until 7*PI/2.  For example, in pseudo-code:
 297 > (make-radius-list 2 3)\
 298 \n((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3)\
 299 \n(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3))
 300 "
 301     (append-map
 302      (lambda (adder)
 303        (map (lambda (quadrant)
 304               (cons (+ adder (car quadrant))
 305                     (cdr quadrant)))
 306             `((0.0 . (,x-radius . 0.0))
 307               (,PI-OVER-TWO . (0.0 . ,y-radius))
 308               (,PI . (,(- x-radius) . 0.0))
 309               (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
 310      `(0.0 ,TWO-PI)))
 311
 312   (define
 313     (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
 314     "Insert @var{value} in ordered list @var{inlist}. If @var{cutl?}, we
 315 cut away any parts of @var{inlist} before @var{value}. @var{cutr?} works
 316 the same way but for the right side. For example:
 317 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #f)
 318 '(1 2 3 4 6 7)
 319 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f)
 320 '(4 6 7)
 321 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t)
 322 '(1 2 3 4)
 323 "
 324     (define
 325       (helper ordering-function value left-list right-list cutl? cutr?)
 326       (if (null? right-list)
 327           (append
 328            (if cutl? '() left-list)
 329            (list value)
 330            (if cutr? '() right-list))
 331           (if (ordering-function value (car right-list))
 332               (append
 333                (if cutl? '() left-list)
 334                (list value)
 335                (if cutr? '() right-list))
 336               (helper
 337                ordering-function
 338                value
 339                (append left-list (list (car right-list)))
 340                (cdr right-list)
 341                cutl?
 342                cutr?))))
 343     (helper ordering-function value '() inlist cutl? cutr?))
 344
 345   (define (ordering-function-1 a b) (car< a b))
 346
 347   (define (ordering-function-2 a b) (car<= a b))
 348
 349   (define (min-max-crawler min-max side l)
 350     "Apply function @var{side} to each member of list and
 351 then reduce using @var{min-max}:
 352 > (min-max-crawler min car '((0 . 3) (-1 . 4) (1 . 2)))
 353 -1
 354 > (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2)))
 355 2
 356 "
 357     (reduce min-max
 358             (if (eq? min-max min) 100000 -100000)
 359             (map side l)))
 360
 361   (let*
 362       (;; the outside limit of the x-radius
 363        (x-out-radius (+ x-radius (/ thick 2.0)))
 364        ;; the outside limit of the y-radius
 365        (y-out-radius (+ y-radius (/ thick 2.0)))
 366        ;; end angle to radians
 367        (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
 368        ;; length of the radius at the end angle
 369        (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
 370        ;; start angle to radians
 371        (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
 372        ;; length of the radius at the start angle
 373        (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
 374        ;; points that the arc passes through at 90 degree intervals
 375        (radius-list (make-radius-list x-out-radius y-out-radius))
 376        ;; rectangular coordinates of arc endpoint
 377        (rectangular-end-radius (polar->rectangular end-radius end-angle))
 378        ;; rectangular coordinates of arc begin point
 379        (rectangular-start-radius (polar->rectangular start-radius start-angle))
 380        ;; we want the end angle to always be bigger than the start angle
 381        ;; so we redefine it here just in case it is less
 382        (new-end-angle
 383         (if (<= new-end-angle new-start-angle)
 384             (+ TWO-PI new-end-angle)
 385             new-end-angle))
 386        ;; all the points that may be extrema of the arc
 387        ;; this is the 90 degree points plus the beginning and end points
 388        ;; we use this to calculate extents
 389        (possible-extrema
 390         (insert-in-ordered-list
 391          ordering-function-2
 392          (cons new-end-angle rectangular-end-radius)
 393          (insert-in-ordered-list
 394           ordering-function-1
 395           (cons new-start-angle rectangular-start-radius)
 396           radius-list
 397           #t
 398           #f)
 399          #f
 400          #t)))
 401     (ly:make-stencil
 402      (list
 403       'partial-ellipse
 404       x-radius
 405       y-radius
 406       start-angle
 407       end-angle
 408       thick
 409       connect
 410       fill)
 411      ;; we know the extrema points by crawling through the
 412      ;; list of possible extrema and finding the min and max
 413      ;; for x and y
 414      (cons (min-max-crawler min cadr possible-extrema)
 415            (min-max-crawler max cadr possible-extrema))
 416      (cons (min-max-crawler min cddr possible-extrema)
 417            (min-max-crawler max cddr possible-extrema)))))
 418
 419 (define (line-part-min-max x1 x2)
 420   (list (min x1 x2) (max x1 x2)))
 421
 422 (define (bezier-part-min-max x1 x2 x3 x4)
 423   ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
 424    (map
 425     (lambda (x)
 426       (+ (* x1 (expt (- 1 x) 3))
 427          (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
 428             (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
 429                (* x4 (expt x 3))))))
 430     (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
 431            (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
 432         (list 0.0 1.0)
 433         (filter
 434          (lambda (x) (and (>= x 0) (<= x 1)))
 435          (append
 436           (list 0.0 1.0)
 437           (map (lambda (op)
 438                  (if (not (eqv? 0.0
 439                                 (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
 440                      ;; Zeros of the bezier curve
 441                      (/ (+ (- x1 (* 2 x2))
 442                            (op x3
 443                                (sqrt (- (+ (expt x2 2)
 444                                            (+ (expt x3 2) (* x1 x4)))
 445                                         (+ (* x1 x3)
 446                                            (+ (* x2 x4) (* x2 x3)))))))
 447                         (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
 448                      ;; Apply L'hopital's rule to get the zeros if 0/0
 449                      (* (op 0 1)
 450                         (/ (/ (- x4 x3) 2)
 451                            (sqrt (- (+ (* x2 x2)
 452                                        (+ (* x3 x3) (* x1 x4)))
 453                                     (+ (* x1 x3)
 454                                        (+ (* x2 x4) (* x2 x3)))))))))
 455                (list + -))))))))
 456
 457 (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
 458   (map (lambda (x)
 459          (apply bezier-part-min-max x))
 460        `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
 461
 462 (define (line-min-max x1 y1 x2 y2)
 463   (map (lambda (x)
 464          (apply line-part-min-max x))
 465        `((,x1 ,x2) (,y1 ,y2))))
 466
 467 (define (path-min-max origin pointlist)
 468
 469   ((lambda (x)
 470      (list
 471       (reduce min +inf.0 (map caar x))
 472       (reduce max -inf.0 (map cadar x))
 473       (reduce min +inf.0 (map caadr x))
 474       (reduce max -inf.0 (map cadadr x))))
 475    (map (lambda (x)
 476           (if (= (length x) 8)
 477               (apply bezier-min-max x)
 478               (apply line-min-max x)))
 479         (map (lambda (x y)
 480                (append (list (cadr (reverse x)) (car (reverse x))) y))
 481              (append (list origin)
 482                      (reverse (cdr (reverse pointlist)))) pointlist))))
 483
 484 (define-public (make-path-stencil path thickness x-scale y-scale fill)
 485   "Make a stencil based on the path described by the list @var{path},
 486 with thickness @var{thickness}, and scaled by @var{x-scale} in the X
 487 direction and @var{y-scale} in the Y direction.  @var{fill} is a boolean
 488 argument that specifies if the path should be filled.  Valid path
 489 commands are: moveto rmoveto lineto rlineto curveto rcurveto closepath,
 490 and their standard SVG single letter equivalents: M m L l C c Z z."
 491
 492   (define (convert-path path origin previous-point)
 493     "Recursive function to standardize command names and
 494 convert any relative path expressions (in @var{path}) to absolute
 495 values.  Returns a list of lists.  @var{origin} is a pair of x and y
 496 coordinates for the origin point of the path (used for closepath and
 497 reset by moveto commands).  @var{previous-point} is a pair of x and y
 498 coordinates for the previous point in the path."
 499     (if (pair? path)
 500         (let*
 501          ((head-raw (car path))
 502           (rest (cdr path))
 503           (head (cond
 504                  ((memq head-raw '(rmoveto M m)) 'moveto)
 505                  ((memq head-raw '(rlineto L l)) 'lineto)
 506                  ((memq head-raw '(rcurveto C c)) 'curveto)
 507                  ((memq head-raw '(Z z)) 'closepath)
 508                  (else head-raw)))
 509           (arity (cond
 510                   ((memq head '(lineto moveto)) 2)
 511                   ((eq? head 'curveto) 6)
 512                   (else 0)))
 513           (coordinates-raw (take rest arity))
 514           (is-absolute (if (memq head-raw
 515                            '(rmoveto m rlineto l rcurveto c)) #f #t))
 516           (coordinates (if is-absolute
 517                            coordinates-raw
 518                            ;; convert relative coordinates to absolute by
 519                            ;; adding them to previous point values
 520                            (map (lambda (c n)
 521                                   (if (even? n)
 522                                       (+ c (car previous-point))
 523                                       (+ c (cdr previous-point))))
 524                              coordinates-raw
 525                              (iota arity))))
 526           (new-point (if (eq? head 'closepath)
 527                          origin
 528                          (cons
 529                           (list-ref coordinates (- arity 2))
 530                           (list-ref coordinates (- arity 1)))))
 531           (new-origin (if (eq? head 'moveto)
 532                           new-point
 533                           origin)))
 534          (cons (cons head coordinates)
 535            (convert-path (drop rest arity) new-origin new-point)))
 536         '()))
 537
 538   (let* ((path-absolute (convert-path path (cons 0 0) (cons 0 0)))
 539          ;; scale coordinates
 540          (path-scaled (if (and (= 1 x-scale) (= 1 y-scale))
 541                           path-absolute
 542                           (map (lambda (path-unit)
 543                                  (map (lambda (c n)
 544                                         (cond
 545                                          ((= 0 n) c)
 546                                          ((odd? n) (* c x-scale))
 547                                          (else (* c y-scale))))
 548                                    path-unit
 549                                    (iota (length path-unit))))
 550                             path-absolute)))
 551          ;; a path must begin with a 'moveto'
 552          (path-final (if (eq? 'moveto (car (car path-scaled)))
 553                          path-scaled
 554                          (append (list (list 'moveto 0 0)) path-scaled)))
 555          ;; remove all commands in order to calculate bounds
 556          (path-headless (map cdr (delete (list 'closepath) path-final)))
 557          (bound-list (path-min-max
 558                       (car path-headless)
 559                       (cdr path-headless))))
 560     (ly:make-stencil
 561      `(path ,thickness
 562         `(,@',(concatenate path-final))
 563         'round
 564         'round
 565         ,(if fill #t #f))
 566      (coord-translate
 567       ((if (< x-scale 0) reverse-interval identity)
 568        (cons
 569         (list-ref bound-list 0)
 570         (list-ref bound-list 1)))
 571       `(,(/ thickness -2) . ,(/ thickness 2)))
 572      (coord-translate
 573       ((if (< y-scale 0) reverse-interval identity)
 574        (cons
 575         (list-ref bound-list 2)
 576         (list-ref bound-list 3)))
 577       `(,(/ thickness -2) . ,(/ thickness 2))))))
 578
 579 (define-public (make-connected-path-stencil pointlist thickness
 580                                             x-scale y-scale connect fill)
 581   "Make a connected path described by the list @var{pointlist}, beginning
 582 at point '(0 . 0), with thickness @var{thickness}, and scaled by
 583 @var{x-scale} in the X direction and @var{y-scale} in the Y direction.
 584 @var{connect} and @var{fill} are boolean arguments that specify if the
 585 path should be connected or filled, respectively."
 586   (make-path-stencil
 587    (concatenate
 588     (append
 589      (map (lambda (path-unit)
 590             (case (length path-unit)
 591               ((2) (append (list 'lineto) path-unit))
 592               ((6) (append (list 'curveto) path-unit))))
 593        pointlist)
 594      ;; if this path is connected, add closepath to the end
 595      (if connect (list '(closepath)) '())))
 596    thickness x-scale y-scale fill))
 597
 598 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
 599   "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
 600 @code{y-radius}, and thickness @var{thickness} with fill defined by
 601 @code{fill}."
 602   (let*
 603       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 604        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 605
 606     (ly:make-stencil
 607      (list 'ellipse x-radius y-radius thickness fill)
 608      (cons (- x-out-radius) x-out-radius)
 609      (cons (- y-out-radius) y-out-radius))))
 610
 611 (define-public (box-grob-stencil grob)
 612   "Make a box of exactly the extents of the grob.  The box precisely
 613 encloses the contents."
 614   (let* ((xext (ly:grob-extent grob grob 0))
 615          (yext (ly:grob-extent grob grob 1))
 616          (thick 0.01))
 617
 618     (ly:stencil-add
 619      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
 620      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
 621      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
 622      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
 623
 624 ;; TODO merge this and prev function.
 625 (define-public (box-stencil stencil thickness padding)
 626   "Add a box around @var{stencil}, producing a new stencil."
 627   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
 628          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
 629          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
 630          (x-rule (make-filled-box-stencil
 631                   (interval-widen x-ext thickness) (cons 0 thickness))))
 632     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
 633     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
 634     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
 635     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
 636     stencil))
 637
 638 (define-public (circle-stencil stencil thickness padding)
 639   "Add a circle around @var{stencil}, producing a new stencil."
 640   (let* ((x-ext (ly:stencil-extent stencil X))
 641          (y-ext (ly:stencil-extent stencil Y))
 642          (diameter (max (interval-length x-ext)
 643                         (interval-length y-ext)))
 644          (radius (+ (/ diameter 2) padding thickness))
 645          (circle (make-circle-stencil radius thickness #f)))
 646
 647     (ly:stencil-add
 648      stencil
 649      (ly:stencil-translate circle
 650                            (cons
 651                             (interval-center x-ext)
 652                             (interval-center y-ext))))))
 653
 654 (define-public (oval-stencil stencil thickness x-padding y-padding)
 655   "Add an oval around @code{stencil}, padded by the padding pair,
 656 producing a new stencil."
 657   (let* ((x-ext (ly:stencil-extent stencil X))
 658          (y-ext (ly:stencil-extent stencil Y))
 659          (x-length (+ (interval-length x-ext) x-padding thickness))
 660          (y-length (+ (interval-length y-ext) y-padding thickness))
 661          (x-radius (* 0.707 x-length) )
 662          (y-radius (* 0.707 y-length) )
 663          (oval (make-oval-stencil x-radius y-radius thickness #f)))
 664
 665     (ly:stencil-add
 666      stencil
 667      (ly:stencil-translate oval
 668                            (cons
 669                             (interval-center x-ext)
 670                             (interval-center y-ext))))))
 671
 672 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
 673   "Add an ellipse around @var{stencil}, padded by the padding pair,
 674 producing a new stencil."
 675   (let* ((x-ext (ly:stencil-extent stencil X))
 676          (y-ext (ly:stencil-extent stencil Y))
 677          (x-length (+ (interval-length x-ext) x-padding thickness))
 678          (y-length (+ (interval-length y-ext) y-padding thickness))
 679          ;; (aspect-ratio (/ x-length y-length))
 680          (x-radius (* 0.707 x-length) )
 681          (y-radius (* 0.707 y-length) )
 682          ;; (diameter (max (- (cdr x-ext) (car x-ext))
 683          ;;             (- (cdr y-ext) (car y-ext))))
 684          ;; radius (+ (/ diameter 2) padding thickness))
 685          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
 686
 687     (ly:stencil-add
 688      stencil
 689      (ly:stencil-translate ellipse
 690                            (cons
 691                             (interval-center x-ext)
 692                             (interval-center y-ext))))))
 693
 694 (define-public (rounded-box-stencil stencil thickness padding blot)
 695   "Add a rounded box around @var{stencil}, producing a new stencil."
 696
 697   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
 698          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
 699          (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
 700          (ideal-blot (min blot (/ min-ext 2)))
 701          (ideal-thickness (min thickness (/ min-ext 2)))
 702          (outer (ly:round-filled-box
 703                  (interval-widen xext ideal-thickness)
 704                  (interval-widen yext ideal-thickness)
 705                  ideal-blot))
 706          (inner (ly:make-stencil (list 'color (x11-color 'white)
 707                                        (ly:stencil-expr (ly:round-filled-box
 708                                                          xext yext (- ideal-blot ideal-thickness)))))))
 709     (set! stencil (ly:stencil-add outer inner))
 710     stencil))
 711
 712 (define-public (flip-stencil axis stil)
 713   "Flip stencil @var{stil} in the direction of @var{axis}.
 714 Value @code{X} (or @code{0}) for @var{axis} flips it horizontally.
 715 Value @code{Y} (or @code{1}) flips it vertically.  @var{stil} is
 716 flipped in place; its position, the coordinates of its bounding
 717 box, remains the same."
 718   (let* (
 719           ;; scale stencil using -1 to flip it and
 720           ;; then restore it to its original position
 721           (xy (if (= axis X) '(-1 . 1) '(1 . -1)))
 722           (flipped-stil (ly:stencil-scale stil (car xy) (cdr xy)))
 723           (flipped-ext (ly:stencil-extent flipped-stil axis))
 724           (original-ext (ly:stencil-extent stil axis))
 725           (offset (- (car original-ext) (car flipped-ext)))
 726           (replaced-stil (ly:stencil-translate-axis flipped-stil offset axis)))
 727     replaced-stil))
 728
 729 (define-public (stencil-with-color stencil color)
 730   (if (color? color)
 731       (ly:make-stencil
 732        (list 'color color (ly:stencil-expr stencil))
 733        (ly:stencil-extent stencil X)
 734        (ly:stencil-extent stencil Y))
 735       stencil))
 736
 737 (define*-public (stencil-whiteout-outline
 738                  stil #:optional (thickness 0.3) (color white)
 739                  (angle-increments 16) (radial-increments 1))
 740   "This function works by creating a series of white or @var{color}
 741 stencils radially offset from the original stencil with angles from
 742 0 to 2*pi, at an increment of @code{angle-inc}, and with radii
 743 from @code{radial-inc} to @var{thickness}.  @var{thickness} is how big
 744 the white outline is, as a multiple of line-thickness.
 745 @var{radial-increments} is how many copies of the white stencil we make
 746 on our way out to thickness.  @var{angle-increments} is how many copies
 747 of the white stencil we make between 0 and 2*pi."
 748   (if (or (not (positive? angle-increments))
 749           (not (positive? radial-increments)))
 750       (begin
 751        (ly:warning "Both angle-increments and radial-increments must be positive numbers.")
 752        stil)
 753       (let* ((angle-inc (/ 360 angle-increments))
 754              (radial-inc (/ thickness radial-increments)))
 755
 756         (define (circle-plot ang dec radius original-stil new-stil)
 757           ;; ang (angle) and dec (decrement) are in degrees, not radians
 758           (if (<= ang 0)
 759               new-stil
 760               (circle-plot (- ang dec) dec radius original-stil
 761                 (ly:stencil-add
 762                  new-stil
 763                  (ly:stencil-translate original-stil
 764                    (ly:directed ang radius))))))
 765
 766         (define (radial-plot radius original-stil new-stil)
 767           (if (<= radius 0)
 768               new-stil
 769               (ly:stencil-add new-stil
 770                 (radial-plot
 771                  (- radius radial-inc)
 772                  original-stil
 773                  (circle-plot 360 angle-inc
 774                    radius original-stil empty-stencil)))))
 775
 776         (let ((whiteout-expr
 777                 (ly:stencil-expr
 778                  (stencil-with-color
 779                   (radial-plot thickness stil empty-stencil)
 780                   color))))
 781           (ly:stencil-add
 782             (ly:make-stencil
 783               `(delay-stencil-evaluation ,(delay whiteout-expr)))
 784             stil)))))
 785
 786 (define*-public (stencil-whiteout-box stil
 787                  #:optional (thickness 0) (blot 0) (color white))
 788   "@var{thickness} is how far, as a multiple of line-thickness,
 789 the white outline extends past the extents of stencil @var{stil}."
 790   (let*
 791    ((x-ext (interval-widen (ly:stencil-extent stil X) thickness))
 792     (y-ext (interval-widen (ly:stencil-extent stil Y) thickness)))
 793
 794    (ly:stencil-add
 795     (stencil-with-color (ly:round-filled-box x-ext y-ext blot) color)
 796     stil)))
 797
 798 (define*-public (stencil-whiteout stil
 799                  #:optional style thickness (line-thickness 0.1))
 800   "@var{style}, @var{thickness} and @var{line-thickness} are optional
 801 arguments. If set, @var{style} determines the shape of the white
 802 background.  Given @code{'outline} the white background is produced
 803 by @code{stencil-whiteout-outline}, given @code{'rounded-box} it is
 804 produced by @code{stencil-whiteout-box} with rounded corners, given
 805 other arguments (e.g. @code{'box}) or when unspecified it defaults to
 806 @code{stencil-whiteout-box} with square corners.  If @var{thickness} is
 807 specified it determines how far, as a multiple of @var{line-thickness},
 808 the white background extends past the extents of stencil @var{stil}.  If
 809 @var{thickness} has not been specified, an appropriate default is chosen
 810 based on @var{style}."
 811   (let ((thick (* line-thickness
 812                  (if (number? thickness)
 813                      thickness
 814                      (cond
 815                       ((eq? style 'outline) 3)
 816                       ((eq? style 'rounded-box) 3)
 817                       (else 0))))))
 818     (cond
 819      ((eq? style 'special) stil)
 820      ((eq? style 'outline) (stencil-whiteout-outline stil thick))
 821      ((eq? style 'rounded-box) (stencil-whiteout-box stil thick (* 2 thick)))
 822      (else (stencil-whiteout-box stil thick)))))
 823
 824 (define-public (arrow-stencil-maker start? end?)
 825   "Return a function drawing a line from current point to @code{destination},
 826 with optional arrows of @code{max-size} on start and end controlled by
 827 @var{start?} and @var{end?}."
 828   (lambda (destination max-size)
 829     (let*
 830         ((e_x 1+0i)
 831          (e_y 0+1i)
 832          (distance (sqrt (+ (* (car destination) (car destination))
 833                             (* (cdr destination) (cdr destination)))))
 834          (size (min max-size (/ distance 3)))
 835          (rotate (lambda (z ang)
 836                    (* (make-polar 1 ang)
 837                       z)))
 838          (complex-to-offset (lambda (z)
 839                               (list (real-part z) (imag-part z))))
 840
 841          (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
 842          (e_z (/ z-dest (magnitude z-dest)))
 843          (triangle-points (list
 844                            (* size -1+0.25i)
 845                            0
 846                            (* size -1-0.25i)))
 847          (p1s (map (lambda (z)
 848                      (+ z-dest (rotate z (angle z-dest))))
 849                    triangle-points))
 850          (p2s (map (lambda (z)
 851                      (rotate z (angle (- z-dest))))
 852                    triangle-points))
 853          (null (cons 0 0))
 854          (arrow-1
 855           (ly:make-stencil
 856            `(polygon (quote ,(append-map complex-to-offset p1s))
 857                      0.0
 858                      #t) null null))
 859          (arrow-2
 860           (ly:make-stencil
 861            `(polygon (quote ,(append-map complex-to-offset p2s))
 862                      0.0
 863                      #t) null null ) )
 864          (thickness (min (/ distance 12) 0.1))
 865          (shorten-line (min (/ distance 3) 0.5))
 866          (start (complex-to-offset (/ (* e_z shorten-line) 2)))
 867          (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
 868
 869          (line (ly:make-stencil
 870                 `(draw-line ,thickness
 871                             ,(car start) ,(cadr start)
 872                             ,(car end) ,(cadr end)
 873                             )
 874                 (cons (min 0 (car destination))
 875                       (min 0 (cdr destination)))
 876                 (cons (max 0 (car destination))
 877                       (max 0 (cdr destination)))))
 878
 879          (result
 880           (ly:stencil-add
 881            (if start? arrow-2 empty-stencil)
 882            (if end? arrow-1 empty-stencil)
 883            line)))
 884
 885       result)))
 886
 887 (define-public dimension-arrows (arrow-stencil-maker #t #t))
 888
 889 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 890 ;; ANNOTATIONS
 891 ;;
 892 ;; annotations are arrows indicating the numerical value of
 893 ;; spacing variables
 894 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 895
 896 (define*-public (annotate-y-interval layout name extent is-length
 897                                      #:key (color darkblue))
 898   (let ((text-props (cons '((font-size . -3)
 899                             (font-family . typewriter))
 900                           (layout-extract-page-properties layout)))
 901         (annotation #f))
 902     (define (center-stencil-on-extent stil)
 903       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
 904                             (cons 0 (interval-center extent))))
 905     ;; do something sensible for 0,0 intervals.
 906     (set! extent (interval-widen extent 0.001))
 907     (if (not (interval-sane? extent))
 908         (set! annotation (interpret-markup
 909                           layout text-props
 910                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
 911         (let ((text-stencil (interpret-markup
 912                              layout text-props
 913                              (markup #:whiteout #:simple name)))
 914               (dim-stencil (interpret-markup
 915                             layout text-props
 916                             (markup #:whiteout
 917                                     #:simple (cond
 918                                               ((interval-empty? extent)
 919                                                "empty")
 920                                               (is-length
 921                                                (ly:format "~$" (interval-length extent)))
 922                                               (else
 923                                                (ly:format "(~$,~$)"
 924                                                           (car extent) (cdr extent)))))))
 925               (arrows (ly:stencil-translate-axis
 926                        (dimension-arrows (cons 0 (interval-length extent)) 1.0)
 927                        (interval-start extent) Y)))
 928           (set! annotation
 929                 (center-stencil-on-extent text-stencil))
 930           (set! annotation
 931                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
 932           (set! annotation
 933                 (ly:stencil-combine-at-edge annotation X LEFT
 934                                             (center-stencil-on-extent dim-stencil)
 935                                             0.5))
 936           (set! annotation
 937                 (stencil-with-color annotation color))))
 938     annotation))
 939
 940
 941 ;; TODO: figure out how to annotate padding nicely
 942 ;; TODO: emphasize either padding or min-dist depending on which constraint was active
 943 (define*-public (annotate-spacing-spec layout name spacing-spec
 944                                        start-Y-offset next-staff-Y
 945                                        #:key (base-color blue))
 946   (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
 947          (space (get-spacing-var 'basic-distance))
 948          (padding (get-spacing-var 'padding))
 949          (min-dist (get-spacing-var 'minimum-distance))
 950          (contrast-color (append (cdr base-color) (list (car base-color))))
 951          (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
 952          (min-dist-color (if min-dist-blocks contrast-color base-color))
 953          (name-string (if (string-null? name)
 954                          ""
 955                          (simple-format #f " (~a)" name)))
 956          (basic-annotation
 957           (annotate-y-interval layout
 958                                (simple-format #f "basic-dist~a" name-string)
 959                                (cons (- start-Y-offset space) start-Y-offset)
 960                                #t
 961                                #:color (map (lambda (x) (* x 0.25)) base-color)))
 962          (min-annotation
 963           (annotate-y-interval layout
 964                                (simple-format #f "min-dist~a" name-string)
 965                                (cons (- start-Y-offset min-dist) start-Y-offset)
 966                                #t
 967                                #:color min-dist-color))
 968          (extra-annotation
 969           (annotate-y-interval layout
 970                                (simple-format #f "extra dist~a" name-string)
 971                                (cons next-staff-Y (- start-Y-offset min-dist))
 972                                #t
 973                                #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
 974
 975     (stack-stencils X RIGHT 0.0
 976                     (list
 977                      basic-annotation
 978                      (if min-dist-blocks
 979                          min-annotation
 980                          (ly:stencil-add min-annotation extra-annotation))))))
 981
 982 (define-public (eps-file->stencil axis size file-name)
 983   (let*
 984       ((contents (ly:gulp-file file-name))
 985        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
 986        (bbox-size (if (= axis X)
 987                       (- (list-ref bbox 2) (list-ref bbox 0))
 988                       (- (list-ref bbox 3) (list-ref bbox 1))
 989                       ))
 990        (factor (if (< 0 bbox-size)
 991                    (exact->inexact (/ size bbox-size))
 992                    0))
 993        (scaled-bbox
 994         (map (lambda (x) (* factor x)) bbox))
 995        ;; We need to shift the whole eps to (0,0), otherwise it will appear
 996        ;; displaced in lilypond (displacement will depend on the scaling!)
 997        (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
 998        (clip-rect-string (ly:format
 999                           "~a ~a ~a ~a rectclip"
1000                           (list-ref bbox 0)
1001                           (list-ref bbox 1)
1002                           (- (list-ref bbox 2) (list-ref bbox 0))
1003                           (- (list-ref bbox 3) (list-ref bbox 1)))))
1004
1005
1006     (if bbox
1007         (ly:make-stencil
1008          (list
1009           'embedded-ps
1010           (string-append
1011            (ly:format
1012             "
1013 gsave
1014 currentpoint translate
1015 BeginEPSF
1016 ~a dup scale
1017 ~a
1018 ~a
1019 %%BeginDocument: ~a
1020 "         factor translate-string  clip-rect-string
1021
1022 file-name
1023 )
1024            contents
1025            "%%EndDocument
1026 EndEPSF
1027 grestore
1028 "))
1029          ;; Stencil starts at (0,0), since we have shifted the eps, and its
1030          ;; size is exactly the size of the scaled bounding box
1031          (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
1032          (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
1033
1034         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
1035     ))
1036
1037 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1038 ;; output signatures.
1039
1040 (define-public (write-system-signatures basename paper-systems count)
1041   (if (pair? paper-systems)
1042       (begin
1043         (let*
1044             ((outname (simple-format #f "~a-~a.signature" basename count)) )
1045
1046           (ly:message "Writing ~a" outname)
1047           (write-system-signature outname (car paper-systems))
1048           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
1049
1050 (use-modules (scm paper-system))
1051 (define-public (write-system-signature filename paper-system)
1052   (define (float? x)
1053     (and (number? x) (inexact? x)))
1054
1055   (define system-grob
1056     (paper-system-system-grob paper-system))
1057
1058   (define output (open-output-file filename))
1059
1060   ;; todo: optionally use a command line flag? Or just junk this?
1061   (define compare-expressions #f)
1062   (define (strip-floats expr)
1063     "Replace floats by #f"
1064     (cond
1065      ((float? expr) #f)
1066      ((ly:font-metric? expr) (ly:font-name expr))
1067      ((pair? expr) (cons (strip-floats (car expr))
1068                          (strip-floats (cdr expr))))
1069      (else expr)))
1070
1071   (define (fold-false-pairs expr)
1072     "Try to remove lists of #f as much as possible."
1073     (if (pair? expr)
1074         (let*
1075             ((first (car expr))
1076              (rest (fold-false-pairs (cdr expr))))
1077
1078           (if first
1079               (cons (fold-false-pairs first) rest)
1080               rest))
1081         expr))
1082
1083   (define (raw-string expr)
1084     "escape quotes and slashes for python consumption"
1085     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
1086
1087   (define (raw-pair expr)
1088     (simple-format #f "~a ~a"
1089                    (car expr) (cdr expr)))
1090
1091   (define (found-grob expr)
1092     (let*
1093         ((grob (car expr))
1094          (rest (cdr expr))
1095          (collected '())
1096          (cause (event-cause grob))
1097          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
1098          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
1099
1100          ;; todo: use stencil extent if available.
1101          (x-ext (ly:grob-extent grob system-grob X))
1102          (y-ext (ly:grob-extent grob system-grob Y))
1103          (expression-skeleton
1104           (if compare-expressions
1105               (interpret-for-signature
1106                #f (lambda (e)
1107                     (set! collected (cons e collected)))
1108                rest)
1109               "")))
1110
1111       (simple-format output
1112                      "~a@~a@~a@~a@~a\n"
1113                      (cdr (assq 'name (ly:grob-property grob 'meta) ))
1114                      (raw-string location)
1115                      (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
1116                      (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
1117                      (raw-string collected))
1118       ))
1119
1120   (define (interpret-for-signature escape collect expr)
1121     (define (interpret expr)
1122       (let*
1123           ((head (if (pair? expr)
1124                      (car expr)
1125                      #f)))
1126
1127         (cond
1128          ((eq? head 'grob-cause) (escape (cdr expr)))
1129          ((eq? head 'color) (interpret (caddr expr)))
1130          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
1131          ((eq? head 'translate-stencil) (interpret (caddr expr)))
1132          ;; for signatures, we indeed want the _outline_ rather than
1133          ;; the expression interpreted.  Right?
1134          ((eq? head 'with-outline) (interpret (cadr expr)))
1135          ((eq? head 'combine-stencil)
1136           (for-each interpret  (cdr expr)))
1137          (else
1138           (collect (fold-false-pairs (strip-floats expr))))
1139
1140          )))
1141
1142     (interpret expr))
1143
1144   (if (ly:grob? system-grob)
1145       (begin
1146         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
1147                  output)
1148         (interpret-for-signature found-grob (lambda (x) #f)
1149                                  (ly:stencil-expr
1150                                   (paper-system-stencil paper-system)))))
1151
1152   ;; should be superfluous, but leaking "too many open files"?
1153   (close-port output))