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 (or args (list)))
  (values))

(defun xgoto (target args)
  (api:clear-act)
  (setf (root current-location) (chain target (to-upper-case)))
  (api:stash-state args)
  (funcall (getprop (root locs) (root current-location))
           (or args (list)))
  (values))

;;; 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)
  (funcall (getprop (root locs) target) args)
  (values))

(defun func (target &rest args)
  (funcall (getprop (root locs) 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))
  (values))

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

(defun main-pl (s)
  (api:add-text :main s)
  (api:newline :main)
  (values))

(defun main-nl (s)
  (api:newline :main)
  (api:add-text :main s)
  (values))

(defun maintxt (s)
  (api:get-text :main)
  (values))

;; For clarity (it leaves a lib.desc() call in JS)
(defun desc (s)
  "")

(defun main-clear ()
  (api:clear-text :main)
  (values))

;;; 12stat

(defun stat-p (s)
  (api:add-text :stat s)
  (values))

(defun stat-pl (s)
  (api:add-text :stat s)
  (api:newline :stat)
  (values))

(defun stat-nl (s)
  (api:newline :stat)
  (api:add-text :stat s)
  (values))

(defun stattxt (s)
  (api:get-text :stat)
  (values))

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

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

;;; 13diag

;;; 14act

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

;;; 15objs

(defun addobj (name)
  (chain (root objs) (push name))
  (api:update-objs)
  (values))

(defun delobj (name)
  (let ((index (chain (root objs) (index-of name))))
    (when (> index -1)
      (killobj (1+ index))))
  (values))

(defun killobj (&optional (num nil))
  (if (eq nil num)
      (setf (root objs) (list))
      (chain (root objs) (splice (1- num) 1)))
  (api:update-objs)
  (values))

;;; 16menu

(defun menu (menu-name)
  (let ((menu-data (list)))
    (loop :for item :in (api:get-array (api:var-real-name menu-name))
       :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)
    (values)))

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

(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)
  (flet ((rgb-to-hex (comp)
           (let ((hex (chain (*number comp) (to-string 16))))
             (if (< (length hex) 2)
                 (+ "0" hex)
                 hex))))
    (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red))))

(defun openqst ()
  (api:report-error "OPENQST is not supported."))

(defun addqst ()
  (api:report-error "ADDQST is not supported. Bundle the library with the main game."))

(defun killqst ()
  (api:report-error "KILLQST is not supported."))