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.
This commit is contained in:
Matthew Flatt
parent
40fb54248d
commit
f79e2b4ee0
|
|
@ -31,6 +31,16 @@
|
|||
set-recording-limit
|
||||
record-unconvert)
|
||||
|
||||
(struct dc-state (;; values from the target dc:
|
||||
region
|
||||
alpha
|
||||
transformation
|
||||
;; virtual vaules for the target dc:
|
||||
scale-x scale-y
|
||||
origin-x origin-y
|
||||
rotation
|
||||
initial-matrix))
|
||||
|
||||
(define black (send the-color-database find-color "black"))
|
||||
|
||||
(define (clone-point p)
|
||||
|
|
@ -164,34 +174,75 @@
|
|||
(for/list ([i (in-list s)]) (list (car i) (unconvert-color (cdr i)))))
|
||||
|
||||
(define (region-maker r)
|
||||
(if r
|
||||
(if (send r internal-get-dc)
|
||||
(let ([paths (send r get-paths)])
|
||||
(lambda (dc)
|
||||
(lambda (dc state)
|
||||
(let ([new-r (make-object region% dc)])
|
||||
(send new-r set-paths! paths)
|
||||
(send new-r set-paths! (transform-region-paths paths (dc-state-transformation state)))
|
||||
new-r)))
|
||||
(let ([new-r (make-object region%)])
|
||||
(send new-r union r)
|
||||
(lambda (dc) new-r))))
|
||||
(lambda (dc state) new-r)))
|
||||
(lambda (dc state) #f)))
|
||||
|
||||
(define (transform-region-paths paths t)
|
||||
(if (equal? t '#(1.0 0.0 0.0 1.0 0.0 0.0))
|
||||
paths
|
||||
;; the paths in `path's have points that were transformed
|
||||
;; by the recording dc's transformation, but we need to prefix
|
||||
;; that with the transformation of the record action's target dc
|
||||
(map (lambda (p)
|
||||
(define old-p (car p))
|
||||
(define new-p (new dc-path%))
|
||||
(send new-p append old-p)
|
||||
(send new-p transform t)
|
||||
(cons new-p (cdr p)))
|
||||
paths)))
|
||||
|
||||
(define (convert-region r)
|
||||
(and r
|
||||
(cons (and (send r internal-get-dc) #t)
|
||||
(map convert-path (send r get-paths)))))
|
||||
(map (lambda (s) (cons (convert-path (car s)) (cdr s)))
|
||||
(send r get-paths)))))
|
||||
|
||||
(define (unconvert-region l)
|
||||
(if l
|
||||
(let ()
|
||||
(define paths (map unconvert-path (cdr l)))
|
||||
(define paths (map (lambda (p) (cons (unconvert-path (car p)) (cdr p)))
|
||||
(cdr l)))
|
||||
(if (car l)
|
||||
(lambda (dc)
|
||||
(lambda (dc state)
|
||||
(let ([new-r (make-object region% (and (car l) dc))])
|
||||
(send new-r set-paths! paths)
|
||||
(send new-r set-paths! (transform-region-paths paths (dc-state-transformation state)))
|
||||
new-r))
|
||||
(let ([new-r (make-object region%)])
|
||||
(send new-r set-paths! paths)
|
||||
(lambda (dc) new-r))))
|
||||
(lambda (dc) #f)))
|
||||
(lambda (dc state) new-r))))
|
||||
(lambda (dc state) #f)))
|
||||
|
||||
(define (combine-regions dc r1 r2)
|
||||
(cond
|
||||
[(not r1) r2]
|
||||
[(not r2) r1]
|
||||
[else
|
||||
(define dc1 (send r1 internal-get-dc))
|
||||
(cond
|
||||
[(eq? (not dc1)
|
||||
(not (send r2 internal-get-dc)))
|
||||
;; regions have same dc-ness:
|
||||
(define r (make-object region% dc1))
|
||||
(send r union r1)
|
||||
(send r intersect r2)
|
||||
r]
|
||||
[(not dc1)
|
||||
(combine-regions dc r2 r1)]
|
||||
[else
|
||||
;; r1 has dc, r2 doesn't; convert r2 to dc-attached region:
|
||||
(define r (make-object region% dc))
|
||||
(define paths (send r2 get-paths))
|
||||
(send r set-paths! (transform-region-paths paths (send dc get-initial-matrix)))
|
||||
(combine-regions dc r1 r)])]))
|
||||
|
||||
(define (clone-path p)
|
||||
(let ([new-p (make-object dc-path%)])
|
||||
|
|
@ -253,6 +304,14 @@
|
|||
(define (unconvert-font l)
|
||||
(apply make-object font% l))
|
||||
|
||||
(define (install-transform dc state)
|
||||
(send dc set-transformation (vector (dc-state-transformation state) 0 0 1 1 0))
|
||||
(send dc transform (dc-state-initial-matrix state))
|
||||
(send dc translate (dc-state-origin-x state) (dc-state-origin-y state))
|
||||
(send dc scale (dc-state-scale-x state) (dc-state-scale-y state))
|
||||
(send dc rotate (dc-state-rotation state))
|
||||
state)
|
||||
|
||||
(define (record-dc-mixin %)
|
||||
(class %
|
||||
(super-new)
|
||||
|
|
@ -380,10 +439,8 @@
|
|||
(if serialize?
|
||||
(for/list ([convert (in-list (reverse converts))])
|
||||
(convert))
|
||||
(let ([procs (reverse procs)])
|
||||
(lambda (dc)
|
||||
(for ([proc (in-list procs)])
|
||||
(proc dc)))))))
|
||||
((if (applies-to-default?) generate-drawer generate-drawer/restore)
|
||||
(reverse procs)))))
|
||||
|
||||
(define/public (reset-recording)
|
||||
(start-atomic)
|
||||
|
|
@ -406,16 +463,10 @@
|
|||
[(a) (get-alpha)]
|
||||
[(cr) (get-clipping-region)]
|
||||
[(to-default?) (applies-to-default?)])
|
||||
(when to-default?
|
||||
(unless (and (zero? ox) (zero? oy)) (set-origin ox oy))
|
||||
(unless (and (= 1 sx) (= 1 sy)) (set-scale sx sy))
|
||||
(unless (zero? r) (set-rotation r))
|
||||
(unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (set-initial-matrix m)))
|
||||
(unless to-default?
|
||||
(unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (transform m))
|
||||
(unless (zero? r) (rotate r))
|
||||
(unless (and (= 1 sx) (= 1 sy)) (scale sx sy))
|
||||
(unless (and (zero? ox) (zero? oy)) (translate (- sx) (- sy))))
|
||||
(unless (equal? m '#(1.0 0.0 0.0 1.0 0.0 0.0)) (set-initial-matrix m))
|
||||
(do-set-pen! p)
|
||||
(do-set-brush! b)
|
||||
(set-font f)
|
||||
|
|
@ -448,38 +499,79 @@
|
|||
(super erase)
|
||||
(reset-recording))
|
||||
|
||||
;; For the compsable part of the DC, we writ things out the long way.
|
||||
;; For everythign else, we use `define/record'.
|
||||
|
||||
(define/override (set-clipping-region r)
|
||||
(super set-clipping-region r)
|
||||
(when (continue-recording?)
|
||||
(let ([make-r (if r
|
||||
(region-maker r)
|
||||
(lambda (dc) #f))])
|
||||
(record (lambda (dc) (send dc set-clipping-region (make-r dc)))
|
||||
(let ([make-r (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)))))))
|
||||
|
||||
(define/override (set-alpha a)
|
||||
(super set-alpha a)
|
||||
(record (lambda (dc state)
|
||||
(send dc set-alpha (* a (dc-state-alpha state)))
|
||||
state)
|
||||
(lambda () `(set-alpha ,a))))
|
||||
|
||||
(define/override (set-scale sx sy)
|
||||
(super set-scale sx sy)
|
||||
(record (lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [scale-x sx] [scale-y sy])))
|
||||
(lambda () `(set-scale ,sx ,sy))))
|
||||
(define/override (set-origin ox oy)
|
||||
(super set-origin ox oy)
|
||||
(record (lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [origin-x ox] [origin-y oy])))
|
||||
(lambda () `(set-origin ,ox ,oy))))
|
||||
(define/override (set-rotation r)
|
||||
(super set-rotation r)
|
||||
(record (lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [rotation r])))
|
||||
(lambda () `(set-rotation ,r))))
|
||||
(define/override (set-initial-matrix mi)
|
||||
(super set-initial-matrix mi)
|
||||
(let ([mi (vector->immutable-vector mi)])
|
||||
(record (lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [initial-matrix mi])))
|
||||
(lambda () `(set-initial-matrix ,mi)))))
|
||||
|
||||
(generate-record-unconvert
|
||||
([(set-clipping-region) (lambda (r)
|
||||
(define make-r (unconvert-region r))
|
||||
(lambda (dc)
|
||||
(send dc set-clipping-region (make-r dc))))])
|
||||
(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)))
|
||||
state))]
|
||||
[(set-scale) (lambda (sx sy)
|
||||
(lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [scale-x sx] [scale-y sy]))))]
|
||||
[(set-origin) (lambda (ox oy)
|
||||
(lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [origin-x ox] [origin-y oy]))))]
|
||||
[(set-rotation) (lambda (r)
|
||||
(lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [rotation r]))))]
|
||||
[(set-initial-matrix) (lambda (mi)
|
||||
(lambda (dc state)
|
||||
(install-transform dc (struct-copy dc-state state [initial-matrix mi]))))])
|
||||
;; remaining clauses are generated:
|
||||
|
||||
(define/record (set-scale sx sy))
|
||||
|
||||
(define/record (set-origin sx sy))
|
||||
|
||||
(define/record (set-rotation r))
|
||||
|
||||
(define/record (transform [mi vector->immutable-vector]))
|
||||
|
||||
(define/record (set-initial-matrix [mi vector->immutable-vector]))
|
||||
|
||||
(define/record (set-transformation [mi vector->immutable-vector]))
|
||||
|
||||
(define/record (set-smoothing s))
|
||||
|
||||
(define/record (set-alpha n))
|
||||
|
||||
(define/record (set-font [f values convert-font unconvert-font]))
|
||||
|
||||
(define/record (do-set-pen! [p clone-pen convert-pen unconvert-pen]))
|
||||
|
|
@ -576,7 +668,21 @@
|
|||
(reset-recording)))
|
||||
|
||||
(define (recorded-datum->procedure d)
|
||||
(define procs (send (new record-dc%) record-unconvert d))
|
||||
(generate-drawer/restore (send (new record-dc%) record-unconvert d)))
|
||||
|
||||
(define (generate-drawer procs)
|
||||
(lambda (dc)
|
||||
(define cr (send dc get-clipping-region))
|
||||
(define a (send dc get-alpha))
|
||||
(define t (send dc get-initial-matrix))
|
||||
(for/fold ([state (dc-state cr a t 1.0 1.0 0.0 0.0 0.0 '#(1.0 0.0 0.0 1.0 0.0 0.0))]) ([proc (in-list procs)])
|
||||
(if (procedure-arity-includes? proc 2)
|
||||
(proc dc state)
|
||||
(begin
|
||||
(proc dc)
|
||||
state)))))
|
||||
|
||||
(define (generate-drawer/restore procs)
|
||||
(lambda (dc)
|
||||
(unless (dc . is-a? . dc<%>)
|
||||
(raise-type-error 'recorded-datum->procedure "dc<%> object" dc))
|
||||
|
|
@ -593,8 +699,9 @@
|
|||
(define a (send dc get-alpha))
|
||||
(define cr (send dc get-clipping-region))
|
||||
|
||||
(for ([proc (in-list procs)])
|
||||
(proc dc))
|
||||
(send dc translate 0 0) ; forces all transformation into the initial matrix
|
||||
|
||||
((generate-drawer procs) dc)
|
||||
|
||||
;; Restore the state:
|
||||
(send dc set-origin ox oy)
|
||||
|
|
|
|||
|
|
@ -37,7 +37,9 @@
|
|||
;; A null path list corresponds to an empty region.
|
||||
(define paths null)
|
||||
(define/public (get-paths) paths)
|
||||
(define/public (set-paths! p) (set! paths p))
|
||||
(define/public (set-paths! p)
|
||||
(set! paths p)
|
||||
(set! empty-known? #f))
|
||||
|
||||
(define locked 0)
|
||||
(define/public (lock-region delta) (set! locked (+ locked delta)))
|
||||
|
|
|
|||
|
|
@ -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,19 +1011,29 @@
|
|||
(send dc draw-rectangle 187 310 20 20)
|
||||
(send dc set-pen p)))
|
||||
|
||||
(when (and last? use-record?)
|
||||
(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))
|
||||
(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?
|
||||
(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)))
|
||||
((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)))
|
||||
|
||||
'done)])
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user