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