diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index 719588d9..a99ca6a1 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -12,6 +12,7 @@ "wx.ss" "wxtop.ss" "wxpanel.ss" + "wxitem.ss" "mrwindow.ss" "mrcontainer.ss") @@ -41,6 +42,10 @@ (define-keywords top-level-window%-keywords window%-keywords container%-keywords area%-keywords) + (define-local-member-name + do-create-status-line + do-set-status-text) + (define basic-top-level-window% (class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>) (mk-wx mismatches label parent) @@ -111,15 +116,25 @@ [on-message (lambda (m) (void))]) (private-field [wx #f] + [mid-panel #f] ;; supports status line [wx-panel #f] + [status-message #f] [finish (entry-point (lambda (top-level hide-panel?) - (set! wx-panel (make-object wx-vertical-panel% #f this top-level null #f)) + (set! mid-panel (make-object wx-vertical-panel% #f this top-level null #f)) + (send (send mid-panel area-parent) add-child mid-panel) + (set! wx-panel (make-object wx-vertical-panel% #f this mid-panel null #f)) (send (send wx-panel area-parent) add-child wx-panel) (send top-level set-container wx-panel) (when hide-panel? - (send wx-panel show #f)) + (send mid-panel show #f)) top-level))]) + (public + [do-create-status-line (lambda () + (set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f)) + (send status-message stretchable-in-x #t))] + [do-set-status-text (lambda (s) + (send status-message set-label s))]) (sequence (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor)))) @@ -128,7 +143,8 @@ (class100*/kw basic-top-level-window% () [(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null]) top-level-window%-keywords] - (inherit on-traverse-char on-system-menu-char) + (inherit on-traverse-char on-system-menu-char + do-create-status-line do-set-status-text) (sequence (let ([cwho '(constructor frame)]) (check-label-string cwho label) @@ -164,8 +180,8 @@ (send wx handle-menu-key e)))] [on-mdi-activate (lambda (on?) (void))] [on-toolbar-button-click (lambda () (void))] - [create-status-line (entry-point (lambda () (unless status-line? (send wx create-status-line) (set! status-line? #t))))] - [set-status-text (lambda (s) (send wx set-status-text s))] + [create-status-line (entry-point (lambda () (unless status-line? (do-create-status-line) (set! status-line? #t))))] + [set-status-text (lambda (s) (do-set-status-text s))] [has-status-line? (lambda () status-line?)] [iconize (entry-point (lambda (on?) (send wx iconize on?)))] [is-iconized? (entry-point (lambda () (send wx iconized?)))] diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 8bc23e58..8908dd79 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -61,9 +61,11 @@ (-a _void (drawRect: [_NSRect r]) (let ([ctx (tell NSGraphicsContext currentContext)]) (tellv ctx saveGraphicsState) - (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]) + (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] + [r (tell #:type _NSRect self bounds)]) (CGContextSetRGBFillColor cg 0 0 0 1.0) - (CGContextFillRect cg r)) + (CGContextAddRect cg r) + (CGContextStrokePath cg)) (tellv ctx restoreGraphicsState)))) (define-cocoa NSSetFocusRingStyle (_fun _int -> _void)) @@ -144,11 +146,15 @@ (define hscroll-ok? (and (memq 'hscroll style) #t)) (define hscroll? hscroll-ok?) - (define-values (x-margin y-margin) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) + + (define-values (x-margin y-margin x-sb-margin y-sb-margin) (cond - [(memq 'control-border style) (values 3 3)] - [(memq 'border style) (values 1 1)] - [else (values 0 0)])) + [(memq 'control-border style) (values 3 3 3 3)] + [(memq 'border style) (values 1 1 0 0)] + [else (values 0 0 0 0)])) (define canvas-style style) @@ -193,6 +199,7 @@ [cocoa (as-objc-allocation (tell (tell (cond + [is-combo? NSView] [(memq 'control-border style) FocusView] [(memq 'border style) FrameView] [else NSView]) @@ -236,7 +243,9 @@ (+ (NSPoint-x p) (if is-combo? 2 0)) (- (NSPoint-y p) (if is-combo? 22 0)) (max 1 (- (unbox xb) (if is-combo? 22 0))) - (unbox yb)))) + (unbox yb) + (if auto-scroll? (scroll-pos h-scroller) 0) + (if auto-scroll? (scroll-pos v-scroller) 0)))) (define/override (get-client-size xb yb) (super get-client-size xb yb) @@ -276,27 +285,25 @@ (when v-scroller (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width x-margin) + (make-NSPoint (- w scroll-width x-sb-margin) (+ (if hscroll? scroll-width 0) - y-margin)) + y-sb-margin)) (make-NSSize scroll-width (max 0 (- h (if hscroll? scroll-width 0) - x-margin x-margin)))))) + x-sb-margin x-sb-margin)))))) (when h-scroller (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect (make-NSRect - (make-NSPoint x-margin y-margin) + (make-NSPoint x-sb-margin y-sb-margin) (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) - x-margin x-margin)) + x-sb-margin x-sb-margin)) scroll-width)))) (fix-dc) + (when auto-scroll? + (reset-auto-scroll 0 0)) (on-size 0 0)) - (define/override (client-y-offset) - (if hscroll? - scroll-width - 0)) (define/public (show-scrollbars h? v?) (let ([h? (and h? hscroll-ok?)] @@ -325,16 +332,62 @@ h-page v-page h-pos v-pos auto?) - (scroll-range h-scroller h-len) - (scroll-page h-scroller h-page) - (scroll-pos h-scroller h-pos) - (when h-scroller - (tell (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) - (when v-scroller - (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len))))) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) h-len)) + (set! virtual-height (and (positive? v-len) v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (let ([a? auto-scroll?]) + (set! auto-scroll? #f) + (when a? (fix-dc))) ; disable scroll offsets + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (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) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))) + (set! virtual-width #f) + (set! virtual-height #f)])) + + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (scroll-range h-scroller h-len) + (scroll-page h-scroller h-page) + (scroll-pos h-scroller h-pos) + (when h-scroller + (tell (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (positive? h-len))) + (scroll-range v-scroller v-len) + (scroll-page v-scroller v-page) + (scroll-pos v-scroller v-pos) + (when v-scroller + (tell (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (positive? v-len))))))) + + (define/private (refresh-for-autoscroll) + (fix-dc) + (refresh)) (define (update which scroll- v) (if (eq? which 'vertical) @@ -361,14 +414,14 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint (- w scroll-width x-margin) + (make-NSPoint (- w scroll-width x-sb-margin) (+ (if hscroll? scroll-width 0) - y-margin)) + y-sb-margin)) (make-NSSize scroll-width (max (- h (if hscroll? scroll-width 0) - y-margin y-margin) + y-sb-margin y-sb-margin) (+ scroll-width 10)))))) 1 1))) @@ -378,9 +431,9 @@ (as-objc-allocation (tell (tell NSScroller alloc) initWithFrame: #:type _NSRect (make-NSRect - (make-NSPoint x-margin y-margin) + (make-NSPoint x-sb-margin y-sb-margin) (make-NSSize (max (- w (if vscroll? scroll-width 0) - x-margin x-margin) + x-sb-margin x-sb-margin) (+ scroll-width 10)) scroll-width)))) 1 @@ -501,10 +554,12 @@ 'thumb] [else #f])]) (when kind - (on-scroll (new scroll-event% - [event-type kind] - [direction direction] - [position (get-scroll-pos direction)]))))))) + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type kind] + [direction direction] + [position (get-scroll-pos direction)])))))))) (constrained-reply (get-eventspace) (lambda () (let loop () (pre-event-sync #t) (when (yield) (loop)))) @@ -547,9 +602,31 @@ in-menu-click?) (def/public-unimplemented set-background-to-gray) - (def/public-unimplemented scroll) + + (define/public (scroll x y) + (when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller)))) + (when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller)))) + (when auto-scroll? (refresh-for-autoscroll))) + (def/public-unimplemented warp-pointer) - (def/public-unimplemented view-start) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (scroll-pos h-scroller) + 0)) + (set-box! yb (if virtual-height + (scroll-pos v-scroller) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + (define/public (set-resize-corner on?) (void)) - (def/public-unimplemented get-virtual-size))) + + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))))) diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index ff50d1cd..9c738213 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -13,7 +13,9 @@ (provide dc% _CGContextRef CGContextSetRGBFillColor - CGContextFillRect) + CGContextFillRect + CGContextAddRect + CGContextStrokePath) (define _CGContextRef (_cpointer 'CGContextRef)) (define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void)) @@ -21,6 +23,8 @@ (define-appserv CGContextFlush (_fun _CGContextRef -> _void)) (define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void)) (define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void)) +(define-appserv CGContextStrokePath (_fun _CGContextRef -> _void)) (define-appserv CGContextConvertPointToUserSpace (_fun _CGContextRef _NSPoint -> _NSPoint)) (define-appserv CGContextConvertSizeToUserSpace (_fun _CGContextRef _NSSize -> _NSSize)) @@ -29,7 +33,7 @@ (init context dx dy width height) (super-new) - (inherit reset-cr) + (inherit reset-cr set-auto-scroll) (define the-context context) ;; retain as long as we need `cg' (define cg (tell #:type _CGContextRef context graphicsPort)) @@ -64,11 +68,12 @@ (define cr #f) (set-bounds dx dy width height) - (define/public (reset-bounds dx dy width height) + (define/public (reset-bounds dx dy width height auto-dx auto-dy) (let ([old-cr cr]) (when old-cr (set! cr #f) (cairo_destroy old-cr))) + (set-auto-scroll auto-dx auto-dy) (CGContextScaleCTM cg 1 -1) (CGContextTranslateCTM cg (- old-dx) (- old-dy)) (set-bounds dx dy width height) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index abe343ea..c21d443e 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -141,6 +141,10 @@ (define margin (if has-border? 1 0)) + (define auto-scroll? #f) + (define virtual-height #f) + (define virtual-width #f) + (define-values (client-gtk gtk hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box) (cond [(or (memq 'hscroll style) @@ -289,13 +293,24 @@ (define/public (reset-child-dcs) (when (dc . is-a? . dc%) - (send dc reset-dc))) + (reset-dc))) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?) (when on? (reset-child-dcs))) + (define/private (reset-dc) + (if auto-scroll? + (send dc reset-dc + (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0) + (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0)) + (send dc reset-dc 0 0))) + (define/override (internal-on-client-size w h) - (send dc reset-dc)) + (reset-dc)) (define/override (on-client-size w h) (let ([xb (box 0)] [yb (box 0)]) @@ -319,20 +334,59 @@ ;; remove corner (gtk_widget_hide resize-box)]))) + (define/private (configure-adj adj scroll-gtk len page pos) + (when (and scroll-gtk adj) + (if (zero? len) + (gtk_adjustment_configure adj 0 0 1 1 1 1) + (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))) + (define/public (set-scrollbars h-step v-step h-len v-len h-page v-page h-pos v-pos auto?) - (when hscroll-adj - (gtk_adjustment_configure hscroll-adj h-pos 0 h-len 1 h-page h-page)) - (when vscroll-adj - (gtk_adjustment_configure vscroll-adj v-pos 0 v-len 1 v-page v-page))) + (let ([h-page (if (zero? h-len) 0 h-page)] + [v-page (if (zero? v-len) 0 v-page)]) + (cond + [auto? + (set! auto-scroll? #t) + (set! virtual-width (and (positive? h-len) hscroll-gtk h-len)) + (set! virtual-height (and (positive? v-len) vscroll-gtk v-len)) + (reset-auto-scroll h-pos v-pos) + (refresh-for-autoscroll)] + [else + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)]))) - (define/private (dispatch which proc) + (define/private (reset-auto-scroll h-pos v-pos) + (let ([xb (box 0)] + [yb (box 0)]) + (get-client-size xb yb) + (let ([cw (unbox xb)] + [ch (unbox yb)]) + (let ([h-len (if virtual-width + (max 0 (- virtual-width cw)) + 0)] + [v-len (if virtual-height + (max 0 (- virtual-height ch)) + 0)] + [h-page (if virtual-width + cw + 0)] + [v-page (if virtual-height + ch + 0)]) + (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos) + (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))))) + + (define/private (refresh-for-autoscroll) + (reset-dc) + (refresh)) + + (define/private (dispatch which proc [default (void)]) (if (eq? which 'vertical) - (when vscroll-adj (proc vscroll-adj)) - (when hscroll-adj (proc hscroll-adj)))) + (if vscroll-adj (proc vscroll-adj) default) + (if hscroll-adj (proc hscroll-adj) default))) (define/public (set-scroll-page which v) (dispatch which (lambda (adj) @@ -349,13 +403,14 @@ (dispatch which (lambda (adj) (gtk_adjustment_set_value adj v)))) (define/public (get-scroll-page which) - (->long (dispatch which (lambda (adj) - (- (gtk_adjustment_get_page_size adj) - (gtk_adjustment_get_page_size adj)))))) + (->long (dispatch which gtk_adjustment_get_page_size 0))) (define/public (get-scroll-range which) - (->long (dispatch which gtk_adjustment_get_upper))) + (->long (dispatch which (lambda (adj) + (- (gtk_adjustment_get_upper adj) + (gtk_adjustment_get_page_size adj))) + 0))) (define/public (get-scroll-pos which) - (->long (dispatch which gtk_adjustment_get_value))) + (->long (dispatch which gtk_adjustment_get_value 0))) (define clear-bg? (and (not (memq 'transparent style)) @@ -403,16 +458,38 @@ (def/public-unimplemented set-background-to-gray) (define/public (do-scroll direction) - (on-scroll (new scroll-event% - [event-type 'thumb] - [direction direction] - [position (get-scroll-pos direction)]))) + (if auto-scroll? + (refresh-for-autoscroll) + (on-scroll (new scroll-event% + [event-type 'thumb] + [direction direction] + [position (get-scroll-pos direction)])))) (define/public (on-scroll e) (void)) - (def/public-unimplemented scroll) + (define/public (scroll x y) + (when hscroll-adj (gtk_adjustment_set_value hscroll-adj x)) + (when vscroll-adj (gtk_adjustment_set_value vscroll-adj y)) + (when auto-scroll? (refresh-for-autoscroll))) + (def/public-unimplemented warp-pointer) - (def/public-unimplemented view-start) + + (define/public (view-start xb yb) + (if auto-scroll? + (begin + (set-box! xb (if virtual-width + (gtk_adjustment_get_value hscroll-adj) + 0)) + (set-box! yb (if virtual-height + (gtk_adjustment_get_value vscroll-adj) + 0))) + (begin + (set-box! xb 0) + (set-box! yb 0)))) + (define/public (set-resize-corner on?) (void)) - (define/public (get-virtual-size xb yb) (set-box! xb 10) (set-box! yb 10)))) + (define/public (get-virtual-size xb yb) + (get-client-size xb yb) + (when virtual-width (set-box! xb virtual-width)) + (when virtual-height (set-box! yb virtual-height))))) diff --git a/collects/mred/private/wx/gtk/dc.rkt b/collects/mred/private/wx/gtk/dc.rkt index bb31608e..5beaf40d 100644 --- a/collects/mred/private/wx/gtk/dc.rkt +++ b/collects/mred/private/wx/gtk/dc.rkt @@ -23,7 +23,7 @@ get-client-size window-lock [get-window g_object_get_window]) - (inherit reset-cr) + (inherit reset-cr set-auto-scroll) (define c #f) @@ -47,13 +47,14 @@ (set! c #f) (semaphore-post window-lock))) - (define/public (reset-dc) + (define/public (reset-dc scroll-dx scroll-dy) ;; FIXME: ensure that the dc is not in use (as-entry (lambda () (when c (cairo_destroy c) - (set! c #f))))) + (set! c #f)) + (set-auto-scroll scroll-dx scroll-dy)))) (define/override (get-size) (let-values ([(w h) (get-client-size)]) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index b29ba9d1..91678fb0 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -20,6 +20,7 @@ (define-gtk gtk_label_set_text (_fun _GtkWidget _string -> _void)) (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) +(define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) (define (mnemonic-string s) (if (regexp-match? #rx"&" s) @@ -62,6 +63,9 @@ (gtk_label_new_with_mnemonic ""))))] [no-show? (memq 'deleted style)]) + (when (string? label) + (gtk_misc_set_alignment (get-gtk) 0.0 0.0)) + (set-auto-size) (define/override (set-label s) diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index e5dee91e..5f3ef186 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -287,9 +287,9 @@ The @scheme[h-value] and @scheme[v-value] arguments each specify a fraction of the scrollbar's movement. A @scheme[0.0] value sets the scrollbar to its left/top, while a @scheme[1.0] value sets the scrollbar to its right/bottom. A @scheme[0.5] value sets the scrollbar to its middle. In - general, if the canvas's virtual size is @scheme[v], its client size is - @scheme[c], and @scheme[(> v c)], then scrolling to @scheme[p] - sets the view start to @scheme[(floor (* p (- v c)))]. + general, if the canvas's virtual size is @scheme[_v], its client size is + @scheme[_c], and @scheme[(> _v _c)], then scrolling to @scheme[_p] + sets the view start to @scheme[(floor (* _p (- _v _c)))]. See also @method[canvas% init-auto-scrollbars] and diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 225394a2..c54e7c62 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1,4 +1,3 @@ - #lang scheme/gui (require mzlib/class @@ -1679,7 +1678,7 @@ (get-scroll-pos 'horizontal) (get-scroll-range 'horizontal) (get-scroll-page 'horizontal))] - [dc (get-dc)]) + [dc (get-dc)]) (let-values ([(w h) (get-client-size)] [(w2 h2) (get-virtual-size)] [(x y) (get-view-start)])