Special variables and locations

TODO

@@ -1,16 +1,17 b''
 
 * Special locations
 * Special variables
+* IMG
 * CLI build for Linux
 * CLI build for Windows
 
 * Reporting error lines in the parser
 * Report duplicate label (in the parser)
 * reporting error lines at runtime (by storing them in every form in the parser
 * Report JUMP with missing label (in tagbody)
 
 * Build Istreblenie
 * Build Цветохимия
 * Windows GUI (for the compiler)
 * Save-load game in slots
 * Resizable frames

extras/body.html

@@ -1,23 +1,26 b''
 
 <div id="qsp">
   <div class="qsp-col qsp-col1">
     <div id="qsp-main" class="qsp-frame">&nbsp;</div>
     <div id="qsp-acts" class="qsp-frame">&nbsp;</div>
     <input id="qsp-input" class="qsp-frame">
   </div>
   <div class="qsp-col qsp-col2">
     <div id="qsp-stat" class="qsp-frame">&nbsp;</div>
     <div id="qsp-objs" class="qsp-frame">&nbsp;</div>
   </div>
   <div class="qsp-col qsp-col3">
     <a id="qsp-btn-save"><img></a>
     <a id="qsp-btn-open"><img></a>
   </div>
 </div>
 
 <div id="qsp-dropdown">
 </div>
 
 <div id="qsp-image-container" class="center-on-screen">
   <img id="qsp-image">
 </div>
+
+<style id="qsp-style">
+</style>

extras/default.css

@@ -1,129 +1,132 b''
 
 .qsp-frame {
     border: 1px solid black;
     overflow: auto;
     padding: 5px;
     box-sizing: border-box;
 }
 
 #qsp {
     position: absolute;
     display: flex;
     flex-flow: row;
     top: 0;
     left: 0;
     width: 100%;
     height: 100%;
 }
 
 .qsp-col {
     display: flex;
     flex-flow: column;
 }
 
 .qsp-col1 {
     flex: 7 7 70px;
 }
 
 .qsp-col2 {
     flex: 3 3 30px;
 }
 
 .qsp-col3 {
     flex: 0 0 40px;
 }
 
 #qsp-main {
     flex: 6 6 60px;
+    background-repeat: no-repeat;
+    background-position: right top;
+    background-attachment: fixed;
 }
 
 #qsp-acts {
     flex: 4 4 40px;
 }
 
 #qsp-input {
 }
 
 #qsp-stat {
     flex: 5 5 50px;
 }
 
 #qsp-objs {
     flex: 5 5 50px;
 }
 
 .qsp-act {
     display: block;
     padding: 2px;
     font-size: large;
 }
 
 .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;
 }
 
 #qsp-dropdown a {
   color: black;
   padding: 12px 16px;
   text-decoration: none;
   display: block;
 }
 
 #qsp-dropdown a:hover {
     background-color: #ddd;
 }
 
 /* Buttons */
 
 .qsp-col3 a, .qsp-col3 img {
     width: 50px;
     height: 50px;
 }
 
 #qsp-btn-save img {
     background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACSklEQVRoge3ZPWgUQRjG8V/iRRFU/GoEQdSohSgWWqQSooVgK9iJFiKCnYV2BkFQsBRBQQwWVsHKIoWxEOzEwmhhogbRMhhFicTvYm+JCUlmZzabRLN/OPaWeZ+ZeW7feXf2lpqampqamnRaImKP4hA2VjCP27hbpoNGwbib2IPreB+IPYY7M7SvxWYM4QNO4QqWyQxVRgdeYnnB+K5A+wUcbB7z+O14hxPx08toLRDTgfv4mjrIJFrwwMS0HsABXMTxlE6LpNYqfE7pPJIBdOKhLM1uxIiLrpG5YtC4GSLMVGGkLdD+GpfxAuvxaVL7oCzN+jCG7iKDVmHkKS5hSSBuJ3bg6hRt+Zrpa553z8bEuoQrUVXk1exwKLBI1ZpPBnAL+0KBqanVim1Ykaifji+yNfIrVphipB1n8BgjCfqZ2IrTuIZXMcIUIydxFj8TtEW4JysW52JEKWtkVHUm4EdzjChSrkgLlmJXghb6m8ep9MN4K25XjvTF3sCaElrT6McS+0w2Mirb+JWhrH4CC/0+UpjUK7Ia5/86f4IeHMHeEvPJ+4km1chHE43k9KROpCyLPrViym8/vjW/b5Jt3acjL7/RzEX5bRg3sjKg+2fK7/PmZ9aZzdTqxwYzp06IBZFaDeHUCbFgUquy1Anx35TfRWXkd+WzCBOcQxEjQ7JH0PmiHW9CQUWM9Mr+Y+osO6ME8nF7Q4FFn8T2y14VDMt2vsFfqCRbZBvTdbLXFI9CgphHyjbsVu4+EcMInuH7HI1XU1NTU7OI+QMFe2N82rtssgAAAABJRU5ErkJggg==');
 }
 
 #qsp-btn-open img {
     background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACCklEQVRoge3Yz6sNYRzH8deVexNxSaEoroWFUuomOceSPVnIwsbSxs6Psrgphf9AsrZR7kJWsroUlrZKKZRSl4USGouZk9Npzp1n5pm5x4/nXdNzpvP9Pp/v95nv82OGRCKRSCQS/w8zuIn3yGpe37CEQ6sedQk38BA7G/jO4BQ+YEebQZUxVfH/OxzGVSxX2D4o2mO4jmt4jpNFe6d5mPFkRbvQ0H9h6OqUtR33/xXr0celGn4/sYjXoQ5dJ3ILB7AOW2r4bcIj7GsrkEFpXWyrwwbaf15nXWqv6SqK1abuHDmPjV0EMobhBWIZt8cZVu0j2ZDNHF7gblRozdiO49g1zqDOEzmKJ7gcGVQTzmLDSgZ1Eunh2dD9aewpsXtctH3cwzn5ALysoVWlXZvhleMV5ovfU8J363mciAliRLsRg0Q244vfT3A/zgT2cQHbImIY1S4ldPk9Ii+NH8V9H08DfbfiY6BtiHYpoYmMBr4bbwN9YzfVoEELnew9+blpwBv5u0oI9wPtQrUbkWFaXqOzsZ01IFg7pLQOyp/A58igmhCsHZJInYndNsHa/0wiVWTy9/a5NjprQGvag0Qmwd462iGltdQ8lihqlVVIIn/9/CAvrajDWgTRB8VhMt1/aSljVr4RToc6hJTWioe1jujJD4rfQx2qRvuTyX1JuTIh3UQikUgkEhPnF+1xZ9hHnLjAAAAAAElFTkSuQmCC');
 }
 
 .center-on-screen {
     position: absolute;
     top: 0;
     left: 0;
     height: 100%;
     width: 100%;
     pointer-events: none;
     display: flex;
     justify-content: center;
     align-items: center;
 }
 
 .center-on-screen > * {
     pointer-events: auto;
 }
 
 #qsp-image-container {
     display: none;
 }
 
 /* misc */
 
 .disable a {
   pointer-events: none;
   cursor: default;
 }

src/api-macros.lisp

@@ -1,34 +1,46 b''
 
 (in-package sugar-qsp.api)
 
 (defpsmacro with-call-args (args &body body)
   `(progn
      (init-args ,args)
      ,@body
      (get-result)))
 
 (defpsmacro with-frame (&body body)
   `(progn
      (push-local-frame)
      (unwind-protect
           ,@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)
              :collect "\", \""
              :collect arg)
       "\");"))
 
 (defpsmacro with-sleep ((resume-func) &body body)
   `(new (*promise
          (lambda (resolve)
            (start-sleeping)
            (let ((,resume-func (lambda ()
                                  (finish-sleeping)
                                  (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

@@ -1,469 +1,528 b''
 
 (in-package sugar-qsp.api)
 
 ;;; API deals with DOM manipulation and some bookkeeping for the
 ;;; intrinsics, namely variables
 ;;; API is an implementation detail and has no QSP documentation. It
 ;;; doesn't call intrinsics
 
 ;;; 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>")
 
 (defun report-error (text)
   (alert text))
 
 (defun start-sleeping ()
   (chain (by-id "qsp") class-list (add "disable")))
 
 (defun finish-sleeping ()
   (chain (by-id "qsp") class-list (remove "disable")))
 
 (defun sleep (msec)
   (with-sleep (resume)
     (set-timeout resume msec)))
 
 (defun init-dom ()
   ;; Save/load buttons
   (let ((btn (by-id "qsp-btn-save")))
     (setf (@ btn onclick) savegame)
     (setf (@ btn href) "#"))
   (let ((btn (by-id "qsp-btn-open")))
     (setf (@ btn onclick) opengame)
     (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)
           (setf (@ window mouse)
                 (list (@ event page-x)
                       (@ event page-y)))
           (finish-menu nil))))
 
 (defun call-serv-loc (var-name &rest args)
   (let ((loc-name (get-var var-name 0 :str)))
     (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))))
   (getprop (root games) game-name))
 
 (defun run-game (name)
   (let ((game (filename-game name)))
     (setf (root main-game) name)
     ;; Replace locations with the new game's 
     (setf (root locs) game)
     (funcall (getprop game
                       (chain *object (keys game) 0))
              (list))))
 
 ;;; Misc
 
 (defun newline (key)
   (append-id (key-to-id key) "<br>" t))
 
 (defun clear-id (id)
   (setf (inner-html (by-id id)) ""))
 
 (defvar text-escaper (chain document (create-element :textarea)))
 
 (defun prepare-contents (s &optional force-html)
   (if (or force-html (get-var "USEHTML" 0 :num))
       s
       (progn
         (setf (@ text-escaper text-content) s)
         (inner-html text-escaper))))
 
 (defun get-id (id &optional force-html)
   (inner-html (by-id id)))
 
 (defun set-id (id contents &optional force-html)
   (setf (inner-html (by-id id)) (prepare-contents contents force-html)))
 
 (defun append-id (id contents &optional force-html)
   (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)
   (dotimes (i (length args))
     (let ((arg (elt args i)))
       (if (numberp arg)
           (set-var args i :num arg)
           (set-var args i :str arg)))))
 
 (defun get-result ()
   (if (not (equal "" (get-var "RESULT" 0 :str)))
       (get-var "RESULT" 0 :str)
       (get-var "RESULT" 0 :num)))
 
 (defun call-loc (name args)
   (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")
     (:acts "qsp-acts")
     (:input "qsp-input")
     (:image "qsp-image")
     (:dropdown "qsp-dropdown")
     (t (report-error "Internal error!"))))
 
 (defun get-frame (key)
   (by-id (key-to-id key)))
 
 (defun add-text (key text)
   (append-id (key-to-id key) text))
 
 (defun get-text (key)
   (get-id (key-to-id key)))
 
 (defun clear-text (key)
   (clear-id (key-to-id key)))
 
 (defun enable-frame (key enable)
   (let ((obj (get-frame key)))
     (setf (@ obj style display) (if enable "block" "none"))
     (void)))
 
 ;;; Actions
 
 (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)
   (delete (getprop (root acts) title))
   (update-acts))
 
 (defun clear-act ()
   (setf (root acts) (create))
-  (clear-id "qsp-acts"))
+  (update-acts))
 
 (defun update-acts ()
   (clear-id "qsp-acts")
   (let ((elt (by-id "qsp-acts")))
     (for-in (title (root acts))
             (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"
 
 (defun qspfor (name index from to step body)
   (for ((i from))
        ((< i to))
        ((incf i step))
        (set-var name index :num i)
        (unless (funcall body)
          (return-from qspfor))))
 
 ;;; Variable class
 
 (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 ()
   (create :num 0 :str ""))
 
 (setf (@ *var prototype index-num)
       (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
 
 (defun var-real-name (name)
   (if (= (@ name 0) #\$)
       (values (chain name (substr 1)) :str)
       (values name :num)))
 
 (defun ensure-var (name)
   (setf name (chain name (to-upper-case)))
   (let ((store (var-ref name)))
     (unless store
       (setf store (new (*var name)))
       (setf (getprop (root vars) name) store))
     store))
 
 (defun var-ref (name)
   (let ((local-store (current-local-frame)))
     (cond ((and local-store (in name local-store))
            (getprop local-store name))
           ((in name (root vars))
            (getprop (root vars) name))
           (t nil))))
 
 (defun get-var (name index slot)
   (chain (ensure-var name) (get index slot)))
 
 (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)
   (setf name (chain name (to-upper-case)))
   (if (and index (not (= 0 index))) 
       (chain (getprop (root vars) name) (kill index))
       (delete (getprop (root vars) name)))
   (void))
 
 (defun array-size (name)
-  (@ (var-ref name) values length))
+  (@ (var-ref name) :values length))
 
 ;;; Locals
 
 (defun push-local-frame ()
   (chain (root locals) (push (create)))
   (void))
 
 (defun pop-local-frame ()
   (chain (root locals) (pop))
   (void))
 
 (defun current-local-frame ()
   (elt (root locals) (1- (length (root locals)))))
 
 (defun new-local (name)
   (let ((frame (current-local-frame)))
     (unless (in name frame)
       (setf (getprop frame name) (create)))
     (void)))
 
 ;;; 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
 
 (defun open-menu (menu-data)
   (let ((elt (get-frame :dropdown))
         (i 0))
     (loop :for item :in menu-data
        :do (incf i)
        :do (incf (inner-html elt)
                  (if (eq item :delimiter)
                      (make-menu-delimiter i)
                      (make-menu-item-html i
                                           (@ item :text)
                                           (@ item :icon)
                                           (@ item :loc)))))
     (let ((mouse (@ window mouse)))
       (setf (@ elt style left) (+ (elt mouse 0) "px"))
       (setf (@ elt style top) (+ (elt mouse 1) "px"))
       ;; Make sure it's inside the viewport
       (when (> (@ document body inner-width)
                (+ (elt mouse 0) (@ elt inner-width)))
         (incf (@ elt style left) (@ elt inner-width)))
       (when (> (@ document body inner-height)
                (+ (elt mouse 0) (@ elt inner-height)))
         (incf (@ elt style top) (@ elt inner-height))))
     (setf (@ elt style display) "block")))
 
 (defun finish-menu (loc)
   (when (root menu-resume)
     (let ((elt (get-frame :dropdown)))
       (setf (inner-html elt) "")
       (setf (@ elt style display) "none")
       (funcall (root menu-resume))
       (setf (root menu-resume) nil))
     (when loc
       (call-loc loc)))
   (void))
 
 (defun menu (menu-data)
   (with-sleep (resume)
     (open-menu menu-data)
     (setf (root menu-resume) resume))
   (void))
 
 ;;; Content
 
 (defun clean-audio ()
   (loop :for k :in (chain *object (keys (root playing)))
      :for v := (getprop (root playing) k)
      :do (when (@ v ended)
            (delete (@ (root playing) k)))))
 
 (defun show-image (path)
   (let ((img (get-frame :image)))
     (cond (path
            (setf (@ img src) path)
            (setf (@ img style display) "flex"))
           (t
            (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 ()
   (let ((element (chain document (create-element :input))))
     (chain element (set-attribute :type :file))
     (chain element (set-attribute :id :qsp-opengame))
     (chain element (set-attribute :tabindex -1))
     (chain 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 (@ event target files 0))
                    (reader (new (*file-reader))))
               (setf (@ reader onload)
                     (lambda (ev)
                       (block nil
                         (let ((target (@ ev current-target)))
                           (unless (@ target result)
                             (return))
                           (base64-to-state (@ target result))
                           (unstash-state)))))
               (chain reader (read-as-text file)))))
     (chain document body (append-child element))
     (chain element (click))
     (chain document body (remove-child element))))
 
 (defun savegame ()
   (let ((element (chain document (create-element :a))))
     (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64))))
     (chain element (set-attribute :download "savegame.sav"))
     (setf (@ element style display) :none)
     (chain document body (append-child element))
     (chain element (click))
     (chain document body (remove-child element))))
 
 (defun stash-state (args)
   (call-serv-loc "ONGSAVE")
   (setf (root state-stash)
         (chain *j-s-o-n (stringify
                          (create :vars (root vars)
                                  :objs (root objs)
                                  :loc-args args
                                  :msecs (- (chain *date (now)) (root started-at))
                                  :timer-interval (root timer-interval)
                                  :main-html (inner-html
                                              (get-frame :main))
                                  :stat-html (inner-html
                                              (get-frame :stat))
                                  :next-location (root current-location)))))
   (void))
 
 (defun unstash-state ()
   (let ((data (chain *j-s-o-n (parse (root state-stash)))))
     (clear-act)
     (setf (root vars) (@ data :vars))
     (loop :for k :in (chain *object (keys (root vars)))
        :do (chain *object (set-prototype-of (getprop (root vars) k)
                                             (@ *var prototype))))
     (setf (root started-at) (- (chain *date (now)) (@ data :msecs)))
     (setf (root objs) (@ data :objs))
     (setf (root current-location) (@ data :next-location))
     (setf (inner-html (get-frame :main))
           (@ data :main-html))
     (setf (inner-html (get-frame :stat))
           (@ data :stat-html))
     (update-objs)
     (set-timer (@ data :timer-interval))
     (call-serv-loc "ONGLOAD")
     (call-loc (root current-location) (@ data :loc-args))
     (void)))
 
 (defun state-to-base64 ()
   (btoa (encode-u-r-i-component (root state-stash))))
 
 (defun base64-to-state (data)
   (setf (root state-stash) (decode-u-r-i-component (atob data))))
 
 ;;; Timers
 
 (defun set-timer (interval)
   (setf (root timer-interval) interval)
   (clear-interval (root timer-obj))
   (setf (root timer-obj)
         (set-interval
          (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

@@ -1,174 +1,168 b''
 
 (in-package sugar-qsp.lib)
 
 ;;;; Macros implementing some intrinsics where it makes sense
 ;;;; E.g. an equivalent JS function exists, or it's a direct API call
 
 ;;; 1loc
 
 ;;; 2var
 
 (defpsmacro killvar (varname &optional index)
   `(api-call kill-var ,varname ,index))
 
 (defpsmacro killall ()
   `(api-call kill-all))
 
 ;;; 3expr
 
 (defpsmacro obj (name)
   `(funcall (root objs includes) ,name))
 
 (defpsmacro loc (name)
   `(funcall (root locs includes) ,name))
 
 (defpsmacro no (arg)
   `(- -1 ,arg))
 
 ;;; 4code
 
 (defpsmacro qspver ()
   "0.0.1")
 
 (defpsmacro curloc ()
   `(root current-location))
 
 (defpsmacro rnd ()
   `(funcall rand 1 1000))
 
 (defpsmacro qspmax (&rest args)
   (if (= 1 (length args))
       `(*math.max.apply nil ,@args)
       `(*math.max ,@args)))
 
 (defpsmacro qspmin (&rest args)
   (if (= 1 (length args))
       `(*math.min.apply nil ,@args)
       `(*math.min ,@args)))
 
 ;;; 5arrays
 
 (defpsmacro arrsize (name)
   `(api-call array-size ,name))
 
 ;;; 6str
 
 (defpsmacro len (s)
   `(length ,s))
 
 (defpsmacro mid (s from &optional count)
   `(chain ,s (substring ,from ,count)))
 
 (defpsmacro ucase (s)
   `(chain ,s (to-upper-case)))
 
 (defpsmacro lcase (s)
   `(chain ,s (to-lower-case)))
 
 (defpsmacro trim (s)
   `(chain ,s (trim)))
 
 (defpsmacro replace (s from to)
   `(chain ,s (replace ,from ,to)))
 
 (defpsmacro val (s)
   `(parse-int ,s 10))
 
 (defpsmacro qspstr (n)
   `(chain ,n (to-string)))
 
 ;;; 7if
 
 ;;; 8sub
 
 ;;; 9loops
 
 ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge)
 
 (defpsmacro exit ()
   `(return-from nil (values)))
 
 ;;; 10dynamic
 
 ;;; 11main
 
 (defpsmacro desc (s)
   (declare (ignore s))
   "")
 
 ;;; 12stat
 
 (defpsmacro showstat (enable)
   `(api-call enable-frame :stat ,enable))
 
 ;;; 13diag
 
 (defpsmacro msg (text)
   `(alert ,text))
 
 ;;; 14act
 
 (defpsmacro showacts (enable)
   `(api-call enable-frame :acts ,enable))
 
 (defpsmacro delact (name)
   `(api-call del-act ,name))
 
 (defpsmacro cla ()
   `(api-call clear-act))
 
 ;;; 15objs
 
 (defpsmacro showobjs (enable)
   `(api-call enable-frame :objs ,enable))
 
 (defpsmacro countobj ()
   `(length (root objs)))
 
 (defpsmacro getobj (index)
   `(or (elt (root objs) ,index) ""))
 
 ;;; 16menu
 
 ;;; 17sound
 
 (defpsmacro isplay (filename)
   `(funcall (root playing includes) ,filename))
 
 ;;; 18img
 
 (defpsmacro view (&optional path)
   `(api-call show-image ,path))
 
 ;;; 19input
 
 (defpsmacro showinput (enable)
   `(api-call enable-frame :input ,enable))
 
 ;;; 20time
 
 (defpsmacro wait (msec)
   `(await (api-call sleep ,msec)))
 
 (defpsmacro settimer (interval)
   `(api-call set-timer ,interval))
 
 ;;; 21local
 
-(defpsmacro local (var &optional expr)
-  `(progn
-     (api-call new-local ,(string (second var)))
-     ,@(when expr
-         `((set ,var ,expr)))))
-
 ;;; 22for
 
 ;;; misc
 
 (defpsmacro opengame (&optional filename)
   (declare (ignore filename))
   `(api-call opengame))
 
 (defpsmacro savegame (&optional filename)
   (declare (ignore filename))
   `(api-call savegame))

src/intrinsics.ps

@@ -1,310 +1,314 b''
 
 (in-package sugar-qsp.lib)
 
 ;;;; Functions and procedures defined by the QSP language.
 ;;;; They can call api and deal with locations and other data directly.
 ;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls.
 
 ;;; 1loc
 
 (defun goto (target args)
   (api:clear-text :main)
   (funcall xgoto target args)
   (void))
 
 (defun xgoto (target args)
   (setf args (or args (list)))
   (api:clear-act)
   (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
 
 ;;; 3expr
 
 ;;; 4code
 
 (defun rand (a &optional (b 1))
   (let ((min (min a b))
         (max (max a b)))
     (+ min (chain *math (random (- max min))))))
 
 ;;; 5arrays
 
 (defun copyarr (to from start count)
   (multiple-value-bind (to-name to-slot)
       (api:var-real-name to)
     (multiple-value-bind (from-name from-slot)
         (api:var-real-name from)
       (for ((i start))
            ((< i (min (api:array-size from-name)
                       (+ start count))))
            ((incf i))
            (api:set-var to-name (+ start i) to-slot
                         (api:get-var from-name (+ start i) from-slot))))))
 
 (defun arrpos (name value &optional (start 0))
   (multiple-value-bind (real-name slot)
       (api:var-real-name name)
     (for ((i start)) ((< i (api:array-size name))) ((incf i))
          (when (eq (api:get-var real-name i slot) value)
            (return-from arrpos i))))
   -1)
 
 (defun arrcomp (name pattern &optional (start 0))
   (multiple-value-bind (real-name slot)
       (api:var-real-name name)
     (for ((i start)) ((< i (api:array-size name))) ((incf i))
          (when (funcall (getprop (api:get-var real-name i slot) 'match) pattern)
            (return-from arrcomp i))))
   -1)
 
 ;;; 6str
 
 (defun instr (s subs &optional (start 1))
   (+ start (chain s (substring (- start 1)) (search subs))))
 
 (defun isnum (s)
   (if (is-na-n s)
       0
       -1))
 
 (defun strcomp (s pattern)
   (if (chain s (match pattern))
       -1
       0))
 
 (defun strfind (s pattern group)
   (let* ((re (new (*reg-exp pattern)))
          (match (chain re (exec s))))
     (chain match (group group))))
 
 (defun strpos (s pattern &optional (group 0))
   (let* ((re (new (*reg-exp pattern)))
          (match (chain re (exec s)))
          (found (chain match (group group))))
     (if found
         (chain s (search found))
         0)))
 
 ;;; 7if
 
 ;; Has to be a function because it always evaluates all three of its
 ;; arguments
 (defun iif (cond-expr then-expr else-expr)
   (if cond-expr then-expr else-expr))
 
 ;;; 8sub
 
 (defun gosub (target &rest args)
   (api:call-loc target args)
   (void))
 
 (defun func (target &rest args)
   (api:call-loc target args))
 
 ;;; 9loops
 
 ;;; 10dynamic
 
 (defun dynamic (block &rest args)
   (when (stringp block)
     (api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC."))
   (api:with-call-args args
     (funcall block args))
   (void))
 
 (defun dyneval (block &rest args)
   (when (stringp block)
     (api:report-error "DYNEVAL can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL."))
   (api:with-call-args args
     (funcall block args)))
 
 ;;; 11main
 
 (defun main-p (s)
   (api:add-text :main s)
   (void))
 
 (defun main-pl (s)
   (api:add-text :main s)
   (api:newline :main)
   (void))
 
 (defun main-nl (s)
   (api:newline :main)
   (api:add-text :main s)
   (void))
 
 (defun maintxt (s)
   (api:get-text :main)
   (void))
 
-;; For clarity (it leaves a lib.desc() call in JS)
 (defun desc (s)
   "")
 
 (defun main-clear ()
   (api:clear-text :main)
   (void))
 
 ;;; 12stat
 
 (defun stat-p (s)
   (api:add-text :stat s)
   (void))
 
 (defun stat-pl (s)
   (api:add-text :stat s)
   (api:newline :stat)
   (void))
 
 (defun stat-nl (s)
   (api:newline :stat)
   (api:add-text :stat s)
   (void))
 
 (defun stattxt (s)
   (api:get-text :stat)
   (void))
 
 (defun stat-clear ()
   (api:clear-text :stat)
   (void))
 
 (defun cls ()
   (stat-clear)
   (main-clear)
   (cla)
   (cmdclear)
   (void))
 
 ;;; 13diag
 
 ;;; 14act
 
 (defun curacts ()
   (let ((acts (root acts)))
     (lambda ()
       (setf (root acts) acts)
       (void))))
 
 ;;; 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)
   (let ((menu-data (list)))
     (loop :for item-obj :in (@ (api:get-array (api:var-real-name menu-name)) values)
        :for item := (@ item-obj :str)
        :do (cond ((string= item "")
                   (break))
                  ((string= item "-:-")
                   (chain menu-data (push :delimiter)))
                  (t
                   (let* ((tokens (chain item (split ":"))))
                     (when (= (length tokens) 2)
                       (chain tokens (push "")))
                     (let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":")))
                            (loc (getprop tokens (- (length tokens) 2)))
                            (icon (getprop tokens (- (length tokens) 1))))
                       (chain menu-data
                              (push (create :text text
                                            :loc loc
                                            :icon icon))))))))
     (api:menu menu-data)
     (void)))
 
 ;;; 17sound
 
 (defun play (filename &optional (volume 100))
   (let ((audio (new (*audio filename))))
     (setf (getprop (root playing) filename) audio)
     (setf (@ audio volume) (* volume 0.01))
     (chain audio (play))))
 
 (defun close (filename)
   (funcall (root playing filename) stop)
   (delete (root playing filename))
   (void))
 
 (defun closeall ()
   (loop :for k :in (chain *object (keys (root playing)))
      :for v := (getprop (root playing) k)
      :do (funcall v stop))
   (setf (root playing) (create)))
 
 ;;; 18img
 
 (defun refint ()
   ;; "Force interface update" Uh... what exactly do we do here?
   (api:report-error "REFINT is not supported")
   )
 
 ;;; 19input
 
 (defun usertxt ()
   (let ((input (by-id "qsp-input")))
     (@ input value)))
 
 (defun cmdclear ()
   (let ((input (by-id "qsp-input")))
     (setf (@ input value) "")))
 
 (defun input (text)
   (chain window (prompt text)))
 
 ;;; 20time
 
 (defun msecscount ()
   (- (chain *date (now)) (root started-at)))
 
 ;;; 21local
 
 ;;; 22for
 
 ;;; 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))
 
 (defun addqst (name)
   (let ((game (api-call filename-game name)))
     ;; Add the game's locations
     (chain *object (assign (root locs)
                            (getprop (root games) name)))))
 
 (defun killqst ()
   ;; Delete all locations not from the current main game
   (loop :for (k v) :in (root games)
      :do (unless (string= k (root main-game))
            (delete (getprop (root locs) k)))))
 

src/js-syms.lisp

@@ -1,41 +1,41 b''
 
 (in-package sugar-qsp.js)
 
 ;;; Contains symbols from standard JS library to avoid obfuscating
 ;;; and/or namespacing them
 
 (cl:defmacro syms (cl:&rest syms)
   `(cl:progn
      ,@(cl:loop :for sym :in syms
           :collect `(cl:export ',sym))))
 
 (syms
  ;; main
  window
- *object
+ *object assign
  now
  onload
  keys includes
  has-own-property
  ;; api
  document get-element-by-id
  onclick onchange
  atob btoa split
  alert prompt
  set-timeout set-interval clear-interval
  *promise *j-s-o-n
  href parse match
  set-prototype-of
  body append-child remove-child
  add ; remove (is already in COMMON-LISP)
  create-element set-attribute class-list
  *file-reader read-as-text
  style display src
  page-x page-y
  top left
  ;; lib
  *number parse-int
  to-string to-upper-case concat
  click target current-target files index-of result
  decode-u-r-i-component splice
  )

src/main.ps

@@ -1,51 +1,51 b''
 
 (in-package sugar-qsp.main)
 
 (setf (root)
       (create
        ;;; Game session state (saved in savegames)
        ;; Variables
        vars (create)
        ;; Inventory (objects)
-       objs (list)
+       objs (create)
        current-location nil
        ;; Game time
        started-at (chain *date (now))
        ;; Timers
        timer-interval 500
        timer-obj nil
        ;; Games
        loaded-games (list)
 
        ;;; Transient state
        ;; ACTions
        acts (create)
        ;; Savegame data
        state-stash (create)
        ;; List of audio files being played
        playing (create)
        ;; Local variables stack (starts with an empty frame)
        locals (list)
 
        ;;; Game data
        ;; Games (filename -> [locations])
        games (list)
        ;; The main (non library) game. Updated by openqst
        main-game nil
        ;; Active locations
        locs (create)))
 
 ;; Launch the game from the first location
 (setf (@ window onload)
       (lambda ()
         (#.(intern "INIT-DOM" "SUGAR-QSP.API"))
         ;; For MSECCOUNT
         (setf (root started-at) (chain *date (now)))
         ;; For $COUNTER and SETTIMER
         (#.(intern "SET-TIMER" "SUGAR-QSP.API")
            (root timer-interval))
         ;; Start the first game
         (#.(intern "RUN-GAME" "SUGAR-QSP.API")
            (chain *object (keys (root games)) 0))
         (values)))
 

src/ps-macros.lisp

@@ -1,172 +1,181 b''
 
 (in-package sugar-qsp.lib)
 
 ;;;; Parenscript macros which make the parser's intermediate
 ;;;; representation directly compilable by Parenscript
 ;;;; Some utility macros for other .ps sources too.
 
 ;;; Utils
 
 ;;; Common
 
 (defpsmacro label-block (() &body body)
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
            '((defvar _labels)))
        (tagbody
           ,@body
           (void)))))
 
 (defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
          "")
         ((and (= 1 (length forms))
               (stringp (first forms)))
          (first forms))
         (t
          `(& ,@forms))))
 
 ;;; 1loc
 
 (defpsmacro game ((name) &body body)
   `(progn
      (setf (root games ,name)
            (create))
      ,@(loop :for location :in body
           :collect `(setf (root games ,name ,(caadr location))
                           ,location))))
 
 (defpsmacro location ((name) &body body)
   (declare (ignore name))
   "Name is used by the game macro above"
-  `(async-lambda (args)
+  `(async-lambda ()
      (label-block ()
        ,@body)))
 
 (defpsmacro goto% (target &rest args)
   `(progn
      (goto ,target ,args)
      (exit)))
 
 (defpsmacro xgoto% (target &rest args)
   `(progn
      (xgoto ,target ,args)
      (exit)))
 
 ;;; 2var
 
 (defpsmacro qspvar (name index slot)
   `(api-call get-var ,(string name) ,index ,slot))
 
 (defpsmacro set ((var vname vindex vslot) value)
   (assert (eq var 'qspvar))
   `(api-call set-var ,(string vname) ,vindex ,vslot ,value))
 
 ;;; 3expr
 
 (defpsmacro <> (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 (defpsmacro ! (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 ;;; 4code
 
 (defpsmacro exec (&body body)
   (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps* body)))
 
 ;;; 5arrays
 
 ;;; 6str
 
 (defpsmacro & (&rest args)
   `(chain "" (concat ,@args)))
 
 ;;; 7if
 
 (defpsmacro qspcond (&rest clauses)
   `(cond ,@(loop :for clause :in clauses
               :collect (list (first clause)
                              `(tagbody
                                  ,@(rest clause))))))
 
 ;;; 8sub
 
 ;;; 9loops
 ;;; Yep, that's a huge kludge since Javascript doesn't support arbitrary labels
 
 (defpsmacro jump (target)
   `(return-from label-body
      (funcall (getprop _labels ,(string-upcase (second target))))))
 
 (defpsmacro tagbody (&body body)
   (let ((funcs (list nil "_nil")))
     (dolist (form body)
       (cond ((keywordp form)
              (setf (first funcs) (reverse (first funcs)))
              (push (string-upcase form) funcs)
              (push nil funcs))
             (t
              (push form (first funcs)))))
     (setf (first funcs) (reverse (first funcs)))
     (setf funcs (reverse funcs))
     (if (= 2 (length funcs))
         `(progn
            ,@body)
         `(progn
            (setf ,@(loop :for (label code . rest-labels) :on funcs :by #'cddr
                       :append `((@ _labels ,label)
                                 (block label-body
                                   (block ,(intern label)
                                     ,@code
                                     ,@(when rest-labels
                                         `((funcall
                                            (getprop _labels ,(first rest-labels))))))))))
            (funcall (getprop _labels "_nil"))))))
 
+(defpsmacro exit ()
+  '(return-from nil (values)))
+
 ;;; 10dynamic
 
 (defpsmacro qspblock (&body body)
   `(async-lambda (args)
      (label-block ()
        ,@body)))
 
 ;;; 11main
 
 (defpsmacro act (name img &body body)
   `(api-call add-act ,name ,img
              (async-lambda ()
                (label-block ()
                  ,@body))))
 
 ;;; 12aux
 
 ;;; 13diag
 
 ;;; 14act
 
 ;;; 15objs
 
 ;;; 16menu
 
 ;;; 17sound
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; 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)
   `((intern "QSPFOR" "API")
     ,(string (second var)) ,(third var) ;; name and index
     ,from ,to ,step
     (lambda ()
       (block nil
         ,@body
         t))))

sugar-qsp.asd

@@ -1,19 +1,18 b''
 
 (defsystem sugar-qsp
   :description "QSP compiler to monolithic HTML page"
   :depends-on (:alexandria ;; General
                :esrap ;; Parsing
                :parenscript :flute ;; Codegening
                )
   :pathname "src/"
   :serial t
   :components ((:file "package")
                (:file "patches")
                (:file "js-syms")
                (:file "main-macros")
                (:file "ps-macros")
                (:file "api-macros")
-               (:file "intrinsic-macros")
                (:file "class")
                (:file "main")
                (:file "parser")))