Update rotation wrapper if it exists.

1 files changed, 56 insertions, 32 deletions

diff --git a/pict.scm b/pict.scm
index 98e0237..5279fed 100644
--- a/pict.scm
+++ b/pict.scm
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (pict?
@@ -276,40 +277,63 @@ strings that are built from the list of attributes LST."
 ;; for wrapping.  "g" for the transform and SVG for x, y, width, and
 ;; height (because "g" doesn't have those).
 
-;; XXX: repeated rotations result in an increase of the size of the
-;; pict, as they are not applied to the inner shape but wrapped around
-;; the pict.  It may be better to get at the inner shape first by
-;; finding the child of the first (g (@ (class "transform")) ...)
-;; expression.
 (define (rotate pict deg)
   "Rotate the PICT by DEG degrees."
-  (let* ((width  (pict-width pict))
-         (height (pict-height pict))
-         (cx     (/ width 2))
-         (cy     (/ height 2))
-         (vecx   (make-rectangular width 0))
-         (vecy   (make-rectangular 0 height))
-         (rot    (make-polar 1 (deg->rad deg)))
-         (rotx   (* vecx rot))
-         (roty   (* vecy rot))
-         (new-height (+ (abs (imag-part rotx))
-                        (abs (imag-part roty))))
-         (new-width  (+ (abs (real-part rotx))
-                        (abs (real-part roty)))))
-    (make-pict
-     `(svg (@ (height ,new-height)
-              (width ,new-width)
-              (class "rotate")
-              (x 0)
-              (y 0))
-           ,((compose (transform-modifier "translate"
-                                          (format #f "~a ~a"
-                                                  (/ (- new-width width) 2)
-                                                  (/ (- new-height height) 2)))
-                      (transform-modifier "rotate"
-                                          (format #f "~a ~a ~a"
-                                                  deg cx cy)))
-             `(g (@ (class "transform")) ,(pict-sxml pict)))))))
+  (define (compute-modifiers inner)
+    (let* ((width  (pict-width inner))
+           (height (pict-height inner))
+           (cx     (/ width 2))
+           (cy     (/ height 2))
+           (vecx   (make-rectangular width 0))
+           (vecy   (make-rectangular 0 height))
+           (degs   (+ deg
+                      ;; Current rotation
+                      (pict-rotation pict)))
+           (rot    (make-polar 1 (deg->rad degs)))
+           (rotx   (* vecx rot))
+           (roty   (* vecy rot))
+           (new-height (+ (abs (imag-part rotx))
+                          (abs (imag-part roty))))
+           (new-width  (+ (abs (real-part rotx))
+                          (abs (real-part roty)))))
+      (values
+       (compose (transform-modifier "translate"
+                                    (const
+                                     (format #f "~a ~a"
+                                             (/ (- new-width width) 2)
+                                             (/ (- new-height height) 2))))
+                (transform-modifier "rotate"
+                                    (const
+                                     (format #f "~a ~a ~a"
+                                             degs cx cy))))
+       new-height
+       new-width)))
+  ;; If pict has an svg.rotate + g.transform wrapper: modify that.
+  ;; Only wrap it if there is no such wrapper.  Limiting the number of
+  ;; wrappers to 1 ensures that the bounding box of the pict does not
+  ;; grow on successive rotations.
+  (make-pict
+   (match (pict-sxml pict)
+     (('svg attr ('g (and g-attrs
+                          ('@ ('class "transform") rest))
+                     ;; TODO: this should only be a single child
+                     children))
+      (let-values (((modifiers new-height new-width)
+                    (compute-modifiers (make-pict children))))
+        ((compose (attribute-modifier 'height (const new-height))
+                  (attribute-modifier 'width (const new-width)))
+         `(svg ,attr
+               ,(modifiers `(g ,g-attrs ,children))))))
+     (sxml
+      (let-values (((modifiers new-height new-width)
+                    (compute-modifiers pict)))
+        `(svg (@ (height ,new-height)
+                 (width ,new-width)
+                 (class "rotate")
+                 (x 0)
+                 (y 0))
+              ,(modifiers
+                `(g (@ (class "transform")) ,sxml))))))))
 
 (define (scale pict factor)
   "Scale the PICT by the given FACTOR."