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) "")
(loop :for obj :in (root objs)
- :do (incf (inner-html elt) (+ "- " obj)))
+ :do (incf (inner-html elt)
+ (make-obj obj)))
(incf (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")))