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

...

Browse Source 
original commit: 9b70ee3537fe9d32d23f6a132bac91ae03984bf5
This commit is contained in:
Robby Findler 1998-10-20 19:48:11 +00:00
parent f37af6ed72
commit f93286b505
10 changed files with 65 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/editor.ss
View File

@ -180,7 +180,7 @@
(let ([keymap (get-keymap)])
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap keymap:file #f)))))
(send keymap chain-to-keymap (keymap:get-file) #f)))))
(define backup-autosave<%>
(interface (basic<%>)

24
collects/framework/frame.ss
View File

@ -33,17 +33,27 @@
make-root-area-container))
(define basic-mixin
(mixin (frame<%>) (basic<%>) args
(rename [super-can-close? can-close?]
[super-on-close on-close]
[super-on-focus on-focus])
(override
[can-close?
(lambda ()
(send group:the-frame-group
can-remove-frame?
this))]
(and (super-can-close?)
(send (group:get-the-frame-group)
can-remove-frame?
this)))]
[on-close
(lambda ()
(send group:the-frame-group
(super-on-close)
(send (group:get-the-frame-group)
remove-frame
this))])
this))]
[on-focus
(lambda (on?)
(super-on-focus)
(when on?
(send (group:get-the-frame-group) set-active-frame this)))])
(public
[get-area-container% (lambda () vertical-panel%)]
[get-menu-bar% (lambda () menu-bar%)]
@ -95,7 +105,7 @@
[do-label
(lambda ()
(super-set-label (get-entire-label))
(send group:the-frame-group frame-label-changed this))])
(send (group:get-the-frame-group) frame-label-changed this))])
(public
[get-entire-label
@ -410,7 +420,7 @@
(set! replace-edit (make-object text%))
(for-each (lambda (keymap)
(send keymap chain-to-keymap
keymap:search
(keymap:get-search)
#t))
(list (send find-edit get-keymap)
(send replace-edit get-keymap)))))

10
collects/framework/group.ss
View File

@ -93,7 +93,7 @@
(set-close-menu-item-state! a-frame #t))
frames))))])
(public
[set-empty-callbacks
[set-empty-callbacks
(lambda (test close-down)
(set! empty-test test)
(set! empty-close-down close-down))]
@ -197,4 +197,10 @@
frame
(loop (cdr frames))))]))))])))
(define the-frame-group (make-object %)))
(define the-frame-group #f)
(define get-the-frame-group
(lambda ()
(set! the-frame-group (make-object %))
(set! get-the-frame-group (lambda () the-frame-group))
(get-the-frame-group))))

5
collects/framework/guiutils.ss
View File

@ -106,8 +106,7 @@
result)))
(define get-choice
(opt-lambda (message true-choice false-choice
[title "Warning"][x -1][y -1])
(opt-lambda (message true-choice false-choice [title "Warning"])
(let* ([result (void)]
[choice-dialog%
(class dialog% ()
@ -122,7 +121,7 @@
(set! result #f)
(show #f))])
(sequence
(super-init () title #t x y)
(super-init () title #t -1 -1)
(let* ([messages
(let loop ([m message])
(let ([match (regexp-match (format "([^~n]*)~n(.*)")

18
collects/framework/handler.ss
View File

@ -82,22 +82,18 @@
(lambda (name)
(find-named-handler name format-handlers)))
(define edit-file-consult-group (make-parameter #t))
; Open a file for editing
(define edit-file
(opt-lambda (filename
[make-default
(lambda (filename)
(make-object frame:text-info-file% filename))]
[consult-group? (edit-file-consult-group)])
(lambda ()
(make-object frame:text-info-file% filename))])
(gui-utils:show-busy-cursor
(lambda ()
(if filename
(let ([already-open (and consult-group?
(send group:the-frame-group
locate-file
filename))])
(let ([already-open (send (group:get-the-frame-group)
locate-file
filename)])
(if already-open
(begin
(send already-open show #t)
@ -108,8 +104,8 @@
#f)])
(if handler
(handler filename)
(make-default filename)))))
(make-default filename))))))
(make-default)))))
(make-default))))))
; Query the user for a file and then edit it

33
collects/framework/icon.ss
View File

@ -47,7 +47,6 @@
(define get-autowrap-bitmap (load-icon bitmap% "return.xbm" 'xbm))
(define get-paren-highlight-bitmap (load-icon bitmap% "paren.xbm" 'xbm))
(define get-reset-console-bitmap (load-icon bitmap% "reset.xbm" 'xbm))
(define get
(let ([icon #f]
@ -60,25 +59,21 @@
(set! icon (make-object bitmap% p 'xbm))
icon)))))
(define-values (get-gc-on-dc get-gc-width get-gc-height)
(let* ([get-bitmap (load-icon bitmap%
"recycle.gif"
'gif)]
[bitmap #f]
[bdc #f]
[fetch
(lambda ()
(unless bdc
(set! bdc (make-object bitmap-dc%))
(set! bitmap (get-bitmap))
(send bdc select-object bitmap)))])
(values (lambda () (fetch) bdc)
(lambda () (fetch) (if (send bitmap ok?)
(send bitmap get-width)
(define gc-on-bitmap #f)
(define gc-on-bdc #f)
(define (fetch)
(unless gc-on-bdc
(set! gc-on-bdc (make-object bitmap-dc%))
(set! gc-on-bitmap ((load-icon bitmap% "recycle.gif" 'gif)))
(send gc-on-bdc select-object gc-on-bitmap)))
(define (get-gc-on-dc) (fetch) gc-on-bdc)
(define (get-gc-width) (fetch) (if (send gc-on-bitmap ok?)
(send gc-on-bitmap get-width)
10))
(lambda () (fetch) (if (send bitmap ok?)
(send bitmap get-height)
10)))))
(define (get-gc-height) (fetch) (if (send gc-on-bitmap ok?)
(send gc-on-bitmap get-height)
10))
(define get-gc-off-dc
(let ([bdc #f])

7
collects/framework/keys.ss
View File

@ -6,6 +6,8 @@
[scheme-paren : framework:scheme-paren^]
[frame : framework:frame^])
(rename [-get-file get-file])
; This is a list of keys that are typed with the SHIFT key, but
; are not normally thought of as shifted. It will have to be
; changed for different keyboards.
@ -862,9 +864,12 @@
(define global (make-object keymap%))
(setup-global global)
(define (get-global) global)
(define file (make-object keymap%))
(setup-file file)
(define (-get-file) file)
(define search (make-object keymap%))
(setup-search search))
(setup-search search)
(define (get-search) search))

4
collects/framework/main.ss
View File

@ -180,7 +180,7 @@
(semaphore-post s))))))))
(let ([at-most-one (at-most-one-maker)])
(send group:the-frame-group set-empty-callbacks
(send (group:get-the-frame-group) set-empty-callbacks
(lambda ()
(at-most-one (void)
(lambda () (exit:exit #t))))
@ -194,7 +194,7 @@
(at-most-one
#t
(lambda ()
(send group:the-frame-group close-all))))))
(send (group:get-the-frame-group) close-all))))))
;; misc other stuff

16
collects/framework/sig.ss
View File

@ -163,7 +163,7 @@
(define-signature framework:group^
(%
the-frame-group))
get-the-frame-group))
(define-signature framework:handler^
(handler? handler-name handler-extension handler-handler
@ -179,7 +179,6 @@
get-paren-highlight-bitmap
get-autowrap-bitmap
get-reset-console-bitmap
get-lock-bitmap
get-lock-bdc
@ -194,21 +193,18 @@
get-gc-height))
(define-signature framework:keymap^
(shifted-key-list
keyerr
set-keymap-error-handler
(set-keymap-error-handler
set-keymap-implied-shifts
make-meta-prefix-list
send-map-function-meta
make-meta-prefix-list
setup-global
setup-search
setup-file
global
search
file))
get-global
get-search
get-file))
(define-signature framework:match-cache^
(%))

4
collects/framework/text.ss
View File

@ -310,7 +310,7 @@
(let ([keymap (get-keymap)])
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap keymap:global #f)))))
(send keymap chain-to-keymap (keymap:get-global) #f)))))
(define file<%> (interface (basic<%>)))
@ -405,7 +405,7 @@
(let ([keymap (get-keymap)])
(keymap:set-keymap-error-handler keymap)
(keymap:set-keymap-implied-shifts keymap)
(send keymap chain-to-keymap keymap:search #f)))))
(send keymap chain-to-keymap (keymap:get-search) #f)))))
(define return-mixin
(mixin (text<%>) (text<%>) (return . args)