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 | } |
@@ -1,127 +1,147 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;; API deals with DOM manipulation and some bookkeeping for the |
|
4 | ;;; API deals with DOM manipulation and some bookkeeping for the | |
5 | ;;; intrinsics, namely variables |
|
5 | ;;; intrinsics, namely variables | |
6 | ;;; API is an implementation detail and has no QSP documentation. It |
|
6 | ;;; API is an implementation detail and has no QSP documentation. It | |
7 | ;;; doesn't call intrinsics |
|
7 | ;;; doesn't call intrinsics | |
8 |
|
8 | |||
9 | (setf (root api) (ps:create)) |
|
9 | (setf (root api) (ps:create)) | |
10 |
|
10 | |||
11 | ;;; Utils |
|
11 | ;;; Utils | |
12 |
|
12 | |||
13 | (defm (root api make-act-html) (title img) |
|
13 | (defm (root api make-act-html) (title img) | |
14 | (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>" |
|
14 | (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>" | |
15 | title |
|
15 | title | |
16 | "</a>")) |
|
16 | "</a>")) | |
17 |
|
17 | |||
18 | ;;; Startup |
|
18 | ;;; Startup | |
19 |
|
19 | |||
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) | |
26 | (dotimes (i (length args)) |
|
46 | (dotimes (i (length args)) | |
27 | (if (numberp (elt args i)) |
|
47 | (if (numberp (elt args i)) | |
28 | (set (var args i) (elt args i)) |
|
48 | (set (var args i) (elt args i)) | |
29 | (set (var $args i) (elt args i))))) |
|
49 | (set (var $args i) (elt args i))))) | |
30 |
|
50 | |||
31 | (defm (root api get-result) () |
|
51 | (defm (root api get-result) () | |
32 | (if (not (equal "" (var $result 0))) |
|
52 | (if (not (equal "" (var $result 0))) | |
33 | (var $result 0) |
|
53 | (var $result 0) | |
34 | (var result 0))) |
|
54 | (var result 0))) | |
35 |
|
55 | |||
36 | ;;; Text windows |
|
56 | ;;; Text windows | |
37 |
|
57 | |||
38 | (defm (root api key-to-id) (key) |
|
58 | (defm (root api key-to-id) (key) | |
39 | (case key |
|
59 | (case key | |
40 | (:main "qsp-main") |
|
60 | (:main "qsp-main") | |
41 | (:stat "qsp-stat") |
|
61 | (:stat "qsp-stat") | |
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 | |
55 | (api-call key-to-id key)))) |
|
75 | (api-call key-to-id key)))) | |
56 | (ps:chain div (append-child (document.create-element "br"))))) |
|
76 | (ps:chain div (append-child (document.create-element "br"))))) | |
57 |
|
77 | |||
58 | ;;; Actions |
|
78 | ;;; Actions | |
59 |
|
79 | |||
60 | (defm (root api add-act) (title img act) |
|
80 | (defm (root api add-act) (title img act) | |
61 | (setf (ps:getprop (root acts) title) |
|
81 | (setf (ps:getprop (root acts) title) | |
62 | (ps:create :img img :act act))) |
|
82 | (ps:create :img img :act act))) | |
63 |
|
83 | |||
64 | (defm (root api del-act) (title) |
|
84 | (defm (root api del-act) (title) | |
65 | (delete (ps:getprop (root acts) title)) |
|
85 | (delete (ps:getprop (root acts) title)) | |
66 | (api-call update-acts)) |
|
86 | (api-call update-acts)) | |
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 | |||
81 | (defm (root api var-slot) (name) |
|
101 | (defm (root api var-slot) (name) | |
82 | (if (= (ps:@ name 0) #\$) |
|
102 | (if (= (ps:@ name 0) #\$) | |
83 | :str |
|
103 | :str | |
84 | :num)) |
|
104 | :num)) | |
85 |
|
105 | |||
86 | (defm (root api var-real-name) (name) |
|
106 | (defm (root api var-real-name) (name) | |
87 | (if (= (ps:@ name 0) #\$) |
|
107 | (if (= (ps:@ name 0) #\$) | |
88 | (ps:chain name (substr 1)) |
|
108 | (ps:chain name (substr 1)) | |
89 | name)) |
|
109 | name)) | |
90 |
|
110 | |||
91 | (defm (root api ensure-var) (name index) |
|
111 | (defm (root api ensure-var) (name index) | |
92 | (unless (in name (root vars)) |
|
112 | (unless (in name (root vars)) | |
93 | (setf (ps:getprop (root vars) name) |
|
113 | (setf (ps:getprop (root vars) name) | |
94 | (ps:create))) |
|
114 | (ps:create))) | |
95 | (unless (in index (ps:getprop (root vars) name)) |
|
115 | (unless (in index (ps:getprop (root vars) name)) | |
96 | (setf (ps:getprop (root vars) name index) |
|
116 | (setf (ps:getprop (root vars) name index) | |
97 | (ps:create :num 0 :str ""))) |
|
117 | (ps:create :num 0 :str ""))) | |
98 | (values)) |
|
118 | (values)) | |
99 |
|
119 | |||
100 | (defm (root api get-var) (name index) |
|
120 | (defm (root api get-var) (name index) | |
101 | (let ((var-name (api-call var-real-name name))) |
|
121 | (let ((var-name (api-call var-real-name name))) | |
102 | (api-call ensure-var var-name index) |
|
122 | (api-call ensure-var var-name index) | |
103 | (ps:getprop (root vars) var-name index |
|
123 | (ps:getprop (root vars) var-name index | |
104 | (api-call var-slot name)))) |
|
124 | (api-call var-slot name)))) | |
105 |
|
125 | |||
106 | (defm (root api set-var) (name index value) |
|
126 | (defm (root api set-var) (name index value) | |
107 | (let ((var-name (api-call var-real-name name))) |
|
127 | (let ((var-name (api-call var-real-name name))) | |
108 | (api-call ensure-var var-name index) |
|
128 | (api-call ensure-var var-name index) | |
109 | (setf (ps:getprop (root vars) var-name index |
|
129 | (setf (ps:getprop (root vars) var-name index | |
110 | (api-call var-slot name)) |
|
130 | (api-call var-slot name)) | |
111 | value) |
|
131 | value) | |
112 | (values))) |
|
132 | (values))) | |
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 | |
121 |
|
141 | |||
122 | (defm (root api update-objs) () |
|
142 | (defm (root api update-objs) () | |
123 | (let ((elt (document.get-element-by-id "qsp-objs"))) |
|
143 | (let ((elt (document.get-element-by-id "qsp-objs"))) | |
124 | (setf elt.inner-h-t-m-l "<ul>") |
|
144 | (setf elt.inner-h-t-m-l "<ul>") | |
125 | (loop :for obj :in (root objs) |
|
145 | (loop :for obj :in (root objs) | |
126 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) |
|
146 | :do (incf elt.inner-h-t-m-l (+ "<li>" obj))) | |
127 | (incf elt.inner-h-t-m-l "</ul>"))) |
|
147 | (incf elt.inner-h-t-m-l "</ul>"))) |
@@ -1,168 +1,172 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) | |
50 | (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) |
|
15 | (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil))) | |
51 | (loop :for arg :in args |
|
16 | (loop :for arg :in args | |
52 | :do (alexandria:switch (arg :test #'string=) |
|
17 | :do (alexandria:switch (arg :test #'string=) | |
53 | ("-o" (setf mode :target)) |
|
18 | ("-o" (setf mode :target)) | |
54 | ("--js" (setf mode :js)) |
|
19 | ("--js" (setf mode :js)) | |
55 | ("--css" (setf mode :css)) |
|
20 | ("--css" (setf mode :css)) | |
56 | ("--body" (setf mode :body)) |
|
21 | ("--body" (setf mode :body)) | |
57 | ("-c" (setf (getf data :compile) t)) |
|
22 | ("-c" (setf (getf data :compile) t)) | |
58 | ("--beautify" (setf (getf data :beautify) t)) |
|
23 | ("--beautify" (setf (getf data :beautify) t)) | |
59 | (t (push arg (getf data mode))))) |
|
24 | (t (push arg (getf data mode))))) | |
60 | (unless (= 1 (length (getf data :source))) |
|
25 | (unless (= 1 (length (getf data :source))) | |
61 | (print-usage) |
|
26 | (print-usage) | |
62 | (report-error "There should be exactly one source")) |
|
27 | (report-error "There should be exactly one source")) | |
63 | (unless (> 1 (length (getf data :target))) |
|
28 | (unless (> 1 (length (getf data :target))) | |
64 | (print-usage) |
|
29 | (print-usage) | |
65 | (report-error "There should be no more than one target")) |
|
30 | (report-error "There should be no more than one target")) | |
66 | (unless (> 1 (length (getf data :body))) |
|
31 | (unless (> 1 (length (getf data :body))) | |
67 | (print-usage) |
|
32 | (print-usage) | |
68 | (report-error "There should be no more than one body")) |
|
33 | (report-error "There should be no more than one body")) | |
69 | (unless (getf data :target) |
|
34 | (unless (getf data :target) | |
70 | (setf (getf data :target) |
|
35 | (setf (getf data :target) | |
71 | (let* ((source (first (getf data :source))) |
|
36 | (let* ((source (first (getf data :source))) | |
72 | (tokens (uiop:split-string source :separator ".")) |
|
37 | (tokens (uiop:split-string source :separator ".")) | |
73 | (target (format nil "~{~A~^.~}.html" |
|
38 | (target (format nil "~{~A~^.~}.html" | |
74 | (butlast tokens)))) |
|
39 | (butlast tokens)))) | |
75 | (list target)))) |
|
40 | (list target)))) | |
76 | (list :source (first (getf data :source)) |
|
41 | (list :source (first (getf data :source)) | |
77 | :target (first (getf data :target)) |
|
42 | :target (first (getf data :target)) | |
78 | :js (getf data :js) |
|
43 | :js (getf data :js) | |
79 | :css (getf data :css) |
|
44 | :css (getf data :css) | |
80 | :body (first (getf data :body)) |
|
45 | :body (first (getf data :body)) | |
81 | :compile (getf data :compile) |
|
46 | :compile (getf data :compile) | |
82 | :beautify (getf data :beautify)))) |
|
47 | :beautify (getf data :beautify)))) | |
83 |
|
48 | |||
84 | (defun print-usage () |
|
49 | (defun print-usage () | |
85 | (format t "USAGE: ")) |
|
50 | (format t "USAGE: ")) | |
86 |
|
51 | |||
87 | (defun parse-file (filename) |
|
52 | (defun parse-file (filename) | |
88 | (p:parse 'sugar-qsp-grammar |
|
53 | (p:parse 'sugar-qsp-grammar | |
89 | (alexandria:read-file-into-string filename))) |
|
54 | (alexandria:read-file-into-string filename))) | |
90 |
|
55 | |||
91 | (defun make-javascript (locations) |
|
56 | (defun make-javascript (locations) | |
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" | |
124 | (file-namestring filename) (ps:ps-compile-file filename))) |
|
105 | (file-namestring filename) (ps:ps-compile-file filename))) | |
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))) |
@@ -1,206 +1,193 b'' | |||||
1 |
|
1 | |||
2 | (in-package sugar-qsp) |
|
2 | (in-package sugar-qsp) | |
3 |
|
3 | |||
4 | ;;;; Parenscript macros which make the parser's intermediate |
|
4 | ;;;; Parenscript macros which make the parser's intermediate | |
5 | ;;;; representation directly compilable by Parenscript |
|
5 | ;;;; representation directly compilable by Parenscript | |
6 | ;;;; Some utility macros for other .ps sources too. |
|
6 | ;;;; Some utility macros for other .ps sources too. | |
7 |
|
7 | |||
8 | ;;; Utils |
|
8 | ;;; Utils | |
9 |
|
9 | |||
10 | (ps:defpsmacro defm (path args &body body) |
|
10 | (ps:defpsmacro defm (path args &body body) | |
11 | `(setf ,path (lambda ,args ,@body))) |
|
11 | `(setf ,path (lambda ,args ,@body))) | |
12 |
|
12 | |||
13 | (ps:defpsmacro root (&rest path) |
|
13 | (ps:defpsmacro root (&rest path) | |
14 | `(ps:@ *sugar-q-s-p ,@path)) |
|
14 | `(ps:@ *sugar-q-s-p ,@path)) | |
15 |
|
15 | |||
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 | |
35 | :collect `(var ,var 0))))) |
|
22 | :collect `(var ,var 0))))) | |
36 | ,@(loop :for var :in vars |
|
23 | ,@(loop :for var :in vars | |
37 | :collect `(set (var ,var 0) ,(if (char= #\$ (elt (string var) 0)) |
|
24 | :collect `(set (var ,var 0) ,(if (char= #\$ (elt (string var) 0)) | |
38 | "" 0))) |
|
25 | "" 0))) | |
39 | (unwind-protect |
|
26 | (unwind-protect | |
40 | (progn ,@body) |
|
27 | (progn ,@body) | |
41 | (progn |
|
28 | (progn | |
42 | ,@(loop :for var :in vars |
|
29 | ,@(loop :for var :in vars | |
43 | :for i from 0 |
|
30 | :for i from 0 | |
44 | :collect `(set (var ,var 0) (ps:@ __conserved ,i))))))) |
|
31 | :collect `(set (var ,var 0) (ps:@ __conserved ,i))))))) | |
45 |
|
32 | |||
46 | ;;; Common |
|
33 | ;;; Common | |
47 |
|
34 | |||
48 | (defmacro defpsintrinsic (name) |
|
35 | (defmacro defpsintrinsic (name) | |
49 | `(ps:defpsmacro ,name (&rest args) |
|
36 | `(ps:defpsmacro ,name (&rest args) | |
50 | `(funcall (root lib ,',name) |
|
37 | `(funcall (root lib ,',name) | |
51 | ,@args))) |
|
38 | ,@args))) | |
52 |
|
39 | |||
53 | (defmacro defpsintrinsics (() &rest names) |
|
40 | (defmacro defpsintrinsics (() &rest names) | |
54 | `(progn ,@(loop :for name :in names |
|
41 | `(progn ,@(loop :for name :in names | |
55 | :collect `(defpsintrinsic ,name)))) |
|
42 | :collect `(defpsintrinsic ,name)))) | |
56 |
|
43 | |||
57 | (defpsintrinsics () |
|
44 | (defpsintrinsics () | |
58 | 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) |
|
45 | 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) | |
59 |
|
46 | |||
60 | (ps:defpsmacro api-call (func &rest args) |
|
47 | (ps:defpsmacro api-call (func &rest args) | |
61 | `(funcall (root api ,func) ,@args)) |
|
48 | `(funcall (root api ,func) ,@args)) | |
62 |
|
49 | |||
63 | (ps:defpsmacro label-block (&body body) |
|
50 | (ps:defpsmacro label-block (&body body) | |
64 | `(block nil |
|
51 | `(block nil | |
65 | ,@(when (some #'keywordp body) |
|
52 | ,@(when (some #'keywordp body) | |
66 | '((defvar __labels))) |
|
53 | '((defvar __labels))) | |
67 | (tagbody |
|
54 | (tagbody | |
68 | ,@body) |
|
55 | ,@body) | |
69 | (values))) |
|
56 | (values))) | |
70 |
|
57 | |||
71 | (ps:defpsmacro str (&rest forms) |
|
58 | (ps:defpsmacro str (&rest forms) | |
72 | (cond ((zerop (length forms)) |
|
59 | (cond ((zerop (length forms)) | |
73 | "") |
|
60 | "") | |
74 | ((and (= 1 (length forms)) |
|
61 | ((and (= 1 (length forms)) | |
75 | (stringp (first forms))) |
|
62 | (stringp (first forms))) | |
76 | (first forms)) |
|
63 | (first forms)) | |
77 | (t |
|
64 | (t | |
78 | `(& ,@forms)))) |
|
65 | `(& ,@forms)))) | |
79 |
|
66 | |||
80 | ;;; 1loc |
|
67 | ;;; 1loc | |
81 |
|
68 | |||
82 | (ps:defpsmacro location ((name) &body body) |
|
69 | (ps:defpsmacro location ((name) &body body) | |
83 | `(setf (root locations ,name) |
|
70 | `(setf (root locations ,name) | |
84 | (lambda () |
|
71 | (lambda () | |
85 | (label-block |
|
72 | (label-block | |
86 | ,@body |
|
73 | ,@body | |
87 | (api-call update-acts))))) |
|
74 | (api-call update-acts))))) | |
88 |
|
75 | |||
89 | (ps:defpsmacro goto (target &rest args) |
|
76 | (ps:defpsmacro goto (target &rest args) | |
90 | `(progn |
|
77 | `(progn | |
91 | (funcall (root lib goto) ,target ,@args) |
|
78 | (funcall (root lib goto) ,target ,@args) | |
92 | (exit))) |
|
79 | (exit))) | |
93 |
|
80 | |||
94 | (ps:defpsmacro xgoto (target &rest args) |
|
81 | (ps:defpsmacro xgoto (target &rest args) | |
95 | `(progn |
|
82 | `(progn | |
96 | (funcall (root lib xgoto) ,target ,@args) |
|
83 | (funcall (root lib xgoto) ,target ,@args) | |
97 | (exit))) |
|
84 | (exit))) | |
98 |
|
85 | |||
99 | (ps:defpsmacro desc (target) |
|
86 | (ps:defpsmacro desc (target) | |
100 | (declare (ignore target)) |
|
87 | (declare (ignore target)) | |
101 | (report-error "DESC is not supported")) |
|
88 | (report-error "DESC is not supported")) | |
102 |
|
89 | |||
103 | ;;; 2var |
|
90 | ;;; 2var | |
104 |
|
91 | |||
105 | (ps:defpsmacro var (name index) |
|
92 | (ps:defpsmacro var (name index) | |
106 | `(api-call get-var ,(string name) ,index)) |
|
93 | `(api-call get-var ,(string name) ,index)) | |
107 |
|
94 | |||
108 | (ps:defpsmacro set ((var vname vindex) value) |
|
95 | (ps:defpsmacro set ((var vname vindex) value) | |
109 | (assert (eq var 'var)) |
|
96 | (assert (eq var 'var)) | |
110 | `(api-call set-var ,(string vname) ,vindex ,value)) |
|
97 | `(api-call set-var ,(string vname) ,vindex ,value)) | |
111 |
|
98 | |||
112 | ;;; 3expr |
|
99 | ;;; 3expr | |
113 |
|
100 | |||
114 | (ps:defpsmacro <> (op1 op2) |
|
101 | (ps:defpsmacro <> (op1 op2) | |
115 | `(not (equal ,op1 ,op2))) |
|
102 | `(not (equal ,op1 ,op2))) | |
116 |
|
103 | |||
117 | (ps:defpsmacro ! (op1 op2) |
|
104 | (ps:defpsmacro ! (op1 op2) | |
118 | `(not (equal ,op1 ,op2))) |
|
105 | `(not (equal ,op1 ,op2))) | |
119 |
|
106 | |||
120 | ;;; 4code |
|
107 | ;;; 4code | |
121 |
|
108 | |||
122 | (ps:defpsmacro exec (&body body) |
|
109 | (ps:defpsmacro exec (&body body) | |
123 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body))) |
|
110 | (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body))) | |
124 |
|
111 | |||
125 | ;;; 5arrays |
|
112 | ;;; 5arrays | |
126 |
|
113 | |||
127 | ;;; 6str |
|
114 | ;;; 6str | |
128 |
|
115 | |||
129 | (ps:defpsmacro & (&rest args) |
|
116 | (ps:defpsmacro & (&rest args) | |
130 | `(ps:chain "" (concat ,@args))) |
|
117 | `(ps:chain "" (concat ,@args))) | |
131 |
|
118 | |||
132 | ;;; 7if |
|
119 | ;;; 7if | |
133 |
|
120 | |||
134 | (ps:defpsmacro qspcond (&rest clauses) |
|
121 | (ps:defpsmacro qspcond (&rest clauses) | |
135 | `(cond ,@(loop :for clause :in clauses |
|
122 | `(cond ,@(loop :for clause :in clauses | |
136 | :collect (list (first clause) |
|
123 | :collect (list (first clause) | |
137 | `(tagbody ,@(rest clause)))))) |
|
124 | `(tagbody ,@(rest clause)))))) | |
138 |
|
125 | |||
139 | ;;; 8sub |
|
126 | ;;; 8sub | |
140 |
|
127 | |||
141 | ;;; 9loops |
|
128 | ;;; 9loops | |
142 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels |
|
129 | ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels | |
143 |
|
130 | |||
144 | (ps:defpsmacro jump (target) |
|
131 | (ps:defpsmacro jump (target) | |
145 | `(return-from ,(intern (string-upcase (second target))) |
|
132 | `(return-from ,(intern (string-upcase (second target))) | |
146 | (funcall (ps:getprop __labels ,target)))) |
|
133 | (funcall (ps:getprop __labels ,target)))) | |
147 |
|
134 | |||
148 | (ps:defpsmacro tagbody (&body body) |
|
135 | (ps:defpsmacro tagbody (&body body) | |
149 | (let ((funcs (list nil :__nil))) |
|
136 | (let ((funcs (list nil :__nil))) | |
150 | (dolist (form body) |
|
137 | (dolist (form body) | |
151 | (cond ((keywordp form) |
|
138 | (cond ((keywordp form) | |
152 | (setf (first funcs) (reverse (first funcs))) |
|
139 | (setf (first funcs) (reverse (first funcs))) | |
153 | (push form funcs) |
|
140 | (push form funcs) | |
154 | (push nil funcs)) |
|
141 | (push nil funcs)) | |
155 | (t |
|
142 | (t | |
156 | (push form (first funcs))))) |
|
143 | (push form (first funcs))))) | |
157 | (setf (first funcs) (reverse (first funcs))) |
|
144 | (setf (first funcs) (reverse (first funcs))) | |
158 | (setf funcs (reverse funcs)) |
|
145 | (setf funcs (reverse funcs)) | |
159 | (if (= 2 (length funcs)) |
|
146 | (if (= 2 (length funcs)) | |
160 | `(progn |
|
147 | `(progn | |
161 | ,@body) |
|
148 | ,@body) | |
162 | `(progn |
|
149 | `(progn | |
163 | (setf ,@(loop :for f :on funcs :by #'cddr |
|
150 | (setf ,@(loop :for f :on funcs :by #'cddr | |
164 | :append (list `(ps:@ __labels ,(first f)) |
|
151 | :append (list `(ps:@ __labels ,(first f)) | |
165 | `(block ,(intern (string-upcase (string (first f)))) |
|
152 | `(block ,(intern (string-upcase (string (first f)))) | |
166 | ,@(second f) |
|
153 | ,@(second f) | |
167 | ,@(when (third f) |
|
154 | ,@(when (third f) | |
168 | `((funcall |
|
155 | `((funcall | |
169 | (ps:getprop __labels ,(third f))))))))) |
|
156 | (ps:getprop __labels ,(third f))))))))) | |
170 | (jump (str "__nil")))))) |
|
157 | (jump (str "__nil")))))) | |
171 |
|
158 | |||
172 | (ps:defpsmacro exit () |
|
159 | (ps:defpsmacro exit () | |
173 | `(return-from nil (values))) |
|
160 | `(return-from nil (values))) | |
174 |
|
161 | |||
175 | ;;; 10dynamic |
|
162 | ;;; 10dynamic | |
176 |
|
163 | |||
177 | (ps:defpsmacro qspblock (&body body) |
|
164 | (ps:defpsmacro qspblock (&body body) | |
178 | `(lambda () |
|
165 | `(lambda () | |
179 | (label-block |
|
166 | (label-block | |
180 | ,@body))) |
|
167 | ,@body))) | |
181 |
|
168 | |||
182 | ;;; 11main |
|
169 | ;;; 11main | |
183 |
|
170 | |||
184 | (ps:defpsmacro act (name img &body body) |
|
171 | (ps:defpsmacro act (name img &body body) | |
185 | `(api-call add-act ,name ,img |
|
172 | `(api-call add-act ,name ,img | |
186 | (lambda () |
|
173 | (lambda () | |
187 | (label-block |
|
174 | (label-block | |
188 | ,@body)))) |
|
175 | ,@body)))) | |
189 |
|
176 | |||
190 | ;;; 12aux |
|
177 | ;;; 12aux | |
191 |
|
178 | |||
192 | ;;; 13diag |
|
179 | ;;; 13diag | |
193 |
|
180 | |||
194 | ;;; 14act |
|
181 | ;;; 14act | |
195 |
|
182 | |||
196 | ;;; 15objs |
|
183 | ;;; 15objs | |
197 |
|
184 | |||
198 | ;;; 16menu |
|
185 | ;;; 16menu | |
199 |
|
186 | |||
200 | ;;; 17sound |
|
187 | ;;; 17sound | |
201 |
|
188 | |||
202 | ;;; 18img |
|
189 | ;;; 18img | |
203 |
|
190 | |||
204 | ;;; 19input |
|
191 | ;;; 19input | |
205 |
|
192 | |||
206 | ;;; 20time |
|
193 | ;;; 20time |
General Comments 0
You need to be logged in to leave comments.
Login now