fix `record-dc%' problem with regions
Closes PR 12655
This commit is contained in:
parent
a1446a037b
commit
4b36e708a3
|
@ -197,14 +197,20 @@
|
|||
(if r
|
||||
(if (send r internal-get-dc)
|
||||
(let ([paths (send r get-paths)])
|
||||
(lambda (dc state)
|
||||
(let ([new-r (make-object region% dc)])
|
||||
(send new-r set-paths! (transform-region-paths paths (dc-state-transformation state)))
|
||||
new-r)))
|
||||
(values (lambda (dc state)
|
||||
(let ([new-r (make-object region% dc)])
|
||||
(send new-r set-paths! (transform-region-paths paths (dc-state-transformation state)))
|
||||
new-r))
|
||||
paths
|
||||
#t))
|
||||
(let ([new-r (make-object region%)])
|
||||
(send new-r union r)
|
||||
(lambda (dc state) new-r)))
|
||||
(lambda (dc state) #f)))
|
||||
(values (lambda (dc state) new-r)
|
||||
new-r
|
||||
#f)))
|
||||
(values (lambda (dc state) #f)
|
||||
#f
|
||||
#f)))
|
||||
|
||||
(define (transform-region-paths paths t)
|
||||
(if (equal? t '#(1.0 0.0 0.0 1.0 0.0 0.0))
|
||||
|
@ -220,11 +226,13 @@
|
|||
(cons new-p (cdr p)))
|
||||
paths)))
|
||||
|
||||
(define (convert-region r)
|
||||
(and r
|
||||
(cons (and (send r internal-get-dc) #t)
|
||||
(define (convert-region paths/r has-dc?)
|
||||
(and paths/r
|
||||
(cons has-dc?
|
||||
(map (lambda (s) (cons (convert-path (car s)) (cdr s)))
|
||||
(send r get-paths)))))
|
||||
(if (paths/r . is-a? . region%)
|
||||
(send paths/r get-paths)
|
||||
paths/r)))))
|
||||
|
||||
(define (unconvert-region l)
|
||||
(if l
|
||||
|
@ -525,13 +533,13 @@
|
|||
(define/override (set-clipping-region r)
|
||||
(super set-clipping-region r)
|
||||
(when (continue-recording?)
|
||||
(let ([make-r (region-maker r)])
|
||||
(let-values ([(make-r paths has-dc?) (region-maker r)])
|
||||
(record (lambda (dc state)
|
||||
(send dc set-clipping-region (combine-regions dc
|
||||
(dc-state-region state)
|
||||
(make-r dc state)))
|
||||
state)
|
||||
(lambda () (list 'set-clipping-region (convert-region r)))))))
|
||||
(lambda () (list 'set-clipping-region (convert-region paths has-dc?)))))))
|
||||
|
||||
(define/override (set-alpha a)
|
||||
(super set-alpha a)
|
||||
|
|
|
@ -1200,7 +1200,18 @@
|
|||
(when (send r get-dc)
|
||||
(unless (eq? (send r is-empty?) (eq? clip 'empty))
|
||||
(show-error 'draw-text "region `is-empty?' mismatch"))))))
|
||||
|
||||
|
||||
(define (mutate-region)
|
||||
(when (and (not clock-clip?)
|
||||
(not (eq? clip 'none)))
|
||||
;; To be uncooperative, mutate the clipping region:
|
||||
(define r (send dc get-clipping-region))
|
||||
(define r2 (make-object region% (send r get-dc)))
|
||||
(send r2 union r)
|
||||
(send dc set-clipping-region #f)
|
||||
(send r set-rectangle 0 0 10 10)
|
||||
(send dc set-clipping-region r2)))
|
||||
|
||||
;; check default pen/brush:
|
||||
(send dc draw-rectangle 0 0 5 5)
|
||||
(send dc draw-line 0 0 20 6)
|
||||
|
@ -1208,6 +1219,8 @@
|
|||
(send dc set-font (make-object font% 10 'default))
|
||||
|
||||
(draw-series dc pen0s pen0t pen0x "0 x 0" 5 0 0 #f)
|
||||
|
||||
(mutate-region)
|
||||
|
||||
(draw-series dc pen1s pen1t pen1x "1 x 1" 70 0 1 #f)
|
||||
|
||||
|
@ -1256,8 +1269,7 @@
|
|||
(list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT))
|
||||
(list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT))))))
|
||||
|
||||
(send dc set-clipping-region #f)
|
||||
|
||||
(send dc set-clipping-region #f)
|
||||
|
||||
(send dc end-page)
|
||||
(when (and kind multi-page?)
|
||||
|
|
Loading…
Reference in New Issue
Block a user