# HG changeset patch
# User <naryl+rhodecode@ave.maria.si>
# Date 2020-03-19 07:39:49
# Node ID 809cbd272830c98a691f73b2d30f4207ade90119
# Parent  9ffa78711c899273f0cb66c42f0c09922a31b353

A better UI

diff --git a/extras/body.html b/extras/body.html
new file mode 100644
--- /dev/null
+++ b/extras/body.html
@@ -0,0 +1,7 @@
+
+<div id="qsp">
+  <div id="qsp-main" class="qsp-frame">&nbsp;</div>
+  <div id="qsp-acts" class="qsp-frame">&nbsp;</div>
+  <div id="qsp-stat" class="qsp-frame">&nbsp;</div>
+  <div id="qsp-objs" class="qsp-frame">&nbsp;</div>
+</div>
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