74 lines
1.8 KiB
Racket
74 lines
1.8 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base
|
|
racket/syntax)
|
|
racket/match
|
|
racket/class
|
|
racket/gui/base
|
|
racket/contract/base)
|
|
|
|
(struct key-state
|
|
(keys
|
|
shift? control? meta? alt?
|
|
mod3? mod4? mod5?)
|
|
#:mutable)
|
|
|
|
(define-syntax (set-key-state stx)
|
|
(syntax-case stx ()
|
|
[(_ ks ke id)
|
|
(with-syntax ([set-key-state-id?!
|
|
(format-id #'id "set-key-state-~a?!" #'id)]
|
|
[get-id-down
|
|
(format-id #'id "get-~a-down" #'id)])
|
|
(syntax/loc stx
|
|
(set-key-state-id?! ks (send ke get-id-down))))]))
|
|
(define-syntax-rule (set-key-states ks ke (id ...))
|
|
(begin (set-key-state ks ke id) ...))
|
|
|
|
(define (key-event? x)
|
|
(is-a? x key-event%))
|
|
|
|
(define (key-state-update! ks ke)
|
|
(define ht (key-state-keys ks))
|
|
(match (send ke get-key-code)
|
|
['release
|
|
(hash-set! ht (send ke get-key-release-code) #f)]
|
|
[kc
|
|
(hash-set! ht kc #t)])
|
|
(set-key-states
|
|
ks ke
|
|
(shift control meta alt mod3 mod4 mod5)))
|
|
|
|
(define (make-key-state)
|
|
(key-state (make-hasheq) #f #f #f #f #f #f #f))
|
|
|
|
(define (key-state-set? ks kc)
|
|
(hash-ref (key-state-keys ks) kc #f))
|
|
(define (key-state-set?! ks kc)
|
|
(begin0 (key-state-set? ks kc)
|
|
(hash-set! (key-state-keys ks) kc #f)))
|
|
|
|
(provide
|
|
(contract-out
|
|
[struct key-state
|
|
([keys hash?]
|
|
[shift? boolean?]
|
|
[control? boolean?]
|
|
[meta? boolean?]
|
|
[alt? boolean?]
|
|
[mod3? boolean?]
|
|
[mod4? boolean?]
|
|
[mod5? boolean?])]
|
|
[key-event?
|
|
(-> any/c boolean?)]
|
|
[make-key-state
|
|
(-> key-state?)]
|
|
[key-state-update!
|
|
(-> key-state? key-event?
|
|
any)]
|
|
[key-state-set?
|
|
(-> key-state? (or/c char? key-code-symbol?)
|
|
boolean?)]
|
|
[key-state-set?!
|
|
(-> key-state? (or/c char? key-code-symbol?)
|
|
boolean?)]))
|