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

...

Browse Source 
original commit: 5ce90b885b770c91c010100d69cbc5622263bc65
This commit is contained in:
Robby Findler 1999-02-16 03:31:54 +00:00
parent 230c4b5d15
commit 5ebcb7bf53
4 changed files with 116 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

203
collects/framework/finder.ss
View File

@ -149,14 +149,16 @@
[do-dir [do-dir
(lambda (choice event) (lambda (choice event)
(let ([which (send event get-selection)]) (let ([which (send choice get-selection)])
(if (< which (length dirs)) (if (< which (length dirs))
(set-directory (list-ref dirs which)))))] (set-directory (list-ref dirs which)))))]
[do-name-list [do-name-list
(lambda (list-box _) (lambda (list-box evt)
(when (send list-box get-string-selections) (if (eq? (send evt get-event-type) 'list-box-dclick)
(set-edit)))] (do-ok)
(when (send list-box get-string-selection)
(set-edit))))]
[do-result-list [do-result-list
(lambda args #f)] (lambda args #f)]
@ -328,110 +330,106 @@
[left-middle-panel (make-object vertical-panel% middle-panel)] [left-middle-panel (make-object vertical-panel% middle-panel)]
[right-middle-panel (when multi-mode? [right-middle-panel (when multi-mode?
(make-object vertical-panel% middle-panel))] (make-object vertical-panel% middle-panel))]
[name-list% [name-list%
(class-asi list-box% (class-asi list-box%
(inherit (inherit
get-first-visible-item get-string-selection
get-string get-string
get-selection get-selection
get-string-selection get-number
get-number get-first-visible-item
number-of-visible-items number-of-visible-items
set-first-visible-item set-first-visible-item
focus set-selection)
set-selection)
(override
[on-subwindow-char
(lambda (_ key)
(let ([code (send key get-key-code)]
[num-items (get-number)]
[curr-pos (get-selection)])
(cond
[(or (equal? code 'numpad-return)
(equal? code #\return))
(do-ok)]
; look for letter at beginning of a filename
[(char? code)
(letrec
([loop
(lambda (pos)
(unless
(>= pos num-items)
(let ([first-char (string-ref (get-string pos) 0)])
(if (char=? code first-char)
(set-selection-and-edit pos)
(loop (add1 pos))))))])
(loop (add1 curr-pos)))]
; movement keys
[(and (eq? code 'up)
(> curr-pos 0))
(set-selection-and-edit (sub1 curr-pos))]
[(and (eq? code 'down)
(< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)]
[curr-first (get-first-visible-item)]
[new-curr-pos (add1 curr-pos)]
[new-first (if (< new-curr-pos (+ curr-first num-vis))
curr-first ; no scroll needed
(add1 curr-first))])
(set-first-visible-item new-first)
(set-selection-and-edit new-curr-pos))]
[(and (eq? code 'prior)
(> curr-pos 0))
(let* ([num-vis (number-of-visible-items)]
[new-first (- (get-first-visible-item) num-vis)])
(set-first-visible-item (max new-first 0))
(set-selection-and-edit (max 0 (- curr-pos num-vis))))]
[(and (eq? code 'next)
(< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)]
[new-first (+ (get-first-visible-item) num-vis)])
(set-first-visible-item
(min new-first (- (get-number) num-vis)))
(set-selection-and-edit
(min (sub1 num-items) (+ curr-pos num-vis))))]
[else #f])))])
(public (public
[set-selection-and-edit
[set-selection-and-edit ; set selection, update edit box (lambda (pos)
(when (> (get-number) 0)
(lambda (pos) (let* ([first-item (get-first-visible-item)]
(when (> (get-number) 0) [last-item (sub1 (+ (number-of-visible-items)
(let* ([first-item (get-first-visible-item)] first-item))])
[last-item (sub1 (+ (number-of-visible-items) (if (or (< pos first-item) (> pos last-item))
first-item))]) (set-first-visible-item pos))
(if (or (< pos first-item) (> pos last-item)) (set-selection pos)))
(set-first-visible-item pos)) (set-edit))]
(set-selection pos)))
(set-edit))]
[pre-on-char ; set selection according to keystroke
(lambda (_ key)
(let ([code (send key get-key-code)]
[num-items (get-number)]
[curr-pos (get-selection)])
(cond
[(or (equal? code 'numpad-return)
(equal? code #\return))
(do-ok)]
[(equal? code #\tab)
(send directory-field focus)]
; look for letter at beginning of a filename
[(char? code)
(letrec
([loop
(lambda (pos)
(unless
(>= pos num-items)
(let ([first-char (string-ref (get-string pos) 0)])
(if (char=? code first-char)
(set-selection-and-edit pos)
(loop (add1 pos))))))])
(loop (add1 curr-pos)))]
; movement keys
[(and (eq? code 'up)
(> curr-pos 0))
(set-selection-and-edit (sub1 curr-pos))]
[(and (eq? code 'down)
(< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)]
[curr-first (get-first-visible-item)]
[new-curr-pos (add1 curr-pos)]
[new-first (if (< new-curr-pos (+ curr-first num-vis))
curr-first ; no scroll needed
(add1 curr-first))])
(set-first-visible-item new-first)
(set-selection-and-edit new-curr-pos))]
[(and (eq? code 'prior)
(> curr-pos 0))
(let* ([num-vis (number-of-visible-items)]
[new-first (- (get-first-visible-item) num-vis)])
(set-first-visible-item (max new-first 0))
(set-selection-and-edit (max 0 (- curr-pos num-vis))))]
[(and (eq? code 'next)
(< curr-pos (sub1 num-items)))
(let* ([num-vis (number-of-visible-items)]
[new-first (+ (get-first-visible-item) num-vis)])
(set-first-visible-item (min new-first (- (get-number) num-vis)))
(set-selection-and-edit
(min (sub1 num-items) (+ curr-pos num-vis))))]
[else #f])))]
[on-default-action [on-default-action
(lambda () (lambda ()
(when (> (send name-list get-number) 0) (when (> (get-number) 0)
(let* ([which (send name-list get-string-selection)] (let* ([which (get-string-selection)]
[dir (build-path current-dir [dir (build-path current-dir
(make-relative which))]) (make-relative which))])
(if (directory-exists? dir) (if (directory-exists? dir)
(set-directory (mzlib:file:normalize-path dir)) (set-directory (mzlib:file:normalize-path dir))
(if multi-mode? (if multi-mode?
(do-add) (do-add)
(do-ok))))))]))] (do-ok))))))]))]
[name-list (make-object name-list% [name-list (make-object name-list%
#f null left-middle-panel do-name-list #f null left-middle-panel do-name-list
@ -503,10 +501,9 @@
top-panel top-panel
(lambda (button evt) (do-updir))) (lambda (button evt) (do-updir)))
(send dir-choice stretchable-width #t)
(send name-list stretchable-width #t) (send name-list stretchable-width #t)
(send top-panel stretchable-height #f) (send top-panel stretchable-height #f)
(send bottom-panel stretchable-height #f) (send bottom-panel stretchable-height #f)
(when save-mode? (when save-mode?
@ -536,9 +533,7 @@
(private (private
[cancel-button (make-object button% "Cancel" bottom-panel do-cancel)] [cancel-button (make-object button% "Cancel" bottom-panel do-cancel)]
[ok-button [ok-button
(make-object button% (make-object button% "OK" bottom-panel do-ok '(border))])
"OK"
bottom-panel do-ok)])
(sequence (sequence
(cond (cond
[(and start-dir [(and start-dir

1
collects/framework/group.ss
View File

@ -1,6 +1,5 @@
(unit/sig framework:group^ (unit/sig framework:group^
(import mred-interfaces^ (import mred-interfaces^
[exit : framework:exit^]
[frame : framework:frame^] [frame : framework:frame^]
[mzlib:function : mzlib:function^] [mzlib:function : mzlib:function^]
[mzlib:file : mzlib:file^]) [mzlib:file : mzlib:file^])

16
collects/framework/main.ss
View File

@ -178,15 +178,21 @@
(set! test #f) (set! test #f)
(semaphore-post s)))))))) (semaphore-post s))))))))
(preferences:set-default 'framework:just-exit-when-no-frames #t boolean?)
(let ([at-most-one (at-most-one-maker)]) (let ([at-most-one (at-most-one-maker)])
(send (group:get-the-frame-group) set-empty-callbacks (send (group:get-the-frame-group) set-empty-callbacks
(lambda () (lambda ()
(at-most-one (void) (if (preferences:get 'framework:just-exit-when-no-frames)
(lambda () (exit:exit #t)))) (void)
(at-most-one (void)
(lambda () (exit:exit #t)))))
(lambda () (lambda ()
(at-most-one #t (if (preferences:get 'framework:just-exit-when-no-frames)
(lambda () #t
(exit:run-callbacks))))) (at-most-one #t
(lambda ()
(exit:run-callbacks))))))
(exit:insert-callback (exit:insert-callback
(lambda () (lambda ()

5
collects/tests/framework/frame.ss
View File

@ -95,6 +95,7 @@
(lambda () (lambda ()
(send-sexp-to-mred (send-sexp-to-mred
`(begin `(begin
(preferences:set 'framework:exit-when-no-frames #f)
(preferences:set 'framework:file-dialogs 'common) (preferences:set 'framework:file-dialogs 'common)
(send (make-object ,class-expression "test open") show #t))) (send (make-object ,class-expression "test open") show #t)))
(wait-for-frame "test open") (wait-for-frame "test open")
@ -123,7 +124,9 @@
t)) t))
(wait-for-frame "test open") (wait-for-frame "test open")
(send-sexp-to-mred (send-sexp-to-mred
`(test:close-top-level-window (get-top-level-focus-window)))))))) `(begin
(preferences:set 'framework:exit-when-no-frames #t)
(test:close-top-level-window (get-top-level-focus-window)))))))))
(test-open "frame:editor open" 'frame:text%) (test-open "frame:editor open" 'frame:text%)
(test-open "frame:editor open" 'frame:searchable%) (test-open "frame:editor open" 'frame:searchable%)