src/api.ps

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