From 2fd545051eb6307ab2a3fe70e69af27cb44e96cb Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Wed, 16 Dec 2015 20:47:20 -0500
Subject: events: mouse: Add motion event bindings.

* sdl2/bindings.scm (button-mask): New procedure.
  (SDL_BUTTON_LMASK, SDL_BUTTON_RMASK, SDL_BUTTON_MMASK,
  SDL_BUTTON_X1MASK, SDL_BUTTON_X2MASK): New variables.
* sdl2/events.scm (<mouse-motion-event>): New record type.
  (make-mouse-motion-event mouse-motion-event?,
mouse-motion-event-timestamp, mouse-motion-event-window-id,
mouse-motion-event-which, mouse-motion-event-buttons,
mouse-motion-event-x, mouse-motion-event-y, mouse-motion-event-x-rel,
mouse-motion-event-y-rel, parse-mouse-motion-event): New procedures.
---
 sdl2/bindings.scm | 10 ++++++++++
 sdl2/events.scm   | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 69 insertions(+)

diff --git a/sdl2/bindings.scm b/sdl2/bindings.scm
index 43f0be6..a25822f 100644
--- a/sdl2/bindings.scm
+++ b/sdl2/bindings.scm
@@ -816,6 +816,16 @@ RETURN-TYPE and accept arguments of ARG-TYPES."
 (define-public SDL_BUTTON_X1     4)
 (define-public SDL_BUTTON_X2     5)
 
+(define (button-mask n)
+  (ash 1 (1- n)))
+
+(define-public SDL_BUTTON_LMASK  (button-mask SDL_BUTTON_LEFT))
+(define-public SDL_BUTTON_MMASK  (button-mask SDL_BUTTON_MIDDLE))
+(define-public SDL_BUTTON_RMASK  (button-mask SDL_BUTTON_RIGHT))
+(define-public SDL_BUTTON_X1MASK (button-mask SDL_BUTTON_X1))
+(define-public SDL_BUTTON_X2MASK (button-mask SDL_BUTTON_X2))
+
+
 
 ;;;
 ;;; Timer
diff --git a/sdl2/events.scm b/sdl2/events.scm
index a9d3b98..b667098 100644
--- a/sdl2/events.scm
+++ b/sdl2/events.scm
@@ -63,6 +63,17 @@
             mouse-button-event-x
             mouse-button-event-y
 
+            make-mouse-motion-event
+            mouse-motion-event?
+            mouse-motion-event-timestamp
+            mouse-motion-event-window-id
+            mouse-motion-event-which
+            mouse-motion-event-buttons
+            mouse-motion-event-x
+            mouse-motion-event-y
+            mouse-motion-event-x-rel
+            mouse-motion-event-y-rel
+
             poll-event))
 
 (define (make-sdl-event)
@@ -732,6 +743,52 @@
                               clicks
                               x y))))
 
+(define-record-type <mouse-motion-event>
+  (make-mouse-motion-event timestamp window-id which buttons x y x-rel y-rel)
+  mouse-motion-event?
+  (timestamp mouse-motion-event-timestamp)
+  (window-id mouse-motion-event-window-id)
+  (which mouse-motion-event-which)
+  (buttons mouse-motion-event-buttons)
+  (x mouse-motion-event-x)
+  (y mouse-motion-event-y)
+  (x-rel mouse-motion-event-x-rel)
+  (y-rel mouse-motion-event-y-rel))
+
+(define (parse-mouse-motion-event ptr)
+  (define types
+    (list uint32  ; type
+          uint32  ; timestamp
+          uint32  ; windowID
+          uint32  ; which
+          uint32  ; state
+          int32   ; x
+          int32   ; y
+          int32   ; xrel
+          int32)) ; yrel
+
+  (define (button-mask->list mask)
+    (fold (lambda (pair prev)
+            (match pair
+              ((sym . bit)
+               (if (zero? (logand mask bit))
+                   prev
+                   (cons sym prev)))))
+          '()
+          `((left   . ,ffi:SDL_BUTTON_LMASK)
+            (middle . ,ffi:SDL_BUTTON_MMASK)
+            (right  . ,ffi:SDL_BUTTON_RMASK)
+            (x1     . ,ffi:SDL_BUTTON_X1MASK)
+            (x2     . ,ffi:SDL_BUTTON_X2MASK))))
+
+  (match (parse-c-struct ptr types)
+    ((_ timestamp window-id which state x y xrel yrel)
+     (make-mouse-motion-event timestamp
+                              window-id
+                              which
+                              (button-mask->list state)
+                              x y xrel yrel))))
+
 
 ;;;
 ;;; Event management
@@ -752,4 +809,6 @@
             ((or (= type ffi:SDL_MOUSEBUTTONDOWN)
                  (= type ffi:SDL_MOUSEBUTTONUP))
              (parse-mouse-button-event ptr))
+            ((= type ffi:SDL_MOUSEMOTION)
+             (parse-mouse-motion-event ptr))
             (else 'fixme:unsupported-event))))))
-- 
cgit v1.2.3