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) (ps:chain target (to-upper-case)))
  (api-call stash-state)
  (funcall (ps:getprop (root locs) (root current-location))))

;;; 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)
  (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 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 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)
  (conserving-vars (args result)
    (api-call init-args args)
    (funcall (ps:getprop (root locs) target))
    (values)))

(defm (root lib func) (target &rest args)
  (conserving-vars (args result)
    (api-call init-args args)
    (funcall (ps:getprop (root locs) 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)
  (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 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) ())

(defm (root lib view) ())

;;; 19input

(defm (root lib showinput) ())

(defm (root lib usertxt) ())

(defm (root lib cmdclear) ())

(defm (root lib input) ())

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

(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) (&optional filename)
  (let ((element (document.create-element :input)))
    (element.set-attribute :type :file)
    (element.set-attribute :id :qsp-opengame)
    (element.set-attribute :tabindex -1)
    (element.set-attribute "aria-hidden" t)
    (setf element.style.display :block)
    (setf element.style.visibility :hidden)
    (setf element.style.position :fixed)
    (setf element.onchange
          (lambda (event)
            (let* ((file (elt event.target.files 0))
                   (reader (ps:new (*file-reader))))
              (setf reader.onload
                    (lambda (ev)
                      (block nil
                             (let ((target ev.current-target))
                               (unless target.result
                                 (return))
                               (api-call base64-to-state target.result)))))
              (reader.read-as-text file))))
    (document.body.append-child element)
    (element.click)
    (document.body.remove-child element)))

(defm (root lib savegame) (&optional filename)
  (let ((element (document.create-element :a)))
    (element.set-attribute :href (+ "data:text/plain;charset=utf-8," (api-call state-to-base64)))
    (element.set-attribute :download "savegame.sav")
    (setf element.style.display :none)
    (document.body.append-child element)
    (element.click)
    (document.body.remove-child element)))