Bugfixes

TODO

@@ -1,11 +1,15 b''
 
+* Remove cl-uglify-js (no support for ES6 at all and no way to monkey-patch it reliably)
+* Use Parenscript's async/await
+* Use Parenscript's minifier
+* WAIT and MENU with async/await
 * Special locations
 * Special variables
 * CLI build for Linux
 * CLI build for Windows
 
 * Build Istreblenie
 * Windows GUI (for the compiler)
 * Save-load game in slots
 * Resizable frames
-** modifying it to suit compiler specifics
  No newline at end of file
+** modifying it to suit compiler specifics

src/api.ps

@@ -1,387 +1,390 b''
 
 (in-package sugar-qsp)
 
 ;;; API deals with DOM manipulation and some bookkeeping for the
 ;;; intrinsics, namely variables
 ;;; API is an implementation detail and has no QSP documentation. It
 ;;; doesn't call intrinsics
 
 (setf (root api) (ps:create))
 
 ;;; Utils
 
 (defm (root api make-act-html) (title img)
   (+ "<a class='qsp-act' href='#' onclick='SugarQSP.acts[\"" title "\"].act();'>"
      title
      "</a>"))
 
 (defm (root api make-menu-item-html) (num title img loc)
   (+ "<a href='#' onclick='SugarQSP.api.runMenu(" num ", \"" loc "\")();'>"
      "<img src='" img "'>"
      title
      "</a>"))
 
 (defm (root api report-error) (text)
   (alert text))
 
 (defm (root api init-dom) ()
   ;; Save/load buttons
   (let ((btn (document.get-element-by-id "qsp-btn-save")))
     (setf (ps:@ btn onclick) this.savegame)
     (setf (ps:@ btn href) "#"))
   (let ((btn (document.get-element-by-id "qsp-btn-open")))
     (setf (ps:@ btn onclick) this.opengame)
     (setf (ps:@ btn href) "#"))
   ;; Close image on click
   (setf (ps:@ (document.get-element-by-id "qsp-image-container") onclick)
         (this.show-image nil))
   ;; Close the dropdown on any click
   (setf window.onclick
         (lambda (event)
           (setf (ps:@ (api-call get-frame :dropdown) style display) "none"))))
 
 (defm (root api call-serv-loc) (var-name &rest args)
   (let ((loc-name (api-call get-var name 0 :str)))
     (when loc-name
       (let ((loc (ps:getprop (root locs) loc-name)))
         (when loc
           (funcall loc args))))))
 
 ;;; Misc
 
+(defm (root api newline) (key)
+  (this.append-id (this.key-to-id key) "<br>" t))
+
 (defm (root api clear-id) (id)
-  (setf (ps:chain document (get-element-by-id id) inner-text) ""))
+  (setf (ps:chain document (get-element-by-id id) inner-h-t-m-l) ""))
+
+(setf (root api text-escaper) (document.create-element :textarea))
+
+(defm (root api prepare-contents) (s &optional force-html)
+  (if (or force-html (var "USEHTML" 0 :num))
+      s
+      (progn
+        (setf (ps:@ (root api text-escaper) text-content) s)
+        (ps:@ (root api text-escaper) inner-h-t-m-l))))
 
 (defm (root api get-id) (id &optional force-html)
-  (if (or force-html (var "USEHTML" 0 :num))
-      (ps:chain (document.get-element-by-id id) inner-h-t-m-l)
-      (ps:chain (document.get-element-by-id id) inner-text)))
+  (ps:chain (document.get-element-by-id id) inner-h-t-m-l))
 
 (defm (root api set-id) (id contents &optional force-html)
-  (if (or force-html (var "USEHTML" 0 :num))
-      (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
-      (setf (ps:chain (document.get-element-by-id id) inner-text) contents)))
+  (setf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) (this.prepare-contents contents force-html)))
 
 (defm (root api append-id) (id contents &optional force-html)
-  (if (or force-html (var "USEHTML" 0 :num))
-      (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) contents)
-      (incf (ps:chain (document.get-element-by-id id) inner-text) contents)))
+  (when contents
+    (incf (ps:chain (document.get-element-by-id id) inner-h-t-m-l) (this.prepare-contents contents force-html))))
 
 ;;; Function calls
 
 (defm (root api init-args) (args)
   (dotimes (i (length args))
     (let ((arg (elt args i)))
       (if (numberp arg)
           (this.set-var args i :num arg)
           (this.set-var args i :str arg)))))
 
 (defm (root api get-result) ()
   (if (not (equal "" (var result 0 :str)))
       (var result 0 :str)
       (var result 0 :num)))
 
 (defm (root api call-loc) (name args)
   (funcall (ps:getprop (root locs) name) args))
 
 ;;; Text windows
 
 (defm (root api key-to-id) (key)
   (case key
     (:main "qsp-main")
     (:stat "qsp-stat")
     (:objs "qsp-objs")
     (:acts "qsp-acts")
     (:input "qsp-input")
     (:dropdown "qsp-dropdown")
     (t (this.report-error "Internal error!"))))
 
 (defm (root api get-frame) (key)
   (document.get-element-by-id (this.key-to-id key)))
 
 (defm (root api add-text) (key text)
   (this.append-id (this.key-to-id key) text))
 
 (defm (root api get-text) (key)
   (this.get-id (this.key-to-id key)))
 
 (defm (root api clear-text) (key)
   (this.clear-id (this.key-to-id key)))
 
-(defm (root api newline) (key)
-  (let ((div (this.get-frame key)))
-    (ps:chain div (append-child (document.create-element "br")))))
-
 (defm (root api enable-frame) (key enable)
   (let ((obj (this.get-frame key)))
     (setf obj.style.display (if enable "block" "none"))
     (values)))
 
 ;;; Actions
 
 (defm (root api add-act) (title img act)
   (setf (ps:getprop (root acts) title)
         (ps:create :img img :act act))
   (this.update-acts))
 
 (defm (root api del-act) (title)
   (delete (ps:getprop (root acts) title))
   (this.update-acts))
 
 (defm (root api clear-act) ()
   (setf (root acts) (ps:create))
   (this.clear-id "qsp-acts"))
 
 (defm (root api update-acts) ()
   (this.clear-id "qsp-acts")
   (let ((elt (document.get-element-by-id "qsp-acts")))
     (ps:for-in (title (root acts))
       (let ((obj (ps:getprop (root acts) title)))
         (incf elt.inner-h-t-m-l (this.make-act-html title (ps:getprop obj :img)))))))
       
 
 ;;; "Syntax"
 
 (defm (root api qspfor) (name index from to step body)
   (block nil
     (ps:for ((i from))
             ((< i to))
             ((incf i step))
       (this.set-var name index :num i)
       (unless (funcall body)
         (return)))))
 
 ;;; Variable class
 
 (defm (root api *var) (name)
   ;; From strings to numbers
   (setf this.indexes (ps:create))
   ;; From numbers to {num: 0, str: ""} objects
   (setf this.values (list))
   (values))
 
 (defm (root api *var prototype new-value) ()
   (ps:create :num 0 :str ""))
 
 (defm (root api *var prototype index-num) (index)
   (let ((num-index
          (if (stringp index)
              (if (in index this.indexes)
                  (ps:getprop this.indexes index)
                  (let ((n (length this.values)))
                    (setf (ps:getprop this.indexes index) n)
                    n))
              index)))
     (unless (in num-index this.values)
       (setf (elt this.values num-index) (this.new-value)))
     num-index))
 
 (defm (root api *var prototype get) (index slot)
   (unless (or index (= 0 index))
     (setf index (1- (length this.values))))
   (ps:getprop this.values (this.index-num index) slot))
 
 (defm (root api *var prototype set) (index slot value)
   (unless (or index (= 0 index))
     (setf index (length store)))
   (case slot
     (:num (setf value (ps:chain *number (parse-int value))))
     (:str (setf value (ps:chain value (to-string)))))
   (setf (ps:getprop this.values (this.index-num index) slot) value)
   (values))
 
 (defm (root api *var prototype kill) (index)
   (setf (elt this.values (this.index-num index)) (this.new-value)))
 
 ;;; Variables
 
 (defm (root api var-real-name) (name)
   (if (= (ps:@ name 0) #\$)
       (values (ps:chain name (substr 1)) :str)
       (values name :num)))
 
 (defm (root api ensure-var) (name)
   (let ((store (this.var-ref name)))
     (unless store
       (setf store (ps:new (this.-var name)))
       (setf (ps:getprop (root vars) name) store))
     store))
 
 (defm (root api var-ref) (name)
   (let ((local-store (this.current-local-frame)))
     (cond ((and local-store (in name local-store))
            (ps:getprop local-store name))
           ((in name (root vars))
            (ps:getprop (root vars) name))
           (t nil))))
 
 (defm (root api get-var) (name index slot)
   (ps:chain (this.ensure-var name) (get index slot)))
 
 (defm (root api set-var) (name index slot value)
   (ps:chain (this.ensure-var name) (set index slot value))
   (values))
 
 (defm (root api get-array) (name)
   (this.var-ref name))
 
 (defm (root api set-array) (name value)
   (let ((store (this.var-ref name)))
     (setf (ps:@ store values) (ps:@ value values))
     (setf (ps:@ store indexes) (ps:@ value indexes)))
   (values))
 
 (defm (root api kill-var) (name &optional index)
   (if (and index (not (= 0 index))) 
       (ps:chain (ps:getprop (root vars) name) (kill index))
       (ps:delete (ps:getprop (root vars) name)))
   (values))
 
 (defm (root api array-size) (name)
   (ps:getprop (this.var-ref name) 'length))
 
 ;;; Locals
 
 (defm (root api push-local-frame) ()
   (ps:chain (root locals) (push (ps:create)))
   (values))
 
 (defm (root api pop-local-frame) ()
   (ps:chain (root locals) (pop))
   (values))
 
 (defm (root api current-local-frame) ()
   (elt (root locals) (1- (length (root locals)))))
 
 (defm (root api new-local) (name)
   (let ((frame (this.current-local-frame)))
     (unless (in name frame)
       (setf (ps:getprop frame name) (ps:create)))
     (values)))
 
 ;;; Objects
 
 (defm (root api update-objs) ()
   (let ((elt (document.get-element-by-id "qsp-objs")))
     (setf elt.inner-h-t-m-l "<ul>")
     (loop :for obj :in (root objs)
        :do (incf elt.inner-h-t-m-l (+ "<li>" obj)))
     (incf elt.inner-h-t-m-l "</ul>")))
 
 ;;; Menu
 
 (defm (root api menu) (menu-data)
   (let ((elt (document.get-element-by-id "qsp-dropdown"))
         (i 0))
     (setf elt.inner-h-t-m-l "")
     (loop :for item :in menu-data
        :do (incf i)
        :do (incf elt.inner-h-t-m-l (this.make-menu-item-html i item.text item.icon item.loc)))
     (setf elt.style.display "block")))
 
 ;;; Content
 
 (defm (root api clean-audio) ()
   (loop :for k :in (*object.keys (root playing))
      :for v := (ps:getprop (root playing) k)
      :do (when (ps:@ v ended)
            (ps:delete (ps:@ (root playing) k)))))
 
 (defm (root api show-image) (path)
   (let ((img (document.get-element-by-id "qsp-image")))
     (cond (path
            (setf img.src path)
            (setf img.style.display "flex"))
           (t
            (setf img.src "")
            (setf img.style.display "hidden")))))
 
 ;;; Saves
 
 (defm (root api opengame) ()
   (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)
                                (api-call unstash-state)))))
               (reader.read-as-text file))))
     (document.body.append-child element)
     (element.click)
     (document.body.remove-child element)))
 
 (defm (root api savegame) ()
   (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)))
 
 (defm (root api stash-state) (args)
   (api-call call-serv-loc "ONGSAVE")
   (setf (root state-stash)
         (*j-s-o-n.stringify
          (ps:create vars (root vars)
                     objs (root objs)
                     loc-args args
                     msecs (- (*date.now) (root started-at))
                     main-html (ps:@
                                (document.get-element-by-id :qsp-main)
                                inner-h-t-m-l)
                     stat-html (ps:@
                                (document.get-element-by-id :qsp-stat)
                                inner-h-t-m-l)
                     next-location (root current-location))))
   (values))
 
 (defm (root api unstash-state) ()
   (let ((data (*j-s-o-n.parse (root state-stash))))
     (this.clear-act)
     (setf (root vars) (ps:@ data vars))
     (loop :for k :in (*object.keys (root vars))
        :do (*object.set-prototype-of (ps:getprop (root vars) k)
                                      (root api *var prototype)))
     (setf (root started-at) (- (*date.now) (ps:@ data msecs)))
     (setf (root objs) (ps:@ data objs))
     (setf (root current-location) (ps:@ data next-location))
     (setf (ps:@ (document.get-element-by-id :qsp-main) inner-h-t-m-l)
           (ps:@ data main-html))
     (setf (ps:@ (document.get-element-by-id :qsp-stat) inner-h-t-m-l)
           (ps:@ data stat-html))
     (this.update-objs)
     (api-call call-serv-loc "ONGLOAD")
     (api-call call-loc (root current-location) (ps:@ data loc-args))
     (values)))
 
 (defm (root api state-to-base64) ()
   (btoa (encode-u-r-i-component (root state-stash))))
 
 (defm (root api base64-to-state) (data)
   (setf (root state-stash) (decode-u-r-i-component (atob data))))
 
 ;;; Timers
 
 (defm (root api set-timer) (interval)
   (setf (root timer-interval) interval)
   (clear-interval (root timer-obj))
   (setf (root timer-obj)
         (set-interval
          (lambda ()
            (api-call call-serv-loc "COUNTER"))
          interval)))

src/intrinsics.ps

@@ -1,302 +1,307 b''
 
 (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) ()
-  (api-call report-error "RGB is not implemented."))
+(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."))

sugar-qsp.asd

@@ -1,13 +1,14 b''
 
 (defsystem sugar-qsp
   :description "QSP compiler to monolithic HTML page"
   :depends-on (:alexandria :esrap
                :parenscript :parse-js :cl-uglify-js :flute)
   :pathname "src/"
   :serial t
   :components ((:file "package")
+               (:file "patches")
                (:file "ps-macros")
                (:file "intrinsic-macros")
                (:file "class")
                (:file "main")
                (:file "parser")))