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

racket/gui cocoa: use CGLayer for canvas bitmaps

Browse Source 
The backing bitmap for a canvas is created as a CGLayer, which can
make screen refresh much faster. Also, calling the `make-bitmap` method
of `canvas%` produces a CGLayer-based bitmap, so drawing those bitmaps
to a fast context can be fast.

The improvement particularly helps with Retina displays, making
DrRacket more responsive and increasing the potential frame rate
of Slideshow.
This commit is contained in:
Matthew Flatt 2013-11-22 16:46:55 -07:00
parent c1f6050938
commit 9cb646bbd2
10 changed files with 314 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/draw-pkgs/draw-doc/scribblings/draw/guide.scrbl
View File

@ -766,6 +766,29 @@ Different kinds of bitmaps can produce different results:
when consistency with screen drawing is needed for some other
reason.}
@item{Drawing to a bitmap produced by @racket[make-screen-bitmap]
from @racketmodname[racket/gui/base]
uses the same platform-specific drawing operations
as drawing into a @racket[canvas%] instance. A bitmap produced
by @racket[make-screen-bitmap] is the same as one produced by
@racket[make-platform-bitmap] on Windows or Mac OS X, but it
may be sensitive to the X11 server on Unix. On Mac OS X, when
the main screen is in Retina mode (at the time that the bitmap
is created), the bitmap is also internally scaled so that one
drawing unit uses two pixels.
Use @racket[make-screen-bitmap] when drawing to a bitmap as an
offscreen buffer before transferring an image to the screen, or
when consistency with screen drawing is needed for some other
reason.}
@item{A bitmap produced by @xmethod[canvas% make-bitmap] from
@racketmodname[racket/gui/base] is like a bitmap from
@racket[make-screen-bitmap], but on Mac OS X, the bitmap is
optimized for drawing to the screen (by taking advantage of
system APIs that can, in turn, take advantage of graphics
hardware).}
]

2
pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap-dc.rkt
View File

@ -40,7 +40,7 @@
(set! c #f))
(set! bm v)
(when (and bm (send bm ok?))
(set! c (cairo_create (send bm get-cairo-surface)))
(set! c (cairo_create (send bm get-cairo-target-surface)))
(set! b&w? (not (send bm is-color?)))))
(define/public (internal-set-bitmap v [direct? #f])

28
pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap.rkt
View File

@ -283,6 +283,9 @@
(def/public (get-loaded-mask) loaded-mask)
(def/public (set-loaded-mask [(make-or-false bitmap%) m]) (set! loaded-mask m))
(define/public (draw-bitmap-to cr sx sy dx dy w h alpha clipping)
#f)
(define/public (release-bitmap-storage)
(drop-alpha-s)
(when s
@ -632,6 +635,7 @@
(def/public (ok?) (and s #t))
(define/public (get-cairo-surface) (or s (get-empty-surface)))
(define/public (get-cairo-target-surface) (get-cairo-surface))
(define/public (get-cairo-alpha-surface)
(or (if (or b&w? alpha-channel?)
s
@ -923,7 +927,7 @@
(define quartz-bitmap%
(class bitmap%
(init w h [with-alpha? #t] [resolution 1.0])
(init w h [with-alpha? #t] [resolution 1.0] [dest-cg #f])
(super-make-object (make-alternate-bitmap-kind w h))
(define cocoa-resolution resolution)
@ -932,15 +936,19 @@
cocoa-resolution)
(define s
(let ([s (cairo_quartz_surface_create (if with-alpha?
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24)
(inexact->exact
(ceiling
(* cocoa-resolution w)))
(inexact->exact
(ceiling
(* cocoa-resolution h))))])
(let* ([sw (inexact->exact
(ceiling
(* cocoa-resolution w)))]
[sh (inexact->exact
(ceiling
(* cocoa-resolution h)))]
[s (if dest-cg
(cairo_quartz_surface_create_for_cg_context dest-cg sw sh)
(cairo_quartz_surface_create (if with-alpha?
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24)
sw
sh))])
;; initialize bitmap to empty - needed?
(let ([cr (cairo_create s)])
(cairo_set_operator cr (if with-alpha?

7
pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt
View File

@ -1763,6 +1763,13 @@
(cairo_restore cr)
(cairo_pattern_destroy p)))])
(cond
[(send src draw-bitmap-to cr
a-src-x a-src-y
a-dest-x a-dest-y
a-dest-w a-dest-h
alpha
clipping-region)
(void)]
[(or (send src is-color?)
(and (not (eq? style 'opaque))
(= alpha 1.0)

2
pkgs/draw-pkgs/draw-lib/racket/draw/private/local.rkt
View File

@ -9,11 +9,13 @@
;; bitmap%
get-cairo-surface
get-cairo-target-surface
get-cairo-alpha-surface
get-cairo-device-scale
release-bitmap-storage
get-bitmap-gl-context
drop-alpha-s
draw-bitmap-to
;; bitmap-dc%
internal-get-bitmap

20
pkgs/draw-pkgs/draw-lib/racket/draw/unsafe/cairo.rkt
View File

@ -96,6 +96,8 @@
(define-cairo cairo_get_target (_cfun _cairo_t -> _cairo_surface_t)) ;; not an allocator
(define-cairo cairo_surface_get_type (_cfun _cairo_surface_t -> _int))
;; Context
(define-cairo cairo_paint (_cfun _cairo_t -> _void))
(define-cairo cairo_paint_with_alpha (_cfun _cairo_t _double* -> _void))
@ -126,6 +128,20 @@
(set! warned? #t))
(values 0 0 0 0)))))
(define-cstruct _cairo_rectangle_t ([x _double]
[y _double]
[width _double]
[height _double]))
(define-cstruct _cairo_rectangle_list_t ([status _int]
[rectangles _cairo_rectangle_t-pointer]
[num_rectangles _int]))
(provide (struct-out cairo_rectangle_t) _cairo_rectangle_t
(struct-out cairo_rectangle_list_t))
(define-cairo cairo_rectangle_list_destroy (_cfun _cairo_rectangle_list_t-pointer -> _void)
#:wrap (deallocator))
(define-cairo cairo_copy_clip_rectangle_list (_cfun _cairo_t -> _cairo_rectangle_list_t-pointer)
#:wrap (allocator cairo_rectangle_list_destroy))
(define-cairo cairo_fill_extents (_cfun _cairo_t
(x1 : (_ptr o _double))
(y1 : (_ptr o _double))
@ -440,6 +456,10 @@
(define/provide CAIRO_CONTENT_COLOR_ALPHA #x3000)
(define-enum
6
CAIRO_SURFACE_TYPE_QUARTZ)
;; ----------------------------------------
(define-cstruct _cairo_path_data_t_header ([type _int]

2
pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/canvas.rkt
View File

@ -432,7 +432,7 @@
(define/public (get-dc) dc)
(define/public (make-compatible-bitmap w h)
(make-screen-bitmap w h))
(make-window-bitmap w h (get-cocoa-window)))
(define/override (fix-dc [refresh? #t])
(when (dc . is-a? . dc%)

22
pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/cg.rkt
View File

@ -1,11 +1,19 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
ffi/unsafe/alloc
"types.rkt"
"utils.rkt")
(provide (protect-out (all-defined-out)))
(define-cstruct _CGAffineTransform ([a _CGFloat]
[b _CGFloat]
[c _CGFloat]
[d _CGFloat]
[e _CGFloat]
[f _CGFloat]))
(define _CGContextRef (_cpointer 'CGContextRef))
(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void))
(define-appserv CGContextFlush (_fun _CGContextRef -> _void))
@ -14,8 +22,22 @@
(define-appserv CGContextRotateCTM (_fun _CGContextRef _CGFloat -> _void))
(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void))
(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void))
(define-appserv CGContextConcatCTM (_fun _CGContextRef _CGAffineTransform -> _void))
(define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void))
(define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void))
(define-appserv CGContextClearRect (_fun _CGContextRef _NSRect -> _void))
(define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void))
(define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void))
(define-appserv CGContextStrokePath (_fun _CGContextRef -> _void))
(define-appserv CGContextClipToRects (_fun _CGContextRef (_vector i _NSRect) _size -> _void))
(define-appserv CGContextSetAlpha (_fun _CGContextRef _CGFloat -> _void))
(define _CGLayerRef (_cpointer 'CGLayerRef))
(define-appserv CGLayerRelease (_fun _CGLayerRef -> _void)
#:wrap (deallocator))
(define-appserv CGLayerCreateWithContext (_fun _CGContextRef _NSSize _pointer -> _CGLayerRef)
#:wrap (allocator CGLayerRelease))
(define-appserv CGLayerGetContext (_fun _CGLayerRef -> _CGContextRef))
(define-appserv CGLayerGetSize (_fun _CGLayerRef -> _NSSize))
(define-appserv CGContextDrawLayerAtPoint (_fun _CGContextRef _NSPoint _CGLayerRef -> _void))
(define-appserv CGContextDrawLayerInRect (_fun _CGContextRef _NSRect _CGLayerRef -> _void))

165
pkgs/gui-pkgs/gui-lib/mred/private/wx/cocoa/dc.rkt
View File

@ -19,9 +19,11 @@
(protect-out dc%
do-backing-flush)
display-bitmap-resolution
make-screen-bitmap)
make-screen-bitmap
make-window-bitmap)
(import-class NSOpenGLContext NSScreen NSGraphicsContext)
(import-class NSOpenGLContext NSScreen)
(define NSOpenGLCPSwapInterval 222)
(define dc%
@ -62,8 +64,8 @@
;; Use a quartz bitmap so that text looks good:
(define trans? transparent?)
(define/override (make-backing-bitmap w h)
(make-object quartz-bitmap% w h trans?
(display-bitmap-resolution 0 void)))
(make-window-bitmap w h (send canvas get-cocoa-window) trans?))
(define/override (can-combine-text? sz) #t)
(define/override (get-backing-size xb yb)
@ -89,6 +91,8 @@
(define/override (cancel-delay req)
(send canvas cancel-canvas-flush-delay req))))
(define-local-member-name get-layer)
(define (do-backing-flush canvas dc ctx dx dy)
(tellv ctx saveGraphicsState)
(begin0
@ -98,15 +102,20 @@
[h (box 0)])
(send canvas get-client-size w h)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)])
(unless (send canvas is-flipped?)
(CGContextTranslateCTM cg 0 (unbox h))
(CGContextScaleCTM cg 1 -1))
(CGContextTranslateCTM cg dx dy)
(let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))]
[cr (cairo_create surface)])
(cairo_surface_destroy surface)
(backing-draw-bm bm cr (unbox w) (unbox h))
(cairo_destroy cr))))))
(cond
[(bm . is-a? . layer-bitmap%)
(define layer (send bm get-layer))
(CGContextDrawLayerAtPoint cg (make-NSPoint 0 0) layer)]
[else
(unless (send canvas is-flipped?)
(CGContextTranslateCTM cg 0 (unbox h))
(CGContextScaleCTM cg 1 -1))
(CGContextTranslateCTM cg dx dy)
(let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))]
[cr (cairo_create surface)])
(cairo_surface_destroy surface)
(backing-draw-bm bm cr (unbox w) (unbox h))
(cairo_destroy cr))])))))
(tellv ctx restoreGraphicsState)))
(define (display-bitmap-resolution num fail)
@ -129,4 +138,132 @@
(define/top (make-screen-bitmap [exact-positive-integer? w]
[exact-positive-integer? h])
(make-object quartz-bitmap% w h #t (display-bitmap-resolution 0 void)))
(make-object quartz-bitmap% w h #t
(display-bitmap-resolution 0 void)))
(define (make-window-bitmap w h win [trans? #t])
(if win
(make-object layer-bitmap% w h win
;; Force to non-transparent, because trying to
;; draw a layer into a transparent context
;; (when conversion to a bitmap is needed)
;; doesn't seem to work.
trans?)
(make-screen-bitmap w h)))
(define layer-bitmap%
(class quartz-bitmap%
(init w h win trans?)
(define layer (make-layer win w h))
(define layer-w w)
(define layer-h h)
(define/public (get-layer) layer)
(define is-trans? trans?)
(super-make-object w h trans? 1
(let ([cg (CGLayerGetContext layer)])
(CGContextTranslateCTM cg 0 h)
(CGContextScaleCTM cg 1 -1)
cg))
(define/override (draw-bitmap-to cr sx sy dx dy w h alpha clipping-region)
;; Called when the destination rectangle is inside the clipping region
(define s (cairo_get_target cr))
(cond
[(and (= (cairo_surface_get_type s) CAIRO_SURFACE_TYPE_QUARTZ)
(= sx 0)
(= sy 0)
(let ([rs (cairo_copy_clip_rectangle_list cr)])
(cond
[(and (= CAIRO_STATUS_SUCCESS (cairo_rectangle_list_t-status rs))
(< (cairo_rectangle_list_t-num_rectangles rs) 64))
rs]
[else
(cairo_rectangle_list_destroy rs)
#f])))
=>
(lambda (rs)
;; Use fast layer drawing:
(unless (or (zero? (cairo_rectangle_list_t-num_rectangles rs))
(zero? alpha))
(atomically
(define m (make-cairo_matrix_t 0 0 0 0 0 0))
(cairo_get_matrix cr m)
(define trans
(make-CGAffineTransform (cairo_matrix_t-xx m)
(cairo_matrix_t-yx m)
(cairo_matrix_t-xy m)
(cairo_matrix_t-yy m)
(cairo_matrix_t-x0 m)
(cairo_matrix_t-y0 m)))
(cairo_surface_flush s)
(define cg (cairo_quartz_surface_get_cg_context s))
(CGContextSaveGState cg)
(CGContextConcatCTM cg trans)
(let ([n (cairo_rectangle_list_t-num_rectangles rs)])
(define vec
(for/vector #:length n ([i (in-range n)])
(define r (ptr-add (cairo_rectangle_list_t-rectangles rs) i _cairo_rectangle_t))
(make-NSRect (make-NSPoint (cairo_rectangle_t-x r)
(cairo_rectangle_t-y r))
(make-NSSize (cairo_rectangle_t-width r)
(cairo_rectangle_t-height r)))))
(CGContextClipToRects cg vec n))
;; Flip target, because drawing to layer was flipped
(CGContextTranslateCTM cg 0 (+ dy h))
(CGContextScaleCTM cg 1 -1)
(CGContextSetAlpha cg alpha)
(CGContextDrawLayerInRect cg
(make-NSRect (make-NSPoint dx 0)
(make-NSSize w h))
layer)
(CGContextRestoreGState cg)
(cairo_surface_mark_dirty s)))
(cairo_rectangle_list_destroy rs)
#t)]
[else #f]))
(define s-bm #f)
(define/override (get-cairo-surface)
;; Convert to a platform bitmap, which Cairo understands
(let ([t-bm (or s-bm
(let ([bm (make-object quartz-bitmap%
layer-w layer-h
is-trans?
1.0)])
(define dc (send bm make-dc))
;; For some reason, we must touch the DC
;; to make transarent work right. It works
;; to draw beyond the visible region:
(send dc draw-rectangle (+ layer-w 5) (+ layer-h 5) 1 1)
(send dc draw-bitmap this 0 0)
(send dc set-bitmap #f)
(set! s-bm bm)
bm))])
(send t-bm get-cairo-surface)))
(define/override (get-cairo-target-surface)
(super get-cairo-surface))
(define/override (drop-alpha-s)
(super drop-alpha-s)
(set! s-bm #f))
(define/override (release-bitmap-storage)
(super release-bitmap-storage)
(set! s-bm #f)
(atomically
(when layer
(CGLayerRelease layer)
(set! layer #f))))))
(define (make-layer win w h)
(atomically
(with-autorelease
(let* ([ctx (tell NSGraphicsContext graphicsContextWithWindow: win)]
[tmp-cg (tell #:type _CGContextRef ctx graphicsPort)]
[layer (CGLayerCreateWithContext tmp-cg (make-NSSize w h) #f)])
layer))))

105
pkgs/gui-pkgs/gui-test/tests/gracket/draw.rkt
View File

@ -205,6 +205,8 @@
[vp (make-object vertical-panel% f)]
[hp0 (make-object horizontal-panel% vp)]
[hp (make-object horizontal-panel% vp)]
[hp2.75 (new horizontal-panel% [parent vp]
[stretchable-height #f])]
[hp3 (make-object horizontal-panel% vp)]
[hp2 hp]
[hp2.5 hp0]
@ -222,6 +224,7 @@
[do-clock #f]
[use-bitmap? #f]
[platform-bitmap? #f]
[compat-bitmap? #f]
[use-record? #f]
[serialize-record? #f]
[use-bad? #f]
@ -253,7 +256,7 @@
(define pixel-copy? #f)
(define kern? #f)
(define clip-pre-scale? #f)
(define c-clip? #f)
(define c-clip #f)
(define mask-ex-mode 'mred)
(define xscale 1)
(define yscale 1)
@ -261,18 +264,20 @@
(define c-xscale 1)
(define c-yscale 1)
(define c-offset 0)
(define c-gray? #f)
(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-canvas-clip (lambda (mode) (set! c-clip mode) (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-canvas-offset (lambda (o) (set! c-offset o) (refresh))])
[set-canvas-offset (lambda (o) (set! c-offset o) (refresh))]
[set-canvas-gray (lambda (g?) (set! c-gray? g?) (refresh))])
(override*
[on-paint
(case-lambda
@ -299,9 +304,13 @@
(make-object bitmap% "no such file")
(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?))))
(cond
[platform-bitmap?
(make-platform-bitmap w h)]
[compat-bitmap?
(send this make-bitmap w h)]
[else
(make-object bitmap% w h depth-one? c-gray?)])))
#f)]
[draw-series
(lambda (dc pens pent penx size x y flevel last?)
@ -1022,12 +1031,27 @@
(or (and (not (or kind (eq? dc can-dc)))
(send mem-dc get-bitmap))
use-record?))
(when c-gray?
(let ([b (send can-dc get-brush)]
[p (send can-dc get-pen)])
(send can-dc set-brush "gray" 'solid)
(send can-dc set-pen "black" 1 'transparent)
(send can-dc draw-rectangle 0 0 1024 1024)
(send can-dc set-brush b)
(send can-dc set-pen p)))
(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?
(when c-clip
(define r (new region%))
(send r set-rectangle 0 0 200 200)
(case c-clip
[(square) (send r set-rectangle 0 0 200 200)]
[(squares)
(define r2 (new region%))
(send r set-rectangle 0 0 200 200)
(send r2 set-rectangle 210 210 40 40)
(send r union r2)]
[(octagon) (send r set-polygon octagon)])
(send can-dc set-clipping-region r))
(if use-record?
(if serialize-record?
@ -1084,7 +1108,7 @@
(send dc start-doc "Draw Test")
(send dc start-page)
(send dc clear)
(send dc erase)
(send dc set-alpha current-alpha)
(send dc set-rotation (- current-rotation))
@ -1107,7 +1131,7 @@
(send the-color-database find-color "WHITE")))
;(send dc set-clipping-region #f)
(send dc clear)
(send dc erase)
(let ([clip-dc dc])
(if clock-clip?
@ -1286,14 +1310,15 @@
(super-new [parent parent][style '(hscroll vscroll)])
(init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0))
vp)])
(make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Record" "Serialize" "Bad") hp0
(make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Compatible" "Record" "Serialize" "Bad") hp0
(lambda (self event)
(set! use-bitmap? (< 0 (send self get-selection)))
(set! depth-one? (< 1 (send self get-selection)))
(set! depth-one? (= 2 (send self get-selection)))
(set! platform-bitmap? (= 3 (send self get-selection)))
(set! use-record? (<= 4 (send self get-selection) 5))
(set! serialize-record? (= 5 (send self get-selection)))
(set! use-bad? (< 5 (send self get-selection)))
(set! compat-bitmap? (= 4 (send self get-selection)))
(set! use-record? (<= 5 (send self get-selection) 6))
(set! serialize-record? (= 6 (send self get-selection)))
(set! use-bad? (< 7 (send self get-selection)))
(send canvas refresh)))
(make-object button% "PS" hp
(lambda (self event)
@ -1359,12 +1384,29 @@
(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
(make-object choice% "Clip"
'("None" "Rectangle" "Rectangle2" "Octagon"
"Circle" "Wedge" "Round Rectangle" "Lambda" "A"
"Rectangle + Octagon" "Rectangle + Circle"
"Octagon - Rectangle" "Rectangle & Octagon" "Rectangle ^ Octagon" "Polka"
"Empty")
hp2.75
(lambda (self event)
(set! clip (list-ref
'(none rect rect2 poly circle wedge roundrect lam A
rect+poly rect+circle poly-rect poly&rect poly^rect
polka empty)
(send self get-selection)))
(send canvas refresh)))
(make-object check-box% "Clip Pre-Scale" hp2.75
(lambda (self event)
(send canvas set-clip-pre-scale (send self get-value))))
(make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp2.75
(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
(make-object check-box% "+10" hp2.75
(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
@ -1375,26 +1417,17 @@
(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"
"Rectangle + Octagon" "Rectangle + Circle"
"Octagon - Rectangle" "Rectangle & Octagon" "Rectangle ^ Octagon" "Polka"
"Empty")
hp3
(make-object choice% "Cvs Clip" '("None" "Empty" "Square" "Squares" "Octagon") hp3
(lambda (self event)
(set! clip (list-ref
'(none rect rect2 poly circle wedge roundrect lam A
rect+poly rect+circle poly-rect poly&rect poly^rect
polka empty)
(send self get-selection)))
(send canvas refresh)))
(make-object check-box% "Clip Pre-Scale" hp3
(send canvas set-canvas-clip (case (send self get-selection)
[(0) #f]
[(1) 'empty]
[(2) 'square]
[(3) 'squares]
[(4) 'octagon]))))
(make-object check-box% "Cvs Gray" 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))))
(send canvas set-canvas-gray (send self get-value))))
(let ([clock (lambda (clip?)
(thread (lambda ()
(set! clock-clip? clip?)
@ -1414,7 +1447,7 @@
(set! clock-end #f)
(send canvas refresh))))])
(set! do-clock clock)
(make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t)))
(make-object button% "Clip Clock" hp2.75 (lambda (b e) (clock #t)))
(make-object button% "Print" hp4 (lambda (self event) (send canvas on-paint 'print)))
(make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)])
(when c