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

added hierlist methods

Browse Source 
svn: r43
This commit is contained in:
Matthew Flatt 2005-06-01 22:44:02 +00:00
parent d878d6d8de
commit 589799f291
2 changed files with 71 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/hierlist/doc.txt
View File

@ -93,10 +93,26 @@ New methods:
> select-last :: (send a-list select-last) > select-last :: (send a-list select-last)
> select-in :: (send a-list select-in) > select-in :: (send a-list select-in)
> select-out :: (send a-list select-out) > select-out :: (send a-list select-out)
> select :: (send a-list select i) > click-select :: (send a-list select i)
> page-up :: (send a-list page-up) > page-up :: (send a-list page-up)
> page-down :: (send a-list page-down) > page-down :: (send a-list page-down)
- Move the selection and scroll - Move the selection, scroll, and call on-select
> select :: (send a-list select i)
- Like `click-select', but does not call `on-select'
unless `on-select' is always called (see `on-select-always')
> on-select-always :: (send on-select-always)
> on-select-always :: (send on-select-always on?)
- Gets/sets whether the `on-select' method is called in
response to `select' (as opposed to `click-select');
the default is #t
> allow-deselect :: (send allow-deselect)
> allow-deselect :: (send allow-deselect on?)
- Gets/sets whether the `select' can be used with a #f
argument to deselect the current item (leaving none
selected); the default is #f
-------------------------------------------------- --------------------------------------------------
@ -109,8 +125,11 @@ New methods:
> is-selected? :: (send an-item is-selected?) - returns #t or #f > is-selected? :: (send an-item is-selected?) - returns #t or #f
> select :: (send an-item select on?) - selects or deselects the > click-select :: (send an-item select on?) - selects or deselects
item; hierarchical-list%'s on-select is called the item; hierarchical-list%'s `on-select' is called; see also
`allow-deselect'
> select :: (send an-item select on?) - like `click-select',
but `on-select' might not be called; see `on-select-always'
> user-data :: (send an-item user-data) - returns user data; > user-data :: (send an-item user-data) - returns user data;
initialized to #f initialized to #f

70
collects/hierlist/hierlist-unit.ss
View File

@ -147,8 +147,8 @@
(send item-keymap add-function "mouse-select" (send item-keymap add-function "mouse-select"
(lambda (edit event) (when (send event button-down?) (lambda (edit event) (when (send event button-down?)
(send edit select #t) (send edit click-select #t)
; To handle hypertext clicks: ;; To handle hypertext clicks:
(send edit on-default-event event)))) (send edit on-default-event event))))
(send item-keymap add-function "mouse-double-select" (send item-keymap add-function "mouse-double-select"
(lambda (edit event) (when (send event button-down?) (lambda (edit event) (when (send event button-down?)
@ -185,6 +185,7 @@
[is-selected? (lambda () (send (get-editor) is-selected?))] [is-selected? (lambda () (send (get-editor) is-selected?))]
[select (lambda (on?) (send snip select on?))] [select (lambda (on?) (send snip select on?))]
[click-select (lambda (on?) (send snip click-select on?))]
[scroll-to (lambda () (let* ([admin (send snip get-admin)] [scroll-to (lambda () (let* ([admin (send snip get-admin)]
[dc (send admin get-dc)] [dc (send admin get-dc)]
[h-box (box 0.0)]) [h-box (box 0.0)])
@ -307,11 +308,14 @@
(send dc draw-rectangle (+ dx left 1) (+ dy top_ 1) (- right left 2) (- bottom top_ 2))) (send dc draw-rectangle (+ dx left 1) (+ dy top_ 1) (- right left 2) (- bottom top_ 2)))
(send dc set-pen p) (send dc set-pen p)
(send dc set-brush b))))]) (send dc set-brush b))))])
(private
[do-select (lambda (on? clicked?)
(unless (eq? (not selected?)
(not on?))
(top-select (if on? item #f) snip clicked?)))])
(public (public
[select (lambda (on?) [select (lambda (on?) (do-select on? #f))]
(unless (eq? (not selected?) [click-select (lambda (on?) (do-select on? #t))]
(not on?))
(top-select (if on? item #f) snip)))]
[double-select (lambda () (send top on-double-select item))] [double-select (lambda () (send top on-double-select item))]
[select-prev (lambda () (send top select-prev))]) [select-prev (lambda () (send top select-prev))])
(override (override
@ -454,6 +458,7 @@
[get-parent (lambda () parent)] [get-parent (lambda () parent)]
[get-item-text% (lambda () hierarchical-item-text%)] [get-item-text% (lambda () hierarchical-item-text%)]
[select (lambda (on?) (send item-buffer select on?))] [select (lambda (on?) (send item-buffer select on?))]
[click-select (lambda (on?) (send item-buffer click-select on?))]
[deselect-all (lambda () (select #f))] [deselect-all (lambda () (select #f))]
[show-select (lambda (on?) (send item-buffer show-select on?))] [show-select (lambda (on?) (send item-buffer show-select on?))]
[get-item-buffer (lambda () item-buffer)] [get-item-buffer (lambda () item-buffer)]
@ -488,10 +493,8 @@
[get-title-text% (lambda () hierarchical-item-text%)] [get-title-text% (lambda () hierarchical-item-text%)]
[get-content-text% (lambda () hierarchical-list-text%)] [get-content-text% (lambda () hierarchical-list-text%)]
[get-arrow-snip% (lambda () arrow-snip%)] [get-arrow-snip% (lambda () arrow-snip%)]
[select (lambda (on?) [select (lambda (on?) (send title-buffer select on?))]
(if on? [click-select (lambda (on?) (send title-buffer click-select on?))]
(send title-buffer select #t)
(send title-buffer select #f)))]
[deselect-all (lambda () [deselect-all (lambda ()
(select #f) (select #f)
(send content-buffer deselect-all))] (send content-buffer deselect-all))]
@ -655,7 +658,7 @@
[parent-snip [parent-snip
(let ([parent (send parent-snip get-item)]) (let ([parent (send parent-snip get-item)])
(when (send parent get-allow-selection?) (when (send parent get-allow-selection?)
(send parent select #t) (send parent click-select #t)
(send parent scroll-to)))] (send parent scroll-to)))]
[else [else
(void)]))))] (void)]))))]
@ -667,7 +670,7 @@
(send selected open) (send selected open)
(let ([items (send selected-item get-items)]) (let ([items (send selected-item get-items)])
(unless (null? items) (unless (null? items)
(send (car items) select #t) (send (car items) click-select #t)
(send (car items) scroll-to))) (send (car items) scroll-to)))
(send edit-sequence-text end-edit-sequence))] (send edit-sequence-text end-edit-sequence))]
[else (void)]))] [else (void)]))]
@ -675,18 +678,21 @@
[select-prev (lambda () (move -1))] [select-prev (lambda () (move -1))]
[select-first (lambda () (let ([l (get-items)]) [select-first (lambda () (let ([l (get-items)])
(unless (null? l) (unless (null? l)
(send (car l) select #t) (send (car l) click-select #t)
(send (car l) scroll-to))))] (send (car l) scroll-to))))]
[select-last (lambda () (let loop ([l (get-items)]) [select-last (lambda () (let loop ([l (get-items)])
(cond (cond
[(null? l) (void)] [(null? l) (void)]
[(null? (cdr l)) [(null? (cdr l))
(send (car l) select #t) (send (car l) click-select #t)
(send (car l) scroll-to)] (send (car l) scroll-to)]
[else (loop (cdr l))])))] [else (loop (cdr l))])))]
[select (lambda (i) [select (lambda (i)
(send i select #t) (send i select #t)
(send i scroll-to))] (send i scroll-to))]
[click-select (lambda (i)
(send i click-select #t)
(send i scroll-to))]
[page-up (lambda () (page 'up))] [page-up (lambda () (page 'up))]
[page-down (lambda () (page 'down))] [page-down (lambda () (page 'down))]
[show-focus [show-focus
@ -751,7 +757,7 @@
(when (< -1 pos (length l)) (when (< -1 pos (length l))
(let ([i (vector-ref vec pos)]) (let ([i (vector-ref vec pos)])
(when (send i get-allow-selection?) (when (send i get-allow-selection?)
(send i select #t) (send i click-select #t)
(send i scroll-to))))) (send i scroll-to)))))
(let ([y-box (box 0.0)] (let ([y-box (box 0.0)]
[x-box (box 0.0)] [x-box (box 0.0)]
@ -778,14 +784,25 @@
(max 0 (- (unbox sbox) len)) (max 0 (- (unbox sbox) len))
(min (sub1 (length items)) (+ (unbox ebox) len)))] (min (sub1 (length items)) (+ (unbox ebox) len)))]
[i (list-ref items l)]) [i (list-ref items l)])
(send i select #t) (send i click-select #t)
(send i scroll-to))))) (send i scroll-to)))))
(send top-buffer move-position dir #f 'page)))]) (send top-buffer move-position dir #f 'page)))])
(private-field (private-field
[selectable? #t] [selectable? #t]
[show-focus? #f]) [show-focus? #f]
[on-select-always? #t]
[allow-deselect? #f])
(public
[on-select-always
(case-lambda
[() on-select-always?]
[(v) (set! on-select-always? (and v #t))])]
[allow-deselect
(case-lambda
[() allow-deselect?]
[(v) (set! allow-deselect? (and v #t))])])
(private (private
[do-select (lambda (item s) [do-select (lambda (item s clicked?)
(cond (cond
[(and selectable? [(and selectable?
item item
@ -795,11 +812,20 @@
(set! selected (if item s #f)) (set! selected (if item s #f))
(set! selected-item item) (set! selected-item item)
(when selected (send selected show-select #t)) (when selected (send selected show-select #t))
(on-select item))] (when (or clicked? on-select-always?)
[item (on-select item)))]
(on-click item)]))]) [(and item
clicked?)
(on-click item)]
[allow-deselect?
(when selected-item
(send selected show-select #f)
(set! selected #f)
(set! selected-item #f))
(when (or clicked? on-select-always?)
(on-select #f))]))])
(private-field (private-field
[top-buffer (make-object hierarchical-list-text% this (lambda (i s) (do-select i s)) 0 #f)] [top-buffer (make-object hierarchical-list-text% this (lambda (i s c?) (do-select i s c?)) 0 #f)]
[selected #f] [selected #f]
[selected-item #f]) [selected-item #f])
(sequence (sequence