|
|
|
|
|
(in-package sugar-qsp)
|
|
|
|
|
|
;;;; 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.
|
|
|
|
|
|
(setf (root lib) (ps:create))
|
|
|
|
|
|
;;; 1loc
|
|
|
|
|
|
(defm (root lib goto) (target args)
|
|
|
(api-call clear-text :main)
|
|
|
(funcall (root lib xgoto) target (or args (list)))
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib xgoto) (target args)
|
|
|
(api-call clear-act)
|
|
|
(setf (root current-location) (ps:chain target (to-upper-case)))
|
|
|
(api-call stash-state args)
|
|
|
(funcall (ps:getprop (root locs) (root current-location))
|
|
|
(or args (list)))
|
|
|
(values))
|
|
|
|
|
|
;;; 2var
|
|
|
|
|
|
;;; 3expr
|
|
|
|
|
|
;;; 4code
|
|
|
|
|
|
(defm (root lib rand) (a &optional (b 1))
|
|
|
(let ((min (min a b))
|
|
|
(max (max a b)))
|
|
|
(+ min (ps:chain *math (random (- max min))))))
|
|
|
|
|
|
;;; 5arrays
|
|
|
|
|
|
(defm (root lib copyarr) (to from start count)
|
|
|
(multiple-value-bind (to-name to-slot)
|
|
|
(api-call var-real-name to)
|
|
|
(multiple-value-bind (from-name from-slot)
|
|
|
(api-call var-real-name from)
|
|
|
(ps:for ((i start))
|
|
|
((< i (min (api-call array-size from-name)
|
|
|
(+ start count))))
|
|
|
((incf i))
|
|
|
(api-call set-var to-name (+ start i) to-slot
|
|
|
(api-call get-var from-name (+ start i) from-slot))))))
|
|
|
|
|
|
(defm (root lib arrpos) (name value &optional (start 0))
|
|
|
(multiple-value-bind (real-name slot)
|
|
|
(api-call var-real-name name)
|
|
|
(ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
|
|
|
(when (eq (api-call get-var real-name i slot) value)
|
|
|
(return i))))
|
|
|
-1)
|
|
|
|
|
|
(defm (root lib arrcomp) (name pattern &optional (start 0))
|
|
|
(multiple-value-bind (real-name slot)
|
|
|
(api-call var-real-name name)
|
|
|
(ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
|
|
|
(when (funcall (ps:getprop (api-call get-var real-name i slot) 'match) pattern)
|
|
|
(return i))))
|
|
|
-1)
|
|
|
|
|
|
;;; 6str
|
|
|
|
|
|
(defm (root lib instr) (s subs &optional (start 1))
|
|
|
(+ start (ps:chain s (substring (- start 1)) (search subs))))
|
|
|
|
|
|
(defm (root lib isnum) (s)
|
|
|
(if (is-na-n s)
|
|
|
0
|
|
|
-1))
|
|
|
|
|
|
(defm (root lib strcomp) (s pattern)
|
|
|
(if (s.match pattern)
|
|
|
-1
|
|
|
0))
|
|
|
|
|
|
(defm (root lib strfind) (s pattern group)
|
|
|
(let* ((re (ps:new (*reg-exp pattern)))
|
|
|
(match (re.exec s)))
|
|
|
(match.group group)))
|
|
|
|
|
|
(defm (root lib strpos) (s pattern &optional (group 0))
|
|
|
(let* ((re (ps:new (*reg-exp pattern)))
|
|
|
(match (re.exec s))
|
|
|
(found (match.group group)))
|
|
|
(if found
|
|
|
(s.search found)
|
|
|
0)))
|
|
|
|
|
|
;;; 7if
|
|
|
|
|
|
;; Has to be a function because it always evaluates all three of its
|
|
|
;; arguments
|
|
|
(defm (root lib iif) (cond-expr then-expr else-expr)
|
|
|
(if cond-expr then-expr else-expr))
|
|
|
|
|
|
;;; 8sub
|
|
|
|
|
|
(defm (root lib gosub) (target &rest args)
|
|
|
(funcall (ps:getprop (root locs) target) args)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib func) (target &rest args)
|
|
|
(funcall (ps:getprop (root locs) target) args))
|
|
|
|
|
|
;;; 9loops
|
|
|
|
|
|
;;; 10dynamic
|
|
|
|
|
|
(defm (root lib dynamic) (block &rest args)
|
|
|
(when (stringp block)
|
|
|
(api-call report-error "DYNAMIC can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNAMIC."))
|
|
|
(funcall block args)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib dyneval) (block &rest args)
|
|
|
(when (stringp block)
|
|
|
(api-call report-error "DYNEVAL can't evaluate arbitrary strings.\nUse {braces} to create blocks for DYNEVAL."))
|
|
|
(funcall block args))
|
|
|
|
|
|
;;; 11main
|
|
|
|
|
|
(defm (root lib main-p) (s)
|
|
|
(api-call add-text :main s)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib main-pl) (s)
|
|
|
(api-call add-text :main s)
|
|
|
(api-call newline :main)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib main-nl) (s)
|
|
|
(api-call newline :main)
|
|
|
(api-call add-text :main s)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib maintxt) (s)
|
|
|
(api-call get-text :main)
|
|
|
(values))
|
|
|
|
|
|
;; For clarity (it leaves a lib.desc() call in JS)
|
|
|
(defm (root lib desc) (s)
|
|
|
"")
|
|
|
|
|
|
(defm (root lib main-clear) ()
|
|
|
(api-call clear-text :main)
|
|
|
(values))
|
|
|
|
|
|
;;; 12stat
|
|
|
|
|
|
(defm (root lib stat-p) (s)
|
|
|
(api-call add-text :stat s)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib stat-pl) (s)
|
|
|
(api-call add-text :stat s)
|
|
|
(api-call newline :stat)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib stat-nl) (s)
|
|
|
(api-call newline :stat)
|
|
|
(api-call add-text :stat s)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib stattxt) (s)
|
|
|
(api-call get-text :stat)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib stat-clear) ()
|
|
|
(api-call clear-text :stat)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib cls) ()
|
|
|
(funcall (root lib stat-clear))
|
|
|
(funcall (root lib main-clear))
|
|
|
(funcall (root lib cla))
|
|
|
(funcall (root lib cmdclear))
|
|
|
(values))
|
|
|
|
|
|
;;; 13diag
|
|
|
|
|
|
;;; 14act
|
|
|
|
|
|
(defm (root lib curacts) ()
|
|
|
(let ((acts (root acts)))
|
|
|
(lambda ()
|
|
|
(setf (root acts) acts)
|
|
|
(values))))
|
|
|
|
|
|
;;; 15objs
|
|
|
|
|
|
(defm (root lib addobj) (name)
|
|
|
(ps:chain (root objs) (push name))
|
|
|
(api-call update-objs)
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib delobj) (name)
|
|
|
(let ((index (ps:chain (root objs) (index-of name))))
|
|
|
(when (> index -1)
|
|
|
(funcall (root lib killobj) (1+ index))))
|
|
|
(values))
|
|
|
|
|
|
(defm (root lib killobj) (&optional (num nil))
|
|
|
(if (eq nil num)
|
|
|
(setf (root objs) (list))
|
|
|
(ps:chain (root objs) (splice (1- num) 1)))
|
|
|
(api-call update-objs)
|
|
|
(values))
|
|
|
|
|
|
;;; 16menu
|
|
|
|
|
|
(defm (root lib menu) (menu-name)
|
|
|
(let ((menu-data (list)))
|
|
|
(loop :for item :in (api-call get-array (api-call var-real-name menu-name))
|
|
|
:do (cond ((string= item "")
|
|
|
(break))
|
|
|
((string= item "-:-")
|
|
|
(ps:chain menu-data (push :delimiter)))
|
|
|
(t
|
|
|
(let* ((tokens (ps:chain item (split ":"))))
|
|
|
(when (= (length tokens) 2)
|
|
|
(tokens.push ""))
|
|
|
(let* ((text (ps:chain tokens (splice 0 (- tokens.length 2)) (join ":")))
|
|
|
(loc (ps:getprop tokens (- tokens.length 2)))
|
|
|
(icon (ps:getprop tokens (- tokens.length 1))))
|
|
|
(ps:chain menu-data
|
|
|
(push (ps:create text text
|
|
|
loc loc
|
|
|
icon icon))))))))
|
|
|
(api-call menu menu-data)
|
|
|
(values)))
|
|
|
|
|
|
;;; 17sound
|
|
|
|
|
|
(defm (root lib play) (filename &optional (volume 100))
|
|
|
(let ((audio (ps:new (*audio filename))))
|
|
|
(setf (ps:getprop (root playing) filename) audio)
|
|
|
(setf (ps:@ audio volume) (* volume 0.01))
|
|
|
(ps:chain audio (play))))
|
|
|
|
|
|
(defm (root lib close) (filename)
|
|
|
(funcall (root playing filename) stop)
|
|
|
(ps:delete (root playing filename)))
|
|
|
|
|
|
(defm (root lib closeall) ()
|
|
|
(loop :for k :in (*object.keys (root playing))
|
|
|
:for v := (ps:getprop (root playing) k)
|
|
|
:do (funcall v stop))
|
|
|
(setf (root playing) (ps:create)))
|
|
|
|
|
|
;;; 18img
|
|
|
|
|
|
(defm (root lib refint) ()
|
|
|
;; "Force interface update" Uh... what exactly do we do here?
|
|
|
(api-call report-error "REFINT is not supported")
|
|
|
)
|
|
|
|
|
|
;;; 19input
|
|
|
|
|
|
(defm (root lib usertxt) ()
|
|
|
(let ((input (document.get-element-by-id "qsp-input")))
|
|
|
(ps:@ input value)))
|
|
|
|
|
|
(defm (root lib cmdclear) ()
|
|
|
(let ((input (document.get-element-by-id "qsp-input")))
|
|
|
(setf (ps:@ input value) "")))
|
|
|
|
|
|
(defm (root lib input) (text)
|
|
|
(window.prompt text))
|
|
|
|
|
|
;;; 20time
|
|
|
|
|
|
;; I wonder if there's a better solution than busy-wait
|
|
|
(defm (root lib wait) (msec)
|
|
|
(let* ((now (ps:new (*date)))
|
|
|
(exit-time (+ (funcall now.get-time) msec)))
|
|
|
(loop :while (< (funcall now.get-time) exit-time))))
|
|
|
|
|
|
(defm (root lib msecscount) ()
|
|
|
(- (*date.now) (root started-at)))
|
|
|
|
|
|
;;; 21local
|
|
|
|
|
|
;;; 22for
|
|
|
|
|
|
;;; misc
|
|
|
|
|
|
(defm (root lib rgb) ()
|
|
|
(api-call report-error "RGB is not implemented."))
|
|
|
|
|
|
(defm (root lib openqst) ()
|
|
|
(api-call report-error "OPENQST is not supported."))
|
|
|
|
|
|
(defm (root lib addqst) ()
|
|
|
(api-call report-error "ADDQST is not supported. Bundle the library with the main game."))
|
|
|
|
|
|
(defm (root lib killqst) ()
|
|
|
(api-call report-error "KILLQST is not supported."))
|
|
|
|