diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,6 +1,7 @@ * Special locations * Special variables +* IMG * CLI build for Linux * CLI build for Windows diff --git a/extras/body.html b/extras/body.html --- a/extras/body.html +++ b/extras/body.html @@ -21,3 +21,6 @@
+ + diff --git a/extras/default.css b/extras/default.css --- a/extras/default.css +++ b/extras/default.css @@ -35,6 +35,9 @@ #qsp-main { flex: 6 6 60px; + background-repeat: no-repeat; + background-position: right top; + background-attachment: fixed; } #qsp-acts { diff --git a/src/api-macros.lisp b/src/api-macros.lisp --- a/src/api-macros.lisp +++ b/src/api-macros.lisp @@ -14,8 +14,11 @@ ,@body (pop-local-frame)))) +(defpsmacro href-call (func &rest args) + `(+ "javascript:" (inline-call ,func ,@args))) + (defpsmacro inline-call (func &rest args) - `(+ (ps-inline ,func) + `(+ ,func "(\"" ,(first args) ,@(loop :for arg :in (cdr args) @@ -32,3 +35,12 @@ (resolve))))) ,@body)))) +(defvar serv-vars (create)) + +(defpsmacro define-serv-var (name (slot value &optional index) &body body) + (setf name (string-upcase (symbol-name name))) + `(setf (getprop serv-vars name) + (create :name ,name + :slot ,slot + :body (lambda (,value ,@(when index (list index))) + ,@body)))) diff --git a/src/api.ps b/src/api.ps --- a/src/api.ps +++ b/src/api.ps @@ -9,17 +9,25 @@ ;;; Utils (defun make-act-html (title img) - (+ "" + (+ "" (if img (+ "") "") title "")) (defun make-menu-item-html (num title img loc) - (+ "" + (+ "" (if img (+ "") "") title "")) +(defun make-obj (title img selected) + (+ "
  • " + "" + (if img (+ "") "") + obj + "")) + (defun make-menu-delimiter () "
    ") @@ -46,7 +54,9 @@ (setf (@ btn href) "#")) ;; Close image on click (setf (@ (by-id "qsp-image-container") onclick) - (show-image nil)) + show-image) + (setf (@ (get-frame :input) onkeyup) + on-input-key) ;; Close the dropdown on any click (setf (@ window onclick) (lambda (event) @@ -60,7 +70,7 @@ (when loc-name (let ((loc (getprop (root locs) loc-name))) (when loc - (funcall loc args)))))) + (call-loc loc-name args)))))) (defun filename-game (filename) (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2)))) @@ -102,6 +112,11 @@ (when contents (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) +(defun on-input-key (ev) + (when (= 13 (@ ev key-code)) + (chain ev (prevent-default)) + (call-serv-loc "USERCOM"))) + ;;; Function calls (defun init-args (args) @@ -120,16 +135,17 @@ (setf name (chain name (to-upper-case))) (with-frame (with-call-args args - (funcall (getprop (root locs) name) args)))) + (funcall (getprop (root locs) name))))) (defun call-act (title) (with-frame - (funcall (getprop (root acts) title 'act)))) + (funcall (getprop (root acts) title :act)))) ;;; Text windows (defun key-to-id (key) (case key + (:all "qsp") (:main "qsp-main") (:stat "qsp-stat") (:objs "qsp-objs") @@ -160,7 +176,7 @@ (defun add-act (title img act) (setf (getprop (root acts) title) - (create img img act act)) + (create :title title :img img :act act :selected nil)) (update-acts)) (defun del-act (title) @@ -169,7 +185,7 @@ (defun clear-act () (setf (root acts) (create)) - (clear-id "qsp-acts")) + (update-acts)) (defun update-acts () (clear-id "qsp-acts") @@ -178,6 +194,11 @@ (let ((obj (getprop (root acts) title))) (incf (inner-html elt) (make-act-html title (getprop obj :img))))))) +(defun select-act (title) + (loop :for (k v) :of (root acts) + (setf (getprop v :selected) nil)) + (setf (getprop (root acts) title :selected) t) + (call-serv-loc "ONACTSEL")) ;;; "Syntax" @@ -193,9 +214,9 @@ (defun *var (name) ;; From strings to numbers - (setf (@ this indexes) (create)) + (setf (@ this :indexes) (create)) ;; From numbers to {num: 0, str: ""} objects - (setf (@ this values) (list)) + (setf (@ this :values) (list)) (void)) (defun new-value () @@ -205,39 +226,39 @@ (lambda (index) (let ((num-index (if (stringp index) - (if (in index (@ this indexes)) - (getprop (@ this indexes) index) - (let ((n (length (@ this values)))) - (setf (getprop (@ this indexes) index) n) + (if (in index (@ this :indexes)) + (getprop (@ this :indexes) index) + (let ((n (length (@ this :values)))) + (setf (getprop (@ this :indexes) index) n) n)) index))) - (unless (in num-index (@ this values)) - (setf (elt (@ this values) num-index) (new-value))) + (unless (in num-index (@ this :values)) + (setf (elt (@ this :values) num-index) (new-value))) num-index))) (setf (@ *var prototype get) (lambda (index slot) (unless (or index (= 0 index)) - (setf index (1- (length (@ this values))))) - (getprop (@ this values) (chain this (index-num index)) slot))) + (setf index (1- (length (@ this :values))))) + (getprop (@ this :values) (chain this (index-num index)) slot))) (setf (@ *var prototype set) (lambda (index slot value) (unless (or index (= 0 index)) - (setf index (length (@ this values)))) + (setf index (length (@ this :values)))) (case slot (:num (setf value (chain *number (parse-int value)))) (:str (setf value (chain value (to-string))))) - (setf (getprop (@ this values) + (setf (getprop (@ this :values) (chain this (index-num index)) slot) value) (void))) (setf (@ *var prototype kill) (lambda (index) - (setf (elt (@ this values) (chain this (index-num index))) + (setf (elt (@ this :values) (chain this (index-num index))) (new-value)) - (delete (getprop 'this 'indexes index)))) + (delete (getprop 'this :indexes index)))) ;;; Variables @@ -267,17 +288,22 @@ (defun set-var (name index slot value) (chain (ensure-var name) (set index slot value)) + (let ((serv-var (getprop serv-vars name))) + (when serv-var + (funcall (@ serv-var :func) + (get-var name index (@ serv-var :slot)) + index))) (void)) (defun get-array (name) (setf name (chain name (to-upper-case))) - (var-ref name)) + (ensure-var name)) (defun set-array (name value) (setf name (chain name (to-upper-case))) - (let ((store (var-ref name))) - (setf (@ store values) (@ value values)) - (setf (@ store indexes) (@ value indexes))) + (let ((store (ensure-var name))) + (setf (@ store :values) (@ value :values)) + (setf (@ store :indexes) (@ value :indexes))) (void)) (defun kill-var (name &optional index) @@ -288,7 +314,7 @@ (void)) (defun array-size (name) - (@ (var-ref name) values length)) + (@ (var-ref name) :values length)) ;;; Locals @@ -311,11 +337,18 @@ ;;; Objects +(defun select-obj (title img) + (loop :for (k v) :of (root objs) + (setf (getprop v :selected) nil)) + (setf (getprop (root objs) title :selected) t) + (call-serv-loc "ONOBJSEL" title img)) + (defun update-objs () (let ((elt (by-id "qsp-objs"))) (setf (inner-html elt) ""))) ;;; Menu @@ -378,6 +411,17 @@ (setf (@ img src) "") (setf (@ img style display) "hidden"))))) +(defun rgb-string (rgb) + (let ((red (rgb >> 16)) + (green (& (rgb >> 8) 255)) + (blue (& rgb 255))) + (flet ((rgb-to-hex (comp) + (let ((hex (chain (*number comp) (to-string 16)))) + (if (< (length hex) 2) + (+ "0" hex) + hex)))) + (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red))))) + ;;; Saves (defun opengame () @@ -467,3 +511,18 @@ (lambda () (call-serv-loc "COUNTER")) interval))) + +;;; Special variables + +(define-serv-var backimage (:str path) + (setf (@ (get-frame :main) style background-image) path)) + +(define-serv-var bcolor (:num color) + (setf (@ (get-frame :all) style background-color) (rgb-string color))) + +(define-serv-var fcolor (:num color) + (setf (@ (get-frame :all) style color) (rgb-string color))) + +(define-serv-var lcolor (:num color) + (setf (@ (get-frame :style) inner-text) + (+ "a { color: " (rgb-string color) ";}"))) diff --git a/src/intrinsic-macros.lisp b/src/intrinsic-macros.lisp --- a/src/intrinsic-macros.lisp +++ b/src/intrinsic-macros.lisp @@ -155,12 +155,6 @@ ;;; 21local -(defpsmacro local (var &optional expr) - `(progn - (api-call new-local ,(string (second var))) - ,@(when expr - `((set ,var ,expr))))) - ;;; 22for ;;; misc diff --git a/src/intrinsics.ps b/src/intrinsics.ps --- a/src/intrinsics.ps +++ b/src/intrinsics.ps @@ -18,6 +18,7 @@ (setf (root current-location) (chain target (to-upper-case))) (api:stash-state args) (api:call-loc (root current-location) args) + (api:call-serv-loc "ONNEWLOC") (void)) ;;; 2var @@ -142,7 +143,6 @@ (api:get-text :main) (void)) -;; For clarity (it leaves a lib.desc() call in JS) (defun desc (s) "") @@ -193,24 +193,31 @@ ;;; 15objs -(defun addobj (name) - (chain (root objs) (push name)) +(defun addobj (name img) + (setf img (or img "")) + (setf (getprop (root objs) name) + (create :name name :img img :selected nil)) (api:update-objs) + (api-call call-serv-loc "ONOBJADD" name img) (void)) (defun delobj (name) - (let ((index (chain (root objs) (index-of name)))) - (when (> index -1) - (killobj (1+ index)))) + (delete (getprop (root objs) name)) + (api-call call-serv-loc "ONOBJDEL" name) (void)) (defun killobj (&optional (num nil)) (if (eq nil num) - (setf (root objs) (list)) - (chain (root objs) (splice (1- num) 1))) + (setf (root objs) (create)) + (delobj (elt (chain *object (keys (root objs))) num))) (api:update-objs) (void)) +(defun selobj () + (loop :for (k v) :of (root objs) + :do (when (@ v :selected) + (return-from selobj (@ v :name))))) + ;;; 16menu (defun menu (menu-name) @@ -286,12 +293,9 @@ ;;; misc (defun rgb (red green blue) - (flet ((rgb-to-hex (comp) - (let ((hex (chain (*number comp) (to-string 16)))) - (if (< (length hex) 2) - (+ "0" hex) - hex)))) - (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red)))) + (+ (<< red 16) + (<< green 8) + blue)) (defun openqst (name) (api-call run-game name)) diff --git a/src/js-syms.lisp b/src/js-syms.lisp --- a/src/js-syms.lisp +++ b/src/js-syms.lisp @@ -12,7 +12,7 @@ (syms ;; main window - *object + *object assign now onload keys includes diff --git a/src/main.ps b/src/main.ps --- a/src/main.ps +++ b/src/main.ps @@ -7,7 +7,7 @@ ;; Variables vars (create) ;; Inventory (objects) - objs (list) + objs (create) current-location nil ;; Game time started-at (chain *date (now)) diff --git a/src/ps-macros.lisp b/src/ps-macros.lisp --- a/src/ps-macros.lisp +++ b/src/ps-macros.lisp @@ -40,7 +40,7 @@ (defpsmacro location ((name) &body body) (declare (ignore name)) "Name is used by the game macro above" - `(async-lambda (args) + `(async-lambda () (label-block () ,@body))) @@ -125,6 +125,9 @@ (getprop _labels ,(first rest-labels)))))))))) (funcall (getprop _labels "_nil")))))) +(defpsmacro exit () + '(return-from nil (values))) + ;;; 10dynamic (defpsmacro qspblock (&body body) @@ -160,6 +163,12 @@ ;;; 21local +(defpsmacro local (var &optional expr) + `(progn + (api-call new-local ,(string (second var))) + ,@(when expr + `((set ,var ,expr))))) + ;;; 22for (defpsmacro qspfor (var from to step &body body) diff --git a/sugar-qsp.asd b/sugar-qsp.asd --- a/sugar-qsp.asd +++ b/sugar-qsp.asd @@ -13,7 +13,6 @@ (:file "main-macros") (:file "ps-macros") (:file "api-macros") - (:file "intrinsic-macros") (:file "class") (:file "main") (:file "parser")))