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