#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 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 ([border (and has-border? (as-gtk-allocation (gtk_hbox_new #f 0)))] [h (if has-border? (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 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 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))]))) (define for-gl? (memq 'gl style)) (when for-gl? (prepare-widget-gl-context client-gtk gl-config) (gtk_widget_set_double_buffered client-gtk #f)) (define dc #f) (define transparent? (memq 'transparent style)) (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] [transparent? (memq 'transparent style)])) (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 10 #\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) (unless (and gtk3? transparent?) (request-flush-delay (get-flush-window)))) (define/public (cancel-canvas-flush-delay req) (unless (and gtk3? transparent?) (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/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 (memq 'transparent style)) (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)))