|
|
|
|
|
(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='" (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 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-var var-name 0 :str)))
|
|
|
(when loc-name
|
|
|
(let ((loc (getprop (root 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 (root games) game-name))
|
|
|
|
|
|
(defun run-game (name)
|
|
|
(let ((game (filename-game name)))
|
|
|
(setf (root main-game) name)
|
|
|
;; Replace locations with the new game's
|
|
|
(setf (root 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)) ""))
|
|
|
|
|
|
(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))))
|
|
|
|
|
|
(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 ()
|
|
|
(if (not (equal "" (get-var "RESULT" 0 :str)))
|
|
|
(get-var "RESULT" 0 :str)
|
|
|
(get-var "RESULT" 0 :num)))
|
|
|
|
|
|
(defun call-loc (name args)
|
|
|
(setf name (chain name (to-upper-case)))
|
|
|
(with-frame
|
|
|
(with-call-args args
|
|
|
(funcall (getprop (root locs) name)))))
|
|
|
|
|
|
(defun call-act (title)
|
|
|
(with-frame
|
|
|
(funcall (getprop (root acts) title :act))))
|
|
|
|
|
|
;;; 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 (root acts) title)
|
|
|
(create :title title :img img :act act :selected nil))
|
|
|
(update-acts))
|
|
|
|
|
|
(defun del-act (title)
|
|
|
(delete (getprop (root acts) title))
|
|
|
(update-acts))
|
|
|
|
|
|
(defun clear-act ()
|
|
|
(setf (root acts) (create))
|
|
|
(update-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)))))))
|
|
|
|
|
|
(defun select-act (title)
|
|
|
(loop :for (k v) :of (root acts)
|
|
|
:do (setf (getprop v :selected) nil))
|
|
|
(setf (getprop (root acts) title :selected) t)
|
|
|
(call-serv-loc "ONACTSEL"))
|
|
|
|
|
|
;;; "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))
|
|
|
(void))
|
|
|
|
|
|
(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)
|
|
|
(void)))
|
|
|
|
|
|
(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)
|
|
|
(setf name (chain name (to-upper-case)))
|
|
|
(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))
|
|
|
(let ((serv-var (getprop serv-vars name)))
|
|
|
(when serv-var
|
|
|
(funcall (@ serv-var :body)
|
|
|
(get-var name index (@ serv-var :slot))
|
|
|
index)))
|
|
|
(void))
|
|
|
|
|
|
(defun get-array (name)
|
|
|
(setf name (chain name (to-upper-case)))
|
|
|
(ensure-var name))
|
|
|
|
|
|
(defun set-array (name value)
|
|
|
(setf name (chain name (to-upper-case)))
|
|
|
(let ((store (ensure-var name)))
|
|
|
(setf (@ store :values) (@ value :values))
|
|
|
(setf (@ store :indexes) (@ value :indexes)))
|
|
|
(void))
|
|
|
|
|
|
(defun kill-var (name &optional index)
|
|
|
(setf name (chain name (to-upper-case)))
|
|
|
(if (and index (not (= 0 index)))
|
|
|
(chain (getprop (root vars) name) (kill index))
|
|
|
(delete (getprop (root vars) name)))
|
|
|
(void))
|
|
|
|
|
|
(defun array-size (name)
|
|
|
(@ (var-ref name) :values length))
|
|
|
|
|
|
;;; Locals
|
|
|
|
|
|
(defun push-local-frame ()
|
|
|
(chain (root locals) (push (create)))
|
|
|
(void))
|
|
|
|
|
|
(defun pop-local-frame ()
|
|
|
(chain (root locals) (pop))
|
|
|
(void))
|
|
|
|
|
|
(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)))
|
|
|
(void)))
|
|
|
|
|
|
;;; Objects
|
|
|
|
|
|
(defun select-obj (title img)
|
|
|
(loop :for (k v) :of (root objs)
|
|
|
:do (setf (getprop v :selected) nil))
|
|
|
(setf (getprop (root 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 (root 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 (root menu-resume)
|
|
|
(let ((elt (get-frame :dropdown)))
|
|
|
(setf (inner-html elt) "")
|
|
|
(setf (@ elt style display) "none")
|
|
|
(funcall (root menu-resume))
|
|
|
(setf (root menu-resume) nil))
|
|
|
(when loc
|
|
|
(call-loc loc)))
|
|
|
(void))
|
|
|
|
|
|
(defun menu (menu-data)
|
|
|
(with-sleep (resume)
|
|
|
(open-menu menu-data)
|
|
|
(setf (root menu-resume) resume))
|
|
|
(void))
|
|
|
|
|
|
;;; 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 (get-frame :image)))
|
|
|
(cond (path
|
|
|
(setf (@ img src) path)
|
|
|
(setf (@ img style display) "flex"))
|
|
|
(t
|
|
|
(setf (@ img src) "")
|
|
|
(setf (@ img style display) "hidden")))))
|
|
|
|
|
|
(defun show-inline-images (frame-name images)
|
|
|
(let ((frame (get-frame frame-name))
|
|
|
(text ""))
|
|
|
(incf text "<div style='position:relative; display: inline-block'>")
|
|
|
(incf text (+ "<img src='" (@ images 0) "'>"))
|
|
|
(loop :for image :in (chain images (slice 1))
|
|
|
:do (incf text
|
|
|
(+ "<img style='position:absolute' src='" image "'>")))
|
|
|
(incf text "</div>")
|
|
|
(incf (inner-html frame) text)))
|
|
|
|
|
|
(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 red)))))
|
|
|
|
|
|
;;; 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))
|
|
|
:timer-interval (root timer-interval)
|
|
|
:main-html (inner-html
|
|
|
(get-frame :main))
|
|
|
:stat-html (inner-html
|
|
|
(get-frame :stat))
|
|
|
:next-location (root current-location)))))
|
|
|
(void))
|
|
|
|
|
|
(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 (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 (root current-location) (@ data :loc-args))
|
|
|
(void)))
|
|
|
|
|
|
(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)))
|
|
|
|
|
|
;;; Special variables
|
|
|
|
|
|
(defvar serv-vars (create))
|
|
|
|
|
|
(define-serv-var backimage (:str path)
|
|
|
(setf (@ (get-frame :main) style background-image) path))
|
|
|
|
|
|
(define-serv-var bcolor (:num color)
|
|
|
(setf (@ (get-frame :all) style background-color) (rgb-string color)))
|
|
|
|
|
|
(define-serv-var fcolor (:num color)
|
|
|
(setf (@ (get-frame :all) style color) (rgb-string color)))
|
|
|
|
|
|
(define-serv-var lcolor (:num color)
|
|
|
(setf (@ (get-frame :style) inner-text)
|
|
|
(+ "a { color: " (rgb-string color) ";}")))
|
|
|
|
|
|
(define-serv-var fsize (:num size)
|
|
|
(setf (@ (get-frame :all) style font-size) size))
|
|
|
|
|
|
(define-serv-var fname (:str font-name)
|
|
|
(setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))
|
|
|
|
