X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=e64cc2b91c8662fad2736fd71d5fc56bb5a0ca48;hb=e96e340ad1d9ae9d40849c2f0fe26f963f52c522;hp=db5ff186c37d659a863e9cb0d77e65a0d764c61d;hpb=99b6f3aa3558b01c9d4158b19a1f1794c534f89c;p=lilypond.git diff --git a/scm/stencil.scm b/scm/stencil.scm index db5ff186c3..e64cc2b91c 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -1,6 +1,6 @@ ;;;; This file is part of LilyPond, the GNU music typesetter. ;;;; -;;;; Copyright (C) 2003--2014 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2015 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 @@ -464,9 +464,9 @@ coordinates for the previous point in the path." ((eq? head 'curveto) 6) (else 0))) (coordinates-raw (take rest arity)) - (absolute? (if (memq head-raw + (is-absolute (if (memq head-raw '(rmoveto m rlineto l rcurveto c)) #f #t)) - (coordinates (if absolute? + (coordinates (if is-absolute coordinates-raw ;; convert relative coordinates to absolute by ;; adding them to previous point values @@ -662,24 +662,90 @@ producing a new stencil." (set! stencil (ly:stencil-add outer inner)) stencil)) +(define-public (flip-stencil axis stil) + "Flip stencil @var{stil} in the direction of @var{axis}. +Value @code{X} (or @code{0}) for @var{axis} flips it horizontally. +Value @code{Y} (or @code{1}) flips it vertically. @var{stil} is +flipped in place; its position, the coordinates of its bounding +box, remains the same." + (let* ( + ;; scale stencil using -1 to flip it and + ;; then restore it to its original position + (xy (if (= axis X) '(-1 . 1) '(1 . -1))) + (flipped-stil (ly:stencil-scale stil (car xy) (cdr xy))) + (flipped-ext (ly:stencil-extent flipped-stil axis)) + (original-ext (ly:stencil-extent stil axis)) + (offset (- (car original-ext) (car flipped-ext))) + (replaced-stil (ly:stencil-translate-axis flipped-stil offset axis))) + replaced-stil)) + (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) +(define*-public (stencil-whiteout + stil #:optional (thickness 0.3) (color white) + (angle-increments 16) (radial-increments 1)) + "This function works by creating a series of white or @var{color} +stencils radially offset from the original stencil with angles from +0 to 2*pi, at an increment of @code{angle-inc}, and with radii +from @code{radial-inc} to @var{thickness}. @var{thickness} is how big +the white outline is in staff-spaces. @var{radial-increments} is how +many copies of the white stencil we make on our way out to thickness. +@var{angle-increments} is how many copies of the white stencil +we make between 0 and 2*pi." + (if (or (not (positive? angle-increments)) + (not (positive? radial-increments))) + (begin + (ly:warning "Both angle-increments and radial-increments must be positive numbers.") + stil) + (let* ((2pi 6.283185307) + (angle-inc (/ 2pi angle-increments)) + (radial-inc (/ thickness radial-increments))) + + (define (circle-plot ang dec radius original-stil new-stil) + ;; ang (angle) and dec (decrement) are in radians, not degrees + (if (<= ang 0) + new-stil + (circle-plot (- ang dec) dec radius original-stil + (ly:stencil-add + new-stil + (ly:stencil-translate original-stil + (cons + (* radius (cos ang)) + (* radius (sin ang)))))))) + + (define (radial-plot radius original-stil new-stil) + (if (<= radius 0) + new-stil + (ly:stencil-add new-stil + (radial-plot + (- radius radial-inc) + original-stil + (circle-plot 2pi angle-inc + radius original-stil empty-stencil))))) + + (let ((whiteout-expr + (ly:stencil-expr + (stencil-with-color + (radial-plot thickness stil empty-stencil) + color)))) + (ly:stencil-add + (ly:make-stencil + `(delay-stencil-evaluation ,(delay whiteout-expr))) + stil))))) + +(define-public (stencil-whiteout-box stencil) (let* ((x-ext (ly:stencil-extent stencil X)) - (y-ext (ly:stencil-extent stencil Y)) - - ) + (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) - )) + stencil))) (define-public (arrow-stencil-maker start? end?) "Return a function drawing a line from current point to @code{destination}, @@ -770,10 +836,10 @@ with optional arrows of @code{max-size} on start and end controlled by (make-simple-markup (simple-format #f "~a: NaN/inf" name)))) (let ((text-stencil (interpret-markup layout text-props - (markup #:whiteout #:simple name))) + (markup #:whiteout-box #:simple name))) (dim-stencil (interpret-markup layout text-props - (markup #:whiteout + (markup #:whiteout-box #:simple (cond ((interval-empty? extent) "empty") @@ -800,7 +866,8 @@ with optional arrows of @code{max-size} on start and end controlled by ;; TODO: figure out how to annotate padding nicely ;; TODO: emphasize either padding or min-dist depending on which constraint was active -(define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y +(define*-public (annotate-spacing-spec layout name spacing-spec + start-Y-offset next-staff-Y #:key (base-color blue)) (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0))) (space (get-spacing-var 'basic-distance)) @@ -809,21 +876,27 @@ with optional arrows of @code{max-size} on start and end controlled by (contrast-color (append (cdr base-color) (list (car base-color)))) (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y)) (min-dist-color (if min-dist-blocks contrast-color base-color)) - (basic-annotation (annotate-y-interval layout - "basic-dist" - (cons (- start-Y-offset space) start-Y-offset) - #t - #:color (map (lambda (x) (* x 0.25)) base-color))) - (min-annotation (annotate-y-interval layout - "min-dist" - (cons (- start-Y-offset min-dist) start-Y-offset) - #t - #:color min-dist-color)) - (extra-annotation (annotate-y-interval layout - "extra dist" - (cons next-staff-Y (- start-Y-offset min-dist)) - #t - #:color (map (lambda (x) (* x 0.5)) min-dist-color)))) + (name-string (if (string-null? name) + "" + (simple-format #f " (~a)" name))) + (basic-annotation + (annotate-y-interval layout + (simple-format #f "basic-dist~a" name-string) + (cons (- start-Y-offset space) start-Y-offset) + #t + #:color (map (lambda (x) (* x 0.25)) base-color))) + (min-annotation + (annotate-y-interval layout + (simple-format #f "min-dist~a" name-string) + (cons (- start-Y-offset min-dist) start-Y-offset) + #t + #:color min-dist-color)) + (extra-annotation + (annotate-y-interval layout + (simple-format #f "extra dist~a" name-string) + (cons next-staff-Y (- start-Y-offset min-dist)) + #t + #:color (map (lambda (x) (* x 0.5)) min-dist-color)))) (stack-stencils X RIGHT 0.0 (list