From 91265dad43fd186de8ae43286a086ae237dd5aed Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Sun, 14 Aug 2011 18:41:18 -0400
Subject: [PATCH] working on the tool ui

---
 tool/button-with-alternatives.rkt | 93 +++++++++++++++++--------------
 tool/tool-ui.rkt                  | 60 ++++++++++++++++++++
 2 files changed, 112 insertions(+), 41 deletions(-)
 create mode 100644 tool/tool-ui.rkt

diff --git a/tool/button-with-alternatives.rkt b/tool/button-with-alternatives.rkt
index f4f3c55..8526450 100644
--- a/tool/button-with-alternatives.rkt
+++ b/tool/button-with-alternatives.rkt
@@ -2,48 +2,59 @@
 
 ;; Implements a button with alternatives.
 
-(require racket/gui/base
-         racket/class)
+(require racket/class
+         racket/list
+         mrlib/name-message
+         framework)
+
+(provide button-with-alternatives%)
+
+
+
+;; Most of this is stolen from the custom controls written in
+;; drracket/private/unit.rkt.  It might be good to generalize this
+;; so it's easier to use.
+(define button-with-alternatives%
+  (class name-message%
+    (init-field parent)
+    (init-field choices-thunk)
+
+    (define currently-selected 
+      (let ([choices (choices-thunk)])
+        (cond
+          [(empty? choices)
+           #f]
+          [else
+           (first (choices-thunk))])))
+    
+    (define/public (get-selection)
+      currently-selected)
+    
+    (define/public (get-choices)
+      (choices-thunk))
+    
+    (define/override (fill-popup menu reset)
+      (for ([ch (choices-thunk)])
+        (make-menu-item menu ch)))
+
+    (define (make-menu-item menu ch)
+      (define item
+        (new (if (and currently-selected
+                      (string=? ch currently-selected))
+                 menu:can-restore-checkable-menu-item%
+                 menu:can-restore-menu-item%)
+             [label (gui-utils:quote-literal-label ch)]
+             [parent menu]
+             [callback (lambda (menu-item control-event)
+                         (set! currently-selected ch))]))
+      (when (string=? ch currently-selected)
+        (send item check #t))
+      item)
+      
+    (super-new [parent parent]
+               [label ""])))
+
 
-(define (whalesong-tool-ui parent-widget
-                           #:on-browser (on-browser
-                                         (lambda ()
-                                           (void)))
-                           #:on-build-package (on-build-package 
-                                               (lambda ()
-                                                 (void))))
-  (define container (new horizontal-pane%
-                         [parent parent-widget]))
-  (define b (new button% 
-                 [label "Whalesong"]
-                 [callback (lambda (b ce)
-                             (define selection 
-                               (send ch get-selection))
-                             (cond
-                               [(= selection 0)
-                                (on-browser)]
-                               [(= selection 1)
-                                (on-build-package)]
-                               [else
-                                (void)]))]
-                 [parent container]))
-  (define ch (new choice% 
-                  [label ""]
-                  [choices (list "Run in browser"
-                                 "Build smartphone package")]
-                  [style '(horizontal-label)]
-                  [parent container]))
-  container)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define f (new frame% [label "test frame"]))
-(whalesong-tool-ui f
-                   #:on-browser 
-                   (lambda () 
-                     (printf "on-browser\n"))
-
-                   #:on-build-package 
-                   (lambda ()
-                     (printf "on-build-package\n")))
-(send f show #t)
\ No newline at end of file
diff --git a/tool/tool-ui.rkt b/tool/tool-ui.rkt
new file mode 100644
index 0000000..705d643
--- /dev/null
+++ b/tool/tool-ui.rkt
@@ -0,0 +1,60 @@
+#lang racket
+(require "button-with-alternatives.rkt"
+         racket/gui/base)
+
+;; Defines the Whalesong tool user interface.  We add a button
+;; with choices to either run the program in the browser, or
+;; build a package.
+
+
+(define (whalesong-tool-ui parent-widget
+                           #:label (label "Run Whalesong")
+                           #:on-browser (on-browser
+                                         (lambda ()
+                                           (void)))
+                           #:on-build-package (on-build-package 
+                                               (lambda ()
+                                                 (void))))
+  (define container (new horizontal-pane%
+                         [parent parent-widget]))
+  
+  (define b 
+    (new button% 
+         [label label]
+         [callback (lambda (b ce)
+                     (define selection 
+                       (send alternatives get-selection))
+                     (cond
+                       [(string=? selection "Run in browser")
+                        (on-browser)]
+                       [(string=? selection "Build smartphone package")
+                        (on-build-package)]
+                       [else
+                        (void)]))]
+         [parent container]))  
+  
+  (define alternatives
+    (new button-with-alternatives% 
+         [parent container]
+         [choices-thunk (lambda () (list "Run in browser"
+                                         "Build smartphone package"))]))
+    #;(define ch (new choice% 
+                  [label ""]
+                  [choices (list "Run in browser"
+                                 "Build smartphone package")]
+                  [style '(horizontal-label)]
+                  [parent container]))
+  container)
+
+
+(define (test)
+  (define f (new frame% [label "test frame"]))
+  (whalesong-tool-ui f
+                     #:on-browser 
+                     (lambda () 
+                       (printf "on-browser\n"))
+                     
+                     #:on-build-package 
+                     (lambda ()
+                       (printf "on-build-package\n")))
+  (send f show #t))
\ No newline at end of file