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