stoe/engine/input.lisp

#|
  This file is a part of stoe project.
  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#

(uiop:define-package :stoe/engine/input
    (:use :cl :alexandria
          :stoe/core/utils
          :stoe/core/containers
          :stoe/core/modules)
  (:export #:on-key-event #:on-button-event #:on-motion-event
           #:make-keymap #:set-global-keymap
           #:define-key #:global-set-key
           #:define-motion #:global-set-motion))
(in-package :stoe/engine/input)

(define-constant +keyevent-classes+ '(:press :release :repeat :continuous)
  :test #'equal :documentation "List of the available key event classes.")

(define-constant +repeat-delay+ 200
  :documentation "Delay to wait before triggering the first repeat event.")

(define-constant +repeat-rate+ 30
  :documentation "Rate of the repeat event.")

(defstruct (keymap (:constructor %make-keymap))
  name
  (table (make-hash-table))
  (modifiers :none))

(defun make-keymap (name)
  "Create a new keymap."
  (%make-keymap :name name))

(defvar *default-global-keymap* (make-keymap "Global")
  "Default global key bindings.")

(defvar *current-global-keymap* nil
  "The keymap currently in use.")

(defvar *event-queue* (make-queue)
  "The event queue.")

(defvar *active-keys* nil
  "List containing the currently active (pressed) keys.
Only those will trigger the release event.")

(defun initialize (&optional argv)
  "Initialize the input module."
  (declare (ignore argv))
  (format t "Initialize Input module~%"))

(defun finalize ()
  "Finalize the input module."
  (format t "Finalize Input module~%")
  (set-global-keymap nil))

(defun update (delta-time)
  "Update the input module.
trigger key events that occured this frame."
  (loop for event = (dequeue *event-queue*)
     until (null event)
     do (process-event event))
  (mapc (lambda (key) (process-active-key key delta-time)) *active-keys*))

(defmodule stoe/engine/input :input)

(defun set-global-keymap (keymap)
  "Set the current global keymap."
  (setf *current-global-keymap* keymap))

(defun current-global-keymap ()
  "Return the current global keymap."
  (or *current-global-keymap* *default-global-keymap*))

(defstruct active-key
  keysym
  (pressed t)
  (next-repeat-time +repeat-delay+)
  event)

(defun activep (keysym)
  "Is `keyname' active?"
  (member keysym *active-keys* :test (lambda (keysym key) (eq keysym (active-key-keysym key)))))

(defun add-active-key (keysym event)
  (push (make-active-key :keysym keysym :event event) *active-keys*))

(defun remove-active-key (keysym)
  (setf *active-keys* (delete keysym *active-keys* :test (lambda (keysym key) (eq keysym (active-key-keysym key))))))

(defclass input-event () ()
  (:documentation "Base class for input events"))

(defclass key-event (input-event)
  ((keycode :initarg :keycode :reader keycode)
   (keysym :initarg :keysym :reader keysym)
   (text :initarg :text :reader text)
   (pressed :initarg :pressed :reader pressed))
  (:documentation "Keyboard key event"))

(defclass button-event (input-event)
  ((button :initarg :button :reader button)
   (pressed :initarg :pressed :reader pressed))
  (:documentation "Mouse button event"))

(defclass motion-event (input-event)
  ((x :initarg :x :reader x)
   (y :initarg :y :reader y)
   (dx :initarg :dx :reader dx)
   (dy :initarg :dy :reader dy))
  (:documentation "Mouse motion event"))

(defun on-key-event (pressed keycode keysym string)
  "A key has been pressed or released."
  (enqueue *event-queue* (make-instance 'key-event :pressed pressed :keycode keycode :keysym keysym :text string)))

(defun on-button-event (pressed button)
  "A mouse button has been pressed or released."
  (enqueue *event-queue* (make-instance 'button-event :pressed pressed :button button)))

(defun on-motion-event (x y dx dy)
  "The mouse has been moved."
  (enqueue *event-queue* (make-instance 'motion-event :x x :y y :dx dx :dy dy)))

(defgeneric process-event (input-event)
  (:documentation "Process each event according to its class."))

(defmethod process-event ((evt key-event))
  (let ((keysym (keysym evt)))
    (when (xor (pressed evt) (activep keysym))
      (if (pressed evt)
          (progn
            (add-active-key keysym evt)
            (run-binding evt (current-global-keymap) keysym :press))
          (progn
            (run-binding evt (current-global-keymap) keysym :release)
            (remove-active-key keysym))))))

(defmethod process-event ((evt button-event))
  (let ((keysym (button evt)))
    (when (xor (pressed evt) (activep keysym))
      (if (pressed evt)
          (progn
            (add-active-key keysym evt)
            (run-binding evt (current-global-keymap) keysym :press))
          (progn
            (run-binding evt (current-global-keymap) keysym :release)
            (remove-active-key keysym))))))

(defmethod process-event ((evt motion-event))
  (run-motion evt (current-global-keymap) :mouse-axis))

(defun process-active-key (key delta-time)
  (if (active-key-pressed key)
      (setf (active-key-pressed key) nil)
      (run-binding (active-key-event key) (current-global-keymap) (active-key-keysym key) :continuous))
  (decf (active-key-next-repeat-time key) delta-time)
  (when (<= (active-key-next-repeat-time key) 0)
    (run-binding (active-key-event key) (current-global-keymap) (active-key-keysym key) :repeat)
    (setf (active-key-next-repeat-time key) +repeat-rate+)))

(defun find-binding (keymap keysym class)
  (let ((binding (gethash keysym (keymap-table keymap))))
    (when binding
      (cdr (assoc class (gethash (keymap-modifiers keymap) binding))))))

(defun run-binding (event keymap keysym class)
  (let ((binding (find-binding keymap keysym class)))
    (when binding
      (let ((fun (first binding))
            (args (rest binding)))
        (if args
            (apply fun (mapcar (lambda (arg)
                                 (if (and (keywordp arg) (slot-exists-p event (intern (symbol-name arg))))
                                     (slot-value event event)
                                     arg))
                               args))
            (funcall fun))))))

(defun find-motion (keymap axis)
  (gethash axis (keymap-table keymap)))

(defun run-motion (event keymap axis)
  (let ((motion (find-motion keymap axis)))
    (when motion
      (let ((fun (first motion))
            (args (rest motion)))
        (if args
            (apply fun (mapcar (lambda (arg)
                                 (if (and (keywordp arg) (slot-exists-p event (intern (symbol-name arg) :stoe/engine/input)))
                                     (slot-value event (intern (symbol-name arg) :stoe/engine/input))
                                     arg))
                               args))
            (funcall fun))))))

(defun insert-keybinding (keymap key fun args)
  "Define a key to trigger `fun' within `keymap'."
  (let ((keysym (first key))
        (modifiers (second key))
        (classes (third key)))
    (let ((binding (gethash keysym (keymap-table keymap))))
      (unless binding
        (setf binding (setf (gethash keysym (keymap-table keymap)) (make-hash-table))))
      (mapc (lambda (class)
              (pushnew (cons class (cons fun args)) (gethash modifiers binding))) (safe-list classes)))
    fun))

(defmacro define-key (keymap key fun &rest args)
  `(let* ((keydef (safe-list ',key))
          (modifiers-and-classes (rest keydef))
          (modifiers (remove-if (lambda (sym) (member sym +keyevent-classes+)) modifiers-and-classes))
          (classes (remove-if-not (lambda (sym) (member sym +keyevent-classes+)) modifiers-and-classes)))
     (insert-keybinding ,keymap (list (first keydef)
                                     (case (length modifiers)
                                       (0 :none)
                                       (1 (first modifiers))
                                       (t modifiers))
                                     (case (length classes)
                                       (0 :press)
                                       (1 (first classes))
                                       (t classes)))
                        ,fun ',args)))

(defmacro global-set-key (key fun &rest args)
  "Set a key for the global keymap."
  `(define-key (current-global-keymap) ,key ,fun ,@args))

(defun insert-motionbinding (keymap axis fun args)
  (setf (gethash axis (keymap-table keymap)) (cons fun args)))

(defmacro define-motion (keymap fun &rest args)
  `(insert-motionbinding ,keymap :mouse-axis ,fun ',args))

(defmacro global-set-motion (fun &rest args)
  `(define-motion (current-global-keymap) ,fun ,@args))