racket/gui cocoa: use CGLayer for canvas bitmaps
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. original commit: 9cb646bbd23221161ac7e0002b95937e4064e926
This commit is contained in:
Matthew Flatt
parent
243b3a1ed5
commit
c7134a00af
|
|
@ -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%)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user