forked from Shirakumo/trial
-
Notifications
You must be signed in to change notification settings - Fork 0
/
controller.lisp
168 lines (137 loc) · 6.21 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
#|
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)
(defvar *observers* (make-array 0 :adjustable T :fill-pointer T))
(define-action-set system-action)
(define-action reload-scene (system-action))
(define-action quit-game (system-action)
(key-press (and (eql key :q) (find :control modifiers))))
(define-action toggle-overlay (system-action)
(key-press (one-of key :section :grave)))
(defclass controller (entity listener)
((display :initform NIL :initarg :display :accessor display))
(:default-initargs
:name :controller))
(defmethod handle ((ev quit-game) (controller controller))
(quit *context*))
(defmethod handle ((ev event) (controller controller))
(map-event ev *scene*))
(defmethod handle ((ev lose-focus) (controller controller))
(clear-retained))
(defmethod handle ((ev reload-scene) (controller controller))
(let ((old (scene (display controller))))
(change-scene (display controller) (make-instance (type-of old) :clock (clock old)))))
(defun find-controller ()
(or (when *context* (unit :controller (scene (handler *context*))))
(error "No reachable controller found.")))
(defmethod observe ((func function) &key title)
(let ((title (or title (format NIL "~d" (length *observers*)))))
(let ((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)
(apply #'observe (compile NIL `(lambda (ev)
(declare (ignorable ev))
,thing))
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 *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)))))
(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 (display controller)) :unload NIL))))
(defun maybe-reload-scene (&optional (window (list-windows)))
(dolist (window (enlist window))
(issue (scene window) 'reload-scene)))
(defclass eval-request (event)
((func :initarg :func)))
(define-handler (controller eval-request) (func)
(funcall func))
(defun call-in-render-loop (function scene)
(issue scene 'eval-request :func function))
(defmacro with-eval-in-render-loop ((scene) &body body)
`(call-in-render-loop (lambda () ,@body) ,scene))
(defclass display-controller (controller renderable)
((text :initform NIL :accessor text)
(fps-buffer :initform (make-array 100 :fill-pointer T :initial-element 1) :reader fps-buffer)
(show-overlay :initform T :accessor show-overlay)))
(defmethod register-object-for-pass (pass (controller display-controller))
(register-object-for-pass pass (text controller)))
(defmethod stage ((controller display-controller) (area staging-area))
(stage (text controller) area))
(defmethod handle ((ev toggle-overlay) (controller display-controller))
(setf (show-overlay controller) (not (show-overlay controller))))
(defun compute-fps-buffer-fps (fps-buffer)
(/ (loop for i from 0 below (array-total-size fps-buffer)
sum (aref fps-buffer i))
(array-total-size fps-buffer)))
(defun compose-controller-debug-text (controller ev)
(multiple-value-bind (gfree gtotal) (gpu-room)
(multiple-value-bind (cfree ctotal) (cpu-room)
(with-output-to-string (stream)
(format stream "TIME [s]: ~8,2f~%~
FPS [Hz]: ~8,2f~%~
RAM [KB]: ~8d (~2d%)~%~
VRAM [KB]: ~8d (~2d%)~%~
RESOURCES: ~8d"
(clock (scene (display controller)))
(compute-fps-buffer-fps (fps-buffer controller))
(- ctotal cfree) (floor (/ (- ctotal cfree) ctotal 0.01))
(- gtotal gfree) (floor (/ (- gtotal gfree) gtotal 0.01))
(hash-table-count (loaded (loader (display controller)))))
(loop with observers = *observers*
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))))))))
(defmethod handle ((ev tick) (controller display-controller))
(when (and (show-overlay controller)
*context*)
(let ((text (text controller)))
(setf (vy (location text))
(- -5 (getf (text-extent text "a") :t)))
(setf (vx (location text)) 5)
(setf (text text) (compose-controller-debug-text controller ev)))))
(defmethod render ((controller display-controller) program)
(when (show-overlay controller)
(let ((fps-buffer (fps-buffer controller)))
(when (= (array-total-size fps-buffer) (fill-pointer fps-buffer))
(setf (fill-pointer fps-buffer) 0))
(vector-push (if (= 0 (frame-time (display controller)))
1
(/ (frame-time (display controller))))
fps-buffer))
(with-pushed-matrix ((*projection-matrix* :zero)
(*model-matrix* :identity)
(*view-matrix* :identity))
(orthographic-projection 0 (width *context*)
0 (height *context*)
0 10)
(translate-by 2 (- (height *context*) 14) 0)
(render (text controller) program))))