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

working on the tool ui

Browse Source
This commit is contained in:
Danny Yoo 2011-08-14 18:41:18 -04:00
parent 809b5469f2
commit 91265dad43
2 changed files with 112 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
tool/button-with-alternatives.rkt
View File

@ -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)

60
tool/tool-ui.rkt Normal file
View File

@ -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))