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

...

Browse Source 
original commit: 1d5edeb1d820309361c64a8df93603f7e3688008
This commit is contained in:
Mike MacHenry 2003-12-03 19:33:23 +00:00
parent 3894596b2a
commit cbcf1fba9a
3 changed files with 92 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/test-suite/private/button-snip.ss
View File

@ -3,9 +3,7 @@
(require
(lib "mred.ss" "mred")
(lib "class.ss")
(lib "etc.ss")
(lib "locked-pasteboard.ss" "mrlib" "private" "aligned-pasteboard")
(lib "click-forwarding-editor.ss" "mrlib"))
(lib "etc.ss"))
(provide
button-snip%
@ -19,6 +17,7 @@
(init-field callback)
(field
[got-click? false]
[inside? false]
[image (car images)]
[depressed (cdr images)])
@ -29,21 +28,26 @@
(set! depressed (cdr i))
(load-file image))
;; Should I be calling super-on-event?
(rename [super-on-event on-event])
(define/override (on-event dc x y editorx editory event)
(case (send event get-event-type)
[(left-down)
(set! got-click? true)
(set! inside? true)
(load-file depressed)]
[(left-up)
(when got-click?
(load-file image)
(set! got-click? false)
(callback this event))]
(load-file image)
(when (and got-click? inside?)
(callback this event))
(set! got-click? false)
(set! inside? false)]
[(enter)
(set! inside? true)
(when got-click?
(load-file depressed))]
[(leave)
(set! inside? false)
(when got-click?
(load-file image))]
[else (void)]))
@ -61,16 +65,21 @@
(lambda (b e)
(if (= state 1)
(begin
(callback1 b e)
(set-images images2)
(set! state 2))
(set! state 2)
(callback1 b e))
(begin
(callback2 b e)
(set-images images1)
(set! state 1))))))))
(set! state 1)
(callback2 b e))))))))
;;;;;;;;;;
;; tests
(require
(lib "locked-pasteboard.ss" "mrlib" "private" "aligned-pasteboard")
(lib "click-forwarding-editor.ss" "mrlib"))
(define (test)
(define f (new frame% (label "test") (width 200) (height 200)))
(define e (new (locked-pasteboard-mixin
@ -78,7 +87,7 @@
(define c (new editor-canvas% (editor e) (parent f)))
(define b (new button-snip%
(images (cons (build-path (collection-path "icons") "turn-up.gif")
(build-path (collection-path "icons") "turn-down.gif")))
(build-path (collection-path "icons") "turn-up-click.gif")))
(callback
(lambda (b e)
(message-box "Test" "Horray!")))))
@ -90,17 +99,20 @@
(define e (new (locked-pasteboard-mixin
(click-forwarding-editor-mixin pasteboard%))))
(define c (new editor-canvas% (editor e) (parent f)))
(define t (new text%))
(define es (new editor-snip% (editor t)))
(define b (new toggle-button-snip%
(images1 (cons (build-path (collection-path "icons") "turn-up.gif")
(build-path (collection-path "icons") "turn-up.gif")))
(build-path (collection-path "icons") "turn-up-click.gif")))
(images2 (cons (build-path (collection-path "icons") "turn-down.gif")
(build-path (collection-path "icons") "turn-down.gif")))
(build-path (collection-path "icons") "turn-down-click.gif")))
(callback1
(lambda (b e)
(message-box "Test" "Horray!")))
(send* t (erase) (insert "Up"))))
(callback2
(lambda (b e)
(message-box "Test" "Horray, Horray!")))))
(send* t (erase) (insert "Down"))))))
(send e insert es 50 0)
(send e insert b)
(send f show #t))
)

6
collects/test-suite/private/fixed-width-label-snip.ss
View File

@ -18,6 +18,12 @@
(top-margin 5)
(bottom-margin 5))
(unless (member label labels)
(error 'fixed-width-label-snip
"Instantiation of label-snip expected one of ~s. Given ~s"
labels
label))
(define (get-string-size dc string)
(let-values ([(width height baseline vspace)
(send dc get-text-extent string)])

58
collects/test-suite/private/tabbable-text.ss Normal file
View File

@ -0,0 +1,58 @@
(module tabbable-text mzscheme
(require
(lib "class.ss")
(lib "list.ss")
(lib "etc.ss")
(lib "framework.ss" "framework")
(lib "mred.ss" "mred")
(lib "contract.ss"))
(define tabbable-text<%> (interface () set-caret-owner))
(provide/contract
(tabbable-text<%> interface?)
(tabbable-text-mixin mixin-contract)
(set-tabbing (() (listof (is-a?/c tabbable-text<%>)) . ->* . (void?))))
(define tabbable-text-mixin
(mixin (editor:keymap<%>) (tabbable-text<%>)
(init-field
[ahead #f]
[back #f])
;; get-keymaps (-> (listof keymap%))
;; the list of keymaps associated with this text
(rename [super-get-keymaps get-keymaps])
(define/override (get-keymaps)
(let ([keymap (make-object keymap%)])
(when ahead
(send keymap add-function "tab-ahead"
(lambda (ignored event)
(ahead)))
(send keymap map-function ":tab" "tab-ahead"))
(when back
(send keymap add-function "tab-back"
(lambda (ignored event)
(back)))
(send keymap map-function "s:tab" "tab-back"))
(cons keymap (super-get-keymaps))))
(define/public (set-ahead t) (set! ahead t))
(define/public (set-back t) (set! back t))
(super-new)))
;; sets the tabbing of all of the texts in the order of the list
(define (set-tabbing . l)
(cond
[(or (empty? l) (empty? (rest l))) (void)]
[else
(send (first l) set-ahead
(lambda () (send (second l) set-caret-owner false 'global)))
(send (second l) set-back
(lambda () (send (first l) set-caret-owner false 'global)))
(apply set-tabbing (rest l))]))
)