1 files changed, 171 insertions, 0 deletions
diff --git a/sly/joystick.scm b/sly/joystick.scm
new file mode 100644
index 0000000..611c5ba
--- /dev/null
+++ b/sly/joystick.scm
@@ -0,0 +1,171 @@
+;;; Sly
+;;; Copyright (C) 2014 Jordan Russell <jordan.likes.curry@gmail.com>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Joystick signals
+;;
+;;; Code:
+
+(define-module (sly joystick)
+  #:use-module ((sdl sdl) #:prefix SDL:)
+  #:use-module (sly event)
+  #:use-module (sly signal)
+  #:use-module (sly vector)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:re-export ((SDL:joystick-name . joystick-name)
+               (SDL:num-joysticks . num-joysticks))
+  #:export (enable-joystick
+            joystick-num-axes
+            joystick-num-buttons
+            joystick-axis-hook
+            joystick-button-press-hook
+            joystick-button-release-hook
+            axis-value-raw
+            raw-axis-max
+            raw-axis-min
+            axis-value
+            button-down?
+            make-directional-signal
+            make-directional-signal-raw
+            axis-scale))
+
+(define *joysticks* '())
+
+(define (enable-joystick)
+  (set! *joysticks*
+        (map SDL:joystick-open
+             (iota (SDL:num-joysticks)))))
+
+(define (get-joystick idx)
+  (list-ref *joysticks* idx))
+
+(define-syntax-rule (js-proc->idx-proc (js-proc . name) doc)
+  (define (name idx)
+    doc
+    (if (> idx (SDL:num-joysticks))
+        0
+        (js-proc (get-joystick idx)))))
+
+(js-proc->idx-proc (SDL:joystick-num-axes . joystick-num-axes)
+                   "Get number of axes of joystick at IDX")
+
+(js-proc->idx-proc (SDL:joystick-num-buttons . joystick-num-buttons)
+                   "Get number of buttons of joystick at IDX")
+
+(define joystick-axis-hook (make-hook 3))
+
+(register-event-handler
+ 'joy-axis-motion
+ (lambda (e)
+   (run-hook joystick-axis-hook
+             (SDL:event:jaxis:which e)
+             (SDL:event:jaxis:axis e)
+             (SDL:event:jaxis:value e))))
+
+(define-record-type <axis-event>
+  (make-axis-event which axis value)
+  axis-event?
+  (which axis-event-joystick)
+  (axis axis-event-axis)
+  (value axis-event-value))
+
+(define joystick-button-press-hook (make-hook 2))
+
+(register-event-handler
+ 'joy-button-down
+ (lambda (e)
+   (run-hook joystick-button-press-hook
+             (SDL:event:jbutton:which e)
+             (SDL:event:jbutton:button e))))
+
+(define joystick-button-release-hook (make-hook 2))
+
+(register-event-handler
+ 'joy-button-up
+ (lambda (e)
+   (run-hook joystick-button-release-hook
+             (SDL:event:jbutton:which e)
+             (SDL:event:jbutton:button e))))
+
+(define-signal last-axis-event
+  (hook->signal joystick-axis-hook 'none
+                make-axis-event))
+
+(define raw-axis-min -32768)
+(define raw-axis-max 32767)
+
+(define (axis-value-raw idx axis)
+  "Create a signal on the axis at AXIS of the joystick at IDX;
+joystick axis values are stored in a signed 16 bit integer and so,
+values range from [-32768,32767]"
+  (signal-map axis-event-value
+              (signal-filter
+               (lambda (e)
+                 (and (axis-event? e)
+                      (= (axis-event-joystick e) idx)
+                      (= (axis-event-axis e) axis)))
+               (make-axis-event idx axis 0)
+               last-axis-event)))
+
+(define (make-directional-signal-raw idx x-axis y-axis)
+  "Create a signal for a Dpad or Analog stick with X and Y axes;
+values range from [-32768,32767]"
+  (signal-map vector
+              (axis-value-raw idx x-axis)
+              (axis-value-raw idx y-axis)))
+
+(define (axis-scale raw-value)
+  "Map a RAW-VALUE in [-32768, 32767] to a value in [-1, 1]"
+  (define (clamp x)
+    (cond ((< (abs x) 1/100) 0)
+          ((> x 99/100) 1)
+          ((< x -99/100) -1)
+          (else x)))
+  (clamp (/ raw-value 32768)))
+
+(define (axis-value idx axis)
+  "Create a signal for the value of AXIS on joystick IDX;
+values are scaled to [-1,1]"
+  (signal-map axis-scale (axis-value-raw idx axis)))
+
+(define (make-directional-signal idx x-axis y-axis)
+  "Create a signal for a Dpad or Analog stick with X and Y axes;
+values are scaled to [-1,1]"
+  (signal-map (lambda (v)
+                (vector (axis-scale (vx v))
+                        (axis-scale (vy v))))
+              (make-directional-signal-raw idx x-axis y-axis)))
+
+(define-signal button-last-down
+  (hook->signal joystick-button-press-hook 'none
+                list))
+
+(define-signal button-last-up
+  (hook->signal joystick-button-release-hook 'none
+                list))
+
+;; shamelessly copied from keyboard.scm
+(define (button-down? idx n)
+  "Create a signal for the state of button N on joystick at IDX"
+  (define (same-button? l)
+    (equal? (list idx n) l))
+  (define (button-filter value signal)
+    (signal-constant value (signal-filter same-button? #f signal)))
+  (signal-merge (button-filter #f button-last-up)
+                (button-filter #t button-last-down)))