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

racket/draw: fix set-clipping-rect' in record-dc%'

Browse Source
This commit is contained in:
Matthew Flatt 2012-08-23 09:42:34 -06:00
parent d9784aa7eb
commit edd2035f88
2 changed files with 44 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/racket/draw/private/record-dc.rkt
View File

@ -544,10 +544,13 @@
(super erase)
(reset-recording))
;; For the compsable part of the DC, we writ things out the long way.
;; For the compsable part of the DC, we write things out the long way.
;; For everythign else, we use `define/record'.
(define/override (set-clipping-region r)
(do-set-clipping-region r))
(define/private (do-set-clipping-region r)
(super set-clipping-region r)
(when (continue-recording?)
(let-values ([(make-r paths has-dc?) (region-maker r)])
@ -558,6 +561,14 @@
state)
(lambda () (list 'set-clipping-region (convert-region paths has-dc?)))))))
(def/override (set-clipping-rect [real? x]
[real? y]
[nonnegative-real? w]
[nonnegative-real? h])
(let ([r (make-object region% this)])
(send r set-rectangle x y w h)
(do-set-clipping-region r)))
(define/override (set-alpha a)
(super set-alpha a)
(record (lambda (dc state)
@ -595,6 +606,16 @@
(dc-state-region state)
(make-r dc state)))
state))]
[(set-clipping-rect) ;; backward compatibility for old datums
(lambda (x y w h)
(define r (make-object region% #f))
(send r set-rectangle x y w h)
(define make-r (unconvert-region (convert-region r #f)))
(lambda (dc state)
(send dc set-clipping-region (combine-regions dc
(dc-state-region state)
(make-r dc state)))
state))]
[(set-alpha) (lambda (a)
(lambda (dc state)
(send dc set-alpha (* a (dc-state-alpha state)))
@ -631,8 +652,6 @@
(define/record (set-text-mode m))
(define/record (set-clipping-rect x y w h))
(define/record (clear))
(define/record (draw-arc x y width height start-radians end-radians))

22
collects/tests/gracket/dc.rktl
View File

@ -596,6 +596,28 @@
(send gl1 call-as-current (lambda () (error "fail"))))
(test 12 'post-exn (send gl1 call-as-current (lambda () 12)))))
;; ----------------------------------------
;; check clipping
(let ()
(define rdc (new record-dc%))
(send rdc set-brush "green" 'solid)
(send rdc set-clipping-rect 2 2 5 5)
(send rdc draw-rectangle 0 0 9 9)
(define bm (make-bitmap 25 25))
(define bm-dc (make-object bitmap-dc% bm))
(send bm-dc set-clipping-rect 10 10 5 5)
((send rdc get-recorded-procedure) bm-dc)
(define s (make-bytes (* 20 20 4)))
(send bm get-argb-pixels 0 0 20 20 s)
(for ([i (in-range 0 (* 20 20 4) 4)])
(test 0 'record-dc-clipping-byte (bytes-ref s i))))
;; ----------------------------------------
(report-errs)