Remove qlot

INSTALL.md

@@ -0,0 +1,4 b''
+
+1. Install sbcl using your distribution's package manager, or download it from https://sbcl.org
+2. Install quicklisp from https://quicklisp.org E.g. `wget https://beta.quicklisp.org/quicklisp.lisp && sbcl --load quicklisp.org` then follow instructions.
+3. `make`

.hgignore

@@ -1,7 +1,8 b''
 .*~
 .qlot
 .html
 .png
+.orig
 tests
-sugar-qsp
-sugar-qsp.tar.xz
+txt2web
+txt2web.tar.xz

Makefile

@@ -1,39 +1,32 b''
 
 BIN = txt2web
 DIST = $(BIN).tar.xz
 
 all: $(BIN)
 
 dist: $(DIST)
 
 graphs: diagrams.png
 
 $(BIN): *.asd src/*.lisp src/*.ps strings/*.sexp
 	sbcl --load build.lisp -- $(BIN)
 
-install-deps:
-	sbcl --load install-deps.lisp
-
-update-deps:
-	sbcl --load update-deps.lisp
-
 %.png: %.dot
 	dot $< -T png -o $@
 
 $(DIST): $(BIN) extras/*
 	tar cfvJ $@ $< extras
 
 upload: $(DIST)
 	curl --upload-file $(DIST) https://transfer.sh/$(DIST)
 	@echo
 
-distclean: clean clean-deps
-
 clean:
 	rm -f $(BIN) $(DIST)
 
-clean-deps:
-	-rm qlfile.lock
-	-rm -rf .qlot
+clean-cache:
+	-rm -rf ~/.cache/common-lisp
 
-.PHONY: all graphs install-deps update-deps clean upload
+fresh: clean clean-cache all
+
+.PHONY: all graphs upload clean clean-cache fresh

build.lisp

@@ -1,10 +1,4 b''
-(let ((root (asdf:system-source-directory :txt2web)))
-  (asdf:initialize-source-registry
-   `(:source-registry
-     :ignore-inherited-configuration
-     (:directory ,root)
-     (:tree ,(format nil "~A~A" root ".qlot/dists")))))
+(ql:quickload :txt2web)
 
-(asdf:load-system :txt2web)
 (uiop:register-image-restore-hook 'txt2web::entry-point-no-args nil)
 (uiop:dump-image "txt2web" :executable t)

src/api.ps

@@ -1,531 +1,531 b''
 
 (in-package txt2web)
 
 ;;; 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)
   (with-frame
       (funcall (getprop *acts title :act)))
   (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 (title)
   (delete (getprop *acts title))
   (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))
+  (ps: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))))
   (void))
 
 (defun set-any-element (slot index value)
   (cond ((null index)
          (chain (elt slot) (push value)))
         ((numberp index)
          (setf (elt slot index) value))
         ((stringp index)
          (set-str-element slot index value))
         (t (report-error "INTERNAL ERROR")))
   (void))
 
 (defun set-serv-var (name index value)
   (let ((slot (getprop *globals name)))
     (set-any-element slot index value))
   (funcall (getprop serv-vars name :body) value index)
   (void))
 
 (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 blue)))))
 
 (defun store-obj (key obj)
   (store-str key (btoa (encode-u-r-i-component (chain *j-s-o-n (stringify obj)))))
   (void))
 (defun store-str (key str)
   (chain local-storage (set-item (+ "qsp_" key) str))
   (void))
 
 (defun load-obj (key)
   (chain *j-s-o-n (parse (encode-u-r-i-component (atob (load-str key))))))
 (defun load-str (key)
   (chain local-storage (get-item (+ "qsp_" key))))
 
 ;;; Saves
 
 (defun slot-savegame (slot comment)
   (let ((saves (load-obj "saves")))
     (setf (@ saves slot) comment)
     (store-obj saves))
   (store-str slot (state-to-base64))
   (void))
 
 (defun slot-loadgame (slot)
   (base64-to-state (load-str slot))
   (void))
 
 (defun slot-deletegame (slot)
   (let ((saves (load-obj "saves")))
     (setf (@ saves slot) undefined)
     (store-obj saves))
   (store-str slot undefined)
   (void))
 
 (defun slot-listgames ()
   (load-obj "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 (path)
   (setf (@ (get-frame :main) style background-image) path))
 
 (define-serv-var bcolor (color)
   (setf (@ (get-frame :all) style background-color) (rgb-string color)))
 
 (define-serv-var fcolor (color)
   (setf (@ (get-frame :all) style color) (rgb-string color)))
 
 (define-serv-var lcolor (color)
   (setf (@ (get-frame :style) inner-text)
         (+ "a { color: " (rgb-string color) ";}")))
 
 (define-serv-var fsize (size)
   (setf (@ (get-frame :all) style font-size) size))
 
 (define-serv-var $fname (font-name)
   (setf (@ (get-frame :all) style font-family) (+ font-name ",serif")))

src/main.lisp

@@ -1,153 +1,153 b''
 
 (in-package txt2web)
 
 (defvar *app-name* "")
 
 (defun entry-point-no-args ()
   (entry-point uiop:*command-line-arguments*))
 
 (defun entry-point (args)
   (setf *app-name* (uiop:argv0))
   (let ((*package* (find-package :txt2web)))
     (catch :terminate
       (let ((compiler (apply #'make-instance 'compiler (parse-opts args))))
         (write-compiled-file compiler))))
   (values))
 
 (defun parse-opts (args)
   (let ((mode :sources)
         (data (list :sources nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
     (loop :for arg :in args
        :do (alexandria:switch (arg :test #'string=)
              ("-o" (setf mode :target))
              ("--js" (setf mode :js))
              ("--css" (setf mode :css))
              ("--body" (setf mode :body))
              ("-c" (setf (getf data :compile) t))
              ("--beautify" (setf (getf data :beautify) t))
              (t (push arg (getf data mode)))))
     (unless (< 0 (length (getf data :sources)))
       (report-error "There should be at least one source"))
     (unless (> 1 (length (getf data :target)))
       (report-error "There should be no more than one target"))
     (unless (> 1 (length (getf data :body)))
       (report-error "There should be no more than one body"))
     (unless (getf data :target)
       (setf (getf data :target)
             (let* ((sources (first (getf data :sources)))
                    (tokens (uiop:split-string sources :separator "."))
                    (target (format nil "~{~A~^.~}.html"
                                    (butlast tokens))))
               (list target))))
     (list :sources (getf data :sources)
           :target (first (getf data :target))
           :js (getf data :js)
           :css (getf data :css)
           :body (first (getf data :body))
           :compile (getf data :compile)
           :beautify (getf data :beautify))))
 
 (defun print-usage ()
   (lformat t :usage *app-name*))
 
 (defun parse-file (filename)
   (p:parse 'txt2web-grammar
            (alexandria:read-file-into-string filename)))
 
 (defun report-error (fmt &rest args)
   (format t "ERROR: ~A~%" (apply #'format nil fmt args))
   (print-usage)
   (throw :terminate nil))
 
 ;;; JS
 
 (defun minify-package (package-designator minify prefix)
   (setf (ps:ps-package-prefix package-designator) prefix)
   (if minify
       (ps:obfuscate-package package-designator)
       (ps:unobfuscate-package package-designator)))
 
 (defmethod js-sources ((compiler compiler))
   (let ((ps:*ps-print-pretty* (beautify compiler)))
     (cond ((beautify compiler)
            (minify-package "TXT2WEB.MAIN" nil "qsp_")
            (minify-package "TXT2WEB.API"  nil "qsp_api_")
            (minify-package "TXT2WEB.LIB"  nil "qsp_lib_"))
           (t
            (minify-package "TXT2WEB.MAIN" t   "_")
            (minify-package "TXT2WEB.API"  t   "a_")
            (minify-package "TXT2WEB.LIB"  t   "l_")))
     (format nil "~{~A~^~%~%~}" (mapcar #'ps:ps* (reverse (js compiler))))))
 
 ;;; CSS
 
 (defmethod css-sources ((compiler compiler))
   (format nil "~{~A~^~%~%~}" (css compiler)))
 
 ;;; HTML
 
 (defmethod html-sources ((compiler compiler))
   (let ((flute:*escape-html* nil)
         (body-template (body compiler))
         (js (js-sources compiler))
         (css (css-sources compiler)))
     (with-output-to-string (out)
       (write
        (flute:h
          (html
           (head
-           (title "SugarQSP"))
+           (title "txt2web"))
           (body
            body-template
            (style css)
            (script js))))
        :stream out
        :pretty nil))))
 
 (defun filename-game (filename)
   (let ((filename (alexandria:lastcar (uiop:split-string filename :separator "/"))))
     (format nil "~{~A~^.~}" (butlast (uiop:split-string filename :separator ".")))))
 
 (defmethod initialize-instance ((compiler compiler) &key sources ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
   (call-next-method)
   (with-slots (body css js)
       compiler
     ;; Compile the game's JS
     (dolist (source sources)
       (let ((ps (parse-file source))
             (game-name (filename-game source)))
         (destructuring-bind (kw &rest locations)
             ps
           (unless (eq kw 'lib:game)
             (report-error "Internal error!"))
           (push 
            `(lib:game (,game-name) ,@locations)
            js))))
     ;; Does the user need us to do anything else
     (unless compile
       ;; Read in body
       (when body-file
         (setf body
               (alexandria:read-file-into-string body-file)))
       ;; Include js files
       (dolist (js-file js-files)
         (push (format nil "////// Included file ~A~%~A" js-file
                       (alexandria:read-file-into-string js-file))
               js))
       ;; Include css files
       (when css-files
         ;; User option overrides the default css
         (setf css nil)
         (dolist (css-file css-files)
           (push (format nil "////// Included file ~A~%~A" css-file
                         (alexandria:read-file-into-string css-file))
                 css))))))
 
 (defmethod write-compiled-file ((compiler compiler))
   (alexandria:write-string-into-file
    (if (compile-only compiler)
        ;; Just the JS
        (js-sources compiler)
        ;; All of it
        (html-sources compiler))
    (target compiler) :if-exists :supersede))