scm/stencil.scm

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