##// END OF EJS Templates
Menu, game saving
naryl -
r11:ca6bf409 default
parent child Browse files
Show More
@@ -0,0 +1,21 b''
1
2 (in-package sugar-qsp)
3
4 (eval-when (:compile-toplevel :load-toplevel :execute)
5 (defun src-file (filename)
6 (uiop/pathname:merge-pathnames*
7 filename
8 (asdf:system-source-directory :sugar-qsp)))
9 (defun compile-ps (filename)
10 (format nil "////// Parenscript file: ~A~%~%~A"
11 (file-namestring filename) (ps:ps-compile-file filename))))
12
13 (defclass compiler ()
14 ((body :accessor body :initform #.(alexandria:read-file-into-string (src-file "extras/body.html")))
15 (css :accessor css :initform (list #.(alexandria:read-file-into-string (src-file "extras/default.css"))))
16 (js :accessor js :initform (list #.(compile-ps (src-file "src/intrinsics.ps"))
17 #.(compile-ps (src-file "src/api.ps"))
18 #.(compile-ps (src-file "src/main.ps"))))
19 (compile :accessor compile-only :initarg :compile)
20 (target :accessor target :initarg :target)
21 (beautify :accessor beautify :initarg :beautify)))
@@ -0,0 +1,137 b''
1
2 (in-package sugar-qsp)
3
4 ;;;; Macros implementing some intrinsics where it makes sense
5 ;;;; E.g. an equivalent JS function exists, or it's a direct API call
6
7 ;;; 1loc
8
9 ;;; 2var
10
11 (ps:defpsmacro killvar (varname &optional (index :whole))
12 `(api-call kill-var ,varname ,index))
13
14 (ps:defpsmacro killall ()
15 `(api-call kill-all))
16
17 ;;; 3expr
18
19 (ps:defpsmacro obj (name)
20 `(funcall (root objs includes) ,name))
21
22 (ps:defpsmacro loc (name)
23 `(funcall (root locs includes) ,name))
24
25 (ps:defpsmacro no (arg)
26 `(- -1 ,arg))
27
28 ;;; 4code
29
30 (ps:defpsmacro qspver ()
31 "0.0.1")
32
33 (ps:defpsmacro curloc ()
34 `(root current-location))
35
36 (ps:defpsmacro rnd ()
37 `(funcall (root lib rand) 1 1000))
38
39 (ps:defpsmacro qspmax (&rest args)
40 `(max ,@args))
41
42 (ps:defpsmacro qspmin (&rest args)
43 `(min ,@args))
44
45 ;;; 5arrays
46
47 (ps:defpsmacro arrsize (name)
48 `(api-call array-size ,name))
49
50 ;;; 6str
51
52 (ps:defpsmacro len (s)
53 `(length ,s))
54
55 (ps:defpsmacro mid (s from &optional count)
56 `(ps:chain ,s (substring ,from ,count)))
57
58 (ps:defpsmacro ucase (s)
59 `(ps:chain ,s (to-upper-case)))
60
61 (ps:defpsmacro lcase (s)
62 `(ps:chain ,s (to-lower-case)))
63
64 (ps:defpsmacro trim (s)
65 `(ps:chain ,s (trim)))
66
67 (ps:defpsmacro replace (s from to)
68 `(ps:chain ,s (replace ,from ,to)))
69
70 (ps:defpsmacro val (s)
71 `(parse-int ,s 10))
72
73 (ps:defpsmacro qspstr (n)
74 `(ps:chain ,n (to-string)))
75
76 ;;; 7if
77
78 ;;; 8sub
79
80 ;;; 9loops
81
82 ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge)
83
84 (ps:defpsmacro exit ()
85 `(return-from nil (values)))
86
87 ;;; 10dynamic
88
89 ;;; 11main
90
91 (ps:defpsmacro desc (s)
92 (declare (ignore s))
93 "")
94
95 ;;; 12stat
96
97 (ps:defpsmacro showstat (enable)
98 `(api-call enable-frame :stat ,enable))
99
100 ;;; 13diag
101
102 (ps:defpsmacro msg (text)
103 `(alert ,text))
104
105 ;;; 14act
106
107 (ps:defpsmacro showacts (enable)
108 `(api-call enable-frame :acts ,enable))
109
110 (ps:defpsmacro delact (name)
111 `(api-call del-act ,name))
112
113 (ps:defpsmacro cla ()
114 `(api-call clear-act))
115
116 ;;; 15objs
117
118 (ps:defpsmacro showobjs (enable)
119 `(api-call enable-frame :objs ,enable))
120
121 (ps:defpsmacro countobj ()
122 `(length (root objs)))
123
124 (ps:defpsmacro getobj (index)
125 `(or (elt (root objs) ,index) ""))
126
127 ;;; 16menu
128
129 ;;; 17sound
130
131 ;;; 18img
132
133 ;;; 19input
134
135 ;;; 20time
136
137 ;;; misc
@@ -1,9 +1,6 b''
1
1
2 * Windows GUI
2 * Windows GUI (for the compiler)
3 * Save-load game
3 * Save-load game in slots
4 * Resizable frames
4 * Resizable frames
5 * Build Istreblenie
5 * Build Istreblenie
6 ** modifying it to suit compiler specifics
6 ** modifying it to suit compiler specifics No newline at end of file
7 ** Implementing apis and intrinsics as needed
8
9 * Use real characters in cl-uglify-js No newline at end of file
@@ -10,3 +10,6 b''
10 <div id="qsp-objs" class="qsp-frame">&nbsp;</div>
10 <div id="qsp-objs" class="qsp-frame">&nbsp;</div>
11 </div>
11 </div>
12 </div>
12 </div>
13
14 <div id="qsp-dropdown">
15 </div>
@@ -57,3 +57,28 b''
57 .qsp-act:hover {
57 .qsp-act:hover {
58 outline: #9E9E9E outset 3px
58 outline: #9E9E9E outset 3px
59 }
59 }
60
61 // Dropdown
62
63 #qsp-dropdown {
64 display: none;
65 position: absolute;
66 background-color: #f1f1f1;
67 min-width: 160px;
68 overflow: auto;
69 box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2);
70 z-index: 1;
71 margin: auto;
72 top: 200;
73 }
74
75 #qsp-dropdown a {
76 color: black;
77 padding: 12px 16px;
78 text-decoration: none;
79 display: block;
80 }
81
82 #qsp-dropdown a:hover {
83 background-color: #ddd;
84 }
@@ -15,14 +15,35 b''
15 title
15 title
16 "</a>"))
16 "</a>"))
17
17
18 (defm (root api make-menu-item-html) (num title img loc)
19 (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>"
20 "<img src='" img "'>"
21 title
22 "</a>"))
23
18 ;; To be used in saving game
24 ;; To be used in saving game
19 (defm (root api stash-state) ()
25 (defm (root api stash-state) ()
20 (setf (root state-stash)
26 (setf (root state-stash)
21 (ps:create vars (root vars)
27 (*j-s-o-n.stringify
22 objs (root objs)
28 (ps:create vars (root vars)
23 next-location (root current-location)))
29 objs (root objs)
30 next-location (root current-location))))
24 (values))
31 (values))
25
32
33 (defm (root api state-to-base64) ()
34 (btoa (encode-u-r-i-component (root state-stash))))
35
36 (defm (root api base64-to-state) (data)
37 (setf (root state-stash) (decode-u-r-i-component (atob data)))
38 (let ((data (*j-s-o-n.parse (root state-stash))))
39 (api-call clear-act)
40 (setf (root vars) (ps:@ data vars))
41 (setf (root objs) (ps:@ data objs))
42 (setf (root current-location) (ps:@ data next-location))
43 (funcall (root locs (root current-location)))
44 (api-call update-objs)
45 (values)))
46
26 ;;; Misc
47 ;;; Misc
27
48
28 (defm (root api clear-id) (id)
49 (defm (root api clear-id) (id)
@@ -62,8 +83,15 b''
62 (case key
83 (case key
63 (:main "qsp-main")
84 (:main "qsp-main")
64 (:stat "qsp-stat")
85 (:stat "qsp-stat")
86 (:objs "qsp-objs")
87 (:acts "qsp-acts")
88 (:input "qsp-input")
89 (:dropdown "qsp-dropdown")
65 (t (report-error "Internal error!"))))
90 (t (report-error "Internal error!"))))
66
91
92 (defm (root api get-frame) (key)
93 (document.get-element-by-id (api-call key-to-id key)))
94
67 (defm (root api add-text) (key text)
95 (defm (root api add-text) (key text)
68 (api-call append-id (api-call key-to-id key) text))
96 (api-call append-id (api-call key-to-id key) text))
69
97
@@ -74,15 +102,20 b''
74 (api-call clear-id (api-call key-to-id key)))
102 (api-call clear-id (api-call key-to-id key)))
75
103
76 (defm (root api newline) (key)
104 (defm (root api newline) (key)
77 (let ((div (document.get-element-by-id
105 (let ((div (api-call get-frame key)))
78 (api-call key-to-id key))))
79 (ps:chain div (append-child (document.create-element "br")))))
106 (ps:chain div (append-child (document.create-element "br")))))
80
107
108 (defm (root api enable-frame) (key enable)
109 (let ((clss (ps:getprop (api-call get-frame key) 'class-list)))
110 (setf clss.style.display (if enable "block" "none"))
111 (values)))
112
81 ;;; Actions
113 ;;; Actions
82
114
83 (defm (root api add-act) (title img act)
115 (defm (root api add-act) (title img act)
84 (setf (ps:getprop (root acts) title)
116 (setf (ps:getprop (root acts) title)
85 (ps:create :img img :act act)))
117 (ps:create :img img :act act))
118 (api-call update-acts))
86
119
87 (defm (root api del-act) (title)
120 (defm (root api del-act) (title)
88 (delete (ps:getprop (root acts) title))
121 (delete (ps:getprop (root acts) title))
@@ -134,12 +167,18 b''
134 value)
167 value)
135 (values)))
168 (values)))
136
169
170 (defm (root api get-array) (name type)
171 (ps:getprop (root vars) (api-call var-real-name name)))
172
137 (defm (root api kill-var) (name index)
173 (defm (root api kill-var) (name index)
138 (if (eq index :whole)
174 (if (eq index :whole)
139 (ps:delete (ps:getprop (root vars) name))
175 (ps:delete (ps:getprop (root vars) name))
140 (ps:delete (ps:getprop (root vars) name index)))
176 (ps:delete (ps:getprop (root vars) name index)))
141 (values))
177 (values))
142
178
179 (defm (root api array-size) (name)
180 (ps:getprop (root vars) (api-call var-real-name name) 'length))
181
143 ;;; Objects
182 ;;; Objects
144
183
145 (defm (root api update-objs) ()
184 (defm (root api update-objs) ()
@@ -148,3 +187,14 b''
148 (loop :for obj :in (root objs)
187 (loop :for obj :in (root objs)
149 :do (incf elt.inner-h-t-m-l (+ "<li>" obj)))
188 :do (incf elt.inner-h-t-m-l (+ "<li>" obj)))
150 (incf elt.inner-h-t-m-l "</ul>")))
189 (incf elt.inner-h-t-m-l "</ul>")))
190
191 ;;; Menu
192
193 (defm (root api menu) (menu-data)
194 (let ((elt (document.get-element-by-id "qsp-dropdown"))
195 (i 0))
196 (setf elt.inner-h-t-m-l "")
197 (loop :for item :in menu-data
198 :do (incf i)
199 :do (incf elt.inner-h-t-m-l (api-call make-menu-item-html i item.text item.icon item.loc)))
200 (setf elt.style.display "block")))
@@ -16,51 +16,21 b''
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) (ps:chain target (to-upper-case)))
20 (api-call stash-state)
20 (api-call stash-state)
21 (funcall (ps:getprop (root locations) (ps:chain target (to-upper-case)))))
21 (funcall (ps:getprop (root locs) (root current-location))))
22
22
23 ;;; 2var
23 ;;; 2var
24
24
25 (defm (root lib killvar) (varname &optional (index :whole))
26 (api-call kill-var varname index))
27
28 (defm (root lib killall) ()
29 (api-call kill-all))
30
31 ;;; 3expr
25 ;;; 3expr
32
26
33 (defm (root lib obj) (name)
34 (funcall (root objs includes) name))
35
36 (defm (root lib loc) ()
37 (funcall (root locations includes) name))
38
39 (defm (root lib no) (arg)
40 (- -1 arg))
41
42 ;;; 4code
27 ;;; 4code
43
28
44 (defm (root lib qspver) ()
29 (defm (root lib rand) (a &optional (b 1))
45 "0.0.1")
46
47 (defm (root lib curloc) ()
48 (root current-location))
49
50 (defm (root lib rand) (a b)
51 (let ((min (min a b))
30 (let ((min (min a b))
52 (max (max a b)))
31 (max (max a b)))
53 (+ min (ps:chain *math (random (- max min))))))
32 (+ min (ps:chain *math (random (- max min))))))
54
33
55 (defm (root lib rnd) ()
56 (funcall (root lib rand) 1 1000))
57
58 (defm (root lib qspmax) (&rest args)
59 (apply (ps:@ *math max) args))
60
61 (defm (root lib qspmin) (&rest args)
62 (apply (ps:@ *math min) args))
63
64 ;;; 5arrays
34 ;;; 5arrays
65
35
66 (defm (root lib copyarr) (to from start count)
36 (defm (root lib copyarr) (to from start count)
@@ -71,9 +41,6 b''
71 (api-call set-var to (+ start i)
41 (api-call set-var to (+ start i)
72 (api-call get-var from (+ start i)))))
42 (api-call get-var from (+ start i)))))
73
43
74 (defm (root lib arrsize) (name)
75 (api-call array-size name))
76
77 (defm (root lib arrpos) (name value &optional (start 0))
44 (defm (root lib arrpos) (name value &optional (start 0))
78 (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
45 (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
79 (when (eq (api-call get-var name i) value)
46 (when (eq (api-call get-var name i) value)
@@ -88,24 +55,6 b''
88
55
89 ;;; 6str
56 ;;; 6str
90
57
91 (defm (root lib len) (s)
92 (length s))
93
94 (defm (root lib mid) (s from &optional count)
95 (s.substring from count))
96
97 (defm (root lib ucase) (s)
98 (s.to-upper-case))
99
100 (defm (root lib lcase) (s)
101 (s.to-lower-case))
102
103 (defm (root lib trim) (s)
104 (s.trim))
105
106 (defm (root lib replace) (s from to)
107 (s.replace from to))
108
109 (defm (root lib instr) (s subs &optional (start 1))
58 (defm (root lib instr) (s subs &optional (start 1))
110 (+ start (ps:chain s (substring (- start 1)) (search subs))))
59 (+ start (ps:chain s (substring (- start 1)) (search subs))))
111
60
@@ -114,12 +63,6 b''
114 0
63 0
115 -1))
64 -1))
116
65
117 (defm (root lib val) (s)
118 (parse-int s 10))
119
120 (defm (root lib qspstr) (n)
121 (+ "" n))
122
123 (defm (root lib strcomp) (s pattern)
66 (defm (root lib strcomp) (s pattern)
124 (if (s.match pattern)
67 (if (s.match pattern)
125 -1
68 -1
@@ -140,21 +83,23 b''
140
83
141 ;;; 7if
84 ;;; 7if
142
85
86 ;; Has to be a function because it always evaluates all three of its
87 ;; arguments
143 (defm (root lib iif) (cond-expr then-expr else-expr)
88 (defm (root lib iif) (cond-expr then-expr else-expr)
144 (if (= -1 cond-expr) then-expr else-expr))
89 (if cond-expr then-expr else-expr))
145
90
146 ;;; 8sub
91 ;;; 8sub
147
92
148 (defm (root lib gosub) (target &rest args)
93 (defm (root lib gosub) (target &rest args)
149 (conserving-vars (args result)
94 (conserving-vars (args result)
150 (api-call init-args args)
95 (api-call init-args args)
151 (funcall (ps:getprop (root locations) target))
96 (funcall (ps:getprop (root locs) target))
152 (values)))
97 (values)))
153
98
154 (defm (root lib func) (target &rest args)
99 (defm (root lib func) (target &rest args)
155 (conserving-vars (args result)
100 (conserving-vars (args result)
156 (api-call init-args args)
101 (api-call init-args args)
157 (funcall (ps:getprop (root locations) target))
102 (funcall (ps:getprop (root locs) target))
158 (api-call get-result)))
103 (api-call get-result)))
159
104
160 ;;; 9loops
105 ;;; 9loops
@@ -176,79 +121,114 b''
176 ;;; 11main
121 ;;; 11main
177
122
178 (defm (root lib main-p) (s)
123 (defm (root lib main-p) (s)
179 (api-call add-text :main s))
124 (api-call add-text :main s)
125 (values))
180
126
181 (defm (root lib main-pl) (s)
127 (defm (root lib main-pl) (s)
182 (api-call add-text :main s)
128 (api-call add-text :main s)
183 (api-call newline :main))
129 (api-call newline :main)
130 (values))
184
131
185 (defm (root lib main-nl) (s)
132 (defm (root lib main-nl) (s)
186 (api-call newline :main)
133 (api-call newline :main)
187 (api-call add-text :main s))
134 (api-call add-text :main s)
135 (values))
188
136
189 (defm (root lib maintxt) (s)
137 (defm (root lib maintxt) (s)
190 (api-call get-text :main))
138 (api-call get-text :main)
139 (values))
191
140
141 ;; For clarity (it leaves a lib.desc() call in JS)
192 (defm (root lib desc) (s)
142 (defm (root lib desc) (s)
193 "")
143 "")
194
144
195 (defm (root lib main-clear) ()
145 (defm (root lib main-clear) ()
196 (api-call clear-text :main))
146 (api-call clear-text :main)
147 (values))
197
148
198 ;;; 12stat
149 ;;; 12stat
199
150
200 (defm (root lib showstat) ())
151 (defm (root lib stat-p) (s)
152 (api-call add-text :stat s)
153 (values))
201
154
202 (defm (root lib stat-p) ())
155 (defm (root lib stat-pl) (s)
156 (api-call add-text :stat s)
157 (api-call newline :stat)
158 (values))
203
159
204 (defm (root lib stat-pl) ())
160 (defm (root lib stat-nl) (s)
161 (api-call newline :stat)
162 (api-call add-text :stat s)
163 (values))
205
164
206 (defm (root lib stat-nl) ())
165 (defm (root lib stattxt) (s)
207
166 (api-call get-text :stat)
208 (defm (root lib stattxt) ())
167 (values))
209
168
210 (defm (root lib clear) ())
169 (defm (root lib stat-clear) ()
170 (api-call clear-text :stat)
171 (values))
211
172
212 (defm (root lib cls) ())
173 (defm (root lib cls) ()
174 (funcall (root lib stat-clear))
175 (funcall (root lib main-clear))
176 (funcall (root lib cla))
177 (funcall (root lib cmdclear))
178 (values))
213
179
214 ;;; 13diag
180 ;;; 13diag
215
181
216 (defm (root lib msg) ())
217
218 ;;; 14act
182 ;;; 14act
219
183
220 (defm (root lib showacts) ())
184 (defm (root lib curacts) ()
221
185 (let ((acts (root acts)))
222 (defm (root lib delact) (name)
186 (lambda ()
223 (api-call del-act name))
187 (setf (root acts) acts)
224
188 (values))))
225 (defm (root lib curacts) ())
226
227 (defm (root lib cla) ())
228
189
229 ;;; 15objs
190 ;;; 15objs
230
191
231 (defm (root lib showobjs) ())
232
233 (defm (root lib addobj) (name)
192 (defm (root lib addobj) (name)
234 (ps:chain (root objs) (push name))
193 (ps:chain (root objs) (push name))
235 (api-call update-objs))
194 (api-call update-objs)
195 (values))
236
196
237 (defm (root lib delobj) (name)
197 (defm (root lib delobj) (name)
238 (let ((index (ps:chain (root objs) (index-of name))))
198 (let ((index (ps:chain (root objs) (index-of name))))
239 (when (> index -1)
199 (when (> index -1)
240 (ps:chain (root objs) (splice index 1))))
200 (funcall (root lib killobj) index)))
241 (api-call update-objs))
201 (values))
242
202
243 (defm (root lib killobj) ())
203 (defm (root lib killobj) (&optional num)
244
204 (if num
245 (defm (root lib countobj) ())
205 (ps:chain (root objs) (splice (1+ num) 1))
246
206 (setf (root objs) (list)))
247 (defm (root lib getobj) ())
207 (api-call update-objs)
208 (values))
248
209
249 ;;; 16menu
210 ;;; 16menu
250
211
251 (defm (root lib menu) ())
212 (defm (root lib menu) (menu-name)
213 (let ((menu-data (list)))
214 (loop :for item :in (api-call get-array menu-name)
215 :do (cond ((string= item "")
216 (break))
217 ((string= item "-:-")
218 (ps:chain menu-data (push :delimiter)))
219 (t
220 (let* ((tokens (ps:chain item (split ":"))))
221 (when (= (length tokens) 2)
222 (tokens.push ""))
223 (let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":")))
224 (loc (ps:getprop tokens (- tokens.length 2)))
225 (icon (ps:getprop tokens (- tokens.length 1))))
226 (ps:chain menu-data
227 (push (ps:create text text
228 loc loc
229 icon icon))))))))
230 (api-call menu menu-data)
231 (values)))
252
232
253 ;;; 17sound
233 ;;; 17sound
254
234
@@ -278,7 +258,11 b''
278
258
279 ;;; 20time
259 ;;; 20time
280
260
281 (defm (root lib wait) ())
261 ;; I wonder if there's a better solution than busy-wait
262 (defm (root lib wait) (msec)
263 (let* ((now (ps:new (*date)))
264 (exit-time (+ (funcall now.get-time) msec)))
265 (loop :while (< (funcall now.get-time) exit-time))))
282
266
283 (defm (root lib msecscount) ())
267 (defm (root lib msecscount) ())
284
268
@@ -294,6 +278,36 b''
294
278
295 (defm (root lib killqst) ())
279 (defm (root lib killqst) ())
296
280
297 (defm (root lib opengame) ())
281 (defm (root lib opengame) (&optional filename)
282 (let ((element (document.create-element :input)))
283 (element.set-attribute :type :file)
284 (element.set-attribute :id :qsp-opengame)
285 (element.set-attribute :tabindex -1)
286 (element.set-attribute "aria-hidden" t)
287 (setf element.style.display :block)
288 (setf element.style.visibility :hidden)
289 (setf element.style.position :fixed)
290 (setf element.onchange
291 (lambda (event)
292 (let* ((file (elt event.target.files 0))
293 (reader (ps:new (*file-reader))))
294 (setf reader.onload
295 (lambda (ev)
296 (block nil
297 (let ((target ev.current-target))
298 (unless target.result
299 (return))
300 (api-call base64-to-state target.result)))))
301 (reader.read-as-text file))))
302 (document.body.append-child element)
303 (element.click)
304 (document.body.remove-child element)))
298
305
299 (defm (root lib savegame) ())
306 (defm (root lib savegame) (&optional filename)
307 (let ((element (document.create-element :a)))
308 (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64)))
309 (element.set-attribute :download "savegame.sav")
310 (setf element.style.display :none)
311 (document.body.append-child element)
312 (element.click)
313 (document.body.remove-child element)))
@@ -54,7 +54,7 b''
54 (alexandria:read-file-into-string filename)))
54 (alexandria:read-file-into-string filename)))
55
55
56 (defun make-javascript (locations)
56 (defun make-javascript (locations)
57 (format nil "~{~A~^~%~%~}"
57 (format nil "////// THE GAME STARTS HERE~%~%~{~A~^~%~%~}"
58 (mapcar #'ps:ps* locations)))
58 (mapcar #'ps:ps* locations)))
59
59
60 (defun uglify-js::write-json-chars (quote s stream)
60 (defun uglify-js::write-json-chars (quote s stream)
@@ -92,18 +92,9 b' Monkey-patched to output plain utf-8 ins'
92
92
93 ;;; JS
93 ;;; JS
94
94
95 (defun src-file (filename)
96 (uiop/pathname:merge-pathnames*
97 filename
98 (asdf:system-source-directory :sugar-qsp)))
99
100 (defmethod js-sources ((compiler compiler))
95 (defmethod js-sources ((compiler compiler))
101 (format nil "~{~A~^~%~%~}" (reverse (js compiler))))
96 (format nil "~{~A~^~%~%~}" (reverse (js compiler))))
102
97
103 (defun compile-ps (filename)
104 (format nil "////// Parenscript file: ~A~%~%~A"
105 (file-namestring filename) (ps:ps-compile-file filename)))
106
107 ;;; CSS
98 ;;; CSS
108
99
109 (defmethod css-sources ((compiler compiler))
100 (defmethod css-sources ((compiler compiler))
@@ -129,16 +120,6 b' Monkey-patched to output plain utf-8 ins'
129 :stream out
120 :stream out
130 :pretty nil))))
121 :pretty nil))))
131
122
132 (defclass compiler ()
133 ((body :accessor body :initform #.(alexandria:read-file-into-string (src-file "extras/body.html")))
134 (css :accessor css :initform (list #.(alexandria:read-file-into-string (src-file "extras/default.css"))))
135 (js :accessor js :initform (list #.(compile-ps (src-file "src/intrinsics.ps"))
136 #.(compile-ps (src-file "src/api.ps"))
137 #.(compile-ps (src-file "src/main.ps"))))
138 (compile :accessor compile-only :initarg :compile)
139 (target :accessor target :initarg :target)
140 (beautify :accessor beautify :initarg :beautify)))
141
142 (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
123 (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
143 (call-next-method)
124 (call-next-method)
144 (with-slots (body css js)
125 (with-slots (body css js)
@@ -6,10 +6,16 b''
6 objs (list)
6 objs (list)
7 state-stash (ps:create)
7 state-stash (ps:create)
8 acts (ps:create)
8 acts (ps:create)
9 locations (ps:create)))
9 locs (ps:create)))
10
10
11 ;; Launch the game from the first location
11 (setf window.onload
12 (setf window.onload
12 (lambda ()
13 (lambda ()
13 (funcall (ps:getprop (root locations)
14 (funcall (ps:getprop (root locs)
14 (ps:chain *object (keys (root locations)) 0)))
15 (ps:chain *object (keys (root locs)) 0)))
15 (values)))
16 (values)))
17
18 ;; Close the dropdown on any click
19 (setf window.onclick
20 (lambda (event)
21 (setf (ps:@ (api-call get-frame :dropdown) style display) "none")))
@@ -184,7 +184,7 b''
184 (declare (ignore spaces1 spaces2))
184 (declare (ignore spaces1 spaces2))
185 (string-upcase (string-trim " " (p:text name)))))
185 (string-upcase (string-trim " " (p:text name)))))
186
186
187 (p:defrule location-end (and #\- #\newline before-statement)
187 (p:defrule location-end (and #\- (* not-newline) #\newline before-statement)
188 (:constant nil))
188 (:constant nil))
189
189
190 ;;; Block body
190 ;;; Block body
@@ -486,8 +486,8 b''
486 (openqst nil 1 1)
486 (openqst nil 1 1)
487 (addqst nil 1 1 "addqst" "addlib" "inclib")
487 (addqst nil 1 1 "addqst" "addlib" "inclib")
488 (killqst nil 1 1 "killqst" "dellib" "freelib")
488 (killqst nil 1 1 "killqst" "dellib" "freelib")
489 (opengame nil 0 1)
489 (opengame nil 0 0)
490 (savegame nil 0 1)
490 (savegame nil 0 0)
491 ;; Real time
491 ;; Real time
492 (wait nil 1 1)
492 (wait nil 1 1)
493 (msecscount t 0 0)
493 (msecscount t 0 0)
@@ -41,7 +41,7 b''
41 :collect `(defpsintrinsic ,name))))
41 :collect `(defpsintrinsic ,name))))
42
42
43 (defpsintrinsics ()
43 (defpsintrinsics ()
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)
44 rand copyarr arrpos arrcomp instr isnum strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear stat-p stat-pl stat-nl stattxt stat-clear cls curacts addobj delobj killobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer)
45
45
46 (ps:defpsmacro api-call (func &rest args)
46 (ps:defpsmacro api-call (func &rest args)
47 `(funcall (root api ,func) ,@args))
47 `(funcall (root api ,func) ,@args))
@@ -66,11 +66,10 b''
66 ;;; 1loc
66 ;;; 1loc
67
67
68 (ps:defpsmacro location ((name) &body body)
68 (ps:defpsmacro location ((name) &body body)
69 `(setf (root locations ,name)
69 `(setf (root locs ,name)
70 (lambda ()
70 (lambda ()
71 (label-block
71 (label-block
72 ,@body
72 ,@body))))
73 (api-call update-acts)))))
74
73
75 (ps:defpsmacro goto (target &rest args)
74 (ps:defpsmacro goto (target &rest args)
76 `(progn
75 `(progn
@@ -155,9 +154,6 b''
155 (ps:getprop __labels ,(third f)))))))))
154 (ps:getprop __labels ,(third f)))))))))
156 (jump (str "__nil"))))))
155 (jump (str "__nil"))))))
157
156
158 (ps:defpsmacro exit ()
159 `(return-from nil (values)))
160
161 ;;; 10dynamic
157 ;;; 10dynamic
162
158
163 (ps:defpsmacro qspblock (&body body)
159 (ps:defpsmacro qspblock (&body body)
@@ -7,5 +7,7 b''
7 :serial t
7 :serial t
8 :components ((:file "package")
8 :components ((:file "package")
9 (:file "ps-macros")
9 (:file "ps-macros")
10 (:file "intrinsic-macros")
11 (:file "class")
10 (:file "main")
12 (:file "main")
11 (:file "parser")))
13 (:file "parser")))
General Comments 0
You need to be logged in to leave comments. Login now