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

unify cocoa & gtk canvas-painting implementation

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-16 07:04:48 -06:00
parent 73d28a3fff
commit f40e7edae8
10 changed files with 1108 additions and 1077 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -16,6 +16,7 @@
"gc.rkt"
"image.rkt"
"../common/backing-dc.rkt"
"../common/canvas-mixin.rkt"
"../common/event.rkt"
"../common/queue.rkt"
"../../syntax.rkt"
@ -164,6 +165,7 @@
(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
(define canvas%
(canvas-mixin
(class window%
(init parent
x y w h
@ -211,41 +213,15 @@
(tellv cocoa setNeedsDisplay: #:type _BOOL #t))
(super focus-is-on on?))
;; Avoid multiple queued paints, and also allow cancel
;; of queued paint:
(define paint-queued #f) ; #f or (box #t)
(define/public (queue-paint)
;; can be called from any thread, including the event-pump thread
(unless paint-queued
(let ([b (box #t)])
(set! paint-queued b)
(let ([req (request-flush-delay (get-cocoa-window))])
(queue-window-refresh-event
this
(lambda () (do-on-paint req b)))))))
(define/private (do-on-paint req b)
;; only called in the handler thread
(when (or (not b) (unbox b))
(let ([pq paint-queued])
(when pq (set-box! pq #f)))
(set! paint-queued #f)
(when (or (not b) (is-shown-to-root?))
(send dc suspend-flush)
(send dc ensure-ready)
(send dc erase) ; start with a clean slate
(let ([bg (get-canvas-background)])
(when bg
(let ([old-bg (send dc get-background)])
(send dc set-background bg)
(send dc clear)
(send dc set-background old-bg))))
(on-paint)
(send dc resume-flush)
(queue-backing-flush)))
(when req
(cancel-flush-delay req)))
;; The `queue-paint' and `paint-children' methods
;; are defined by `canvas-mixin' from ../common/canvas-mixin
(define/public (queue-paint) (void))
(define/public (request-canvas-flush-delay)
(request-flush-delay (get-cocoa-window)))
(define/public (cancel-canvas-flush-delay req)
(cancel-flush-delay req))
(define/public (queue-canvas-refresh-event thunk)
(queue-window-refresh-event this thunk))
(define/public (paint-or-queue-paint)
(or (do-backing-flush this dc (tell NSGraphicsContext currentContext)
@ -254,11 +230,6 @@
(queue-paint)
#f)))
(define/override (paint-children)
(when (or paint-queued
(not (send dc can-backing-flush?)))
(do-on-paint #f #f)))
(define/public (begin-refresh-sequence)
(send dc suspend-flush))
(define/public (end-refresh-sequence)
@ -810,4 +781,4 @@
(define/public (unregister-collecting-blits)
(atomically
(suspend-all-reg-blits)
(set! blits null)))))
(set! blits null))))))

3
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -35,8 +35,9 @@
(define/override (release-bitmap-storage)
(atomically
(when s
(cairo_surface_destroy s)
(set! s #f)))))
(set! s #f))))))
(define dc%
(class backing-dc%

6
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -475,8 +475,10 @@
(and on? #t))
(tellv cocoa zoom: cocoa)))
(def/public-unimplemented iconized?)
(def/public-unimplemented iconize)
(define/public (iconized?)
(tell #:type _BOOL cocoa isMiniaturized))
(define/public (iconize on?)
(tellv cocoa miniaturize: cocoa))
(define/public (set-title s)
(tellv cocoa setTitle: #:type _NSString s))))

3
collects/mred/private/wx/cocoa/window.rkt
View File

@ -663,7 +663,8 @@
(do-request-flush-delay
cocoa-win
(lambda (cocoa-win)
(tellv cocoa-win disableFlushWindow))
(tellv cocoa-win disableFlushWindow)
#t)
(lambda (cocoa-win)
(tellv cocoa-win enableFlushWindow))))

58
collects/mred/private/wx/common/canvas-mixin.rkt Normal file
View File

@ -0,0 +1,58 @@
#lang racket/base
(require racket/class
"backing-dc.rkt")
(provide canvas-mixin)
(define (canvas-mixin %)
(class %
(super-new)
(inherit request-canvas-flush-delay
cancel-canvas-flush-delay
queue-canvas-refresh-event
is-shown-to-root?
on-paint
queue-backing-flush
get-dc
get-canvas-background)
;; Avoid multiple queued paints, and also allow cancel
;; of queued paint:
(define paint-queued #f) ; #f or (box #t)
(define/override (queue-paint)
;; can be called from any thread, including the event-pump thread
(unless paint-queued
(let ([b (box #t)])
(set! paint-queued b)
(let ([req (request-canvas-flush-delay)])
(queue-canvas-refresh-event
(lambda () (do-on-paint req b)))))))
(define/private (do-on-paint req b)
;; only called in the handler thread
(when (or (not b) (unbox b))
(let ([pq paint-queued])
(when pq (set-box! pq #f)))
(set! paint-queued #f)
(when (or (not b) (is-shown-to-root?))
(let ([dc (get-dc)])
(send dc suspend-flush)
(send dc ensure-ready)
(send dc erase) ; start with a clean slate
(let ([bg (get-canvas-background)])
(when bg
(let ([old-bg (send dc get-background)])
(send dc set-background bg)
(send dc clear)
(send dc set-background old-bg))))
(on-paint)
(send dc resume-flush)
(queue-backing-flush))))
(when req
(cancel-canvas-flush-delay req)))
(define/override (paint-children)
(when (or paint-queued
(not (send (get-dc) can-backing-flush?)))
(do-on-paint #f #f)))))

4
collects/mred/private/wx/common/delay.rkt
View File

@ -8,7 +8,9 @@
(define (do-request-flush-delay win disable enable)
(atomically
(let ([req (box win)])
(and
(disable win)
(begin
(add-event-boundary-sometimes-callback!
req
(lambda (v)
@ -16,7 +18,7 @@
(when (unbox req)
(set-box! req #f)
(enable win))))
req)))
req)))))
(define (do-cancel-flush-delay req enable)
(atomically

52
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -6,6 +6,7 @@
racket/draw/color
racket/draw/local
"../common/backing-dc.rkt"
"../common/canvas-mixin.rkt"
"../../syntax.rkt"
"../../lock.rkt"
"../common/event.rkt"
@ -176,6 +177,7 @@
#t)
(define canvas%
(canvas-mixin
(class (client-size-mixin window%)
(init parent
x y w h
@ -337,39 +339,15 @@
(define/override (get-client-delta)
(values margin margin))
;; Avoid multiple queued paints:
(define paint-queued? #f)
;; To handle paint requests that happen while on-paint
;; is being called already. kProbably doesn't happen,
;; because expose callabcks should be in the right
;; eventspace.
(define now-drawing? #f)
(define refresh-after-drawing? #f)
(define/public (queue-paint)
;; can be called from any thread, including the event-pump thread
(unless paint-queued?
(set! paint-queued? #t)
(queue-window-refresh-event
this
(lambda ()
(set! paint-queued? #f)
(set! now-drawing? #t)
(send dc suspend-flush)
(send dc ensure-ready)
(send dc erase) ; clean slate
(let ([bg (get-canvas-background)])
(when bg
(let ([old-bg (send dc get-background)])
(send dc set-background bg)
(send dc clear)
(send dc set-background old-bg))))
(on-paint)
(send dc resume-flush)
(set! now-drawing? #f)
(when refresh-after-drawing?
(set! refresh-after-drawing? #f)
(refresh))))))
;; The `queue-paint' and `paint-children' methods
;; are defined by `canvas-mixin' from ../common/canvas-mixin
(define/public (queue-paint) (void))
(define/public (request-canvas-flush-delay)
(request-flush-delay client-gtk))
(define/public (cancel-canvas-flush-delay req)
(cancel-flush-delay req))
(define/public (queue-canvas-refresh-event thunk)
(queue-window-refresh-event this thunk))
(define/public (paint-or-queue-paint)
(or (do-backing-flush this dc (if is-combo?
@ -530,10 +508,6 @@
(define/public (set-canvas-background col) (set! bg-col col))
(define/public (get-canvas-background-for-clearing)
;; called in event-dispatch mode
(if now-drawing?
(begin
(set! refresh-after-drawing? #t)
#f)
(if clear-bg?
(let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
[w (widget-window gtk)]
@ -543,7 +517,7 @@
(conv (color-green bg-col))
(conv (color-blue bg-col))))
gc)
#f)))
#f))
(when is-combo?
(connect-changed client-gtk))
@ -633,4 +607,4 @@
(for ([r (in-list reg-blits)])
(g_object_unref (car r))
(scheme_remove_gc_callback (cdr r)))
(set! reg-blits null)))))
(set! reg-blits null))))))

14
collects/mred/private/wx/gtk/frame.rkt
View File

@ -237,14 +237,24 @@
(gtk_window_resize gtk (max 1 w) (max 1 h)))
(define/override (show on?)
(let ([es (get-eventspace)])
(when (and on?
(eventspace-shutdown? (get-eventspace)))
(eventspace-shutdown? es))
(error (string->symbol
(format "show method in ~a"
(if (frame-relative-dialog-status this)
'dialog%
'frame%)))
"eventspace has been shutdown"))
"eventspace has been shutdown")
(when saved-child
(if (eq? (current-thread) (eventspace-handler-thread es))
(send saved-child paint-children)
(let ([s (make-semaphore)])
(queue-callback (lambda ()
(when saved-child
(send saved-child paint-children))
(semaphore-post s)))
(sync/timeout 1 s))))))
(super show on?))
(define saved-child #f)

5
collects/mred/private/wx/gtk/panel.rkt
View File

@ -32,6 +32,11 @@
(for ([child (in-list children)])
(send child reset-child-dcs))))
(define/override (paint-children)
(when (pair? children)
(for ([child (in-list children)])
(send child paint-children))))
(define/override (set-size x y w h)
(super set-size x y w h)
(reset-child-dcs))

11
collects/mred/private/wx/gtk/window.rkt
View File

@ -568,6 +568,9 @@
(when parent
(send parent register-child this on?)))
(define/public (paint-children)
(void))
(def/public-unimplemented on-drop-file)
(def/public-unimplemented get-handle)
(def/public-unimplemented set-phantom-size)
@ -625,12 +628,16 @@
(do-request-flush-delay
gtk
(lambda (gtk)
(gdk_window_freeze_updates (widget-window gtk)))
(let ([win (widget-window gtk)])
(and win
(gdk_window_freeze_updates win)
#t)))
(lambda (gtk)
(gdk_window_thaw_updates (widget-window gtk)))))
(define (cancel-flush-delay req)
(when req
(do-cancel-flush-delay
req
(lambda (gtk)
(gdk_window_thaw_updates (widget-window gtk)))))
(gdk_window_thaw_updates (widget-window gtk))))))