Show More
@@ -1,533 +1,531 b'' | |||
|
1 | 1 | |
|
2 | 2 | (in-package sugar-qsp.api) |
|
3 | 3 | |
|
4 | 4 | ;;; API deals with DOM manipulation and some bookkeeping for the |
|
5 | 5 | ;;; intrinsics, namely variables |
|
6 | 6 | ;;; API is an implementation detail and has no QSP documentation. It |
|
7 | 7 | ;;; doesn't call intrinsics |
|
8 | 8 | |
|
9 | 9 | ;;; Utils |
|
10 | 10 | |
|
11 | 11 | (defun make-act-html (title img) |
|
12 | 12 | (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>" |
|
13 | 13 | (if img (+ "<img src='" img "'>") "") |
|
14 | 14 | title |
|
15 | 15 | "</a>")) |
|
16 | 16 | |
|
17 | 17 | (defun make-menu-item-html (num title img loc) |
|
18 | 18 | (+ "<a href='" (href-call finish-menu loc) "'>" |
|
19 | 19 | (if img (+ "<img src='" img "'>") "") |
|
20 | 20 | title |
|
21 | 21 | "</a>")) |
|
22 | 22 | |
|
23 | 23 | (defun make-obj (title img selected) |
|
24 | 24 | (+ "<li onclick='" (inline-call select-obj title img) "'>" |
|
25 | 25 | "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>" |
|
26 | 26 | (if img (+ "<img src='" img "'>") "") |
|
27 | 27 | title |
|
28 | 28 | "</a>")) |
|
29 | 29 | |
|
30 | 30 | (defun make-menu-delimiter () |
|
31 | 31 | "<hr>") |
|
32 | 32 | |
|
33 | 33 | (defun copy-obj (obj) |
|
34 | 34 | (chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj))))) |
|
35 | 35 | |
|
36 | 36 | (defun report-error (text) |
|
37 | 37 | (alert text)) |
|
38 | 38 | |
|
39 | 39 | (defun start-sleeping () |
|
40 | 40 | (chain (by-id "qsp") class-list (add "disable"))) |
|
41 | 41 | |
|
42 | 42 | (defun finish-sleeping () |
|
43 | 43 | (chain (by-id "qsp") class-list (remove "disable"))) |
|
44 | 44 | |
|
45 | 45 | (defun sleep (msec) |
|
46 | 46 | (with-sleep (resume) |
|
47 | 47 | (set-timeout resume msec))) |
|
48 | 48 | |
|
49 | 49 | (defun init-dom () |
|
50 | 50 | ;; Save/load buttons |
|
51 | 51 | (let ((btn (by-id "qsp-btn-save"))) |
|
52 | 52 | (setf (@ btn onclick) savegame) |
|
53 | 53 | (setf (@ btn href) "#")) |
|
54 | 54 | (let ((btn (by-id "qsp-btn-open"))) |
|
55 | 55 | (setf (@ btn onclick) opengame) |
|
56 | 56 | (setf (@ btn href) "#")) |
|
57 | 57 | ;; Close image on click |
|
58 | 58 | (setf (@ (by-id "qsp-image-container") onclick) |
|
59 | 59 | show-image) |
|
60 | 60 | ;; Enter in input field |
|
61 | 61 | (setf (@ (get-frame :input) onkeyup) |
|
62 | 62 | on-input-key) |
|
63 | 63 | ;; Close the dropdown on any click |
|
64 | 64 | (setf (@ window onclick) |
|
65 | 65 | (lambda (event) |
|
66 | 66 | (setf (@ window mouse) |
|
67 | 67 | (list (@ event page-x) |
|
68 | 68 | (@ event page-y))) |
|
69 | 69 | (finish-menu nil)))) |
|
70 | 70 | |
|
71 | 71 | (defun call-serv-loc (var-name &rest args) |
|
72 | 72 | (let ((loc-name (get-global var-name 0))) |
|
73 | 73 | (when loc-name |
|
74 | 74 | (let ((loc (getprop *locs loc-name))) |
|
75 | 75 | (when loc |
|
76 | 76 | (call-loc loc-name args)))))) |
|
77 | 77 | |
|
78 | 78 | (defun filename-game (filename) |
|
79 | 79 | (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2)))) |
|
80 | 80 | (getprop *games game-name)) |
|
81 | 81 | |
|
82 | 82 | (defun run-game (name) |
|
83 | 83 | (let ((game (filename-game name))) |
|
84 | 84 | (setf *main-game name) |
|
85 | 85 | ;; Replace locations with the new game's |
|
86 | 86 | (setf *locs game) |
|
87 | 87 | (funcall (getprop game |
|
88 | 88 | (chain *object (keys game) 0)) |
|
89 | 89 | (list)))) |
|
90 | 90 | |
|
91 | 91 | ;;; Misc |
|
92 | 92 | |
|
93 | 93 | (defun newline (key) |
|
94 | 94 | (append-id (key-to-id key) "<br>" t)) |
|
95 | 95 | |
|
96 | 96 | (defun clear-id (id) |
|
97 | 97 | (setf (inner-html (by-id id)) "")) |
|
98 | 98 | |
|
99 | 99 | (defun escape-html (text) |
|
100 | 100 | (chain text |
|
101 | 101 | (replace (regex "/&/g") "&") |
|
102 | 102 | (replace (regex "/</g") "<") |
|
103 | 103 | (replace (regex "/>/g") ">") |
|
104 | 104 | (replace (regex "/\"/g") """) |
|
105 | 105 | (replace (regex "/'/g") "'"))) |
|
106 | 106 | |
|
107 | 107 | (defun prepare-contents (s &optional force-html) |
|
108 | 108 | (setf s (chain s (to-string))) |
|
109 | 109 | (if (or force-html (get-global "USEHTML" 0)) |
|
110 | 110 | s |
|
111 | 111 | (escape-html s))) |
|
112 | 112 | |
|
113 | 113 | (defun get-id (id &optional force-html) |
|
114 | 114 | (inner-html (by-id id))) |
|
115 | 115 | |
|
116 | 116 | (defun set-id (id contents &optional force-html) |
|
117 | 117 | (setf (inner-html (by-id id)) (prepare-contents contents force-html))) |
|
118 | 118 | |
|
119 | 119 | (defun append-id (id contents &optional force-html) |
|
120 | 120 | (when contents |
|
121 | 121 | (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) |
|
122 | 122 | |
|
123 | 123 | (defun on-input-key (ev) |
|
124 | 124 | (when (= 13 (@ ev key-code)) |
|
125 | 125 | (chain ev (prevent-default)) |
|
126 | 126 | (call-serv-loc "$USERCOM"))) |
|
127 | 127 | |
|
128 | 128 | ;;; Function calls |
|
129 | 129 | |
|
130 | 130 | (defun init-args (args) |
|
131 | 131 | (dotimes (i (length args)) |
|
132 | 132 | (let ((arg (elt args i))) |
|
133 | 133 | (if (numberp arg) |
|
134 | 134 | (set-var args i :num arg) |
|
135 | 135 | (set-var args i :str arg))))) |
|
136 | 136 | |
|
137 | 137 | (defun get-result () |
|
138 | 138 | (or (get-global "$RESULT" 0) |
|
139 | 139 | (get-global "RESULT" 0))) |
|
140 | 140 | |
|
141 | 141 | (defun call-loc (name args) |
|
142 | 142 | (setf name (chain name (to-upper-case))) |
|
143 | 143 | (with-frame |
|
144 | 144 | (with-call-args args |
|
145 | 145 | (funcall (getprop *locs name)))) |
|
146 | 146 | (void)) |
|
147 | 147 | |
|
148 | 148 | (defun call-act (title) |
|
149 | (setf *current-action title) | |
|
150 | 149 | (with-frame |
|
151 | 150 | (funcall (getprop *acts title :act))) |
|
152 | (setf *current-action nil) | |
|
153 | 151 | (void)) |
|
154 | 152 | |
|
155 | 153 | ;;; Text windows |
|
156 | 154 | |
|
157 | 155 | (defun key-to-id (key) |
|
158 | 156 | (case key |
|
159 | 157 | (:all "qsp") |
|
160 | 158 | (:main "qsp-main") |
|
161 | 159 | (:stat "qsp-stat") |
|
162 | 160 | (:objs "qsp-objs") |
|
163 | 161 | (:acts "qsp-acts") |
|
164 | 162 | (:input "qsp-input") |
|
165 | 163 | (:image "qsp-image") |
|
166 | 164 | (:dropdown "qsp-dropdown") |
|
167 | 165 | (t (report-error "Internal error!")))) |
|
168 | 166 | |
|
169 | 167 | (defun get-frame (key) |
|
170 | 168 | (by-id (key-to-id key))) |
|
171 | 169 | |
|
172 | 170 | (defun add-text (key text) |
|
173 | 171 | (append-id (key-to-id key) text)) |
|
174 | 172 | |
|
175 | 173 | (defun get-text (key) |
|
176 | 174 | (get-id (key-to-id key))) |
|
177 | 175 | |
|
178 | 176 | (defun clear-text (key) |
|
179 | 177 | (clear-id (key-to-id key))) |
|
180 | 178 | |
|
181 | 179 | (defun enable-frame (key enable) |
|
182 | 180 | (let ((obj (get-frame key))) |
|
183 | 181 | (setf (@ obj style display) (if enable "block" "none")) |
|
184 | 182 | (void))) |
|
185 | 183 | |
|
186 | 184 | ;;; Actions |
|
187 | 185 | |
|
188 | 186 | (defun add-act (title img act) |
|
189 | 187 | (setf (getprop *acts title) |
|
190 | 188 | (create :title title :img img :act act :selected nil)) |
|
191 | 189 | (update-acts)) |
|
192 | 190 | |
|
193 |
(defun del-act ( |
|
|
194 |
(delete (getprop *acts |
|
|
191 | (defun del-act (title) | |
|
192 | (delete (getprop *acts title)) | |
|
195 | 193 | (update-acts)) |
|
196 | 194 | |
|
197 | 195 | (defun clear-act () |
|
198 | 196 | (setf *acts (create)) |
|
199 | 197 | (update-acts)) |
|
200 | 198 | |
|
201 | 199 | (defun update-acts () |
|
202 | 200 | (clear-id "qsp-acts") |
|
203 | 201 | (let ((elt (by-id "qsp-acts"))) |
|
204 | 202 | (for-in (title *acts) |
|
205 | 203 | (let ((obj (getprop *acts title))) |
|
206 | 204 | (incf (inner-html elt) (make-act-html title (getprop obj :img))))))) |
|
207 | 205 | |
|
208 | 206 | (defun select-act (title) |
|
209 | 207 | (loop :for (k v) :of *acts |
|
210 | 208 | :do (setf (getprop v :selected) nil)) |
|
211 | 209 | (setf (getprop *acts title :selected) t) |
|
212 | 210 | (call-serv-loc "$ONACTSEL")) |
|
213 | 211 | |
|
214 | 212 | ;;; "Syntax" |
|
215 | 213 | |
|
216 | 214 | (defun qspfor (name index from to step body) |
|
217 | 215 | (for ((i from)) |
|
218 | 216 | ((< i to)) |
|
219 | 217 | ((incf i step)) |
|
220 | 218 | (set-var name index :num i) |
|
221 | 219 | (unless (await (funcall body)) |
|
222 | 220 | (return-from qspfor)))) |
|
223 | 221 | |
|
224 | 222 | ;;; Variables |
|
225 | 223 | |
|
226 | 224 | (defun new-var (slot &rest indexes) |
|
227 | 225 | (let ((v (list))) |
|
228 | 226 | (dolist (index indexes) |
|
229 | 227 | (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0))) |
|
230 | 228 | (setf (@ v :indexes) (create)) |
|
231 | 229 | v)) |
|
232 | 230 | |
|
233 | 231 | (defun set-str-element (slot index value) |
|
234 | 232 | (if (has index (getprop slot :indexes)) |
|
235 | 233 | (setf (elt (getprop slot) |
|
236 | 234 | (getprop slot :indexes index)) |
|
237 | 235 | value) |
|
238 | 236 | (progn |
|
239 | 237 | (chain slot (push value)) |
|
240 | 238 | (setf (elt slot index) |
|
241 | 239 | (length slot)))) |
|
242 | 240 | (void)) |
|
243 | 241 | |
|
244 | 242 | (defun set-any-element (slot index value) |
|
245 | 243 | (cond ((null index) |
|
246 | 244 | (chain (elt slot) (push value))) |
|
247 | 245 | ((numberp index) |
|
248 | 246 | (setf (elt slot index) value)) |
|
249 | 247 | ((stringp index) |
|
250 | 248 | (set-str-element slot index value)) |
|
251 | 249 | (t (report-error "INTERNAL ERROR"))) |
|
252 | 250 | (void)) |
|
253 | 251 | |
|
254 | 252 | (defun set-serv-var (name index value) |
|
255 | 253 | (let ((slot (getprop *globals name))) |
|
256 | 254 | (set-any-element slot index value)) |
|
257 | 255 | (funcall (getprop serv-vars name :body) value index) |
|
258 | 256 | (void)) |
|
259 | 257 | |
|
260 | 258 | (defun get-element (slot index) |
|
261 | 259 | (if (numberp index) |
|
262 | 260 | (elt slot index) |
|
263 | 261 | (elt slot (getprop slot :indexes index)))) |
|
264 | 262 | |
|
265 | 263 | (defun get-global (name index) |
|
266 | 264 | (elt (getprop *globals name) index)) |
|
267 | 265 | |
|
268 | 266 | (defun kill-var (store name &optional index) |
|
269 | 267 | (setf name (chain name (to-upper-case))) |
|
270 | 268 | (if (and index (not (= 0 index))) |
|
271 | 269 | (chain (getprop *globals name) (kill index)) |
|
272 | 270 | (delete (getprop *globals name))) |
|
273 | 271 | (void)) |
|
274 | 272 | |
|
275 | 273 | (defun array-size (name) |
|
276 | 274 | (@ (var-ref name) :values length)) |
|
277 | 275 | |
|
278 | 276 | ;;; Locals |
|
279 | 277 | |
|
280 | 278 | (defun push-local-frame () |
|
281 | 279 | (chain *locals (push (create))) |
|
282 | 280 | (void)) |
|
283 | 281 | |
|
284 | 282 | (defun pop-local-frame () |
|
285 | 283 | (chain *locals (pop)) |
|
286 | 284 | (void)) |
|
287 | 285 | |
|
288 | 286 | (defun current-local-frame () |
|
289 | 287 | (elt *locals (1- (length *locals)))) |
|
290 | 288 | |
|
291 | 289 | ;;; Objects |
|
292 | 290 | |
|
293 | 291 | (defun select-obj (title img) |
|
294 | 292 | (loop :for (k v) :of *objs |
|
295 | 293 | :do (setf (getprop v :selected) nil)) |
|
296 | 294 | (setf (getprop *objs title :selected) t) |
|
297 | 295 | (call-serv-loc "$ONOBJSEL" title img)) |
|
298 | 296 | |
|
299 | 297 | (defun update-objs () |
|
300 | 298 | (let ((elt (by-id "qsp-objs"))) |
|
301 | 299 | (setf (inner-html elt) "<ul>") |
|
302 | 300 | (loop :for (name obj) :of *objs |
|
303 | 301 | :do (incf (inner-html elt) |
|
304 | 302 | (make-obj name (@ obj :img) (@ obj :selected)))) |
|
305 | 303 | (incf (inner-html elt) "</ul>"))) |
|
306 | 304 | |
|
307 | 305 | ;;; Menu |
|
308 | 306 | |
|
309 | 307 | (defun open-menu (menu-data) |
|
310 | 308 | (let ((elt (get-frame :dropdown)) |
|
311 | 309 | (i 0)) |
|
312 | 310 | (loop :for item :in menu-data |
|
313 | 311 | :do (incf i) |
|
314 | 312 | :do (incf (inner-html elt) |
|
315 | 313 | (if (eq item :delimiter) |
|
316 | 314 | (make-menu-delimiter i) |
|
317 | 315 | (make-menu-item-html i |
|
318 | 316 | (@ item :text) |
|
319 | 317 | (@ item :icon) |
|
320 | 318 | (@ item :loc))))) |
|
321 | 319 | (let ((mouse (@ window mouse))) |
|
322 | 320 | (setf (@ elt style left) (+ (elt mouse 0) "px")) |
|
323 | 321 | (setf (@ elt style top) (+ (elt mouse 1) "px")) |
|
324 | 322 | ;; Make sure it's inside the viewport |
|
325 | 323 | (when (> (@ document body inner-width) |
|
326 | 324 | (+ (elt mouse 0) (@ elt inner-width))) |
|
327 | 325 | (incf (@ elt style left) (@ elt inner-width))) |
|
328 | 326 | (when (> (@ document body inner-height) |
|
329 | 327 | (+ (elt mouse 0) (@ elt inner-height))) |
|
330 | 328 | (incf (@ elt style top) (@ elt inner-height)))) |
|
331 | 329 | (setf (@ elt style display) "block"))) |
|
332 | 330 | |
|
333 | 331 | (defun finish-menu (loc) |
|
334 | 332 | (when *menu-resume |
|
335 | 333 | (let ((elt (get-frame :dropdown))) |
|
336 | 334 | (setf (inner-html elt) "") |
|
337 | 335 | (setf (@ elt style display) "none") |
|
338 | 336 | (funcall *menu-resume) |
|
339 | 337 | (setf *menu-resume nil)) |
|
340 | 338 | (when loc |
|
341 | 339 | (call-loc loc))) |
|
342 | 340 | (void)) |
|
343 | 341 | |
|
344 | 342 | (defun menu (menu-data) |
|
345 | 343 | (with-sleep (resume) |
|
346 | 344 | (open-menu menu-data) |
|
347 | 345 | (setf *menu-resume resume)) |
|
348 | 346 | (void)) |
|
349 | 347 | |
|
350 | 348 | ;;; Content |
|
351 | 349 | |
|
352 | 350 | (defun clean-audio () |
|
353 | 351 | (loop :for k :in (chain *object (keys *playing)) |
|
354 | 352 | :for v := (getprop *playing k) |
|
355 | 353 | :do (when (@ v ended) |
|
356 | 354 | (delete (@ *playing k))))) |
|
357 | 355 | |
|
358 | 356 | (defun show-image (path) |
|
359 | 357 | (let ((img (get-frame :image))) |
|
360 | 358 | (cond (path |
|
361 | 359 | (setf (@ img src) path) |
|
362 | 360 | (setf (@ img style display) "flex")) |
|
363 | 361 | (t |
|
364 | 362 | (setf (@ img src) "") |
|
365 | 363 | (setf (@ img style display) "hidden"))))) |
|
366 | 364 | |
|
367 | 365 | (defun show-inline-images (frame-name images) |
|
368 | 366 | (let ((frame (get-frame frame-name)) |
|
369 | 367 | (text "")) |
|
370 | 368 | (incf text "<div style='position:relative; display: inline-block'>") |
|
371 | 369 | (incf text (+ "<img src='" (@ images 0) "'>")) |
|
372 | 370 | (loop :for image :in (chain images (slice 1)) |
|
373 | 371 | :do (incf text |
|
374 | 372 | (+ "<img style='position:absolute' src='" image "'>"))) |
|
375 | 373 | (incf text "</div>") |
|
376 | 374 | (incf (inner-html frame) text))) |
|
377 | 375 | |
|
378 | 376 | (defun rgb-string (rgb) |
|
379 | 377 | (let ((red (ps::>> rgb 16)) |
|
380 | 378 | (green (logand (ps::>> rgb 8) 255)) |
|
381 | 379 | (blue (logand rgb 255))) |
|
382 | 380 | (flet ((rgb-to-hex (comp) |
|
383 | 381 | (let ((hex (chain (*number comp) (to-string 16)))) |
|
384 | 382 | (if (< (length hex) 2) |
|
385 | 383 | (+ "0" hex) |
|
386 | 384 | hex)))) |
|
387 | 385 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue))))) |
|
388 | 386 | |
|
389 | 387 | (defun store-obj (key obj) |
|
390 | 388 | (store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj))))) |
|
391 | 389 | (void)) |
|
392 | 390 | (defun store-str (key str) |
|
393 | 391 | (chain local-storage (set-item (+ "qsp_" key) str)) |
|
394 | 392 | (void)) |
|
395 | 393 | |
|
396 | 394 | (defun load-obj (key) |
|
397 | 395 | (chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key)))))) |
|
398 | 396 | (defun load-str (key) |
|
399 | 397 | (chain local-storage (get-item (+ "qsp_" key)))) |
|
400 | 398 | |
|
401 | 399 | ;;; Saves |
|
402 | 400 | |
|
403 | 401 | (defun slot-savegame (slot comment) |
|
404 | 402 | (let ((saves (load-obj "saves"))) |
|
405 | 403 | (setf (@ saves slot) comment) |
|
406 | 404 | (store-obj saves)) |
|
407 | 405 | (store-str slot (state-to-base64)) |
|
408 | 406 | (void)) |
|
409 | 407 | |
|
410 | 408 | (defun slot-loadgame (slot) |
|
411 | 409 | (base64-to-state (load-str slot)) |
|
412 | 410 | (void)) |
|
413 | 411 | |
|
414 | 412 | (defun slot-deletegame (slot) |
|
415 | 413 | (let ((saves (load-obj "saves"))) |
|
416 | 414 | (setf (@ saves slot) undefined) |
|
417 | 415 | (store-obj saves)) |
|
418 | 416 | (store-str slot undefined) |
|
419 | 417 | (void)) |
|
420 | 418 | |
|
421 | 419 | (defun slot-listgames () |
|
422 | 420 | (load-obj "saves")) |
|
423 | 421 | |
|
424 | 422 | (defun opengame () |
|
425 | 423 | (let ((element (chain document (create-element :input)))) |
|
426 | 424 | (chain element (set-attribute :type :file)) |
|
427 | 425 | (chain element (set-attribute :id :qsp-opengame)) |
|
428 | 426 | (chain element (set-attribute :tabindex -1)) |
|
429 | 427 | (chain element (set-attribute "aria-hidden" t)) |
|
430 | 428 | (setf (@ element style display) :block) |
|
431 | 429 | (setf (@ element style visibility) :hidden) |
|
432 | 430 | (setf (@ element style position) :fixed) |
|
433 | 431 | (setf (@ element onchange) |
|
434 | 432 | (lambda (event) |
|
435 | 433 | (let* ((file (@ event target files 0)) |
|
436 | 434 | (reader (new (*file-reader)))) |
|
437 | 435 | (setf (@ reader onload) |
|
438 | 436 | (lambda (ev) |
|
439 | 437 | (block nil |
|
440 | 438 | (let ((target (@ ev current-target))) |
|
441 | 439 | (unless (@ target result) |
|
442 | 440 | (return)) |
|
443 | 441 | (base64-to-state (@ target result)) |
|
444 | 442 | (unstash-state))))) |
|
445 | 443 | (chain reader (read-as-text file))))) |
|
446 | 444 | (chain document body (append-child element)) |
|
447 | 445 | (chain element (click)) |
|
448 | 446 | (chain document body (remove-child element)))) |
|
449 | 447 | |
|
450 | 448 | (defun savegame () |
|
451 | 449 | (let ((element (chain document (create-element :a)))) |
|
452 | 450 | (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64)))) |
|
453 | 451 | (chain element (set-attribute :download "savegame.sav")) |
|
454 | 452 | (setf (@ element style display) :none) |
|
455 | 453 | (chain document body (append-child element)) |
|
456 | 454 | (chain element (click)) |
|
457 | 455 | (chain document body (remove-child element)))) |
|
458 | 456 | |
|
459 | 457 | (defun stash-state (args) |
|
460 | 458 | (call-serv-loc "$ONGSAVE") |
|
461 | 459 | (setf *state-stash |
|
462 | 460 | (chain *j-s-o-n (stringify |
|
463 | 461 | (create :vars *globals |
|
464 | 462 | :objs *objs |
|
465 | 463 | :loc-args args |
|
466 | 464 | :msecs (- (chain *date (now)) *started-at) |
|
467 | 465 | :timer-interval *timer-interval |
|
468 | 466 | :main-html (inner-html |
|
469 | 467 | (get-frame :main)) |
|
470 | 468 | :stat-html (inner-html |
|
471 | 469 | (get-frame :stat)) |
|
472 | 470 | :next-location *current-location)))) |
|
473 | 471 | (void)) |
|
474 | 472 | |
|
475 | 473 | (defun unstash-state () |
|
476 | 474 | (let ((data (chain *j-s-o-n (parse *state-stash)))) |
|
477 | 475 | (clear-act) |
|
478 | 476 | (setf *globals (@ data :vars)) |
|
479 | 477 | (loop :for k :in (chain *object (keys *globals)) |
|
480 | 478 | :do (chain *object (set-prototype-of (getprop *globals k) |
|
481 | 479 | (@ *var prototype)))) |
|
482 | 480 | (setf *started-at (- (chain *date (now)) (@ data :msecs))) |
|
483 | 481 | (setf *objs (@ data :objs)) |
|
484 | 482 | (setf *current-location (@ data :next-location)) |
|
485 | 483 | (setf (inner-html (get-frame :main)) |
|
486 | 484 | (@ data :main-html)) |
|
487 | 485 | (setf (inner-html (get-frame :stat)) |
|
488 | 486 | (@ data :stat-html)) |
|
489 | 487 | (update-objs) |
|
490 | 488 | (set-timer (@ data :timer-interval)) |
|
491 | 489 | (call-serv-loc "$ONGLOAD") |
|
492 | 490 | (call-loc *current-location (@ data :loc-args)) |
|
493 | 491 | (void))) |
|
494 | 492 | |
|
495 | 493 | (defun state-to-base64 () |
|
496 | 494 | (btoa (encode-u-r-i-component *state-stash))) |
|
497 | 495 | |
|
498 | 496 | (defun base64-to-state (data) |
|
499 | 497 | (setf *state-stash (decode-u-r-i-component (atob data)))) |
|
500 | 498 | |
|
501 | 499 | ;;; Timers |
|
502 | 500 | |
|
503 | 501 | (defun set-timer (interval) |
|
504 | 502 | (setf *timer-interval interval) |
|
505 | 503 | (clear-interval *timer-obj) |
|
506 | 504 | (setf *timer-obj |
|
507 | 505 | (set-interval |
|
508 | 506 | (lambda () |
|
509 | 507 | (call-serv-loc "$COUNTER")) |
|
510 | 508 | interval))) |
|
511 | 509 | |
|
512 | 510 | ;;; Special variables |
|
513 | 511 | |
|
514 | 512 | (defvar serv-vars (create)) |
|
515 | 513 | |
|
516 | 514 | (define-serv-var $backimage (path) |
|
517 | 515 | (setf (@ (get-frame :main) style background-image) path)) |
|
518 | 516 | |
|
519 | 517 | (define-serv-var bcolor (color) |
|
520 | 518 | (setf (@ (get-frame :all) style background-color) (rgb-string color))) |
|
521 | 519 | |
|
522 | 520 | (define-serv-var fcolor (color) |
|
523 | 521 | (setf (@ (get-frame :all) style color) (rgb-string color))) |
|
524 | 522 | |
|
525 | 523 | (define-serv-var lcolor (color) |
|
526 | 524 | (setf (@ (get-frame :style) inner-text) |
|
527 | 525 | (+ "a { color: " (rgb-string color) ";}"))) |
|
528 | 526 | |
|
529 | 527 | (define-serv-var fsize (size) |
|
530 | 528 | (setf (@ (get-frame :all) style font-size) size)) |
|
531 | 529 | |
|
532 | 530 | (define-serv-var $fname (font-name) |
|
533 | 531 | (setf (@ (get-frame :all) style font-family) (+ font-name ",serif"))) |
@@ -1,173 +1,170 b'' | |||
|
1 | 1 | |
|
2 | 2 | (in-package sugar-qsp.lib) |
|
3 | 3 | |
|
4 | 4 | ;;;; Macros implementing some intrinsics where it makes sense |
|
5 | 5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call |
|
6 | 6 | |
|
7 | 7 | ;;; 1loc |
|
8 | 8 | |
|
9 | 9 | ;;; 2var |
|
10 | 10 | |
|
11 | 11 | (defpsmacro killvar (varname &optional index) |
|
12 | 12 | `(api-call kill-var ,varname ,index)) |
|
13 | 13 | |
|
14 | 14 | (defpsmacro killall () |
|
15 | 15 | `(api-call kill-all)) |
|
16 | 16 | |
|
17 | 17 | ;;; 3expr |
|
18 | 18 | |
|
19 | 19 | (defpsmacro no (arg) |
|
20 | 20 | `(- -1 ,arg)) |
|
21 | 21 | |
|
22 | 22 | ;;; 4code |
|
23 | 23 | |
|
24 | 24 | (defpsmacro qspver () |
|
25 | 25 | "0.0.1") |
|
26 | 26 | |
|
27 | 27 | (defpsmacro curloc () |
|
28 | 28 | `*current-location) |
|
29 | 29 | |
|
30 | 30 | (defpsmacro rnd () |
|
31 | 31 | `(funcall rand 1 1000)) |
|
32 | 32 | |
|
33 | 33 | (defpsmacro qspmax (&rest args) |
|
34 | 34 | (if (= 1 (length args)) |
|
35 | 35 | `(*math.max.apply nil ,@args) |
|
36 | 36 | `(*math.max ,@args))) |
|
37 | 37 | |
|
38 | 38 | (defpsmacro qspmin (&rest args) |
|
39 | 39 | (if (= 1 (length args)) |
|
40 | 40 | `(*math.min.apply nil ,@args) |
|
41 | 41 | `(*math.min ,@args))) |
|
42 | 42 | |
|
43 | 43 | ;;; 5arrays |
|
44 | 44 | |
|
45 | 45 | (defpsmacro arrsize (name) |
|
46 | 46 | `(api-call array-size ,name)) |
|
47 | 47 | |
|
48 | 48 | ;;; 6str |
|
49 | 49 | |
|
50 | 50 | (defpsmacro len (s) |
|
51 | 51 | `(length ,s)) |
|
52 | 52 | |
|
53 | 53 | (defpsmacro mid (s from &optional count) |
|
54 | 54 | `(chain ,s (substring ,from ,count))) |
|
55 | 55 | |
|
56 | 56 | (defpsmacro ucase (s) |
|
57 | 57 | `(chain ,s (to-upper-case))) |
|
58 | 58 | |
|
59 | 59 | (defpsmacro lcase (s) |
|
60 | 60 | `(chain ,s (to-lower-case))) |
|
61 | 61 | |
|
62 | 62 | (defpsmacro trim (s) |
|
63 | 63 | `(chain ,s (trim))) |
|
64 | 64 | |
|
65 | 65 | (defpsmacro replace (s from to) |
|
66 | 66 | `(chain ,s (replace ,from ,to))) |
|
67 | 67 | |
|
68 | 68 | (defpsmacro val (s) |
|
69 | 69 | `(parse-int ,s 10)) |
|
70 | 70 | |
|
71 | 71 | (defpsmacro qspstr (n) |
|
72 | 72 | `(chain ,n (to-string))) |
|
73 | 73 | |
|
74 | 74 | ;;; 7if |
|
75 | 75 | |
|
76 | 76 | ;;; 8sub |
|
77 | 77 | |
|
78 | 78 | ;;; 9loops |
|
79 | 79 | |
|
80 | 80 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) |
|
81 | 81 | |
|
82 | 82 | (defpsmacro exit () |
|
83 | 83 | `(return-from nil (values))) |
|
84 | 84 | |
|
85 | 85 | ;;; 10dynamic |
|
86 | 86 | |
|
87 | 87 | ;;; 11main |
|
88 | 88 | |
|
89 | 89 | (defpsmacro desc (s) |
|
90 | 90 | (declare (ignore s)) |
|
91 | 91 | "") |
|
92 | 92 | |
|
93 | 93 | ;;; 12stat |
|
94 | 94 | |
|
95 | 95 | (defpsmacro showstat (enable) |
|
96 | 96 | `(api-call enable-frame :stat ,enable)) |
|
97 | 97 | |
|
98 | 98 | ;;; 13diag |
|
99 | 99 | |
|
100 | 100 | (defpsmacro msg (text) |
|
101 | 101 | `(alert ,text)) |
|
102 | 102 | |
|
103 | 103 | ;;; 14act |
|
104 | 104 | |
|
105 | (defpsmacro curact () | |
|
106 | `*current-action) | |
|
107 | ||
|
108 | 105 | (defpsmacro showacts (enable) |
|
109 | 106 | `(api-call enable-frame :acts ,enable)) |
|
110 | 107 | |
|
111 | 108 | (defpsmacro delact (&optional name) |
|
112 | 109 | (if name |
|
113 | 110 | `(api-call del-act ,name) |
|
114 | 111 | `(api-call del-act))) |
|
115 | 112 | |
|
116 | 113 | (defpsmacro cla () |
|
117 | 114 | `(api-call clear-act)) |
|
118 | 115 | |
|
119 | 116 | ;;; 15objs |
|
120 | 117 | |
|
121 | 118 | (defpsmacro showobjs (enable) |
|
122 | 119 | `(api-call enable-frame :objs ,enable)) |
|
123 | 120 | |
|
124 | 121 | (defpsmacro countobj () |
|
125 | 122 | `(length *objs)) |
|
126 | 123 | |
|
127 | 124 | (defpsmacro getobj (index) |
|
128 | 125 | `(or (elt *objs ,index) "")) |
|
129 | 126 | |
|
130 | 127 | ;;; 16menu |
|
131 | 128 | |
|
132 | 129 | ;;; 17sound |
|
133 | 130 | |
|
134 | 131 | (defpsmacro isplay (filename) |
|
135 | 132 | `(funcall (@ playing includes) ,filename)) |
|
136 | 133 | |
|
137 | 134 | ;;; 18img |
|
138 | 135 | |
|
139 | 136 | (defpsmacro view (&optional path) |
|
140 | 137 | `(api-call show-image ,path)) |
|
141 | 138 | |
|
142 | 139 | (defpsmacro img (&rest images) |
|
143 | 140 | `(api-call show-inline-images :stat (list ,@images))) |
|
144 | 141 | |
|
145 | 142 | (defpsmacro *img (&rest images) |
|
146 | 143 | `(api-call show-inline-images :main (list ,@images))) |
|
147 | 144 | |
|
148 | 145 | ;;; 19input |
|
149 | 146 | |
|
150 | 147 | (defpsmacro showinput (enable) |
|
151 | 148 | `(api-call enable-frame :input ,enable)) |
|
152 | 149 | |
|
153 | 150 | ;;; 20time |
|
154 | 151 | |
|
155 | 152 | (defpsmacro wait (msec) |
|
156 | 153 | `(await (api-call sleep ,msec))) |
|
157 | 154 | |
|
158 | 155 | (defpsmacro settimer (interval) |
|
159 | 156 | `(api-call set-timer ,interval)) |
|
160 | 157 | |
|
161 | 158 | ;;; 21local |
|
162 | 159 | |
|
163 | 160 | ;;; 22for |
|
164 | 161 | |
|
165 | 162 | ;;; misc |
|
166 | 163 | |
|
167 | 164 | (defpsmacro opengame (&optional filename) |
|
168 | 165 | (declare (ignore filename)) |
|
169 | 166 | `(api-call opengame)) |
|
170 | 167 | |
|
171 | 168 | (defpsmacro savegame (&optional filename) |
|
172 | 169 | (declare (ignore filename)) |
|
173 | 170 | `(api-call savegame)) |
@@ -1,321 +1,326 b'' | |||
|
1 | 1 | |
|
2 | 2 | (in-package sugar-qsp.lib) |
|
3 | 3 | |
|
4 | 4 | ;;;; Functions and procedures defined by the QSP language. |
|
5 | 5 | ;;;; They can call api and deal with locations and other data directly. |
|
6 | 6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. |
|
7 | 7 | |
|
8 | 8 | ;;; 1loc |
|
9 | 9 | |
|
10 | 10 | (defun goto (target args) |
|
11 | 11 | (api:clear-text :main) |
|
12 | 12 | (funcall xgoto target args) |
|
13 | 13 | (void)) |
|
14 | 14 | |
|
15 | 15 | (defun xgoto (target args) |
|
16 | 16 | (setf args (or args (list))) |
|
17 | 17 | (api:clear-act) |
|
18 | 18 | (setf *current-location (chain target (to-upper-case))) |
|
19 | 19 | (api:stash-state args) |
|
20 | 20 | (api:call-loc *current-location args) |
|
21 | 21 | (api:call-serv-loc "$ONNEWLOC") |
|
22 | 22 | (void)) |
|
23 | 23 | |
|
24 | 24 | ;;; 2var |
|
25 | 25 | |
|
26 | 26 | ;;; 3expr |
|
27 | 27 | |
|
28 | 28 | (defun obj (name) |
|
29 | 29 | (has name *objs)) |
|
30 | 30 | |
|
31 | 31 | (defun loc (name) |
|
32 | 32 | (has name *locs)) |
|
33 | 33 | |
|
34 | 34 | ;;; 4code |
|
35 | 35 | |
|
36 | 36 | (defun rand (a &optional (b 1)) |
|
37 | 37 | (let ((min (min a b)) |
|
38 | 38 | (max (max a b))) |
|
39 | 39 | (+ min (chain *math (random (- max min)))))) |
|
40 | 40 | |
|
41 | 41 | ;;; 5arrays |
|
42 | 42 | |
|
43 | 43 | (defun copyarr (to from start count) |
|
44 | 44 | (multiple-value-bind (to-name to-slot) |
|
45 | 45 | (api:var-real-name to) |
|
46 | 46 | (multiple-value-bind (from-name from-slot) |
|
47 | 47 | (api:var-real-name from) |
|
48 | 48 | (for ((i start)) |
|
49 | 49 | ((< i (min (api:array-size from-name) |
|
50 | 50 | (+ start count)))) |
|
51 | 51 | ((incf i)) |
|
52 | 52 | (api:set-var to-name (+ start i) to-slot |
|
53 | 53 | (api:get-var from-name (+ start i) from-slot)))))) |
|
54 | 54 | |
|
55 | 55 | (defun arrpos (name value &optional (start 0)) |
|
56 | 56 | (multiple-value-bind (real-name slot) |
|
57 | 57 | (api:var-real-name name) |
|
58 | 58 | (for ((i start)) ((< i (api:array-size name))) ((incf i)) |
|
59 | 59 | (when (eq (api:get-var real-name i slot) value) |
|
60 | 60 | (return-from arrpos i)))) |
|
61 | 61 | -1) |
|
62 | 62 | |
|
63 | 63 | (defun arrcomp (name pattern &optional (start 0)) |
|
64 | 64 | (multiple-value-bind (real-name slot) |
|
65 | 65 | (api:var-real-name name) |
|
66 | 66 | (for ((i start)) ((< i (api:array-size name))) ((incf i)) |
|
67 | 67 | (when (funcall (getprop (api:get-var real-name i slot) 'match) pattern) |
|
68 | 68 | (return-from arrcomp i)))) |
|
69 | 69 | -1) |
|
70 | 70 | |
|
71 | 71 | ;;; 6str |
|
72 | 72 | |
|
73 | 73 | (defun instr (s subs &optional (start 1)) |
|
74 | 74 | (+ start (chain s (substring (- start 1)) (search subs)))) |
|
75 | 75 | |
|
76 | 76 | (defun isnum (s) |
|
77 | 77 | (if (is-na-n s) |
|
78 | 78 | 0 |
|
79 | 79 | -1)) |
|
80 | 80 | |
|
81 | 81 | (defun strcomp (s pattern) |
|
82 | 82 | (if (chain s (match pattern)) |
|
83 | 83 | -1 |
|
84 | 84 | 0)) |
|
85 | 85 | |
|
86 | 86 | (defun strfind (s pattern group) |
|
87 | 87 | (let* ((re (new (*reg-exp pattern))) |
|
88 | 88 | (match (chain re (exec s)))) |
|
89 | 89 | (chain match (group group)))) |
|
90 | 90 | |
|
91 | 91 | (defun strpos (s pattern &optional (group 0)) |
|
92 | 92 | (let* ((re (new (*reg-exp pattern))) |
|
93 | 93 | (match (chain re (exec s))) |
|
94 | 94 | (found (chain match (group group)))) |
|
95 | 95 | (if found |
|
96 | 96 | (chain s (search found)) |
|
97 | 97 | 0))) |
|
98 | 98 | |
|
99 | 99 | ;;; 7if |
|
100 | 100 | |
|
101 | 101 | ;; Has to be a function because it always evaluates all three of its |
|
102 | 102 | ;; arguments |
|
103 | 103 | (defun iif (cond-expr then-expr else-expr) |
|
104 | 104 | (if cond-expr then-expr else-expr)) |
|
105 | 105 | |
|
106 | 106 | ;;; 8sub |
|
107 | 107 | |
|
108 | 108 | (defun gosub (target &rest args) |
|
109 | 109 | (api:call-loc target args) |
|
110 | 110 | (void)) |
|
111 | 111 | |
|
112 | 112 | (defun func (target &rest args) |
|
113 | 113 | (api:call-loc target args)) |
|
114 | 114 | |
|
115 | 115 | ;;; 9loops |
|
116 | 116 | |
|
117 | 117 | ;;; 10dynamic |
|
118 | 118 | |
|
119 | 119 | (defun dynamic (block &rest args) |
|
120 | 120 | (when (stringp block) |
|
121 | 121 | (api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC.")) |
|
122 | 122 | (api:with-call-args args |
|
123 | 123 | (funcall block args)) |
|
124 | 124 | (void)) |
|
125 | 125 | |
|
126 | 126 | (defun dyneval (block &rest args) |
|
127 | 127 | (when (stringp block) |
|
128 | 128 | (api:report-error "DYNEVAL can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL.")) |
|
129 | 129 | (api:with-call-args args |
|
130 | 130 | (funcall block args))) |
|
131 | 131 | |
|
132 | 132 | ;;; 11main |
|
133 | 133 | |
|
134 | 134 | (defun main-p (s) |
|
135 | 135 | (api:add-text :main s) |
|
136 | 136 | (void)) |
|
137 | 137 | |
|
138 | 138 | (defun main-pl (s) |
|
139 | 139 | (api:add-text :main s) |
|
140 | 140 | (api:newline :main) |
|
141 | 141 | (void)) |
|
142 | 142 | |
|
143 | 143 | (defun main-nl (s) |
|
144 | 144 | (api:newline :main) |
|
145 | 145 | (api:add-text :main s) |
|
146 | 146 | (void)) |
|
147 | 147 | |
|
148 | 148 | (defun maintxt (s) |
|
149 | 149 | (api:get-text :main) |
|
150 | 150 | (void)) |
|
151 | 151 | |
|
152 | 152 | (defun desc (s) |
|
153 | 153 | "") |
|
154 | 154 | |
|
155 | 155 | (defun main-clear () |
|
156 | 156 | (api:clear-text :main) |
|
157 | 157 | (void)) |
|
158 | 158 | |
|
159 | 159 | ;;; 12stat |
|
160 | 160 | |
|
161 | 161 | (defun stat-p (s) |
|
162 | 162 | (api:add-text :stat s) |
|
163 | 163 | (void)) |
|
164 | 164 | |
|
165 | 165 | (defun stat-pl (s) |
|
166 | 166 | (api:add-text :stat s) |
|
167 | 167 | (api:newline :stat) |
|
168 | 168 | (void)) |
|
169 | 169 | |
|
170 | 170 | (defun stat-nl (s) |
|
171 | 171 | (api:newline :stat) |
|
172 | 172 | (api:add-text :stat s) |
|
173 | 173 | (void)) |
|
174 | 174 | |
|
175 | 175 | (defun stattxt (s) |
|
176 | 176 | (api:get-text :stat) |
|
177 | 177 | (void)) |
|
178 | 178 | |
|
179 | 179 | (defun stat-clear () |
|
180 | 180 | (api:clear-text :stat) |
|
181 | 181 | (void)) |
|
182 | 182 | |
|
183 | 183 | (defun cls () |
|
184 | 184 | (stat-clear) |
|
185 | 185 | (main-clear) |
|
186 | 186 | (cla) |
|
187 | 187 | (cmdclear) |
|
188 | 188 | (void)) |
|
189 | 189 | |
|
190 | 190 | ;;; 13diag |
|
191 | 191 | |
|
192 | 192 | ;;; 14act |
|
193 | 193 | |
|
194 | (defun selact () | |
|
195 | (loop :for (k v) :of *acts | |
|
196 | :do (when (@ v :selected) | |
|
197 | (return-from selact (@ v :name))))) | |
|
198 | ||
|
194 | 199 | (defun curacts () |
|
195 | 200 | (let ((acts (api-call copy-obj *acts))) |
|
196 | 201 | (lambda () |
|
197 | 202 | (setf *acts acts) |
|
198 | 203 | (void)))) |
|
199 | 204 | |
|
200 | 205 | ;;; 15objs |
|
201 | 206 | |
|
202 | 207 | (defun addobj (name img) |
|
203 | 208 | (setf img (or img "")) |
|
204 | 209 | (setf (getprop *objs name) |
|
205 | 210 | (create :name name :img img :selected nil)) |
|
206 | 211 | (api:update-objs) |
|
207 | 212 | (api-call call-serv-loc "$ONOBJADD" name img) |
|
208 | 213 | (void)) |
|
209 | 214 | |
|
210 | 215 | (defun delobj (name) |
|
211 | 216 | (delete (getprop *objs name)) |
|
212 | 217 | (api:update-objs) |
|
213 | 218 | (api-call call-serv-loc "$ONOBJDEL" name) |
|
214 | 219 | (void)) |
|
215 | 220 | |
|
216 | 221 | (defun killobj (&optional (num nil)) |
|
217 | 222 | (if (eq nil num) |
|
218 | 223 | (setf *objs (create)) |
|
219 | 224 | (delobj (elt (chain *object (keys *objs)) num))) |
|
220 | 225 | (api:update-objs) |
|
221 | 226 | (void)) |
|
222 | 227 | |
|
223 | 228 | (defun selobj () |
|
224 | 229 | (loop :for (k v) :of *objs |
|
225 | 230 | :do (when (@ v :selected) |
|
226 | 231 | (return-from selobj (@ v :name))))) |
|
227 | 232 | |
|
228 | 233 | ;;; 16menu |
|
229 | 234 | |
|
230 | 235 | (defun menu (menu-name) |
|
231 | 236 | (let ((menu-data (list))) |
|
232 | 237 | (loop :for item-obj :in (@ (api:get-array (api:var-real-name menu-name)) values) |
|
233 | 238 | :for item := (@ item-obj :str) |
|
234 | 239 | :do (cond ((string= item "") |
|
235 | 240 | (break)) |
|
236 | 241 | ((string= item "-:-") |
|
237 | 242 | (chain menu-data (push :delimiter))) |
|
238 | 243 | (t |
|
239 | 244 | (let* ((tokens (chain item (split ":")))) |
|
240 | 245 | (when (= (length tokens) 2) |
|
241 | 246 | (chain tokens (push ""))) |
|
242 | 247 | (let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":"))) |
|
243 | 248 | (loc (getprop tokens (- (length tokens) 2))) |
|
244 | 249 | (icon (getprop tokens (- (length tokens) 1)))) |
|
245 | 250 | (chain menu-data |
|
246 | 251 | (push (create :text text |
|
247 | 252 | :loc loc |
|
248 | 253 | :icon icon)))))))) |
|
249 | 254 | (api:menu menu-data) |
|
250 | 255 | (void))) |
|
251 | 256 | |
|
252 | 257 | ;;; 17sound |
|
253 | 258 | |
|
254 | 259 | (defun play (filename &optional (volume 100)) |
|
255 | 260 | (let ((audio (new (*audio filename)))) |
|
256 | 261 | (setf (getprop *playing filename) audio) |
|
257 | 262 | (setf (@ audio volume) (* volume 0.01)) |
|
258 | 263 | (chain audio (play)))) |
|
259 | 264 | |
|
260 | 265 | (defun close (filename) |
|
261 | 266 | (funcall (getprop *playing filename) stop) |
|
262 | 267 | (delete (getprop *playing filename)) |
|
263 | 268 | (void)) |
|
264 | 269 | |
|
265 | 270 | (defun closeall () |
|
266 | 271 | (loop :for k :in (chain *object (keys *playing)) |
|
267 | 272 | :for v := (getprop *playing k) |
|
268 | 273 | :do (funcall v stop)) |
|
269 | 274 | (setf *playing (create))) |
|
270 | 275 | |
|
271 | 276 | ;;; 18img |
|
272 | 277 | |
|
273 | 278 | (defun refint () |
|
274 | 279 | ;; "Force interface update" Uh... what exactly do we do here? |
|
275 | 280 | ;(api:report-error "REFINT is not supported") |
|
276 | 281 | ) |
|
277 | 282 | |
|
278 | 283 | ;;; 19input |
|
279 | 284 | |
|
280 | 285 | (defun usertxt () |
|
281 | 286 | (let ((input (by-id "qsp-input"))) |
|
282 | 287 | (@ input value))) |
|
283 | 288 | |
|
284 | 289 | (defun cmdclear () |
|
285 | 290 | (let ((input (by-id "qsp-input"))) |
|
286 | 291 | (setf (@ input value) ""))) |
|
287 | 292 | |
|
288 | 293 | (defun input (text) |
|
289 | 294 | (chain window (prompt text))) |
|
290 | 295 | |
|
291 | 296 | ;;; 20time |
|
292 | 297 | |
|
293 | 298 | (defun msecscount () |
|
294 | 299 | (- (chain *date (now)) *started-at)) |
|
295 | 300 | |
|
296 | 301 | ;;; 21local |
|
297 | 302 | |
|
298 | 303 | ;;; 22for |
|
299 | 304 | |
|
300 | 305 | ;;; misc |
|
301 | 306 | |
|
302 | 307 | (defun rgb (red green blue) |
|
303 | 308 | (+ (<< red 16) |
|
304 | 309 | (<< green 8) |
|
305 | 310 | blue)) |
|
306 | 311 | |
|
307 | 312 | (defun openqst (name) |
|
308 | 313 | (api-call run-game name)) |
|
309 | 314 | |
|
310 | 315 | (defun addqst (name) |
|
311 | 316 | (let ((game (api-call filename-game name))) |
|
312 | 317 | ;; Add the game's locations |
|
313 | 318 | (chain *object (assign *locs |
|
314 | 319 | (getprop *games name))))) |
|
315 | 320 | |
|
316 | 321 | (defun killqst () |
|
317 | 322 | ;; Delete all locations not from the current main game |
|
318 | 323 | (loop :for (k v) :in *games |
|
319 | 324 | :do (unless (string= k *main-game) |
|
320 | 325 | (delete (getprop *locs k))))) |
|
321 | 326 |
@@ -1,55 +1,54 b'' | |||
|
1 | 1 | |
|
2 | 2 | (in-package sugar-qsp.main) |
|
3 | 3 | |
|
4 | 4 | ;;; Game session state (saved in savegames) |
|
5 | 5 | ;; Variables |
|
6 | 6 | (var *globals (create)) |
|
7 | 7 | ;; Inventory (objects) |
|
8 | 8 | (var *objs (create)) |
|
9 | 9 | (var *current-location nil) |
|
10 | (var *current-action nil) | |
|
11 | 10 | ;; Game time |
|
12 | 11 | (var *started-at (chain *date (now))) |
|
13 | 12 | ;; Timers |
|
14 | 13 | (var *timer-interval 500) |
|
15 | 14 | (var *timer-obj nil) |
|
16 | 15 | ;; Games |
|
17 | 16 | (var *loaded-games (list)) |
|
18 | 17 | |
|
19 | 18 | ;;; Transient state |
|
20 | 19 | ;; ACTions |
|
21 | 20 | (var *acts (create)) |
|
22 | 21 | ;; Savegame data |
|
23 | 22 | (var *state-stash (create)) |
|
24 | 23 | ;; List of audio files being played |
|
25 | 24 | (var *playing (create)) |
|
26 | 25 | ;; Local variables stack (starts with an empty frame) |
|
27 | 26 | (var *locals (list)) |
|
28 | 27 | ;; Promise to continue running the game after menu |
|
29 | 28 | (var *menu-resume nil) |
|
30 | 29 | |
|
31 | 30 | ;;; Game data |
|
32 | 31 | ;; Games (filename -> [locations]) |
|
33 | 32 | (var *games (list)) |
|
34 | 33 | ;; The main (non library) game. Updated by openqst |
|
35 | 34 | (var *main-game nil) |
|
36 | 35 | ;; Active locations |
|
37 | 36 | (var *locs (create)) |
|
38 | 37 | |
|
39 | 38 | (setf (@ window onload) |
|
40 | 39 | (lambda () |
|
41 | 40 | (#.(intern "INIT-DOM" "SUGAR-QSP.API")) |
|
42 | 41 | ;; For MSECCOUNT |
|
43 | 42 | (setf *started-at (chain *date (now))) |
|
44 | 43 | ;; For $COUNTER and SETTIMER |
|
45 | 44 | (#.(intern "SET-TIMER" "SUGAR-QSP.API") |
|
46 | 45 | *timer-interval) |
|
47 | 46 | ;; Start the first game |
|
48 | 47 | (#.(intern "RUN-GAME" "SUGAR-QSP.API") |
|
49 | 48 | (chain *object (keys *games) 0)) |
|
50 | 49 | (values))) |
|
51 | 50 | |
|
52 | 51 | ;;; Some very common utilities (for both api and lib) |
|
53 | 52 | |
|
54 | 53 | (defun by-id (id) |
|
55 | 54 | (chain document (get-element-by-id id))) |
@@ -1,108 +1,108 b'' | |||
|
1 | 1 | |
|
2 | 2 | (in-package cl-user) |
|
3 | 3 | |
|
4 | 4 | (defpackage :sugar-qsp.js) |
|
5 | 5 | |
|
6 | 6 | (defpackage :sugar-qsp.main |
|
7 | 7 | (:use :cl :ps :sugar-qsp.js) |
|
8 | 8 | (:export #:api-call #:by-id |
|
9 | 9 | #:has |
|
10 | 10 | |
|
11 |
#:*globals #:*objs #:*current-location |
|
|
11 | #:*globals #:*objs #:*current-location | |
|
12 | 12 | #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games |
|
13 | 13 | |
|
14 | 14 | #:*acts #:*state-stash #:*playing #:*locals |
|
15 | 15 | |
|
16 | 16 | #:*games #:*main-game #:*locs #:*menu-resume |
|
17 | 17 | )) |
|
18 | 18 | |
|
19 | 19 | (defpackage :code-walker |
|
20 | 20 | (:use :cl) |
|
21 | 21 | (:export #:deftransform |
|
22 | 22 | #:deftransform-stop |
|
23 | 23 | #:walk |
|
24 | 24 | #:whole |
|
25 | 25 | #:walk-continue)) |
|
26 | 26 | |
|
27 | 27 | ;;; API functions |
|
28 | 28 | (defpackage :sugar-qsp.api |
|
29 | 29 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) |
|
30 | 30 | (:export #:with-frame #:with-call-args |
|
31 | 31 | #:stash-state |
|
32 | 32 | |
|
33 | 33 | #:report-error #:sleep #:init-dom #:call-serv-loc #:*serv-vars* |
|
34 | 34 | #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id |
|
35 | 35 | #:init-args #:get-result #:call-loc #:call-act |
|
36 | 36 | #:get-frame #:add-text #:get-text #:clear-text #:enable-frame |
|
37 | 37 | #:add-act #:del-act #:clear-act #:update-acts |
|
38 | 38 | #:set-str-element #:set-any-element #:set-serv-var |
|
39 | 39 | #:*var #:new-value #:index-num #:get #:set #:kill |
|
40 | 40 | #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var |
|
41 | 41 | #:get-array #:set-array #:kill-var #:array-size |
|
42 | 42 | #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local |
|
43 | 43 | #:update-objs |
|
44 | 44 | #:menu |
|
45 | 45 | #:clean-audio |
|
46 | 46 | #:show-image |
|
47 | 47 | #:opengame #:savegame |
|
48 | 48 | )) |
|
49 | 49 | |
|
50 | 50 | ;;; QSP library functions and macros |
|
51 | 51 | (defpackage :sugar-qsp.lib |
|
52 | 52 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) |
|
53 | 53 | (:local-nicknames (#:api :sugar-qsp.api) |
|
54 | 54 | (#:walker :code-walker)) |
|
55 | 55 | (:export #:str #:exec #:qspblock #:qspfor #:game #:location |
|
56 | 56 | #:qspcond #:qspvar #:set #:local #:jump |
|
57 | 57 | |
|
58 | 58 | #:killvar #:killall |
|
59 | 59 | #:obj #:loc #:no |
|
60 | 60 | #:qspver #:curloc |
|
61 | 61 | #:rnd #:qspmax #:qspmin |
|
62 | 62 | #:arrsize #:len |
|
63 | 63 | #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr |
|
64 | 64 | #:exit #:desc |
|
65 | 65 | #:showstat #:msg |
|
66 | 66 | #:showacts #:delact #:cla |
|
67 | 67 | #:showobjs #:countobj #:getobj |
|
68 | 68 | #:isplay |
|
69 | 69 | #:view |
|
70 | 70 | #:showinput |
|
71 | 71 | #:wait #:settimer |
|
72 | 72 | #:local |
|
73 | 73 | #:opengame #:savegame |
|
74 | 74 | |
|
75 | 75 | #:goto #:xgoto |
|
76 | 76 | #:rand |
|
77 | 77 | #:copyarr #:arrpos #:arrcomp |
|
78 | 78 | #:instr #:isnum #:strcomp #:strfind #:strpos |
|
79 | 79 | #:iif |
|
80 | 80 | #:gosub #:func |
|
81 | 81 | #:dynamic #:dyneval |
|
82 | 82 | #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear |
|
83 | 83 | #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls |
|
84 | 84 | #:curacts |
|
85 | 85 | #:addobj #:delobj #:killobj |
|
86 | 86 | #:menu |
|
87 | 87 | #:play #:close #:closeall |
|
88 | 88 | #:refint |
|
89 | 89 | #:usertxt #:cmdclear #:input |
|
90 | 90 | #:msecscount |
|
91 | 91 | #:rgb |
|
92 | 92 | #:openqst #:addqst #:killqst |
|
93 | 93 | )) |
|
94 | 94 | |
|
95 | 95 | (setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_") |
|
96 | 96 | (setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_") |
|
97 | 97 | (setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_") |
|
98 | 98 | |
|
99 | 99 | ;;; The compiler |
|
100 | 100 | (defpackage :sugar-qsp |
|
101 | 101 | (:use :cl) |
|
102 | 102 | (:local-nicknames (#:p #:esrap) |
|
103 | 103 | (#:lib :sugar-qsp.lib) |
|
104 | 104 | (#:api :sugar-qsp.api) |
|
105 | 105 | (#:main :sugar-qsp.main) |
|
106 | 106 | (#:walker :code-walker)) |
|
107 | 107 | (:export #:parse-file #:entry-point)) |
|
108 | 108 |
General Comments 0
You need to be logged in to leave comments.
Login now