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 &rest args)
  (api-call clear-text :main)
  (apply (root lib xgoto) target args))

(defm (root lib xgoto) (target &rest args)
  (api-call clear-act)
  (api-call init-args args)
  (setf (root current-location) target)
  (api-call stash-state)
  (funcall (ps:getprop (root locations) (ps:chain target (to-upper-case)))))

;;; 2var

(defm (root lib killvar) (varname &optional (index :whole))
  (api-call kill-var varname index))

(defm (root lib killall) ()
  (api-call kill-all))

;;; 3expr

(defm (root lib obj) (name)
  (funcall (root objs includes) name))

(defm (root lib loc) ()
  (funcall (root locations includes) name))

(defm (root lib no) (arg)
  (- -1 arg))

;;; 4code

(defm (root lib qspver) ()
  "0.0.1")

(defm (root lib curloc) ()
  (root current-location))

(defm (root lib rand) (a b)
  (let ((min (min a b))
        (max (max a b)))
    (+ min (ps:chain *math (random (- max min))))))

(defm (root lib rnd) ()
  (funcall (root lib rand) 1 1000))

(defm (root lib qspmax) (&rest args)
  (apply (ps:@ *math max) args))

(defm (root lib qspmin) (&rest args)
  (apply (ps:@ *math min) args))

;;; 5arrays

(defm (root lib copyarr) (to from start count)
  (ps:for ((i start))
          ((< i (min (api-call array-size from)
                     (+ start count))))
          ((incf i))
    (api-call set-var to (+ start i)
              (api-call get-var from (+ start i)))))

(defm (root lib arrsize) (name)
  (api-call array-size name))

(defm (root lib arrpos) (name value &optional (start 0))
  (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
    (when (eq (api-call get-var name i) value)
      (return i)))
  -1)

(defm (root lib arrcomp) (name pattern &optional (start 0))
  (ps:for ((i start)) ((< i (api-call array-size name))) ((incf i))
    (when (funcall (ps:getprop (api-call get-var name i) 'match) pattern)
      (return i)))
  -1)

;;; 6str

(defm (root lib len) (s)
  (length s))

(defm (root lib mid) (s from &optional count)
  (s.substring from count))

(defm (root lib ucase) (s)
  (s.to-upper-case))

(defm (root lib lcase) (s)
  (s.to-lower-case))

(defm (root lib trim) (s)
  (s.trim))

(defm (root lib replace) (s from to)
  (s.replace from to))

(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 val) (s)
  (parse-int s 10))

(defm (root lib qspstr) (n)
  (+ "" n))

(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

(defm (root lib iif) (cond-expr then-expr else-expr)
  (if (= -1 cond-expr) then-expr else-expr))

;;; 8sub

(defm (root lib gosub) (target &rest args)
  (conserving-vars (args result)
    (api-call init-args args)
    (funcall (ps:getprop (root locations) target))
    (values)))

(defm (root lib func) (target &rest args)
  (conserving-vars (args result)
    (api-call init-args args)
    (funcall (ps:getprop (root locations) target))
    (api-call get-result)))

;;; 9loops

;;; 10dynamic

(defm (root lib dyneval) (block &rest args)
  (conserving-vars (args result)
    (api-call init-args args)
    (funcall block)
    (api-call get-result)))

(defm (root lib dynamic) (&rest args)
  (conserving-vars (args result)
    (api-call init-args args)
    (funcall block)
    (values)))

;;; 11main

(defm (root lib main-p) (s)
  (api-call add-text :main s))

(defm (root lib main-pl) (s)
  (api-call add-text :main s)
  (api-call newline :main))

(defm (root lib main-nl) (s)
  (api-call newline :main)
  (api-call add-text :main s))

(defm (root lib maintxt) (s)
  (api-call get-text :main))

(defm (root lib desc) (s)
  "")

(defm (root lib main-clear) ()
  (api-call clear-text :main))

;;; 12stat

(defm (root lib showstat) ())

(defm (root lib stat-p) ())

(defm (root lib stat-pl) ())

(defm (root lib stat-nl) ())

(defm (root lib stattxt) ())

(defm (root lib clear) ())

(defm (root lib cls) ())

;;; 13diag

(defm (root lib msg) ())

;;; 14act

(defm (root lib showacts) ())

(defm (root lib delact) (name)
  (api-call del-act name))

(defm (root lib curacts) ())

(defm (root lib cla) ())

;;; 15objs

(defm (root lib showobjs) ())

(defm (root lib addobj) (name)
  (ps:chain (root objs) (push name))
  (api-call update-objs))

(defm (root lib delobj) (name)
  (let ((index (ps:chain (root objs) (index-of name))))
    (when (> index -1)
      (ps:chain (root objs) (splice index 1))))
  (api-call update-objs))

(defm (root lib killobj) ())

(defm (root lib countobj) ())

(defm (root lib getobj) ())

;;; 16menu

(defm (root lib menu) ())

;;; 17sound

(defm (root lib play) ())

(defm (root lib isplay) ())

(defm (root lib close) ())

(defm (root lib closeall) ())

;;; 18img

(defm (root lib refint) ())

(defm (root lib view) ())

;;; 19input

(defm (root lib showinput) ())

(defm (root lib usertxt) ())

(defm (root lib cmdclear) ())

(defm (root lib input) ())

;;; 20time

(defm (root lib wait) ())

(defm (root lib msecscount) ())

(defm (root lib settimer) ())

;;; misc

(defm (root lib rgb) ())

(defm (root lib openqst) ())

(defm (root lib addqst) ())

(defm (root lib killqst) ())

(defm (root lib opengame) ())

(defm (root lib savegame) ())