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 'special) stil)
 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          ;; for signatures, we indeed want the _outline_ rather than
1131          ;; the expression interpreted.  Right?
1132          ((eq? head 'with-outline) (interpret (cadr expr)))
1133          ((eq? head 'combine-stencil)
1134           (for-each interpret  (cdr expr)))
1135          (else
1136           (collect (fold-false-pairs (strip-floats expr))))
1137
1138          )))
1139
1140     (interpret expr))
1141
1142   (if (ly:grob? system-grob)
1143       (begin
1144         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
1145                  output)
1146         (interpret-for-signature found-grob (lambda (x) #f)
1147                                  (ly:stencil-expr
1148                                   (paper-system-stencil paper-system)))))
1149
1150   ;; should be superfluous, but leaking "too many open files"?
1151   (close-port output))