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

test case box update: layout, collapsing, evaluation

Browse Source 
original commit: ab1e199d078dcbb8c4a8f0e2b1b47411139c5498
This commit is contained in:
Mike MacHenry 2003-10-21 21:04:56 +00:00
parent 35ca8437b4
commit 03df8d9c74
2 changed files with 199 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/test-suite/private/button-snip.ss Normal file
View File

@ -0,0 +1,106 @@
(module button-snip mzscheme
(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"))
(provide
button-snip%
toggle-button-snip%)
;; a snip of a button that can be pushed to invoke a given callback
(define button-snip%
(class image-snip%
(inherit load-file)
(init images)
(init-field callback)
(field
[got-click? false]
[image (car images)]
[depressed (cdr images)])
;; (string? . -> . void?)
;; set the image to be displayed on the button when it is not clicked
(define/public (set-images i)
(set! image (car i))
(set! depressed (cdr i))
(load-file image))
(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)
(load-file depressed)]
[(left-up)
(when got-click?
(load-file image)
(set! got-click? false)
(callback this event))]
[(enter)
(when got-click?
(load-file depressed))]
[(leave)
(when got-click?
(load-file image))]
[else (void)]))
(super-new)
(load-file image)))
(define toggle-button-snip%
(class button-snip%
(inherit set-images)
(init-field images1 images2 callback1 callback2 (state 1))
(super-new
(images images1)
(callback
(lambda (b e)
(if (= state 1)
(begin
(callback1 b e)
(set-images images2)
(set! state 2))
(begin
(callback2 b e)
(set-images images1)
(set! state 1))))))))
;;;;;;;;;;
;; tests
(define (test)
(define f (new frame% (label "test") (width 200) (height 200)))
(define e (new (locked-pasteboard-mixin
(click-forwarding-editor-mixin pasteboard%))))
(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")))
(callback
(lambda (b e)
(message-box "Test" "Horray!")))))
(send e insert b)
(send f show #t))
(define (test2)
(define f (new frame% (label "test") (width 200) (height 200)))
(define e (new (locked-pasteboard-mixin
(click-forwarding-editor-mixin pasteboard%))))
(define c (new editor-canvas% (editor e) (parent f)))
(define b (new toggle-button-snip%
(images1 (cons (build-path (collection-path "icons") "turn-up.gif")
(build-path (collection-path "icons") "turn-up.gif")))
(images2 (cons (build-path (collection-path "icons") "turn-down.gif")
(build-path (collection-path "icons") "turn-down.gif")))
(callback1
(lambda (b e)
(message-box "Test" "Horray!")))
(callback2
(lambda (b e)
(message-box "Test" "Horray, Horray!")))))
(send e insert b)
(send f show #t))
)

93
collects/test-suite/private/fixed-width-label-snip.ss Normal file
View File

@ -0,0 +1,93 @@
(module fixed-width-label-snip mzscheme
(require
(lib "class.ss")
(lib "list.ss")
(lib "debug.ss" "mike-lib")
(lib "mred.ss" "mred"))
(provide fixed-width-label-snip)
(define (fixed-width-label-snip labels)
(define label-snip%
(class snip%
(inherit set-snipclass)
(init-field
label
(left-margin 5)
(right-margin 5)
(top-margin 5)
(bottom-margin 5))
(define (get-string-size dc string)
(let-values ([(width height baseline vspace)
(send dc get-text-extent string)])
(cons width height)))
(define (get-max-string-size dc strings)
(foldl
(lambda (str sizes)
(let ([these-sizes (get-string-size dc str)])
(cons (max (car these-sizes)
(car sizes))
(max (cdr these-sizes)
(cdr sizes)))))
(get-string-size dc (car strings))
(cdr strings)))
(define/override (get-extent dc x y w h descent space lspace rspace)
(let ([maxes (get-max-string-size dc labels)])
(set-box! w (+ left-margin (car maxes) right-margin))
(set-box! h (+ top-margin (cdr maxes) bottom-margin))))
(rename [super-draw draw])
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(super-draw dc x y left top right bottom dx dy draw-caret)
(let ([max-sizes (get-max-string-size dc labels)]
[sizes (get-string-size dc label)])
(send dc draw-text label
(+ left-margin x (- (car max-sizes) (car sizes)))
(+ y top-margin))))
(rename [super-copy copy])
(define/override (copy)
(super-copy))
(define/override (resize w h) #f)
;; write ((is-a?/c editor-stream-out%) . -> . void?)
;; write the snip out to the stream
(define/override (write f)
(send f put label))
(super-new)
(set-snipclass (new label-snip-class%))))
(define label-snip-class%
(class snip-class%
;; read ((is-a?/c editor-stream-in%) . -> . snip%)
;; read a snip from the stream
(define/override (read f)
(new label-snip% (label (send f get-string))))
(super-new)))
(let ([lsc (new label-snip-class%)])
(send lsc set-classname "...")
(send lsc set-version 1)
(send (get-the-snip-class-list) add lsc))
label-snip%)
(define (test)
(define mylabels (list "Call" "Expected" "Actual"))
(define label% (fixed-width-label-snip mylabels))
(define align? #t)
(define f (new frame% (label "test") (width 175) (height 175)))
(define e (new pasteboard%))
(define c (new editor-canvas% (editor e) (parent f)))
(for-each
(lambda (s)
(send e insert (new label% (label s))))
'("Expected"))
(send f show #t))
)