scm/stencil.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2003--2011 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
 202   (ly:make-stencil
 203    (list 'oval x-radius y-radius thickness fill)
 204    (cons (- x-out-radius) x-out-radius)
 205    (cons (- y-out-radius) y-out-radius))))
 206
 207 (define-public
 208   (make-partial-ellipse-stencil
 209     x-radius y-radius start-angle end-angle thick connect fill)
 210
 211   (define (make-radius-list x-radius y-radius)
 212     (apply append
 213            (map (lambda (adder)
 214                   (map (lambda (quadrant)
 215                          (cons (+ adder (car quadrant))
 216                                (cdr quadrant)))
 217                        `((0.0 . (,x-radius . 0.0))
 218                          (,PI-OVER-TWO . (0.0 . ,y-radius))
 219                          (,PI . (,(- x-radius) . 0.0))
 220                          (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
 221                 `(0.0 ,TWO-PI))))
 222
 223   (define
 224     (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
 225     (define
 226       (helper ordering-function value left-list right-list cutl? cutr?)
 227       (if (null? right-list)
 228           (append
 229             (if cutl? '() left-list)
 230             (list value)
 231             (if cutr? '() right-list))
 232           (if (ordering-function value (car right-list))
 233               (append
 234                 (if cutl? '() left-list)
 235                 (list value)
 236                 (if cutr? '() right-list))
 237               (helper
 238                 ordering-function
 239                 value
 240                 (append left-list (list (car right-list)))
 241                 (cdr right-list)
 242                 cutl?
 243                 cutr?))))
 244     (helper ordering-function value '() inlist cutl? cutr?))
 245
 246   (define (ordering-function-1 a b) (car< a b))
 247
 248   (define (ordering-function-2 a b) (car<= a b))
 249
 250   (define (min-max-crawler min-max side l)
 251     (reduce min-max
 252             (if (eq? min-max min) 100000 -100000)
 253             (map (lambda (x) (side x)) l)))
 254
 255   (let*
 256       ((x-out-radius (+ x-radius (/ thick 2.0)))
 257        (y-out-radius (+ y-radius (/ thick 2.0)))
 258        (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
 259        (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
 260        (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
 261        (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
 262        (radius-list (make-radius-list x-out-radius y-out-radius))
 263        (rectangular-end-radius (polar->rectangular end-radius end-angle))
 264        (rectangular-start-radius (polar->rectangular start-radius start-angle))
 265        (new-end-angle
 266          (if (<= new-end-angle new-start-angle)
 267              (+ TWO-PI new-end-angle)
 268              new-end-angle))
 269        (possible-extrema
 270          (insert-in-ordered-list
 271            ordering-function-2
 272            (cons new-end-angle rectangular-end-radius)
 273            (insert-in-ordered-list
 274              ordering-function-1
 275              (cons new-start-angle rectangular-start-radius)
 276              radius-list
 277              #t
 278              #f)
 279            #f
 280            #t)))
 281     (ly:make-stencil
 282       (list
 283         'partial-ellipse
 284         x-radius
 285         y-radius
 286         start-angle
 287         end-angle
 288         thick
 289         connect
 290         fill)
 291       (cons (min-max-crawler min cadr possible-extrema)
 292             (min-max-crawler max cadr possible-extrema))
 293       (cons (min-max-crawler min cddr possible-extrema)
 294             (min-max-crawler max cddr possible-extrema)))))
 295
 296 (define (path-min-max origin pointlist)
 297
 298   (define (line-part-min-max x1 x2)
 299     (list (min x1 x2) (max x1 x2)))
 300
 301   (define (bezier-part-min-max x1 x2 x3 x4)
 302     ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
 303       (map
 304         (lambda (x)
 305           (+ (* x1 (expt (- 1 x) 3))
 306              (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
 307                 (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
 308                    (* x4 (expt x 3))))))
 309         (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
 310                (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
 311             (list 0.0 1.0)
 312             (filter
 313               (lambda (x) (and (>= x 0) (<= x 1)))
 314               (append
 315                 (list 0.0 1.0)
 316                 (map (lambda (op)
 317                        (if (not (eqv? 0.0
 318                                       (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))))
 319                            ;; Zeros of the bezier curve
 320                            (/ (+ (- x1 (* 2 x2))
 321                                  (op x3
 322                                      (sqrt (- (+ (expt x2 2)
 323                                                  (+ (expt x3 2) (* x1 x4)))
 324                                               (+ (* x1 x3)
 325                                                  (+ (* x2 x4) (* x2 x3)))))))
 326                               (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
 327                            ;; Apply L'hopital's rule to get the zeros if 0/0
 328                            (* (op 0 1)
 329                               (/ (/ (- x4 x3) 2)
 330                                  (sqrt (- (+ (* x2 x2)
 331                                              (+ (* x3 x3) (* x1 x4)))
 332                                           (+ (* x1 x3)
 333                                              (+ (* x2 x4) (* x2 x3)))))))))
 334                      (list + -))))))))
 335
 336   (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
 337     (map (lambda (x)
 338            (apply bezier-part-min-max x))
 339          `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
 340
 341   (define (line-min-max x1 y1 x2 y2)
 342     (map (lambda (x)
 343            (apply line-part-min-max x))
 344          `((,x1 ,x2) (,y1 ,y2))))
 345
 346   ((lambda (x)
 347      (list
 348        (reduce min +inf.0 (map caar x))
 349        (reduce max -inf.0 (map cadar x))
 350        (reduce min +inf.0 (map caadr x))
 351        (reduce max -inf.0 (map cadadr x))))
 352     (map (lambda (x)
 353            (if (eq? (length x) 8)
 354                (apply bezier-min-max x)
 355                (apply line-min-max x)))
 356          (map (lambda (x y)
 357                 (append (list (cadr (reverse x)) (car (reverse x))) y))
 358               (append (list origin)
 359                       (reverse (cdr (reverse pointlist)))) pointlist))))
 360
 361 (define-public (make-connected-path-stencil pointlist thickness
 362                                             x-scale y-scale connect fill)
 363   "Make a connected path described by the list @var{pointlist}, with
 364 thickness @var{thickness}, and scaled by @var{x-scale} in the X direction
 365 and @var{y-scale} in the Y direction.  @var{connect} and @var{fill} are
 366 boolean arguments that specify if the path should be connected or filled,
 367 respectively."
 368
 369   ;; paths using this routine are designed to begin at point '(0 . 0)
 370   (let* ((origin (list 0 0))
 371          (boundlist (path-min-max origin pointlist))
 372          ;; modify pointlist to scale the coordinates
 373          (path (map (lambda (x)
 374                       (apply
 375                         (if (eq? 6 (length x))
 376                             (lambda (x1 x2 x3 x4 x5 x6)
 377                               (list 'curveto
 378                                     (* x1 x-scale)
 379                                     (* x2 y-scale)
 380                                     (* x3 x-scale)
 381                                     (* x4 y-scale)
 382                                     (* x5 x-scale)
 383                                     (* x6 y-scale)))
 384                             (lambda (x1 x2)
 385                               (list 'lineto
 386                                     (* x1 x-scale)
 387                                     (* x2 y-scale))))
 388                         x))
 389                     pointlist))
 390          ;; a path must begin with a `moveto'
 391          (prepend-origin (apply list (cons 'moveto origin) path))
 392          ;; if this path is connected, add closepath to the end
 393          (final-path (if connect
 394                          (append prepend-origin (list 'closepath))
 395                          prepend-origin))
 396          (command-list (fold-right append '() final-path)))
 397
 398   (ly:make-stencil
 399     `(path ,thickness
 400            `(,@',command-list)
 401            'round
 402            'round
 403            ,(if fill #t #f))
 404     (coord-translate
 405       ((if (< x-scale 0) reverse-interval identity)
 406         (cons (* x-scale (list-ref boundlist 0))
 407               (* x-scale (list-ref boundlist 1))))
 408         `(,(/ thickness -2) . ,(/ thickness 2)))
 409     (coord-translate
 410       ((if (< y-scale 0) reverse-interval identity)
 411         (cons (* y-scale (list-ref boundlist 2))
 412               (* y-scale (list-ref boundlist 3))))
 413         `(,(/ thickness -2) . ,(/ thickness 2))))))
 414
 415 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
 416   "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
 417 @code{y-radius}, and thickness @var{thickness} with fill defined by
 418 @code{fill}."
 419   (let*
 420       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 421        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 422
 423   (ly:make-stencil
 424    (list 'ellipse x-radius y-radius thickness fill)
 425    (cons (- x-out-radius) x-out-radius)
 426    (cons (- y-out-radius) y-out-radius))))
 427
 428 (define-public (box-grob-stencil grob)
 429   "Make a box of exactly the extents of the grob.  The box precisely
 430 encloses the contents."
 431   (let* ((xext (ly:grob-extent grob grob 0))
 432          (yext (ly:grob-extent grob grob 1))
 433          (thick 0.01))
 434
 435     (ly:stencil-add
 436      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
 437      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
 438      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
 439      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
 440
 441 ;; TODO merge this and prev function.
 442 (define-public (box-stencil stencil thickness padding)
 443   "Add a box around @var{stencil}, producing a new stencil."
 444   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
 445          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
 446          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
 447          (x-rule (make-filled-box-stencil
 448                   (interval-widen x-ext thickness) (cons 0 thickness))))
 449     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
 450     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
 451     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
 452     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
 453     stencil))
 454
 455 (define-public (circle-stencil stencil thickness padding)
 456   "Add a circle around @var{stencil}, producing a new stencil."
 457   (let* ((x-ext (ly:stencil-extent stencil X))
 458          (y-ext (ly:stencil-extent stencil Y))
 459          (diameter (max (interval-length x-ext)
 460                         (interval-length y-ext)))
 461          (radius (+ (/ diameter 2) padding thickness))
 462          (circle (make-circle-stencil radius thickness #f)))
 463
 464     (ly:stencil-add
 465      stencil
 466      (ly:stencil-translate circle
 467                            (cons
 468                             (interval-center x-ext)
 469                             (interval-center y-ext))))))
 470
 471 (define-public (oval-stencil stencil thickness x-padding y-padding)
 472   "Add an oval around @code{stencil}, padded by the padding pair,
 473 producing a new stencil."
 474   (let* ((x-ext (ly:stencil-extent stencil X))
 475          (y-ext (ly:stencil-extent stencil Y))
 476          (x-length (+ (interval-length x-ext) x-padding thickness))
 477          (y-length (+ (interval-length y-ext) y-padding thickness))
 478          (x-radius (* 0.707 x-length) )
 479          (y-radius (* 0.707 y-length) )
 480          (oval (make-oval-stencil x-radius y-radius thickness #f)))
 481
 482     (ly:stencil-add
 483      stencil
 484      (ly:stencil-translate oval
 485                            (cons
 486                             (interval-center x-ext)
 487                             (interval-center y-ext))))))
 488
 489 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
 490   "Add an ellipse around @var{stencil}, padded by the padding pair,
 491 producing a new stencil."
 492   (let* ((x-ext (ly:stencil-extent stencil X))
 493          (y-ext (ly:stencil-extent stencil Y))
 494          (x-length (+ (interval-length x-ext) x-padding thickness))
 495          (y-length (+ (interval-length y-ext) y-padding thickness))
 496          ;(aspect-ratio (/ x-length y-length))
 497          (x-radius (* 0.707 x-length) )
 498          (y-radius (* 0.707 y-length) )
 499          ;(diameter (max (- (cdr x-ext) (car x-ext))
 500          ;              (- (cdr y-ext) (car y-ext))))
 501          ;(radius (+ (/ diameter 2) padding thickness))
 502          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
 503
 504     (ly:stencil-add
 505      stencil
 506      (ly:stencil-translate ellipse
 507                            (cons
 508                             (interval-center x-ext)
 509                             (interval-center y-ext))))))
 510
 511 (define-public (rounded-box-stencil stencil thickness padding blot)
 512    "Add a rounded box around @var{stencil}, producing a new stencil."
 513
 514   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
 515          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
 516    (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
 517    (ideal-blot (min blot (/ min-ext 2)))
 518    (ideal-thickness (min thickness (/ min-ext 2)))
 519          (outer (ly:round-filled-box
 520             (interval-widen xext ideal-thickness)
 521             (interval-widen yext ideal-thickness)
 522                ideal-blot))
 523          (inner (ly:make-stencil (list 'color (x11-color 'white)
 524             (ly:stencil-expr (ly:round-filled-box
 525                xext yext (- ideal-blot ideal-thickness)))))))
 526     (set! stencil (ly:stencil-add outer inner))
 527     stencil))
 528
 529 (define-public (stencil-with-color stencil color)
 530   (ly:make-stencil
 531    (list 'color color (ly:stencil-expr stencil))
 532    (ly:stencil-extent stencil X)
 533    (ly:stencil-extent stencil Y)))
 534
 535 (define-public (stencil-whiteout stencil)
 536   (let*
 537       ((x-ext (ly:stencil-extent stencil X))
 538        (y-ext (ly:stencil-extent stencil Y))
 539
 540        )
 541
 542     (ly:stencil-add
 543      (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
 544                          white)
 545      stencil)
 546     ))
 547
 548 (define-public (arrow-stencil-maker start? end?)
 549   "Return a function drawing a line from current point to @code{destination},
 550 with optional arrows of @code{max-size} on start and end controlled by
 551 @var{start?} and @var{end?}."
 552   (lambda (destination max-size)
 553   (let*
 554       ((e_x 1+0i)
 555        (e_y 0+1i)
 556        (distance (sqrt (+ (* (car destination) (car destination))
 557                           (* (cdr destination) (cdr destination)))))
 558        (size (min max-size (/ distance 3)))
 559        (rotate (lambda (z ang)
 560                  (* (make-polar 1 ang)
 561                     z)))
 562        (complex-to-offset (lambda (z)
 563                             (list (real-part z) (imag-part z))))
 564
 565        (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
 566        (e_z (/ z-dest (magnitude z-dest)))
 567        (triangle-points (list
 568                          (* size -1+0.25i)
 569                          0
 570                          (* size -1-0.25i)))
 571        (p1s (map (lambda (z)
 572                    (+ z-dest (rotate z (angle z-dest))))
 573                  triangle-points))
 574        (p2s (map (lambda (z)
 575                    (rotate z (angle (- z-dest))))
 576                    triangle-points))
 577        (null (cons 0 0))
 578        (arrow-1
 579         (ly:make-stencil
 580          `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
 581                    0.0
 582                    #t) null null))
 583        (arrow-2
 584         (ly:make-stencil
 585          `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
 586                    0.0
 587                    #t) null null ) )
 588        (thickness (min (/ distance 12) 0.1))
 589        (shorten-line (min (/ distance 3) 0.5))
 590        (start (complex-to-offset (/ (* e_z shorten-line) 2)))
 591        (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
 592
 593        (line (ly:make-stencil
 594               `(draw-line ,thickness
 595                           ,(car start) ,(cadr start)
 596                           ,(car end) ,(cadr end)
 597                           )
 598               (cons (min 0 (car destination))
 599                     (min 0 (cdr destination)))
 600               (cons (max 0 (car destination))
 601                     (max 0 (cdr destination)))))
 602
 603        (result
 604          (ly:stencil-add
 605            (if start? arrow-2 empty-stencil)
 606            (if end? arrow-1 empty-stencil)
 607            line)))
 608
 609     result)))
 610
 611 (define-public dimension-arrows (arrow-stencil-maker #t #t))
 612
 613 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 614 ;; ANNOTATIONS
 615 ;;
 616 ;; annotations are arrows indicating the numerical value of
 617 ;; spacing variables
 618 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 619
 620 (define*-public (annotate-y-interval layout name extent is-length
 621                                      #:key (color darkblue))
 622   (let ((text-props (cons '((font-size . -3)
 623                             (font-family . typewriter))
 624                           (layout-extract-page-properties layout)))
 625         (annotation #f))
 626     (define (center-stencil-on-extent stil)
 627       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
 628                             (cons 0 (interval-center extent))))
 629     ;; do something sensible for 0,0 intervals.
 630     (set! extent (interval-widen extent 0.001))
 631     (if (not (interval-sane? extent))
 632         (set! annotation (interpret-markup
 633                           layout text-props
 634                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
 635         (let ((text-stencil (interpret-markup
 636                              layout text-props
 637                              (markup #:whiteout #:simple name)))
 638               (dim-stencil (interpret-markup
 639                             layout text-props
 640                             (markup #:whiteout
 641                                     #:simple (cond
 642                                               ((interval-empty? extent)
 643                                                "empty")
 644                                               (is-length
 645                                                (ly:format "~$" (interval-length extent)))
 646                                               (else
 647                                                (ly:format "(~$,~$)"
 648                                                        (car extent) (cdr extent)))))))
 649               (arrows (ly:stencil-translate-axis
 650                        (dimension-arrows (cons 0 (interval-length extent)) 1.0)
 651                        (interval-start extent) Y)))
 652           (set! annotation
 653                 (center-stencil-on-extent text-stencil))
 654           (set! annotation
 655                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
 656           (set! annotation
 657                 (ly:stencil-combine-at-edge annotation X LEFT
 658                                             (center-stencil-on-extent dim-stencil)
 659                                             0.5))
 660           (set! annotation
 661                 (ly:make-stencil (list 'color color (ly:stencil-expr annotation))
 662                                  (ly:stencil-extent annotation X)
 663                                  (cons 10000 -10000)))))
 664     annotation))
 665
 666
 667 (define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end
 668                                       #:key (base-color blue))
 669   (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
 670          (space (get-spacing-var 'space))
 671          (padding (get-spacing-var 'padding))
 672          (min-dist (get-spacing-var 'minimum-distance))
 673          (contrast-color (append (cdr base-color) (list (car base-color)))))
 674     (stack-stencils X RIGHT 0.0
 675                     (list
 676                      (annotate-y-interval layout
 677                                           "space"
 678                                           (cons (- start-Y-offset space) start-Y-offset)
 679                                           #t
 680                                           #:color (map (lambda (x) (* x 0.25)) base-color))
 681                      (annotate-y-interval layout
 682                                           "min-dist"
 683                                           (cons (- start-Y-offset min-dist) start-Y-offset)
 684                                           #t
 685                                           #:color (map (lambda (x) (* x 0.5)) base-color))
 686                      (ly:stencil-add
 687                       (annotate-y-interval layout
 688                                            "bottom-of-extent"
 689                                            (cons prev-system-end start-Y-offset)
 690                                            #t
 691                                            #:color base-color)
 692                       (annotate-y-interval layout
 693                                            "padding"
 694                                            (cons (- prev-system-end padding) prev-system-end)
 695                                            #t
 696                                            #:color contrast-color))))))
 697
 698
 699 (define-public (eps-file->stencil axis size file-name)
 700   (let*
 701       ((contents (ly:gulp-file file-name))
 702        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
 703        (bbox-size (if (= axis X)
 704                       (- (list-ref bbox 2) (list-ref bbox 0))
 705                       (- (list-ref bbox 3) (list-ref bbox 1))
 706                       ))
 707        (factor (if (< 0 bbox-size)
 708                    (exact->inexact (/ size bbox-size))
 709                    0))
 710        (scaled-bbox
 711         (map (lambda (x) (* factor x)) bbox))
 712        ; We need to shift the whole eps to (0,0), otherwise it will appear
 713        ; displaced in lilypond (displacement will depend on the scaling!)
 714        (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
 715        (clip-rect-string (ly:format
 716                           "~a ~a ~a ~a rectclip"
 717                           (list-ref bbox 0)
 718                           (list-ref bbox 1)
 719                           (- (list-ref bbox 2) (list-ref bbox 0))
 720                           (- (list-ref bbox 3) (list-ref bbox 1)))))
 721
 722
 723     (if bbox
 724         (ly:make-stencil
 725          (list
 726           'embedded-ps
 727           (string-append
 728            (ly:format
 729            "
 730 gsave
 731 currentpoint translate
 732 BeginEPSF
 733 ~a dup scale
 734 ~a
 735 ~a
 736 %%BeginDocument: ~a
 737 "         factor translate-string  clip-rect-string
 738
 739            file-name
 740            )
 741            contents
 742            "%%EndDocument
 743 EndEPSF
 744 grestore
 745 "))
 746          ; Stencil starts at (0,0), since we have shifted the eps, and its
 747          ; size is exactly the size of the scaled bounding box
 748          (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
 749          (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
 750
 751         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
 752     ))
 753
 754 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 755 ;; output signatures.
 756
 757 (define-public (write-system-signatures basename paper-systems count)
 758   (if (pair? paper-systems)
 759       (begin
 760         (let*
 761             ((outname (simple-format #f "~a-~a.signature" basename count)) )
 762
 763           (ly:message "Writing ~a" outname)
 764           (write-system-signature outname (car paper-systems))
 765           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
 766
 767 (use-modules (scm paper-system))
 768 (define-public (write-system-signature filename paper-system)
 769   (define (float? x)
 770     (and (number? x) (inexact? x)))
 771
 772   (define system-grob
 773     (paper-system-system-grob paper-system))
 774
 775   (define output (open-output-file filename))
 776
 777   ;; todo: optionally use a command line flag? Or just junk this?
 778   (define compare-expressions #f)
 779   (define (strip-floats expr)
 780     "Replace floats by #f"
 781     (cond
 782      ((float? expr) #f)
 783      ((ly:font-metric? expr) (ly:font-name expr))
 784      ((pair? expr) (cons (strip-floats (car expr))
 785                          (strip-floats (cdr expr))))
 786      (else expr)))
 787
 788   (define (fold-false-pairs expr)
 789     "Try to remove lists of #f as much as possible."
 790     (if (pair? expr)
 791         (let*
 792             ((first (car expr))
 793              (rest (fold-false-pairs (cdr expr))))
 794
 795           (if first
 796               (cons (fold-false-pairs first) rest)
 797               rest))
 798         expr))
 799
 800   (define (raw-string expr)
 801     "escape quotes and slashes for python consumption"
 802     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
 803
 804   (define (raw-pair expr)
 805     (simple-format #f "~a ~a"
 806             (car expr) (cdr expr)))
 807
 808   (define (found-grob expr)
 809     (let*
 810         ((grob (car expr))
 811          (rest (cdr expr))
 812          (collected '())
 813          (cause (event-cause grob))
 814          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
 815          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
 816
 817          ;; todo: use stencil extent if available.
 818          (x-ext (ly:grob-extent grob system-grob X))
 819          (y-ext (ly:grob-extent grob system-grob Y))
 820          (expression-skeleton
 821           (if compare-expressions
 822               (interpret-for-signature
 823                #f (lambda (e)
 824                     (set! collected (cons e collected)))
 825                rest)
 826              "")))
 827
 828       (simple-format output
 829               "~a@~a@~a@~a@~a\n"
 830               (cdr (assq 'name (ly:grob-property grob 'meta) ))
 831               (raw-string location)
 832               (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
 833               (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
 834               (raw-string collected))
 835       ))
 836
 837   (define (interpret-for-signature escape collect expr)
 838     (define (interpret expr)
 839       (let*
 840           ((head (if (pair? expr)
 841                      (car expr)
 842                      #f)))
 843
 844         (cond
 845          ((eq? head 'grob-cause) (escape (cdr expr)))
 846          ((eq? head 'color) (interpret (caddr expr)))
 847          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
 848          ((eq? head 'translate-stencil) (interpret (caddr expr)))
 849          ((eq? head 'combine-stencil)
 850           (for-each (lambda (e) (interpret e))  (cdr expr)))
 851          (else
 852           (collect (fold-false-pairs (strip-floats expr))))
 853
 854          )))
 855
 856     (interpret expr))
 857
 858   (if (ly:grob? system-grob)
 859       (begin
 860         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
 861                  output)
 862         (interpret-for-signature found-grob (lambda (x) #f)
 863                                  (ly:stencil-expr
 864                                   (paper-system-stencil paper-system)))))
 865
 866   ;; should be superfluous, but leaking "too many open files"?
 867   (close-port output))
 868