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 horizontal-panel%) 'horizontal-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-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
(lambda ()
(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%]
[(group-box-panel) wx-vertical-group-panel%]
[(horizontal-panel) wx-horizontal-panel%]
[else wx-panel%])
this this (mred->wx-container parent) style
[(horizontal-panel)
(if (as-canvas?)
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)))
wx)
(lambda () wx)

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

@ -17,6 +17,7 @@
"item.rkt"
"gc.rkt"
"image.rkt"
"panel.rkt"
"../common/backing-dc.rkt"
"../common/canvas-mixin.rkt"
"../common/event.rkt"
@ -26,7 +27,8 @@
"../common/freeze.rkt")
(provide
(protect-out canvas%))
(protect-out canvas%
canvas-panel%))
;; ----------------------------------------
@ -60,7 +62,7 @@
(tellv ctx restoreGraphicsState)))))))
(define-objc-mixin (MyViewMixin Superclass)
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
#:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder)
[wxb]
(-a _void (drawRect: [_NSRect r])
(when wxb
@ -247,12 +249,17 @@
refresh-for-autoscroll
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 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 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 has-control-border? (and (not is-combo?)
(memq 'control-border style)))
@ -340,11 +347,12 @@
(define content-cocoa
(let ([r (make-NSRect (make-NSPoint 0 0)
(make-NSSize (max 0 (- w (* 2 x-margin)))
(max 0 (- h (* 2 y-margin)))))])
(make-NSSize (max 0 (- w (if vscroll? scroll-width 0) (* 2 x-margin)))
(max 0 (- h (if hscroll? scroll-width 0) (* 2 y-margin)))))])
(as-objc-allocation
(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)
(let ([pf (gl-config->pixel-format gl-config)])
(begin0
@ -366,6 +374,8 @@
(queue-paint)
(define/public (is-panel?) #f)
(define/public (get-dc) dc)
(define/public (make-compatible-bitmap w h)
@ -453,7 +463,8 @@
(is-shown-to-root?))
(atomically (resume-all-reg-blits)))
(fix-dc)
(when (is-auto-scroll?)
(when (and (is-auto-scroll?)
(not (is-panel?)))
(reset-auto-scroll 0 0))
(on-size))
@ -488,12 +499,14 @@
h-pos v-pos)
(scroll-range h-scroller h-len)
(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
(tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
(scroll-range v-scroller v-len)
(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
(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)
(update which scroll-pos v))
(define/private (guard-scroll which v)
(define/private (guard-scroll skip-guard? which v)
(if skip-guard?
v
(if (is-auto-scroll?)
0
v))
v)))
(define/public (get-scroll-page which)
(guard-scroll which
(define/public (get-scroll-page which [skip-guard? #f])
(guard-scroll skip-guard?
which
(scroll-page (if (eq? which 'vertical) v-scroller h-scroller))))
(define/public (get-scroll-range which)
(guard-scroll which
(define/public (get-scroll-range which [skip-guard? #f])
(guard-scroll skip-guard?
which
(scroll-range (if (eq? which 'vertical) v-scroller h-scroller))))
(define/public (get-scroll-pos which)
(guard-scroll which
(define/public (get-scroll-pos which [skip-guard? #f])
(guard-scroll skip-guard?
which
(scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))))
(define v-scroller
@ -680,18 +698,18 @@
(let ([kind
(cond
[(= part NSScrollerDecrementPage)
(set-scroll-pos direction (- (get-scroll-pos direction)
(get-scroll-page direction)))
(set-scroll-pos direction (- (get-scroll-pos direction #t)
(get-scroll-page direction #t)))
'page-up]
[(= part NSScrollerIncrementPage)
(set-scroll-pos direction (+ (get-scroll-pos direction)
(get-scroll-page direction)))
(set-scroll-pos direction (+ (get-scroll-pos direction #t)
(get-scroll-page direction #t)))
'page-down]
[(= part NSScrollerDecrementLine)
(set-scroll-pos direction (- (get-scroll-pos direction) 1))
(set-scroll-pos direction (- (get-scroll-pos direction #t) 1))
'line-up]
[(= part NSScrollerIncrementLine)
(set-scroll-pos direction (+ (get-scroll-pos direction) 1))
(set-scroll-pos direction (+ (get-scroll-pos direction #t) 1))
'line-down]
[(= part NSScrollerKnob)
'thumb]
@ -715,10 +733,11 @@
(e . is-a? . mouse-event%)
(send e button-down? 'left))
(set-focus))
(and (not (is-panel?))
(or (not is-combo?)
(e . is-a? . key-event%)
(not (send e button-down? 'left))
(not (on-menu-click? e))))
(not (on-menu-click? e)))))
(define/override (gets-focus?)
wants-focus?)
@ -843,3 +862,20 @@
(atomically
(suspend-all-reg-blits)
(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)))

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

@ -35,6 +35,7 @@
(send p set-parent this))
(define/override (fix-dc)
(super fix-dc)
(for ([child (in-list children)])
(send child fix-dc)))
@ -59,6 +60,7 @@
(send child child-accept-drag on?)))
(define/override (enable-window on?)
(super enable-window on?)
(let ([on? (and on? (is-window-enabled?))])
(for ([child (in-list children)])
(send child enable-window on?))))

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

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

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

@ -20,10 +20,12 @@
"gl-context.rkt"
"combo.rkt"
"pixbuf.rkt"
"gcwin.rkt")
"gcwin.rkt"
"panel.rkt")
(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_fixed_set_has_window (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget))
(define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget))
@ -186,14 +190,16 @@
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)])
(when wx
(if wx
(begin
(unless (send wx paint-or-queue-paint)
(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))))))
#t))
(gdk_gc_unref gc))))
(not (send wx is-panel?)))
#f))))
(define-signal-handler connect-expose-border "expose-event"
(_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
@ -253,17 +259,28 @@
(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
combo-button-gtk
scroll-width)
(atomically ;; need to connect all children to gtk to avoid leaks
(cond
[(or (memq 'hscroll style)
(memq 'vscroll style))
(let* ([client-gtk (gtk_drawing_area_new)]
(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)])
[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))]
[v (gtk_vbox_new #f 0)]
[v2 (gtk_vbox_new #f 0)]
@ -278,6 +295,8 @@
;; | | [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))
(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 h2 hscroll #t #t 0)
(gtk_box_pack_start v2 resize-box #f #f 0)
(when (memq 'hscroll style)
(when hs?
(gtk_widget_show hscroll))
(gtk_widget_show vscroll)
(gtk_widget_show h)
(gtk_widget_show v)
(when (memq 'vscroll style)
(when vs?
(gtk_widget_show v2))
(gtk_widget_show h2)
(when (memq 'hscroll style)
(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 h hadj vadj
(and (memq 'hscroll style) h2)
(and (memq 'vscroll style) v2)
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
(values client-gtk container-gtk 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 #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?
(let ([client-gtk (gtk_drawing_area_new)]
[h (as-gtk-allocation (gtk_hbox_new #f 0))])
@ -318,22 +340,26 @@
(gtk_container_set_border_width h margin)
(connect-expose-border h)
(gtk_widget_show client-gtk)
(values client-gtk h #f #f #f #f #f #f 0))]
(values client-gtk client-gtk h #f #f #f #f #f #f 0))]
[else
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
(values client-gtk client-gtk #f #f #f #f #f #f 0))])))
(values client-gtk client-gtk client-gtk #f #f #f #f #f #f 0))])))
(super-new [parent parent]
[gtk gtk]
[client-gtk client-gtk]
[no-show? (memq 'deleted style)]
[extra-gtks (if (eq? client-gtk gtk)
[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))))])
(list client-gtk)))))])
(set-size x y w h)
@ -369,7 +395,8 @@
GDK_FOCUS_CHANGE_MASK
GDK_ENTER_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)
GTK_CAN_FOCUS)))
(when combo-button-gtk
@ -380,14 +407,18 @@
(set-auto-size)
(adjust-client-delta (+ (* 2 margin)
(if (memq 'vscroll style)
(if (or (memq 'vscroll style)
(memq 'auto-vscroll style))
scroll-width
0))
(+ (* 2 margin)
(if (memq 'hscroll style)
(if (or (memq 'hscroll style)
(memq 'auto-hscroll style))
scroll-width
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
@ -399,6 +430,7 @@
(send dc make-backing-bitmap w h))
(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)
@ -528,7 +560,10 @@
(lambda ()
(if (zero? len)
(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
h-len v-len
@ -741,3 +776,33 @@
(g_object_unref (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)
(+ 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)
(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
-1
(GdkVisual-rec-depth
@ -126,7 +126,7 @@
(send canvas get-canvas-background))
(make-object win32-bitmap% w h (widget-window (send canvas get-client-gtk)))]
[else
(super make-backing-bitmap w h)]))
(super make-backing-bitmap (max 1 w) (max 1 h))]))
(define/override (get-backing-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%))
(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_get_label_widget (_fun _GtkWidget -> _GtkWidget))
(define group-panel%
(class (client-size-mixin (panel-mixin window%))
(class (client-size-mixin (panel-container-mixin (panel-mixin window%)))
(init parent
x y w h
style
@ -49,8 +46,4 @@
(define/public (set-label s)
(gtk_frame_set_label gtk s))
(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))))
(define/override (get-client-gtk) client-gtk)))

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

@ -10,7 +10,11 @@
(provide
(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_event_box_new (_fun -> _GtkWidget))
@ -33,11 +37,13 @@
(send child set-parent this))
(define/override (reset-child-dcs)
(super reset-child-dcs)
(when (pair? children)
(for ([child (in-list children)])
(send child reset-child-dcs))))
(define/override (paint-children)
(super paint-children)
(when (pair? children)
(for ([child (in-list children)])
(send child paint-children))))
@ -56,8 +62,16 @@
(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%
(class (panel-mixin window%)
(class (panel-container-mixin (panel-mixin window%))
(init parent
x y w h
style
@ -85,8 +99,4 @@
GDK_POINTER_MOTION_HINT_MASK
GDK_FOCUS_CHANGE_MASK
GDK_ENTER_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))))
GDK_LEAVE_NOTIFY_MASK))))

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

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

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

@ -15,7 +15,6 @@
(protect-out tab-panel%))
(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_remove_page (_fun _GtkWidget _int -> _void))
@ -23,8 +22,6 @@
(define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int))
(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_widget_ref (_fun _GtkWidget -> _void))
@ -40,7 +37,7 @@
(send wx page-changed i)))))
(define tab-panel%
(class (client-size-mixin (panel-mixin window%))
(class (client-size-mixin (panel-container-mixin (panel-mixin window%)))
(init parent
x y w h
style
@ -165,8 +162,4 @@
(define/public (set-selection i)
(gtk_notebook_set_current_page gtk i))
(define/public (get-selection)
(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))))
(gtk_notebook_get_current_page gtk))))

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

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

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

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

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

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

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

@ -18,10 +18,12 @@
"item.rkt"
"hbitmap.rkt"
"gcwin.rkt"
"theme.rkt")
"theme.rkt"
"panel.rkt")
(provide
(protect-out canvas%))
(protect-out canvas%
canvas-panel%))
(define WS_EX_STATICEDGE #x00020000)
(define WS_EX_CLIENTEDGE #x00000200)
@ -88,8 +90,10 @@
reset-auto-scroll
refresh-for-autoscroll)
(define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style))
(define hscroll? (or (memq 'hscroll style)
(memq 'auto-hscroll style)))
(define vscroll? (or (memq 'vscroll style)
(memq 'auto-vscroll style)))
(define for-gl? (memq 'gl style))
(define panel-hwnd
@ -99,7 +103,7 @@
#f
(bitwise-ior WS_CHILD)
0 0 w h
(send parent get-client-hwnd)
(send parent get-content-hwnd)
#f
hInstance
#f)))
@ -116,7 +120,7 @@
(if hscroll? WS_HSCROLL 0)
(if vscroll? WS_VSCROLL 0))
0 0 w h
(or panel-hwnd (send parent get-client-hwnd))
(or panel-hwnd (send parent get-content-hwnd))
#f
hInstance
#f))
@ -135,13 +139,28 @@
hInstance
#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))
(super-new [parent parent]
[hwnd hwnd]
[extra-hwnds (if panel-hwnd
(list canvas-hwnd combo-hwnd)
null)]
(if (eq? content-hwnd canvas-hwnd)
null
(list content-hwnd)))]
[style style])
(when combo-hwnd
@ -151,6 +170,9 @@
(and (memq 'control-border style)
(OpenThemeData canvas-hwnd "Edit")))
(define/override (get-content-hwnd)
content-hwnd)
(define/override (wndproc w msg wParam lParam default)
(cond
[(= msg WM_PAINT)
@ -228,6 +250,15 @@
(get-virtual-v-pos)
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)
(when (dc . is-a? . dc<%>)
;; if the canvas was never shown, then it has never
@ -338,10 +369,13 @@
(send col green)
(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?)
wants-focus?)
(define/public (is-panel?) #f)
(define h-scroll-visible? hscroll?)
(define v-scroll-visible? vscroll?)
(define/public (show-scrollbars h? v?)
@ -462,6 +496,7 @@
(define/override (definitely-wants-event? w msg wParam e)
(cond
[(is-panel?) #f]
[(e . is-a? . key-event%)
;; All key events to canvas, event for combo:
#t]
@ -552,3 +587,40 @@
(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_BORDER WS_CLIPSIBLINGS)
0 0 0 0
(send parent get-client-hwnd)
(send parent get-content-hwnd)
#f
hInstance
#f))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -21,7 +21,10 @@
wx-pane%
wx-vertical-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%
(class100 object% (prnt x y w h style label)
@ -88,7 +91,19 @@
;; Needed for windowless panes
[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
[has-tabbing-children? (lambda () #t)]
@ -252,15 +267,19 @@
;; entire panel (not just client) as a list of two elements:
;; (min-x min-y).
[do-graphical-size
(lambda (compute-x compute-y)
(lambda (ignore-scroll? compute-x compute-y)
(letrec ([gms-help
(lambda (kid-info x-accum y-accum first?)
(if (null? kid-info)
(list x-accum y-accum)
(gms-help
(cdr kid-info)
(compute-x x-accum kid-info (and hidden-child first?))
(compute-y y-accum kid-info (and hidden-child first?))
(if (and can-scroll-x? (not ignore-scroll?))
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)))])
(let-values ([(client-w client-h)
(get-two-int-values (lambda (a b) (get-client-size a b)))])
@ -269,8 +288,8 @@
(gms-help (get-children-info)
(* 2 border) (* 2 border)
#t)]
[delta-w (- (get-width) client-w)]
[delta-h (- (get-height) client-h)])
[delta-w (if ignore-scroll? 0 (- (get-width) client-w))]
[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))
(+ delta-h (cadr min-client-size)))))))]
@ -283,8 +302,9 @@
;; effects: none
[get-graphical-min-size (lambda () (void))]
[do-get-graphical-min-size
(lambda ()
(lambda ([ignore-scroll? #f])
(do-graphical-size
ignore-scroll?
(lambda (x-accum kid-info first?)
(max x-accum (+ (* 2 (border))
(child-info-x-min (car kid-info)))))
@ -390,14 +410,47 @@
(force-redraw))]
[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
;; input: width, height: size of area area in panel.
;; returns: nothing
;; effects: places children at default positions in panel.
[redraw
(lambda (width height)
(let ([children-info (get-children-info)]
[children children]) ; keep list of children matching children-info
(lambda (in-width in-height)
(let-values ([(children-info) (get-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)
(list (child-info-x-min i) (child-info-y-min i)
(child-info-x-stretch i) (child-info-y-stretch i)))
@ -431,6 +484,36 @@
l)))))]
[panel-redraw
(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
(lambda (child info placement)
(let-values ([(x y w h) (apply values placement)])
@ -451,7 +534,10 @@
child-infos
placements))])
(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)
(send (get-top-level) show-control this #t)))))
@ -499,7 +585,7 @@
[minor-align-pos 'center])
(inherit force-redraw border get-width get-height
get-graphical-min-size)
do-get-graphical-min-size)
(private-field [curr-spacing const-default-spacing])
(override
[spacing
@ -565,17 +651,12 @@
(count-stretchable (cdr kid-info))))))])
(let* ([spacing (spacing)]
[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)]
[extra-space (- (major-dim width height)
(- (apply
[extra-space (max 0
(- (major-dim width height)
(apply
major-dim
(get-graphical-min-size))
(apply major-dim delta-list)))]
(do-get-graphical-min-size #t))))]
[extra-per-stretchable (if (zero? num-stretchable)
0
(inexact->exact
@ -657,9 +738,10 @@
[get-alignment (λ () (do-get-alignment (if horizontal? (λ (x y) x) (λ (x y) y))))]
[do-get-graphical-min-size
(lambda ()
(lambda ([ignore-scroll? #f])
(if horizontal?
(do-graphical-size
ignore-scroll?
(lambda (x-accum kid-info hidden?)
(+ x-accum (child-info-x-min (car kid-info))
(if (or hidden? (null? (cdr kid-info)))
@ -670,6 +752,7 @@
(+ (child-info-y-min (car kid-info))
(* 2 (border))))))
(do-graphical-size
ignore-scroll?
(lambda (x-accum kid-info hidden?)
(max x-accum
(+ (child-info-x-min (car kid-info))
@ -725,9 +808,11 @@
(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-canvas-panel% (wx-make-panel% wx:canvas-panel%))
(define wx-tab-panel% (wx-make-panel% wx:tab-panel%))
(define wx-group-panel% (wx-make-panel% wx:group-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-linear-tab-panel% (wx-make-linear-panel% wx-tab-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-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-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-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%)
(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]
[vert-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-height any/c #t])]{
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
less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel}
The @racket[style] flags are the same as for @racket[panel%].
@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%)
(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]
[vert-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])]{
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}
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[]
}}

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%)
(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]
[vert-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-height any/c #t])]{
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
less than its total size). @DeletedStyleNote[@scheme[style] @scheme[parent]]{panel}
The @racket[style] flags are the same as for @racket[panel%].
@WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaContKWs[] @AreaKWs[]
}

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

@ -38,10 +38,10 @@
style))
(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
(or parent mdi-frame default-parent-frame)
x y w h
w h x y
(if mdi-frame
(cons 'mdi-child style)
(add-frame-style style)))))
@ -564,18 +564,20 @@
(define float-frame? #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?
active-dialog%
active-frame%)
"T\u03A3ster")) ; \u03A3 is eta
"T\u03A3ster" ; \u03A3 is eta
#f #f 100))
(define hp (make-object horizontal-panel% f))
(define ip (make-object vertical-panel% hp))
(define cp (make-object vertical-panel% hp))
(define ep (make-object vertical-panel% hp))
(define lp (make-object vertical-panel% hp))
(define ip (new vertical-panel% [parent hp] [style panel-style]))
(define cp (new vertical-panel% [parent hp] [style panel-style]))
(define ep (new vertical-panel% [parent hp] [style panel-style]))
(define lp (new vertical-panel% [parent hp] [style panel-style]))
(define (basic-add-testers name w)
(add-hide name w cp)
@ -618,18 +620,20 @@
(set! prev-frame 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?
active-dialog%
active-frame%)
"Tester2"))
"Tester2"
#f #f 100))
(define hp2 (make-object horizontal-panel% f2))
(define ip2-0 (make-object vertical-panel% hp2))
(define cp2 (make-object vertical-panel% hp2))
(define ep2 (make-object vertical-panel% hp2))
(define lp2 (make-object vertical-panel% hp2))
(define ip2-0 (new vertical-panel% [parent hp2] [style panel-style]))
(define cp2 (new vertical-panel% [parent hp2] [style panel-style]))
(define ep2 (new vertical-panel% [parent hp2] [style panel-style]))
(define lp2 (new vertical-panel% [parent hp2] [style panel-style]))
(define (basic-add-testers2 name w)
(add-hide name w cp2)
@ -2515,7 +2519,16 @@
(positive? (send enabled-radio get-selection))
(positive? (send selection-radio get-selection))
(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
(and msg?
@ -2523,6 +2536,17 @@
[parent p2]
[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))
(make-selector-and-runner bp1 bp2 #t #t "Big" big-frame)

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

@ -3,6 +3,9 @@ Enabled single-precision floats by default
Added single-flonum?
Changed eqv? so that inexacts are equivalent only when they
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
Renamed "proxy" to "impersonator"