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

better display, extra info for v350.4

Browse Source 
svn: r3621
This commit is contained in:
Matthew Flatt 2006-07-06 16:07:22 +00:00
parent 7bf9d9e904
commit 7993786b03
1 changed files with 25 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/tests/mred/showkey.ss
View File

@ -3,23 +3,25 @@
(lib "class100.ss"))
(let ()
(define iter 0)
(define c%
(class100-asi canvas%
(override
[on-event
(lambda (ev)
(printf "~aMOUSE ~a (~a,~a)~n meta: ~a control: ~a alt: ~a shift: ~a~n buttons: ~a ~a ~a~a~a~a~a~n"
(printf "~a~a MOUSE ~a (~a,~a)\n mods:~a~a~a~a\n buttons:~a~a~a~a~a~a~a~n"
(es-check)
iter
(send ev get-event-type)
(send ev get-x)
(send ev get-y)
(send ev get-meta-down)
(send ev get-control-down)
(send ev get-alt-down)
(send ev get-shift-down)
(send ev get-left-down)
(send ev get-middle-down)
(send ev get-right-down)
(if (send ev get-meta-down) " META" "")
(if (send ev get-control-down) " CTL" "")
(if (send ev get-alt-down) " ALT" "")
(if (send ev get-shift-down) " SHIFT" "")
(if (send ev get-left-down) " LEFT" "")
(if (send ev get-middle-down) " MIDDLE" "")
(if (send ev get-right-down) " RIGHT" "")
(if (send ev dragging?)
" dragging"
"")
@ -34,20 +36,27 @@
"")))]
[on-char
(lambda (ev)
(printf "~aKEY code: ~a rel-code: ~a~n meta: ~a control: ~a alt: ~a shift: ~a~n"
(set! iter (add1 iter))
(printf "~a~a KEY: ~a\n rel-code: ~a\n other-code: ~a\n mods:~a~a~a~a~n"
(es-check)
iter
(let ([v (send ev get-key-code)])
(if (symbol? v)
v
(format "~a = ASCII ~a" v (char->integer v))))
(format "~s = ASCII ~a" (string v) (char->integer v))))
(let ([v (send ev get-key-release-code)])
(if (symbol? v)
v
(format "~a = ASCII ~a" v (char->integer v))))
(send ev get-meta-down)
(send ev get-control-down)
(send ev get-alt-down)
(send ev get-shift-down)))])))
(format "~s = ASCII ~a" (string v) (char->integer v))))
(let ([v (send ev get-other-shift-key-code)])
(and v
(if (symbol? v)
v
(format "~s = ASCII ~a" (string v) (char->integer v)))))
(if (send ev get-meta-down) " META" "")
(if (send ev get-control-down) " CTL" "")
(if (send ev get-alt-down) " ALT" "")
(if (send ev get-shift-down) " SHIFT" "")))])))
(define f (make-object (class100 frame% ()
(inherit accept-drop-files)
(override
@ -59,7 +68,7 @@
(define c (make-object c% f))
(define (es-check) (if (eq? (send f get-eventspace) (current-eventspace))
""
">>WRONG EVENTSPACE<< "))
">>WRONG EVENTSPACE<<\n"))
(send c focus)
(send f show #t))