diff --git a/collects/racket/draw/private/record-dc.rkt b/collects/racket/draw/private/record-dc.rkt index 519067e16f..0737745343 100644 --- a/collects/racket/draw/private/record-dc.rkt +++ b/collects/racket/draw/private/record-dc.rkt @@ -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 (send r internal-get-dc) - (let ([paths (send r get-paths)]) - (lambda (dc) - (let ([new-r (make-object region% dc)]) - (send new-r set-paths! paths) - new-r))) - (let ([new-r (make-object region%)]) - (send new-r union r) - (lambda (dc) new-r)))) + (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))) + (let ([new-r (make-object region%)]) + (send new-r union 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 (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)) (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) diff --git a/collects/racket/draw/private/region.rkt b/collects/racket/draw/private/region.rkt index f4bc18c0f9..ced36f4cd9 100644 --- a/collects/racket/draw/private/region.rkt +++ b/collects/racket/draw/private/region.rkt @@ -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))) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index a2afb464ca..9a37bba56c 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -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