api.ps
393 lines
| 12.0 KiB
| application/postscript
|
PostScriptLexer
/ src / api.ps
r1 | ||||
(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)) | ||||
r6 | ;;; Utils | |||
(defm (root api make-act-html) (title img) | ||||
r23 | (+ "<a class='qsp-act' href='#' onclick='SugarQSP.api.callAct(\"" title "\");'>" | |||
r6 | title | |||
"</a>")) | ||||
r11 | (defm (root api make-menu-item-html) (num title img loc) | |||
(+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>" | ||||
"<img src='" img "'>" | ||||
title | ||||
"</a>")) | ||||
r20 | (defm (root api report-error) (text) | |||
(alert text)) | ||||
r18 | (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")))) | ||||
r20 | (defm (root api call-serv-loc) (var-name &rest args) | |||
(let ((loc-name (api-call get-var name 0 :str))) | ||||
(when loc-name | ||||
(let ((loc (ps:getprop (root locs) loc-name))) | ||||
(when loc | ||||
(funcall loc args)))))) | ||||
r11 | ||||
r9 | ;;; Misc | |||
r22 | (defm (root api newline) (key) | |||
(this.append-id (this.key-to-id key) "<br>" t)) | ||||
r9 | (defm (root api clear-id) (id) | |||
r23 | (setf (ps:inner-html (document.get-element-by-id id)) "")) | |||
r22 | ||||
(setf (root api text-escaper) (document.create-element :textarea)) | ||||
(defm (root api prepare-contents) (s &optional force-html) | ||||
(if (or force-html (var "USEHTML" 0 :num)) | ||||
s | ||||
(progn | ||||
(setf (ps:@ (root api text-escaper) text-content) s) | ||||
r23 | (ps:inner-html (root api text-escaper))))) | |||
r9 | ||||
r21 | (defm (root api get-id) (id &optional force-html) | |||
r23 | (ps:inner-html (document.get-element-by-id id))) | |||
r9 | ||||
r21 | (defm (root api set-id) (id contents &optional force-html) | |||
r23 | (setf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html))) | |||
r9 | ||||
r21 | (defm (root api append-id) (id contents &optional force-html) | |||
r22 | (when contents | |||
r23 | (incf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html)))) | |||
r9 | ||||
r1 | ;;; Function calls | |||
(defm (root api init-args) (args) | ||||
(dotimes (i (length args)) | ||||
r16 | (let ((arg (elt args i))) | |||
(if (numberp arg) | ||||
(this.set-var args i :num arg) | ||||
(this.set-var args i :str arg))))) | ||||
r1 | ||||
(defm (root api get-result) () | ||||
r16 | (if (not (equal "" (var result 0 :str))) | |||
(var result 0 :str) | ||||
(var result 0 :num))) | ||||
r1 | ||||
r21 | (defm (root api call-loc) (name args) | |||
r23 | (with-frame | |||
(funcall (ps:getprop (root locs) name) args))) | ||||
(defm (root api call-act) (title) | ||||
(with-frame | ||||
(funcall (ps:getprop (root acts) title)))) | ||||
r21 | ||||
r1 | ;;; Text windows | |||
r6 | (defm (root api key-to-id) (key) | |||
(case key | ||||
(:main "qsp-main") | ||||
(:stat "qsp-stat") | ||||
r11 | (:objs "qsp-objs") | |||
(:acts "qsp-acts") | ||||
(:input "qsp-input") | ||||
(:dropdown "qsp-dropdown") | ||||
r20 | (t (this.report-error "Internal error!")))) | |||
r6 | ||||
r11 | (defm (root api get-frame) (key) | |||
r15 | (document.get-element-by-id (this.key-to-id key))) | |||
r11 | ||||
r6 | (defm (root api add-text) (key text) | |||
r15 | (this.append-id (this.key-to-id key) text)) | |||
r6 | ||||
(defm (root api get-text) (key) | ||||
r15 | (this.get-id (this.key-to-id key))) | |||
r6 | ||||
(defm (root api clear-text) (key) | ||||
r15 | (this.clear-id (this.key-to-id key))) | |||
r6 | ||||
r11 | (defm (root api enable-frame) (key enable) | |||
r21 | (let ((obj (this.get-frame key))) | |||
(setf obj.style.display (if enable "block" "none")) | ||||
r11 | (values))) | |||
r1 | ;;; Actions | |||
r6 | (defm (root api add-act) (title img act) | |||
(setf (ps:getprop (root acts) title) | ||||
r11 | (ps:create :img img :act act)) | |||
r15 | (this.update-acts)) | |||
r6 | ||||
(defm (root api del-act) (title) | ||||
(delete (ps:getprop (root acts) title)) | ||||
r15 | (this.update-acts)) | |||
r6 | ||||
(defm (root api clear-act) () | ||||
(setf (root acts) (ps:create)) | ||||
r15 | (this.clear-id "qsp-acts")) | |||
r6 | ||||
(defm (root api update-acts) () | ||||
r15 | (this.clear-id "qsp-acts") | |||
r21 | (let ((elt (document.get-element-by-id "qsp-acts"))) | |||
(ps:for-in (title (root acts)) | ||||
(let ((obj (ps:getprop (root acts) title))) | ||||
r23 | (incf (ps:inner-html elt) (this.make-act-html title (ps:getprop obj :img))))))) | |||
r21 | ||||
r1 | ||||
r19 | ;;; "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))))) | ||||
r16 | ;;; 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 "")) | ||||
r1 | ||||
r16 | (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 | ||||
r6 | ||||
(defm (root api var-real-name) (name) | ||||
(if (= (ps:@ name 0) #\$) | ||||
r16 | (values (ps:chain name (substr 1)) :str) | |||
(values name :num))) | ||||
r6 | ||||
r16 | (defm (root api ensure-var) (name) | |||
r15 | (let ((store (this.var-ref name))) | |||
r14 | (unless store | |||
r16 | (setf store (ps:new (this.-var name))) | |||
(setf (ps:getprop (root vars) name) store)) | ||||
store)) | ||||
r6 | ||||
r14 | (defm (root api var-ref) (name) | |||
r16 | (let ((local-store (this.current-local-frame))) | |||
r21 | (cond ((and local-store (in name local-store)) | |||
r16 | (ps:getprop local-store name)) | |||
((in name (root vars)) | ||||
(ps:getprop (root vars) name)) | ||||
r14 | (t nil)))) | |||
r16 | (defm (root api get-var) (name index slot) | |||
(ps:chain (this.ensure-var name) (get index slot))) | ||||
r6 | ||||
r16 | (defm (root api set-var) (name index slot value) | |||
(ps:chain (this.ensure-var name) (set index slot value)) | ||||
(values)) | ||||
r6 | ||||
r14 | (defm (root api get-array) (name) | |||
r16 | (this.var-ref name)) | |||
r11 | ||||
r14 | (defm (root api set-array) (name value) | |||
r16 | (let ((store (this.var-ref name))) | |||
(setf (ps:@ store values) (ps:@ value values)) | ||||
(setf (ps:@ store indexes) (ps:@ value indexes))) | ||||
(values)) | ||||
r14 | ||||
(defm (root api kill-var) (name &optional index) | ||||
r16 | (if (and index (not (= 0 index))) | |||
(ps:chain (ps:getprop (root vars) name) (kill index)) | ||||
r14 | (ps:delete (ps:getprop (root vars) name))) | |||
r6 | (values)) | |||
r11 | (defm (root api array-size) (name) | |||
r16 | (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))) | ||||
r11 | ||||
r6 | ;;; Objects | |||
(defm (root api update-objs) () | ||||
(let ((elt (document.get-element-by-id "qsp-objs"))) | ||||
r23 | (setf (ps:inner-html elt) "<ul>") | |||
r6 | (loop :for obj :in (root objs) | |||
r23 | :do (incf (ps:inner-html elt) (+ "<li>" obj))) | |||
(incf (ps:inner-html elt) "</ul>"))) | ||||
r11 | ||||
;;; Menu | ||||
(defm (root api menu) (menu-data) | ||||
(let ((elt (document.get-element-by-id "qsp-dropdown")) | ||||
(i 0)) | ||||
r23 | (setf (ps:inner-html elt) "") | |||
r11 | (loop :for item :in menu-data | |||
:do (incf i) | ||||
r23 | :do (incf (ps:inner-html elt) (this.make-menu-item-html i item.text item.icon item.loc))) | |||
r11 | (setf elt.style.display "block"))) | |||
r12 | ||||
;;; 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))))) | ||||
r14 | ||||
r18 | (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))) | ||||
r20 | ||||
(defm (root api stash-state) (args) | ||||
r21 | (api-call call-serv-loc "ONGSAVE") | |||
r20 | (setf (root state-stash) | |||
(*j-s-o-n.stringify | ||||
(ps:create vars (root vars) | ||||
objs (root objs) | ||||
loc-args args | ||||
msecs (- (*date.now) (root started-at)) | ||||
r23 | main-html (ps:inner-html | |||
(document.get-element-by-id :qsp-main)) | ||||
stat-html (ps:inner-html | ||||
(document.get-element-by-id :qsp-stat)) | ||||
r20 | 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 started-at) (- (*date.now) (ps:@ data msecs))) | ||||
(setf (root objs) (ps:@ data objs)) | ||||
(setf (root current-location) (ps:@ data next-location)) | ||||
r23 | (setf (ps:inner-html (document.get-element-by-id :qsp-main)) | |||
r20 | (ps:@ data main-html)) | |||
r23 | (setf (ps:inner-html (document.get-element-by-id :qsp-stat)) | |||
r20 | (ps:@ data stat-html)) | |||
(this.update-objs) | ||||
r21 | (api-call call-serv-loc "ONGLOAD") | |||
(api-call call-loc (root current-location) (ps:@ data loc-args)) | ||||
r20 | (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)))) | ||||
;;; Timers | ||||
(defm (root api set-timer) (interval) | ||||
(setf (root timer-interval) interval) | ||||
(clear-interval (root timer-obj)) | ||||
(setf (root timer-obj) | ||||
(set-interval | ||||
(lambda () | ||||
(api-call call-serv-loc "COUNTER")) | ||||
interval))) | ||||