Fix

src/intrinsic-macros.lisp

@@ -1,180 +1,166 b''
 
 (in-package txt2web.lib)
 
 ;;;; Macros implementing some intrinsics where it makes sense
 ;;;; E.g. an equivalent JS function exists, or it's a direct API call
 
 ;;; 1loc
 
 ;;; 2var
 
 (defpsmacro killvar (&optional varname index)
   `(api-call kill-var ,varname ,index))
 
 (defpsmacro killall ()
   `(progn
      (killvar)
      (killobj)))
 
 ;;; 3expr
 
 (defpsmacro no (arg)
   `(- -1 ,arg))
 
 ;;; 4code
 
 (defpsmacro qspver ()
   "0.0.1")
 
 (defpsmacro curloc ()
   `*current-location)
 
 (defpsmacro rnd ()
   `(funcall rand 1 1000))
 
 (defpsmacro qspmax (&rest args)
   (if (= 1 (length args))
       `(*math.max.apply nil ,@args)
       `(*math.max ,@args)))
 
 (defpsmacro qspmin (&rest args)
   (if (= 1 (length args))
       `(*math.min.apply nil ,@args)
       `(*math.min ,@args)))
 
 ;;; 5arrays
 
 (defpsmacro arrsize (name)
   `(api-call array-size ,name))
 
 ;;; 6str
 
 (defpsmacro len (s)
   `(length ,s))
 
 (defpsmacro mid (s from &optional count)
   `(chain ,s (substring ,from ,count)))
 
 (defpsmacro ucase (s)
   `(chain ,s (to-upper-case)))
 
 (defpsmacro lcase (s)
   `(chain ,s (to-lower-case)))
 
 (defpsmacro trim (s)
   `(chain ,s (trim)))
 
 (defpsmacro qspreplace (s from to)
   `(chain ,s (replace ,from ,to)))
 
 (defpsmacro val (s)
   `(parse-int ,s 10))
 
 (defpsmacro qspstr (n)
   `(chain ,n (to-string)))
 
 ;;; 7if
 
 ;;; 8sub
 
 ;;; 9loops
 
 ;; JUMP is in ps-macros.lisp (because it's a part of a huge kludge)
 
 (defpsmacro exit ()
   `(return-from nil (values)))
 
 ;;; 10dynamic
 
-(defpsmacro dynamic (block &rest args)
-  `(progn
-     (when (stringp ,block)
-       (api:report-error "DYNAMIC can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNAMIC."))
-     (api:with-call-args ,args nil
-       (funcall ,block))))
-
-(defpsmacro dyneval (block &rest args)
-  `(progn
-     (when (stringp ,block)
-       (api:report-error "DYNEVAL can't evaluate arbitrary strings.\\nUse {braces} to create blocks for DYNEVAL."))
-     (api:with-call-args ,args t
-       (funcall ,block))))
-
 ;;; 11main
 
 (defpsmacro desc (s)
   (declare (ignore s))
   "")
 
 ;;; 12stat
 
 (defpsmacro showstat (enable)
   `(api-call enable-frame :stat ,enable))
 
 ;;; 13diag
 
 (defpsmacro msg (text)
   `(alert ,text))
 
 ;;; 14act
 
 (defpsmacro showacts (enable)
   `(api-call enable-frame :acts ,enable))
 
 (defpsmacro delact (&optional name)
   (if name
       `(api-call del-act ,name)
       `(api-call del-act)))
 
 (defpsmacro cla ()
   `(api-call clear-act))
 
 ;;; 15objs
 
 (defpsmacro showobjs (enable)
   `(api-call enable-frame :objs ,enable))
 
 (defpsmacro countobj ()
   `(length *objs))
 
 (defpsmacro getobj (index)
   `(or (elt *objs ,index) ""))
 
 ;;; 16menu
 
 ;;; 17sound
 
 (defpsmacro isplay (filename)
   `(funcall (@ playing includes) ,filename))
 
 ;;; 18img
 
 (defpsmacro view (&optional path)
   `(api-call show-image ,path))
 
 ;;; 19input
 
 (defpsmacro showinput (enable)
   `(api-call enable-frame :input ,enable))
 
 ;;; 20time
 
 (defpsmacro wait (msec)
   `(await (api-call sleep ,msec)))
 
 (defpsmacro settimer (interval)
   `(api-call set-timer ,interval))
 
 ;;; 21local
 
 ;;; 22for
 
 ;;; misc
 
 (defpsmacro opengame (&optional filename)
   (declare (ignore filename))
   `(api-call opengame))
 
 (defpsmacro savegame (&optional filename)
   (declare (ignore filename))
   `(api-call savegame))

src/intrinsics.ps

@@ -1,315 +1,328 b''
 
 (in-package txt2web.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 *current-location (chain target (to-upper-case)))
   (api:stash-state args)
   (api:call-loc *current-location args)
   (api:call-serv-loc "$ONNEWLOC")
   (void))
 
 ;;; 2var
 
 ;;; 3expr
 
 (defun obj (name)
   (has name *objs))
 
 (defun loc (name)
   (has name *locs))
 
 ;;; 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)
       (loop :for i :from start :to (min (api:array-size from-name)
                                         (+ start count))
          :do (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)
     (loop :for i :from start :to (api:array-size name)
        :do (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)
     (loop :for i :from start :to (api:array-size name)
        :do (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 nil
+    (funcall block)))
+
+(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 t
+    (funcall block)))
+
 ;;; 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 ()
   (api:get-text :main))
 
 (defun desc ()
   "")
 
 (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 ()
   (api:get-text :stat))
 
 (defun stat-clear ()
   (api:clear-text :stat)
   (void))
 
 (defun cls ()
   (stat-clear)
   (main-clear)
   (cla)
   (cmdclear)
   (void))
 
 ;;; 13diag
 
 ;;; 14act
 
 (defun selact ()
   (loop :for (k v) :of *acts
      :do (when (@ v :selected)
            (return-from selact (@ v :name)))))
 
 (defun curacts ()
-  (let ((acts (api-call copy-obj *acts)))
+  (let ((acts (chain *object (assign (create) *acts))))
     (lambda ()
       (setf *acts acts)
+      (api:update-acts)
       (void))))
 
 ;;; 15objs
 
 (defun addobj (name img)
   (setf img (or img ""))
   (setf (getprop *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 *objs name))
   (api:update-objs)
   (api-call call-serv-loc "$ONOBJDEL" name)
   (void))
 
 (defun killobj (&optional (num nil))
   (if (eq undefined num)
       (setf *objs (create))
       (delobj (elt (chain *object (keys *objs)) num)))
   (api:update-objs)
   (void))
 
 (defun selobj ()
   (loop :for (k v) :of *objs
      :do (when (@ v :selected)
            (return-from selobj (@ v :name)))))
 
 (defun unsel ()
   (loop :for (k v) :of *objs
      :do (setf (@ v :selected) nil)))
 
 ;;; 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 *playing filename) audio)
     (setf (@ audio volume) (* volume 0.01))
     (chain audio (play))))
 
 (defun close (filename)
   (funcall (getprop *playing filename) stop)
   (delete (getprop *playing filename))
   (void))
 
 (defun closeall ()
   (loop :for k :in (chain *object (keys *playing))
      :for v := (getprop *playing k)
      :do (funcall v stop))
   (setf *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)) *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 *locs
                            (getprop *games name)))))
 
 (defun killqst ()
   ;; Delete all locations not from the current main game
   (loop :for (k v) :in *games
      :do (unless (string= k *main-game)
            (delete (getprop *locs k)))))