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

switch gtk to new canvas-refresh strategy

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-06 12:18:08 -06:00
parent 7a7658e86d
commit 9f36c96960
4 changed files with 83 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/private/wx/common/queue.rkt
View File

@ -93,6 +93,8 @@
(define (add-event-boundary-callback! v proc)
(hash-set! boundary-ht v proc))
(define (add-event-boundary-sometimes-callback! v proc)
(when (zero? (hash-count sometimes-boundary-ht))
(set! last-time (current-inexact-milliseconds)))
(hash-set! sometimes-boundary-ht v proc))
(define (remove-event-boundary-callback! v)

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

@ -4,6 +4,8 @@
racket/draw
ffi/unsafe/alloc
racket/draw/color
racket/draw/local
"../common/backing-dc.rkt"
"../../syntax.rkt"
"../common/event.rkt"
"utils.rkt"
@ -86,11 +88,11 @@
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(unless (send wx paint-or-queue-paint)
(let ([gc (send wx get-canvas-background-for-clearing)])
(when gc
(gdk_draw_rectangle (g_object_get_window gtk) gc #t
0 0 32000 32000)))
(send wx queue-paint))
0 0 32000 32000)))))
#t))
(define-signal-handler connect-expose-border "expose-event"
@ -220,18 +222,7 @@
(set-size x y w h)
(define dc (new dc%
[gtk client-gtk]
[get-client-size (lambda ()
(let ([w (box 0)]
[h (box 0)])
(get-virtual-size w h)
(values (unbox w) (unbox h))))]
[window-lock (send (get-top-win) get-dc-lock)]
[get-window (lambda (client-gtk)
(if is-combo?
(get-subwindow client-gtk)
(g_object_get_window client-gtk)))]))
(define dc (new dc% [canvas this]))
(gtk_widget_realize gtk)
(gtk_widget_realize client-gtk)
@ -287,15 +278,27 @@
(queue-window-event this (lambda ()
(set! paint-queued? #f)
(set! now-drawing? #t)
(send dc reset-backing-retained) ; clean slate
(on-paint)
(set! now-drawing? #f)
(when refresh-after-drawing?
(set! refresh-after-drawing? #f)
(refresh))))))
(define/public (paint-or-queue-paint)
(or (do-backing-flush this dc (if is-combo?
(get-subwindow client-gtk)
(g_object_get_window client-gtk)))
(begin
(queue-paint)
#f)))
(define/public (on-paint) (void))
(define/override (refresh)
(queue-paint))
(define/public (queue-backing-flush)
(gtk_widget_queue_draw client-gtk))
(define/public (reset-child-dcs)
@ -305,7 +308,10 @@
(register-as-child parent on?)
(when on? (reset-child-dcs)))
(send dc start-backing-retained)
(define/private (reset-dc)
(send dc reset-backing-retained)
(if auto-scroll?
(send dc reset-dc
(if virtual-width
@ -314,7 +320,7 @@
(if virtual-height
(gtk_adjustment_get_value vscroll-adj)
0))
(send dc reset-dc 0 0)))
(void)))
(define/override (internal-on-client-size w h)
(reset-dc))

100
collects/mred/private/wx/gtk/dc.rkt
View File

@ -4,64 +4,72 @@
"utils.rkt"
"types.rkt"
"../../lock.rkt"
"../common/backing-dc.rkt"
racket/draw/cairo
racket/draw/dc
racket/draw/local
ffi/unsafe/alloc)
(provide dc% reset-dc)
(provide dc%
do-backing-flush)
(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t)
#:wrap (allocator cairo_destroy))
(define-local-member-name
reset-dc)
(define dc%
(class backing-dc%
(init [(cnvs canvas)])
(define canvas cnvs)
(define dc-backend%
(class default-dc-backend%
(init-field gtk
get-client-size
window-lock
[get-window g_object_get_window])
(inherit reset-cr set-auto-scroll)
(super-new)
(define c #f)
(define/override (get-cr)
(or c
(let ([w (get-window gtk)])
(and w
(begin
;; Under Windows, creating a Cairo context within
;; a frame inteferes with any other Cairo context
;; within the same frame. So we use a lock to
;; serialize drawing to different contexts.
(when window-lock (semaphore-wait window-lock))
(set! c (gdk_cairo_create w))
(reset-cr c)
c)))))
(define/override (release-cr cr)
(when window-lock
(cairo_destroy c)
(set! c #f)
(semaphore-post window-lock)))
(define/public (reset-dc scroll-dx scroll-dy)
;; FIXME: ensure that the dc is not in use
(as-entry
(lambda ()
(when c
(cairo_destroy c)
(set! c #f))
(set-auto-scroll scroll-dx scroll-dy))))
(define/override (get-backing-size xb yb)
(send canvas get-client-size xb yb))
(define/override (get-size)
(let-values ([(w h) (get-client-size)])
(values (exact->inexact w)
(exact->inexact h))))
(let ([xb (box 0)]
[yb (box 0)])
(send canvas get-virtual-size xb yb)
(values (unbox xb) (unbox yb))))
(super-new)))
(define/override (queue-backing-flush)
(send canvas queue-backing-flush))
(define dc%
(dc-mixin dc-backend%))
(define suspend-count 0)
(define req #f)
(define/override (suspend-flush)
(as-entry
(lambda ()
#;
(when (zero? suspend-count)
(set! req (request-flush-delay (send canvas get-cocoa-window))))
(set! suspend-count (add1 suspend-count))
(super suspend-flush))))
(define/override (resume-flush)
(as-entry
(lambda ()
(set! suspend-count (sub1 suspend-count))
#;
(when (and (zero? suspend-count) req)
(cancel-flush-delay req)
(set! req #f))
(super resume-flush))))))
(define (do-backing-flush canvas dc win)
(send dc on-backing-flush
(lambda (bm)
(let ([w (box 0)]
[h (box 0)])
(send canvas get-client-size w h)
(let ([cr (gdk_cairo_create win)])
(let ([s (cairo_get_source cr)])
(cairo_pattern_reference s)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(cairo_new_path cr)
(cairo_rectangle cr 0 0 (unbox w) (unbox h))
(cairo_fill cr)
(cairo_set_source cr s)
(cairo_pattern_destroy s))
(cairo_destroy cr))))))

3
collects/mred/private/wxme/editor.rkt
View File

@ -63,7 +63,8 @@
(define/public (set-last-used v) (set! last-used v))
(define/public (ready-offscreen width height)
(if (or (width . > . RIDICULOUS-SIZE)
(if (or #t ; disable on all platforms
(width . > . RIDICULOUS-SIZE)
(height . > . RIDICULOUS-SIZE)
(eq? (system-type) 'macosx))
#f