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:make-stencil
 242    (list 'transparent-stencil
 243          (ly:stencil-expr (make-filled-box-stencil xext yext)))
 244    xext yext))
 245
 246 (define-public (make-filled-box-stencil xext yext)
 247   "Make a filled box."
 248
 249   (ly:make-stencil
 250    (list 'round-filled-box (- (car xext)) (cdr xext)
 251          (- (car yext)) (cdr yext) 0.0)
 252    xext yext))
 253
 254 (define-public (make-circle-stencil radius thickness fill)
 255   "Make a circle of radius @var{radius} and thickness @var{thickness}."
 256   (let*
 257       ((out-radius (+ radius (/ thickness 2.0))))
 258
 259     (ly:make-stencil
 260      (list 'circle radius thickness fill)
 261      (cons (- out-radius) out-radius)
 262      (cons (- out-radius) out-radius))))
 263
 264 (define-public (make-oval-stencil x-radius y-radius thickness fill)
 265   "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
 266 y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
 267 defined by @code{fill}."
 268   (let*
 269       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 270        (y-out-radius (+ y-radius (/ thickness 2.0)))
 271        (x-max x-radius)
 272        (x-min (- x-radius))
 273        (y-max y-radius)
 274        (y-min (- y-radius))
 275        (commands `(,(list 'moveto x-max 0)
 276                    ,(list 'curveto x-max y-max x-min y-max x-min 0)
 277                    ,(list 'curveto x-min y-min x-max y-min x-max 0)
 278                    ,(list 'closepath)))
 279        (command-list (fold-right append '() commands)))
 280     (ly:make-stencil
 281      `(path ,thickness `(,@',command-list) 'round 'round ,fill)
 282      (cons (- x-out-radius) x-out-radius)
 283      (cons (- y-out-radius) y-out-radius))))
 284
 285 (define-public
 286   (make-partial-ellipse-stencil
 287    x-radius y-radius start-angle end-angle thick connect fill)
 288   "Create an elliptical arc
 289 @var{x-radius} is the X radius of the arc.
 290 @var{y-radius} is the Y radius of the arc.
 291 @var{start-angle} is the starting angle of the arc in degrees.
 292 @var{end-angle} is the ending angle of the arc in degrees.
 293 @var{thick} is the thickness of the line.
 294 @var{connect} is a boolean flag indicating if the end should
 295 be connected to the start by a line.
 296 @var{fill} is a boolean flag indicating if the shape should be filled."
 297   (define (make-radius-list x-radius y-radius)
 298     "Makes a list of angle/radius pairs at intervals of PI/2 for
 299 the partial ellipse until 7*PI/2.  For example, in pseudo-code:
 300 > (make-radius-list 2 3)\
 301 \n((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3)\
 302 \n(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3))
 303 "
 304     (append-map
 305      (lambda (adder)
 306        (map (lambda (quadrant)
 307               (cons (+ adder (car quadrant))
 308                     (cdr quadrant)))
 309             `((0.0 . (,x-radius . 0.0))
 310               (,PI-OVER-TWO . (0.0 . ,y-radius))
 311               (,PI . (,(- x-radius) . 0.0))
 312               (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
 313      `(0.0 ,TWO-PI)))
 314
 315   (define
 316     (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
 317     "Insert @var{value} in ordered list @var{inlist}. If @var{cutl?}, we
 318 cut away any parts of @var{inlist} before @var{value}. @var{cutr?} works
 319 the same way but for the right side. For example:
 320 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #f)
 321 '(1 2 3 4 6 7)
 322 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f)
 323 '(4 6 7)
 324 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t)
 325 '(1 2 3 4)
 326 "
 327     (define
 328       (helper ordering-function value left-list right-list cutl? cutr?)
 329       (if (null? right-list)
 330           (append
 331            (if cutl? '() left-list)
 332            (list value)
 333            (if cutr? '() right-list))
 334           (if (ordering-function value (car right-list))
 335               (append
 336                (if cutl? '() left-list)
 337                (list value)
 338                (if cutr? '() right-list))
 339               (helper
 340                ordering-function
 341                value
 342                (append left-list (list (car right-list)))
 343                (cdr right-list)
 344                cutl?
 345                cutr?))))
 346     (helper ordering-function value '() inlist cutl? cutr?))
 347
 348   (define (ordering-function-1 a b) (car< a b))
 349
 350   (define (ordering-function-2 a b) (car<= a b))
 351
 352   (define (min-max-crawler min-max side l)
 353     "Apply function @var{side} to each member of list and
 354 then reduce using @var{min-max}:
 355 > (min-max-crawler min car '((0 . 3) (-1 . 4) (1 . 2)))
 356 -1
 357 > (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2)))
 358 2
 359 "
 360     (reduce min-max
 361             (if (eq? min-max min) 100000 -100000)
 362             (map side l)))
 363
 364   (let*
 365       (;; the outside limit of the x-radius
 366        (x-out-radius (+ x-radius (/ thick 2.0)))
 367        ;; the outside limit of the y-radius
 368        (y-out-radius (+ y-radius (/ thick 2.0)))
 369        ;; end angle to radians
 370        (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
 371        ;; length of the radius at the end angle
 372        (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
 373        ;; start angle to radians
 374        (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
 375        ;; length of the radius at the start angle
 376        (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
 377        ;; points that the arc passes through at 90 degree intervals
 378        (radius-list (make-radius-list x-out-radius y-out-radius))
 379        ;; rectangular coordinates of arc endpoint
 380        (rectangular-end-radius (polar->rectangular end-radius end-angle))
 381        ;; rectangular coordinates of arc begin point
 382        (rectangular-start-radius (polar->rectangular start-radius start-angle))
 383        ;; we want the end angle to always be bigger than the start angle
 384        ;; so we redefine it here just in case it is less
 385        (new-end-angle
 386         (if (<= new-end-angle new-start-angle)
 387             (+ TWO-PI new-end-angle)
 388             new-end-angle))
 389        ;; all the points that may be extrema of the arc
 390        ;; this is the 90 degree points plus the beginning and end points
 391        ;; we use this to calculate extents
 392        (possible-extrema
 393         (insert-in-ordered-list
 394          ordering-function-2
 395          (cons new-end-angle rectangular-end-radius)
 396          (insert-in-ordered-list
 397           ordering-function-1
 398           (cons new-start-angle rectangular-start-radius)
 399           radius-list
 400           #t
 401           #f)
 402          #f
 403          #t)))
 404     (ly:make-stencil
 405      (list
 406       'partial-ellipse
 407       x-radius
 408       y-radius
 409       start-angle
 410       end-angle
 411       thick
 412       connect
 413       fill)
 414      ;; we know the extrema points by crawling through the
 415      ;; list of possible extrema and finding the min and max
 416      ;; for x and y
 417      (cons (min-max-crawler min cadr possible-extrema)
 418            (min-max-crawler max cadr possible-extrema))
 419      (cons (min-max-crawler min cddr possible-extrema)
 420            (min-max-crawler max cddr possible-extrema)))))
 421
 422 (define (line-part-min-max x1 x2)
 423   (list (min x1 x2) (max x1 x2)))
 424
 425 (define (bezier-part-min-max x1 x2 x3 x4)
 426   ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
 427    (map
 428     (lambda (x)
 429       (+ (* x1 (expt (- 1 x) 3))
 430          (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
 431             (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
 432                (* x4 (expt x 3))))))
 433     (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
 434            (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
 435         (list 0.0 1.0)
 436         (filter
 437          (lambda (x) (and (>= x 0) (<= x 1)))
 438          (append
 439           (list 0.0 1.0)
 440           (map (lambda (op)
 441                  (if (not (eqv? 0.0
 442                                 (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
 443                      ;; Zeros of the bezier curve
 444                      (/ (+ (- x1 (* 2 x2))
 445                            (op x3
 446                                (sqrt (- (+ (expt x2 2)
 447                                            (+ (expt x3 2) (* x1 x4)))
 448                                         (+ (* x1 x3)
 449                                            (+ (* x2 x4) (* x2 x3)))))))
 450                         (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
 451                      ;; Apply L'hopital's rule to get the zeros if 0/0
 452                      (* (op 0 1)
 453                         (/ (/ (- x4 x3) 2)
 454                            (sqrt (- (+ (* x2 x2)
 455                                        (+ (* x3 x3) (* x1 x4)))
 456                                     (+ (* x1 x3)
 457                                        (+ (* x2 x4) (* x2 x3)))))))))
 458                (list + -))))))))
 459
 460 (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
 461   (map (lambda (x)
 462          (apply bezier-part-min-max x))
 463        `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
 464
 465 (define (line-min-max x1 y1 x2 y2)
 466   (map (lambda (x)
 467          (apply line-part-min-max x))
 468        `((,x1 ,x2) (,y1 ,y2))))
 469
 470 (define (path-min-max origin pointlist)
 471
 472   ((lambda (x)
 473      (list
 474       (reduce min +inf.0 (map caar x))
 475       (reduce max -inf.0 (map cadar x))
 476       (reduce min +inf.0 (map caadr x))
 477       (reduce max -inf.0 (map cadadr x))))
 478    (map (lambda (x)
 479           (if (= (length x) 8)
 480               (apply bezier-min-max x)
 481               (apply line-min-max x)))
 482         (map (lambda (x y)
 483                (append (list (cadr (reverse x)) (car (reverse x))) y))
 484              (append (list origin)
 485                      (reverse (cdr (reverse pointlist)))) pointlist))))
 486
 487 (define-public (make-path-stencil path thickness x-scale y-scale fill)
 488   "Make a stencil based on the path described by the list @var{path},
 489 with thickness @var{thickness}, and scaled by @var{x-scale} in the X
 490 direction and @var{y-scale} in the Y direction.  @var{fill} is a boolean
 491 argument that specifies if the path should be filled.  Valid path
 492 commands are: moveto rmoveto lineto rlineto curveto rcurveto closepath,
 493 and their standard SVG single letter equivalents: M m L l C c Z z."
 494
 495   (define (convert-path path origin previous-point)
 496     "Recursive function to standardize command names and
 497 convert any relative path expressions (in @var{path}) to absolute
 498 values.  Returns a list of lists.  @var{origin} is a pair of x and y
 499 coordinates for the origin point of the path (used for closepath and
 500 reset by moveto commands).  @var{previous-point} is a pair of x and y
 501 coordinates for the previous point in the path."
 502     (if (pair? path)
 503         (let*
 504          ((head-raw (car path))
 505           (rest (cdr path))
 506           (head (cond
 507                  ((memq head-raw '(rmoveto M m)) 'moveto)
 508                  ((memq head-raw '(rlineto L l)) 'lineto)
 509                  ((memq head-raw '(rcurveto C c)) 'curveto)
 510                  ((memq head-raw '(Z z)) 'closepath)
 511                  (else head-raw)))
 512           (arity (cond
 513                   ((memq head '(lineto moveto)) 2)
 514                   ((eq? head 'curveto) 6)
 515                   (else 0)))
 516           (coordinates-raw (take rest arity))
 517           (is-absolute (if (memq head-raw
 518                            '(rmoveto m rlineto l rcurveto c)) #f #t))
 519           (coordinates (if is-absolute
 520                            coordinates-raw
 521                            ;; convert relative coordinates to absolute by
 522                            ;; adding them to previous point values
 523                            (map (lambda (c n)
 524                                   (if (even? n)
 525                                       (+ c (car previous-point))
 526                                       (+ c (cdr previous-point))))
 527                              coordinates-raw
 528                              (iota arity))))
 529           (new-point (if (eq? head 'closepath)
 530                          origin
 531                          (cons
 532                           (list-ref coordinates (- arity 2))
 533                           (list-ref coordinates (- arity 1)))))
 534           (new-origin (if (eq? head 'moveto)
 535                           new-point
 536                           origin)))
 537          (cons (cons head coordinates)
 538            (convert-path (drop rest arity) new-origin new-point)))
 539         '()))
 540
 541   (let* ((path-absolute (convert-path path (cons 0 0) (cons 0 0)))
 542          ;; scale coordinates
 543          (path-scaled (if (and (= 1 x-scale) (= 1 y-scale))
 544                           path-absolute
 545                           (map (lambda (path-unit)
 546                                  (map (lambda (c n)
 547                                         (cond
 548                                          ((= 0 n) c)
 549                                          ((odd? n) (* c x-scale))
 550                                          (else (* c y-scale))))
 551                                    path-unit
 552                                    (iota (length path-unit))))
 553                             path-absolute)))
 554          ;; a path must begin with a 'moveto'
 555          (path-final (if (eq? 'moveto (car (car path-scaled)))
 556                          path-scaled
 557                          (append (list (list 'moveto 0 0)) path-scaled)))
 558          ;; remove all commands in order to calculate bounds
 559          (path-headless (map cdr (delete (list 'closepath) path-final)))
 560          (bound-list (path-min-max
 561                       (car path-headless)
 562                       (cdr path-headless))))
 563     (ly:make-stencil
 564      `(path ,thickness
 565         `(,@',(concatenate path-final))
 566         'round
 567         'round
 568         ,(if fill #t #f))
 569      (coord-translate
 570       ((if (< x-scale 0) reverse-interval identity)
 571        (cons
 572         (list-ref bound-list 0)
 573         (list-ref bound-list 1)))
 574       `(,(/ thickness -2) . ,(/ thickness 2)))
 575      (coord-translate
 576       ((if (< y-scale 0) reverse-interval identity)
 577        (cons
 578         (list-ref bound-list 2)
 579         (list-ref bound-list 3)))
 580       `(,(/ thickness -2) . ,(/ thickness 2))))))
 581
 582 (define-public (make-connected-path-stencil pointlist thickness
 583                                             x-scale y-scale connect fill)
 584   "Make a connected path described by the list @var{pointlist}, beginning
 585 at point '(0 . 0), with thickness @var{thickness}, and scaled by
 586 @var{x-scale} in the X direction and @var{y-scale} in the Y direction.
 587 @var{connect} and @var{fill} are boolean arguments that specify if the
 588 path should be connected or filled, respectively."
 589   (make-path-stencil
 590    (concatenate
 591     (append
 592      (map (lambda (path-unit)
 593             (case (length path-unit)
 594               ((2) (append (list 'lineto) path-unit))
 595               ((6) (append (list 'curveto) path-unit))))
 596        pointlist)
 597      ;; if this path is connected, add closepath to the end
 598      (if connect (list '(closepath)) '())))
 599    thickness x-scale y-scale fill))
 600
 601 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
 602   "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
 603 @code{y-radius}, and thickness @var{thickness} with fill defined by
 604 @code{fill}."
 605   (let*
 606       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 607        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 608
 609     (ly:make-stencil
 610      (list 'ellipse x-radius y-radius thickness fill)
 611      (cons (- x-out-radius) x-out-radius)
 612      (cons (- y-out-radius) y-out-radius))))
 613
 614 (define-public (box-grob-stencil grob)
 615   "Make a box of exactly the extents of the grob.  The box precisely
 616 encloses the contents."
 617   (let* ((xext (ly:grob-extent grob grob 0))
 618          (yext (ly:grob-extent grob grob 1))
 619          (thick 0.01))
 620
 621     (ly:stencil-add
 622      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
 623      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
 624      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
 625      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
 626
 627 ;; TODO merge this and prev function.
 628 (define-public (box-stencil stencil thickness padding)
 629   "Add a box around @var{stencil}, producing a new stencil."
 630   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
 631          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
 632          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
 633          (x-rule (make-filled-box-stencil
 634                   (interval-widen x-ext thickness) (cons 0 thickness))))
 635     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
 636     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
 637     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
 638     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
 639     stencil))
 640
 641 (define-public (circle-stencil stencil thickness padding)
 642   "Add a circle around @var{stencil}, producing a new stencil."
 643   (let* ((x-ext (ly:stencil-extent stencil X))
 644          (y-ext (ly:stencil-extent stencil Y))
 645          (diameter (max (interval-length x-ext)
 646                         (interval-length y-ext)))
 647          (radius (+ (/ diameter 2) padding thickness))
 648          (circle (make-circle-stencil radius thickness #f)))
 649
 650     (ly:stencil-add
 651      stencil
 652      (ly:stencil-translate circle
 653                            (cons
 654                             (interval-center x-ext)
 655                             (interval-center y-ext))))))
 656
 657 (define-public (oval-stencil stencil thickness x-padding y-padding)
 658   "Add an oval around @code{stencil}, padded by the padding pair,
 659 producing a new stencil."
 660   (let* ((x-ext (ly:stencil-extent stencil X))
 661          (y-ext (ly:stencil-extent stencil Y))
 662          (x-length (+ (interval-length x-ext) x-padding thickness))
 663          (y-length (+ (interval-length y-ext) y-padding thickness))
 664          (x-radius (* 0.707 x-length) )
 665          (y-radius (* 0.707 y-length) )
 666          (oval (make-oval-stencil x-radius y-radius thickness #f)))
 667
 668     (ly:stencil-add
 669      stencil
 670      (ly:stencil-translate oval
 671                            (cons
 672                             (interval-center x-ext)
 673                             (interval-center y-ext))))))
 674
 675 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
 676   "Add an ellipse around @var{stencil}, padded by the padding pair,
 677 producing a new stencil."
 678   (let* ((x-ext (ly:stencil-extent stencil X))
 679          (y-ext (ly:stencil-extent stencil Y))
 680          (x-length (+ (interval-length x-ext) x-padding thickness))
 681          (y-length (+ (interval-length y-ext) y-padding thickness))
 682          ;; (aspect-ratio (/ x-length y-length))
 683          (x-radius (* 0.707 x-length) )
 684          (y-radius (* 0.707 y-length) )
 685          ;; (diameter (max (- (cdr x-ext) (car x-ext))
 686          ;;             (- (cdr y-ext) (car y-ext))))
 687          ;; radius (+ (/ diameter 2) padding thickness))
 688          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
 689
 690     (ly:stencil-add
 691      stencil
 692      (ly:stencil-translate ellipse
 693                            (cons
 694                             (interval-center x-ext)
 695                             (interval-center y-ext))))))
 696
 697 (define-public (rounded-box-stencil stencil thickness padding blot)
 698   "Add a rounded box around @var{stencil}, producing a new stencil."
 699
 700   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
 701          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
 702          (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
 703          (ideal-blot (min blot (/ min-ext 2)))
 704          (ideal-thickness (min thickness (/ min-ext 2)))
 705          (outer (ly:round-filled-box
 706                  (interval-widen xext ideal-thickness)
 707                  (interval-widen yext ideal-thickness)
 708                  ideal-blot))
 709          (inner (ly:make-stencil (list 'color (x11-color 'white)
 710                                        (ly:stencil-expr (ly:round-filled-box
 711                                                          xext yext (- ideal-blot ideal-thickness)))))))
 712     (set! stencil (ly:stencil-add outer inner))
 713     stencil))
 714
 715 (define-public (flip-stencil axis stil)
 716   "Flip stencil @var{stil} in the direction of @var{axis}.
 717 Value @code{X} (or @code{0}) for @var{axis} flips it horizontally.
 718 Value @code{Y} (or @code{1}) flips it vertically.  @var{stil} is
 719 flipped in place; its position, the coordinates of its bounding
 720 box, remains the same."
 721   (let* (
 722           ;; scale stencil using -1 to flip it and
 723           ;; then restore it to its original position
 724           (xy (if (= axis X) '(-1 . 1) '(1 . -1)))
 725           (flipped-stil (ly:stencil-scale stil (car xy) (cdr xy)))
 726           (flipped-ext (ly:stencil-extent flipped-stil axis))
 727           (original-ext (ly:stencil-extent stil axis))
 728           (offset (- (car original-ext) (car flipped-ext)))
 729           (replaced-stil (ly:stencil-translate-axis flipped-stil offset axis)))
 730     replaced-stil))
 731
 732 (define-public (stencil-with-color stencil color)
 733   (ly:make-stencil
 734    (list 'color color (ly:stencil-expr stencil))
 735    (ly:stencil-extent stencil X)
 736    (ly:stencil-extent stencil Y)))
 737
 738 (define*-public (stencil-whiteout-outline
 739                  stil #:optional (thickness 0.3) (color white)
 740                  (angle-increments 16) (radial-increments 1))
 741   "This function works by creating a series of white or @var{color}
 742 stencils radially offset from the original stencil with angles from
 743 0 to 2*pi, at an increment of @code{angle-inc}, and with radii
 744 from @code{radial-inc} to @var{thickness}.  @var{thickness} is how big
 745 the white outline is, as a multiple of line-thickness.
 746 @var{radial-increments} is how many copies of the white stencil we make
 747 on our way out to thickness.  @var{angle-increments} is how many copies
 748 of the white stencil we make between 0 and 2*pi."
 749   (if (or (not (positive? angle-increments))
 750           (not (positive? radial-increments)))
 751       (begin
 752        (ly:warning "Both angle-increments and radial-increments must be positive numbers.")
 753        stil)
 754       (let* ((2pi 6.283185307)
 755              (angle-inc (/ 2pi angle-increments))
 756              (radial-inc (/ thickness radial-increments)))
 757
 758         (define (circle-plot ang dec radius original-stil new-stil)
 759           ;; ang (angle) and dec (decrement) are in radians, not degrees
 760           (if (<= ang 0)
 761               new-stil
 762               (circle-plot (- ang dec) dec radius original-stil
 763                 (ly:stencil-add
 764                  new-stil
 765                  (ly:stencil-translate original-stil
 766                    (cons
 767                     (* radius (cos ang))
 768                     (* radius (sin ang))))))))
 769
 770         (define (radial-plot radius original-stil new-stil)
 771           (if (<= radius 0)
 772               new-stil
 773               (ly:stencil-add new-stil
 774                 (radial-plot
 775                  (- radius radial-inc)
 776                  original-stil
 777                  (circle-plot 2pi angle-inc
 778                    radius original-stil empty-stencil)))))
 779
 780         (let ((whiteout-expr
 781                 (ly:stencil-expr
 782                  (stencil-with-color
 783                   (radial-plot thickness stil empty-stencil)
 784                   color))))
 785           (ly:stencil-add
 786             (ly:make-stencil
 787               `(delay-stencil-evaluation ,(delay whiteout-expr)))
 788             stil)))))
 789
 790 (define*-public (stencil-whiteout-box stil
 791                  #:optional (thickness 0) (blot 0) (color white))
 792   "@var{thickness} is how far, as a multiple of line-thickness,
 793 the white outline extends past the extents of stencil @var{stil}."
 794   (let*
 795    ((x-ext (interval-widen (ly:stencil-extent stil X) thickness))
 796     (y-ext (interval-widen (ly:stencil-extent stil Y) thickness)))
 797
 798    (ly:stencil-add
 799     (stencil-with-color (ly:round-filled-box x-ext y-ext blot) color)
 800     stil)))
 801
 802 (define*-public (stencil-whiteout stil
 803                  #:optional style thickness (line-thickness 0.1))
 804   "@var{style}, @var{thickness} and @var{line-thickness} are optional
 805 arguments. If set, @var{style} determines the shape of the white
 806 background.  Given @code{'outline} the white background is produced
 807 by @code{stencil-whiteout-outline}, given @code{'rounded-box} it is
 808 produced by @code{stencil-whiteout-box} with rounded corners, given
 809 other arguments (e.g. @code{'box}) or when unspecified it defaults to
 810 @code{stencil-whiteout-box} with square corners.  If @var{thickness} is
 811 specified it determines how far, as a multiple of @var{line-thickness},
 812 the white background extends past the extents of stencil @var{stil}.  If
 813 @var{thickness} has not been specified, an appropriate default is chosen
 814 based on @var{style}."
 815   (let ((thick (* line-thickness
 816                  (if (number? thickness)
 817                      thickness
 818                      (cond
 819                       ((eq? style 'outline) 3)
 820                       ((eq? style 'rounded-box) 3)
 821                       (else 0))))))
 822     (cond
 823      ((eq? style 'outline) (stencil-whiteout-outline stil thick))
 824      ((eq? style 'rounded-box) (stencil-whiteout-box stil thick (* 2 thick)))
 825      (else (stencil-whiteout-box stil thick)))))
 826
 827 (define-public (arrow-stencil-maker start? end?)
 828   "Return a function drawing a line from current point to @code{destination},
 829 with optional arrows of @code{max-size} on start and end controlled by
 830 @var{start?} and @var{end?}."
 831   (lambda (destination max-size)
 832     (let*
 833         ((e_x 1+0i)
 834          (e_y 0+1i)
 835          (distance (sqrt (+ (* (car destination) (car destination))
 836                             (* (cdr destination) (cdr destination)))))
 837          (size (min max-size (/ distance 3)))
 838          (rotate (lambda (z ang)
 839                    (* (make-polar 1 ang)
 840                       z)))
 841          (complex-to-offset (lambda (z)
 842                               (list (real-part z) (imag-part z))))
 843
 844          (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
 845          (e_z (/ z-dest (magnitude z-dest)))
 846          (triangle-points (list
 847                            (* size -1+0.25i)
 848                            0
 849                            (* size -1-0.25i)))
 850          (p1s (map (lambda (z)
 851                      (+ z-dest (rotate z (angle z-dest))))
 852                    triangle-points))
 853          (p2s (map (lambda (z)
 854                      (rotate z (angle (- z-dest))))
 855                    triangle-points))
 856          (null (cons 0 0))
 857          (arrow-1
 858           (ly:make-stencil
 859            `(polygon (quote ,(append-map complex-to-offset p1s))
 860                      0.0
 861                      #t) null null))
 862          (arrow-2
 863           (ly:make-stencil
 864            `(polygon (quote ,(append-map complex-to-offset p2s))
 865                      0.0
 866                      #t) null null ) )
 867          (thickness (min (/ distance 12) 0.1))
 868          (shorten-line (min (/ distance 3) 0.5))
 869          (start (complex-to-offset (/ (* e_z shorten-line) 2)))
 870          (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
 871
 872          (line (ly:make-stencil
 873                 `(draw-line ,thickness
 874                             ,(car start) ,(cadr start)
 875                             ,(car end) ,(cadr end)
 876                             )
 877                 (cons (min 0 (car destination))
 878                       (min 0 (cdr destination)))
 879                 (cons (max 0 (car destination))
 880                       (max 0 (cdr destination)))))
 881
 882          (result
 883           (ly:stencil-add
 884            (if start? arrow-2 empty-stencil)
 885            (if end? arrow-1 empty-stencil)
 886            line)))
 887
 888       result)))
 889
 890 (define-public dimension-arrows (arrow-stencil-maker #t #t))
 891
 892 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 893 ;; ANNOTATIONS
 894 ;;
 895 ;; annotations are arrows indicating the numerical value of
 896 ;; spacing variables
 897 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 898
 899 (define*-public (annotate-y-interval layout name extent is-length
 900                                      #:key (color darkblue))
 901   (let ((text-props (cons '((font-size . -3)
 902                             (font-family . typewriter))
 903                           (layout-extract-page-properties layout)))
 904         (annotation #f))
 905     (define (center-stencil-on-extent stil)
 906       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
 907                             (cons 0 (interval-center extent))))
 908     ;; do something sensible for 0,0 intervals.
 909     (set! extent (interval-widen extent 0.001))
 910     (if (not (interval-sane? extent))
 911         (set! annotation (interpret-markup
 912                           layout text-props
 913                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
 914         (let ((text-stencil (interpret-markup
 915                              layout text-props
 916                              (markup #:whiteout #:simple name)))
 917               (dim-stencil (interpret-markup
 918                             layout text-props
 919                             (markup #:whiteout
 920                                     #:simple (cond
 921                                               ((interval-empty? extent)
 922                                                "empty")
 923                                               (is-length
 924                                                (ly:format "~$" (interval-length extent)))
 925                                               (else
 926                                                (ly:format "(~$,~$)"
 927                                                           (car extent) (cdr extent)))))))
 928               (arrows (ly:stencil-translate-axis
 929                        (dimension-arrows (cons 0 (interval-length extent)) 1.0)
 930                        (interval-start extent) Y)))
 931           (set! annotation
 932                 (center-stencil-on-extent text-stencil))
 933           (set! annotation
 934                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
 935           (set! annotation
 936                 (ly:stencil-combine-at-edge annotation X LEFT
 937                                             (center-stencil-on-extent dim-stencil)
 938                                             0.5))
 939           (set! annotation
 940                 (stencil-with-color annotation color))))
 941     annotation))
 942
 943
 944 ;; TODO: figure out how to annotate padding nicely
 945 ;; TODO: emphasize either padding or min-dist depending on which constraint was active
 946 (define*-public (annotate-spacing-spec layout name spacing-spec
 947                                        start-Y-offset next-staff-Y
 948                                        #:key (base-color blue))
 949   (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
 950          (space (get-spacing-var 'basic-distance))
 951          (padding (get-spacing-var 'padding))
 952          (min-dist (get-spacing-var 'minimum-distance))
 953          (contrast-color (append (cdr base-color) (list (car base-color))))
 954          (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
 955          (min-dist-color (if min-dist-blocks contrast-color base-color))
 956          (name-string (if (string-null? name)
 957                          ""
 958                          (simple-format #f " (~a)" name)))
 959          (basic-annotation
 960           (annotate-y-interval layout
 961                                (simple-format #f "basic-dist~a" name-string)
 962                                (cons (- start-Y-offset space) start-Y-offset)
 963                                #t
 964                                #:color (map (lambda (x) (* x 0.25)) base-color)))
 965          (min-annotation
 966           (annotate-y-interval layout
 967                                (simple-format #f "min-dist~a" name-string)
 968                                (cons (- start-Y-offset min-dist) start-Y-offset)
 969                                #t
 970                                #:color min-dist-color))
 971          (extra-annotation
 972           (annotate-y-interval layout
 973                                (simple-format #f "extra dist~a" name-string)
 974                                (cons next-staff-Y (- start-Y-offset min-dist))
 975                                #t
 976                                #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
 977
 978     (stack-stencils X RIGHT 0.0
 979                     (list
 980                      basic-annotation
 981                      (if min-dist-blocks
 982                          min-annotation
 983                          (ly:stencil-add min-annotation extra-annotation))))))
 984
 985 (define-public (eps-file->stencil axis size file-name)
 986   (let*
 987       ((contents (ly:gulp-file file-name))
 988        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
 989        (bbox-size (if (= axis X)
 990                       (- (list-ref bbox 2) (list-ref bbox 0))
 991                       (- (list-ref bbox 3) (list-ref bbox 1))
 992                       ))
 993        (factor (if (< 0 bbox-size)
 994                    (exact->inexact (/ size bbox-size))
 995                    0))
 996        (scaled-bbox
 997         (map (lambda (x) (* factor x)) bbox))
 998        ;; We need to shift the whole eps to (0,0), otherwise it will appear
 999        ;; displaced in lilypond (displacement will depend on the scaling!)
1000        (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
1001        (clip-rect-string (ly:format
1002                           "~a ~a ~a ~a rectclip"
1003                           (list-ref bbox 0)
1004                           (list-ref bbox 1)
1005                           (- (list-ref bbox 2) (list-ref bbox 0))
1006                           (- (list-ref bbox 3) (list-ref bbox 1)))))
1007
1008
1009     (if bbox
1010         (ly:make-stencil
1011          (list
1012           'embedded-ps
1013           (string-append
1014            (ly:format
1015             "
1016 gsave
1017 currentpoint translate
1018 BeginEPSF
1019 ~a dup scale
1020 ~a
1021 ~a
1022 %%BeginDocument: ~a
1023 "         factor translate-string  clip-rect-string
1024
1025 file-name
1026 )
1027            contents
1028            "%%EndDocument
1029 EndEPSF
1030 grestore
1031 "))
1032          ;; Stencil starts at (0,0), since we have shifted the eps, and its
1033          ;; size is exactly the size of the scaled bounding box
1034          (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
1035          (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
1036
1037         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
1038     ))
1039
1040 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1041 ;; output signatures.
1042
1043 (define-public (write-system-signatures basename paper-systems count)
1044   (if (pair? paper-systems)
1045       (begin
1046         (let*
1047             ((outname (simple-format #f "~a-~a.signature" basename count)) )
1048
1049           (ly:message "Writing ~a" outname)
1050           (write-system-signature outname (car paper-systems))
1051           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
1052
1053 (use-modules (scm paper-system))
1054 (define-public (write-system-signature filename paper-system)
1055   (define (float? x)
1056     (and (number? x) (inexact? x)))
1057
1058   (define system-grob
1059     (paper-system-system-grob paper-system))
1060
1061   (define output (open-output-file filename))
1062
1063   ;; todo: optionally use a command line flag? Or just junk this?
1064   (define compare-expressions #f)
1065   (define (strip-floats expr)
1066     "Replace floats by #f"
1067     (cond
1068      ((float? expr) #f)
1069      ((ly:font-metric? expr) (ly:font-name expr))
1070      ((pair? expr) (cons (strip-floats (car expr))
1071                          (strip-floats (cdr expr))))
1072      (else expr)))
1073
1074   (define (fold-false-pairs expr)
1075     "Try to remove lists of #f as much as possible."
1076     (if (pair? expr)
1077         (let*
1078             ((first (car expr))
1079              (rest (fold-false-pairs (cdr expr))))
1080
1081           (if first
1082               (cons (fold-false-pairs first) rest)
1083               rest))
1084         expr))
1085
1086   (define (raw-string expr)
1087     "escape quotes and slashes for python consumption"
1088     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
1089
1090   (define (raw-pair expr)
1091     (simple-format #f "~a ~a"
1092                    (car expr) (cdr expr)))
1093
1094   (define (found-grob expr)
1095     (let*
1096         ((grob (car expr))
1097          (rest (cdr expr))
1098          (collected '())
1099          (cause (event-cause grob))
1100          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
1101          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
1102
1103          ;; todo: use stencil extent if available.
1104          (x-ext (ly:grob-extent grob system-grob X))
1105          (y-ext (ly:grob-extent grob system-grob Y))
1106          (expression-skeleton
1107           (if compare-expressions
1108               (interpret-for-signature
1109                #f (lambda (e)
1110                     (set! collected (cons e collected)))
1111                rest)
1112               "")))
1113
1114       (simple-format output
1115                      "~a@~a@~a@~a@~a\n"
1116                      (cdr (assq 'name (ly:grob-property grob 'meta) ))
1117                      (raw-string location)
1118                      (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
1119                      (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
1120                      (raw-string collected))
1121       ))
1122
1123   (define (interpret-for-signature escape collect expr)
1124     (define (interpret expr)
1125       (let*
1126           ((head (if (pair? expr)
1127                      (car expr)
1128                      #f)))
1129
1130         (cond
1131          ((eq? head 'grob-cause) (escape (cdr expr)))
1132          ((eq? head 'color) (interpret (caddr expr)))
1133          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
1134          ((eq? head 'translate-stencil) (interpret (caddr expr)))
1135          ((eq? head 'combine-stencil)
1136           (for-each (lambda (e) (interpret e))  (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))