fix problems with `record-dc%' and composition

Recorded clipping, transformations, and alpha didn't compose with
the target DC's existing clipping, transformations, and alpha.

original commit: f79e2b4ee0bbe6a7302f658e78155b11d9dd7db8
This commit is contained in:
Matthew Flatt 2012-02-26 12:17:44 +00:00
parent 9f45143c24
commit 286e0527e7

View File

@ -232,6 +232,7 @@
[save-file-format #f]
[clip 'none]
[current-alpha 1.0]
[current-c-alpha 1.0]
[current-rotation 0.0]
[current-skew? #f])
(send hp0 stretchable-height #f)
@ -251,19 +252,26 @@
(define pixel-copy? #f)
(define kern? #f)
(define clip-pre-scale? #f)
(define c-clip? #f)
(define mask-ex-mode 'mred)
(define xscale 1)
(define yscale 1)
(define offset 0)
(define c-xscale 1)
(define c-yscale 1)
(define c-offset 0)
(public*
[set-bitmaps (lambda (on?) (set! no-bitmaps? (not on?)) (refresh))]
[set-stipples (lambda (on?) (set! no-stipples? (not on?)) (refresh))]
[set-pixel-copy (lambda (on?) (set! pixel-copy? on?) (refresh))]
[set-kern (lambda (on?) (set! kern? on?) (refresh))]
[set-clip-pre-scale (lambda (on?) (set! clip-pre-scale? on?) (refresh))]
[set-canvas-clip (lambda (on?) (set! c-clip? on?) (refresh))]
[set-mask-ex-mode (lambda (mode) (set! mask-ex-mode mode) (refresh))]
[set-canvas-scale (lambda (xs ys) (set! c-xscale xs) (set! c-yscale ys) (refresh))]
[set-scale (lambda (xs ys) (set! xscale xs) (set! yscale ys) (refresh))]
[set-offset (lambda (o) (set! offset o) (refresh))])
[set-offset (lambda (o) (set! offset o) (refresh))]
[set-canvas-offset (lambda (o) (set! c-offset o) (refresh))])
(override*
[on-paint
(case-lambda
@ -1003,20 +1011,30 @@
(send dc draw-rectangle 187 310 20 20)
(send dc set-pen p)))
(when (and last? use-record?)
(if serialize-record?
(let ()
(define-values (i o) (make-pipe))
(pretty-print (send dc get-recorded-datum))
(write (send dc get-recorded-datum) o)
((recorded-datum->procedure (read i)) can-dc))
((send dc get-recorded-procedure) can-dc)))
(when (and last?
(or (and (not (or kind (eq? dc can-dc)))
(send mem-dc get-bitmap))
use-record?))
(send can-dc set-origin c-offset c-offset)
(send can-dc set-scale c-xscale c-yscale)
(send can-dc set-alpha current-c-alpha)
(when c-clip?
(define r (new region%))
(send r set-rectangle 0 0 200 200)
(send can-dc set-clipping-region r))
(if use-record?
(if serialize-record?
(let ()
(define-values (i o) (make-pipe))
(write (send dc get-recorded-datum) o)
((recorded-datum->procedure (read i)) can-dc))
((send dc get-recorded-procedure) can-dc))
(send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque))
(send can-dc set-origin 0 0)
(send can-dc set-scale 1 1)
(send can-dc set-alpha 1.0)
(send can-dc set-clipping-region #f)))
(when (and last?
(not (or kind (eq? dc can-dc)))
(send mem-dc get-bitmap))
(send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)))
'done)])
(send (get-dc) set-scale 1 1)
@ -1286,14 +1304,6 @@
(set! save-filename f)
(set! save-file-format format)
(send canvas refresh))))))
(make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp
(lambda (self event)
(send canvas set-scale
(list-ref '(1 2 1/2 1 2) (send self get-selection))
(list-ref '(1 2 1/2 2 1) (send self get-selection)))))
(make-object check-box% "+10" hp
(lambda (self event)
(send canvas set-offset (if (send self get-value) 10 0))))
(make-object check-box% "Cyan" hp
(lambda (self event)
(set! cyan? (send self get-value))
@ -1330,6 +1340,22 @@
(make-object check-box% "Kern" hp2.5
(lambda (self event)
(send canvas set-kern (send self get-value))))
(make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp3
(lambda (self event)
(send canvas set-scale
(list-ref '(1 2 1/2 1 2) (send self get-selection))
(list-ref '(1 2 1/2 2 1) (send self get-selection)))))
(make-object check-box% "+10" hp3
(lambda (self event)
(send canvas set-offset (if (send self get-value) 10 0))))
(make-object choice% #f '("Cvs 1" "Cvs *2" "Cvs /2" "Cvs 1,*2" "Cvs *2,1") hp3
(lambda (self event)
(send canvas set-canvas-scale
(list-ref '(1 2 1/2 1 2) (send self get-selection))
(list-ref '(1 2 1/2 2 1) (send self get-selection)))))
(make-object check-box% "Cvs +10" hp3
(lambda (self event)
(send canvas set-canvas-offset (if (send self get-value) 10 0))))
(make-object choice% "Clip"
'("None" "Rectangle" "Rectangle2" "Octagon"
"Circle" "Wedge" "Round Rectangle" "Lambda" "A"
@ -1347,6 +1373,9 @@
(make-object check-box% "Clip Pre-Scale" hp3
(lambda (self event)
(send canvas set-clip-pre-scale (send self get-value))))
(make-object check-box% "Cvs Clip" hp3
(lambda (self event)
(send canvas set-canvas-clip (send self get-value))))
(let ([clock (lambda (clip?)
(thread (lambda ()
(set! clock-clip? clip?)
@ -1378,6 +1407,10 @@
(set! current-alpha a)
(send canvas refresh))))
10 '(horizontal plain))
(make-object check-box% "Cvs Fade" hp4
(lambda (c e)
(set! current-c-alpha (if (send c get-value) 0.5 1.0))
(send canvas refresh)))
(make-object slider% "Rotation" 0 100 hp4
(lambda (s e)
(let ([a (* pi 1/4 (/ (send s get-value) 100.0))])
@ -1391,9 +1424,3 @@
(send canvas refresh)))))
(send f show #t))
; Canvas, Pixmaps, and Bitmaps:
; get-pixel
; begin-set-pixel
; end-set-pixel
; set-pixel