X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=cdac70fcc861d79bf2a81e6cc75fa6f9317e09c7;hb=06a307a1cddf950cc3dd41f8fac49ced4c714ddd;hp=8b193ce15d290c043f78d99006179ff3f5ca6185;hpb=3cd4ec70813835810b04383581ab57eb7085e4a2;p=lilypond.git diff --git a/scm/stencil.scm b/scm/stencil.scm index 8b193ce15d..cdac70fcc8 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2003--2005 Han-Wen Nienhuys +;;;; (c) 2003--2006 Han-Wen Nienhuys (define-public (stack-stencils axis dir padding stils) "Stack stencils STILS in direction AXIS, DIR, using PADDING." @@ -19,7 +19,9 @@ ((null? stils) empty-stencil) ((null? (cdr stils)) (car stils)) (else (ly:stencil-combine-at-edge - (car stils) axis dir (stack-stencils-padding-list axis dir (cdr padding) (cdr stils)) + (car stils) + axis dir + (stack-stencils-padding-list axis dir (cdr padding) (cdr stils)) (car padding))))) (define-public (centered-stencil stencil) @@ -53,14 +55,14 @@ "Make a filled box." (ly:make-stencil - (list 'filledbox (- (car xext)) (cdr xext) - (- (car yext)) (cdr yext)) + (list 'round-filled-box (- (car xext)) (cdr xext) + (- (car yext)) (cdr yext) 0.0) xext yext)) -(define-public (make-circle-stencil radius thickness) +(define-public (make-circle-stencil radius thickness fill) "Make a circle of radius @var{radius} and thickness @var{thickness}" (ly:make-stencil - (list 'circle radius thickness) + (list 'circle radius thickness fill) (cons (- radius) radius) (cons (- radius) radius))) @@ -100,7 +102,7 @@ encloses the contents. (- (cdr y-ext) (car y-ext)))) (radius (+ (/ diameter 2) padding thickness))) (ly:stencil-add - (centered-stencil stencil) (make-circle-stencil radius thickness)))) + (centered-stencil stencil) (make-circle-stencil radius thickness #f)))) (define-public (fontify-text font-metric text) "Set TEXT with font FONT-METRIC, returning a stencil." @@ -115,3 +117,154 @@ encloses the contents. (c `(white-text ,(* 2 scale) ,text))) ;;urg -- extent is not from ps font, but we hope it's close (ly:make-stencil c (car b) (cdr b)))) + +(define-public (dimension-arrows destination) + "Draw twosided arrow from here to @var{destination}" + + (let* + ((e_x 1+0i) + (e_y 0+1i) + (rotate (lambda (z ang) + (* (make-polar 1 ang) + z))) + (complex-to-offset (lambda (z) + (list (real-part z) (imag-part z)))) + + (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination)))) + (e_z (/ z-dest (magnitude z-dest))) + (triangle-points '(-1+0.25i + 0 + -1-0.25i)) + (p1s (map (lambda (z) + (+ z-dest (rotate z (angle z-dest)))) + triangle-points)) + (p2s (map (lambda (z) + (rotate z (angle (- z-dest)))) + triangle-points)) + (null (cons 0 0)) + (arrow-1 + (ly:make-stencil + `(polygon (quote ,(concatenate (map complex-to-offset p1s))) + 0.0 + #t) null null)) + (arrow-2 + (ly:make-stencil + `(polygon (quote ,(concatenate (map complex-to-offset p2s))) + 0.0 + #t) null null ) ) + (thickness 0.1) + (shorten-line 0.5) + (start (complex-to-offset (/ (* e_z shorten-line) 2))) + (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2)))) + + (line (ly:make-stencil + `(draw-line ,thickness + ,(car start) ,(cadr start) + ,(car end) ,(cadr end) + ) + (cons (min 0 (car destination)) + (min 0 (cdr destination))) + (cons (max 0 (car destination)) + (max 0 (cdr destination))))) + + (result (ly:stencil-add arrow-2 arrow-1 line))) + + + result)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ANNOTATIONS +;; +;; annotations are arrows indicating the numerical value of +;; spacing variables +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-public (annotate-y-interval layout name extent is-length) + (let* + ((text-props (cons + '((font-size . -3) + (font-family . typewriter)) + (layout-extract-page-properties layout))) + (annotation #f) + ) + + ;; do something sensible for 0,0 intervals. + (set! extent (interval-widen extent 0.001)) + (if (not (interval-sane? extent)) + (set! annotation (interpret-markup layout text-props + (make-simple-markup (format "~a: NaN/inf" name)))) + (let* + ((text-stencil (interpret-markup + layout text-props + (make-column-markup + (list + (make-whiteout-markup (make-simple-markup name)) + (make-whiteout-markup + (make-simple-markup + (cond + ((interval-empty? extent) "empty") + (is-length (format "~$" (interval-length extent))) + (else + (format "(~$,~$)" (car extent) + (cdr extent)))))))))) + (arrows + (ly:stencil-translate-axis + (dimension-arrows (cons 0 (interval-length extent))) + (interval-start extent) Y))) + + (set! annotation + (ly:stencil-aligned-to text-stencil Y CENTER)) + + (set! annotation (ly:stencil-translate + annotation + (cons 0 (interval-center extent)))) + + + (set! annotation + (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5 0)) + + (set! annotation + (ly:make-stencil (ly:stencil-expr annotation) + (ly:stencil-extent annotation X) + (cons 10000 -10000))))) + annotation)) + + +(define-public (eps-file->stencil axis size file-name) + (let* + ((contents (ly:gulp-file file-name)) + (bbox (get-postscript-bbox contents)) + (bbox-size (if (= axis X) + (- (list-ref bbox 2) (list-ref bbox 0)) + (- (list-ref bbox 3) (list-ref bbox 1)) + )) + (factor (exact->inexact (/ size bbox-size))) + (scaled-bbox + (map (lambda (x) (* factor x)) bbox))) + + (if bbox + (ly:make-stencil + (list + 'embedded-ps + (string-append + (format + " +gsave +currentpoint translate +BeginEPSF +~a ~a scale +%%BeginDocument: ~a +" factor factor + file-name + ) + contents + "%%EndDocument +EndEPSF +grestore +")) + + (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2)) + (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3))) + + (ly:make-stencil "" '(0 . 0) '(0 . 0))) + ))