scm/stencil.scm

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