API call for FOR loop to make the main code less cluttered

src/api.ps

@@ -1,348 +1,359 b''
 
 (in-package sugar-qsp)
 
 ;;; 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
 
 (setf (root api) (ps:create))
 
 ;;; Utils
 
 (defm (root api make-act-html) (title img)
   (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>"
      title
      "</a>"))
 
 (defm (root api make-menu-item-html) (num title img loc)
   (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>"
      "<img src='" img "'>"
      title
      "</a>"))
 
 (defm (root api init-dom) ()
   ;; Save/load buttons
   (let ((btn (document.get-element-by-id "qsp-btn-save")))
     (setf (ps:@ btn onclick) this.savegame)
     (setf (ps:@ btn href) "#"))
   (let ((btn (document.get-element-by-id "qsp-btn-open")))
     (setf (ps:@ btn onclick) this.opengame)
     (setf (ps:@ btn href) "#"))
   ;; Close image on click
   (setf (ps:@ (document.get-element-by-id "qsp-image-container") onclick)
         (this.show-image nil))
   ;; Close the dropdown on any click
   (setf window.onclick
         (lambda (event)
           (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))))
 
 ;; To be used in saving game
 (defm (root api stash-state) (args)
   (setf (root state-stash)
         (*j-s-o-n.stringify
          (ps:create vars (root vars)
                     objs (root objs)
                     loc-args args
                     main-html (ps:@
                                (document.get-element-by-id :qsp-main)
                                inner-h-t-m-l)
                     stat-html (ps:@
                                (document.get-element-by-id :qsp-stat)
                                inner-h-t-m-l)
                     next-location (root current-location))))
   (values))
 
 (defm (root api unstash-state) ()
   (let ((data (*j-s-o-n.parse (root state-stash))))
     (this.clear-act)
     (setf (root vars) (ps:@ data vars))
     (loop :for k :in (*object.keys (root vars))
        :do (*object.set-prototype-of (ps:getprop (root vars) k)
                                      (root api *var prototype)))
     (setf (root objs) (ps:@ data objs))
     (setf (root current-location) (ps:@ data next-location))
     (setf (ps:@ (document.get-element-by-id :qsp-main) inner-h-t-m-l)
           (ps:@ data main-html))
     (setf (ps:@ (document.get-element-by-id :qsp-stat) inner-h-t-m-l)
           (ps:@ data stat-html))
     (funcall (root locs (root current-location)) (ps:@ data loc-args))
     (this.update-objs)
     (values)))
 
 (defm (root api state-to-base64) ()
   (btoa (encode-u-r-i-component (root state-stash))))
 
 (defm (root api base64-to-state) (data)
   (setf (root state-stash) (decode-u-r-i-component (atob data))))
 
 ;;; Misc
 
 (defm (root api clear-id) (id)
   (setf (ps:chain document (get-element-by-id id) inner-text) ""))
 
 (defm (root api get-id) (id)
   (if (var "USEHTML" 0 :num)
       (ps:chain (document.get-element-by-id id) inner-h-t-m-l)
       (ps:chain (document.get-element-by-id id) inner-text)))
 
 (defm (root api set-id) (id contents)
   (if (var "USEHTML" 0 :num)
       (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
       (setf (ps:chain (document.get-element-by-id id) inner-text) contents)))
 
 (defm (root api append-id) (id contents)
   (if (var "USEHTML" 0 :num)
       (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
       (incf (ps:chain (document.get-element-by-id id) inner-text) contents)))
 
 ;;; Function calls
 
 (defm (root api init-args) (args)
   (dotimes (i (length args))
     (let ((arg (elt args i)))
       (if (numberp arg)
           (this.set-var args i :num arg)
           (this.set-var args i :str arg)))))
 
 (defm (root api get-result) ()
   (if (not (equal "" (var result 0 :str)))
       (var result 0 :str)
       (var result 0 :num)))
 
 ;;; Text windows
 
 (defm (root api key-to-id) (key)
   (case key
     (:main "qsp-main")
     (:stat "qsp-stat")
     (:objs "qsp-objs")
     (:acts "qsp-acts")
     (:input "qsp-input")
     (:dropdown "qsp-dropdown")
     (t (report-error "Internal error!"))))
 
 (defm (root api get-frame) (key)
   (document.get-element-by-id (this.key-to-id key)))
 
 (defm (root api add-text) (key text)
   (this.append-id (this.key-to-id key) text))
 
 (defm (root api get-text) (key)
   (this.get-id (this.key-to-id key)))
 
 (defm (root api clear-text) (key)
   (this.clear-id (this.key-to-id key)))
 
 (defm (root api newline) (key)
   (let ((div (this.get-frame key)))
     (ps:chain div (append-child (document.create-element "br")))))
 
 (defm (root api enable-frame) (key enable)
   (let ((clss (ps:getprop (this.get-frame key) 'class-list)))
     (setf clss.style.display (if enable "block" "none"))
     (values)))
 
 ;;; Actions
 
 (defm (root api add-act) (title img act)
   (setf (ps:getprop (root acts) title)
         (ps:create :img img :act act))
   (this.update-acts))
 
 (defm (root api del-act) (title)
   (delete (ps:getprop (root acts) title))
   (this.update-acts))
 
 (defm (root api clear-act) ()
   (setf (root acts) (ps:create))
   (this.clear-id "qsp-acts"))
 
 (defm (root api update-acts) ()
   (this.clear-id "qsp-acts")
   (ps:for-in (title (root acts))
     (let ((obj (ps:getprop (root acts) title)))
       (this.append-id "qsp-acts"
                 (this.make-act-html title (ps:getprop obj :img))))))
 
+;;; "Syntax"
+
+(defm (root api qspfor) (name index from to step body)
+  (block nil
+    (ps:for ((i from))
+            ((< i to))
+            ((incf i step))
+      (this.set-var name index :num i)
+      (unless (funcall body)
+        (return)))))
+
 ;;; Variable class
 
 (defm (root api *var) (name)
   ;; From strings to numbers
   (setf this.indexes (ps:create))
   ;; From numbers to {num: 0, str: ""} objects
   (setf this.values (list))
   (values))
 
 (defm (root api *var prototype new-value) ()
   (ps:create :num 0 :str ""))
 
 (defm (root api *var prototype index-num) (index)
   (let ((num-index
          (if (stringp index)
              (if (in index this.indexes)
                  (ps:getprop this.indexes index)
                  (let ((n (length this.values)))
                    (setf (ps:getprop this.indexes index) n)
                    n))
              index)))
     (unless (in num-index this.values)
       (setf (elt this.values num-index) (this.new-value)))
     num-index))
 
 (defm (root api *var prototype get) (index slot)
   (unless (or index (= 0 index))
     (setf index (1- (length this.values))))
   (ps:getprop this.values (this.index-num index) slot))
 
 (defm (root api *var prototype set) (index slot value)
   (unless (or index (= 0 index))
     (setf index (length store)))
   (case slot
     (:num (setf value (ps:chain *number (parse-int value))))
     (:str (setf value (ps:chain value (to-string)))))
   (setf (ps:getprop this.values (this.index-num index) slot) value)
   (values))
 
 (defm (root api *var prototype kill) (index)
   (setf (elt this.values (this.index-num index)) (this.new-value)))
 
 ;;; Variables
 
 (defm (root api var-real-name) (name)
   (if (= (ps:@ name 0) #\$)
       (values (ps:chain name (substr 1)) :str)
       (values name :num)))
 
 (defm (root api ensure-var) (name)
   (let ((store (this.var-ref name)))
     (unless store
       (setf store (ps:new (this.-var name)))
       (setf (ps:getprop (root vars) name) store))
     store))
 
 (defm (root api var-ref) (name)
   (let ((local-store (this.current-local-frame)))
     (cond ((in name local-store)
            (ps:getprop local-store name))
           ((in name (root vars))
            (ps:getprop (root vars) name))
           (t nil))))
 
 (defm (root api get-var) (name index slot)
   (ps:chain (this.ensure-var name) (get index slot)))
 
 (defm (root api set-var) (name index slot value)
   (ps:chain (this.ensure-var name) (set index slot value))
   (values))
 
 (defm (root api get-array) (name)
   (this.var-ref name))
 
 (defm (root api set-array) (name value)
   (let ((store (this.var-ref name)))
     (setf (ps:@ store values) (ps:@ value values))
     (setf (ps:@ store indexes) (ps:@ value indexes)))
   (values))
 
 (defm (root api kill-var) (name &optional index)
   (if (and index (not (= 0 index))) 
       (ps:chain (ps:getprop (root vars) name) (kill index))
       (ps:delete (ps:getprop (root vars) name)))
   (values))
 
 (defm (root api array-size) (name)
   (ps:getprop (this.var-ref name) 'length))
 
 ;;; Locals
 
 (defm (root api push-local-frame) ()
   (ps:chain (root locals) (push (ps:create)))
   (values))
 
 (defm (root api pop-local-frame) ()
   (ps:chain (root locals) (pop))
   (values))
 
 (defm (root api current-local-frame) ()
   (elt (root locals) (1- (length (root locals)))))
 
 (defm (root api new-local) (name)
   (let ((frame (this.current-local-frame)))
     (unless (in name frame)
       (setf (ps:getprop frame name) (ps:create)))
     (values)))
 
 ;;; Objects
 
 (defm (root api update-objs) ()
   (let ((elt (document.get-element-by-id "qsp-objs")))
     (setf elt.inner-h-t-m-l "<ul>")
     (loop :for obj :in (root objs)
        :do (incf elt.inner-h-t-m-l (+ "<li>" obj)))
     (incf elt.inner-h-t-m-l "</ul>")))
 
 ;;; Menu
 
 (defm (root api menu) (menu-data)
   (let ((elt (document.get-element-by-id "qsp-dropdown"))
         (i 0))
     (setf elt.inner-h-t-m-l "")
     (loop :for item :in menu-data
        :do (incf i)
        :do (incf elt.inner-h-t-m-l (this.make-menu-item-html i item.text item.icon item.loc)))
     (setf elt.style.display "block")))
 
 ;;; Content
 
 (defm (root api clean-audio) ()
   (loop :for k :in (*object.keys (root playing))
      :for v := (ps:getprop (root playing) k)
      :do (when (ps:@ v ended)
            (ps:delete (ps:@ (root playing) k)))))
 
 (defm (root api show-image) (path)
   (let ((img (document.get-element-by-id "qsp-image")))
     (cond (path
            (setf img.src path)
            (setf img.style.display "flex"))
           (t
            (setf img.src "")
            (setf img.style.display "hidden")))))
 
 ;;; Saves
 
 (defm (root api opengame) ()
   (let ((element (document.create-element :input)))
     (element.set-attribute :type :file)
     (element.set-attribute :id :qsp-opengame)
     (element.set-attribute :tabindex -1)
     (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 (elt event.target.files 0))
                    (reader (ps:new (*file-reader))))
               (setf reader.onload
                     (lambda (ev)
                       (block nil
                              (let ((target ev.current-target))
                                (unless target.result
                                  (return))
                                (api-call base64-to-state target.result)
                                (api-call unstash-state)))))
               (reader.read-as-text file))))
     (document.body.append-child element)
     (element.click)
     (document.body.remove-child element)))
 
 (defm (root api savegame) ()
   (let ((element (document.create-element :a)))
     (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64)))
     (element.set-attribute :download "savegame.sav")
     (setf element.style.display :none)
     (document.body.append-child element)
     (element.click)
     (document.body.remove-child element)))

src/ps-macros.lisp

@@ -1,203 +1,204 b''
 
 (in-package sugar-qsp)
 
 ;;;; Parenscript macros which make the parser's intermediate
 ;;;; representation directly compilable by Parenscript
 ;;;; Some utility macros for other .ps sources too.
 
 ;;; Utils
 
 (ps:defpsmacro defm (path args &body body)
   `(setf ,path (lambda ,args ,@body)))
 
 (ps:defpsmacro root (&rest path)
   `(ps:@ *sugar-q-s-p ,@path))
 
 (ps:defpsmacro in (key obj)
   `(ps:chain ,obj (has-own-property ,key)))
 
 (ps:defpsmacro with-frame (&body body)
   `(progn
      (api-call push-local-frame)
      (unwind-protect
           ,@body
        (api-call pop-local-frame))))
 
 ;;; Common
 
 (defmacro defpsintrinsic (name)
   `(ps:defpsmacro ,name (&rest args)
      `(funcall (root lib ,',name)
                ,@args)))
 
 (defmacro defpsintrinsics (() &rest names)
   `(progn ,@(loop :for name :in names
                  :collect `(defpsintrinsic ,name))))
 
 (defpsintrinsics ()
     rand copyarr arrpos arrcomp instr isnum strcomp strfind strpos iif gosub func dynamic dyneval main-p main-pl main-nl maintxt main-clear stat-p stat-pl stat-nl stattxt stat-clear cls curacts addobj delobj killobj menu play isplay close closeall refint view rgb showinput usertxt cmdclear input openqst addqst killqst opengame savegame wait msecscount settimer)
 
 (ps:defpsmacro api-call (func &rest args)
   `(funcall (root api ,func) ,@args))
 
 (ps:defpsmacro label-block ((&key (locals t)) &body body)
   (let ((has-labels (some #'keywordp body)))
     `(block nil
        ,@(when has-labels
            '((defvar __labels)))
        ,@(if locals
              `((with-frame
                     (tagbody
                        ,@body)))
              `((tagbody
                   ,@body))))))
 
 (ps:defpsmacro str (&rest forms)
   (cond ((zerop (length forms))
          "")
         ((and (= 1 (length forms))
               (stringp (first forms)))
          (first forms))
         (t
          `(& ,@forms))))
 
 ;;; 1loc
 
 (ps:defpsmacro location ((name) &body body)
   `(setf (root locs ,name)
          (lambda (args)
            (label-block ()
             (api-call init-args args)
             ,@body
             (api-call get-result)))))
 
 (ps:defpsmacro goto (target &rest args)
   `(progn
      (funcall (root lib goto) ,target ,args)
      (exit)))
 
 (ps:defpsmacro xgoto (target &rest args)
   `(progn
      (funcall (root lib xgoto) ,target ,args)
      (exit)))
 
 (ps:defpsmacro desc (target)
   (declare (ignore target))
   (report-error "DESC is not supported"))
 
 ;;; 2var
 
 (ps:defpsmacro var (name index slot)
   `(api-call get-var ,(string name) ,index ,slot))
 
 (ps:defpsmacro set ((var vname vindex vslot) value)
   (assert (eq var 'var))
   `(api-call set-var ,(string vname) ,vindex ,vslot ,value))
 
 ;;; 3expr
 
 (ps:defpsmacro <> (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 (ps:defpsmacro ! (op1 op2)
   `(not (equal ,op1 ,op2)))
 
 ;;; 4code
 
 (ps:defpsmacro exec (&body body)
   (format nil "javascript: ~{~A~^~%~}" (mapcar #'ps:ps* body)))
 
 ;;; 5arrays
 
 ;;; 6str
 
 (ps:defpsmacro & (&rest args)
   `(ps:chain "" (concat ,@args)))
 
 ;;; 7if
 
 (ps: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
 
 (ps:defpsmacro jump (target)
   `(return-from ,(intern (string-upcase (second target)))
      (funcall (ps:getprop __labels ,target))))
 
 (ps:defpsmacro tagbody (&body body)
   (let ((funcs (list nil :__nil)))
     (dolist (form body)
       (cond ((keywordp form)
              (setf (first funcs) (reverse (first funcs)))
              (push 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 f :on funcs :by #'cddr
                       :append `((ps:@ __labels ,(first f))
                                 (block ,(intern (string-upcase (string (first f))))
                                   ,@(second f)
                                   ,@(when (third f)
                                       `((funcall
                                          (ps:getprop __labels ,(third f)))))))))
            (jump (str "__nil"))))))
 
 ;;; 10dynamic
 
 (ps:defpsmacro qspblock (&body body)
   `(lambda (args)
      (label-block ()
       (api-call init-args args)
       ,@body
       (api-call get-result))))
 
 ;;; 11main
 
 (ps:defpsmacro act (name img &body body)
   `(api-call add-act ,name ,img
              (lambda ()
                (label-block ()
                 ,@body))))
 
 ;;; 12aux
 
 ;;; 13diag
 
 ;;; 14act
 
 ;;; 15objs
 
 ;;; 16menu
 
 ;;; 17sound
 
 ;;; 18img
 
 ;;; 19input
 
 ;;; 20time
 
 ;;; 21local
 
 ;;; 22for
 
 (ps:defpsmacro qspfor (var from to step &body body)
-  `(block nil
-     (set ,var ,from)
-     (ps:for ()
-             ((< ,var ,to))
-             ((set ,var (+ ,var ,step)))
-             ,@body)))
+  `(api-call qspfor
+             ,(string (second var)) ,(third var) ;; name and index
+             ,from ,to ,step
+             (lambda ()
+               (block nil
+                 ,@body
+                 t))))