From: Patrick McCarty <pnorcks@gmail.com>
Date: Sat, 19 Jun 2010 04:06:18 +0000 (-0700)
Subject: Add a new \path markup command.
X-Git-Tag: release/2.13.31-1~75
X-Git-Url: https://git.donarmstrong.com/lilypond.git?a=commitdiff_plain;h=32f5bf1a2255777c44aaf201843b17f3a3ef2131;p=lilypond.git

Add a new \path markup command.

Details on usage are found in the docstring.
---

diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index cc2d232754..1d1c30cc67 100644
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -620,6 +620,137 @@ grestore
 		 str))
    '(0 . 0) '(0 . 0)))
 
+(define-markup-command (path layout props thickness commands) (number? list?)
+  #:category graphic
+  #:properties ((line-cap-style 'round)
+		(line-join-style 'round)
+		(filled #f))
+  "
+@cindex paths, drawing
+@cindex drawing paths
+Draws a path with line thickness @var{thickness} according to the
+directions given in @var{commands}.  @var{commands} is a list of
+lists where the @code{car} of each sublist is a drawing command and
+the @code{cdr} comprises the associated arguments for each command.
+
+Line-cap styles and line-join styles may be customized by
+overriding the @code{line-cap-style} and @code{line-join-style}
+properties, respectively.  Available line-cap styles are
+@code{'butt}, @code{'round}, and @code{'square}.  Available
+line-join styles are @code{'miter}, @code{'round}, and
+@code{'bevel}.
+
+The property @code{filled} specifies whether or not the path is
+filled with color.
+
+There are seven commands available to use in the list
+@code{commands}: @code{moveto}, @code{rmoveto}, @code{lineto},
+@code{rlineto}, @code{curveto}, @code{rcurveto}, and
+@code{closepath}.  Note that the commands that begin with @emph{r}
+are the relative variants of the other three commands.
+
+The commands @code{moveto}, @code{rmoveto}, @code{lineto}, and
+@code{rlineto} take 2 arguments; they are the X and Y coordinates
+for the destination point.
+
+The commands @code{curveto} and @code{rcurveto} create cubic
+Bézier curves, and take 6 arguments; the first two are the X and Y
+coordinates for the first control point, the second two are the X
+and Y coordinates for the second control point, and the last two
+are the X and Y coordinates for the destination point.
+
+The @code{closepath} command takes zero arguments and closes the
+current subpath in the active path.
+
+Note that a sequence of commands @emph{must} begin with a
+@code{moveto} or @code{rmoveto} to work with the SVG output.
+
+@lilypond[verbatim,quote]
+samplePath =
+  #'((moveto 0 0)
+     (lineto -1 1)
+     (lineto 1 1)
+     (lineto 1 -1)
+     (curveto -5 -5 -5 5 -1 0)
+     (closepath))
+
+\\markup {
+  \\path #0.25 #samplePath
+}
+@end lilypond"
+  (let* ((half-thickness (/ thickness 2))
+	 (current-point '(0 . 0))
+	 (set-point (lambda (lst) (set! current-point lst)))
+	 (relative? (lambda (x)
+		      (string-prefix? "r" (symbol->string (car x)))))
+	 ;; For calculating extents, we want to modify the command
+	 ;; list so that all coordinates are absolute.
+	 (new-commands (map (lambda (x)
+			      (cond
+				;; for rmoveto, rlineto
+				((and (relative? x) (eq? 3 (length x)))
+				 (let ((cp (cons
+					     (+ (car current-point)
+						(second x))
+					     (+ (cdr current-point)
+						(third x)))))
+				   (set-point cp)
+				   (list (car cp)
+					 (cdr cp))))
+				;; for rcurveto
+				((and (relative? x) (eq? 7 (length x)))
+				 (let* ((old-cp current-point)
+					(cp (cons
+					      (+ (car old-cp)
+						 (sixth x))
+					      (+ (cdr old-cp)
+						 (seventh x)))))
+				   (set-point cp)
+				   (list (+ (car old-cp) (second x))
+					 (+ (cdr old-cp) (third x))
+					 (+ (car old-cp) (fourth x))
+					 (+ (cdr old-cp) (fifth x))
+					 (car cp)
+					 (cdr cp))))
+				;; for moveto, lineto
+				((eq? 3 (length x))
+				 (set-point (cons (second x)
+						  (third x)))
+				 (drop x 1))
+				;; for curveto
+				((eq? 7 (length x))
+				 (set-point (cons (sixth x)
+						  (seventh x)))
+				 (drop x 1))
+				;; keep closepath for filtering;
+				;; see `without-closepath'.
+				(else x)))
+			    commands))
+	 ;; connected-shape-min-max does not accept 0-arg lists,
+	 ;; and since closepath does not affect extents, filter
+	 ;; out those commands here.
+	 (without-closepath (filter (lambda (x)
+				      (not (equal? 'closepath (car x))))
+				    new-commands))
+	 (extents (connected-shape-min-max
+		    ;; set the origin to the first moveto
+		    (list (list-ref (car without-closepath) 0)
+			  (list-ref (car without-closepath) 1))
+		    without-closepath))
+	 (X-extent (cons (list-ref extents 0) (list-ref extents 1)))
+	 (Y-extent (cons (list-ref extents 2) (list-ref extents 3)))
+	 (command-list (fold-right append '() commands)))
+
+    ;; account for line thickness
+    (set! X-extent (interval-widen X-extent half-thickness))
+    (set! Y-extent (interval-widen Y-extent half-thickness))
+
+    (ly:make-stencil
+      `(path ,thickness `(,@',command-list)
+	     ',line-cap-style ',line-join-style ,filled)
+      X-extent
+      Y-extent)))
+
 (define-markup-command (score layout props score)
   (ly:score?)
   #:category music