|
|
|
|
|
(in-package txt2web.lib)
|
|
|
|
|
|
;;;; Functions and procedures defined by the QSP language.
|
|
|
;;;; They can call api and deal with locations and other data directly.
|
|
|
;;;; Except vars. Use VAR and SET or GET-VAR and SET-VAR api calls.
|
|
|
|
|
|
;;; 1loc
|
|
|
|
|
|
(defun goto (target args)
|
|
|
(api:clear-text :main)
|
|
|
(funcall xgoto target args)
|
|
|
(void))
|
|
|
|
|
|
(defun xgoto (target args)
|
|
|
(setf args (or args (list)))
|
|
|
(api:clear-act)
|
|
|
(setf *current-location (chain target (to-upper-case)))
|
|
|
(api:stash-state args)
|
|
|
(api:call-loc *current-location args)
|
|
|
(api:call-serv-loc "$ONNEWLOC")
|
|
|
(void))
|
|
|
|
|
|
;;; 2var
|
|
|
|
|
|
;;; 3expr
|
|
|
|
|
|
(defun obj (name)
|
|
|
(has name *objs))
|
|
|
|
|
|
(defun loc (name)
|
|
|
(has name *locs))
|
|
|
|
|
|
;;; 4code
|
|
|
|
|
|
(defun rand (a &optional (b 1))
|
|
|
(let ((min (min a b))
|
|
|
(max (max a b)))
|
|
|
(+ min (chain *math (random (- max min))))))
|
|
|
|
|
|
;;; 5arrays
|
|
|
|
|
|
(defun copyarr (to from start count)
|
|
|
(multiple-value-bind (to-name to-slot)
|
|
|
(api:var-real-name to)
|
|
|
(multiple-value-bind (from-name from-slot)
|
|
|
(api:var-real-name from)
|
|
|
(loop :for i :from start :to (min (api:array-size from-name)
|
|
|
(+ start count))
|
|
|
:do (api:set-var to-name (+ start i) to-slot
|
|
|
(api:get-var from-name (+ start i) from-slot))))))
|
|
|
|
|
|
(defun arrpos (name value &optional (start 0))
|
|
|
(multiple-value-bind (real-name slot)
|
|
|
(api:var-real-name name)
|
|
|
(loop :for i :from start :to (api:array-size name)
|
|
|
:do (when (eq (api:get-var real-name i slot) value)
|
|
|
(return-from arrpos i))))
|
|
|
-1)
|
|
|
|
|
|
(defun arrcomp (name pattern &optional (start 0))
|
|
|
(multiple-value-bind (real-name slot)
|
|
|
(api:var-real-name name)
|
|
|
(loop :for i :from start :to (api:array-size name)
|
|
|
:do (when (funcall (getprop (api:get-var real-name i slot)
|
|
|
'match)
|
|
|
pattern)
|
|
|
(return-from arrcomp i))))
|
|
|
-1)
|
|
|
|
|
|
;;; 6str
|
|
|
|
|
|
(defun instr (s subs &optional (start 1))
|
|
|
(+ start (chain s (substring (- start 1)) (search subs))))
|
|
|
|
|
|
(defun isnum (s)
|
|
|
(if (is-na-n s)
|
|
|
0
|
|
|
-1))
|
|
|
|
|
|
(defun strcomp (s pattern)
|
|
|
(if (chain s (match pattern))
|
|
|
-1
|
|
|
0))
|
|
|
|
|
|
(defun strfind (s pattern group)
|
|
|
(let* ((re (new (*reg-exp pattern)))
|
|
|
(match (chain re (exec s))))
|
|
|
(chain match (group group))))
|
|
|
|
|
|
(defun strpos (s pattern &optional (group 0))
|
|
|
(let* ((re (new (*reg-exp pattern)))
|
|
|
(match (chain re (exec s)))
|
|
|
(found (chain match (group group))))
|
|
|
(if found
|
|
|
(chain s (search found))
|
|
|
0)))
|
|
|
|
|
|
;;; 7if
|
|
|
|
|
|
;; Has to be a function because it always evaluates all three of its
|
|
|
;; arguments
|
|
|
(defun iif (cond-expr then-expr else-expr)
|
|
|
(if cond-expr then-expr else-expr))
|
|
|
|
|
|
;;; 8sub
|
|
|
|
|
|
(defun gosub (target &rest args)
|
|
|
(api:call-loc target args)
|
|
|
(void))
|
|
|
|
|
|
(defun func (target &rest args)
|
|
|
(api:call-loc target args))
|
|
|
|
|
|
;;; 9loops
|
|
|
|
|
|
;;; 10dynamic
|
|
|
|
|
|
(defun dynamic (block &rest args)
|
|
|
(when (stringp block)
|
|
|
(api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC."))
|
|
|
(api:with-call-args args nil
|
|
|
(funcall block)))
|
|
|
|
|
|
(defun dyneval (block &rest args)
|
|
|
(when (stringp block)
|
|
|
(api:report-error "DYNEVAL can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL."))
|
|
|
(api:with-call-args args t
|
|
|
(funcall block)))
|
|
|
|
|
|
;;; 11main
|
|
|
|
|
|
(defun main-p (s)
|
|
|
(api:add-text :main s)
|
|
|
(void))
|
|
|
|
|
|
(defun main-pl (s)
|
|
|
(api:add-text :main s)
|
|
|
(api:newline :main)
|
|
|
(void))
|
|
|
|
|
|
(defun main-nl (s)
|
|
|
(api:newline :main)
|
|
|
(api:add-text :main s)
|
|
|
(void))
|
|
|
|
|
|
(defun maintxt ()
|
|
|
(api:get-text :main))
|
|
|
|
|
|
(defun desc ()
|
|
|
"")
|
|
|
|
|
|
(defun main-clear ()
|
|
|
(api:clear-text :main)
|
|
|
(void))
|
|
|
|
|
|
;;; 12stat
|
|
|
|
|
|
(defun stat-p (s)
|
|
|
(api:add-text :stat s)
|
|
|
(void))
|
|
|
|
|
|
(defun stat-pl (s)
|
|
|
(api:add-text :stat s)
|
|
|
(api:newline :stat)
|
|
|
(void))
|
|
|
|
|
|
(defun stat-nl (s)
|
|
|
(api:newline :stat)
|
|
|
(api:add-text :stat s)
|
|
|
(void))
|
|
|
|
|
|
(defun stattxt ()
|
|
|
(api:get-text :stat))
|
|
|
|
|
|
(defun stat-clear ()
|
|
|
(api:clear-text :stat)
|
|
|
(void))
|
|
|
|
|
|
(defun cls ()
|
|
|
(stat-clear)
|
|
|
(main-clear)
|
|
|
(cla)
|
|
|
(cmdclear)
|
|
|
(void))
|
|
|
|
|
|
;;; 13diag
|
|
|
|
|
|
;;; 14act
|
|
|
|
|
|
(defun selact ()
|
|
|
(loop :for (k v) :of *acts
|
|
|
:do (when (@ v :selected)
|
|
|
(return-from selact (@ v :name)))))
|
|
|
|
|
|
(defun curacts ()
|
|
|
(let ((acts (chain *object (assign (create) *acts))))
|
|
|
(lambda ()
|
|
|
(setf *acts acts)
|
|
|
(api:update-acts)
|
|
|
(void))))
|
|
|
|
|
|
;;; 15objs
|
|
|
|
|
|
(defun addobj (name img)
|
|
|
(setf img (or img ""))
|
|
|
(setf (getprop *objs name)
|
|
|
(create :name name :img img :selected nil))
|
|
|
(api:update-objs)
|
|
|
(api-call call-serv-loc "$ONOBJADD" name img)
|
|
|
(void))
|
|
|
|
|
|
(defun delobj (name)
|
|
|
(delete (getprop *objs name))
|
|
|
(api:update-objs)
|
|
|
(api-call call-serv-loc "$ONOBJDEL" name)
|
|
|
(void))
|
|
|
|
|
|
(defun killobj (&optional (num nil))
|
|
|
(if (eq undefined num)
|
|
|
(setf *objs (create))
|
|
|
(delobj (elt (chain *object (keys *objs)) num)))
|
|
|
(api:update-objs)
|
|
|
(void))
|
|
|
|
|
|
(defun selobj ()
|
|
|
(loop :for (k v) :of *objs
|
|
|
:do (when (@ v :selected)
|
|
|
(return-from selobj (@ v :name)))))
|
|
|
|
|
|
(defun unsel ()
|
|
|
(loop :for (k v) :of *objs
|
|
|
:do (setf (@ v :selected) nil)))
|
|
|
|
|
|
;;; 16menu
|
|
|
|
|
|
(defun menu (menu-name)
|
|
|
(let ((menu-data (list)))
|
|
|
(loop :for item-obj :in (@ (api:get-array (api:var-real-name menu-name)) values)
|
|
|
:for item := (@ item-obj :str)
|
|
|
:do (cond ((string= item "")
|
|
|
(break))
|
|
|
((string= item "-:-")
|
|
|
(chain menu-data (push :delimiter)))
|
|
|
(t
|
|
|
(let* ((tokens (chain item (split ":"))))
|
|
|
(when (= (length tokens) 2)
|
|
|
(chain tokens (push "")))
|
|
|
(let* ((text (chain tokens (splice 0 (- (length tokens) 2)) (join ":")))
|
|
|
(loc (getprop tokens (- (length tokens) 2)))
|
|
|
(icon (getprop tokens (- (length tokens) 1))))
|
|
|
(chain menu-data
|
|
|
(push (create :text text
|
|
|
:loc loc
|
|
|
:icon icon))))))))
|
|
|
(api:menu menu-data)
|
|
|
(void)))
|
|
|
|
|
|
;;; 17sound
|
|
|
|
|
|
(defun play (filename &optional (volume 100))
|
|
|
(let ((audio (new (*audio filename))))
|
|
|
(setf (getprop *playing filename) audio)
|
|
|
(setf (@ audio volume) (* volume 0.01))
|
|
|
(chain audio (play))))
|
|
|
|
|
|
(defun close (filename)
|
|
|
(funcall (getprop *playing filename) stop)
|
|
|
(delete (getprop *playing filename))
|
|
|
(void))
|
|
|
|
|
|
(defun closeall ()
|
|
|
(loop :for k :in (chain *object (keys *playing))
|
|
|
:for v := (getprop *playing k)
|
|
|
:do (funcall v stop))
|
|
|
(setf *playing (create)))
|
|
|
|
|
|
;;; 18img
|
|
|
|
|
|
(defun refint ()
|
|
|
;; "Force interface update" Uh... what exactly do we do here?
|
|
|
;(api:report-error "REFINT is not supported")
|
|
|
)
|
|
|
|
|
|
;;; 19input
|
|
|
|
|
|
(defun usertxt ()
|
|
|
(let ((input (by-id "qsp-input")))
|
|
|
(@ input value)))
|
|
|
|
|
|
(defun cmdclear ()
|
|
|
(let ((input (by-id "qsp-input")))
|
|
|
(setf (@ input value) "")))
|
|
|
|
|
|
(defun input (text)
|
|
|
(chain window (prompt text)))
|
|
|
|
|
|
;;; 20time
|
|
|
|
|
|
(defun msecscount ()
|
|
|
(- (chain *date (now)) *started-at))
|
|
|
|
|
|
;;; 21local
|
|
|
|
|
|
;;; 22for
|
|
|
|
|
|
;;; misc
|
|
|
|
|
|
(defun rgb (red green blue)
|
|
|
(+ (<< red 16)
|
|
|
(<< green 8)
|
|
|
blue))
|
|
|
|
|
|
(defun openqst (name)
|
|
|
(api-call run-game name))
|
|
|
|
|
|
(defun addqst (name)
|
|
|
(let ((game (api-call filename-game name)))
|
|
|
;; Add the game's locations
|
|
|
(chain *object (assign *locs
|
|
|
(getprop *games name)))))
|
|
|
|
|
|
(defun killqst ()
|
|
|
;; Delete all locations not from the current main game
|
|
|
(loop :for (k v) :in *games
|
|
|
:do (unless (string= k *main-game)
|
|
|
(delete (getprop *locs k)))))
|
|
|
|
|
|
|