##// END OF EJS Templates
u » naryl » qsp-txt2web
RSS

Clone from https://hg.sr.ht/~naryl/qsp-txt2web

txt->qsps, remove FOR and IMG, broken LOCAL and LOOP
naryl -
r60:517f9c14 default
parent child Browse files
Show More
Show file before | Show file after | Hide comments
This diff has been collapsed as it changes many lines, (1134 lines changed) Show them Hide them
@@ -0,0 +1,1134 b''
1 <!DOCTYPE html>
2 <html><head><title>txt2web</title></head><body>
3 <div id="qsp">
4 <div class="qsp-col qsp-col1">
5 <div id="qsp-main" class="qsp-frame">&zwnj;</div>
6 <div id="qsp-acts" class="qsp-frame">&zwnj;</div>
7 <input id="qsp-input" class="qsp-frame">
8 </div>
9 <div class="qsp-col qsp-col2">
10 <div id="qsp-stat" class="qsp-frame">&zwnj;</div>
11 <div id="qsp-objs" class="qsp-frame">&zwnj;</div>
12 </div>
13 <div class="qsp-col qsp-col3">
14 <a id="qsp-btn-save"><img></a>
15 <a id="qsp-btn-open"><img></a>
16 </div>
17 </div>
18
19 <div id="qsp-dropdown">
20 </div>
21
22 <div id="qsp-image-container" class="center-on-screen">
23 <img id="qsp-image">
24 </div>
25
26 <style id="qsp-style">
27 </style>
28 <style>
29 .qsp-frame {
30 border: 1px solid black;
31 overflow: auto;
32 padding: 5px;
33 box-sizing: border-box;
34 }
35
36 #qsp {
37 position: absolute;
38 display: flex;
39 flex-flow: row;
40 top: 0;
41 left: 0;
42 width: 100%;
43 height: 100%;
44 }
45
46 .qsp-col {
47 display: flex;
48 flex-flow: column;
49 }
50
51 .qsp-col1 {
52 flex: 7 7 70px;
53 }
54
55 .qsp-col2 {
56 flex: 3 3 30px;
57 }
58
59 .qsp-col3 {
60 flex: 0 0 40px;
61 }
62
63 #qsp-main {
64 flex: 6 6 60px;
65 background-repeat: no-repeat;
66 background-position: right top;
67 background-attachment: fixed;
68 }
69
70 #qsp-acts {
71 flex: 4 4 40px;
72 }
73
74 #qsp-input {
75 }
76
77 #qsp-stat {
78 flex: 5 5 50px;
79 }
80
81 #qsp-objs {
82 flex: 5 5 50px;
83 }
84
85 .qsp-act {
86 display: block;
87 padding: 2px;
88 font-size: large;
89 }
90
91 .qsp-act:hover {
92 outline: #9E9E9E outset 3px
93 }
94
95 /* Dropdown */
96
97 #qsp-dropdown {
98 display: none;
99 position: absolute;
100 background-color: #f1f1f1;
101 min-width: 160px;
102 overflow: auto;
103 box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2);
104 z-index: 1;
105 margin: auto;
106 }
107
108 #qsp-dropdown a {
109 color: black;
110 padding: 12px 16px;
111 text-decoration: none;
112 display: block;
113 }
114
115 #qsp-dropdown a:hover {
116 background-color: #ddd;
117 }
118
119 /* Buttons */
120
121 .qsp-col3 a, .qsp-col3 img {
122 width: 50px;
123 height: 50px;
124 }
125
126 #qsp-btn-save img {
127 background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACSklEQVRoge3ZPWgUQRjG8V/iRRFU/GoEQdSohSgWWqQSooVgK9iJFiKCnYV2BkFQsBRBQQwWVsHKIoWxEOzEwmhhogbRMhhFicTvYm+JCUlmZzabRLN/OPaWeZ+ZeW7feXf2lpqampqamnRaImKP4hA2VjCP27hbpoNGwbib2IPreB+IPYY7M7SvxWYM4QNO4QqWyQxVRgdeYnnB+K5A+wUcbB7z+O14hxPx08toLRDTgfv4mjrIJFrwwMS0HsABXMTxlE6LpNYqfE7pPJIBdOKhLM1uxIiLrpG5YtC4GSLMVGGkLdD+GpfxAuvxaVL7oCzN+jCG7iKDVmHkKS5hSSBuJ3bg6hRt+Zrpa553z8bEuoQrUVXk1exwKLBI1ZpPBnAL+0KBqanVim1Ykaifji+yNfIrVphipB1n8BgjCfqZ2IrTuIZXMcIUIydxFj8TtEW4JysW52JEKWtkVHUm4EdzjChSrkgLlmJXghb6m8ep9MN4K25XjvTF3sCaElrT6McS+0w2Mirb+JWhrH4CC/0+UpjUK7Ia5/86f4IeHMHeEvPJ+4km1chHE43k9KROpCyLPrViym8/vjW/b5Jt3acjL7/RzEX5bRg3sjKg+2fK7/PmZ9aZzdTqxwYzp06IBZFaDeHUCbFgUquy1Anx35TfRWXkd+WzCBOcQxEjQ7JH0PmiHW9CQUWM9Mr+Y+osO6ME8nF7Q4FFn8T2y14VDMt2vsFfqCRbZBvTdbLXFI9CgphHyjbsVu4+EcMInuH7HI1XU1NTU7OI+QMFe2N82rtssgAAAABJRU5ErkJggg==');
128 }
129
130 #qsp-btn-open img {
131 background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACCklEQVRoge3Yz6sNYRzH8deVexNxSaEoroWFUuomOceSPVnIwsbSxs6Psrgphf9AsrZR7kJWsroUlrZKKZRSl4USGouZk9Npzp1n5pm5x4/nXdNzpvP9Pp/v95nv82OGRCKRSCQS/w8zuIn3yGpe37CEQ6sedQk38BA7G/jO4BQ+YEebQZUxVfH/OxzGVSxX2D4o2mO4jmt4jpNFe6d5mPFkRbvQ0H9h6OqUtR33/xXr0celGn4/sYjXoQ5dJ3ILB7AOW2r4bcIj7GsrkEFpXWyrwwbaf15nXWqv6SqK1abuHDmPjV0EMobhBWIZt8cZVu0j2ZDNHF7gblRozdiO49g1zqDOEzmKJ7gcGVQTzmLDSgZ1Eunh2dD9aewpsXtctH3cwzn5ALysoVWlXZvhleMV5ovfU8J363mciAliRLsRg0Q244vfT3A/zgT2cQHbImIY1S4ldPk9Ii+NH8V9H08DfbfiY6BtiHYpoYmMBr4bbwN9YzfVoEELnew9+blpwBv5u0oI9wPtQrUbkWFaXqOzsZ01IFg7pLQOyp/A58igmhCsHZJInYndNsHa/0wiVWTy9/a5NjprQGvag0Qmwd462iGltdQ8lihqlVVIIn/9/CAvrajDWgTRB8VhMt1/aSljVr4RToc6hJTWioe1jujJD4rfQx2qRvuTyX1JuTIh3UQikUgkEhPnF+1xZ9hHnLjAAAAAAElFTkSuQmCC');
132 }
133
134 .center-on-screen {
135 position: absolute;
136 top: 0;
137 left: 0;
138 height: 100%;
139 width: 100%;
140 pointer-events: none;
141 display: flex;
142 justify-content: center;
143 align-items: center;
144 }
145
146 .center-on-screen > * {
147 pointer-events: auto;
148 }
149
150 #qsp-image-container {
151 display: none;
152 }
153
154 /* misc */
155
156 .disable a {
157 pointer-events: none;
158 cursor: default;
159 }
160
161 .qsp-objs li.qsp-obj-selected {
162 background-color: blue;
163 }
164 </style><script>var qsp_Globals = { };
165 var qsp_Objs = { };
166 var qsp_CurrentLocation = null;
167 var qsp_StartedAt = Date.now();
168 var qsp_TimerInterval = 500;
169 var qsp_TimerObj = null;
170 var qsp_LoadedGames = [];
171 var qsp_Acts = { };
172 var qsp_StateStash = { };
173 var qsp_Playing = { };
174 var qsp_Locals = [];
175 var qsp_MenuResume = null;
176 var qsp_Games = [];
177 var qsp_MainGame = null;
178 var qsp_Locs = { };
179 window.onload = qsp_start;
180 function qsp_start() {
181 qsp_api_initDom();
182 qsp_StartedAt = Date.now();
183 qsp_api_setTimer(qsp_TimerInterval);
184 qsp_api_runGame(Object.keys(qsp_Games)[0]);
185 __PS_MV_REG = [];
186 return;
187 };
188 function qsp_byId(qsp_id) {
189 return document.getElementById(qsp_id);
190 };
191
192 function qsp_api_makeActHtml(qsp_api_title, qsp_api_img) {
193 return '<a class=\'qsp-act\' href=\'' + ('javascript:' + ('qsp_api_callAct' + '(\"' + qsp_api_title + '\");')) + '\' onmouseover=\'' + ('qsp_api_selectAct' + '(\"' + qsp_api_title + '\");') + '\'>' + (qsp_api_img ? '<img src=\'' + qsp_api_img + '\'>' : '') + qsp_api_title + '</a>';
194 };
195 function qsp_api_makeMenuItemHtml(qsp_api_num, qsp_api_title, qsp_api_img, qsp_api_loc) {
196 return '<a href=\'' + ('javascript:' + ('qsp_api_finishMenu' + '(\"' + qsp_api_loc + '\");')) + '\'>' + (qsp_api_img ? '<img src=\'' + qsp_api_img + '\'>' : '') + qsp_api_title + '</a>';
197 };
198 function qsp_api_makeObj(qsp_api_title, qsp_api_img, qsp_api_selected) {
199 return '<li onclick=\'' + ('qsp_api_selectObj' + '(\"' + qsp_api_title + '\", \"' + qsp_api_img + '\");') + '\'>' + '<a class=\'qsp-obj' + (qsp_api_selected ? ' qsp-obj-selected' : '') + '\'>' + (qsp_api_img ? '<img src=\'' + qsp_api_img + '\'>' : '') + qsp_api_title + '</a>';
200 };
201 function qsp_api_makeMenuDelimiter() {
202 return '<hr>';
203 };
204 function qsp_api_copyObj(qsp_api_obj) {
205 return JSON.parse(JSON.stringify(qsp_api_obj));
206 };
207 function qsp_api_reportError(qsp_api_text) {
208 __PS_MV_REG = [];
209 return alert(qsp_api_text);
210 };
211 function qsp_api_startSleeping() {
212 __PS_MV_REG = [];
213 return qsp_byId('qsp').classList.add('disable');
214 };
215 function qsp_api_finishSleeping() {
216 __PS_MV_REG = [];
217 return qsp_byId('qsp').classList.remove('disable');
218 };
219 function sleep(qsp_api_msec) {
220 __PS_MV_REG = [];
221 return new Promise(function (qsp_api_resolve) {
222 qsp_api_startSleeping();
223 var qsp_api_resume = function () {
224 qsp_api_finishSleeping();
225 __PS_MV_REG = [];
226 return qsp_api_resolve();
227 };
228 __PS_MV_REG = [];
229 return setTimeout(qsp_api_resume, qsp_api_msec);
230 });
231 };
232 function qsp_api_initDom() {
233 var qsp_api_btn = qsp_byId('qsp-btn-save');
234 qsp_api_btn.onclick = qsp_api_savegame;
235 qsp_api_btn.href = '#';
236 var btn1 = qsp_byId('qsp-btn-open');
237 btn1.onclick = qsp_api_opengame;
238 btn1.href = '#';
239 qsp_byId('qsp-image-container').onclick = qsp_api_showImage;
240 qsp_api_getFrame('input').qsp_api_onkeyup = qsp_api_onInputKey;
241 __PS_MV_REG = [];
242 return window.onclick = function (qsp_api_event) {
243 window.qsp_api_mouse = [qsp_api_event.pageX, qsp_api_event.pageY];
244 __PS_MV_REG = [];
245 return qsp_api_finishMenu(null);
246 };
247 };
248 function qsp_api_callServLoc(qsp_api_varName) {
249 var qsp_api_args = Array.prototype.slice.call(arguments, 1);
250 var qsp_api_locName = qsp_api_getGlobal(qsp_api_varName, 0);
251 if (qsp_api_locName) {
252 var qsp_api_loc = qsp_Locs[qsp_api_locName];
253 __PS_MV_REG = [];
254 return qsp_api_loc ? qsp_api_callLoc(qsp_api_locName, qsp_api_args) : null;
255 };
256 };
257 function qsp_api_filenameGame(qsp_api_filename) {
258 var qsp_api_gameName = qsp_api_filename.match('(.*/)?([^.]+)(\\.[a-zA-Z]+)?')[2];
259 return qsp_Games[qsp_api_gameName];
260 };
261 function qsp_api_runGame(qsp_api_name) {
262 var qsp_api_game = qsp_api_filenameGame(qsp_api_name);
263 qsp_MainGame = qsp_api_name;
264 qsp_Locs = qsp_api_game;
265 __PS_MV_REG = [];
266 return qsp_api_game[Object.keys(qsp_api_game)[0]]([]);
267 };
268 function qsp_api_newline(qsp_api_key) {
269 __PS_MV_REG = [];
270 return qsp_api_appendId(qsp_api_keyToId(qsp_api_key), '<br>', true);
271 };
272 function qsp_api_clearId(qsp_api_id) {
273 __PS_MV_REG = [];
274 return qsp_byId(qsp_api_id).innerHTML = '';
275 };
276 function qsp_api_escapeHtml(qsp_api_text) {
277 return qsp_api_text.replace(/&/g, '&amp;').replace(/</g, '&lt;').replace(/>/g, '&gt;').replace(/"/g, '&quot;').replace(/'/g, '&apos;');
278 };
279 function qsp_api_prepareContents(qsp_api_s, qsp_api_forceHtml) {
280 qsp_api_s = qsp_api_s.toString();
281 __PS_MV_REG = [];
282 return qsp_api_forceHtml || qsp_api_getGlobal('USEHTML', 0) ? qsp_api_s : qsp_api_escapeHtml(qsp_api_s);
283 };
284 function qsp_api_getId(qsp_api_id, qsp_api_forceHtml) {
285 __PS_MV_REG = [];
286 return qsp_byId(qsp_api_id).innerHTML;
287 };
288 function qsp_api_setId(qsp_api_id, qsp_api_contents, qsp_api_forceHtml) {
289 __PS_MV_REG = [];
290 return qsp_byId(qsp_api_id).innerHTML = qsp_api_prepareContents(qsp_api_contents, qsp_api_forceHtml);
291 };
292 function qsp_api_appendId(qsp_api_id, qsp_api_contents, qsp_api_forceHtml) {
293 __PS_MV_REG = [];
294 return qsp_api_contents ? (qsp_byId(qsp_api_id).innerHTML += qsp_api_prepareContents(qsp_api_contents, qsp_api_forceHtml)) : null;
295 };
296 function qsp_api_onInputKey(qsp_api_ev) {
297 if (13 === qsp_api_ev.qsp_api_keyCode) {
298 qsp_api_ev.qsp_api_preventDefault();
299 __PS_MV_REG = [];
300 return qsp_api_callServLoc('$USERCOM');
301 };
302 };
303 function qsp_api_initArgs(qsp_api_args) {
304 for (var qsp_api_i = 0; qsp_api_i < qsp_api_args.length; qsp_api_i += 1) {
305 var qsp_api_arg = qsp_api_args[qsp_api_i];
306 if (typeof qsp_api_arg === 'number') {
307 qsp_api_setVar(qsp_api_args, qsp_api_i, 'num', qsp_api_arg);
308 } else {
309 qsp_api_setVar(qsp_api_args, qsp_api_i, 'str', qsp_api_arg);
310 };
311 };
312 };
313 function qsp_api_getResult() {
314 __PS_MV_REG = [];
315 return qsp_api_getGlobal('$RESULT', 0) || qsp_api_getGlobal('RESULT', 0);
316 };
317 function qsp_api_callLoc(qsp_api_name, qsp_api_args) {
318 qsp_api_name = qsp_api_name.toUpperCase();
319 qsp_api_pushLocalFrame();
320 try {
321 qsp_api_initArgs(qsp_api_args);
322 qsp_Locs[qsp_api_name]();
323 qsp_api_getResult();
324 } finally {
325 qsp_api_popLocalFrame();
326 };
327 };
328 function qsp_api_callAct(qsp_api_title) {
329 qsp_api_pushLocalFrame();
330 try {
331 qsp_Acts[qsp_api_title]['act']();
332 } finally {
333 qsp_api_popLocalFrame();
334 };
335 };
336 function qsp_api_keyToId(qsp_api_key) {
337 switch (qsp_api_key) {
338 case 'all':
339 return 'qsp';
340 case 'main':
341 return 'qsp-main';
342 case 'stat':
343 return 'qsp-stat';
344 case 'objs':
345 return 'qsp-objs';
346 case 'acts':
347 return 'qsp-acts';
348 case 'input':
349 return 'qsp-input';
350 case 'image':
351 return 'qsp-image';
352 case 'dropdown':
353 return 'qsp-dropdown';
354 default:
355 __PS_MV_REG = [];
356 return qsp_api_reportError('Internal error!');
357 };
358 };
359 function qsp_api_getFrame(qsp_api_key) {
360 __PS_MV_REG = [];
361 return qsp_byId(qsp_api_keyToId(qsp_api_key));
362 };
363 function qsp_api_addText(qsp_api_key, qsp_api_text) {
364 __PS_MV_REG = [];
365 return qsp_api_appendId(qsp_api_keyToId(qsp_api_key), qsp_api_text);
366 };
367 function qsp_api_getText(qsp_api_key) {
368 __PS_MV_REG = [];
369 return qsp_api_getId(qsp_api_keyToId(qsp_api_key));
370 };
371 function qsp_api_clearText(qsp_api_key) {
372 __PS_MV_REG = [];
373 return qsp_api_clearId(qsp_api_keyToId(qsp_api_key));
374 };
375 function qsp_api_enableFrame(qsp_api_key, qsp_api_enable) {
376 var qsp_api_obj = qsp_api_getFrame(qsp_api_key);
377 qsp_api_obj.style.display = qsp_api_enable ? 'block' : 'none';
378 };
379 function qsp_api_addAct(qsp_api_title, qsp_api_img, qsp_api_act) {
380 qsp_Acts[qsp_api_title] = { 'title' : qsp_api_title,
381 'img' : qsp_api_img,
382 'act' : qsp_api_act,
383 'selected' : null
384 };
385 __PS_MV_REG = [];
386 return qsp_api_updateActs();
387 };
388 function qsp_api_delAct(qsp_api_title) {
389 delete qsp_Acts[qsp_api_title];
390 __PS_MV_REG = [];
391 return qsp_api_updateActs();
392 };
393 function qsp_api_clearAct() {
394 qsp_Acts = { };
395 __PS_MV_REG = [];
396 return qsp_api_updateActs();
397 };
398 function qsp_api_updateActs() {
399 qsp_api_clearId('qsp-acts');
400 var elt = qsp_byId('qsp-acts');
401 for (var qsp_api_title in qsp_Acts) {
402 var qsp_api_obj = qsp_Acts[qsp_api_title];
403 elt.innerHTML += qsp_api_makeActHtml(qsp_api_title, qsp_api_obj['img']);
404 };
405 };
406 function qsp_api_selectAct(qsp_api_title) {
407 for (var qsp_api_k in qsp_Acts) {
408 var qsp_api_v = qsp_Acts[qsp_api_k];
409 qsp_api_v['selected'] = null;
410 };
411 qsp_Acts[qsp_api_title]['selected'] = true;
412 __PS_MV_REG = [];
413 return qsp_api_callServLoc('$ONACTSEL');
414 };
415 function qsp_api_qspfor(qsp_api_name, qsp_api_index, qsp_api_from, qsp_api_to, step, body) {
416 for (var qsp_api_i = qsp_api_from; qsp_api_i <= qsp_api_to; qsp_api_i += step) {
417 qsp_api_setVar(qsp_api_name, qsp_api_index, 'num', qsp_api_i);
418 if (!await (body())) {
419 __PS_MV_REG = [];
420 return;
421 };
422 };
423 };
424 function qsp_api_newVar(qsp_api_slot) {
425 var qsp_api_indexes = Array.prototype.slice.call(arguments, 1);
426 var qsp_api_v = [];
427 for (var qsp_api_index = null, _js_idx2 = 0; _js_idx2 < qsp_api_indexes.length; _js_idx2 += 1) {
428 qsp_api_index = qsp_api_indexes[_js_idx2];
429 qsp_api_v[qsp_api_index] = '$' === qsp_api_slot[0] ? '' : 0;
430 };
431 qsp_api_v['indexes'] = { };
432 __PS_MV_REG = [];
433 return qsp_api_v;
434 };
435 function qsp_api_setStrElement(qsp_api_slot, qsp_api_index, qsp_api_value) {
436 if (qsp_api_slot['indexes'].hasOwnProperty(qsp_api_index)) {
437 qsp_api_slot[null][qsp_api_slot['indexes'][qsp_api_index]] = qsp_api_value;
438 } else {
439 qsp_api_slot.push(qsp_api_value);
440 qsp_api_slot[qsp_api_index] = qsp_api_slot.length;
441 };
442 };
443 function qsp_api_setAnyElement(qsp_api_slot, qsp_api_index, qsp_api_value) {
444 if (qsp_api_index == null) {
445 qsp_api_slot.push(qsp_api_value);
446 } else if (typeof qsp_api_index === 'number') {
447 qsp_api_slot[qsp_api_index] = qsp_api_value;
448 } else if (typeof qsp_api_index === 'string') {
449 qsp_api_setStrElement(qsp_api_slot, qsp_api_index, qsp_api_value);
450 } else {
451 qsp_api_reportError('INTERNAL ERROR');
452 };
453 };
454 function qsp_api_setServVar(qsp_api_name, qsp_api_index, qsp_api_value) {
455 var qsp_api_slot = qsp_Globals[qsp_api_name];
456 qsp_api_setAnyElement(qsp_api_slot, qsp_api_index, qsp_api_value);
457 qsp_api_servVars[qsp_api_name]['body'](qsp_api_value, qsp_api_index);
458 };
459 function qsp_api_getElement(qsp_api_slot, qsp_api_index) {
460 return typeof qsp_api_index === 'number' ? qsp_api_slot[qsp_api_index] : qsp_api_slot[qsp_api_slot['indexes'][qsp_api_index]];
461 };
462 function qsp_api_getGlobal(qsp_api_name, qsp_api_index) {
463 return qsp_Globals[qsp_api_name][qsp_api_index];
464 };
465 function qsp_api_killVar(qsp_api_store, qsp_api_name, qsp_api_index) {
466 qsp_api_name = qsp_api_name.toUpperCase();
467 if (qsp_api_index && 0 !== qsp_api_index) {
468 qsp_Globals[qsp_api_name].qsp_api_kill(qsp_api_index);
469 } else {
470 delete qsp_Globals[qsp_api_name];
471 };
472 };
473 function qsp_api_arraySize(qsp_api_name) {
474 __PS_MV_REG = [];
475 return qsp_api_varRef(qsp_api_name)['values'].length;
476 };
477 function qsp_api_pushLocalFrame() {
478 qsp_Locals.push({ });
479 };
480 function qsp_api_popLocalFrame() {
481 qsp_Locals.pop();
482 };
483 function qsp_api_currentLocalFrame() {
484 return qsp_Locals[qsp_Locals.length - 1];
485 };
486 function qsp_api_selectObj(qsp_api_title, qsp_api_img) {
487 for (var qsp_api_k in qsp_Objs) {
488 var qsp_api_v = qsp_Objs[qsp_api_k];
489 qsp_api_v['selected'] = null;
490 };
491 qsp_Objs[qsp_api_title]['selected'] = true;
492 __PS_MV_REG = [];
493 return qsp_api_callServLoc('$ONOBJSEL', qsp_api_title, qsp_api_img);
494 };
495 function qsp_api_updateObjs() {
496 var elt = qsp_byId('qsp-objs');
497 elt.innerHTML = '<ul>';
498 for (var qsp_api_name in qsp_Objs) {
499 var qsp_api_obj = qsp_Objs[qsp_api_name];
500 elt.innerHTML += qsp_api_makeObj(qsp_api_name, qsp_api_obj['img'], qsp_api_obj['selected']);
501 };
502 __PS_MV_REG = [];
503 return elt.innerHTML += '</ul>';
504 };
505 function qsp_api_openMenu(qsp_api_menuData) {
506 var elt = qsp_api_getFrame('dropdown');
507 var qsp_api_i = 0;
508 var _js4 = qsp_api_menuData.length;
509 for (var _js3 = 0; _js3 < _js4; _js3 += 1) {
510 var qsp_api_item = qsp_api_menuData[_js3];
511 ++qsp_api_i;
512 elt.innerHTML += qsp_api_item === 'delimiter' ? qsp_api_makeMenuDelimiter(qsp_api_i) : qsp_api_makeMenuItemHtml(qsp_api_i, qsp_api_item['text'], qsp_api_item['icon'], qsp_api_item['loc']);
513 };
514 var mouse5 = window.qsp_api_mouse;
515 elt.style.left = mouse5[0] + 'px';
516 elt.style.top = mouse5[1] + 'px';
517 if (document.body.qsp_api_innerWidth > mouse5[0] + elt.qsp_api_innerWidth) {
518 elt.style.left += elt.qsp_api_innerWidth;
519 };
520 if (document.body.qsp_api_innerHeight > mouse5[0] + elt.qsp_api_innerHeight) {
521 elt.style.top += elt.qsp_api_innerHeight;
522 };
523 __PS_MV_REG = [];
524 return elt.style.display = 'block';
525 };
526 function qsp_api_finishMenu(qsp_api_loc) {
527 if (qsp_MenuResume) {
528 var elt = qsp_api_getFrame('dropdown');
529 elt.innerHTML = '';
530 elt.style.display = 'none';
531 qsp_MenuResume();
532 qsp_MenuResume = null;
533 if (qsp_api_loc) {
534 qsp_api_callLoc(qsp_api_loc);
535 };
536 };
537 };
538 function qsp_api_menu(qsp_api_menuData) {
539 new Promise(function (qsp_api_resolve) {
540 qsp_api_startSleeping();
541 var qsp_api_resume = function () {
542 qsp_api_finishSleeping();
543 __PS_MV_REG = [];
544 return qsp_api_resolve();
545 };
546 qsp_api_openMenu(qsp_api_menuData);
547 __PS_MV_REG = [];
548 return qsp_MenuResume = qsp_api_resume;
549 });
550 };
551 function qsp_api_cleanAudio() {
552 var _js6 = Object.keys(qsp_Playing);
553 var _js8 = _js6.length;
554 for (var _js7 = 0; _js7 < _js8; _js7 += 1) {
555 var qsp_api_k = _js6[_js7];
556 var qsp_api_v = qsp_Playing[qsp_api_k];
557 if (qsp_api_v.qsp_api_ended) {
558 delete qsp_Playing.qsp_api_k;
559 };
560 };
561 };
562 function qsp_api_showImage(qsp_api_path) {
563 var qsp_api_img = qsp_api_getFrame('image');
564 if (qsp_api_path) {
565 qsp_api_img.src = qsp_api_path;
566 __PS_MV_REG = [];
567 return qsp_api_img.style.display = 'flex';
568 } else {
569 qsp_api_img.src = '';
570 __PS_MV_REG = [];
571 return qsp_api_img.style.display = 'hidden';
572 };
573 };
574 function qsp_api_showInlineImages(qsp_api_frameName, qsp_api_images) {
575 var qsp_api_frame = qsp_api_getFrame(qsp_api_frameName);
576 var qsp_api_text = '';
577 qsp_api_text += '<div style=\'position:relative; display: inline-block\'>';
578 qsp_api_text += '<img src=\'' + qsp_api_images[0] + '\'>';
579 var _js9 = qsp_api_images.slice(1);
580 var _js11 = _js9.length;
581 for (var _js10 = 0; _js10 < _js11; _js10 += 1) {
582 var qsp_api_image = _js9[_js10];
583 qsp_api_text += '<img style=\'position:absolute\' src=\'' + qsp_api_image + '\'>';
584 };
585 qsp_api_text += '</div>';
586 __PS_MV_REG = [];
587 return qsp_api_frame.innerHTML += qsp_api_text;
588 };
589 function qsp_api_rgbString(qsp_api_rgb) {
590 var qsp_api_red = qsp_api_rgb >> 16;
591 var qsp_api_green = qsp_api_rgb >> 8 & 255;
592 var qsp_api_blue = qsp_api_rgb & 255;
593 var qsp_api_rgbToHex = function (qsp_api_comp) {
594 var qsp_api_hex = Number(qsp_api_comp).toString(16);
595 __PS_MV_REG = [];
596 return qsp_api_hex.length < 2 ? '0' + qsp_api_hex : qsp_api_hex;
597 };
598 __PS_MV_REG = [];
599 return '#' + qsp_api_rgbToHex(qsp_api_red) + qsp_api_rgbToHex(qsp_api_green) + qsp_api_rgbToHex(qsp_api_blue);
600 };
601 function qsp_api_storeObj(qsp_api_key, qsp_api_obj) {
602 qsp_api_storeStr(qsp_api_key, btoa(encodeURIComponent(JSON.stringify(qsp_api_obj))));
603 };
604 function qsp_api_storeStr(qsp_api_key, qsp_api_str) {
605 localStorage.setItem('qsp_' + qsp_api_key, qsp_api_str);
606 };
607 function qsp_api_loadObj(qsp_api_key) {
608 __PS_MV_REG = [];
609 return JSON.parse(encodeURIComponent(atob(qsp_api_loadStr(qsp_api_key))));
610 };
611 function qsp_api_loadStr(qsp_api_key) {
612 return localStorage.getItem('qsp_' + qsp_api_key);
613 };
614 function qsp_api_slotSavegame(qsp_api_slot, qsp_api_comment) {
615 var qsp_api_saves = qsp_api_loadObj('saves');
616 qsp_api_saves.qsp_api_slot = qsp_api_comment;
617 qsp_api_storeObj(qsp_api_saves);
618 qsp_api_storeStr(qsp_api_slot, qsp_api_stateToBase64());
619 };
620 function qsp_api_slotLoadgame(qsp_api_slot) {
621 qsp_api_base64ToState(qsp_api_loadStr(qsp_api_slot));
622 };
623 function qsp_api_slotDeletegame(qsp_api_slot) {
624 var qsp_api_saves = qsp_api_loadObj('saves');
625 qsp_api_saves.qsp_api_slot = undefined;
626 qsp_api_storeObj(qsp_api_saves);
627 qsp_api_storeStr(qsp_api_slot, undefined);
628 };
629 function qsp_api_slotListgames() {
630 __PS_MV_REG = [];
631 return qsp_api_loadObj('saves');
632 };
633 function qsp_api_opengame() {
634 var qsp_api_element = document.createElement('input');
635 qsp_api_element.setAttribute('type', 'file');
636 qsp_api_element.setAttribute('id', 'qsp-opengame');
637 qsp_api_element.setAttribute('tabindex', -1);
638 qsp_api_element.setAttribute('aria-hidden', true);
639 qsp_api_element.style.display = 'block';
640 qsp_api_element.style.qsp_api_visibility = 'hidden';
641 qsp_api_element.style.position = 'fixed';
642 qsp_api_element.onchange = function (qsp_api_event) {
643 var qsp_api_file = qsp_api_event.target.files[0];
644 var qsp_api_reader = new FileReader();
645 qsp_api_reader.onload = function (qsp_api_ev) {
646 var target = qsp_api_ev.currentTarget;
647 if (!target.result) {
648 return null;
649 };
650 qsp_api_base64ToState(target.result);
651 __PS_MV_REG = [];
652 return qsp_api_unstashState();
653 };
654 __PS_MV_REG = [];
655 return qsp_api_reader.readAsText(qsp_api_file);
656 };
657 document.body.appendChild(qsp_api_element);
658 qsp_api_element.click();
659 return document.body.removeChild(qsp_api_element);
660 };
661 function qsp_api_savegame() {
662 var qsp_api_element = document.createElement('a');
663 qsp_api_element.setAttribute('href', 'data:text/plain;charset=utf-8,' + qsp_api_stateToBase64());
664 qsp_api_element.setAttribute('download', 'savegame.sav');
665 qsp_api_element.style.display = 'none';
666 document.body.appendChild(qsp_api_element);
667 qsp_api_element.click();
668 __PS_MV_REG = [];
669 return document.body.removeChild(qsp_api_element);
670 };
671 function qsp_api_stashState(qsp_api_args) {
672 qsp_api_callServLoc('$ONGSAVE');
673 qsp_StateStash = JSON.stringify({ 'vars' : qsp_Globals,
674 'objs' : qsp_Objs,
675 'loc-args' : qsp_api_args,
676 'msecs' : Date.now() - qsp_StartedAt,
677 'timer-interval' : qsp_TimerInterval,
678 'main-html' : qsp_api_getFrame('main').innerHTML,
679 'stat-html' : qsp_api_getFrame('stat').innerHTML,
680 'next-location' : qsp_CurrentLocation
681 });
682 };
683 function qsp_api_unstashState() {
684 var qsp_api_data = JSON.parse(qsp_StateStash);
685 qsp_api_clearAct();
686 qsp_Globals = qsp_api_data['vars'];
687 var _js12 = Object.keys(qsp_Globals);
688 var _js14 = _js12.length;
689 for (var _js13 = 0; _js13 < _js14; _js13 += 1) {
690 var qsp_api_k = _js12[_js13];
691 Object.setPrototypeOf(qsp_Globals[qsp_api_k], qsp_api_Var.prototype);
692 };
693 qsp_StartedAt = Date.now() - qsp_api_data['msecs'];
694 qsp_Objs = qsp_api_data['objs'];
695 qsp_CurrentLocation = qsp_api_data['next-location'];
696 qsp_api_getFrame('main').innerHTML = qsp_api_data['main-html'];
697 qsp_api_getFrame('stat').innerHTML = qsp_api_data['stat-html'];
698 qsp_api_updateObjs();
699 qsp_api_setTimer(qsp_api_data['timer-interval']);
700 qsp_api_callServLoc('$ONGLOAD');
701 qsp_api_callLoc(qsp_CurrentLocation, qsp_api_data['loc-args']);
702 };
703 function qsp_api_stateToBase64() {
704 __PS_MV_REG = [];
705 return btoa(encodeURIComponent(qsp_StateStash));
706 };
707 function qsp_api_base64ToState(qsp_api_data) {
708 __PS_MV_REG = [];
709 return qsp_StateStash = decodeURIComponent(atob(qsp_api_data));
710 };
711 function qsp_api_setTimer(qsp_api_interval) {
712 qsp_TimerInterval = qsp_api_interval;
713 clearInterval(qsp_TimerObj);
714 __PS_MV_REG = [];
715 return qsp_TimerObj = setInterval(function () {
716 __PS_MV_REG = [];
717 return qsp_api_callServLoc('$COUNTER');
718 }, qsp_api_interval);
719 };
720 if ('undefined' === typeof qsp_api_servVars) {
721 var qsp_api_servVars = { };
722 };
723 qsp_api_servVars['$BACKIMAGE'] = { 'name' : '$BACKIMAGE', 'body' : function (qsp_api_path) {
724 __PS_MV_REG = [];
725 return qsp_api_getFrame('main').style.backgroundImage = qsp_api_path;
726 } };
727 qsp_api_servVars['BCOLOR'] = { 'name' : 'BCOLOR', 'body' : function (color) {
728 __PS_MV_REG = [];
729 return qsp_api_getFrame('all').style.backgroundColor = qsp_api_rgbString(color);
730 } };
731 qsp_api_servVars['FCOLOR'] = { 'name' : 'FCOLOR', 'body' : function (color) {
732 __PS_MV_REG = [];
733 return qsp_api_getFrame('all').style.color = qsp_api_rgbString(color);
734 } };
735 qsp_api_servVars['LCOLOR'] = { 'name' : 'LCOLOR', 'body' : function (color) {
736 __PS_MV_REG = [];
737 return qsp_api_getFrame('style').innerText = 'a { color: ' + qsp_api_rgbString(color) + ';}';
738 } };
739 qsp_api_servVars['FSIZE'] = { 'name' : 'FSIZE', 'body' : function (size) {
740 __PS_MV_REG = [];
741 return qsp_api_getFrame('all').style.fontSize = size;
742 } };
743 qsp_api_servVars['$FNAME'] = { 'name' : '$FNAME', 'body' : function (fontName) {
744 __PS_MV_REG = [];
745 return qsp_api_getFrame('all').style.fontFamily = fontName + ',serif';
746 } };
747
748 function qsp_lib_goto(target, qsp_lib_args) {
749 qsp_api_clearText('main');
750 qsp_lib_xgoto(target, qsp_lib_args);
751 };
752 function qsp_lib_xgoto(target, qsp_lib_args) {
753 qsp_lib_args = qsp_lib_args || [];
754 qsp_api_clearAct();
755 qsp_CurrentLocation = target.toUpperCase();
756 qsp_api_stashState(qsp_lib_args);
757 qsp_api_callLoc(qsp_CurrentLocation, qsp_lib_args);
758 qsp_api_callServLoc('$ONNEWLOC');
759 };
760 function qsp_lib_obj(qsp_lib_name) {
761 return qsp_Objs.hasOwnProperty(qsp_lib_name);
762 };
763 function qsp_lib_loc(qsp_lib_name) {
764 return qsp_Locs.hasOwnProperty(qsp_lib_name);
765 };
766 function qsp_lib_rand(qsp_lib_a, qsp_lib_b) {
767 if (qsp_lib_b === undefined) {
768 qsp_lib_b = 1;
769 };
770 var min15 = Math.min(qsp_lib_a, qsp_lib_b);
771 var max16 = Math.max(qsp_lib_a, qsp_lib_b);
772 __PS_MV_REG = [];
773 return min15 + qsp_lib_Math.random(max16 - min15);
774 };
775 function qsp_lib_copyarr(qsp_lib_to, qsp_lib_from, qsp_lib_start, count) {
776 __PS_MV_REG = [];
777 var qsp_lib_toName = qsp_api_varRealName(qsp_lib_to);
778 var qsp_lib_toSlot = __PS_MV_REG[0];
779 __PS_MV_REG = [];
780 var qsp_lib_fromName = qsp_api_varRealName(qsp_lib_from);
781 var qsp_lib_fromSlot = __PS_MV_REG[0];
782 var _js17 = Math.min(qsp_api_arraySize(qsp_lib_fromName), qsp_lib_start + count);
783 for (var qsp_lib_i = qsp_lib_start; qsp_lib_i <= _js17; qsp_lib_i += 1) {
784 qsp_api_setVar(qsp_lib_toName, qsp_lib_start + qsp_lib_i, qsp_lib_toSlot, qsp_api_getVar(qsp_lib_fromName, qsp_lib_start + qsp_lib_i, qsp_lib_fromSlot));
785 };
786 };
787 function qsp_lib_arrpos(qsp_lib_name, qsp_lib_value, qsp_lib_start) {
788 if (qsp_lib_start === undefined) {
789 qsp_lib_start = 0;
790 };
791 __PS_MV_REG = [];
792 var qsp_lib_realName = qsp_api_varRealName(qsp_lib_name);
793 var qsp_lib_slot = __PS_MV_REG[0];
794 var _js18 = qsp_api_arraySize(qsp_lib_name);
795 for (var qsp_lib_i = qsp_lib_start; qsp_lib_i <= _js18; qsp_lib_i += 1) {
796 if (qsp_api_getVar(qsp_lib_realName, qsp_lib_i, qsp_lib_slot) === qsp_lib_value) {
797 __PS_MV_REG = [];
798 return qsp_lib_i;
799 };
800 };
801 __PS_MV_REG = [];
802 return -1;
803 };
804 function qsp_lib_arrcomp(qsp_lib_name, qsp_lib_pattern, qsp_lib_start) {
805 if (qsp_lib_start === undefined) {
806 qsp_lib_start = 0;
807 };
808 __PS_MV_REG = [];
809 var qsp_lib_realName = qsp_api_varRealName(qsp_lib_name);
810 var qsp_lib_slot = __PS_MV_REG[0];
811 var _js19 = qsp_api_arraySize(qsp_lib_name);
812 for (var qsp_lib_i = qsp_lib_start; qsp_lib_i <= _js19; qsp_lib_i += 1) {
813 if (qsp_api_getVar(qsp_lib_realName, qsp_lib_i, qsp_lib_slot).match(qsp_lib_pattern)) {
814 __PS_MV_REG = [];
815 return qsp_lib_i;
816 };
817 };
818 __PS_MV_REG = [];
819 return -1;
820 };
821 function qsp_lib_instr(qsp_lib_s, qsp_lib_subs, qsp_lib_start) {
822 if (qsp_lib_start === undefined) {
823 qsp_lib_start = 1;
824 };
825 return qsp_lib_start + qsp_lib_s.qsp_lib_substring(qsp_lib_start - 1).search(qsp_lib_subs);
826 };
827 function qsp_lib_isnum(qsp_lib_s) {
828 __PS_MV_REG = [];
829 return qsp_lib_isNaN(qsp_lib_s) ? 0 : -1;
830 };
831 function qsp_lib_strcomp(qsp_lib_s, qsp_lib_pattern) {
832 return qsp_lib_s.match(qsp_lib_pattern) ? -1 : 0;
833 };
834 function qsp_lib_strfind(qsp_lib_s, qsp_lib_pattern, qsp_lib_group) {
835 var qsp_lib_re = new qsp_lib_RegExp(qsp_lib_pattern);
836 var match = qsp_lib_re.qsp_lib_exec(qsp_lib_s);
837 __PS_MV_REG = [];
838 return match.qsp_lib_group(qsp_lib_group);
839 };
840 function qsp_lib_strpos(qsp_lib_s, qsp_lib_pattern, qsp_lib_group) {
841 if (qsp_lib_group === undefined) {
842 qsp_lib_group = 0;
843 };
844 var qsp_lib_re = new qsp_lib_RegExp(qsp_lib_pattern);
845 var match = qsp_lib_re.qsp_lib_exec(qsp_lib_s);
846 var qsp_lib_found = match.qsp_lib_group(qsp_lib_group);
847 __PS_MV_REG = [];
848 return qsp_lib_found ? qsp_lib_s.search(qsp_lib_found) : 0;
849 };
850 function qsp_lib_iif(qsp_lib_condExpr, qsp_lib_thenExpr, qsp_lib_elseExpr) {
851 return qsp_lib_condExpr ? qsp_lib_thenExpr : qsp_lib_elseExpr;
852 };
853 function qsp_lib_gosub(target) {
854 var qsp_lib_args = Array.prototype.slice.call(arguments, 1);
855 qsp_api_callLoc(target, qsp_lib_args);
856 };
857 function qsp_lib_func(target) {
858 var qsp_lib_args = Array.prototype.slice.call(arguments, 1);
859 __PS_MV_REG = [];
860 return qsp_api_callLoc(target, qsp_lib_args);
861 };
862 function qsp_lib_dynamic(block) {
863 var qsp_lib_args = Array.prototype.slice.call(arguments, 1);
864 if (typeof block === 'string') {
865 qsp_api_reportError('DYNAMIC can\'t evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC.');
866 };
867 qsp_api_initArgs(qsp_lib_args);
868 block(qsp_lib_args);
869 qsp_api_getResult();
870 };
871 function qsp_lib_dyneval(block) {
872 var qsp_lib_args = Array.prototype.slice.call(arguments, 1);
873 if (typeof block === 'string') {
874 qsp_api_reportError('DYNEVAL can\'t evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL.');
875 };
876 qsp_api_initArgs(qsp_lib_args);
877 block(qsp_lib_args);
878 __PS_MV_REG = [];
879 return qsp_api_getResult();
880 };
881 function qsp_lib_mainP(qsp_lib_s) {
882 qsp_api_addText('main', qsp_lib_s);
883 };
884 function qsp_lib_mainPl(qsp_lib_s) {
885 qsp_api_addText('main', qsp_lib_s);
886 qsp_api_newline('main');
887 };
888 function qsp_lib_mainNl(qsp_lib_s) {
889 qsp_api_newline('main');
890 qsp_api_addText('main', qsp_lib_s);
891 };
892 function qsp_lib_maintxt(qsp_lib_s) {
893 qsp_api_getText('main');
894 };
895 function qsp_lib_desc(qsp_lib_s) {
896 return '';
897 };
898 function qsp_lib_mainClear() {
899 qsp_api_clearText('main');
900 };
901 function qsp_lib_statP(qsp_lib_s) {
902 qsp_api_addText('stat', qsp_lib_s);
903 };
904 function qsp_lib_statPl(qsp_lib_s) {
905 qsp_api_addText('stat', qsp_lib_s);
906 qsp_api_newline('stat');
907 };
908 function qsp_lib_statNl(qsp_lib_s) {
909 qsp_api_newline('stat');
910 qsp_api_addText('stat', qsp_lib_s);
911 };
912 function qsp_lib_stattxt(qsp_lib_s) {
913 qsp_api_getText('stat');
914 };
915 function qsp_lib_statClear() {
916 qsp_api_clearText('stat');
917 };
918 function qsp_lib_cls() {
919 qsp_lib_statClear();
920 qsp_lib_mainClear();
921 qsp_api_clearAct();
922 qsp_lib_cmdclear();
923 };
924 function qsp_lib_selact() {
925 for (var qsp_lib_k in qsp_Acts) {
926 var qsp_lib_v = qsp_Acts[qsp_lib_k];
927 if (qsp_lib_v['selected']) {
928 return qsp_lib_v['name'];
929 };
930 };
931 };
932 function qsp_lib_curacts() {
933 var qsp_lib_acts = qsp_api_copyObj(qsp_Acts);
934 __PS_MV_REG = [];
935 return function () {
936 qsp_Acts = qsp_lib_acts;
937 };
938 };
939 function qsp_lib_addobj(qsp_lib_name, qsp_lib_img) {
940 qsp_lib_img = qsp_lib_img || '';
941 qsp_Objs[qsp_lib_name] = { 'name' : qsp_lib_name,
942 'img' : qsp_lib_img,
943 'selected' : null
944 };
945 qsp_api_updateObjs();
946 qsp_api_callServLoc('$ONOBJADD', qsp_lib_name, qsp_lib_img);
947 };
948 function qsp_lib_delobj(qsp_lib_name) {
949 delete qsp_Objs[qsp_lib_name];
950 qsp_api_updateObjs();
951 qsp_api_callServLoc('$ONOBJDEL', qsp_lib_name);
952 };
953 function qsp_lib_killobj(qsp_lib_num) {
954 if (null === qsp_lib_num) {
955 qsp_Objs = { };
956 } else {
957 qsp_lib_delobj(Object.keys(qsp_Objs)[qsp_lib_num]);
958 };
959 qsp_api_updateObjs();
960 };
961 function qsp_lib_selobj() {
962 for (var qsp_lib_k in qsp_Objs) {
963 var qsp_lib_v = qsp_Objs[qsp_lib_k];
964 if (qsp_lib_v['selected']) {
965 return qsp_lib_v['name'];
966 };
967 };
968 };
969 function qsp_lib_unsel() {
970 for (var qsp_lib_k in qsp_Objs) {
971 var qsp_lib_v = qsp_Objs[qsp_lib_k];
972 qsp_lib_v['selected'] = null;
973 };
974 };
975 function qsp_lib_menu(qsp_lib_menuName) {
976 var qsp_lib_menuData = [];
977 var _js20 = qsp_api_getArray(qsp_api_varRealName(qsp_lib_menuName)).values;
978 var _js22 = _js20.length;
979 for (var _js21 = 0; _js21 < _js22; _js21 += 1) {
980 var qsp_lib_itemObj = _js20[_js21];
981 var qsp_lib_item = qsp_lib_itemObj['str'];
982 if (qsp_lib_item === '') {
983 break;
984 } else if (qsp_lib_item === '-:-') {
985 qsp_lib_menuData.push('delimiter');
986 } else {
987 var qsp_lib_tokens = qsp_lib_item.split(':');
988 if (qsp_lib_tokens.length === 2) {
989 qsp_lib_tokens.push('');
990 };
991 var qsp_lib_text = qsp_lib_tokens.splice(0, qsp_lib_tokens.length - 2).join(':');
992 var qsp_lib_loc = qsp_lib_tokens[qsp_lib_tokens.length - 2];
993 var qsp_lib_icon = qsp_lib_tokens[qsp_lib_tokens.length - 1];
994 qsp_lib_menuData.push({ 'text' : qsp_lib_text,
995 'loc' : qsp_lib_loc,
996 'icon' : qsp_lib_icon
997 });
998 };
999 };
1000 qsp_api_menu(qsp_lib_menuData);
1001 };
1002 function qsp_lib_play(qsp_lib_filename, qsp_lib_volume) {
1003 if (qsp_lib_volume === undefined) {
1004 qsp_lib_volume = 100;
1005 };
1006 var qsp_lib_audio = new qsp_lib_Audio(qsp_lib_filename);
1007 qsp_Playing[qsp_lib_filename] = qsp_lib_audio;
1008 qsp_lib_audio.qsp_lib_volume = qsp_lib_volume * 0.01;
1009 __PS_MV_REG = [];
1010 return qsp_lib_audio.qsp_lib_play();
1011 };
1012 function close(qsp_lib_filename) {
1013 qsp_Playing[qsp_lib_filename](qsp_lib_stop);
1014 delete qsp_Playing[qsp_lib_filename];
1015 };
1016 function qsp_lib_closeall() {
1017 var _js23 = Object.keys(qsp_Playing);
1018 var _js25 = _js23.length;
1019 for (var _js24 = 0; _js24 < _js25; _js24 += 1) {
1020 var qsp_lib_k = _js23[_js24];
1021 var qsp_lib_v = qsp_Playing[qsp_lib_k];
1022 qsp_lib_v(qsp_lib_stop);
1023 };
1024 return qsp_Playing = { };
1025 };
1026 function qsp_lib_refint() {
1027 return null;
1028 };
1029 function qsp_lib_usertxt() {
1030 var qsp_lib_input = qsp_byId('qsp-input');
1031 __PS_MV_REG = [];
1032 return qsp_lib_input.qsp_lib_value;
1033 };
1034 function qsp_lib_cmdclear() {
1035 var qsp_lib_input = qsp_byId('qsp-input');
1036 __PS_MV_REG = [];
1037 return qsp_lib_input.qsp_lib_value = '';
1038 };
1039 function qsp_lib_input(qsp_lib_text) {
1040 return window.prompt(qsp_lib_text);
1041 };
1042 function qsp_lib_msecscount() {
1043 return Date.now() - qsp_StartedAt;
1044 };
1045 function qsp_lib_rgb(qsp_lib_red, qsp_lib_green, qsp_lib_blue) {
1046 return (qsp_lib_red << 16) + (qsp_lib_green << 8) + qsp_lib_blue;
1047 };
1048 function qsp_lib_openqst(qsp_lib_name) {
1049 __PS_MV_REG = [];
1050 return qsp_api_runGame(qsp_lib_name);
1051 };
1052 function qsp_lib_addqst(qsp_lib_name) {
1053 var qsp_lib_game = qsp_api_filenameGame(qsp_lib_name);
1054 __PS_MV_REG = [];
1055 return Object.assign(qsp_Locs, qsp_Games[qsp_lib_name]);
1056 };
1057 function qsp_lib_killqst() {
1058 var _js27 = qsp_Games.length;
1059 for (var _js26 = 0; _js26 < _js27; _js26 += 1) {
1060 var _db28 = qsp_Games[_js26];
1061 var qsp_lib_k = _db28[0];
1062 var qsp_lib_v = _db28[1];
1063 if (qsp_lib_k !== qsp_MainGame) {
1064 delete qsp_Locs[qsp_lib_k];
1065 };
1066 };
1067 };
1068
1069 qsp_Games['9loops'] = { };
1070 Object.assign(qsp_Globals, { 'X0' : qsp_api_newVar('X0', 0),
1071 'X' : qsp_api_newVar('X', 0),
1072 'Y0' : qsp_api_newVar('Y0', 0),
1073 'Y' : qsp_api_newVar('Y', 0),
1074 'S' : qsp_api_newVar('S', 0),
1075 'USEHTML' : qsp_api_newVar('USEHTML', 0),
1076 'RESULT' : qsp_api_newVar('RESULT', 0),
1077 '$RESULT' : qsp_api_newVar('$RESULT', 0),
1078 '$ONGLOAD' : qsp_api_newVar('$ONGLOAD', 0),
1079 '$ONGSAVE' : qsp_api_newVar('$ONGSAVE', 0),
1080 '$ONOBJADD' : qsp_api_newVar('$ONOBJADD', 0),
1081 '$ONOBJDEL' : qsp_api_newVar('$ONOBJDEL', 0),
1082 '$ONOBJSEL' : qsp_api_newVar('$ONOBJSEL', 0),
1083 '$ONNEWLOC' : qsp_api_newVar('$ONNEWLOC', 0),
1084 '$ONACTSEL' : qsp_api_newVar('$ONACTSEL', 0),
1085 '$COUNTER' : qsp_api_newVar('$COUNTER', 0),
1086 '$USERCOM' : qsp_api_newVar('$USERCOM', 0)
1087 });
1088 qsp_Games['9loops']['LOOPS'] = async function (qsp_lib_args) {
1089 var qsp_lib__labels = [];
1090 qsp_lib__labels['_nil'] = async function () {
1091 return 'ΠšΠžΠΠ•Π¦';
1092 qsp_lib_statP('Π­Ρ‚ΠΎ сообщСниС Π½Π΅ Π±ΡƒΠ΄Π΅Ρ‚ Π²Ρ‹Π²Π΅Π΄Π΅Π½ΠΎ');
1093 __PS_MV_REG = [];
1094 return 'ΠšΠžΠΠ•Π¦';
1095 };
1096 qsp_lib__labels['ΠšΠžΠΠ•Π¦'] = async function () {
1097 qsp_lib_statP('А это сообщСниС ΠΏΠΎΠ»ΡŒΠ·ΠΎΠ²Π°Ρ‚Π΅Π»ΡŒ ΡƒΠ²ΠΈΠ΄ΠΈΡ‚');
1098 qsp_Globals['S'][0] = 0;
1099 __PS_MV_REG = [];
1100 return 'LOOP1';
1101 };
1102 qsp_lib__labels['LOOP1'] = async function () {
1103 while (true) {
1104 if (qsp_Globals['S'][0] < 9) {
1105 qsp_Globals['S'][0] += 1;
1106 qsp_lib_statPl(qsp_Globals['S'][0]);
1107 continue;
1108 };
1109 qsp_lib_statP('Всё!');
1110 break;
1111 };
1112 __PS_MV_REG = [];
1113 return 'LOOP2';
1114 };
1115 qsp_lib__labels['LOOP2'] = async function () {
1116 while (true) {
1117 if (qsp_Globals['Y'][0] < qsp_Globals['Y0'][0]) {
1118 if (qsp_Globals['X'][0] < qsp_Globals['X0'][0]) {
1119 qsp_Globals['X'][0] += 1;
1120 continue;
1121 };
1122 qsp_Globals['Y'][0] += 1;
1123 qsp_Globals['X'][0] = 0;
1124 continue;
1125 if (qsp_Globals['Y'][0] > qsp_Globals['Y0'][0]) {
1126 return;
1127 };
1128 };
1129 break;
1130 };
1131 };
1132 for (var qsp_lib__nextblock = '_nil'; qsp_lib__nextblock; qsp_lib__nextblock = await (qsp_lib__labels[qsp_lib__nextblock]())) {
1133 };
1134 };</script></body></html> No newline at end of file
Show file before | Show file after | Hide comments
@@ -0,0 +1,3 b''
1 # loc
2 LCOLOR = rgb(106,90,205)
3 -
Show file before | Show file after | Hide comments
@@ -1,9 +1,10 b''
1 .*~
1 .*~
2 .*.txt
2 .qlot
3 .qlot
3 .html
4 .html
4 .png
5 .png
5 .orig
6 .orig
6 tests
7 tests
7 txt2web
8 txt2web
8 txt2web.tar.xz
9 .*.tar.xz
9 system-index.txt
10 system-index.txt
Show file before | Show file after | Hide comments
@@ -1,17 +1,14 b''
1
1
2 * Localization
3 * Save-load game in slots
2 * Save-load game in slots
4
3
5 * CLI build for Windows
6
7 * Reporting error lines in the parser
4 * Reporting error lines in the parser
8 * Report duplicate label (in the parser)
5 * Report duplicate label (in the parser)
9 * reporting error lines at runtime (by storing them in every form in the parser
6 * reporting error lines at runtime (by storing them in every form in the parser
10 * Report JUMP with missing label (in tagbody)
7 * Report JUMP with missing label (in tagbody)
11 * Localizing parser errors...
8 * Localizing parser errors...
12
9
13 * Build Istreblenie
10 * Build Istreblenie
14 * Build ЦвСтохимия
11 * Build ЦвСтохимия
15
12
16 * Windows GUI (for the compiler)
13 * Windows GUI (for the compiler)
17 * Resizable frames
14 * Resizable frames
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/10dynamic.txt to examples/10dynamic.qsps
NO CONTENT: file renamed from examples/10dynamic.txt to examples/10dynamic.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/11main.txt to examples/11main.qsps
NO CONTENT: file renamed from examples/11main.txt to examples/11main.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/12aux.txt to examples/12aux.qsps
NO CONTENT: file renamed from examples/12aux.txt to examples/12aux.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/13diag.txt to examples/13diag.qsps
NO CONTENT: file renamed from examples/13diag.txt to examples/13diag.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/14act.txt to examples/14act.qsps
NO CONTENT: file renamed from examples/14act.txt to examples/14act.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/15objs.txt to examples/15objs.qsps
NO CONTENT: file renamed from examples/15objs.txt to examples/15objs.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/16menu.txt to examples/16menu.qsps
NO CONTENT: file renamed from examples/16menu.txt to examples/16menu.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/17sound.txt to examples/17sound.qsps
NO CONTENT: file renamed from examples/17sound.txt to examples/17sound.qsps
Show file before | Show file after | Hide comments
@@ -1,26 +1,14 b''
1
1
2 # img
2 # img
3 $BACKIMAGE = 'content/back.png'
3 $BACKIMAGE = 'content/back.png'
4
4
5 VIEW 'content/monster.png'
5 VIEW 'content/monster.png'
6
6
7 ! Π’ΠΊΠ»ΡŽΡ‡Π°Π΅ΠΌ Ρ€Π΅ΠΆΠΈΠΌ HTML. Если Π²ΠΎ всСй ΠΈΠ³Ρ€Π΅ ΠΈΡΠΏΠΎΠ»ΡŒΠ·ΡƒΠ΅Ρ‚ΡΡ HTML,
7 ! Π’ΠΊΠ»ΡŽΡ‡Π°Π΅ΠΌ Ρ€Π΅ΠΆΠΈΠΌ HTML. Если Π²ΠΎ всСй ΠΈΠ³Ρ€Π΅ ΠΈΡΠΏΠΎΠ»ΡŒΠ·ΡƒΠ΅Ρ‚ΡΡ HTML,
8 ! Ρ‚ΠΎ достаточно Π²ΠΊΠ»ΡŽΡ‡ΠΈΡ‚ΡŒ Π΅Π³ΠΎ Π½Π° самой ΠΏΠ΅Ρ€Π²ΠΎΠΉ Π»ΠΎΠΊΠ°Ρ†ΠΈΠΈ.
8 ! Ρ‚ΠΎ достаточно Π²ΠΊΠ»ΡŽΡ‡ΠΈΡ‚ΡŒ Π΅Π³ΠΎ Π½Π° самой ΠΏΠ΅Ρ€Π²ΠΎΠΉ Π»ΠΎΠΊΠ°Ρ†ΠΈΠΈ.
9 USEHTML = 1
9 USEHTML = 1
10 ! Π’Ρ‹Π²ΠΎΠ΄ΠΈΠΌ ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΊΡƒ Π² основноС описаниС
10 ! Π’Ρ‹Π²ΠΎΠ΄ΠΈΠΌ ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΊΡƒ Π² основноС описаниС
11 '<img src="content/room.jpg">'
11 '<img src="content/room.jpg">'
12 ! Π’Ρ‹Π²ΠΎΠ΄ΠΈΠΌ ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΊΡƒ Π² Π΄ΠΎΠΏ. описаниС
12 ! Π’Ρ‹Π²ΠΎΠ΄ΠΈΠΌ ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΊΡƒ Π² Π΄ΠΎΠΏ. описаниС
13 PL '<img src="content/map.jpg">'
13 PL '<img src="content/map.jpg">'
14
15 !! Π ΠΠ‘Π¨Π˜Π Π•ΠΠ˜Π• ΠšΠžΠœΠŸΠ˜Π›Π―Π’ΠžΠ Π (Π½Π΅ ΠΈΡΠΏΠΎΠ»ΡŒΠ·ΡƒΠΉΡ‚Π΅ Ссли Ρ…ΠΎΡ‚ΠΈΡ‚ΠΈΠ΅ пСрСносимости Π½Π° Π΄Ρ€ΡƒΠ³ΠΈΠ΅ ΠΏΠ»Π΅Π΅Ρ€Ρ‹)
16 ! Π’Ρ‹Π²ΠΎΠ΄ΠΈΠΌ ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΊΡƒ Π² основноС описаниС
17 *IMG 'content/room.jpg'
18 ! Π’Ρ‹Π²ΠΎΠ΄ΠΈΠΌ Π΄Π²Π΅ ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΊΠΈ рядом Π² Π΄ΠΎΠΏΠΎΠ»Π½ΠΈΡ‚Π΅Π»ΡŒΠ½ΠΎΠ΅ описаниС
19 IMG 'content/stat1.png'
20 IMG 'content/stat2.png'
21 ! Π’.Π΅. ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΊΠΈ Π²Π΅Π΄ΡƒΡ‚ сСбя ΠΊΠ°ΠΊ тСкст ΠΈ пСрСносы строк Π½ΡƒΠΆΠ½ΠΎ Π²ΡΡ‚Π°Π²Π»ΡΡ‚ΡŒ явно
22
23 ! НСсколько ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΎΠΊ Ρ€Π°ΡΠΏΠΎΠ»Π°Π³Π°ΡŽΡ‚ΡΡ Π² ΠΎΠ΄Π½ΠΎΠΌ ΠΈ Ρ‚ΠΎΠΌ ΠΆΠ΅ мСстС Π² порядкС пСрСчислСния.
24 ! Π˜ΡΠΏΠΎΠ»ΡŒΠ·ΡƒΡ ΠΏΡ€ΠΎΠ·Ρ€Π°Ρ‡Π½ΠΎΡΡ‚ΡŒ ΠΌΠΎΠΆΠ½ΠΎ ΠΏΠΎΠ»ΡƒΡ‡ΠΈΡ‚ΡŒ эффСкт налоТСния Π½Π΅ΡΠΊΠΎΠ»ΡŒΠΊΠΈΡ… ΠΊΠ°Ρ€Ρ‚ΠΈΠ½ΠΎΠΊ слоями
25 IMG 'content/ragdoll.png', $equipment['body'], $equipment['head']
26 -
14 -
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/19input.txt to examples/19input.qsps
NO CONTENT: file renamed from examples/19input.txt to examples/19input.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/1loc.txt to examples/1loc.qsps
NO CONTENT: file renamed from examples/1loc.txt to examples/1loc.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/20time.txt to examples/20time.qsps
NO CONTENT: file renamed from examples/20time.txt to examples/20time.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/21locals.txt to examples/21locals.qsps
NO CONTENT: file renamed from examples/21locals.txt to examples/21locals.qsps
Show file before | Show file after | Hide comments
@@ -1,18 +1,18 b''
1
1
2 # for
2 # for
3 FOR k1=0 TO 5:
3 LOOP k1=0 WHILE k1 < 5:
4 *PL k1
4 *PL k1
5 IF k1=3: EXIT
5 IF k1=3: EXIT
6 END
6 END
7
7
8 FOR Π½ΠΎΠΌΠ΅Ρ€_Π½ΠΏΡ† = 1 TO количСство_Π½ΠΏΡ†: GS 'ΠΈΠ½ΠΈΡ†ΠΈΠ°Π»ΠΈΠ·ΠΈΡ€ΠΎΠ²Π°Ρ‚ΡŒ Π½ΠΏΡ†', Π½ΠΎΠΌΠ΅Ρ€_Π½ΠΏΡ†
8 LOOP Π½ΠΎΠΌΠ΅Ρ€_Π½ΠΏΡ† = 1 WHILE Π½ΠΎΠΌΠ΅Ρ€_Π½ΠΏΡ† < количСство_Π½ΠΏΡ†: GS 'ΠΈΠ½ΠΈΡ†ΠΈΠ°Π»ΠΈΠ·ΠΈΡ€ΠΎΠ²Π°Ρ‚ΡŒ Π½ΠΏΡ†', Π½ΠΎΠΌΠ΅Ρ€_Π½ΠΏΡ†
9
9
10 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ['ΠΌΠ΅Ρ‡'] = 10
10 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ['ΠΌΠ΅Ρ‡'] = 10
11 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ['доспСх'] = 250
11 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ['доспСх'] = 250
12 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ['Ρ‰ΠΈΡ‚'] = 15
12 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ['Ρ‰ΠΈΡ‚'] = 15
13 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ_снаряТСния = 0
13 ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ_снаряТСния = 0
14 FOR Π½ΠΎΠΌΠ΅Ρ€_ΠΏΡ€Π΅Π΄ΠΌΠ΅Ρ‚Π° = 0 TO ARRSIZE('ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ')-1: ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ_снаряТСния += ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ[Π½ΠΎΠΌΠ΅Ρ€_ΠΏΡ€Π΅Π΄ΠΌΠ΅Ρ‚Π°]
14 LOOP Π½ΠΎΠΌΠ΅Ρ€_ΠΏΡ€Π΅Π΄ΠΌΠ΅Ρ‚Π° = 0 WHILE Π½ΠΎΠΌΠ΅Ρ€_ΠΏΡ€Π΅Π΄ΠΌΠ΅Ρ‚Π° < ARRSIZE('ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ'): ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ_снаряТСния += ΡΡ‚ΠΎΠΈΠΌΠΎΡΡ‚ΡŒ[Π½ΠΎΠΌΠ΅Ρ€_ΠΏΡ€Π΅Π΄ΠΌΠ΅Ρ‚Π°]
15
15
16 FOR i = 1 TO 10 STEP 2: *PL i
16 LOOP i = 1 WHILE i < 10 STEP i += 2: *PL i
17
17
18 -
18 -
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/2var.txt to examples/2var.qsps
NO CONTENT: file renamed from examples/2var.txt to examples/2var.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/3expr.txt to examples/3expr.qsps
NO CONTENT: file renamed from examples/3expr.txt to examples/3expr.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/4code.txt to examples/4code.qsps
NO CONTENT: file renamed from examples/4code.txt to examples/4code.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/5arrays.txt to examples/5arrays.qsps
NO CONTENT: file renamed from examples/5arrays.txt to examples/5arrays.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/6str.txt to examples/6str.qsps
NO CONTENT: file renamed from examples/6str.txt to examples/6str.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/7if.txt to examples/7if.qsps
NO CONTENT: file renamed from examples/7if.txt to examples/7if.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/8sub.txt to examples/8sub.qsps
NO CONTENT: file renamed from examples/8sub.txt to examples/8sub.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/9999error.txt to examples/9999error.qsps
NO CONTENT: file renamed from examples/9999error.txt to examples/9999error.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/9loops.txt to examples/9loops.qsps
NO CONTENT: file renamed from examples/9loops.txt to examples/9loops.qsps
Show file before | Show file after | Hide comments
1 NO CONTENT: file renamed from examples/bench.txt to examples/bench.qsps
NO CONTENT: file renamed from examples/bench.txt to examples/bench.qsps
Show file before | Show file after | Hide comments
@@ -1,529 +1,510 b''
1
1
2 (in-package txt2web.api)
2 (in-package txt2web.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 ;;; Utils
9 ;;; Utils
10
10
11 (defun make-act-html (title img)
11 (defun make-act-html (title img)
12 (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
12 (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
13 (if img (+ "<img src='" img "'>") "")
13 (if img (+ "<img src='" img "'>") "")
14 title
14 title
15 "</a>"))
15 "</a>"))
16
16
17 (defun make-menu-item-html (num title img loc)
17 (defun make-menu-item-html (num title img loc)
18 (+ "<a href='" (href-call finish-menu loc) "'>"
18 (+ "<a href='" (href-call finish-menu loc) "'>"
19 (if img (+ "<img src='" img "'>") "")
19 (if img (+ "<img src='" img "'>") "")
20 title
20 title
21 "</a>"))
21 "</a>"))
22
22
23 (defun make-obj (title img selected)
23 (defun make-obj (title img selected)
24 (+ "<li onclick='" (inline-call select-obj title img) "'>"
24 (+ "<li onclick='" (inline-call select-obj title img) "'>"
25 "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
25 "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
26 (if img (+ "<img src='" img "'>") "")
26 (if img (+ "<img src='" img "'>") "")
27 title
27 title
28 "</a>"))
28 "</a>"))
29
29
30 (defun make-menu-delimiter ()
30 (defun make-menu-delimiter ()
31 "<hr>")
31 "<hr>")
32
32
33 (defun copy-obj (obj)
33 (defun copy-obj (obj)
34 (chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj)))))
34 (chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj)))))
35
35
36 (defun report-error (text)
36 (defun report-error (text)
37 (alert text))
37 (alert text))
38
38
39 (defun start-sleeping ()
39 (defun start-sleeping ()
40 (chain (by-id "qsp") class-list (add "disable")))
40 (chain (by-id "qsp") class-list (add "disable")))
41
41
42 (defun finish-sleeping ()
42 (defun finish-sleeping ()
43 (chain (by-id "qsp") class-list (remove "disable")))
43 (chain (by-id "qsp") class-list (remove "disable")))
44
44
45 (defun sleep (msec)
45 (defun sleep (msec)
46 (with-sleep (resume)
46 (with-sleep (resume)
47 (set-timeout resume msec)))
47 (set-timeout resume msec)))
48
48
49 (defun init-dom ()
49 (defun init-dom ()
50 ;; Save/load buttons
50 ;; Save/load buttons
51 (let ((btn (by-id "qsp-btn-save")))
51 (let ((btn (by-id "qsp-btn-save")))
52 (setf (@ btn onclick) savegame)
52 (setf (@ btn onclick) savegame)
53 (setf (@ btn href) "#"))
53 (setf (@ btn href) "#"))
54 (let ((btn (by-id "qsp-btn-open")))
54 (let ((btn (by-id "qsp-btn-open")))
55 (setf (@ btn onclick) opengame)
55 (setf (@ btn onclick) opengame)
56 (setf (@ btn href) "#"))
56 (setf (@ btn href) "#"))
57 ;; Close image on click
57 ;; Close image on click
58 (setf (@ (by-id "qsp-image-container") onclick)
58 (setf (@ (by-id "qsp-image-container") onclick)
59 show-image)
59 show-image)
60 ;; Enter in input field
60 ;; Enter in input field
61 (setf (@ (get-frame :input) onkeyup)
61 (setf (@ (get-frame :input) onkeyup)
62 on-input-key)
62 on-input-key)
63 ;; Close the dropdown on any click
63 ;; Close the dropdown on any click
64 (setf (@ window onclick)
64 (setf (@ window onclick)
65 (lambda (event)
65 (lambda (event)
66 (setf (@ window mouse)
66 (setf (@ window mouse)
67 (list (@ event page-x)
67 (list (@ event page-x)
68 (@ event page-y)))
68 (@ event page-y)))
69 (finish-menu nil))))
69 (finish-menu nil))))
70
70
71 (defun call-serv-loc (var-name &rest args)
71 (defun call-serv-loc (var-name &rest args)
72 (let ((loc-name (get-global var-name 0)))
72 (let ((loc-name (get-global var-name 0)))
73 (when loc-name
73 (when loc-name
74 (let ((loc (getprop *locs loc-name)))
74 (let ((loc (getprop *locs loc-name)))
75 (when loc
75 (when loc
76 (call-loc loc-name args))))))
76 (call-loc loc-name args))))))
77
77
78 (defun filename-game (filename)
78 (defun filename-game (filename)
79 (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2))))
79 (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2))))
80 (getprop *games game-name))
80 (getprop *games game-name))
81
81
82 (defun run-game (name)
82 (defun run-game (name)
83 (let ((game (filename-game name)))
83 (let ((game (filename-game name)))
84 (setf *main-game name)
84 (setf *main-game name)
85 ;; Replace locations with the new game's
85 ;; Replace locations with the new game's
86 (setf *locs game)
86 (setf *locs game)
87 (funcall (getprop game
87 (funcall (getprop game
88 (chain *object (keys game) 0))
88 (chain *object (keys game) 0))
89 (list))))
89 (list))))
90
90
91 ;;; Misc
91 ;;; Misc
92
92
93 (defun newline (key)
93 (defun newline (key)
94 (append-id (key-to-id key) "<br>" t))
94 (append-id (key-to-id key) "<br>" t))
95
95
96 (defun clear-id (id)
96 (defun clear-id (id)
97 (setf (inner-html (by-id id)) ""))
97 (setf (inner-html (by-id id)) ""))
98
98
99 (defun escape-html (text)
99 (defun escape-html (text)
100 (chain text
100 (chain text
101 (replace (regex "/&/g") "&amp;")
101 (replace (regex "/&/g") "&amp;")
102 (replace (regex "/</g") "&lt;")
102 (replace (regex "/</g") "&lt;")
103 (replace (regex "/>/g") "&gt;")
103 (replace (regex "/>/g") "&gt;")
104 (replace (regex "/\"/g") "&quot;")
104 (replace (regex "/\"/g") "&quot;")
105 (replace (regex "/'/g") "&apos;")))
105 (replace (regex "/'/g") "&apos;")))
106
106
107 (defun prepare-contents (s &optional force-html)
107 (defun prepare-contents (s &optional force-html)
108 (setf s (chain s (to-string)))
108 (setf s (chain s (to-string)))
109 (if (or force-html (get-global "USEHTML" 0))
109 (if (or force-html (get-global "USEHTML" 0))
110 s
110 s
111 (escape-html s)))
111 (escape-html s)))
112
112
113 (defun get-id (id &optional force-html)
113 (defun get-id (id &optional force-html)
114 (inner-html (by-id id)))
114 (inner-html (by-id id)))
115
115
116 (defun set-id (id contents &optional force-html)
116 (defun set-id (id contents &optional force-html)
117 (setf (inner-html (by-id id)) (prepare-contents contents force-html)))
117 (setf (inner-html (by-id id)) (prepare-contents contents force-html)))
118
118
119 (defun append-id (id contents &optional force-html)
119 (defun append-id (id contents &optional force-html)
120 (when contents
120 (when contents
121 (incf (inner-html (by-id id)) (prepare-contents contents force-html))))
121 (incf (inner-html (by-id id)) (prepare-contents contents force-html))))
122
122
123 (defun on-input-key (ev)
123 (defun on-input-key (ev)
124 (when (= 13 (@ ev key-code))
124 (when (= 13 (@ ev key-code))
125 (chain ev (prevent-default))
125 (chain ev (prevent-default))
126 (call-serv-loc "$USERCOM")))
126 (call-serv-loc "$USERCOM")))
127
127
128 ;;; Function calls
128 ;;; Function calls
129
129
130 (defun init-args (args)
130 (defun init-args (args)
131 (dotimes (i (length args))
131 (dotimes (i (length args))
132 (let ((arg (elt args i)))
132 (let ((arg (elt args i)))
133 (if (numberp arg)
133 (if (numberp arg)
134 (set-var args i :num arg)
134 (set-var args i :num arg)
135 (set-var args i :str arg)))))
135 (set-var args i :str arg)))))
136
136
137 (defun get-result ()
137 (defun get-result ()
138 (or (get-global "$RESULT" 0)
138 (or (get-global "$RESULT" 0)
139 (get-global "RESULT" 0)))
139 (get-global "RESULT" 0)))
140
140
141 (defun call-loc (name args)
141 (defun call-loc (name args)
142 (setf name (chain name (to-upper-case)))
142 (setf name (chain name (to-upper-case)))
143 (with-frame
143 (with-frame
144 (with-call-args args
144 (with-call-args args
145 (funcall (getprop *locs name))))
145 (funcall (getprop *locs name))))
146 (void))
146 (void))
147
147
148 (defun call-act (title)
148 (defun call-act (title)
149 (with-frame
149 (with-frame
150 (funcall (getprop *acts title :act)))
150 (funcall (getprop *acts title :act)))
151 (void))
151 (void))
152
152
153 ;;; Text windows
153 ;;; Text windows
154
154
155 (defun key-to-id (key)
155 (defun key-to-id (key)
156 (case key
156 (case key
157 (:all "qsp")
157 (:all "qsp")
158 (:main "qsp-main")
158 (:main "qsp-main")
159 (:stat "qsp-stat")
159 (:stat "qsp-stat")
160 (:objs "qsp-objs")
160 (:objs "qsp-objs")
161 (:acts "qsp-acts")
161 (:acts "qsp-acts")
162 (:input "qsp-input")
162 (:input "qsp-input")
163 (:image "qsp-image")
163 (:image "qsp-image")
164 (:dropdown "qsp-dropdown")
164 (:dropdown "qsp-dropdown")
165 (t (report-error "Internal error!"))))
165 (t (report-error "Internal error!"))))
166
166
167 (defun get-frame (key)
167 (defun get-frame (key)
168 (by-id (key-to-id key)))
168 (by-id (key-to-id key)))
169
169
170 (defun add-text (key text)
170 (defun add-text (key text)
171 (append-id (key-to-id key) text))
171 (append-id (key-to-id key) text))
172
172
173 (defun get-text (key)
173 (defun get-text (key)
174 (get-id (key-to-id key)))
174 (get-id (key-to-id key)))
175
175
176 (defun clear-text (key)
176 (defun clear-text (key)
177 (clear-id (key-to-id key)))
177 (clear-id (key-to-id key)))
178
178
179 (defun enable-frame (key enable)
179 (defun enable-frame (key enable)
180 (let ((obj (get-frame key)))
180 (let ((obj (get-frame key)))
181 (setf (@ obj style display) (if enable "block" "none"))
181 (setf (@ obj style display) (if enable "block" "none"))
182 (void)))
182 (void)))
183
183
184 ;;; Actions
184 ;;; Actions
185
185
186 (defun add-act (title img act)
186 (defun add-act (title img act)
187 (setf (getprop *acts title)
187 (setf (getprop *acts title)
188 (create :title title :img img :act act :selected nil))
188 (create :title title :img img :act act :selected nil))
189 (update-acts))
189 (update-acts))
190
190
191 (defun del-act (title)
191 (defun del-act (title)
192 (delete (getprop *acts title))
192 (delete (getprop *acts title))
193 (update-acts))
193 (update-acts))
194
194
195 (defun clear-act ()
195 (defun clear-act ()
196 (setf *acts (create))
196 (setf *acts (create))
197 (update-acts))
197 (update-acts))
198
198
199 (defun update-acts ()
199 (defun update-acts ()
200 (clear-id "qsp-acts")
200 (clear-id "qsp-acts")
201 (let ((elt (by-id "qsp-acts")))
201 (let ((elt (by-id "qsp-acts")))
202 (for-in (title *acts)
202 (for-in (title *acts)
203 (let ((obj (getprop *acts title)))
203 (let ((obj (getprop *acts title)))
204 (incf (inner-html elt) (make-act-html title (getprop obj :img)))))))
204 (incf (inner-html elt) (make-act-html title (getprop obj :img)))))))
205
205
206 (defun select-act (title)
206 (defun select-act (title)
207 (loop :for (k v) :of *acts
207 (loop :for (k v) :of *acts
208 :do (setf (getprop v :selected) nil))
208 :do (setf (getprop v :selected) nil))
209 (setf (getprop *acts title :selected) t)
209 (setf (getprop *acts title :selected) t)
210 (call-serv-loc "$ONACTSEL"))
210 (call-serv-loc "$ONACTSEL"))
211
211
212 ;;; "Syntax"
213
214 (defun qspfor (name index from to step body)
215 (loop :for i :from from :to to :by step
216 :do (set-var name index :num i)
217 :do (unless (await (funcall body))
218 (return-from qspfor))))
219
220 ;;; Variables
212 ;;; Variables
221
213
222 (defun new-var (slot &rest indexes)
214 (defun new-var (slot &rest indexes)
223 (let ((v (list)))
215 (let ((v (list)))
224 (dolist (index indexes)
216 (dolist (index indexes)
225 (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
217 (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
226 (setf (@ v :indexes) (create))
218 (setf (@ v :indexes) (create))
227 v))
219 v))
228
220
229 (defun set-str-element (slot index value)
221 (defun set-str-element (slot index value)
230 (if (has index (getprop slot :indexes))
222 (if (has index (getprop slot :indexes))
231 (setf (elt (getprop slot)
223 (setf (elt (getprop slot)
232 (getprop slot :indexes index))
224 (getprop slot :indexes index))
233 value)
225 value)
234 (progn
226 (progn
235 (chain slot (push value))
227 (chain slot (push value))
236 (setf (elt slot index)
228 (setf (elt slot index)
237 (length slot))))
229 (length slot))))
238 (void))
230 (void))
239
231
240 (defun set-any-element (slot index value)
232 (defun set-any-element (slot index value)
241 (cond ((null index)
233 (cond ((null index)
242 (chain (elt slot) (push value)))
234 (chain (elt slot) (push value)))
243 ((numberp index)
235 ((numberp index)
244 (setf (elt slot index) value))
236 (setf (elt slot index) value))
245 ((stringp index)
237 ((stringp index)
246 (set-str-element slot index value))
238 (set-str-element slot index value))
247 (t (report-error "INTERNAL ERROR")))
239 (t (report-error "INTERNAL ERROR")))
248 (void))
240 (void))
249
241
250 (defun set-serv-var (name index value)
242 (defun set-serv-var (name index value)
251 (let ((slot (getprop *globals name)))
243 (let ((slot (getprop *globals name)))
252 (set-any-element slot index value))
244 (set-any-element slot index value))
253 (funcall (getprop serv-vars name :body) value index)
245 (funcall (getprop serv-vars name :body) value index)
254 (void))
246 (void))
255
247
256 (defun get-element (slot index)
248 (defun get-element (slot index)
257 (if (numberp index)
249 (if (numberp index)
258 (elt slot index)
250 (elt slot index)
259 (elt slot (getprop slot :indexes index))))
251 (elt slot (getprop slot :indexes index))))
260
252
261 (defun get-global (name index)
253 (defun get-global (name index)
262 (elt (getprop *globals name) index))
254 (elt (getprop *globals name) index))
263
255
264 (defun kill-var (store name &optional index)
256 (defun kill-var (store name &optional index)
265 (setf name (chain name (to-upper-case)))
257 (setf name (chain name (to-upper-case)))
266 (if (and index (not (= 0 index)))
258 (if (and index (not (= 0 index)))
267 (chain (getprop *globals name) (kill index))
259 (chain (getprop *globals name) (kill index))
268 (delete (getprop *globals name)))
260 (delete (getprop *globals name)))
269 (void))
261 (void))
270
262
271 (defun array-size (name)
263 (defun array-size (name)
272 (@ (var-ref name) :values length))
264 (@ (var-ref name) :values length))
273
265
274 ;;; Locals
266 ;;; Locals
275
267
276 (defun push-local-frame ()
268 (defun push-local-frame ()
277 (chain *locals (push (create)))
269 (chain *locals (push (create)))
278 (void))
270 (void))
279
271
280 (defun pop-local-frame ()
272 (defun pop-local-frame ()
281 (chain *locals (pop))
273 (chain *locals (pop))
282 (void))
274 (void))
283
275
284 (defun current-local-frame ()
276 (defun current-local-frame ()
285 (elt *locals (1- (length *locals))))
277 (elt *locals (1- (length *locals))))
286
278
287 ;;; Objects
279 ;;; Objects
288
280
289 (defun select-obj (title img)
281 (defun select-obj (title img)
290 (loop :for (k v) :of *objs
282 (loop :for (k v) :of *objs
291 :do (setf (getprop v :selected) nil))
283 :do (setf (getprop v :selected) nil))
292 (setf (getprop *objs title :selected) t)
284 (setf (getprop *objs title :selected) t)
293 (call-serv-loc "$ONOBJSEL" title img))
285 (call-serv-loc "$ONOBJSEL" title img))
294
286
295 (defun update-objs ()
287 (defun update-objs ()
296 (let ((elt (by-id "qsp-objs")))
288 (let ((elt (by-id "qsp-objs")))
297 (setf (inner-html elt) "<ul>")
289 (setf (inner-html elt) "<ul>")
298 (loop :for (name obj) :of *objs
290 (loop :for (name obj) :of *objs
299 :do (incf (inner-html elt)
291 :do (incf (inner-html elt)
300 (make-obj name (@ obj :img) (@ obj :selected))))
292 (make-obj name (@ obj :img) (@ obj :selected))))
301 (incf (inner-html elt) "</ul>")))
293 (incf (inner-html elt) "</ul>")))
302
294
303 ;;; Menu
295 ;;; Menu
304
296
305 (defun open-menu (menu-data)
297 (defun open-menu (menu-data)
306 (let ((elt (get-frame :dropdown))
298 (let ((elt (get-frame :dropdown))
307 (i 0))
299 (i 0))
308 (loop :for item :in menu-data
300 (loop :for item :in menu-data
309 :do (incf i)
301 :do (incf i)
310 :do (incf (inner-html elt)
302 :do (incf (inner-html elt)
311 (if (eq item :delimiter)
303 (if (eq item :delimiter)
312 (make-menu-delimiter i)
304 (make-menu-delimiter i)
313 (make-menu-item-html i
305 (make-menu-item-html i
314 (@ item :text)
306 (@ item :text)
315 (@ item :icon)
307 (@ item :icon)
316 (@ item :loc)))))
308 (@ item :loc)))))
317 (let ((mouse (@ window mouse)))
309 (let ((mouse (@ window mouse)))
318 (setf (@ elt style left) (+ (elt mouse 0) "px"))
310 (setf (@ elt style left) (+ (elt mouse 0) "px"))
319 (setf (@ elt style top) (+ (elt mouse 1) "px"))
311 (setf (@ elt style top) (+ (elt mouse 1) "px"))
320 ;; Make sure it's inside the viewport
312 ;; Make sure it's inside the viewport
321 (when (> (@ document body inner-width)
313 (when (> (@ document body inner-width)
322 (+ (elt mouse 0) (@ elt inner-width)))
314 (+ (elt mouse 0) (@ elt inner-width)))
323 (incf (@ elt style left) (@ elt inner-width)))
315 (incf (@ elt style left) (@ elt inner-width)))
324 (when (> (@ document body inner-height)
316 (when (> (@ document body inner-height)
325 (+ (elt mouse 0) (@ elt inner-height)))
317 (+ (elt mouse 0) (@ elt inner-height)))
326 (incf (@ elt style top) (@ elt inner-height))))
318 (incf (@ elt style top) (@ elt inner-height))))
327 (setf (@ elt style display) "block")))
319 (setf (@ elt style display) "block")))
328
320
329 (defun finish-menu (loc)
321 (defun finish-menu (loc)
330 (when *menu-resume
322 (when *menu-resume
331 (let ((elt (get-frame :dropdown)))
323 (let ((elt (get-frame :dropdown)))
332 (setf (inner-html elt) "")
324 (setf (inner-html elt) "")
333 (setf (@ elt style display) "none")
325 (setf (@ elt style display) "none")
334 (funcall *menu-resume)
326 (funcall *menu-resume)
335 (setf *menu-resume nil))
327 (setf *menu-resume nil))
336 (when loc
328 (when loc
337 (call-loc loc)))
329 (call-loc loc)))
338 (void))
330 (void))
339
331
340 (defun menu (menu-data)
332 (defun menu (menu-data)
341 (with-sleep (resume)
333 (with-sleep (resume)
342 (open-menu menu-data)
334 (open-menu menu-data)
343 (setf *menu-resume resume))
335 (setf *menu-resume resume))
344 (void))
336 (void))
345
337
346 ;;; Content
338 ;;; Content
347
339
348 (defun clean-audio ()
340 (defun clean-audio ()
349 (loop :for k :in (chain *object (keys *playing))
341 (loop :for k :in (chain *object (keys *playing))
350 :for v := (getprop *playing k)
342 :for v := (getprop *playing k)
351 :do (when (@ v ended)
343 :do (when (@ v ended)
352 (delete (@ *playing k)))))
344 (delete (@ *playing k)))))
353
345
354 (defun show-image (path)
346 (defun show-image (path)
355 (let ((img (get-frame :image)))
347 (let ((img (get-frame :image)))
356 (cond (path
348 (cond (path
357 (setf (@ img src) path)
349 (setf (@ img src) path)
358 (setf (@ img style display) "flex"))
350 (setf (@ img style display) "flex"))
359 (t
351 (t
360 (setf (@ img src) "")
352 (setf (@ img src) "")
361 (setf (@ img style display) "hidden")))))
353 (setf (@ img style display) "hidden")))))
362
354
363 (defun show-inline-images (frame-name images)
364 (let ((frame (get-frame frame-name))
365 (text ""))
366 (incf text "<div style='position:relative; display: inline-block'>")
367 (incf text (+ "<img src='" (@ images 0) "'>"))
368 (loop :for image :in (chain images (slice 1))
369 :do (incf text
370 (+ "<img style='position:absolute' src='" image "'>")))
371 (incf text "</div>")
372 (incf (inner-html frame) text)))
373
374 (defun rgb-string (rgb)
355 (defun rgb-string (rgb)
375 (let ((red (ps::>> rgb 16))
356 (let ((red (ps::>> rgb 16))
376 (green (logand (ps::>> rgb 8) 255))
357 (green (logand (ps::>> rgb 8) 255))
377 (blue (logand rgb 255)))
358 (blue (logand rgb 255)))
378 (flet ((rgb-to-hex (comp)
359 (flet ((rgb-to-hex (comp)
379 (let ((hex (chain (*number comp) (to-string 16))))
360 (let ((hex (chain (*number comp) (to-string 16))))
380 (if (< (length hex) 2)
361 (if (< (length hex) 2)
381 (+ "0" hex)
362 (+ "0" hex)
382 hex))))
363 hex))))
383 (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue)))))
364 (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue)))))
384
365
385 (defun store-obj (key obj)
366 (defun store-obj (key obj)
386 (store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj)))))
367 (store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj)))))
387 (void))
368 (void))
388 (defun store-str (key str)
369 (defun store-str (key str)
389 (chain local-storage (set-item (+ "qsp_" key) str))
370 (chain local-storage (set-item (+ "qsp_" key) str))
390 (void))
371 (void))
391
372
392 (defun load-obj (key)
373 (defun load-obj (key)
393 (chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key))))))
374 (chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key))))))
394 (defun load-str (key)
375 (defun load-str (key)
395 (chain local-storage (get-item (+ "qsp_" key))))
376 (chain local-storage (get-item (+ "qsp_" key))))
396
377
397 ;;; Saves
378 ;;; Saves
398
379
399 (defun slot-savegame (slot comment)
380 (defun slot-savegame (slot comment)
400 (let ((saves (load-obj "saves")))
381 (let ((saves (load-obj "saves")))
401 (setf (@ saves slot) comment)
382 (setf (@ saves slot) comment)
402 (store-obj saves))
383 (store-obj saves))
403 (store-str slot (state-to-base64))
384 (store-str slot (state-to-base64))
404 (void))
385 (void))
405
386
406 (defun slot-loadgame (slot)
387 (defun slot-loadgame (slot)
407 (base64-to-state (load-str slot))
388 (base64-to-state (load-str slot))
408 (void))
389 (void))
409
390
410 (defun slot-deletegame (slot)
391 (defun slot-deletegame (slot)
411 (let ((saves (load-obj "saves")))
392 (let ((saves (load-obj "saves")))
412 (setf (@ saves slot) undefined)
393 (setf (@ saves slot) undefined)
413 (store-obj saves))
394 (store-obj saves))
414 (store-str slot undefined)
395 (store-str slot undefined)
415 (void))
396 (void))
416
397
417 (defun slot-listgames ()
398 (defun slot-listgames ()
418 (load-obj "saves"))
399 (load-obj "saves"))
419
400
420 (defun opengame ()
401 (defun opengame ()
421 (let ((element (chain document (create-element :input))))
402 (let ((element (chain document (create-element :input))))
422 (chain element (set-attribute :type :file))
403 (chain element (set-attribute :type :file))
423 (chain element (set-attribute :id :qsp-opengame))
404 (chain element (set-attribute :id :qsp-opengame))
424 (chain element (set-attribute :tabindex -1))
405 (chain element (set-attribute :tabindex -1))
425 (chain element (set-attribute "aria-hidden" t))
406 (chain element (set-attribute "aria-hidden" t))
426 (setf (@ element style display) :block)
407 (setf (@ element style display) :block)
427 (setf (@ element style visibility) :hidden)
408 (setf (@ element style visibility) :hidden)
428 (setf (@ element style position) :fixed)
409 (setf (@ element style position) :fixed)
429 (setf (@ element onchange)
410 (setf (@ element onchange)
430 (lambda (event)
411 (lambda (event)
431 (let* ((file (@ event target files 0))
412 (let* ((file (@ event target files 0))
432 (reader (new (*file-reader))))
413 (reader (new (*file-reader))))
433 (setf (@ reader onload)
414 (setf (@ reader onload)
434 (lambda (ev)
415 (lambda (ev)
435 (block nil
416 (block nil
436 (let ((target (@ ev current-target)))
417 (let ((target (@ ev current-target)))
437 (unless (@ target result)
418 (unless (@ target result)
438 (return))
419 (return))
439 (base64-to-state (@ target result))
420 (base64-to-state (@ target result))
440 (unstash-state)))))
421 (unstash-state)))))
441 (chain reader (read-as-text file)))))
422 (chain reader (read-as-text file)))))
442 (chain document body (append-child element))
423 (chain document body (append-child element))
443 (chain element (click))
424 (chain element (click))
444 (chain document body (remove-child element))))
425 (chain document body (remove-child element))))
445
426
446 (defun savegame ()
427 (defun savegame ()
447 (let ((element (chain document (create-element :a))))
428 (let ((element (chain document (create-element :a))))
448 (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64))))
429 (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64))))
449 (chain element (set-attribute :download "savegame.sav"))
430 (chain element (set-attribute :download "savegame.sav"))
450 (setf (@ element style display) :none)
431 (setf (@ element style display) :none)
451 (chain document body (append-child element))
432 (chain document body (append-child element))
452 (chain element (click))
433 (chain element (click))
453 (chain document body (remove-child element))))
434 (chain document body (remove-child element))))
454
435
455 (defun stash-state (args)
436 (defun stash-state (args)
456 (call-serv-loc "$ONGSAVE")
437 (call-serv-loc "$ONGSAVE")
457 (setf *state-stash
438 (setf *state-stash
458 (chain *j-s-o-n (stringify
439 (chain *j-s-o-n (stringify
459 (create :vars *globals
440 (create :vars *globals
460 :objs *objs
441 :objs *objs
461 :loc-args args
442 :loc-args args
462 :msecs (- (chain *date (now)) *started-at)
443 :msecs (- (chain *date (now)) *started-at)
463 :timer-interval *timer-interval
444 :timer-interval *timer-interval
464 :main-html (inner-html
445 :main-html (inner-html
465 (get-frame :main))
446 (get-frame :main))
466 :stat-html (inner-html
447 :stat-html (inner-html
467 (get-frame :stat))
448 (get-frame :stat))
468 :next-location *current-location))))
449 :next-location *current-location))))
469 (void))
450 (void))
470
451
471 (defun unstash-state ()
452 (defun unstash-state ()
472 (let ((data (chain *j-s-o-n (parse *state-stash))))
453 (let ((data (chain *j-s-o-n (parse *state-stash))))
473 (clear-act)
454 (clear-act)
474 (setf *globals (@ data :vars))
455 (setf *globals (@ data :vars))
475 (loop :for k :in (chain *object (keys *globals))
456 (loop :for k :in (chain *object (keys *globals))
476 :do (chain *object (set-prototype-of (getprop *globals k)
457 :do (chain *object (set-prototype-of (getprop *globals k)
477 (@ *var prototype))))
458 (@ *var prototype))))
478 (setf *started-at (- (chain *date (now)) (@ data :msecs)))
459 (setf *started-at (- (chain *date (now)) (@ data :msecs)))
479 (setf *objs (@ data :objs))
460 (setf *objs (@ data :objs))
480 (setf *current-location (@ data :next-location))
461 (setf *current-location (@ data :next-location))
481 (setf (inner-html (get-frame :main))
462 (setf (inner-html (get-frame :main))
482 (@ data :main-html))
463 (@ data :main-html))
483 (setf (inner-html (get-frame :stat))
464 (setf (inner-html (get-frame :stat))
484 (@ data :stat-html))
465 (@ data :stat-html))
485 (update-objs)
466 (update-objs)
486 (set-timer (@ data :timer-interval))
467 (set-timer (@ data :timer-interval))
487 (call-serv-loc "$ONGLOAD")
468 (call-serv-loc "$ONGLOAD")
488 (call-loc *current-location (@ data :loc-args))
469 (call-loc *current-location (@ data :loc-args))
489 (void)))
470 (void)))
490
471
491 (defun state-to-base64 ()
472 (defun state-to-base64 ()
492 (btoa (encode-u-r-i-component *state-stash)))
473 (btoa (encode-u-r-i-component *state-stash)))
493
474
494 (defun base64-to-state (data)
475 (defun base64-to-state (data)
495 (setf *state-stash (decode-u-r-i-component (atob data))))
476 (setf *state-stash (decode-u-r-i-component (atob data))))
496
477
497 ;;; Timers
478 ;;; Timers
498
479
499 (defun set-timer (interval)
480 (defun set-timer (interval)
500 (setf *timer-interval interval)
481 (setf *timer-interval interval)
501 (clear-interval *timer-obj)
482 (clear-interval *timer-obj)
502 (setf *timer-obj
483 (setf *timer-obj
503 (set-interval
484 (set-interval
504 (lambda ()
485 (lambda ()
505 (call-serv-loc "$COUNTER"))
486 (call-serv-loc "$COUNTER"))
506 interval)))
487 interval)))
507
488
508 ;;; Special variables
489 ;;; Special variables
509
490
510 (defvar serv-vars (create))
491 (defvar serv-vars (create))
511
492
512 (define-serv-var $backimage (path)
493 (define-serv-var $backimage (path)
513 (setf (@ (get-frame :main) style background-image) path))
494 (setf (@ (get-frame :main) style background-image) path))
514
495
515 (define-serv-var bcolor (color)
496 (define-serv-var bcolor (color)
516 (setf (@ (get-frame :all) style background-color) (rgb-string color)))
497 (setf (@ (get-frame :all) style background-color) (rgb-string color)))
517
498
518 (define-serv-var fcolor (color)
499 (define-serv-var fcolor (color)
519 (setf (@ (get-frame :all) style color) (rgb-string color)))
500 (setf (@ (get-frame :all) style color) (rgb-string color)))
520
501
521 (define-serv-var lcolor (color)
502 (define-serv-var lcolor (color)
522 (setf (@ (get-frame :style) inner-text)
503 (setf (@ (get-frame :style) inner-text)
523 (+ "a { color: " (rgb-string color) ";}")))
504 (+ "a { color: " (rgb-string color) ";}")))
524
505
525 (define-serv-var fsize (size)
506 (define-serv-var fsize (size)
526 (setf (@ (get-frame :all) style font-size) size))
507 (setf (@ (get-frame :all) style font-size) size))
527
508
528 (define-serv-var $fname (font-name)
509 (define-serv-var $fname (font-name)
529 (setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))
510 (setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))
Show file before | Show file after | Hide comments
@@ -1,170 +1,164 b''
1
1
2 (in-package txt2web.lib)
2 (in-package txt2web.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
6
6
7 ;;; 1loc
7 ;;; 1loc
8
8
9 ;;; 2var
9 ;;; 2var
10
10
11 (defpsmacro killvar (varname &optional index)
11 (defpsmacro killvar (varname &optional index)
12 `(api-call kill-var ,varname ,index))
12 `(api-call kill-var ,varname ,index))
13
13
14 (defpsmacro killall ()
14 (defpsmacro killall ()
15 `(api-call kill-all))
15 `(api-call kill-all))
16
16
17 ;;; 3expr
17 ;;; 3expr
18
18
19 (defpsmacro no (arg)
19 (defpsmacro no (arg)
20 `(- -1 ,arg))
20 `(- -1 ,arg))
21
21
22 ;;; 4code
22 ;;; 4code
23
23
24 (defpsmacro qspver ()
24 (defpsmacro qspver ()
25 "0.0.1")
25 "0.0.1")
26
26
27 (defpsmacro curloc ()
27 (defpsmacro curloc ()
28 `*current-location)
28 `*current-location)
29
29
30 (defpsmacro rnd ()
30 (defpsmacro rnd ()
31 `(funcall rand 1 1000))
31 `(funcall rand 1 1000))
32
32
33 (defpsmacro qspmax (&rest args)
33 (defpsmacro qspmax (&rest args)
34 (if (= 1 (length args))
34 (if (= 1 (length args))
35 `(*math.max.apply nil ,@args)
35 `(*math.max.apply nil ,@args)
36 `(*math.max ,@args)))
36 `(*math.max ,@args)))
37
37
38 (defpsmacro qspmin (&rest args)
38 (defpsmacro qspmin (&rest args)
39 (if (= 1 (length args))
39 (if (= 1 (length args))
40 `(*math.min.apply nil ,@args)
40 `(*math.min.apply nil ,@args)
41 `(*math.min ,@args)))
41 `(*math.min ,@args)))
42
42
43 ;;; 5arrays
43 ;;; 5arrays
44
44
45 (defpsmacro arrsize (name)
45 (defpsmacro arrsize (name)
46 `(api-call array-size ,name))
46 `(api-call array-size ,name))
47
47
48 ;;; 6str
48 ;;; 6str
49
49
50 (defpsmacro len (s)
50 (defpsmacro len (s)
51 `(length ,s))
51 `(length ,s))
52
52
53 (defpsmacro mid (s from &optional count)
53 (defpsmacro mid (s from &optional count)
54 `(chain ,s (substring ,from ,count)))
54 `(chain ,s (substring ,from ,count)))
55
55
56 (defpsmacro ucase (s)
56 (defpsmacro ucase (s)
57 `(chain ,s (to-upper-case)))
57 `(chain ,s (to-upper-case)))
58
58
59 (defpsmacro lcase (s)
59 (defpsmacro lcase (s)
60 `(chain ,s (to-lower-case)))
60 `(chain ,s (to-lower-case)))
61
61
62 (defpsmacro trim (s)
62 (defpsmacro trim (s)
63 `(chain ,s (trim)))
63 `(chain ,s (trim)))
64
64
65 (defpsmacro qspreplace (s from to)
65 (defpsmacro qspreplace (s from to)
66 `(chain ,s (replace ,from ,to)))
66 `(chain ,s (replace ,from ,to)))
67
67
68 (defpsmacro val (s)
68 (defpsmacro val (s)
69 `(parse-int ,s 10))
69 `(parse-int ,s 10))
70
70
71 (defpsmacro qspstr (n)
71 (defpsmacro qspstr (n)
72 `(chain ,n (to-string)))
72 `(chain ,n (to-string)))
73
73
74 ;;; 7if
74 ;;; 7if
75
75
76 ;;; 8sub
76 ;;; 8sub
77
77
78 ;;; 9loops
78 ;;; 9loops
79
79
80 ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge)
80 ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge)
81
81
82 (defpsmacro exit ()
82 (defpsmacro exit ()
83 `(return-from nil (values)))
83 `(return-from nil (values)))
84
84
85 ;;; 10dynamic
85 ;;; 10dynamic
86
86
87 ;;; 11main
87 ;;; 11main
88
88
89 (defpsmacro desc (s)
89 (defpsmacro desc (s)
90 (declare (ignore s))
90 (declare (ignore s))
91 "")
91 "")
92
92
93 ;;; 12stat
93 ;;; 12stat
94
94
95 (defpsmacro showstat (enable)
95 (defpsmacro showstat (enable)
96 `(api-call enable-frame :stat ,enable))
96 `(api-call enable-frame :stat ,enable))
97
97
98 ;;; 13diag
98 ;;; 13diag
99
99
100 (defpsmacro msg (text)
100 (defpsmacro msg (text)
101 `(alert ,text))
101 `(alert ,text))
102
102
103 ;;; 14act
103 ;;; 14act
104
104
105 (defpsmacro showacts (enable)
105 (defpsmacro showacts (enable)
106 `(api-call enable-frame :acts ,enable))
106 `(api-call enable-frame :acts ,enable))
107
107
108 (defpsmacro delact (&optional name)
108 (defpsmacro delact (&optional name)
109 (if name
109 (if name
110 `(api-call del-act ,name)
110 `(api-call del-act ,name)
111 `(api-call del-act)))
111 `(api-call del-act)))
112
112
113 (defpsmacro cla ()
113 (defpsmacro cla ()
114 `(api-call clear-act))
114 `(api-call clear-act))
115
115
116 ;;; 15objs
116 ;;; 15objs
117
117
118 (defpsmacro showobjs (enable)
118 (defpsmacro showobjs (enable)
119 `(api-call enable-frame :objs ,enable))
119 `(api-call enable-frame :objs ,enable))
120
120
121 (defpsmacro countobj ()
121 (defpsmacro countobj ()
122 `(length *objs))
122 `(length *objs))
123
123
124 (defpsmacro getobj (index)
124 (defpsmacro getobj (index)
125 `(or (elt *objs ,index) ""))
125 `(or (elt *objs ,index) ""))
126
126
127 ;;; 16menu
127 ;;; 16menu
128
128
129 ;;; 17sound
129 ;;; 17sound
130
130
131 (defpsmacro isplay (filename)
131 (defpsmacro isplay (filename)
132 `(funcall (@ playing includes) ,filename))
132 `(funcall (@ playing includes) ,filename))
133
133
134 ;;; 18img
134 ;;; 18img
135
135
136 (defpsmacro view (&optional path)
136 (defpsmacro view (&optional path)
137 `(api-call show-image ,path))
137 `(api-call show-image ,path))
138
138
139 (defpsmacro img (&rest images)
140 `(api-call show-inline-images :stat (list ,@images)))
141
142 (defpsmacro *img (&rest images)
143 `(api-call show-inline-images :main (list ,@images)))
144
145 ;;; 19input
139 ;;; 19input
146
140
147 (defpsmacro showinput (enable)
141 (defpsmacro showinput (enable)
148 `(api-call enable-frame :input ,enable))
142 `(api-call enable-frame :input ,enable))
149
143
150 ;;; 20time
144 ;;; 20time
151
145
152 (defpsmacro wait (msec)
146 (defpsmacro wait (msec)
153 `(await (api-call sleep ,msec)))
147 `(await (api-call sleep ,msec)))
154
148
155 (defpsmacro settimer (interval)
149 (defpsmacro settimer (interval)
156 `(api-call set-timer ,interval))
150 `(api-call set-timer ,interval))
157
151
158 ;;; 21local
152 ;;; 21local
159
153
160 ;;; 22for
154 ;;; 22for
161
155
162 ;;; misc
156 ;;; misc
163
157
164 (defpsmacro opengame (&optional filename)
158 (defpsmacro opengame (&optional filename)
165 (declare (ignore filename))
159 (declare (ignore filename))
166 `(api-call opengame))
160 `(api-call opengame))
167
161
168 (defpsmacro savegame (&optional filename)
162 (defpsmacro savegame (&optional filename)
169 (declare (ignore filename))
163 (declare (ignore filename))
170 `(api-call savegame))
164 `(api-call savegame))
Show file before | Show file after | Hide comments
@@ -1,157 +1,158 b''
1
1
2 (in-package txt2web)
2 (in-package txt2web)
3
3
4 (defvar *app-name* "txt2web")
4 (defvar *app-name* "txt2web")
5
5
6 (defun entry-point-no-args ()
6 (defun entry-point-no-args ()
7 (setf *delivered* t)
7 (setf *delivered* t)
8 (entry-point uiop:*command-line-arguments*))
8 (entry-point uiop:*command-line-arguments*))
9
9
10 (defun entry-point (args)
10 (defun entry-point (args)
11 (let ((*package* (find-package :txt2web)))
11 (let ((*package* (find-package :txt2web)))
12 (catch :terminate
12 (catch :terminate
13 (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
13 (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
14 (write-compiled-file compiler))))
14 (write-compiled-file compiler))))
15 (values))
15 (values))
16
16
17 (defun parse-opts (args)
17 (defun parse-opts (args)
18 (let ((mode :sources)
18 (let ((mode :sources)
19 (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
19 (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
20 (loop :for arg :in args
20 (loop :for arg :in args
21 :do (alexandria:switch (arg :test #'string=)
21 :do (alexandria:switch (arg :test #'string=)
22 ("-o" (setf mode :target))
22 ("-o" (setf mode :target))
23 ("--js" (setf mode :js))
23 ("--js" (setf mode :js))
24 ("--css" (setf mode :css))
24 ("--css" (setf mode :css))
25 ("--body" (setf mode :body))
25 ("--body" (setf mode :body))
26 ("-c" (setf (getf data :compile) t))
26 ("-c" (setf (getf data :compile) t))
27 ("--beautify" (setf (getf data :beautify) t))
27 ("--beautify" (setf (getf data :beautify) t))
28 (t (push arg (getf data mode)))))
28 (t (push arg (getf data mode)))))
29 (unless (< 0 (length (getf data :sources)))
29 (unless (< 0 (length (getf data :sources)))
30 (report-error "There should be at least one source"))
30 (report-error "There should be at least one source"))
31 (unless (> 1 (length (getf data :target)))
31 (unless (> 1 (length (getf data :target)))
32 (report-error "There should be no more than one target"))
32 (report-error "There should be no more than one target"))
33 (unless (> 1 (length (getf data :body)))
33 (unless (> 1 (length (getf data :body)))
34 (report-error "There should be no more than one body"))
34 (report-error "There should be no more than one body"))
35 (unless (getf data :target)
35 (unless (getf data :target)
36 (setf (getf data :target)
36 (setf (getf data :target)
37 (let* ((sources (first (getf data :sources)))
37 (let* ((sources (first (getf data :sources)))
38 (tokens (uiop:split-string sources :separator "."))
38 (tokens (uiop:split-string sources :separator "."))
39 (target (format nil "~{~A~^.~}.html"
39 (target (format nil "~{~A~^.~}.html"
40 (butlast tokens))))
40 (butlast tokens))))
41 (list target))))
41 (list target))))
42 (list :sources (getf data :sources)
42 (list :sources (getf data :sources)
43 :target (first (getf data :target))
43 :target (first (getf data :target))
44 :js (getf data :js)
44 :js (getf data :js)
45 :css (getf data :css)
45 :css (getf data :css)
46 :body (first (getf data :body))
46 :body (first (getf data :body))
47 :compile (getf data :compile)
47 :compile (getf data :compile)
48 :beautify (getf data :beautify))))
48 :beautify (getf data :beautify))))
49
49
50 (defun print-usage ()
50 (defun print-usage ()
51 (lformat t :usage *app-name*))
51 (lformat t :usage *app-name*))
52
52
53 (defun parse-file (filename)
53 (defun parse-file (filename)
54 (handler-case
54 (handler-case
55 (p:parse 'txt2web-grammar
55 (p:parse 'txt2web-grammar
56 (alexandria:read-file-into-string filename :external-format :utf-8))
56 (alexandria:read-file-into-string filename :external-format :utf-8))
57 (p:esrap-parse-error (e)
57 (p:esrap-parse-error (e)
58 (format t "~A~%" e)
58 (format t "~A~%" e)
59 (throw :terminate nil))))
59 (throw :terminate nil))))
60
60
61 (defun report-error (fmt &rest args)
61 (defun report-error (fmt &rest args)
62 (format t "ERROR: ~A~%" (apply #'format nil fmt args))
62 (format t "ERROR: ~A~%" (apply #'format nil fmt args))
63 (print-usage)
63 (print-usage)
64 (throw :terminate nil))
64 (throw :terminate nil))
65
65
66 ;;; JS
66 ;;; JS
67
67
68 (defun minify-package (package-designator minify prefix)
68 (defun minify-package (package-designator minify prefix)
69 (setf (ps:ps-package-prefix package-designator) prefix)
69 (setf (ps:ps-package-prefix package-designator) prefix)
70 (if minify
70 (if minify
71 (ps:obfuscate-package package-designator)
71 (ps:obfuscate-package package-designator)
72 (ps:unobfuscate-package package-designator)))
72 (ps:unobfuscate-package package-designator)))
73
73
74 (defmethod js-sources ((compiler compiler))
74 (defmethod js-sources ((compiler compiler))
75 (let ((ps:*ps-print-pretty* (beautify compiler)))
75 (let ((ps:*ps-print-pretty* (beautify compiler)))
76 (cond ((beautify compiler)
76 (cond ((beautify compiler)
77 (minify-package "TXT2WEB.MAIN" nil "qsp_")
77 (minify-package "TXT2WEB.MAIN" nil "qsp_")
78 (minify-package "TXT2WEB.API" nil "qsp_api_")
78 (minify-package "TXT2WEB.API" nil "qsp_api_")
79 (minify-package "TXT2WEB.LIB" nil "qsp_lib_"))
79 (minify-package "TXT2WEB.LIB" nil "qsp_lib_"))
80 (t
80 (t
81 (minify-package "TXT2WEB.MAIN" t "_")
81 (minify-package "TXT2WEB.MAIN" t "_")
82 (minify-package "TXT2WEB.API" t "a_")
82 (minify-package "TXT2WEB.API" t "a_")
83 (minify-package "TXT2WEB.LIB" t "l_")))
83 (minify-package "TXT2WEB.LIB" t "l_")))
84 (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
84 (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
85
85
86 ;;; CSS
86 ;;; CSS
87
87
88 (defmethod css-sources ((compiler compiler))
88 (defmethod css-sources ((compiler compiler))
89 (format nil "~{~A~^~%~%~}" (css compiler)))
89 (format nil "~{~A~^~%~%~}" (css compiler)))
90
90
91 ;;; HTML
91 ;;; HTML
92
92
93 (defmethod html-sources ((compiler compiler))
93 (defmethod html-sources ((compiler compiler))
94 (let ((flute:*escape-html* nil)
94 (let ((flute:*escape-html* nil)
95 (body-template (body compiler))
95 (body-template (body compiler))
96 (js (js-sources compiler))
96 (js (js-sources compiler))
97 (css (css-sources compiler)))
97 (css (css-sources compiler)))
98 (with-output-to-string (out)
98 (with-output-to-string (out)
99 (write
99 (write
100 (flute:h
100 (flute:h
101 (html
101 (html
102 (head
102 (head
103 (meta :charset "utf-8")
103 (title "txt2web"))
104 (title "txt2web"))
104 (body
105 (body
105 body-template
106 body-template
106 (style css)
107 (style css)
107 (script js))))
108 (script js))))
108 :stream out
109 :stream out
109 :pretty nil))))
110 :pretty nil))))
110
111
111 (defun filename-game (filename)
112 (defun filename-game (filename)
112 (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/"))))
113 (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/"))))
113 (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator ".")))))
114 (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator ".")))))
114
115
115 (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
116 (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
116 (call-next-method)
117 (call-next-method)
117 (with-slots (body css js)
118 (with-slots (body css js)
118 compiler
119 compiler
119 ;; Compile the game's JS
120 ;; Compile the game's JS
120 (dolist (source sources)
121 (dolist (source sources)
121 (let ((ps (parse-file source))
122 (let ((ps (parse-file source))
122 (game-name (filename-game source)))
123 (game-name (filename-game source)))
123 (destructuring-bind (kw &rest locations)
124 (destructuring-bind (kw &rest locations)
124 ps
125 ps
125 (unless (eq kw 'lib:game)
126 (unless (eq kw 'lib:game)
126 (report-error "Internal error!"))
127 (report-error "Internal error!"))
127 (push
128 (push
128 `(lib:game (,game-name) ,@locations)
129 `(lib:game (,game-name) ,@locations)
129 js))))
130 js))))
130 ;; Does the user need us to do anything else
131 ;; Does the user need us to do anything else
131 (unless compile
132 (unless compile
132 ;; Read in body
133 ;; Read in body
133 (when body-file
134 (when body-file
134 (setf body
135 (setf body
135 (alexandria:read-file-into-string body-file :external-format :utf-8)))
136 (alexandria:read-file-into-string body-file :external-format :utf-8)))
136 ;; Include js files
137 ;; Include js files
137 (dolist (js-file js-files)
138 (dolist (js-file js-files)
138 (push (format nil "////// Included file ~A~%~A" js-file
139 (push (format nil "////// Included file ~A~%~A" js-file
139 (alexandria:read-file-into-string js-file :external-format :utf-8))
140 (alexandria:read-file-into-string js-file :external-format :utf-8))
140 js))
141 js))
141 ;; Include css files
142 ;; Include css files
142 (when css-files
143 (when css-files
143 ;; User option overrides the default css
144 ;; User option overrides the default css
144 (setf css nil)
145 (setf css nil)
145 (dolist (css-file css-files)
146 (dolist (css-file css-files)
146 (push (format nil "////// Included file ~A~%~A" css-file
147 (push (format nil "////// Included file ~A~%~A" css-file
147 (alexandria:read-file-into-string css-file :external-format :utf-8))
148 (alexandria:read-file-into-string css-file :external-format :utf-8))
148 css))))))
149 css))))))
149
150
150 (defmethod write-compiled-file ((compiler compiler))
151 (defmethod write-compiled-file ((compiler compiler))
151 (alexandria:write-string-into-file
152 (alexandria:write-string-into-file
152 (if (compile-only compiler)
153 (if (compile-only compiler)
153 ;; Just the JS
154 ;; Just the JS
154 (js-sources compiler)
155 (js-sources compiler)
155 ;; All of it
156 ;; All of it
156 (html-sources compiler))
157 (html-sources compiler))
157 (target compiler) :if-exists :supersede))
158 (target compiler) :if-exists :supersede))
Show file before | Show file after | Hide comments
@@ -1,108 +1,108 b''
1
1
2 (in-package cl-user)
2 (in-package cl-user)
3
3
4 (defpackage :txt2web.js)
4 (defpackage :txt2web.js)
5
5
6 (defpackage :txt2web.main
6 (defpackage :txt2web.main
7 (:use :cl :ps :txt2web.js)
7 (:use :cl :ps :txt2web.js)
8 (:export #:api-call #:by-id
8 (:export #:api-call #:by-id
9 #:has
9 #:has
10
10
11 #:*globals #:*objs #:*current-location
11 #:*globals #:*objs #:*current-location
12 #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games
12 #:*started-at #:*timer-interval #:*timer-obj #:*loaded-games
13
13
14 #:*acts #:*state-stash #:*playing #:*locals
14 #:*acts #:*state-stash #:*playing #:*locals
15
15
16 #:*games #:*main-game #:*locs #:*menu-resume
16 #:*games #:*main-game #:*locs #:*menu-resume
17 ))
17 ))
18
18
19 (defpackage :code-walker
19 (defpackage :code-walker
20 (:use :cl)
20 (:use :cl)
21 (:export #:deftransform
21 (:export #:deftransform
22 #:deftransform-stop
22 #:deftransform-stop
23 #:walk
23 #:walk
24 #:whole
24 #:whole
25 #:walk-continue))
25 #:walk-continue))
26
26
27 ;;; API functions
27 ;;; API functions
28 (defpackage :txt2web.api
28 (defpackage :txt2web.api
29 (:use :cl :ps :txt2web.main :txt2web.js)
29 (:use :cl :ps :txt2web.main :txt2web.js)
30 (:export #:with-frame #:with-call-args
30 (:export #:with-frame #:with-call-args
31 #:stash-state
31 #:stash-state
32
32
33 #:report-error #:sleep #:init-dom #:call-serv-loc #:*serv-vars*
33 #:report-error #:sleep #:init-dom #:call-serv-loc #:*serv-vars*
34 #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id
34 #:newline #:clear-id #:prepare-contents #:get-id #:set-id #:append-id
35 #:init-args #:get-result #:call-loc #:call-act
35 #:init-args #:get-result #:call-loc #:call-act
36 #:get-frame #:add-text #:get-text #:clear-text #:enable-frame
36 #:get-frame #:add-text #:get-text #:clear-text #:enable-frame
37 #:add-act #:del-act #:clear-act #:update-acts
37 #:add-act #:del-act #:clear-act #:update-acts
38 #:set-str-element #:set-any-element #:set-serv-var
38 #:set-str-element #:set-any-element #:set-serv-var
39 #:*var #:new-value #:index-num #:get #:set #:kill
39 #:*var #:new-value #:index-num #:get #:set #:kill
40 #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var
40 #:var-real-name #:ensure-var #:var-ref #:get-var #:set-var
41 #:get-array #:set-array #:kill-var #:array-size
41 #:get-array #:set-array #:kill-var #:array-size
42 #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local
42 #:push-local-frame #:pop-local-frame #:current-local-frame #:new-local
43 #:update-objs
43 #:update-objs
44 #:menu
44 #:menu
45 #:clean-audio
45 #:clean-audio
46 #:show-image
46 #:show-image
47 #:opengame #:savegame
47 #:opengame #:savegame
48 ))
48 ))
49
49
50 ;;; QSP library functions and macros
50 ;;; QSP library functions and macros
51 (defpackage :txt2web.lib
51 (defpackage :txt2web.lib
52 (:use :cl :ps :txt2web.main :txt2web.js)
52 (:use :cl :ps :txt2web.main :txt2web.js)
53 (:local-nicknames (#:api :txt2web.api)
53 (:local-nicknames (#:api :txt2web.api)
54 (#:walker :code-walker))
54 (#:walker :code-walker))
55 (:export #:str #:exec #:qspblock #:qspfor #:game #:location
55 (:export #:str #:exec #:qspblock #:qsploop #:game #:location
56 #:qspcond #:qspvar #:set #:local #:jump
56 #:qspcond #:qspvar #:set #:local #:jump
57
57
58 #:killvar #:killall
58 #:killvar #:killall
59 #:obj #:loc #:no
59 #:obj #:loc #:no
60 #:qspver #:curloc
60 #:qspver #:curloc
61 #:rnd #:qspmax #:qspmin
61 #:rnd #:qspmax #:qspmin
62 #:arrsize #:len
62 #:arrsize #:len
63 #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr
63 #:mid #:ucase #:lcase #:trim #:replace #:val #:qspstr
64 #:exit #:desc
64 #:exit #:desc
65 #:showstat #:msg
65 #:showstat #:msg
66 #:showacts #:delact #:cla
66 #:showacts #:delact #:cla
67 #:showobjs #:countobj #:getobj
67 #:showobjs #:countobj #:getobj
68 #:isplay
68 #:isplay
69 #:view
69 #:view
70 #:showinput
70 #:showinput
71 #:wait #:settimer
71 #:wait #:settimer
72 #:local
72 #:local
73 #:opengame #:savegame
73 #:opengame #:savegame
74
74
75 #:goto #:xgoto
75 #:goto #:xgoto
76 #:rand
76 #:rand
77 #:copyarr #:arrpos #:arrcomp
77 #:copyarr #:arrpos #:arrcomp
78 #:instr #:isnum #:strcomp #:strfind #:strpos
78 #:instr #:isnum #:strcomp #:strfind #:strpos
79 #:iif
79 #:iif
80 #:gosub #:func
80 #:gosub #:func
81 #:dynamic #:dyneval
81 #:dynamic #:dyneval
82 #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear
82 #:main-p #:main-pl #:main-nl #:maintxt #:desc #:main-clear
83 #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls
83 #:stat-p #:stat-pl #:stat-nl #:stattxt #:stat-clear #:cls
84 #:curacts
84 #:curacts
85 #:addobj #:delobj #:killobj
85 #:addobj #:delobj #:killobj
86 #:menu
86 #:menu
87 #:play #:close #:closeall
87 #:play #:close #:closeall
88 #:refint
88 #:refint
89 #:usertxt #:cmdclear #:input
89 #:usertxt #:cmdclear #:input
90 #:msecscount
90 #:msecscount
91 #:rgb
91 #:rgb
92 #:openqst #:addqst #:killqst
92 #:openqst #:addqst #:killqst
93 ))
93 ))
94
94
95 (setf (ps:ps-package-prefix "TXT2WEB.MAIN") "qsp_")
95 (setf (ps:ps-package-prefix "TXT2WEB.MAIN") "qsp_")
96 (setf (ps:ps-package-prefix "TXT2WEB.API") "qsp_api_")
96 (setf (ps:ps-package-prefix "TXT2WEB.API") "qsp_api_")
97 (setf (ps:ps-package-prefix "TXT2WEB.LIB") "qsp_lib_")
97 (setf (ps:ps-package-prefix "TXT2WEB.LIB") "qsp_lib_")
98
98
99 ;;; The compiler
99 ;;; The compiler
100 (defpackage :txt2web
100 (defpackage :txt2web
101 (:use :cl)
101 (:use :cl)
102 (:local-nicknames (#:p #:esrap)
102 (:local-nicknames (#:p #:esrap)
103 (#:lib :txt2web.lib)
103 (#:lib :txt2web.lib)
104 (#:api :txt2web.api)
104 (#:api :txt2web.api)
105 (#:main :txt2web.main)
105 (#:main :txt2web.main)
106 (#:walker :code-walker))
106 (#:walker :code-walker))
107 (:export #:parse-file #:entry-point))
107 (:export #:parse-file #:entry-point))
108
108
Show file before | Show file after | Hide comments
@@ -1,660 +1,664 b''
1
1
2 (in-package txt2web)
2 (in-package txt2web)
3
3
4 ;;;; Parses TXT source to an intermediate representation
4 ;;;; Parses TXT source to an intermediate representation
5
5
6 (eval-when (:compile-toplevel :load-toplevel :execute)
6 (eval-when (:compile-toplevel :load-toplevel :execute)
7 (defparameter *max-args* 10))
7 (defparameter *max-args* 10))
8
8
9 ;;; Utility
9 ;;; Utility
10
10
11 (defun remove-nth (list nth)
11 (defun remove-nth (list nth)
12 (append (subseq list 0 nth)
12 (append (subseq list 0 nth)
13 (subseq list (1+ nth))))
13 (subseq list (1+ nth))))
14
14
15 (defun not-quote (char)
15 (defun not-quote (char)
16 (not (eql #\' char)))
16 (not (eql #\' char)))
17
17
18 (defun not-doublequote (char)
18 (defun not-doublequote (char)
19 (not (eql #\" char)))
19 (not (eql #\" char)))
20
20
21 (defun not-brace (char)
21 (defun not-brace (char)
22 (not (eql #\} char)))
22 (not (eql #\} char)))
23
23
24 (defun not-integer (string)
24 (defun not-integer (string)
25 (when (find-if-not #'digit-char-p string)
25 (when (find-if-not #'digit-char-p string)
26 t))
26 t))
27
27
28 (defun not-newline (char)
28 (defun not-newline (char)
29 (not (eql #\newline char)))
29 (not (eql #\newline char)))
30
30
31 (defun id-any-char (char)
31 (defun id-any-char (char)
32 (and
32 (and
33 (not (digit-char-p char))
33 (not (digit-char-p char))
34 (not (eql #\newline char))
34 (not (eql #\newline char))
35 (not (find char " !:&=<>+-*/,'\"()[]{}"))))
35 (not (find char " !:&=<>+-*/,'\"()[]{}"))))
36
36
37 (defun intern-first (list)
37 (defun intern-first (list)
38 (list* (intern (string-upcase (first list)) "TXT2WEB.LIB")
38 (list* (intern (string-upcase (first list)) "TXT2WEB.LIB")
39 (rest list)))
39 (rest list)))
40
40
41 (eval-when (:compile-toplevel :load-toplevel :execute)
41 (eval-when (:compile-toplevel :load-toplevel :execute)
42 (defun remove-nil (list)
42 (defun remove-nil (list)
43 (remove nil list)))
43 (remove nil list)))
44
44
45 (defun binop-rest (list)
45 (defun binop-rest (list)
46 (destructuring-bind (ws1 operator ws2 operand2)
46 (destructuring-bind (ws1 operator ws2 operand2)
47 list
47 list
48 (declare (ignore ws1 ws2))
48 (declare (ignore ws1 ws2))
49 (list (intern (string-upcase operator) "TXT2WEB.LIB") operand2)))
49 (list (intern (string-upcase operator) "TXT2WEB.LIB") operand2)))
50
50
51 (defun do-binop% (left-op other-ops)
51 (defun do-binop% (left-op other-ops)
52 (if (null other-ops)
52 (if (null other-ops)
53 left-op
53 left-op
54 (destructuring-bind ((operator right-op) &rest rest-ops)
54 (destructuring-bind ((operator right-op) &rest rest-ops)
55 other-ops
55 other-ops
56 (if (and (listp left-op)
56 (if (and (listp left-op)
57 (eq (first left-op)
57 (eq (first left-op)
58 operator))
58 operator))
59 (do-binop% (append left-op (list right-op)) rest-ops)
59 (do-binop% (append left-op (list right-op)) rest-ops)
60 (do-binop% (list operator left-op right-op) rest-ops)))))
60 (do-binop% (list operator left-op right-op) rest-ops)))))
61
61
62 (walker:deftransform parser-qspmod mod (&rest args)
62 (walker:deftransform parser-qspmod mod (&rest args)
63 (list* 'qspmod (mapcar #'walker:walk-continue args)))
63 (list* 'qspmod (mapcar #'walker:walk-continue args)))
64
64
65 (defun do-binop (list)
65 (defun do-binop (list)
66 (walker:walk 'parser-qspmod
66 (walker:walk 'parser-qspmod
67 (destructuring-bind (left-op rest-ops)
67 (destructuring-bind (left-op rest-ops)
68 list
68 list
69 (do-binop% left-op
69 (do-binop% left-op
70 (mapcar #'binop-rest rest-ops)))))
70 (mapcar #'binop-rest rest-ops)))))
71
71
72 (defun maybe-text (list)
72 (defun maybe-text (list)
73 "Leaves lists in place and applies esrap:text to everything else"
73 "Leaves lists in place and applies esrap:text to everything else"
74 (let ((parts nil)
74 (let ((parts nil)
75 (part (list 'text)))
75 (part (list 'text)))
76 (loop :for token :in list
76 (loop :for token :in list
77 :do (cond ((listp token)
77 :do (cond ((listp token)
78 (push (nreverse part) parts)
78 (push (nreverse part) parts)
79 (setf part (list 'text))
79 (setf part (list 'text))
80 (push token parts))
80 (push token parts))
81 (t (push token part))))
81 (t (push token part))))
82 (push (nreverse part) parts)
82 (push (nreverse part) parts)
83 (remove ""
83 (remove ""
84 (loop :for part :in (nreverse parts)
84 (loop :for part :in (nreverse parts)
85 :collect (case (first part)
85 :collect (case (first part)
86 ('text (p:text (rest part)))
86 ('text (p:text (rest part)))
87 (t part)))
87 (t part)))
88 :test #'equal)))
88 :test #'equal)))
89
89
90 (p:defrule line-continuation (and #\_ #\newline)
90 (p:defrule line-continuation (and #\_ #\newline)
91 (:constant nil))
91 (:constant nil))
92
92
93 (p:defrule text-spaces (+ (or #\space #\tab line-continuation))
93 (p:defrule text-spaces (+ (or #\space #\tab line-continuation))
94 (:text t))
94 (:text t))
95
95
96 (p:defrule spaces (+ (or #\space #\tab line-continuation))
96 (p:defrule spaces (+ (or #\space #\tab line-continuation))
97 (:constant nil)
97 (:constant nil)
98 (:error-report nil))
98 (:error-report nil))
99
99
100 (p:defrule spaces? (* (or #\space #\tab line-continuation))
100 (p:defrule spaces? (* (or #\space #\tab line-continuation))
101 (:constant nil)
101 (:constant nil)
102 (:error-report nil))
102 (:error-report nil))
103
103
104 (p:defrule colon #\:
104 (p:defrule colon #\:
105 (:constant nil))
105 (:constant nil))
106
106
107 (p:defrule equal #\=
107 (p:defrule equal #\=
108 (:constant nil))
108 (:constant nil))
109
109
110 (p:defrule alphanumeric (alphanumericp character))
110 (p:defrule alphanumeric (alphanumericp character))
111
111
112 (p:defrule not-newline (not-newline character))
112 (p:defrule not-newline (not-newline character))
113
113
114 (p:defrule squote-esc "''"
114 (p:defrule squote-esc "''"
115 (:lambda (list)
115 (:lambda (list)
116 (p:text (elt list 0))))
116 (p:text (elt list 0))))
117
117
118 (p:defrule dquote-esc "\"\""
118 (p:defrule dquote-esc "\"\""
119 (:lambda (list)
119 (:lambda (list)
120 (p:text (elt list 0))))
120 (p:text (elt list 0))))
121
121
122 (p:defrule sstring-char (or squote-esc (not-quote character))
122 (p:defrule sstring-char (or squote-esc (not-quote character))
123 (:text t))
123 (:text t))
124
124
125 (p:defrule dstring-char (or dquote-esc (not-doublequote character))
125 (p:defrule dstring-char (or dquote-esc (not-doublequote character))
126 (:text t))
126 (:text t))
127
127
128 ;;; Identifiers
128 ;;; Identifiers
129
129
130 (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr countobj curact curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit for freelib func getobj gosub goto gs gt if iif img *img inclib input instr isnum isplay jump killall killobj killqst killvar lcase len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect user_text usrtxt val view wait xgoto xgt))
130 (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr countobj curact curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit loop freelib func getobj gosub goto gs gt if iif img *img inclib input instr isnum isplay jump killall killobj killqst killvar lcase len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect user_text usrtxt val view wait while xgoto xgt))
131
131
132 (defun trim-$ (str)
132 (defun trim-$ (str)
133 (if (char= #\$ (elt str 0))
133 (if (char= #\$ (elt str 0))
134 (subseq str 1)
134 (subseq str 1)
135 str))
135 str))
136
136
137 (defun qsp-keyword-p (id)
137 (defun qsp-keyword-p (id)
138 (member (intern (trim-$ (string-upcase id))) *keywords*))
138 (member (intern (trim-$ (string-upcase id))) *keywords*))
139
139
140 (defun not-qsp-keyword-p (id)
140 (defun not-qsp-keyword-p (id)
141 (not (member (intern (trim-$ (string-upcase id))) *keywords*)))
141 (not (member (intern (trim-$ (string-upcase id))) *keywords*)))
142
142
143 (p:defrule qsp-keyword (qsp-keyword-p identifier-raw))
143 (p:defrule qsp-keyword (qsp-keyword-p identifier-raw))
144
144
145 (p:defrule id-first (id-any-char character))
145 (p:defrule id-first (id-any-char character))
146 (p:defrule id-next (or (id-any-char character)
146 (p:defrule id-next (or (id-any-char character)
147 (digit-char-p character)))
147 (digit-char-p character)))
148 (p:defrule identifier-raw (and id-first (* id-next))
148 (p:defrule identifier-raw (and id-first (* id-next))
149 (:lambda (list)
149 (:lambda (list)
150 (intern (string-upcase (p:text list)) "TXT2WEB.LIB")))
150 (intern (string-upcase (p:text list)) "TXT2WEB.LIB")))
151
151
152 (p:defrule identifier (not-qsp-keyword-p identifier-raw))
152 (p:defrule identifier (not-qsp-keyword-p identifier-raw))
153
153
154 ;;; Strings
154 ;;; Strings
155
155
156 (p:defrule qsp-string (or normal-string brace-string))
156 (p:defrule qsp-string (or normal-string brace-string))
157
157
158 (p:defrule brace-string (and #\{ before-statement block-body #\})
158 (p:defrule brace-string (and #\{ before-statement block-body #\})
159 (:lambda (list)
159 (:lambda (list)
160 (list* 'lib:qspblock (third list))))
160 (list* 'lib:qspblock (third list))))
161
161
162 (p:defrule normal-string (or sstring dstring)
162 (p:defrule normal-string (or sstring dstring)
163 (:lambda (str)
163 (:lambda (str)
164 (list* 'lib:str (or str (list "")))))
164 (list* 'lib:str (or str (list "")))))
165
165
166 (p:defrule sstring (and #\' (* (or sstring-interpol
166 (p:defrule sstring (and #\' (* (or sstring-interpol
167 sstring-exec
167 sstring-exec
168 sstring-char))
168 sstring-char))
169 #\')
169 #\')
170 (:lambda (list)
170 (:lambda (list)
171 (maybe-text (second list))))
171 (maybe-text (second list))))
172
172
173 (p:defrule dstring (and #\" (* (or dstring-interpol
173 (p:defrule dstring (and #\" (* (or dstring-interpol
174 dstring-exec
174 dstring-exec
175 dstring-char))
175 dstring-char))
176 #\")
176 #\")
177 (:lambda (list)
177 (:lambda (list)
178 (maybe-text (second list))))
178 (maybe-text (second list))))
179
179
180 (defun parse-interpol (list)
180 (defun parse-interpol (list)
181 (p:parse 'expression (p:text (mapcar 'second (second list)))))
181 (p:parse 'expression (p:text (mapcar 'second (second list)))))
182
182
183 (defun parse-exec (list)
183 (defun parse-exec (list)
184 (list* 'lib:exec (p:parse 'exec-body (p:text (second list)))))
184 (list* 'lib:exec (p:parse 'exec-body (p:text (second list)))))
185
185
186 (p:defrule sstring-interpol (and "<<" (+ (and (p:! ">>")
186 (p:defrule sstring-interpol (and "<<" (+ (and (p:! ">>")
187 sstring-char))
187 sstring-char))
188 ">>")
188 ">>")
189 (:function parse-interpol))
189 (:function parse-interpol))
190
190
191 (p:defrule dstring-interpol (and "<<" (+ (and (p:! ">>")
191 (p:defrule dstring-interpol (and "<<" (+ (and (p:! ">>")
192 dstring-char))
192 dstring-char))
193 ">>")
193 ">>")
194 (:function parse-interpol))
194 (:function parse-interpol))
195
195
196 (p:defrule sstring-exec (or (and (p:~ "\"exec:")
196 (p:defrule sstring-exec (or (and (p:~ "\"exec:")
197 (+ (and (p:& (not-doublequote character)) sstring-char))
197 (+ (and (p:& (not-doublequote character)) sstring-char))
198 #\")
198 #\")
199 (and (p:~ "''exec:")
199 (and (p:~ "''exec:")
200 (+ (not-quote character))
200 (+ (not-quote character))
201 "''"))
201 "''"))
202 (:function parse-exec))
202 (:function parse-exec))
203
203
204 (p:defrule dstring-exec (or (and (p:~ "'exec:")
204 (p:defrule dstring-exec (or (and (p:~ "'exec:")
205 (+ (and (p:& (not-quote character)) dstring-char))
205 (+ (and (p:& (not-quote character)) dstring-char))
206 #\')
206 #\')
207 (and (p:~ "\"\"exec")
207 (and (p:~ "\"\"exec")
208 (+ (not-doublequote character))
208 (+ (not-doublequote character))
209 "\"\""))
209 "\"\""))
210 (:function parse-exec))
210 (:function parse-exec))
211
211
212 ;;; Location
212 ;;; Location
213
213
214 (p:defrule txt2web-grammar (and (* (or spaces #\newline))
214 (p:defrule txt2web-grammar (and (* (or spaces #\newline))
215 (* location))
215 (* location))
216 (:lambda (list)
216 (:lambda (list)
217 `(lib:game ,@(second list))))
217 `(lib:game ,@(second list))))
218
218
219 (p:defrule location (and location-header block-body location-end)
219 (p:defrule location (and location-header block-body location-end)
220 (:destructure (header body end)
220 (:destructure (header body end)
221 (declare (ignore end))
221 (declare (ignore end))
222 `(lib:location (,header) ,@body)))
222 `(lib:location (,header) ,@body)))
223
223
224 (p:defrule location-header (and #\#
224 (p:defrule location-header (and #\#
225 (+ not-newline)
225 (+ not-newline)
226 (and #\newline spaces? before-statement))
226 (and #\newline spaces? before-statement))
227 (:destructure (spaces1 name spaces2)
227 (:destructure (spaces1 name spaces2)
228 (declare (ignore spaces1 spaces2))
228 (declare (ignore spaces1 spaces2))
229 (string-upcase (string-trim " " (p:text name)))))
229 (string-upcase (string-trim " " (p:text name)))))
230
230
231 (p:defrule location-end (and #\- (* not-newline) #\newline before-statement)
231 (p:defrule location-end (and #\- (* not-newline) #\newline before-statement)
232 (:constant nil))
232 (:constant nil))
233
233
234 ;;; Block body
234 ;;; Block body
235
235
236 (p:defrule newline-block-body (and #\newline spaces? block-body)
236 (p:defrule newline-block-body (and #\newline spaces? block-body)
237 (:function third))
237 (:function third))
238
238
239 (p:defrule block-body (* statement)
239 (p:defrule block-body (* statement)
240 (:function remove-nil))
240 (:function remove-nil))
241
241
242 ;; Just for <a href="exec:...'>
242 ;; Just for <a href="exec:...'>
243 ;; Explicitly called from that rule's production
243 ;; Explicitly called from that rule's production
244 (p:defrule exec-body (and before-statement line-body)
244 (p:defrule exec-body (and before-statement line-body)
245 (:function second))
245 (:function second))
246
246
247 (p:defrule line-body (and inline-statement (* next-inline-statement))
247 (p:defrule line-body (and inline-statement (* next-inline-statement))
248 (:lambda (list)
248 (:lambda (list)
249 (list* (first list) (second list))))
249 (list* (first list) (second list))))
250
250
251 (p:defrule before-statement (* (or #\newline spaces))
251 (p:defrule before-statement (* (or #\newline spaces))
252 (:constant nil))
252 (:constant nil))
253
253
254 (p:defrule statement-end (or statement-end-real statement-end-block-close))
254 (p:defrule statement-end (or statement-end-real statement-end-block-close))
255
255
256 (p:defrule statement-end-real (and (or #\newline
256 (p:defrule statement-end-real (and (or #\newline
257 (and #\& spaces? (p:& statement%)))
257 (and #\& spaces? (p:& statement%)))
258 before-statement)
258 before-statement)
259 (:constant nil))
259 (:constant nil))
260
260
261 (p:defrule statement-end-block-close (or (p:& #\}))
261 (p:defrule statement-end-block-close (or (p:& #\}))
262 (:constant nil))
262 (:constant nil))
263
263
264 (p:defrule inline-statement (and statement% spaces?)
264 (p:defrule inline-statement (and statement% spaces?)
265 (:function first))
265 (:function first))
266
266
267 (p:defrule next-inline-statement (and #\& spaces? inline-statement)
267 (p:defrule next-inline-statement (and #\& spaces? inline-statement)
268 (:function third))
268 (:function third))
269
269
270 (p:defrule not-a-non-statement (and (p:! (p:~ "elseif"))
270 (p:defrule not-a-non-statement (and (p:! (p:~ "elseif"))
271 (p:! (p:~ "else"))
271 (p:! (p:~ "else"))
272 (p:! (p:~ "end"))))
272 (p:! (p:~ "end"))))
273
273
274 (p:defrule statement (and inline-statement statement-end)
274 (p:defrule statement (and inline-statement statement-end)
275 (:function first))
275 (:function first))
276
276
277 (p:defrule statement% (and not-a-non-statement
277 (p:defrule statement% (and not-a-non-statement
278 (or label comment string-output
278 (or label comment string-output
279 block non-returning-intrinsic local
279 block non-returning-intrinsic local
280 assignment expression-output))
280 assignment expression-output))
281 (:function second))
281 (:function second))
282
282
283 (p:defrule expr-stopper (or comment block non-returning-intrinsic))
283 (p:defrule expr-stopper (or comment block non-returning-intrinsic))
284
284
285 (p:defrule string-output qsp-string
285 (p:defrule string-output qsp-string
286 (:lambda (string)
286 (:lambda (string)
287 (list 'lib:main-pl string)))
287 (list 'lib:main-pl string)))
288
288
289 (p:defrule expression-output expression
289 (p:defrule expression-output expression
290 (:lambda (list)
290 (:lambda (list)
291 (list 'lib:main-pl list)))
291 (list 'lib:main-pl list)))
292
292
293 (p:defrule label (and colon identifier)
293 (p:defrule label (and colon identifier)
294 (:lambda (list)
294 (:lambda (list)
295 (intern (string (second list)) :keyword)))
295 (intern (string (second list)) :keyword)))
296
296
297 (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline)))
297 (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline)))
298 (:constant nil))
298 (:constant nil))
299
299
300 (p:defrule brace-comment (and #\{ (* (not-brace character)) #\})
300 (p:defrule brace-comment (and #\{ (* (not-brace character)) #\})
301 (:constant nil))
301 (:constant nil))
302
302
303 (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression)))
303 (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression)))
304 (:lambda (list)
304 (:lambda (list)
305 (list* 'lib:local (third list)
305 (list* 'lib:local (third list)
306 (when (fourth list)
306 (when (fourth list)
307 (list (fourth (fourth list)))))))
307 (list (fourth (fourth list)))))))
308
308
309 ;;; Blocks
309 ;;; Blocks
310
310
311 (p:defrule block (or block-act block-if block-for))
311 (p:defrule block (or block-act block-if block-loop))
312
312
313 (p:defrule block-if (and block-if-head block-if-body)
313 (p:defrule block-if (and block-if-head block-if-body)
314 (:destructure (head body)
314 (:destructure (head body)
315 `(lib:qspcond (,@head ,@(first body))
315 `(lib:qspcond (,@head ,@(first body))
316 ,@(rest body))))
316 ,@(rest body))))
317
317
318 (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?)
318 (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?)
319 (:function remove-nil)
319 (:function remove-nil)
320 (:function cdr))
320 (:function cdr))
321
321
322 (p:defrule block-if-body (or block-if-ml block-if-sl)
322 (p:defrule block-if-body (or block-if-ml block-if-sl)
323 (:destructure (if-body elseifs else &rest ws)
323 (:destructure (if-body elseifs else &rest ws)
324 (declare (ignore ws))
324 (declare (ignore ws))
325 `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else))))))
325 `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else))))))
326
326
327 (p:defrule block-if-sl (and line-body
327 (p:defrule block-if-sl (and line-body
328 (p:? block-if-elseif-inline)
328 (p:? block-if-elseif-inline)
329 (p:? block-if-else-inline)
329 (p:? block-if-else-inline)
330 spaces?))
330 spaces?))
331
331
332 (p:defrule block-if-ml (and (and #\newline spaces?)
332 (p:defrule block-if-ml (and (and #\newline spaces?)
333 block-body
333 block-body
334 (p:? block-if-elseif)
334 (p:? block-if-elseif)
335 (p:? block-if-else)
335 (p:? block-if-else)
336 block-if-end)
336 block-if-end)
337 (:lambda (list)
337 (:lambda (list)
338 (cdr list)))
338 (cdr list)))
339
339
340 (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline))
340 (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline))
341 (:destructure (head statements elseif)
341 (:destructure (head statements elseif)
342 `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
342 `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
343
343
344 (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif))
344 (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif))
345 (:destructure (head ws statements elseif)
345 (:destructure (head ws statements elseif)
346 (declare (ignore ws))
346 (declare (ignore ws))
347 `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
347 `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
348
348
349 (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?)
349 (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?)
350 (:function remove-nil)
350 (:function remove-nil)
351 (:function intern-first))
351 (:function intern-first))
352
352
353 (p:defrule block-if-else-inline (and block-if-else-head line-body)
353 (p:defrule block-if-else-inline (and block-if-else-head line-body)
354 (:function second))
354 (:function second))
355
355
356 (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body)
356 (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body)
357 (:function fourth))
357 (:function fourth))
358
358
359 (p:defrule block-if-else-head (and (p:~ "else") spaces?)
359 (p:defrule block-if-else-head (and (p:~ "else") spaces?)
360 (:constant nil))
360 (:constant nil))
361
361
362 (p:defrule block-if-end (and (p:~ "end")
362 (p:defrule block-if-end (and (p:~ "end")
363 (p:? (and spaces (p:~ "if"))))
363 (p:? (and spaces (p:~ "if"))))
364 (:constant nil))
364 (:constant nil))
365
365
366 (p:defrule block-act (and block-act-head (or block-ml block-sl))
366 (p:defrule block-act (and block-act-head (or block-ml block-sl))
367 (:lambda (list)
367 (:lambda (list)
368 (apply #'append list)))
368 (apply #'append list)))
369
369
370 (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces?
370 (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces?
371 (p:? block-act-head-img)
371 (p:? block-act-head-img)
372 colon spaces?)
372 colon spaces?)
373 (:lambda (list)
373 (:lambda (list)
374 (intern-first (list (first list)
374 (intern-first (list (first list)
375 (third list)
375 (third list)
376 (or (fifth list) '(lib:str ""))))))
376 (or (fifth list) '(lib:str ""))))))
377
377
378 (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
378 (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
379 (:lambda (list)
379 (:lambda (list)
380 (or (third list) "")))
380 (or (third list) "")))
381
381
382 (p:defrule block-for (and block-for-head (or block-ml block-sl))
382 (p:defrule block-loop (and block-loop-head (or block-ml block-sl))
383 (:lambda (list)
383 (:lambda (list)
384 (apply #'append list)))
384 (apply #'append list)))
385
385
386 (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression
386 (p:defrule block-loop-head (and (p:~ "loop") spaces
387 (p:~ "to") spaces expression
387 (p:? (and block-loop-head-init spaces?))
388 block-for-head-step
388 block-loop-head-while spaces?
389 (p:? (and block-loop-head-step spaces?))
389 colon spaces?)
390 colon spaces?)
390 (:lambda (list)
391 (:lambda (list)
391 (list 'lib:qspfor
392 (break "~S" list)
393 (list 'lib:qsploop
392 (elt list 2)
394 (elt list 2)
393 (elt list 6)
395 (elt list 6)
394 (elt list 9)
396 (elt list 9)
395 (elt list 10))))
397 (elt list 10))))
396
398
397 (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?))
399 (p:defrule block-loop-head-init (or local plain-assignment))
398 (:lambda (list)
400
399 (if list
401 (p:defrule block-loop-head-while (and (p:~ "while") eq-expr)
400 (third list)
402 (:function second))
401 1)))
403
404 (p:defrule block-loop-head-step (and (p:~ "step") (or plain-assignment op-assignment))
405 (:function second))
402
406
403 (p:defrule block-sl line-body)
407 (p:defrule block-sl line-body)
404
408
405 (p:defrule block-ml (and newline-block-body block-end)
409 (p:defrule block-ml (and newline-block-body block-end)
406 (:lambda (list)
410 (:lambda (list)
407 (apply #'list* (butlast list))))
411 (apply #'list* (butlast list))))
408
412
409 (p:defrule block-end (and (p:~ "end"))
413 (p:defrule block-end (and (p:~ "end"))
410 (:constant nil))
414 (:constant nil))
411
415
412 ;;; Calls
416 ;;; Calls
413
417
414 (p:defrule first-argument (and expression spaces?)
418 (p:defrule first-argument (and expression spaces?)
415 (:function first))
419 (:function first))
416 (p:defrule next-argument (and "," spaces? expression)
420 (p:defrule next-argument (and "," spaces? expression)
417 (:function third))
421 (:function third))
418 (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments))
422 (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments))
419 (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\))
423 (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\))
420 (:function third))
424 (:function third))
421 (p:defrule plain-arguments (and spaces? base-arguments)
425 (p:defrule plain-arguments (and spaces? base-arguments)
422 (:function second))
426 (:function second))
423 (p:defrule no-arguments (or (and spaces? (p:& #\newline))
427 (p:defrule no-arguments (or (and spaces? (p:& #\newline))
424 (and spaces? (p:& #\&))
428 (and spaces? (p:& #\&))
425 spaces?)
429 spaces?)
426 (:constant nil))
430 (:constant nil))
427 (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?)
431 (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?)
428 (:lambda (list)
432 (:lambda (list)
429 (if (null list)
433 (if (null list)
430 nil
434 nil
431 (list* (first list) (second list)))))
435 (list* (first list) (second list)))))
432
436
433 ;;; Intrinsics
437 ;;; Intrinsics
434
438
435 (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses)
439 (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses)
436 `(progn
440 `(progn
437 ,@(loop :for clause :in clauses
441 ,@(loop :for clause :in clauses
438 :collect `(defintrinsic ,@clause))
442 :collect `(defintrinsic ,@clause))
439 (p:defrule ,returning-rule-name (or ,@(remove-nil
443 (p:defrule ,returning-rule-name (or ,@(remove-nil
440 (mapcar (lambda (clause)
444 (mapcar (lambda (clause)
441 (when (second clause)
445 (when (second clause)
442 (alexandria:symbolicate
446 (alexandria:symbolicate
443 'intrinsic- (first clause))))
447 'intrinsic- (first clause))))
444 clauses))))
448 clauses))))
445 (p:defrule ,non-returning-rule-name (or ,@(remove-nil
449 (p:defrule ,non-returning-rule-name (or ,@(remove-nil
446 (mapcar (lambda (clause)
450 (mapcar (lambda (clause)
447 (unless (second clause)
451 (unless (second clause)
448 (alexandria:symbolicate
452 (alexandria:symbolicate
449 'intrinsic- (first clause))))
453 'intrinsic- (first clause))))
450 clauses))))
454 clauses))))
451 (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name))))
455 (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name))))
452
456
453 (defmacro defintrinsic (sym returning &optional (min-arity 0) max-arity &rest names)
457 (defmacro defintrinsic (sym returning &optional (min-arity 0) max-arity &rest names)
454 (declare (ignore returning))
458 (declare (ignore returning))
455 (unless max-arity
459 (unless max-arity
456 (setf max-arity *max-args*))
460 (setf max-arity *max-args*))
457 (setf names
461 (setf names
458 (if names
462 (if names
459 (mapcar #'string-upcase names)
463 (mapcar #'string-upcase names)
460 (list (string sym))))
464 (list (string sym))))
461 `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym)
465 `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym)
462 (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name)))
466 (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name)))
463 arguments)
467 arguments)
464 (:destructure (dollar name arguments)
468 (:destructure (dollar name arguments)
465 (declare (ignore dollar))
469 (declare (ignore dollar))
466 (unless (<= ,min-arity (length arguments) ,max-arity)
470 (unless (<= ,min-arity (length arguments) ,max-arity)
467 (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S"
471 (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S"
468 name ,min-arity ,max-arity (length arguments) arguments))
472 name ,min-arity ,max-arity (length arguments) arguments))
469 (list* ',(intern (string sym) "TXT2WEB.LIB") arguments))))
473 (list* ',(intern (string sym) "TXT2WEB.LIB") arguments))))
470
474
471 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
475 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
472 ;; Transitions
476 ;; Transitions
473 (goto% nil 0 nil "gt" "goto")
477 (goto% nil 0 nil "gt" "goto")
474 (xgoto% nil 0 nil "xgt" "xgoto")
478 (xgoto% nil 0 nil "xgt" "xgoto")
475 ;; Variables
479 ;; Variables
476 (killvar nil 0 2)
480 (killvar nil 0 2)
477 ;; Expressions
481 ;; Expressions
478 (obj t 1 1)
482 (obj t 1 1)
479 (loc t 1 1)
483 (loc t 1 1)
480 (no t 1 1)
484 (no t 1 1)
481 ;; Basic
485 ;; Basic
482 (qspver t 0 0)
486 (qspver t 0 0)
483 (curloc t 0 0)
487 (curloc t 0 0)
484 (rand t 1 2)
488 (rand t 1 2)
485 (rnd t 0 0)
489 (rnd t 0 0)
486 (qspmax t 1 nil "max")
490 (qspmax t 1 nil "max")
487 (qspmin t 1 nil "min")
491 (qspmin t 1 nil "min")
488 ;; Arrays
492 ;; Arrays
489 (killall nil 0 0)
493 (killall nil 0 0)
490 (copyarr nil 2 4)
494 (copyarr nil 2 4)
491 (arrsize t 1 1)
495 (arrsize t 1 1)
492 (arrpos t 2 3)
496 (arrpos t 2 3)
493 (arrcomp t 2 3)
497 (arrcomp t 2 3)
494 ;; Strings
498 ;; Strings
495 (len t 1 1)
499 (len t 1 1)
496 (mid t 2 3)
500 (mid t 2 3)
497 (ucase t 1 1)
501 (ucase t 1 1)
498 (lcase t 1 1)
502 (lcase t 1 1)
499 (trim t 1 1)
503 (trim t 1 1)
500 (qspreplace t 2 3 "replace")
504 (qspreplace t 2 3 "replace")
501 (instr t 2 3)
505 (instr t 2 3)
502 (isnum t 1 1)
506 (isnum t 1 1)
503 (val t 1 1)
507 (val t 1 1)
504 (qspstr t 1 1 "str")
508 (qspstr t 1 1 "str")
505 (strcomp t 2 2)
509 (strcomp t 2 2)
506 (strfind t 2 3)
510 (strfind t 2 3)
507 (strpos t 2 3)
511 (strpos t 2 3)
508 ;; IF
512 ;; IF
509 (iif t 2 3)
513 (iif t 2 3)
510 ;; Subs
514 ;; Subs
511 (gosub nil 1 nil "gosub" "gs")
515 (gosub nil 1 nil "gosub" "gs")
512 (func t 1 nil)
516 (func t 1 nil)
513 (exit nil 0 0)
517 (exit nil 0 0)
514 ;; Jump
518 ;; Jump
515 (jump nil 1 1)
519 (jump nil 1 1)
516 ;; Dynamic
520 ;; Dynamic
517 (dynamic nil 1 nil)
521 (dynamic nil 1 nil)
518 (dyneval t 1 nil)
522 (dyneval t 1 nil)
519 ;; Sound
523 ;; Sound
520 (play nil 1 2)
524 (play nil 1 2)
521 (isplay t 1 1)
525 (isplay t 1 1)
522 (close nil 1 1)
526 (close nil 1 1)
523 (closeall nil 0 0 "close all")
527 (closeall nil 0 0 "close all")
524 ;; Main window
528 ;; Main window
525 (main-pl nil 1 1 "*pl")
529 (main-pl nil 1 1 "*pl")
526 (main-nl nil 0 1 "*nl")
530 (main-nl nil 0 1 "*nl")
527 (main-p nil 1 1 "*p")
531 (main-p nil 1 1 "*p")
528 (maintxt t 0 0)
532 (maintxt t 0 0)
529 (desc t 1 1)
533 (desc t 1 1)
530 (main-clear nil 0 0 "*clear" "*clr")
534 (main-clear nil 0 0 "*clear" "*clr")
531 ;; Aux window
535 ;; Aux window
532 (showstat nil 1 1)
536 (showstat nil 1 1)
533 (stat-pl nil 1 1 "pl")
537 (stat-pl nil 1 1 "pl")
534 (stat-nl nil 0 1 "nl")
538 (stat-nl nil 0 1 "nl")
535 (stat-p nil 1 1 "p")
539 (stat-p nil 1 1 "p")
536 (stattxt t 0 0)
540 (stattxt t 0 0)
537 (stat-clear nil 0 0 "clear" "clr")
541 (stat-clear nil 0 0 "clear" "clr")
538 (cls nil 0 0)
542 (cls nil 0 0)
539 ;; Dialog
543 ;; Dialog
540 (msg nil 1 1)
544 (msg nil 1 1)
541 ;; Acts
545 ;; Acts
542 (showacts nil 1 1)
546 (showacts nil 1 1)
543 (delact nil 1 1 "delact" "del act")
547 (delact nil 1 1 "delact" "del act")
544 (curacts t 0 0)
548 (curacts t 0 0)
545 (selact t 0 0)
549 (selact t 0 0)
546 (cla nil 0 0)
550 (cla nil 0 0)
547 ;; Objects
551 ;; Objects
548 (showobjs nil 1 1)
552 (showobjs nil 1 1)
549 (addobj nil 1 3 "addobj" "add obj")
553 (addobj nil 1 3 "addobj" "add obj")
550 (delobj nil 1 1 "delobj" "del obj")
554 (delobj nil 1 1 "delobj" "del obj")
551 (killobj nil 0 1)
555 (killobj nil 0 1)
552 (countobj t 0 0)
556 (countobj t 0 0)
553 (getobj t 1 1)
557 (getobj t 1 1)
554 (selobj t 0 0)
558 (selobj t 0 0)
555 (unsel nil 0 0 "unsel" "unselect")
559 (unsel nil 0 0 "unsel" "unselect")
556 ;; Menu
560 ;; Menu
557 (menu nil 1 1)
561 (menu nil 1 1)
558 ;; Images
562 ;; Images
559 (refint nil 0 0)
563 (refint nil 0 0)
560 (view nil 0 1)
564 (view nil 0 1)
561 (img nil 1)
565 (img nil 1)
562 (*img nil 1)
566 (*img nil 1)
563 ;; Fonts
567 ;; Fonts
564 (rgb t 3 3)
568 (rgb t 3 3)
565 ;; Input
569 ;; Input
566 (showinput nil 1 1)
570 (showinput nil 1 1)
567 (usertxt t 0 0 "user_text" "usrtxt")
571 (usertxt t 0 0 "user_text" "usrtxt")
568 (cmdclear nil 0 0 "cmdclear" "cmdclr")
572 (cmdclear nil 0 0 "cmdclear" "cmdclr")
569 (input t 1 1)
573 (input t 1 1)
570 ;; Files
574 ;; Files
571 (openqst nil 1 1)
575 (openqst nil 1 1)
572 (addqst nil 1 1 "addqst" "addlib" "inclib")
576 (addqst nil 1 1 "addqst" "addlib" "inclib")
573 (killqst nil 1 1 "killqst" "dellib" "freelib")
577 (killqst nil 1 1 "killqst" "dellib" "freelib")
574 (opengame nil 0 0)
578 (opengame nil 0 0)
575 (savegame nil 0 0)
579 (savegame nil 0 0)
576 ;; Real time
580 ;; Real time
577 (wait nil 1 1)
581 (wait nil 1 1)
578 (msecscount t 0 0)
582 (msecscount t 0 0)
579 (settimer nil 1 1))
583 (settimer nil 1 1))
580
584
581 ;;; Expression
585 ;;; Expression
582
586
583 (p:defrule expression or-expr)
587 (p:defrule expression or-expr)
584
588
585 (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr)))
589 (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr)))
586 (:function do-binop))
590 (:function do-binop))
587
591
588 (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr)))
592 (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr)))
589 (:function do-binop))
593 (:function do-binop))
590
594
591 (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>"
595 (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>"
592 "=" "<" ">" "!")
596 "=" "<" ">" "!")
593 spaces? sum-expr)))
597 spaces? sum-expr)))
594 (:function do-binop))
598 (:function do-binop))
595
599
596 (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr)))
600 (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr)))
597 (:function do-binop))
601 (:function do-binop))
598
602
599 (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr)))
603 (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr)))
600 (:function do-binop))
604 (:function do-binop))
601
605
602 (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr)))
606 (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr)))
603 (:function do-binop))
607 (:function do-binop))
604
608
605 (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr)
609 (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr)
606 (:lambda (list)
610 (:lambda (list)
607 (let ((expr (remove-nil list)))
611 (let ((expr (remove-nil list)))
608 (if (= 1 (length expr))
612 (if (= 1 (length expr))
609 (first expr)
613 (first expr)
610 (intern-first expr)))))
614 (intern-first expr)))))
611
615
612 (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?)
616 (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?)
613 (:function first))
617 (:function first))
614
618
615 (p:defrule paren-expr (and #\( spaces? expression spaces? #\))
619 (p:defrule paren-expr (and #\( spaces? expression spaces? #\))
616 (:function third))
620 (:function third))
617
621
618 (p:defrule or-op (p:~ "or")
622 (p:defrule or-op (p:~ "or")
619 (:constant "or"))
623 (:constant "or"))
620
624
621 (p:defrule and-op (p:~ "and")
625 (p:defrule and-op (p:~ "and")
622 (:constant "and"))
626 (:constant "and"))
623
627
624 ;;; Variables
628 ;;; Variables
625
629
626 (p:defrule variable (and identifier (p:? array-index))
630 (p:defrule variable (and identifier (p:? array-index))
627 (:destructure (id idx-raw)
631 (:destructure (id idx-raw)
628 (let ((idx (case idx-raw
632 (let ((idx (case idx-raw
629 ((nil) 0)
633 ((nil) 0)
630 (:last nil)
634 (:last nil)
631 (t idx-raw))))
635 (t idx-raw))))
632 (list 'lib:qspvar id idx))))
636 (list 'lib:qspvar id idx))))
633
637
634 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
638 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
635 (:lambda (list)
639 (:lambda (list)
636 (or (third list) :last)))
640 (or (third list) :last)))
637
641
638 (p:defrule assignment (or kw-assignment plain-assignment op-assignment)
642 (p:defrule assignment (or kw-assignment plain-assignment op-assignment)
639 (:destructure (qspvar eq expr)
643 (:destructure (qspvar eq expr)
640 (declare (ignore eq))
644 (declare (ignore eq))
641 (list 'lib:set qspvar expr)))
645 (list 'lib:set qspvar expr)))
642
646
643 (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment))
647 (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment))
644 (:function third))
648 (:function third))
645
649
646 (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression)
650 (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression)
647 (:destructure (qspvar ws1 op eq ws2 expr)
651 (:destructure (qspvar ws1 op eq ws2 expr)
648 (declare (ignore ws1 ws2))
652 (declare (ignore ws1 ws2))
649 (list qspvar eq (intern-first (list op qspvar expr)))))
653 (list qspvar eq (intern-first (list op qspvar expr)))))
650
654
651 (p:defrule plain-assignment (and variable spaces? #\= spaces? expression)
655 (p:defrule plain-assignment (and variable spaces? #\= spaces? expression)
652 (:function remove-nil))
656 (:function remove-nil))
653
657
654 ;;; Non-string literals
658 ;;; Non-string literals
655
659
656 (p:defrule literal (or qsp-string brace-string number))
660 (p:defrule literal (or qsp-string brace-string number))
657
661
658 (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
662 (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
659 (:lambda (list)
663 (:lambda (list)
660 (parse-integer (p:text list))))
664 (parse-integer (p:text list))))
Show file before | Show file after | Hide comments
@@ -1,386 +1,394 b''
1
1
2 (in-package txt2web.lib)
2 (in-package txt2web.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
6 ;;;; Some utility macros for other .ps sources too.
6 ;;;; Some utility macros for other .ps sources too.
7
7
8 ;;;; Block type | Has own locals | Has labels | async
8 ;;;; Block type | Has own locals | Has labels | async
9 ;;; Location | TRUE | TRUE | TRUE
9 ;;; Location | TRUE | TRUE | TRUE
10 ;;; Act | TRUE | TRUE | TRUE
10 ;;; Act | TRUE | TRUE | TRUE
11 ;;; {} | TRUE | TRUE | TRUE
11 ;;; {} | TRUE | TRUE | TRUE
12 ;;; IF | FALSE | TRUE | TRUE
12 ;;; IF | FALSE | TRUE | TRUE
13 ;;; FOR | FALSE | TRUE | TRUE
13 ;;; FOR | FALSE | TRUE | TRUE
14 ;;;
14 ;;;
15 ;;; IF and FOR are actually not blocks at all. They're implemented as Javascript's if and for loops.
15 ;;; IF and FOR are actually not blocks at all. They're implemented as Javascript's if and for loops.
16 ;;; Jumps back are also optimized to Javascript's while loops.
16 ;;; Jumps back are also optimized to Javascript's while loops.
17
17
18 ;;; Utils
18 ;;; Utils
19
19
20 ;;; Common
20 ;;; Common
21
21
22 (defpsmacro label-block (() &body body)
22 (defpsmacro label-block (() &body body)
23 (let ((has-labels (some #'keywordp body)))
23 (let ((has-labels (some #'keywordp body)))
24 `(block nil
24 `(block nil
25 ,@(when has-labels
25 ,@(when has-labels
26 '((var _labels (list))))
26 '((var _labels (list))))
27 (tagbody
27 (tagbody
28 ,@body
28 ,@body
29 (void)))))
29 (void)))))
30
30
31 (defpsmacro str (&rest forms)
31 (defpsmacro str (&rest forms)
32 (cond ((zerop (length forms))
32 (cond ((zerop (length forms))
33 "")
33 "")
34 ((and (= 1 (length forms))
34 ((and (= 1 (length forms))
35 (stringp (first forms)))
35 (stringp (first forms)))
36 (first forms))
36 (first forms))
37 (t
37 (t
38 `(& ,@forms))))
38 `(& ,@forms))))
39
39
40 (defpsmacro locals-block (&body body)
40 (defpsmacro locals-block (&body body)
41 "Includes labels too (through qsp-lambda)"
41 "Includes labels too (through qsp-lambda)"
42 (let ((*locals* nil))
42 (let ((*locals* nil))
43 (walker:walk 'locals body)
43 (walker:walk 'locals body)
44 `(qsp-lambda
44 `(qsp-lambda
45 (create-locals ,*locals*)
45 (create-locals ,*locals*)
46 ,@(walker:walk 'apply-vars body))))
46 ,@(walker:walk 'apply-vars body))))
47
47
48 ;;; 1loc
48 ;;; 1loc
49
49
50 (defparameter *special-variables*
50 (defparameter *special-variables*
51 '((usehtml 0)
51 '((usehtml 0)
52 (result 0)
52 (result 0)
53 ($result 0)
53 ($result 0)
54 ($ongload 0)
54 ($ongload 0)
55 ($ongsave 0)
55 ($ongsave 0)
56 ($onobjadd 0)
56 ($onobjadd 0)
57 ($onobjdel 0)
57 ($onobjdel 0)
58 ($onobjsel 0)
58 ($onobjsel 0)
59 ($onnewloc 0)
59 ($onnewloc 0)
60 ($onactsel 0)
60 ($onactsel 0)
61 ($counter 0)
61 ($counter 0)
62 ($usercom 0)))
62 ($usercom 0)))
63
63
64 (defpsmacro game ((name) &body body)
64 (defpsmacro game ((name) &body body)
65 (setf body (walker:walk 'for-transform body))
65 (setf body (walker:walk 'for-transform body))
66 (setf *globals* *special-variables*)
66 (setf *globals* *special-variables*)
67 (walker:walk 'globals body)
67 (walker:walk 'globals body)
68 `(progn
68 `(progn
69 ;; Game object
69 ;; Game object
70 (setf (@ *games ,name)
70 (setf (@ *games ,name)
71 (create))
71 (create))
72 ;; Global variables from this game
72 ;; Global variables from this game
73 (create-globals ,*globals*)
73 (create-globals ,*globals*)
74 ;; Locations
74 ;; Locations
75 ,@(loop :for location :in body
75 ,@(loop :for location :in body
76 :collect `(setf (@ *games ,name ,(caadr location))
76 :collect `(setf (@ *games ,name ,(caadr location))
77 ,location))))
77 ,location))))
78
78
79 (defpsmacro location ((name) &body body)
79 (defpsmacro location ((name) &body body)
80 (declare (ignore name))
80 (declare (ignore name))
81 "Name is used by the game macro above"
81 "Name is used by the game macro above"
82 `(locals-block ,@body))
82 `(locals-block ,@body))
83
83
84 (defpsmacro goto% (target &rest args)
84 (defpsmacro goto% (target &rest args)
85 `(progn
85 `(progn
86 (goto ,target ,args)
86 (goto ,target ,args)
87 (exit)))
87 (exit)))
88
88
89 (defpsmacro xgoto% (target &rest args)
89 (defpsmacro xgoto% (target &rest args)
90 `(progn
90 `(progn
91 (xgoto ,target ,args)
91 (xgoto ,target ,args)
92 (exit)))
92 (exit)))
93
93
94 ;;; 2var
94 ;;; 2var
95
95
96 (defvar *globals* nil)
96 (defvar *globals* nil)
97 (defvar *locals* nil)
97 (defvar *locals* nil)
98
98
99 (defpsmacro create-globals (globals)
99 (defpsmacro create-globals (globals)
100 (flet ((indexes (name)
100 (flet ((indexes (name)
101 (remove nil
101 (remove nil
102 (remove-if #'listp
102 (remove-if #'listp
103 (mapcar #'second
103 (mapcar #'second
104 (remove name globals
104 (remove name globals
105 :key #'first
105 :key #'first
106 :test-not #'eq))))))
106 :test-not #'eq))))))
107 (let ((names (remove-duplicates (mapcar #'first globals))))
107 (let ((names (remove-duplicates (mapcar #'first globals))))
108 `(chain *object
108 `(chain *object
109 (assign *globals
109 (assign *globals
110 (create
110 (create
111 ,@(loop :for sym :in names
111 ,@(loop :for sym :in names
112 :for indexes := (indexes sym)
112 :for indexes := (indexes sym)
113 :for name := (string-upcase sym)
113 :for name := (string-upcase sym)
114 :append `(,name
114 :append `(,name
115 (api-call new-var ,name ,@indexes)))))))))
115 (api-call new-var ,name ,@indexes)))))))))
116
116
117 (walker:deftransform globals qspvar (&rest var)
117 (walker:deftransform globals qspvar (&rest var)
118 (pushnew var *globals* :test #'equal)
118 (pushnew var *globals* :test #'equal)
119 (walker:walk-continue))
119 (walker:walk-continue))
120
120
121 (walker:deftransform globals local (var &rest expr)
121 (walker:deftransform globals local (var &rest expr)
122 (declare (ignore var))
122 (declare (ignore var))
123 (walker:walk 'globals expr))
123 (walker:walk 'globals expr))
124
124
125 (defpsmacro create-locals (locals)
125 (defpsmacro create-locals (locals)
126 (when locals
126 (when locals
127 `(progn
127 `(progn
128 (var locals (create
128 (var locals (create
129 ,@(loop :for (sym index) :in locals
129 ,@(loop :for (sym index) :in locals
130 :for name := (string-upcase sym)
130 :for name := (string-upcase sym)
131 :append `(,name (api-call new-var ,name))))))))
131 :append `(,name (api-call new-var ,name))))))))
132
132
133 ;; locations, blocks, and acts all have their own locals namespace
133 ;; locations, blocks, and acts all have their own locals namespace
134 (walker:deftransform-stop locals qspblock)
134 (walker:deftransform-stop locals qspblock)
135 (walker:deftransform-stop locals act)
135 (walker:deftransform-stop locals act)
136
136
137 (walker:deftransform locals local (var &optional expr)
137 (walker:deftransform locals local (var &optional expr)
138 (declare (ignore expr))
138 (declare (ignore expr))
139 (pushnew (rest var) *locals* :test #'equal)
139 (pushnew (rest var) *locals* :test #'equal)
140 nil)
140 nil)
141
141
142 ;; index types:
142 ;; index types:
143 ;; literal number
143 ;; literal number
144 ;; literal string
144 ;; literal string
145 ;; variable number
145 ;; variable number
146 ;; variable string
146 ;; variable string
147 ;; expression (may be possible to determine if it's a string or a number)
147 ;; expression (may be possible to determine if it's a string or a number)
148
148
149 (defun $-var-p (sym)
149 (defun $-var-p (sym)
150 (char= #\$ (elt (string-upcase (symbol-name sym)) 0)))
150 (char= #\$ (elt (string-upcase (symbol-name sym)) 0)))
151
151
152 (defun literal-string-p (form)
152 (defun literal-string-p (form)
153 (and (listp form)
153 (and (listp form)
154 (= 2 (length form))
154 (= 2 (length form))
155 (eq 'str (first form))
155 (eq 'str (first form))
156 (stringp (second form))))
156 (stringp (second form))))
157
157
158 (defun variable-number-p (form)
158 (defun variable-number-p (form)
159 (and (listp form)
159 (and (listp form)
160 (eq 'qspvar (first form))
160 (eq 'qspvar (first form))
161 (not ($-var-p (second form)))))
161 (not ($-var-p (second form)))))
162
162
163 (defun variable-string-p (form)
163 (defun variable-string-p (form)
164 (and (listp form)
164 (and (listp form)
165 (eq 'qspvar (first form))
165 (eq 'qspvar (first form))
166 ($-var-p (second form))))
166 ($-var-p (second form))))
167
167
168 (walker:deftransform apply-vars set (var expr)
168 (walker:deftransform apply-vars set (var expr)
169 (destructuring-bind (qspvar name index)
169 (destructuring-bind (qspvar name index)
170 var
170 var
171 (declare (ignore qspvar))
171 (declare (ignore qspvar))
172 (setf name (string-upcase name))
172 (setf name (string-upcase name))
173 (let ((slot `(getprop
173 (let ((slot `(getprop
174 ,(if (member name *locals* :key #'first)
174 ,(if (member name *locals* :key #'first)
175 'locals '*globals)
175 'locals '*globals)
176 ,name))
176 ,name))
177 (index (walker:walk 'apply-vars index))
177 (index (walker:walk 'apply-vars index))
178 (value (walker:walk 'apply-vars expr)))
178 (value (walker:walk 'apply-vars expr)))
179 (cond
179 (cond
180 ((member name api:*serv-vars* :test #'equalp)
180 ((member name api:*serv-vars* :test #'equalp)
181 `(api:set-serv-var ,name ,index ,value))
181 `(api:set-serv-var ,name ,index ,value))
182 ((null index)
182 ((null index)
183 `(chain (elt ,slot) (push ,value)))
183 `(chain (elt ,slot) (push ,value)))
184 ((or (numberp index)
184 ((or (numberp index)
185 (variable-number-p index))
185 (variable-number-p index))
186 `(setf (elt ,slot ,index) ,value))
186 `(setf (elt ,slot ,index) ,value))
187 ((or (literal-string-p index)
187 ((or (literal-string-p index)
188 (variable-string-p index))
188 (variable-string-p index))
189 `(api:set-str-element ,slot ,index ,value))
189 `(api:set-str-element ,slot ,index ,value))
190 (t
190 (t
191 `(api:set-any-element ,slot ,index ,value))))))
191 `(api:set-any-element ,slot ,index ,value))))))
192
192
193 (walker:deftransform apply-vars local (var &optional expr)
193 (walker:deftransform apply-vars local (var &optional expr)
194 ;; TODO: var can't be a service variable
194 ;; TODO: var can't be a service variable
195 (when expr
195 (when expr
196 (walker:walk 'apply-vars (list 'set var expr))))
196 (walker:walk 'apply-vars (list 'set var expr))))
197
197
198 (walker:deftransform apply-vars qspvar (name index)
198 (walker:deftransform apply-vars qspvar (name index)
199 (let ((slot `(getprop
199 (let ((slot `(getprop
200 ,(if (member name *locals* :key #'first) 'locals '*globals)
200 ,(if (member name *locals* :key #'first) 'locals '*globals)
201 ,(string-upcase name))))
201 ,(string-upcase name))))
202 (cond
202 (cond
203 ((null index)
203 ((null index)
204 `(elt ,slot (1- (length ,slot))))
204 `(elt ,slot (1- (length ,slot))))
205 ((or (numberp index)
205 ((or (numberp index)
206 (variable-number-p index))
206 (variable-number-p index))
207 `(elt ,slot ,(walker:walk-continue index)))
207 `(elt ,slot ,(walker:walk-continue index)))
208 ((or (literal-string-p index)
208 ((or (literal-string-p index)
209 (variable-string-p index))
209 (variable-string-p index))
210 `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index))))
210 `(elt ,slot (@ ,slot :indexes ,(walker:walk-continue index))))
211 (t
211 (t
212 `(get-element ,slot ,(walker:walk-continue index))))))
212 `(get-element ,slot ,(walker:walk-continue index))))))
213
213
214 (walker:deftransform apply-vars qspblock (&rest block)
214 (walker:deftransform apply-vars qspblock (&rest block)
215 (declare (ignore block))
215 (declare (ignore block))
216 (walker:whole))
216 (walker:whole))
217 (walker:deftransform apply-vars act (&rest block)
217 (walker:deftransform apply-vars act (&rest block)
218 (declare (ignore block))
218 (declare (ignore block))
219 (walker:whole))
219 (walker:whole))
220 (walker:deftransform apply-vars qspfor (var from to step body)
220 (walker:deftransform apply-vars qspfor (var from to step body)
221 (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body))))
221 (list* 'qspfor var (mapcar #'walker:walk-continue (list from to step body))))
222
222
223 ;;; 3expr
223 ;;; 3expr
224
224
225 (defpsmacro <> (op1 op2)
225 (defpsmacro <> (op1 op2)
226 `(not (equal ,op1 ,op2)))
226 `(not (equal ,op1 ,op2)))
227
227
228 (defpsmacro ! (op1 op2)
228 (defpsmacro ! (op1 op2)
229 `(not (equal ,op1 ,op2)))
229 `(not (equal ,op1 ,op2)))
230
230
231 (defpsmacro qspmod (&rest ops)
231 (defpsmacro qspmod (&rest ops)
232 (case (length ops)
232 (case (length ops)
233 (1 (first ops))
233 (1 (first ops))
234 (2 `(mod ,@ops))
234 (2 `(mod ,@ops))
235 (t `(mod ,(first ops) (qspmod ,@(rest ops))))))
235 (t `(mod ,(first ops) (qspmod ,@(rest ops))))))
236
236
237 ;;; 4code
237 ;;; 4code
238
238
239 (defpsmacro exec (&body body)
239 (defpsmacro exec (&body body)
240 (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))
240 (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))
241
241
242 ;;; 5arrays
242 ;;; 5arrays
243
243
244 ;;; 6str
244 ;;; 6str
245
245
246 (defpsmacro & (&rest args)
246 (defpsmacro & (&rest args)
247 `(chain "" (concat ,@args)))
247 `(chain "" (concat ,@args)))
248
248
249 ;;; 7if
249 ;;; 7if
250
250
251 (defpsmacro qspcond (&rest clauses)
251 (defpsmacro qspcond (&rest clauses)
252 `(cond ,@(loop :for clause :in clauses
252 `(cond ,@(loop :for clause :in clauses
253 :for f := (if (eq 'txt2web::else (first clause))
253 :for f := (if (eq 'txt2web::else (first clause))
254 't
254 't
255 (first clause))
255 (first clause))
256 :collect (list f
256 :collect (list f
257 `(tagbody
257 `(tagbody
258 ,@(rest clause))))))
258 ,@(rest clause))))))
259
259
260 ;;; 8sub
260 ;;; 8sub
261
261
262 ;;; 9loops
262 ;;; 9jump
263 ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
263 ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
264
264
265 (defpsmacro jump (target)
265 (defpsmacro jump (target)
266 `(return-from label-body ,(string-upcase (second target))))
266 `(return-from label-body ,(string-upcase (second target))))
267
267
268 (defpsmacro tagbody (&body body)
268 (defpsmacro tagbody (&body body)
269 (let ((create-locals (if (eq (caar body) 'create-locals)
269 (let ((create-locals (if (eq (caar body) 'create-locals)
270 (list (car body))))
270 (list (car body))))
271 (void (if (equal (car (last body)) '(void))
271 (void (if (equal (car (last body)) '(void))
272 '((void)))))
272 '((void)))))
273 (when create-locals
273 (when create-locals
274 (setf body (cdr body)))
274 (setf body (cdr body)))
275 (when void
275 (when void
276 (setf body (butlast body)))
276 (setf body (butlast body)))
277 (let ((funcs (list nil "_nil")))
277 (let ((funcs (list nil "_nil")))
278 (dolist (form body)
278 (dolist (form body)
279 (cond ((keywordp form)
279 (cond ((keywordp form)
280 (setf (first funcs) (reverse (first funcs)))
280 (setf (first funcs) (reverse (first funcs)))
281 (push (string-upcase form) funcs)
281 (push (string-upcase form) funcs)
282 (push nil funcs))
282 (push nil funcs))
283 (t
283 (t
284 (push form (first funcs)))))
284 (push form (first funcs)))))
285 (setf (first funcs) (reverse (first funcs)))
285 (setf (first funcs) (reverse (first funcs)))
286 (setf funcs (reverse funcs))
286 (setf funcs (reverse funcs))
287 `(progn
287 `(progn
288 ,@create-locals
288 ,@create-locals
289 ,(if (= 2 (length funcs))
289 ,(if (= 2 (length funcs))
290 `(progn
290 `(progn
291 ,@body)
291 ,@body)
292 `(progn
292 `(progn
293 (tagbody-blocks ,funcs)
293 (tagbody-blocks ,funcs)
294 (loop
294 (loop
295 :for _nextblock
295 :for _nextblock
296 := :_nil
296 := :_nil
297 :then (await (funcall (getprop _labels _nextblock)))
297 :then (await (funcall (getprop _labels _nextblock)))
298 :while _nextblock)))
298 :while _nextblock)))
299 ,@void))))
299 ,@void))))
300
300
301 (defvar *current-label*)
301 (defvar *current-label*)
302 (defvar *has-jump-back*)
302 (defvar *has-jump-back*)
303 (walker:deftransform optimize-jump jump (target)
303 (walker:deftransform optimize-jump jump (target)
304 (cond ((string= (string-upcase (second target)) *current-label*)
304 (cond ((string= (string-upcase (second target)) *current-label*)
305 (setf *has-jump-back* t)
305 (setf *has-jump-back* t)
306 '(continue))
306 '(continue))
307 (t
307 (t
308 (walker:walk-continue))))
308 (walker:walk-continue))))
309
309
310 (defpsmacro tagbody-blocks (funcs)
310 (defpsmacro tagbody-blocks (funcs)
311 `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
311 `(setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
312 :append `((@ _labels ,label)
312 :append `((@ _labels ,label)
313 (async-lambda ()
313 (async-lambda ()
314 (block label-body
314 (block label-body
315 (tagbody-block-body ,label ,code
315 (tagbody-block-body ,label ,code
316 ,(first rest-labels))))))))
316 ,(first rest-labels))))))))
317
317
318 (defpsmacro tagbody-block-body (label code next-label)
318 (defpsmacro tagbody-block-body (label code next-label)
319 (let ((*current-label* label)
319 (let ((*current-label* label)
320 (*has-jump-back* nil))
320 (*has-jump-back* nil))
321 (let ((code (walker:walk 'optimize-jump code)))
321 (let ((code (walker:walk 'optimize-jump code)))
322 (if *has-jump-back*
322 (if *has-jump-back*
323 `(progn
323 `(progn
324 (loop :do (progn
324 (loop :do (progn
325 ,@code
325 ,@code
326 (break)))
326 (break)))
327 ,@(if next-label
327 ,@(if next-label
328 (list next-label)
328 (list next-label)
329 nil))
329 nil))
330 `(progn
330 `(progn
331 ,@code
331 ,@code
332 ,@(if next-label
332 ,@(if next-label
333 (list next-label)
333 (list next-label)
334 nil))))))
334 nil))))))
335
335
336 (defpsmacro exit ()
336 (defpsmacro exit ()
337 '(return-from nil (values)))
337 '(return-from nil (values)))
338
338
339 ;;; 10dynamic
339 ;;; 10dynamic
340
340
341 (defpsmacro qspblock (&body body)
341 (defpsmacro qspblock (&body body)
342 `(locals-block
342 `(locals-block
343 ,@body))
343 ,@body))
344
344
345 (defpsmacro qsp-lambda (&body body)
345 (defpsmacro qsp-lambda (&body body)
346 `(async-lambda (args)
346 `(async-lambda (args)
347 (label-block ()
347 (label-block ()
348 ,@body)))
348 ,@body)))
349
349
350 ;;; 11main
350 ;;; 11main
351
351
352 (defpsmacro act (name img &body body)
352 (defpsmacro act (name img &body body)
353 `(api-call add-act ,name ,img
353 `(api-call add-act ,name ,img
354 (locals-block
354 (locals-block
355 ,@body)))
355 ,@body)))
356
356
357 ;;; 12aux
357 ;;; 12aux
358
358
359 ;;; 13diag
359 ;;; 13diag
360
360
361 ;;; 14act
361 ;;; 14act
362
362
363 ;;; 15objs
363 ;;; 15objs
364
364
365 ;;; 16menu
365 ;;; 16menu
366
366
367 ;;; 17sound
367 ;;; 17sound
368
368
369 ;;; 18img
369 ;;; 18img
370
370
371 ;;; 19input
371 ;;; 19input
372
372
373 ;;; 20time
373 ;;; 20time
374
374
375 ;;; 21local
375 ;;; 21local
376
376
377 ;;; 22for
377 ;;; 22loop
378
379 (defpsmacro qsploop (init cond step &body body)
380 `(progn
381 ,init
382 (loop :while ,cond
383 :do (progn
384 ,@body
385 ,step))))
378
386
379 ;; Transform because it creates a (set ...) hence it has to be processed
387 ;; Transform because it creates a (set ...) hence it has to be processed
380 ;; before the apply-vars transform. And macros are processed after all
388 ;; before the apply-vars transform. And macros are processed after all
381 ;; the transforms
389 ;; the transforms
382 (walker:deftransform for-transform qspfor (var from to step &rest body)
390 (walker:deftransform for-transform qspfor (var from to step &rest body)
383 `(loop :for i :from ,from :to ,to :by ,step
391 `(loop :for i :from ,from :to ,to :by ,step
384 :do (set ,var i)
392 :do (set ,var i)
385 :do (block nil
393 :do (block nil
386 ,@(walker:walk-continue body))))
394 ,@(walker:walk-continue body))))
Show file before | Show file after | Hide comments
1 NO CONTENT: file was removed
NO CONTENT: file was removed
General Comments 0
You need to be logged in to leave comments. Login now