Bugfixes, remaining font stuff

examples/txt2gam-game.txt

@@ -1,96 +1,97 b''
 
 # start
 USEHTML=1
+BCOLOR = RGB(255, 255, 255)
 '<center><font size="20" color="#FF0000" face="Times New Roman"><b>Текстовый квест</b></font></center><br>'
 '   <b>Ваша цель</b> - зарабатывать <i>деньги</i>, покупать на них <i>подарки</i> и дарить своим <i>близким</i>.'
 ACT '<b>Начать игру</b>':GOTO 'Дом'
 -
 #Работа
 '<center><b>Порт</b></center><br>'
 '   Порт находится на самой южной окраине города. Здесь постоянно загружаются и разгружаются различные суда. Рабочих рук не хватает и складской бригадир всегда рад заплатить <i>деньги</i> за помощь.'
 '   У вас <font size="16"><b><<Деньги>></b></font> монет.'
 '   Вам нужно перенести <font size="16" color="#00AA00"><b><<3-Ящик>></b></font> ящика.'
 ACT 'Идти домой':GOTO 'Дом'
 ACT 'Идти в магазин':GOTO 'Магазин'
 ACT 'Перенести ящик':
 	Ящик = Ящик + 1
     WAIT 500
     IF Ящик = 3:
 		Деньги = Деньги + 5
 		Ящик = 0
 	END
 	GOTO 'Работа'
 END
 -
 #Магазин
 '<center><b>Магазин</b></center><br>'
 '   Магазин небольшой, но тут обычно есть всё, что нужно простому горожанину. Витрины заставлены различными товарами. У кассы стоит полная женщина и хмуро смотрит на вас.'
 '   У вас <font size="16"><b><<Деньги>></b></font> монет.'
 IF Деньги >= 3:
 	ACT 'Купить конструктор':
 		Деньги = Деньги - 3
 		ADDOBJ 'Конструктор'
 		GOTO 'Магазин'
 	END
 END
 IF Деньги >= 5:
 	ACT 'Купить плюшевого медведя':
 		Деньги = Деньги - 5
 		ADDOBJ 'Плюшевый медведь'
 		GOTO 'Магазин'
 	END
 	ACT 'Купить вязальный набор':
 		Деньги = Деньги - 5
 		ADDOBJ 'Вязальный набор'
 		GOTO 'Магазин'
 	END
 END
 IF Деньги >= 7:
 	ACT 'Купить инструменты':
 		Деньги = Деньги - 7
 		ADDOBJ 'Инструменты'
 		GOTO 'Магазин'
 	END
 END
 ACT 'Идти домой':GOTO 'Дом'
 ACT 'Идти в порт':GOTO 'Работа'
 -
 #Дом
 '<center><b>Дом</b></center><br>'
 '   Дома всегда очень уютно. И вкусно пахнет едой. Мама, сидя в кресле, вяжет носки. Отец с вашим братом чинит скворечник. Сестра хлопочет на кухне. Дома всегда хорошо.'
 '   У вас <font size="16"><b><<Деньги>></b></font> монет.'
 IF OBJ 'Конструктор':
 	ACT 'Подарить конструктор брату':
 		DELOBJ 'Конструктор'
 		' - Вот тебе конструктор.'
 		' - Спасибо, брат.'
 		DELACT 'Подарить конструктор брату'
 	END
 END
 IF OBJ 'Плюшевый медведь':
 	ACT 'Подарить медведя сестре':
 		DELOBJ 'Плюшевый медведь'
 		' - Вот тебе плюшевый медведь.'
 		' - Спасибо, брат.'
 		DELACT 'Подарить медведя сестре'
 	END
 END
 IF OBJ 'Вязальный набор':
 	ACT 'Подарить набор маме':
 		DELOBJ 'Вязальный набор'
 		' - Вот тебе вязальный набор.'
 		' - Спасибо, сынок.'
 		DELACT 'Подарить набор маме'
 	END
 END
 IF OBJ 'Инструменты':
 	ACT 'Подарить инструменты отцу':
 		DELOBJ 'Инструменты'
 		' - Вот тебе инструменты.'
 		' - Спасибо, сын.'
 		DELACT 'Подарить инструменты отцу'
 	END
 END
 ACT 'Идти в порт':GOTO 'Работа'
 ACT 'Идти в магазин':GOTO 'Магазин'
 -

extras/default.css

@@ -1,132 +1,136 b''
 
 .qsp-frame {
     border: 1px solid black;
     overflow: auto;
     padding: 5px;
     box-sizing: border-box;
 }
 
 #qsp {
     position: absolute;
     display: flex;
     flex-flow: row;
     top: 0;
     left: 0;
     width: 100%;
     height: 100%;
 }
 
 .qsp-col {
     display: flex;
     flex-flow: column;
 }
 
 .qsp-col1 {
     flex: 7 7 70px;
 }
 
 .qsp-col2 {
     flex: 3 3 30px;
 }
 
 .qsp-col3 {
     flex: 0 0 40px;
 }
 
 #qsp-main {
     flex: 6 6 60px;
     background-repeat: no-repeat;
     background-position: right top;
     background-attachment: fixed;
 }
 
 #qsp-acts {
     flex: 4 4 40px;
 }
 
 #qsp-input {
 }
 
 #qsp-stat {
     flex: 5 5 50px;
 }
 
 #qsp-objs {
     flex: 5 5 50px;
 }
 
 .qsp-act {
     display: block;
     padding: 2px;
     font-size: large;
 }
 
 .qsp-act:hover {
     outline: #9E9E9E outset 3px
 }
 
 /* Dropdown */
 
 #qsp-dropdown {
   display: none;
   position: absolute;
   background-color: #f1f1f1;
   min-width: 160px;
   overflow: auto;
   box-shadow: 0px 8px 16px 0px rgba(0,0,0,0.2);
   z-index: 1;
   margin: auto;
 }
 
 #qsp-dropdown a {
   color: black;
   padding: 12px 16px;
   text-decoration: none;
   display: block;
 }
 
 #qsp-dropdown a:hover {
     background-color: #ddd;
 }
 
 /* Buttons */
 
 .qsp-col3 a, .qsp-col3 img {
     width: 50px;
     height: 50px;
 }
 
 #qsp-btn-save img {
     background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACSklEQVRoge3ZPWgUQRjG8V/iRRFU/GoEQdSohSgWWqQSooVgK9iJFiKCnYV2BkFQsBRBQQwWVsHKIoWxEOzEwmhhogbRMhhFicTvYm+JCUlmZzabRLN/OPaWeZ+ZeW7feXf2lpqampqamnRaImKP4hA2VjCP27hbpoNGwbib2IPreB+IPYY7M7SvxWYM4QNO4QqWyQxVRgdeYnnB+K5A+wUcbB7z+O14hxPx08toLRDTgfv4mjrIJFrwwMS0HsABXMTxlE6LpNYqfE7pPJIBdOKhLM1uxIiLrpG5YtC4GSLMVGGkLdD+GpfxAuvxaVL7oCzN+jCG7iKDVmHkKS5hSSBuJ3bg6hRt+Zrpa553z8bEuoQrUVXk1exwKLBI1ZpPBnAL+0KBqanVim1Ykaifji+yNfIrVphipB1n8BgjCfqZ2IrTuIZXMcIUIydxFj8TtEW4JysW52JEKWtkVHUm4EdzjChSrkgLlmJXghb6m8ep9MN4K25XjvTF3sCaElrT6McS+0w2Mirb+JWhrH4CC/0+UpjUK7Ia5/86f4IeHMHeEvPJ+4km1chHE43k9KROpCyLPrViym8/vjW/b5Jt3acjL7/RzEX5bRg3sjKg+2fK7/PmZ9aZzdTqxwYzp06IBZFaDeHUCbFgUquy1Anx35TfRWXkd+WzCBOcQxEjQ7JH0PmiHW9CQUWM9Mr+Y+osO6ME8nF7Q4FFn8T2y14VDMt2vsFfqCRbZBvTdbLXFI9CgphHyjbsVu4+EcMInuH7HI1XU1NTU7OI+QMFe2N82rtssgAAAABJRU5ErkJggg==');
 }
 
 #qsp-btn-open img {
     background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAYAAAAeP4ixAAAABmJLR0QA/wD/AP+gvaeTAAACCklEQVRoge3Yz6sNYRzH8deVexNxSaEoroWFUuomOceSPVnIwsbSxs6Psrgphf9AsrZR7kJWsroUlrZKKZRSl4USGouZk9Npzp1n5pm5x4/nXdNzpvP9Pp/v95nv82OGRCKRSCQS/w8zuIn3yGpe37CEQ6sedQk38BA7G/jO4BQ+YEebQZUxVfH/OxzGVSxX2D4o2mO4jmt4jpNFe6d5mPFkRbvQ0H9h6OqUtR33/xXr0celGn4/sYjXoQ5dJ3ILB7AOW2r4bcIj7GsrkEFpXWyrwwbaf15nXWqv6SqK1abuHDmPjV0EMobhBWIZt8cZVu0j2ZDNHF7gblRozdiO49g1zqDOEzmKJ7gcGVQTzmLDSgZ1Eunh2dD9aewpsXtctH3cwzn5ALysoVWlXZvhleMV5ovfU8J363mciAliRLsRg0Q244vfT3A/zgT2cQHbImIY1S4ldPk9Ii+NH8V9H08DfbfiY6BtiHYpoYmMBr4bbwN9YzfVoEELnew9+blpwBv5u0oI9wPtQrUbkWFaXqOzsZ01IFg7pLQOyp/A58igmhCsHZJInYndNsHa/0wiVWTy9/a5NjprQGvag0Qmwd462iGltdQ8lihqlVVIIn/9/CAvrajDWgTRB8VhMt1/aSljVr4RToc6hJTWioe1jujJD4rfQx2qRvuTyX1JuTIh3UQikUgkEhPnF+1xZ9hHnLjAAAAAAElFTkSuQmCC');
 }
 
 .center-on-screen {
     position: absolute;
     top: 0;
     left: 0;
     height: 100%;
     width: 100%;
     pointer-events: none;
     display: flex;
     justify-content: center;
     align-items: center;
 }
 
 .center-on-screen > * {
     pointer-events: auto;
 }
 
 #qsp-image-container {
     display: none;
 }
 
 /* misc */
 
 .disable a {
   pointer-events: none;
   cursor: default;
 }
+
+.qsp-objs li.qsp-obj-selected {
+    background-color: blue;
+}

src/api-macros.lisp

@@ -1,46 +1,44 b''
 
 (in-package sugar-qsp.api)
 
 (defpsmacro with-call-args (args &body body)
   `(progn
      (init-args ,args)
      ,@body
      (get-result)))
 
 (defpsmacro with-frame (&body body)
   `(progn
      (push-local-frame)
      (unwind-protect
           ,@body
        (pop-local-frame))))
 
 (defpsmacro href-call (func &rest args)
   `(+ "javascript:" (inline-call ,func ,@args)))
 
 (defpsmacro inline-call (func &rest args)
-  `(+ ,func
+  `(+ ',func
       "(\""
       ,(first args)
       ,@(loop :for arg :in (cdr args)
              :collect "\", \""
              :collect arg)
       "\");"))
 
 (defpsmacro with-sleep ((resume-func) &body body)
   `(new (*promise
          (lambda (resolve)
            (start-sleeping)
            (let ((,resume-func (lambda ()
                                  (finish-sleeping)
                                  (resolve)))))
            ,@body))))
 
-(defvar serv-vars (create))
-
 (defpsmacro define-serv-var (name (slot value &optional index) &body body)
   (setf name (string-upcase (symbol-name name)))
-  `(setf (getprop serv-vars name)
+  `(setf (getprop serv-vars ,name)
          (create :name ,name
                  :slot ,slot
                  :body (lambda (,value ,@(when index (list index)))
                          ,@body))))

src/api.ps

@@ -1,528 +1,536 b''
 
 (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>"
-     "<a href='" (href-call select-obj title img) "'"
-        "class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
+  (+ "<li onclick='" (inline-call select-obj title img) "'>"
+     "<a class='qsp-obj" (if selected " qsp-obj-selected" "") "'>"
      (if img (+ "<img src='" img "'>") "")
-     obj
+     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)
-       (setf (getprop v :selected) nil))
+     :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 :func)
+      (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)
-       (setf (getprop v :selected) nil))
+     :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 obj :in (root objs)
+    (loop :for (name obj) :of (root objs)
        :do (incf (inner-html elt)
-                 (make-obj obj)))
+                 (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 rgb-string (rgb)
-  (let ((red (rgb >> 16))
-        (green (& (rgb >> 8) 255))
-        (blue (& rgb 255)))
+  (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")))

src/intrinsic-macros.lisp

@@ -1,168 +1,168 b''
 
 (in-package sugar-qsp.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 (varname &optional index)
   `(api-call kill-var ,varname ,index))
 
 (defpsmacro killall ()
   `(api-call kill-all))
 
 ;;; 3expr
 
 (defpsmacro obj (name)
-  `(funcall (root objs includes) ,name))
+  `(in ,name (root objs)))
 
 (defpsmacro loc (name)
-  `(funcall (root locs includes) ,name))
+  `(in ,name (root locs)))
 
 (defpsmacro no (arg)
   `(- -1 ,arg))
 
 ;;; 4code
 
 (defpsmacro qspver ()
   "0.0.1")
 
 (defpsmacro curloc ()
   `(root 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 replace (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
 
 ;;; 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 (name)
   `(api-call del-act ,name))
 
 (defpsmacro cla ()
   `(api-call clear-act))
 
 ;;; 15objs
 
 (defpsmacro showobjs (enable)
   `(api-call enable-frame :objs ,enable))
 
 (defpsmacro countobj ()
   `(length (root objs)))
 
 (defpsmacro getobj (index)
   `(or (elt (root objs) ,index) ""))
 
 ;;; 16menu
 
 ;;; 17sound
 
 (defpsmacro isplay (filename)
   `(funcall (root 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/js-syms.lisp

@@ -1,41 +1,41 b''
 
 (in-package sugar-qsp.js)
 
 ;;; Contains symbols from standard JS library to avoid obfuscating
 ;;; and/or namespacing them
 
 (cl:defmacro syms (cl:&rest syms)
   `(cl:progn
      ,@(cl:loop :for sym :in syms
           :collect `(cl:export ',sym))))
 
 (syms
  ;; main
  window
  *object assign
  now
  onload
  keys includes
  has-own-property
  ;; api
- document get-element-by-id
+ document get-element-by-id get-elements-by-tag-name
  onclick onchange
  atob btoa split
  alert prompt
  set-timeout set-interval clear-interval
  *promise *j-s-o-n
  href parse match
  set-prototype-of
  body append-child remove-child
  add ; remove (is already in COMMON-LISP)
  create-element set-attribute class-list
  *file-reader read-as-text
  style display src
  page-x page-y
  top left
  ;; lib
  *number parse-int
  to-string to-upper-case concat
  click target current-target files index-of result
  decode-u-r-i-component splice
  )

src/patches.lisp

@@ -1,69 +1,74 b''
 
 (in-package parenscript)
 
 ;;; async/await
 
 (defprinter ps-js::await (x)
   (psw (string-downcase "await "))
   (print-op-argument 'ps-js::await x))
 
 (define-trivial-special-ops await ps-js::await)
 
 (define-statement-operator async-defun (name lambda-list &rest body)
   (multiple-value-bind (effective-args body-block docstring)
       (compile-named-function-body name lambda-list body)
     (list 'ps-js::async-defun name effective-args docstring body-block)))
 
 (defprinter ps-js::async-defun (name args docstring body-block)
   (when docstring (print-comment docstring))
   (psw "async ")
   (print-fun-def name args body-block))
 
 (define-expression-operator async-lambda (lambda-list &rest body)
   (multiple-value-bind (effective-args effective-body)
       (parse-extended-function lambda-list body)
     `(ps-js::async-lambda
       ,effective-args
       ,(let ((*function-block-names* ()))
          (compile-function-body effective-args effective-body)))))
 
 (defprinter ps-js::async-lambda (args body-block)
   (psw "async ")
   (print-fun-def nil args body-block))
 
 (cl:export 'await)
 (cl:export 'async-defun)
 (cl:export 'async-lambda)
 
 ;;; ES6
 
 (define-expression-operator => (lambda-list &rest body)
   (unless (listp lambda-list)
     (setf lambda-list (list lambda-list)))
   (multiple-value-bind (effective-args effective-body)
       (parse-extended-function lambda-list body)
     `(ps-js::=>
       ,effective-args
       ,(let ((*function-block-names* ()))
          (compile-function-body effective-args effective-body)))))
 
 (defprinter ps-js::=> (args body)
   (unless (= 1 (length args))
     (psw "("))
   (loop for (arg . remaining) on args do
        (psw (symbol-to-js-string arg)) (when remaining (psw ", ")))
   (unless (= 1 (length args))
     (psw ")"))
   (psw " => ")
   (ps-print body))
 
 (cl:export '=>)
 
 ;;; Actually return nothing (with no empty return)
 (defvar *old-return-result-of* (function return-result-of))
 
 (defun return-result-of (tag form)
   (if (equal form '(void))
       nil
       (funcall *old-return-result-of* tag form)))
 (export 'void)
+
+;;; Bitwise stuff
+;; No idea why these are not exported
+(export '<<)
+(export '>>)