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"> </div> |
|
10 | <div id="qsp-objs" class="qsp-frame"> </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 |
|
|
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 |
|
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 |
|
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 loc |
|
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 loc |
|
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 s |
|
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- |
|
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 |
|
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 |
|
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 |
( |
|
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 |
loc |
|
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 loc |
|
14 | (funcall (ps:getprop (root locs) | |
14 |
(ps:chain *object (keys (root loc |
|
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 |
|
489 | (opengame nil 0 0) | |
490 |
(savegame nil 0 |
|
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 loc |
|
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) |
General Comments 0
You need to be logged in to leave comments.
Login now