scm/stencil.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2012 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 xext yext)
  19   (let* ((command-list `(moveto
  20                          ,(car (list-ref coords 3))
  21                          ,(cdr (list-ref coords 3))
  22                          curveto
  23                          ,(car (list-ref coords 0))
  24                          ,(cdr (list-ref coords 0))
  25                          ,(car (list-ref coords 1))
  26                          ,(cdr (list-ref coords 1))
  27                          ,(car (list-ref coords 2))
  28                          ,(cdr (list-ref coords 2))
  29                          curveto
  30                          ,(car (list-ref coords 4))
  31                          ,(cdr (list-ref coords 4))
  32                          ,(car (list-ref coords 5))
  33                          ,(cdr (list-ref coords 5))
  34                          ,(car (list-ref coords 6))
  35                          ,(cdr (list-ref coords 6))
  36                          closepath)))
  37   (ly:make-stencil
  38     `(path ,thick `(,@' ,command-list) 'round 'round #t)
  39     xext
  40     yext)))
  41
  42 (define-public (stack-stencils axis dir padding stils)
  43   "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
  44 @var{padding}."
  45   (cond
  46    ((null? stils) empty-stencil)
  47    ((null? (cdr stils)) (car stils))
  48    (else (ly:stencil-combine-at-edge
  49           (car stils) axis dir (stack-stencils axis dir padding (cdr stils))
  50           padding))))
  51
  52 (define-public (stack-stencils-padding-list axis dir padding stils)
  53   "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
  54 a list of @var{padding}."
  55   (cond
  56    ((null? stils) empty-stencil)
  57    ((null? (cdr stils)) (car stils))
  58    (else (ly:stencil-combine-at-edge
  59           (car stils)
  60           axis dir
  61           (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
  62           (car padding)))))
  63
  64 (define-public (centered-stencil stencil)
  65   "Center stencil @var{stencil} in both the X and Y directions."
  66   (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
  67
  68 (define-public (stack-lines dir padding baseline stils)
  69   "Stack vertically with a baseline skip."
  70   (define result empty-stencil)
  71   (define last-y #f)
  72   (do
  73       ((last-stencil #f (car p))
  74        (p stils (cdr p)))
  75
  76       ((null? p))
  77
  78     (if (number? last-y)
  79         (begin
  80           (let* ((dy (max (+ (* dir (interval-bound (ly:stencil-extent last-stencil Y) dir))
  81                              padding
  82                              (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
  83                           baseline))
  84                  (y (+ last-y  (* dir dy))))
  85
  86
  87
  88             (set! result
  89                   (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
  90             (set! last-y y)))
  91         (begin
  92           (set! last-y 0)
  93           (set! result (car p)))))
  94
  95   result)
  96
  97
  98 (define-public (bracketify-stencil stil axis thick protrusion padding)
  99   "Add brackets around @var{stil}, producing a new stencil."
 100
 101   (let* ((ext (ly:stencil-extent stil axis))
 102          (lb (ly:bracket axis ext thick protrusion))
 103          (rb (ly:bracket axis ext thick (- protrusion))))
 104     (set! stil
 105           (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
 106     (set! stil
 107           (ly:stencil-combine-at-edge lb (other-axis axis) 1 stil padding))
 108     stil))
 109
 110 (define (make-parenthesis-stencil
 111          y-extent half-thickness width angularity)
 112   "Create a parenthesis stencil.
 113 @var{y-extent} is the Y extent of the markup inside the parenthesis.
 114 @var{half-thickness} is the half thickness of the parenthesis.
 115 @var{width} is the width of a parenthesis.
 116 The higher the value of number @var{angularity},
 117 the more angular the shape of the parenthesis."
 118   (let* ((line-width 0.1)
 119          ;; Horizontal position of baseline that end points run through.
 120          (base-x
 121           (if (< width 0)
 122               (- width)
 123               0))
 124          ;; X value farthest from baseline on outside  of curve
 125          (outer-x (+ base-x width))
 126          ;; X extent of bezier sandwich centerline curves
 127          (x-extent (ordered-cons base-x outer-x))
 128          (bottom-y (interval-start y-extent))
 129          (top-y (interval-end y-extent))
 130
 131          (lower-end-point (cons base-x bottom-y))
 132          (upper-end-point (cons base-x top-y))
 133
 134          (outer-control-x (+ base-x (* 4/3 width)))
 135          (inner-control-x (+ outer-control-x
 136                              (if (< width 0)
 137                                  half-thickness
 138                                  (- half-thickness))))
 139
 140          ;; Vertical distance between a control point
 141          ;; and the end point it connects to.
 142          (offset-index (- (* 0.6 angularity) 0.8))
 143          (lower-control-y (interval-index y-extent offset-index))
 144          (upper-control-y (interval-index y-extent (- offset-index)))
 145
 146          (lower-outer-control-point
 147           (cons outer-control-x lower-control-y))
 148          (upper-outer-control-point
 149           (cons outer-control-x upper-control-y))
 150          (upper-inner-control-point
 151           (cons inner-control-x upper-control-y))
 152          (lower-inner-control-point
 153           (cons inner-control-x lower-control-y)))
 154
 155     (make-bezier-sandwich-stencil
 156       (list
 157              ;; Step 4: curve through inner control points
 158              ;; to lower end point.
 159              upper-inner-control-point
 160              lower-inner-control-point
 161              lower-end-point
 162              ;; Step 3: move to upper end point.
 163              upper-end-point
 164              ;; Step 2: curve through outer control points
 165              ;; to upper end point.
 166              lower-outer-control-point
 167              upper-outer-control-point
 168              upper-end-point
 169              ;; Step 1: move to lower end point.
 170              lower-end-point)
 171       line-width
 172       (interval-widen x-extent (/ line-width 2))
 173       (interval-widen y-extent (/ line-width 2)))))
 174
 175 (define-public (parenthesize-stencil
 176                 stencil half-thickness width angularity padding)
 177   "Add parentheses around @var{stencil}, returning a new stencil."
 178   (let* ((y-extent (ly:stencil-extent stencil Y))
 179          (lp (make-parenthesis-stencil
 180               y-extent half-thickness (- width) angularity))
 181          (rp (make-parenthesis-stencil
 182               y-extent half-thickness width angularity)))
 183     (set! stencil (ly:stencil-combine-at-edge lp X RIGHT stencil padding))
 184     (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
 185     stencil))
 186
 187 (define-public (make-line-stencil width startx starty endx endy)
 188   "Make a line stencil of given linewidth and set its extents accordingly."
 189   (let ((xext (cons (min startx endx) (max startx endx)))
 190         (yext (cons (min starty endy) (max starty endy))))
 191     (ly:make-stencil
 192       (list 'draw-line width startx starty endx endy)
 193       ; Since the line has rounded edges, we have to / can safely add half the
 194       ; width to all coordinates!
 195       (interval-widen xext (/ width 2))
 196       (interval-widen yext (/ width 2)))))
 197
 198
 199 (define-public (make-filled-box-stencil xext yext)
 200   "Make a filled box."
 201
 202   (ly:make-stencil
 203       (list 'round-filled-box (- (car xext)) (cdr xext)
 204                        (- (car yext)) (cdr yext) 0.0)
 205       xext yext))
 206
 207 (define-public (make-circle-stencil radius thickness fill)
 208   "Make a circle of radius @var{radius} and thickness @var{thickness}."
 209   (let*
 210       ((out-radius (+ radius (/ thickness 2.0))))
 211
 212   (ly:make-stencil
 213    (list 'circle radius thickness fill)
 214    (cons (- out-radius) out-radius)
 215    (cons (- out-radius) out-radius))))
 216
 217 (define-public (make-oval-stencil x-radius y-radius thickness fill)
 218   "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
 219 y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
 220 defined by @code{fill}."
 221   (let*
 222       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 223        (y-out-radius (+ y-radius (/ thickness 2.0)))
 224        (x-max x-radius)
 225        (x-min (- x-radius))
 226        (y-max y-radius)
 227        (y-min (- y-radius))
 228        (commands `(,(list 'moveto x-max 0)
 229                    ,(list 'curveto x-max y-max x-min y-max x-min 0)
 230                    ,(list 'curveto x-min y-min x-max y-min x-max 0)
 231                    ,(list 'closepath)))
 232        (command-list (fold-right append '() commands)))
 233   (ly:make-stencil
 234     `(path ,thickness `(,@',command-list) 'round 'round ,fill)
 235     (cons (- x-out-radius) x-out-radius)
 236     (cons (- y-out-radius) y-out-radius))))
 237
 238 (define-public
 239   (make-partial-ellipse-stencil
 240     x-radius y-radius start-angle end-angle thick connect fill)
 241
 242   (define (make-radius-list x-radius y-radius)
 243     (apply append
 244            (map (lambda (adder)
 245                   (map (lambda (quadrant)
 246                          (cons (+ adder (car quadrant))
 247                                (cdr quadrant)))
 248                        `((0.0 . (,x-radius . 0.0))
 249                          (,PI-OVER-TWO . (0.0 . ,y-radius))
 250                          (,PI . (,(- x-radius) . 0.0))
 251                          (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
 252                 `(0.0 ,TWO-PI))))
 253
 254   (define
 255     (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
 256     (define
 257       (helper ordering-function value left-list right-list cutl? cutr?)
 258       (if (null? right-list)
 259           (append
 260             (if cutl? '() left-list)
 261             (list value)
 262             (if cutr? '() right-list))
 263           (if (ordering-function value (car right-list))
 264               (append
 265                 (if cutl? '() left-list)
 266                 (list value)
 267                 (if cutr? '() right-list))
 268               (helper
 269                 ordering-function
 270                 value
 271                 (append left-list (list (car right-list)))
 272                 (cdr right-list)
 273                 cutl?
 274                 cutr?))))
 275     (helper ordering-function value '() inlist cutl? cutr?))
 276
 277   (define (ordering-function-1 a b) (car< a b))
 278
 279   (define (ordering-function-2 a b) (car<= a b))
 280
 281   (define (min-max-crawler min-max side l)
 282     (reduce min-max
 283             (if (eq? min-max min) 100000 -100000)
 284             (map (lambda (x) (side x)) l)))
 285
 286   (let*
 287       ((x-out-radius (+ x-radius (/ thick 2.0)))
 288        (y-out-radius (+ y-radius (/ thick 2.0)))
 289        (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
 290        (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
 291        (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
 292        (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
 293        (radius-list (make-radius-list x-out-radius y-out-radius))
 294        (rectangular-end-radius (polar->rectangular end-radius end-angle))
 295        (rectangular-start-radius (polar->rectangular start-radius start-angle))
 296        (new-end-angle
 297          (if (<= new-end-angle new-start-angle)
 298              (+ TWO-PI new-end-angle)
 299              new-end-angle))
 300        (possible-extrema
 301          (insert-in-ordered-list
 302            ordering-function-2
 303            (cons new-end-angle rectangular-end-radius)
 304            (insert-in-ordered-list
 305              ordering-function-1
 306              (cons new-start-angle rectangular-start-radius)
 307              radius-list
 308              #t
 309              #f)
 310            #f
 311            #t)))
 312     (ly:make-stencil
 313       (list
 314         'partial-ellipse
 315         x-radius
 316         y-radius
 317         start-angle
 318         end-angle
 319         thick
 320         connect
 321         fill)
 322       (cons (min-max-crawler min cadr possible-extrema)
 323             (min-max-crawler max cadr possible-extrema))
 324       (cons (min-max-crawler min cddr possible-extrema)
 325             (min-max-crawler max cddr possible-extrema)))))
 326
 327 (define (line-part-min-max x1 x2)
 328   (list (min x1 x2) (max x1 x2)))
 329
 330 (define (bezier-part-min-max x1 x2 x3 x4)
 331   ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
 332     (map
 333       (lambda (x)
 334         (+ (* x1 (expt (- 1 x) 3))
 335            (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
 336               (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
 337                  (* x4 (expt x 3))))))
 338       (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
 339              (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
 340           (list 0.0 1.0)
 341           (filter
 342             (lambda (x) (and (>= x 0) (<= x 1)))
 343             (append
 344               (list 0.0 1.0)
 345               (map (lambda (op)
 346                      (if (not (eqv? 0.0
 347                                     (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
 348                          ;; Zeros of the bezier curve
 349                          (/ (+ (- x1 (* 2 x2))
 350                                (op x3
 351                                    (sqrt (- (+ (expt x2 2)
 352                                                (+ (expt x3 2) (* x1 x4)))
 353                                             (+ (* x1 x3)
 354                                                (+ (* x2 x4) (* x2 x3)))))))
 355                             (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
 356                          ;; Apply L'hopital's rule to get the zeros if 0/0
 357                          (* (op 0 1)
 358                             (/ (/ (- x4 x3) 2)
 359                                (sqrt (- (+ (* x2 x2)
 360                                            (+ (* x3 x3) (* x1 x4)))
 361                                         (+ (* x1 x3)
 362                                            (+ (* x2 x4) (* x2 x3)))))))))
 363                    (list + -))))))))
 364
 365 (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
 366   (map (lambda (x)
 367          (apply bezier-part-min-max x))
 368        `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
 369
 370 (define (line-min-max x1 y1 x2 y2)
 371   (map (lambda (x)
 372          (apply line-part-min-max x))
 373        `((,x1 ,x2) (,y1 ,y2))))
 374
 375 (define (path-min-max origin pointlist)
 376
 377   ((lambda (x)
 378      (list
 379        (reduce min +inf.0 (map caar x))
 380        (reduce max -inf.0 (map cadar x))
 381        (reduce min +inf.0 (map caadr x))
 382        (reduce max -inf.0 (map cadadr x))))
 383     (map (lambda (x)
 384            (if (eq? (length x) 8)
 385                (apply bezier-min-max x)
 386                (apply line-min-max x)))
 387          (map (lambda (x y)
 388                 (append (list (cadr (reverse x)) (car (reverse x))) y))
 389               (append (list origin)
 390                       (reverse (cdr (reverse pointlist)))) pointlist))))
 391
 392 (define-public (make-connected-path-stencil pointlist thickness
 393                                             x-scale y-scale connect fill)
 394   "Make a connected path described by the list @var{pointlist}, with
 395 thickness @var{thickness}, and scaled by @var{x-scale} in the X direction
 396 and @var{y-scale} in the Y direction.  @var{connect} and @var{fill} are
 397 boolean arguments that specify if the path should be connected or filled,
 398 respectively."
 399
 400   ;; paths using this routine are designed to begin at point '(0 . 0)
 401   (let* ((origin (list 0 0))
 402          (boundlist (path-min-max origin pointlist))
 403          ;; modify pointlist to scale the coordinates
 404          (path (map (lambda (x)
 405                       (apply
 406                         (if (eq? 6 (length x))
 407                             (lambda (x1 x2 x3 x4 x5 x6)
 408                               (list 'curveto
 409                                     (* x1 x-scale)
 410                                     (* x2 y-scale)
 411                                     (* x3 x-scale)
 412                                     (* x4 y-scale)
 413                                     (* x5 x-scale)
 414                                     (* x6 y-scale)))
 415                             (lambda (x1 x2)
 416                               (list 'lineto
 417                                     (* x1 x-scale)
 418                                     (* x2 y-scale))))
 419                         x))
 420                     pointlist))
 421          ;; a path must begin with a `moveto'
 422          (prepend-origin (apply list (cons 'moveto origin) path))
 423          ;; if this path is connected, add closepath to the end
 424          (final-path (if connect
 425                          (append prepend-origin (list 'closepath))
 426                          prepend-origin))
 427          (command-list (fold-right append '() final-path)))
 428   (ly:make-stencil
 429     `(path ,thickness
 430            `(,@',command-list)
 431            'round
 432            'round
 433            ,(if fill #t #f))
 434     (coord-translate
 435       ((if (< x-scale 0) reverse-interval identity)
 436         (cons (* x-scale (list-ref boundlist 0))
 437               (* x-scale (list-ref boundlist 1))))
 438         `(,(/ thickness -2) . ,(/ thickness 2)))
 439     (coord-translate
 440       ((if (< y-scale 0) reverse-interval identity)
 441         (cons (* y-scale (list-ref boundlist 2))
 442               (* y-scale (list-ref boundlist 3))))
 443         `(,(/ thickness -2) . ,(/ thickness 2))))))
 444
 445 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
 446   "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
 447 @code{y-radius}, and thickness @var{thickness} with fill defined by
 448 @code{fill}."
 449   (let*
 450       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 451        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 452
 453   (ly:make-stencil
 454    (list 'ellipse x-radius y-radius thickness fill)
 455    (cons (- x-out-radius) x-out-radius)
 456    (cons (- y-out-radius) y-out-radius))))
 457
 458 (define-public (box-grob-stencil grob)
 459   "Make a box of exactly the extents of the grob.  The box precisely
 460 encloses the contents."
 461   (let* ((xext (ly:grob-extent grob grob 0))
 462          (yext (ly:grob-extent grob grob 1))
 463          (thick 0.01))
 464
 465     (ly:stencil-add
 466      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
 467      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
 468      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
 469      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
 470
 471 ;; TODO merge this and prev function.
 472 (define-public (box-stencil stencil thickness padding)
 473   "Add a box around @var{stencil}, producing a new stencil."
 474   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
 475          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
 476          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
 477          (x-rule (make-filled-box-stencil
 478                   (interval-widen x-ext thickness) (cons 0 thickness))))
 479     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
 480     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
 481     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
 482     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
 483     stencil))
 484
 485 (define-public (circle-stencil stencil thickness padding)
 486   "Add a circle around @var{stencil}, producing a new stencil."
 487   (let* ((x-ext (ly:stencil-extent stencil X))
 488          (y-ext (ly:stencil-extent stencil Y))
 489          (diameter (max (interval-length x-ext)
 490                         (interval-length y-ext)))
 491          (radius (+ (/ diameter 2) padding thickness))
 492          (circle (make-circle-stencil radius thickness #f)))
 493
 494     (ly:stencil-add
 495      stencil
 496      (ly:stencil-translate circle
 497                            (cons
 498                             (interval-center x-ext)
 499                             (interval-center y-ext))))))
 500
 501 (define-public (oval-stencil stencil thickness x-padding y-padding)
 502   "Add an oval around @code{stencil}, padded by the padding pair,
 503 producing a new stencil."
 504   (let* ((x-ext (ly:stencil-extent stencil X))
 505          (y-ext (ly:stencil-extent stencil Y))
 506          (x-length (+ (interval-length x-ext) x-padding thickness))
 507          (y-length (+ (interval-length y-ext) y-padding thickness))
 508          (x-radius (* 0.707 x-length) )
 509          (y-radius (* 0.707 y-length) )
 510          (oval (make-oval-stencil x-radius y-radius thickness #f)))
 511
 512     (ly:stencil-add
 513      stencil
 514      (ly:stencil-translate oval
 515                            (cons
 516                             (interval-center x-ext)
 517                             (interval-center y-ext))))))
 518
 519 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
 520   "Add an ellipse around @var{stencil}, padded by the padding pair,
 521 producing a new stencil."
 522   (let* ((x-ext (ly:stencil-extent stencil X))
 523          (y-ext (ly:stencil-extent stencil Y))
 524          (x-length (+ (interval-length x-ext) x-padding thickness))
 525          (y-length (+ (interval-length y-ext) y-padding thickness))
 526          ;(aspect-ratio (/ x-length y-length))
 527          (x-radius (* 0.707 x-length) )
 528          (y-radius (* 0.707 y-length) )
 529          ;(diameter (max (- (cdr x-ext) (car x-ext))
 530          ;              (- (cdr y-ext) (car y-ext))))
 531          ;(radius (+ (/ diameter 2) padding thickness))
 532          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
 533
 534     (ly:stencil-add
 535      stencil
 536      (ly:stencil-translate ellipse
 537                            (cons
 538                             (interval-center x-ext)
 539                             (interval-center y-ext))))))
 540
 541 (define-public (rounded-box-stencil stencil thickness padding blot)
 542    "Add a rounded box around @var{stencil}, producing a new stencil."
 543
 544   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
 545          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
 546    (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
 547    (ideal-blot (min blot (/ min-ext 2)))
 548    (ideal-thickness (min thickness (/ min-ext 2)))
 549          (outer (ly:round-filled-box
 550             (interval-widen xext ideal-thickness)
 551             (interval-widen yext ideal-thickness)
 552                ideal-blot))
 553          (inner (ly:make-stencil (list 'color (x11-color 'white)
 554             (ly:stencil-expr (ly:round-filled-box
 555                xext yext (- ideal-blot ideal-thickness)))))))
 556     (set! stencil (ly:stencil-add outer inner))
 557     stencil))
 558
 559 (define-public (stencil-with-color stencil color)
 560   (ly:make-stencil
 561    (list 'color color (ly:stencil-expr stencil))
 562    (ly:stencil-extent stencil X)
 563    (ly:stencil-extent stencil Y)))
 564
 565 (define-public (stencil-whiteout stencil)
 566   (let*
 567       ((x-ext (ly:stencil-extent stencil X))
 568        (y-ext (ly:stencil-extent stencil Y))
 569
 570        )
 571
 572     (ly:stencil-add
 573      (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
 574                          white)
 575      stencil)
 576     ))
 577
 578 (define-public (arrow-stencil-maker start? end?)
 579   "Return a function drawing a line from current point to @code{destination},
 580 with optional arrows of @code{max-size} on start and end controlled by
 581 @var{start?} and @var{end?}."
 582   (lambda (destination max-size)
 583   (let*
 584       ((e_x 1+0i)
 585        (e_y 0+1i)
 586        (distance (sqrt (+ (* (car destination) (car destination))
 587                           (* (cdr destination) (cdr destination)))))
 588        (size (min max-size (/ distance 3)))
 589        (rotate (lambda (z ang)
 590                  (* (make-polar 1 ang)
 591                     z)))
 592        (complex-to-offset (lambda (z)
 593                             (list (real-part z) (imag-part z))))
 594
 595        (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
 596        (e_z (/ z-dest (magnitude z-dest)))
 597        (triangle-points (list
 598                          (* size -1+0.25i)
 599                          0
 600                          (* size -1-0.25i)))
 601        (p1s (map (lambda (z)
 602                    (+ z-dest (rotate z (angle z-dest))))
 603                  triangle-points))
 604        (p2s (map (lambda (z)
 605                    (rotate z (angle (- z-dest))))
 606                    triangle-points))
 607        (null (cons 0 0))
 608        (arrow-1
 609         (ly:make-stencil
 610          `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
 611                    0.0
 612                    #t) null null))
 613        (arrow-2
 614         (ly:make-stencil
 615          `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
 616                    0.0
 617                    #t) null null ) )
 618        (thickness (min (/ distance 12) 0.1))
 619        (shorten-line (min (/ distance 3) 0.5))
 620        (start (complex-to-offset (/ (* e_z shorten-line) 2)))
 621        (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
 622
 623        (line (ly:make-stencil
 624               `(draw-line ,thickness
 625                           ,(car start) ,(cadr start)
 626                           ,(car end) ,(cadr end)
 627                           )
 628               (cons (min 0 (car destination))
 629                     (min 0 (cdr destination)))
 630               (cons (max 0 (car destination))
 631                     (max 0 (cdr destination)))))
 632
 633        (result
 634          (ly:stencil-add
 635            (if start? arrow-2 empty-stencil)
 636            (if end? arrow-1 empty-stencil)
 637            line)))
 638
 639     result)))
 640
 641 (define-public dimension-arrows (arrow-stencil-maker #t #t))
 642
 643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 644 ;; ANNOTATIONS
 645 ;;
 646 ;; annotations are arrows indicating the numerical value of
 647 ;; spacing variables
 648 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 649
 650 (define*-public (annotate-y-interval layout name extent is-length
 651                                      #:key (color darkblue))
 652   (let ((text-props (cons '((font-size . -3)
 653                             (font-family . typewriter))
 654                           (layout-extract-page-properties layout)))
 655         (annotation #f))
 656     (define (center-stencil-on-extent stil)
 657       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
 658                             (cons 0 (interval-center extent))))
 659     ;; do something sensible for 0,0 intervals.
 660     (set! extent (interval-widen extent 0.001))
 661     (if (not (interval-sane? extent))
 662         (set! annotation (interpret-markup
 663                           layout text-props
 664                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
 665         (let ((text-stencil (interpret-markup
 666                              layout text-props
 667                              (markup #:whiteout #:simple name)))
 668               (dim-stencil (interpret-markup
 669                             layout text-props
 670                             (markup #:whiteout
 671                                     #:simple (cond
 672                                               ((interval-empty? extent)
 673                                                "empty")
 674                                               (is-length
 675                                                (ly:format "~$" (interval-length extent)))
 676                                               (else
 677                                                (ly:format "(~$,~$)"
 678                                                        (car extent) (cdr extent)))))))
 679               (arrows (ly:stencil-translate-axis
 680                        (dimension-arrows (cons 0 (interval-length extent)) 1.0)
 681                        (interval-start extent) Y)))
 682           (set! annotation
 683                 (center-stencil-on-extent text-stencil))
 684           (set! annotation
 685                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
 686           (set! annotation
 687                 (ly:stencil-combine-at-edge annotation X LEFT
 688                                             (center-stencil-on-extent dim-stencil)
 689                                             0.5))
 690           (set! annotation
 691                 (stencil-with-color annotation color))))
 692     annotation))
 693
 694
 695 ;; TODO: figure out how to annotate padding nicely
 696 ;; TODO: emphasize either padding or min-dist depending on which constraint was active
 697 (define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y
 698                                       #:key (base-color blue))
 699    (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
 700          (space (get-spacing-var 'basic-distance))
 701          (padding (get-spacing-var 'padding))
 702          (min-dist (get-spacing-var 'minimum-distance))
 703          (contrast-color (append (cdr base-color) (list (car base-color))))
 704          (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
 705          (min-dist-color (if min-dist-blocks contrast-color base-color))
 706          (basic-annotation (annotate-y-interval layout
 707                                                 "basic-dist"
 708                                                 (cons (- start-Y-offset space) start-Y-offset)
 709                                                 #t
 710                                                 #:color (map (lambda (x) (* x 0.25)) base-color)))
 711          (min-annotation (annotate-y-interval layout
 712                                               "min-dist"
 713                                               (cons (- start-Y-offset min-dist) start-Y-offset)
 714                                               #t
 715                                               #:color min-dist-color))
 716          (extra-annotation (annotate-y-interval layout
 717                                                 "extra dist"
 718                                                 (cons next-staff-Y (- start-Y-offset min-dist))
 719                                                 #t
 720                                                 #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
 721
 722     (stack-stencils X RIGHT 0.0
 723                     (list
 724                      basic-annotation
 725                      (if min-dist-blocks
 726                          min-annotation
 727                          (ly:stencil-add min-annotation extra-annotation))))))
 728
 729 (define-public (eps-file->stencil axis size file-name)
 730   (let*
 731       ((contents (ly:gulp-file file-name))
 732        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
 733        (bbox-size (if (= axis X)
 734                       (- (list-ref bbox 2) (list-ref bbox 0))
 735                       (- (list-ref bbox 3) (list-ref bbox 1))
 736                       ))
 737        (factor (if (< 0 bbox-size)
 738                    (exact->inexact (/ size bbox-size))
 739                    0))
 740        (scaled-bbox
 741         (map (lambda (x) (* factor x)) bbox))
 742        ; We need to shift the whole eps to (0,0), otherwise it will appear
 743        ; displaced in lilypond (displacement will depend on the scaling!)
 744        (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
 745        (clip-rect-string (ly:format
 746                           "~a ~a ~a ~a rectclip"
 747                           (list-ref bbox 0)
 748                           (list-ref bbox 1)
 749                           (- (list-ref bbox 2) (list-ref bbox 0))
 750                           (- (list-ref bbox 3) (list-ref bbox 1)))))
 751
 752
 753     (if bbox
 754         (ly:make-stencil
 755          (list
 756           'embedded-ps
 757           (string-append
 758            (ly:format
 759            "
 760 gsave
 761 currentpoint translate
 762 BeginEPSF
 763 ~a dup scale
 764 ~a
 765 ~a
 766 %%BeginDocument: ~a
 767 "         factor translate-string  clip-rect-string
 768
 769            file-name
 770            )
 771            contents
 772            "%%EndDocument
 773 EndEPSF
 774 grestore
 775 "))
 776          ; Stencil starts at (0,0), since we have shifted the eps, and its
 777          ; size is exactly the size of the scaled bounding box
 778          (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
 779          (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
 780
 781         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
 782     ))
 783
 784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 785 ;; output signatures.
 786
 787 (define-public (write-system-signatures basename paper-systems count)
 788   (if (pair? paper-systems)
 789       (begin
 790         (let*
 791             ((outname (simple-format #f "~a-~a.signature" basename count)) )
 792
 793           (ly:message "Writing ~a" outname)
 794           (write-system-signature outname (car paper-systems))
 795           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
 796
 797 (use-modules (scm paper-system))
 798 (define-public (write-system-signature filename paper-system)
 799   (define (float? x)
 800     (and (number? x) (inexact? x)))
 801
 802   (define system-grob
 803     (paper-system-system-grob paper-system))
 804
 805   (define output (open-output-file filename))
 806
 807   ;; todo: optionally use a command line flag? Or just junk this?
 808   (define compare-expressions #f)
 809   (define (strip-floats expr)
 810     "Replace floats by #f"
 811     (cond
 812      ((float? expr) #f)
 813      ((ly:font-metric? expr) (ly:font-name expr))
 814      ((pair? expr) (cons (strip-floats (car expr))
 815                          (strip-floats (cdr expr))))
 816      (else expr)))
 817
 818   (define (fold-false-pairs expr)
 819     "Try to remove lists of #f as much as possible."
 820     (if (pair? expr)
 821         (let*
 822             ((first (car expr))
 823              (rest (fold-false-pairs (cdr expr))))
 824
 825           (if first
 826               (cons (fold-false-pairs first) rest)
 827               rest))
 828         expr))
 829
 830   (define (raw-string expr)
 831     "escape quotes and slashes for python consumption"
 832     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
 833
 834   (define (raw-pair expr)
 835     (simple-format #f "~a ~a"
 836             (car expr) (cdr expr)))
 837
 838   (define (found-grob expr)
 839     (let*
 840         ((grob (car expr))
 841          (rest (cdr expr))
 842          (collected '())
 843          (cause (event-cause grob))
 844          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
 845          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
 846
 847          ;; todo: use stencil extent if available.
 848          (x-ext (ly:grob-extent grob system-grob X))
 849          (y-ext (ly:grob-extent grob system-grob Y))
 850          (expression-skeleton
 851           (if compare-expressions
 852               (interpret-for-signature
 853                #f (lambda (e)
 854                     (set! collected (cons e collected)))
 855                rest)
 856              "")))
 857
 858       (simple-format output
 859               "~a@~a@~a@~a@~a\n"
 860               (cdr (assq 'name (ly:grob-property grob 'meta) ))
 861               (raw-string location)
 862               (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
 863               (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
 864               (raw-string collected))
 865       ))
 866
 867   (define (interpret-for-signature escape collect expr)
 868     (define (interpret expr)
 869       (let*
 870           ((head (if (pair? expr)
 871                      (car expr)
 872                      #f)))
 873
 874         (cond
 875          ((eq? head 'grob-cause) (escape (cdr expr)))
 876          ((eq? head 'color) (interpret (caddr expr)))
 877          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
 878          ((eq? head 'translate-stencil) (interpret (caddr expr)))
 879          ((eq? head 'combine-stencil)
 880           (for-each (lambda (e) (interpret e))  (cdr expr)))
 881          (else
 882           (collect (fold-false-pairs (strip-floats expr))))
 883
 884          )))
 885
 886     (interpret expr))
 887
 888   (if (ly:grob? system-grob)
 889       (begin
 890         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
 891                  output)
 892         (interpret-for-signature found-grob (lambda (x) #f)
 893                                  (ly:stencil-expr
 894                                   (paper-system-stencil paper-system)))))
 895
 896   ;; should be superfluous, but leaking "too many open files"?
 897   (close-port output))
 898