suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/draw: add `record-dc%'

Browse Source 
original commit: 645ca02e927e2ef0bc9857bc3fa6cb3725bcdca8
This commit is contained in:
Matthew Flatt 2012-02-25 19:17:32 +00:00
parent 76320f0ea1
commit 9f45143c24
1 changed files with 33 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
collects/tests/gracket/draw.rkt
View File

@ -220,6 +220,9 @@
[clock-clip? #f] [clock-clip? #f]
[do-clock #f] [do-clock #f]
[use-bitmap? #f] [use-bitmap? #f]
[platform-bitmap? #f]
[use-record? #f]
[serialize-record? #f]
[use-bad? #f] [use-bad? #f]
[depth-one? #f] [depth-one? #f]
[cyan? #f] [cyan? #f]
@ -285,7 +288,11 @@
[bm (if use-bitmap? [bm (if use-bitmap?
(if use-bad? (if use-bad?
(make-object bitmap% "no such file") (make-object bitmap% "no such file")
(make-object bitmap% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT) depth-one?)) (let ([w (ceiling (* xscale DRAW-WIDTH))]
[h (ceiling (* yscale DRAW-HEIGHT))])
(if platform-bitmap?
(make-platform-bitmap w h)
(make-object bitmap% w h depth-one?))))
#f)] #f)]
[draw-series [draw-series
(lambda (dc pens pent penx size x y flevel last?) (lambda (dc pens pent penx size x y flevel last?)
@ -996,7 +1003,17 @@
(send dc draw-rectangle 187 310 20 20) (send dc draw-rectangle 187 310 20 20)
(send dc set-pen p))) (send dc set-pen p)))
(when (and last? (not (or kind (eq? dc can-dc))) (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?
(not (or kind (eq? dc can-dc)))
(send mem-dc get-bitmap)) (send mem-dc get-bitmap))
(send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque))) (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)))
@ -1031,11 +1048,13 @@
[as-eps (not page?)] [as-eps (not page?)]
[use-paper-bbox page?]))])]) [use-paper-bbox page?]))])])
(and (send dc ok?) dc)) (and (send dc ok?) dc))
(if (and use-bitmap?) (if use-record?
(begin (make-object record-dc% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT))
(send mem-dc set-bitmap bm) (if (and use-bitmap?)
mem-dc) (begin
(get-dc)))]) (send mem-dc set-bitmap bm)
mem-dc)
(get-dc))))])
(when dc (when dc
(send dc start-doc "Draw Test") (send dc start-doc "Draw Test")
(send dc start-page) (send dc start-page)
@ -1205,7 +1224,7 @@
(unless (cond (unless (cond
[kind #t] [kind #t]
[use-bad? #t] [use-bad? #t]
[use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [use-bitmap? (and (= w (ceiling (* xscale DRAW-WIDTH))) (= h (ceiling (* yscale DRAW-HEIGHT))))]
[else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))])
(show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h (show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h
(if use-bitmap? (if use-bitmap?
@ -1230,13 +1249,15 @@
(super-new [parent parent][style '(hscroll vscroll)]) (super-new [parent parent][style '(hscroll vscroll)])
(init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0)) (init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0))
vp)]) vp)])
(make-object radio-box% #f '("Canvas" "Pixmap" "Bitmap" "Bad") hp0 (make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Record" "Serialize" "Bad") hp0
(lambda (self event) (lambda (self event)
(set! use-bitmap? (< 0 (send self get-selection))) (set! use-bitmap? (< 0 (send self get-selection)))
(set! depth-one? (< 1 (send self get-selection))) (set! depth-one? (< 1 (send self get-selection)))
(set! use-bad? (< 2 (send self get-selection))) (set! platform-bitmap? (= 3 (send self get-selection)))
(send canvas refresh)) (set! use-record? (<= 4 (send self get-selection) 5))
'(horizontal)) (set! serialize-record? (= 5 (send self get-selection)))
(set! use-bad? (< 5 (send self get-selection)))
(send canvas refresh)))
(make-object button% "PS" hp (make-object button% "PS" hp
(lambda (self event) (lambda (self event)
(send canvas on-paint 'ps))) (send canvas on-paint 'ps)))