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