src/intrinsics.ps

(in-package sugar-qsp.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 (root current-location) (chain target (to-upper-case)))
  (api:stash-state args)
  (api:call-loc (root current-location) args)
  (api:call-serv-loc "ONNEWLOC")
  (void))

;;; 2var

;;; 3expr

;;; 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)
      (for ((i start))
           ((< i (min (api:array-size from-name)
                      (+ start count))))
           ((incf i))
           (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)
    (for ((i start)) ((< i (api:array-size name))) ((incf i))
         (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)
    (for ((i start)) ((< i (api:array-size name))) ((incf i))
         (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
    (funcall block args))
  (void))

(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
    (funcall block args)))

;;; 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 (s)
  (api:get-text :main)
  (void))

(defun desc (s)
  "")

(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 (s)
  (api:get-text :stat)
  (void))

(defun stat-clear ()
  (api:clear-text :stat)
  (void))

(defun cls ()
  (stat-clear)
  (main-clear)
  (cla)
  (cmdclear)
  (void))

;;; 13diag

;;; 14act

(defun curacts ()
  (let ((acts (root acts)))
    (lambda ()
      (setf (root acts) acts)
      (void))))

;;; 15objs

(defun addobj (name img)
  (setf img (or img ""))
  (setf (getprop (root 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 (root objs) name))
  (api-call call-serv-loc "ONOBJDEL" name)
  (void))

(defun killobj (&optional (num nil))
  (if (eq nil num)
      (setf (root objs) (create))
      (delobj (elt (chain *object (keys (root objs))) num)))
  (api:update-objs)
  (void))

(defun selobj ()
  (loop :for (k v) :of (root objs)
     :do (when (@ v :selected)
           (return-from selobj (@ v :name)))))

;;; 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 (root playing) filename) audio)
    (setf (@ audio volume) (* volume 0.01))
    (chain audio (play))))

(defun close (filename)
  (funcall (root playing filename) stop)
  (delete (root playing filename))
  (void))

(defun closeall ()
  (loop :for k :in (chain *object (keys (root playing)))
     :for v := (getprop (root playing) k)
     :do (funcall v stop))
  (setf (root 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)) (root 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 (root locs)
                           (getprop (root games) name)))))

(defun killqst ()
  ;; Delete all locations not from the current main game
  (loop :for (k v) :in (root games)
     :do (unless (string= k (root main-game))
           (delete (getprop (root locs) k)))))