Show More
@@ -1,8 +1,9 b'' | |||||
1 |
|
1 | |||
2 | * Windows GUI |
|
2 | * Windows GUI | |
|
3 | * Save-load game | |||
3 | * Resizable frames |
|
4 | * Resizable frames | |
4 | * Build Istreblenie |
|
5 | * Build Istreblenie | |
5 | ** modifying it to suit compiler specifics |
|
6 | ** modifying it to suit compiler specifics | |
6 | ** Implementing apis and intrinsics as needed |
|
7 | ** Implementing apis and intrinsics as needed | |
7 |
|
8 | |||
8 | * Use real characters in cl-uglify-js No newline at end of file |
|
9 | * Use real characters in cl-uglify-js |
@@ -1,7 +1,12 b'' | |||||
1 |
|
1 | |||
2 | <div id="qsp"> |
|
2 | <div id="qsp"> | |
3 | <div id="qsp-main" class="qsp-frame"> </div> |
|
3 | <div class="qsp-col qsp-col1"> | |
4 |
<div id="qsp- |
|
4 | <div id="qsp-main" class="qsp-frame"> </div> | |
5 |
<div id="qsp- |
|
5 | <div id="qsp-acts" class="qsp-frame"> </div> | |
6 |
< |
|
6 | <input id="qsp-input" class="qsp-frame"> | |
|
7 | </div> | |||
|
8 | <div class="qsp-col qsp-col2"> | |||
|
9 | <div id="qsp-stat" class="qsp-frame"> </div> | |||
|
10 | <div id="qsp-objs" class="qsp-frame"> </div> | |||
|
11 | </div> | |||
7 | </div> |
|
12 | </div> |
@@ -1,54 +1,59 b'' | |||||
1 |
|
1 | |||
2 | .qsp-frame { |
|
2 | .qsp-frame { | |
3 | border: 1px solid black; |
|
3 | border: 1px solid black; | |
4 | overflow: auto; |
|
4 | overflow: auto; | |
5 | position: absolute; |
|
|||
6 | padding: 5px; |
|
5 | padding: 5px; | |
7 | box-sizing: border-box; |
|
6 | box-sizing: border-box; | |
8 | } |
|
7 | } | |
9 |
|
8 | |||
10 | #qsp { |
|
9 | #qsp { | |
11 |
position: |
|
10 | position: absolute; | |
|
11 | display: flex; | |||
|
12 | flex-flow: row; | |||
12 | top: 0; |
|
13 | top: 0; | |
13 | left: 0; |
|
14 | left: 0; | |
14 | width: 100%; |
|
15 | width: 100%; | |
15 | height: 100%; |
|
16 | height: 100%; | |
16 | } |
|
17 | } | |
17 |
|
18 | |||
|
19 | .qsp-col { | |||
|
20 | display: flex; | |||
|
21 | flex-flow: column; | |||
|
22 | } | |||
|
23 | ||||
|
24 | .qsp-col1 { | |||
|
25 | flex: 7 7 70px; | |||
|
26 | } | |||
|
27 | ||||
|
28 | .qsp-col2 { | |||
|
29 | flex: 3 3 30px; | |||
|
30 | } | |||
|
31 | ||||
18 | #qsp-main { |
|
32 | #qsp-main { | |
19 | height: 60%; |
|
33 | flex: 6 6 60px; | |
20 | width: 70%; |
|
|||
21 | top: 0; |
|
|||
22 | left: 0; |
|
|||
23 | } |
|
34 | } | |
24 |
|
35 | |||
25 | #qsp-acts { |
|
36 | #qsp-acts { | |
26 | height: 40%; |
|
37 | flex: 4 4 40px; | |
27 | width: 70%; |
|
38 | } | |
28 | bottom: 0; |
|
39 | ||
29 | left: 0; |
|
40 | #qsp-input { | |
30 | } |
|
41 | } | |
31 |
|
42 | |||
32 | #qsp-stat { |
|
43 | #qsp-stat { | |
33 | height: 50%; |
|
44 | flex: 5 5 50px; | |
34 | width: 30%; |
|
|||
35 | top: 0; |
|
|||
36 | right: 0; |
|
|||
37 | } |
|
45 | } | |
38 |
|
46 | |||
39 | #qsp-objs { |
|
47 | #qsp-objs { | |
40 | height: 50%; |
|
48 | flex: 5 5 50px; | |
41 | width: 30%; |
|
|||
42 | bottom: 0; |
|
|||
43 | right: 0; |
|
|||
44 | } |
|
49 | } | |
45 |
|
50 | |||
46 | .qsp-act { |
|
51 | .qsp-act { | |
47 | display: block; |
|
52 | display: block; | |
48 | padding: 2px; |
|
53 | padding: 2px; | |
49 | font-size: large; |
|
54 | font-size: large; | |
50 | } |
|
55 | } | |
51 |
|
56 | |||
52 | .qsp-act:hover { |
|
57 | .qsp-act:hover { | |
53 | outline: #9E9E9E outset 3px |
|
58 | outline: #9E9E9E outset 3px | |
54 | } |
|
59 | } |
@@ -1,147 +1,150 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;; API deals with DOM manipulation and some bookkeeping for the |
|
4 | ;;; API deals with DOM manipulation and some bookkeeping for the | |
5 | ;;; intrinsics, namely variables |
|
5 | ;;; intrinsics, namely variables | |
6 | ;;; API is an implementation detail and has no QSP documentation. It |
|
6 | ;;; API is an implementation detail and has no QSP documentation. It | |
7 | ;;; doesn't call intrinsics |
|
7 | ;;; doesn't call intrinsics | |
8 |
|
8 | |||
9 | (setf (root api) (ps:create)) |
|
9 | (setf (root api) (ps:create)) | |
10 |
|
10 | |||
11 | ;;; Utils |
|
11 | ;;; Utils | |
12 |
|
12 | |||
13 | (defm (root api make-act-html) (title img) |
|
13 | (defm (root api make-act-html) (title img) | |
14 | (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>" |
|
14 | (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>" | |
15 | title |
|
15 | title | |
16 | "</a>")) |
|
16 | "</a>")) | |
17 |
|
17 | |||
18 | ;;; Startup |
|
18 | ;; To be used in saving game | |
19 |
|
19 | (defm (root api stash-state) () | ||
20 | (defm (root api init-dom) () |
|
20 | (setf (root state-stash) | |
21 | ) |
|
21 | (ps:create vars (root vars) | |
|
22 | objs (root objs) | |||
|
23 | next-location (root current-location))) | |||
|
24 | (values)) | |||
22 |
|
25 | |||
23 | ;;; Misc |
|
26 | ;;; Misc | |
24 |
|
27 | |||
25 | (defm (root api clear-id) (id) |
|
28 | (defm (root api clear-id) (id) | |
26 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) |
|
29 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) | |
27 |
|
30 | |||
28 | (defm (root api get-id) (id) |
|
31 | (defm (root api get-id) (id) | |
29 | (if (var "USEHTML" 0) |
|
32 | (if (var "USEHTML" 0) | |
30 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) |
|
33 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) | |
31 | (ps:chain (document.get-element-by-id id) inner-text))) |
|
34 | (ps:chain (document.get-element-by-id id) inner-text))) | |
32 |
|
35 | |||
33 | (defm (root api set-id) (id contents) |
|
36 | (defm (root api set-id) (id contents) | |
34 | (if (var "USEHTML" 0) |
|
37 | (if (var "USEHTML" 0) | |
35 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
38 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |
36 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) |
|
39 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
37 |
|
40 | |||
38 | (defm (root api append-id) (id contents) |
|
41 | (defm (root api append-id) (id contents) | |
39 | (if (var "USEHTML" 0) |
|
42 | (if (var "USEHTML" 0) | |
40 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) |
|
43 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |
41 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) |
|
44 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |
42 |
|
45 | |||
43 | ;;; Function calls |
|
46 | ;;; Function calls | |
44 |
|
47 | |||
45 | (defm (root api init-args) (args) |
|
48 | (defm (root api init-args) (args) | |
46 | (dotimes (i (length args)) |
|
49 | (dotimes (i (length args)) | |
47 | (if (numberp (elt args i)) |
|
50 | (if (numberp (elt args i)) | |
48 | (set (var args i) (elt args i)) |
|
51 | (set (var args i) (elt args i)) | |
49 | (set (var $args i) (elt args i))))) |
|
52 | (set (var $args i) (elt args i))))) | |
50 |
|
53 | |||
51 | (defm (root api get-result) () |
|
54 | (defm (root api get-result) () | |
52 | (if (not (equal "" (var $result 0))) |
|
55 | (if (not (equal "" (var $result 0))) | |
53 | (var $result 0) |
|
56 | (var $result 0) | |
54 | (var result 0))) |
|
57 | (var result 0))) | |
55 |
|
58 | |||
56 | ;;; Text windows |
|
59 | ;;; Text windows | |
57 |
|
60 | |||
58 | (defm (root api key-to-id) (key) |
|
61 | (defm (root api key-to-id) (key) | |
59 | (case key |
|
62 | (case key | |
60 | (:main "qsp-main") |
|
63 | (:main "qsp-main") | |
61 | (:stat "qsp-stat") |
|
64 | (:stat "qsp-stat") | |
62 | (t (report-error "Internal error!")))) |
|
65 | (t (report-error "Internal error!")))) | |
63 |
|
66 | |||
64 | (defm (root api add-text) (key text) |
|
67 | (defm (root api add-text) (key text) | |
65 | (api-call append-id (api-call key-to-id key) text)) |
|
68 | (api-call append-id (api-call key-to-id key) text)) | |
66 |
|
69 | |||
67 | (defm (root api get-text) (key) |
|
70 | (defm (root api get-text) (key) | |
68 | (api-call get-id (api-call key-to-id key))) |
|
71 | (api-call get-id (api-call key-to-id key))) | |
69 |
|
72 | |||
70 | (defm (root api clear-text) (key) |
|
73 | (defm (root api clear-text) (key) | |
71 | (api-call clear-id (api-call key-to-id key))) |
|
74 | (api-call clear-id (api-call key-to-id key))) | |
72 |
|
75 | |||
73 | (defm (root api newline) (key) |
|
76 | (defm (root api newline) (key) | |
74 | (let ((div (document.get-element-by-id |
|
77 | (let ((div (document.get-element-by-id | |
75 | (api-call key-to-id key)))) |
|
78 | (api-call key-to-id key)))) | |
76 | (ps:chain div (append-child (document.create-element "br"))))) |
|
79 | (ps:chain div (append-child (document.create-element "br"))))) | |
77 |
|
80 | |||
78 | ;;; Actions |
|
81 | ;;; Actions | |
79 |
|
82 | |||
80 | (defm (root api add-act) (title img act) |
|
83 | (defm (root api add-act) (title img act) | |
81 | (setf (ps:getprop (root acts) title) |
|
84 | (setf (ps:getprop (root acts) title) | |
82 | (ps:create :img img :act act))) |
|
85 | (ps:create :img img :act act))) | |
83 |
|
86 | |||
84 | (defm (root api del-act) (title) |
|
87 | (defm (root api del-act) (title) | |
85 | (delete (ps:getprop (root acts) title)) |
|
88 | (delete (ps:getprop (root acts) title)) | |
86 | (api-call update-acts)) |
|
89 | (api-call update-acts)) | |
87 |
|
90 | |||
88 | (defm (root api clear-act) () |
|
91 | (defm (root api clear-act) () | |
89 | (setf (root acts) (ps:create)) |
|
92 | (setf (root acts) (ps:create)) | |
90 | (api-call clear-id "qsp-acts")) |
|
93 | (api-call clear-id "qsp-acts")) | |
91 |
|
94 | |||
92 | (defm (root api update-acts) () |
|
95 | (defm (root api update-acts) () | |
93 | (api-call clear-id "qsp-acts") |
|
96 | (api-call clear-id "qsp-acts") | |
94 | (ps:for-in (title (root acts)) |
|
97 | (ps:for-in (title (root acts)) | |
95 | (let ((obj (ps:getprop (root acts) title))) |
|
98 | (let ((obj (ps:getprop (root acts) title))) | |
96 | (api-call append-id "qsp-acts" |
|
99 | (api-call append-id "qsp-acts" | |
97 | (api-call make-act-html title (ps:getprop obj :img)))))) |
|
100 | (api-call make-act-html title (ps:getprop obj :img)))))) | |
98 |
|
101 | |||
99 | ;;; Variables |
|
102 | ;;; Variables | |
100 |
|
103 | |||
101 | (defm (root api var-slot) (name) |
|
104 | (defm (root api var-slot) (name) | |
102 | (if (= (ps:@ name 0) #\$) |
|
105 | (if (= (ps:@ name 0) #\$) | |
103 | :str |
|
106 | :str | |
104 | :num)) |
|
107 | :num)) | |
105 |
|
108 | |||
106 | (defm (root api var-real-name) (name) |
|
109 | (defm (root api var-real-name) (name) | |
107 | (if (= (ps:@ name 0) #\$) |
|
110 | (if (= (ps:@ name 0) #\$) | |
108 | (ps:chain name (substr 1)) |
|
111 | (ps:chain name (substr 1)) | |
109 | name)) |
|
112 | name)) | |
110 |
|
113 | |||
111 | (defm (root api ensure-var) (name index) |
|
114 | (defm (root api ensure-var) (name index) | |
112 | (unless (in name (root vars)) |
|
115 | (unless (in name (root vars)) | |
113 | (setf (ps:getprop (root vars) name) |
|
116 | (setf (ps:getprop (root vars) name) | |
114 | (ps:create))) |
|
117 | (ps:create))) | |
115 | (unless (in index (ps:getprop (root vars) name)) |
|
118 | (unless (in index (ps:getprop (root vars) name)) | |
116 | (setf (ps:getprop (root vars) name index) |
|
119 | (setf (ps:getprop (root vars) name index) | |
117 | (ps:create :num 0 :str ""))) |
|
120 | (ps:create :num 0 :str ""))) | |
118 | (values)) |
|
121 | (values)) | |
119 |
|
122 | |||
120 | (defm (root api get-var) (name index) |
|
123 | (defm (root api get-var) (name index) | |
121 | (let ((var-name (api-call var-real-name name))) |
|
124 | (let ((var-name (api-call var-real-name name))) | |
122 | (api-call ensure-var var-name index) |
|
125 | (api-call ensure-var var-name index) | |
123 | (ps:getprop (root vars) var-name index |
|
126 | (ps:getprop (root vars) var-name index | |
124 | (api-call var-slot name)))) |
|
127 | (api-call var-slot name)))) | |
125 |
|
128 | |||
126 | (defm (root api set-var) (name index value) |
|
129 | (defm (root api set-var) (name index value) | |
127 | (let ((var-name (api-call var-real-name name))) |
|
130 | (let ((var-name (api-call var-real-name name))) | |
128 | (api-call ensure-var var-name index) |
|
131 | (api-call ensure-var var-name index) | |
129 | (setf (ps:getprop (root vars) var-name index |
|
132 | (setf (ps:getprop (root vars) var-name index | |
130 | (api-call var-slot name)) |
|
133 | (api-call var-slot name)) | |
131 | value) |
|
134 | value) | |
132 | (values))) |
|
135 | (values))) | |
133 |
|
136 | |||
134 | (defm (root api kill-var) (name index) |
|
137 | (defm (root api kill-var) (name index) | |
135 | (if (eq index :whole) |
|
138 | (if (eq index :whole) | |
136 | (ps:delete (ps:getprop (root vars) name)) |
|
139 | (ps:delete (ps:getprop (root vars) name)) | |
137 | (ps:delete (ps:getprop (root vars) name index))) |
|
140 | (ps:delete (ps:getprop (root vars) name index))) | |
138 | (values)) |
|
141 | (values)) | |
139 |
|
142 | |||
140 | ;;; Objects |
|
143 | ;;; Objects | |
141 |
|
144 | |||
142 | (defm (root api update-objs) () |
|
145 | (defm (root api update-objs) () | |
143 | (let ((elt (document.get-element-by-id "qsp-objs"))) |
|
146 | (let ((elt (document.get-element-by-id "qsp-objs"))) | |
144 | (setf elt.inner-h-t-m-l "<ul>") |
|
147 | (setf elt.inner-h-t-m-l "<ul>") | |
145 | (loop :for obj :in (root objs) |
|
148 | (loop :for obj :in (root objs) | |
146 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) |
|
149 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) | |
147 | (incf elt.inner-h-t-m-l "</ul>"))) |
|
150 | (incf elt.inner-h-t-m-l "</ul>"))) |
@@ -1,298 +1,299 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;;; Functions and procedures defined by the QSP language. |
|
4 | ;;;; Functions and procedures defined by the QSP language. | |
5 | ;;;; They can call api and deal with locations and other data directly. |
|
5 | ;;;; They can call api and deal with locations and other data directly. | |
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. |
|
6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. | |
7 |
|
7 | |||
8 | (setf (root lib) (ps:create)) |
|
8 | (setf (root lib) (ps:create)) | |
9 |
|
9 | |||
10 | ;;; 1loc |
|
10 | ;;; 1loc | |
11 |
|
11 | |||
12 | (defm (root lib goto) (target &rest args) |
|
12 | (defm (root lib goto) (target &rest args) | |
13 | (api-call clear-text :main) |
|
13 | (api-call clear-text :main) | |
14 | (apply (root lib xgoto) target args)) |
|
14 | (apply (root lib xgoto) target args)) | |
15 |
|
15 | |||
16 | (defm (root lib xgoto) (target &rest args) |
|
16 | (defm (root lib xgoto) (target &rest args) | |
17 | (api-call clear-act) |
|
17 | (api-call clear-act) | |
18 | (api-call init-args args) |
|
18 | (api-call init-args args) | |
19 | (setf (root current-location) target) |
|
19 | (setf (root current-location) target) | |
|
20 | (api-call stash-state) | |||
20 | (funcall (ps:getprop (root locations) (ps:chain target (to-upper-case))))) |
|
21 | (funcall (ps:getprop (root locations) (ps:chain target (to-upper-case))))) | |
21 |
|
22 | |||
22 | ;;; 2var |
|
23 | ;;; 2var | |
23 |
|
24 | |||
24 | (defm (root lib killvar) (varname &optional (index :whole)) |
|
25 | (defm (root lib killvar) (varname &optional (index :whole)) | |
25 | (api-call kill-var varname index)) |
|
26 | (api-call kill-var varname index)) | |
26 |
|
27 | |||
27 | (defm (root lib killall) () |
|
28 | (defm (root lib killall) () | |
28 | (api-call kill-all)) |
|
29 | (api-call kill-all)) | |
29 |
|
30 | |||
30 | ;;; 3expr |
|
31 | ;;; 3expr | |
31 |
|
32 | |||
32 | (defm (root lib obj) (name) |
|
33 | (defm (root lib obj) (name) | |
33 | (funcall (root objs includes) name)) |
|
34 | (funcall (root objs includes) name)) | |
34 |
|
35 | |||
35 | (defm (root lib loc) () |
|
36 | (defm (root lib loc) () | |
36 | (funcall (root locations includes) name)) |
|
37 | (funcall (root locations includes) name)) | |
37 |
|
38 | |||
38 | (defm (root lib no) (arg) |
|
39 | (defm (root lib no) (arg) | |
39 | (- -1 arg)) |
|
40 | (- -1 arg)) | |
40 |
|
41 | |||
41 | ;;; 4code |
|
42 | ;;; 4code | |
42 |
|
43 | |||
43 | (defm (root lib qspver) () |
|
44 | (defm (root lib qspver) () | |
44 | "0.0.1") |
|
45 | "0.0.1") | |
45 |
|
46 | |||
46 | (defm (root lib curloc) () |
|
47 | (defm (root lib curloc) () | |
47 | (root current-location)) |
|
48 | (root current-location)) | |
48 |
|
49 | |||
49 | (defm (root lib rand) (a b) |
|
50 | (defm (root lib rand) (a b) | |
50 | (let ((min (min a b)) |
|
51 | (let ((min (min a b)) | |
51 | (max (max a b))) |
|
52 | (max (max a b))) | |
52 | (+ min (ps:chain *math (random (- max min)))))) |
|
53 | (+ min (ps:chain *math (random (- max min)))))) | |
53 |
|
54 | |||
54 | (defm (root lib rnd) () |
|
55 | (defm (root lib rnd) () | |
55 | (funcall (root lib rand) 1 1000)) |
|
56 | (funcall (root lib rand) 1 1000)) | |
56 |
|
57 | |||
57 | (defm (root lib qspmax) (&rest args) |
|
58 | (defm (root lib qspmax) (&rest args) | |
58 | (apply (ps:@ *math max) args)) |
|
59 | (apply (ps:@ *math max) args)) | |
59 |
|
60 | |||
60 | (defm (root lib qspmin) (&rest args) |
|
61 | (defm (root lib qspmin) (&rest args) | |
61 | (apply (ps:@ *math min) args)) |
|
62 | (apply (ps:@ *math min) args)) | |
62 |
|
63 | |||
63 | ;;; 5arrays |
|
64 | ;;; 5arrays | |
64 |
|
65 | |||
65 | (defm (root lib copyarr) (to from start count) |
|
66 | (defm (root lib copyarr) (to from start count) | |
66 | (ps:for ((i start)) |
|
67 | (ps:for ((i start)) | |
67 | ((< i (min (api-call array-size from) |
|
68 | ((< i (min (api-call array-size from) | |
68 | (+ start count)))) |
|
69 | (+ start count)))) | |
69 | ((incf i)) |
|
70 | ((incf i)) | |
70 | (api-call set-var to (+ start i) |
|
71 | (api-call set-var to (+ start i) | |
71 | (api-call get-var from (+ start i))))) |
|
72 | (api-call get-var from (+ start i))))) | |
72 |
|
73 | |||
73 | (defm (root lib arrsize) (name) |
|
74 | (defm (root lib arrsize) (name) | |
74 | (api-call array-size name)) |
|
75 | (api-call array-size name)) | |
75 |
|
76 | |||
76 | (defm (root lib arrpos) (name value &optional (start 0)) |
|
77 | (defm (root lib arrpos) (name value &optional (start 0)) | |
77 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
78 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |
78 | (when (eq (api-call get-var name i) value) |
|
79 | (when (eq (api-call get-var name i) value) | |
79 | (return i))) |
|
80 | (return i))) | |
80 | -1) |
|
81 | -1) | |
81 |
|
82 | |||
82 | (defm (root lib arrcomp) (name pattern &optional (start 0)) |
|
83 | (defm (root lib arrcomp) (name pattern &optional (start 0)) | |
83 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) |
|
84 | (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) | |
84 | (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) |
|
85 | (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern) | |
85 | (return i))) |
|
86 | (return i))) | |
86 | -1) |
|
87 | -1) | |
87 |
|
88 | |||
88 | ;;; 6str |
|
89 | ;;; 6str | |
89 |
|
90 | |||
90 | (defm (root lib len) (s) |
|
91 | (defm (root lib len) (s) | |
91 | (length s)) |
|
92 | (length s)) | |
92 |
|
93 | |||
93 | (defm (root lib mid) (s from &optional count) |
|
94 | (defm (root lib mid) (s from &optional count) | |
94 | (s.substring from count)) |
|
95 | (s.substring from count)) | |
95 |
|
96 | |||
96 | (defm (root lib ucase) (s) |
|
97 | (defm (root lib ucase) (s) | |
97 | (s.to-upper-case)) |
|
98 | (s.to-upper-case)) | |
98 |
|
99 | |||
99 | (defm (root lib lcase) (s) |
|
100 | (defm (root lib lcase) (s) | |
100 | (s.to-lower-case)) |
|
101 | (s.to-lower-case)) | |
101 |
|
102 | |||
102 | (defm (root lib trim) (s) |
|
103 | (defm (root lib trim) (s) | |
103 | (s.trim)) |
|
104 | (s.trim)) | |
104 |
|
105 | |||
105 | (defm (root lib replace) (s from to) |
|
106 | (defm (root lib replace) (s from to) | |
106 | (s.replace from to)) |
|
107 | (s.replace from to)) | |
107 |
|
108 | |||
108 | (defm (root lib instr) (s subs &optional (start 1)) |
|
109 | (defm (root lib instr) (s subs &optional (start 1)) | |
109 | (+ start (ps:chain s (substring (- start 1)) (search subs)))) |
|
110 | (+ start (ps:chain s (substring (- start 1)) (search subs)))) | |
110 |
|
111 | |||
111 | (defm (root lib isnum) (s) |
|
112 | (defm (root lib isnum) (s) | |
112 | (if (is-na-n s) |
|
113 | (if (is-na-n s) | |
113 | 0 |
|
114 | 0 | |
114 | -1)) |
|
115 | -1)) | |
115 |
|
116 | |||
116 | (defm (root lib val) (s) |
|
117 | (defm (root lib val) (s) | |
117 | (parse-int s 10)) |
|
118 | (parse-int s 10)) | |
118 |
|
119 | |||
119 | (defm (root lib qspstr) (n) |
|
120 | (defm (root lib qspstr) (n) | |
120 | (+ "" n)) |
|
121 | (+ "" n)) | |
121 |
|
122 | |||
122 | (defm (root lib strcomp) (s pattern) |
|
123 | (defm (root lib strcomp) (s pattern) | |
123 | (if (s.match pattern) |
|
124 | (if (s.match pattern) | |
124 | -1 |
|
125 | -1 | |
125 | 0)) |
|
126 | 0)) | |
126 |
|
127 | |||
127 | (defm (root lib strfind) (s pattern group) |
|
128 | (defm (root lib strfind) (s pattern group) | |
128 | (let* ((re (ps:new (*reg-exp pattern))) |
|
129 | (let* ((re (ps:new (*reg-exp pattern))) | |
129 | (match (re.exec s))) |
|
130 | (match (re.exec s))) | |
130 | (match.group group))) |
|
131 | (match.group group))) | |
131 |
|
132 | |||
132 | (defm (root lib strpos) (s pattern &optional (group 0)) |
|
133 | (defm (root lib strpos) (s pattern &optional (group 0)) | |
133 | (let* ((re (ps:new (*reg-exp pattern))) |
|
134 | (let* ((re (ps:new (*reg-exp pattern))) | |
134 | (match (re.exec s)) |
|
135 | (match (re.exec s)) | |
135 | (found (match.group group))) |
|
136 | (found (match.group group))) | |
136 | (if found |
|
137 | (if found | |
137 | (s.search found) |
|
138 | (s.search found) | |
138 | 0))) |
|
139 | 0))) | |
139 |
|
140 | |||
140 | ;;; 7if |
|
141 | ;;; 7if | |
141 |
|
142 | |||
142 | (defm (root lib iif) (cond-expr then-expr else-expr) |
|
143 | (defm (root lib iif) (cond-expr then-expr else-expr) | |
143 | (if (= -1 cond-expr) then-expr else-expr)) |
|
144 | (if (= -1 cond-expr) then-expr else-expr)) | |
144 |
|
145 | |||
145 | ;;; 8sub |
|
146 | ;;; 8sub | |
146 |
|
147 | |||
147 | (defm (root lib gosub) (target &rest args) |
|
148 | (defm (root lib gosub) (target &rest args) | |
148 |
(conserving-vars (args |
|
149 | (conserving-vars (args result) | |
149 | (api-call init-args args) |
|
150 | (api-call init-args args) | |
150 | (funcall (ps:getprop (root locations) target)) |
|
151 | (funcall (ps:getprop (root locations) target)) | |
151 | (values))) |
|
152 | (values))) | |
152 |
|
153 | |||
153 | (defm (root lib func) (target &rest args) |
|
154 | (defm (root lib func) (target &rest args) | |
154 |
(conserving-vars (args |
|
155 | (conserving-vars (args result) | |
155 | (api-call init-args args) |
|
156 | (api-call init-args args) | |
156 | (funcall (ps:getprop (root locations) target)) |
|
157 | (funcall (ps:getprop (root locations) target)) | |
157 | (api-call get-result))) |
|
158 | (api-call get-result))) | |
158 |
|
159 | |||
159 | ;;; 9loops |
|
160 | ;;; 9loops | |
160 |
|
161 | |||
161 | ;;; 10dynamic |
|
162 | ;;; 10dynamic | |
162 |
|
163 | |||
163 | (defm (root lib dyneval) (block &rest args) |
|
164 | (defm (root lib dyneval) (block &rest args) | |
164 |
(conserving-vars (args |
|
165 | (conserving-vars (args result) | |
165 | (api-call init-args args) |
|
166 | (api-call init-args args) | |
166 | (funcall block) |
|
167 | (funcall block) | |
167 | (api-call get-result))) |
|
168 | (api-call get-result))) | |
168 |
|
169 | |||
169 | (defm (root lib dynamic) (&rest args) |
|
170 | (defm (root lib dynamic) (&rest args) | |
170 |
(conserving-vars (args |
|
171 | (conserving-vars (args result) | |
171 | (api-call init-args args) |
|
172 | (api-call init-args args) | |
172 | (funcall block) |
|
173 | (funcall block) | |
173 | (values))) |
|
174 | (values))) | |
174 |
|
175 | |||
175 | ;;; 11main |
|
176 | ;;; 11main | |
176 |
|
177 | |||
177 | (defm (root lib main-p) (s) |
|
178 | (defm (root lib main-p) (s) | |
178 | (api-call add-text :main s)) |
|
179 | (api-call add-text :main s)) | |
179 |
|
180 | |||
180 | (defm (root lib main-pl) (s) |
|
181 | (defm (root lib main-pl) (s) | |
181 | (api-call add-text :main s) |
|
182 | (api-call add-text :main s) | |
182 | (api-call newline :main)) |
|
183 | (api-call newline :main)) | |
183 |
|
184 | |||
184 | (defm (root lib main-nl) (s) |
|
185 | (defm (root lib main-nl) (s) | |
185 | (api-call newline :main) |
|
186 | (api-call newline :main) | |
186 | (api-call add-text :main s)) |
|
187 | (api-call add-text :main s)) | |
187 |
|
188 | |||
188 | (defm (root lib maintxt) (s) |
|
189 | (defm (root lib maintxt) (s) | |
189 | (api-call get-text :main)) |
|
190 | (api-call get-text :main)) | |
190 |
|
191 | |||
191 | (defm (root lib desc) (s) |
|
192 | (defm (root lib desc) (s) | |
192 | (api-call report-error "DESC is not supported")) |
|
193 | "") | |
193 |
|
194 | |||
194 | (defm (root lib main-clear) () |
|
195 | (defm (root lib main-clear) () | |
195 | (api-call clear-text :main)) |
|
196 | (api-call clear-text :main)) | |
196 |
|
197 | |||
197 | ;;; 12stat |
|
198 | ;;; 12stat | |
198 |
|
199 | |||
199 | (defm (root lib showstat) ()) |
|
200 | (defm (root lib showstat) ()) | |
200 |
|
201 | |||
201 | (defm (root lib stat-p) ()) |
|
202 | (defm (root lib stat-p) ()) | |
202 |
|
203 | |||
203 | (defm (root lib stat-pl) ()) |
|
204 | (defm (root lib stat-pl) ()) | |
204 |
|
205 | |||
205 | (defm (root lib stat-nl) ()) |
|
206 | (defm (root lib stat-nl) ()) | |
206 |
|
207 | |||
207 | (defm (root lib stattxt) ()) |
|
208 | (defm (root lib stattxt) ()) | |
208 |
|
209 | |||
209 | (defm (root lib clear) ()) |
|
210 | (defm (root lib clear) ()) | |
210 |
|
211 | |||
211 | (defm (root lib cls) ()) |
|
212 | (defm (root lib cls) ()) | |
212 |
|
213 | |||
213 | ;;; 13diag |
|
214 | ;;; 13diag | |
214 |
|
215 | |||
215 | (defm (root lib msg) ()) |
|
216 | (defm (root lib msg) ()) | |
216 |
|
217 | |||
217 | ;;; 14act |
|
218 | ;;; 14act | |
218 |
|
219 | |||
219 | (defm (root lib showacts) ()) |
|
220 | (defm (root lib showacts) ()) | |
220 |
|
221 | |||
221 | (defm (root lib delact) (name) |
|
222 | (defm (root lib delact) (name) | |
222 | (api-call del-act name)) |
|
223 | (api-call del-act name)) | |
223 |
|
224 | |||
224 | (defm (root lib curacts) ()) |
|
225 | (defm (root lib curacts) ()) | |
225 |
|
226 | |||
226 | (defm (root lib cla) ()) |
|
227 | (defm (root lib cla) ()) | |
227 |
|
228 | |||
228 | ;;; 15objs |
|
229 | ;;; 15objs | |
229 |
|
230 | |||
230 | (defm (root lib showobjs) ()) |
|
231 | (defm (root lib showobjs) ()) | |
231 |
|
232 | |||
232 | (defm (root lib addobj) (name) |
|
233 | (defm (root lib addobj) (name) | |
233 | (ps:chain (root objs) (push name)) |
|
234 | (ps:chain (root objs) (push name)) | |
234 | (api-call update-objs)) |
|
235 | (api-call update-objs)) | |
235 |
|
236 | |||
236 | (defm (root lib delobj) (name) |
|
237 | (defm (root lib delobj) (name) | |
237 | (let ((index (ps:chain (root objs) (index-of name)))) |
|
238 | (let ((index (ps:chain (root objs) (index-of name)))) | |
238 | (when (> index -1) |
|
239 | (when (> index -1) | |
239 | (ps:chain (root objs) (splice index 1)))) |
|
240 | (ps:chain (root objs) (splice index 1)))) | |
240 | (api-call update-objs)) |
|
241 | (api-call update-objs)) | |
241 |
|
242 | |||
242 | (defm (root lib killobj) ()) |
|
243 | (defm (root lib killobj) ()) | |
243 |
|
244 | |||
244 | (defm (root lib countobj) ()) |
|
245 | (defm (root lib countobj) ()) | |
245 |
|
246 | |||
246 | (defm (root lib getobj) ()) |
|
247 | (defm (root lib getobj) ()) | |
247 |
|
248 | |||
248 | ;;; 16menu |
|
249 | ;;; 16menu | |
249 |
|
250 | |||
250 | (defm (root lib menu) ()) |
|
251 | (defm (root lib menu) ()) | |
251 |
|
252 | |||
252 | ;;; 17sound |
|
253 | ;;; 17sound | |
253 |
|
254 | |||
254 | (defm (root lib play) ()) |
|
255 | (defm (root lib play) ()) | |
255 |
|
256 | |||
256 | (defm (root lib isplay) ()) |
|
257 | (defm (root lib isplay) ()) | |
257 |
|
258 | |||
258 | (defm (root lib close) ()) |
|
259 | (defm (root lib close) ()) | |
259 |
|
260 | |||
260 | (defm (root lib closeall) ()) |
|
261 | (defm (root lib closeall) ()) | |
261 |
|
262 | |||
262 | ;;; 18img |
|
263 | ;;; 18img | |
263 |
|
264 | |||
264 | (defm (root lib refint) ()) |
|
265 | (defm (root lib refint) ()) | |
265 |
|
266 | |||
266 | (defm (root lib view) ()) |
|
267 | (defm (root lib view) ()) | |
267 |
|
268 | |||
268 | ;;; 19input |
|
269 | ;;; 19input | |
269 |
|
270 | |||
270 | (defm (root lib showinput) ()) |
|
271 | (defm (root lib showinput) ()) | |
271 |
|
272 | |||
272 | (defm (root lib usertxt) ()) |
|
273 | (defm (root lib usertxt) ()) | |
273 |
|
274 | |||
274 | (defm (root lib cmdclear) ()) |
|
275 | (defm (root lib cmdclear) ()) | |
275 |
|
276 | |||
276 | (defm (root lib input) ()) |
|
277 | (defm (root lib input) ()) | |
277 |
|
278 | |||
278 | ;;; 20time |
|
279 | ;;; 20time | |
279 |
|
280 | |||
280 | (defm (root lib wait) ()) |
|
281 | (defm (root lib wait) ()) | |
281 |
|
282 | |||
282 | (defm (root lib msecscount) ()) |
|
283 | (defm (root lib msecscount) ()) | |
283 |
|
284 | |||
284 | (defm (root lib settimer) ()) |
|
285 | (defm (root lib settimer) ()) | |
285 |
|
286 | |||
286 | ;;; misc |
|
287 | ;;; misc | |
287 |
|
288 | |||
288 | (defm (root lib rgb) ()) |
|
289 | (defm (root lib rgb) ()) | |
289 |
|
290 | |||
290 | (defm (root lib openqst) ()) |
|
291 | (defm (root lib openqst) ()) | |
291 |
|
292 | |||
292 | (defm (root lib addqst) ()) |
|
293 | (defm (root lib addqst) ()) | |
293 |
|
294 | |||
294 | (defm (root lib killqst) ()) |
|
295 | (defm (root lib killqst) ()) | |
295 |
|
296 | |||
296 | (defm (root lib opengame) ()) |
|
297 | (defm (root lib opengame) ()) | |
297 |
|
298 | |||
298 | (defm (root lib savegame) ()) |
|
299 | (defm (root lib savegame) ()) |
@@ -1,15 +1,15 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | (setf (root) |
|
4 | (setf (root) | |
5 | (ps:create vars (ps:create) |
|
5 | (ps:create vars (ps:create) | |
6 | objs (list) |
|
6 | objs (list) | |
|
7 | state-stash (ps:create) | |||
7 | acts (ps:create) |
|
8 | acts (ps:create) | |
8 | locations (ps:create))) |
|
9 | locations (ps:create))) | |
9 |
|
10 | |||
10 | (setf window.onload |
|
11 | (setf window.onload | |
11 | (lambda () |
|
12 | (lambda () | |
12 | (api-call init-dom) |
|
|||
13 | (funcall (ps:getprop (root locations) |
|
13 | (funcall (ps:getprop (root locations) | |
14 | (ps:chain *object (keys (root locations)) 0))) |
|
14 | (ps:chain *object (keys (root locations)) 0))) | |
15 | (values))) |
|
15 | (values))) |
@@ -1,193 +1,192 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
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 | ;;; Utils |
|
8 | ;;; Utils | |
9 |
|
9 | |||
10 | (ps:defpsmacro defm (path args &body body) |
|
10 | (ps:defpsmacro defm (path args &body body) | |
11 | `(setf ,path (lambda ,args ,@body))) |
|
11 | `(setf ,path (lambda ,args ,@body))) | |
12 |
|
12 | |||
13 | (ps:defpsmacro root (&rest path) |
|
13 | (ps:defpsmacro root (&rest path) | |
14 | `(ps:@ *sugar-q-s-p ,@path)) |
|
14 | `(ps:@ *sugar-q-s-p ,@path)) | |
15 |
|
15 | |||
16 | (ps:defpsmacro in (key obj) |
|
16 | (ps:defpsmacro in (key obj) | |
17 | `(ps:chain ,obj (has-own-property ,key))) |
|
17 | `(ps:chain ,obj (has-own-property ,key))) | |
18 |
|
18 | |||
19 | (ps:defpsmacro conserving-vars (vars &body body) |
|
19 | (ps:defpsmacro conserving-vars (vars &body body) | |
20 | "Calls body with safely stored away VARS, and restores their values after that returning what BODY returns." |
|
20 | "Calls body with safely stored away VARS (whole arrays, both namespaces), and restores their values after that returning what BODY returns." | |
21 | `(let ((__conserved (list ,@(loop :for var :in vars |
|
21 | `(let ((__conserved (list ,@(loop :for var :in vars | |
22 |
:collect `(var ,var |
|
22 | :collect `(root vars ,var))))) | |
23 | ,@(loop :for var :in vars |
|
23 | ,@(loop :for var :in vars | |
24 | :collect `(set (var ,var 0) ,(if (char= #\$ (elt (string var) 0)) |
|
24 | :collect `(setf (root vars ,var) (ps:create :num 0 :str ""))) | |
25 | "" 0))) |
|
|||
26 | (unwind-protect |
|
25 | (unwind-protect | |
27 | (progn ,@body) |
|
26 | (progn ,@body) | |
28 | (progn |
|
27 | (progn | |
29 | ,@(loop :for var :in vars |
|
28 | ,@(loop :for var :in vars | |
30 |
|
|
29 | :for i from 0 | |
31 |
:collect `(set (var ,var |
|
30 | :collect `(setf (root vars ,var) (ps:@ __conserved ,i))))))) | |
32 |
|
31 | |||
33 | ;;; Common |
|
32 | ;;; Common | |
34 |
|
33 | |||
35 | (defmacro defpsintrinsic (name) |
|
34 | (defmacro defpsintrinsic (name) | |
36 | `(ps:defpsmacro ,name (&rest args) |
|
35 | `(ps:defpsmacro ,name (&rest args) | |
37 | `(funcall (root lib ,',name) |
|
36 | `(funcall (root lib ,',name) | |
38 | ,@args))) |
|
37 | ,@args))) | |
39 |
|
38 | |||
40 | (defmacro defpsintrinsics (() &rest names) |
|
39 | (defmacro defpsintrinsics (() &rest names) | |
41 | `(progn ,@(loop :for name :in names |
|
40 | `(progn ,@(loop :for name :in names | |
42 | :collect `(defpsintrinsic ,name)))) |
|
41 | :collect `(defpsintrinsic ,name)))) | |
43 |
|
42 | |||
44 | (defpsintrinsics () |
|
43 | (defpsintrinsics () | |
45 | killvar obj loc no qspver curloc rand rnd qspmax qspmin killall copyarr arrsize arrpos arrcomp len mid ucase lcase trim replace instr isnum val qspstr strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear showstat stat-p stat-pl stat-nl stattxt stat-clear cls msg showacts delact curacts cla showobjs addobj delobj killobj countobj getobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer) |
|
44 | killvar obj loc no qspver curloc rand rnd qspmax qspmin killall copyarr arrsize arrpos arrcomp len mid ucase lcase trim replace instr isnum val qspstr strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear showstat stat-p stat-pl stat-nl stattxt stat-clear cls msg showacts delact curacts cla showobjs addobj delobj killobj countobj getobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer) | |
46 |
|
45 | |||
47 | (ps:defpsmacro api-call (func &rest args) |
|
46 | (ps:defpsmacro api-call (func &rest args) | |
48 | `(funcall (root api ,func) ,@args)) |
|
47 | `(funcall (root api ,func) ,@args)) | |
49 |
|
48 | |||
50 | (ps:defpsmacro label-block (&body body) |
|
49 | (ps:defpsmacro label-block (&body body) | |
51 | `(block nil |
|
50 | `(block nil | |
52 | ,@(when (some #'keywordp body) |
|
51 | ,@(when (some #'keywordp body) | |
53 | '((defvar __labels))) |
|
52 | '((defvar __labels))) | |
54 | (tagbody |
|
53 | (tagbody | |
55 | ,@body) |
|
54 | ,@body) | |
56 | (values))) |
|
55 | (values))) | |
57 |
|
56 | |||
58 | (ps:defpsmacro str (&rest forms) |
|
57 | (ps:defpsmacro str (&rest forms) | |
59 | (cond ((zerop (length forms)) |
|
58 | (cond ((zerop (length forms)) | |
60 | "") |
|
59 | "") | |
61 | ((and (= 1 (length forms)) |
|
60 | ((and (= 1 (length forms)) | |
62 | (stringp (first forms))) |
|
61 | (stringp (first forms))) | |
63 | (first forms)) |
|
62 | (first forms)) | |
64 | (t |
|
63 | (t | |
65 | `(& ,@forms)))) |
|
64 | `(& ,@forms)))) | |
66 |
|
65 | |||
67 | ;;; 1loc |
|
66 | ;;; 1loc | |
68 |
|
67 | |||
69 | (ps:defpsmacro location ((name) &body body) |
|
68 | (ps:defpsmacro location ((name) &body body) | |
70 | `(setf (root locations ,name) |
|
69 | `(setf (root locations ,name) | |
71 | (lambda () |
|
70 | (lambda () | |
72 | (label-block |
|
71 | (label-block | |
73 | ,@body |
|
72 | ,@body | |
74 | (api-call update-acts))))) |
|
73 | (api-call update-acts))))) | |
75 |
|
74 | |||
76 | (ps:defpsmacro goto (target &rest args) |
|
75 | (ps:defpsmacro goto (target &rest args) | |
77 | `(progn |
|
76 | `(progn | |
78 | (funcall (root lib goto) ,target ,@args) |
|
77 | (funcall (root lib goto) ,target ,@args) | |
79 | (exit))) |
|
78 | (exit))) | |
80 |
|
79 | |||
81 | (ps:defpsmacro xgoto (target &rest args) |
|
80 | (ps:defpsmacro xgoto (target &rest args) | |
82 | `(progn |
|
81 | `(progn | |
83 | (funcall (root lib xgoto) ,target ,@args) |
|
82 | (funcall (root lib xgoto) ,target ,@args) | |
84 | (exit))) |
|
83 | (exit))) | |
85 |
|
84 | |||
86 | (ps:defpsmacro desc (target) |
|
85 | (ps:defpsmacro desc (target) | |
87 | (declare (ignore target)) |
|
86 | (declare (ignore target)) | |
88 | (report-error "DESC is not supported")) |
|
87 | (report-error "DESC is not supported")) | |
89 |
|
88 | |||
90 | ;;; 2var |
|
89 | ;;; 2var | |
91 |
|
90 | |||
92 | (ps:defpsmacro var (name index) |
|
91 | (ps:defpsmacro var (name index) | |
93 | `(api-call get-var ,(string name) ,index)) |
|
92 | `(api-call get-var ,(string name) ,index)) | |
94 |
|
93 | |||
95 | (ps:defpsmacro set ((var vname vindex) value) |
|
94 | (ps:defpsmacro set ((var vname vindex) value) | |
96 | (assert (eq var 'var)) |
|
95 | (assert (eq var 'var)) | |
97 | `(api-call set-var ,(string vname) ,vindex ,value)) |
|
96 | `(api-call set-var ,(string vname) ,vindex ,value)) | |
98 |
|
97 | |||
99 | ;;; 3expr |
|
98 | ;;; 3expr | |
100 |
|
99 | |||
101 | (ps:defpsmacro <> (op1 op2) |
|
100 | (ps:defpsmacro <> (op1 op2) | |
102 | `(not (equal ,op1 ,op2))) |
|
101 | `(not (equal ,op1 ,op2))) | |
103 |
|
102 | |||
104 | (ps:defpsmacro ! (op1 op2) |
|
103 | (ps:defpsmacro ! (op1 op2) | |
105 | `(not (equal ,op1 ,op2))) |
|
104 | `(not (equal ,op1 ,op2))) | |
106 |
|
105 | |||
107 | ;;; 4code |
|
106 | ;;; 4code | |
108 |
|
107 | |||
109 | (ps:defpsmacro exec (&body body) |
|
108 | (ps:defpsmacro exec (&body body) | |
110 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body))) |
|
109 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body))) | |
111 |
|
110 | |||
112 | ;;; 5arrays |
|
111 | ;;; 5arrays | |
113 |
|
112 | |||
114 | ;;; 6str |
|
113 | ;;; 6str | |
115 |
|
114 | |||
116 | (ps:defpsmacro & (&rest args) |
|
115 | (ps:defpsmacro & (&rest args) | |
117 | `(ps:chain "" (concat ,@args))) |
|
116 | `(ps:chain "" (concat ,@args))) | |
118 |
|
117 | |||
119 | ;;; 7if |
|
118 | ;;; 7if | |
120 |
|
119 | |||
121 | (ps:defpsmacro qspcond (&rest clauses) |
|
120 | (ps:defpsmacro qspcond (&rest clauses) | |
122 | `(cond ,@(loop :for clause :in clauses |
|
121 | `(cond ,@(loop :for clause :in clauses | |
123 | :collect (list (first clause) |
|
122 | :collect (list (first clause) | |
124 | `(tagbody ,@(rest clause)))))) |
|
123 | `(tagbody ,@(rest clause)))))) | |
125 |
|
124 | |||
126 | ;;; 8sub |
|
125 | ;;; 8sub | |
127 |
|
126 | |||
128 | ;;; 9loops |
|
127 | ;;; 9loops | |
129 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels |
|
128 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | |
130 |
|
129 | |||
131 | (ps:defpsmacro jump (target) |
|
130 | (ps:defpsmacro jump (target) | |
132 | `(return-from ,(intern (string-upcase (second target))) |
|
131 | `(return-from ,(intern (string-upcase (second target))) | |
133 | (funcall (ps:getprop __labels ,target)))) |
|
132 | (funcall (ps:getprop __labels ,target)))) | |
134 |
|
133 | |||
135 | (ps:defpsmacro tagbody (&body body) |
|
134 | (ps:defpsmacro tagbody (&body body) | |
136 | (let ((funcs (list nil :__nil))) |
|
135 | (let ((funcs (list nil :__nil))) | |
137 | (dolist (form body) |
|
136 | (dolist (form body) | |
138 | (cond ((keywordp form) |
|
137 | (cond ((keywordp form) | |
139 | (setf (first funcs) (reverse (first funcs))) |
|
138 | (setf (first funcs) (reverse (first funcs))) | |
140 | (push form funcs) |
|
139 | (push form funcs) | |
141 | (push nil funcs)) |
|
140 | (push nil funcs)) | |
142 | (t |
|
141 | (t | |
143 | (push form (first funcs))))) |
|
142 | (push form (first funcs))))) | |
144 | (setf (first funcs) (reverse (first funcs))) |
|
143 | (setf (first funcs) (reverse (first funcs))) | |
145 | (setf funcs (reverse funcs)) |
|
144 | (setf funcs (reverse funcs)) | |
146 | (if (= 2 (length funcs)) |
|
145 | (if (= 2 (length funcs)) | |
147 | `(progn |
|
146 | `(progn | |
148 | ,@body) |
|
147 | ,@body) | |
149 | `(progn |
|
148 | `(progn | |
150 | (setf ,@(loop :for f :on funcs :by #'cddr |
|
149 | (setf ,@(loop :for f :on funcs :by #'cddr | |
151 | :append (list `(ps:@ __labels ,(first f)) |
|
150 | :append (list `(ps:@ __labels ,(first f)) | |
152 | `(block ,(intern (string-upcase (string (first f)))) |
|
151 | `(block ,(intern (string-upcase (string (first f)))) | |
153 | ,@(second f) |
|
152 | ,@(second f) | |
154 | ,@(when (third f) |
|
153 | ,@(when (third f) | |
155 | `((funcall |
|
154 | `((funcall | |
156 | (ps:getprop __labels ,(third f))))))))) |
|
155 | (ps:getprop __labels ,(third f))))))))) | |
157 | (jump (str "__nil")))))) |
|
156 | (jump (str "__nil")))))) | |
158 |
|
157 | |||
159 | (ps:defpsmacro exit () |
|
158 | (ps:defpsmacro exit () | |
160 | `(return-from nil (values))) |
|
159 | `(return-from nil (values))) | |
161 |
|
160 | |||
162 | ;;; 10dynamic |
|
161 | ;;; 10dynamic | |
163 |
|
162 | |||
164 | (ps:defpsmacro qspblock (&body body) |
|
163 | (ps:defpsmacro qspblock (&body body) | |
165 | `(lambda () |
|
164 | `(lambda () | |
166 | (label-block |
|
165 | (label-block | |
167 | ,@body))) |
|
166 | ,@body))) | |
168 |
|
167 | |||
169 | ;;; 11main |
|
168 | ;;; 11main | |
170 |
|
169 | |||
171 | (ps:defpsmacro act (name img &body body) |
|
170 | (ps:defpsmacro act (name img &body body) | |
172 | `(api-call add-act ,name ,img |
|
171 | `(api-call add-act ,name ,img | |
173 | (lambda () |
|
172 | (lambda () | |
174 | (label-block |
|
173 | (label-block | |
175 | ,@body)))) |
|
174 | ,@body)))) | |
176 |
|
175 | |||
177 | ;;; 12aux |
|
176 | ;;; 12aux | |
178 |
|
177 | |||
179 | ;;; 13diag |
|
178 | ;;; 13diag | |
180 |
|
179 | |||
181 | ;;; 14act |
|
180 | ;;; 14act | |
182 |
|
181 | |||
183 | ;;; 15objs |
|
182 | ;;; 15objs | |
184 |
|
183 | |||
185 | ;;; 16menu |
|
184 | ;;; 16menu | |
186 |
|
185 | |||
187 | ;;; 17sound |
|
186 | ;;; 17sound | |
188 |
|
187 | |||
189 | ;;; 18img |
|
188 | ;;; 18img | |
190 |
|
189 | |||
191 | ;;; 19input |
|
190 | ;;; 19input | |
192 |
|
191 | |||
193 | ;;; 20time |
|
192 | ;;; 20time |
General Comments 0
You need to be logged in to leave comments.
Login now