start on racket guis, 7-GUIS task 1
This commit is contained in:
parent
5a5fb74124
commit
ce0dba8f36
|
@ -0,0 +1,25 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
(require (only-in racket/format ~a))
|
||||
|
||||
;; a mouse-click counter
|
||||
|
||||
(spawn
|
||||
(on-start
|
||||
|
||||
(define frame (spawn-frame #:label "Counter"))
|
||||
(define pane (spawn-horizontal-pane #:parent frame))
|
||||
(define view (spawn-text-field #:parent pane #:label "" #:init-value "0" #:enabled #f #:min-width 100))
|
||||
(define _but (spawn-button #:parent pane #:label "Count"))
|
||||
|
||||
(spawn
|
||||
(field [counter 0])
|
||||
(on (message (button-press _but))
|
||||
(counter (add1 (counter)))
|
||||
(send! (set-text-field view (~a (counter)))))
|
||||
(on-start
|
||||
(send! (show-frame frame #t))))))
|
||||
|
||||
(module+ main
|
||||
(void))
|
|
@ -0,0 +1 @@
|
|||
#lang setup/infotab
|
|
@ -0,0 +1,96 @@
|
|||
#lang syndicate
|
||||
|
||||
(provide spawn-frame
|
||||
spawn-horizontal-pane
|
||||
spawn-text-field
|
||||
spawn-button
|
||||
(struct-out frame@)
|
||||
(struct-out show-frame)
|
||||
(struct-out horizontal-pane@)
|
||||
(struct-out text-field@)
|
||||
(struct-out set-text-field)
|
||||
(struct-out button@)
|
||||
(struct-out button-press))
|
||||
|
||||
(require (only-in racket/class
|
||||
new
|
||||
send))
|
||||
(require racket/gui/base)
|
||||
|
||||
;; an ID is a (Sealof Any)
|
||||
|
||||
(assertion-struct frame@ (id))
|
||||
(message-struct show-frame (id value))
|
||||
|
||||
(assertion-struct horizontal-pane@ (id))
|
||||
|
||||
(assertion-struct text-field@ (id))
|
||||
(message-struct set-text-field (id value))
|
||||
|
||||
(assertion-struct button@ (id))
|
||||
(message-struct button-press (id))
|
||||
|
||||
;; String -> ID
|
||||
(define (spawn-frame #:label label)
|
||||
(define frame
|
||||
(parameterize ((current-eventspace (make-eventspace)))
|
||||
(new frame% [label label])))
|
||||
(define id (seal frame))
|
||||
(spawn
|
||||
(assert (frame@ id))
|
||||
(on (message (show-frame id $val))
|
||||
(send frame show val)))
|
||||
id)
|
||||
|
||||
;; ID -> ID
|
||||
(define (spawn-horizontal-pane #:parent parent)
|
||||
(define parent-component (seal-contents parent))
|
||||
(define pane (new horizontal-pane% [parent parent-component]))
|
||||
(define id (seal pane))
|
||||
|
||||
(spawn
|
||||
(assert (horizontal-pane@ id)))
|
||||
|
||||
id)
|
||||
|
||||
; ID String String Bool Nat -> ID
|
||||
(define (spawn-text-field #:parent parent
|
||||
#:label label
|
||||
#:init-value init
|
||||
#:enabled enabled?
|
||||
#:min-width min-width)
|
||||
(define parent-component (seal-contents parent))
|
||||
(define tf (new text-field%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[init-value init]
|
||||
[enabled enabled?]
|
||||
[min-width min-width]))
|
||||
(define id (seal tf))
|
||||
|
||||
(spawn
|
||||
(assert (text-field@ id))
|
||||
(on (message (set-text-field id $value))
|
||||
(send tf set-value value)))
|
||||
|
||||
id)
|
||||
|
||||
;; ID String -> ID
|
||||
(define (spawn-button #:parent parent
|
||||
#:label label)
|
||||
(define (inject-button-press! b e)
|
||||
(send-ground-message (button-press id)))
|
||||
(define parent-component (seal-contents parent))
|
||||
(define but (new button%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[callback inject-button-press!]))
|
||||
(define id (seal but))
|
||||
|
||||
(spawn
|
||||
(assert (button@ id))
|
||||
;; NOTE - this assumes we are one level away from ground
|
||||
(on (message (inbound (button-press id)))
|
||||
(send! (button-press id))))
|
||||
|
||||
id)
|
Loading…
Reference in New Issue