Show More
@@ -0,0 +1,7 b'' | |||||
|
1 | ||||
|
2 | <div id="qsp"> | |||
|
3 | <div id="qsp-main" class="qsp-frame"> </div> | |||
|
4 | <div id="qsp-acts" class="qsp-frame"> </div> | |||
|
5 | <div id="qsp-stat" class="qsp-frame"> </div> | |||
|
6 | <div id="qsp-objs" class="qsp-frame"> </div> | |||
|
7 | </div> |
@@ -0,0 +1,54 b'' | |||||
|
1 | ||||
|
2 | .qsp-frame { | |||
|
3 | border: 1px solid black; | |||
|
4 | overflow: auto; | |||
|
5 | position: absolute; | |||
|
6 | padding: 5px; | |||
|
7 | box-sizing: border-box; | |||
|
8 | } | |||
|
9 | ||||
|
10 | #qsp { | |||
|
11 | position: fixed; | |||
|
12 | top: 0; | |||
|
13 | left: 0; | |||
|
14 | width: 100%; | |||
|
15 | height: 100%; | |||
|
16 | } | |||
|
17 | ||||
|
18 | #qsp-main { | |||
|
19 | height: 60%; | |||
|
20 | width: 70%; | |||
|
21 | top: 0; | |||
|
22 | left: 0; | |||
|
23 | } | |||
|
24 | ||||
|
25 | #qsp-acts { | |||
|
26 | height: 40%; | |||
|
27 | width: 70%; | |||
|
28 | bottom: 0; | |||
|
29 | left: 0; | |||
|
30 | } | |||
|
31 | ||||
|
32 | #qsp-stat { | |||
|
33 | height: 50%; | |||
|
34 | width: 30%; | |||
|
35 | top: 0; | |||
|
36 | right: 0; | |||
|
37 | } | |||
|
38 | ||||
|
39 | #qsp-objs { | |||
|
40 | height: 50%; | |||
|
41 | width: 30%; | |||
|
42 | bottom: 0; | |||
|
43 | right: 0; | |||
|
44 | } | |||
|
45 | ||||
|
46 | .qsp-act { | |||
|
47 | display: block; | |||
|
48 | padding: 2px; | |||
|
49 | font-size: large; | |||
|
50 | } | |||
|
51 | ||||
|
52 | .qsp-act:hover { | |||
|
53 | outline: #9E9E9E outset 3px | |||
|
54 | } |
@@ -20,6 +20,26 b'' | |||||
20 | (defm (root api init-dom) () |
|
20 | (defm (root api init-dom) () | |
21 | ) |
|
21 | ) | |
22 |
|
22 | |||
|
23 | ;;; Misc | |||
|
24 | ||||
|
25 | (defm (root api clear-id) (id) | |||
|
26 | (setf (ps:chain document (get-element-by-id id) inner-text) "")) | |||
|
27 | ||||
|
28 | (defm (root api get-id) (id) | |||
|
29 | (if (var "USEHTML" 0) | |||
|
30 | (ps:chain (document.get-element-by-id id) inner-h-t-m-l) | |||
|
31 | (ps:chain (document.get-element-by-id id) inner-text))) | |||
|
32 | ||||
|
33 | (defm (root api set-id) (id contents) | |||
|
34 | (if (var "USEHTML" 0) | |||
|
35 | (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |||
|
36 | (setf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |||
|
37 | ||||
|
38 | (defm (root api append-id) (id contents) | |||
|
39 | (if (var "USEHTML" 0) | |||
|
40 | (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents) | |||
|
41 | (incf (ps:chain (document.get-element-by-id id) inner-text) contents))) | |||
|
42 | ||||
23 | ;;; Function calls |
|
43 | ;;; Function calls | |
24 |
|
44 | |||
25 | (defm (root api init-args) (args) |
|
45 | (defm (root api init-args) (args) | |
@@ -42,13 +62,13 b'' | |||||
42 | (t (report-error "Internal error!")))) |
|
62 | (t (report-error "Internal error!")))) | |
43 |
|
63 | |||
44 | (defm (root api add-text) (key text) |
|
64 | (defm (root api add-text) (key text) | |
45 |
(append-id |
|
65 | (api-call append-id (api-call key-to-id key) text)) | |
46 |
|
66 | |||
47 | (defm (root api get-text) (key) |
|
67 | (defm (root api get-text) (key) | |
48 |
(get-id |
|
68 | (api-call get-id (api-call key-to-id key))) | |
49 |
|
69 | |||
50 | (defm (root api clear-text) (key) |
|
70 | (defm (root api clear-text) (key) | |
51 |
( |
|
71 | (api-call clear-id (api-call key-to-id key))) | |
52 |
|
72 | |||
53 | (defm (root api newline) (key) |
|
73 | (defm (root api newline) (key) | |
54 | (let ((div (document.get-element-by-id |
|
74 | (let ((div (document.get-element-by-id | |
@@ -67,14 +87,14 b'' | |||||
67 |
|
87 | |||
68 | (defm (root api clear-act) () |
|
88 | (defm (root api clear-act) () | |
69 | (setf (root acts) (ps:create)) |
|
89 | (setf (root acts) (ps:create)) | |
70 | (set-id-contents "qsp-acts" "")) |
|
90 | (api-call clear-id "qsp-acts")) | |
71 |
|
91 | |||
72 | (defm (root api update-acts) () |
|
92 | (defm (root api update-acts) () | |
73 | (set-id-contents "qsp-acts" "") |
|
93 | (api-call clear-id "qsp-acts") | |
74 | (ps:for-in (title (root acts)) |
|
94 | (ps:for-in (title (root acts)) | |
75 | (let ((obj (ps:getprop (root acts) title))) |
|
95 | (let ((obj (ps:getprop (root acts) title))) | |
76 |
(append-id |
|
96 | (api-call append-id "qsp-acts" | |
77 |
|
|
97 | (api-call make-act-html title (ps:getprop obj :img)))))) | |
78 |
|
98 | |||
79 | ;;; Variables |
|
99 | ;;; Variables | |
80 |
|
100 | |||
@@ -113,8 +133,8 b'' | |||||
113 |
|
133 | |||
114 | (defm (root api kill-var) (name index) |
|
134 | (defm (root api kill-var) (name index) | |
115 | (if (eq index :whole) |
|
135 | (if (eq index :whole) | |
116 | (ps:delete (getprop (root vars) name)) |
|
136 | (ps:delete (ps:getprop (root vars) name)) | |
117 | (ps:delete (getprop (root vars) name index))) |
|
137 | (ps:delete (ps:getprop (root vars) name index))) | |
118 | (values)) |
|
138 | (values)) | |
119 |
|
139 | |||
120 | ;;; Objects |
|
140 | ;;; Objects |
@@ -1,49 +1,14 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 |
(defun entry-point ( |
|
4 | (defun entry-point-no-args () | |
5 | (init-vars) |
|
5 | (entry-point uiop:*command-line-arguments*)) | |
|
6 | ||||
|
7 | (defun entry-point (args) | |||
6 | (catch :terminate |
|
8 | (catch :terminate | |
7 | (destructuring-bind (&key source target js css body compile beautify) |
|
9 | (let ((compiler (apply #'make-instance 'compiler (parse-opts args)))) | |
8 | (parse-opts args) |
|
10 | (write-compiled-file compiler))) | |
9 | ;; Just compile the source |
|
11 | (values)) | |
10 | (when compile |
|
|||
11 | (alexandria:write-string-into-file |
|
|||
12 | (make-javascript (parse-file source)) |
|
|||
13 | target :if-exists :supersede) |
|
|||
14 | (return-from entry-point)) |
|
|||
15 | ;; Read in body |
|
|||
16 | (when body |
|
|||
17 | (setf *html-template-body* |
|
|||
18 | (alexandria:read-file-into-string body))) |
|
|||
19 | ;; Compile the game's JS |
|
|||
20 | (push (make-javascript (parse-file source)) *js-files*) |
|
|||
21 | ;; Include js files |
|
|||
22 | (dolist (js-file js) |
|
|||
23 | (push (format nil "// Included file ~A~%~A" js-file |
|
|||
24 | (alexandria:read-file-into-string js-file)) |
|
|||
25 | *js-files*)) |
|
|||
26 | ;; Include css files |
|
|||
27 | (dolist (css-file css) |
|
|||
28 | (push (format nil "// Included file ~A~%~A" css-file |
|
|||
29 | (alexandria:read-file-into-string css-file)) |
|
|||
30 | *css-files*)) |
|
|||
31 | ;; Compile into one file |
|
|||
32 | (alexandria:write-string-into-file (make-html beautify) target |
|
|||
33 | :if-exists :supersede)))) |
|
|||
34 |
|
||||
35 | (defun init-vars () |
|
|||
36 | (setf *css-files* (list " |
|
|||
37 | .col1 { flush: left; clear: left; width: 80%; } |
|
|||
38 | .col2 { flush: right; clear: right; width: 20%; } |
|
|||
39 | .row1 { height: 70%; } |
|
|||
40 | .row2 { height: 30%; } |
|
|||
41 | .qsp-frame {border: 1px black; } |
|
|||
42 | #qsp-acts a {display: block; } |
|
|||
43 | ")) |
|
|||
44 | (setf *js-files* (list (compile-ps (ps-file "intrinsics.ps")) |
|
|||
45 | (compile-ps (ps-file "api.ps")) |
|
|||
46 | (compile-ps (ps-file "main.ps"))))) |
|
|||
47 |
|
12 | |||
48 | (defun parse-opts (args) |
|
13 | (defun parse-opts (args) | |
49 | (let ((mode :source) |
|
14 | (let ((mode :source) | |
@@ -92,32 +57,48 b'' | |||||
92 | (format nil "~{~A~^~%~%~}" |
|
57 | (format nil "~{~A~^~%~%~}" | |
93 | (mapcar #'ps:ps* locations))) |
|
58 | (mapcar #'ps:ps* locations))) | |
94 |
|
59 | |||
95 | (defun make-html (beautify-js) |
|
60 | (defun uglify-js::write-json-chars (quote s stream) | |
96 | (html-sources (css-sources) |
|
61 | "Write JSON representations (chars or escape sequences) of | |
97 | (if beautify-js |
|
62 | characters in string S to STREAM. | |
98 | (js-sources) |
|
63 | Monkey-patched to output plain utf-8 instead of escape-sequences." | |
99 | (cl-uglify-js:ast-gen-code |
|
64 | (write-char quote stream) | |
100 | (cl-uglify-js:ast-mangle |
|
65 | (loop :for ch :across s | |
101 | (cl-uglify-js:ast-squeeze |
|
66 | :for code := (char-code ch) | |
102 | (parse-js:parse-js (js-sources)))) |
|
67 | :with special | |
103 | :beautify nil)))) |
|
68 | :do (cond ((eq ch quote) | |
|
69 | (write-char #\\ stream) (write-char ch stream)) | |||
|
70 | ((setq special (car (rassoc ch uglify-js::+json-lisp-escaped-chars+))) | |||
|
71 | (write-char #\\ stream) (write-char special stream)) | |||
|
72 | (t | |||
|
73 | (write-char ch stream)))) | |||
|
74 | (write-char quote stream)) | |||
|
75 | ||||
|
76 | (defun preprocess-js (js beautify) | |||
|
77 | (if beautify | |||
|
78 | (cl-uglify-js:ast-gen-code | |||
|
79 | (cl-uglify-js:ast-squeeze | |||
|
80 | (parse-js:parse-js js) | |||
|
81 | :sequences nil) | |||
|
82 | :beautify t) | |||
|
83 | (cl-uglify-js:ast-gen-code | |||
|
84 | (cl-uglify-js:ast-mangle | |||
|
85 | (cl-uglify-js:ast-squeeze | |||
|
86 | (parse-js:parse-js js))) | |||
|
87 | :beautify nil))) | |||
104 |
|
88 | |||
105 | (defun report-error (fmt &rest args) |
|
89 | (defun report-error (fmt &rest args) | |
106 | (apply #'format t fmt args) |
|
90 | (apply #'format t fmt args) | |
107 | (break) |
|
|||
108 | (throw :terminate nil)) |
|
91 | (throw :terminate nil)) | |
109 |
|
92 | |||
110 | ;;; JS |
|
93 | ;;; JS | |
111 |
|
94 | |||
112 | (defparameter *js-files* nil) |
|
95 | (defun src-file (filename) | |
113 |
|
||||
114 | (defun ps-file (filename) |
|
|||
115 | (uiop/pathname:merge-pathnames* |
|
96 | (uiop/pathname:merge-pathnames* | |
116 | (format nil "src/~A" filename) |
|
97 | filename | |
117 | (asdf:system-source-directory :sugar-qsp))) |
|
98 | (asdf:system-source-directory :sugar-qsp))) | |
118 |
|
99 | |||
119 | (defun js-sources () |
|
100 | (defmethod js-sources ((compiler compiler)) | |
120 |
(format nil "~{~A~^~%~%~}" (reverse |
|
101 | (format nil "~{~A~^~%~%~}" (reverse (js compiler)))) | |
121 |
|
102 | |||
122 | (defun compile-ps (filename) |
|
103 | (defun compile-ps (filename) | |
123 | (format nil "////// Parenscript file: ~A~%~%~A" |
|
104 | (format nil "////// Parenscript file: ~A~%~%~A" | |
@@ -125,44 +106,67 b'' | |||||
125 |
|
106 | |||
126 | ;;; CSS |
|
107 | ;;; CSS | |
127 |
|
108 | |||
128 | (defparameter *css-files* nil) |
|
109 | (defmethod css-sources ((compiler compiler)) | |
129 |
|
110 | (format nil "~{~A~^~%~%~}" (css compiler))) | ||
130 | (defun css-sources () |
|
|||
131 | (format nil "~{~A~^~%~%~}" *css-files*)) |
|
|||
132 |
|
111 | |||
133 | ;;; HTML |
|
112 | ;;; HTML | |
134 |
|
113 | |||
135 | (defparameter *html-template-body* |
|
114 | (defmethod html-sources ((compiler compiler)) | |
136 | (flute:h |
|
115 | (let ((flute:*escape-html* nil) | |
137 | (div#qsp |
|
116 | (body-template (body compiler)) | |
138 | (div#qsp-main.qsp-frame.col1.row1 " ") |
|
117 | (js (js-sources compiler)) | |
139 | (hr) |
|
118 | (css (css-sources compiler))) | |
140 | "Действия:" |
|
119 | (with-output-to-string (out) | |
141 | (div#qsp-acts.qsp-frame.row2 " ") |
|
120 | (write | |
142 | (hr) |
|
|||
143 | "Дополнительное окно:" |
|
|||
144 | (div#qsp-stat.qsp-frame.row1 " ") |
|
|||
145 | (hr) |
|
|||
146 | "Инвентарь:" |
|
|||
147 | (div#qsp-objs.qsp-frame.row2 " ")))) |
|
|||
148 |
|
||||
149 | (defun html-sources (&optional (css " ") (javascript " ")) |
|
|||
150 | (with-output-to-string (out) |
|
|||
151 | (write |
|
|||
152 | (let ((flute:*escape-html* nil)) |
|
|||
153 | (flute:h |
|
121 | (flute:h | |
154 | (html |
|
122 | (html | |
155 | (head |
|
123 | (head | |
156 | (title "SugarQSP")) |
|
124 | (title "SugarQSP")) | |
157 | (body |
|
125 | (body | |
158 |
|
|
126 | body-template | |
159 | (style css) |
|
127 | (style css) | |
160 | (script javascript))))) |
|
128 | (script (preprocess-js js (beautify compiler)))))) | |
161 | :stream out |
|
129 | :stream out | |
162 | :pretty nil))) |
|
130 | :pretty nil)))) | |
|
131 | ||||
|
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))) | |||
163 |
|
141 | |||
164 | (defun write-html-default-body (filename) |
|
142 | (defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys) | |
165 | (with-open-file (out filename :direction :output) |
|
143 | (call-next-method) | |
166 | (write *html-template-body* |
|
144 | (with-slots (body css js) | |
167 | :stream out |
|
145 | compiler | |
168 | :pretty t))) |
|
146 | ;; Compile the game's JS | |
|
147 | (push (make-javascript (parse-file source)) js) | |||
|
148 | ;; Does the user need us to do anything else | |||
|
149 | (unless compile | |||
|
150 | ;; Read in body | |||
|
151 | (when body-file | |||
|
152 | (setf body | |||
|
153 | (alexandria:read-file-into-string body-file))) | |||
|
154 | ;; Include js files | |||
|
155 | (dolist (js-file js-files) | |||
|
156 | (push (format nil "////// Included file ~A~%~A" js-file | |||
|
157 | (alexandria:read-file-into-string js-file)) | |||
|
158 | js)) | |||
|
159 | ;; Include css files | |||
|
160 | (dolist (css-file css-files) | |||
|
161 | (push (format nil "////// Included file ~A~%~A" css-file | |||
|
162 | (alexandria:read-file-into-string css-file)) | |||
|
163 | css))))) | |||
|
164 | ||||
|
165 | (defmethod write-compiled-file ((compiler compiler)) | |||
|
166 | (alexandria:write-string-into-file | |||
|
167 | (if (compile-only compiler) | |||
|
168 | ;; Just the JS | |||
|
169 | (preprocess-js (js-sources compiler) (beautify compiler)) | |||
|
170 | ;; All of it | |||
|
171 | (html-sources compiler)) | |||
|
172 | (target compiler) :if-exists :supersede)) |
@@ -1,14 +1,15 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | (setf (root) (ps:create vars (ps:create) |
|
4 | (setf (root) | |
5 | objs (list) |
|
5 | (ps:create vars (ps:create) | |
6 |
|
|
6 | objs (list) | |
7 |
|
|
7 | acts (ps:create) | |
|
8 | locations (ps:create))) | |||
8 |
|
9 | |||
9 | (defm (root start) () |
|
10 | (setf window.onload | |
10 | (api-call init-dom) |
|
11 | (lambda () | |
11 | (funcall (root locations *start*))) |
|
12 | (api-call init-dom) | |
12 |
|
13 | (funcall (ps:getprop (root locations) | ||
13 | (setf window.onload (lambda () |
|
14 | (ps:chain *object (keys (root locations)) 0))) | |
14 | (funcall (root start)))) |
|
15 | (values))) |
@@ -16,19 +16,6 b'' | |||||
16 | (ps:defpsmacro in (key obj) |
|
16 | (ps:defpsmacro in (key obj) | |
17 | `(ps:chain ,obj (has-own-property ,key))) |
|
17 | `(ps:chain ,obj (has-own-property ,key))) | |
18 |
|
18 | |||
19 | (ps:defpsmacro get-id-contents (id) |
|
|||
20 | `(if (var "USEHTML" 0) |
|
|||
21 | (ps:chain (document.get-element-by-id ,id) inner-h-t-m-l) |
|
|||
22 | (ps:chain (document.get-element-by-id ,id) inner-text))) |
|
|||
23 |
|
||||
24 | (ps:defpsmacro set-id-contents (id contents) |
|
|||
25 | `(if (var "USEHTML" 0) |
|
|||
26 | (setf (ps:chain (document.get-element-by-id ,id) inner-h-t-m-l) ,contents) |
|
|||
27 | (setf (ps:chain (document.get-element-by-id ,id) inner-text) ,contents))) |
|
|||
28 |
|
||||
29 | (ps:defpsmacro append-id-contents (id contents) |
|
|||
30 | `(set-id-contents ,id (+ (get-id-contents ,id) ,contents))) |
|
|||
31 |
|
||||
32 | (ps:defpsmacro conserving-vars (vars &body body) |
|
19 | (ps:defpsmacro conserving-vars (vars &body body) | |
33 | "Calls body with safely stored away VARS, and restores their values after that returning what BODY returns." |
|
20 | "Calls body with safely stored away VARS, and restores their values after that returning what BODY returns." | |
34 | `(let ((__conserved (list ,@(loop :for var :in vars |
|
21 | `(let ((__conserved (list ,@(loop :for var :in vars |
General Comments 0
You need to be logged in to leave comments.
Login now