Show More
@@ -0,0 +1,15 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp.api) | |||
|
3 | ||||
|
4 | (defpsmacro with-call-args (args &body body) | |||
|
5 | `(progn | |||
|
6 | (init-args ,args) | |||
|
7 | ,@body | |||
|
8 | (get-result))) | |||
|
9 | ||||
|
10 | (defpsmacro with-frame (&body body) | |||
|
11 | `(progn | |||
|
12 | (push-local-frame) | |||
|
13 | (unwind-protect | |||
|
14 | ,@body | |||
|
15 | (pop-local-frame)))) |
@@ -0,0 +1,37 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp.js) | |||
|
3 | ||||
|
4 | ;;; Contains symbols from standard JS library to avoid obfuscating | |||
|
5 | ;;; and/or namespacing them | |||
|
6 | ||||
|
7 | (cl:defmacro syms (cl:&rest syms) | |||
|
8 | `(cl:progn | |||
|
9 | ,@(cl:loop :for sym :in syms | |||
|
10 | :collect `(cl:export ',sym)))) | |||
|
11 | ||||
|
12 | (syms | |||
|
13 | ;; main | |||
|
14 | window | |||
|
15 | *object | |||
|
16 | now | |||
|
17 | onload | |||
|
18 | keys includes | |||
|
19 | has-own-property | |||
|
20 | ;; api | |||
|
21 | document get-element-by-id | |||
|
22 | onclick onchange | |||
|
23 | atob btoa | |||
|
24 | alert prompt | |||
|
25 | set-timeout set-interval clear-interval | |||
|
26 | *promise *j-s-o-n | |||
|
27 | href parse | |||
|
28 | set-prototype-of | |||
|
29 | body append-child remove-child | |||
|
30 | create-element set-attribute | |||
|
31 | *file-reader read-as-text | |||
|
32 | style display src | |||
|
33 | ;; lib | |||
|
34 | *number parse-int | |||
|
35 | to-upper-case concat | |||
|
36 | click target current-target files index-of | |||
|
37 | ) |
@@ -0,0 +1,15 b'' | |||||
|
1 | ||||
|
2 | (in-package sugar-qsp.main) | |||
|
3 | ||||
|
4 | ||||
|
5 | (defpsmacro by-id (id) | |||
|
6 | `(chain document (get-element-by-id ,id))) | |||
|
7 | ||||
|
8 | (defmacro+ps api-call (name &rest args) | |||
|
9 | `(,(intern (string-upcase name) "API") ,@args)) | |||
|
10 | ||||
|
11 | (defpsmacro root (&rest path) | |||
|
12 | `(@ data ,@path)) | |||
|
13 | ||||
|
14 | (defpsmacro in (key obj) | |||
|
15 | `(chain ,obj (has-own-property ,key))) |
@@ -1,107 +1,106 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.api) | |
3 |
|
3 | |||
4 | ;;; API deals with DOM manipulation and some bookkeeping for the |
|
4 | ;;; API deals with DOM manipulation and some bookkeeping for the | |
5 | ;;; intrinsics, namely variables |
|
5 | ;;; intrinsics, namely variables | |
6 | ;;; API is an implementation detail and has no QSP documentation. It |
|
6 | ;;; API is an implementation detail and has no QSP documentation. It | |
7 | ;;; doesn't call intrinsics |
|
7 | ;;; doesn't call intrinsics | |
8 |
|
8 | |||
9 | (setf (root api) (ps:create)) |
|
|||
10 |
|
||||
11 | ;;; Utils |
|
9 | ;;; Utils | |
12 |
|
10 | |||
13 |
(def |
|
11 | (defun make-act-html (title img) | |
14 |
(+ "<a class='qsp-act' href=' |
|
12 | (+ "<a class='qsp-act' href='" (ps-inline call-act) "(\"" title "\");'>" | |
15 | title |
|
13 | title | |
16 | "</a>")) |
|
14 | "</a>")) | |
17 |
|
15 | |||
18 |
(def |
|
16 | (defun make-menu-item-html (num title img loc) | |
19 |
(+ "<a href=' |
|
17 | (+ "<a href='" (ps-inline run-menu) "(" num ", \"" loc "\")();'>" | |
20 | "<img src='" img "'>" |
|
18 | "<img src='" img "'>" | |
21 | title |
|
19 | title | |
22 | "</a>")) |
|
20 | "</a>")) | |
23 |
|
21 | |||
24 |
(def |
|
22 | (defun report-error (text) | |
25 | (alert text)) |
|
23 | (alert text)) | |
26 |
|
24 | |||
27 |
(def |
|
25 | (defun sleep (msec) | |
28 |
( |
|
26 | (new (*promise (=> resolve (set-timeout resolve msec))))) | |
29 |
|
27 | |||
30 |
(def |
|
28 | (defun init-dom () | |
31 | ;; Save/load buttons |
|
29 | ;; Save/load buttons | |
32 |
(let ((btn ( |
|
30 | (let ((btn (by-id "qsp-btn-save"))) | |
33 |
(setf ( |
|
31 | (setf (@ btn onclick) savegame) | |
34 |
(setf ( |
|
32 | (setf (@ btn href) "#")) | |
35 |
(let ((btn ( |
|
33 | (let ((btn (by-id "qsp-btn-open"))) | |
36 |
(setf ( |
|
34 | (setf (@ btn onclick) opengame) | |
37 |
(setf ( |
|
35 | (setf (@ btn href) "#")) | |
38 | ;; Close image on click |
|
36 | ;; Close image on click | |
39 |
(setf ( |
|
37 | (setf (@ (by-id "qsp-image-container") onclick) | |
40 |
( |
|
38 | (show-image nil)) | |
41 | ;; Close the dropdown on any click |
|
39 | ;; Close the dropdown on any click | |
42 |
(setf window |
|
40 | (setf (@ window onclick) | |
43 | (lambda (event) |
|
41 | (lambda (event) | |
44 |
(setf ( |
|
42 | (setf (@ (get-frame :dropdown) style display) "none")))) | |
45 |
|
43 | |||
46 |
(def |
|
44 | (defun call-serv-loc (var-name &rest args) | |
47 |
(let ((loc-name ( |
|
45 | (let ((loc-name (get-var var-name 0 :str))) | |
48 | (when loc-name |
|
46 | (when loc-name | |
49 |
(let ((loc ( |
|
47 | (let ((loc (getprop (root locs) loc-name))) | |
50 | (when loc |
|
48 | (when loc | |
51 | (funcall loc args)))))) |
|
49 | (funcall loc args)))))) | |
52 |
|
50 | |||
53 | ;;; Misc |
|
51 | ;;; Misc | |
54 |
|
52 | |||
55 |
(def |
|
53 | (defun newline (key) | |
56 |
( |
|
54 | (append-id (key-to-id key) "<br>" t)) | |
57 |
|
55 | |||
58 |
(def |
|
56 | (defun clear-id (id) | |
59 |
(setf ( |
|
57 | (setf (inner-html (by-id id)) "")) | |
60 |
|
58 | |||
61 |
( |
|
59 | (defvar text-escaper (chain document (create-element :textarea))) | |
62 |
|
60 | |||
63 |
(def |
|
61 | (defun prepare-contents (s &optional force-html) | |
64 | (if (or force-html (var "USEHTML" 0 :num)) |
|
62 | (if (or force-html (get-var "USEHTML" 0 :num)) | |
65 | s |
|
63 | s | |
66 | (progn |
|
64 | (progn | |
67 |
(setf ( |
|
65 | (setf (@ text-escaper text-content) s) | |
68 |
( |
|
66 | (inner-html text-escaper)))) | |
69 |
|
67 | |||
70 |
(def |
|
68 | (defun get-id (id &optional force-html) | |
71 |
( |
|
69 | (inner-html (by-id id))) | |
72 |
|
70 | |||
73 |
(def |
|
71 | (defun set-id (id contents &optional force-html) | |
74 |
(setf ( |
|
72 | (setf (inner-html (by-id id)) (prepare-contents contents force-html))) | |
75 |
|
73 | |||
76 |
(def |
|
74 | (defun append-id (id contents &optional force-html) | |
77 | (when contents |
|
75 | (when contents | |
78 |
(incf ( |
|
76 | (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) | |
79 |
|
77 | |||
80 | ;;; Function calls |
|
78 | ;;; Function calls | |
81 |
|
79 | |||
82 |
(def |
|
80 | (defun init-args (args) | |
83 | (dotimes (i (length args)) |
|
81 | (dotimes (i (length args)) | |
84 | (let ((arg (elt args i))) |
|
82 | (let ((arg (elt args i))) | |
85 | (if (numberp arg) |
|
83 | (if (numberp arg) | |
86 |
( |
|
84 | (set-var args i :num arg) | |
87 |
( |
|
85 | (set-var args i :str arg))))) | |
88 |
|
86 | |||
89 |
(def |
|
87 | (defun get-result () | |
90 | (if (not (equal "" (var result 0 :str))) |
|
88 | (if (not (equal "" (get-var result 0 :str))) | |
91 | (var result 0 :str) |
|
89 | (get-var result 0 :str) | |
92 | (var result 0 :num))) |
|
90 | (get-var result 0 :num))) | |
93 |
|
91 | |||
94 |
(def |
|
92 | (defun call-loc (name args) | |
95 | (with-frame |
|
93 | (with-frame | |
96 | (funcall (ps:getprop (root locs) name) args))) |
|
94 | (with-call-args args | |
|
95 | (funcall (getprop (root locs) name) args)))) | |||
97 |
|
96 | |||
98 |
(def |
|
97 | (defun call-act (title) | |
99 | (with-frame |
|
98 | (with-frame | |
100 |
(funcall ( |
|
99 | (funcall (getprop (root acts) title 'act)))) | |
101 |
|
100 | |||
102 | ;;; Text windows |
|
101 | ;;; Text windows | |
103 |
|
102 | |||
104 |
(def |
|
103 | (defun key-to-id (key) | |
105 | (case key |
|
104 | (case key | |
106 | (:main "qsp-main") |
|
105 | (:main "qsp-main") | |
107 | (:stat "qsp-stat") |
|
106 | (:stat "qsp-stat") | |
@@ -109,288 +108,298 b'' | |||||
109 | (:acts "qsp-acts") |
|
108 | (:acts "qsp-acts") | |
110 | (:input "qsp-input") |
|
109 | (:input "qsp-input") | |
111 | (:dropdown "qsp-dropdown") |
|
110 | (:dropdown "qsp-dropdown") | |
112 |
(t ( |
|
111 | (t (report-error "Internal error!")))) | |
113 |
|
112 | |||
114 |
(def |
|
113 | (defun get-frame (key) | |
115 |
( |
|
114 | (by-id (key-to-id key))) | |
116 |
|
115 | |||
117 |
(def |
|
116 | (defun add-text (key text) | |
118 |
( |
|
117 | (append-id (key-to-id key) text)) | |
119 |
|
118 | |||
120 |
(def |
|
119 | (defun get-text (key) | |
121 |
( |
|
120 | (get-id (key-to-id key))) | |
122 |
|
121 | |||
123 |
(def |
|
122 | (defun clear-text (key) | |
124 |
( |
|
123 | (clear-id (key-to-id key))) | |
125 |
|
124 | |||
126 |
(def |
|
125 | (defun enable-frame (key enable) | |
127 |
(let ((obj ( |
|
126 | (let ((obj (get-frame key))) | |
128 |
(setf |
|
127 | (setf (@ obj style display) (if enable "block" "none")) | |
129 | (values))) |
|
128 | (values))) | |
130 |
|
129 | |||
131 | ;;; Actions |
|
130 | ;;; Actions | |
132 |
|
131 | |||
133 |
(def |
|
132 | (defun add-act (title img act) | |
134 |
(setf ( |
|
133 | (setf (getprop (root acts) title) | |
135 |
( |
|
134 | (create img img act act)) | |
136 |
( |
|
135 | (update-acts)) | |
137 |
|
136 | |||
138 |
(def |
|
137 | (defun del-act (title) | |
139 |
(delete ( |
|
138 | (delete (getprop (root acts) title)) | |
140 |
( |
|
139 | (update-acts)) | |
141 |
|
140 | |||
142 |
(def |
|
141 | (defun clear-act () | |
143 |
(setf (root acts) ( |
|
142 | (setf (root acts) (create)) | |
144 |
( |
|
143 | (clear-id "qsp-acts")) | |
145 |
|
144 | |||
146 |
(def |
|
145 | (defun update-acts () | |
147 |
( |
|
146 | (clear-id "qsp-acts") | |
148 |
(let ((elt ( |
|
147 | (let ((elt (by-id "qsp-acts"))) | |
149 |
( |
|
148 | (for-in (title (root acts)) | |
150 |
(let ((obj ( |
|
149 | (let ((obj (getprop (root acts) title))) | |
151 |
(incf ( |
|
150 | (incf (inner-html elt) (make-act-html title (getprop obj :img))))))) | |
152 |
|
151 | |||
153 |
|
152 | |||
154 | ;;; "Syntax" |
|
153 | ;;; "Syntax" | |
155 |
|
154 | |||
156 |
(def |
|
155 | (defun qspfor (name index from to step body) | |
157 | (block nil |
|
156 | (for ((i from)) | |
158 | (ps:for ((i from)) |
|
157 | ((< i to)) | |
159 |
|
|
158 | ((incf i step)) | |
160 | ((incf i step)) |
|
159 | (set-var name index :num i) | |
161 | (this.set-var name index :num i) |
|
160 | (unless (funcall body) | |
162 | (unless (funcall body) |
|
161 | (return-from qspfor)))) | |
163 | (return))))) |
|
|||
164 |
|
162 | |||
165 | ;;; Variable class |
|
163 | ;;; Variable class | |
166 |
|
164 | |||
167 |
(def |
|
165 | (defun *var (name) | |
168 | ;; From strings to numbers |
|
166 | ;; From strings to numbers | |
169 |
(setf |
|
167 | (setf (@ this indexes) (create)) | |
170 | ;; From numbers to {num: 0, str: ""} objects |
|
168 | ;; From numbers to {num: 0, str: ""} objects | |
171 |
(setf |
|
169 | (setf (@ this values) (list)) | |
172 | (values)) |
|
170 | (values)) | |
173 |
|
171 | |||
174 | (defm (root api *var prototype new-value) () |
|
172 | (defun new-value () | |
175 |
( |
|
173 | (create :num 0 :str "")) | |
176 |
|
174 | |||
177 |
( |
|
175 | (setf (@ *var prototype index-num) | |
178 | (let ((num-index |
|
176 | (lambda (index) | |
179 |
|
|
177 | (let ((num-index | |
180 |
(if ( |
|
178 | (if (stringp index) | |
181 |
( |
|
179 | (if (in index (@ this indexes)) | |
182 |
( |
|
180 | (getprop (@ this indexes) index) | |
183 | (setf (ps:getprop this.indexes index) n) |
|
181 | (let ((n (length (@ this values)))) | |
184 | n)) |
|
182 | (setf (getprop (@ this indexes) index) n) | |
185 |
|
|
183 | n)) | |
186 | (unless (in num-index this.values) |
|
184 | index))) | |
187 |
( |
|
185 | (unless (in num-index (@ this values)) | |
188 | num-index)) |
|
186 | (setf (elt (@ this values) num-index) (new-value))) | |
|
187 | num-index))) | |||
189 |
|
188 | |||
190 |
( |
|
189 | (setf (@ *var prototype get) | |
191 | (unless (or index (= 0 index)) |
|
190 | (lambda (index slot) | |
192 | (setf index (1- (length this.values)))) |
|
191 | (unless (or index (= 0 index)) | |
193 | (ps:getprop this.values (this.index-num index) slot)) |
|
192 | (setf index (1- (length (@ this values))))) | |
|
193 | (getprop (@ this values) (chain this (index-num index)) slot))) | |||
194 |
|
194 | |||
195 |
( |
|
195 | (setf (@ *var prototype set) | |
196 | (unless (or index (= 0 index)) |
|
196 | (lambda (index slot value) | |
197 | (setf index (length store))) |
|
197 | (unless (or index (= 0 index)) | |
198 | (case slot |
|
198 | (setf index (length (@ this values)))) | |
199 | (:num (setf value (ps:chain *number (parse-int value)))) |
|
199 | (case slot | |
200 |
(: |
|
200 | (:num (setf value (chain *number (parse-int value)))) | |
201 | (setf (ps:getprop this.values (this.index-num index) slot) value) |
|
201 | (:str (setf value (chain value (to-string))))) | |
202 | (values)) |
|
202 | (setf (getprop (@ this values) | |
|
203 | (chain this (index-num index)) | |||
|
204 | slot) value) | |||
|
205 | (values))) | |||
203 |
|
206 | |||
204 |
( |
|
207 | (setf (@ *var prototype kill) | |
205 | (setf (elt this.values (this.index-num index)) (this.new-value))) |
|
208 | (lambda (index) | |
|
209 | (setf (elt (@ this values) (chain this (index-num index))) | |||
|
210 | (new-value)) | |||
|
211 | (delete (getprop 'this 'indexes index)))) | |||
206 |
|
212 | |||
207 | ;;; Variables |
|
213 | ;;; Variables | |
208 |
|
214 | |||
209 |
(def |
|
215 | (defun var-real-name (name) | |
210 |
(if (= ( |
|
216 | (if (= (@ name 0) #\$) | |
211 |
(values ( |
|
217 | (values (chain name (substr 1)) :str) | |
212 | (values name :num))) |
|
218 | (values name :num))) | |
213 |
|
219 | |||
214 |
(def |
|
220 | (defun ensure-var (name) | |
215 |
(let ((store ( |
|
221 | (let ((store (var-ref name))) | |
216 | (unless store |
|
222 | (unless store | |
217 |
(setf store ( |
|
223 | (setf store (new (-var name))) | |
218 |
(setf ( |
|
224 | (setf (getprop (root vars) name) store)) | |
219 | store)) |
|
225 | store)) | |
220 |
|
226 | |||
221 |
(def |
|
227 | (defun var-ref (name) | |
222 |
(let ((local-store ( |
|
228 | (let ((local-store (current-local-frame))) | |
223 | (cond ((and local-store (in name local-store)) |
|
229 | (cond ((and local-store (in name local-store)) | |
224 |
( |
|
230 | (getprop local-store name)) | |
225 | ((in name (root vars)) |
|
231 | ((in name (root vars)) | |
226 |
( |
|
232 | (getprop (root vars) name)) | |
227 | (t nil)))) |
|
233 | (t nil)))) | |
228 |
|
234 | |||
229 |
(def |
|
235 | (defun get-var (name index slot) | |
230 |
( |
|
236 | (chain (ensure-var name) (get index slot))) | |
231 |
|
237 | |||
232 |
(def |
|
238 | (defun set-var (name index slot value) | |
233 |
( |
|
239 | (chain (ensure-var name) (set index slot value)) | |
234 | (values)) |
|
240 | (values)) | |
235 |
|
241 | |||
236 |
(def |
|
242 | (defun get-array (name) | |
237 |
( |
|
243 | (var-ref name)) | |
238 |
|
244 | |||
239 |
(def |
|
245 | (defun set-array (name value) | |
240 |
(let ((store ( |
|
246 | (let ((store (var-ref name))) | |
241 |
(setf ( |
|
247 | (setf (@ store values) (@ value values)) | |
242 |
(setf ( |
|
248 | (setf (@ store indexes) (@ value indexes))) | |
243 | (values)) |
|
249 | (values)) | |
244 |
|
250 | |||
245 |
(def |
|
251 | (defun kill-var (name &optional index) | |
246 | (if (and index (not (= 0 index))) |
|
252 | (if (and index (not (= 0 index))) | |
247 |
( |
|
253 | (chain (getprop (root vars) name) (kill index)) | |
248 |
( |
|
254 | (delete (getprop (root vars) name))) | |
249 | (values)) |
|
255 | (values)) | |
250 |
|
256 | |||
251 |
(def |
|
257 | (defun array-size (name) | |
252 |
( |
|
258 | (getprop (var-ref name) 'length)) | |
253 |
|
259 | |||
254 | ;;; Locals |
|
260 | ;;; Locals | |
255 |
|
261 | |||
256 |
(def |
|
262 | (defun push-local-frame () | |
257 |
( |
|
263 | (chain (root locals) (push (create))) | |
258 | (values)) |
|
264 | (values)) | |
259 |
|
265 | |||
260 |
(def |
|
266 | (defun pop-local-frame () | |
261 |
( |
|
267 | (chain (root locals) (pop)) | |
262 | (values)) |
|
268 | (values)) | |
263 |
|
269 | |||
264 |
(def |
|
270 | (defun current-local-frame () | |
265 | (elt (root locals) (1- (length (root locals))))) |
|
271 | (elt (root locals) (1- (length (root locals))))) | |
266 |
|
272 | |||
267 |
(def |
|
273 | (defun new-local (name) | |
268 |
(let ((frame ( |
|
274 | (let ((frame (current-local-frame))) | |
269 | (unless (in name frame) |
|
275 | (unless (in name frame) | |
270 |
(setf ( |
|
276 | (setf (getprop frame name) (create))) | |
271 | (values))) |
|
277 | (values))) | |
272 |
|
278 | |||
273 | ;;; Objects |
|
279 | ;;; Objects | |
274 |
|
280 | |||
275 |
(def |
|
281 | (defun update-objs () | |
276 |
(let ((elt ( |
|
282 | (let ((elt (by-id "qsp-objs"))) | |
277 |
(setf ( |
|
283 | (setf (inner-html elt) "<ul>") | |
278 | (loop :for obj :in (root objs) |
|
284 | (loop :for obj :in (root objs) | |
279 |
:do (incf ( |
|
285 | :do (incf (inner-html elt) (+ "<li>" obj))) | |
280 |
(incf ( |
|
286 | (incf (inner-html elt) "</ul>"))) | |
281 |
|
287 | |||
282 | ;;; Menu |
|
288 | ;;; Menu | |
283 |
|
289 | |||
284 |
(def |
|
290 | (defun menu (menu-data) | |
285 |
(let ((elt ( |
|
291 | (let ((elt (by-id "qsp-dropdown")) | |
286 | (i 0)) |
|
292 | (i 0)) | |
287 |
(setf ( |
|
293 | (setf (inner-html elt) "") | |
288 | (loop :for item :in menu-data |
|
294 | (loop :for item :in menu-data | |
289 | :do (incf i) |
|
295 | :do (incf i) | |
290 |
:do (incf ( |
|
296 | :do (incf (inner-html elt) (make-menu-item-html i | |
291 | (setf elt.style.display "block"))) |
|
297 | (@ item text) | |
|
298 | (@ item icon) | |||
|
299 | (@ item loc)))) | |||
|
300 | (setf (@ elt style display) "block"))) | |||
292 |
|
301 | |||
293 | ;;; Content |
|
302 | ;;; Content | |
294 |
|
303 | |||
295 |
(def |
|
304 | (defun clean-audio () | |
296 |
(loop :for k :in (*object |
|
305 | (loop :for k :in (chain *object (keys (root playing))) | |
297 |
:for v := ( |
|
306 | :for v := (getprop (root playing) k) | |
298 |
:do (when ( |
|
307 | :do (when (@ v ended) | |
299 |
( |
|
308 | (delete (@ (root playing) k))))) | |
300 |
|
309 | |||
301 |
(def |
|
310 | (defun show-image (path) | |
302 |
(let ((img ( |
|
311 | (let ((img (by-id "qsp-image"))) | |
303 | (cond (path |
|
312 | (cond (path | |
304 |
(setf |
|
313 | (setf (@ img src) path) | |
305 |
(setf |
|
314 | (setf (@ img style display) "flex")) | |
306 | (t |
|
315 | (t | |
307 |
(setf |
|
316 | (setf (@ img src) "") | |
308 |
(setf |
|
317 | (setf (@ img style display) "hidden"))))) | |
309 |
|
318 | |||
310 | ;;; Saves |
|
319 | ;;; Saves | |
311 |
|
320 | |||
312 |
(def |
|
321 | (defun opengame () | |
313 |
(let ((element (document |
|
322 | (let ((element (chain document (create-element :input)))) | |
314 |
(element |
|
323 | (chain element (set-attribute :type :file)) | |
315 |
(element |
|
324 | (chain element (set-attribute :id :qsp-opengame)) | |
316 |
(element |
|
325 | (chain element (set-attribute :tabindex -1)) | |
317 |
(element |
|
326 | (chain element (set-attribute "aria-hidden" t)) | |
318 |
(setf element |
|
327 | (setf (@ element style display) :block) | |
319 |
(setf element |
|
328 | (setf (@ element style visibility) :hidden) | |
320 |
(setf element |
|
329 | (setf (@ element style position) :fixed) | |
321 |
(setf element |
|
330 | (setf (@ element onchange) | |
322 | (lambda (event) |
|
331 | (lambda (event) | |
323 |
(let* ((file ( |
|
332 | (let* ((file (@ event target files 0)) | |
324 |
(reader ( |
|
333 | (reader (new (*file-reader)))) | |
325 |
(setf reader |
|
334 | (setf (@ reader onload) | |
326 | (lambda (ev) |
|
335 | (lambda (ev) | |
327 | (block nil |
|
336 | (block nil | |
328 |
|
|
337 | (let ((target (@ ev current-target))) | |
329 |
|
|
338 | (unless (@ target result) | |
330 |
|
|
339 | (return)) | |
331 |
|
|
340 | (base64-to-state (@ target result)) | |
332 |
|
|
341 | (unstash-state))))) | |
333 |
(reader |
|
342 | (chain reader (read-as-text file))))) | |
334 |
(document |
|
343 | (chain document body (append-child element)) | |
335 |
(element |
|
344 | (chain element (click)) | |
336 |
(document |
|
345 | (chain document body (remove-child element)))) | |
337 |
|
346 | |||
338 |
(def |
|
347 | (defun savegame () | |
339 |
(let ((element (document |
|
348 | (let ((element (chain document (create-element :a)))) | |
340 |
(element |
|
349 | (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64)))) | |
341 |
(element |
|
350 | (chain element (set-attribute :download "savegame.sav")) | |
342 |
(setf element |
|
351 | (setf (@ element style display) :none) | |
343 |
(document |
|
352 | (chain document body (append-child element)) | |
344 |
(element |
|
353 | (chain element (click)) | |
345 |
(document |
|
354 | (chain document body (remove-child element)))) | |
346 |
|
355 | |||
347 |
(def |
|
356 | (defun stash-state (args) | |
348 |
( |
|
357 | (call-serv-loc "ONGSAVE") | |
349 | (setf (root state-stash) |
|
358 | (setf (root state-stash) | |
350 |
(*j-s-o-n |
|
359 | (chain *j-s-o-n (stringify | |
351 |
( |
|
360 | (create vars (root vars) | |
352 | objs (root objs) |
|
361 | objs (root objs) | |
353 | loc-args args |
|
362 | loc-args args | |
354 |
msecs (- ( |
|
363 | msecs (- (chain *date (now)) (root started-at)) | |
355 |
main-html ( |
|
364 | main-html (inner-html | |
356 |
( |
|
365 | (by-id :qsp-main)) | |
357 |
stat-html ( |
|
366 | stat-html (inner-html | |
358 |
( |
|
367 | (by-id :qsp-stat)) | |
359 | next-location (root current-location)))) |
|
368 | next-location (root current-location))))) | |
360 | (values)) |
|
369 | (values)) | |
361 |
|
370 | |||
362 |
(def |
|
371 | (defun unstash-state () | |
363 |
(let ((data (*j-s-o-n |
|
372 | (let ((data (chain *j-s-o-n (parse (root state-stash))))) | |
364 |
( |
|
373 | (clear-act) | |
365 |
(setf (root vars) ( |
|
374 | (setf (root vars) (@ data vars)) | |
366 |
(loop :for k :in (*object |
|
375 | (loop :for k :in (chain *object (keys (root vars))) | |
367 |
:do (*object |
|
376 | :do (chain *object (set-prototype-of (getprop (root vars) k) | |
368 |
( |
|
377 | (@ *var prototype)))) | |
369 |
(setf (root started-at) (- ( |
|
378 | (setf (root started-at) (- (chain *date (now)) (@ data msecs))) | |
370 |
(setf (root objs) ( |
|
379 | (setf (root objs) (@ data objs)) | |
371 |
(setf (root current-location) ( |
|
380 | (setf (root current-location) (@ data next-location)) | |
372 |
(setf ( |
|
381 | (setf (inner-html (by-id :qsp-main)) | |
373 |
( |
|
382 | (@ data main-html)) | |
374 |
(setf ( |
|
383 | (setf (inner-html (by-id :qsp-stat)) | |
375 |
( |
|
384 | (@ data stat-html)) | |
376 |
( |
|
385 | (update-objs) | |
377 |
( |
|
386 | (call-serv-loc "ONGLOAD") | |
378 |
( |
|
387 | (call-loc (root current-location) (@ data loc-args)) | |
379 | (values))) |
|
388 | (values))) | |
380 |
|
389 | |||
381 |
(def |
|
390 | (defun state-to-base64 () | |
382 | (btoa (encode-u-r-i-component (root state-stash)))) |
|
391 | (btoa (encode-u-r-i-component (root state-stash)))) | |
383 |
|
392 | |||
384 |
(def |
|
393 | (defun base64-to-state (data) | |
385 | (setf (root state-stash) (decode-u-r-i-component (atob data)))) |
|
394 | (setf (root state-stash) (decode-u-r-i-component (atob data)))) | |
386 |
|
395 | |||
387 | ;;; Timers |
|
396 | ;;; Timers | |
388 |
|
397 | |||
389 |
(def |
|
398 | (defun set-timer (interval) | |
390 | (setf (root timer-interval) interval) |
|
399 | (setf (root timer-interval) interval) | |
391 | (clear-interval (root timer-obj)) |
|
400 | (clear-interval (root timer-obj)) | |
392 | (setf (root timer-obj) |
|
401 | (setf (root timer-obj) | |
393 | (set-interval |
|
402 | (set-interval | |
394 | (lambda () |
|
403 | (lambda () | |
395 |
( |
|
404 | (call-serv-loc "COUNTER")) | |
396 | interval))) |
|
405 | interval))) |
@@ -8,21 +8,25 b'' | |||||
8 | (asdf:system-source-directory :sugar-qsp))) |
|
8 | (asdf:system-source-directory :sugar-qsp))) | |
9 | (defun read-code-from-string (string) |
|
9 | (defun read-code-from-string (string) | |
10 | (with-input-from-string (in string) |
|
10 | (with-input-from-string (in string) | |
11 | `(progn |
|
11 | (let ((*package* *package*)) | |
12 | ,@(loop :for form := (read in nil :eof) |
|
12 | `(progn | |
13 | :until (eq form :eof) |
|
13 | ,@(loop :for form := (read in nil :eof) | |
14 |
|
|
14 | :until (eq form :eof) | |
|
15 | :when (eq (first form) 'cl:in-package) | |||
|
16 | :do (setf *package* (find-package (second form))) | |||
|
17 | :else | |||
|
18 | :collect form))))) | |||
15 | (defun load-src (filename) |
|
19 | (defun load-src (filename) | |
16 | (alexandria:read-file-into-string (src-file filename)))) |
|
20 | (alexandria:read-file-into-string (src-file filename)))) | |
17 |
|
21 | |||
18 | (defclass compiler () |
|
22 | (defclass compiler () | |
19 | ((body :accessor body :initform #.(load-src "extras/body.html")) |
|
23 | ((body :accessor body :initform #.(load-src "extras/body.html")) | |
20 | (css :accessor css :initform (list #.(load-src "extras/default.css"))) |
|
24 | (css :accessor css :initform (list #.(load-src "extras/default.css"))) | |
21 |
(js :accessor js :initform |
|
25 | (js :accessor js :initform (reverse | |
22 |
|
|
26 | (list | |
23 |
|
|
27 | '#.(read-code-from-string (load-src "src/main.ps")) | |
24 |
|
|
28 | '#.(read-code-from-string (load-src "src/api.ps")) | |
25 |
|
|
29 | '#.(read-code-from-string (load-src "src/intrinsics.ps"))))) | |
26 | (compile :accessor compile-only :initarg :compile) |
|
30 | (compile :accessor compile-only :initarg :compile) | |
27 | (target :accessor target :initarg :target) |
|
31 | (target :accessor target :initarg :target) | |
28 | (beautify :accessor beautify :initarg :beautify))) |
|
32 | (beautify :accessor beautify :initarg :beautify))) |
@@ -1,5 +1,5 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.lib) | |
3 |
|
3 | |||
4 | ;;;; Macros implementing some intrinsics where it makes sense |
|
4 | ;;;; Macros implementing some intrinsics where it makes sense | |
5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call |
|
5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call | |
@@ -8,74 +8,74 b'' | |||||
8 |
|
8 | |||
9 | ;;; 2var |
|
9 | ;;; 2var | |
10 |
|
10 | |||
11 |
( |
|
11 | (defpsmacro killvar (varname &optional index) | |
12 |
`( |
|
12 | `(kill-var ,varname ,index)) | |
13 |
|
13 | |||
14 |
( |
|
14 | (defpsmacro killall () | |
15 | `(api-call kill-all)) |
|
15 | `(api-call kill-all)) | |
16 |
|
16 | |||
17 | ;;; 3expr |
|
17 | ;;; 3expr | |
18 |
|
18 | |||
19 |
( |
|
19 | (defpsmacro obj (name) | |
20 | `(funcall (root objs includes) ,name)) |
|
20 | `(funcall (root objs includes) ,name)) | |
21 |
|
21 | |||
22 |
( |
|
22 | (defpsmacro loc (name) | |
23 | `(funcall (root locs includes) ,name)) |
|
23 | `(funcall (root locs includes) ,name)) | |
24 |
|
24 | |||
25 |
( |
|
25 | (defpsmacro no (arg) | |
26 | `(- -1 ,arg)) |
|
26 | `(- -1 ,arg)) | |
27 |
|
27 | |||
28 | ;;; 4code |
|
28 | ;;; 4code | |
29 |
|
29 | |||
30 |
( |
|
30 | (defpsmacro qspver () | |
31 | "0.0.1") |
|
31 | "0.0.1") | |
32 |
|
32 | |||
33 |
( |
|
33 | (defpsmacro curloc () | |
34 | `(root current-location)) |
|
34 | `(root current-location)) | |
35 |
|
35 | |||
36 |
( |
|
36 | (defpsmacro rnd () | |
37 |
`(funcall |
|
37 | `(funcall rand 1 1000)) | |
38 |
|
38 | |||
39 |
( |
|
39 | (defpsmacro qspmax (&rest args) | |
40 | (if (= 1 (length args)) |
|
40 | (if (= 1 (length args)) | |
41 | `(*math.max.apply nil ,@args) |
|
41 | `(*math.max.apply nil ,@args) | |
42 | `(*math.max ,@args))) |
|
42 | `(*math.max ,@args))) | |
43 |
|
43 | |||
44 |
( |
|
44 | (defpsmacro qspmin (&rest args) | |
45 | (if (= 1 (length args)) |
|
45 | (if (= 1 (length args)) | |
46 | `(*math.min.apply nil ,@args) |
|
46 | `(*math.min.apply nil ,@args) | |
47 | `(*math.min ,@args))) |
|
47 | `(*math.min ,@args))) | |
48 |
|
48 | |||
49 | ;;; 5arrays |
|
49 | ;;; 5arrays | |
50 |
|
50 | |||
51 |
( |
|
51 | (defpsmacro arrsize (name) | |
52 | `(api-call array-size ,name)) |
|
52 | `(api-call array-size ,name)) | |
53 |
|
53 | |||
54 | ;;; 6str |
|
54 | ;;; 6str | |
55 |
|
55 | |||
56 |
( |
|
56 | (defpsmacro len (s) | |
57 | `(length ,s)) |
|
57 | `(length ,s)) | |
58 |
|
58 | |||
59 |
( |
|
59 | (defpsmacro mid (s from &optional count) | |
60 |
`( |
|
60 | `(chain ,s (substring ,from ,count))) | |
61 |
|
61 | |||
62 |
( |
|
62 | (defpsmacro ucase (s) | |
63 |
`( |
|
63 | `(chain ,s (to-upper-case))) | |
64 |
|
64 | |||
65 |
( |
|
65 | (defpsmacro lcase (s) | |
66 |
`( |
|
66 | `(chain ,s (to-lower-case))) | |
67 |
|
67 | |||
68 |
( |
|
68 | (defpsmacro trim (s) | |
69 |
`( |
|
69 | `(chain ,s (trim))) | |
70 |
|
70 | |||
71 |
( |
|
71 | (defpsmacro replace (s from to) | |
72 |
`( |
|
72 | `(chain ,s (replace ,from ,to))) | |
73 |
|
73 | |||
74 |
( |
|
74 | (defpsmacro val (s) | |
75 | `(parse-int ,s 10)) |
|
75 | `(parse-int ,s 10)) | |
76 |
|
76 | |||
77 |
( |
|
77 | (defpsmacro qspstr (n) | |
78 |
`( |
|
78 | `(chain ,n (to-string))) | |
79 |
|
79 | |||
80 | ;;; 7if |
|
80 | ;;; 7if | |
81 |
|
81 | |||
@@ -85,77 +85,77 b'' | |||||
85 |
|
85 | |||
86 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) |
|
86 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) | |
87 |
|
87 | |||
88 |
( |
|
88 | (defpsmacro exit () | |
89 | `(return-from nil (values))) |
|
89 | `(return-from nil (values))) | |
90 |
|
90 | |||
91 | ;;; 10dynamic |
|
91 | ;;; 10dynamic | |
92 |
|
92 | |||
93 | ;;; 11main |
|
93 | ;;; 11main | |
94 |
|
94 | |||
95 |
( |
|
95 | (defpsmacro desc (s) | |
96 | (declare (ignore s)) |
|
96 | (declare (ignore s)) | |
97 | "") |
|
97 | "") | |
98 |
|
98 | |||
99 | ;;; 12stat |
|
99 | ;;; 12stat | |
100 |
|
100 | |||
101 |
( |
|
101 | (defpsmacro showstat (enable) | |
102 | `(api-call enable-frame :stat ,enable)) |
|
102 | `(api-call enable-frame :stat ,enable)) | |
103 |
|
103 | |||
104 | ;;; 13diag |
|
104 | ;;; 13diag | |
105 |
|
105 | |||
106 |
( |
|
106 | (defpsmacro msg (text) | |
107 | `(alert ,text)) |
|
107 | `(alert ,text)) | |
108 |
|
108 | |||
109 | ;;; 14act |
|
109 | ;;; 14act | |
110 |
|
110 | |||
111 |
( |
|
111 | (defpsmacro showacts (enable) | |
112 | `(api-call enable-frame :acts ,enable)) |
|
112 | `(api-call enable-frame :acts ,enable)) | |
113 |
|
113 | |||
114 |
( |
|
114 | (defpsmacro delact (name) | |
115 | `(api-call del-act ,name)) |
|
115 | `(api-call del-act ,name)) | |
116 |
|
116 | |||
117 |
( |
|
117 | (defpsmacro cla () | |
118 | `(api-call clear-act)) |
|
118 | `(api-call clear-act)) | |
119 |
|
119 | |||
120 | ;;; 15objs |
|
120 | ;;; 15objs | |
121 |
|
121 | |||
122 |
( |
|
122 | (defpsmacro showobjs (enable) | |
123 | `(api-call enable-frame :objs ,enable)) |
|
123 | `(api-call enable-frame :objs ,enable)) | |
124 |
|
124 | |||
125 |
( |
|
125 | (defpsmacro countobj () | |
126 | `(length (root objs))) |
|
126 | `(length (root objs))) | |
127 |
|
127 | |||
128 |
( |
|
128 | (defpsmacro getobj (index) | |
129 | `(or (elt (root objs) ,index) "")) |
|
129 | `(or (elt (root objs) ,index) "")) | |
130 |
|
130 | |||
131 | ;;; 16menu |
|
131 | ;;; 16menu | |
132 |
|
132 | |||
133 | ;;; 17sound |
|
133 | ;;; 17sound | |
134 |
|
134 | |||
135 |
( |
|
135 | (defpsmacro isplay (filename) | |
136 | `(funcall (root playing includes) ,filename)) |
|
136 | `(funcall (root playing includes) ,filename)) | |
137 |
|
137 | |||
138 | ;;; 18img |
|
138 | ;;; 18img | |
139 |
|
139 | |||
140 |
( |
|
140 | (defpsmacro view (&optional path) | |
141 | `(api-call show-image ,path)) |
|
141 | `(api-call show-image ,path)) | |
142 |
|
142 | |||
143 | ;;; 19input |
|
143 | ;;; 19input | |
144 |
|
144 | |||
145 |
( |
|
145 | (defpsmacro showinput (enable) | |
146 | `(api-call enable-frame :input ,enable)) |
|
146 | `(api-call enable-frame :input ,enable)) | |
147 |
|
147 | |||
148 | ;;; 20time |
|
148 | ;;; 20time | |
149 |
|
149 | |||
150 |
( |
|
150 | (defpsmacro wait (msec) | |
151 | `(await (api-call sleep ,msec))) |
|
151 | `(await (api-call sleep ,msec))) | |
152 |
|
152 | |||
153 |
( |
|
153 | (defpsmacro settimer (interval) | |
154 | `(api-call set-timer ,interval)) |
|
154 | `(api-call set-timer ,interval)) | |
155 |
|
155 | |||
156 | ;;; 21local |
|
156 | ;;; 21local | |
157 |
|
157 | |||
158 |
( |
|
158 | (defpsmacro local (var &optional expr) | |
159 | `(progn |
|
159 | `(progn | |
160 | (api-call new-local ,(string (second var))) |
|
160 | (api-call new-local ,(string (second var))) | |
161 | ,@(when expr |
|
161 | ,@(when expr | |
@@ -165,10 +165,10 b'' | |||||
165 |
|
165 | |||
166 | ;;; misc |
|
166 | ;;; misc | |
167 |
|
167 | |||
168 |
( |
|
168 | (defpsmacro opengame (&optional filename) | |
169 | (declare (ignore filename)) |
|
169 | (declare (ignore filename)) | |
170 | `(api-call opengame)) |
|
170 | `(api-call opengame)) | |
171 |
|
171 | |||
172 |
( |
|
172 | (defpsmacro savegame (&optional filename) | |
173 | (declare (ignore filename)) |
|
173 | (declare (ignore filename)) | |
174 | `(api-call savegame)) |
|
174 | `(api-call savegame)) |
@@ -1,24 +1,22 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.lib) | |
3 |
|
3 | |||
4 | ;;;; Functions and procedures defined by the QSP language. |
|
4 | ;;;; Functions and procedures defined by the QSP language. | |
5 | ;;;; They can call api and deal with locations and other data directly. |
|
5 | ;;;; They can call api and deal with locations and other data directly. | |
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. |
|
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. | |
7 |
|
7 | |||
8 | (setf (root lib) (ps:create)) |
|
|||
9 |
|
||||
10 | ;;; 1loc |
|
8 | ;;; 1loc | |
11 |
|
9 | |||
12 |
(def |
|
10 | (defun goto (target args) | |
13 |
(api |
|
11 | (api:clear-text :main) | |
14 |
(funcall |
|
12 | (funcall xgoto target (or args (list))) | |
15 | (values)) |
|
13 | (values)) | |
16 |
|
14 | |||
17 |
(def |
|
15 | (defun xgoto (target args) | |
18 |
(api |
|
16 | (api:clear-act) | |
19 |
(setf (root current-location) ( |
|
17 | (setf (root current-location) (chain target (to-upper-case))) | |
20 |
(api |
|
18 | (api:stash-state args) | |
21 |
(funcall ( |
|
19 | (funcall (getprop (root locs) (root current-location)) | |
22 | (or args (list))) |
|
20 | (or args (list))) | |
23 | (values)) |
|
21 | (values)) | |
24 |
|
22 | |||
@@ -28,164 +26,166 b'' | |||||
28 |
|
26 | |||
29 | ;;; 4code |
|
27 | ;;; 4code | |
30 |
|
28 | |||
31 |
(def |
|
29 | (defun rand (a &optional (b 1)) | |
32 | (let ((min (min a b)) |
|
30 | (let ((min (min a b)) | |
33 | (max (max a b))) |
|
31 | (max (max a b))) | |
34 |
(+ min ( |
|
32 | (+ min (chain *math (random (- max min)))))) | |
35 |
|
33 | |||
36 | ;;; 5arrays |
|
34 | ;;; 5arrays | |
37 |
|
35 | |||
38 |
(def |
|
36 | (defun copyarr (to from start count) | |
39 | (multiple-value-bind (to-name to-slot) |
|
37 | (multiple-value-bind (to-name to-slot) | |
40 |
(api |
|
38 | (api:var-real-name to) | |
41 | (multiple-value-bind (from-name from-slot) |
|
39 | (multiple-value-bind (from-name from-slot) | |
42 |
(api |
|
40 | (api:var-real-name from) | |
43 |
( |
|
41 | (for ((i start)) | |
44 |
|
|
42 | ((< i (min (api:array-size from-name) | |
45 |
|
|
43 | (+ start count)))) | |
46 |
|
|
44 | ((incf i)) | |
47 |
|
|
45 | (api:set-var to-name (+ start i) to-slot | |
48 |
(api |
|
46 | (api:get-var from-name (+ start i) from-slot)))))) | |
49 |
|
47 | |||
50 |
(def |
|
48 | (defun arrpos (name value &optional (start 0)) | |
51 | (multiple-value-bind (real-name slot) |
|
49 | (multiple-value-bind (real-name slot) | |
52 |
(api |
|
50 | (api:var-real-name name) | |
53 |
( |
|
51 | (for ((i start)) ((< i (api:array-size name))) ((incf i)) | |
54 |
(when (eq (api |
|
52 | (when (eq (api:get-var real-name i slot) value) | |
55 | (return i)))) |
|
53 | (return-from arrpos i)))) | |
56 | -1) |
|
54 | -1) | |
57 |
|
55 | |||
58 |
(def |
|
56 | (defun arrcomp (name pattern &optional (start 0)) | |
59 | (multiple-value-bind (real-name slot) |
|
57 | (multiple-value-bind (real-name slot) | |
60 |
(api |
|
58 | (api:var-real-name name) | |
61 |
( |
|
59 | (for ((i start)) ((< i (api:array-size name))) ((incf i)) | |
62 |
(when (funcall ( |
|
60 | (when (funcall (getprop (api:get-var real-name i slot) 'match) pattern) | |
63 | (return i)))) |
|
61 | (return-from arrcomp i)))) | |
64 | -1) |
|
62 | -1) | |
65 |
|
63 | |||
66 | ;;; 6str |
|
64 | ;;; 6str | |
67 |
|
65 | |||
68 |
(def |
|
66 | (defun instr (s subs &optional (start 1)) | |
69 |
(+ start ( |
|
67 | (+ start (chain s (substring (- start 1)) (search subs)))) | |
70 |
|
68 | |||
71 |
(def |
|
69 | (defun isnum (s) | |
72 | (if (is-na-n s) |
|
70 | (if (is-na-n s) | |
73 | 0 |
|
71 | 0 | |
74 | -1)) |
|
72 | -1)) | |
75 |
|
73 | |||
76 |
(def |
|
74 | (defun strcomp (s pattern) | |
77 |
(if ( |
|
75 | (if (chain s (match pattern)) | |
78 | -1 |
|
76 | -1 | |
79 | 0)) |
|
77 | 0)) | |
80 |
|
78 | |||
81 |
(def |
|
79 | (defun strfind (s pattern group) | |
82 |
(let* ((re ( |
|
80 | (let* ((re (new (*reg-exp pattern))) | |
83 |
(match ( |
|
81 | (match (chain re (exec s)))) | |
84 |
( |
|
82 | (chain match (group group)))) | |
85 |
|
83 | |||
86 |
(def |
|
84 | (defun strpos (s pattern &optional (group 0)) | |
87 |
(let* ((re ( |
|
85 | (let* ((re (new (*reg-exp pattern))) | |
88 |
(match ( |
|
86 | (match (chain re (exec s))) | |
89 |
(found ( |
|
87 | (found (chain match (group group)))) | |
90 | (if found |
|
88 | (if found | |
91 |
( |
|
89 | (chain s (search found)) | |
92 | 0))) |
|
90 | 0))) | |
93 |
|
91 | |||
94 | ;;; 7if |
|
92 | ;;; 7if | |
95 |
|
93 | |||
96 | ;; Has to be a function because it always evaluates all three of its |
|
94 | ;; Has to be a function because it always evaluates all three of its | |
97 | ;; arguments |
|
95 | ;; arguments | |
98 |
(def |
|
96 | (defun iif (cond-expr then-expr else-expr) | |
99 | (if cond-expr then-expr else-expr)) |
|
97 | (if cond-expr then-expr else-expr)) | |
100 |
|
98 | |||
101 | ;;; 8sub |
|
99 | ;;; 8sub | |
102 |
|
100 | |||
103 |
(def |
|
101 | (defun gosub (target &rest args) | |
104 |
(funcall ( |
|
102 | (funcall (getprop (root locs) target) args) | |
105 | (values)) |
|
103 | (values)) | |
106 |
|
104 | |||
107 |
(def |
|
105 | (defun func (target &rest args) | |
108 |
(funcall ( |
|
106 | (funcall (getprop (root locs) target) args)) | |
109 |
|
107 | |||
110 | ;;; 9loops |
|
108 | ;;; 9loops | |
111 |
|
109 | |||
112 | ;;; 10dynamic |
|
110 | ;;; 10dynamic | |
113 |
|
111 | |||
114 |
(def |
|
112 | (defun dynamic (block &rest args) | |
115 | (when (stringp block) |
|
113 | (when (stringp block) | |
116 |
(api |
|
114 | (api:report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC.")) | |
117 | (funcall block args) |
|
115 | (api:with-call-args args | |
|
116 | (funcall block args)) | |||
118 | (values)) |
|
117 | (values)) | |
119 |
|
118 | |||
120 |
(def |
|
119 | (defun dyneval (block &rest args) | |
121 | (when (stringp block) |
|
120 | (when (stringp block) | |
122 |
(api |
|
121 | (api:report-error "DYNEVAL can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNEVAL.")) | |
123 | (funcall block args)) |
|
122 | (api:with-call-args args | |
|
123 | (funcall block args))) | |||
124 |
|
124 | |||
125 | ;;; 11main |
|
125 | ;;; 11main | |
126 |
|
126 | |||
127 |
(def |
|
127 | (defun main-p (s) | |
128 |
(api |
|
128 | (api:add-text :main s) | |
129 | (values)) |
|
129 | (values)) | |
130 |
|
130 | |||
131 |
(def |
|
131 | (defun main-pl (s) | |
132 |
(api |
|
132 | (api:add-text :main s) | |
133 |
(api |
|
133 | (api:newline :main) | |
134 | (values)) |
|
134 | (values)) | |
135 |
|
135 | |||
136 |
(def |
|
136 | (defun main-nl (s) | |
137 |
(api |
|
137 | (api:newline :main) | |
138 |
(api |
|
138 | (api:add-text :main s) | |
139 | (values)) |
|
139 | (values)) | |
140 |
|
140 | |||
141 |
(def |
|
141 | (defun maintxt (s) | |
142 |
(api |
|
142 | (api:get-text :main) | |
143 | (values)) |
|
143 | (values)) | |
144 |
|
144 | |||
145 | ;; For clarity (it leaves a lib.desc() call in JS) |
|
145 | ;; For clarity (it leaves a lib.desc() call in JS) | |
146 |
(def |
|
146 | (defun desc (s) | |
147 | "") |
|
147 | "") | |
148 |
|
148 | |||
149 |
(def |
|
149 | (defun main-clear () | |
150 |
(api |
|
150 | (api:clear-text :main) | |
151 | (values)) |
|
151 | (values)) | |
152 |
|
152 | |||
153 | ;;; 12stat |
|
153 | ;;; 12stat | |
154 |
|
154 | |||
155 |
(def |
|
155 | (defun stat-p (s) | |
156 |
(api |
|
156 | (api:add-text :stat s) | |
157 | (values)) |
|
157 | (values)) | |
158 |
|
158 | |||
159 |
(def |
|
159 | (defun stat-pl (s) | |
160 |
(api |
|
160 | (api:add-text :stat s) | |
161 |
(api |
|
161 | (api:newline :stat) | |
162 | (values)) |
|
162 | (values)) | |
163 |
|
163 | |||
164 |
(def |
|
164 | (defun stat-nl (s) | |
165 |
(api |
|
165 | (api:newline :stat) | |
166 |
(api |
|
166 | (api:add-text :stat s) | |
167 | (values)) |
|
167 | (values)) | |
168 |
|
168 | |||
169 |
(def |
|
169 | (defun stattxt (s) | |
170 |
(api |
|
170 | (api:get-text :stat) | |
171 | (values)) |
|
171 | (values)) | |
172 |
|
172 | |||
173 |
(def |
|
173 | (defun stat-clear () | |
174 |
(api |
|
174 | (api:clear-text :stat) | |
175 | (values)) |
|
175 | (values)) | |
176 |
|
176 | |||
177 |
(def |
|
177 | (defun cls () | |
178 | (funcall (root lib stat-clear)) |
|
178 | (stat-clear) | |
179 | (funcall (root lib main-clear)) |
|
179 | (main-clear) | |
180 | (funcall (root lib cla)) |
|
180 | (cla) | |
181 | (funcall (root lib cmdclear)) |
|
181 | (cmdclear) | |
182 | (values)) |
|
182 | (values)) | |
183 |
|
183 | |||
184 | ;;; 13diag |
|
184 | ;;; 13diag | |
185 |
|
185 | |||
186 | ;;; 14act |
|
186 | ;;; 14act | |
187 |
|
187 | |||
188 |
(def |
|
188 | (defun curacts () | |
189 | (let ((acts (root acts))) |
|
189 | (let ((acts (root acts))) | |
190 | (lambda () |
|
190 | (lambda () | |
191 | (setf (root acts) acts) |
|
191 | (setf (root acts) acts) | |
@@ -193,89 +193,89 b'' | |||||
193 |
|
193 | |||
194 | ;;; 15objs |
|
194 | ;;; 15objs | |
195 |
|
195 | |||
196 |
(def |
|
196 | (defun addobj (name) | |
197 |
( |
|
197 | (chain (root objs) (push name)) | |
198 |
(api |
|
198 | (api:update-objs) | |
199 | (values)) |
|
199 | (values)) | |
200 |
|
200 | |||
201 |
(def |
|
201 | (defun delobj (name) | |
202 |
(let ((index ( |
|
202 | (let ((index (chain (root objs) (index-of name)))) | |
203 | (when (> index -1) |
|
203 | (when (> index -1) | |
204 |
( |
|
204 | (killobj (1+ index)))) | |
205 | (values)) |
|
205 | (values)) | |
206 |
|
206 | |||
207 |
(def |
|
207 | (defun killobj (&optional (num nil)) | |
208 | (if (eq nil num) |
|
208 | (if (eq nil num) | |
209 | (setf (root objs) (list)) |
|
209 | (setf (root objs) (list)) | |
210 |
( |
|
210 | (chain (root objs) (splice (1- num) 1))) | |
211 |
(api |
|
211 | (api:update-objs) | |
212 | (values)) |
|
212 | (values)) | |
213 |
|
213 | |||
214 | ;;; 16menu |
|
214 | ;;; 16menu | |
215 |
|
215 | |||
216 |
(def |
|
216 | (defun menu (menu-name) | |
217 | (let ((menu-data (list))) |
|
217 | (let ((menu-data (list))) | |
218 |
(loop :for item :in (api |
|
218 | (loop :for item :in (api:get-array (api:var-real-name menu-name)) | |
219 | :do (cond ((string= item "") |
|
219 | :do (cond ((string= item "") | |
220 | (break)) |
|
220 | (break)) | |
221 | ((string= item "-:-") |
|
221 | ((string= item "-:-") | |
222 |
( |
|
222 | (chain menu-data (push :delimiter))) | |
223 | (t |
|
223 | (t | |
224 |
(let* ((tokens ( |
|
224 | (let* ((tokens (chain item (split ":")))) | |
225 | (when (= (length tokens) 2) |
|
225 | (when (= (length tokens) 2) | |
226 |
(tokens |
|
226 | (chain tokens (push ""))) | |
227 |
(let* ((text ( |
|
227 | (let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":"))) | |
228 |
(loc ( |
|
228 | (loc (getprop tokens (- (length tokens) 2))) | |
229 |
(icon ( |
|
229 | (icon (getprop tokens (- (length tokens) 1)))) | |
230 |
( |
|
230 | (chain menu-data | |
231 |
|
|
231 | (push (create text text | |
232 |
|
|
232 | loc loc | |
233 |
|
|
233 | icon icon)))))))) | |
234 |
(api |
|
234 | (api:menu menu-data) | |
235 | (values))) |
|
235 | (values))) | |
236 |
|
236 | |||
237 | ;;; 17sound |
|
237 | ;;; 17sound | |
238 |
|
238 | |||
239 |
(def |
|
239 | (defun play (filename &optional (volume 100)) | |
240 |
(let ((audio ( |
|
240 | (let ((audio (new (*audio filename)))) | |
241 |
(setf ( |
|
241 | (setf (getprop (root playing) filename) audio) | |
242 |
(setf ( |
|
242 | (setf (@ audio volume) (* volume 0.01)) | |
243 |
( |
|
243 | (chain audio (play)))) | |
244 |
|
244 | |||
245 |
(def |
|
245 | (defun close (filename) | |
246 | (funcall (root playing filename) stop) |
|
246 | (funcall (root playing filename) stop) | |
247 |
( |
|
247 | (delete (root playing filename))) | |
248 |
|
248 | |||
249 |
(def |
|
249 | (defun closeall () | |
250 |
(loop :for k :in (*object |
|
250 | (loop :for k :in (chain *object (keys (root playing))) | |
251 |
:for v := ( |
|
251 | :for v := (getprop (root playing) k) | |
252 | :do (funcall v stop)) |
|
252 | :do (funcall v stop)) | |
253 |
(setf (root playing) ( |
|
253 | (setf (root playing) (create))) | |
254 |
|
254 | |||
255 | ;;; 18img |
|
255 | ;;; 18img | |
256 |
|
256 | |||
257 |
(def |
|
257 | (defun refint () | |
258 | ;; "Force interface update" Uh... what exactly do we do here? |
|
258 | ;; "Force interface update" Uh... what exactly do we do here? | |
259 |
(api |
|
259 | (api:report-error "REFINT is not supported") | |
260 | ) |
|
260 | ) | |
261 |
|
261 | |||
262 | ;;; 19input |
|
262 | ;;; 19input | |
263 |
|
263 | |||
264 |
(def |
|
264 | (defun usertxt () | |
265 |
(let ((input ( |
|
265 | (let ((input (by-id "qsp-input"))) | |
266 |
( |
|
266 | (@ input value))) | |
267 |
|
267 | |||
268 |
(def |
|
268 | (defun cmdclear () | |
269 |
(let ((input ( |
|
269 | (let ((input (by-id "qsp-input"))) | |
270 |
(setf ( |
|
270 | (setf (@ input value) ""))) | |
271 |
|
271 | |||
272 |
(def |
|
272 | (defun input (text) | |
273 |
(window |
|
273 | (chain window (prompt text))) | |
274 |
|
274 | |||
275 | ;;; 20time |
|
275 | ;;; 20time | |
276 |
|
276 | |||
277 |
(def |
|
277 | (defun msecscount () | |
278 |
(- ( |
|
278 | (- (chain *date (now)) (root started-at))) | |
279 |
|
279 | |||
280 | ;;; 21local |
|
280 | ;;; 21local | |
281 |
|
281 | |||
@@ -283,19 +283,19 b'' | |||||
283 |
|
283 | |||
284 | ;;; misc |
|
284 | ;;; misc | |
285 |
|
285 | |||
286 |
(def |
|
286 | (defun rgb (red green blue) | |
287 | (flet ((rgb-to-hex (comp) |
|
287 | (flet ((rgb-to-hex (comp) | |
288 |
(let ((hex ( |
|
288 | (let ((hex (chain (*number comp) (to-string 16)))) | |
289 | (if (< (length hex) 2) |
|
289 | (if (< (length hex) 2) | |
290 | (+ "0" hex) |
|
290 | (+ "0" hex) | |
291 | hex)))) |
|
291 | hex)))) | |
292 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red)))) |
|
292 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red)))) | |
293 |
|
293 | |||
294 |
(def |
|
294 | (defun openqst () | |
295 |
(api |
|
295 | (api:report-error "OPENQST is not supported.")) | |
296 |
|
296 | |||
297 |
(def |
|
297 | (defun addqst () | |
298 |
(api |
|
298 | (api:report-error "ADDQST is not supported. Bundle the library with the main game.")) | |
299 |
|
299 | |||
300 |
(def |
|
300 | (defun killqst () | |
301 |
(api |
|
301 | (api:report-error "KILLQST is not supported.")) |
@@ -59,8 +59,22 b'' | |||||
59 |
|
59 | |||
60 | ;;; JS |
|
60 | ;;; JS | |
61 |
|
61 | |||
|
62 | (defun minify-package (package-designator minify prefix) | |||
|
63 | (setf (ps:ps-package-prefix package-designator) prefix) | |||
|
64 | (if minify | |||
|
65 | (ps:obfuscate-package package-designator) | |||
|
66 | (ps:unobfuscate-package package-designator))) | |||
|
67 | ||||
62 | (defmethod js-sources ((compiler compiler)) |
|
68 | (defmethod js-sources ((compiler compiler)) | |
63 | (let ((ps:*ps-print-pretty* (beautify compiler))) |
|
69 | (let ((ps:*ps-print-pretty* (beautify compiler))) | |
|
70 | (cond ((beautify compiler) | |||
|
71 | (minify-package "SUGAR-QSP.MAIN" nil "qsp_") | |||
|
72 | (minify-package "SUGAR-QSP.API" nil "qsp_api_") | |||
|
73 | (minify-package "SUGAR-QSP.LIB" nil "qsp_lib_")) | |||
|
74 | (t | |||
|
75 | (minify-package "SUGAR-QSP.MAIN" t "_") | |||
|
76 | (minify-package "SUGAR-QSP.API" t "a_") | |||
|
77 | (minify-package "SUGAR-QSP.LIB" t "l_"))) | |||
64 | (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler)))))) |
|
78 | (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler)))))) | |
65 |
|
79 | |||
66 | ;;; CSS |
|
80 | ;;; CSS |
@@ -1,41 +1,43 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.main) | |
3 |
|
3 | |||
4 | (setf (root) |
|
4 | (setf (root) | |
5 |
( |
|
5 | (create | |
6 | ;;; Game session state |
|
6 | ;;; Game session state | |
7 | ;; Variables |
|
7 | ;; Variables | |
8 |
vars ( |
|
8 | vars (create) | |
9 | ;; Inventory (objects) |
|
9 | ;; Inventory (objects) | |
10 | objs (list) |
|
10 | objs (list) | |
|
11 | current-location nil | |||
11 | ;; Game time |
|
12 | ;; Game time | |
12 |
started-at ( |
|
13 | started-at (chain *date (now)) | |
13 | ;; Timers |
|
14 | ;; Timers | |
14 | timer-interval 500 |
|
15 | timer-interval 500 | |
15 | timer-obj nil |
|
16 | timer-obj nil | |
16 | ;;; Transient state |
|
17 | ;;; Transient state | |
17 | ;; Savegame data |
|
18 | ;; Savegame data | |
18 |
state-stash ( |
|
19 | state-stash (create) | |
19 | ;; List of audio files being played |
|
20 | ;; List of audio files being played | |
20 |
playing ( |
|
21 | playing (create) | |
21 | ;; Local variables stack (starts with an empty frame) |
|
22 | ;; Local variables stack (starts with an empty frame) | |
22 | locals (list) |
|
23 | locals (list) | |
23 | ;;; Game data |
|
24 | ;;; Game data | |
24 | ;; ACTions |
|
25 | ;; ACTions | |
25 |
acts ( |
|
26 | acts (create) | |
26 | ;; Locations |
|
27 | ;; Locations | |
27 |
locs ( |
|
28 | locs (create))) | |
28 |
|
29 | |||
29 | ;; Launch the game from the first location |
|
30 | ;; Launch the game from the first location | |
30 |
(setf window |
|
31 | (setf (@ window onload) | |
31 | (lambda () |
|
32 | (lambda () | |
32 | (api-call init-dom) |
|
33 | (#.(intern "INIT-DOM" "SUGAR-QSP.API")) | |
33 | ;; For MSECCOUNT |
|
34 | ;; For MSECCOUNT | |
34 |
(setf (root started-at) ( |
|
35 | (setf (root started-at) (chain *date (now))) | |
35 | ;; For $COUNTER and SETTIMER |
|
36 | ;; For $COUNTER and SETTIMER | |
36 | (api-call set-timer (root timer-interval)) |
|
37 | (#.(intern "SET-TIMER" "SUGAR-QSP.API") | |
37 | (funcall (ps:getprop (root locs) |
|
38 | (root timer-interval)) | |
38 | (ps:chain *object (keys (root locs)) 0)) |
|
39 | (funcall (getprop (root locs) | |
|
40 | (chain *object (keys (root locs)) 0)) | |||
39 | (list)) |
|
41 | (list)) | |
40 | (values))) |
|
42 | (values))) | |
41 |
|
43 |
@@ -1,7 +1,93 b'' | |||||
1 |
|
1 | |||
2 | (in-package cl-user) |
|
2 | (in-package cl-user) | |
3 |
|
3 | |||
|
4 | (defpackage :sugar-qsp.js) | |||
|
5 | ||||
|
6 | (defpackage :sugar-qsp.main | |||
|
7 | (:use :cl :ps :sugar-qsp.js) | |||
|
8 | (:export #:api-call #:by-id | |||
|
9 | #:root #:in | |||
|
10 | #:vars #:objs #:current-location | |||
|
11 | #:started-at #:timer-interval #:timer-obj | |||
|
12 | #:state-stash #:playing #:locals | |||
|
13 | #:acts #:locs)) | |||
|
14 | ||||
|
15 | ;;; API functions | |||
|
16 | (defpackage :sugar-qsp.api | |||
|
17 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) | |||
|
18 | (:export #:with-frame #:with-call-args | |||
|
19 | #:stash-state | |||
|
20 | ||||
|
21 | #:report-error #:sleep #:init-dom #:call-serv-loc | |||
|
22 | #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id | |||
|
23 | #:init-args #:get-result #:call-loc #:call-act | |||
|
24 | #:get-frame #:add-text #:get-text #:clear-text #:enable-frame | |||
|
25 | #:add-act #:del-act #:clear-act #:update-acts | |||
|
26 | #:qspfor | |||
|
27 | #:*var #:new-value #:index-num #:get #:set #:kill | |||
|
28 | #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var | |||
|
29 | #:get-array #:set-array #:kill-var #:array-size | |||
|
30 | #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local | |||
|
31 | #:update-objs | |||
|
32 | #:menu | |||
|
33 | #:clean-audio | |||
|
34 | #:show-image | |||
|
35 | #:opengame #:savegame | |||
|
36 | )) | |||
|
37 | ||||
|
38 | ;;; QSP library functions and macros | |||
|
39 | (defpackage :sugar-qsp.lib | |||
|
40 | (:use :cl :ps :sugar-qsp.main :sugar-qsp.js) | |||
|
41 | (:local-nicknames (#:api :sugar-qsp.api)) | |||
|
42 | (:export #:str #:exec #:qspblock #:qspfor #:location | |||
|
43 | #:qspcond #:qspvar #:set #:local | |||
|
44 | ||||
|
45 | #:killvar #:killall | |||
|
46 | #:obj #:loc #:no | |||
|
47 | #:qspver #:curloc | |||
|
48 | #:rnd #:qspmax #:qspmin | |||
|
49 | #:arrsize #:len | |||
|
50 | #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr | |||
|
51 | #:exit #:desc | |||
|
52 | #:showstat #:msg | |||
|
53 | #:showacts #:delact #:cla | |||
|
54 | #:showobjs #:countobj #:getobj | |||
|
55 | #:isplay | |||
|
56 | #:view | |||
|
57 | #:showinput | |||
|
58 | #:wait #:settimer | |||
|
59 | #:local | |||
|
60 | #:opengame #:savegame | |||
|
61 | ||||
|
62 | #:goto #:xgoto | |||
|
63 | #:rand | |||
|
64 | #:copyarr #:arrpos #:arrcomp | |||
|
65 | #:instr #:isnum #:strcomp #:strfind #:strpos | |||
|
66 | #:iif | |||
|
67 | #:gosub #:func | |||
|
68 | #:dynamic #:dyneval | |||
|
69 | #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear | |||
|
70 | #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls | |||
|
71 | #:curacts | |||
|
72 | #:addobj #:delobj #:killobj | |||
|
73 | #:menu | |||
|
74 | #:play #:close #:closeall | |||
|
75 | #:refint | |||
|
76 | #:usertxt #:cmdclear #:input | |||
|
77 | #:msecscount | |||
|
78 | #:rgb | |||
|
79 | #:openqst #:addqst #:killqst | |||
|
80 | )) | |||
|
81 | ||||
|
82 | ;;; The compiler | |||
4 | (defpackage :sugar-qsp |
|
83 | (defpackage :sugar-qsp | |
5 | (:use :cl) |
|
84 | (:use :cl) | |
6 |
(:local-nicknames (#:p #:esrap) |
|
85 | (:local-nicknames (#:p #:esrap) | |
|
86 | (#:lib :sugar-qsp.lib) | |||
|
87 | (#:api :sugar-qsp.api) | |||
|
88 | (#:main :sugar-qsp.main)) | |||
7 | (:export #:parse-file #:entry-point)) |
|
89 | (:export #:parse-file #:entry-point)) | |
|
90 | ||||
|
91 | (setf (ps:ps-package-prefix "SUGAR-QSP.MAIN") "qsp_") | |||
|
92 | (setf (ps:ps-package-prefix "SUGAR-QSP.API") "qsp_api_") | |||
|
93 | (setf (ps:ps-package-prefix "SUGAR-QSP.LIB") "qsp_lib_") |
@@ -33,7 +33,7 b'' | |||||
33 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) |
|
33 | (not (find char " !:&=<>+-*/,'\"()[]{}")))) | |
34 |
|
34 | |||
35 | (defun intern-first (list) |
|
35 | (defun intern-first (list) | |
36 | (list* (intern (string-upcase (first list))) |
|
36 | (list* (intern (string-upcase (first list)) :lib) | |
37 | (rest list))) |
|
37 | (rest list))) | |
38 |
|
38 | |||
39 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|
39 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
@@ -44,7 +44,7 b'' | |||||
44 | (destructuring-bind (ws1 operator ws2 operand2) |
|
44 | (destructuring-bind (ws1 operator ws2 operand2) | |
45 | list |
|
45 | list | |
46 | (declare (ignore ws1 ws2)) |
|
46 | (declare (ignore ws1 ws2)) | |
47 | (list (intern (string-upcase operator)) operand2))) |
|
47 | (list (intern (string-upcase operator) :lib) operand2))) | |
48 |
|
48 | |||
49 | (defun do-binop% (left-op other-ops) |
|
49 | (defun do-binop% (left-op other-ops) | |
50 | (if (null other-ops) |
|
50 | (if (null other-ops) | |
@@ -127,7 +127,7 b'' | |||||
127 | (digit-char-p character))) |
|
127 | (digit-char-p character))) | |
128 | (p:defrule identifier-raw (and id-first (* id-next)) |
|
128 | (p:defrule identifier-raw (and id-first (* id-next)) | |
129 | (:lambda (list) |
|
129 | (:lambda (list) | |
130 | (intern (string-upcase (p:text list))))) |
|
130 | (intern (string-upcase (p:text list)) :lib))) | |
131 |
|
131 | |||
132 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) |
|
132 | (p:defrule identifier (not-qsp-keyword-p identifier-raw)) | |
133 |
|
133 | |||
@@ -137,7 +137,7 b'' | |||||
137 |
|
137 | |||
138 | (p:defrule normal-string (or sstring dstring) |
|
138 | (p:defrule normal-string (or sstring dstring) | |
139 | (:lambda (str) |
|
139 | (:lambda (str) | |
140 | (list* 'str (or str (list ""))))) |
|
140 | (list* 'lib:str (or str (list ""))))) | |
141 |
|
141 | |||
142 | (p:defrule sstring (and #\' (* (or string-interpol |
|
142 | (p:defrule sstring (and #\' (* (or string-interpol | |
143 | sstring-exec |
|
143 | sstring-exec | |
@@ -162,15 +162,15 b'' | |||||
162 |
|
162 | |||
163 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") |
|
163 | (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\") | |
164 | (:lambda (list) |
|
164 | (:lambda (list) | |
165 | (list* 'exec (p:parse 'exec-body (second list))))) |
|
165 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
166 |
|
166 | |||
167 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') |
|
167 | (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\') | |
168 | (:lambda (list) |
|
168 | (:lambda (list) | |
169 | (list* 'exec (p:parse 'exec-body (second list))))) |
|
169 | (list* 'lib:exec (p:parse 'exec-body (second list))))) | |
170 |
|
170 | |||
171 | (p:defrule brace-string (and #\{ before-statement block-body #\}) |
|
171 | (p:defrule brace-string (and #\{ before-statement block-body #\}) | |
172 | (:lambda (list) |
|
172 | (:lambda (list) | |
173 | (list* 'qspblock (third list)))) |
|
173 | (list* 'lib:qspblock (third list)))) | |
174 |
|
174 | |||
175 | ;;; Location |
|
175 | ;;; Location | |
176 |
|
176 | |||
@@ -181,7 +181,7 b'' | |||||
181 | (p:defrule location (and location-header block-body location-end) |
|
181 | (p:defrule location (and location-header block-body location-end) | |
182 | (:destructure (header body end) |
|
182 | (:destructure (header body end) | |
183 | (declare (ignore end)) |
|
183 | (declare (ignore end)) | |
184 | `(location (,header) ,@body))) |
|
184 | `(lib:location (,header) ,@body))) | |
185 |
|
185 | |||
186 | (p:defrule location-header (and #\# |
|
186 | (p:defrule location-header (and #\# | |
187 | (+ not-newline) |
|
187 | (+ not-newline) | |
@@ -246,11 +246,11 b'' | |||||
246 |
|
246 | |||
247 | (p:defrule string-output qsp-string |
|
247 | (p:defrule string-output qsp-string | |
248 | (:lambda (string) |
|
248 | (:lambda (string) | |
249 | (list 'main-pl string))) |
|
249 | (list 'lib:main-pl string))) | |
250 |
|
250 | |||
251 | (p:defrule expression-output expression |
|
251 | (p:defrule expression-output expression | |
252 | (:lambda (list) |
|
252 | (:lambda (list) | |
253 | (list 'main-pl list))) |
|
253 | (list 'lib:main-pl list))) | |
254 |
|
254 | |||
255 | (p:defrule label (and colon identifier) |
|
255 | (p:defrule label (and colon identifier) | |
256 | (:lambda (list) |
|
256 | (:lambda (list) | |
@@ -264,7 +264,7 b'' | |||||
264 |
|
264 | |||
265 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) |
|
265 | (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression))) | |
266 | (:lambda (list) |
|
266 | (:lambda (list) | |
267 | (list* 'local (third list) |
|
267 | (list* 'lib:local (third list) | |
268 | (when (fourth list) |
|
268 | (when (fourth list) | |
269 | (list (fourth (fourth list))))))) |
|
269 | (list (fourth (fourth list))))))) | |
270 |
|
270 | |||
@@ -274,8 +274,8 b'' | |||||
274 |
|
274 | |||
275 | (p:defrule block-if (and block-if-head block-if-body) |
|
275 | (p:defrule block-if (and block-if-head block-if-body) | |
276 | (:destructure (head body) |
|
276 | (:destructure (head body) | |
277 | `(qspcond (,@head ,@(first body)) |
|
277 | `(lib:qspcond (,@head ,@(first body)) | |
278 | ,@(rest body)))) |
|
278 | ,@(rest body)))) | |
279 |
|
279 | |||
280 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) |
|
280 | (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?) | |
281 | (:function remove-nil) |
|
281 | (:function remove-nil) | |
@@ -335,7 +335,7 b'' | |||||
335 | (:lambda (list) |
|
335 | (:lambda (list) | |
336 | (intern-first (list (first list) |
|
336 | (intern-first (list (first list) | |
337 | (third list) |
|
337 | (third list) | |
338 | (or (fifth list) '(str "")))))) |
|
338 | (or (fifth list) '(lib:str "")))))) | |
339 |
|
339 | |||
340 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) |
|
340 | (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?) | |
341 | (:lambda (list) |
|
341 | (:lambda (list) | |
@@ -352,7 +352,7 b'' | |||||
352 | (:lambda (list) |
|
352 | (:lambda (list) | |
353 | (unless (eq (fourth (third list)) :num) |
|
353 | (unless (eq (fourth (third list)) :num) | |
354 | (error "For counter variable must be numeric.")) |
|
354 | (error "For counter variable must be numeric.")) | |
355 | (list 'qspfor |
|
355 | (list 'lib:qspfor | |
356 | (elt list 2) |
|
356 | (elt list 2) | |
357 | (elt list 6) |
|
357 | (elt list 6) | |
358 | (elt list 9) |
|
358 | (elt list 9) | |
@@ -428,12 +428,12 b'' | |||||
428 | (unless (<= ,min-arity (length arguments) ,max-arity) |
|
428 | (unless (<= ,min-arity (length arguments) ,max-arity) | |
429 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" |
|
429 | (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S" | |
430 | name ,min-arity ,max-arity (length arguments) arguments)) |
|
430 | name ,min-arity ,max-arity (length arguments) arguments)) | |
431 | (list* ',sym arguments)))) |
|
431 | (list* ',(intern (string sym) :lib) arguments)))) | |
432 |
|
432 | |||
433 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) |
|
433 | (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic) | |
434 | ;; Transitions |
|
434 | ;; Transitions | |
435 |
(goto |
|
435 | (goto% nil 0 10 "gt" "goto") | |
436 |
(xgoto |
|
436 | (xgoto% nil 0 10 "xgt" "xgoto") | |
437 | ;; Variables |
|
437 | ;; Variables | |
438 | (killvar nil 0 2) |
|
438 | (killvar nil 0 2) | |
439 | ;; Expressions |
|
439 | ;; Expressions | |
@@ -583,24 +583,24 b'' | |||||
583 | (p:defrule variable (and identifier (p:? array-index)) |
|
583 | (p:defrule variable (and identifier (p:? array-index)) | |
584 | (:destructure (id idx) |
|
584 | (:destructure (id idx) | |
585 | (if (char= #\$ (elt (string id) 0)) |
|
585 | (if (char= #\$ (elt (string id) 0)) | |
586 | (list 'var (intern (subseq (string-upcase id) 1)) (or idx 0) :str) |
|
586 | (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) (or idx 0) :str) | |
587 | (list 'var id (or idx 0) :num)))) |
|
587 | (list 'lib:qspvar id (or idx 0) :num)))) | |
588 |
|
588 | |||
589 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) |
|
589 | (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\]) | |
590 | (:function third)) |
|
590 | (:function third)) | |
591 |
|
591 | |||
592 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) |
|
592 | (p:defrule assignment (or kw-assignment plain-assignment op-assignment) | |
593 | (:destructure (var eq expr) |
|
593 | (:destructure (qspvar eq expr) | |
594 | (declare (ignore eq)) |
|
594 | (declare (ignore eq)) | |
595 | (list 'set var expr))) |
|
595 | (list 'lib:set qspvar expr))) | |
596 |
|
596 | |||
597 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) |
|
597 | (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment)) | |
598 | (:function third)) |
|
598 | (:function third)) | |
599 |
|
599 | |||
600 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) |
|
600 | (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression) | |
601 | (:destructure (var ws1 op eq ws2 expr) |
|
601 | (:destructure (qspvar ws1 op eq ws2 expr) | |
602 | (declare (ignore ws1 ws2)) |
|
602 | (declare (ignore ws1 ws2)) | |
603 | (list var eq (intern-first (list op var expr))))) |
|
603 | (list qspvar eq (intern-first (list op qspvar expr))))) | |
604 |
|
604 | |||
605 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) |
|
605 | (p:defrule plain-assignment (and variable spaces? #\= spaces? expression) | |
606 | (:function remove-nil)) |
|
606 | (:function remove-nil)) |
@@ -1,5 +1,5 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp.lib) | |
3 |
|
3 | |||
4 | ;;;; Parenscript macros which make the parser's intermediate |
|
4 | ;;;; Parenscript macros which make the parser's intermediate | |
5 | ;;;; representation directly compilable by Parenscript |
|
5 | ;;;; representation directly compilable by Parenscript | |
@@ -7,40 +7,9 b'' | |||||
7 |
|
7 | |||
8 | ;;; Utils |
|
8 | ;;; Utils | |
9 |
|
9 | |||
10 | (ps:defpsmacro defm (path args &body body) |
|
|||
11 | `(setf ,path (lambda ,args ,@body))) |
|
|||
12 |
|
||||
13 | (ps:defpsmacro root (&rest path) |
|
|||
14 | `(ps:@ *sugar-q-s-p ,@path)) |
|
|||
15 |
|
||||
16 | (ps:defpsmacro in (key obj) |
|
|||
17 | `(ps:chain ,obj (has-own-property ,key))) |
|
|||
18 |
|
||||
19 | (ps:defpsmacro with-frame (&body body) |
|
|||
20 | `(progn |
|
|||
21 | (api-call push-local-frame) |
|
|||
22 | (unwind-protect |
|
|||
23 | ,@body |
|
|||
24 | (api-call pop-local-frame)))) |
|
|||
25 |
|
||||
26 | ;;; Common |
|
10 | ;;; Common | |
27 |
|
11 | |||
28 | (defmacro defpsintrinsic (name) |
|
12 | (defpsmacro label-block ((&key (locals t)) &body body) | |
29 | `(ps:defpsmacro ,name (&rest args) |
|
|||
30 | `(funcall (root lib ,',name) |
|
|||
31 | ,@args))) |
|
|||
32 |
|
||||
33 | (defmacro defpsintrinsics (() &rest names) |
|
|||
34 | `(progn ,@(loop :for name :in names |
|
|||
35 | :collect `(defpsintrinsic ,name)))) |
|
|||
36 |
|
||||
37 | (defpsintrinsics () |
|
|||
38 | rand copyarr arrpos arrcomp instr isnum strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear stat-p stat-pl stat-nl stattxt stat-clear cls curacts addobj delobj killobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer) |
|
|||
39 |
|
||||
40 | (ps:defpsmacro api-call (func &rest args) |
|
|||
41 | `(funcall (root api ,func) ,@args)) |
|
|||
42 |
|
||||
43 | (ps:defpsmacro label-block ((&key (locals t)) &body body) |
|
|||
44 | (let ((has-labels (some #'keywordp body))) |
|
13 | (let ((has-labels (some #'keywordp body))) | |
45 | `(block nil |
|
14 | `(block nil | |
46 | ,@(when has-labels |
|
15 | ,@(when has-labels | |
@@ -51,7 +20,7 b'' | |||||
51 | `((tagbody |
|
20 | `((tagbody | |
52 | ,@body)))))) |
|
21 | ,@body)))))) | |
53 |
|
22 | |||
54 |
( |
|
23 | (defpsmacro str (&rest forms) | |
55 | (cond ((zerop (length forms)) |
|
24 | (cond ((zerop (length forms)) | |
56 | "") |
|
25 | "") | |
57 | ((and (= 1 (length forms)) |
|
26 | ((and (= 1 (length forms)) | |
@@ -62,60 +31,54 b'' | |||||
62 |
|
31 | |||
63 | ;;; 1loc |
|
32 | ;;; 1loc | |
64 |
|
33 | |||
65 |
( |
|
34 | (defpsmacro location ((name) &body body) | |
66 | `(setf (root locs ,name) |
|
35 | `(setf (root locs ,name) | |
67 |
( |
|
36 | (async-lambda (args) | |
68 | (label-block () |
|
37 | (label-block () | |
69 | (api-call init-args args) |
|
38 | ,@body)))) | |
70 | ,@body |
|
|||
71 | (api-call get-result))))) |
|
|||
72 |
|
39 | |||
73 |
( |
|
40 | (defpsmacro goto% (target &rest args) | |
74 | `(progn |
|
41 | `(progn | |
75 |
( |
|
42 | (goto ,target ,args) | |
76 | (exit))) |
|
43 | (exit))) | |
77 |
|
44 | |||
78 |
( |
|
45 | (defpsmacro xgoto% (target &rest args) | |
79 | `(progn |
|
46 | `(progn | |
80 |
( |
|
47 | (xgoto ,target ,args) | |
81 | (exit))) |
|
48 | (exit))) | |
82 |
|
49 | |||
83 | (ps:defpsmacro desc (target) |
|
|||
84 | (declare (ignore target)) |
|
|||
85 | (report-error "DESC is not supported")) |
|
|||
86 |
|
||||
87 | ;;; 2var |
|
50 | ;;; 2var | |
88 |
|
51 | |||
89 |
( |
|
52 | (defpsmacro qspvar (name index slot) | |
90 | `(api-call get-var ,(string name) ,index ,slot)) |
|
53 | `(api-call get-var ,(string name) ,index ,slot)) | |
91 |
|
54 | |||
92 |
( |
|
55 | (defpsmacro set ((var vname vindex vslot) value) | |
93 | (assert (eq var 'var)) |
|
56 | (assert (eq var 'qspvar)) | |
94 | `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) |
|
57 | `(api-call set-var ,(string vname) ,vindex ,vslot ,value)) | |
95 |
|
58 | |||
96 | ;;; 3expr |
|
59 | ;;; 3expr | |
97 |
|
60 | |||
98 |
( |
|
61 | (defpsmacro <> (op1 op2) | |
99 | `(not (equal ,op1 ,op2))) |
|
62 | `(not (equal ,op1 ,op2))) | |
100 |
|
63 | |||
101 |
( |
|
64 | (defpsmacro ! (op1 op2) | |
102 | `(not (equal ,op1 ,op2))) |
|
65 | `(not (equal ,op1 ,op2))) | |
103 |
|
66 | |||
104 | ;;; 4code |
|
67 | ;;; 4code | |
105 |
|
68 | |||
106 |
( |
|
69 | (defpsmacro exec (&body body) | |
107 |
(format nil "javascript: ~{~A~^~%~}" (mapcar #' |
|
70 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body))) | |
108 |
|
71 | |||
109 | ;;; 5arrays |
|
72 | ;;; 5arrays | |
110 |
|
73 | |||
111 | ;;; 6str |
|
74 | ;;; 6str | |
112 |
|
75 | |||
113 |
( |
|
76 | (defpsmacro & (&rest args) | |
114 |
`( |
|
77 | `(chain "" (concat ,@args))) | |
115 |
|
78 | |||
116 | ;;; 7if |
|
79 | ;;; 7if | |
117 |
|
80 | |||
118 |
( |
|
81 | (defpsmacro qspcond (&rest clauses) | |
119 | `(cond ,@(loop :for clause :in clauses |
|
82 | `(cond ,@(loop :for clause :in clauses | |
120 | :collect (list (first clause) |
|
83 | :collect (list (first clause) | |
121 | `(tagbody |
|
84 | `(tagbody | |
@@ -126,11 +89,11 b'' | |||||
126 | ;;; 9loops |
|
89 | ;;; 9loops | |
127 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels |
|
90 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | |
128 |
|
91 | |||
129 |
( |
|
92 | (defpsmacro jump (target) | |
130 | `(return-from ,(intern (string-upcase (second target))) |
|
93 | `(return-from ,(intern (string-upcase (second target))) | |
131 |
(funcall ( |
|
94 | (funcall (getprop __labels ,target)))) | |
132 |
|
95 | |||
133 |
( |
|
96 | (defpsmacro tagbody (&body body) | |
134 | (let ((funcs (list nil :__nil))) |
|
97 | (let ((funcs (list nil :__nil))) | |
135 | (dolist (form body) |
|
98 | (dolist (form body) | |
136 | (cond ((keywordp form) |
|
99 | (cond ((keywordp form) | |
@@ -146,30 +109,28 b'' | |||||
146 | ,@body) |
|
109 | ,@body) | |
147 | `(progn |
|
110 | `(progn | |
148 | (setf ,@(loop :for f :on funcs :by #'cddr |
|
111 | (setf ,@(loop :for f :on funcs :by #'cddr | |
149 |
:append `(( |
|
112 | :append `((@ __labels ,(first f)) | |
150 | (block ,(intern (string-upcase (string (first f)))) |
|
113 | (block ,(intern (string-upcase (string (first f)))) | |
151 | ,@(second f) |
|
114 | ,@(second f) | |
152 | ,@(when (third f) |
|
115 | ,@(when (third f) | |
153 | `((funcall |
|
116 | `((funcall | |
154 |
( |
|
117 | (getprop __labels ,(third f))))))))) | |
155 | (jump (str "__nil")))))) |
|
118 | (jump (str "__nil")))))) | |
156 |
|
119 | |||
157 | ;;; 10dynamic |
|
120 | ;;; 10dynamic | |
158 |
|
121 | |||
159 |
( |
|
122 | (defpsmacro qspblock (&body body) | |
160 | `(lambda (args) |
|
123 | `(async-lambda (args) | |
161 | (label-block () |
|
124 | (label-block () | |
162 | (api-call init-args args) |
|
125 | ,@body))) | |
163 | ,@body |
|
|||
164 | (api-call get-result)))) |
|
|||
165 |
|
126 | |||
166 | ;;; 11main |
|
127 | ;;; 11main | |
167 |
|
128 | |||
168 |
( |
|
129 | (defpsmacro act (name img &body body) | |
169 | `(api-call add-act ,name ,img |
|
130 | `(api-call add-act ,name ,img | |
170 | (lambda () |
|
131 | (async-lambda () | |
171 | (label-block () |
|
132 | (label-block () | |
172 | ,@body)))) |
|
133 | ,@body)))) | |
173 |
|
134 | |||
174 | ;;; 12aux |
|
135 | ;;; 12aux | |
175 |
|
136 | |||
@@ -193,11 +154,11 b'' | |||||
193 |
|
154 | |||
194 | ;;; 22for |
|
155 | ;;; 22for | |
195 |
|
156 | |||
196 |
( |
|
157 | (defpsmacro qspfor (var from to step &body body) | |
197 | `(api-call qspfor |
|
158 | `((intern "QSPFOR" "API") | |
198 |
|
|
159 | ,(string (second var)) ,(third var) ;; name and index | |
199 |
|
|
160 | ,from ,to ,step | |
200 |
|
|
161 | (lambda () | |
201 |
|
|
162 | (block nil | |
202 |
|
|
163 | ,@body | |
203 |
|
|
164 | t)))) |
@@ -9,7 +9,10 b'' | |||||
9 | :serial t |
|
9 | :serial t | |
10 | :components ((:file "package") |
|
10 | :components ((:file "package") | |
11 | (:file "patches") |
|
11 | (:file "patches") | |
|
12 | (:file "js-syms") | |||
|
13 | (:file "main-macros") | |||
12 | (:file "ps-macros") |
|
14 | (:file "ps-macros") | |
|
15 | (:file "api-macros") | |||
13 | (:file "intrinsic-macros") |
|
16 | (:file "intrinsic-macros") | |
14 | (:file "class") |
|
17 | (:file "class") | |
15 | (:file "main") |
|
18 | (:file "main") |
General Comments 0
You need to be logged in to leave comments.
Login now