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