Show More
@@ -1,180 +1,166 b'' | |||
|
1 | 1 | |
|
2 | 2 | (in-package txt2web.lib) |
|
3 | 3 | |
|
4 | 4 | ;;;; Macros implementing some intrinsics where it makes sense |
|
5 | 5 | ;;;; E.g. an equivalent JS function exists, or it's a direct API call |
|
6 | 6 | |
|
7 | 7 | ;;; 1loc |
|
8 | 8 | |
|
9 | 9 | ;;; 2var |
|
10 | 10 | |
|
11 | 11 | (defpsmacro killvar (&optional varname index) |
|
12 | 12 | `(api-call kill-var ,varname ,index)) |
|
13 | 13 | |
|
14 | 14 | (defpsmacro killall () |
|
15 | 15 | `(progn |
|
16 | 16 | (killvar) |
|
17 | 17 | (killobj))) |
|
18 | 18 | |
|
19 | 19 | ;;; 3expr |
|
20 | 20 | |
|
21 | 21 | (defpsmacro no (arg) |
|
22 | 22 | `(- -1 ,arg)) |
|
23 | 23 | |
|
24 | 24 | ;;; 4code |
|
25 | 25 | |
|
26 | 26 | (defpsmacro qspver () |
|
27 | 27 | "0.0.1") |
|
28 | 28 | |
|
29 | 29 | (defpsmacro curloc () |
|
30 | 30 | `*current-location) |
|
31 | 31 | |
|
32 | 32 | (defpsmacro rnd () |
|
33 | 33 | `(funcall rand 1 1000)) |
|
34 | 34 | |
|
35 | 35 | (defpsmacro qspmax (&rest args) |
|
36 | 36 | (if (= 1 (length args)) |
|
37 | 37 | `(*math.max.apply nil ,@args) |
|
38 | 38 | `(*math.max ,@args))) |
|
39 | 39 | |
|
40 | 40 | (defpsmacro qspmin (&rest args) |
|
41 | 41 | (if (= 1 (length args)) |
|
42 | 42 | `(*math.min.apply nil ,@args) |
|
43 | 43 | `(*math.min ,@args))) |
|
44 | 44 | |
|
45 | 45 | ;;; 5arrays |
|
46 | 46 | |
|
47 | 47 | (defpsmacro arrsize (name) |
|
48 | 48 | `(api-call array-size ,name)) |
|
49 | 49 | |
|
50 | 50 | ;;; 6str |
|
51 | 51 | |
|
52 | 52 | (defpsmacro len (s) |
|
53 | 53 | `(length ,s)) |
|
54 | 54 | |
|
55 | 55 | (defpsmacro mid (s from &optional count) |
|
56 | 56 | `(chain ,s (substring ,from ,count))) |
|
57 | 57 | |
|
58 | 58 | (defpsmacro ucase (s) |
|
59 | 59 | `(chain ,s (to-upper-case))) |
|
60 | 60 | |
|
61 | 61 | (defpsmacro lcase (s) |
|
62 | 62 | `(chain ,s (to-lower-case))) |
|
63 | 63 | |
|
64 | 64 | (defpsmacro trim (s) |
|
65 | 65 | `(chain ,s (trim))) |
|
66 | 66 | |
|
67 | 67 | (defpsmacro qspreplace (s from to) |
|
68 | 68 | `(chain ,s (replace ,from ,to))) |
|
69 | 69 | |
|
70 | 70 | (defpsmacro val (s) |
|
71 | 71 | `(parse-int ,s 10)) |
|
72 | 72 | |
|
73 | 73 | (defpsmacro qspstr (n) |
|
74 | 74 | `(chain ,n (to-string))) |
|
75 | 75 | |
|
76 | 76 | ;;; 7if |
|
77 | 77 | |
|
78 | 78 | ;;; 8sub |
|
79 | 79 | |
|
80 | 80 | ;;; 9loops |
|
81 | 81 | |
|
82 | 82 | ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) |
|
83 | 83 | |
|
84 | 84 | (defpsmacro exit () |
|
85 | 85 | `(return-from nil (values))) |
|
86 | 86 | |
|
87 | 87 | ;;; 10dynamic |
|
88 | 88 | |
|
89 | (defpsmacro dynamic (block &rest args) | |
|
90 | `(progn | |
|
91 | (when (stringp ,block) | |
|
92 | (api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC.")) | |
|
93 | (api:with-call-args ,args nil | |
|
94 | (funcall ,block)))) | |
|
95 | ||
|
96 | (defpsmacro dyneval (block &rest args) | |
|
97 | `(progn | |
|
98 | (when (stringp ,block) | |
|
99 | (api:report-error "DYNEVAL can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL.")) | |
|
100 | (api:with-call-args ,args t | |
|
101 | (funcall ,block)))) | |
|
102 | ||
|
103 | 89 | ;;; 11main |
|
104 | 90 | |
|
105 | 91 | (defpsmacro desc (s) |
|
106 | 92 | (declare (ignore s)) |
|
107 | 93 | "") |
|
108 | 94 | |
|
109 | 95 | ;;; 12stat |
|
110 | 96 | |
|
111 | 97 | (defpsmacro showstat (enable) |
|
112 | 98 | `(api-call enable-frame :stat ,enable)) |
|
113 | 99 | |
|
114 | 100 | ;;; 13diag |
|
115 | 101 | |
|
116 | 102 | (defpsmacro msg (text) |
|
117 | 103 | `(alert ,text)) |
|
118 | 104 | |
|
119 | 105 | ;;; 14act |
|
120 | 106 | |
|
121 | 107 | (defpsmacro showacts (enable) |
|
122 | 108 | `(api-call enable-frame :acts ,enable)) |
|
123 | 109 | |
|
124 | 110 | (defpsmacro delact (&optional name) |
|
125 | 111 | (if name |
|
126 | 112 | `(api-call del-act ,name) |
|
127 | 113 | `(api-call del-act))) |
|
128 | 114 | |
|
129 | 115 | (defpsmacro cla () |
|
130 | 116 | `(api-call clear-act)) |
|
131 | 117 | |
|
132 | 118 | ;;; 15objs |
|
133 | 119 | |
|
134 | 120 | (defpsmacro showobjs (enable) |
|
135 | 121 | `(api-call enable-frame :objs ,enable)) |
|
136 | 122 | |
|
137 | 123 | (defpsmacro countobj () |
|
138 | 124 | `(length *objs)) |
|
139 | 125 | |
|
140 | 126 | (defpsmacro getobj (index) |
|
141 | 127 | `(or (elt *objs ,index) "")) |
|
142 | 128 | |
|
143 | 129 | ;;; 16menu |
|
144 | 130 | |
|
145 | 131 | ;;; 17sound |
|
146 | 132 | |
|
147 | 133 | (defpsmacro isplay (filename) |
|
148 | 134 | `(funcall (@ playing includes) ,filename)) |
|
149 | 135 | |
|
150 | 136 | ;;; 18img |
|
151 | 137 | |
|
152 | 138 | (defpsmacro view (&optional path) |
|
153 | 139 | `(api-call show-image ,path)) |
|
154 | 140 | |
|
155 | 141 | ;;; 19input |
|
156 | 142 | |
|
157 | 143 | (defpsmacro showinput (enable) |
|
158 | 144 | `(api-call enable-frame :input ,enable)) |
|
159 | 145 | |
|
160 | 146 | ;;; 20time |
|
161 | 147 | |
|
162 | 148 | (defpsmacro wait (msec) |
|
163 | 149 | `(await (api-call sleep ,msec))) |
|
164 | 150 | |
|
165 | 151 | (defpsmacro settimer (interval) |
|
166 | 152 | `(api-call set-timer ,interval)) |
|
167 | 153 | |
|
168 | 154 | ;;; 21local |
|
169 | 155 | |
|
170 | 156 | ;;; 22for |
|
171 | 157 | |
|
172 | 158 | ;;; misc |
|
173 | 159 | |
|
174 | 160 | (defpsmacro opengame (&optional filename) |
|
175 | 161 | (declare (ignore filename)) |
|
176 | 162 | `(api-call opengame)) |
|
177 | 163 | |
|
178 | 164 | (defpsmacro savegame (&optional filename) |
|
179 | 165 | (declare (ignore filename)) |
|
180 | 166 | `(api-call savegame)) |
@@ -1,315 +1,328 b'' | |||
|
1 | 1 | |
|
2 | 2 | (in-package txt2web.lib) |
|
3 | 3 | |
|
4 | 4 | ;;;; Functions and procedures defined by the QSP language. |
|
5 | 5 | ;;;; They can call api and deal with locations and other data directly. |
|
6 | 6 | ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls. |
|
7 | 7 | |
|
8 | 8 | ;;; 1loc |
|
9 | 9 | |
|
10 | 10 | (defun goto (target args) |
|
11 | 11 | (api:clear-text :main) |
|
12 | 12 | (funcall xgoto target args) |
|
13 | 13 | (void)) |
|
14 | 14 | |
|
15 | 15 | (defun xgoto (target args) |
|
16 | 16 | (setf args (or args (list))) |
|
17 | 17 | (api:clear-act) |
|
18 | 18 | (setf *current-location (chain target (to-upper-case))) |
|
19 | 19 | (api:stash-state args) |
|
20 | 20 | (api:call-loc *current-location args) |
|
21 | 21 | (api:call-serv-loc "$ONNEWLOC") |
|
22 | 22 | (void)) |
|
23 | 23 | |
|
24 | 24 | ;;; 2var |
|
25 | 25 | |
|
26 | 26 | ;;; 3expr |
|
27 | 27 | |
|
28 | 28 | (defun obj (name) |
|
29 | 29 | (has name *objs)) |
|
30 | 30 | |
|
31 | 31 | (defun loc (name) |
|
32 | 32 | (has name *locs)) |
|
33 | 33 | |
|
34 | 34 | ;;; 4code |
|
35 | 35 | |
|
36 | 36 | (defun rand (a &optional (b 1)) |
|
37 | 37 | (let ((min (min a b)) |
|
38 | 38 | (max (max a b))) |
|
39 | 39 | (+ min (chain *math (random (- max min)))))) |
|
40 | 40 | |
|
41 | 41 | ;;; 5arrays |
|
42 | 42 | |
|
43 | 43 | (defun copyarr (to from start count) |
|
44 | 44 | (multiple-value-bind (to-name to-slot) |
|
45 | 45 | (api:var-real-name to) |
|
46 | 46 | (multiple-value-bind (from-name from-slot) |
|
47 | 47 | (api:var-real-name from) |
|
48 | 48 | (loop :for i :from start :to (min (api:array-size from-name) |
|
49 | 49 | (+ start count)) |
|
50 | 50 | :do (api:set-var to-name (+ start i) to-slot |
|
51 | 51 | (api:get-var from-name (+ start i) from-slot)))))) |
|
52 | 52 | |
|
53 | 53 | (defun arrpos (name value &optional (start 0)) |
|
54 | 54 | (multiple-value-bind (real-name slot) |
|
55 | 55 | (api:var-real-name name) |
|
56 | 56 | (loop :for i :from start :to (api:array-size name) |
|
57 | 57 | :do (when (eq (api:get-var real-name i slot) value) |
|
58 | 58 | (return-from arrpos i)))) |
|
59 | 59 | -1) |
|
60 | 60 | |
|
61 | 61 | (defun arrcomp (name pattern &optional (start 0)) |
|
62 | 62 | (multiple-value-bind (real-name slot) |
|
63 | 63 | (api:var-real-name name) |
|
64 | 64 | (loop :for i :from start :to (api:array-size name) |
|
65 | 65 | :do (when (funcall (getprop (api:get-var real-name i slot) |
|
66 | 66 | 'match) |
|
67 | 67 | pattern) |
|
68 | 68 | (return-from arrcomp i)))) |
|
69 | 69 | -1) |
|
70 | 70 | |
|
71 | 71 | ;;; 6str |
|
72 | 72 | |
|
73 | 73 | (defun instr (s subs &optional (start 1)) |
|
74 | 74 | (+ start (chain s (substring (- start 1)) (search subs)))) |
|
75 | 75 | |
|
76 | 76 | (defun isnum (s) |
|
77 | 77 | (if (is-na-n s) |
|
78 | 78 | 0 |
|
79 | 79 | -1)) |
|
80 | 80 | |
|
81 | 81 | (defun strcomp (s pattern) |
|
82 | 82 | (if (chain s (match pattern)) |
|
83 | 83 | -1 |
|
84 | 84 | 0)) |
|
85 | 85 | |
|
86 | 86 | (defun strfind (s pattern group) |
|
87 | 87 | (let* ((re (new (*reg-exp pattern))) |
|
88 | 88 | (match (chain re (exec s)))) |
|
89 | 89 | (chain match (group group)))) |
|
90 | 90 | |
|
91 | 91 | (defun strpos (s pattern &optional (group 0)) |
|
92 | 92 | (let* ((re (new (*reg-exp pattern))) |
|
93 | 93 | (match (chain re (exec s))) |
|
94 | 94 | (found (chain match (group group)))) |
|
95 | 95 | (if found |
|
96 | 96 | (chain s (search found)) |
|
97 | 97 | 0))) |
|
98 | 98 | |
|
99 | 99 | ;;; 7if |
|
100 | 100 | |
|
101 | 101 | ;; Has to be a function because it always evaluates all three of its |
|
102 | 102 | ;; arguments |
|
103 | 103 | (defun iif (cond-expr then-expr else-expr) |
|
104 | 104 | (if cond-expr then-expr else-expr)) |
|
105 | 105 | |
|
106 | 106 | ;;; 8sub |
|
107 | 107 | |
|
108 | 108 | (defun gosub (target &rest args) |
|
109 | 109 | (api:call-loc target args) |
|
110 | 110 | (void)) |
|
111 | 111 | |
|
112 | 112 | (defun func (target &rest args) |
|
113 | 113 | (api:call-loc target args)) |
|
114 | 114 | |
|
115 | 115 | ;;; 9loops |
|
116 | 116 | |
|
117 | 117 | ;;; 10dynamic |
|
118 | 118 | |
|
119 | (defun dynamic (block &rest args) | |
|
120 | (when (stringp block) | |
|
121 | (api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC.")) | |
|
122 | (api:with-call-args args nil | |
|
123 | (funcall block))) | |
|
124 | ||
|
125 | (defun dyneval (block &rest args) | |
|
126 | (when (stringp block) | |
|
127 | (api:report-error "DYNEVAL can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL.")) | |
|
128 | (api:with-call-args args t | |
|
129 | (funcall block))) | |
|
130 | ||
|
119 | 131 | ;;; 11main |
|
120 | 132 | |
|
121 | 133 | (defun main-p (s) |
|
122 | 134 | (api:add-text :main s) |
|
123 | 135 | (void)) |
|
124 | 136 | |
|
125 | 137 | (defun main-pl (s) |
|
126 | 138 | (api:add-text :main s) |
|
127 | 139 | (api:newline :main) |
|
128 | 140 | (void)) |
|
129 | 141 | |
|
130 | 142 | (defun main-nl (s) |
|
131 | 143 | (api:newline :main) |
|
132 | 144 | (api:add-text :main s) |
|
133 | 145 | (void)) |
|
134 | 146 | |
|
135 | 147 | (defun maintxt () |
|
136 | 148 | (api:get-text :main)) |
|
137 | 149 | |
|
138 | 150 | (defun desc () |
|
139 | 151 | "") |
|
140 | 152 | |
|
141 | 153 | (defun main-clear () |
|
142 | 154 | (api:clear-text :main) |
|
143 | 155 | (void)) |
|
144 | 156 | |
|
145 | 157 | ;;; 12stat |
|
146 | 158 | |
|
147 | 159 | (defun stat-p (s) |
|
148 | 160 | (api:add-text :stat s) |
|
149 | 161 | (void)) |
|
150 | 162 | |
|
151 | 163 | (defun stat-pl (s) |
|
152 | 164 | (api:add-text :stat s) |
|
153 | 165 | (api:newline :stat) |
|
154 | 166 | (void)) |
|
155 | 167 | |
|
156 | 168 | (defun stat-nl (s) |
|
157 | 169 | (api:newline :stat) |
|
158 | 170 | (api:add-text :stat s) |
|
159 | 171 | (void)) |
|
160 | 172 | |
|
161 | 173 | (defun stattxt () |
|
162 | 174 | (api:get-text :stat)) |
|
163 | 175 | |
|
164 | 176 | (defun stat-clear () |
|
165 | 177 | (api:clear-text :stat) |
|
166 | 178 | (void)) |
|
167 | 179 | |
|
168 | 180 | (defun cls () |
|
169 | 181 | (stat-clear) |
|
170 | 182 | (main-clear) |
|
171 | 183 | (cla) |
|
172 | 184 | (cmdclear) |
|
173 | 185 | (void)) |
|
174 | 186 | |
|
175 | 187 | ;;; 13diag |
|
176 | 188 | |
|
177 | 189 | ;;; 14act |
|
178 | 190 | |
|
179 | 191 | (defun selact () |
|
180 | 192 | (loop :for (k v) :of *acts |
|
181 | 193 | :do (when (@ v :selected) |
|
182 | 194 | (return-from selact (@ v :name))))) |
|
183 | 195 | |
|
184 | 196 | (defun curacts () |
|
185 |
(let ((acts ( |
|
|
197 | (let ((acts (chain *object (assign (create) *acts)))) | |
|
186 | 198 | (lambda () |
|
187 | 199 | (setf *acts acts) |
|
200 | (api:update-acts) | |
|
188 | 201 | (void)))) |
|
189 | 202 | |
|
190 | 203 | ;;; 15objs |
|
191 | 204 | |
|
192 | 205 | (defun addobj (name img) |
|
193 | 206 | (setf img (or img "")) |
|
194 | 207 | (setf (getprop *objs name) |
|
195 | 208 | (create :name name :img img :selected nil)) |
|
196 | 209 | (api:update-objs) |
|
197 | 210 | (api-call call-serv-loc "$ONOBJADD" name img) |
|
198 | 211 | (void)) |
|
199 | 212 | |
|
200 | 213 | (defun delobj (name) |
|
201 | 214 | (delete (getprop *objs name)) |
|
202 | 215 | (api:update-objs) |
|
203 | 216 | (api-call call-serv-loc "$ONOBJDEL" name) |
|
204 | 217 | (void)) |
|
205 | 218 | |
|
206 | 219 | (defun killobj (&optional (num nil)) |
|
207 | 220 | (if (eq undefined num) |
|
208 | 221 | (setf *objs (create)) |
|
209 | 222 | (delobj (elt (chain *object (keys *objs)) num))) |
|
210 | 223 | (api:update-objs) |
|
211 | 224 | (void)) |
|
212 | 225 | |
|
213 | 226 | (defun selobj () |
|
214 | 227 | (loop :for (k v) :of *objs |
|
215 | 228 | :do (when (@ v :selected) |
|
216 | 229 | (return-from selobj (@ v :name))))) |
|
217 | 230 | |
|
218 | 231 | (defun unsel () |
|
219 | 232 | (loop :for (k v) :of *objs |
|
220 | 233 | :do (setf (@ v :selected) nil))) |
|
221 | 234 | |
|
222 | 235 | ;;; 16menu |
|
223 | 236 | |
|
224 | 237 | (defun menu (menu-name) |
|
225 | 238 | (let ((menu-data (list))) |
|
226 | 239 | (loop :for item-obj :in (@ (api:get-array (api:var-real-name menu-name)) values) |
|
227 | 240 | :for item := (@ item-obj :str) |
|
228 | 241 | :do (cond ((string= item "") |
|
229 | 242 | (break)) |
|
230 | 243 | ((string= item "-:-") |
|
231 | 244 | (chain menu-data (push :delimiter))) |
|
232 | 245 | (t |
|
233 | 246 | (let* ((tokens (chain item (split ":")))) |
|
234 | 247 | (when (= (length tokens) 2) |
|
235 | 248 | (chain tokens (push ""))) |
|
236 | 249 | (let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":"))) |
|
237 | 250 | (loc (getprop tokens (- (length tokens) 2))) |
|
238 | 251 | (icon (getprop tokens (- (length tokens) 1)))) |
|
239 | 252 | (chain menu-data |
|
240 | 253 | (push (create :text text |
|
241 | 254 | :loc loc |
|
242 | 255 | :icon icon)))))))) |
|
243 | 256 | (api:menu menu-data) |
|
244 | 257 | (void))) |
|
245 | 258 | |
|
246 | 259 | ;;; 17sound |
|
247 | 260 | |
|
248 | 261 | (defun play (filename &optional (volume 100)) |
|
249 | 262 | (let ((audio (new (*audio filename)))) |
|
250 | 263 | (setf (getprop *playing filename) audio) |
|
251 | 264 | (setf (@ audio volume) (* volume 0.01)) |
|
252 | 265 | (chain audio (play)))) |
|
253 | 266 | |
|
254 | 267 | (defun close (filename) |
|
255 | 268 | (funcall (getprop *playing filename) stop) |
|
256 | 269 | (delete (getprop *playing filename)) |
|
257 | 270 | (void)) |
|
258 | 271 | |
|
259 | 272 | (defun closeall () |
|
260 | 273 | (loop :for k :in (chain *object (keys *playing)) |
|
261 | 274 | :for v := (getprop *playing k) |
|
262 | 275 | :do (funcall v stop)) |
|
263 | 276 | (setf *playing (create))) |
|
264 | 277 | |
|
265 | 278 | ;;; 18img |
|
266 | 279 | |
|
267 | 280 | (defun refint () |
|
268 | 281 | ;; "Force interface update" Uh... what exactly do we do here? |
|
269 | 282 | ;(api:report-error "REFINT is not supported") |
|
270 | 283 | ) |
|
271 | 284 | |
|
272 | 285 | ;;; 19input |
|
273 | 286 | |
|
274 | 287 | (defun usertxt () |
|
275 | 288 | (let ((input (by-id "qsp-input"))) |
|
276 | 289 | (@ input value))) |
|
277 | 290 | |
|
278 | 291 | (defun cmdclear () |
|
279 | 292 | (let ((input (by-id "qsp-input"))) |
|
280 | 293 | (setf (@ input value) ""))) |
|
281 | 294 | |
|
282 | 295 | (defun input (text) |
|
283 | 296 | (chain window (prompt text))) |
|
284 | 297 | |
|
285 | 298 | ;;; 20time |
|
286 | 299 | |
|
287 | 300 | (defun msecscount () |
|
288 | 301 | (- (chain *date (now)) *started-at)) |
|
289 | 302 | |
|
290 | 303 | ;;; 21local |
|
291 | 304 | |
|
292 | 305 | ;;; 22for |
|
293 | 306 | |
|
294 | 307 | ;;; misc |
|
295 | 308 | |
|
296 | 309 | (defun rgb (red green blue) |
|
297 | 310 | (+ (<< red 16) |
|
298 | 311 | (<< green 8) |
|
299 | 312 | blue)) |
|
300 | 313 | |
|
301 | 314 | (defun openqst (name) |
|
302 | 315 | (api-call run-game name)) |
|
303 | 316 | |
|
304 | 317 | (defun addqst (name) |
|
305 | 318 | (let ((game (api-call filename-game name))) |
|
306 | 319 | ;; Add the game's locations |
|
307 | 320 | (chain *object (assign *locs |
|
308 | 321 | (getprop *games name))))) |
|
309 | 322 | |
|
310 | 323 | (defun killqst () |
|
311 | 324 | ;; Delete all locations not from the current main game |
|
312 | 325 | (loop :for (k v) :in *games |
|
313 | 326 | :do (unless (string= k *main-game) |
|
314 | 327 | (delete (getprop *locs k))))) |
|
315 | 328 |
General Comments 0
You need to be logged in to leave comments.
Login now