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