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

strings for Universe callbacks

Browse Source 
svn: r14644
This commit is contained in:
Matthias Felleisen 2009-04-29 03:08:40 +00:00
parent b42f1b5d8b
commit 10e0e08143
3 changed files with 28 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/2htdp/private/check-aux.ss
View File

@ -54,22 +54,29 @@
;; -----------------------------------------------------------------------------
;; MouseEvent -> [List Nat Nat MouseEventType]
;; MouseEvent% -> [List Nat Nat MouseEventType]
;; turn a mouse event into its pieces
(define (mouse-event->parts e)
(define x (- (send e get-x) INSET))
(define y (- (send e get-y) INSET))
(values x y (cond [(send e button-down?) 'button-down]
[(send e button-up?) 'button-up]
[(send e dragging?) 'drag]
[(send e moving?) 'move]
[(send e entering?) 'enter]
[(send e leaving?) 'leave]
[else ; (send e get-event-type)
(error 'on-mouse-event
(format
"Unknown event type: ~a"
(send e get-event-type)))])))
(values x y
(cond [(send e button-down?) "button-down"]
[(send e button-up?) "button-up"]
[(send e dragging?) "drag"]
[(send e moving?) "move"]
[(send e entering?) "enter"]
[(send e leaving?) "leave"]
[else ; (send e get-event-type)
(let ([m (send e get-event-type)])
(error 'on-mouse (format "Unknown event: ~a" m)))])))
;; KeyEvent% -> String
(define (key-event->parts e)
(define x (send e get-key-code))
(cond
[(char? x) (string x)]
[(symbol? x) (symbol->string x)]
[else (error 'on-key (format "Unknown event: ~a" x))]))
;; -----------------------------------------------------------------------------
;; Any -> Symbol

2
collects/2htdp/private/world.ss
View File

@ -170,7 +170,7 @@
(super-new)
;; deal with keyboard events
(define/override (on-char e)
(when live (pkey (send e get-key-code))))
(when live (pkey (key-event->parts e))))
;; deal with mouse events if live and within range
(define/override (on-event e)
(define-values (x y me) (mouse-event->parts e))

16
collects/2htdp/universe.ss
View File

@ -122,12 +122,12 @@
(lambda (p)
(syntax-case p ()
[(n) #`(symbol> #,tag n)]
[_ (err tag p)])))]
[_ (err tag p "expected a string for the current world")])))]
[record? (lambda (tag)
(lambda (p)
(syntax-case p ()
[(b) #`(bool> #,tag b)]
[_ (err tag p)])))])
[_ (err tag p "expected a boolean (to record or not to record?")])))])
(define-syntax (big-bang stx)
(syntax-case stx ()
@ -195,21 +195,21 @@
(on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
(stop-when empty?))))
(define (mouse-event? a)
(pair? (member a '(button-down button-up drag move enter leave))))
(define ME (map symbol->string '(button-down button-up drag move enter leave)))
(define (mouse-event? a) (and (string? a) (pair? (member a ME))))
(define (mouse=? k m)
(check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
(check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
(eq? k m))
(string=? k m))
(define (key-event? k)
(or (char? k) (symbol? k)))
(define (key-event? k) (string? k))
(define (key=? k m)
(check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
(check-arg 'key=? (key-event? m) 'KeyEvent "second" m)
(eqv? k m))
(string=? k m))
(define LOCALHOST "127.0.0.1")