diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,5 +1,4 @@ -* MENU with async/await * Special locations * Special variables * CLI build for Linux @@ -11,6 +10,7 @@ * Report JUMP with missing label (in tagbody) * Build Istreblenie +* Build Цветохимия * Windows GUI (for the compiler) * Save-load game in slots * Resizable frames diff --git a/qlfile b/qlfile --- a/qlfile +++ b/qlfile @@ -1,13 +1,11 @@ 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 diff --git a/src/api.ps b/src/api.ps --- a/src/api.ps +++ b/src/api.ps @@ -62,6 +62,19 @@ (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) diff --git a/src/intrinsics.ps b/src/intrinsics.ps --- a/src/intrinsics.ps +++ b/src/intrinsics.ps @@ -13,10 +13,11 @@ (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 @@ 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))))) + diff --git a/src/js-syms.lisp b/src/js-syms.lisp --- a/src/js-syms.lisp +++ b/src/js-syms.lisp @@ -24,7 +24,7 @@ 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) diff --git a/src/main.lisp b/src/main.lisp --- a/src/main.lisp +++ b/src/main.lisp @@ -11,8 +11,8 @@ (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 @@ ("-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 @@ (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 @@ :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 @@ (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)) diff --git a/src/main.ps b/src/main.ps --- a/src/main.ps +++ b/src/main.ps @@ -3,7 +3,7 @@ (setf (root) (create - ;;; Game session state + ;;; Game session state (saved in savegames) ;; Variables vars (create) ;; Inventory (objects) @@ -14,17 +14,25 @@ ;; 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 @@ ;; 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))) diff --git a/src/package.lisp b/src/package.lisp --- a/src/package.lisp +++ b/src/package.lisp @@ -10,7 +10,7 @@ #: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 @@ (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 diff --git a/src/parser.lisp b/src/parser.lisp --- a/src/parser.lisp +++ b/src/parser.lisp @@ -176,7 +176,8 @@ (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) diff --git a/src/ps-macros.lisp b/src/ps-macros.lisp --- a/src/ps-macros.lisp +++ b/src/ps-macros.lisp @@ -29,11 +29,20 @@ ;;; 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