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