fix clipping-region issues

collects/mred/private/wx/cocoa/dc.rkt

@@ -47,16 +47,19 @@
         (cairo_surface_destroy surface))
       (set! clip-width width)
       (set! clip-height height)
-      (cairo_rectangle cr 0 0 width height)
+      (reset-clip cr))
-      (cairo_clip cr))
 
     (define clip-width width)
     (define clip-height height)
 
     (define/override (reset-clip cr)
       (super reset-clip cr)
+      (let ([m (make-cairo_matrix_t 0 0 0 0 0 0)])
+        (cairo_get_matrix cr m)
+        (cairo_set_matrix cr (make-cairo_matrix_t 1 0 0 1 0 0))
         (cairo_rectangle cr 0 0 clip-width clip-height)
-      (cairo_clip cr))
+        (cairo_clip cr)
+        (cairo_set_matrix cr m)))
 
     (define cr #f)
     (set-bounds dx dy width height)

collects/racket/draw/cairo.rkt

@@ -94,11 +94,14 @@
 (define-cairo cairo_scale (_fun _cairo_t _double* _double* -> _void))
 (define-cairo cairo_rotate (_fun _cairo_t _double* -> _void))
 (define-cairo cairo_identity_matrix (_fun _cairo_t -> _void))
+(define-cairo cairo_get_matrix (_fun _cairo_t _cairo_matrix_t-pointer -> _void))
 (define-cairo cairo_set_matrix (_fun _cairo_t _cairo_matrix_t-pointer -> _void))
 
 (define-cairo cairo_matrix_init_translate (_fun _cairo_matrix_t-pointer _double* _double* -> _void))
 (define-cairo cairo_matrix_init (_fun _cairo_matrix_t-pointer _double* _double* _double* _double* _double* _double* -> _void))
-
+(define-cairo cairo_matrix_translate (_fun _cairo_matrix_t-pointer _double* _double* -> _void))
+(define-cairo cairo_matrix_scale (_fun _cairo_matrix_t-pointer _double* _double* -> _void))
+(define-cairo cairo_matrix_rotate (_fun _cairo_matrix_t-pointer _double* -> _void))
 
 ;; Stroke & Fill
 (define-cairo cairo_set_source_rgb (_fun _cairo_t _double* _double* _double* -> _void))

collects/racket/draw/dc-path.rkt

@@ -11,7 +11,8 @@
                   [reverse s:reverse]))
 
 (provide dc-path%
-         do-path)
+         do-path
+         matrix-vector?)
 
 (define-local-member-name
   get-closed-points
@@ -21,6 +22,12 @@
 (define 2pi (* 2.0 pi))
 (define pi/2 (/ pi 2.0))
 
+(define (matrix-vector? m)
+  (and (vector? m)
+       (= 6 (vector-length m))
+       (for/and ([e (in-vector m)])
+         (real? e))))
+
 (define dc-path%
   (class object%
     ;; A path is a list of pairs and vectors:
@@ -330,6 +337,29 @@
              [cx (make-polar (magnitude cx) (+ (angle cx) (- th)))])
         (values (real-part cx) (imag-part cx))))
 
+    (def/public (transform [matrix-vector? m])
+      (flatten-open!)
+      (flatten-closed!)
+      (set! open-points (transform-points open-points m))
+      (set! closed-points
+            (for/list ([pts (in-list closed-points)])
+              (transform-points pts m))))
+    (define/private (transform-points pts m)
+      (for/list ([p (in-list pts)])
+        (if (pair? p)
+            (let-values ([(x y) (transform-point m (car p) (cdr p))])
+              (cons x y))
+            (let-values ([(x2 y2) (transform-point m (vector-ref p 0) (vector-ref p 1))]
+                         [(x3 y3) (transform-point m (vector-ref p 2) (vector-ref p 3))])
+              (vector x2 y2 x3 y3)))))
+    (define/private (transform-point m x y)
+      (values (+ (* x (vector-ref m 0))
+                 (* y (vector-ref m 2))
+                 (vector-ref m 4))
+              (+ (* x (vector-ref m 1))
+                 (* y (vector-ref m 3))
+                 (vector-ref m 5))))
+
     (def/public (rectangle [real? x] [real? y] [real? w] [real? h])
       (when (open?) (close))
       (move-to x y)

collects/racket/draw/dc.rkt

@@ -38,12 +38,6 @@
 (define -bitmap-dc% #f)
 (define (install-bitmap-dc-class! v) (set! -bitmap-dc% v))
 
-(define (matrix-vector? m)
-  (and (vector? m)
-       (= 6 (vector-length m))
-       (for/and ([e (in-vector m)])
-         (real? e))))
-
 ;; dc-backend : interface
 ;;
 ;; This is the interface that the backend specific code must implement
@@ -266,7 +260,7 @@
       (cairo_set_matrix cr matrix)
       (cairo_translate cr origin-x origin-y)
       (cairo_scale cr scale-x scale-y)
-      (cairo_rotate cr rotation))
+      (cairo_rotate cr (- rotation)))
     
     (define/private (reset-matrix)
       (with-cr
@@ -409,6 +403,23 @@
          (send clipping-region lock-region 1)
          (send clipping-region install-region cr))))
 
+    (define/public (get-clipping-matrix)
+      (let* ([cm (make-cairo_matrix_t (cairo_matrix_t-xx matrix)
+                                      (cairo_matrix_t-yx matrix)
+                                      (cairo_matrix_t-xy matrix)
+                                      (cairo_matrix_t-yy matrix)
+                                      (cairo_matrix_t-x0 matrix)
+                                      (cairo_matrix_t-y0 matrix))])
+        (cairo_matrix_translate cm origin-x origin-y)
+        (cairo_matrix_scale cm scale-x scale-y)
+        (cairo_matrix_rotate cm (- rotation))
+        (vector (cairo_matrix_t-xx cm)
+                (cairo_matrix_t-yx cm)
+                (cairo_matrix_t-xy cm)
+                (cairo_matrix_t-yy cm)
+                (cairo_matrix_t-x0 cm)
+                (cairo_matrix_t-y0 cm))))
+
     (def/public (set-clipping-rect [real? x] 
                                    [real? y] 
                                    [nonnegative-real? w]

collects/racket/draw/local.rkt

@@ -13,6 +13,7 @@
 
   ;; dc%
   in-cairo-context
+  get-clipping-matrix
 
   ;; region%
   install-region

collects/racket/draw/region.rkt

@@ -21,10 +21,11 @@
 
     (init [the-dc #f])
     (define dc the-dc)
+    (when dc
       (unless (dc . is-a? . dc<%>)
         (raise-type-error (init-name 'region%)
-                        "dc<%> instance"
+                          "dc<%> instance or #f"
-                        dc))
+                          dc)))
 
     ;; Intersected paths, each as (cons <path> <fill-style>),
     ;;  where <fill-style> is 'odd-even, 'winding, or 'any.
@@ -46,8 +47,7 @@
                this))
       (set! empty-known? #f))
 
-    (define (ox oy) (send dc get-origin))
+    (define matrix (and dc (send dc get-clipping-matrix)))
-    (define (sx sy) (send dc get-scale))
     
     (def/public (get-dc) dc)
     (define/public (internal-get-dc) dc)
@@ -73,7 +73,14 @@
     (define/public (install-region cr [init (void)] [install (lambda (cr v) (cairo_clip cr))])
       (let ([default-fill-rule (if (ormap (lambda (pr) (eq? (cdr pr) 'odd-even)) paths)
                                    CAIRO_FILL_RULE_EVEN_ODD
-                                   CAIRO_FILL_RULE_WINDING)])
+                                   CAIRO_FILL_RULE_WINDING)]
+            [old-matrix (and matrix
+                             (let ([m (make-cairo_matrix_t 0 0 0 0 0 0)])
+                               (cairo_get_matrix cr m)
+                               m))])
+        (when old-matrix 
+          ;; each path is already transformed
+          (cairo_set_matrix cr (make-cairo_matrix_t 1 0 0 1 0 0)))
         (for/fold ([v init]) ([pr (in-list paths)])
           (cairo_new_path cr)
           (send (car pr) do-path cr values values)
@@ -82,7 +89,8 @@
                                  [(odd-even) CAIRO_FILL_RULE_EVEN_ODD]
                                  [(winding) CAIRO_FILL_RULE_WINDING]
                                  [else default-fill-rule]))
-          (install cr v))))
+          (install cr v))
+        (when old-matrix (cairo_set_matrix cr old-matrix))))
 
     (def/public (is-empty?)
       (really-is-empty?))
@@ -131,6 +139,7 @@
         (send p move-to (+ x (/ width 2)) (+ y (/ height 2)))
         (send p arc x y width height start-radians end-radians)
         (send p close)
+        (when matrix (send p transform matrix))
         (set! paths (list (cons p 'any)))))
 
     (def/public (set-ellipse [real? x]
@@ -140,6 +149,7 @@
       (modifying 'set-ellipse)
       (let ([p (new dc-path%)])
         (send p ellipse x y width height)
+        (when matrix (send p transform matrix))
         (set! paths (list (cons p 'any)))))
 
     (def/public (set-path [dc-path% path]
@@ -149,6 +159,7 @@
       (modifying 'set-path)
       (let ([p (new dc-path%)])
         (send p append path)
+        (when matrix (send p transform matrix))
         (set! paths (list (cons p fill-style)))))
 
     (def/public (set-polygon [(make-alts (make-list point%) list-of-pair-of-real?) pts]
@@ -168,6 +179,7 @@
                   (send p line-to (car i) (cdr i))
                   (send p line-to (point-x i) (point-y i))))
             (send p close)
+            (when matrix (send p transform matrix))
             (set! paths (list (cons p fill-style))))))
 
     (def/public (set-rectangle [real? x]
@@ -177,6 +189,7 @@
       (modifying 'set-rectangle)
       (let ([p (new dc-path%)])
         (send p rectangle x y width height)
+        (when matrix (send p transform matrix))
         (set! paths (list (cons p 'any)))))
 
     (def/public (set-rounded-rectangle [real? x]
@@ -187,6 +200,7 @@
       (modifying 'set-rounded-rectangle)
       (let ([p (new dc-path%)])
         (send p rounded-rectangle x y width height radius)
+        (when matrix (send p transform matrix))
         (set! paths (list (cons p 'any)))))
 
     (define/private (check-compatible r who)