X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=abd9795f7ebf6873fd211b29dd446888d6e78e69;hb=47db9a3883d726ca53e2133a3b2298f78dd6a32e;hp=0ce428a6e56568be4f7058037df8f9b900293d51;hpb=aa525a28382042e1a570bbc976e61e585e1fde3a;p=lilypond.git

diff --git a/scm/stencil.scm b/scm/stencil.scm
index 0ce428a6e5..abd9795f7e 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 <hanwen@xs4all.nl>
+;;;; Copyright (C) 2003--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -159,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)))))
 
@@ -434,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
@@ -739,7 +800,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))
@@ -748,21 +810,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