X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=db5ff186c37d659a863e9cb0d77e65a0d764c61d;hb=6f3f8f0fceed3b318c2572337e7dca83e4a11f6c;hp=8bbbed086f0c4f0efc588e033258da99ccda2e54;hpb=44dd3acc534e7a534f846810b481c3f603eaa92e;p=lilypond.git diff --git a/scm/stencil.scm b/scm/stencil.scm index 8bbbed086f..db5ff186c3 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--2012 Han-Wen Nienhuys +;;;; Copyright (C) 2003--2014 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 @@ -55,7 +55,12 @@ a list of @var{paddings}." empty-stencil (fold (lambda (next padding front) - (ly:stencil-stack front axis dir next padding)) + (let ((offset (+ (- (interval-end (ly:stencil-extent front axis)) + (interval-start (ly:stencil-extent next axis))) + padding))) + (ly:stencil-add + front + (ly:stencil-translate-axis next offset axis)))) (car stils) (cdr stils) paddings))) @@ -154,7 +159,7 @@ the more angular the shape of the parenthesis." upper-end-point ;; Step 1: move to lower end point. lower-end-point) - line-width + (* 2 half-thickness) (interval-widen x-extent (/ line-width 2)) (interval-widen y-extent (/ line-width 2))))) @@ -181,6 +186,12 @@ the more angular the shape of the parenthesis." (interval-widen xext (/ width 2)) (interval-widen yext (/ width 2))))) +(define-public (make-transparent-box-stencil xext yext) + "Make a transparent box." + (ly:make-stencil + (list 'transparent-stencil + (ly:stencil-expr (make-filled-box-stencil xext yext))) + xext yext)) (define-public (make-filled-box-stencil xext yext) "Make a filled box." @@ -236,20 +247,20 @@ be connected to the start by a line. (define (make-radius-list x-radius y-radius) "Makes a list of angle/radius pairs at intervals of PI/2 for the partial ellipse until 7*PI/2. For example, in pseudo-code: -> (make-radius-list 2 3) -((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3) - (2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3)) +> (make-radius-list 2 3)\ +\n((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3)\ +\n(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3)) " - (apply append - (map (lambda (adder) - (map (lambda (quadrant) - (cons (+ adder (car quadrant)) - (cdr quadrant))) - `((0.0 . (,x-radius . 0.0)) - (,PI-OVER-TWO . (0.0 . ,y-radius)) - (,PI . (,(- x-radius) . 0.0)) - (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius)))))) - `(0.0 ,TWO-PI)))) + (append-map + (lambda (adder) + (map (lambda (quadrant) + (cons (+ adder (car quadrant)) + (cdr quadrant))) + `((0.0 . (,x-radius . 0.0)) + (,PI-OVER-TWO . (0.0 . ,y-radius)) + (,PI . (,(- x-radius) . 0.0)) + (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius)))))) + `(0.0 ,TWO-PI))) (define (insert-in-ordered-list ordering-function value inlist cutl? cutr?) @@ -267,21 +278,21 @@ the same way but for the right side. For example: (helper ordering-function value left-list right-list cutl? cutr?) (if (null? right-list) (append - (if cutl? '() left-list) - (list value) - (if cutr? '() right-list)) + (if cutl? '() left-list) + (list value) + (if cutr? '() right-list)) (if (ordering-function value (car right-list)) (append - (if cutl? '() left-list) - (list value) - (if cutr? '() right-list)) + (if cutl? '() left-list) + (list value) + (if cutr? '() right-list)) (helper - ordering-function - value - (append left-list (list (car right-list))) - (cdr right-list) - cutl? - cutr?)))) + ordering-function + value + (append left-list (list (car right-list))) + (cdr right-list) + cutl? + cutr?)))) (helper ordering-function value '() inlist cutl? cutr?)) (define (ordering-function-1 a b) (car< a b)) @@ -298,7 +309,7 @@ then reduce using @var{min-max}: " (reduce min-max (if (eq? min-max min) 100000 -100000) - (map (lambda (x) (side x)) l))) + (map side l))) (let* (;; the outside limit of the x-radius @@ -322,41 +333,41 @@ then reduce using @var{min-max}: ;; we want the end angle to always be bigger than the start angle ;; so we redefine it here just in case it is less (new-end-angle - (if (<= new-end-angle new-start-angle) - (+ TWO-PI new-end-angle) - new-end-angle)) + (if (<= new-end-angle new-start-angle) + (+ TWO-PI new-end-angle) + new-end-angle)) ;; all the points that may be extrema of the arc ;; this is the 90 degree points plus the beginning and end points ;; we use this to calculate extents (possible-extrema + (insert-in-ordered-list + ordering-function-2 + (cons new-end-angle rectangular-end-radius) (insert-in-ordered-list - ordering-function-2 - (cons new-end-angle rectangular-end-radius) - (insert-in-ordered-list - ordering-function-1 - (cons new-start-angle rectangular-start-radius) - radius-list - #t - #f) - #f - #t))) + ordering-function-1 + (cons new-start-angle rectangular-start-radius) + radius-list + #t + #f) + #f + #t))) (ly:make-stencil - (list - 'partial-ellipse - x-radius - y-radius - start-angle - end-angle - thick - connect - fill) - ;; we know the extrema points by crawling through the - ;; list of possible extrema and finding the min and max - ;; for x and y - (cons (min-max-crawler min cadr possible-extrema) - (min-max-crawler max cadr possible-extrema)) - (cons (min-max-crawler min cddr possible-extrema) - (min-max-crawler max cddr possible-extrema))))) + (list + 'partial-ellipse + x-radius + y-radius + start-angle + end-angle + thick + connect + fill) + ;; we know the extrema points by crawling through the + ;; list of possible extrema and finding the min and max + ;; for x and y + (cons (min-max-crawler min cadr possible-extrema) + (min-max-crawler max cadr possible-extrema)) + (cons (min-max-crawler min cddr possible-extrema) + (min-max-crawler max cddr possible-extrema))))) (define (line-part-min-max x1 x2) (list (min x1 x2) (max x1 x2))) @@ -423,59 +434,120 @@ then reduce using @var{min-max}: (append (list origin) (reverse (cdr (reverse pointlist)))) pointlist)))) -(define-public (make-connected-path-stencil pointlist thickness - x-scale y-scale connect fill) - "Make a connected path described by the list @var{pointlist}, with -thickness @var{thickness}, and scaled by @var{x-scale} in the X direction -and @var{y-scale} in the Y direction. @var{connect} and @var{fill} are -boolean arguments that specify if the path should be connected or filled, -respectively." - - ;; paths using this routine are designed to begin at point '(0 . 0) - (let* ((origin (list 0 0)) - (boundlist (path-min-max origin pointlist)) - ;; modify pointlist to scale the coordinates - (path (map (lambda (x) - (apply - (if (= 6 (length x)) - (lambda (x1 x2 x3 x4 x5 x6) - (list 'curveto - (* x1 x-scale) - (* x2 y-scale) - (* x3 x-scale) - (* x4 y-scale) - (* x5 x-scale) - (* x6 y-scale))) - (lambda (x1 x2) - (list 'lineto - (* x1 x-scale) - (* x2 y-scale)))) - x)) - pointlist)) - ;; a path must begin with a `moveto' - (prepend-origin (apply list (cons 'moveto origin) path)) - ;; if this path is connected, add closepath to the end - (final-path (if connect - (append prepend-origin (list 'closepath)) - prepend-origin)) - (command-list (fold-right append '() final-path))) +(define-public (make-path-stencil path thickness x-scale y-scale fill) + "Make a stencil based on the path described by the list @var{path}, +with thickness @var{thickness}, and scaled by @var{x-scale} in the X +direction and @var{y-scale} in the Y direction. @var{fill} is a boolean +argument that specifies if the path should be filled. Valid path +commands are: moveto rmoveto lineto rlineto curveto rcurveto closepath, +and their standard SVG single letter equivalents: M m L l C c Z z." + + (define (convert-path path origin previous-point) + "Recursive function to standardize command names and +convert any relative path expressions (in @var{path}) to absolute +values. Returns a list of lists. @var{origin} is a pair of x and y +coordinates for the origin point of the path (used for closepath and +reset by moveto commands). @var{previous-point} is a pair of x and y +coordinates for the previous point in the path." + (if (pair? path) + (let* + ((head-raw (car path)) + (rest (cdr path)) + (head (cond + ((memq head-raw '(rmoveto M m)) 'moveto) + ((memq head-raw '(rlineto L l)) 'lineto) + ((memq head-raw '(rcurveto C c)) 'curveto) + ((memq head-raw '(Z z)) 'closepath) + (else head-raw))) + (arity (cond + ((memq head '(lineto moveto)) 2) + ((eq? head 'curveto) 6) + (else 0))) + (coordinates-raw (take rest arity)) + (absolute? (if (memq head-raw + '(rmoveto m rlineto l rcurveto c)) #f #t)) + (coordinates (if absolute? + coordinates-raw + ;; convert relative coordinates to absolute by + ;; adding them to previous point values + (map (lambda (c n) + (if (even? n) + (+ c (car previous-point)) + (+ c (cdr previous-point)))) + coordinates-raw + (iota arity)))) + (new-point (if (eq? head 'closepath) + origin + (cons + (list-ref coordinates (- arity 2)) + (list-ref coordinates (- arity 1))))) + (new-origin (if (eq? head 'moveto) + new-point + origin))) + (cons (cons head coordinates) + (convert-path (drop rest arity) new-origin new-point))) + '())) + + (let* ((path-absolute (convert-path path (cons 0 0) (cons 0 0))) + ;; scale coordinates + (path-scaled (if (and (= 1 x-scale) (= 1 y-scale)) + path-absolute + (map (lambda (path-unit) + (map (lambda (c n) + (cond + ((= 0 n) c) + ((odd? n) (* c x-scale)) + (else (* c y-scale)))) + path-unit + (iota (length path-unit)))) + path-absolute))) + ;; a path must begin with a 'moveto' + (path-final (if (eq? 'moveto (car (car path-scaled))) + path-scaled + (append (list (list 'moveto 0 0)) path-scaled))) + ;; remove all commands in order to calculate bounds + (path-headless (map cdr (delete (list 'closepath) path-final))) + (bound-list (path-min-max + (car path-headless) + (cdr path-headless)))) (ly:make-stencil `(path ,thickness - `(,@',command-list) - 'round - 'round - ,(if fill #t #f)) + `(,@',(concatenate path-final)) + 'round + 'round + ,(if fill #t #f)) (coord-translate ((if (< x-scale 0) reverse-interval identity) - (cons (* x-scale (list-ref boundlist 0)) - (* x-scale (list-ref boundlist 1)))) + (cons + (list-ref bound-list 0) + (list-ref bound-list 1))) `(,(/ thickness -2) . ,(/ thickness 2))) (coord-translate ((if (< y-scale 0) reverse-interval identity) - (cons (* y-scale (list-ref boundlist 2)) - (* y-scale (list-ref boundlist 3)))) + (cons + (list-ref bound-list 2) + (list-ref bound-list 3))) `(,(/ thickness -2) . ,(/ thickness 2)))))) +(define-public (make-connected-path-stencil pointlist thickness + x-scale y-scale connect fill) + "Make a connected path described by the list @var{pointlist}, beginning +at point '(0 . 0), with thickness @var{thickness}, and scaled by +@var{x-scale} in the X direction and @var{y-scale} in the Y direction. +@var{connect} and @var{fill} are boolean arguments that specify if the +path should be connected or filled, respectively." + (make-path-stencil + (concatenate + (append + (map (lambda (path-unit) + (case (length path-unit) + ((2) (append (list 'lineto) path-unit)) + ((6) (append (list 'curveto) path-unit)))) + pointlist) + ;; if this path is connected, add closepath to the end + (if connect (list '(closepath)) '()))) + thickness x-scale y-scale fill)) + (define-public (make-ellipse-stencil x-radius y-radius thickness fill) "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill defined by @@ -641,12 +713,12 @@ with optional arrows of @code{max-size} on start and end controlled by (null (cons 0 0)) (arrow-1 (ly:make-stencil - `(polygon (quote ,(concatenate (map complex-to-offset p1s))) + `(polygon (quote ,(append-map complex-to-offset p1s)) 0.0 #t) null null)) (arrow-2 (ly:make-stencil - `(polygon (quote ,(concatenate (map complex-to-offset p2s))) + `(polygon (quote ,(append-map complex-to-offset p2s)) 0.0 #t) null null ) ) (thickness (min (/ distance 12) 0.1)) @@ -929,4 +1001,3 @@ grestore ;; should be superfluous, but leaking "too many open files"? (close-port output)) -