src/intrinsics.ps

(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) (red green blue)
  (flet ((rgb-to-hex (comp)
           (let ((hex (ps: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))))

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