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