|
|
|
|
|
(in-package txt2web.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='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
|
|
|
(if img (+ "<img src='" img "'>") "")
|
|
|
title
|
|
|
"</a>"))
|
|
|
|
|
|
(defun make-menu-item-html (num title img loc)
|
|
|
(+ "<a href='" (href-call finish-menu loc) "'>"
|
|
|
(if img (+ "<img src='" img "'>") "")
|
|
|
title
|
|
|
"</a>"))
|
|
|
|
|
|
(defun make-obj (title img selected)
|
|
|
(+ "<li onclick='" (inline-call select-obj title img) "'>"
|
|
|
"<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
|
|
|
(if img (+ "<img src='" img "'>") "")
|
|
|
title
|
|
|
"</a>"))
|
|
|
|
|
|
(defun make-menu-delimiter ()
|
|
|
"<hr>")
|
|
|
|
|
|
(defun copy-obj (obj)
|
|
|
(chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj)))))
|
|
|
|
|
|
(defun report-error (text)
|
|
|
(alert text))
|
|
|
|
|
|
(defun start-sleeping ()
|
|
|
(chain (by-id "qsp") class-list (add "disable")))
|
|
|
|
|
|
(defun finish-sleeping ()
|
|
|
(chain (by-id "qsp") class-list (remove "disable")))
|
|
|
|
|
|
(defun sleep (msec)
|
|
|
(with-sleep (resume)
|
|
|
(set-timeout resume 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)
|
|
|
;; Enter in input field
|
|
|
(setf (@ (get-frame :input) onkeyup)
|
|
|
on-input-key)
|
|
|
;; Close the dropdown on any click
|
|
|
(setf (@ window onclick)
|
|
|
(lambda (event)
|
|
|
(setf (@ window mouse)
|
|
|
(list (@ event page-x)
|
|
|
(@ event page-y)))
|
|
|
(finish-menu nil))))
|
|
|
|
|
|
(defun call-serv-loc (var-name &rest args)
|
|
|
(let ((loc-name (get-global var-name 0)))
|
|
|
(when loc-name
|
|
|
(let ((loc (getprop *locs loc-name)))
|
|
|
(when loc
|
|
|
(call-loc loc-name args))))))
|
|
|
|
|
|
(defun filename-game (filename)
|
|
|
(let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2))))
|
|
|
(getprop *games game-name))
|
|
|
|
|
|
(defun run-game (name)
|
|
|
(let ((game (filename-game name)))
|
|
|
(setf *main-game name)
|
|
|
;; Replace locations with the new game's
|
|
|
(setf *locs game)
|
|
|
(funcall (getprop game
|
|
|
(chain *object (keys game) 0))
|
|
|
(list))))
|
|
|
|
|
|
;;; Misc
|
|
|
|
|
|
(defun newline (key)
|
|
|
(append-id (key-to-id key) "<br>" t))
|
|
|
|
|
|
(defun clear-id (id)
|
|
|
(setf (inner-html (by-id id)) ""))
|
|
|
|
|
|
(defun escape-html (text)
|
|
|
(chain text
|
|
|
(replace (regex "/&/g") "&")
|
|
|
(replace (regex "/</g") "<")
|
|
|
(replace (regex "/>/g") ">")
|
|
|
(replace (regex "/\"/g") """)
|
|
|
(replace (regex "/'/g") "'")))
|
|
|
|
|
|
(defun prepare-contents (s &optional force-html)
|
|
|
(setf s (chain s (to-string)))
|
|
|
(if (or force-html (get-global "USEHTML" 0))
|
|
|
s
|
|
|
(escape-html s)))
|
|
|
|
|
|
(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))))
|
|
|
|
|
|
(defun on-input-key (ev)
|
|
|
(when (= 13 (@ ev key-code))
|
|
|
(chain ev (prevent-default))
|
|
|
(call-serv-loc "$USERCOM")))
|
|
|
|
|
|
;;; 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 ()
|
|
|
(or (get-global "$RESULT" 0)
|
|
|
(get-global "RESULT" 0)))
|
|
|
|
|
|
(defun call-loc (name args)
|
|
|
(setf name (chain name (to-upper-case)))
|
|
|
(with-frame
|
|
|
(with-call-args args
|
|
|
(funcall (getprop *locs name))))
|
|
|
(void))
|
|
|
|
|
|
(defun call-act (title)
|
|
|
(with-frame
|
|
|
(funcall (getprop *acts title :act)))
|
|
|
(void))
|
|
|
|
|
|
;;; Text windows
|
|
|
|
|
|
(defun key-to-id (key)
|
|
|
(case key
|
|
|
(:all "qsp")
|
|
|
(:main "qsp-main")
|
|
|
(:stat "qsp-stat")
|
|
|
(:objs "qsp-objs")
|
|
|
(:acts "qsp-acts")
|
|
|
(:input "qsp-input")
|
|
|
(:image "qsp-image")
|
|
|
(: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"))
|
|
|
(void)))
|
|
|
|
|
|
;;; Actions
|
|
|
|
|
|
(defun add-act (title img act)
|
|
|
(setf (getprop *acts title)
|
|
|
(create :title title :img img :act act :selected nil))
|
|
|
(update-acts))
|
|
|
|
|
|
(defun del-act (title)
|
|
|
(delete (getprop *acts title))
|
|
|
(update-acts))
|
|
|
|
|
|
(defun clear-act ()
|
|
|
(setf *acts (create))
|
|
|
(update-acts))
|
|
|
|
|
|
(defun update-acts ()
|
|
|
(clear-id "qsp-acts")
|
|
|
(let ((elt (by-id "qsp-acts")))
|
|
|
(for-in (title *acts)
|
|
|
(let ((obj (getprop *acts title)))
|
|
|
(incf (inner-html elt) (make-act-html title (getprop obj :img)))))))
|
|
|
|
|
|
(defun select-act (title)
|
|
|
(loop :for (k v) :of *acts
|
|
|
:do (setf (getprop v :selected) nil))
|
|
|
(setf (getprop *acts title :selected) t)
|
|
|
(call-serv-loc "$ONACTSEL"))
|
|
|
|
|
|
;;; Variables
|
|
|
|
|
|
(defun new-var (slot &rest indexes)
|
|
|
(let ((v (list)))
|
|
|
(dolist (index indexes)
|
|
|
(setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
|
|
|
(setf (@ v :indexes) (create))
|
|
|
v))
|
|
|
|
|
|
(defun set-str-element (slot index value)
|
|
|
(if (has index (getprop slot :indexes))
|
|
|
(setf (elt (getprop slot)
|
|
|
(getprop slot :indexes index))
|
|
|
value)
|
|
|
(progn
|
|
|
(chain slot (push value))
|
|
|
(setf (elt slot index)
|
|
|
(length slot))))
|
|
|
(void))
|
|
|
|
|
|
(defun set-any-element (slot index value)
|
|
|
(cond ((null index)
|
|
|
(chain (elt slot) (push value)))
|
|
|
((numberp index)
|
|
|
(setf (elt slot index) value))
|
|
|
((stringp index)
|
|
|
(set-str-element slot index value))
|
|
|
(t (report-error "INTERNAL ERROR")))
|
|
|
(void))
|
|
|
|
|
|
(defun set-serv-var (name index value)
|
|
|
(let ((slot (getprop *globals name)))
|
|
|
(set-any-element slot index value))
|
|
|
(funcall (getprop serv-vars name :body) value index)
|
|
|
(void))
|
|
|
|
|
|
(defun get-element (slot index)
|
|
|
(if (numberp index)
|
|
|
(elt slot index)
|
|
|
(elt slot (getprop slot :indexes index))))
|
|
|
|
|
|
(defun get-global (name index)
|
|
|
(elt (getprop *globals name) index))
|
|
|
|
|
|
(defun kill-var (store name &optional index)
|
|
|
(setf name (chain name (to-upper-case)))
|
|
|
(if (and index (not (= 0 index)))
|
|
|
(chain (getprop *globals name) (kill index))
|
|
|
(delete (getprop *globals name)))
|
|
|
(void))
|
|
|
|
|
|
(defun array-size (name)
|
|
|
(@ (var-ref name) :values length))
|
|
|
|
|
|
;;; Locals
|
|
|
|
|
|
(defun push-local-frame ()
|
|
|
(chain *locals (push (create)))
|
|
|
(void))
|
|
|
|
|
|
(defun pop-local-frame ()
|
|
|
(chain *locals (pop))
|
|
|
(void))
|
|
|
|
|
|
(defun current-local-frame ()
|
|
|
(elt *locals (1- (length *locals))))
|
|
|
|
|
|
;;; Objects
|
|
|
|
|
|
(defun select-obj (title img)
|
|
|
(loop :for (k v) :of *objs
|
|
|
:do (setf (getprop v :selected) nil))
|
|
|
(setf (getprop *objs title :selected) t)
|
|
|
(call-serv-loc "$ONOBJSEL" title img))
|
|
|
|
|
|
(defun update-objs ()
|
|
|
(let ((elt (by-id "qsp-objs")))
|
|
|
(setf (inner-html elt) "<ul>")
|
|
|
(loop :for (name obj) :of *objs
|
|
|
:do (incf (inner-html elt)
|
|
|
(make-obj name (@ obj :img) (@ obj :selected))))
|
|
|
(incf (inner-html elt) "</ul>")))
|
|
|
|
|
|
;;; Menu
|
|
|
|
|
|
(defun open-menu (menu-data)
|
|
|
(let ((elt (get-frame :dropdown))
|
|
|
(i 0))
|
|
|
(loop :for item :in menu-data
|
|
|
:do (incf i)
|
|
|
:do (incf (inner-html elt)
|
|
|
(if (eq item :delimiter)
|
|
|
(make-menu-delimiter i)
|
|
|
(make-menu-item-html i
|
|
|
(@ item :text)
|
|
|
(@ item :icon)
|
|
|
(@ item :loc)))))
|
|
|
(let ((mouse (@ window mouse)))
|
|
|
(setf (@ elt style left) (+ (elt mouse 0) "px"))
|
|
|
(setf (@ elt style top) (+ (elt mouse 1) "px"))
|
|
|
;; Make sure it's inside the viewport
|
|
|
(when (> (@ document body inner-width)
|
|
|
(+ (elt mouse 0) (@ elt inner-width)))
|
|
|
(incf (@ elt style left) (@ elt inner-width)))
|
|
|
(when (> (@ document body inner-height)
|
|
|
(+ (elt mouse 0) (@ elt inner-height)))
|
|
|
(incf (@ elt style top) (@ elt inner-height))))
|
|
|
(setf (@ elt style display) "block")))
|
|
|
|
|
|
(defun finish-menu (loc)
|
|
|
(when *menu-resume
|
|
|
(let ((elt (get-frame :dropdown)))
|
|
|
(setf (inner-html elt) "")
|
|
|
(setf (@ elt style display) "none")
|
|
|
(funcall *menu-resume)
|
|
|
(setf *menu-resume nil))
|
|
|
(when loc
|
|
|
(call-loc loc)))
|
|
|
(void))
|
|
|
|
|
|
(defun menu (menu-data)
|
|
|
(with-sleep (resume)
|
|
|
(open-menu menu-data)
|
|
|
(setf *menu-resume resume))
|
|
|
(void))
|
|
|
|
|
|
;;; Content
|
|
|
|
|
|
(defun clean-audio ()
|
|
|
(loop :for k :in (chain *object (keys *playing))
|
|
|
:for v := (getprop *playing k)
|
|
|
:do (when (@ v ended)
|
|
|
(delete (@ *playing k)))))
|
|
|
|
|
|
(defun show-image (path)
|
|
|
(let ((img (get-frame :image)))
|
|
|
(cond (path
|
|
|
(setf (@ img src) path)
|
|
|
(setf (@ img style display) "flex"))
|
|
|
(t
|
|
|
(setf (@ img src) "")
|
|
|
(setf (@ img style display) "hidden")))))
|
|
|
|
|
|
(defun rgb-string (rgb)
|
|
|
(let ((red (ps::>> rgb 16))
|
|
|
(green (logand (ps::>> rgb 8) 255))
|
|
|
(blue (logand rgb 255)))
|
|
|
(flet ((rgb-to-hex (comp)
|
|
|
(let ((hex (chain (*number comp) (to-string 16))))
|
|
|
(if (< (length hex) 2)
|
|
|
(+ "0" hex)
|
|
|
hex))))
|
|
|
(+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue)))))
|
|
|
|
|
|
(defun store-obj (key obj)
|
|
|
(store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj)))))
|
|
|
(void))
|
|
|
(defun store-str (key str)
|
|
|
(chain local-storage (set-item (+ "qsp_" key) str))
|
|
|
(void))
|
|
|
|
|
|
(defun load-obj (key)
|
|
|
(chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key))))))
|
|
|
(defun load-str (key)
|
|
|
(chain local-storage (get-item (+ "qsp_" key))))
|
|
|
|
|
|
;;; Saves
|
|
|
|
|
|
(defun slot-savegame (slot comment)
|
|
|
(let ((saves (load-obj "saves")))
|
|
|
(setf (@ saves slot) comment)
|
|
|
(store-obj saves))
|
|
|
(store-str slot (state-to-base64))
|
|
|
(void))
|
|
|
|
|
|
(defun slot-loadgame (slot)
|
|
|
(base64-to-state (load-str slot))
|
|
|
(void))
|
|
|
|
|
|
(defun slot-deletegame (slot)
|
|
|
(let ((saves (load-obj "saves")))
|
|
|
(setf (@ saves slot) undefined)
|
|
|
(store-obj saves))
|
|
|
(store-str slot undefined)
|
|
|
(void))
|
|
|
|
|
|
(defun slot-listgames ()
|
|
|
(load-obj "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 *state-stash
|
|
|
(chain *j-s-o-n (stringify
|
|
|
(create :vars *globals
|
|
|
:objs *objs
|
|
|
:loc-args args
|
|
|
:msecs (- (chain *date (now)) *started-at)
|
|
|
:timer-interval *timer-interval
|
|
|
:main-html (inner-html
|
|
|
(get-frame :main))
|
|
|
:stat-html (inner-html
|
|
|
(get-frame :stat))
|
|
|
:next-location *current-location))))
|
|
|
(void))
|
|
|
|
|
|
(defun unstash-state ()
|
|
|
(let ((data (chain *j-s-o-n (parse *state-stash))))
|
|
|
(clear-act)
|
|
|
(setf *globals (@ data :vars))
|
|
|
(loop :for k :in (chain *object (keys *globals))
|
|
|
:do (chain *object (set-prototype-of (getprop *globals k)
|
|
|
(@ *var prototype))))
|
|
|
(setf *started-at (- (chain *date (now)) (@ data :msecs)))
|
|
|
(setf *objs (@ data :objs))
|
|
|
(setf *current-location (@ data :next-location))
|
|
|
(setf (inner-html (get-frame :main))
|
|
|
(@ data :main-html))
|
|
|
(setf (inner-html (get-frame :stat))
|
|
|
(@ data :stat-html))
|
|
|
(update-objs)
|
|
|
(set-timer (@ data :timer-interval))
|
|
|
(call-serv-loc "$ONGLOAD")
|
|
|
(call-loc *current-location (@ data :loc-args))
|
|
|
(void)))
|
|
|
|
|
|
(defun state-to-base64 ()
|
|
|
(btoa (encode-u-r-i-component *state-stash)))
|
|
|
|
|
|
(defun base64-to-state (data)
|
|
|
(setf *state-stash (decode-u-r-i-component (atob data))))
|
|
|
|
|
|
;;; Timers
|
|
|
|
|
|
(defun set-timer (interval)
|
|
|
(setf *timer-interval interval)
|
|
|
(clear-interval *timer-obj)
|
|
|
(setf *timer-obj
|
|
|
(set-interval
|
|
|
(lambda ()
|
|
|
(call-serv-loc "$COUNTER"))
|
|
|
interval)))
|
|
|
|
|
|
;;; Special variables
|
|
|
|
|
|
(defvar serv-vars (create))
|
|
|
|
|
|
(define-serv-var $backimage (path)
|
|
|
(setf (@ (get-frame :main) style background-image) path))
|
|
|
|
|
|
(define-serv-var bcolor (color)
|
|
|
(setf (@ (get-frame :all) style background-color) (rgb-string color)))
|
|
|
|
|
|
(define-serv-var fcolor (color)
|
|
|
(setf (@ (get-frame :all) style color) (rgb-string color)))
|
|
|
|
|
|
(define-serv-var lcolor (color)
|
|
|
(setf (@ (get-frame :style) inner-text)
|
|
|
(+ "a { color: " (rgb-string color) ";}")))
|
|
|
|
|
|
(define-serv-var fsize (size)
|
|
|
(setf (@ (get-frame :all) style font-size) size))
|
|
|
|
|
|
(define-serv-var $fname (font-name)
|
|
|
(setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))
|
|
|
|