From 03df8d9c74d7a8888629de92d3cf5e4769e4a49b Mon Sep 17 00:00:00 2001
From: Mike MacHenry <dskippy@ccs.neu.edu>
Date: Tue, 21 Oct 2003 21:04:56 +0000
Subject: [PATCH] test case box update: layout, collapsing, evaluation

original commit: ab1e199d078dcbb8c4a8f0e2b1b47411139c5498
---
 collects/test-suite/private/button-snip.ss    | 106 ++++++++++++++++++
 .../private/fixed-width-label-snip.ss         |  93 +++++++++++++++
 2 files changed, 199 insertions(+)
 create mode 100644 collects/test-suite/private/button-snip.ss
 create mode 100644 collects/test-suite/private/fixed-width-label-snip.ss

diff --git a/collects/test-suite/private/button-snip.ss b/collects/test-suite/private/button-snip.ss
new file mode 100644
index 00000000..ebc63cde
--- /dev/null
+++ b/collects/test-suite/private/button-snip.ss
@@ -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))
+)
\ No newline at end of file
diff --git a/collects/test-suite/private/fixed-width-label-snip.ss b/collects/test-suite/private/fixed-width-label-snip.ss
new file mode 100644
index 00000000..78b54d70
--- /dev/null
+++ b/collects/test-suite/private/fixed-width-label-snip.ss
@@ -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))
+  )
\ No newline at end of file