diff --git a/extras/body.html b/extras/body.html
new file mode 100644
--- /dev/null
+++ b/extras/body.html
@@ -0,0 +1,7 @@
+
+
diff --git a/extras/default.css b/extras/default.css
new file mode 100644
--- /dev/null
+++ b/extras/default.css
@@ -0,0 +1,54 @@
+
+.qsp-frame {
+ border: 1px solid black;
+ overflow: auto;
+ position: absolute;
+ padding: 5px;
+ box-sizing: border-box;
+}
+
+#qsp {
+ position: fixed;
+ top: 0;
+ left: 0;
+ width: 100%;
+ height: 100%;
+}
+
+#qsp-main {
+ height: 60%;
+ width: 70%;
+ top: 0;
+ left: 0;
+}
+
+#qsp-acts {
+ height: 40%;
+ width: 70%;
+ bottom: 0;
+ left: 0;
+}
+
+#qsp-stat {
+ height: 50%;
+ width: 30%;
+ top: 0;
+ right: 0;
+}
+
+#qsp-objs {
+ height: 50%;
+ width: 30%;
+ bottom: 0;
+ right: 0;
+}
+
+.qsp-act {
+ display: block;
+ padding: 2px;
+ font-size: large;
+}
+
+.qsp-act:hover {
+ outline: #9E9E9E outset 3px
+}
diff --git a/src/api.ps b/src/api.ps
--- a/src/api.ps
+++ b/src/api.ps
@@ -20,6 +20,26 @@
(defm (root api init-dom) ()
)
+;;; Misc
+
+(defm (root api clear-id) (id)
+ (setf (ps:chain document (get-element-by-id id) inner-text) ""))
+
+(defm (root api get-id) (id)
+ (if (var "USEHTML" 0)
+ (ps:chain (document.get-element-by-id id) inner-h-t-m-l)
+ (ps:chain (document.get-element-by-id id) inner-text)))
+
+(defm (root api set-id) (id contents)
+ (if (var "USEHTML" 0)
+ (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
+ (setf (ps:chain (document.get-element-by-id id) inner-text) contents)))
+
+(defm (root api append-id) (id contents)
+ (if (var "USEHTML" 0)
+ (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
+ (incf (ps:chain (document.get-element-by-id id) inner-text) contents)))
+
;;; Function calls
(defm (root api init-args) (args)
@@ -42,13 +62,13 @@
(t (report-error "Internal error!"))))
(defm (root api add-text) (key text)
- (append-id-contents (api-call key-to-id key) text))
+ (api-call append-id (api-call key-to-id key) text))
(defm (root api get-text) (key)
- (get-id-contents (api-call key-to-id key)))
+ (api-call get-id (api-call key-to-id key)))
(defm (root api clear-text) (key)
- (set-id-contents (api-call key-to-id key) ""))
+ (api-call clear-id (api-call key-to-id key)))
(defm (root api newline) (key)
(let ((div (document.get-element-by-id
@@ -67,14 +87,14 @@
(defm (root api clear-act) ()
(setf (root acts) (ps:create))
- (set-id-contents "qsp-acts" ""))
+ (api-call clear-id "qsp-acts"))
(defm (root api update-acts) ()
- (set-id-contents "qsp-acts" "")
+ (api-call clear-id "qsp-acts")
(ps:for-in (title (root acts))
(let ((obj (ps:getprop (root acts) title)))
- (append-id-contents "qsp-acts"
- (api-call make-act-html title (ps:getprop obj :img))))))
+ (api-call append-id "qsp-acts"
+ (api-call make-act-html title (ps:getprop obj :img))))))
;;; Variables
@@ -113,8 +133,8 @@
(defm (root api kill-var) (name index)
(if (eq index :whole)
- (ps:delete (getprop (root vars) name))
- (ps:delete (getprop (root vars) name index)))
+ (ps:delete (ps:getprop (root vars) name))
+ (ps:delete (ps:getprop (root vars) name index)))
(values))
;;; Objects
diff --git a/src/main.lisp b/src/main.lisp
--- a/src/main.lisp
+++ b/src/main.lisp
@@ -1,49 +1,14 @@
(in-package sugar-qsp)
-(defun entry-point (&rest args)
- (init-vars)
+(defun entry-point-no-args ()
+ (entry-point uiop:*command-line-arguments*))
+
+(defun entry-point (args)
(catch :terminate
- (destructuring-bind (&key source target js css body compile beautify)
- (parse-opts args)
- ;; Just compile the source
- (when compile
- (alexandria:write-string-into-file
- (make-javascript (parse-file source))
- target :if-exists :supersede)
- (return-from entry-point))
- ;; Read in body
- (when body
- (setf *html-template-body*
- (alexandria:read-file-into-string body)))
- ;; Compile the game's JS
- (push (make-javascript (parse-file source)) *js-files*)
- ;; Include js files
- (dolist (js-file js)
- (push (format nil "// Included file ~A~%~A" js-file
- (alexandria:read-file-into-string js-file))
- *js-files*))
- ;; Include css files
- (dolist (css-file css)
- (push (format nil "// Included file ~A~%~A" css-file
- (alexandria:read-file-into-string css-file))
- *css-files*))
- ;; Compile into one file
- (alexandria:write-string-into-file (make-html beautify) target
- :if-exists :supersede))))
-
-(defun init-vars ()
- (setf *css-files* (list "
-.col1 { flush: left; clear: left; width: 80%; }
-.col2 { flush: right; clear: right; width: 20%; }
-.row1 { height: 70%; }
-.row2 { height: 30%; }
-.qsp-frame {border: 1px black; }
-#qsp-acts a {display: block; }
-"))
- (setf *js-files* (list (compile-ps (ps-file "intrinsics.ps"))
- (compile-ps (ps-file "api.ps"))
- (compile-ps (ps-file "main.ps")))))
+ (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
+ (write-compiled-file compiler)))
+ (values))
(defun parse-opts (args)
(let ((mode :source)
@@ -92,32 +57,48 @@
(format nil "~{~A~^~%~%~}"
(mapcar #'ps:ps* locations)))
-(defun make-html (beautify-js)
- (html-sources (css-sources)
- (if beautify-js
- (js-sources)
- (cl-uglify-js:ast-gen-code
- (cl-uglify-js:ast-mangle
- (cl-uglify-js:ast-squeeze
- (parse-js:parse-js (js-sources))))
- :beautify nil))))
+(defun uglify-js::write-json-chars (quote s stream)
+ "Write JSON representations (chars or escape sequences) of
+characters in string S to STREAM.
+Monkey-patched to output plain utf-8 instead of escape-sequences."
+ (write-char quote stream)
+ (loop :for ch :across s
+ :for code := (char-code ch)
+ :with special
+ :do (cond ((eq ch quote)
+ (write-char #\\ stream) (write-char ch stream))
+ ((setq special (car (rassoc ch uglify-js::+json-lisp-escaped-chars+)))
+ (write-char #\\ stream) (write-char special stream))
+ (t
+ (write-char ch stream))))
+ (write-char quote stream))
+
+(defun preprocess-js (js beautify)
+ (if beautify
+ (cl-uglify-js:ast-gen-code
+ (cl-uglify-js:ast-squeeze
+ (parse-js:parse-js js)
+ :sequences nil)
+ :beautify t)
+ (cl-uglify-js:ast-gen-code
+ (cl-uglify-js:ast-mangle
+ (cl-uglify-js:ast-squeeze
+ (parse-js:parse-js js)))
+ :beautify nil)))
(defun report-error (fmt &rest args)
(apply #'format t fmt args)
- (break)
(throw :terminate nil))
;;; JS
-(defparameter *js-files* nil)
-
-(defun ps-file (filename)
+(defun src-file (filename)
(uiop/pathname:merge-pathnames*
- (format nil "src/~A" filename)
+ filename
(asdf:system-source-directory :sugar-qsp)))
-(defun js-sources ()
- (format nil "~{~A~^~%~%~}" (reverse *js-files*)))
+(defmethod js-sources ((compiler compiler))
+ (format nil "~{~A~^~%~%~}" (reverse (js compiler))))
(defun compile-ps (filename)
(format nil "////// Parenscript file: ~A~%~%~A"
@@ -125,44 +106,67 @@
;;; CSS
-(defparameter *css-files* nil)
-
-(defun css-sources ()
- (format nil "~{~A~^~%~%~}" *css-files*))
+(defmethod css-sources ((compiler compiler))
+ (format nil "~{~A~^~%~%~}" (css compiler)))
;;; HTML
-(defparameter *html-template-body*
- (flute:h
- (div#qsp
- (div#qsp-main.qsp-frame.col1.row1 " ")
- (hr)
- "Действия:"
- (div#qsp-acts.qsp-frame.row2 " ")
- (hr)
- "Дополнительное окно:"
- (div#qsp-stat.qsp-frame.row1 " ")
- (hr)
- "Инвентарь:"
- (div#qsp-objs.qsp-frame.row2 " "))))
-
-(defun html-sources (&optional (css " ") (javascript " "))
- (with-output-to-string (out)
- (write
- (let ((flute:*escape-html* nil))
+(defmethod html-sources ((compiler compiler))
+ (let ((flute:*escape-html* nil)
+ (body-template (body compiler))
+ (js (js-sources compiler))
+ (css (css-sources compiler)))
+ (with-output-to-string (out)
+ (write
(flute:h
(html
(head
(title "SugarQSP"))
(body
- *html-template-body*
+ body-template
(style css)
- (script javascript)))))
- :stream out
- :pretty nil)))
+ (script (preprocess-js js (beautify compiler))))))
+ :stream out
+ :pretty nil))))
+
+(defclass compiler ()
+ ((body :accessor body :initform #.(alexandria:read-file-into-string (src-file "extras/body.html")))
+ (css :accessor css :initform (list #.(alexandria:read-file-into-string (src-file "extras/default.css"))))
+ (js :accessor js :initform (list #.(compile-ps (src-file "src/intrinsics.ps"))
+ #.(compile-ps (src-file "src/api.ps"))
+ #.(compile-ps (src-file "src/main.ps"))))
+ (compile :accessor compile-only :initarg :compile)
+ (target :accessor target :initarg :target)
+ (beautify :accessor beautify :initarg :beautify)))
-(defun write-html-default-body (filename)
- (with-open-file (out filename :direction :output)
- (write *html-template-body*
- :stream out
- :pretty t)))
+(defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
+ (call-next-method)
+ (with-slots (body css js)
+ compiler
+ ;; Compile the game's JS
+ (push (make-javascript (parse-file source)) js)
+ ;; Does the user need us to do anything else
+ (unless compile
+ ;; Read in body
+ (when body-file
+ (setf body
+ (alexandria:read-file-into-string body-file)))
+ ;; Include js files
+ (dolist (js-file js-files)
+ (push (format nil "////// Included file ~A~%~A" js-file
+ (alexandria:read-file-into-string js-file))
+ js))
+ ;; Include css files
+ (dolist (css-file css-files)
+ (push (format nil "////// Included file ~A~%~A" css-file
+ (alexandria:read-file-into-string css-file))
+ css)))))
+
+(defmethod write-compiled-file ((compiler compiler))
+ (alexandria:write-string-into-file
+ (if (compile-only compiler)
+ ;; Just the JS
+ (preprocess-js (js-sources compiler) (beautify compiler))
+ ;; All of it
+ (html-sources compiler))
+ (target compiler) :if-exists :supersede))
diff --git a/src/main.ps b/src/main.ps
--- a/src/main.ps
+++ b/src/main.ps
@@ -1,14 +1,15 @@
(in-package sugar-qsp)
-(setf (root) (ps:create vars (ps:create)
- objs (list)
- acts (ps:create)
- locations (ps:create)))
+(setf (root)
+ (ps:create vars (ps:create)
+ objs (list)
+ acts (ps:create)
+ locations (ps:create)))
-(defm (root start) ()
- (api-call init-dom)
- (funcall (root locations *start*)))
-
-(setf window.onload (lambda ()
- (funcall (root start))))
+(setf window.onload
+ (lambda ()
+ (api-call init-dom)
+ (funcall (ps:getprop (root locations)
+ (ps:chain *object (keys (root locations)) 0)))
+ (values)))
diff --git a/src/ps-macros.lisp b/src/ps-macros.lisp
--- a/src/ps-macros.lisp
+++ b/src/ps-macros.lisp
@@ -16,19 +16,6 @@
(ps:defpsmacro in (key obj)
`(ps:chain ,obj (has-own-property ,key)))
-(ps:defpsmacro get-id-contents (id)
- `(if (var "USEHTML" 0)
- (ps:chain (document.get-element-by-id ,id) inner-h-t-m-l)
- (ps:chain (document.get-element-by-id ,id) inner-text)))
-
-(ps:defpsmacro set-id-contents (id contents)
- `(if (var "USEHTML" 0)
- (setf (ps:chain (document.get-element-by-id ,id) inner-h-t-m-l) ,contents)
- (setf (ps:chain (document.get-element-by-id ,id) inner-text) ,contents)))
-
-(ps:defpsmacro append-id-contents (id contents)
- `(set-id-contents ,id (+ (get-id-contents ,id) ,contents)))
-
(ps:defpsmacro conserving-vars (vars &body body)
"Calls body with safely stored away VARS, and restores their values after that returning what BODY returns."
`(let ((__conserved (list ,@(loop :for var :in vars