suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix clipping-region issues

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-01 16:57:21 -06:00
parent 202e18ef85
commit d10669d34e
6 changed files with 84 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -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)

5
collects/racket/draw/cairo.rkt
View File

@ -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))

34
collects/racket/draw/dc-path.rkt
View File

@ -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)

25
collects/racket/draw/dc.rkt
View File

@ -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]

1
collects/racket/draw/local.rkt
View File

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

30
collects/racket/draw/region.rkt
View File

@ -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 <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 (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)