Working Linux build, some CLI improvements

.hgignore

@@ -3,3 +3,5 b''
 .html
 .png
 tests
+sugar-qsp
+sugar-qsp.tar.xz

Makefile

@@ -3,13 +3,16 b' BIN = sugar-qsp'
 
 LISP = sbcl
 
-all: diagrams.png $(BIN)
+all: $(BIN)
+
+graphs: diagrams.png
 
 $(BIN): src/*.lisp src/*.ps
 	buildapp.$(LISP) --asdf-path .\
 		--asdf-tree .qlot/dists\
 		--load-system sugar-qsp\
 		--entry sugar-qsp:entry-point\
+		--compress-core\
 		--output $(BIN)
 
 install-deps:
@@ -18,8 +21,19 b' install-deps:'
 update-deps:
 	sbcl --load update-deps.lisp
 
-diagrams.png: diagrams.dot
+%.png: %.dot
 	dot $< -T png -o $@
 
+dist: $(BIN)
+	tar cfvJ sugar-qsp.tar.xz $(BIN) extras
+
+distclean: clean clean-deps
+
 clean:
-	rm sugar-qsp
+	-rm sugar-qsp
+
+clean-deps:
+	-rm qlfile.lock
+	-rm -rf .qlot
+
+.PHONY: all graphs install-deps update-deps clean

TODO

@@ -1,6 +1,6 b''
 
 * Save-load game in slots
-* CLI build for Linux
+
 * CLI build for Windows
 
 * Reporting error lines in the parser
@@ -10,5 +10,6 b''
 
 * Build Istreblenie
 * Build Цветохимия
+
 * Windows GUI (for the compiler)
 * Resizable frames

qlfile

@@ -6,10 +6,5 b' ql flute'
 ql cl-ppcre
 ql anaphora
 ql named-readtables
-ql cl-unicode
-ql flexi-streams
-ql trivial-gray-streams
-ql parse-number
-ql iterate
 ql assoc-utils
 ql let-over-lambda

qlfile.lock

@@ -1,68 +1,40 b''
 ("quicklisp" .
  (:class qlot/source/dist:source-dist
   :initargs (:distribution "http://beta.quicklisp.org/dist/quicklisp.txt" :%version :latest)
-  :version "2020-02-18"))
+  :version "2020-04-27"))
 ("alexandria" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("esrap" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("parenscript" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
-("cl-uglify-js" .
- (:class qlot/source/ql:source-ql
-  :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("flute" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("cl-ppcre" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("anaphora" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("named-readtables" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
-("parse-js" .
- (:class qlot/source/ql:source-ql
-  :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
-("cl-unicode" .
- (:class qlot/source/ql:source-ql
-  :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
-("flexi-streams" .
- (:class qlot/source/ql:source-ql
-  :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
-("trivial-gray-streams" .
- (:class qlot/source/ql:source-ql
-  :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
-("parse-number" .
- (:class qlot/source/ql:source-ql
-  :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
-("iterate" .
- (:class qlot/source/ql:source-ql
-  :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("assoc-utils" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))
 ("let-over-lambda" .
  (:class qlot/source/ql:source-ql
   :initargs (:%version :latest)
-  :version "ql-2020-02-18"))
+  :version "ql-2020-04-27"))

src/api.ps

@@ -386,8 +386,41 b''
                    hex))))
       (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue)))))
 
+(defun store-obj (key obj)
+  (store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj)))))
+  (void))
+(defun store-str (key str)
+  (chain local-storage (set-item (+ "qsp_" key) str))
+  (void))
+
+(defun load-obj (key)
+  (chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key))))))
+(defun load-str (key)
+  (chain local-storage (get-item (+ "qsp_" key))))
+
 ;;; Saves
 
+(defun slot-savegame (slot comment)
+  (let ((saves (load-obj "saves")))
+    (setf (@ saves slot) comment)
+    (store-obj saves))
+  (store-str slot (state-to-base64))
+  (void))
+
+(defun slot-loadgame (slot)
+  (base64-to-state (load-str slot))
+  (void))
+
+(defun slot-deletegame (slot)
+  (let ((saves (load-obj "saves")))
+    (setf (@ saves slot) undefined)
+    (store-obj saves))
+  (store-str slot undefined)
+  (void))
+
+(defun slot-listgames ()
+  (load-obj "saves"))
+
 (defun opengame ()
   (let ((element (chain document (create-element :input))))
     (chain element (set-attribute :type :file))

src/js-syms.lisp

@@ -35,6 +35,7 b''
  top left
  background-image background-color
  color inner-text font-size font-family font-name
+ local-storage set-item get-item
  ;; lib
  *number parse-int
  to-string to-upper-case concat

src/main-macros.lisp

@@ -2,7 +2,7 b''
 (in-package sugar-qsp.main)
 
 (defmacro+ps api-call (name &rest args)
-  `(,(intern (string-upcase name) "API") ,@args))
+  `(,(intern (string-upcase name) "SUGAR-QSP.API") ,@args))
 
 (defpsmacro has (key obj)
   `(chain ,obj (has-own-property ,key)))

src/main.lisp

@@ -1,13 +1,17 b''
 
 (in-package sugar-qsp)
 
+(defvar *app-name* "")
+
 (defun entry-point-no-args ()
   (entry-point uiop:*command-line-arguments*))
 
 (defun entry-point (args)
-  (catch :terminate
-    (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
-      (write-compiled-file compiler)))
+  (setf *app-name* (first args))
+  (let ((*package* (find-package :sugar-qsp)))
+    (catch :terminate
+      (let ((compiler (apply #'make-instance 'compiler (parse-opts (rest args)))))
+        (write-compiled-file compiler))))
   (values))
 
 (defun parse-opts (args)
@@ -23,13 +27,10 b''
              ("--beautify" (setf (getf data :beautify) t))
              (t (push arg (getf data mode)))))
     (unless (< 0 (length (getf data :sources)))
-      (print-usage)
       (report-error "There should be at least one source"))
     (unless (> 1 (length (getf data :target)))
-      (print-usage)
       (report-error "There should be no more than one target"))
     (unless (> 1 (length (getf data :body)))
-      (print-usage)
       (report-error "There should be no more than one body"))
     (unless (getf data :target)
       (setf (getf data :target)
@@ -47,14 +48,25 b''
           :beautify (getf data :beautify))))
 
 (defun print-usage ()
-  (format t "USAGE: "))
+  (format t "Usage: ~A <source> [options]~%" *app-name*)
+  (format t "Options:~%")
+  (format t "  -o <filename>         - Output filename~%")
+  (format t "  --js <filenames...>   - List of extra .js files to include in the game~%")
+  (format t "  --css <filenames...>  - List of .css files to include in the game. Default is in extras/default.css~%")
+  (format t "  --body <filename>     - Alternative page body. Default is in extras/body.html~%")
+  (format t "~%")
+  (format t "  -c                    - Just compile the game to a .js file without making it a full web page~%")
+  (format t "  --beautify            - Make the JS content pretty. By default it gets minified.~%")
+  (format t "~%")
+  (format t "Note that the files in extras/ are not actually used. They're just there for the reference"))
 
 (defun parse-file (filename)
   (p:parse 'sugar-qsp-grammar
            (alexandria:read-file-into-string filename)))
 
 (defun report-error (fmt &rest args)
-  (apply #'format t fmt args)
+  (format t "ERROR: ~A~%" (apply #'format nil fmt args))
+  (print-usage)
   (throw :terminate nil))
 
 ;;; JS
@@ -133,10 +145,13 b''
                       (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)))))
+      (when css-files
+        ;; User option overrides the default css
+        (setf css nil)
+        (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

src/parser.lisp

@@ -35,7 +35,7 b''
    (not (find char " 	!:&=<>+-*/,'\"()[]{}"))))
 
 (defun intern-first (list)
-  (list* (intern (string-upcase (first list)) :lib)
+  (list* (intern (string-upcase (first list)) "SUGAR-QSP.LIB")
          (rest list)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -129,7 +129,7 b''
                        (digit-char-p character)))
 (p:defrule identifier-raw (and id-first (* id-next))
   (:lambda (list)
-    (intern (string-upcase (p:text list)) :lib)))
+    (intern (string-upcase (p:text list)) "SUGAR-QSP.LIB")))
 
 (p:defrule identifier (not-qsp-keyword-p identifier-raw))
 
@@ -431,7 +431,7 b''
        (unless (<= ,min-arity (length arguments) ,max-arity)
          (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S"
                 name ,min-arity ,max-arity (length arguments) arguments))
-       (list* ',(intern (string sym) :lib) arguments))))
+       (list* ',(intern (string sym) "SUGAR-QSP.LIB") arguments))))
 
 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
   ;; Transitions
@@ -495,9 +495,9 b''
   (main-clear   nil 0 0 "*clear" "*clr")
   ;; Aux window
   (showstat nil 1 1)
-  (stat-pl   nil 1 1 "pl")
-  (stat-nl   nil 0 1 "nl")
-  (stat-p    nil 1 1 "p")
+  (stat-pl  nil 1 1 "pl")
+  (stat-nl  nil 0 1 "nl")
+  (stat-p   nil 1 1 "p")
   (stattxt  t   0 0)
   (stat-clear    nil 0 0 "clear" "clr")
   (cls      nil 0 0)
@@ -505,9 +505,9 b''
   (msg      nil 1 1)
   ;; Acts
   (showacts nil 1 1)
-  (delact   nil 0 1 "delact" "del act")
-  (curact   t   0 0)
+  (delact   nil 1 1 "delact" "del act")
   (curacts  t   0 0)
+  (selact   t   0 0)
   (cla      nil 0 0)
   ;; Objects
   (showobjs nil 1 1)
@@ -516,6 +516,7 b''
   (killobj  nil 0 1)
   (countobj t   0 0)
   (getobj   t   1 1)
+  (selobj   t   0 0)
   ;; Menu
   (menu     nil 1 1)
   ;; Images