-
-
Notifications
You must be signed in to change notification settings - Fork 44
/
settings.lisp
231 lines (207 loc) · 9.47 KB
/
settings.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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
(in-package #:org.shirakumo.fraf.trial)
(defvar *save-settings* T)
(define-global +settings-observers+ (make-hash-table :test 'equal))
(define-global +settings+ '(:audio (:latency 0.005
:backend :default
:device :default
:volume (:master 0.5
:effect 1.0
:music 1.0))
:display (:resolution (T T)
:fullscreen T
:vsync T
:target-framerate :none
:gamma 2.2
:ui-scale 1.0
:frame-scale 1.0
:texture (:filter :trilinear :anisotropy 2))
:gameplay (:rumble 1.0
:screen-shake 1.0
:fov 75)
:language :system
:debugging (:remote-debug (:active NIL :port 4005)
:fps-counter NIL)))
(defun setting-file-path ()
(make-pathname :name "settings" :type "lisp"
:defaults (config-directory)))
(defun keymap-path ()
(make-pathname :name "keymap" :type "lisp"
:defaults (config-directory)))
(defun map-leaf-settings (function &optional (settings +settings+))
(labels ((recurse (node rpath)
(loop for (k v) on node by #'cddr
do (if (and (consp v) (keywordp (car v)))
(recurse v (list* k rpath))
(funcall function (reverse (list* k rpath)) v)))))
(recurse settings ())))
(defun load-keymap (&key (path (keymap-path)) reset (package *package*))
(ensure-directories-exist path)
(let ((default (merge-pathnames "keymap.lisp" (data-root))))
(cond ((or reset
(not (probe-file path))
(and (probe-file default) (< (file-write-date path) (file-write-date default))))
(when (probe-file default)
(load-mapping default :package package))
(when (and (probe-file path) (null reset))
(load-mapping path :package package))
(save-keymap :path path :package package))
(T
(load-mapping path :package package)))))
(defun save-keymap (&key (path (keymap-path)) (package *package*))
(ensure-directories-exist path)
(save-mapping path :package package))
(defmethod load-settings (&optional (path (setting-file-path)))
(with-error-logging (:trial.settings)
(v:info :trial.settings "Loading settings from ~a" path)
(depot:with-open (tx (depot:from-pathname path) :input 'character :if-does-not-exist NIL)
(when tx
(with-trial-io-syntax ()
(let ((*save-settings* NIL)
(stream (depot:to-stream tx)))
(map-leaf-settings
(lambda (path value)
(apply #'(setf setting) value path))
(loop for k = (read stream NIL '#1=#:eof)
until (eq k '#1#)
collect k)))))))
+settings+)
(defmethod save-settings (&optional (path (setting-file-path)))
(ignore-errors
(with-error-logging (:trial.settings)
(v:info :trial.settings "Saving settings to ~a" path)
(depot:with-open (tx (depot:from-pathname path) :output 'character)
(let ((stream (depot:to-stream tx)))
(with-trial-io-syntax ()
(labels ((plist (indent part)
(loop for (k v) on part by #'cddr
do (format stream "~&~v{ ~}~s " (* indent 2) '(0) k)
(serialise indent v)))
(serialise (indent part)
(typecase part
(cons
(cond ((keywordp (car part))
(format stream "(")
(plist (1+ indent) part)
(format stream ")"))
(T
(prin1 part stream))))
(null
(format stream "NIL"))
(T
(let ((*print-readably* T))
(prin1 part stream))))))
(plist 0 +settings+)))))))
+settings+)
(defun setting (&rest path)
(loop with node = (or +settings+ (load-settings))
for key in path
for next = (getf node key '#1=#:not-found)
do (if (eq next '#1#)
(return (values NIL NIL))
(setf node next))
finally (return (values node T))))
(define-compiler-macro setting (&whole whole &rest path &environment env)
(if (loop for part in path always (constantp part env))
(let ((inner (gensym "INNER"))
(not-found (gensym "NOT-FOUND")))
(labels ((rec (path)
(if path
`(let ((,inner ,(rec (rest path))))
(if (eq ,inner ',not-found)
,inner
(getf ,inner ,(car path) ',not-found)))
`(or +settings+ (load-settings)))))
`(let ((,inner ,(rec (reverse path))))
(if (eq ,inner ',not-found)
(values NIL NIL)
(values ,inner T)))))
whole))
(defun setting* (default &rest path)
(or (apply #'setting path) default))
(define-compiler-macro setting* (default &rest path)
`(or (setting ,@path) ,default))
(defun %call-setting-observers (sub)
(loop for (k v) on (gethash sub +settings-observers+) by #'cddr
do (with-simple-restart (abort "Don't call the observer.")
(handler-bind (#-trial-release (error #'invoke-debugger)
#+trial-release (error (lambda (e) (v:error :trial.settings e)
(invoke-restart 'abort))))
(funcall v (apply #'setting sub))))))
(defun (setf setting) (value &rest path)
(labels ((update (node key path)
(cond (path
(setf (getf node key) (update (getf node key) (first path) (rest path))))
((eql value (getf node key))
(return-from setting value))
(T
(setf (getf node key) value)))
node))
(setf +settings+ (update +settings+ (first path) (rest path)))
(loop for i from 0 below (length path)
for sub = (butlast path i)
do (%call-setting-observers sub))
(when *save-settings*
(save-settings))
value))
(defun observe-setting (setting name function)
(setf (getf (gethash setting +settings-observers+) name) function))
(defun remove-setting-observer (setting name)
(remf (gethash setting +settings-observers+) name))
(defmacro define-setting-observer (name &rest setting)
(let ((setting (loop for part = (first setting)
until (listp part)
collect (pop setting)))
(args (pop setting))
(body setting)
(v (gensym "VALUE")))
`(observe-setting ',setting ',name
,(if args
`(lambda ,args
,@body)
`(lambda (,v)
(declare (ignore ,v))
,@body)))))
(define-setting-observer video-mode :display :resolution (value)
(when *context*
(show *context* :fullscreen (setting :display :fullscreen) :mode value)))
(define-setting-observer fullscreen :display :fullscreen (value)
(when *context*
(show *context* :fullscreen value :mode (setting :display :resolution))))
(define-setting-observer monitor :display :monitor (value)
(when *context*
(show *context* :fullscreen (setting :display :fullscreen) :mode (or value T))))
(define-setting-observer vsync :display :vsync (vsync)
(when *context*
(setf (vsync *context*) vsync)))
(define-setting-observer framerate :display :target-framerate (value)
(when +main+
(setf (target-frame-time +main+) (float (typecase value
(real (/ value))
(T 0.0))
0d0))))
(define-setting-observer fps-counter :debugging :fps-counter (value)
(when +main+
(let ((scene (scene +main+)))
(when (scene +main+)
(if value
(unless (node 'fps-counter scene)
(enter-and-load (make-instance 'fps-counter) scene +main+))
(when (node 'fps-counter scene)
(leave (node 'fps-counter scene) T)))))))
(define-setting-observer remote-debug :debugging :remote-debug (value)
(let ((pkg (or (find-package "SWANK") (find-package "SLYNK")))
(active (getf value :active))
(port (getf value :port 4005)))
(macrolet ((f (func &rest args)
`(funcall (find-symbol ,(string func) pkg) ,@args)))
(when pkg
(handler-case
(cond (active
(f create-server :port port :dont-close T)
(setf *inhibit-standalone-handler* T))
(T
(ignore-errors (f stop-server port))
(setf *inhibit-standalone-handler* NIL)))
(error (e)
(v:error :trial "Failed to start swank: ~a" e)
(v:debug :trial e)))))))