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 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-var var-name 0 :str)))
    (when loc-name
      (let ((loc (getprop (root 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 (root games) game-name))

(defun run-game (name)
  (let ((game (filename-game name)))
    (setf (root main-game) name)
    ;; Replace locations with the new game's 
    (setf (root 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)) ""))

(defvar text-escaper (chain document (create-element :textarea)))

(defun prepare-contents (s &optional force-html)
  (if (or force-html (get-var "USEHTML" 0 :num))
      s
      (progn
        (setf (@ text-escaper text-content) s)
        (inner-html text-escaper))))

(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 ()
  (if (not (equal "" (get-var "RESULT" 0 :str)))
      (get-var "RESULT" 0 :str)
      (get-var "RESULT" 0 :num)))

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

(defun call-act (title)
  (with-frame
      (funcall (getprop (root acts) title :act))))

;;; 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 (root acts) title)
        (create :title title :img img :act act :selected nil))
  (update-acts))

(defun del-act (title)
  (delete (getprop (root acts) title))
  (update-acts))

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

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

(defun select-act (title)
  (loop :for (k v) :of (root acts)
     :do (setf (getprop v :selected) nil))
  (setf (getprop (root 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 (funcall body)
         (return-from qspfor))))

;;; Variable class

(defun *var (name)
  ;; From strings to numbers
  (setf (@ this :indexes) (create))
  ;; From numbers to {num: 0, str: ""} objects
  (setf (@ this :values) (list))
  (void))

(defun new-value ()
  (create :num 0 :str ""))

(setf (@ *var prototype index-num)
      (lambda (index)
        (let ((num-index
               (if (stringp index)
                   (if (in index (@ this :indexes))
                       (getprop (@ this :indexes) index)
                       (let ((n (length (@ this :values))))
                         (setf (getprop (@ this :indexes) index) n)
                         n))
                   index)))
          (unless (in num-index (@ this :values))
            (setf (elt (@ this :values) num-index) (new-value)))
          num-index)))

(setf (@ *var prototype get)
      (lambda (index slot)
        (unless (or index (= 0 index))
          (setf index (1- (length (@ this :values)))))
        (getprop (@ this :values) (chain this (index-num index)) slot)))

(setf (@ *var prototype set)
      (lambda (index slot value)
        (unless (or index (= 0 index))
          (setf index (length (@ this :values))))
        (case slot
          (:num (setf value (chain *number (parse-int value))))
          (:str (setf value (chain value (to-string)))))
        (setf (getprop (@ this :values)
                       (chain this (index-num index))
                       slot) value)
        (void)))

(setf (@ *var prototype kill)
      (lambda (index)
        (setf (elt (@ this :values) (chain this (index-num index)))
              (new-value))
        (delete (getprop 'this :indexes index))))

;;; Variables

(defun var-real-name (name)
  (if (= (@ name 0) #\$)
      (values (chain name (substr 1)) :str)
      (values name :num)))

(defun ensure-var (name)
  (setf name (chain name (to-upper-case)))
  (let ((store (var-ref name)))
    (unless store
      (setf store (new (*var name)))
      (setf (getprop (root vars) name) store))
    store))

(defun var-ref (name)
  (let ((local-store (current-local-frame)))
    (cond ((and local-store (in name local-store))
           (getprop local-store name))
          ((in name (root vars))
           (getprop (root vars) name))
          (t nil))))

(defun get-var (name index slot)
  (chain (ensure-var name) (get index slot)))

(defun set-var (name index slot value)
  (chain (ensure-var name) (set index slot value))
  (let ((serv-var (getprop serv-vars name)))
    (when serv-var
      (funcall (@ serv-var :body)
               (get-var name index (@ serv-var :slot))
               index)))
  (void))

(defun get-array (name)
  (setf name (chain name (to-upper-case)))
  (ensure-var name))

(defun set-array (name value)
  (setf name (chain name (to-upper-case)))
  (let ((store (ensure-var name)))
    (setf (@ store :values) (@ value :values))
    (setf (@ store :indexes) (@ value :indexes)))
  (void))

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

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

;;; Locals

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

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

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

(defun new-local (name)
  (let ((frame (current-local-frame)))
    (unless (in name frame)
      (setf (getprop frame name) (create)))
    (void)))

;;; Objects

(defun select-obj (title img)
  (loop :for (k v) :of (root objs)
     :do (setf (getprop v :selected) nil))
  (setf (getprop (root 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 (root 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 (root menu-resume)
    (let ((elt (get-frame :dropdown)))
      (setf (inner-html elt) "")
      (setf (@ elt style display) "none")
      (funcall (root menu-resume))
      (setf (root menu-resume) nil))
    (when loc
      (call-loc loc)))
  (void))

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

;;; Content

(defun clean-audio ()
  (loop :for k :in (chain *object (keys (root playing)))
     :for v := (getprop (root playing) k)
     :do (when (@ v ended)
           (delete (@ (root 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 (root state-stash)
        (chain *j-s-o-n (stringify
                         (create :vars (root vars)
                                 :objs (root objs)
                                 :loc-args args
                                 :msecs (- (chain *date (now)) (root started-at))
                                 :timer-interval (root timer-interval)
                                 :main-html (inner-html
                                             (get-frame :main))
                                 :stat-html (inner-html
                                             (get-frame :stat))
                                 :next-location (root current-location)))))
  (void))

(defun unstash-state ()
  (let ((data (chain *j-s-o-n (parse (root state-stash)))))
    (clear-act)
    (setf (root vars) (@ data :vars))
    (loop :for k :in (chain *object (keys (root vars)))
       :do (chain *object (set-prototype-of (getprop (root vars) k)
                                            (@ *var prototype))))
    (setf (root started-at) (- (chain *date (now)) (@ data :msecs)))
    (setf (root objs) (@ data :objs))
    (setf (root 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 (root current-location) (@ data :loc-args))
    (void)))

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

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

;;; Timers

(defun set-timer (interval)
  (setf (root timer-interval) interval)
  (clear-interval (root timer-obj))
  (setf (root 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")))