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