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