scm/stencil.scm

   1 ;;;; stencil.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
   6
   7 (define-public (translate-stencil stencil coordinate-pair)
   8   "Translate @code{stencil} by the distances specified in
   9 @code{coordinate-pair}."
  10   (ly:stencil-translate-axis
  11     (ly:stencil-translate-axis stencil (cdr coordinate-pair) Y)
  12     (car coordinate-pair) X))
  13
  14 (define-public (stack-stencils axis dir padding stils)
  15   "Stack stencils STILS in direction AXIS, DIR, using PADDING."
  16   (cond
  17    ((null? stils) empty-stencil)
  18    ((null? (cdr stils)) (car stils))
  19    (else (ly:stencil-combine-at-edge
  20           (car stils) axis dir (stack-stencils axis dir padding (cdr stils))
  21           padding))))
  22
  23 (define-public (stack-stencils-padding-list axis dir padding stils)
  24   "Stack stencils STILS in direction AXIS, DIR, using a list of PADDING."
  25   (cond
  26    ((null? stils) empty-stencil)
  27    ((null? (cdr stils)) (car stils))
  28    (else (ly:stencil-combine-at-edge
  29           (car stils)
  30           axis dir
  31           (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
  32           (car padding)))))
  33
  34 (define-public (centered-stencil stencil)
  35   "Center stencil @var{stencil} in both the X and Y directions"
  36   (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
  37
  38 (define-public (stack-lines dir padding baseline stils)
  39   "Stack vertically with a baseline-skip."
  40   (define result empty-stencil)
  41   (define last-y #f)
  42   (do
  43       ((last-stencil #f (car p))
  44        (p stils (cdr p)))
  45
  46       ((null? p))
  47
  48     (if (number? last-y)
  49         (begin
  50           (let* ((dy (max (+ (* dir (interval-bound (ly:stencil-extent last-stencil Y) dir))
  51                              padding
  52                              (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
  53                           baseline))
  54                  (y (+ last-y  (* dir dy))))
  55
  56
  57
  58             (set! result
  59                   (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
  60             (set! last-y y)))
  61         (begin
  62           (set! last-y 0)
  63           (set! result (car p)))))
  64
  65   result)
  66
  67
  68 (define-public (bracketify-stencil stil axis thick protusion padding)
  69   "Add brackets around STIL, producing a new stencil."
  70
  71   (let* ((ext (ly:stencil-extent stil axis))
  72          (lb (ly:bracket axis ext thick (- protusion)))
  73          (rb (ly:bracket axis ext thick protusion)))
  74     (set! stil
  75           (ly:stencil-combine-at-edge stil (other-axis axis) 1 lb padding))
  76     (set! stil
  77           (ly:stencil-combine-at-edge stil (other-axis axis) -1 rb padding))
  78     stil))
  79
  80 (define-public (make-line-stencil width startx starty endx endy)
  81   "Make a line stencil of given linewidth and set its extents accordingly"
  82   (let ((xext (cons (min startx endx) (max startx endx)))
  83         (yext (cons (min starty endy) (max starty endy))))
  84     (ly:make-stencil
  85       (list 'draw-line width startx starty endx endy)
  86       ; Since the line has rounded edges, we have to / can safely add half the
  87       ; width to all coordinates!
  88       (interval-widen xext (/ width 2))
  89       (interval-widen yext (/ width 2)))))
  90
  91 (define-public (make-round-filled-box-stencil xext yext blot-diameter)
  92   "Make a filled rounded box."
  93
  94   (ly:make-stencil
  95       (list 'round-filled-box (- (car xext)) (cdr xext)
  96                        (- (car yext)) (cdr yext) blot-diameter)
  97       xext yext))
  98
  99 (define-public (make-filled-box-stencil xext yext)
 100   "Make a filled box."
 101
 102   (ly:make-stencil
 103       (list 'round-filled-box (- (car xext)) (cdr xext)
 104                        (- (car yext)) (cdr yext) 0.0)
 105       xext yext))
 106
 107 (define-public (make-circle-stencil radius thickness fill)
 108   "Make a circle of radius @var{radius} and thickness @var{thickness}"
 109   (let*
 110       ((out-radius (+ radius (/ thickness 2.0))))
 111
 112   (ly:make-stencil
 113    (list 'circle radius thickness fill)
 114    (cons (- out-radius) out-radius)
 115    (cons (- out-radius) out-radius))))
 116
 117 (define-public (make-oval-stencil x-radius y-radius thickness fill)
 118   "Make an oval from two Bezier curves, of x radius @var{x-radius},
 119     y radius @code{y-radius},
 120     and thickness @var{thickness} with fill defined by @code{fill}."
 121   (let*
 122       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 123        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 124
 125   (ly:make-stencil
 126    (list 'oval x-radius y-radius thickness fill)
 127    (cons (- x-out-radius) x-out-radius)
 128    (cons (- y-out-radius) y-out-radius))))
 129
 130 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
 131   "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius},
 132     and thickness @var{thickness} with fill defined by @code{fill}."
 133   (let*
 134       ((x-out-radius (+ x-radius (/ thickness 2.0)))
 135        (y-out-radius (+ y-radius (/ thickness 2.0))) )
 136
 137   (ly:make-stencil
 138    (list 'ellipse x-radius y-radius thickness fill)
 139    (cons (- x-out-radius) x-out-radius)
 140    (cons (- y-out-radius) y-out-radius))))
 141
 142 (define-public (box-grob-stencil grob)
 143   "Make a box of exactly the extents of the grob.  The box precisely
 144 encloses the contents.
 145 "
 146   (let* ((xext (ly:grob-extent grob grob 0))
 147          (yext (ly:grob-extent grob grob 1))
 148          (thick 0.01))
 149
 150     (ly:stencil-add
 151      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
 152      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
 153      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
 154      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
 155
 156 ;; TODO merge this and prev function.
 157 (define-public (box-stencil stencil thickness padding)
 158   "Add a box around STENCIL, producing a new stencil."
 159   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
 160          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
 161          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
 162          (x-rule (make-filled-box-stencil
 163                   (interval-widen x-ext thickness) (cons 0 thickness))))
 164     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
 165     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
 166     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
 167     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
 168     stencil))
 169
 170 (define-public (circle-stencil stencil thickness padding)
 171   "Add a circle around STENCIL, producing a new stencil."
 172   (let* ((x-ext (ly:stencil-extent stencil X))
 173          (y-ext (ly:stencil-extent stencil Y))
 174          (diameter (max (interval-length x-ext)
 175                         (interval-length y-ext)))
 176          (radius (+ (/ diameter 2) padding thickness))
 177          (circle (make-circle-stencil radius thickness #f)))
 178
 179     (ly:stencil-add
 180      stencil
 181      (ly:stencil-translate circle
 182                            (cons
 183                             (interval-center x-ext)
 184                             (interval-center y-ext))))))
 185
 186 (define-public (oval-stencil stencil thickness x-padding y-padding)
 187   "Add an oval around @code{stencil}, padded by the padding pair,
 188    producing a new stencil."
 189   (let* ((x-ext (ly:stencil-extent stencil X))
 190          (y-ext (ly:stencil-extent stencil Y))
 191          (x-length (+ (interval-length x-ext) x-padding thickness))
 192          (y-length (+ (interval-length y-ext) y-padding thickness))
 193          (x-radius (* 0.707 x-length) )
 194          (y-radius (* 0.707 y-length) )
 195          (oval (make-oval-stencil x-radius y-radius thickness #f)))
 196
 197     (ly:stencil-add
 198      stencil
 199      (ly:stencil-translate oval
 200                            (cons
 201                             (interval-center x-ext)
 202                             (interval-center y-ext))))))
 203
 204 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
 205   "Add an ellipse around STENCIL, padded by the padding pair,
 206    producing a new stencil."
 207   (let* ((x-ext (ly:stencil-extent stencil X))
 208          (y-ext (ly:stencil-extent stencil Y))
 209          (x-length (+ (interval-length x-ext) x-padding thickness))
 210          (y-length (+ (interval-length y-ext) y-padding thickness))
 211          ;(aspect-ratio (/ x-length y-length))
 212          (x-radius (* 0.707 x-length) )
 213          (y-radius (* 0.707 y-length) )
 214          ;(diameter (max (- (cdr x-ext) (car x-ext))
 215          ;              (- (cdr y-ext) (car y-ext))))
 216          ;(radius (+ (/ diameter 2) padding thickness))
 217          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
 218
 219     (ly:stencil-add
 220      stencil
 221      (ly:stencil-translate ellipse
 222                            (cons
 223                             (interval-center x-ext)
 224                             (interval-center y-ext))))))
 225
 226 (define-public (rounded-box-stencil stencil thickness padding blot)
 227    "Add a rounded box around STENCIL, producing a new stencil."
 228
 229   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
 230          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
 231    (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
 232    (ideal-blot (min blot (/ min-ext 2)))
 233    (ideal-thickness (min thickness (/ min-ext 2)))
 234          (outer (ly:round-filled-box
 235             (interval-widen xext ideal-thickness)
 236             (interval-widen yext ideal-thickness)
 237                ideal-blot))
 238          (inner (ly:make-stencil (list 'color (x11-color 'white)
 239             (ly:stencil-expr (ly:round-filled-box
 240                xext yext (- ideal-blot ideal-thickness)))))))
 241     (set! stencil (ly:stencil-add outer inner))
 242     stencil))
 243
 244
 245 (define-public (fontify-text font-metric text)
 246   "Set TEXT with font FONT-METRIC, returning a stencil."
 247   (let* ((b (ly:text-dimension font-metric text)))
 248     (ly:make-stencil
 249      `(text ,font-metric ,text) (car b) (cdr b))))
 250
 251 (define-public (fontify-text-white scale font-metric text)
 252   "Set TEXT with scale factor SCALE"
 253   (let* ((b (ly:text-dimension font-metric text))
 254          ;;urg -- workaround for using ps font
 255          (c `(white-text ,(* 2 scale) ,text)))
 256     ;;urg -- extent is not from ps font, but we hope it's close
 257     (ly:make-stencil c (car b) (cdr b))))
 258
 259 (define-public (stencil-with-color stencil color)
 260   (ly:make-stencil
 261    (list 'color color (ly:stencil-expr stencil))
 262    (ly:stencil-extent stencil X)
 263    (ly:stencil-extent stencil Y)))
 264
 265 (define-public (stencil-whiteout stencil)
 266   (let*
 267       ((x-ext (ly:stencil-extent stencil X))
 268        (y-ext (ly:stencil-extent stencil Y))
 269
 270        )
 271
 272     (ly:stencil-add
 273      (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
 274                          white)
 275      stencil)
 276     ))
 277
 278 (define-public (dimension-arrows destination)
 279   "Draw twosided arrow from here to @var{destination}"
 280
 281   (let*
 282       ((e_x 1+0i)
 283        (e_y 0+1i)
 284        (rotate (lambda (z ang)
 285                  (* (make-polar 1 ang)
 286                     z)))
 287        (complex-to-offset (lambda (z)
 288                             (list (real-part z) (imag-part z))))
 289
 290        (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
 291        (e_z (/ z-dest (magnitude z-dest)))
 292        (triangle-points '(-1+0.25i
 293                           0
 294                           -1-0.25i))
 295        (p1s (map (lambda (z)
 296                    (+ z-dest (rotate z (angle z-dest))))
 297                  triangle-points))
 298        (p2s (map (lambda (z)
 299                    (rotate z (angle (- z-dest))))
 300                    triangle-points))
 301        (null (cons 0 0))
 302        (arrow-1
 303         (ly:make-stencil
 304          `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
 305                    0.0
 306                    #t) null null))
 307        (arrow-2
 308         (ly:make-stencil
 309          `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
 310                    0.0
 311                    #t) null null ) )
 312        (thickness 0.1)
 313        (shorten-line 0.5)
 314        (start (complex-to-offset (/ (* e_z shorten-line) 2)))
 315        (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
 316
 317        (line (ly:make-stencil
 318               `(draw-line ,thickness
 319                           ,(car start) ,(cadr start)
 320                           ,(car end) ,(cadr end)
 321                           )
 322               (cons (min 0 (car destination))
 323                     (min 0 (cdr destination)))
 324               (cons (max 0 (car destination))
 325                     (max 0 (cdr destination)))))
 326
 327        (result (ly:stencil-add arrow-2 arrow-1 line)))
 328
 329
 330     result))
 331
 332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 333 ;; ANNOTATIONS
 334 ;;
 335 ;; annotations are arrows indicating the numerical value of
 336 ;; spacing variables
 337 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 338
 339 (define*-public (annotate-y-interval layout name extent is-length
 340                                      #:key (color darkblue))
 341   (let ((text-props (cons '((font-size . -3)
 342                             (font-family . typewriter))
 343                           (layout-extract-page-properties layout)))
 344         (annotation #f))
 345     (define (center-stencil-on-extent stil)
 346       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
 347                             (cons 0 (interval-center extent))))
 348     ;; do something sensible for 0,0 intervals.
 349     (set! extent (interval-widen extent 0.001))
 350     (if (not (interval-sane? extent))
 351         (set! annotation (interpret-markup
 352                           layout text-props
 353                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
 354         (let ((text-stencil (interpret-markup
 355                              layout text-props
 356                              (markup #:whiteout #:simple name)))
 357               (dim-stencil (interpret-markup
 358                             layout text-props
 359                             (markup #:whiteout
 360                                     #:simple (cond
 361                                               ((interval-empty? extent)
 362                                                (format "empty"))
 363                                               (is-length
 364                                                (ly:format "~$" (interval-length extent)))
 365                                               (else
 366                                                (ly:format "(~$,~$)"
 367                                                        (car extent) (cdr extent)))))))
 368               (arrows (ly:stencil-translate-axis
 369                        (dimension-arrows (cons 0 (interval-length extent)))
 370                        (interval-start extent) Y)))
 371           (set! annotation
 372                 (center-stencil-on-extent text-stencil))
 373           (set! annotation
 374                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
 375           (set! annotation
 376                 (ly:stencil-combine-at-edge annotation X LEFT
 377                                             (center-stencil-on-extent dim-stencil)
 378                                             0.5))
 379           (set! annotation
 380                 (ly:make-stencil (list 'color color (ly:stencil-expr annotation))
 381                                  (ly:stencil-extent annotation X)
 382                                  (cons 10000 -10000)))))
 383     annotation))
 384
 385
 386 (define-public (eps-file->stencil axis size file-name)
 387   (let*
 388       ((contents (ly:gulp-file file-name))
 389        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
 390        (bbox-size (if (= axis X)
 391                       (- (list-ref bbox 2) (list-ref bbox 0))
 392                       (- (list-ref bbox 3) (list-ref bbox 1))
 393                       ))
 394        (factor (if (< 0 bbox-size)
 395                    (exact->inexact (/ size bbox-size))
 396                    0))
 397        (scaled-bbox
 398         (map (lambda (x) (* factor x)) bbox))
 399        (clip-rect-string (ly:format
 400                           "~a ~a ~a ~a rectclip"
 401                           (list-ref bbox 0)
 402                           (list-ref bbox 1)
 403                           (- (list-ref bbox 2) (list-ref bbox 0))
 404                           (- (list-ref bbox 3) (list-ref bbox 1)))))
 405
 406
 407     (if bbox
 408         (ly:make-stencil
 409          (list
 410           'embedded-ps
 411           (string-append
 412            (ly:format
 413            "
 414 gsave
 415 currentpoint translate
 416 BeginEPSF
 417 ~a dup scale
 418 ~a
 419 %%BeginDocument: ~a
 420 "          factor clip-rect-string
 421
 422            file-name
 423            )
 424            contents
 425            "%%EndDocument
 426 EndEPSF
 427 grestore
 428 "))
 429
 430          (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2))
 431          (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3)))
 432
 433         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
 434     ))
 435
 436 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 437 ;; output signatures.
 438
 439 (define-public (write-system-signatures basename paper-systems count)
 440   (if (pair? paper-systems)
 441       (begin
 442         (let*
 443             ((outname (simple-format #f "~a-~a.signature" basename count)) )
 444
 445           (ly:message "Writing ~a" outname)
 446           (write-system-signature outname (car paper-systems))
 447           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
 448
 449 (use-modules (scm paper-system))
 450 (define-public (write-system-signature filename paper-system)
 451   (define (float? x)
 452     (and (number? x) (inexact? x)))
 453
 454   (define system-grob
 455     (paper-system-system-grob paper-system))
 456
 457   (define output (open-output-file filename))
 458
 459   ;; todo: optionally use a command line flag? Or just junk this?
 460   (define compare-expressions #f)
 461   (define (strip-floats expr)
 462     "Replace floats by #f"
 463     (cond
 464      ((float? expr) #f)
 465      ((ly:font-metric? expr) (ly:font-name expr))
 466      ((pair? expr) (cons (strip-floats (car expr))
 467                          (strip-floats (cdr expr))))
 468      (else expr)))
 469
 470   (define (fold-false-pairs expr)
 471     "Try to remove lists of #f as much as possible."
 472     (if (pair? expr)
 473         (let*
 474             ((first (car expr))
 475              (rest (fold-false-pairs (cdr expr))))
 476
 477           (if first
 478               (cons (fold-false-pairs first) rest)
 479               rest))
 480         expr))
 481
 482   (define (raw-string expr)
 483     "escape quotes and slashes for python consumption"
 484     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
 485
 486   (define (raw-pair expr)
 487     (simple-format #f "~a ~a"
 488             (car expr) (cdr expr)))
 489
 490   (define (found-grob expr)
 491     (let*
 492         ((grob (car expr))
 493          (rest (cdr expr))
 494          (collected '())
 495          (cause (event-cause grob))
 496          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
 497          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
 498
 499          ;; todo: use stencil extent if available.
 500          (x-ext (ly:grob-extent grob system-grob X))
 501          (y-ext (ly:grob-extent grob system-grob Y))
 502          (expression-skeleton
 503           (if compare-expressions
 504               (interpret-for-signature
 505                #f (lambda (e)
 506                     (set! collected (cons e collected)))
 507                rest)
 508              "")))
 509
 510       (simple-format output
 511               "~a@~a@~a@~a@~a\n"
 512               (cdr (assq 'name (ly:grob-property grob 'meta) ))
 513               (raw-string location)
 514               (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
 515               (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
 516               (raw-string collected))
 517       ))
 518
 519   (define (interpret-for-signature escape collect expr)
 520     (define (interpret expr)
 521       (let*
 522           ((head (if (pair? expr)
 523                      (car expr)
 524                      #f)))
 525
 526         (cond
 527          ((eq? head 'grob-cause) (escape (cdr expr)))
 528          ((eq? head 'color) (interpret (caddr expr)))
 529          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
 530          ((eq? head 'translate-stencil) (interpret (caddr expr)))
 531          ((eq? head 'combine-stencil)
 532           (for-each (lambda (e) (interpret e))  (cdr expr)))
 533          (else
 534           (collect (fold-false-pairs (strip-floats expr))))
 535
 536          )))
 537
 538     (interpret expr))
 539
 540   (if (ly:grob? system-grob)
 541       (begin
 542         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
 543                  output)
 544         (interpret-for-signature found-grob (lambda (x) #f)
 545                                  (ly:stencil-expr
 546                                   (paper-system-stencil paper-system)))))
 547
 548   ;; should be superfluous, but leaking "too many open files"?
 549   (close-port output))
 550