-
-
Notifications
You must be signed in to change notification settings - Fork 46
/
main.lisp
153 lines (130 loc) · 5.23 KB
/
main.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
(in-package #:org.shirakumo.fraf.trial)
(define-event scene-changed () scene old-scene)
(defclass main (display gamepad-input-handler)
((scene :initform (make-instance 'pipelined-scene) :accessor scene)
(loader :initform (make-instance 'loader) :accessor loader)))
(defmethod initialize-instance :before ((main main) &key)
(clear-retained)
(setf +main+ main))
(defmethod start ((main main))
(cond ((uiop:getenvp "TRIAL_QUIT_AFTER_INIT")
(quit (context main)))
(T
(call-next-method))))
(defmethod finalize ((main main))
(v:info :trial.main "RAPTURE")
(when (context main)
(acquire-context (context main) :force T))
(finalize (loader main))
(finalize (scene main)))
(defmethod finalize :after ((main main))
(setf +main+ NIL)
(setf +input-source+ :keyboard)
(setf +map-key-events+ T))
(defmethod username ((main main))
(system-username))
(defmethod username ((default (eql T)))
(if +main+
(username +main+)
(system-username)))
(defmethod scene ((default (eql T)))
(scene +main+))
(defmethod handle (event (main main))
(when (scene main)
(issue (scene main) event)))
(defmethod handle :before (event (main main))
(typecase event
((or mouse-event keyboard-event)
(setf +input-source+ :keyboard))
(gamepad-move
(when (< 0.1 (pos event))
(setf +input-source+ (device event))))
(gamepad-press
(setf +input-source+ (device event)))))
(defmethod handle ((window window-close) (main main))
(quit (context main)))
(defmethod update ((main main) tt dt fc)
(let ((scene (scene main)))
(issue scene 'pre-tick :tt tt :dt dt :fc fc)
(issue scene 'tick :tt tt :dt dt :fc fc)
(issue scene 'post-tick :tt tt :dt dt :fc fc)
(process scene)))
(defmethod commit (thing (main main) &rest args)
(apply #'commit thing (loader main) args))
(defmethod setup-rendering :after ((main main))
(restart-case
(change-scene main (scene main) :old NIL)
(abort ()
:report "Don't set up the scene, leaving it empty."
(unless (scene main)
(setf (scene main) (make-instance 'scene)))
(clear (scene main)))))
(defmethod setup-scene :around ((main main) (scene scene))
(v:info :trial.main "Setting up ~a" scene)
(with-timing-report (info :trial.main "Scene setup took ~fs run time, ~fs clock time.")
(call-next-method))
;; Cause camera to refresh
(issue scene 'resize :width (width main) :height (height main))
scene)
(defmethod setup-scene ((main main) scene)
())
(defmethod setup-scene :after ((main main) (scene scene))
(unless (node :controller scene)
(enter (make-instance 'controller) scene)))
;; FIXME: When transitioning between scenes we should try to re-use existing textures
;; and fbos to reduce the amount of unnecessary allocation.
(defmethod change-scene ((main main) (new scene) &key (old (scene main)))
(unless (eq old new)
(setf (scene main) new)
(with-cleanup-on-failure (setf (scene main) old)
(setup-scene main new)
(with-timing-report (info :trial.main "Commit took ~fs run time, ~fs clock time.")
(commit new (loader main)))
(handle (make-event 'scene-changed :scene new :old-scene old) new)))
(values new old))
(defmethod enter-and-load ((object renderable) (container container) (main main))
(let ((area (make-instance 'staging-area)))
(stage object area)
(enter object container)
(with-cleanup-on-failure (loop for pass across (passes (scene main))
do (when (object-renderable-p object pass)
(leave object pass))
finally (leave object container))
(loop for pass across (passes (scene main))
do (when (object-renderable-p object pass)
(loop for program being the hash-keys of (program-table pass)
do (stage program area))))
(commit area (loader main) :unload NIL))
object))
(defmethod enter-and-load ((object entity) (container container) (main main))
(let ((area (make-instance 'staging-area)))
(stage object area)
(enter object container)
(with-cleanup-on-failure (leave object container)
(commit area (loader main) :unload NIL))
object))
(defmethod render ((source main) (target main))
(when (visible-p (context target))
(render (scene source) NIL)
;; KLUDGE: This assumes a pipelined scene
(blit-to-screen (scene source))))
(defmethod launch ((main symbol) &rest initargs)
#+nx (setf (v:repl-level) :trace)
(standalone-logging-handler)
(v:output-here)
(v:info :trial.main "GENESIS")
(v:info :trail.main "Launching version ~a (~a)" (version :app) (version :binary))
(when (uiop:getenvp "TRIAL_QUIT_AFTER_INIT")
(let ((context (getf initargs :context)))
(setf (getf initargs :context) (list* :visible NIL context))))
(handler-bind ((error #'standalone-error-handler)
#+trial-release (style-warning #'muffle-warning))
(flet ((thunk ()
(apply #'launch-with-context main initargs)))
(if (or (find :darwin *features*) (deploy:deployed-p))
(float-features:with-float-traps-masked T
(thunk))
(thunk))))
(v:info :trial.main "We're done")
(setf *context* NIL)
#-nx (tg:gc :full T))