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