diff --git a/.hgignore b/.hgignore --- a/.hgignore +++ b/.hgignore @@ -3,3 +3,5 @@ .html .png tests +sugar-qsp +sugar-qsp.tar.xz diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -3,13 +3,16 @@ 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 @@ 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 diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,6 +1,6 @@ * Save-load game in slots -* CLI build for Linux + * CLI build for Windows * Reporting error lines in the parser @@ -10,5 +10,6 @@ * Build Istreblenie * Build Цветохимия + * Windows GUI (for the compiler) * Resizable frames diff --git a/qlfile b/qlfile --- a/qlfile +++ b/qlfile @@ -6,10 +6,5 @@ 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 diff --git a/qlfile.lock b/qlfile.lock --- a/qlfile.lock +++ b/qlfile.lock @@ -1,68 +1,40 @@ ("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")) diff --git a/src/api.ps b/src/api.ps --- a/src/api.ps +++ b/src/api.ps @@ -386,8 +386,41 @@ 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)) diff --git a/src/js-syms.lisp b/src/js-syms.lisp --- a/src/js-syms.lisp +++ b/src/js-syms.lisp @@ -35,6 +35,7 @@ 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 diff --git a/src/main-macros.lisp b/src/main-macros.lisp --- a/src/main-macros.lisp +++ b/src/main-macros.lisp @@ -2,7 +2,7 @@ (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))) diff --git a/src/main.lisp b/src/main.lisp --- a/src/main.lisp +++ b/src/main.lisp @@ -1,13 +1,17 @@ (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 @@ ("--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 @@ :beautify (getf data :beautify)))) (defun print-usage () - (format t "USAGE: ")) + (format t "Usage: ~A [options]~%" *app-name*) + (format t "Options:~%") + (format t " -o - Output filename~%") + (format t " --js - List of extra .js files to include in the game~%") + (format t " --css - List of .css files to include in the game. Default is in extras/default.css~%") + (format t " --body - 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 @@ (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 diff --git a/src/parser.lisp b/src/parser.lisp --- a/src/parser.lisp +++ b/src/parser.lisp @@ -35,7 +35,7 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (killobj nil 0 1) (countobj t 0 0) (getobj t 1 1) + (selobj t 0 0) ;; Menu (menu nil 1 1) ;; Images