unify cocoa & gtk canvas-painting implementation
This commit is contained in:
Matthew Flatt
parent
73d28a3fff
commit
f40e7edae8
File diff suppressed because it is too large
Load Diff
|
|
@ -35,8 +35,9 @@
|
||||||
|
|
||||||
(define/override (release-bitmap-storage)
|
(define/override (release-bitmap-storage)
|
||||||
(atomically
|
(atomically
|
||||||
(cairo_surface_destroy s)
|
(when s
|
||||||
(set! s #f)))))
|
(cairo_surface_destroy s)
|
||||||
|
(set! s #f))))))
|
||||||
|
|
||||||
(define dc%
|
(define dc%
|
||||||
(class backing-dc%
|
(class backing-dc%
|
||||||
|
|
|
||||||
|
|
@ -475,8 +475,10 @@
|
||||||
(and on? #t))
|
(and on? #t))
|
||||||
(tellv cocoa zoom: cocoa)))
|
(tellv cocoa zoom: cocoa)))
|
||||||
|
|
||||||
(def/public-unimplemented iconized?)
|
(define/public (iconized?)
|
||||||
(def/public-unimplemented iconize)
|
(tell #:type _BOOL cocoa isMiniaturized))
|
||||||
|
(define/public (iconize on?)
|
||||||
|
(tellv cocoa miniaturize: cocoa))
|
||||||
|
|
||||||
(define/public (set-title s)
|
(define/public (set-title s)
|
||||||
(tellv cocoa setTitle: #:type _NSString s))))
|
(tellv cocoa setTitle: #:type _NSString s))))
|
||||||
|
|
|
||||||
|
|
@ -663,7 +663,8 @@
|
||||||
(do-request-flush-delay
|
(do-request-flush-delay
|
||||||
cocoa-win
|
cocoa-win
|
||||||
(lambda (cocoa-win)
|
(lambda (cocoa-win)
|
||||||
(tellv cocoa-win disableFlushWindow))
|
(tellv cocoa-win disableFlushWindow)
|
||||||
|
#t)
|
||||||
(lambda (cocoa-win)
|
(lambda (cocoa-win)
|
||||||
(tellv cocoa-win enableFlushWindow))))
|
(tellv cocoa-win enableFlushWindow))))
|
||||||
|
|
||||||
|
|
|
||||||
58
collects/mred/private/wx/common/canvas-mixin.rkt
Normal file
58
collects/mred/private/wx/common/canvas-mixin.rkt
Normal 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)))))
|
||||||
|
|
@ -8,15 +8,17 @@
|
||||||
(define (do-request-flush-delay win disable enable)
|
(define (do-request-flush-delay win disable enable)
|
||||||
(atomically
|
(atomically
|
||||||
(let ([req (box win)])
|
(let ([req (box win)])
|
||||||
(disable win)
|
(and
|
||||||
(add-event-boundary-sometimes-callback!
|
(disable win)
|
||||||
req
|
(begin
|
||||||
(lambda (v)
|
(add-event-boundary-sometimes-callback!
|
||||||
;; in atomic mode
|
req
|
||||||
(when (unbox req)
|
(lambda (v)
|
||||||
(set-box! req #f)
|
;; in atomic mode
|
||||||
(enable win))))
|
(when (unbox req)
|
||||||
req)))
|
(set-box! req #f)
|
||||||
|
(enable win))))
|
||||||
|
req)))))
|
||||||
|
|
||||||
(define (do-cancel-flush-delay req enable)
|
(define (do-cancel-flush-delay req enable)
|
||||||
(atomically
|
(atomically
|
||||||
|
|
|
||||||
|
|
@ -6,6 +6,7 @@
|
||||||
racket/draw/color
|
racket/draw/color
|
||||||
racket/draw/local
|
racket/draw/local
|
||||||
"../common/backing-dc.rkt"
|
"../common/backing-dc.rkt"
|
||||||
|
"../common/canvas-mixin.rkt"
|
||||||
"../../syntax.rkt"
|
"../../syntax.rkt"
|
||||||
"../../lock.rkt"
|
"../../lock.rkt"
|
||||||
"../common/event.rkt"
|
"../common/event.rkt"
|
||||||
|
|
@ -176,461 +177,434 @@
|
||||||
#t)
|
#t)
|
||||||
|
|
||||||
(define canvas%
|
(define canvas%
|
||||||
(class (client-size-mixin window%)
|
(canvas-mixin
|
||||||
(init parent
|
(class (client-size-mixin window%)
|
||||||
x y w h
|
(init parent
|
||||||
style
|
x y w h
|
||||||
[ignored-name #f]
|
style
|
||||||
[gl-config #f])
|
[ignored-name #f]
|
||||||
|
[gl-config #f])
|
||||||
|
|
||||||
(inherit get-gtk set-size get-size get-client-size
|
(inherit get-gtk set-size get-size get-client-size
|
||||||
on-size get-top-win
|
on-size get-top-win
|
||||||
set-auto-size
|
set-auto-size
|
||||||
adjust-client-delta infer-client-delta)
|
adjust-client-delta infer-client-delta)
|
||||||
|
|
||||||
(define is-combo? (memq 'combo style))
|
(define is-combo? (memq 'combo style))
|
||||||
(define has-border? (or (memq 'border style)
|
(define has-border? (or (memq 'border style)
|
||||||
(memq 'control-border style)))
|
(memq 'control-border style)))
|
||||||
|
|
||||||
(define margin (if has-border? 1 0))
|
(define margin (if has-border? 1 0))
|
||||||
|
|
||||||
(define auto-scroll? #f)
|
(define auto-scroll? #f)
|
||||||
(define virtual-height #f)
|
(define virtual-height #f)
|
||||||
(define virtual-width #f)
|
(define virtual-width #f)
|
||||||
|
|
||||||
(define-values (client-gtk gtk
|
(define-values (client-gtk gtk
|
||||||
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
|
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
|
||||||
combo-button-gtk
|
combo-button-gtk
|
||||||
scroll-width)
|
scroll-width)
|
||||||
(atomically ;; need to connect all children to gtk to avoid leaks
|
(atomically ;; need to connect all children to gtk to avoid leaks
|
||||||
(cond
|
|
||||||
[(or (memq 'hscroll style)
|
|
||||||
(memq 'vscroll style))
|
|
||||||
(let* ([client-gtk (gtk_drawing_area_new)]
|
|
||||||
[hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
|
|
||||||
[vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)])
|
|
||||||
(let ([h (as-gtk-allocation (gtk_hbox_new #f 0))]
|
|
||||||
[v (gtk_vbox_new #f 0)]
|
|
||||||
[v2 (gtk_vbox_new #f 0)]
|
|
||||||
[h2 (gtk_vbox_new #f 0)]
|
|
||||||
[hscroll (gtk_hscrollbar_new hadj)]
|
|
||||||
[vscroll (gtk_vscrollbar_new vadj)]
|
|
||||||
[resize-box (gtk_drawing_area_new)])
|
|
||||||
;; |------------------------------------|
|
|
||||||
;; | h |-----------------| |-----------||
|
|
||||||
;; | | v | | v2 ||
|
|
||||||
;; | | | | [vscroll] ||
|
|
||||||
;; | | [h2 [hscroll]] | | [resize] ||
|
|
||||||
;; | |-----------------| |-----------||
|
|
||||||
;; |------------------------------------|
|
|
||||||
(when has-border?
|
|
||||||
(gtk_container_set_border_width h margin))
|
|
||||||
(gtk_box_pack_start h v #t #t 0)
|
|
||||||
(gtk_box_pack_start v client-gtk #t #t 0)
|
|
||||||
(gtk_box_pack_start h v2 #f #f 0)
|
|
||||||
(gtk_box_pack_start v2 vscroll #t #t 0)
|
|
||||||
(gtk_box_pack_start v h2 #f #f 0)
|
|
||||||
(gtk_box_pack_start h2 hscroll #t #t 0)
|
|
||||||
(gtk_box_pack_start v2 resize-box #f #f 0)
|
|
||||||
(when (memq 'hscroll style)
|
|
||||||
(gtk_widget_show hscroll))
|
|
||||||
(gtk_widget_show vscroll)
|
|
||||||
(gtk_widget_show h)
|
|
||||||
(gtk_widget_show v)
|
|
||||||
(when (memq 'vscroll style)
|
|
||||||
(gtk_widget_show v2))
|
|
||||||
(gtk_widget_show h2)
|
|
||||||
(when (memq 'hscroll style)
|
|
||||||
(gtk_widget_show resize-box))
|
|
||||||
(gtk_widget_show client-gtk)
|
|
||||||
(let ([req (make-GtkRequisition 0 0)])
|
|
||||||
(gtk_widget_size_request vscroll req)
|
|
||||||
(values client-gtk h hadj vadj
|
|
||||||
(and (memq 'hscroll style) h2)
|
|
||||||
(and (memq 'vscroll style) v2)
|
|
||||||
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
|
|
||||||
#f
|
|
||||||
(GtkRequisition-width req)))))]
|
|
||||||
[is-combo?
|
|
||||||
(let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
|
|
||||||
[orig-entry (gtk_bin_get_child gtk)])
|
|
||||||
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
|
|
||||||
[has-border?
|
|
||||||
(let ([client-gtk (gtk_drawing_area_new)]
|
|
||||||
[h (as-gtk-allocation (gtk_hbox_new #f 0))])
|
|
||||||
(gtk_box_pack_start h client-gtk #t #t 0)
|
|
||||||
(gtk_container_set_border_width h margin)
|
|
||||||
(connect-expose-border h)
|
|
||||||
(gtk_widget_show client-gtk)
|
|
||||||
(values client-gtk h #f #f #f #f #f #f 0))]
|
|
||||||
[else
|
|
||||||
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
|
|
||||||
(values client-gtk client-gtk #f #f #f #f #f #f 0))])))
|
|
||||||
|
|
||||||
(super-new [parent parent]
|
|
||||||
[gtk gtk]
|
|
||||||
[client-gtk client-gtk]
|
|
||||||
[no-show? (memq 'deleted style)]
|
|
||||||
[extra-gtks (if (eq? client-gtk gtk)
|
|
||||||
null
|
|
||||||
(if hscroll-adj
|
|
||||||
(list client-gtk hscroll-adj vscroll-adj)
|
|
||||||
(if combo-button-gtk
|
|
||||||
(list client-gtk combo-button-gtk)
|
|
||||||
(list client-gtk))))])
|
|
||||||
|
|
||||||
(set-size x y w h)
|
|
||||||
|
|
||||||
(define dc (new dc% [canvas this]))
|
|
||||||
|
|
||||||
(gtk_widget_realize gtk)
|
|
||||||
(gtk_widget_realize client-gtk)
|
|
||||||
|
|
||||||
(when resize-box
|
|
||||||
(let ([r (make-GtkRequisition 0 0)])
|
|
||||||
(gtk_widget_size_request hscroll-gtk r)
|
|
||||||
(gtk_widget_set_size_request resize-box
|
|
||||||
(GtkRequisition-height r)
|
|
||||||
(GtkRequisition-height r))))
|
|
||||||
|
|
||||||
(connect-expose client-gtk)
|
|
||||||
#;(gtk_widget_set_double_buffered client-gtk #f)
|
|
||||||
(connect-key-and-mouse client-gtk)
|
|
||||||
(connect-focus client-gtk)
|
|
||||||
(gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK
|
|
||||||
GDK_KEY_RELEASE_MASK
|
|
||||||
GDK_BUTTON_PRESS_MASK
|
|
||||||
GDK_BUTTON_RELEASE_MASK
|
|
||||||
GDK_POINTER_MOTION_MASK
|
|
||||||
GDK_FOCUS_CHANGE_MASK
|
|
||||||
GDK_ENTER_NOTIFY_MASK
|
|
||||||
GDK_LEAVE_NOTIFY_MASK))
|
|
||||||
(unless (memq 'no-focus style)
|
|
||||||
(set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk)
|
|
||||||
GTK_CAN_FOCUS)))
|
|
||||||
(when combo-button-gtk
|
|
||||||
(connect-combo-key-and-mouse combo-button-gtk))
|
|
||||||
|
|
||||||
(when hscroll-adj (connect-value-changed-h hscroll-adj))
|
|
||||||
(when vscroll-adj (connect-value-changed-v vscroll-adj))
|
|
||||||
|
|
||||||
(set-auto-size)
|
|
||||||
(adjust-client-delta (+ (* 2 margin)
|
|
||||||
(if (memq 'vscroll style)
|
|
||||||
scroll-width
|
|
||||||
0))
|
|
||||||
(+ (* 2 margin)
|
|
||||||
(if (memq 'hscroll style)
|
|
||||||
scroll-width
|
|
||||||
0)))
|
|
||||||
|
|
||||||
(define/override (direct-update?) #f)
|
|
||||||
|
|
||||||
(define/public (get-dc) dc)
|
|
||||||
|
|
||||||
(define/public (make-compatible-bitmap w h)
|
|
||||||
(send dc make-backing-bitmap w h))
|
|
||||||
|
|
||||||
(define/override (get-client-gtk) client-gtk)
|
|
||||||
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
|
|
||||||
|
|
||||||
(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))))))
|
|
||||||
|
|
||||||
(define/public (paint-or-queue-paint)
|
|
||||||
(or (do-backing-flush this dc (if is-combo?
|
|
||||||
(get-subwindow client-gtk)
|
|
||||||
(widget-window client-gtk)))
|
|
||||||
(begin
|
|
||||||
(queue-paint)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(define/public (on-paint) (void))
|
|
||||||
|
|
||||||
(define/public (get-flush-window) client-gtk)
|
|
||||||
|
|
||||||
(define/public (begin-refresh-sequence)
|
|
||||||
(send dc suspend-flush))
|
|
||||||
(define/public (end-refresh-sequence)
|
|
||||||
(send dc resume-flush))
|
|
||||||
|
|
||||||
(define/override (refresh)
|
|
||||||
(queue-paint))
|
|
||||||
|
|
||||||
(define/public (queue-backing-flush)
|
|
||||||
;; called atomically (not expecting exceptions)
|
|
||||||
(gtk_widget_queue_draw client-gtk))
|
|
||||||
|
|
||||||
(define/override (reset-child-dcs)
|
|
||||||
(when (dc . is-a? . dc%)
|
|
||||||
(reset-dc)))
|
|
||||||
|
|
||||||
(send dc start-backing-retained)
|
|
||||||
|
|
||||||
(define/private (reset-dc)
|
|
||||||
(send dc reset-backing-retained)
|
|
||||||
(refresh)
|
|
||||||
(send dc set-auto-scroll
|
|
||||||
(if virtual-width
|
|
||||||
(gtk_adjustment_get_value hscroll-adj)
|
|
||||||
0)
|
|
||||||
(if virtual-height
|
|
||||||
(gtk_adjustment_get_value vscroll-adj)
|
|
||||||
0)))
|
|
||||||
|
|
||||||
(define/override (internal-on-client-size w h)
|
|
||||||
(reset-dc))
|
|
||||||
(define/override (on-client-size w h)
|
|
||||||
(let ([xb (box 0)]
|
|
||||||
[yb (box 0)])
|
|
||||||
(get-size xb yb)
|
|
||||||
(on-size (unbox xb) (unbox yb))))
|
|
||||||
|
|
||||||
(define/public (show-scrollbars h? v?)
|
|
||||||
(when hscroll-gtk
|
|
||||||
(if h?
|
|
||||||
(gtk_widget_show hscroll-gtk)
|
|
||||||
(gtk_widget_hide hscroll-gtk)))
|
|
||||||
(when vscroll-gtk
|
|
||||||
(if v?
|
|
||||||
(gtk_widget_show vscroll-gtk)
|
|
||||||
(gtk_widget_hide vscroll-gtk)))
|
|
||||||
(when (and hscroll-gtk vscroll-gtk)
|
|
||||||
(cond
|
(cond
|
||||||
[(and v? h?)
|
[(or (memq 'hscroll style)
|
||||||
(gtk_widget_show resize-box)]
|
(memq 'vscroll style))
|
||||||
[(and v? (not h?))
|
(let* ([client-gtk (gtk_drawing_area_new)]
|
||||||
;; remove corner
|
[hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
|
||||||
(gtk_widget_hide resize-box)]))
|
[vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)])
|
||||||
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
|
(let ([h (as-gtk-allocation (gtk_hbox_new #f 0))]
|
||||||
(+ (* 2 margin) (if h? scroll-width 0))))
|
[v (gtk_vbox_new #f 0)]
|
||||||
|
[v2 (gtk_vbox_new #f 0)]
|
||||||
(define/private (configure-adj adj scroll-gtk len page pos)
|
[h2 (gtk_vbox_new #f 0)]
|
||||||
(when (and scroll-gtk adj)
|
[hscroll (gtk_hscrollbar_new hadj)]
|
||||||
(if (zero? len)
|
[vscroll (gtk_vscrollbar_new vadj)]
|
||||||
(gtk_adjustment_configure adj 0 0 1 1 1 1)
|
[resize-box (gtk_drawing_area_new)])
|
||||||
(gtk_adjustment_configure adj pos 0 (+ len page) 1 page page))))
|
;; |------------------------------------|
|
||||||
|
;; | h |-----------------| |-----------||
|
||||||
(define/public (set-scrollbars h-step v-step
|
;; | | v | | v2 ||
|
||||||
h-len v-len
|
;; | | | | [vscroll] ||
|
||||||
h-page v-page
|
;; | | [h2 [hscroll]] | | [resize] ||
|
||||||
h-pos v-pos
|
;; | |-----------------| |-----------||
|
||||||
auto?)
|
;; |------------------------------------|
|
||||||
(let ([h-page (if (zero? h-len) 0 h-page)]
|
(when has-border?
|
||||||
[v-page (if (zero? v-len) 0 v-page)])
|
(gtk_container_set_border_width h margin))
|
||||||
(cond
|
(gtk_box_pack_start h v #t #t 0)
|
||||||
[auto?
|
(gtk_box_pack_start v client-gtk #t #t 0)
|
||||||
(set! auto-scroll? #t)
|
(gtk_box_pack_start h v2 #f #f 0)
|
||||||
(set! virtual-width (and (positive? h-len) hscroll-gtk h-len))
|
(gtk_box_pack_start v2 vscroll #t #t 0)
|
||||||
(set! virtual-height (and (positive? v-len) vscroll-gtk v-len))
|
(gtk_box_pack_start v h2 #f #f 0)
|
||||||
(reset-auto-scroll h-pos v-pos)
|
(gtk_box_pack_start h2 hscroll #t #t 0)
|
||||||
(refresh-for-autoscroll)]
|
(gtk_box_pack_start v2 resize-box #f #f 0)
|
||||||
|
(when (memq 'hscroll style)
|
||||||
|
(gtk_widget_show hscroll))
|
||||||
|
(gtk_widget_show vscroll)
|
||||||
|
(gtk_widget_show h)
|
||||||
|
(gtk_widget_show v)
|
||||||
|
(when (memq 'vscroll style)
|
||||||
|
(gtk_widget_show v2))
|
||||||
|
(gtk_widget_show h2)
|
||||||
|
(when (memq 'hscroll style)
|
||||||
|
(gtk_widget_show resize-box))
|
||||||
|
(gtk_widget_show client-gtk)
|
||||||
|
(let ([req (make-GtkRequisition 0 0)])
|
||||||
|
(gtk_widget_size_request vscroll req)
|
||||||
|
(values client-gtk h hadj vadj
|
||||||
|
(and (memq 'hscroll style) h2)
|
||||||
|
(and (memq 'vscroll style) v2)
|
||||||
|
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
|
||||||
|
#f
|
||||||
|
(GtkRequisition-width req)))))]
|
||||||
|
[is-combo?
|
||||||
|
(let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
|
||||||
|
[orig-entry (gtk_bin_get_child gtk)])
|
||||||
|
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
|
||||||
|
[has-border?
|
||||||
|
(let ([client-gtk (gtk_drawing_area_new)]
|
||||||
|
[h (as-gtk-allocation (gtk_hbox_new #f 0))])
|
||||||
|
(gtk_box_pack_start h client-gtk #t #t 0)
|
||||||
|
(gtk_container_set_border_width h margin)
|
||||||
|
(connect-expose-border h)
|
||||||
|
(gtk_widget_show client-gtk)
|
||||||
|
(values client-gtk h #f #f #f #f #f #f 0))]
|
||||||
[else
|
[else
|
||||||
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
|
||||||
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)])))
|
(values client-gtk client-gtk #f #f #f #f #f #f 0))])))
|
||||||
|
|
||||||
(define/private (reset-auto-scroll h-pos v-pos)
|
(super-new [parent parent]
|
||||||
(let ([xb (box 0)]
|
[gtk gtk]
|
||||||
[yb (box 0)])
|
[client-gtk client-gtk]
|
||||||
(get-client-size xb yb)
|
[no-show? (memq 'deleted style)]
|
||||||
(let ([cw (unbox xb)]
|
[extra-gtks (if (eq? client-gtk gtk)
|
||||||
[ch (unbox yb)])
|
null
|
||||||
(let ([h-len (if virtual-width
|
(if hscroll-adj
|
||||||
(max 0 (- virtual-width cw))
|
(list client-gtk hscroll-adj vscroll-adj)
|
||||||
0)]
|
(if combo-button-gtk
|
||||||
[v-len (if virtual-height
|
(list client-gtk combo-button-gtk)
|
||||||
(max 0 (- virtual-height ch))
|
(list client-gtk))))])
|
||||||
0)]
|
|
||||||
[h-page (if virtual-width
|
(set-size x y w h)
|
||||||
cw
|
|
||||||
|
(define dc (new dc% [canvas this]))
|
||||||
|
|
||||||
|
(gtk_widget_realize gtk)
|
||||||
|
(gtk_widget_realize client-gtk)
|
||||||
|
|
||||||
|
(when resize-box
|
||||||
|
(let ([r (make-GtkRequisition 0 0)])
|
||||||
|
(gtk_widget_size_request hscroll-gtk r)
|
||||||
|
(gtk_widget_set_size_request resize-box
|
||||||
|
(GtkRequisition-height r)
|
||||||
|
(GtkRequisition-height r))))
|
||||||
|
|
||||||
|
(connect-expose client-gtk)
|
||||||
|
#;(gtk_widget_set_double_buffered client-gtk #f)
|
||||||
|
(connect-key-and-mouse client-gtk)
|
||||||
|
(connect-focus client-gtk)
|
||||||
|
(gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK
|
||||||
|
GDK_KEY_RELEASE_MASK
|
||||||
|
GDK_BUTTON_PRESS_MASK
|
||||||
|
GDK_BUTTON_RELEASE_MASK
|
||||||
|
GDK_POINTER_MOTION_MASK
|
||||||
|
GDK_FOCUS_CHANGE_MASK
|
||||||
|
GDK_ENTER_NOTIFY_MASK
|
||||||
|
GDK_LEAVE_NOTIFY_MASK))
|
||||||
|
(unless (memq 'no-focus style)
|
||||||
|
(set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk)
|
||||||
|
GTK_CAN_FOCUS)))
|
||||||
|
(when combo-button-gtk
|
||||||
|
(connect-combo-key-and-mouse combo-button-gtk))
|
||||||
|
|
||||||
|
(when hscroll-adj (connect-value-changed-h hscroll-adj))
|
||||||
|
(when vscroll-adj (connect-value-changed-v vscroll-adj))
|
||||||
|
|
||||||
|
(set-auto-size)
|
||||||
|
(adjust-client-delta (+ (* 2 margin)
|
||||||
|
(if (memq 'vscroll style)
|
||||||
|
scroll-width
|
||||||
|
0))
|
||||||
|
(+ (* 2 margin)
|
||||||
|
(if (memq 'hscroll style)
|
||||||
|
scroll-width
|
||||||
|
0)))
|
||||||
|
|
||||||
|
(define/override (direct-update?) #f)
|
||||||
|
|
||||||
|
(define/public (get-dc) dc)
|
||||||
|
|
||||||
|
(define/public (make-compatible-bitmap w h)
|
||||||
|
(send dc make-backing-bitmap w h))
|
||||||
|
|
||||||
|
(define/override (get-client-gtk) client-gtk)
|
||||||
|
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
|
||||||
|
|
||||||
|
(define/override (get-client-delta)
|
||||||
|
(values margin margin))
|
||||||
|
|
||||||
|
;; 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?
|
||||||
|
(get-subwindow client-gtk)
|
||||||
|
(widget-window client-gtk)))
|
||||||
|
(begin
|
||||||
|
(queue-paint)
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define/public (on-paint) (void))
|
||||||
|
|
||||||
|
(define/public (get-flush-window) client-gtk)
|
||||||
|
|
||||||
|
(define/public (begin-refresh-sequence)
|
||||||
|
(send dc suspend-flush))
|
||||||
|
(define/public (end-refresh-sequence)
|
||||||
|
(send dc resume-flush))
|
||||||
|
|
||||||
|
(define/override (refresh)
|
||||||
|
(queue-paint))
|
||||||
|
|
||||||
|
(define/public (queue-backing-flush)
|
||||||
|
;; called atomically (not expecting exceptions)
|
||||||
|
(gtk_widget_queue_draw client-gtk))
|
||||||
|
|
||||||
|
(define/override (reset-child-dcs)
|
||||||
|
(when (dc . is-a? . dc%)
|
||||||
|
(reset-dc)))
|
||||||
|
|
||||||
|
(send dc start-backing-retained)
|
||||||
|
|
||||||
|
(define/private (reset-dc)
|
||||||
|
(send dc reset-backing-retained)
|
||||||
|
(refresh)
|
||||||
|
(send dc set-auto-scroll
|
||||||
|
(if virtual-width
|
||||||
|
(gtk_adjustment_get_value hscroll-adj)
|
||||||
|
0)
|
||||||
|
(if virtual-height
|
||||||
|
(gtk_adjustment_get_value vscroll-adj)
|
||||||
|
0)))
|
||||||
|
|
||||||
|
(define/override (internal-on-client-size w h)
|
||||||
|
(reset-dc))
|
||||||
|
(define/override (on-client-size w h)
|
||||||
|
(let ([xb (box 0)]
|
||||||
|
[yb (box 0)])
|
||||||
|
(get-size xb yb)
|
||||||
|
(on-size (unbox xb) (unbox yb))))
|
||||||
|
|
||||||
|
(define/public (show-scrollbars h? v?)
|
||||||
|
(when hscroll-gtk
|
||||||
|
(if h?
|
||||||
|
(gtk_widget_show hscroll-gtk)
|
||||||
|
(gtk_widget_hide hscroll-gtk)))
|
||||||
|
(when vscroll-gtk
|
||||||
|
(if v?
|
||||||
|
(gtk_widget_show vscroll-gtk)
|
||||||
|
(gtk_widget_hide vscroll-gtk)))
|
||||||
|
(when (and hscroll-gtk vscroll-gtk)
|
||||||
|
(cond
|
||||||
|
[(and v? h?)
|
||||||
|
(gtk_widget_show resize-box)]
|
||||||
|
[(and v? (not h?))
|
||||||
|
;; remove corner
|
||||||
|
(gtk_widget_hide resize-box)]))
|
||||||
|
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
|
||||||
|
(+ (* 2 margin) (if h? scroll-width 0))))
|
||||||
|
|
||||||
|
(define/private (configure-adj adj scroll-gtk len page pos)
|
||||||
|
(when (and scroll-gtk adj)
|
||||||
|
(if (zero? len)
|
||||||
|
(gtk_adjustment_configure adj 0 0 1 1 1 1)
|
||||||
|
(gtk_adjustment_configure adj pos 0 (+ len page) 1 page page))))
|
||||||
|
|
||||||
|
(define/public (set-scrollbars h-step v-step
|
||||||
|
h-len v-len
|
||||||
|
h-page v-page
|
||||||
|
h-pos v-pos
|
||||||
|
auto?)
|
||||||
|
(let ([h-page (if (zero? h-len) 0 h-page)]
|
||||||
|
[v-page (if (zero? v-len) 0 v-page)])
|
||||||
|
(cond
|
||||||
|
[auto?
|
||||||
|
(set! auto-scroll? #t)
|
||||||
|
(set! virtual-width (and (positive? h-len) hscroll-gtk h-len))
|
||||||
|
(set! virtual-height (and (positive? v-len) vscroll-gtk v-len))
|
||||||
|
(reset-auto-scroll h-pos v-pos)
|
||||||
|
(refresh-for-autoscroll)]
|
||||||
|
[else
|
||||||
|
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
||||||
|
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)])))
|
||||||
|
|
||||||
|
(define/private (reset-auto-scroll h-pos v-pos)
|
||||||
|
(let ([xb (box 0)]
|
||||||
|
[yb (box 0)])
|
||||||
|
(get-client-size xb yb)
|
||||||
|
(let ([cw (unbox xb)]
|
||||||
|
[ch (unbox yb)])
|
||||||
|
(let ([h-len (if virtual-width
|
||||||
|
(max 0 (- virtual-width cw))
|
||||||
0)]
|
0)]
|
||||||
[v-page (if virtual-height
|
[v-len (if virtual-height
|
||||||
ch
|
(max 0 (- virtual-height ch))
|
||||||
0)])
|
0)]
|
||||||
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
[h-page (if virtual-width
|
||||||
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)))))
|
cw
|
||||||
|
0)]
|
||||||
|
[v-page (if virtual-height
|
||||||
|
ch
|
||||||
|
0)])
|
||||||
|
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
||||||
|
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)))))
|
||||||
|
|
||||||
(define/private (refresh-for-autoscroll)
|
(define/private (refresh-for-autoscroll)
|
||||||
(reset-dc)
|
(reset-dc)
|
||||||
(refresh))
|
(refresh))
|
||||||
|
|
||||||
(define/private (dispatch which proc [default (void)])
|
(define/private (dispatch which proc [default (void)])
|
||||||
(if (eq? which 'vertical)
|
(if (eq? which 'vertical)
|
||||||
(if vscroll-adj (proc vscroll-adj) default)
|
(if vscroll-adj (proc vscroll-adj) default)
|
||||||
(if hscroll-adj (proc hscroll-adj) default)))
|
(if hscroll-adj (proc hscroll-adj) default)))
|
||||||
|
|
||||||
(define/public (set-scroll-page which v)
|
(define/public (set-scroll-page which v)
|
||||||
(dispatch which (lambda (adj)
|
(dispatch which (lambda (adj)
|
||||||
(let ([old (gtk_adjustment_get_page_size adj)])
|
(let ([old (gtk_adjustment_get_page_size adj)])
|
||||||
(unless (= old v)
|
(unless (= old v)
|
||||||
(gtk_adjustment_set_page_size adj v)
|
(gtk_adjustment_set_page_size adj v)
|
||||||
(gtk_adjustment_set_page_increment adj v)
|
(gtk_adjustment_set_page_increment adj v)
|
||||||
(gtk_adjustment_set_upper adj (+ (- v old)
|
(gtk_adjustment_set_upper adj (+ (- v old)
|
||||||
(gtk_adjustment_get_upper adj))))))))
|
(gtk_adjustment_get_upper adj))))))))
|
||||||
(define/public (set-scroll-range which v)
|
(define/public (set-scroll-range which v)
|
||||||
(dispatch which (lambda (adj)
|
(dispatch which (lambda (adj)
|
||||||
(gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj))))))
|
(gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj))))))
|
||||||
(define/public (set-scroll-pos which v)
|
(define/public (set-scroll-pos which v)
|
||||||
(dispatch which (lambda (adj) (gtk_adjustment_set_value adj v))))
|
(dispatch which (lambda (adj) (gtk_adjustment_set_value adj v))))
|
||||||
|
|
||||||
(define/public (get-scroll-page which)
|
(define/public (get-scroll-page which)
|
||||||
(->long (dispatch which gtk_adjustment_get_page_size 0)))
|
(->long (dispatch which gtk_adjustment_get_page_size 0)))
|
||||||
(define/public (get-scroll-range which)
|
(define/public (get-scroll-range which)
|
||||||
(->long (dispatch which (lambda (adj)
|
(->long (dispatch which (lambda (adj)
|
||||||
(- (gtk_adjustment_get_upper adj)
|
(- (gtk_adjustment_get_upper adj)
|
||||||
(gtk_adjustment_get_page_size adj)))
|
(gtk_adjustment_get_page_size adj)))
|
||||||
0)))
|
0)))
|
||||||
(define/public (get-scroll-pos which)
|
(define/public (get-scroll-pos which)
|
||||||
(->long (dispatch which gtk_adjustment_get_value 0)))
|
(->long (dispatch which gtk_adjustment_get_value 0)))
|
||||||
|
|
||||||
(define clear-bg?
|
(define clear-bg?
|
||||||
(and (not (memq 'transparent style))
|
(and (not (memq 'transparent style))
|
||||||
(not (memq 'no-autoclear style))))
|
(not (memq 'no-autoclear style))))
|
||||||
(define transparent?
|
(define transparent?
|
||||||
(memq 'transparent style))
|
(memq 'transparent style))
|
||||||
(define gc #f)
|
(define gc #f)
|
||||||
(define bg-col (make-object color% "white"))
|
(define bg-col (make-object color% "white"))
|
||||||
(define/public (get-canvas-background) (if transparent?
|
(define/public (get-canvas-background) (if transparent?
|
||||||
#f
|
#f
|
||||||
bg-col))
|
bg-col))
|
||||||
(define/public (set-canvas-background col) (set! bg-col col))
|
(define/public (set-canvas-background col) (set! bg-col col))
|
||||||
(define/public (get-canvas-background-for-clearing)
|
(define/public (get-canvas-background-for-clearing)
|
||||||
;; called in event-dispatch mode
|
;; called in event-dispatch mode
|
||||||
(if now-drawing?
|
(if clear-bg?
|
||||||
(begin
|
(let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
|
||||||
(set! refresh-after-drawing? #t)
|
[w (widget-window gtk)]
|
||||||
#f)
|
[gc (gdk_gc_new w)])
|
||||||
(if clear-bg?
|
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
|
||||||
(let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
|
(conv (color-red bg-col))
|
||||||
[w (widget-window gtk)]
|
(conv (color-green bg-col))
|
||||||
[gc (gdk_gc_new w)])
|
(conv (color-blue bg-col))))
|
||||||
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
|
gc)
|
||||||
(conv (color-red bg-col))
|
#f))
|
||||||
(conv (color-green bg-col))
|
|
||||||
(conv (color-blue bg-col))))
|
|
||||||
gc)
|
|
||||||
#f)))
|
|
||||||
|
|
||||||
(when is-combo?
|
(when is-combo?
|
||||||
(connect-changed client-gtk))
|
(connect-changed client-gtk))
|
||||||
|
|
||||||
(define/public (append-combo-item str)
|
(define/public (append-combo-item str)
|
||||||
(gtk_combo_box_append_text gtk str))
|
(gtk_combo_box_append_text gtk str))
|
||||||
|
|
||||||
(define/public (combo-maybe-clicked)
|
(define/public (combo-maybe-clicked)
|
||||||
(let ([i (gtk_combo_box_get_active gtk)])
|
(let ([i (gtk_combo_box_get_active gtk)])
|
||||||
(when (i . > . -1)
|
(when (i . > . -1)
|
||||||
(gtk_combo_box_set_active gtk -1)
|
(gtk_combo_box_set_active gtk -1)
|
||||||
(queue-window-event this (lambda () (on-combo-select i))))))
|
(queue-window-event this (lambda () (on-combo-select i))))))
|
||||||
(define/public (on-combo-select i) (void))
|
(define/public (on-combo-select i) (void))
|
||||||
|
|
||||||
(define/public (set-combo-text t) (void))
|
(define/public (set-combo-text t) (void))
|
||||||
|
|
||||||
(def/public-unimplemented set-background-to-gray)
|
(def/public-unimplemented set-background-to-gray)
|
||||||
|
|
||||||
(define/public (do-scroll direction)
|
(define/public (do-scroll direction)
|
||||||
(if auto-scroll?
|
(if auto-scroll?
|
||||||
(refresh-for-autoscroll)
|
(refresh-for-autoscroll)
|
||||||
(on-scroll (new scroll-event%
|
(on-scroll (new scroll-event%
|
||||||
[event-type 'thumb]
|
[event-type 'thumb]
|
||||||
[direction direction]
|
[direction direction]
|
||||||
[position (get-scroll-pos direction)]))))
|
[position (get-scroll-pos direction)]))))
|
||||||
(define/public (on-scroll e) (void))
|
(define/public (on-scroll e) (void))
|
||||||
|
|
||||||
(define/public (scroll x y)
|
(define/public (scroll x y)
|
||||||
(when hscroll-adj (gtk_adjustment_set_value hscroll-adj x))
|
(when hscroll-adj (gtk_adjustment_set_value hscroll-adj x))
|
||||||
(when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))
|
(when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))
|
||||||
(when auto-scroll? (refresh-for-autoscroll)))
|
(when auto-scroll? (refresh-for-autoscroll)))
|
||||||
|
|
||||||
(def/public-unimplemented warp-pointer)
|
(def/public-unimplemented warp-pointer)
|
||||||
|
|
||||||
(define/public (view-start xb yb)
|
(define/public (view-start xb yb)
|
||||||
(if auto-scroll?
|
(if auto-scroll?
|
||||||
(begin
|
(begin
|
||||||
(set-box! xb (if virtual-width
|
(set-box! xb (if virtual-width
|
||||||
(gtk_adjustment_get_value hscroll-adj)
|
(gtk_adjustment_get_value hscroll-adj)
|
||||||
0))
|
0))
|
||||||
(set-box! yb (if virtual-height
|
(set-box! yb (if virtual-height
|
||||||
(gtk_adjustment_get_value vscroll-adj)
|
(gtk_adjustment_get_value vscroll-adj)
|
||||||
0)))
|
0)))
|
||||||
(begin
|
(begin
|
||||||
(set-box! xb 0)
|
(set-box! xb 0)
|
||||||
(set-box! yb 0))))
|
(set-box! yb 0))))
|
||||||
|
|
||||||
(define/public (set-resize-corner on?) (void))
|
(define/public (set-resize-corner on?) (void))
|
||||||
|
|
||||||
(define/public (get-virtual-size xb yb)
|
(define/public (get-virtual-size xb yb)
|
||||||
(get-client-size xb yb)
|
(get-client-size xb yb)
|
||||||
(when virtual-width (set-box! xb virtual-width))
|
(when virtual-width (set-box! xb virtual-width))
|
||||||
(when virtual-height (set-box! yb virtual-height)))
|
(when virtual-height (set-box! yb virtual-height)))
|
||||||
|
|
||||||
(define reg-blits null)
|
(define reg-blits null)
|
||||||
|
|
||||||
(define/private (register-one-blit x y w h on-pixbuf off-pixbuf)
|
(define/private (register-one-blit x y w h on-pixbuf off-pixbuf)
|
||||||
(let* ([cwin (widget-window client-gtk)])
|
(let* ([cwin (widget-window client-gtk)])
|
||||||
(atomically
|
(atomically
|
||||||
(let ([win (create-gc-window cwin x y w h)])
|
(let ([win (create-gc-window cwin x y w h)])
|
||||||
(let ([r (scheme_add_gc_callback
|
(let ([r (scheme_add_gc_callback
|
||||||
(make-gc-show-desc win on-pixbuf w h)
|
(make-gc-show-desc win on-pixbuf w h)
|
||||||
(make-gc-hide-desc win off-pixbuf w h))])
|
(make-gc-hide-desc win off-pixbuf w h))])
|
||||||
(cons win r))))))
|
(cons win r))))))
|
||||||
|
|
||||||
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
||||||
(let ([fix-size (lambda (on on-x on-y)
|
(let ([fix-size (lambda (on on-x on-y)
|
||||||
(if (and (zero? on-x)
|
(if (and (zero? on-x)
|
||||||
(zero? on-y)
|
(zero? on-y)
|
||||||
(= (send on get-width) w)
|
(= (send on get-width) w)
|
||||||
(= (send on get-height) h))
|
(= (send on get-height) h))
|
||||||
on
|
on
|
||||||
(let ([bm (make-object bitmap% w h)])
|
(let ([bm (make-object bitmap% w h)])
|
||||||
(let ([dc (make-object bitmap-dc% on)])
|
(let ([dc (make-object bitmap-dc% on)])
|
||||||
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
|
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
|
||||||
(send dc set-bitmap #f)
|
(send dc set-bitmap #f)
|
||||||
bm))))])
|
bm))))])
|
||||||
(let ([on (fix-size on on-x on-y)]
|
(let ([on (fix-size on on-x on-y)]
|
||||||
[off (fix-size off off-x off-y)])
|
[off (fix-size off off-x off-y)])
|
||||||
(let ([on-pixbuf (bitmap->pixbuf on)]
|
(let ([on-pixbuf (bitmap->pixbuf on)]
|
||||||
[off-pixbuf (bitmap->pixbuf off)])
|
[off-pixbuf (bitmap->pixbuf off)])
|
||||||
(atomically
|
(atomically
|
||||||
(set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits)))))))
|
(set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits)))))))
|
||||||
|
|
||||||
(define/public (unregister-collecting-blits)
|
(define/public (unregister-collecting-blits)
|
||||||
(atomically
|
(atomically
|
||||||
(for ([r (in-list reg-blits)])
|
(for ([r (in-list reg-blits)])
|
||||||
(g_object_unref (car r))
|
(g_object_unref (car r))
|
||||||
(scheme_remove_gc_callback (cdr r)))
|
(scheme_remove_gc_callback (cdr r)))
|
||||||
(set! reg-blits null)))))
|
(set! reg-blits null))))))
|
||||||
|
|
|
||||||
|
|
@ -237,14 +237,24 @@
|
||||||
(gtk_window_resize gtk (max 1 w) (max 1 h)))
|
(gtk_window_resize gtk (max 1 w) (max 1 h)))
|
||||||
|
|
||||||
(define/override (show on?)
|
(define/override (show on?)
|
||||||
(when (and on?
|
(let ([es (get-eventspace)])
|
||||||
(eventspace-shutdown? (get-eventspace)))
|
(when (and on?
|
||||||
(error (string->symbol
|
(eventspace-shutdown? es))
|
||||||
(format "show method in ~a"
|
(error (string->symbol
|
||||||
(if (frame-relative-dialog-status this)
|
(format "show method in ~a"
|
||||||
'dialog%
|
(if (frame-relative-dialog-status this)
|
||||||
'frame%)))
|
'dialog%
|
||||||
"eventspace has been shutdown"))
|
'frame%)))
|
||||||
|
"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?))
|
(super show on?))
|
||||||
|
|
||||||
(define saved-child #f)
|
(define saved-child #f)
|
||||||
|
|
|
||||||
|
|
@ -32,6 +32,11 @@
|
||||||
(for ([child (in-list children)])
|
(for ([child (in-list children)])
|
||||||
(send child reset-child-dcs))))
|
(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)
|
(define/override (set-size x y w h)
|
||||||
(super set-size x y w h)
|
(super set-size x y w h)
|
||||||
(reset-child-dcs))
|
(reset-child-dcs))
|
||||||
|
|
|
||||||
|
|
@ -568,6 +568,9 @@
|
||||||
(when parent
|
(when parent
|
||||||
(send parent register-child this on?)))
|
(send parent register-child this on?)))
|
||||||
|
|
||||||
|
(define/public (paint-children)
|
||||||
|
(void))
|
||||||
|
|
||||||
(def/public-unimplemented on-drop-file)
|
(def/public-unimplemented on-drop-file)
|
||||||
(def/public-unimplemented get-handle)
|
(def/public-unimplemented get-handle)
|
||||||
(def/public-unimplemented set-phantom-size)
|
(def/public-unimplemented set-phantom-size)
|
||||||
|
|
@ -625,12 +628,16 @@
|
||||||
(do-request-flush-delay
|
(do-request-flush-delay
|
||||||
gtk
|
gtk
|
||||||
(lambda (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)
|
(lambda (gtk)
|
||||||
(gdk_window_thaw_updates (widget-window gtk)))))
|
(gdk_window_thaw_updates (widget-window gtk)))))
|
||||||
|
|
||||||
(define (cancel-flush-delay req)
|
(define (cancel-flush-delay req)
|
||||||
(do-cancel-flush-delay
|
(when req
|
||||||
req
|
(do-cancel-flush-delay
|
||||||
(lambda (gtk)
|
req
|
||||||
(gdk_window_thaw_updates (widget-window gtk)))))
|
(lambda (gtk)
|
||||||
|
(gdk_window_thaw_updates (widget-window gtk))))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user