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

...

Browse Source 
original commit: 8b372620ae76c9a61067c61192f05fe32877c08a
This commit is contained in:
Robby Findler 2001-10-23 03:44:55 +00:00
parent ca0a970012
commit c071b7efa2
2 changed files with 341 additions and 323 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/framework/private/main.ss
View File

@ -67,7 +67,8 @@
with-syntax with-syntax
module module
let/cc let/ec letcc catch let/cc let/ec letcc catch
let-syntax letrec-syntax syntax-case let-syntax letrec-syntax
syntax-case syntax-case*
let-signature fluid-let let-signature fluid-let
let-struct let-macro let-values let*-values let-struct let-macro let-values let*-values
case when unless match case when unless match

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

@ -131,7 +131,7 @@
(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 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"
@ -147,28 +147,34 @@
is-selected? is-selected?
select select
user-data user-data
get-allow-selection?
set-allow-selection
get-clickable-snip)) get-clickable-snip))
(define hierarchical-list-item% (define hierarchical-list-item%
(class100* object% (hierarchical-list-item<%>) (snp) (class100* object% (hierarchical-list-item<%>) (snp)
(private-field (private-field
[snip snp] [snip snp]
[data #f]) [data #f]
(public [allow-selection #t])
[get-clickable-snip (lambda () snip)] (public
[get-editor (lambda () (send snip get-item-buffer))] [get-allow-selection? (lambda () allow-selection)]
[is-selected? (lambda () (send (send snip get-editor) is-selected?))] [set-allow-selection (lambda (_a) (set! allow-selection _a))]
[select (lambda (on?) (send (send snip get-editor) select on?))]
[scroll-to (lambda () (let* ([admin (send snip get-admin)] [get-clickable-snip (lambda () snip)]
[dc (send admin get-dc)] [get-editor (lambda () (send snip get-item-buffer))]
[h-box (box 0.0)]) [is-selected? (lambda () (send (send snip get-editor) is-selected?))]
(send snip get-extent dc 0 0 #f h-box #f #f #f #f) [select (lambda (on?) (send snip select on?))]
(send admin [scroll-to (lambda () (let* ([admin (send snip get-admin)]
scroll-to [dc (send admin get-dc)]
snip [h-box (box 0.0)])
0 0 0 (unbox h-box) #t)))] (send snip get-extent dc 0 0 #f h-box #f #f #f #f)
[user-data (case-lambda [() data][(x) (set! data x)])]) (send admin
(sequence (super-init)))) scroll-to
snip
0 0 0 (unbox h-box) #t)))]
[user-data (case-lambda [() data][(x) (set! data x)])])
(sequence (super-init))))
(define hierarchical-list-compound-item<%> (define hierarchical-list-compound-item<%>
(interface (hierarchical-list-item<%>) (interface (hierarchical-list-item<%>)
@ -176,6 +182,10 @@
new-list new-list
delete-item delete-item
get-items get-items
open
close
toggle-open/closed
is-open?
get-arrow-snip)) get-arrow-snip))
(define hierarchical-list-compound-item% (define hierarchical-list-compound-item%
@ -217,159 +227,160 @@
;; Buffer for a single list item ;; Buffer for a single list item
(define hierarchical-item-text% (define hierarchical-item-text%
(class100 text% (tp tp-select itm snp dpth) (class100 text% (tp tp-select itm snp dpth)
(inherit set-max-undo-history hide-caret (inherit set-max-undo-history hide-caret
last-position set-position set-keymap last-position set-position set-keymap
invalidate-bitmap-cache set-max-width invalidate-bitmap-cache set-max-width
get-view-size) get-view-size)
(rename [super-auto-wrap auto-wrap] (rename [super-auto-wrap auto-wrap]
[super-on-default-event on-default-event]) [super-on-default-event on-default-event])
(private-field (private-field
[top tp] [top tp]
[top-select tp-select] [top-select tp-select]
[item itm] [item itm]
[snip snp] [snip snp]
[depth dpth] [depth dpth]
[selected? #f]) [selected? #f])
(public (public
[is-selected? (lambda () selected?)] [is-selected? (lambda () selected?)]
[show-select (lambda (on?) [show-select (lambda (on?)
(set! selected? on?) (set! selected? on?)
(invalidate-bitmap-cache))]) (invalidate-bitmap-cache))])
(override (override
[auto-wrap (case-lambda [auto-wrap (case-lambda
[() (super-auto-wrap)] [() (super-auto-wrap)]
[(on?) (super-auto-wrap on?) [(on?) (super-auto-wrap on?)
(when on? (when on?
(let ([wbox (box 0)]) (let ([wbox (box 0)])
(send (send top get-editor) get-view-size wbox (box 0)) (send (send top get-editor) get-view-size wbox (box 0))
;; These icky constants should be eliminated ;; These icky constants should be eliminated
(let ([w (- (unbox wbox) 8 (* depth arrow-size))]) (let ([w (- (unbox wbox) 8 (* depth arrow-size))])
(set-max-width (if (positive? w) (set-max-width (if (positive? w)
w w
'none)))))])] 'none)))))])]
[on-paint [on-paint
(lambda (pre? dc left top_ right bottom dx dy caret) (lambda (pre? dc left top_ right bottom dx dy caret)
(when (and (not pre?) selected?) (when (and (not pre?) selected?)
(let ([b (send dc get-brush)] (let ([b (send dc get-brush)]
[p (send dc get-pen)] [p (send dc get-pen)]
[filled? (or (not (send top show-focus)) [filled? (or (not (send top show-focus))
(send top has-focus?))]) (send top has-focus?))])
(unless filled? (unless filled?
;; To draw the right outline, we need the display area ;; To draw the right outline, we need the display area
(set! left 0) (set! left 0)
(set! top_ 0) (set! top_ 0)
(let ([wbox (box 0)] (let ([wbox (box 0)]
[hbox (box 0)]) [hbox (box 0)])
(get-view-size wbox hbox) (get-view-size wbox hbox)
(set! right (unbox wbox)) (set! right (unbox wbox))
(set! bottom (unbox hbox)))) (set! bottom (unbox hbox))))
(send dc set-brush (if filled? black-xor transparent)) (send dc set-brush (if filled? black-xor transparent))
(send dc set-pen (if filled? transparent-pen black-xor-pen)) (send dc set-pen (if filled? transparent-pen black-xor-pen))
(send dc draw-rectangle (+ dx left) (+ dy top_) (- right left) (- bottom top_)) (send dc draw-rectangle (+ dx left) (+ dy top_) (- right left) (- bottom top_))
(send dc set-pen p) (send dc set-pen p)
(send dc set-brush b))))]) (send dc set-brush b))))])
(public (public
[select (lambda (on?) [select (lambda (on?)
(unless (eq? (not selected?) (not on?)) (unless (eq? (not selected?)
(top-select (if on? item #f) snip)))] (not on?))
[double-select (lambda () (send top on-double-select item))] (top-select (if on? item #f) snip)))]
[select-prev (lambda () (send top select-prev))]) [double-select (lambda () (send top on-double-select item))]
(override [select-prev (lambda () (send top select-prev))])
[on-default-char (lambda (x) (void))]) (override
(sequence [on-default-char (lambda (x) (void))])
(super-init) (sequence
(hide-caret #t) (super-init)
(set-max-undo-history 0) (hide-caret #t)
(set-keymap item-keymap)))) (set-max-undo-history 0)
(set-keymap item-keymap))))
;; Buffer for a compound list item (and the top-level list) ;; Buffer for a compound list item (and the top-level list)
(define (make-hierarchical-list-text% super%) (define (make-hierarchical-list-text% super%)
(class100 super% (tp tp-select dpth parent-snp) (class100 super% (tp tp-select dpth parent-snp)
(inherit set-max-undo-history hide-caret erase (inherit set-max-undo-history hide-caret erase
last-position insert delete line-start-position line-end-position last-position insert delete line-start-position line-end-position
begin-edit-sequence end-edit-sequence get-style-list) begin-edit-sequence end-edit-sequence get-style-list)
(private-field (private-field
[top tp] [top tp]
[top-select tp-select] [top-select tp-select]
[depth dpth] [depth dpth]
[parent-snip parent-snp] [parent-snip parent-snp]
[children null]) [children null])
(private (private
[make-whitespace (lambda () (make-object whitespace-snip%))] [make-whitespace (lambda () (make-object whitespace-snip%))]
[insert-item [insert-item
(lambda (mixin snip% whitespace?) (lambda (mixin snip% whitespace?)
(let ([s (make-object snip% this top top-select (add1 depth) mixin)]) (let ([s (make-object snip% this top top-select (add1 depth) mixin)])
(begin-edit-sequence) (begin-edit-sequence)
(unless (null? children) (unless (null? children)
(insert #\newline (last-position))) (insert #\newline (last-position)))
(when whitespace? (insert (make-whitespace) (last-position))) (when whitespace? (insert (make-whitespace) (last-position)))
(insert s (last-position)) (insert s (last-position))
(end-edit-sequence) (end-edit-sequence)
(set! children (append children (list s))) (set! children (append children (list s)))
(send s get-item)))]) (send s get-item)))])
(public (public
[get-parent-snip (lambda () parent-snip)] [get-parent-snip (lambda () parent-snip)]
[deselect-all [deselect-all
(lambda () (for-each (lambda (x) (send x deselect-all)) children))] (lambda () (for-each (lambda (x) (send x deselect-all)) children))]
[new-item [new-item
(case-lambda (case-lambda
[() (new-item (lambda (x) x))] [() (new-item (lambda (x) x))]
[(mixin) [(mixin)
(insert-item mixin hierarchical-item-snip% #t)])] (insert-item mixin hierarchical-item-snip% #t)])]
[new-list [new-list
(case-lambda (case-lambda
[() (new-list (lambda (x) x))] [() (new-list (lambda (x) x))]
[(mixin) [(mixin)
(insert-item mixin hierarchical-list-snip% #f)])] (insert-item mixin hierarchical-list-snip% #f)])]
[get-items (lambda () (map (lambda (x) (send x get-item)) children))] [get-items (lambda () (map (lambda (x) (send x get-item)) children))]
[delete-item [delete-item
(lambda (i) (lambda (i)
(let loop ([pos 0][l children][others null]) (let loop ([pos 0][l children][others null])
(cond (cond
[(null? l) (error 'hierarchical-list-compound-item::delete-item "item not found: ~a" i)] [(null? l) (error 'hierarchical-list-compound-item::delete-item "item not found: ~a" i)]
[(eq? (send (car l) get-item) i) [(eq? (send (car l) get-item) i)
(send (car l) deselect-all) (send (car l) deselect-all)
(set! children (append (reverse others) (cdr l))) (set! children (append (reverse others) (cdr l)))
(let ([s (line-start-position pos)] (let ([s (line-start-position pos)]
[e (line-end-position pos)]) [e (line-end-position pos)])
(delete (if (zero? s) s (sub1 s)) (if (zero? s) (add1 e) e)))] (delete (if (zero? s) s (sub1 s)) (if (zero? s) (add1 e) e)))]
[else (loop (add1 pos) (cdr l) (cons (car l) others))])))] [else (loop (add1 pos) (cdr l) (cons (car l) others))])))]
[sort (lambda (less-than?) [sort (lambda (less-than?)
(let ([l (mergesort children (lambda (a b) (let ([l (mergesort children (lambda (a b)
(less-than? (send a get-item) (less-than? (send a get-item)
(send b get-item))))]) (send b get-item))))])
(begin-edit-sequence) (begin-edit-sequence)
(erase) (erase)
(let ([to-scroll-to #f]) (let ([to-scroll-to #f])
(for-each (for-each
(lambda (s) (lambda (s)
(unless to-scroll-to (unless to-scroll-to
(when (send (send s get-item) is-selected?) (when (send (send s get-item) is-selected?)
(set! to-scroll-to s))) (set! to-scroll-to s)))
(unless (is-a? s hierarchical-list-snip%) (unless (is-a? s hierarchical-list-snip%)
(insert (make-whitespace))) (insert (make-whitespace)))
(insert s) (insert s)
(insert #\newline)) (insert #\newline))
l) l)
(unless (null? l) (unless (null? l)
(delete)) ; delete last #\newline (delete)) ; delete last #\newline
(set! children l) (set! children l)
(when to-scroll-to (when to-scroll-to
(send (send to-scroll-to get-item) scroll-to))) (send (send to-scroll-to get-item) scroll-to)))
(end-edit-sequence)))] (end-edit-sequence)))]
[reflow-items [reflow-items
(lambda () (lambda ()
(for-each (for-each
(lambda (c) (lambda (c)
(send c reflow-item)) (send c reflow-item))
children))]) children))])
(override (override
[on-default-char (lambda (x) (void))] [on-default-char (lambda (x) (void))]
[on-default-event (lambda (x) (void))]) [on-default-event (lambda (x) (void))])
(sequence (sequence
(super-init) (super-init)
(hide-caret #t) (hide-caret #t)
(set-max-undo-history 0)))) (set-max-undo-history 0))))
(define hierarchical-list-text% (make-hierarchical-list-text% text%)) (define hierarchical-list-text% (make-hierarchical-list-text% text%))
@ -544,157 +555,163 @@
(define hierarchical-list% (define hierarchical-list%
(class100 editor-canvas% (parent) (class100 editor-canvas% (parent)
(inherit min-width min-height) (inherit min-width min-height)
(rename [super-on-char on-char] (rename [super-on-char on-char]
[super-on-focus on-focus]) [super-on-focus on-focus])
(public (public
[selectable [selectable
(case-lambda (case-lambda
[() selectable?] [() selectable?]
[(on?) (set! selectable? on?)])] [(on?) (set! selectable? on?)])]
[get-selected (lambda () selected-item)] [get-selected (lambda () selected-item)]
[on-item-opened (lambda (i) (void))] [on-item-opened (lambda (i) (void))]
[on-item-closed (lambda (i) (void))] [on-item-closed (lambda (i) (void))]
[on-double-select (lambda (i) (void))] [on-double-select (lambda (i) (void))]
[on-select (lambda (i) (void))] [on-select (lambda (i) (void))]
[new-item (lambda x (send top-buffer new-item . x))] [on-click (lambda (i) (void))]
[new-list (lambda x (send top-buffer new-list . x))] [new-item (lambda x (send top-buffer new-item . x))]
[delete-item (lambda (i) (send top-buffer delete-item i))] [new-list (lambda x (send top-buffer new-list . x))]
[sort (lambda (less-than?) (send top-buffer sort less-than?))] [delete-item (lambda (i) (send top-buffer delete-item i))]
[get-items (lambda () (send top-buffer get-items))] [sort (lambda (less-than?) (send top-buffer sort less-than?))]
[toggle-open/closed [get-items (lambda () (send top-buffer get-items))]
(lambda () [toggle-open/closed
(cond (lambda ()
[(and selected (is-a? selected hierarchical-list-snip%)) (cond
(send selected toggle-open/closed)] [(and selected (is-a? selected hierarchical-list-snip%))
[else (send selected toggle-open/closed)]
(void)]))] [else
[select-out (lambda () (void)]))]
(when selected [select-out (lambda ()
(let* ([parent-snip (send (send selected get-parent) get-parent-snip)]) (when selected
(cond (let* ([parent-snip (send (send selected get-parent) get-parent-snip)])
[parent-snip (cond
(let ([parent (send parent-snip get-item)]) [parent-snip
(send parent select #t) (let ([parent (send parent-snip get-item)])
(send parent scroll-to))] (send parent select #t)
[else (send parent scroll-to))]
(void)]))))] [else
[select-in (lambda () (void)]))))]
(cond [select-in (lambda ()
[(and selected (is-a? selected hierarchical-list-snip%)) (cond
(let ([edit-sequence-text (send selected get-editor)]) [(and selected (is-a? selected hierarchical-list-snip%))
(send edit-sequence-text begin-edit-sequence) (let ([edit-sequence-text (send selected get-editor)])
(send selected open) (send edit-sequence-text begin-edit-sequence)
(let ([items (send selected-item get-items)]) (send selected open)
(unless (null? items) (let ([items (send selected-item get-items)])
(send (car items) select #t) (unless (null? items)
(send (car items) scroll-to))) (send (car items) select #t)
(send edit-sequence-text end-edit-sequence))] (send (car items) scroll-to)))
[else (void)]))] (send edit-sequence-text end-edit-sequence))]
[select-next (lambda () (move +1))] [else (void)]))]
[select-prev (lambda () (move -1))] [select-next (lambda () (move +1))]
[select-first (lambda () (let ([l (get-items)]) [select-prev (lambda () (move -1))]
(unless (null? l) [select-first (lambda () (let ([l (get-items)])
(send (car l) select #t) (unless (null? l)
(send (car l) scroll-to))))] (send (car l) select #t)
[select-last (lambda () (let loop ([l (get-items)]) (send (car l) scroll-to))))]
(cond [select-last (lambda () (let loop ([l (get-items)])
[(null? l) (void)] (cond
[(null? (cdr l)) [(null? l) (void)]
(send (car l) select #t) [(null? (cdr l))
(send (car l) scroll-to)] (send (car l) select #t)
[else (loop (cdr l))])))] (send (car l) scroll-to)]
[page-up (lambda () (page 'up))] [else (loop (cdr l))])))]
[page-down (lambda () (page 'down))] [page-up (lambda () (page 'up))]
[show-focus [page-down (lambda () (page 'down))]
(case-lambda [show-focus
[() show-focus?] (case-lambda
[(on?) (set! show-focus? on?)])]) [() show-focus?]
(override [(on?) (set! show-focus? on?)])])
[on-char (override
(lambda (e) [on-char
(unless (send list-keymap handle-key-event this e) (lambda (e)
(super-on-char e)))] (unless (send list-keymap handle-key-event this e)
[on-size (super-on-char e)))]
(lambda (w h) [on-size
(send top-buffer begin-edit-sequence) (lambda (w h)
(send top-buffer reflow-items) (send top-buffer begin-edit-sequence)
(send top-buffer end-edit-sequence))] (send top-buffer reflow-items)
[on-focus (send top-buffer end-edit-sequence))]
(lambda (on?) [on-focus
(when (and selected show-focus?) (lambda (on?)
(send selected show-select #t)) (when (and selected show-focus?)
(super-on-focus on?))]) (send selected show-select #t))
(private (super-on-focus on?))])
[move (lambda (dir) (private
(define (find i l) [move (lambda (dir)
(let loop ([l l][pos 0]) (define (find i l)
(if (null? l) (let loop ([l l][pos 0])
#f (if (null? l)
(if (eq? (car l) i) #f
pos (if (eq? (car l) i)
(loop (cdr l) (add1 pos)))))) pos
;; Scrolling works differently depending on whether selections (loop (cdr l) (add1 pos))))))
;; are involved: ;; Scrolling works differently depending on whether selections
(if selectable? ;; are involved:
(let* ([l (if selected (if selectable?
(send (send selected get-parent) get-items) (let* ([l (if selected
(get-items))] (send (send selected get-parent) get-items)
[pos (if selected-item (get-items))]
(+ dir (find selected-item l)) [pos (if selected-item
(if (negative? dir) (+ dir (find selected-item l))
(sub1 (length l)) (if (negative? dir)
0))]) (sub1 (length l))
(when (< -1 pos (length l)) 0))])
(let ([i (list-ref l pos)]) (when (< -1 pos (length l))
(send i select #t) (let ([i (list-ref l pos)])
(send i scroll-to)))) (send i select #t)
(let ([y-box (box 0.0)] (send i scroll-to))))
[x-box (box 0.0)] (let ([y-box (box 0.0)]
[w-box (box 0.0)] [x-box (box 0.0)]
[h-box (box 0.0)]) [w-box (box 0.0)]
(send (send top-buffer get-admin) get-view x-box y-box w-box h-box) [h-box (box 0.0)])
(let ([y (if (negative? dir) (send (send top-buffer get-admin) get-view x-box y-box w-box h-box)
(- (unbox y-box) 2) (let ([y (if (negative? dir)
(+ (unbox y-box) (unbox h-box) 1))]) (- (unbox y-box) 2)
(send (send top-buffer get-admin) scroll-to (+ (unbox y-box) (unbox h-box) 1))])
(unbox x-box) y (send (send top-buffer get-admin) scroll-to
(unbox w-box) 1)))))] (unbox x-box) y
[page (lambda (dir) (unbox w-box) 1)))))]
;; Scrolling works differently depending on whether selections [page (lambda (dir)
;; are involved: ;; Scrolling works differently depending on whether selections
(if selectable? ;; are involved:
(let ([items (get-items)]) (if selectable?
(unless (null? items) (let ([items (get-items)])
(let ([sbox (box 0)] (unless (null? items)
[ebox (box 0)]) (let ([sbox (box 0)]
(send top-buffer get-visible-line-range sbox ebox) [ebox (box 0)])
(let* ([len (max 1 (sub1 (- (unbox ebox) (unbox sbox))))] (send top-buffer get-visible-line-range sbox ebox)
[l (if (eq? dir 'up) (let* ([len (max 1 (sub1 (- (unbox ebox) (unbox sbox))))]
(max 0 (- (unbox sbox) len)) [l (if (eq? dir 'up)
(min (sub1 (length items)) (+ (unbox ebox) len)))] (max 0 (- (unbox sbox) len))
[i (list-ref items l)]) (min (sub1 (length items)) (+ (unbox ebox) len)))]
(send i select #t) [i (list-ref items l)])
(send i scroll-to))))) (send i select #t)
(send top-buffer move-position dir #f 'page)))]) (send i scroll-to)))))
(private-field (send top-buffer move-position dir #f 'page)))])
[selectable? #t] (private-field
[show-focus? #f]) [selectable? #t]
(private [show-focus? #f])
[do-select (lambda (item s) (private
(when selectable? [do-select (lambda (item s)
(unless (eq? item selected-item) (cond
(when selected (send selected show-select #f)) [(and selectable?
(set! selected (if item s #f)) item
(set! selected-item item) (send item get-allow-selection?))
(when selected (send selected show-select #t)) (unless (eq? item selected-item)
(on-select item))))]) (when selected (send selected show-select #f))
(private-field (set! selected (if item s #f))
[top-buffer (make-object hierarchical-list-text% this (lambda (i s) (do-select i s)) 0 #f)] (set! selected-item item)
[selected #f] (when selected (send selected show-select #t))
[selected-item #f]) (on-select item))]
(sequence [item
(super-init parent top-buffer '(no-hscroll)) (on-click item)]))])
(send top-buffer set-cursor arrow-cursor) (private-field
(min-width 150) [top-buffer (make-object hierarchical-list-text% this (lambda (i s) (do-select i s)) 0 #f)]
(min-height 200))))))) [selected #f]
[selected-item #f])
(sequence
(super-init parent top-buffer '(no-hscroll))
(send top-buffer set-cursor arrow-cursor)
(min-width 150)
(min-height 200)))))))