-
-
Notifications
You must be signed in to change notification settings - Fork 42
/
controller.lisp
120 lines (98 loc) · 4.51 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
#|
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-action system-action ())
(define-action save-game (system-action)
(key-press (eql key :f2)))
(define-action load-game (system-action)
(key-press (eql key :f3)))
(define-action reload-scene (system-action)
(key-press (eql key :f6)))
(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)))
;; FIXME
;; (define-asset (trial noto-sans) font
;; #p"noto-sans-regular.ttf")
;; (define-asset (trial noto-mono) font
;; #p"noto-mono-regular.ttf")
(define-subject controller ()
((display :initform NIL :accessor display)
(text :initform (make-instance 'text :font (asset 'trial 'noto-mono) :size 18) :accessor text)
(fps-buffer :initform (make-array 100 :fill-pointer T :initial-element 1))
(show-overlay :initform NIL :accessor show-overlay))
(:default-initargs
:name :controller))
(defmethod compute-resources ((controller controller) cache)
(compute-resources (text controller) cache))
(defmethod register-object-for-pass :after (pass (controller controller))
(register-object-for-pass pass (text controller)))
(define-handler (controller toggle-overlay) (ev)
(setf (show-overlay controller) (not (show-overlay controller))))
(define-handler (controller tick) (ev tt)
(when (show-overlay controller)
(multiple-value-bind (gfree gtotal) (gpu-room)
(multiple-value-bind (cfree ctotal) (cpu-room)
(with-slots (fps-buffer text) controller
(when (= (array-total-size fps-buffer) (fill-pointer fps-buffer))
(setf (fill-pointer fps-buffer) 0))
;; FIXME: Yeesh. Don't like these (handler *context*) accesses.
(vector-push (if (= 0 (frame-time (handler *context*))) 1 (/ (frame-time (handler *context*)))) fps-buffer)
(setf (vy (location text))
(- (getf (cl-fond:compute-extent (gl-name (font text)) "a") :t)))
(setf (vx (location text)) 5)
(setf (text text) (format NIL "TIME [s]: ~8,2f~%~
FPS [Hz]: ~8,2f~%~
RAM [KB]: ~8d (~2d%)~%~
VRAM [KB]: ~8d (~2d%)~%~
ASSETS : ~8d"
(clock (scene (display controller)))
(/ (loop for i from 0 below (array-total-size fps-buffer)
sum (aref fps-buffer i))
(array-total-size fps-buffer))
(- ctotal cfree) (floor (/ (- ctotal cfree) ctotal 0.01))
(- gtotal gfree) (floor (/ (- gtotal gfree) gtotal 0.01))
(hash-table-count (assets *context*)))))))))
(defmethod paint ((controller controller) target)
(when (show-overlay controller)
(with-pushed-matrix ((*projection-matrix* :zero)
(*model-matrix* :identity)
(*view-matrix* :identity))
(orthographic-projection 0 (width *context*)
0 (height *context*)
0 10)
(translate-by 0 (height *context*) 0)
(paint (text controller) target))))
(define-handler (controller quit-game) (ev)
(quit *context*))
(define-handler (controller mapping T 100) (ev)
(map-event ev *scene*)
(retain-event ev))
(define-handler (controller reload-scene reload-scene 99) (ev)
(let* ((display (display controller))
(old (scene display)))
(stop old)
(restart-case
(let ((new (make-instance (type-of old))))
(setf (clock new) (clock old))
(setup-scene display new)
(transition old new)
(setf (scene display) new))
(abort ()
:report "Give up reloading the scene and continue with the old."
(start old)))))
(defclass load-request (event)
((asset :initarg :asset)
(action :initarg :action :initform 'reload)))
(define-handler (controller load-request) (ev asset action)
(ecase action
(deallocate (deallocate asset))
(load (load asset))
(reload (reload asset))))
(defun maybe-reload-scene (&optional (window (list-windows)))
(dolist (window (enlist window))
(issue (scene window) 'reload-scene)))