event-loop.lisp

#|
 This file is a part of trial
 (c) 2016 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
 Author: Nicolas Hafner <shinmera@tymoon.eu>
|#

(in-package #:org.shirakumo.fraf.trial)

(define-global +event-pools+ (make-hash-table :test 'eq))

(defclass event ()
  ())

(defclass listener ()
  ())

(defstruct (event-pool (:constructor %make-event-pool (instances)))
  (instances NIL :type simple-vector)
  (index 0 :type (unsigned-byte 32)))

(defgeneric add-listener (listener event-loop))
(defgeneric remove-listener (listener event-loop))
(defgeneric handle (event listener))

#-elide-handler-restarts
(defmethod handle :around ((event event) listener)
  (restart-case
      (call-next-method)
    (abort ()
      :report (lambda (s) (format s "Don't handle ~a in ~a." event listener))
      NIL)
    (leave ()
      :report (lambda (s) (format s "Leave ~a from the loop." listener))
      (leave listener T))))

;; Default to doing nothing.
(defmethod handle ((event event) (listener listener)))

(defun make-event-pool (class count)
  (let ((array (make-array count)))
    (dotimes (i count (%make-event-pool array))
      (setf (aref array i) (allocate-instance (ensure-class class))))))

(defun make-event (class &rest initargs)
  (let ((pool (gethash class +event-pools+)))
    (if pool
        (loop
         (let* ((index (event-pool-index pool))
                (instances (event-pool-instances pool)))
           (when (atomics:cas (event-pool-index pool) index (mod (1+ index) (length instances)))
             (return (apply #'initialize-instance (aref instances index) initargs)))))
        (apply #'make-instance class initargs))))

(define-compiler-macro make-event (&environment env class &rest initargs)
  (let ((pool (gensym "POOL"))
        (index (gensym "INDEX"))
        (instances (gensym "INSTANCES")))
    `(let ((,pool ,(if (constantp class env)
                       `(load-time-value (gethash ,class +event-pools+))
                       `(gethash ,class +event-pools+))))
       (if ,pool
           (loop
            (let* ((,index (event-pool-index ,pool))
                   (,instances (event-pool-instances ,pool)))
              (when (atomics:cas (event-pool-index ,pool) ,index (mod (1+ ,index) (length ,instances)))
                (return (initialize-instance (aref ,instances ,index) ,@initargs)))))
           (make-instance ,class ,@initargs)))))

(defclass event-loop ()
  ((queue :initform (make-queue) :reader queue)
   (listeners :initform (make-hash-table :test 'eq) :accessor listeners)
   (listener-queue :initform '(NIL) :accessor listener-queue)))

(defun issue (loop event-type &rest args)
  (let ((event (etypecase event-type
                 (event event-type)
                 ((or class symbol)
                  (apply #'make-event event-type args)))))
    (queue-push event (queue loop))))

(define-compiler-macro issue (&environment env loop event-type &rest args)
  (cond ((and (constantp event-type env)
              (listp event-type)
              (eql (first event-type) 'quote)
              (symbolp (second event-type)))
         `(queue-push (make-event ,event-type ,@args) (queue ,loop)))
        (T
         (let ((eventg (gensym "EVENT")))
           `(let* ((,eventg ,event-type)
                   (,eventg (etypecase ,eventg
                              (event ,eventg)
                              ((or class symbol)
                               (make-event ,eventg ,@args)))))
              (queue-push ,eventg (queue ,loop)))))))

(defmethod process ((loop event-loop))
  (declare (optimize speed))
  (flet ((handler (event)
           (handle event loop)))
    (declare (dynamic-extent #'handler))
    (restart-case
        (map-queue #'handler (queue loop))
      (discard-events ()
        :report "Discard all remaining events and exit"
        (queue-discard (queue loop))))))

(defun discard-events (loop &optional (type T))
  (let ((queue (queue loop)))
    (let ((elements (queue-elements queue))
          (read (queue-read-index queue))
          (write (queue-write-index queue)))
      (loop for i from read below write
            do (when (typep (aref elements i) type)
                 (setf (aref elements i) NIL)))
      queue)))

(defmethod handle ((event event) (loop event-loop))
  (with-simple-restart (skip-event "Skip handling the event entirely.")
    (loop with queue = (listener-queue loop)
          for listener = (pop queue)
          while listener
          do (handle event listener))))

(defmethod handle ((event event) (fun function))
  (funcall fun event))

;; FIXME: make this thread safe
;; NOTE: we have the LISTENER-QUEUE in order to ensure we can remove arbitrary
;;       listeners //during// event handling, which we could not do if we iterated
;;       the hash table directly
(defmethod add-listener (listener (loop event-loop))
  (if (gethash listener (listeners loop))
      listener
      (let ((cons (cons listener (listener-queue loop))))
        (setf (gethash listener (listeners loop)) cons)
        (setf (listener-queue loop) cons)
        listener)))

(defmethod remove-listener (listener (loop event-loop))
  (let* ((listeners (listeners loop))
         (cons (gethash listener listeners)))
    (declare (type hash-table listeners))
    (when cons
      (setf (car cons) (cadr cons))
      (setf (cdr cons) (cddr cons))
      (setf (gethash (car cons) listeners) cons))
    (remhash listener listeners)
    listener))

(defmethod clear ((loop event-loop))
  (discard-events loop)
  (clrhash (listeners loop))
  (setf (listener-queue loop) '(NIL)))

(defmacro define-handler ((class event &rest qualifiers) slots &body body)
  (destructuring-bind (instance class) (enlist class class)
    (destructuring-bind (variable event) (enlist event event)
      `(defmethod handle ,@qualifiers ((,variable ,event) (,instance ,class))
         (let ,(loop for slot in slots
                     for (var name) = (enlist slot slot)
                     collect `(,var (slot-value ,variable ',name)))
           ,@body)))))

(defmacro define-event (name superclasses &body slots)
  (unless (find 'event superclasses)
    (setf superclasses (append superclasses '(event))))
  `(defclass ,name ,superclasses
     ,(loop for slot in slots
            collect (destructuring-bind (name &optional (default NIL default-p) &key (reader name)) (enlist slot)
                      `(,name :initarg ,(kw name) :initform ,(if default-p default `(error "~a required." ',name)) :reader ,reader)))))

(defmacro define-event-pool (class count)
  `(setf (gethash ',class +event-pools+) (make-event-pool ',class ,count)))

(define-event tick () tt dt fc)
(define-event class-changed () changed-class)