syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Better key press/release handling

This commit is contained in:
Tony Garnock-Jones 2015-10-22 19:47:31 -04:00
parent 112c33302e
commit c8642c2557
2 changed files with 59 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
prospect-gl/2d.rkt
View File

@ -35,8 +35,9 @@
(struct frame-event (counter timestamp) #:transparent)
;; Message sent by world. Describes a key event. Key is a sealed
;; key-event%.
(struct key-event (code key) #:transparent)
;; key-event%. `press?` is #t when the key is pressed (or
;; autorepeated!), and #f when it is released.
(struct key-event (code press? key) #:transparent)
;; Shared state maintained by program. Prelude and postlude are to be
;; sealed instruction lists. It is an error to have more than exactly
@ -117,6 +118,8 @@
(define (image->bitmap i)
(cond
[(is-a? i bitmap%)
i]
[(image:image? i)
(define w (image:image-width i))
(define h (image:image-height i))
@ -131,8 +134,6 @@
bm]
[(pict:pict? i)
(pict:pict->bitmap i)]
[(is-a? i bitmap%)
i]
[else
(error 'image->bitmap "unsupported image type ~v" i)]))
@ -319,7 +320,11 @@
(define/override (on-char key)
(with-gl-context
(lambda ()
(inject-event! (message (key-event (send key get-key-code) (seal key))))
(inject-event!
(message
(match (send key get-key-code)
['release (key-event (send key get-key-release-code) #f (seal key))]
[code (key-event code #t (seal key))])))
(quiesce!))))
(super-new (style '(gl no-autoclear)))))

62
prospect-gl/examples/basic.rkt
View File

@ -4,7 +4,14 @@
(require 2htdp/image)
(require "../2d.rkt")
;; This little dance is because of https://github.com/racket/racket/issues/1099
(require (rename-in 2htdp/planetcute [character-cat-girl character-cat-girl*]))
(define CC character-cat-girl*)
(struct key-pressed (code) #:transparent)
(define window-projection (compile-projection (at-meta (?! (window ? ?)))))
(define key-pressed-projection (compile-projection (key-pressed (?!))))
(2d-world (spawn (lambda (e s)
(match e
@ -27,25 +34,54 @@
(sub (window ? ?) #:meta-level 1)
;; (assert 'fullscreen #:meta-level 1)
)
(let ((move-to (lambda (x y)
(transition (list x y)
(update-sprites (simple-sprite 0 x y 10 10 (rectangle 1 1 "solid" "blue")))))))
(spawn (lambda (e s)
(match e
[(message (at-meta (key-event code press? _)))
(transition (void) ((if press? assert retract) (key-pressed code)))]
[#f #f]))
(void)
(sub (key-event ? ? ?) #:meta-level 1))
(let ((move-to (lambda (x y keys-down)
(transition (list x y keys-down)
(update-sprites
(simple-sprite 0
x
y
(image-width CC)
(image-height CC)
CC))))))
(spawn (lambda (e s)
(match-define (list x y) s)
(match-define (list x y keys-down) s)
(match e
[(message (at-meta (key-event 'left _))) (move-to (- x 2) y)]
[(message (at-meta (key-event 'right _))) (move-to (+ x 2) y)]
[(message (at-meta (key-event 'up _))) (move-to x (- y 2))]
[(message (at-meta (key-event 'down _))) (move-to x (+ y 2))]
[(? patch? p)
(define-values (added removed)
(patch-project/set/single p key-pressed-projection))
(define new-keys-down (set-subtract (set-union keys-down added) removed))
(transition (list x y new-keys-down) '())]
[(message (at-meta (frame-event _ _)))
(define-values (old-x old-y) (values x y))
(define speed 6)
(let* ((x (if (set-member? keys-down 'left) (- x speed) x))
(x (if (set-member? keys-down 'right) (+ x speed) x))
(y (if (set-member? keys-down 'up) (- y speed) y))
(y (if (set-member? keys-down 'down) (+ y speed) y)))
(and (not (and (= x old-x) (= y old-y)))
(move-to x y keys-down)))]
[_ #f]))
(list 100 100)
(update-sprites (simple-sprite -0.5 100 100 10 10 (rectangle 1 1 "solid" "blue")))
(sub (key-event ? ?) #:meta-level 1)))
(list 100 100 (set))
(update-sprites (simple-sprite -0.5
100
100
(image-width CC)
(image-height CC)
CC))
(sub (frame-event ? ?) #:meta-level 1)
(sub (key-pressed ?))))
(spawn (lambda (e s) #f)
(void)
(update-sprites (simple-sprite 0 50 50 50 50 (circle 50 "solid" "orange"))
(simple-sprite -1 60 60 50 50 (circle 50 "solid" "green"))))
(spawn (lambda (e s)
#;(spawn (lambda (e s)
(match e
[(message (at-meta (frame-event counter elapsed-ms)))
(and (> elapsed-ms 0)
@ -63,6 +99,6 @@
(transition s (assert 'stop #:meta-level 1))]
[_ #f]))
(void)
(sub (key-event #\q ?) #:meta-level 1))
(sub (key-event #\q #t ?) #:meta-level 1))
)
(exit 0)