src/api.ps

(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 "\");'>"
     title
     "</a>"))

(defun make-menu-item-html (num title img loc)
  (+ "<a href='" (ps-inline run-menu) "(" num ", \"" loc "\")();'>"
     "<img src='" img "'>"
     title
     "</a>"))

(defun report-error (text)
  (alert text))

(defun sleep (msec)
  (new (*promise (=> resolve (set-timeout resolve 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"))))

(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)
  (with-frame
      (with-call-args args
        (funcall (getprop (root locs) name) args))))

(defun call-act (title)
  (with-frame
      (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")
    (: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"))
    (values)))

;;; 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))
  (values))

(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)
        (values)))

(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)
  (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))
  (values))

(defun get-array (name)
  (var-ref name))

(defun set-array (name value)
  (let ((store (var-ref name)))
    (setf (@ store values) (@ value values))
    (setf (@ store indexes) (@ value indexes)))
  (values))

(defun kill-var (name &optional index)
  (if (and index (not (= 0 index))) 
      (chain (getprop (root vars) name) (kill index))
      (delete (getprop (root vars) name)))
  (values))

(defun array-size (name)
  (getprop (var-ref name) 'length))

;;; Locals

(defun push-local-frame ()
  (chain (root locals) (push (create)))
  (values))

(defun pop-local-frame ()
  (chain (root locals) (pop))
  (values))

(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)))
    (values)))

;;; 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"))
        (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))))
    (setf (@ elt style display) "block")))

;;; 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")))
    (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))
                                 main-html (inner-html
                                            (by-id :qsp-main))
                                 stat-html (inner-html
                                            (by-id :qsp-stat))
                                 next-location (root current-location)))))
  (values))

(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))
          (@ data main-html))
    (setf (inner-html (by-id :qsp-stat))
          (@ data stat-html))
    (update-objs)
    (call-serv-loc "ONGLOAD")
    (call-loc (root current-location) (@ data loc-args))
    (values)))

(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)))