scm/stencil.scm

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