scm/stencil.scm

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