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

auto-scroll canvases and frame status lines

Browse Source 
original commit: c42d95216eb48e94a48364fb01b0e6d4a70d1534
This commit is contained in:
Matthew Flatt 2010-08-03 12:19:51 -06:00
parent 44a8d8ce2b
commit 5746708793
8 changed files with 254 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mred/private/mrtop.rkt
View File

@ -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?)))]

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

@ -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)))))

11
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -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)

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

@ -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)))))

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

@ -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)])

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

@ -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 "<bad-image>"))))]
[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)

6
collects/scribblings/gui/canvas-class.scrbl
View File

@ -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

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

@ -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)])