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

...

Browse Source 
original commit: a6ce24ee031d71a739a111cd2ae68d44b3745321
This commit is contained in:
Robby Findler 2001-09-18 02:09:02 +00:00
parent 745a3d73a8
commit 422acdfbb5
4 changed files with 41 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/framework/private/exit.ss
View File

@ -5,7 +5,8 @@
"sig.ss"
"../gui-utils-sig.ss"
(lib "mred-sig.ss" "mred")
(lib "file.ss"))
(lib "file.ss")
(lib "etc.ss"))
(provide exit@)
@ -45,8 +46,11 @@
(define exiting? #f)
(define (can-exit?) (and (user-oks-exit)
(andmap (lambda (cb) (cb)) can?-callbacks)))
(define can-exit?
(opt-lambda ([skip-user-query? #f])
(and (or skip-user-query?
(user-oks-exit))
(andmap (lambda (cb) (cb)) can?-callbacks))))
(define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks))
(define (user-oks-exit)
@ -65,10 +69,11 @@
user-says)
#t))
(define (-exit)
(unless exiting?
(set! exiting? #t)
(when (can-exit?)
(on-exit)
(queue-callback (lambda () (exit))))
(set! exiting? #f))))))
(define -exit
(opt-lambda ([skip-user-query? #f])
(unless exiting?
(set! exiting? #t)
(when (can-exit? skip-user-query?)
(on-exit)
(queue-callback (lambda () (exit))))
(set! exiting? #f)))))))

24
collects/framework/private/icon.ss
View File

@ -56,21 +56,21 @@
(begin
(set! icon (make-object bitmap% p type))
icon)))))
(define (make-cursor name fallback)
(let ([csr (make-object cursor%
(build-path (collection-path "icons") name)
'gif
8
8)])
(if (send csr ok?)
csr
(make-object cursor% fallback))))
(define (make-cursor name mask fallback)
(let* ([msk-b (make-object bitmap% (build-path (collection-path "icons") mask))]
[csr-b (make-object bitmap% (build-path (collection-path "icons") name))])
(if (and (send msk-b ok?)
(send csr-b ok?))
(let ([csr (make-object cursor% msk-b csr-b 7 7)])
(if (send csr ok?)
csr
(make-object cursor% fallback)))
(make-object cursor% fallback))))
(define up/down-cursor (make-cursor "up-down-cursor.gif" 'size-n/s))
(define up/down-cursor (make-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s))
(define (get-up/down-cursor) up/down-cursor)
(define left/right-cursor (make-cursor "left-right-cursor.gif" 'size-e/w))
(define left/right-cursor (make-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w))
(define (get-left/right-cursor) left/right-cursor)
(define gc-on-bitmap #f)

18
collects/framework/private/standard-menus-items.ss
View File

@ -36,19 +36,19 @@
items)
(define-struct generic (name initializer))
(define-struct (generic/docs struct:generic) (documentation))
(define-struct (generic-override struct:generic/docs) ())
(define-struct (generic-method struct:generic/docs) ())
(define-struct (generic-private-field struct:generic) ())
(define-struct (generic/docs generic) (documentation))
(define-struct (generic-override generic/docs) ())
(define-struct (generic-method generic/docs) ())
(define-struct (generic-private-field generic) ())
(define-struct menu-item (menu-name))
(define (menu-name->get-menu-name menu-item)
(string->symbol
(format "get-~a" (menu-item-menu-name menu-item))))
(define-struct (before/after struct:menu-item) (name procedure))
(define-struct (before struct:before/after) ())
(define-struct (after struct:before/after) ())
(define-struct (before/after menu-item) (name procedure))
(define-struct (before before/after) ())
(define-struct (after before/after) ())
(define (before/after->name before/after)
(string->symbol (format "~a:~a-~a"
(menu-item-menu-name before/after)
@ -57,14 +57,14 @@
"after")
(before/after-name before/after))))
(define-struct (between struct:menu-item) (before after procedure))
(define-struct (between menu-item) (before after procedure))
(define (between->name between)
(string->symbol (format "~a:between-~a-and-~a"
(menu-item-menu-name between)
(between-before between)
(between-after between))))
(define-struct (an-item struct:menu-item)
(define-struct (an-item menu-item)
(item-name
help-string
proc

10
collects/framework/splash.ss
View File

@ -64,24 +64,24 @@
(send splash-frame show #f)))
(define (shutdown-splash)
(set! splash-load-handler (lambda (old-load f) (old-load f))))
(set! splash-load-handler (lambda (old-load f expected) (old-load f expected))))
(define funny?
(let ([date (seconds->date (current-seconds))])
(and (= (date-day date) 25)
(= (date-month date) 12))))
(define (splash-load-handler old-load f)
(define (splash-load-handler old-load f expected)
(let ([finalf (splitup-path f)])
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width))
(old-load f)))
(old-load f expected)))
(current-load
(let ([old-load (current-load)])
(lambda (f)
(splash-load-handler old-load f))))
(lambda (f expected)
(splash-load-handler old-load f expected))))
(define funny-gauge%
(class100 canvas% (parent)