scm/stencil.scm

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