scm/stencil.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2010 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-public (stack-stencils axis dir padding stils)
  19   "Stack stencils STILS in direction AXIS, DIR, using PADDING."
  20   (cond
  21    ((null? stils) empty-stencil)
  22    ((null? (cdr stils)) (car stils))
  23    (else (ly:stencil-combine-at-edge
  24           (car stils) axis dir (stack-stencils axis dir padding (cdr stils))
  25           padding))))
  26
  27 (define-public (stack-stencils-padding-list axis dir padding stils)
  28   "Stack stencils STILS in direction AXIS, DIR, using a list of PADDING."
  29   (cond
  30    ((null? stils) empty-stencil)
  31    ((null? (cdr stils)) (car stils))
  32    (else (ly:stencil-combine-at-edge
  33           (car stils)
  34           axis dir
  35           (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
  36           (car padding)))))
  37
  38 (define-public (centered-stencil stencil)
  39   "Center stencil @var{stencil} in both the X and Y directions"
  40   (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
  41
  42 (define-public (stack-lines dir padding baseline stils)
  43   "Stack vertically with a baseline-skip."
  44   (define result empty-stencil)
  45   (define last-y #f)
  46   (do
  47       ((last-stencil #f (car p))
  48        (p stils (cdr p)))
  49
  50       ((null? p))
  51
  52     (if (number? last-y)
  53         (begin
  54           (let* ((dy (max (+ (* dir (interval-bound (ly:stencil-extent last-stencil Y) dir))
  55                              padding
  56                              (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
  57                           baseline))
  58                  (y (+ last-y  (* dir dy))))
  59
  60
  61
  62             (set! result
  63                   (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
  64             (set! last-y y)))
  65         (begin
  66           (set! last-y 0)
  67           (set! result (car p)))))
  68
  69   result)
  70
  71
  72 (define-public (bracketify-stencil stil axis thick protrusion padding)
  73   "Add brackets around STIL, producing a new stencil."
  74
  75   (let* ((ext (ly:stencil-extent stil axis))
  76          (lb (ly:bracket axis ext thick protrusion))
  77          (rb (ly:bracket axis ext thick (- protrusion))))
  78     (set! stil
  79           (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
  80     (set! stil
  81           (ly:stencil-combine-at-edge lb (other-axis axis) 1 stil padding))
  82     stil))
  83
  84 (define (make-parenthesis-stencil
  85          y-extent half-thickness width angularity)
  86   "Create a parenthesis stencil.
  87 @var{y-extent} is the Y extent of the markup inside the parenthesis.
  88 @var{half-thickness} is the half thickness of the parenthesis.
  89 @var{width} is the width of a parenthesis.
  90 The higher the value of number @var{angularity},
  91 the more angular the shape of the parenthesis."
  92   (let* ((line-width 0.1)
  93          ;; Horizontal position of baseline that end points run through.
  94          (base-x
  95           (if (< width 0)
  96               (- width)
  97               0))
  98          ;; Farthest X value (in relation to baseline)
  99          ;; on the outside of the curve.
 100          (outer-x (+ base-x width))
 101          (x-extent (ordered-cons base-x outer-x))
 102          (bottom-y (interval-start y-extent))
 103          (top-y (interval-end y-extent))
 104
 105          (lower-end-point (cons base-x bottom-y))
 106          (upper-end-point (cons base-x top-y))
 107
 108          (outer-control-x (+ base-x (* 4/3 width)))
 109          (inner-control-x (+ outer-control-x
 110                              (if (< width 0)
 111                                  half-thickness
 112                                  (- half-thickness))))
 113
 114          ;; Vertical distance between a control point
 115          ;; and the end point it connects to.
 116          (offset-index (- (* 0.6 angularity) 0.8))
 117          (lower-control-y (interval-index y-extent offset-index))
 118          (upper-control-y (interval-index y-extent (- offset-index)))
 119
 120          (lower-outer-control-point
 121           (cons outer-control-x lower-control-y))
 122          (upper-outer-control-point
 123           (cons outer-control-x upper-control-y))
 124          (upper-inner-control-point
 125           (cons inner-control-x upper-control-y))
 126          (lower-inner-control-point
 127           (cons inner-control-x lower-control-y)))
 128
 129     (ly:make-stencil
 130      (list 'bezier-sandwich
 131            `(quote ,(list
 132                      ;; Step 4: curve through inner control points
 133                      ;; to lower end point.
 134                      upper-inner-control-point
 135                      lower-inner-control-point
 136                      lower-end-point
 137                      ;; Step 3: move to upper end point.
 138                      upper-end-point
 139                      ;; Step 2: curve through outer control points
 140                      ;; to upper end point.
 141                      lower-outer-control-point
 142                      upper-outer-control-point
 143                      upper-end-point
 144                      ;; Step 1: move to lower end point.
 145                      lower-end-point))
 146            line-width)
 147      x-extent
 148      y-extent)))
 149
 150 (define-public (parenthesize-stencil
 151                 stencil half-thickness width angularity padding)
 152   "Add parentheses around @var{stencil}, returning a new stencil."
 153   (let* ((y-extent (ly:stencil-extent stencil Y))
 154          (lp (make-parenthesis-stencil
 155               y-extent half-thickness (- width) angularity))
 156          (rp (make-parenthesis-stencil
 157               y-extent half-thickness width angularity)))
 158     (set! stencil (ly:stencil-combine-at-edge lp X RIGHT stencil padding))
 159     (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
 160     stencil))
 161
 162 (define-public (make-line-stencil width startx starty endx endy)
 163   "Make a line stencil of given linewidth and set its extents accordingly"
 164   (let ((xext (cons (min startx endx) (max startx endx)))
 165         (yext (cons (min starty endy) (max starty endy))))
 166     (ly:make-stencil
 167       (list 'draw-line width startx starty endx endy)
 168       ; Since the line has rounded edges, we have to / can safely add half the
 169       ; width to all coordinates!
 170       (interval-widen xext (/ width 2))
 171       (interval-widen yext (/ width 2)))))
 172
 173
 174 (define-public (make-filled-box-stencil xext yext)
 175   "Make a filled box."
 176
 177   (ly:make-stencil
 178       (list 'round-filled-box (- (car xext)) (cdr xext)
 179                        (- (car yext)) (cdr yext) 0.0)
 180       xext yext))
 181
 182 (define-public (make-circle-stencil radius thickness fill)
 183   "Make a circle of radius @var{radius} and thickness @var{thickness}"
 184   (let*
 185       ((out-radius (+ radius (/ thickness 2.0))))
 186
 187   (ly:make-stencil
 188    (list 'circle radius thickness fill)
 189    (cons (- out-radius) out-radius)
 190    (cons (- out-radius) out-radius))))
 191
 192 (define-public (make-oval-stencil x-radius y-radius thickness fill)
 193   "Make an oval from two Bezier curves, of x radius @var{x-radius},
 194     y radius @code{y-radius},
 195     and thickness @var{thickness} with fill defined by @code{fill}."
 196   (let*
 197       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 198        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 199
 200   (ly:make-stencil
 201    (list 'oval x-radius y-radius thickness fill)
 202    (cons (- x-out-radius) x-out-radius)
 203    (cons (- y-out-radius) y-out-radius))))
 204
 205 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
 206   "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius},
 207     and thickness @var{thickness} with fill defined by @code{fill}."
 208   (let*
 209       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 210        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 211
 212   (ly:make-stencil
 213    (list 'ellipse x-radius y-radius thickness fill)
 214    (cons (- x-out-radius) x-out-radius)
 215    (cons (- y-out-radius) y-out-radius))))
 216
 217 (define-public (box-grob-stencil grob)
 218   "Make a box of exactly the extents of the grob.  The box precisely
 219 encloses the contents.
 220 "
 221   (let* ((xext (ly:grob-extent grob grob 0))
 222          (yext (ly:grob-extent grob grob 1))
 223          (thick 0.01))
 224
 225     (ly:stencil-add
 226      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
 227      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
 228      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
 229      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
 230
 231 ;; TODO merge this and prev function.
 232 (define-public (box-stencil stencil thickness padding)
 233   "Add a box around STENCIL, producing a new stencil."
 234   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
 235          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
 236          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
 237          (x-rule (make-filled-box-stencil
 238                   (interval-widen x-ext thickness) (cons 0 thickness))))
 239     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
 240     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
 241     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
 242     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
 243     stencil))
 244
 245 (define-public (circle-stencil stencil thickness padding)
 246   "Add a circle around STENCIL, producing a new stencil."
 247   (let* ((x-ext (ly:stencil-extent stencil X))
 248          (y-ext (ly:stencil-extent stencil Y))
 249          (diameter (max (interval-length x-ext)
 250                         (interval-length y-ext)))
 251          (radius (+ (/ diameter 2) padding thickness))
 252          (circle (make-circle-stencil radius thickness #f)))
 253
 254     (ly:stencil-add
 255      stencil
 256      (ly:stencil-translate circle
 257                            (cons
 258                             (interval-center x-ext)
 259                             (interval-center y-ext))))))
 260
 261 (define-public (oval-stencil stencil thickness x-padding y-padding)
 262   "Add an oval around @code{stencil}, padded by the padding pair,
 263    producing a new stencil."
 264   (let* ((x-ext (ly:stencil-extent stencil X))
 265          (y-ext (ly:stencil-extent stencil Y))
 266          (x-length (+ (interval-length x-ext) x-padding thickness))
 267          (y-length (+ (interval-length y-ext) y-padding thickness))
 268          (x-radius (* 0.707 x-length) )
 269          (y-radius (* 0.707 y-length) )
 270          (oval (make-oval-stencil x-radius y-radius thickness #f)))
 271
 272     (ly:stencil-add
 273      stencil
 274      (ly:stencil-translate oval
 275                            (cons
 276                             (interval-center x-ext)
 277                             (interval-center y-ext))))))
 278
 279 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
 280   "Add an ellipse around STENCIL, padded by the padding pair,
 281    producing a new stencil."
 282   (let* ((x-ext (ly:stencil-extent stencil X))
 283          (y-ext (ly:stencil-extent stencil Y))
 284          (x-length (+ (interval-length x-ext) x-padding thickness))
 285          (y-length (+ (interval-length y-ext) y-padding thickness))
 286          ;(aspect-ratio (/ x-length y-length))
 287          (x-radius (* 0.707 x-length) )
 288          (y-radius (* 0.707 y-length) )
 289          ;(diameter (max (- (cdr x-ext) (car x-ext))
 290          ;              (- (cdr y-ext) (car y-ext))))
 291          ;(radius (+ (/ diameter 2) padding thickness))
 292          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
 293
 294     (ly:stencil-add
 295      stencil
 296      (ly:stencil-translate ellipse
 297                            (cons
 298                             (interval-center x-ext)
 299                             (interval-center y-ext))))))
 300
 301 (define-public (rounded-box-stencil stencil thickness padding blot)
 302    "Add a rounded box around STENCIL, producing a new stencil."
 303
 304   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
 305          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
 306    (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
 307    (ideal-blot (min blot (/ min-ext 2)))
 308    (ideal-thickness (min thickness (/ min-ext 2)))
 309          (outer (ly:round-filled-box
 310             (interval-widen xext ideal-thickness)
 311             (interval-widen yext ideal-thickness)
 312                ideal-blot))
 313          (inner (ly:make-stencil (list 'color (x11-color 'white)
 314             (ly:stencil-expr (ly:round-filled-box
 315                xext yext (- ideal-blot ideal-thickness)))))))
 316     (set! stencil (ly:stencil-add outer inner))
 317     stencil))
 318
 319
 320 (define-public (fontify-text font-metric text)
 321   "Set TEXT with font FONT-METRIC, returning a stencil."
 322   (let* ((b (ly:text-dimension font-metric text)))
 323     (ly:make-stencil
 324      `(text ,font-metric ,text) (car b) (cdr b))))
 325
 326 (define-public (fontify-text-white scale font-metric text)
 327   "Set TEXT with scale factor SCALE"
 328   (let* ((b (ly:text-dimension font-metric text))
 329          ;;urg -- workaround for using ps font
 330          (c `(white-text ,(* 2 scale) ,text)))
 331     ;;urg -- extent is not from ps font, but we hope it's close
 332     (ly:make-stencil c (car b) (cdr b))))
 333
 334 (define-public (stencil-with-color stencil color)
 335   (ly:make-stencil
 336    (list 'color color (ly:stencil-expr stencil))
 337    (ly:stencil-extent stencil X)
 338    (ly:stencil-extent stencil Y)))
 339
 340 (define-public (stencil-whiteout stencil)
 341   (let*
 342       ((x-ext (ly:stencil-extent stencil X))
 343        (y-ext (ly:stencil-extent stencil Y))
 344
 345        )
 346
 347     (ly:stencil-add
 348      (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
 349                          white)
 350      stencil)
 351     ))
 352
 353 (define-public (dimension-arrows destination max-size)
 354   "Draw twosided arrow from here to @var{destination}"
 355
 356   (let*
 357       ((e_x 1+0i)
 358        (e_y 0+1i)
 359        (distance (sqrt (+ (* (car destination) (car destination))
 360                           (* (cdr destination) (cdr destination)))))
 361        (size (min max-size (/ distance 3)))
 362        (rotate (lambda (z ang)
 363                  (* (make-polar 1 ang)
 364                     z)))
 365        (complex-to-offset (lambda (z)
 366                             (list (real-part z) (imag-part z))))
 367
 368        (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
 369        (e_z (/ z-dest (magnitude z-dest)))
 370        (triangle-points (list
 371                          (* size -1+0.25i)
 372                          0
 373                          (* size -1-0.25i)))
 374        (p1s (map (lambda (z)
 375                    (+ z-dest (rotate z (angle z-dest))))
 376                  triangle-points))
 377        (p2s (map (lambda (z)
 378                    (rotate z (angle (- z-dest))))
 379                    triangle-points))
 380        (null (cons 0 0))
 381        (arrow-1
 382         (ly:make-stencil
 383          `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
 384                    0.0
 385                    #t) null null))
 386        (arrow-2
 387         (ly:make-stencil
 388          `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
 389                    0.0
 390                    #t) null null ) )
 391        (thickness (min (/ distance 12) 0.1))
 392        (shorten-line (min (/ distance 3) 0.5))
 393        (start (complex-to-offset (/ (* e_z shorten-line) 2)))
 394        (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
 395
 396        (line (ly:make-stencil
 397               `(draw-line ,thickness
 398                           ,(car start) ,(cadr start)
 399                           ,(car end) ,(cadr end)
 400                           )
 401               (cons (min 0 (car destination))
 402                     (min 0 (cdr destination)))
 403               (cons (max 0 (car destination))
 404                     (max 0 (cdr destination)))))
 405
 406        (result (ly:stencil-add arrow-2 arrow-1 line)))
 407
 408
 409     result))
 410
 411 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 412 ;; ANNOTATIONS
 413 ;;
 414 ;; annotations are arrows indicating the numerical value of
 415 ;; spacing variables
 416 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 417
 418 (define*-public (annotate-y-interval layout name extent is-length
 419                                      #:key (color darkblue))
 420   (let ((text-props (cons '((font-size . -3)
 421                             (font-family . typewriter))
 422                           (layout-extract-page-properties layout)))
 423         (annotation #f))
 424     (define (center-stencil-on-extent stil)
 425       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
 426                             (cons 0 (interval-center extent))))
 427     ;; do something sensible for 0,0 intervals.
 428     (set! extent (interval-widen extent 0.001))
 429     (if (not (interval-sane? extent))
 430         (set! annotation (interpret-markup
 431                           layout text-props
 432                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
 433         (let ((text-stencil (interpret-markup
 434                              layout text-props
 435                              (markup #:whiteout #:simple name)))
 436               (dim-stencil (interpret-markup
 437                             layout text-props
 438                             (markup #:whiteout
 439                                     #:simple (cond
 440                                               ((interval-empty? extent)
 441                                                (format "empty"))
 442                                               (is-length
 443                                                (ly:format "~$" (interval-length extent)))
 444                                               (else
 445                                                (ly:format "(~$,~$)"
 446                                                        (car extent) (cdr extent)))))))
 447               (arrows (ly:stencil-translate-axis
 448                        (dimension-arrows (cons 0 (interval-length extent)) 1.0)
 449                        (interval-start extent) Y)))
 450           (set! annotation
 451                 (center-stencil-on-extent text-stencil))
 452           (set! annotation
 453                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
 454           (set! annotation
 455                 (ly:stencil-combine-at-edge annotation X LEFT
 456                                             (center-stencil-on-extent dim-stencil)
 457                                             0.5))
 458           (set! annotation
 459                 (ly:make-stencil (list 'color color (ly:stencil-expr annotation))
 460                                  (ly:stencil-extent annotation X)
 461                                  (cons 10000 -10000)))))
 462     annotation))
 463
 464
 465 (define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end
 466                                       #:key (base-color blue))
 467   (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
 468          (space (get-spacing-var 'space))
 469          (padding (get-spacing-var 'padding))
 470          (min-dist (get-spacing-var 'minimum-distance))
 471          (contrast-color (append (cdr base-color) (list (car base-color)))))
 472     (stack-stencils X RIGHT 0.0
 473                     (list
 474                      (annotate-y-interval layout
 475                                           "space"
 476                                           (cons (- start-Y-offset space) start-Y-offset)
 477                                           #t
 478                                           #:color (map (lambda (x) (* x 0.25)) base-color))
 479                      (annotate-y-interval layout
 480                                           "min-dist"
 481                                           (cons (- start-Y-offset min-dist) start-Y-offset)
 482                                           #t
 483                                           #:color (map (lambda (x) (* x 0.5)) base-color))
 484                      (ly:stencil-add
 485                       (annotate-y-interval layout
 486                                            "bottom-of-extent"
 487                                            (cons prev-system-end start-Y-offset)
 488                                            #t
 489                                            #:color base-color)
 490                       (annotate-y-interval layout
 491                                            "padding"
 492                                            (cons (- prev-system-end padding) prev-system-end)
 493                                            #t
 494                                            #:color contrast-color))))))
 495
 496
 497 (define-public (eps-file->stencil axis size file-name)
 498   (let*
 499       ((contents (ly:gulp-file file-name))
 500        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
 501        (bbox-size (if (= axis X)
 502                       (- (list-ref bbox 2) (list-ref bbox 0))
 503                       (- (list-ref bbox 3) (list-ref bbox 1))
 504                       ))
 505        (factor (if (< 0 bbox-size)
 506                    (exact->inexact (/ size bbox-size))
 507                    0))
 508        (scaled-bbox
 509         (map (lambda (x) (* factor x)) bbox))
 510        ; We need to shift the whole eps to (0,0), otherwise it will appear
 511        ; displaced in lilypond (displacement will depend on the scaling!)
 512        (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
 513        (clip-rect-string (ly:format
 514                           "~a ~a ~a ~a rectclip"
 515                           (list-ref bbox 0)
 516                           (list-ref bbox 1)
 517                           (- (list-ref bbox 2) (list-ref bbox 0))
 518                           (- (list-ref bbox 3) (list-ref bbox 1)))))
 519
 520
 521     (if bbox
 522         (ly:make-stencil
 523          (list
 524           'embedded-ps
 525           (string-append
 526            (ly:format
 527            "
 528 gsave
 529 currentpoint translate
 530 BeginEPSF
 531 ~a dup scale
 532 ~a
 533 ~a
 534 %%BeginDocument: ~a
 535 "         factor translate-string  clip-rect-string
 536
 537            file-name
 538            )
 539            contents
 540            "%%EndDocument
 541 EndEPSF
 542 grestore
 543 "))
 544          ; Stencil starts at (0,0), since we have shifted the eps, and its
 545          ; size is exactly the size of the scaled bounding box
 546          (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
 547          (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
 548
 549         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
 550     ))
 551
 552 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 553 ;; output signatures.
 554
 555 (define-public (write-system-signatures basename paper-systems count)
 556   (if (pair? paper-systems)
 557       (begin
 558         (let*
 559             ((outname (simple-format #f "~a-~a.signature" basename count)) )
 560
 561           (ly:message "Writing ~a" outname)
 562           (write-system-signature outname (car paper-systems))
 563           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
 564
 565 (use-modules (scm paper-system))
 566 (define-public (write-system-signature filename paper-system)
 567   (define (float? x)
 568     (and (number? x) (inexact? x)))
 569
 570   (define system-grob
 571     (paper-system-system-grob paper-system))
 572
 573   (define output (open-output-file filename))
 574
 575   ;; todo: optionally use a command line flag? Or just junk this?
 576   (define compare-expressions #f)
 577   (define (strip-floats expr)
 578     "Replace floats by #f"
 579     (cond
 580      ((float? expr) #f)
 581      ((ly:font-metric? expr) (ly:font-name expr))
 582      ((pair? expr) (cons (strip-floats (car expr))
 583                          (strip-floats (cdr expr))))
 584      (else expr)))
 585
 586   (define (fold-false-pairs expr)
 587     "Try to remove lists of #f as much as possible."
 588     (if (pair? expr)
 589         (let*
 590             ((first (car expr))
 591              (rest (fold-false-pairs (cdr expr))))
 592
 593           (if first
 594               (cons (fold-false-pairs first) rest)
 595               rest))
 596         expr))
 597
 598   (define (raw-string expr)
 599     "escape quotes and slashes for python consumption"
 600     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
 601
 602   (define (raw-pair expr)
 603     (simple-format #f "~a ~a"
 604             (car expr) (cdr expr)))
 605
 606   (define (found-grob expr)
 607     (let*
 608         ((grob (car expr))
 609          (rest (cdr expr))
 610          (collected '())
 611          (cause (event-cause grob))
 612          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
 613          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
 614
 615          ;; todo: use stencil extent if available.
 616          (x-ext (ly:grob-extent grob system-grob X))
 617          (y-ext (ly:grob-extent grob system-grob Y))
 618          (expression-skeleton
 619           (if compare-expressions
 620               (interpret-for-signature
 621                #f (lambda (e)
 622                     (set! collected (cons e collected)))
 623                rest)
 624              "")))
 625
 626       (simple-format output
 627               "~a@~a@~a@~a@~a\n"
 628               (cdr (assq 'name (ly:grob-property grob 'meta) ))
 629               (raw-string location)
 630               (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
 631               (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
 632               (raw-string collected))
 633       ))
 634
 635   (define (interpret-for-signature escape collect expr)
 636     (define (interpret expr)
 637       (let*
 638           ((head (if (pair? expr)
 639                      (car expr)
 640                      #f)))
 641
 642         (cond
 643          ((eq? head 'grob-cause) (escape (cdr expr)))
 644          ((eq? head 'color) (interpret (caddr expr)))
 645          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
 646          ((eq? head 'translate-stencil) (interpret (caddr expr)))
 647          ((eq? head 'combine-stencil)
 648           (for-each (lambda (e) (interpret e))  (cdr expr)))
 649          (else
 650           (collect (fold-false-pairs (strip-floats expr))))
 651
 652          )))
 653
 654     (interpret expr))
 655
 656   (if (ly:grob? system-grob)
 657       (begin
 658         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
 659                  output)
 660         (interpret-for-signature found-grob (lambda (x) #f)
 661                                  (ly:stencil-expr
 662                                   (paper-system-stencil paper-system)))))
 663
 664   ;; should be superfluous, but leaking "too many open files"?
 665   (close-port output))
 666