diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index ddc01161e6..ff50d1cd0c 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/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) - (cairo_clip cr)) + (reset-clip cr)) (define clip-width width) (define clip-height height) (define/override (reset-clip cr) (super reset-clip cr) - (cairo_rectangle cr 0 0 clip-width clip-height) - (cairo_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_set_matrix cr m))) (define cr #f) (set-bounds dx dy width height) diff --git a/collects/racket/draw/cairo.rkt b/collects/racket/draw/cairo.rkt index 9a847976b1..f0de760649 100644 --- a/collects/racket/draw/cairo.rkt +++ b/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)) diff --git a/collects/racket/draw/dc-path.rkt b/collects/racket/draw/dc-path.rkt index 0c8b926737..d480391f1d 100644 --- a/collects/racket/draw/dc-path.rkt +++ b/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: @@ -64,7 +71,7 @@ (align-x (vector-ref p 2)) (align-y (vector-ref p 3)) (align-x (car p2)) (align-y (cdr p2))) (loop (cddr l) #f))))]))) - + (define/public (do-path cr align-x align-y) (flatten-closed!) (flatten-open!) @@ -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) diff --git a/collects/racket/draw/dc.rkt b/collects/racket/draw/dc.rkt index 97da01b278..89a45b53d7 100644 --- a/collects/racket/draw/dc.rkt +++ b/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] diff --git a/collects/racket/draw/local.rkt b/collects/racket/draw/local.rkt index d8b7df9e3a..cc3b05868a 100644 --- a/collects/racket/draw/local.rkt +++ b/collects/racket/draw/local.rkt @@ -13,6 +13,7 @@ ;; dc% in-cairo-context + get-clipping-matrix ;; region% install-region diff --git a/collects/racket/draw/region.rkt b/collects/racket/draw/region.rkt index ecb2eae5c4..94bbf50e4f 100644 --- a/collects/racket/draw/region.rkt +++ b/collects/racket/draw/region.rkt @@ -21,10 +21,11 @@ (init [the-dc #f]) (define dc the-dc) - (unless (dc . is-a? . dc<%>) - (raise-type-error (init-name 'region%) - "dc<%> instance" - dc)) + (when dc + (unless (dc . is-a? . dc<%>) + (raise-type-error (init-name 'region%) + "dc<%> instance or #f" + dc))) ;; Intersected paths, each as (cons ), ;; where is 'odd-even, 'winding, or 'any. @@ -46,8 +47,7 @@ this)) (set! empty-known? #f)) - (define (ox oy) (send dc get-origin)) - (define (sx sy) (send dc get-scale)) + (define matrix (and dc (send dc get-clipping-matrix))) (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)