scm/stencil.scm

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