MENU

examples/16menu.txt

@@ -1,13 +1,22 b''
+
+# start
+act 'Показать меню':
+    gs 'menu'
+end
+-
 
 # menu
+killvar 'usr_menu'
 ! нет иконки
-$usr_menu[0] = 'Взять предмет:take_item'
+$usr_menu[] = 'Взять предмет:take_item'
 ! иконка задана gif-файлом
-$usr_menu[1] = 'Положить предмет:put_item:images/put_item.gif'
+$usr_menu[] = 'Положить предмет:put_item:images/put_item.gif'
 ! иконка задана значением $icon_file
-$usr_menu[2] = 'Осмотреть предмет:look_item:<<$icon_file>>'
+$usr_menu[] = 'Осмотреть предмет:look_item:<<$icon_file>>'
+! Разделитель
+$usr_menu[] = '-:-'
 ! пункт меню задан 3-мя переменными
-$usr_menu[3] = '<<$name>>:<<$loc>>:<<$file>>'
+$usr_menu[] = '<<$name>>:<<$locname>>:<<$file>>'
  
 menu 'usr_menu' &! покажет меню из 4-х пунктов
 -

extras/body.html

@@ -1,23 +1,23 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">
+<div id="qsp-image-container" class="center-on-screen">
   <img id="qsp-image">
 </div>

extras/default.css

@@ -1,121 +1,129 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;
 }
 
 #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;
-  top: 200;
 }
 
 #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');
 }
 
-#qsp-image-container {
+.center-on-screen {
     position: absolute;
     top: 0;
     left: 0;
     height: 100%;
     width: 100%;
-    display: none;
+    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,15 +1,34 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 inline-call (func &rest args)
+  `(+ (ps-inline ,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))))
+

src/api.ps

@@ -1,423 +1,456 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='" (ps-inline call-act) "(\"" title "\");'>"
+  (+ "<a class='qsp-act' href='" (inline-call call-act title) "'>"
+     (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
 (defun make-menu-item-html (num title img loc)
-  (+ "<a href='" (ps-inline run-menu) "(" num ", \"" loc "\")();'>"
-     "<img src='" img "'>"
+  (+ "<a href='" (inline-call finish-menu loc) "'>"
+     (if img (+ "<img src='" img "'>") "")
      title
      "</a>"))
 
+(defun make-menu-delimiter ()
+  "<hr>")
+
 (defun report-error (text)
   (alert text))
 
 (defun start-sleeping ()
-  (chain (by-id "qsp") class-list (add "disable"))
-  (setf (root sleeping) t))
+  (chain (by-id "qsp") class-list (add "disable")))
 
 (defun finish-sleeping ()
-  (chain (by-id "qsp") class-list (remove "disable"))
-  (setf (root sleeping) nil))
+  (chain (by-id "qsp") class-list (remove "disable")))
 
 (defun sleep (msec)
-  (start-sleeping)
-  (new (*promise
-        (lambda (resolve)
-          (set-timeout
-           (lambda ()
-             (finish-sleeping)
-             (resolve))
-           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))
   ;; Close the dropdown on any click
   (setf (@ window onclick)
         (lambda (event)
-          (setf (@ (get-frame :dropdown) style display) "none"))))
+          (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))))))
 
 ;;; 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))))
 
 ;;; 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))))
 
 (defun call-act (title)
-  (unless (root sleeping)
     (with-frame
-        (funcall (getprop (root acts) title 'act)))))
+      (funcall (getprop (root acts) title 'act))))
 
 ;;; Text windows
 
 (defun key-to-id (key)
   (case key
     (: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))
   (update-acts))
 
 (defun del-act (title)
   (delete (getprop (root acts) title))
   (update-acts))
 
 (defun clear-act ()
   (setf (root acts) (create))
   (clear-id "qsp-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)))))))
 
 
 ;;; "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))
   ;; From numbers to {num: 0, str: ""} objects
   (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)
                          n))
                    index)))
           (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 (@ *var prototype set)
       (lambda (index slot value)
         (unless (or index (= 0 index))
           (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)
                        (chain this (index-num index))
                        slot) value)
         (void)))
 
 (setf (@ *var prototype kill)
       (lambda (index)
         (setf (elt (@ this values) (chain this (index-num index)))
               (new-value))
         (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))
   (void))
 
 (defun get-array (name)
+  (setf name (chain name (to-upper-case)))
   (var-ref 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)))
   (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)
-  (getprop (var-ref name) '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 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)))
     (incf (inner-html elt) "</ul>")))
 
 ;;; Menu
 
-(defun menu (menu-data)
-  (let ((elt (by-id "qsp-dropdown"))
+(defun open-menu (menu-data)
+  (let ((elt (get-frame :dropdown))
         (i 0))
-    (setf (inner-html elt) "")
     (loop :for item :in menu-data
        :do (incf i)
-       :do (incf (inner-html elt) (make-menu-item-html i
-                                                       (@ item text)
-                                                       (@ item icon)
-                                                       (@ item loc))))
+       :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 (by-id "qsp-image")))
+  (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")))))
 
 ;;; 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
-                                             (by-id :qsp-main))
+                                             (get-frame :main))
                                  :stat-html (inner-html
-                                             (by-id :qsp-stat))
+                                             (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 (by-id :qsp-main))
+    (setf (inner-html (get-frame :main))
           (@ data :main-html))
-    (setf (inner-html (by-id :qsp-stat))
+    (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)))

src/intrinsic-macros.lisp

@@ -1,174 +1,174 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)
-  `(kill-var ,varname ,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,302 +1,302 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 (or args (list)))
+  (funcall xgoto target args)
   (void))
 
 (defun xgoto (target args)
   (api:clear-act)
   (setf (root current-location) (chain target (to-upper-case)))
   (api:stash-state args)
-  (funcall (getprop (root locs) (root current-location))
-           (or args (list)))
+  (api:call-loc (root current-location) (or args (list)))
   (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)
-  (funcall (getprop (root locs) target) args)
+  (api:call-loc target args)
   (void))
 
 (defun func (target &rest args)
-  (funcall (getprop (root locs) target) 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))
   (api:update-objs)
   (void))
 
 (defun delobj (name)
   (let ((index (chain (root objs) (index-of name))))
     (when (> index -1)
       (killobj (1+ index))))
   (void))
 
 (defun killobj (&optional (num nil))
   (if (eq nil num)
       (setf (root objs) (list))
       (chain (root objs) (splice (1- num) 1)))
   (api:update-objs)
   (void))
 
 ;;; 16menu
 
 (defun menu (menu-name)
   (let ((menu-data (list)))
-    (loop :for item :in (api:get-array (api:var-real-name menu-name))
+    (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))))))))
+                             (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))))
 
 (defun openqst ()
   (api:report-error "OPENQST is not supported."))
 
 (defun addqst ()
   (api:report-error "ADDQST is not supported. Bundle the library with the main game."))
 
 (defun killqst ()
   (api:report-error "KILLQST is not supported."))

src/js-syms.lisp

@@ -1,39 +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
  now
  onload
  keys includes
  has-own-property
  ;; api
  document get-element-by-id
  onclick onchange
- atob btoa
+ atob btoa split
  alert prompt
  set-timeout set-interval clear-interval
  *promise *j-s-o-n
  href parse
  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-upper-case concat
+ to-string to-upper-case concat
  click target current-target files index-of result
  decode-u-r-i-component splice
  )

src/main.ps

@@ -1,43 +1,44 b''
 
 (in-package sugar-qsp.main)
 
 (setf (root)
       (create
        ;;; Game session state
        ;; Variables
        vars (create)
        ;; Inventory (objects)
        objs (list)
        current-location nil
        ;; Game time
        started-at (chain *date (now))
        ;; Timers
        timer-interval 500
        timer-obj nil
        ;;; Transient state
        ;; 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
        ;; ACTions
        acts (create)
        ;; 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 location
         (funcall (getprop (root locs)
                           (chain *object (keys (root locs)) 0))
                  (list))
         (values)))
 

src/parser.lisp

@@ -1,614 +1,619 b''
 
 (in-package sugar-qsp)
 
 ;;;; Parses TXT source to an intermediate representation
 
 ;;; Utility
 
 (defun remove-nth (list nth)
   (append (subseq list 0 nth)
           (subseq list (1+ nth))))
 
 (defun not-quote (char)
   (not (eql #\' char)))
 
 
 (defun not-doublequote (char)
   (not (eql #\" char)))
 
 (defun not-brace (char)
   (not (eql #\} char)))
 
 (defun not-integer (string)
   (when (find-if-not #'digit-char-p string)
     t))
 
 (defun not-newline (char)
   (not (eql #\newline char)))
 
 (defun id-any-char (char)
   (and
    (not (digit-char-p char))
    (not (eql #\newline char))
    (not (find char " 	!:&=<>+-*/,'\"()[]{}"))))
 
 (defun intern-first (list)
   (list* (intern (string-upcase (first list)) :lib)
          (rest list)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun remove-nil (list)
     (remove nil list)))
 
 (defun binop-rest (list)
   (destructuring-bind (ws1 operator ws2 operand2)
       list
     (declare (ignore ws1 ws2))
     (list (intern (string-upcase operator) :lib) operand2)))
 
 (defun do-binop% (left-op other-ops)
   (if (null other-ops)
       left-op
       (destructuring-bind ((operator right-op) &rest rest-ops)
           other-ops
         (if (and (listp left-op)
                  (eq (first left-op)
                      operator))
             (do-binop% (append left-op (list right-op)) rest-ops)
             (do-binop% (list operator left-op right-op) rest-ops)))))
 
 (defun do-binop (list)
   (destructuring-bind (left-op rest-ops)
       list
     (do-binop% left-op
       (mapcar #'binop-rest rest-ops))))
 
 (p:defrule line-continuation (and #\_ #\newline)
   (:constant nil))
 
 (p:defrule text-spaces (+ (or #\space #\tab line-continuation))
   (:text t))
 
 (p:defrule spaces (+ (or #\space #\tab line-continuation))
   (:constant nil)
   (:error-report nil))
 
 (p:defrule spaces? (* (or #\space #\tab line-continuation))
   (:constant nil)
   (:error-report nil))
 
 (p:defrule colon #\:
   (:constant nil))
 
 (p:defrule equal #\=
   (:constant nil))
 
 (p:defrule alphanumeric (alphanumericp character))
 
 (p:defrule not-newline (not-newline character))
 
 (p:defrule squote-esc "''"
   (:lambda (list)
     (p:text (elt list 0))))
 
 (p:defrule dquote-esc "\"\""
   (:lambda (list)
     (p:text (elt list 0))))
 
 (p:defrule sstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "\"exec:")))
                                  (or squote-esc (not-quote character))))
   (:lambda (list)
     (p:text (mapcar #'second list))))
 
 (p:defrule dstring-chars (+ (and (and (p:! "<<") (p:! (p:~ "'exec:")))
                                  (or dquote-esc (not-doublequote character))))
   (:lambda (list)
     (p:text (mapcar #'second list))))
 
 ;;; Identifiers
 
 (defparameter *keywords* '(act addlib addobj addqst and arrcomp arrpos arrsize cla clear *clear close clr *clr cls cmdclear cmdclr copyarr counter countobj curacts curloc debug delact dellib delobj desc disablescroll disablesubex dynamic dyneval else elseif end exit for freelib func getobj gosub goto gs gt if iif inclib input instr isnum isplay jump killall killobj killqst killvar lcase lcolor len let loc local maintxt max menu mid min mod msecscount msg nl *nl no nosave obj opengame openqst or p *p pl *pl play qspver rand refint replace rgb rnd savegame selact selobj set settimer showacts showinput showobjs showstat stattxt step str strcomp strfind strpos to trim ucase unsel unselect usercom user_text usrtxt val view wait xgoto xgt))
 
 (defun trim-$ (str)
   (if (char= #\$ (elt str 0))
       (subseq str 1)
       str))
 
 (defun qsp-keyword-p (id)
   (member (intern (trim-$ (string-upcase id))) *keywords*))
 
 (defun not-qsp-keyword-p (id)
   (not (member (intern (trim-$ (string-upcase id))) *keywords*)))
 
 (p:defrule qsp-keyword (qsp-keyword-p identifier-raw))
 
 (p:defrule id-first (id-any-char character))
 (p:defrule id-next (or (id-any-char character)
                        (digit-char-p character)))
 (p:defrule identifier-raw (and id-first (* id-next))
   (:lambda (list)
     (intern (string-upcase (p:text list)) :lib)))
 
 (p:defrule identifier (not-qsp-keyword-p identifier-raw))
 
 ;;; Strings
 
 (p:defrule qsp-string (or normal-string brace-string))
 
 (p:defrule normal-string (or sstring dstring)
   (:lambda (str)
     (list* 'lib:str (or str (list "")))))
 
 (p:defrule sstring (and #\' (* (or string-interpol
                                    sstring-exec
                                    sstring-chars))
                         #\')
   (:function second))
 
 (p:defrule dstring (and #\" (* (or string-interpol
                                    dstring-exec
                                    dstring-chars))
                         #\")
   (:function second))
 
 (p:defrule string-interpol (and "<<" expression ">>")
   (:function second))
 
 (p:defrule sstring-exec-body (+ (or squote-esc (not-doublequote character)))
   (:text t))
 
 (p:defrule dstring-exec-body (+ (or dquote-esc (not-quote character)))
   (:text t))
 
 (p:defrule sstring-exec (and (p:~ "\"exec:") sstring-exec-body #\")
   (:lambda (list)
     (list* 'lib:exec (p:parse 'exec-body (second list)))))
 
 (p:defrule dstring-exec (and (p:~ "'exec:") dstring-exec-body #\')
   (:lambda (list)
     (list* 'lib:exec (p:parse 'exec-body (second list)))))
 
 (p:defrule brace-string (and #\{ before-statement block-body #\})
   (:lambda (list)
     (list* 'lib:qspblock (third list))))
 
 ;;; Location
 
 (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline))
                                   (* location))
   (:function second))
 
 (p:defrule location (and location-header block-body location-end)
   (:destructure (header body end)
     (declare (ignore end))
     `(lib:location (,header) ,@body)))
 
 (p:defrule location-header (and #\#
                                 (+ not-newline)
                                 (and #\newline spaces? before-statement))
   (:destructure (spaces1 name spaces2)
     (declare (ignore spaces1 spaces2))
     (string-upcase (string-trim " " (p:text name)))))
 
 (p:defrule location-end (and #\- (* not-newline) #\newline before-statement)
   (:constant nil))
 
 ;;; Block body
 
 (p:defrule newline-block-body (and #\newline spaces? block-body)
   (:function third))
 
 (p:defrule block-body (* statement)
   (:function remove-nil))
 
 ;; Just for <a href="exec:...'>
 ;; Explicitly called from that rule's production
 (p:defrule exec-body (and before-statement line-body)
   (:function second))
 
 (p:defrule line-body (and inline-statement (* next-inline-statement))
   (:lambda (list)
     (list* (first list) (second list))))
 
 (p:defrule before-statement (* (or #\newline spaces))
   (:constant nil))
 
 (p:defrule statement-end (or statement-end-real statement-end-block-close))
 
 (p:defrule statement-end-real (and (or #\newline
                                        (and #\& spaces? (p:& statement%)))
                                    before-statement)
   (:constant nil))
 
 (p:defrule statement-end-block-close (or (p:& #\}))
   (:constant nil))
 
 (p:defrule inline-statement (and statement% spaces?)
   (:function first))
 
 (p:defrule next-inline-statement (and #\& spaces? inline-statement)
   (:function third))
 
 (p:defrule not-a-non-statement (and (p:! (p:~ "elseif"))
                                     (p:! (p:~ "else"))
                                     (p:! (p:~ "end"))))
 
 (p:defrule statement (and inline-statement statement-end)
   (:function first))
 
 (p:defrule statement% (and not-a-non-statement
                            (or label comment string-output
                                block non-returning-intrinsic local
                                assignment expression-output))
   (:function second))
 
 (p:defrule expr-stopper (or comment block non-returning-intrinsic))
 
 (p:defrule string-output qsp-string
   (:lambda (string)
     (list 'lib:main-pl string)))
 
 (p:defrule expression-output expression
   (:lambda (list)
     (list 'lib:main-pl list)))
 
 (p:defrule label (and colon identifier)
   (:lambda (list)
     (intern (string (second list)) :keyword)))
 
 (p:defrule comment (and #\! (* (or qsp-string brace-comment text-spaces not-newline)))
   (:constant nil))
 
 (p:defrule brace-comment (and #\{ (* (not-brace character)) #\})
   (:constant nil))
 
 (p:defrule local (and (p:~ "local") spaces variable (p:? (and spaces? #\= spaces? expression)))
   (:lambda (list)
     (list* 'lib:local (third list)
            (when (fourth list)
              (list (fourth (fourth list)))))))
 
 ;;; Blocks
 
 (p:defrule block (or block-act block-if block-for))
 
 (p:defrule block-if (and block-if-head block-if-body)
   (:destructure (head body)
     `(lib:qspcond (,@head ,@(first body))
                   ,@(rest body))))
 
 (p:defrule block-if-head (and (p:~ "if") spaces expression spaces? colon spaces?)
   (:function remove-nil)
   (:function cdr))
 
 (p:defrule block-if-body (or block-if-ml block-if-sl)
   (:destructure (if-body elseifs else &rest ws)
     (declare (ignore ws))
     `(,(remove-nil if-body) ,@elseifs ,@(when else `((else ,@else))))))
 
 (p:defrule block-if-sl (and line-body
                             (p:? block-if-elseif-inline)
                             (p:? block-if-else-inline)
                             spaces?))
 
 (p:defrule block-if-ml (and (and #\newline spaces?)
                             block-body
                             (p:? block-if-elseif)
                             (p:? block-if-else)
                             block-if-end)
   (:lambda (list)
     (cdr list)))
 
 (p:defrule block-if-elseif-inline (and block-if-elseif-head line-body (p:? block-if-elseif-inline))
   (:destructure (head statements elseif)
     `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
 
 (p:defrule block-if-elseif (and block-if-elseif-head statement-end block-body (p:? block-if-elseif))
   (:destructure (head ws statements elseif)
     (declare (ignore ws))
     `((,@(rest head) ,@(remove-nil statements)) ,@elseif)))
 
 (p:defrule block-if-elseif-head (and (p:~ "elseif") spaces expression spaces? colon spaces?)
   (:function remove-nil)
   (:function intern-first))
 
 (p:defrule block-if-else-inline (and block-if-else-head line-body)
   (:function second))
 
 (p:defrule block-if-else (and block-if-else-head #\newline spaces? block-body)
   (:function fourth))
 
 (p:defrule block-if-else-head (and (p:~ "else") spaces?)
   (:constant nil))
 
 (p:defrule block-if-end (and (p:~ "end") 
                              (p:? (and spaces (p:~ "if"))))
   (:constant nil))
 
 (p:defrule block-act (and block-act-head (or block-ml block-sl))
   (:lambda (list)
     (apply #'append list)))
 
 (p:defrule block-act-head (and (p:~ "act") spaces? qsp-string spaces?
                                (p:? block-act-head-img)
                                colon spaces?)
   (:lambda (list)
     (intern-first (list (first list)
                         (third list)
                         (or (fifth list) '(lib:str ""))))))
 
 (p:defrule block-act-head-img (and #\, spaces? qsp-string spaces?)
   (:lambda (list)
     (or (third list) "")))
 
 (p:defrule block-for (and block-for-head (or block-ml block-sl))
   (:lambda (list)
     (apply #'append list)))
 
 (p:defrule block-for-head (and (p:~ "for") spaces variable spaces? equal spaces? expression 
                                (p:~ "to") spaces expression
                                block-for-head-step
                                colon spaces?)
   (:lambda (list)
     (unless (eq (fourth (third list)) :num)
       (error "For counter variable must be numeric."))
     (list 'lib:qspfor
           (elt list 2)
           (elt list 6)
           (elt list 9)
           (elt list 10))))
 
 (p:defrule block-for-head-step (p:? (and (p:~ "step") spaces expression spaces?))
   (:lambda (list)
     (if list
         (third list)
         1)))
 
 (p:defrule block-sl line-body)
 
 (p:defrule block-ml (and newline-block-body block-end)
   (:lambda (list)
     (apply #'list* (butlast list))))
 
 (p:defrule block-end (and (p:~ "end"))
   (:constant nil))
 
 ;;; Calls
 
 (p:defrule first-argument (and expression spaces?)
   (:function first))
 (p:defrule next-argument (and "," spaces? expression)
   (:function third))
 (p:defrule arguments (or parenthesized-arguments plain-arguments no-arguments))
 (p:defrule parenthesized-arguments (and spaces? #\( base-arguments #\))
   (:function third))
 (p:defrule plain-arguments (and spaces? base-arguments)
   (:function second))
 (p:defrule no-arguments (or (and spaces? (p:& #\newline))
                             (and spaces? (p:& #\&))
                             spaces?)
   (:constant nil))
 (p:defrule base-arguments (or (and first-argument (* next-argument)) spaces?)
   (:lambda (list)
     (if (null list)
         nil
         (list* (first list) (second list)))))
 
 ;;; Intrinsics
 
 (defmacro defintrinsics ((rule-name returning-rule-name non-returning-rule-name) &body clauses)
   `(progn
      ,@(loop :for clause :in clauses
           :collect `(defintrinsic ,@clause))
      (p:defrule ,returning-rule-name (or ,@(remove-nil
                                             (mapcar (lambda (clause)
                                                       (when (second clause)
                                                         (alexandria:symbolicate
                                                          'intrinsic- (first clause))))
                                                     clauses))))
      (p:defrule ,non-returning-rule-name (or ,@(remove-nil
                                                 (mapcar (lambda (clause)
                                                           (unless (second clause)
                                                             (alexandria:symbolicate
                                                              'intrinsic- (first clause))))
                                                         clauses))))
      (p:defrule ,rule-name (or ,returning-rule-name ,non-returning-rule-name))))
 
 (defmacro defintrinsic (sym returning &optional (min-arity 0) (max-arity 10) &rest names)
   (declare (ignore returning))
   (setf names 
         (if names
             (mapcar #'string-upcase names)
             (list (string sym))))
   `(p:defrule ,(alexandria:symbolicate 'intrinsic- sym)
        (and (p:? #\$) (or ,@(loop :for name :in names :collect `(p:~ ,name)))
             arguments)
      (:destructure (dollar name arguments)
        (declare (ignore dollar))
        (unless (<= ,min-arity (length arguments) ,max-arity)
          (error "Intrinsic ~A expects between ~A and ~A arguments but ~A were provided:~%~S"
                 name ,min-arity ,max-arity (length arguments) arguments))
        (list* ',(intern (string sym) :lib) arguments))))
 
 (defintrinsics (intrinsic returning-intrinsic non-returning-intrinsic)
   ;; Transitions
   (goto%    nil 0 10 "gt" "goto")
   (xgoto%   nil 0 10 "xgt" "xgoto")
   ;; Variables
   (killvar  nil 0 2)
   ;; Expressions
   (obj      t   1 1)
   (loc      t   1 1)
   (no       t   1 1)
   ;; Basic
   (qspver   t   0 0)
   (curloc   t   0 0)
   (rand     t   1 2)
   (rnd      t   0 0)
   (qspmax   t   1 10 "max")
   (qspmin   t   1 10 "min")
   ;; Arrays
   (killall  nil 0 0)
   (copyarr  nil 2 4)
   (arrsize  t   1 1)
   (arrpos   t   2 3)
   (arrcomp  t   2 3)
   ;; Strings
   (len      t   1 1)
   (mid      t   2 3)
   (ucase    t   1 1)
   (lcase    t   1 1)
   (trim     t   1 1)
   (replace  t   2 3)
   (instr    t   2 3)
   (isnum    t   1 1)
   (val      t   1 1)
   (qspstr   t   1 1 "str")
   (strcomp  t   2 2)
   (strfind  t   2 3)
   (strpos   t   2 3)
   ;; IF
   (iif      t   2 3)
   ;; Subs
   (gosub    nil 1 10 "gosub" "gs")
   (func     t   1 10)
   (exit     nil 0 0)
   ;; Jump
   (jump     nil 1 1)
   ;; Dynamic
   (dynamic  nil 1 10)
   (dyneval  t   1 10)
   ;; Sound
   (play     nil 1 2)
   (isplay   t   1 1)
   (close    nil 1 1)
   (closeall nil 0 0 "close all")
   ;; Main window
   (main-pl  nil 1 1 "*pl")
   (main-nl  nil 0 1 "*nl")
   (main-p   nil 1 1 "*p")
   (maintxt  t   0 0)
   (desc     t   1 1)
   (main-clear   nil 0 0 "*clear" "*clr")
   ;; Aux window
   (showstat nil 1 1)
   (stat-pl   nil 1 1 "pl")
   (stat-nl   nil 0 1 "nl")
   (stat-p    nil 1 1 "p")
   (stattxt  t   0 0)
   (stat-clear    nil 0 0 "clear" "clr")
   (cls      nil 0 0)
   ;; Dialog
   (msg      nil 1 1)
   ;; Acts
   (showacts nil 1 1)
   (delact   nil 1 1 "delact" "del act")
   (curacts  t   0 0)
   (cla      nil 0 0)
   ;; Objects
   (showobjs nil 1 1)
   (addobj   nil 1 3 "addobj" "add obj")
   (delobj   nil 1 1 "delobj" "del obj")
   (killobj  nil 0 1)
   (countobj t   0 0)
   (getobj   t 1 1)
   ;; Menu
   (menu     nil 1 1)
   ;; Images
   (refint   nil 0 0)
   (view     nil 0 1)
   ;; Fonts
   (rgb      t   3 3)
   ;; Input
   (showinput nil 1 1)
   (usertxt  t   0 0 "user_text" "usrtxt")
   (cmdclear nil 0 0 "cmdclear" "cmdclr")
   (input    t   1 1)
   ;; Files
   (openqst  nil 1 1)
   (addqst   nil 1 1 "addqst" "addlib" "inclib")
   (killqst  nil 1 1 "killqst" "dellib" "freelib")
   (opengame nil 0 0)
   (savegame nil 0 0)
   ;; Real time
   (wait     nil 1 1)
   (msecscount t 0 0)
   (settimer nil 1 1))
 
 ;;; Expression
 
 (p:defrule expression or-expr)
 
 (p:defrule or-expr (and and-expr (* (and spaces? or-op spaces? and-expr)))
   (:function do-binop))
 
 (p:defrule and-expr (and eq-expr (* (and spaces? and-op spaces? eq-expr)))
   (:function do-binop))
 
 (p:defrule eq-expr (and sum-expr (* (and spaces? (or "<=" ">=" "=<" "=>" "<>"
                                                      "=" "<" ">" "!")
                                          spaces? sum-expr)))
   (:function do-binop))
 
 (p:defrule sum-expr (and mod-expr (* (and spaces? (or #\+ #\-) spaces? mod-expr)))
   (:function do-binop))
 
 (p:defrule mod-expr (and mul-expr (* (and spaces? (p:~ "mod") spaces? mul-expr)))
   (:function do-binop))
 
 (p:defrule mul-expr (and unary-expr (* (and spaces? (or #\* #\/) spaces? unary-expr)))
   (:function do-binop))
 
 (p:defrule unary-expr (and (p:? (or #\+ #\-)) atom-expr)
   (:lambda (list)
     (let ((expr (remove-nil list)))
       (if (= 1 (length expr))
           (first expr)
           (intern-first expr)))))
 
 (p:defrule atom-expr (and (or variable literal returning-intrinsic paren-expr) spaces?)
   (:function first))
 
 (p:defrule paren-expr (and #\( spaces? expression spaces? #\))
   (:function third))
 
 (p:defrule or-op (p:~ "or")
   (:constant "or"))
 
 (p:defrule and-op (p:~ "and")
   (:constant "and"))
 
 ;;; Variables
 
 (p:defrule variable (and identifier (p:? array-index))
   (:destructure (id idx)
+    (let ((idx (case idx
+                 (nil 0)
+                 (:last nil)
+                 (t idx))))
     (if (char= #\$ (elt (string id) 0))
-        (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) (or idx 0) :str)
-        (list 'lib:qspvar id (or idx 0) :num))))
+          (list 'lib:qspvar (intern (subseq (string-upcase id) 1) :lib) idx :str)
+          (list 'lib:qspvar id idx :num)))))
 
 (p:defrule array-index (and #\[ spaces? (p:? expression) spaces? #\])
-  (:function third))
+  (:lambda (list)
+    (or (third list) :last)))
 
 (p:defrule assignment (or kw-assignment plain-assignment op-assignment)
   (:destructure (qspvar eq expr)
     (declare (ignore eq))
     (list 'lib:set qspvar expr)))
 
 (p:defrule kw-assignment (and (or (p:~ "let") (p:~ "set")) spaces? (or op-assignment plain-assignment))
   (:function third))
 
 (p:defrule op-assignment (and variable spaces? (or "+" "-" "*" "/") #\= spaces? expression)
   (:destructure (qspvar ws1 op eq ws2 expr)
                 (declare (ignore ws1 ws2))
                 (list qspvar eq (intern-first (list op qspvar expr)))))
 
 (p:defrule plain-assignment (and variable spaces? #\= spaces? expression)
   (:function remove-nil))
 
 ;;; Non-string literals
 
 (p:defrule literal (or qsp-string brace-string number))
 
 (p:defrule number (+ (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
   (:lambda (list)
     (parse-integer (p:text list))))