src/intrinsics.ps

(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)))))