-
-
Notifications
You must be signed in to change notification settings - Fork 46
/
controller.lisp
172 lines (146 loc) · 6.99 KB
/
controller.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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
(in-package #:org.shirakumo.fraf.trial)
(define-action-set system-action)
(define-action reload-scene (system-action))
(define-action quit-game (system-action))
(define-action toggle-overlay (system-action))
(defclass controller (entity listener)
((handlers :initform NIL :accessor handlers)
(name :initform :controller)))
(defmethod handle ((ev quit-game) (controller controller))
(quit *context*))
(defmethod handle ((ev event) (controller controller))
(dolist (handler (handlers controller))
(handle ev handler))
(map-event ev (scene +main+)))
(defmethod handle ((ev lose-focus) (controller controller))
(clear-retained))
(defmethod handle ((ev reload-scene) (controller controller))
(let ((old (scene +main+)))
(change-scene +main+ (make-instance (type-of old)))))
(defclass load-request (event)
((thing :initarg :thing)))
(define-handler (controller load-request) (thing)
(typecase thing
(asset
(if (loaded-p thing)
(reload thing)
(load thing)))
(resource
(unless (allocated-p thing)
(allocate thing)))
(T
(commit thing (loader +main+) :unload NIL))))
(defun maybe-reload-scene (&optional (main +main+))
(when main
(issue (scene main) 'reload-scene)))
(defclass eval-request (event)
((func :initarg :func)
(return-values :accessor return-values)))
(define-handler (controller eval-request) (func)
(let ((vals (multiple-value-list (funcall func))))
(setf (return-values eval-request) vals)))
(defun call-in-render-loop (function scene &key block)
(let ((event (issue scene 'eval-request :func function)))
(when block
(loop until (slot-boundp event 'return-values)
do (sleep 0.01))
(values-list (return-values event)))))
(defmacro with-eval-in-render-loop ((&optional (scene '(scene +main+)) &rest args) &body body)
`(call-in-render-loop (lambda () ,@body) ,scene ,@args))
(define-shader-entity display-controller (controller debug-text)
((fps-buffer :initform (make-array 100 :initial-element 1f0 :element-type 'single-float) :reader fps-buffer)
(fps-buffer-idx :initform 0 :accessor fps-buffer-idx)
(observers :initform (make-array 0 :adjustable T :fill-pointer T) :accessor observers)
(background :initform (vec4 1 1 1 0.3))
(show-overlay :initform T :accessor show-overlay)
(%string :initform (make-array 4096 :element-type 'character :fill-pointer 0) :accessor %string)))
(defmethod handle ((ev toggle-overlay) (controller display-controller))
(setf (show-overlay controller) (not (show-overlay controller))))
(defmethod handle ((ev resize) (controller display-controller))
(setf (font-size controller) (if (< 1920 (width ev)) 32 17)))
(defun compute-fps-buffer-fps (fps-buffer)
(declare (optimize speed (safety 0)))
(declare (type (simple-array single-float (100)) fps-buffer))
(let ((sum 0f0))
(declare (type single-float sum))
(loop for i of-type (unsigned-byte 16) from 0 below (length fps-buffer)
do (incf sum (aref fps-buffer i)))
(values (/ sum (length fps-buffer))
(/ (* 1000 (length fps-buffer)) sum))))
(defmethod observe ((func function) &key title)
(let ((observers (ignore-errors (observers (node :controller T)))))
(when observers
(let* ((title (or title (format NIL "~d" (length observers))))
(position (position title observers :key #'car :test #'equal)))
(if position
(setf (aref observers position) (cons title func))
(vector-push-extend (cons title func) observers))
func))))
(defmethod observe (thing &rest args &key &allow-other-keys)
(let ((func (compile NIL `(lambda (ev)
(declare (ignorable ev))
,thing))))
(apply #'observe func args)))
(defmacro observe! (form &rest args)
(let ((ev (gensym "EV")))
`(observe (lambda (,ev) (declare (ignore ,ev)) ,form) ,@args)))
(defmethod stop-observing (&optional title)
(let ((observers (ignore-errors (observers (node :controller T)))))
(when observers
(if title
(let ((pos (position title observers :key #'car :test #'equal)))
(when pos (array-utils:vector-pop-position observers pos)))
(loop for i from 0 below (array-total-size observers)
do (setf (aref observers i) NIL)
finally (setf (fill-pointer observers) 0))))))
(defparameter *controller-pprint*
(let ((table (copy-pprint-dispatch)))
(set-pprint-dispatch 'float (lambda (s o) (format s "~,3@f" o))
10 table)
table))
(defun compose-controller-debug-text (controller ev)
(multiple-value-bind (gfree gtotal) (org.shirakumo.machine-state:gpu-room)
(multiple-value-bind (cfree ctotal) (org.shirakumo.machine-state:gc-room)
(setf (fill-pointer (%string controller)) 0)
(with-output-to-string (stream (%string controller))
(multiple-value-bind (fps dur) (compute-fps-buffer-fps (fps-buffer controller))
(format stream "FPS [Hz]: ~8,2f (~6,2fms)~%~
RAM [KB]: ~8d (~2d%)~%~
VRAM [KB]: ~8d (~2d%)~%~
RESOURCES: ~8d"
fps dur
(truncate (- ctotal cfree) 1024) (floor (/ (- ctotal cfree) ctotal 0.01))
(truncate (- gtotal gfree) 1024) (floor (/ (- gtotal gfree) gtotal 0.01))
(hash-table-count (loaded (loader +main+)))))
(let ((*print-pprint-dispatch* *controller-pprint*))
(loop with observers = (observers controller)
for i from 0 below (length observers)
for (title . func) = (aref observers i)
when func
do (restart-case (format stream "~%~a:~12t~a" title (funcall func ev))
(remove-observer ()
:report "Remove the offending observer."
(setf (aref observers i) NIL))))))
(%string controller))))
(defmethod handle :after ((ev tick) (controller display-controller))
(when (and (show-overlay controller)
*context*)
(setf (text controller) (compose-controller-debug-text controller ev))
(setf (vy (location controller)) (- (vy (size controller)) (font-size controller)))
(setf (vx (location controller)) 5)))
(defmethod render :around ((controller display-controller) (program shader-program))
(when (show-overlay controller)
(with-pushed-matrix ((view-matrix :identity)
(projection-matrix :identity))
(orthographic-projection 0 (width *context*)
0 (height *context*)
0 10)
(translate-by 2 (- (height *context*) 14) 0)
(let ((fps-buffer (fps-buffer controller))
(idx (fps-buffer-idx controller)))
(when (= (length fps-buffer) idx)
(setf idx 0))
(setf (aref fps-buffer idx) (if (= 0 (frame-time +main+)) 1f0 (/ (float (frame-time +main+) 0f0))))
(setf (fps-buffer-idx controller) (1+ idx)))
(with-depth-mask T
(call-next-method)))))