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

racket/gui: scrollbar support panels

Browse Source
This commit is contained in:
Matthew Flatt 2011-02-24 08:12:16 -07:00
parent 83b00c0cf1
commit 93e1467b8b
30 changed files with 521 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/mred/private/mrpanel.rkt
View File

@ -85,18 +85,38 @@
[(is-a? this vertical-panel%) 'vertical-panel] [(is-a? this vertical-panel%) 'vertical-panel]
[(is-a? this horizontal-panel%) 'horizontal-panel] [(is-a? this horizontal-panel%) 'horizontal-panel]
[else 'panel])] [else 'panel])]
[cwho `(constructor ,who)]) [cwho `(constructor ,who)]
[can-canvas? (memq who '(vertical-panel
horizontal-panel
panel))]
[as-canvas? (lambda () (or (memq 'vscroll style)
(memq 'auto-vscroll style)
(memq 'hscroll style)
(memq 'auto-hscroll style)))])
(check-container-parent cwho parent) (check-container-parent cwho parent)
(check-style cwho #f '(border deleted) style) (check-style cwho #f (append '(border deleted)
(if can-canvas?
'(hscroll vscroll auto-hscroll auto-vscroll)
null))
style)
(as-entry (as-entry
(lambda () (lambda ()
(super-init (lambda () (set! wx (make-object (case who (super-init (lambda () (set! wx (make-object (case who
[(vertical-panel) wx-vertical-panel%] [(vertical-panel)
(if (as-canvas?)
wx-vertical-canvas-panel%
wx-vertical-panel%)]
[(tab-panel) wx-vertical-tab-panel%] [(tab-panel) wx-vertical-tab-panel%]
[(group-box-panel) wx-vertical-group-panel%] [(group-box-panel) wx-vertical-group-panel%]
[(horizontal-panel) wx-horizontal-panel%] [(horizontal-panel)
[else wx-panel%]) (if (as-canvas?)
this this (mred->wx-container parent) style wx-horizontal-canvas-panel%
wx-horizontal-panel%)]
[else (if (as-canvas?)
wx-canvas-panel%
wx-panel%)])
this this (mred->wx-container parent)
(cons 'transparent style)
(get-initial-label))) (get-initial-label)))
wx) wx)
(lambda () wx) (lambda () wx)

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

@ -17,6 +17,7 @@
"item.rkt" "item.rkt"
"gc.rkt" "gc.rkt"
"image.rkt" "image.rkt"
"panel.rkt"
"../common/backing-dc.rkt" "../common/backing-dc.rkt"
"../common/canvas-mixin.rkt" "../common/canvas-mixin.rkt"
"../common/event.rkt" "../common/event.rkt"
@ -26,7 +27,8 @@
"../common/freeze.rkt") "../common/freeze.rkt")
(provide (provide
(protect-out canvas%)) (protect-out canvas%
canvas-panel%))
;; ---------------------------------------- ;; ----------------------------------------
@ -60,7 +62,7 @@
(tellv ctx restoreGraphicsState))))))) (tellv ctx restoreGraphicsState)))))))
(define-objc-mixin (MyViewMixin Superclass) (define-objc-mixin (MyViewMixin Superclass)
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) #:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder)
[wxb] [wxb]
(-a _void (drawRect: [_NSRect r]) (-a _void (drawRect: [_NSRect r])
(when wxb (when wxb
@ -247,12 +249,17 @@
refresh-for-autoscroll refresh-for-autoscroll
flush) flush)
(define vscroll-ok? (and (memq 'vscroll style) #t)) (define vscroll-ok? (and (or (memq 'vscroll style)
(memq 'auto-vscroll style)) ; 'auto variant falls through from panel
#t))
(define vscroll? vscroll-ok?) (define vscroll? vscroll-ok?)
(define hscroll-ok? (and (memq 'hscroll style) #t)) (define hscroll-ok? (and (or (memq 'hscroll style)
(memq 'auto-hscroll style))
#t))
(define hscroll? hscroll-ok?) (define hscroll? hscroll-ok?)
(define wants-focus? (not (memq 'no-focus style))) (define wants-focus? (and (not (memq 'no-focus style))
(not (is-panel?))))
(define is-combo? (memq 'combo style)) (define is-combo? (memq 'combo style))
(define has-control-border? (and (not is-combo?) (define has-control-border? (and (not is-combo?)
(memq 'control-border style))) (memq 'control-border style)))
@ -340,11 +347,12 @@
(define content-cocoa (define content-cocoa
(let ([r (make-NSRect (make-NSPoint 0 0) (let ([r (make-NSRect (make-NSPoint 0 0)
(make-NSSize (max 0 (- w (* 2 x-margin))) (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) (* 2 x-margin)))
(max 0 (- h (* 2 y-margin)))))]) (max 0 (- h (if hscroll? scroll-width 0) (* 2 y-margin)))))])
(as-objc-allocation (as-objc-allocation
(if (or is-combo? (not (memq 'gl style))) (if (or is-combo? (not (memq 'gl style)))
(tell (tell (if is-combo? MyComboBox MyView) alloc) (tell (tell (if is-combo? MyComboBox MyView)
alloc)
initWithFrame: #:type _NSRect r) initWithFrame: #:type _NSRect r)
(let ([pf (gl-config->pixel-format gl-config)]) (let ([pf (gl-config->pixel-format gl-config)])
(begin0 (begin0
@ -365,6 +373,8 @@
(send dc start-backing-retained) (send dc start-backing-retained)
(queue-paint) (queue-paint)
(define/public (is-panel?) #f)
(define/public (get-dc) dc) (define/public (get-dc) dc)
@ -453,7 +463,8 @@
(is-shown-to-root?)) (is-shown-to-root?))
(atomically (resume-all-reg-blits))) (atomically (resume-all-reg-blits)))
(fix-dc) (fix-dc)
(when (is-auto-scroll?) (when (and (is-auto-scroll?)
(not (is-panel?)))
(reset-auto-scroll 0 0)) (reset-auto-scroll 0 0))
(on-size)) (on-size))
@ -488,12 +499,14 @@
h-pos v-pos) h-pos v-pos)
(scroll-range h-scroller h-len) (scroll-range h-scroller h-len)
(scroll-page h-scroller h-page) (scroll-page h-scroller h-page)
(scroll-pos h-scroller h-pos) (unless (= h-pos -1)
(scroll-pos h-scroller h-pos))
(when h-scroller (when h-scroller
(tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len)))) (tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
(scroll-range v-scroller v-len) (scroll-range v-scroller v-len)
(scroll-page v-scroller v-page) (scroll-page v-scroller v-page)
(scroll-pos v-scroller v-pos) (unless (= v-pos -1)
(scroll-pos v-scroller v-pos))
(when v-scroller (when v-scroller
(tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) (tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
@ -512,19 +525,24 @@
(define/public (set-scroll-pos which v) (define/public (set-scroll-pos which v)
(update which scroll-pos v)) (update which scroll-pos v))
(define/private (guard-scroll which v) (define/private (guard-scroll skip-guard? which v)
(if (is-auto-scroll?) (if skip-guard?
0 v
v)) (if (is-auto-scroll?)
0
v)))
(define/public (get-scroll-page which) (define/public (get-scroll-page which [skip-guard? #f])
(guard-scroll which (guard-scroll skip-guard?
which
(scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))) (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))))
(define/public (get-scroll-range which) (define/public (get-scroll-range which [skip-guard? #f])
(guard-scroll which (guard-scroll skip-guard?
which
(scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))) (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))))
(define/public (get-scroll-pos which) (define/public (get-scroll-pos which [skip-guard? #f])
(guard-scroll which (guard-scroll skip-guard?
which
(scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))) (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))))
(define v-scroller (define v-scroller
@ -680,18 +698,18 @@
(let ([kind (let ([kind
(cond (cond
[(= part NSScrollerDecrementPage) [(= part NSScrollerDecrementPage)
(set-scroll-pos direction (- (get-scroll-pos direction) (set-scroll-pos direction (- (get-scroll-pos direction #t)
(get-scroll-page direction))) (get-scroll-page direction #t)))
'page-up] 'page-up]
[(= part NSScrollerIncrementPage) [(= part NSScrollerIncrementPage)
(set-scroll-pos direction (+ (get-scroll-pos direction) (set-scroll-pos direction (+ (get-scroll-pos direction #t)
(get-scroll-page direction))) (get-scroll-page direction #t)))
'page-down] 'page-down]
[(= part NSScrollerDecrementLine) [(= part NSScrollerDecrementLine)
(set-scroll-pos direction (- (get-scroll-pos direction) 1)) (set-scroll-pos direction (- (get-scroll-pos direction #t) 1))
'line-up] 'line-up]
[(= part NSScrollerIncrementLine) [(= part NSScrollerIncrementLine)
(set-scroll-pos direction (+ (get-scroll-pos direction) 1)) (set-scroll-pos direction (+ (get-scroll-pos direction #t) 1))
'line-down] 'line-down]
[(= part NSScrollerKnob) [(= part NSScrollerKnob)
'thumb] 'thumb]
@ -715,10 +733,11 @@
(e . is-a? . mouse-event%) (e . is-a? . mouse-event%)
(send e button-down? 'left)) (send e button-down? 'left))
(set-focus)) (set-focus))
(or (not is-combo?) (and (not (is-panel?))
(e . is-a? . key-event%) (or (not is-combo?)
(not (send e button-down? 'left)) (e . is-a? . key-event%)
(not (on-menu-click? e)))) (not (send e button-down? 'left))
(not (on-menu-click? e)))))
(define/override (gets-focus?) (define/override (gets-focus?)
wants-focus?) wants-focus?)
@ -820,8 +839,8 @@
defer: #:type _BOOL NO))] defer: #:type _BOOL NO))]
[iv (tell (tell NSImageView alloc) init)]) [iv (tell (tell NSImageView alloc) init)])
(tellv iv setImage: img) (tellv iv setImage: img)
(tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h))) (make-NSSize w h)))
(tellv (tell win contentView) addSubview: iv) (tellv (tell win contentView) addSubview: iv)
(tellv win setAlphaValue: #:type _CGFloat 0.0) (tellv win setAlphaValue: #:type _CGFloat 0.0)
(tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove) (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
@ -843,3 +862,20 @@
(atomically (atomically
(suspend-all-reg-blits) (suspend-all-reg-blits)
(set! blits null)))))) (set! blits null))))))
(define canvas-panel%
(class (panel-mixin canvas%)
(inherit get-virtual-h-pos
get-virtual-v-pos
get-cocoa-content)
(define/override (is-panel?) #t)
(define/override (reset-dc-for-autoscroll)
(let* ([content-cocoa (get-cocoa-content)])
(tellv content-cocoa setBoundsOrigin: #:type _NSPoint
(make-NSPoint (get-virtual-h-pos)
(- (get-virtual-v-pos)))))
(super reset-dc-for-autoscroll))
(super-new)))

8
collects/mred/private/wx/cocoa/panel.rkt
View File

@ -2,9 +2,9 @@
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"window.rkt") "window.rkt")
(provide (provide
@ -35,6 +35,7 @@
(send p set-parent this)) (send p set-parent this))
(define/override (fix-dc) (define/override (fix-dc)
(super fix-dc)
(for ([child (in-list children)]) (for ([child (in-list children)])
(send child fix-dc))) (send child fix-dc)))
@ -59,6 +60,7 @@
(send child child-accept-drag on?))) (send child child-accept-drag on?)))
(define/override (enable-window on?) (define/override (enable-window on?)
(super enable-window on?)
(let ([on? (and on? (is-window-enabled?))]) (let ([on? (and on? (is-window-enabled?))])
(for ([child (in-list children)]) (for ([child (in-list children)])
(send child enable-window on?)))) (send child enable-window on?))))

1
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -29,6 +29,7 @@
(values (values
button% button%
canvas% canvas%
canvas-panel%
check-box% check-box%
choice% choice%
clipboard-driver% clipboard-driver%

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

@ -20,10 +20,12 @@
"gl-context.rkt" "gl-context.rkt"
"combo.rkt" "combo.rkt"
"pixbuf.rkt" "pixbuf.rkt"
"gcwin.rkt") "gcwin.rkt"
"panel.rkt")
(provide (provide
(protect-out canvas%)) (protect-out canvas%
canvas-panel%))
;; ---------------------------------------- ;; ----------------------------------------
@ -45,6 +47,8 @@
(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))
(define-gtk gtk_fixed_set_has_window (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget))
(define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget)) (define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget))
@ -186,14 +190,16 @@
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event) (lambda (gtk event)
(let ([wx (gtk->wx gtk)]) (let ([wx (gtk->wx gtk)])
(when wx (if wx
(unless (send wx paint-or-queue-paint) (begin
(let ([gc (send wx get-canvas-background-for-clearing)]) (unless (send wx paint-or-queue-paint)
(when gc (let ([gc (send wx get-canvas-background-for-clearing)])
(gdk_draw_rectangle (widget-window gtk) gc #t (when gc
0 0 32000 32000) (gdk_draw_rectangle (widget-window gtk) gc #t
(gdk_gc_unref gc)))))) 0 0 32000 32000)
#t)) (gdk_gc_unref gc))))
(not (send wx is-panel?)))
#f))))
(define-signal-handler connect-expose-border "expose-event" (define-signal-handler connect-expose-border "expose-event"
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean) (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
@ -253,17 +259,28 @@
(define margin (if has-border? 1 0)) (define margin (if has-border? 1 0))
(define-values (client-gtk gtk (define-values (client-gtk container-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 (cond
[(or (memq 'hscroll style) [(or (memq 'hscroll style)
(memq 'vscroll style)) (memq 'auto-hscroll style)
(let* ([client-gtk (gtk_drawing_area_new)] (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)] [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)]) [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 ([h (as-gtk-allocation (gtk_hbox_new #f 0))] (let ([h (as-gtk-allocation (gtk_hbox_new #f 0))]
[v (gtk_vbox_new #f 0)] [v (gtk_vbox_new #f 0)]
[v2 (gtk_vbox_new #f 0)] [v2 (gtk_vbox_new #f 0)]
@ -278,6 +295,8 @@
;; | | [h2 [hscroll]] | | [resize] || ;; | | [h2 [hscroll]] | | [resize] ||
;; | |-----------------| |-----------|| ;; | |-----------------| |-----------||
;; |------------------------------------| ;; |------------------------------------|
(unless (eq? client-gtk container-gtk)
(gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping
(when has-border? (when has-border?
(gtk_container_set_border_width h margin)) (gtk_container_set_border_width h margin))
(gtk_box_pack_start h v #t #t 0) (gtk_box_pack_start h v #t #t 0)
@ -287,30 +306,33 @@
(gtk_box_pack_start v h2 #f #f 0) (gtk_box_pack_start v h2 #f #f 0)
(gtk_box_pack_start h2 hscroll #t #t 0) (gtk_box_pack_start h2 hscroll #t #t 0)
(gtk_box_pack_start v2 resize-box #f #f 0) (gtk_box_pack_start v2 resize-box #f #f 0)
(when (memq 'hscroll style) (when hs?
(gtk_widget_show hscroll)) (gtk_widget_show hscroll))
(gtk_widget_show vscroll) (gtk_widget_show vscroll)
(gtk_widget_show h) (gtk_widget_show h)
(gtk_widget_show v) (gtk_widget_show v)
(when (memq 'vscroll style) (when vs?
(gtk_widget_show v2)) (gtk_widget_show v2))
(gtk_widget_show h2) (gtk_widget_show h2)
(when (memq 'hscroll style) (when hs?
(gtk_widget_show resize-box)) (gtk_widget_show resize-box))
(gtk_widget_show client-gtk) (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)]) (let ([req (make-GtkRequisition 0 0)])
(gtk_widget_size_request vscroll req) (gtk_widget_size_request vscroll req)
(values client-gtk h hadj vadj (values client-gtk container-gtk h hadj vadj
(and (memq 'hscroll style) h2) (and hs? h2)
(and (memq 'vscroll style) v2) (and vs? v2)
(and (memq 'hscroll style) (memq 'vscroll style) resize-box) (and hs? vs? resize-box)
#f #f
(GtkRequisition-width req)))))] (GtkRequisition-width req)))))]
[is-combo? [is-combo?
(let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))] (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
[orig-entry (gtk_bin_get_child gtk)]) [orig-entry (gtk_bin_get_child gtk)])
(gtk_combo_box_set_button_sensitivity gtk GTK_SENSITIVITY_ON) (gtk_combo_box_set_button_sensitivity gtk GTK_SENSITIVITY_ON)
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))] (values orig-entry gtk gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
[has-border? [has-border?
(let ([client-gtk (gtk_drawing_area_new)] (let ([client-gtk (gtk_drawing_area_new)]
[h (as-gtk-allocation (gtk_hbox_new #f 0))]) [h (as-gtk-allocation (gtk_hbox_new #f 0))])
@ -318,22 +340,26 @@
(gtk_container_set_border_width h margin) (gtk_container_set_border_width h margin)
(connect-expose-border h) (connect-expose-border h)
(gtk_widget_show client-gtk) (gtk_widget_show client-gtk)
(values client-gtk h #f #f #f #f #f #f 0))] (values client-gtk client-gtk h #f #f #f #f #f #f 0))]
[else [else
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))]) (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
(values client-gtk client-gtk #f #f #f #f #f #f 0))]))) (values client-gtk client-gtk client-gtk #f #f #f #f #f #f 0))])))
(super-new [parent parent] (super-new [parent parent]
[gtk gtk] [gtk gtk]
[client-gtk client-gtk] [client-gtk client-gtk]
[no-show? (memq 'deleted style)] [no-show? (memq 'deleted style)]
[extra-gtks (if (eq? client-gtk gtk) [extra-gtks (append
null (if (eq? client-gtk container-gtk)
(if hscroll-adj null
(list client-gtk hscroll-adj vscroll-adj) (list container-gtk))
(if combo-button-gtk (if (eq? client-gtk gtk)
(list client-gtk combo-button-gtk) null
(list client-gtk))))]) (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) (set-size x y w h)
@ -369,7 +395,8 @@
GDK_FOCUS_CHANGE_MASK GDK_FOCUS_CHANGE_MASK
GDK_ENTER_NOTIFY_MASK GDK_ENTER_NOTIFY_MASK
GDK_LEAVE_NOTIFY_MASK)) GDK_LEAVE_NOTIFY_MASK))
(unless (memq 'no-focus style) (unless (or (memq 'no-focus style)
(is-panel?))
(set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk) (set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk)
GTK_CAN_FOCUS))) GTK_CAN_FOCUS)))
(when combo-button-gtk (when combo-button-gtk
@ -380,14 +407,18 @@
(set-auto-size) (set-auto-size)
(adjust-client-delta (+ (* 2 margin) (adjust-client-delta (+ (* 2 margin)
(if (memq 'vscroll style) (if (or (memq 'vscroll style)
(memq 'auto-vscroll style))
scroll-width scroll-width
0)) 0))
(+ (* 2 margin) (+ (* 2 margin)
(if (memq 'hscroll style) (if (or (memq 'hscroll style)
(memq 'auto-hscroll style))
scroll-width scroll-width
0))) 0)))
(define/public (is-panel?) #f)
;; Direct update is ok for a canvas, and it ;; Direct update is ok for a canvas, and it
;; allows pushing updates to the screen even ;; allows pushing updates to the screen even
;; if the eventspace thread is busy indefinitely ;; if the eventspace thread is busy indefinitely
@ -399,6 +430,7 @@
(send dc make-backing-bitmap w h)) (send dc make-backing-bitmap w h))
(define/override (get-client-gtk) client-gtk) (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 (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
(define/override (internal-pre-on-event gtk e) (define/override (internal-pre-on-event gtk e)
@ -528,7 +560,10 @@
(lambda () (lambda ()
(if (zero? len) (if (zero? len)
(gtk_adjustment_configure adj 0 0 1 1 1 1) (gtk_adjustment_configure adj 0 0 1 1 1 1)
(gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))))) (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 (define/override (do-set-scrollbars h-step v-step
h-len v-len h-len v-len
@ -741,3 +776,33 @@
(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))))))
;; ----------------------------------------
(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)
(+ x w))
(max (GtkRequisition-height req)
(+ 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)))

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

@ -35,7 +35,7 @@
(init w h gdk-win) (init w h gdk-win)
(super-make-object (make-alternate-bitmap-kind w h)) (super-make-object (make-alternate-bitmap-kind w h))
(define pixmap (gdk_pixmap_new gdk-win w h (define pixmap (gdk_pixmap_new gdk-win (max 1 w) (max 1 h)
(if gdk-win (if gdk-win
-1 -1
(GdkVisual-rec-depth (GdkVisual-rec-depth
@ -126,7 +126,7 @@
(send canvas get-canvas-background)) (send canvas get-canvas-background))
(make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))] (make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))]
[else [else
(super make-backing-bitmap w h)])) (super make-backing-bitmap (max 1 w) (max 1 h))]))
(define/override (get-backing-size xb yb) (define/override (get-backing-size xb yb)
(send canvas get-client-size xb yb)) (send canvas get-client-size xb yb))

11
collects/mred/private/wx/gtk/group-panel.rkt
View File

@ -13,15 +13,12 @@
(protect-out group-panel%)) (protect-out group-panel%))
(define-gtk gtk_frame_new (_fun _string -> _GtkWidget)) (define-gtk gtk_frame_new (_fun _string -> _GtkWidget))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-gtk gtk_frame_set_label (_fun _GtkWidget _string -> _void)) (define-gtk gtk_frame_set_label (_fun _GtkWidget _string -> _void))
(define-gtk gtk_frame_get_label_widget (_fun _GtkWidget -> _GtkWidget)) (define-gtk gtk_frame_get_label_widget (_fun _GtkWidget -> _GtkWidget))
(define group-panel% (define group-panel%
(class (client-size-mixin (panel-mixin window%)) (class (client-size-mixin (panel-container-mixin (panel-mixin window%)))
(init parent (init parent
x y w h x y w h
style style
@ -49,8 +46,4 @@
(define/public (set-label s) (define/public (set-label s)
(gtk_frame_set_label gtk s)) (gtk_frame_set_label gtk s))
(define/override (get-client-gtk) client-gtk) (define/override (get-client-gtk) client-gtk)))
(define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move client-gtk child-gtk x y)
(gtk_widget_set_size_request child-gtk w h))))

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

@ -10,7 +10,11 @@
(provide (provide
(protect-out panel% (protect-out panel%
panel-mixin)) panel-mixin
panel-container-mixin
gtk_fixed_new
gtk_fixed_move))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_event_box_new (_fun -> _GtkWidget)) (define-gtk gtk_event_box_new (_fun -> _GtkWidget))
@ -33,11 +37,13 @@
(send child set-parent this)) (send child set-parent this))
(define/override (reset-child-dcs) (define/override (reset-child-dcs)
(super reset-child-dcs)
(when (pair? children) (when (pair? children)
(for ([child (in-list children)]) (for ([child (in-list children)])
(send child reset-child-dcs)))) (send child reset-child-dcs))))
(define/override (paint-children) (define/override (paint-children)
(super paint-children)
(when (pair? children) (when (pair? children)
(for ([child (in-list children)]) (for ([child (in-list children)])
(send child paint-children)))) (send child paint-children))))
@ -56,8 +62,16 @@
(define/public (set-item-cursor x y) (void)))) (define/public (set-item-cursor x y) (void))))
(define (panel-container-mixin %)
(class %
(inherit get-container-gtk)
(super-new)
(define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move (get-container-gtk) child-gtk x y)
(gtk_widget_set_size_request child-gtk w h))))
(define panel% (define panel%
(class (panel-mixin window%) (class (panel-container-mixin (panel-mixin window%))
(init parent (init parent
x y w h x y w h
style style
@ -85,8 +99,4 @@
GDK_POINTER_MOTION_HINT_MASK GDK_POINTER_MOTION_HINT_MASK
GDK_FOCUS_CHANGE_MASK GDK_FOCUS_CHANGE_MASK
GDK_ENTER_NOTIFY_MASK GDK_ENTER_NOTIFY_MASK
GDK_LEAVE_NOTIFY_MASK)) GDK_LEAVE_NOTIFY_MASK))))
(define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move client-gtk child-gtk x y)
(gtk_widget_set_size_request child-gtk w h))))

1
collects/mred/private/wx/gtk/platform.rkt
View File

@ -30,6 +30,7 @@
(values (values
button% button%
canvas% canvas%
canvas-panel%
check-box% check-box%
choice% choice%
clipboard-driver% clipboard-driver%

11
collects/mred/private/wx/gtk/tab-panel.rkt
View File

@ -15,7 +15,6 @@
(protect-out tab-panel%)) (protect-out tab-panel%))
(define-gtk gtk_notebook_new (_fun -> _GtkWidget)) (define-gtk gtk_notebook_new (_fun -> _GtkWidget))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void)) (define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void))
(define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void)) (define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void))
@ -23,8 +22,6 @@
(define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int)) (define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int))
(define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void)) (define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void))
(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_widget_ref (_fun _GtkWidget -> _void)) (define-gtk gtk_widget_ref (_fun _GtkWidget -> _void))
@ -40,7 +37,7 @@
(send wx page-changed i))))) (send wx page-changed i)))))
(define tab-panel% (define tab-panel%
(class (client-size-mixin (panel-mixin window%)) (class (client-size-mixin (panel-container-mixin (panel-mixin window%)))
(init parent (init parent
x y w h x y w h
style style
@ -165,8 +162,4 @@
(define/public (set-selection i) (define/public (set-selection i)
(gtk_notebook_set_current_page gtk i)) (gtk_notebook_set_current_page gtk i))
(define/public (get-selection) (define/public (get-selection)
(gtk_notebook_get_current_page gtk)) (gtk_notebook_get_current_page gtk))))
(define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move client-gtk child-gtk x y)
(gtk_widget_set_size_request child-gtk w h))))

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

@ -418,10 +418,11 @@
(connect-size-allocate gtk) (connect-size-allocate gtk)
(when add-to-parent? (when add-to-parent?
(gtk_container_add (send parent get-client-gtk) gtk)) (gtk_container_add (send parent get-container-gtk) gtk))
(define/public (get-gtk) gtk) (define/public (get-gtk) gtk)
(define/public (get-client-gtk) gtk) (define/public (get-client-gtk) gtk)
(define/public (get-container-gtk) (get-client-gtk))
(define/public (get-window-gtk) (send parent get-window-gtk)) (define/public (get-window-gtk) (send parent get-window-gtk))
(define/public (move x y) (define/public (move x y)
@ -474,7 +475,7 @@
[creq (make-GtkRequisition 0 0)] [creq (make-GtkRequisition 0 0)]
[hreq (make-GtkRequisition 0 0)]) [hreq (make-GtkRequisition 0 0)])
(gtk_widget_size_request gtk req) (gtk_widget_size_request gtk req)
(gtk_widget_size_request (get-client-gtk) creq) (gtk_widget_size_request (get-container-gtk) creq)
(when sub-h-gtk (when sub-h-gtk
(gtk_widget_size_request sub-h-gtk hreq)) (gtk_widget_size_request sub-h-gtk hreq))
(when w? (when w?
@ -524,9 +525,9 @@
(define/public (set-parent p) (define/public (set-parent p)
;; in atomic mode ;; in atomic mode
(g_object_ref gtk) (g_object_ref gtk)
(gtk_container_remove (send parent get-client-gtk) gtk) (gtk_container_remove (send parent get-container-gtk) gtk)
(set! parent p) (set! parent p)
(gtk_container_add (send parent get-client-gtk) gtk) (gtk_container_add (send parent get-container-gtk) gtk)
(set! save-x 0) (set! save-x 0)
(set! save-y 0) (set! save-y 0)
(g_object_unref gtk)) (g_object_unref gtk))
@ -642,7 +643,7 @@
(define/public (on-drop-file path) (void)) (define/public (on-drop-file path) (void))
(define/public (get-handle) (get-gtk)) (define/public (get-handle) (get-gtk))
(define/public (get-client-handle) (get-client-gtk)) (define/public (get-client-handle) (get-container-gtk))
(define/public (popup-menu m x y) (define/public (popup-menu m x y)
(let ([gx (box x)] (let ([gx (box x)]

1
collects/mred/private/wx/platform.rkt
View File

@ -16,6 +16,7 @@
(define-values (button% (define-values (button%
canvas% canvas%
canvas-panel%
check-box% check-box%
choice% choice%
clipboard-driver% clipboard-driver%

2
collects/mred/private/wx/win32/button.rkt
View File

@ -57,7 +57,7 @@
[(bottom) BS_BOTTOM]) [(bottom) BS_BOTTOM])
0)) 0))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)] #f)]

88
collects/mred/private/wx/win32/canvas.rkt
View File

@ -18,10 +18,12 @@
"item.rkt" "item.rkt"
"hbitmap.rkt" "hbitmap.rkt"
"gcwin.rkt" "gcwin.rkt"
"theme.rkt") "theme.rkt"
"panel.rkt")
(provide (provide
(protect-out canvas%)) (protect-out canvas%
canvas-panel%))
(define WS_EX_STATICEDGE #x00020000) (define WS_EX_STATICEDGE #x00020000)
(define WS_EX_CLIENTEDGE #x00000200) (define WS_EX_CLIENTEDGE #x00000200)
@ -88,8 +90,10 @@
reset-auto-scroll reset-auto-scroll
refresh-for-autoscroll) refresh-for-autoscroll)
(define hscroll? (memq 'hscroll style)) (define hscroll? (or (memq 'hscroll style)
(define vscroll? (memq 'vscroll style)) (memq 'auto-hscroll style)))
(define vscroll? (or (memq 'vscroll style)
(memq 'auto-vscroll style)))
(define for-gl? (memq 'gl style)) (define for-gl? (memq 'gl style))
(define panel-hwnd (define panel-hwnd
@ -99,7 +103,7 @@
#f #f
(bitwise-ior WS_CHILD) (bitwise-ior WS_CHILD)
0 0 w h 0 0 w h
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f))) #f)))
@ -116,7 +120,7 @@
(if hscroll? WS_HSCROLL 0) (if hscroll? WS_HSCROLL 0)
(if vscroll? WS_VSCROLL 0)) (if vscroll? WS_VSCROLL 0))
0 0 w h 0 0 w h
(or panel-hwnd (send parent get-client-hwnd)) (or panel-hwnd (send parent get-content-hwnd))
#f #f
hInstance hInstance
#f)) #f))
@ -135,13 +139,28 @@
hInstance hInstance
#f))) #f)))
(define content-hwnd
(if (is-panel?)
(CreateWindowExW 0
"PLTTabPanel"
#f
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE)
0 0 w h
canvas-hwnd
#f
hInstance
#f)
canvas-hwnd))
(define hwnd (or panel-hwnd canvas-hwnd)) (define hwnd (or panel-hwnd canvas-hwnd))
(super-new [parent parent] (super-new [parent parent]
[hwnd hwnd] [hwnd hwnd]
[extra-hwnds (if panel-hwnd [extra-hwnds (if panel-hwnd
(list canvas-hwnd combo-hwnd) (list canvas-hwnd combo-hwnd)
null)] (if (eq? content-hwnd canvas-hwnd)
null
(list content-hwnd)))]
[style style]) [style style])
(when combo-hwnd (when combo-hwnd
@ -151,6 +170,9 @@
(and (memq 'control-border style) (and (memq 'control-border style)
(OpenThemeData canvas-hwnd "Edit"))) (OpenThemeData canvas-hwnd "Edit")))
(define/override (get-content-hwnd)
content-hwnd)
(define/override (wndproc w msg wParam lParam default) (define/override (wndproc w msg wParam lParam default)
(cond (cond
[(= msg WM_PAINT) [(= msg WM_PAINT)
@ -228,6 +250,15 @@
(get-virtual-v-pos) (get-virtual-v-pos)
0))) 0)))
(define/public (tell-me-what)
(let ([r (GetClientRect (get-client-hwnd))]
[rr (GetWindowRect (get-hwnd))])
(printf "~s\n"
(list hscroll? vscroll?
(list (RECT-left r) (RECT-top r) (RECT-right r) (RECT-bottom r))
(list (RECT-left rr) (RECT-top rr) (RECT-right rr) (RECT-bottom rr))))))
(define/override (show-children) (define/override (show-children)
(when (dc . is-a? . dc<%>) (when (dc . is-a? . dc<%>)
;; if the canvas was never shown, then it has never ;; if the canvas was never shown, then it has never
@ -338,10 +369,13 @@
(send col green) (send col green)
(send col blue))))) (send col blue)))))
(define wants-focus? (not (memq 'no-focus style))) (define wants-focus? (and (not (is-panel?))
(not (memq 'no-focus style))))
(define/override (can-accept-focus?) (define/override (can-accept-focus?)
wants-focus?) wants-focus?)
(define/public (is-panel?) #f)
(define h-scroll-visible? hscroll?) (define h-scroll-visible? hscroll?)
(define v-scroll-visible? vscroll?) (define v-scroll-visible? vscroll?)
(define/public (show-scrollbars h? v?) (define/public (show-scrollbars h? v?)
@ -462,6 +496,7 @@
(define/override (definitely-wants-event? w msg wParam e) (define/override (definitely-wants-event? w msg wParam e)
(cond (cond
[(is-panel?) #f]
[(e . is-a? . key-event%) [(e . is-a? . key-event%)
;; All key events to canvas, event for combo: ;; All key events to canvas, event for combo:
#t] #t]
@ -552,3 +587,40 @@
(set! reg-blits null)))))) (set! reg-blits null))))))
;; ----------------------------------------
(define canvas-panel%
(class (panel-mixin canvas%)
(inherit get-content-hwnd
get-client-hwnd
get-virtual-h-pos
get-virtual-v-pos)
(define/override (is-panel?) #t)
(define/override (notify-child-extent x y)
(let* ([content-hwnd (get-content-hwnd)]
[r (GetWindowRect content-hwnd)]
[w (- (RECT-right r) (RECT-left r))]
[h (- (RECT-bottom r) (RECT-top r))])
(when (or (> x w) (> y h))
(let ([pr (GetWindowRect (get-client-hwnd))])
(MoveWindow content-hwnd
(- (RECT-left r) (RECT-left pr))
(- (RECT-top r) (RECT-top pr))
(max w x) (max y h)
#t)))))
(define/override (reset-dc-for-autoscroll)
(super reset-dc-for-autoscroll)
(let* ([content-hwnd (get-content-hwnd)]
[r (GetWindowRect content-hwnd)]
[w (- (RECT-right r) (RECT-left r))]
[h (- (RECT-bottom r) (RECT-top r))])
(MoveWindow content-hwnd
(- (get-virtual-h-pos))
(- (get-virtual-v-pos))
w h
#t)))
(super-new)))

2
collects/mred/private/wx/win32/choice.rkt
View File

@ -33,7 +33,7 @@
WS_HSCROLL WS_VSCROLL WS_HSCROLL WS_VSCROLL
WS_BORDER WS_CLIPSIBLINGS) WS_BORDER WS_CLIPSIBLINGS)
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)) #f))

2
collects/mred/private/wx/win32/gauge.rkt
View File

@ -39,7 +39,7 @@
PBS_VERTICAL PBS_VERTICAL
0)) 0))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)) #f))

2
collects/mred/private/wx/win32/list-box.rkt
View File

@ -209,7 +209,7 @@
[(eq? kind 'multiple) 0] [(eq? kind 'multiple) 0]
[else LVS_SINGLESEL]))) [else LVS_SINGLESEL])))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)) #f))

2
collects/mred/private/wx/win32/message.rkt
View File

@ -90,7 +90,7 @@
SS_ICON SS_ICON
0))) 0)))
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)] #f)]

2
collects/mred/private/wx/win32/panel.rkt
View File

@ -110,7 +110,7 @@
#f #f
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS) (bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
0 0 w h 0 0 w h
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)] #f)]

1
collects/mred/private/wx/win32/platform.rkt
View File

@ -30,6 +30,7 @@
(values (values
button% button%
canvas% canvas%
canvas-panel%
check-box% check-box%
choice% choice%
clipboard-driver% clipboard-driver%

2
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -41,7 +41,7 @@
#f #f
(bitwise-ior WS_CHILD) (bitwise-ior WS_CHILD)
0 0 w h 0 0 w h
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)) #f))

4
collects/mred/private/wx/win32/slider.rkt
View File

@ -53,7 +53,7 @@
#f #f
(bitwise-ior WS_CHILD) (bitwise-ior WS_CHILD)
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f))) #f)))
@ -71,7 +71,7 @@
0)) 0))
0 0 0 0 0 0 0 0
(or panel-hwnd (or panel-hwnd
(send parent get-client-hwnd)) (send parent get-content-hwnd))
#f #f
hInstance hInstance
#f)) #f))

2
collects/mred/private/wx/win32/tab-panel.rkt
View File

@ -53,7 +53,7 @@
"" ""
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS) (bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0 0 0 0 0
(send parent get-client-hwnd) (send parent get-content-hwnd)
#f #f
hInstance hInstance
#f)) #f))

37
collects/mred/private/wx/win32/window.rkt
View File

@ -150,6 +150,7 @@
(define/public (get-hwnd) hwnd) (define/public (get-hwnd) hwnd)
(define/public (get-client-hwnd) hwnd) (define/public (get-client-hwnd) hwnd)
(define/public (get-content-hwnd) (get-client-hwnd))
(define/public (get-focus-hwnd) hwnd) (define/public (get-focus-hwnd) hwnd)
(define/public (get-eventspace) eventspace) (define/public (get-eventspace) eventspace)
@ -272,7 +273,7 @@
(define/public (on-set-focus) (void)) (define/public (on-set-focus) (void))
(define/public (on-kill-focus) (void)) (define/public (on-kill-focus) (void))
(define/public (get-handle) hwnd) (define/public (get-handle) hwnd)
(define/public (get-client-handle) (get-client-hwnd)) (define/public (get-client-handle) (get-content-hwnd))
(define enabled? #t) (define enabled? #t)
(define parent-enabled? #t) (define parent-enabled? #t)
@ -307,11 +308,11 @@
(define/public (get-x) (define/public (get-x)
(let ([r (GetWindowRect hwnd)] (let ([r (GetWindowRect hwnd)]
[pr (GetWindowRect (send parent get-client-hwnd))]) [pr (GetWindowRect (send parent get-content-hwnd))])
(- (RECT-left r) (RECT-left pr)))) (- (RECT-left r) (RECT-left pr))))
(define/public (get-y) (define/public (get-y)
(let ([r (GetWindowRect hwnd)] (let ([r (GetWindowRect hwnd)]
[pr (GetWindowRect (send parent get-client-hwnd))]) [pr (GetWindowRect (send parent get-content-hwnd))])
(- (RECT-top r) (RECT-top pr)))) (- (RECT-top r) (RECT-top pr))))
(define/public (get-width) (define/public (get-width)
@ -321,19 +322,23 @@
(let ([r (GetWindowRect hwnd)]) (let ([r (GetWindowRect hwnd)])
(- (RECT-bottom r) (RECT-top r)))) (- (RECT-bottom r) (RECT-top r))))
(define/public (notify-child-extent x y)
(void))
(define/public (set-size x y w h) (define/public (set-size x y w h)
(if (or (= x -11111) (let-values ([(x y w h)
(= y -11111) (if (or (= x -11111)
(= w -1) (= y -11111)
(= h -1)) (= w -1)
(let ([r (GetWindowRect hwnd)]) (= h -1))
(MoveWindow hwnd (let ([r (GetWindowRect hwnd)])
(if (= x -11111) (RECT-left r) x) (values (if (= x -11111) (RECT-left r) x)
(if (= y -11111) (RECT-top r) y) (if (= y -11111) (RECT-top r) y)
(if (= w -1) (- (RECT-right r) (RECT-left r)) w) (if (= w -1) (- (RECT-right r) (RECT-left r)) w)
(if (= h -1) (- (RECT-bottom r) (RECT-top r)) h) (if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)))
#t)) (values x y w h))])
(MoveWindow hwnd x y w h #t)) (when parent (send parent notify-child-extent (+ x w) (+ y h)))
(MoveWindow hwnd x y w h #t))
(unless (and (= w -1) (= h -1)) (unless (and (= w -1) (= h -1))
(on-resized)) (on-resized))
(queue-on-size) (queue-on-size)
@ -399,7 +404,7 @@
(define/public (set-parent p) (define/public (set-parent p)
;; in atomic mode ;; in atomic mode
(set! parent p) (set! parent p)
(SetParent hwnd (send parent get-client-hwnd))) (SetParent hwnd (send parent get-content-hwnd)))
(define/public (is-frame?) #f) (define/public (is-frame?) #f)

137
collects/mred/private/wxpanel.rkt
View File

@ -21,7 +21,10 @@
wx-pane% wx-pane%
wx-vertical-pane% wx-vertical-pane%
wx-horizontal-pane% wx-horizontal-pane%
wx-grow-box-pane%)) wx-grow-box-pane%
wx-canvas-panel%
wx-vertical-canvas-panel%
wx-horizontal-canvas-panel%))
(define wx:windowless-panel% (define wx:windowless-panel%
(class100 object% (prnt x y w h style label) (class100 object% (prnt x y w h style label)
@ -88,7 +91,19 @@
;; Needed for windowless panes ;; Needed for windowless panes
[move-children? #f] [move-children? #f]
[ignore-redraw-request? #f]) [ignore-redraw-request? #f]
[auto-scroll-x? (and (memq 'auto-hscroll style) #t)]
[auto-scroll-y? (and (memq 'auto-vscroll style) #t)]
[can-scroll-x? (or auto-scroll-x?
(and (memq 'hscroll style) #t))]
[can-scroll-y? (or auto-scroll-y?
(and (memq 'vscroll style) #t))]
[scroll-x? can-scroll-x?]
[scroll-y? can-scroll-y?])
(override (override
[has-tabbing-children? (lambda () #t)] [has-tabbing-children? (lambda () #t)]
@ -252,15 +267,19 @@
;; entire panel (not just client) as a list of two elements: ;; entire panel (not just client) as a list of two elements:
;; (min-x min-y). ;; (min-x min-y).
[do-graphical-size [do-graphical-size
(lambda (compute-x compute-y) (lambda (ignore-scroll? compute-x compute-y)
(letrec ([gms-help (letrec ([gms-help
(lambda (kid-info x-accum y-accum first?) (lambda (kid-info x-accum y-accum first?)
(if (null? kid-info) (if (null? kid-info)
(list x-accum y-accum) (list x-accum y-accum)
(gms-help (gms-help
(cdr kid-info) (cdr kid-info)
(compute-x x-accum kid-info (and hidden-child first?)) (if (and can-scroll-x? (not ignore-scroll?))
(compute-y y-accum kid-info (and hidden-child first?)) x-accum
(compute-x x-accum kid-info (and hidden-child first?)))
(if (and can-scroll-y? (not ignore-scroll?))
y-accum
(compute-y y-accum kid-info (and hidden-child first?)))
#f)))]) #f)))])
(let-values ([(client-w client-h) (let-values ([(client-w client-h)
(get-two-int-values (lambda (a b) (get-client-size a b)))]) (get-two-int-values (lambda (a b) (get-client-size a b)))])
@ -269,9 +288,9 @@
(gms-help (get-children-info) (gms-help (get-children-info)
(* 2 border) (* 2 border) (* 2 border) (* 2 border)
#t)] #t)]
[delta-w (- (get-width) client-w)] [delta-w (if ignore-scroll? 0 (- (get-width) client-w))]
[delta-h (- (get-height) client-h)]) [delta-h (if ignore-scroll? 0 (- (get-height) client-h))])
(list (+ delta-w (car min-client-size) (if hidden-child (* 2 tab-h-border) 0)) (list (+ delta-w (car min-client-size) (if hidden-child (* 2 tab-h-border) 0))
(+ delta-h (cadr min-client-size)))))))] (+ delta-h (cadr min-client-size)))))))]
;; do-get-min-graphical-size: poll children and return minimum possible ;; do-get-min-graphical-size: poll children and return minimum possible
@ -283,8 +302,9 @@
;; effects: none ;; effects: none
[get-graphical-min-size (lambda () (void))] [get-graphical-min-size (lambda () (void))]
[do-get-graphical-min-size [do-get-graphical-min-size
(lambda () (lambda ([ignore-scroll? #f])
(do-graphical-size (do-graphical-size
ignore-scroll?
(lambda (x-accum kid-info first?) (lambda (x-accum kid-info first?)
(max x-accum (+ (* 2 (border)) (max x-accum (+ (* 2 (border))
(child-info-x-min (car kid-info))))) (child-info-x-min (car kid-info)))))
@ -390,14 +410,47 @@
(force-redraw))] (force-redraw))]
[get-alignment (lambda () (values h-align v-align))] [get-alignment (lambda () (values h-align v-align))]
[adjust-panel-size (lambda (w h)
(if (or can-scroll-x? can-scroll-y?)
(let ([ms (do-get-graphical-min-size #t)])
;; loop for fix-point on x and y scroll
(let loop ([w w] [h h] [iters 0])
(let ([want-scroll-x?
(if auto-scroll-x?
((car ms) . > . w)
scroll-x?)]
[want-scroll-y?
(if auto-scroll-y?
((cadr ms) . > . h)
scroll-y?)])
(if (and (eq? scroll-x? want-scroll-x?)
(eq? scroll-y? want-scroll-y?))
(values (if can-scroll-x?
(max w (car ms))
w)
(if can-scroll-y?
(max h (cadr ms))
h))
(begin
(set! scroll-x? want-scroll-x?)
(set! scroll-y? want-scroll-y?)
(send this show-scrollbars scroll-x? scroll-y?)
(let-values ([(w h)
(get-two-int-values (lambda (a b) (get-client-size a b)))])
(if (= iters 2)
(values w h)
(loop w h (add1 iters)))))))))
(values w h)))]
;; redraw: redraws panel and all children ;; redraw: redraws panel and all children
;; input: width, height: size of area area in panel. ;; input: width, height: size of area area in panel.
;; returns: nothing ;; returns: nothing
;; effects: places children at default positions in panel. ;; effects: places children at default positions in panel.
[redraw [redraw
(lambda (width height) (lambda (in-width in-height)
(let ([children-info (get-children-info)] (let-values ([(children-info) (get-children-info)]
[children children]) ; keep list of children matching children-info [(children) children] ; keep list of children matching children-info
[(width height) (adjust-panel-size in-width in-height)])
(let ([l (place-children (map (lambda (i) (let ([l (place-children (map (lambda (i)
(list (child-info-x-min i) (child-info-y-min i) (list (child-info-x-min i) (child-info-y-min i)
(child-info-x-stretch i) (child-info-y-stretch i))) (child-info-x-stretch i) (child-info-y-stretch i)))
@ -431,6 +484,36 @@
l)))))] l)))))]
[panel-redraw [panel-redraw
(lambda (childs child-infos placements) (lambda (childs child-infos placements)
(when (or scroll-y? scroll-x?)
(let ([w (if scroll-x?
(+ (for/fold ([x 0]) ([p (in-list placements)]
[i (in-list child-infos)])
(max x (+ (max 0 (car p))
(max (+ (child-info-x-min i)
(* 2 (child-info-x-margin i)))
(caddr p)))))
(* 2 (border)))
0)]
[h (if scroll-y?
(+ (for/fold ([y 0]) ([p (in-list placements)]
[i (in-list child-infos)])
(max y (+ (max 0 (cadr p))
(max (+ (child-info-y-min i)
(* 2 (child-info-y-margin i)))
(cadddr p)))))
(* 2 (border)))
0)]
[wb (box 0)]
[hb (box 0)])
(get-client-size wb hb)
(let ([do-x-scroll? (w . > . (unbox wb))]
[do-y-scroll? (h . > . (unbox hb))])
(send this set-scrollbars
(if do-x-scroll? 1 0) (if do-y-scroll? 1 0)
w h
(unbox wb) (unbox hb)
-1 -1
#t))))
(for-each (for-each
(lambda (child info placement) (lambda (child info placement)
(let-values ([(x y w h) (apply values placement)]) (let-values ([(x y w h) (apply values placement)])
@ -451,7 +534,10 @@
child-infos child-infos
placements))]) placements))])
(sequence (sequence
(super-init style parent -1 -1 0 0 (cons 'deleted style) label) (super-init style parent -1 -1
(if can-scroll-y? 20 (if can-scroll-x? 1 0))
(if can-scroll-x? 20 (if can-scroll-y? 1 0))
(cons 'deleted style) label)
(unless (memq 'deleted style) (unless (memq 'deleted style)
(send (get-top-level) show-control this #t))))) (send (get-top-level) show-control this #t)))))
@ -499,7 +585,7 @@
[minor-align-pos 'center]) [minor-align-pos 'center])
(inherit force-redraw border get-width get-height (inherit force-redraw border get-width get-height
get-graphical-min-size) do-get-graphical-min-size)
(private-field [curr-spacing const-default-spacing]) (private-field [curr-spacing const-default-spacing])
(override (override
[spacing [spacing
@ -565,17 +651,12 @@
(count-stretchable (cdr kid-info))))))]) (count-stretchable (cdr kid-info))))))])
(let* ([spacing (spacing)] (let* ([spacing (spacing)]
[border (border)] [border (border)]
[full-w (get-width)]
[full-h (get-height)]
[delta-list (list
(- full-w width)
(- full-h height))]
[num-stretchable (count-stretchable kid-info)] [num-stretchable (count-stretchable kid-info)]
[extra-space (- (major-dim width height) [extra-space (max 0
(- (apply (- (major-dim width height)
major-dim (apply
(get-graphical-min-size)) major-dim
(apply major-dim delta-list)))] (do-get-graphical-min-size #t))))]
[extra-per-stretchable (if (zero? num-stretchable) [extra-per-stretchable (if (zero? num-stretchable)
0 0
(inexact->exact (inexact->exact
@ -657,9 +738,10 @@
[get-alignment (λ () (do-get-alignment (if horizontal? (λ (x y) x) (λ (x y) y))))] [get-alignment (λ () (do-get-alignment (if horizontal? (λ (x y) x) (λ (x y) y))))]
[do-get-graphical-min-size [do-get-graphical-min-size
(lambda () (lambda ([ignore-scroll? #f])
(if horizontal? (if horizontal?
(do-graphical-size (do-graphical-size
ignore-scroll?
(lambda (x-accum kid-info hidden?) (lambda (x-accum kid-info hidden?)
(+ x-accum (child-info-x-min (car kid-info)) (+ x-accum (child-info-x-min (car kid-info))
(if (or hidden? (null? (cdr kid-info))) (if (or hidden? (null? (cdr kid-info)))
@ -670,6 +752,7 @@
(+ (child-info-y-min (car kid-info)) (+ (child-info-y-min (car kid-info))
(* 2 (border)))))) (* 2 (border))))))
(do-graphical-size (do-graphical-size
ignore-scroll?
(lambda (x-accum kid-info hidden?) (lambda (x-accum kid-info hidden?)
(max x-accum (max x-accum
(+ (child-info-x-min (car kid-info)) (+ (child-info-x-min (car kid-info))
@ -725,9 +808,11 @@
(define wx-panel% (wx-make-panel% wx:panel%)) (define wx-panel% (wx-make-panel% wx:panel%))
(define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin)) (define wx-control-panel% (wx-make-panel% wx:panel% const-default-x-margin const-default-y-margin))
(define wx-canvas-panel% (wx-make-panel% wx:canvas-panel%))
(define wx-tab-panel% (wx-make-panel% wx:tab-panel%)) (define wx-tab-panel% (wx-make-panel% wx:tab-panel%))
(define wx-group-panel% (wx-make-panel% wx:group-panel%)) (define wx-group-panel% (wx-make-panel% wx:group-panel%))
(define wx-linear-panel% (wx-make-linear-panel% wx-panel%)) (define wx-linear-panel% (wx-make-linear-panel% wx-panel%))
(define wx-linear-canvas-panel% (wx-make-linear-panel% wx-canvas-panel%))
(define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%)) (define wx-control-linear-panel% (wx-make-linear-panel% wx-control-panel%))
(define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%)) (define wx-linear-tab-panel% (wx-make-linear-panel% wx-tab-panel%))
(define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%)) (define wx-linear-group-panel% (wx-make-linear-panel% wx-group-panel%))
@ -736,6 +821,8 @@
(define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%)) (define wx-vertical-tab-panel% (wx-make-vertical-panel% wx-linear-tab-panel%))
(define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%)) (define wx-vertical-group-panel% (wx-make-vertical-panel% wx-linear-group-panel%))
(define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%)) (define wx-control-horizontal-panel% (wx-make-horizontal-panel% wx-control-linear-panel%))
(define wx-horizontal-canvas-panel% (wx-make-horizontal-panel% wx-linear-canvas-panel%))
(define wx-vertical-canvas-panel% (wx-make-vertical-panel% wx-linear-canvas-panel%))
(define wx-pane% (wx-make-pane% wx:windowless-panel% #t)) (define wx-pane% (wx-make-pane% wx:windowless-panel% #t))
(define wx-grow-box-pane% (define wx-grow-box-pane%

8
collects/scribblings/gui/horizontal-panel-class.scrbl
View File

@ -8,7 +8,9 @@ A horizontal panel arranges its subwindows in a single row. See also
@defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%) @defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
(is-a?/c panel%) (is-a?/c pane%))] (is-a?/c panel%) (is-a?/c pane%))]
[style (listof (one-of/c 'border 'deleted)) null] [style (listof (one-of/c 'border 'deleted
'hscroll 'auto-hscroll
'vscroll 'auto-vscroll)) null]
[enabled any/c #t] [enabled any/c #t]
[vert-margin (integer-in 0 1000) 0] [vert-margin (integer-in 0 1000) 0]
[horiz-margin (integer-in 0 1000) 0] [horiz-margin (integer-in 0 1000) 0]
@ -22,9 +24,7 @@ A horizontal panel arranges its subwindows in a single row. See also
[stretchable-width any/c #t] [stretchable-width any/c #t]
[stretchable-height any/c #t])]{ [stretchable-height any/c #t])]{
If the @scheme['border] style is specified, the window is created with The @racket[style] flags are the same as for @racket[panel%].
a thin border (only in this case, the client size of the panel may be
less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel}
@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
} }

17
collects/scribblings/gui/panel-class.scrbl
View File

@ -17,7 +17,9 @@ A @scheme[panel%] object has a degenerate placement strategy for
@defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%) @defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
(is-a?/c panel%) (is-a?/c pane%))] (is-a?/c panel%) (is-a?/c pane%))]
[style (listof (one-of/c 'border 'deleted)) null] [style (listof (one-of/c 'border 'deleted
'hscroll 'auto-hscroll
'vscroll 'auto-vscroll)) null]
[enabled any/c #t] [enabled any/c #t]
[vert-margin (integer-in 0 1000) 0] [vert-margin (integer-in 0 1000) 0]
[horiz-margin (integer-in 0 1000) 0] [horiz-margin (integer-in 0 1000) 0]
@ -32,9 +34,20 @@ A @scheme[panel%] object has a degenerate placement strategy for
[stretchable-height any/c #t])]{ [stretchable-height any/c #t])]{
If the @scheme['border] style is specified, the window is created with If the @scheme['border] style is specified, the window is created with
a thin border (only in this case, the client size of the panel may be a thin border (in which case the client size of the panel may be
less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel} less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel}
If the @racket['hscroll] or @racket['vscroll] style is specified, then
the panel includes a scrollbar in the corresponding direction, and
the panel's own size in the corresponding direction is not
constrained by the size of its children subareas. The @racket['auto-hscroll]
and @racket['auto-vscroll] styles are like @racket['hscroll] or
@racket['vscroll], but they cause the corresponding scrollbar to
disappear when no scrolling is needed in the corresponding direction;
the @racket['auto-vscroll] and @racket['auto-hscroll] modes assume that
children subareas are placed using the default algorithm for a @racket[panel%],
@racket[vertical-panel%], or @racket[horizontal-panel%].
@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
}} }}

8
collects/scribblings/gui/vertical-panel-class.scrbl
View File

@ -11,7 +11,9 @@ A vertical panel arranges its subwindows in a single column. See
@defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%) @defconstructor[([parent (or/c (is-a?/c frame%) (is-a?/c dialog%)
(is-a?/c panel%) (is-a?/c pane%))] (is-a?/c panel%) (is-a?/c pane%))]
[style (listof (one-of/c 'border 'deleted)) null] [style (listof (one-of/c 'border 'deleted
'hscroll 'auto-hscroll
'vscroll 'auto-vscroll)) null]
[enabled any/c #t] [enabled any/c #t]
[vert-margin (integer-in 0 1000) 0] [vert-margin (integer-in 0 1000) 0]
[horiz-margin (integer-in 0 1000) 0] [horiz-margin (integer-in 0 1000) 0]
@ -25,9 +27,7 @@ A vertical panel arranges its subwindows in a single column. See
[stretchable-width any/c #t] [stretchable-width any/c #t]
[stretchable-height any/c #t])]{ [stretchable-height any/c #t])]{
If the @scheme['border] style is specified, the window is created with The @racket[style] flags are the same as for @racket[panel%].
a thin border (only in this case, the client size of the panel may be
less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel}
@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
} }

54
collects/tests/gracket/item.rkt
View File

@ -38,10 +38,10 @@
style)) style))
(define make-frame (define make-frame
(opt-lambda (% name [parent #f] [x #f] [y #f] [w #f] [h #f] [style '()]) (opt-lambda (% name [parent #f] [w #f] [h #f] [x #f] [y #f] [style '()])
(make-object % name (make-object % name
(or parent mdi-frame default-parent-frame) (or parent mdi-frame default-parent-frame)
x y w h w h x y
(if mdi-frame (if mdi-frame
(cons 'mdi-child style) (cons 'mdi-child style)
(add-frame-style style))))) (add-frame-style style)))))
@ -564,18 +564,20 @@
(define float-frame? #f) (define float-frame? #f)
(define no-caption? #f) (define no-caption? #f)
(define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?) (define (big-frame h-radio? v-label? null-label? stretchy? font initially-disabled?
alternate-init? msg-auto? panel-style)
(define f (make-frame (if use-dialogs? (define f (make-frame (if use-dialogs?
active-dialog% active-dialog%
active-frame%) active-frame%)
"T\u03A3ster")) ; \u03A3 is eta "T\u03A3ster" ; \u03A3 is eta
#f #f 100))
(define hp (make-object horizontal-panel% f)) (define hp (make-object horizontal-panel% f))
(define ip (make-object vertical-panel% hp)) (define ip (new vertical-panel% [parent hp] [style panel-style]))
(define cp (make-object vertical-panel% hp)) (define cp (new vertical-panel% [parent hp] [style panel-style]))
(define ep (make-object vertical-panel% hp)) (define ep (new vertical-panel% [parent hp] [style panel-style]))
(define lp (make-object vertical-panel% hp)) (define lp (new vertical-panel% [parent hp] [style panel-style]))
(define (basic-add-testers name w) (define (basic-add-testers name w)
(add-hide name w cp) (add-hide name w cp)
@ -618,18 +620,20 @@
(set! prev-frame f) (set! prev-frame f)
f) f)
(define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled? alternate-init? msg-auto?) (define (med-frame plain-slider? label-h? null-label? stretchy? font initially-disabled?
alternate-init? msg-auto? panel-style)
(define f2 (make-frame (if use-dialogs? (define f2 (make-frame (if use-dialogs?
active-dialog% active-dialog%
active-frame%) active-frame%)
"Tester2")) "Tester2"
#f #f 100))
(define hp2 (make-object horizontal-panel% f2)) (define hp2 (make-object horizontal-panel% f2))
(define ip2-0 (make-object vertical-panel% hp2)) (define ip2-0 (new vertical-panel% [parent hp2] [style panel-style]))
(define cp2 (make-object vertical-panel% hp2)) (define cp2 (new vertical-panel% [parent hp2] [style panel-style]))
(define ep2 (make-object vertical-panel% hp2)) (define ep2 (new vertical-panel% [parent hp2] [style panel-style]))
(define lp2 (make-object vertical-panel% hp2)) (define lp2 (new vertical-panel% [parent hp2] [style panel-style]))
(define (basic-add-testers2 name w) (define (basic-add-testers2 name w)
(add-hide name w cp2) (add-hide name w cp2)
@ -2515,13 +2519,33 @@
(positive? (send enabled-radio get-selection)) (positive? (send enabled-radio get-selection))
(positive? (send selection-radio get-selection)) (positive? (send selection-radio get-selection))
(and message-auto (and message-auto
(send message-auto get-value)))))) (send message-auto get-value))
(append
(case (send panel-h-mode get-selection)
[(0) '()]
[(1) '(hscroll)]
[(2) '(auto-hscroll)])
(case (send panel-v-mode get-selection)
[(0) '()]
[(1) '(vscroll)]
[(2) '(auto-vscroll)]))))))
(define message-auto (define message-auto
(and msg? (and msg?
(new check-box% (new check-box%
[parent p2] [parent p2]
[label "Auto-Size Message"]))) [label "Auto-Size Message"])))
(define panel-h-mode
(new choice%
[parent p2]
[label "Panels"]
[choices '("No HScroll" "HScroll" "Auto HScroll")]))
(define panel-v-mode
(new choice%
[parent p2]
[label "Panels"]
[choices '("No VScroll" "VScroll" "Auto VScroll")]))
#t)) #t))

3
doc/release-notes/racket/HISTORY.txt
View File

@ -3,6 +3,9 @@ Enabled single-precision floats by default
Added single-flonum? Added single-flonum?
Changed eqv? so that inexacts are equivalent only when they Changed eqv? so that inexacts are equivalent only when they
have the same precision have the same precision
racket/gui: added multi-column support to list-box%
racket/gui: added scrollbar support to panel%, vertical-panel%,
and horizontal-panel%
Version 5.1, February 2011 Version 5.1, February 2011
Renamed "proxy" to "impersonator" Renamed "proxy" to "impersonator"