forked from Shirakumo/trial
-
Notifications
You must be signed in to change notification settings - Fork 0
/
event-loop.lisp
127 lines (109 loc) · 4.71 KB
/
event-loop.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
#|
This file is a part of trial
(c) 2016 Shirakumo http://tymoon.eu ([email protected])
Author: Nicolas Hafner <[email protected]>
|#
(in-package #:org.shirakumo.fraf.trial)
(defclass event ()
())
(defclass listener ()
())
(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)
(with-simple-restart (abort "Don't handle ~a in ~a." event listener)
(call-next-method)))
;; Default to doing nothing.
(defmethod handle ((event event) (listener listener)))
(defclass event-loop ()
((queue :initform (make-array 64 :initial-element NIL :adjustable T :fill-pointer 0) :reader queue)
(queue-index :initform 0 :accessor queue-index)
(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-instance event-type args)))))
(vector-push-extend 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)))
`(vector-push-extend (make-instance ,event-type ,@args) (queue ,loop)))
(T
(let ((eventg (gensym "EVENT")))
`(let* ((,eventg ,event-type)
(,eventg (etypecase ,eventg
(event ,eventg)
((or class symbol)
(make-instance ,eventg ,@args)))))
(vector-push-extend ,eventg (queue ,loop)))))))
;; FIXME: This will forget events if PROCESS or DISCARD-EVENTS is called
;; recursively (thus resetting the index) and new events are issued
;; beyond the point of the index where the recursive call happens.
;; The check will assume nothing has changed and it'll continue from
;; where it left off, thus missing events before the current index.
(defmethod process ((loop event-loop))
(declare (optimize speed))
(with-simple-restart (discard-events "Discard all events.")
(let ((queue (queue loop)))
(declare (type (and (vector T) (not simple-array)) queue))
(loop for i = (1- (the (unsigned-byte 32) (incf (queue-index loop))))
while (< i (length queue))
do (let ((event (aref queue i)))
(when event
(handle event loop)
(setf (aref queue i) NIL))))
(setf (fill-pointer queue) 0
(queue-index loop) 0))))
(defun discard-events (loop)
(loop for i = (1- (incf (queue-index loop)))
while (< i (length (queue loop)))
do (setf (aref (queue loop) i) NIL))
(setf (fill-pointer (queue loop)) 0
(queue-index loop) 0))
(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 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)))))
(defclass tick (event)
((tt :initarg :tt :accessor tt)
(dt :initarg :dt :accessor dt)
(fc :initarg :fc :accessor fc)))
(defclass class-changed (event)
((changed-class :initarg :changed-class :accessor changed-class)))