Special variables and locations

TODO

@@ -1,6 +1,7 b''
 
 * Special locations
 * Special variables
+* IMG
 * CLI build for Linux
 * CLI build for Windows
 

extras/body.html

@@ -21,3 +21,6 b''
 <div id="qsp-image-container" class="center-on-screen">
   <img id="qsp-image">
 </div>
+
+<style id="qsp-style">
+</style>

extras/default.css

@@ -35,6 +35,9 b''
 
 #qsp-main {
     flex: 6 6 60px;
+    background-repeat: no-repeat;
+    background-position: right top;
+    background-attachment: fixed;
 }
 
 #qsp-acts {

src/api-macros.lisp

@@ -14,8 +14,11 b''
           ,@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 b''
                                  (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))))

src/api.ps

@@ -9,17 +9,25 b''
 ;;; Utils
 
 (defun make-act-html (title img)
-  (+ "<a class='qsp-act' href='" (inline-call call-act title) "'>"
+  (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-menu-item-html (num title img loc)
-  (+ "<a href='" (inline-call finish-menu loc) "'>"
+  (+ "<a href='" (href-call finish-menu loc) "'>"
      (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
+(defun make-obj (title img selected)
+  (+ "<li>"
+     "<a href='" (href-call select-obj title img) "'"
+        "class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
+     (if img (+ "<img src='" img "'>") "")
+     obj
+     "</a>"))
+
 (defun make-menu-delimiter ()
   "<hr>")
 
@@ -46,7 +54,9 b''
     (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 b''
     (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 b''
   (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 b''
   (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 b''
 
 (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 b''
 
 (defun clear-act ()
   (setf (root acts) (create))
-  (clear-id "qsp-acts"))
+  (update-acts))
 
 (defun update-acts ()
   (clear-id "qsp-acts")
@@ -178,6 +194,11 b''
             (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 b''
 
 (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 b''
       (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 b''
 
 (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 b''
   (void))
 
 (defun array-size (name)
-  (@ (var-ref name) values length))
+  (@ (var-ref name) :values length))
 
 ;;; Locals
 
@@ -311,11 +337,18 b''
 
 ;;; 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) "<ul>")
     (loop :for obj :in (root objs)
-       :do (incf (inner-html elt) (+ "<li>" obj)))
+       :do (incf (inner-html elt)
+                 (make-obj obj)))
     (incf (inner-html elt) "</ul>")))
 
 ;;; Menu
@@ -378,6 +411,17 b''
            (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 b''
          (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) ";}")))

src/intrinsic-macros.lisp

@@ -155,12 +155,6 b''
 
 ;;; 21local
 
-(defpsmacro local (var &optional expr)
-  `(progn
-     (api-call new-local ,(string (second var)))
-     ,@(when expr
-         `((set ,var ,expr)))))
-
 ;;; 22for
 
 ;;; misc

src/intrinsics.ps

@@ -18,6 +18,7 b''
   (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 b''
   (api:get-text :main)
   (void))
 
-;; For clarity (it leaves a lib.desc() call in JS)
 (defun desc (s)
   "")
 
@@ -193,24 +193,31 b''
 
 ;;; 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 b''
 ;;; 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))

src/js-syms.lisp

@@ -12,7 +12,7 b''
 (syms
  ;; main
  window
- *object
+ *object assign
  now
  onload
  keys includes

src/main.ps

@@ -7,7 +7,7 b''
        ;; Variables
        vars (create)
        ;; Inventory (objects)
-       objs (list)
+       objs (create)
        current-location nil
        ;; Game time
        started-at (chain *date (now))

src/ps-macros.lisp

@@ -40,7 +40,7 b''
 (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 b''
                                            (getprop _labels ,(first rest-labels))))))))))
            (funcall (getprop _labels "_nil"))))))
 
+(defpsmacro exit ()
+  '(return-from nil (values)))
+
 ;;; 10dynamic
 
 (defpsmacro qspblock (&body body)
@@ -160,6 +163,12 b''
 
 ;;; 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)

sugar-qsp.asd

@@ -13,7 +13,6 b''
                (:file "main-macros")
                (:file "ps-macros")
                (:file "api-macros")
-               (:file "intrinsic-macros")
                (:file "class")
                (:file "main")
                (:file "parser")))