941 lines
35 KiB
Racket
941 lines
35 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/define
|
|
racket/class
|
|
racket/draw
|
|
ffi/unsafe/alloc
|
|
(except-in racket/draw/private/color
|
|
color% make-color)
|
|
racket/draw/private/local
|
|
racket/draw/unsafe/cairo
|
|
"../common/backing-dc.rkt"
|
|
"../common/canvas-mixin.rkt"
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/event.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"window.rkt"
|
|
"client-window.rkt"
|
|
"widget.rkt"
|
|
"dc.rkt"
|
|
"gl-context.rkt"
|
|
"combo.rkt"
|
|
"gcwin.rkt"
|
|
"panel.rkt")
|
|
|
|
(provide
|
|
(protect-out canvas%
|
|
canvas-panel%))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-gobj g_object_freeze_notify (_fun _GtkWidget -> _void))
|
|
(define-gobj g_object_thaw_notify (_fun _GtkWidget -> _void))
|
|
|
|
(define-gobj g_object_set_double (_fun _GtkWidget _string _double* (_pointer = #f) -> _void)
|
|
#:c-id g_object_set)
|
|
(define-gobj g_object_get_double (_fun _GtkWidget _string (r : (_ptr o _double)) (_pointer = #f)
|
|
-> _void -> r)
|
|
#:c-id g_object_get)
|
|
|
|
(define-gtk gtk_drawing_area_new (_fun -> _GtkWidget))
|
|
|
|
(define-gtk gtk_combo_box_text_new (_fun -> _GtkWidget)
|
|
#:make-fail make-not-available)
|
|
(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)
|
|
#:fail (lambda () gtk_combo_box_text_new))
|
|
|
|
(define-gtk gtk_combo_box_text_append_text (_fun _GtkWidget _string -> _void)
|
|
#:make-fail make-not-available)
|
|
(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)
|
|
#:fail (lambda () gtk_combo_box_text_append_text))
|
|
|
|
(define-gtk gtk_combo_box_text_remove (_fun _GtkWidget _int -> _void)
|
|
#:make-fail make-not-available)
|
|
(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)
|
|
#:fail (lambda () gtk_combo_box_text_remove))
|
|
|
|
(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void))
|
|
|
|
(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))
|
|
|
|
(define-gtk gtk_widget_set_has_window (_fun _GtkWidget _gboolean -> _void)
|
|
#:make-fail make-not-available)
|
|
(define-gtk gtk_fixed_set_has_window (_fun _GtkWidget _gboolean -> _void)
|
|
#:fail (lambda () gtk_widget_set_has_window))
|
|
|
|
(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget))
|
|
(define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget))
|
|
|
|
(define-gtk gtk_widget_set_double_buffered (_fun _GtkWidget _gboolean -> _void))
|
|
|
|
(define _GtkAdjustment _GtkWidget) ; no, actually a GtkObject
|
|
(define-gtk gtk_adjustment_new (_fun _double* _double* _double* _double* _double* _double* -> _GtkAdjustment))
|
|
(define-gtk gtk_adjustment_configure (_fun _GtkAdjustment _double* _double* _double* _double* _double* _double* -> _void)
|
|
#:fail (lambda ()
|
|
;; This by-hand version doesn't produce quite the same notifications.
|
|
(lambda (gtk value lower upper step-inc page-inc page-size)
|
|
(atomically
|
|
(g_object_freeze_notify gtk)
|
|
(g_object_set_double gtk "lower" lower)
|
|
(g_object_set_double gtk "upper" upper)
|
|
(g_object_set_double gtk "step-increment" step-inc)
|
|
(g_object_set_double gtk "page-increment" page-inc)
|
|
(g_object_set_double gtk "page-size" page-size)
|
|
(let ([value (max lower (min value (- upper page-size)))])
|
|
(gtk_adjustment_set_value gtk value))
|
|
(g_object_thaw_notify gtk)))))
|
|
(define-gtk gtk_adjustment_get_value (_fun _GtkAdjustment -> _double*))
|
|
(define-gtk gtk_adjustment_set_value (_fun _GtkAdjustment _double* -> _void))
|
|
(define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*)
|
|
#:fail (lambda ()
|
|
(lambda (gtk)
|
|
(g_object_get_double gtk "upper"))))
|
|
(define-gtk gtk_adjustment_set_upper (_fun _GtkAdjustment _double* -> _void)
|
|
#:fail (lambda ()
|
|
(lambda (gtk upper)
|
|
(g_object_set_double gtk "upper" upper))))
|
|
(define-gtk gtk_adjustment_get_page_size (_fun _GtkAdjustment -> _double*)
|
|
#:fail (lambda ()
|
|
(lambda (gtk)
|
|
(g_object_get_double gtk "page-size"))))
|
|
(define-gtk gtk_adjustment_set_page_size (_fun _GtkAdjustment _double* -> _void)
|
|
#:fail (lambda ()
|
|
(lambda (gtk page-size)
|
|
(g_object_set_double gtk "page-size" page-size))))
|
|
(define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*)
|
|
#:fail (lambda ()
|
|
(lambda (gtk)
|
|
(g_object_get_double gtk "page-increment"))))
|
|
(define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void)
|
|
#:fail (lambda ()
|
|
(lambda (gtk page-inc)
|
|
(g_object_set_double gtk "page-increment" page-inc))))
|
|
|
|
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
|
|
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
|
|
|
|
(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void)
|
|
#:c-id g_object_set)
|
|
|
|
(define _GtkIMContext (_cpointer 'GtkIMContext))
|
|
(define-gtk gtk_im_multicontext_new (_fun -> _GtkIMContext))
|
|
(define-gtk gtk_im_context_set_use_preedit (_fun _GtkIMContext _gboolean -> _void))
|
|
(define-gtk gtk_im_context_focus_in (_fun _GtkIMContext -> _void))
|
|
(define-gtk gtk_im_context_focus_out (_fun _GtkIMContext -> _void))
|
|
(define-gtk gtk_im_context_filter_keypress (_fun _GtkIMContext _GdkEventKey-pointer -> _gboolean))
|
|
(define-gtk gtk_im_context_set_client_window (_fun _GtkIMContext _GdkWindow -> _void))
|
|
(define-gtk gtk_im_context_set_cursor_location (_fun _GtkIMContext _GdkRectangle-pointer -> _void))
|
|
|
|
(define im-string-result #f)
|
|
(define im-filtering? #f)
|
|
(define im-canvas #f)
|
|
|
|
(define-signal-handler connect-commit "commit"
|
|
(_fun _GtkIMContext _string -> _void)
|
|
(lambda (im str)
|
|
(cond
|
|
[im-filtering?
|
|
;; filtering an event => we can handle the string
|
|
;; result directly
|
|
(set! im-string-result str)]
|
|
[(and im-canvas
|
|
(weak-box-value im-canvas))
|
|
;; not filtering, but there's a target canvas =>
|
|
;; queue a made-up key press event for each character
|
|
;; of the string
|
|
=> (lambda (wx)
|
|
(for ([c (in-string str)])
|
|
(let ([e (new key-event%
|
|
[key-code c]
|
|
[shift-down #f]
|
|
[control-down #f]
|
|
[meta-down #f]
|
|
[alt-down #f]
|
|
[x 0]
|
|
[y 0]
|
|
[time-stamp 0]
|
|
[caps-down #f])])
|
|
(queue-window-event wx (lambda ()
|
|
(send wx dispatch-on-char e #f))))))])))
|
|
|
|
(define im (gtk_im_multicontext_new))
|
|
(void (connect-commit (cast im _pointer _GtkWidget)))
|
|
|
|
(gtk_im_context_set_use_preedit im #f)
|
|
|
|
;; We rely some on the implementation of GtkComboBoxEntry to replace
|
|
;; the drawing routine.
|
|
(define-cstruct _GList ([data _pointer]))
|
|
(define-gdk gdk_window_get_children (_fun _pointer -> _GList-pointer/null))
|
|
(define-gdk gdk_window_hide (_fun _pointer -> _void))
|
|
(define (get-subwindow gtk)
|
|
(let* ([win (widget-window gtk)]
|
|
[subs (gdk_window_get_children win)])
|
|
(if subs
|
|
(GList-data subs)
|
|
win)))
|
|
|
|
(define-signal-handler connect-changed "changed"
|
|
(_fun _GtkWidget -> _void)
|
|
(lambda (gtk)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx combo-maybe-clicked)))))
|
|
|
|
(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
|
|
(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
|
|
(define-gtk gtk_combo_box_set_button_sensitivity (_fun _GtkWidget _int -> _void)
|
|
#:fail (lambda ()
|
|
;; Not available? Too bad. A combo-field% will in rare
|
|
;; cases not be enabled as it should be.
|
|
(lambda (w m) (void))))
|
|
(define GTK_SENSITIVITY_ON 1)
|
|
|
|
(define-signal-handler connect-expose "expose-event"
|
|
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(if wx
|
|
(begin
|
|
(unless (send wx paint-or-queue-paint #f)
|
|
(let ([gc (send wx get-canvas-background-for-clearing)])
|
|
(when gc
|
|
(gdk_draw_rectangle (widget-window gtk) gc #t
|
|
0 0 32000 32000)
|
|
(gdk_gc_unref gc))))
|
|
(not (send wx is-panel?)))
|
|
#f))))
|
|
|
|
(define-signal-handler connect-draw "draw"
|
|
(_fun _GtkWidget _cairo_t -> _gboolean)
|
|
(lambda (gtk cr)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(if wx
|
|
(let ([col (send wx get-canvas-background-for-backing)]
|
|
[win (widget-window gtk)])
|
|
(unless (send wx paint-or-queue-paint cr)
|
|
(when col
|
|
(cairo_set_source_rgb cr
|
|
(color-red col)
|
|
(color-green col)
|
|
(color-blue col))
|
|
(cairo_rectangle cr 0 0 32000 32000)
|
|
(cairo_fill cr)))
|
|
(not (send wx is-panel?)))
|
|
#f))))
|
|
|
|
(define-signal-handler connect-value-changed-h "value-changed"
|
|
(_fun _GtkWidget -> _void)
|
|
(lambda (gtk)
|
|
(do-value-changed gtk 'horizontal)))
|
|
|
|
(define-signal-handler connect-value-changed-v "value-changed"
|
|
(_fun _GtkWidget -> _void)
|
|
(lambda (gtk)
|
|
(do-value-changed gtk 'vertical)))
|
|
|
|
(define-signal-handler connect-unrealize "unrealize"
|
|
(_fun _GtkWidget -> _void)
|
|
(lambda (gtk)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx unrealize)))))
|
|
|
|
(define-signal-handler connect-unmap "unmap"
|
|
(_fun _GtkWidget -> _void)
|
|
(lambda (gtk)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx unrealize)))))
|
|
|
|
(define (do-value-changed gtk dir)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(when (send wx deliver-scroll-callbacks?)
|
|
(queue-window-event wx (lambda ()
|
|
(send wx do-scroll dir)
|
|
(flush-display))))))
|
|
#t)
|
|
|
|
(define canvas%
|
|
(canvas-mixin
|
|
(class (canvas-autoscroll-mixin (client-size-mixin window%))
|
|
(init parent
|
|
x y w h
|
|
style
|
|
[ignored-name #f]
|
|
[gl-config #f])
|
|
|
|
(inherit get-gtk get-size get-client-size
|
|
get-top-win
|
|
set-auto-size
|
|
adjust-client-delta infer-client-delta
|
|
is-auto-scroll? is-disabled-scroll?
|
|
get-virtual-width get-virtual-height
|
|
refresh-for-autoscroll refresh-all-children
|
|
reset-auto-scroll
|
|
get-eventspace
|
|
register-extra-gtk
|
|
call-pre-on-event set-focus on-event)
|
|
|
|
(define is-combo? (memq 'combo style))
|
|
(define has-border? (or (memq 'border style)
|
|
(memq 'control-border style)))
|
|
(define for-gl? (memq 'gl style))
|
|
(define transparent?
|
|
(and (memq 'transparent style)
|
|
(not for-gl?))) ; 'transparent is incompatible with 'gl
|
|
|
|
(define transparentish? (or transparent? is-combo?))
|
|
|
|
(define margin (if has-border? 1 0))
|
|
|
|
(define flush-win-box (mcons #f 0))
|
|
|
|
(define-values (client-gtk container-gtk gtk
|
|
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
|
|
combo-button-gtk
|
|
scroll-width)
|
|
(atomically ;; need to connect all children to gtk to avoid leaks
|
|
(cond
|
|
[(or (memq 'hscroll style)
|
|
(memq 'auto-hscroll style)
|
|
(memq 'vscroll style)
|
|
(memq 'auto-vscroll style))
|
|
(let* ([client-gtk (if (is-panel?)
|
|
(gtk_fixed_new)
|
|
(gtk_drawing_area_new))]
|
|
[container-gtk (if (is-panel?)
|
|
(gtk_fixed_new)
|
|
client-gtk)]
|
|
[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)]
|
|
[hs? (or (memq 'hscroll style)
|
|
(memq 'auto-hscroll style))]
|
|
[vs? (or (memq 'vscroll style)
|
|
(memq 'auto-vscroll style))])
|
|
(let ([container (and gtk3?
|
|
;; See `panel%` for information on why an extra
|
|
;; event-box layer is needed here.
|
|
(as-gtk-allocation (gtk_event_box_new)))]
|
|
[border (and has-border?
|
|
(if gtk3?
|
|
(gtk_hbox_new #f 0)
|
|
(as-gtk-allocation (gtk_hbox_new #f 0))))]
|
|
[h (if (or has-border? gtk3?)
|
|
(gtk_hbox_new #f 0)
|
|
(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] ||
|
|
;; | |-----------------| |-----------||
|
|
;; |------------------------------------|
|
|
(unless (eq? client-gtk container-gtk)
|
|
(gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping
|
|
(when has-border?
|
|
(gtk_container_set_border_width h margin)
|
|
(connect-expose/draw-border border h))
|
|
(when container
|
|
(gtk_container_add container (or border h))
|
|
(gtk_widget_show (or border h)))
|
|
(when border (gtk_box_pack_start border h #t #t 0))
|
|
(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 hs?
|
|
(gtk_widget_show hscroll))
|
|
(gtk_widget_show vscroll)
|
|
(when border
|
|
(gtk_widget_show h))
|
|
(gtk_widget_show v)
|
|
(when vs?
|
|
(gtk_widget_show v2))
|
|
(gtk_widget_show h2)
|
|
(when hs?
|
|
(gtk_widget_show resize-box))
|
|
(gtk_widget_show client-gtk)
|
|
(unless (eq? client-gtk container-gtk)
|
|
(gtk_container_add client-gtk container-gtk)
|
|
(gtk_widget_show container-gtk))
|
|
(let ([req (make-GtkRequisition 0 0)])
|
|
(gtk_widget_size_request vscroll req)
|
|
(values client-gtk container-gtk (or container border h)
|
|
hadj vadj
|
|
(and hs? h2)
|
|
(and vs? v2)
|
|
(and hs? vs? 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)])
|
|
(gtk_combo_box_set_button_sensitivity gtk GTK_SENSITIVITY_ON)
|
|
(values orig-entry gtk gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
|
|
[has-border?
|
|
(let ([client-gtk (gtk_drawing_area_new)]
|
|
[h (gtk_hbox_new #f 0)]
|
|
[border (as-gtk-allocation (gtk_hbox_new #f 0))])
|
|
(gtk_box_pack_start border h #t #t 0)
|
|
(gtk_box_pack_start h client-gtk #t #t 0)
|
|
(gtk_container_set_border_width h margin)
|
|
(connect-expose/draw-border border h)
|
|
(gtk_widget_show h)
|
|
(gtk_widget_show client-gtk)
|
|
(values client-gtk client-gtk border #f #f #f #f #f #f 0))]
|
|
[else
|
|
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
|
|
(values client-gtk client-gtk client-gtk #f #f #f #f #f #f 0))])))
|
|
|
|
(when for-gl?
|
|
(prepare-widget-gl-context client-gtk gl-config)
|
|
(gtk_widget_set_double_buffered client-gtk #f))
|
|
|
|
(define dc #f)
|
|
|
|
(super-new [parent parent]
|
|
[gtk gtk]
|
|
[client-gtk client-gtk]
|
|
[no-show? (memq 'deleted style)]
|
|
[extra-gtks (append
|
|
(if (eq? client-gtk container-gtk)
|
|
null
|
|
(list container-gtk))
|
|
(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)))))])
|
|
|
|
(define/private (check-combo)
|
|
(when is-combo?
|
|
(set! combo-button-gtk (re-extract-combo-button gtk combo-button-gtk this))))
|
|
|
|
(set-size x y w h)
|
|
|
|
(define/override (set-size x y w h)
|
|
(super set-size x y w h)
|
|
(when (and (is-auto-scroll?)
|
|
(not (is-panel?)))
|
|
(reset-auto-scroll))
|
|
(on-size))
|
|
|
|
(set! dc (new dc% [canvas this] [transparentish? transparentish?]))
|
|
|
|
(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))))
|
|
|
|
(if gtk3?
|
|
(connect-draw client-gtk)
|
|
(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 (or (memq 'no-focus style)
|
|
(is-panel?))
|
|
(gtk_widget_set_can_focus client-gtk #t))
|
|
(check-combo)
|
|
(when combo-button-gtk
|
|
(connect-combo-key-and-mouse combo-button-gtk))
|
|
(connect-unrealize client-gtk)
|
|
(connect-unmap client-gtk)
|
|
|
|
(when hscroll-adj (connect-value-changed-h hscroll-adj))
|
|
(when vscroll-adj (connect-value-changed-v vscroll-adj))
|
|
|
|
(when (and gtk3? (or hscroll-gtk vscroll-gtk))
|
|
;; Need to get scroll size now that the control is shown
|
|
(let ([req (make-GtkRequisition 0 0)])
|
|
(gtk_widget_show gtk)
|
|
(gtk_widget_get_preferred_size (or vscroll-gtk hscroll-gtk) req #f)
|
|
(set! scroll-width (if vscroll-gtk
|
|
(GtkRequisition-width req)
|
|
(GtkRequisition-height req)))
|
|
(gtk_widget_hide gtk)))
|
|
|
|
(when (and gtk3? is-combo?)
|
|
;; Needed for sizing:
|
|
(gtk_combo_box_append_text gtk (make-string 8 #\X)))
|
|
|
|
(set-auto-size)
|
|
(adjust-client-delta (+ (* 2 margin)
|
|
(if (or (memq 'vscroll style)
|
|
(memq 'auto-vscroll style))
|
|
scroll-width
|
|
0))
|
|
(+ (* 2 margin)
|
|
(if (or (memq 'hscroll style)
|
|
(memq 'auto-hscroll style))
|
|
scroll-width
|
|
0)))
|
|
(when (and gtk3? is-combo?)
|
|
(infer-client-delta #:inside client-gtk)
|
|
(gtk_combo_box_text_remove gtk 0))
|
|
|
|
(define/public (is-panel?) #f)
|
|
|
|
;; Direct update is ok for a canvas, and it
|
|
;; allows pushing updates to the screen even
|
|
;; if the eventspace thread is busy indefinitely
|
|
(define/override (direct-update?) #t)
|
|
|
|
(define/public (get-dc) dc)
|
|
|
|
(define/public (make-compatible-bitmap w h)
|
|
(send dc make-backing-bitmap w h))
|
|
|
|
(define/public (get-scaled-client-size)
|
|
(define wb (box #f))
|
|
(define hb (box #f))
|
|
(get-client-size wb hb)
|
|
(define s (if gtk3?
|
|
(gtk_widget_get_scale_factor gtk)
|
|
1))
|
|
(values (* s (->screen (unbox wb))) (* s (->screen (unbox hb)))))
|
|
|
|
(define/public (get-gl-client-size)
|
|
(get-scaled-client-size))
|
|
|
|
(define/override (get-client-gtk) client-gtk)
|
|
(define/override (get-container-gtk) container-gtk)
|
|
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
|
|
|
|
(define/override (internal-pre-on-event gtk e)
|
|
(if (ptr-equal? gtk combo-button-gtk)
|
|
(cond
|
|
[gtk3?
|
|
(queue-window-event this (lambda ()
|
|
(unless (call-pre-on-event this e)
|
|
(when (send e button-down?)
|
|
(set-focus))
|
|
(on-event e))))
|
|
#t]
|
|
[(send e button-down?)
|
|
(on-popup)
|
|
#t]
|
|
[else #f])
|
|
#f))
|
|
(define/public (popup-combo)
|
|
;; Unfortunately, the user has to hold the mouse
|
|
;; button down when popping up the menu this way,
|
|
;; whereas the default handler (that we subvert in
|
|
;; `internal-pre-on-event') keeps the menu open if
|
|
;; the user release the mouse button right away.
|
|
(gtk_combo_box_popup 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 (get-flush-window) transparentish?))
|
|
(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 (skip-pre-paint?) #f)
|
|
|
|
(define/public (paint-or-queue-paint cr)
|
|
;; in atomic mode
|
|
(if for-gl?
|
|
(queue-paint)
|
|
(or (do-canvas-backing-flush cr)
|
|
(begin
|
|
(queue-paint)
|
|
#f))))
|
|
|
|
;; overridden to extend for scheduled periodic flushes:
|
|
(define/public (schedule-periodic-backing-flush)
|
|
(void))
|
|
(define/public (do-canvas-backing-flush cr)
|
|
(do-backing-flush this dc (if gtk3?
|
|
cr
|
|
(if is-combo?
|
|
(get-subwindow client-gtk)
|
|
(widget-window client-gtk)))))
|
|
|
|
(define/public (on-paint) (void))
|
|
|
|
(define/public (get-flush-window)
|
|
(atomically
|
|
(if (not (gtk_widget_get_mapped client-gtk))
|
|
(mcons #f #f)
|
|
(if (win-box-valid? flush-win-box)
|
|
flush-win-box
|
|
(begin
|
|
(set! flush-win-box (window->win-box (widget-window client-gtk)))
|
|
flush-win-box)))))
|
|
(define/public (unrealize)
|
|
(unrealize-win-box flush-win-box))
|
|
(define/override (reset-child-freezes)
|
|
;; A transparent canvas can't have a native window, so we
|
|
;; need to release any freezes befre the window implementation
|
|
;; might change.
|
|
(when transparentish? (unrealize)))
|
|
|
|
(define/public (begin-refresh-sequence)
|
|
(send dc suspend-flush))
|
|
(define/public (end-refresh-sequence)
|
|
(send dc resume-flush))
|
|
|
|
;; The `flush' method should be improved to flush local
|
|
;; to the enclosing frame, instead of flushing globally.
|
|
(define/public (flush)
|
|
(flush-display))
|
|
|
|
(define/private (refresh-one)
|
|
(queue-paint))
|
|
(define/override (refresh)
|
|
(refresh-one)
|
|
(refresh-all-children))
|
|
|
|
(define/public (queue-backing-flush)
|
|
;; called atomically
|
|
(unless for-gl?
|
|
(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-one)
|
|
(send dc set-auto-scroll
|
|
(if (get-virtual-width)
|
|
(gtk_adjustment_get_value hscroll-adj)
|
|
0)
|
|
(if (get-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)
|
|
(on-size))
|
|
|
|
;; this `on-size' method is for `editor-canvas%', only:
|
|
(define/public (on-size) (void))
|
|
|
|
(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)]))
|
|
(unless is-combo?
|
|
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
|
|
(+ (* 2 margin) (if h? scroll-width 0)))))
|
|
|
|
(define suspend-scroll-callbacks? #f)
|
|
(define/public (deliver-scroll-callbacks?) (not suspend-scroll-callbacks?))
|
|
(define/private (as-scroll-change thunk)
|
|
(atomically
|
|
(set! suspend-scroll-callbacks? #t)
|
|
(begin0
|
|
(thunk)
|
|
(set! suspend-scroll-callbacks? #f))))
|
|
|
|
|
|
(define/private (configure-adj adj scroll-gtk len page pos)
|
|
(when (and scroll-gtk adj)
|
|
(as-scroll-change
|
|
(lambda ()
|
|
(if (zero? len)
|
|
(gtk_adjustment_configure adj 0 0 1 1 1 1)
|
|
(let ([pos (if (= pos -1)
|
|
(gtk_adjustment_get_value adj)
|
|
pos)])
|
|
(gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))))))
|
|
|
|
(define/override (do-set-scrollbars h-step v-step
|
|
h-len v-len
|
|
h-page v-page
|
|
h-pos v-pos)
|
|
(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/override (reset-dc-for-autoscroll)
|
|
(reset-dc))
|
|
|
|
(define/private (dispatch which proc [default (void)])
|
|
(if (eq? which 'vertical)
|
|
(if vscroll-adj (proc vscroll-adj) default)
|
|
(if hscroll-adj (proc hscroll-adj) default)))
|
|
|
|
(define/public (set-scroll-page which v)
|
|
(dispatch which (lambda (adj)
|
|
(let ([old (gtk_adjustment_get_page_size adj)])
|
|
(unless (= old v)
|
|
(as-scroll-change
|
|
(lambda ()
|
|
(gtk_adjustment_set_page_size adj v)
|
|
(gtk_adjustment_set_page_increment adj v)
|
|
(gtk_adjustment_set_upper adj (+ (- v old)
|
|
(gtk_adjustment_get_upper adj))))))))))
|
|
(define/public (set-scroll-range which v)
|
|
(dispatch which (lambda (adj)
|
|
(as-scroll-change
|
|
(lambda ()
|
|
(gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj))))))))
|
|
(define/public (set-scroll-pos which v)
|
|
(dispatch which (lambda (adj)
|
|
(as-scroll-change
|
|
(lambda ()
|
|
(gtk_adjustment_set_value adj v))))))
|
|
|
|
(define/private (is-disabled-scroll-dir? which)
|
|
(or (if (eq? which 'vertical)
|
|
(not vscroll-gtk)
|
|
(not hscroll-gtk))
|
|
(is-disabled-scroll?)))
|
|
|
|
(define/public (get-scroll-page which)
|
|
(if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
|
|
0
|
|
(->long (dispatch which gtk_adjustment_get_page_size 0))))
|
|
(define/public (get-scroll-range which)
|
|
(if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
|
|
0
|
|
(->long (dispatch which (lambda (adj)
|
|
(- (gtk_adjustment_get_upper adj)
|
|
(gtk_adjustment_get_page_size adj)))
|
|
0))))
|
|
(define/public (get-scroll-pos which)
|
|
(if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
|
|
0
|
|
(->long (dispatch which gtk_adjustment_get_value 0))))
|
|
|
|
(define clear-bg?
|
|
(and (not transparent?)
|
|
(not (memq 'no-autoclear style))))
|
|
(define gc #f)
|
|
(define bg-col (make-object color% "white"))
|
|
(define/public (get-canvas-background) (if transparent?
|
|
#f
|
|
bg-col))
|
|
(define/public (set-canvas-background col) (set! bg-col col))
|
|
(define/public (get-canvas-background-for-backing) (and clear-bg? bg-col))
|
|
(define/public (get-canvas-background-for-clearing)
|
|
;; called in event-dispatch mode
|
|
(if clear-bg?
|
|
(let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
|
|
[w (widget-window gtk)]
|
|
[gc (gdk_gc_new w)])
|
|
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
|
|
(conv (color-red bg-col))
|
|
(conv (color-green bg-col))
|
|
(conv (color-blue bg-col))))
|
|
gc)
|
|
#f))
|
|
|
|
(when is-combo?
|
|
(connect-changed (if gtk3? gtk client-gtk)))
|
|
|
|
(define combo-count 0)
|
|
(define/public (clear-combo-items)
|
|
(atomically
|
|
(for ([n (in-range combo-count)])
|
|
(gtk_combo_box_remove_text gtk 0))
|
|
(set! combo-count 0)))
|
|
(define/public (append-combo-item str)
|
|
(atomically
|
|
(set! combo-count (add1 combo-count))
|
|
(gtk_combo_box_append_text gtk str)))
|
|
|
|
(when is-combo? (append-combo-item "..."))
|
|
|
|
(define/public (on-popup) (void))
|
|
|
|
(define/public (combo-maybe-clicked)
|
|
(let ([i (gtk_combo_box_get_active gtk)])
|
|
(when (i . > . -1)
|
|
(set-no-active-item)
|
|
(queue-window-event this (lambda () (on-combo-select i))))))
|
|
(define/public (on-combo-select i) (void))
|
|
|
|
(define/private (set-no-active-item)
|
|
;; (gtk_combo_box_set_active gtk -1) should work,
|
|
;; or using (.._iter #f) should work, but neither
|
|
;; causes the "changed" signal to be emitted when the
|
|
;; currently active item is re-selected, so we
|
|
;; hack around the problem by adding an item, making
|
|
;; it active, then removing it
|
|
(atomically
|
|
(gtk_combo_box_append_text gtk "dummy")
|
|
(gtk_combo_box_set_active gtk combo-count)
|
|
(gtk_combo_box_remove_text gtk combo-count)))
|
|
|
|
(define/public (set-combo-text t) (void))
|
|
|
|
(define/override (focus-change on?)
|
|
;; input-method management
|
|
(if on?
|
|
(begin
|
|
(set! im-canvas (make-weak-box this))
|
|
(gtk_im_context_focus_in im)
|
|
(gtk_im_context_set_client_window im (widget-window client-gtk))
|
|
(let ([w (box 0)]
|
|
[h (box 0)])
|
|
(get-client-size w h)
|
|
(gtk_im_context_set_cursor_location
|
|
im
|
|
(make-GdkRectangle 0 0 (unbox w) (unbox h)))))
|
|
(when (and im-canvas
|
|
(eq? this (weak-box-value im-canvas)))
|
|
(gtk_im_context_focus_out im)
|
|
(set! im-canvas #f))))
|
|
|
|
(define/override (filter-key-event e)
|
|
;; give the input method a chance to handle the
|
|
;; key event; see call in "window.rkt" for
|
|
;; information on the results
|
|
(if (and im-canvas
|
|
(eq? this (weak-box-value im-canvas)))
|
|
(begin
|
|
(set! im-filtering? #t)
|
|
(set! im-string-result #f)
|
|
(if (begin0
|
|
(gtk_im_context_filter_keypress im e)
|
|
(set! im-filtering? #f))
|
|
im-string-result
|
|
'none))
|
|
'none))
|
|
|
|
(define/public (do-scroll direction)
|
|
(if (is-auto-scroll?)
|
|
(refresh-for-autoscroll)
|
|
(on-scroll (new scroll-event%
|
|
[event-type 'thumb]
|
|
[direction direction]
|
|
[position (get-scroll-pos direction)]))))
|
|
(define/public (on-scroll e) (void))
|
|
|
|
(define/public (scroll x y)
|
|
(when (is-auto-scroll?)
|
|
(as-scroll-change
|
|
(lambda ()
|
|
(when (and hscroll-adj (>= x 0))
|
|
(gtk_adjustment_set_value
|
|
hscroll-adj
|
|
(floor
|
|
(* x (- (gtk_adjustment_get_upper hscroll-adj)
|
|
(gtk_adjustment_get_page_size hscroll-adj))))))
|
|
(when (and vscroll-adj (>= y 0))
|
|
(gtk_adjustment_set_value
|
|
vscroll-adj
|
|
(floor
|
|
(* y (- (gtk_adjustment_get_upper vscroll-adj)
|
|
(gtk_adjustment_get_page_size vscroll-adj))))))))
|
|
(refresh-for-autoscroll)))
|
|
|
|
(define/override (get-virtual-h-pos)
|
|
(inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj))))
|
|
(define/override (get-virtual-v-pos)
|
|
(inexact->exact (ceiling (gtk_adjustment_get_value vscroll-adj))))
|
|
|
|
(define/public (set-resize-corner on?) (void))
|
|
|
|
(define reg-blits null)
|
|
|
|
(define/private (register-one-blit x y w h on-gc-bitmap off-gc-bitmap)
|
|
(atomically
|
|
(let ([win (create-gc-window client-gtk x y w h)])
|
|
(let ([r (scheme_add_gc_callback
|
|
(make-gc-show-desc win on-gc-bitmap w h)
|
|
(make-gc-hide-desc win off-gc-bitmap w h))])
|
|
(cons win r)))))
|
|
|
|
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
|
(let ([on (fix-bitmap-size on w h on-x on-y)]
|
|
[off (fix-bitmap-size off w h off-x off-y)])
|
|
(let ([on-gc-bitmap (bitmap->gc-bitmap on client-gtk)]
|
|
[off-gc-bitmap (bitmap->gc-bitmap off client-gtk)])
|
|
(atomically
|
|
(set! reg-blits (cons (register-one-blit (->screen x) (->screen y)
|
|
(->screen w) (->screen h)
|
|
on-gc-bitmap off-gc-bitmap)
|
|
reg-blits))))))
|
|
|
|
(define/public (unregister-collecting-blits)
|
|
(atomically
|
|
(for ([r (in-list reg-blits)])
|
|
(free-gc-window (car r))
|
|
(scheme_remove_gc_callback (cdr r)))
|
|
(set! reg-blits null))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define canvas-panel%
|
|
(class (panel-container-mixin (panel-mixin canvas%))
|
|
(inherit get-container-gtk
|
|
get-client-gtk
|
|
get-virtual-h-pos
|
|
get-virtual-v-pos)
|
|
(define/override (is-panel?) #t)
|
|
|
|
(define/override (set-child-size child-gtk x y w h)
|
|
;; ensure that container is big enough to hold the child:
|
|
(let ([container-gtk (get-container-gtk)]
|
|
[req (make-GtkRequisition 0 0)])
|
|
(gtk_widget_size_request container-gtk req)
|
|
(gtk_widget_set_size_request container-gtk
|
|
(max (GtkRequisition-width req)
|
|
(->screen (+ x w)))
|
|
(max (GtkRequisition-height req)
|
|
(->screen (+ y h)))))
|
|
(super set-child-size child-gtk x y w h))
|
|
|
|
(define/override (reset-dc-for-autoscroll)
|
|
(super reset-dc-for-autoscroll)
|
|
(gtk_fixed_move (get-client-gtk) (get-container-gtk)
|
|
(- (get-virtual-h-pos))
|
|
(- (get-virtual-v-pos))))
|
|
|
|
(super-new)))
|