diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,9 +1,6 @@ -* Windows GUI -* Save-load game +* Windows GUI (for the compiler) +* Save-load game in slots * Resizable frames * Build Istreblenie -** modifying it to suit compiler specifics -** Implementing apis and intrinsics as needed - -* Use real characters in cl-uglify-js \ No newline at end of file +** modifying it to suit compiler specifics \ No newline at end of file diff --git a/extras/body.html b/extras/body.html --- a/extras/body.html +++ b/extras/body.html @@ -10,3 +10,6 @@
 
+ +
+
diff --git a/extras/default.css b/extras/default.css --- a/extras/default.css +++ b/extras/default.css @@ -57,3 +57,28 @@ .qsp-act:hover { outline: #9E9E9E outset 3px } + +// Dropdown + +#qsp-dropdown { + display: none; + position: absolute; + background-color: #f1f1f1; + min-width: 160px; + overflow: auto; + box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2); + z-index: 1; + margin: auto; + top: 200; +} + +#qsp-dropdown a { + color: black; + padding: 12px 16px; + text-decoration: none; + display: block; +} + +#qsp-dropdown a:hover { + background-color: #ddd; +} diff --git a/src/api.ps b/src/api.ps --- a/src/api.ps +++ b/src/api.ps @@ -15,14 +15,35 @@ title "")) +(defm (root api make-menu-item-html) (num title img loc) + (+ "" + "" + title + "")) + ;; To be used in saving game (defm (root api stash-state) () (setf (root state-stash) - (ps:create vars (root vars) - objs (root objs) - next-location (root current-location))) + (*j-s-o-n.stringify + (ps:create vars (root vars) + objs (root objs) + next-location (root current-location)))) (values)) +(defm (root api state-to-base64) () + (btoa (encode-u-r-i-component (root state-stash)))) + +(defm (root api base64-to-state) (data) + (setf (root state-stash) (decode-u-r-i-component (atob data))) + (let ((data (*j-s-o-n.parse (root state-stash)))) + (api-call clear-act) + (setf (root vars) (ps:@ data vars)) + (setf (root objs) (ps:@ data objs)) + (setf (root current-location) (ps:@ data next-location)) + (funcall (root locs (root current-location))) + (api-call update-objs) + (values))) + ;;; Misc (defm (root api clear-id) (id) @@ -62,8 +83,15 @@ (case key (:main "qsp-main") (:stat "qsp-stat") + (:objs "qsp-objs") + (:acts "qsp-acts") + (:input "qsp-input") + (:dropdown "qsp-dropdown") (t (report-error "Internal error!")))) +(defm (root api get-frame) (key) + (document.get-element-by-id (api-call key-to-id key))) + (defm (root api add-text) (key text) (api-call append-id (api-call key-to-id key) text)) @@ -74,15 +102,20 @@ (api-call clear-id (api-call key-to-id key))) (defm (root api newline) (key) - (let ((div (document.get-element-by-id - (api-call key-to-id key)))) + (let ((div (api-call get-frame key))) (ps:chain div (append-child (document.create-element "br"))))) +(defm (root api enable-frame) (key enable) + (let ((clss (ps:getprop (api-call get-frame key) 'class-list))) + (setf clss.style.display (if enable "block" "none")) + (values))) + ;;; Actions (defm (root api add-act) (title img act) (setf (ps:getprop (root acts) title) - (ps:create :img img :act act))) + (ps:create :img img :act act)) + (api-call update-acts)) (defm (root api del-act) (title) (delete (ps:getprop (root acts) title)) @@ -134,12 +167,18 @@ value) (values))) +(defm (root api get-array) (name type) + (ps:getprop (root vars) (api-call var-real-name name))) + (defm (root api kill-var) (name index) (if (eq index :whole) (ps:delete (ps:getprop (root vars) name)) (ps:delete (ps:getprop (root vars) name index))) (values)) +(defm (root api array-size) (name) + (ps:getprop (root vars) (api-call var-real-name name) 'length)) + ;;; Objects (defm (root api update-objs) () @@ -148,3 +187,14 @@ (loop :for obj :in (root objs) :do (incf elt.inner-h-t-m-l (+ "
  • " obj))) (incf elt.inner-h-t-m-l ""))) + +;;; Menu + +(defm (root api menu) (menu-data) + (let ((elt (document.get-element-by-id "qsp-dropdown")) + (i 0)) + (setf elt.inner-h-t-m-l "") + (loop :for item :in menu-data + :do (incf i) + :do (incf elt.inner-h-t-m-l (api-call make-menu-item-html i item.text item.icon item.loc))) + (setf elt.style.display "block"))) diff --git a/src/class.lisp b/src/class.lisp new file mode 100644 --- /dev/null +++ b/src/class.lisp @@ -0,0 +1,21 @@ + +(in-package sugar-qsp) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun src-file (filename) + (uiop/pathname:merge-pathnames* + filename + (asdf:system-source-directory :sugar-qsp))) + (defun compile-ps (filename) + (format nil "////// Parenscript file: ~A~%~%~A" + (file-namestring filename) (ps:ps-compile-file filename)))) + +(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))) diff --git a/src/intrinsic-macros.lisp b/src/intrinsic-macros.lisp new file mode 100644 --- /dev/null +++ b/src/intrinsic-macros.lisp @@ -0,0 +1,137 @@ + +(in-package sugar-qsp) + +;;;; Macros implementing some intrinsics where it makes sense +;;;; E.g. an equivalent JS function exists, or it's a direct API call + +;;; 1loc + +;;; 2var + +(ps:defpsmacro killvar (varname &optional (index :whole)) + `(api-call kill-var ,varname ,index)) + +(ps:defpsmacro killall () + `(api-call kill-all)) + +;;; 3expr + +(ps:defpsmacro obj (name) + `(funcall (root objs includes) ,name)) + +(ps:defpsmacro loc (name) + `(funcall (root locs includes) ,name)) + +(ps:defpsmacro no (arg) + `(- -1 ,arg)) + +;;; 4code + +(ps:defpsmacro qspver () + "0.0.1") + +(ps:defpsmacro curloc () + `(root current-location)) + +(ps:defpsmacro rnd () + `(funcall (root lib rand) 1 1000)) + +(ps:defpsmacro qspmax (&rest args) + `(max ,@args)) + +(ps:defpsmacro qspmin (&rest args) + `(min ,@args)) + +;;; 5arrays + +(ps:defpsmacro arrsize (name) + `(api-call array-size ,name)) + +;;; 6str + +(ps:defpsmacro len (s) + `(length ,s)) + +(ps:defpsmacro mid (s from &optional count) + `(ps:chain ,s (substring ,from ,count))) + +(ps:defpsmacro ucase (s) + `(ps:chain ,s (to-upper-case))) + +(ps:defpsmacro lcase (s) + `(ps:chain ,s (to-lower-case))) + +(ps:defpsmacro trim (s) + `(ps:chain ,s (trim))) + +(ps:defpsmacro replace (s from to) + `(ps:chain ,s (replace ,from ,to))) + +(ps:defpsmacro val (s) + `(parse-int ,s 10)) + +(ps:defpsmacro qspstr (n) + `(ps:chain ,n (to-string))) + +;;; 7if + +;;; 8sub + +;;; 9loops + +;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge) + +(ps:defpsmacro exit () + `(return-from nil (values))) + +;;; 10dynamic + +;;; 11main + +(ps:defpsmacro desc (s) + (declare (ignore s)) + "") + +;;; 12stat + +(ps:defpsmacro showstat (enable) + `(api-call enable-frame :stat ,enable)) + +;;; 13diag + +(ps:defpsmacro msg (text) + `(alert ,text)) + +;;; 14act + +(ps:defpsmacro showacts (enable) + `(api-call enable-frame :acts ,enable)) + +(ps:defpsmacro delact (name) + `(api-call del-act ,name)) + +(ps:defpsmacro cla () + `(api-call clear-act)) + +;;; 15objs + +(ps:defpsmacro showobjs (enable) + `(api-call enable-frame :objs ,enable)) + +(ps:defpsmacro countobj () + `(length (root objs))) + +(ps:defpsmacro getobj (index) + `(or (elt (root objs) ,index) "")) + +;;; 16menu + +;;; 17sound + +;;; 18img + +;;; 19input + +;;; 20time + +;;; misc diff --git a/src/intrinsics.ps b/src/intrinsics.ps --- a/src/intrinsics.ps +++ b/src/intrinsics.ps @@ -16,51 +16,21 @@ (defm (root lib xgoto) (target &rest args) (api-call clear-act) (api-call init-args args) - (setf (root current-location) target) + (setf (root current-location) (ps:chain target (to-upper-case))) (api-call stash-state) - (funcall (ps:getprop (root locations) (ps:chain target (to-upper-case))))) + (funcall (ps:getprop (root locs) (root current-location)))) ;;; 2var -(defm (root lib killvar) (varname &optional (index :whole)) - (api-call kill-var varname index)) - -(defm (root lib killall) () - (api-call kill-all)) - ;;; 3expr -(defm (root lib obj) (name) - (funcall (root objs includes) name)) - -(defm (root lib loc) () - (funcall (root locations includes) name)) - -(defm (root lib no) (arg) - (- -1 arg)) - ;;; 4code -(defm (root lib qspver) () - "0.0.1") - -(defm (root lib curloc) () - (root current-location)) - -(defm (root lib rand) (a b) +(defm (root lib rand) (a &optional (b 1)) (let ((min (min a b)) (max (max a b))) (+ min (ps:chain *math (random (- max min)))))) -(defm (root lib rnd) () - (funcall (root lib rand) 1 1000)) - -(defm (root lib qspmax) (&rest args) - (apply (ps:@ *math max) args)) - -(defm (root lib qspmin) (&rest args) - (apply (ps:@ *math min) args)) - ;;; 5arrays (defm (root lib copyarr) (to from start count) @@ -71,9 +41,6 @@ (api-call set-var to (+ start i) (api-call get-var from (+ start i))))) -(defm (root lib arrsize) (name) - (api-call array-size name)) - (defm (root lib arrpos) (name value &optional (start 0)) (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i)) (when (eq (api-call get-var name i) value) @@ -88,24 +55,6 @@ ;;; 6str -(defm (root lib len) (s) - (length s)) - -(defm (root lib mid) (s from &optional count) - (s.substring from count)) - -(defm (root lib ucase) (s) - (s.to-upper-case)) - -(defm (root lib lcase) (s) - (s.to-lower-case)) - -(defm (root lib trim) (s) - (s.trim)) - -(defm (root lib replace) (s from to) - (s.replace from to)) - (defm (root lib instr) (s subs &optional (start 1)) (+ start (ps:chain s (substring (- start 1)) (search subs)))) @@ -114,12 +63,6 @@ 0 -1)) -(defm (root lib val) (s) - (parse-int s 10)) - -(defm (root lib qspstr) (n) - (+ "" n)) - (defm (root lib strcomp) (s pattern) (if (s.match pattern) -1 @@ -140,21 +83,23 @@ ;;; 7if +;; Has to be a function because it always evaluates all three of its +;; arguments (defm (root lib iif) (cond-expr then-expr else-expr) - (if (= -1 cond-expr) then-expr else-expr)) + (if cond-expr then-expr else-expr)) ;;; 8sub (defm (root lib gosub) (target &rest args) (conserving-vars (args result) (api-call init-args args) - (funcall (ps:getprop (root locations) target)) + (funcall (ps:getprop (root locs) target)) (values))) (defm (root lib func) (target &rest args) (conserving-vars (args result) (api-call init-args args) - (funcall (ps:getprop (root locations) target)) + (funcall (ps:getprop (root locs) target)) (api-call get-result))) ;;; 9loops @@ -176,79 +121,114 @@ ;;; 11main (defm (root lib main-p) (s) - (api-call add-text :main s)) + (api-call add-text :main s) + (values)) (defm (root lib main-pl) (s) (api-call add-text :main s) - (api-call newline :main)) + (api-call newline :main) + (values)) (defm (root lib main-nl) (s) (api-call newline :main) - (api-call add-text :main s)) + (api-call add-text :main s) + (values)) (defm (root lib maintxt) (s) - (api-call get-text :main)) + (api-call get-text :main) + (values)) +;; For clarity (it leaves a lib.desc() call in JS) (defm (root lib desc) (s) "") (defm (root lib main-clear) () - (api-call clear-text :main)) + (api-call clear-text :main) + (values)) ;;; 12stat -(defm (root lib showstat) ()) +(defm (root lib stat-p) (s) + (api-call add-text :stat s) + (values)) -(defm (root lib stat-p) ()) +(defm (root lib stat-pl) (s) + (api-call add-text :stat s) + (api-call newline :stat) + (values)) -(defm (root lib stat-pl) ()) +(defm (root lib stat-nl) (s) + (api-call newline :stat) + (api-call add-text :stat s) + (values)) -(defm (root lib stat-nl) ()) - -(defm (root lib stattxt) ()) +(defm (root lib stattxt) (s) + (api-call get-text :stat) + (values)) -(defm (root lib clear) ()) +(defm (root lib stat-clear) () + (api-call clear-text :stat) + (values)) -(defm (root lib cls) ()) +(defm (root lib cls) () + (funcall (root lib stat-clear)) + (funcall (root lib main-clear)) + (funcall (root lib cla)) + (funcall (root lib cmdclear)) + (values)) ;;; 13diag -(defm (root lib msg) ()) - ;;; 14act -(defm (root lib showacts) ()) - -(defm (root lib delact) (name) - (api-call del-act name)) - -(defm (root lib curacts) ()) - -(defm (root lib cla) ()) +(defm (root lib curacts) () + (let ((acts (root acts))) + (lambda () + (setf (root acts) acts) + (values)))) ;;; 15objs -(defm (root lib showobjs) ()) - (defm (root lib addobj) (name) (ps:chain (root objs) (push name)) - (api-call update-objs)) + (api-call update-objs) + (values)) (defm (root lib delobj) (name) (let ((index (ps:chain (root objs) (index-of name)))) (when (> index -1) - (ps:chain (root objs) (splice index 1)))) - (api-call update-objs)) + (funcall (root lib killobj) index))) + (values)) -(defm (root lib killobj) ()) - -(defm (root lib countobj) ()) - -(defm (root lib getobj) ()) +(defm (root lib killobj) (&optional num) + (if num + (ps:chain (root objs) (splice (1+ num) 1)) + (setf (root objs) (list))) + (api-call update-objs) + (values)) ;;; 16menu -(defm (root lib menu) ()) +(defm (root lib menu) (menu-name) + (let ((menu-data (list))) + (loop :for item :in (api-call get-array menu-name) + :do (cond ((string= item "") + (break)) + ((string= item "-:-") + (ps:chain menu-data (push :delimiter))) + (t + (let* ((tokens (ps:chain item (split ":")))) + (when (= (length tokens) 2) + (tokens.push "")) + (let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":"))) + (loc (ps:getprop tokens (- tokens.length 2))) + (icon (ps:getprop tokens (- tokens.length 1)))) + (ps:chain menu-data + (push (ps:create text text + loc loc + icon icon)))))))) + (api-call menu menu-data) + (values))) ;;; 17sound @@ -278,7 +258,11 @@ ;;; 20time -(defm (root lib wait) ()) +;; I wonder if there's a better solution than busy-wait +(defm (root lib wait) (msec) + (let* ((now (ps:new (*date))) + (exit-time (+ (funcall now.get-time) msec))) + (loop :while (< (funcall now.get-time) exit-time)))) (defm (root lib msecscount) ()) @@ -294,6 +278,36 @@ (defm (root lib killqst) ()) -(defm (root lib opengame) ()) +(defm (root lib opengame) (&optional filename) + (let ((element (document.create-element :input))) + (element.set-attribute :type :file) + (element.set-attribute :id :qsp-opengame) + (element.set-attribute :tabindex -1) + (element.set-attribute "aria-hidden" t) + (setf element.style.display :block) + (setf element.style.visibility :hidden) + (setf element.style.position :fixed) + (setf element.onchange + (lambda (event) + (let* ((file (elt event.target.files 0)) + (reader (ps:new (*file-reader)))) + (setf reader.onload + (lambda (ev) + (block nil + (let ((target ev.current-target)) + (unless target.result + (return)) + (api-call base64-to-state target.result))))) + (reader.read-as-text file)))) + (document.body.append-child element) + (element.click) + (document.body.remove-child element))) -(defm (root lib savegame) ()) +(defm (root lib savegame) (&optional filename) + (let ((element (document.create-element :a))) + (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64))) + (element.set-attribute :download "savegame.sav") + (setf element.style.display :none) + (document.body.append-child element) + (element.click) + (document.body.remove-child element))) diff --git a/src/main.lisp b/src/main.lisp --- a/src/main.lisp +++ b/src/main.lisp @@ -54,7 +54,7 @@ (alexandria:read-file-into-string filename))) (defun make-javascript (locations) - (format nil "~{~A~^~%~%~}" + (format nil "////// THE GAME STARTS HERE~%~%~{~A~^~%~%~}" (mapcar #'ps:ps* locations))) (defun uglify-js::write-json-chars (quote s stream) @@ -92,18 +92,9 @@ Monkey-patched to output plain utf-8 ins ;;; JS -(defun src-file (filename) - (uiop/pathname:merge-pathnames* - filename - (asdf:system-source-directory :sugar-qsp))) - (defmethod js-sources ((compiler compiler)) (format nil "~{~A~^~%~%~}" (reverse (js compiler)))) -(defun compile-ps (filename) - (format nil "////// Parenscript file: ~A~%~%~A" - (file-namestring filename) (ps:ps-compile-file filename))) - ;;; CSS (defmethod css-sources ((compiler compiler)) @@ -129,16 +120,6 @@ Monkey-patched to output plain utf-8 ins :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))) - (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) diff --git a/src/main.ps b/src/main.ps --- a/src/main.ps +++ b/src/main.ps @@ -6,10 +6,16 @@ objs (list) state-stash (ps:create) acts (ps:create) - locations (ps:create))) + locs (ps:create))) +;; Launch the game from the first location (setf window.onload (lambda () - (funcall (ps:getprop (root locations) - (ps:chain *object (keys (root locations)) 0))) + (funcall (ps:getprop (root locs) + (ps:chain *object (keys (root locs)) 0))) (values))) + +;; Close the dropdown on any click +(setf window.onclick + (lambda (event) + (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))) diff --git a/src/parser.lisp b/src/parser.lisp --- a/src/parser.lisp +++ b/src/parser.lisp @@ -184,7 +184,7 @@ (declare (ignore spaces1 spaces2)) (string-upcase (string-trim " " (p:text name))))) -(p:defrule location-end (and #\- #\newline before-statement) +(p:defrule location-end (and #\- (* not-newline) #\newline before-statement) (:constant nil)) ;;; Block body @@ -486,8 +486,8 @@ (openqst nil 1 1) (addqst nil 1 1 "addqst" "addlib" "inclib") (killqst nil 1 1 "killqst" "dellib" "freelib") - (opengame nil 0 1) - (savegame nil 0 1) + (opengame nil 0 0) + (savegame nil 0 0) ;; Real time (wait nil 1 1) (msecscount t 0 0) diff --git a/src/ps-macros.lisp b/src/ps-macros.lisp --- a/src/ps-macros.lisp +++ b/src/ps-macros.lisp @@ -41,7 +41,7 @@ :collect `(defpsintrinsic ,name)))) (defpsintrinsics () - 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) + rand copyarr arrpos arrcomp instr isnum strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear stat-p stat-pl stat-nl stattxt stat-clear cls curacts addobj delobj killobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer) (ps:defpsmacro api-call (func &rest args) `(funcall (root api ,func) ,@args)) @@ -66,11 +66,10 @@ ;;; 1loc (ps:defpsmacro location ((name) &body body) - `(setf (root locations ,name) + `(setf (root locs ,name) (lambda () (label-block - ,@body - (api-call update-acts))))) + ,@body)))) (ps:defpsmacro goto (target &rest args) `(progn @@ -155,9 +154,6 @@ (ps:getprop __labels ,(third f))))))))) (jump (str "__nil")))))) -(ps:defpsmacro exit () - `(return-from nil (values))) - ;;; 10dynamic (ps:defpsmacro qspblock (&body body) diff --git a/sugar-qsp.asd b/sugar-qsp.asd --- a/sugar-qsp.asd +++ b/sugar-qsp.asd @@ -7,5 +7,7 @@ :serial t :components ((:file "package") (:file "ps-macros") + (:file "intrinsic-macros") + (:file "class") (:file "main") (:file "parser")))