api.ps
522 lines
| 14.9 KiB
| application/postscript
|
PostScriptLexer
/ src / api.ps
r1 | ||||
r53 | (in-package txt2web.api) | |||
r1 | ||||
;;; 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 | ||||
r6 | ;;; Utils | |||
r25 | (defun make-act-html (title img) | |||
r32 | (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>" | |||
r30 | (if img (+ "<img src='" img "'>") "") | |||
r6 | title | |||
"</a>")) | ||||
r25 | (defun make-menu-item-html (num title img loc) | |||
r32 | (+ "<a href='" (href-call finish-menu loc) "'>" | |||
r30 | (if img (+ "<img src='" img "'>") "") | |||
r11 | title | |||
"</a>")) | ||||
r32 | (defun make-obj (title img selected) | |||
r68 | (+ "<li onclick='" (inline-call select-obj title img) | |||
"' class='qsp-obj" (if selected " selected" "") "'>" | ||||
r32 | (if img (+ "<img src='" img "'>") "") | |||
r33 | title | |||
r68 | "</li>")) | |||
r32 | ||||
r30 | (defun make-menu-delimiter () | |||
"<hr>") | ||||
r41 | (defun copy-obj (obj) | |||
(chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj))))) | ||||
r25 | (defun report-error (text) | |||
r20 | (alert text)) | |||
r29 | (defun start-sleeping () | |||
r30 | (chain (by-id "qsp") class-list (add "disable"))) | |||
r29 | ||||
(defun finish-sleeping () | ||||
r30 | (chain (by-id "qsp") class-list (remove "disable"))) | |||
r29 | ||||
r25 | (defun sleep (msec) | |||
r30 | (with-sleep (resume) | |||
(set-timeout resume msec))) | ||||
r24 | ||||
r25 | (defun init-dom () | |||
r18 | ;; Save/load buttons | |||
r25 | (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) "#")) | ||||
r18 | ;; Close image on click | |||
r25 | (setf (@ (by-id "qsp-image-container") onclick) | |||
r32 | show-image) | |||
r33 | ;; Enter in input field | |||
r32 | (setf (@ (get-frame :input) onkeyup) | |||
on-input-key) | ||||
r18 | ;; Close the dropdown on any click | |||
r25 | (setf (@ window onclick) | |||
r18 | (lambda (event) | |||
r30 | (setf (@ window mouse) | |||
(list (@ event page-x) | ||||
(@ event page-y))) | ||||
(finish-menu nil)))) | ||||
r18 | ||||
r64 | (defun init-globals (game-name) | |||
(chain *object (assign *globals (getprop *default-globals game-name)))) | ||||
r25 | (defun call-serv-loc (var-name &rest args) | |||
r37 | (let ((loc-name (get-global var-name 0))) | |||
r20 | (when loc-name | |||
r66 | (let ((loc (getprop *locs (chain loc-name (to-upper-case))))) | |||
r20 | (when loc | |||
r32 | (call-loc loc-name args)))))) | |||
r11 | ||||
r31 | (defun filename-game (filename) | |||
(let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2)))) | ||||
r39 | (getprop *games game-name)) | |||
r31 | ||||
(defun run-game (name) | ||||
(let ((game (filename-game name))) | ||||
r39 | (setf *main-game name) | |||
r31 | ;; Replace locations with the new game's | |||
r39 | (setf *locs game) | |||
r31 | (funcall (getprop game | |||
(chain *object (keys game) 0)) | ||||
(list)))) | ||||
r9 | ;;; Misc | |||
r25 | (defun newline (key) | |||
(append-id (key-to-id key) "<br>" t)) | ||||
r22 | ||||
r25 | (defun clear-id (id) | |||
(setf (inner-html (by-id id)) "")) | ||||
r22 | ||||
r36 | (defun escape-html (text) | |||
(chain text | ||||
(replace (regex "/&/g") "&") | ||||
(replace (regex "/</g") "<") | ||||
(replace (regex "/>/g") ">") | ||||
(replace (regex "/\"/g") """) | ||||
(replace (regex "/'/g") "'"))) | ||||
r22 | ||||
r25 | (defun prepare-contents (s &optional force-html) | |||
r37 | (setf s (chain s (to-string))) | |||
(if (or force-html (get-global "USEHTML" 0)) | ||||
r22 | s | |||
r36 | (escape-html s))) | |||
r9 | ||||
r25 | (defun get-id (id &optional force-html) | |||
(inner-html (by-id id))) | ||||
r9 | ||||
r25 | (defun set-id (id contents &optional force-html) | |||
(setf (inner-html (by-id id)) (prepare-contents contents force-html))) | ||||
r9 | ||||
r25 | (defun append-id (id contents &optional force-html) | |||
r22 | (when contents | |||
r25 | (incf (inner-html (by-id id)) (prepare-contents contents force-html)))) | |||
r9 | ||||
r32 | (defun on-input-key (ev) | |||
(when (= 13 (@ ev key-code)) | ||||
(chain ev (prevent-default)) | ||||
r37 | (call-serv-loc "$USERCOM"))) | |||
r32 | ||||
r1 | ;;; Function calls | |||
r25 | (defun init-args (args) | |||
r64 | (dotimes (i 10) | |||
(set-global "ARGS" i 0) | ||||
(set-global "$ARGS" i "") | ||||
r65 | (when (and args (< i (length args))) | |||
r64 | (let ((arg (elt args i))) | |||
(if (numberp arg) | ||||
(set-global "ARGS" i arg) | ||||
(set-global "$ARGS" i arg)))))) | ||||
r1 | ||||
r25 | (defun get-result () | |||
r37 | (or (get-global "$RESULT" 0) | |||
(get-global "RESULT" 0))) | ||||
r1 | ||||
r25 | (defun call-loc (name args) | |||
r30 | (setf name (chain name (to-upper-case))) | |||
r23 | (with-frame | |||
r65 | (with-call-args args t | |||
(funcall (getprop *locs name))))) | ||||
r23 | ||||
r25 | (defun call-act (title) | |||
r41 | (with-frame | |||
(funcall (getprop *acts title :act))) | ||||
(void)) | ||||
r21 | ||||
r1 | ;;; Text windows | |||
r25 | (defun key-to-id (key) | |||
r6 | (case key | |||
r32 | (:all "qsp") | |||
r6 | (:main "qsp-main") | |||
(:stat "qsp-stat") | ||||
r11 | (:objs "qsp-objs") | |||
(:acts "qsp-acts") | ||||
(:input "qsp-input") | ||||
r30 | (:image "qsp-image") | |||
r11 | (:dropdown "qsp-dropdown") | |||
r25 | (t (report-error "Internal error!")))) | |||
r6 | ||||
r25 | (defun get-frame (key) | |||
(by-id (key-to-id key))) | ||||
r11 | ||||
r25 | (defun add-text (key text) | |||
(append-id (key-to-id key) text)) | ||||
r6 | ||||
r25 | (defun get-text (key) | |||
(get-id (key-to-id key))) | ||||
r6 | ||||
r25 | (defun clear-text (key) | |||
(clear-id (key-to-id key))) | ||||
r6 | ||||
r25 | (defun enable-frame (key enable) | |||
(let ((obj (get-frame key))) | ||||
(setf (@ obj style display) (if enable "block" "none")) | ||||
r27 | (void))) | |||
r11 | ||||
r1 | ;;; Actions | |||
r25 | (defun add-act (title img act) | |||
r39 | (setf (getprop *acts title) | |||
r32 | (create :title title :img img :act act :selected nil)) | |||
r25 | (update-acts)) | |||
r6 | ||||
r45 | (defun del-act (title) | |||
(delete (getprop *acts title)) | ||||
r25 | (update-acts)) | |||
r6 | ||||
r25 | (defun clear-act () | |||
r39 | (setf *acts (create)) | |||
r32 | (update-acts)) | |||
r6 | ||||
r25 | (defun update-acts () | |||
(clear-id "qsp-acts") | ||||
(let ((elt (by-id "qsp-acts"))) | ||||
r39 | (for-in (title *acts) | |||
(let ((obj (getprop *acts title))) | ||||
r25 | (incf (inner-html elt) (make-act-html title (getprop obj :img))))))) | |||
r32 | (defun select-act (title) | |||
r39 | (loop :for (k v) :of *acts | |||
r33 | :do (setf (getprop v :selected) nil)) | |||
r39 | (setf (getprop *acts title :selected) t) | |||
r37 | (call-serv-loc "$ONACTSEL")) | |||
r1 | ||||
r16 | ;;; Variables | |||
r6 | ||||
r38 | (defun new-var (slot &rest indexes) | |||
r37 | (let ((v (list))) | |||
r38 | (dolist (index indexes) | |||
r37 | (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0))) | |||
r38 | (setf (@ v :indexes) (create)) | |||
r37 | v)) | |||
r14 | ||||
r37 | (defun set-str-element (slot index value) | |||
r41 | (if (has index (getprop slot :indexes)) | |||
r66 | (setf (elt slot (getprop slot :indexes index)) | |||
r37 | value) | |||
(progn | ||||
(chain slot (push value)) | ||||
r66 | (setf (getprop slot :indexes index) | |||
(1- (length slot))))) | ||||
r42 | (void)) | |||
r6 | ||||
r37 | (defun set-any-element (slot index value) | |||
r42 | (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)) | ||||
r11 | ||||
r37 | (defun get-element (slot index) | |||
(if (numberp index) | ||||
(elt slot index) | ||||
(elt slot (getprop slot :indexes index)))) | ||||
r14 | ||||
r64 | (defun set-global (name index value) | |||
(set-any-element (getprop *globals name) index value)) | ||||
r37 | (defun get-global (name index) | |||
r64 | (get-element (getprop *globals name) index)) | |||
r37 | ||||
r64 | (defun kill-var (&optional name index) | |||
(cond (name | ||||
(setf name (chain name (to-upper-case))) | ||||
r66 | (cond ((and index (not (= 0 index))) | |||
(chain (getprop *globals name) (kill index))) | ||||
(t | ||||
(setf (getprop *globals name) (list)) | ||||
(setf (getprop *globals name "indexes") (create))))) | ||||
r64 | (t | |||
(setf *globals (create)) | ||||
(init-globals *main-game))) | ||||
r27 | (void)) | |||
r6 | ||||
r25 | (defun array-size (name) | |||
r32 | (@ (var-ref name) :values length)) | |||
r16 | ||||
;;; Locals | ||||
r25 | (defun push-local-frame () | |||
r39 | (chain *locals (push (create))) | |||
r27 | (void)) | |||
r16 | ||||
r25 | (defun pop-local-frame () | |||
r39 | (chain *locals (pop)) | |||
r27 | (void)) | |||
r16 | ||||
r25 | (defun current-local-frame () | |||
r39 | (elt *locals (1- (length *locals)))) | |||
r16 | ||||
r6 | ;;; Objects | |||
r32 | (defun select-obj (title img) | |||
r39 | (loop :for (k v) :of *objs | |||
r33 | :do (setf (getprop v :selected) nil)) | |||
r39 | (setf (getprop *objs title :selected) t) | |||
r37 | (call-serv-loc "$ONOBJSEL" title img)) | |||
r32 | ||||
r25 | (defun update-objs () | |||
r68 | (clear-id "qsp-objs") | |||
r25 | (let ((elt (by-id "qsp-objs"))) | |||
r39 | (loop :for (name obj) :of *objs | |||
r32 | :do (incf (inner-html elt) | |||
r68 | (make-obj name (@ obj :img) (@ obj :selected)))))) | |||
r11 | ||||
;;; Menu | ||||
r30 | (defun open-menu (menu-data) | |||
(let ((elt (get-frame :dropdown)) | ||||
r11 | (i 0)) | |||
(loop :for item :in menu-data | ||||
:do (incf i) | ||||
r30 | :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)))) | ||||
r25 | (setf (@ elt style display) "block"))) | |||
r12 | ||||
r30 | (defun finish-menu (loc) | |||
r39 | (when *menu-resume | |||
r30 | (let ((elt (get-frame :dropdown))) | |||
(setf (inner-html elt) "") | ||||
(setf (@ elt style display) "none") | ||||
r39 | (funcall *menu-resume) | |||
(setf *menu-resume nil)) | ||||
r30 | (when loc | |||
(call-loc loc))) | ||||
(void)) | ||||
(defun menu (menu-data) | ||||
(with-sleep (resume) | ||||
(open-menu menu-data) | ||||
r39 | (setf *menu-resume resume)) | |||
r30 | (void)) | |||
r12 | ;;; Content | |||
r25 | (defun clean-audio () | |||
r39 | (loop :for k :in (chain *object (keys *playing)) | |||
:for v := (getprop *playing k) | ||||
r25 | :do (when (@ v ended) | |||
r39 | (delete (@ *playing k))))) | |||
r14 | ||||
r25 | (defun show-image (path) | |||
r30 | (let ((img (get-frame :image))) | |||
r18 | (cond (path | |||
r25 | (setf (@ img src) path) | |||
(setf (@ img style display) "flex")) | ||||
r18 | (t | |||
r25 | (setf (@ img src) "") | |||
(setf (@ img style display) "hidden"))))) | ||||
r18 | ||||
r32 | (defun rgb-string (rgb) | |||
r33 | (let ((red (ps::>> rgb 16)) | |||
(green (logand (ps::>> rgb 8) 255)) | ||||
(blue (logand rgb 255))) | ||||
r32 | (flet ((rgb-to-hex (comp) | |||
(let ((hex (chain (*number comp) (to-string 16)))) | ||||
(if (< (length hex) 2) | ||||
(+ "0" hex) | ||||
hex)))) | ||||
r43 | (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex blue))))) | |||
r32 | ||||
r44 | (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)))) | ||||
r18 | ;;; Saves | |||
r44 | (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")) | ||||
r25 | (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) | ||||
r18 | (lambda (event) | |||
r25 | (let* ((file (@ event target files 0)) | |||
(reader (new (*file-reader)))) | ||||
(setf (@ reader onload) | ||||
r18 | (lambda (ev) | |||
(block nil | ||||
r25 | (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)))) | ||||
r18 | ||||
r25 | (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)))) | ||||
r20 | ||||
r25 | (defun stash-state (args) | |||
r37 | (call-serv-loc "$ONGSAVE") | |||
r39 | (setf *state-stash | |||
r25 | (chain *j-s-o-n (stringify | |||
r40 | (create :vars *globals | |||
r39 | :objs *objs | |||
r27 | :loc-args args | |||
r39 | :msecs (- (chain *date (now)) *started-at) | |||
:timer-interval *timer-interval | ||||
r27 | :main-html (inner-html | |||
r30 | (get-frame :main)) | |||
r27 | :stat-html (inner-html | |||
r30 | (get-frame :stat)) | |||
r39 | :next-location *current-location)))) | |||
r27 | (void)) | |||
r20 | ||||
r25 | (defun unstash-state () | |||
r39 | (let ((data (chain *j-s-o-n (parse *state-stash)))) | |||
r25 | (clear-act) | |||
r40 | (setf *globals (@ data :vars)) | |||
(loop :for k :in (chain *object (keys *globals)) | ||||
:do (chain *object (set-prototype-of (getprop *globals k) | ||||
r25 | (@ *var prototype)))) | |||
r39 | (setf *started-at (- (chain *date (now)) (@ data :msecs))) | |||
(setf *objs (@ data :objs)) | ||||
(setf *current-location (@ data :next-location)) | ||||
r30 | (setf (inner-html (get-frame :main)) | |||
r27 | (@ data :main-html)) | |||
r30 | (setf (inner-html (get-frame :stat)) | |||
r27 | (@ data :stat-html)) | |||
r25 | (update-objs) | |||
r27 | (set-timer (@ data :timer-interval)) | |||
r37 | (call-serv-loc "$ONGLOAD") | |||
r39 | (call-loc *current-location (@ data :loc-args)) | |||
r27 | (void))) | |||
r20 | ||||
r25 | (defun state-to-base64 () | |||
r39 | (btoa (encode-u-r-i-component *state-stash))) | |||
r20 | ||||
r25 | (defun base64-to-state (data) | |||
r39 | (setf *state-stash (decode-u-r-i-component (atob data)))) | |||
r20 | ||||
;;; Timers | ||||
r25 | (defun set-timer (interval) | |||
r39 | (setf *timer-interval interval) | |||
(clear-interval *timer-obj) | ||||
(setf *timer-obj | ||||
r20 | (set-interval | |||
(lambda () | ||||
r37 | (call-serv-loc "$COUNTER")) | |||
r20 | interval))) | |||
r32 | ||||
;;; Special variables | ||||
r33 | (defvar serv-vars (create)) | |||
r42 | (define-serv-var $backimage (path) | |||
r32 | (setf (@ (get-frame :main) style background-image) path)) | |||
r42 | (define-serv-var bcolor (color) | |||
r32 | (setf (@ (get-frame :all) style background-color) (rgb-string color))) | |||
r42 | (define-serv-var fcolor (color) | |||
r32 | (setf (@ (get-frame :all) style color) (rgb-string color))) | |||
r42 | (define-serv-var lcolor (color) | |||
r32 | (setf (@ (get-frame :style) inner-text) | |||
(+ "a { color: " (rgb-string color) ";}"))) | ||||
r33 | ||||
r42 | (define-serv-var fsize (size) | |||
r33 | (setf (@ (get-frame :all) style font-size) size)) | |||
r42 | (define-serv-var $fname (font-name) | |||
r33 | (setf (@ (get-frame :all) style font-family) (+ font-name ",serif"))) | |||