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