racket/gui: scrollbar support panels
This commit is contained in:
Matthew Flatt
parent
83b00c0cf1
commit
93e1467b8b
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -365,6 +373,8 @@
|
|||
(send dc start-backing-retained)
|
||||
|
||||
(queue-paint)
|
||||
|
||||
(define/public (is-panel?) #f)
|
||||
|
||||
(define/public (get-dc) dc)
|
||||
|
||||
|
|
@ -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)
|
||||
(if (is-auto-scroll?)
|
||||
0
|
||||
v))
|
||||
(define/private (guard-scroll skip-guard? which v)
|
||||
(if skip-guard?
|
||||
v
|
||||
(if (is-auto-scroll?)
|
||||
0
|
||||
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))
|
||||
(or (not is-combo?)
|
||||
(e . is-a? . key-event%)
|
||||
(not (send e button-down? 'left))
|
||||
(not (on-menu-click? e))))
|
||||
(and (not (is-panel?))
|
||||
(or (not is-combo?)
|
||||
(e . is-a? . key-event%)
|
||||
(not (send e button-down? 'left))
|
||||
(not (on-menu-click? e)))))
|
||||
|
||||
(define/override (gets-focus?)
|
||||
wants-focus?)
|
||||
|
|
@ -820,8 +839,8 @@
|
|||
defer: #:type _BOOL NO))]
|
||||
[iv (tell (tell NSImageView alloc) init)])
|
||||
(tellv iv setImage: img)
|
||||
(tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
|
||||
(make-NSSize w h)))
|
||||
(tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
|
||||
(make-NSSize w h)))
|
||||
(tellv (tell win contentView) addSubview: iv)
|
||||
(tellv win setAlphaValue: #:type _CGFloat 0.0)
|
||||
(tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
|
||||
|
|
@ -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,9 +2,9 @@
|
|||
(require racket/class
|
||||
ffi/unsafe
|
||||
ffi/unsafe/objc
|
||||
"../../syntax.rkt"
|
||||
"types.rkt"
|
||||
"utils.rkt"
|
||||
"../../syntax.rkt"
|
||||
"types.rkt"
|
||||
"utils.rkt"
|
||||
"window.rkt")
|
||||
|
||||
(provide
|
||||
|
|
@ -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?))))
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@
|
|||
(values
|
||||
button%
|
||||
canvas%
|
||||
canvas-panel%
|
||||
check-box%
|
||||
choice%
|
||||
clipboard-driver%
|
||||
|
|
|
|||
|
|
@ -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
|
||||
(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))
|
||||
(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))))
|
||||
(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)
|
||||
null
|
||||
(if hscroll-adj
|
||||
(list client-gtk hscroll-adj vscroll-adj)
|
||||
(if combo-button-gtk
|
||||
(list client-gtk combo-button-gtk)
|
||||
(list client-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)))))])
|
||||
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@
|
|||
(values
|
||||
button%
|
||||
canvas%
|
||||
canvas-panel%
|
||||
check-box%
|
||||
choice%
|
||||
clipboard-driver%
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
|
||||
(define-values (button%
|
||||
canvas%
|
||||
canvas-panel%
|
||||
check-box%
|
||||
choice%
|
||||
clipboard-driver%
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@
|
|||
PBS_VERTICAL
|
||||
0))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
(send parent get-content-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@
|
|||
SS_ICON
|
||||
0)))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
(send parent get-content-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f)]
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@
|
|||
(values
|
||||
button%
|
||||
canvas%
|
||||
canvas-panel%
|
||||
check-box%
|
||||
choice%
|
||||
clipboard-driver%
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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,19 +322,23 @@
|
|||
(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)
|
||||
(if (or (= x -11111)
|
||||
(= y -11111)
|
||||
(= w -1)
|
||||
(= h -1))
|
||||
(let ([r (GetWindowRect hwnd)])
|
||||
(MoveWindow hwnd
|
||||
(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))
|
||||
(MoveWindow hwnd x y w h #t))
|
||||
(let-values ([(x y w h)
|
||||
(if (or (= x -11111)
|
||||
(= y -11111)
|
||||
(= w -1)
|
||||
(= h -1))
|
||||
(let ([r (GetWindowRect hwnd)])
|
||||
(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)))
|
||||
(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))
|
||||
(queue-on-size)
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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,9 +288,9 @@
|
|||
(gms-help (get-children-info)
|
||||
(* 2 border) (* 2 border)
|
||||
#t)]
|
||||
[delta-w (- (get-width) client-w)]
|
||||
[delta-h (- (get-height) client-h)])
|
||||
(list (+ delta-w (car min-client-size) (if hidden-child (* 2 tab-h-border) 0))
|
||||
[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)))))))]
|
||||
|
||||
;; do-get-min-graphical-size: poll children and return minimum possible
|
||||
|
|
@ -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
|
||||
major-dim
|
||||
(get-graphical-min-size))
|
||||
(apply major-dim delta-list)))]
|
||||
[extra-space (max 0
|
||||
(- (major-dim width height)
|
||||
(apply
|
||||
major-dim
|
||||
(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,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,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[]
|
||||
|
||||
}}
|
||||
|
|
|
|||
|
|
@ -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[]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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,13 +2519,33 @@
|
|||
(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?
|
||||
(new check-box%
|
||||
[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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user