src/api.ps

(in-package sugar-qsp.api)

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

;;; Utils

(defun make-act-html (title img)
  (+ "<a class='qsp-act' href='" (href-call call-act title) "' onmouseover='" (inline-call select-act title) "'>"
     (if img (+ "<img src='" img "'>") "")
     title
     "</a>"))

(defun make-menu-item-html (num title img loc)
  (+ "<a href='" (href-call finish-menu loc) "'>"
     (if img (+ "<img src='" img "'>") "")
     title
     "</a>"))

(defun make-obj (title img selected)
  (+ "<li onclick='" (inline-call select-obj title img) "'>"
     "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
     (if img (+ "<img src='" img "'>") "")
     title
     "</a>"))

(defun make-menu-delimiter ()
  "<hr>")

(defun copy-obj (obj)
  (chain *j-s-o-n (parse (chain *j-s-o-n (stringify obj)))))

(defun report-error (text)
  (alert text))

(defun start-sleeping ()
  (chain (by-id "qsp") class-list (add "disable")))

(defun finish-sleeping ()
  (chain (by-id "qsp") class-list (remove "disable")))

(defun sleep (msec)
  (with-sleep (resume)
    (set-timeout resume msec)))

(defun init-dom ()
  ;; Save/load buttons
  (let ((btn (by-id "qsp-btn-save")))
    (setf (@ btn onclick) savegame)
    (setf (@ btn href) "#"))
  (let ((btn (by-id "qsp-btn-open")))
    (setf (@ btn onclick) opengame)
    (setf (@ btn href) "#"))
  ;; Close image on click
  (setf (@ (by-id "qsp-image-container") onclick)
        show-image)
  ;; Enter in input field
  (setf (@ (get-frame :input) onkeyup)
        on-input-key)
  ;; Close the dropdown on any click
  (setf (@ window onclick)
        (lambda (event)
          (setf (@ window mouse)
                (list (@ event page-x)
                      (@ event page-y)))
          (finish-menu nil))))

(defun call-serv-loc (var-name &rest args)
  (let ((loc-name (get-global var-name 0)))
    (when loc-name
      (let ((loc (getprop *locs loc-name)))
        (when loc
          (call-loc loc-name args))))))

(defun filename-game (filename)
  (let ((game-name (chain filename (match "(.*/)?([^.]+)(\\.[a-zA-Z]+)?") 2))))
  (getprop *games game-name))

(defun run-game (name)
  (let ((game (filename-game name)))
    (setf *main-game name)
    ;; Replace locations with the new game's 
    (setf *locs game)
    (funcall (getprop game
                      (chain *object (keys game) 0))
             (list))))

;;; Misc

(defun newline (key)
  (append-id (key-to-id key) "<br>" t))

(defun clear-id (id)
  (setf (inner-html (by-id id)) ""))

(defun escape-html (text)
  (chain text
         (replace (regex "/&/g") "&amp;")
         (replace (regex "/</g") "&lt;")
         (replace (regex "/>/g") "&gt;")
         (replace (regex "/\"/g") "&quot;")
         (replace (regex "/'/g") "&apos;")))

(defun prepare-contents (s &optional force-html)
  (setf s (chain s (to-string)))
  (if (or force-html (get-global "USEHTML" 0))
      s
      (escape-html s)))

(defun get-id (id &optional force-html)
  (inner-html (by-id id)))

(defun set-id (id contents &optional force-html)
  (setf (inner-html (by-id id)) (prepare-contents contents force-html)))

(defun append-id (id contents &optional force-html)
  (when contents
    (incf (inner-html (by-id id)) (prepare-contents contents force-html))))

(defun on-input-key (ev)
  (when (= 13 (@ ev key-code))
    (chain ev (prevent-default))
    (call-serv-loc "$USERCOM")))

;;; Function calls

(defun init-args (args)
  (dotimes (i (length args))
    (let ((arg (elt args i)))
      (if (numberp arg)
          (set-var args i :num arg)
          (set-var args i :str arg)))))

(defun get-result ()
  (or (get-global "$RESULT" 0)
      (get-global "RESULT" 0)))

(defun call-loc (name args)
  (setf name (chain name (to-upper-case)))
  (with-frame
      (with-call-args args
        (funcall (getprop *locs name))))
  (void))

(defun call-act (title)
  (setf *current-action title)
  (with-frame
      (funcall (getprop *acts title :act)))
  (setf *current-action nil)
  (void))

;;; Text windows

(defun key-to-id (key)
  (case key
    (:all "qsp")
    (:main "qsp-main")
    (:stat "qsp-stat")
    (:objs "qsp-objs")
    (:acts "qsp-acts")
    (:input "qsp-input")
    (:image "qsp-image")
    (:dropdown "qsp-dropdown")
    (t (report-error "Internal error!"))))

(defun get-frame (key)
  (by-id (key-to-id key)))

(defun add-text (key text)
  (append-id (key-to-id key) text))

(defun get-text (key)
  (get-id (key-to-id key)))

(defun clear-text (key)
  (clear-id (key-to-id key)))

(defun enable-frame (key enable)
  (let ((obj (get-frame key)))
    (setf (@ obj style display) (if enable "block" "none"))
    (void)))

;;; Actions

(defun add-act (title img act)
  (setf (getprop *acts title)
        (create :title title :img img :act act :selected nil))
  (update-acts))

(defun del-act (&optional title)
  (delete (getprop *acts (or title *current-action)))
  (update-acts))

(defun clear-act ()
  (setf *acts (create))
  (update-acts))

(defun update-acts ()
  (clear-id "qsp-acts")
  (let ((elt (by-id "qsp-acts")))
    (for-in (title *acts)
            (let ((obj (getprop *acts title)))
              (incf (inner-html elt) (make-act-html title (getprop obj :img)))))))

(defun select-act (title)
  (loop :for (k v) :of *acts
     :do (setf (getprop v :selected) nil))
  (setf (getprop *acts title :selected) t)
  (call-serv-loc "$ONACTSEL"))

;;; "Syntax"

(defun qspfor (name index from to step body)
  (for ((i from))
       ((< i to))
       ((incf i step))
       (set-var name index :num i)
       (unless (await (funcall body))
         (return-from qspfor))))

;;; Variables

(defun new-var (slot &rest indexes)
  (let ((v (list)))
    (dolist (index indexes)
      (setf (elt v index) (if (eq #\$ (elt slot 0)) "" 0)))
    (setf (@ v :indexes) (create))
    v))

(defun set-str-element (slot index value)
  (if (has index (getprop slot :indexes))
      (setf (elt (getprop slot) 
                 (getprop slot :indexes index))
            value)
      (progn
        (chain slot (push value))
        (setf (elt slot index)
              (length slot)))))

(defun set-any-element (slot index value)
  (if (numberp index)
      (setf (elt slot index) value)
      (set-str-element slot index value)))

(defun get-element (slot index)
  (if (numberp index)
      (elt slot index)
      (elt slot (getprop slot :indexes index))))

(defun get-global (name index)
  (elt (getprop *globals name) index))

(defun kill-var (store name &optional index)
  (setf name (chain name (to-upper-case)))
  (if (and index (not (= 0 index))) 
      (chain (getprop *globals name) (kill index))
      (delete (getprop *globals name)))
  (void))

(defun array-size (name)
  (@ (var-ref name) :values length))

;;; Locals

(defun push-local-frame ()
  (chain *locals (push (create)))
  (void))

(defun pop-local-frame ()
  (chain *locals (pop))
  (void))

(defun current-local-frame ()
  (elt *locals (1- (length *locals))))

;;; Objects

(defun select-obj (title img)
  (loop :for (k v) :of *objs
     :do (setf (getprop v :selected) nil))
  (setf (getprop *objs title :selected) t)
  (call-serv-loc "$ONOBJSEL" title img))

(defun update-objs ()
  (let ((elt (by-id "qsp-objs")))
    (setf (inner-html elt) "<ul>")
    (loop :for (name obj) :of *objs
       :do (incf (inner-html elt)
                 (make-obj name (@ obj :img) (@ obj :selected))))
    (incf (inner-html elt) "</ul>")))

;;; Menu

(defun open-menu (menu-data)
  (let ((elt (get-frame :dropdown))
        (i 0))
    (loop :for item :in menu-data
       :do (incf i)
       :do (incf (inner-html elt)
                 (if (eq item :delimiter)
                     (make-menu-delimiter i)
                     (make-menu-item-html i
                                          (@ item :text)
                                          (@ item :icon)
                                          (@ item :loc)))))
    (let ((mouse (@ window mouse)))
      (setf (@ elt style left) (+ (elt mouse 0) "px"))
      (setf (@ elt style top) (+ (elt mouse 1) "px"))
      ;; Make sure it's inside the viewport
      (when (> (@ document body inner-width)
               (+ (elt mouse 0) (@ elt inner-width)))
        (incf (@ elt style left) (@ elt inner-width)))
      (when (> (@ document body inner-height)
               (+ (elt mouse 0) (@ elt inner-height)))
        (incf (@ elt style top) (@ elt inner-height))))
    (setf (@ elt style display) "block")))

(defun finish-menu (loc)
  (when *menu-resume
    (let ((elt (get-frame :dropdown)))
      (setf (inner-html elt) "")
      (setf (@ elt style display) "none")
      (funcall *menu-resume)
      (setf *menu-resume nil))
    (when loc
      (call-loc loc)))
  (void))

(defun menu (menu-data)
  (with-sleep (resume)
    (open-menu menu-data)
    (setf *menu-resume resume))
  (void))

;;; Content

(defun clean-audio ()
  (loop :for k :in (chain *object (keys *playing))
     :for v := (getprop *playing k)
     :do (when (@ v ended)
           (delete (@ *playing k)))))

(defun show-image (path)
  (let ((img (get-frame :image)))
    (cond (path
           (setf (@ img src) path)
           (setf (@ img style display) "flex"))
          (t
           (setf (@ img src) "")
           (setf (@ img style display) "hidden")))))

(defun show-inline-images (frame-name images)
  (let ((frame (get-frame frame-name))
        (text ""))
    (incf text "<div style='position:relative; display: inline-block'>")
    (incf text (+ "<img src='" (@ images 0) "'>"))
    (loop :for image :in (chain images (slice 1))
       :do (incf text
                 (+ "<img style='position:absolute' src='" image "'>")))
    (incf text "</div>")
    (incf (inner-html frame) text)))

(defun rgb-string (rgb)
  (let ((red (ps::>> rgb 16))
        (green (logand (ps::>> rgb 8) 255))
        (blue (logand rgb 255)))
    (flet ((rgb-to-hex (comp)
             (let ((hex (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)))))

;;; Saves

(defun opengame ()
  (let ((element (chain document (create-element :input))))
    (chain element (set-attribute :type :file))
    (chain element (set-attribute :id :qsp-opengame))
    (chain element (set-attribute :tabindex -1))
    (chain 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 (@ event target files 0))
                   (reader (new (*file-reader))))
              (setf (@ reader onload)
                    (lambda (ev)
                      (block nil
                        (let ((target (@ ev current-target)))
                          (unless (@ target result)
                            (return))
                          (base64-to-state (@ target result))
                          (unstash-state)))))
              (chain reader (read-as-text file)))))
    (chain document body (append-child element))
    (chain element (click))
    (chain document body (remove-child element))))

(defun savegame ()
  (let ((element (chain document (create-element :a))))
    (chain element (set-attribute :href (+ "data:text/plain;charset=utf-8," (state-to-base64))))
    (chain element (set-attribute :download "savegame.sav"))
    (setf (@ element style display) :none)
    (chain document body (append-child element))
    (chain element (click))
    (chain document body (remove-child element))))

(defun stash-state (args)
  (call-serv-loc "$ONGSAVE")
  (setf *state-stash
        (chain *j-s-o-n (stringify
                         (create :vars *globals
                                 :objs *objs
                                 :loc-args args
                                 :msecs (- (chain *date (now)) *started-at)
                                 :timer-interval *timer-interval
                                 :main-html (inner-html
                                             (get-frame :main))
                                 :stat-html (inner-html
                                             (get-frame :stat))
                                 :next-location *current-location))))
  (void))

(defun unstash-state ()
  (let ((data (chain *j-s-o-n (parse *state-stash))))
    (clear-act)
    (setf *globals (@ data :vars))
    (loop :for k :in (chain *object (keys *globals))
       :do (chain *object (set-prototype-of (getprop *globals k)
                                            (@ *var prototype))))
    (setf *started-at (- (chain *date (now)) (@ data :msecs)))
    (setf *objs (@ data :objs))
    (setf *current-location (@ data :next-location))
    (setf (inner-html (get-frame :main))
          (@ data :main-html))
    (setf (inner-html (get-frame :stat))
          (@ data :stat-html))
    (update-objs)
    (set-timer (@ data :timer-interval))
    (call-serv-loc "$ONGLOAD")
    (call-loc *current-location (@ data :loc-args))
    (void)))

(defun state-to-base64 ()
  (btoa (encode-u-r-i-component *state-stash)))

(defun base64-to-state (data)
  (setf *state-stash (decode-u-r-i-component (atob data))))

;;; Timers

(defun set-timer (interval)
  (setf *timer-interval interval)
  (clear-interval *timer-obj)
  (setf *timer-obj
        (set-interval
         (lambda ()
           (call-serv-loc "$COUNTER"))
         interval)))

;;; Special variables

(defvar serv-vars (create))

(define-serv-var backimage (:str path)
  (setf (@ (get-frame :main) style background-image) path))

(define-serv-var bcolor (:num color)
  (setf (@ (get-frame :all) style background-color) (rgb-string color)))

(define-serv-var fcolor (:num color)
  (setf (@ (get-frame :all) style color) (rgb-string color)))

(define-serv-var lcolor (:num color)
  (setf (@ (get-frame :style) inner-text)
        (+ "a { color: " (rgb-string color) ";}")))

(define-serv-var fsize (:num size)
  (setf (@ (get-frame :all) style font-size) size))

(define-serv-var fname (:str font-name)
  (setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))