diff --git a/collects/racket/draw/private/record-dc.rkt b/collects/racket/draw/private/record-dc.rkt index 3acaee6ee7..7074fcd77e 100644 --- a/collects/racket/draw/private/record-dc.rkt +++ b/collects/racket/draw/private/record-dc.rkt @@ -103,6 +103,11 @@ (class % (super-new) + (inherit get-origin get-scale get-rotation get-initial-matrix + get-pen get-brush get-font + get-smoothing get-text-mode + get-alpha get-clipping-region) + (define record-limit +inf.0) (define current-size 0) @@ -135,7 +140,30 @@ (start-atomic) (set! procs null) (set! current-size 0) - (end-atomic)) + (end-atomic) + ;; install current configuration explicitly (so it gets recorded): + (let-values ([(ox oy) (get-origin)] + [(sx sy) (get-scale)] + [(r) (get-rotation)] + [(m) (get-initial-matrix)] + [(p) (get-pen)] + [(b) (get-brush)] + [(s) (get-smoothing)] + [(f) (get-font)] + [(tm) (get-text-mode)] + [(a) (get-alpha)] + [(cr) (get-clipping-region)]) + (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) + (unless (eq? s 'unsmoothed) (set-smoothing s)) + (unless (eq? tm 'transparent) (set-text-mode tm)) + (unless (= a 1.0) (set-alpha a)) + (when cr (set-clipping-region cr)))) (define clones (make-hasheq)) (define/private (clone clone-x x) diff --git a/collects/tests/gracket/record-dc.rkt b/collects/tests/gracket/record-dc.rkt new file mode 100644 index 0000000000..14346568c5 --- /dev/null +++ b/collects/tests/gracket/record-dc.rkt @@ -0,0 +1,59 @@ +#lang racket/base +(require racket/class + racket/draw + racket/draw/private/record-dc) + +(define bm1 (make-bitmap 100 100)) +(define bm2 (make-bitmap 100 100)) +(define bm3 (make-bitmap 100 100)) + +(define dc1 (make-object bitmap-dc% bm1)) +(define dc2 (make-object (record-dc-mixin bitmap-dc%) bm2)) +(define dc3 (make-object bitmap-dc% bm3)) + +(define (config dc) + (send dc set-origin 2 3) + (send dc set-scale 1.1 0.9) + (send dc set-rotation 0.1) + (send dc set-initial-matrix '#(1.0 -0.1 0.1 1.0 1.0 2.0)) + (send dc set-pen "red" 2 'solid) + (send dc set-brush "blue" 'solid) + (send dc set-font (make-font #:size 32)) + (send dc set-smoothing 'smoothed) + (send dc set-text-mode 'solid) + (send dc set-alpha 0.8) + (send dc set-clipping-rect 5 5 95 95)) + +(define (draw dc) + (send dc draw-ellipse 2 2 100 100) + (send dc draw-text "Hello" 10 10)) + +(define (get-bytes bm) + (define w (send bm get-width)) + (define h (send bm get-height)) + (define bstr (make-bytes (* 4 w h))) + (send bm get-argb-pixels 0 0 w h bstr) + bstr) + +(config dc1) +(draw dc1) + +(define pre-bytes (get-bytes bm1)) + +(config dc2) +(send dc2 erase) +(draw dc2) + +(define middle-bytes (get-bytes bm2)) + +(define cms (send dc2 get-recorded-command)) + +(cms dc3) + +(define post-bytes (get-bytes bm3)) + +(unless (equal? pre-bytes middle-bytes) + (error "middle != pre")) + +(unless (equal? pre-bytes post-bytes) + (error "post != pre"))