More keyboard events

[gacela.git] / gacela / event.scm

diff --git a/gacela/event.scm b/gacela/event.scm
index 9efd8e1c552e6654dd5fdf9c197d2032bf905e3d..04223971108da1a33c1cb4980f41d85aed63b652 100644 (file)
--- a/gacela/event.scm
+++ b/gacela/event.scm
@@ -18,7 +18,12 @@
 (define-module (gacela event)
   #:use-module ((sdl2 events) #:prefix sdl2:)
   #:export (process-events
-           quit?))
+           quit-event?
+           key-events
+           any-key-down?
+           any-key-up?
+           key-down?
+           key-up?))
 
 
 (define *current-events* '())
@@ -33,5 +38,38 @@
 (define (process-events)
   (set! *current-events* (poll-events)))
 
-(define (quit?)
+(define (quit-event?)
   (not (null? (filter (lambda (e) (sdl2:quit-event? e)) *current-events*))))
+
+(define (key-events)
+  (filter (lambda (e) (sdl2:keyboard-event? e)) *current-events*))
+
+(define (any-key-down?)
+  (let loop ((events *current-events*))
+    (if (null? events)
+       #f
+       (or (sdl2:keyboard-down-event? (car events))
+           (loop (cdr events))))))
+
+(define (any-key-up?)
+  (let loop ((events *current-events*))
+    (if (null? events)
+       #f
+       (or (sdl2:keyboard-up-event? (car events))
+           (loop (cdr events))))))
+
+(define (key-down? key)
+  (let ((ke (filter
+            (lambda (e)
+              (and (sdl2:keyboard-down-event? e)
+                   (equal? (sdl2:keyboard-event-key e) key)))
+            *current-events*)))
+    (not (null? ke))))
+
+(define (key-up? key)
+  (let ((ke (filter
+            (lambda (e)
+              (and (sdl2:keyboard-up-event? e)
+                   (equal? (sdl2:keyboard-event-key e) key)))
+            *current-events*)))
+    (not (null? ke))))