(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)
(+ ""
title
""))
(defm (root api make-menu-item-html) (num title img loc)
(+ ""
""
title
""))
(defm (root api report-error) (text)
(alert text))
(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"))))
(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))))))
;;; Misc
(defm (root api newline) (key)
(this.append-id (this.key-to-id key) "
" t))
(defm (root api clear-id) (id)
(setf (ps:inner-html (document.get-element-by-id id)) ""))
(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)
(ps:inner-html (root api text-escaper)))))
(defm (root api get-id) (id &optional force-html)
(ps:inner-html (document.get-element-by-id id)))
(defm (root api set-id) (id contents &optional force-html)
(setf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html)))
(defm (root api append-id) (id contents &optional force-html)
(when contents
(incf (ps:inner-html (document.get-element-by-id id)) (this.prepare-contents contents force-html))))
;;; 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)))
(defm (root api call-loc) (name args)
(with-frame
(funcall (ps:getprop (root locs) name) args)))
(defm (root api call-act) (title)
(with-frame
(funcall (ps:getprop (root acts) title))))
;;; 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 (this.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 enable-frame) (key enable)
(let ((obj (this.get-frame key)))
(setf obj.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")
(let ((elt (document.get-element-by-id "qsp-acts")))
(ps:for-in (title (root acts))
(let ((obj (ps:getprop (root acts) title)))
(incf (ps:inner-html elt) (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 ((and local-store (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 (ps:inner-html elt) "