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

..

Browse Source 
original commit: d8a74e1ebde399e0ad63cfcb1f8874d6f64cdeb5
This commit is contained in:
Robby Findler 2002-08-23 17:46:47 +00:00
parent 84b51af447
commit a4e60db069
5 changed files with 111 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/framework/gui-utils.ss
View File

@ -235,6 +235,10 @@
(inherit get-dc) (inherit get-dc)
(define/override (on-paint) (define/override (on-paint)
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(send dc set-brush background-brush)
(send dc set-pen background-pen)
(let-values ([(cw ch) (get-client-size)])
(send dc draw-rectangle 0 0 cw ch))
(let loop ([names choices] (let loop ([names choices]
[n 0] [n 0]
[x (get-initial-x dc)]) [x (get-initial-x dc)])
@ -374,6 +378,7 @@
[(button-down/over) button-down/over-brush] [(button-down/over) button-down/over-brush]
[(unselected) unselected-brush] [(unselected) unselected-brush]
[else (error 'draw-name "unknown state: ~s\n" state)])) [else (error 'draw-name "unknown state: ~s\n" state)]))
(send dc set-pen name-box-pen)
(send dc set-clipping-region region) (send dc set-clipping-region region)
(send dc draw-rectangle (send dc draw-rectangle
(bz (min (send p1 get-x) (bz (min (send p1 get-x)
@ -508,6 +513,22 @@
(make-object color% 225 225 255) (make-object color% 225 225 255)
'solid)])) 'solid)]))
;; name-box-pen : pen
;; this pen draws the lines around each individual item
(define name-box-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
;; background-brush : brush
;; this brush is set when drawing the background for the control
(define background-brush
(case (system-type)
[(macosx) (send the-brush-list find-or-create-brush (get-panel-background) 'panel)]
[else (send the-brush-list find-or-create-brush "white" 'solid)]))
;; background-pen : pen
;; this pen is set when drawing the background for the control
(define background-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
;; label-font : font ;; label-font : font
(define label-font (send the-font-list find-or-create-font (define label-font (send the-font-list find-or-create-font
12 12

21
collects/framework/private/frame.ss
View File

@ -211,6 +211,14 @@
(define locked-message (string-constant read-only)) (define locked-message (string-constant read-only))
(define unlocked-message (string-constant read/write)) (define unlocked-message (string-constant read/write))
(define lock-canvas-font (send the-font-list find-or-create-font
(if (eq? (system-type) 'macosx)
13
12)
'system 'normal
'normal
#f))
(define lock-canvas% (define lock-canvas%
(class100 canvas% (parent . args) (class100 canvas% (parent . args)
(private-field (private-field
@ -226,25 +234,26 @@
(lambda () (lambda ()
(let* ([dc (get-dc)] (let* ([dc (get-dc)]
[draw [draw
(lambda (str bg-color line-color) (lambda (str bg-color bg-style line-color)
(send dc set-font lock-canvas-font)
(let-values ([(w h) (get-client-size)] (let-values ([(w h) (get-client-size)]
[(tw th ta td) (send dc get-text-extent str)]) [(tw th ta td) (send dc get-text-extent str)])
(send dc set-pen (send the-pen-list find-or-create-pen line-color 1 'solid)) (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 'solid))
(send dc set-brush (send the-brush-list find-or-create-brush bg-color 'solid)) (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
(send dc draw-rectangle 0 0 w h) (send dc draw-rectangle 0 0 w h)
(send dc draw-text str (send dc draw-text str
(- (/ w 2) (/ tw 2)) (- (/ w 2) (/ tw 2))
(- (/ h 2) (/ th 2)))))]) (- (/ h 2) (/ th 2)))))])
(if locked? (if locked?
(draw locked-message "yellow" "black") (draw locked-message "yellow" 'solid "black")
(draw unlocked-message (get-panel-background) (get-panel-background)))))]) (draw unlocked-message (get-panel-background) 'panel (get-panel-background)))))])
(inherit min-width min-height stretchable-width stretchable-height) (inherit min-width min-height stretchable-width stretchable-height)
(sequence (sequence
(apply super-init parent args) (apply super-init parent args)
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(send dc set-font (send parent get-label-font)) (send dc set-font (send parent get-label-font))
(let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message)] (let-values ([(w1 h1 _1 _2) (send dc get-text-extent locked-message lock-canvas-font)]
[(w2 h2 _3 _4) (send dc get-text-extent unlocked-message)]) [(w2 h2 _3 _4) (send dc get-text-extent unlocked-message lock-canvas-font)])
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #t) (stretchable-height #t)
(min-width (inexact->exact (floor (max w1 w2)))) (min-width (inexact->exact (floor (max w1 w2))))

12
collects/framework/private/gen-standard-menus.ss
View File

@ -14,8 +14,7 @@
,(an-item->help-string-name item) ,(an-item->help-string-name item)
,(an-item->on-demand-name item) ,(an-item->on-demand-name item)
,(an-item->create-menu-item-name item)) ,(an-item->create-menu-item-name item))
`[define ,(an-item->callback-name item) `[define ,(an-item->callback-name item) ,(an-item-proc item)]
,(or (an-item-proc item) `(lambda (x y) (void)))]
`[define ,(an-item->get-item-name item) `[define ,(an-item->get-item-name item)
(lambda () ,(an-item->item-name item))] (lambda () ,(an-item->item-name item))]
`[define ,(an-item->string-name item) `[define ,(an-item->string-name item)
@ -25,7 +24,7 @@
`[define ,(an-item->on-demand-name item) `[define ,(an-item->on-demand-name item)
,(an-item-on-demand item)] ,(an-item-on-demand item)]
`[define ,(an-item->create-menu-item-name item) `[define ,(an-item->create-menu-item-name item)
(lambda () ,(not (not (an-item-proc item))))]))) (lambda () ,(an-item-create item))])))
;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause)) ;; build-before-super-clause : ((X -> sym) (X sexp) -> X -> (listof clause))
(define build-before-super-clause (define build-before-super-clause
@ -35,7 +34,12 @@
`[define ,(->name obj) `[define ,(->name obj)
,(case (-procedure obj) ,(case (-procedure obj)
[(nothing) '(lambda (menu) (void))] [(nothing) '(lambda (menu) (void))]
[(separator) '(lambda (menu) (make-object separator-menu-item% menu))])])))) [(separator) '(lambda (menu) (make-object separator-menu-item% menu))]
[(nothing-on-macosx)
'(lambda (menu)
(unless (eq? (system-type) 'macosx)
(make-object separator-menu-item% menu)))]
[else (error 'gen-standard-menus "unknown between sym: ~e" (-procedure obj))])]))))
;; build-before-super-between-clause : between -> (listof clause) ;; build-before-super-between-clause : between -> (listof clause)
(define build-before-super-between-clause (define build-before-super-between-clause

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

@ -17,6 +17,8 @@
[group : framework:group^] [group : framework:group^]
[handler : framework:handler^]) [handler : framework:handler^])
(application-preferences-handler (lambda () (preferences:show-dialog)))
;; preferences ;; preferences
(preferences:set-default 'framework:recent-max-count (preferences:set-default 'framework:recent-max-count
50 50

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

@ -18,7 +18,7 @@
(struct between (before after procedure)) (struct between (before after procedure))
(struct an-item (item-name help-string proc key menu-string on-demand)) (struct an-item (item-name help-string proc key menu-string on-demand create))
(struct a-submenu-item ()) (struct a-submenu-item ())
;; an-item -> symbol ;; an-item -> symbol
@ -71,7 +71,8 @@
proc proc
key key
menu-string menu-string
on-demand)) on-demand
create))
(define-struct (a-submenu-item an-item) ()) (define-struct (a-submenu-item an-item) ())
(define (an-item->callback-name item) (define (an-item->callback-name item)
@ -214,49 +215,62 @@
'(lambda (item control) (handler:edit-file #f) #t) '(lambda (item control) (handler:edit-file #f) #t)
#\n #\n
'(string-constant new-menu-item) '(string-constant new-menu-item)
on-demand-do-nothing) on-demand-do-nothing
#t)
(make-between 'file-menu 'new 'open 'nothing) (make-between 'file-menu 'new 'open 'nothing)
(make-an-item 'file-menu 'open '(string-constant open-info) (make-an-item 'file-menu 'open '(string-constant open-info)
'(lambda (item control) (handler:open-file) #t) '(lambda (item control) (handler:open-file) #t)
#\o #\o
'(string-constant open-menu-item) '(string-constant open-menu-item)
on-demand-do-nothing) on-demand-do-nothing
(make-a-submenu-item 'file-menu 'open-recent '(string-constant open-recent-info) #t)
'(lambda (x y) (void)) ;; hack to avoid rewriting lots of stuff (really shouldn't have this) (make-a-submenu-item 'file-menu 'open-recent
#f ;; this also shouldn't need to be here '(string-constant open-recent-info)
'(lambda (x y) (void))
#f
'(string-constant open-recent-menu-item) '(string-constant open-recent-menu-item)
'(lambda (menu) '(lambda (menu)
(handler:install-recent-items menu))) (handler:install-recent-items menu))
#t)
(make-between 'file-menu 'open 'revert 'nothing) (make-between 'file-menu 'open 'revert 'nothing)
(make-an-item 'file-menu 'revert (make-an-item 'file-menu 'revert
'(string-constant revert-info) '(string-constant revert-info)
#f #f '(lambda (item control) (void))
#f
'(string-constant revert-menu-item) '(string-constant revert-menu-item)
on-demand-do-nothing) on-demand-do-nothing
#f)
(make-between 'file-menu 'revert 'save 'nothing) (make-between 'file-menu 'revert 'save 'nothing)
(make-an-item 'file-menu 'save (make-an-item 'file-menu 'save
'(string-constant save-info) '(string-constant save-info)
#f #\s '(lambda (item control) (void))
#\s
'(string-constant save-menu-item) '(string-constant save-menu-item)
on-demand-do-nothing) on-demand-do-nothing
#f)
(make-an-item 'file-menu 'save-as (make-an-item 'file-menu 'save-as
'(string-constant save-as-info) '(string-constant save-as-info)
#f #f '(lambda (item control) (void))
#f
'(string-constant save-as-menu-item) '(string-constant save-as-menu-item)
on-demand-do-nothing) on-demand-do-nothing
#f)
(make-between 'file-menu 'save-as 'print 'separator) (make-between 'file-menu 'save-as 'print 'separator)
(make-an-item 'file-menu 'print (make-an-item 'file-menu 'print
'(string-constant print-info) '(string-constant print-info)
#f #\p '(lambda (item control) (void))
#\p
'(string-constant print-menu-item) '(string-constant print-menu-item)
on-demand-do-nothing) on-demand-do-nothing
#f)
(make-between 'file-menu 'print 'close 'separator) (make-between 'file-menu 'print 'close 'separator)
(make-an-item 'file-menu 'close (make-an-item 'file-menu 'close
'(string-constant close-info) '(string-constant close-info)
'(lambda (item control) (when (can-close?) (on-close) (show #f)) #t) '(lambda (item control) (when (can-close?) (on-close) (show #f)) #t)
#\w #\w
'(string-constant close-menu-item) '(string-constant close-menu-item)
on-demand-do-nothing) on-demand-do-nothing
#t)
(make-between 'file-menu 'close 'quit 'nothing) (make-between 'file-menu 'close 'quit 'nothing)
(make-an-item 'file-menu 'quit (make-an-item 'file-menu 'quit
'(string-constant quit-info) '(string-constant quit-info)
@ -267,7 +281,8 @@
'(if (eq? (system-type) 'windows) '(if (eq? (system-type) 'windows)
(string-constant quit-menu-item-windows) (string-constant quit-menu-item-windows)
(string-constant quit-menu-item-others)) (string-constant quit-menu-item-others))
on-demand-do-nothing) on-demand-do-nothing
'(not (eq? (system-type) 'macosx)))
(make-after 'file-menu 'quit 'nothing) (make-after 'file-menu 'quit 'nothing)
(make-an-item 'edit-menu 'undo (make-an-item 'edit-menu 'undo
@ -275,33 +290,38 @@
(edit-menu:do 'undo) (edit-menu:do 'undo)
#\z #\z
'(string-constant undo-menu-item) '(string-constant undo-menu-item)
(edit-menu:can-do-on-demand 'undo)) (edit-menu:can-do-on-demand 'undo)
#t)
(make-an-item 'edit-menu 'redo (make-an-item 'edit-menu 'redo
'(string-constant redo-info) '(string-constant redo-info)
(edit-menu:do 'redo) (edit-menu:do 'redo)
#\y #\y
'(string-constant redo-menu-item) '(string-constant redo-menu-item)
(edit-menu:can-do-on-demand 'redo)) (edit-menu:can-do-on-demand 'redo)
#t)
(make-between 'edit-menu 'redo 'cut 'separator) (make-between 'edit-menu 'redo 'cut 'separator)
(make-an-item 'edit-menu 'cut '(string-constant cut-info) (make-an-item 'edit-menu 'cut '(string-constant cut-info)
(edit-menu:do 'cut) (edit-menu:do 'cut)
#\x #\x
'(string-constant cut-menu-item) '(string-constant cut-menu-item)
(edit-menu:can-do-on-demand 'cut)) (edit-menu:can-do-on-demand 'cut)
#t)
(make-between 'edit-menu 'cut 'copy 'nothing) (make-between 'edit-menu 'cut 'copy 'nothing)
(make-an-item 'edit-menu 'copy (make-an-item 'edit-menu 'copy
'(string-constant copy-info) '(string-constant copy-info)
(edit-menu:do 'copy) (edit-menu:do 'copy)
#\c #\c
'(string-constant copy-menu-item) '(string-constant copy-menu-item)
(edit-menu:can-do-on-demand 'copy)) (edit-menu:can-do-on-demand 'copy)
#t)
(make-between 'edit-menu 'copy 'paste 'nothing) (make-between 'edit-menu 'copy 'paste 'nothing)
(make-an-item 'edit-menu 'paste (make-an-item 'edit-menu 'paste
'(string-constant paste-info) '(string-constant paste-info)
(edit-menu:do 'paste) (edit-menu:do 'paste)
#\v #\v
'(string-constant paste-menu-item) '(string-constant paste-menu-item)
(edit-menu:can-do-on-demand 'paste)) (edit-menu:can-do-on-demand 'paste)
#t)
(make-between 'edit-menu 'paste 'clear 'nothing) (make-between 'edit-menu 'paste 'clear 'nothing)
(make-an-item 'edit-menu 'clear (make-an-item 'edit-menu 'clear
'(string-constant clear-info) '(string-constant clear-info)
@ -310,47 +330,57 @@
'(if (eq? (system-type) 'windows) '(if (eq? (system-type) 'windows)
(string-constant clear-menu-item-windows) (string-constant clear-menu-item-windows)
(string-constant clear-menu-item-windows)) (string-constant clear-menu-item-windows))
(edit-menu:can-do-on-demand 'clear)) (edit-menu:can-do-on-demand 'clear)
#t)
(make-between 'edit-menu 'clear 'select-all 'nothing) (make-between 'edit-menu 'clear 'select-all 'nothing)
(make-an-item 'edit-menu 'select-all (make-an-item 'edit-menu 'select-all
'(string-constant select-all-info) '(string-constant select-all-info)
(edit-menu:do 'select-all) (edit-menu:do 'select-all)
#\a #\a
'(string-constant select-all-menu-item) '(string-constant select-all-menu-item)
(edit-menu:can-do-on-demand 'select-all)) (edit-menu:can-do-on-demand 'select-all)
#t)
(make-between 'edit-menu 'select-all 'find 'separator) (make-between 'edit-menu 'select-all 'find 'separator)
(make-an-item 'edit-menu 'find (make-an-item 'edit-menu 'find
'(string-constant find-info) '(string-constant find-info)
#f '(lambda (item control) (void))
#\f #\f
'(string-constant find-menu-item) '(string-constant find-menu-item)
edit-menu:edit-target-on-demand) edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'find-again (make-an-item 'edit-menu 'find-again
'(string-constant find-again-info) '(string-constant find-again-info)
#f '(lambda (item control) (void))
#\g #\g
'(string-constant find-again-menu-item) '(string-constant find-again-menu-item)
edit-menu:edit-target-on-demand) edit-menu:edit-target-on-demand
#f)
(make-an-item 'edit-menu 'replace-and-find-again (make-an-item 'edit-menu 'replace-and-find-again
'(string-constant replace-and-find-again-info) '(string-constant replace-and-find-again-info)
#f #\h '(lambda (item control) (void))
#\h
'(string-constant replace-and-find-again-menu-item) '(string-constant replace-and-find-again-menu-item)
edit-menu:edit-target-on-demand) edit-menu:edit-target-on-demand
(make-between 'edit-menu 'find 'preferences 'separator) #f)
(make-between 'edit-menu 'find 'preferences
'nothing-on-macosx)
(make-an-item 'edit-menu 'preferences (make-an-item 'edit-menu 'preferences
'(string-constant preferences-info) '(string-constant preferences-info)
'(lambda (item control) (preferences:show-dialog) #t) '(lambda (item control) (preferences:show-dialog) #t)
#\; #\;
'(string-constant preferences-menu-item) '(string-constant preferences-menu-item)
on-demand-do-nothing) on-demand-do-nothing
'(not (eq? (system-type) 'macosx)))
(make-after 'edit-menu 'preferences 'nothing) (make-after 'edit-menu 'preferences 'nothing)
(make-before 'help-menu 'about 'nothing) (make-before 'help-menu 'about 'nothing)
(make-an-item 'help-menu 'about (make-an-item 'help-menu 'about
'(string-constant about-info) '(string-constant about-info)
#f '(lambda (item control) (void))
#f #f
'(string-constant about-menu-item) '(string-constant about-menu-item)
on-demand-do-nothing) on-demand-do-nothing
#f)
(make-after 'help-menu 'about 'nothing)))) (make-after 'help-menu 'about 'nothing))))