Multiple sources, multiple games, openqst/addqst/killqst

TODO

@@ -1,5 +1,4 b''
 
-* MENU with async/await
 * Special locations
 * Special variables
 * CLI build for Linux
@@ -11,6 +10,7 b''
 * Report JUMP with missing label (in tagbody)
 
 * Build Istreblenie
+* Build Цветохимия
 * Windows GUI (for the compiler)
 * Save-load game in slots
 * Resizable frames

qlfile

@@ -1,13 +1,11 b''
 ql alexandria
 ql esrap
 ql parenscript
-ql cl-uglify-js
 ql flute
 
 ql cl-ppcre
 ql anaphora
 ql named-readtables
-ql parse-js
 ql cl-unicode
 ql flexi-streams
 ql trivial-gray-streams

src/api.ps

@@ -62,6 +62,19 b''
         (when loc
           (funcall loc 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)

src/intrinsics.ps

@@ -13,10 +13,11 b''
   (void))
 
 (defun xgoto (target args)
+  (setf args (or args (list)))
   (api:clear-act)
   (setf (root current-location) (chain target (to-upper-case)))
   (api:stash-state args)
-  (api:call-loc (root current-location) (or args (list)))
+  (api:call-loc (root current-location) args)
   (void))
 
 ;;; 2var
@@ -292,11 +293,18 b''
                  hex))))
     (+ "#" (rgb-to-hex red) (rgb-to-hex green) (rgb-to-hex red))))
 
-(defun openqst ()
-  (api:report-error "OPENQST is not supported."))
+(defun openqst (name)
+  (api-call run-game name))
 
-(defun addqst ()
-  (api:report-error "ADDQST is not supported. Bundle the library with the main game."))
+(defun addqst (name)
+  (let ((game (api-call filename-game name)))
+    ;; Add the game's locations
+    (chain *object (assign (root locs)
+                           (getprop (root games) name)))))
 
 (defun killqst ()
-  (api:report-error "KILLQST is not supported."))
+  ;; Delete all locations not from the current main game
+  (loop :for (k v) :in (root games)
+     :do (unless (string= k (root main-game))
+           (delete (getprop (root locs) k)))))
+

src/js-syms.lisp

@@ -24,7 +24,7 b''
  alert prompt
  set-timeout set-interval clear-interval
  *promise *j-s-o-n
- href parse
+ href parse match
  set-prototype-of
  body append-child remove-child
  add ; remove (is already in COMMON-LISP)

src/main.lisp

@@ -11,8 +11,8 b''
   (values))
 
 (defun parse-opts (args)
-  (let ((mode :source)
-        (data (list :source nil :target nil :js nil :css nil :body nil :compile nil :beautify nil)))
+  (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))
@@ -22,9 +22,9 b''
              ("-c" (setf (getf data :compile) t))
              ("--beautify" (setf (getf data :beautify) t))
              (t (push arg (getf data mode)))))
-    (unless (= 1 (length (getf data :source)))
+    (unless (< 0 (length (getf data :sources)))
       (print-usage)
-      (report-error "There should be exactly one source"))
+      (report-error "There should be at least one source"))
     (unless (> 1 (length (getf data :target)))
       (print-usage)
       (report-error "There should be no more than one target"))
@@ -33,12 +33,12 b''
       (report-error "There should be no more than one body"))
     (unless (getf data :target)
       (setf (getf data :target)
-            (let* ((source (first (getf data :source)))
-                   (tokens (uiop:split-string source :separator "."))
+            (let* ((sources (first (getf data :sources)))
+                   (tokens (uiop:split-string sources :separator "."))
                    (target (format nil "~{~A~^.~}.html"
                                    (butlast tokens))))
               (list target))))
-    (list :source (first (getf data :source))
+    (list :sources (getf data :sources)
           :target (first (getf data :target))
           :js (getf data :js)
           :css (getf data :css)
@@ -102,12 +102,25 b''
        :stream out
        :pretty nil))))
 
-(defmethod initialize-instance ((compiler compiler) &key source ((:js js-files)) ((:css css-files)) ((:body body-file)) compile &allow-other-keys)
+(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
-    (push (list* 'progn (parse-file source)) 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
@@ -129,7 +142,7 b''
   (alexandria:write-string-into-file
    (if (compile-only compiler)
        ;; Just the JS
-       (preprocess-js (js-sources compiler) (beautify compiler))
+       (js-sources compiler)
        ;; All of it
        (html-sources compiler))
    (target compiler) :if-exists :supersede))

src/main.ps

@@ -3,7 +3,7 b''
 
 (setf (root)
       (create
-       ;;; Game session state
+       ;;; Game session state (saved in savegames)
        ;; Variables
        vars (create)
        ;; Inventory (objects)
@@ -14,17 +14,25 b''
        ;; Timers
        timer-interval 500
        timer-obj nil
+       ;; Games
+       loaded-games (list)
+
        ;;; Transient state
+       ;; ACTions
+       acts (create)
        ;; Savegame data
        state-stash (create)
        ;; List of audio files being played
        playing (create)
        ;; Local variables stack (starts with an empty frame)
        locals (list)
+
        ;;; Game data
-       ;; ACTions
-       acts (create)
-       ;; Locations
+       ;; Games (filename -> [locations])
+       games (list)
+       ;; The main (non library) game. Updated by openqst
+       main-game nil
+       ;; Active locations
        locs (create)))
 
 ;; Launch the game from the first location
@@ -36,9 +44,8 b''
         ;; For $COUNTER and SETTIMER
         (#.(intern "SET-TIMER" "SUGAR-QSP.API")
            (root timer-interval))
-        ;; Start the first location
-        (funcall (getprop (root locs)
-                          (chain *object (keys (root locs)) 0))
-                 (list))
+        ;; Start the first game
+        (#.(intern "RUN-GAME" "SUGAR-QSP.API")
+           (chain *object (keys (root games)) 0))
         (values)))
 

src/package.lisp

@@ -10,7 +10,7 b''
            #:vars #:objs #:current-location
            #:started-at #:timer-interval #:timer-obj
            #:state-stash #:playing #:locals
-           #:acts #:locs))
+           #:acts #:locs #:games))
 
 ;;; API functions
 (defpackage :sugar-qsp.api
@@ -39,7 +39,7 b''
 (defpackage :sugar-qsp.lib
   (:use :cl :ps :sugar-qsp.main :sugar-qsp.js)
   (:local-nicknames (#:api :sugar-qsp.api))
-  (:export #:str #:exec #:qspblock #:qspfor #:location
+  (:export #:str #:exec #:qspblock #:qspfor #:game #:location
            #:qspcond #:qspvar #:set #:local #:jump
 
            #:killvar #:killall

src/parser.lisp

@@ -176,7 +176,8 b''
 
 (p:defrule sugar-qsp-grammar (and (* (or spaces #\newline))
                                   (* location))
-  (:function second))
+  (:lambda (list)
+    `(lib:game ,@(second list))))
 
 (p:defrule location (and location-header block-body location-end)
   (:destructure (header body end)

src/ps-macros.lisp

@@ -29,11 +29,20 b''
 
 ;;; 1loc
 
+(defpsmacro game ((name) &body body)
+  `(progn
+     (setf (root games ,name)
+           (create))
+     ,@(loop :for location :in body
+          :collect `(setf (root games ,name ,(caadr location))
+                          ,location))))
+
 (defpsmacro location ((name) &body body)
-  `(setf (root locs ,name)
-         (async-lambda (args)
-                       (label-block ()
-                         ,@body))))
+  (declare (ignore name))
+  "Name is used by the game macro above"
+  `(async-lambda (args)
+     (label-block ()
+       ,@body)))
 
 (defpsmacro goto% (target &rest args)
   `(progn