X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=5e32f1efbb6896f918631269661f7482297ed683;hb=0d8a6a8ff518317b638a58328e8ef61e165ed058;hp=047c0d0bb9622a2d514da8360bcca871e14f636b;hpb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;p=lilypond.git diff --git a/scm/stencil.scm b/scm/stencil.scm index 047c0d0bb9..5e32f1efbb 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -1,8 +1,19 @@ -;;;; stencil.scm -- +;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2003--2008 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2010 Han-Wen Nienhuys +;;;; +;;;; LilyPond is free software: you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation, either version 3 of the License, or +;;;; (at your option) any later version. +;;;; +;;;; LilyPond is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with LilyPond. If not, see . (define-public (stack-stencils axis dir padding stils) "Stack stencils STILS in direction AXIS, DIR, using PADDING." @@ -35,7 +46,7 @@ (do ((last-stencil #f (car p)) (p stils (cdr p))) - + ((null? p)) (if (number? last-y) @@ -45,9 +56,9 @@ (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir)))) baseline)) (y (+ last-y (* dir dy)))) - - - + + + (set! result (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y))) (set! last-y y))) @@ -56,34 +67,113 @@ (set! result (car p))))) result) - -(define-public (bracketify-stencil stil axis thick protusion padding) + +(define-public (bracketify-stencil stil axis thick protrusion padding) "Add brackets around STIL, producing a new stencil." (let* ((ext (ly:stencil-extent stil axis)) - (lb (ly:bracket axis ext thick (- protusion))) - (rb (ly:bracket axis ext thick protusion))) + (lb (ly:bracket axis ext thick protrusion)) + (rb (ly:bracket axis ext thick (- protrusion)))) (set! stil - (ly:stencil-combine-at-edge stil (other-axis axis) 1 lb padding)) + (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding)) (set! stil - (ly:stencil-combine-at-edge stil (other-axis axis) -1 rb padding)) + (ly:stencil-combine-at-edge lb (other-axis axis) 1 stil padding)) stil)) +(define (make-parenthesis-stencil + y-extent half-thickness width angularity) + "Create a parenthesis stencil. +@var{y-extent} is the Y extent of the markup inside the parenthesis. +@var{half-thickness} is the half thickness of the parenthesis. +@var{width} is the width of a parenthesis. +The higher the value of number @var{angularity}, +the more angular the shape of the parenthesis." + (let* ((line-width 0.1) + ;; Horizontal position of baseline that end points run through. + (base-x + (if (< width 0) + (- width) + 0)) + ;; X value farthest from baseline on outside of curve + (outer-x (+ base-x width)) + ;; X extent of bezier sandwich centerline curves + (x-extent (ordered-cons base-x outer-x)) + (bottom-y (interval-start y-extent)) + (top-y (interval-end y-extent)) + + (lower-end-point (cons base-x bottom-y)) + (upper-end-point (cons base-x top-y)) + + (outer-control-x (+ base-x (* 4/3 width))) + (inner-control-x (+ outer-control-x + (if (< width 0) + half-thickness + (- half-thickness)))) + + ;; Vertical distance between a control point + ;; and the end point it connects to. + (offset-index (- (* 0.6 angularity) 0.8)) + (lower-control-y (interval-index y-extent offset-index)) + (upper-control-y (interval-index y-extent (- offset-index))) + + (lower-outer-control-point + (cons outer-control-x lower-control-y)) + (upper-outer-control-point + (cons outer-control-x upper-control-y)) + (upper-inner-control-point + (cons inner-control-x upper-control-y)) + (lower-inner-control-point + (cons inner-control-x lower-control-y))) + + (ly:make-stencil + (list 'bezier-sandwich + `(quote ,(list + ;; Step 4: curve through inner control points + ;; to lower end point. + upper-inner-control-point + lower-inner-control-point + lower-end-point + ;; Step 3: move to upper end point. + upper-end-point + ;; Step 2: curve through outer control points + ;; to upper end point. + lower-outer-control-point + upper-outer-control-point + upper-end-point + ;; Step 1: move to lower end point. + lower-end-point)) + line-width) + (interval-widen x-extent (/ line-width 2)) + (interval-widen y-extent (/ line-width 2))))) + +(define-public (parenthesize-stencil + stencil half-thickness width angularity padding) + "Add parentheses around @var{stencil}, returning a new stencil." + (let* ((y-extent (ly:stencil-extent stencil Y)) + (lp (make-parenthesis-stencil + y-extent half-thickness (- width) angularity)) + (rp (make-parenthesis-stencil + y-extent half-thickness width angularity))) + (set! stencil (ly:stencil-combine-at-edge lp X RIGHT stencil padding)) + (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding)) + stencil)) + (define-public (make-line-stencil width startx starty endx endy) "Make a line stencil of given linewidth and set its extents accordingly" (let ((xext (cons (min startx endx) (max startx endx))) (yext (cons (min starty endy) (max starty endy)))) (ly:make-stencil (list 'draw-line width startx starty endx endy) - ; Since the line has rounded edges, we have to / can safely add half the + ; Since the line has rounded edges, we have to / can safely add half the ; width to all coordinates! (interval-widen xext (/ width 2)) (interval-widen yext (/ width 2))))) + (define-public (make-filled-box-stencil xext yext) "Make a filled box." - + (ly:make-stencil (list 'round-filled-box (- (car xext)) (cdr xext) (- (car yext)) (cdr yext) 0.0) @@ -93,22 +183,22 @@ "Make a circle of radius @var{radius} and thickness @var{thickness}" (let* ((out-radius (+ radius (/ thickness 2.0)))) - + (ly:make-stencil - (list 'circle radius thickness fill) + (list 'circle radius thickness fill) (cons (- out-radius) out-radius) (cons (- out-radius) out-radius)))) (define-public (make-oval-stencil x-radius y-radius thickness fill) - "Make an oval from two Bezier curves, of x radius @var{x-radius}, + "Make an oval from two Bezier curves, of x radius @var{x-radius}, y radius @code{y-radius}, and thickness @var{thickness} with fill defined by @code{fill}." (let* - ((x-out-radius (+ x-radius (/ thickness 2.0))) + ((x-out-radius (+ x-radius (/ thickness 2.0))) (y-out-radius (+ y-radius (/ thickness 2.0))) ) - + (ly:make-stencil - (list 'oval x-radius y-radius thickness fill) + (list 'oval x-radius y-radius thickness fill) (cons (- x-out-radius) x-out-radius) (cons (- y-out-radius) y-out-radius)))) @@ -116,11 +206,11 @@ "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius}, and thickness @var{thickness} with fill defined by @code{fill}." (let* - ((x-out-radius (+ x-radius (/ thickness 2.0))) + ((x-out-radius (+ x-radius (/ thickness 2.0))) (y-out-radius (+ y-radius (/ thickness 2.0))) ) - + (ly:make-stencil - (list 'ellipse x-radius y-radius thickness fill) + (list 'ellipse x-radius y-radius thickness fill) (cons (- x-out-radius) x-out-radius) (cons (- y-out-radius) y-out-radius)))) @@ -138,7 +228,7 @@ encloses the contents. (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext) (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext)))) -;; TODO merge this and prev function. +;; TODO merge this and prev function. (define-public (box-stencil stencil thickness padding) "Add a box around STENCIL, producing a new stencil." (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding)) @@ -148,7 +238,7 @@ encloses the contents. (interval-widen x-ext thickness) (cons 0 thickness)))) (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding)) (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding)) - (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0)) + (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0)) (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0)) stencil)) @@ -157,7 +247,7 @@ encloses the contents. (let* ((x-ext (ly:stencil-extent stencil X)) (y-ext (ly:stencil-extent stencil Y)) (diameter (max (interval-length x-ext) - (interval-length y-ext))) + (interval-length y-ext))) (radius (+ (/ diameter 2) padding thickness)) (circle (make-circle-stencil radius thickness #f))) @@ -169,7 +259,7 @@ encloses the contents. (interval-center y-ext)))))) (define-public (oval-stencil stencil thickness x-padding y-padding) - "Add an oval around @code{stencil}, padded by the padding pair, + "Add an oval around @code{stencil}, padded by the padding pair, producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) (y-ext (ly:stencil-extent stencil Y)) @@ -187,7 +277,7 @@ encloses the contents. (interval-center y-ext)))))) (define-public (ellipse-stencil stencil thickness x-padding y-padding) - "Add an ellipse around STENCIL, padded by the padding pair, + "Add an ellipse around STENCIL, padded by the padding pair, producing a new stencil." (let* ((x-ext (ly:stencil-extent stencil X)) (y-ext (ly:stencil-extent stencil Y)) @@ -209,7 +299,7 @@ encloses the contents. (interval-center y-ext)))))) (define-public (rounded-box-stencil stencil thickness padding blot) - "Add a rounded box around STENCIL, producing a new stencil." + "Add a rounded box around STENCIL, producing a new stencil." (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding)) (yext (interval-widen (ly:stencil-extent stencil 1) padding)) @@ -217,74 +307,63 @@ encloses the contents. (ideal-blot (min blot (/ min-ext 2))) (ideal-thickness (min thickness (/ min-ext 2))) (outer (ly:round-filled-box - (interval-widen xext ideal-thickness) - (interval-widen yext ideal-thickness) + (interval-widen xext ideal-thickness) + (interval-widen yext ideal-thickness) ideal-blot)) - (inner (ly:make-stencil (list 'color (x11-color 'white) - (ly:stencil-expr (ly:round-filled-box + (inner (ly:make-stencil (list 'color (x11-color 'white) + (ly:stencil-expr (ly:round-filled-box xext yext (- ideal-blot ideal-thickness))))))) (set! stencil (ly:stencil-add outer inner)) stencil)) - -(define-public (fontify-text font-metric text) - "Set TEXT with font FONT-METRIC, returning a stencil." - (let* ((b (ly:text-dimension font-metric text))) - (ly:make-stencil - `(text ,font-metric ,text) (car b) (cdr b)))) - -(define-public (fontify-text-white scale font-metric text) - "Set TEXT with scale factor SCALE" - (let* ((b (ly:text-dimension font-metric text)) - ;;urg -- workaround for using ps font - (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 (stencil-with-color stencil color) (ly:make-stencil (list 'color color (ly:stencil-expr stencil)) (ly:stencil-extent stencil X) (ly:stencil-extent stencil Y))) - + (define-public (stencil-whiteout stencil) (let* ((x-ext (ly:stencil-extent stencil X)) (y-ext (ly:stencil-extent stencil Y)) ) - + (ly:stencil-add (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0) white) stencil) )) -(define-public (dimension-arrows destination) +(define-public (dimension-arrows destination max-size) "Draw twosided arrow from here to @var{destination}" - + (let* ((e_x 1+0i) (e_y 0+1i) + (distance (sqrt (+ (* (car destination) (car destination)) + (* (cdr destination) (cdr destination))))) + (size (min max-size (/ distance 3))) (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)) + (triangle-points (list + (* size -1+0.25i) + 0 + (* size -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 + (null (cons 0 0)) + (arrow-1 (ly:make-stencil `(polygon (quote ,(concatenate (map complex-to-offset p1s))) 0.0 @@ -294,11 +373,11 @@ encloses the contents. `(polygon (quote ,(concatenate (map complex-to-offset p2s))) 0.0 #t) null null ) ) - (thickness 0.1) - (shorten-line 0.5) + (thickness (min (/ distance 12) 0.1)) + (shorten-line (min (/ distance 3) 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) @@ -308,7 +387,7 @@ encloses the contents. (min 0 (cdr destination))) (cons (max 0 (car destination)) (max 0 (cdr destination))))) - + (result (ly:stencil-add arrow-2 arrow-1 line))) @@ -318,7 +397,7 @@ encloses the contents. ;; ANNOTATIONS ;; ;; annotations are arrows indicating the numerical value of -;; spacing variables +;; spacing variables ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define*-public (annotate-y-interval layout name extent is-length @@ -330,7 +409,7 @@ encloses the contents. (define (center-stencil-on-extent stil) (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER) (cons 0 (interval-center extent)))) - ;; do something sensible for 0,0 intervals. + ;; do something sensible for 0,0 intervals. (set! extent (interval-widen extent 0.001)) (if (not (interval-sane? extent)) (set! annotation (interpret-markup @@ -350,8 +429,8 @@ encloses the contents. (else (ly:format "(~$,~$)" (car extent) (cdr extent))))))) - (arrows (ly:stencil-translate-axis - (dimension-arrows (cons 0 (interval-length extent))) + (arrows (ly:stencil-translate-axis + (dimension-arrows (cons 0 (interval-length extent)) 1.0) (interval-start extent) Y))) (set! annotation (center-stencil-on-extent text-stencil)) @@ -368,6 +447,38 @@ encloses the contents. annotation)) +(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end + #:key (base-color blue)) + (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0))) + (space (get-spacing-var 'space)) + (padding (get-spacing-var 'padding)) + (min-dist (get-spacing-var 'minimum-distance)) + (contrast-color (append (cdr base-color) (list (car base-color))))) + (stack-stencils X RIGHT 0.0 + (list + (annotate-y-interval layout + "space" + (cons (- start-Y-offset space) start-Y-offset) + #t + #:color (map (lambda (x) (* x 0.25)) base-color)) + (annotate-y-interval layout + "min-dist" + (cons (- start-Y-offset min-dist) start-Y-offset) + #t + #:color (map (lambda (x) (* x 0.5)) base-color)) + (ly:stencil-add + (annotate-y-interval layout + "bottom-of-extent" + (cons prev-system-end start-Y-offset) + #t + #:color base-color) + (annotate-y-interval layout + "padding" + (cons (- prev-system-end padding) prev-system-end) + #t + #:color contrast-color)))))) + + (define-public (eps-file->stencil axis size file-name) (let* ((contents (ly:gulp-file file-name)) @@ -381,13 +492,16 @@ encloses the contents. 0)) (scaled-bbox (map (lambda (x) (* factor x)) bbox)) + ; We need to shift the whole eps to (0,0), otherwise it will appear + ; displaced in lilypond (displacement will depend on the scaling!) + (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1)))) (clip-rect-string (ly:format "~a ~a ~a ~a rectclip" - (list-ref bbox 0) - (list-ref bbox 1) + (list-ref bbox 0) + (list-ref bbox 1) (- (list-ref bbox 2) (list-ref bbox 0)) (- (list-ref bbox 3) (list-ref bbox 1))))) - + (if bbox (ly:make-stencil @@ -400,9 +514,10 @@ gsave currentpoint translate BeginEPSF ~a dup scale -~a +~a +~a %%BeginDocument: ~a -" factor clip-rect-string +" factor translate-string clip-rect-string file-name ) @@ -411,10 +526,11 @@ BeginEPSF EndEPSF grestore ")) - - (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2)) - (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3))) - + ; Stencil starts at (0,0), since we have shifted the eps, and its + ; size is exactly the size of the scaled bounding box + (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0))) + (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1)))) + (ly:make-stencil "" '(0 . 0) '(0 . 0))) )) @@ -426,7 +542,7 @@ grestore (begin (let* ((outname (simple-format #f "~a-~a.signature" basename count)) ) - + (ly:message "Writing ~a" outname) (write-system-signature outname (car paper-systems)) (write-system-signatures basename (cdr paper-systems) (1+ count)))))) @@ -438,7 +554,7 @@ grestore (define system-grob (paper-system-system-grob paper-system)) - + (define output (open-output-file filename)) ;; todo: optionally use a command line flag? Or just junk this? @@ -463,7 +579,7 @@ grestore (cons (fold-false-pairs first) rest) rest)) expr)) - + (define (raw-string expr) "escape quotes and slashes for python consumption" (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post)) @@ -471,7 +587,7 @@ grestore (define (raw-pair expr) (simple-format #f "~a ~a" (car expr) (cdr expr))) - + (define (found-grob expr) (let* ((grob (car expr)) @@ -517,7 +633,7 @@ grestore (for-each (lambda (e) (interpret e)) (cdr expr))) (else (collect (fold-false-pairs (strip-floats expr)))) - + ))) (interpret expr)) @@ -532,4 +648,4 @@ grestore ;; should be superfluous, but leaking "too many open files"? (close-port output)) - +