From 086e3362830393bcd51a3d79fe50c66ca15b7112 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 3 Aug 2017 10:39:58 -0500 Subject: [PATCH] Update codebase to use 8sync-fibers --- Makefile.am | 1 + data/web-static/css/main.css | 4 +- guix.scm | 3 +- mudsync/container.scm | 23 ++++----- mudsync/game-master.scm | 12 ++--- mudsync/gameobj.scm | 73 ++++++++++++++--------------- mudsync/networking.scm | 15 +++--- mudsync/package-config.scm | 7 +-- mudsync/player.scm | 13 +++--- mudsync/receive-star.scm | 27 +++++++++++ mudsync/room.scm | 20 ++++---- mudsync/run-game.scm | 45 ++++++++++-------- worlds/bricabrac.scm | 90 +++++++++++++++++------------------- 13 files changed, 182 insertions(+), 151 deletions(-) create mode 100644 mudsync/receive-star.scm diff --git a/Makefile.am b/Makefile.am index 15f8e8d..8738105 100644 --- a/Makefile.am +++ b/Makefile.am @@ -54,6 +54,7 @@ SOURCES = \ mudsync/player.scm \ mudsync/room.scm \ mudsync/run-game.scm \ + mudsync/receive-star.scm \ mudsync/package-config.scm \ mudsync/utils.scm \ mudsync/contrib/mime-types.scm \ diff --git a/data/web-static/css/main.css b/data/web-static/css/main.css index 2bda6fc..8138f6c 100644 --- a/data/web-static/css/main.css +++ b/data/web-static/css/main.css @@ -2,14 +2,14 @@ font-family: 'Inconsolata'; font-style: normal; font-weight: 400; - src: local('Inconsolata-Regular'), local('Inconsolata'), local('Inconsolata Regular'), url('../fonts/inconsolata/Inconsolata-Regular.ttf'); + src: url('../fonts/inconsolata/Inconsolata-Regular.ttf'); } @font-face { font-family: 'Inconsolata'; font-style: normal; font-weight: 700; - src: local('Inconsolata-Bold'), local('Inconsolata Bold'), url('../fonts/inconsolata/Inconsolata-Bold.ttf'); + src: url('../fonts/inconsolata/Inconsolata-Bold.ttf'); } *, *:before, *:after { diff --git a/guix.scm b/guix.scm index 6a98699..8963b30 100644 --- a/guix.scm +++ b/guix.scm @@ -64,7 +64,8 @@ ("texinfo" ,texinfo))) (inputs `(("guile" ,guile-2.2) ("guile-8sync" ,guile-8sync) - ("guile-irregex" ,guile2.2-irregex))) + ("guile-irregex" ,guile2.2-irregex) + ("guile-fibers" ,guile-fibers))) (arguments `(#:phases (modify-phases %standard-phases (add-before 'configure 'bootstrap diff --git a/mudsync/container.scm b/mudsync/container.scm index 3e7763d..65ef0b7 100644 --- a/mudsync/container.scm +++ b/mudsync/container.scm @@ -26,6 +26,7 @@ #:use-module (8sync) #:use-module (oop goops) #:use-module (mudsync gameobj) + #:use-module (mudsync receive-star) #:use-module (mudsync utils) #:use-module (ice-9 control) #:export ( @@ -49,23 +50,23 @@ #:key direct-obj indir-obj preposition (player (message-from message))) (define player-name - (mbody-val (<-wait player 'get-name))) + (<-wait player 'get-name)) (define player-loc - (mbody-val (<-wait player 'get-loc))) + (<-wait player 'get-loc)) (define our-name (slot-ref gameobj 'name)) ;; We need to check if we even have such a thing (define this-thing (call/ec (lambda (return) (for-each (lambda (occupant) - (define goes-by (mbody-val (<-wait occupant 'goes-by))) + (define goes-by (<-wait occupant 'goes-by)) (when (ci-member direct-obj goes-by) (return occupant))) (gameobj-occupants gameobj)) ;; nothing found #f))) (define (this-thing-name) - (mbody-val (<-wait this-thing 'get-name))) + (<-wait this-thing 'get-name)) (define (should-take-from-me) (and this-thing (slot-ref-maybe-runcheck gameobj 'take-from-me? player this-thing))) @@ -74,7 +75,7 @@ ,(this-thing-name) " " ,preposition " " ,our-name ".")) (define (this-thing-objection) - (mbody-receive (_ taken-ok? #:key why-not) ; does the object object to being removed? + (receive* (taken-ok? #:key why-not) ; does the object object to being removed? (<-wait this-thing 'ok-to-be-taken-from? player) ; @@ no need to supply from where (and (not taken-ok?) ;; Either give the specified reason, or give a boilerplate one @@ -115,23 +116,23 @@ #:key direct-obj indir-obj preposition (player (message-from message))) (define player-name - (mbody-val (<-wait player 'get-name))) + (<-wait player 'get-name)) (define player-loc - (mbody-val (<-wait player 'get-loc))) + (<-wait player 'get-loc)) (define our-name (slot-ref gameobj 'name)) ;; We need to check if we even have such a thing (define this-thing (call/ec (lambda (return) (for-each (lambda (occupant) - (define goes-by (mbody-val (<-wait occupant 'goes-by))) + (define goes-by (<-wait occupant 'goes-by)) (when (ci-member direct-obj goes-by) (return occupant))) - (mbody-val (<-wait player 'get-occupants))) + (<-wait player 'get-occupants)) ;; nothing found #f))) (define (this-thing-name) - (mbody-val (<-wait this-thing 'get-name))) + (<-wait this-thing 'get-name)) (define (should-put-in-me) (and this-thing (slot-ref-maybe-runcheck gameobj 'put-in-me? player this-thing))) @@ -139,7 +140,7 @@ `("As much as you'd like to, it doesn't seem like you can put " ,(this-thing-name) " " ,preposition " " ,our-name ".")) (define (this-thing-objection) - (mbody-receive (_ put-in-ok? #:key why-not) ; does the object object to being moved? + (receive* (put-in-ok? #:key why-not) ; does the object object to being moved? (<-wait this-thing 'ok-to-be-put-in? player (actor-id gameobj)) (and (not put-in-ok?) ;; Either give the specified reason, or give a boilerplate one diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm index 7b93a3b..7b135c1 100644 --- a/mudsync/game-master.scm +++ b/mudsync/game-master.scm @@ -88,7 +88,7 @@ ((symbol class loc args ...) ;; initialize the special object (let ((special-obj - (apply create-actor* gm class + (apply create-actor* class ;; set cookie to be the object's symbol (symbol->string symbol) #:gm (actor-id gm) @@ -121,8 +121,8 @@ (define (gm-setup-network gm) ;; Create a default network manager if none available (slot-set! gm 'network-manager - (create-actor* gm "netman" - #:send-input-to (actor-id gm))) + (create-actor* "netman" + #:send-input-to (actor-id gm))) ;; TODO: Add host and port options (<-wait (gm-network-manager gm) 'start-listening)) @@ -150,7 +150,7 @@ #:input data)) (define* (gm-lookup-special actor message #:key symbol) - (<-reply message (hash-ref (slot-ref actor 'special-dir) symbol))) + (hash-ref (slot-ref actor 'special-dir) symbol)) (define* (gm-write-home actor message #:key text) (define client-id (hash-ref (gm-reverse-client-dir actor) @@ -186,7 +186,7 @@ using the gameobj-spec." (((? (cut eq? <> special-symbol) symbol) class loc args ...) ;; initialize the special object (let ((special-obj - (apply create-actor* gm class + (apply create-actor* class ;; set cookie to be the object's symbol (symbol->string symbol) #:gm (actor-id gm) @@ -239,7 +239,7 @@ with an anonymous persona" (hash-ref (gm-special-dir gm) default-room)) ;; create and register the player (player - (create-actor* gm (@@ (mudsync player) ) "player" + (create-actor* (@@ (mudsync player) ) "player" #:name guest-name #:gm (actor-id gm) #:client client-id))) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 3957e0a..ebd8f65 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -22,6 +22,7 @@ (define-module (mudsync gameobj) #:use-module (mudsync command) #:use-module (mudsync utils) + #:use-module (mudsync receive-star) #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (8sync rmeta-slot) @@ -178,7 +179,7 @@ (tell gameobj-tell-no-op) (assist-replace gameobj-act-assist-replace) (ok-to-drop-here? (lambda (gameobj message . _) - (<-reply message #t))) ; ok to drop by default + #t)) ; ok to drop by default (ok-to-be-taken-from? gameobj-ok-to-be-taken-from) (ok-to-be-put-in? gameobj-ok-to-be-put-in) @@ -199,7 +200,7 @@ (define (create-gameobj class gm loc . args) "Create a gameobj of CLASS with GM and set to location LOC, applying rest of ARGS. Note that this doesn't do any special dyn-ref of the location." - (let ((new-gameobj (apply create-actor (%current-actor) class + (let ((new-gameobj (apply create-actor class #:gm gm args))) ;; Set the location (<-wait new-gameobj 'set-loc! #:loc loc) @@ -217,7 +218,7 @@ Note that this doesn't do any special dyn-ref of the location." ;; Kind of a useful utility, maybe? (define (simple-slot-getter slot) (lambda (actor message) - (<-reply message (slot-ref actor slot)))) + (slot-ref actor slot))) (define (gameobj-replace-step-occupants actor occupants) ;; Snarf all the occupants! @@ -234,12 +235,14 @@ Note that this doesn't do any special dyn-ref of the location." (define (run-replacement actor replaces replace-steps) (when replaces - (mbody-receive (_ #:key occupants) - (<-wait replaces 'assist-replace) - (for-each - (lambda (replace-step) - (replace-step actor occupants)) - replace-steps)))) + (call-with-values + (lambda () + (<-wait replaces 'assist-replace)) + (lambda* (#:key occupants) + (for-each + (lambda (replace-step) + (replace-step actor occupants)) + replace-steps))))) (define %nothing (cons '*the* '*nothing*)) (define (gameobj-setup-props gameobj) @@ -271,7 +274,7 @@ Note that this doesn't do any special dyn-ref of the location." (hashq-set! (slot-ref gameobj 'props) key val)) (define* (gameobj-act-get-prop actor message key #:optional dflt) - (<-reply message (gameobj-get-prop actor key dflt))) + (gameobj-get-prop actor key dflt)) (define (gameobj-goes-by gameobj) "Find the name we go by. Defaults to #:name if nothing else provided." @@ -284,7 +287,7 @@ Note that this doesn't do any special dyn-ref of the location." (define (gameobj-act-goes-by actor message) "Reply to a message requesting what we go by." - (<-reply message (gameobj-goes-by actor))) + (gameobj-goes-by actor)) (define (val-or-run val-or-proc) "Evaluate if a procedure, or just return otherwise" @@ -300,29 +303,27 @@ Note that this doesn't do any special dyn-ref of the location." "Get commands a co-occupant of the room might execute for VERB" (define candidate-commands (get-candidate-commands actor 'commands verb)) - (<-reply message - #:commands candidate-commands - #:goes-by (gameobj-goes-by actor))) + (values #:commands candidate-commands + #:goes-by (gameobj-goes-by actor))) (define* (gameobj-get-container-dom-commands actor message #:key verb) "Get (dominant) commands as the container / room of message's sender" (define candidate-commands (get-candidate-commands actor 'container-dom-commands verb)) - (<-reply message #:commands candidate-commands)) + (values #:commands candidate-commands)) (define* (gameobj-get-container-sub-commands actor message #:key verb) "Get (subordinate) commands as the container / room of message's sender" (define candidate-commands (get-candidate-commands actor 'container-sub-commands verb)) - (<-reply message #:commands candidate-commands)) + (values #:commands candidate-commands)) (define* (gameobj-get-contained-commands actor message #:key verb) "Get commands as being contained (eg inventory) of commanding gameobj" (define candidate-commands (get-candidate-commands actor 'contained-commands verb)) - (<-reply message - #:commands candidate-commands - #:goes-by (gameobj-goes-by actor))) + (values #:commands candidate-commands + #:goes-by (gameobj-goes-by actor))) (define* (gameobj-add-occupant! actor message #:key who) "Add an actor to our list of present occupants" @@ -355,12 +356,10 @@ Note that this doesn't do any special dyn-ref of the location." (define* (gameobj-get-occupants actor message #:key exclude) "Get all present occupants of the room." - (define occupants - (gameobj-occupants actor #:exclude exclude)) - (<-reply message occupants)) + (gameobj-occupants actor #:exclude exclude)) (define (gameobj-act-get-loc actor message) - (<-reply message (slot-ref actor 'loc))) + (slot-ref actor 'loc)) (define (gameobj-set-loc! gameobj loc) "Set the location of this object." @@ -402,7 +401,7 @@ and whos-asking, and see if we should just return it or run it." (define* (gameobj-get-desc actor message #:key whos-looking) "This is the action equivalent of the gameobj-desc getter" - (<-reply message (gameobj-desc actor #:whos-looking whos-looking))) + (gameobj-desc actor #:whos-looking whos-looking)) (define (gameobj-visible-to-player? gameobj whos-looking) "Check to see whether we're visible to the player or not. @@ -424,7 +423,7 @@ By default, this is whether or not the generally-visible flag is set." name) (#f #f)) #f)) - (<-reply message #:text name-to-return)) + (values #:text name-to-return)) (define (gameobj-self-destruct gameobj) "General gameobj self destruction routine" @@ -456,24 +455,21 @@ By default, this is whether or not the generally-visible flag is set." ;; But that's life in a live hacked game! (define (gameobj-act-assist-replace gameobj message) "Vanilla method for assisting in self-replacement for live hacking" - (apply <-reply message - (gameobj-replace-data* gameobj))) + (apply values (gameobj-replace-data* gameobj))) (define (gameobj-ok-to-be-taken-from gameobj message whos-acting) (call-with-values (lambda () (slot-ref-maybe-runcheck gameobj 'take-me? whos-acting #:from #t)) ;; This allows this to reply with #:why-not if appropriate - (lambda args - (apply <-reply message args)))) + (lambda args args))) (define (gameobj-ok-to-be-put-in gameobj message whos-acting where) (call-with-values (lambda () (slot-ref-maybe-runcheck gameobj 'drop-me? whos-acting where)) ;; This allows this to reply with #:why-not if appropriate - (lambda args - (apply <-reply message args)))) + (lambda args args))) ;;; Utilities every gameobj has @@ -486,8 +482,8 @@ By default, this is whether or not the generally-visible flag is set." ((? symbol? _) ;; TODO: If we get back an #f at this point, should we throw ;; an error? Obviously #f is okay, but maybe not if - (mbody-val (<-wait (slot-ref gameobj 'gm) 'lookup-special - #:symbol special-symbol))) + (<-wait (slot-ref gameobj 'gm) 'lookup-special + #:symbol special-symbol)) ;; if it's false, return nothing (#f #f) ;; otherwise it's probably an address, return it as-is @@ -513,9 +509,9 @@ By default, this is whether or not the generally-visible flag is set." #:key direct-obj (player (message-from message))) (define player-name - (mbody-val (<-wait player 'get-name))) + (<-wait player 'get-name)) (define player-loc - (mbody-val (<-wait player 'get-loc))) + (<-wait player 'get-loc)) (define our-name (slot-ref gameobj 'name)) (define self-should-take (slot-ref-maybe-runcheck gameobj 'take-me? player)) @@ -544,14 +540,15 @@ By default, this is whether or not the generally-visible flag is set." #:key direct-obj (player (message-from message))) (define player-name - (mbody-val (<-wait player 'get-name))) + (<-wait player 'get-name)) (define player-loc - (mbody-val (<-wait player 'get-loc))) + (<-wait player 'get-loc)) (define our-name (slot-ref gameobj 'name)) (define should-drop (slot-ref-maybe-runcheck gameobj 'drop-me? player)) (define (room-objection-to-drop) - (mbody-receive (_ drop-ok? #:key why-not) ; does the room object to dropping? + + (receive* (drop-ok? #:key why-not) ; does the room object to dropping? (<-wait player-loc 'ok-to-drop-here? player (actor-id gameobj)) (and (not drop-ok?) ;; Either give the specified reason, or give a boilerplate one diff --git a/mudsync/networking.scm b/mudsync/networking.scm index b541c1e..2a193ae 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -60,7 +60,8 @@ (web-server-port %default-web-server-port)) (if web-server-port (nm-install-web-server actor server web-server-port)) - (nm-install-socket actor server port))) + ;; (nm-install-socket actor server port) + )) (send-to-client nm-send-to-client-id) (new-socket-client nm-new-socket-client) (new-web-client nm-new-web-client) @@ -164,7 +165,7 @@ (hash-set! (nm-clients nm) client-id (cons 'websocket ws-client-id)) (<- (nm-send-input-to nm) 'new-client #:client client-id) - (<-reply message client-id)) + client-id) (define (nm-client-receive-loop nm client-socket client-id) "Make a method to receive client data" @@ -183,11 +184,11 @@ "Handle a closed port" (format #t "DEBUG: handled closed port ~a\n" client-id) (hash-remove! (nm-clients nm) client-id) - (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-closed #:client client-id)) + (<- (nm-send-input-to nm) 'client-closed #:client client-id)) (define (nm-handle-line nm client-id line) "Handle an incoming line of input from a client" - (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-input + (<- (nm-send-input-to nm) 'client-input #:data line #:client client-id)) @@ -226,7 +227,7 @@ like the web one" (define (nm-install-web-server nm server web-server-port) "This installs the web server, which we see in use below...." (set! (.web-server nm) - (create-actor nm + (create-actor #:network-manager (actor-id nm) #:port web-server-port #:http-handler (wrap-apply http-handler) @@ -315,8 +316,8 @@ like the web one" (define (websocket-client-connect websocket-server client-id) (let ((nm-client-id - (mbody-val (<-wait (.network-manager websocket-server) - 'new-web-client client-id)))) + (<-wait (.network-manager websocket-server) + 'new-web-client client-id))) (hash-set! (.nm-client-ids websocket-server) client-id nm-client-id))) diff --git a/mudsync/package-config.scm b/mudsync/package-config.scm index e0fe09e..679508d 100644 --- a/mudsync/package-config.scm +++ b/mudsync/package-config.scm @@ -26,13 +26,8 @@ (or (getenv "MUDSYNC_DATADIR") "/usr/local/share/mudsync")) -(define (clean-path path) - "Remove any nasty .. stuff from the path" - (string-join (delete ".." (string-split path file-name-separator-char)) - file-name-separator-string)) - (define (scope-datadir filename) - (clean-path (string-append %datadir filename))) + (string-append %datadir filename)) (define (web-static-filepath filename) (scope-datadir (string-append "/web-static" filename))) diff --git a/mudsync/player.scm b/mudsync/player.scm index 78d9a01..feea1ef 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -21,6 +21,7 @@ #:use-module (mudsync gameobj) #:use-module (mudsync game-master) #:use-module (mudsync parser) + #:use-module (mudsync receive-star) #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (8sync rmeta-slot) @@ -100,7 +101,7 @@ (define inv-names (map (lambda (inv-item) - (mbody-val (<-wait inv-item 'get-name))) + (<-wait inv-item 'get-name)) (gameobj-occupants player))) (define text-to-show (if (eq? inv-names '()) @@ -150,14 +151,14 @@ ;; Ask the room for its commands (define room-dom-commands ;; TODO: Map room id and sort - (mbody-receive (_ #:key commands) + (receive* (#:key commands) (<-wait player-loc 'get-container-dom-commands #:verb verb) commands)) (define room-sub-commands ;; TODO: Map room id and sort - (mbody-receive (_ #:key commands) + (receive* (#:key commands) (<-wait player-loc 'get-container-sub-commands #:verb verb) commands)) @@ -166,7 +167,7 @@ (define co-occupants (remove (lambda (x) (equal? x (actor-id player))) - (mbody-val (<-wait player-loc 'get-occupants)))) + (<-wait player-loc 'get-occupants))) ;; @@: There's a race condition here if someone leaves the room ;; during this, heh... @@ -177,7 +178,7 @@ (define co-occupant-commands (fold (lambda (co-occupant prev) - (mbody-receive (_ #:key commands goes-by) + (receive* (#:key commands goes-by) (<-wait co-occupant 'get-commands #:verb verb) (append @@ -199,7 +200,7 @@ (define inv-item-commands (fold (lambda (inv-item prev) - (mbody-receive (_ #:key commands goes-by) + (receive* (#:key commands goes-by) (<-wait inv-item 'get-contained-commands #:verb verb) (append diff --git a/mudsync/receive-star.scm b/mudsync/receive-star.scm new file mode 100644 index 0000000..9f4f76c --- /dev/null +++ b/mudsync/receive-star.scm @@ -0,0 +1,27 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2017 Christopher Allan Webber +;;; +;;; This file is part of Mudsync. +;;; +;;; Mudsync is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Mudsync is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mudsync. If not, see . + +(define-module (mudsync receive-star) + #:export (receive*)) + +(define-syntax-rule (receive* formals expr body ...) + (call-with-values + (lambda () + expr) + (lambda* formals + body ...))) diff --git a/mudsync/room.scm b/mudsync/room.scm index ba4af4c..403d610 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -154,7 +154,7 @@ #f)) (define player (message-from message)) (define player-name - (mbody-val (<-wait player 'get-name))) + (<-wait player 'get-name)) (cond (exit (call-with-values (lambda () @@ -217,10 +217,12 @@ (define occupant-names-all (map (lambda (occupant) - (call-with-message (<-wait occupant 'visible-name - #:whos-looking player-id) - (lambda* (_ #:key text) - text))) + (call-with-values + (lambda () + (<-wait occupant 'visible-name + #:whos-looking player-id)) + (lambda* (#:key text) + text))) (remove (lambda (x) (equal? x player-id)) (hash-map->list (lambda (x _) x) @@ -261,7 +263,7 @@ (lambda (return) (for-each (lambda (occupant) - (define goes-by (mbody-val (<-wait occupant 'goes-by))) + (define goes-by (<-wait occupant 'goes-by)) (if (ci-member called-this goes-by) (return occupant))) (hash-map->list (lambda (key val) key) @@ -296,7 +298,7 @@ (define* (room-cmd-say room message #:key phrase) "Command: Say something to room participants." (define player-name - (mbody-val (<-wait (message-from message) 'get-name))) + (<-wait (message-from message) 'get-name)) (define message-to-send `((b "<" ,player-name ">") " " ,phrase)) (room-tell-room room message-to-send)) @@ -304,14 +306,14 @@ (define* (room-cmd-emote room message #:key phrase) "Command: Say something to room participants." (define player-name - (mbody-val (<-wait (message-from message) 'get-name))) + (<-wait (message-from message) 'get-name)) (define message-to-send `((b "* " ,player-name) " " ,phrase)) (room-tell-room room message-to-send)) (define* (room-announce-entrance room message #:key who-entered) (define player-name - (mbody-val (<-wait who-entered 'get-name))) + (<-wait who-entered 'get-name)) (define message-to-send (format #f "~a enters the room.\n" player-name)) (room-tell-room room message-to-send diff --git a/mudsync/run-game.scm b/mudsync/run-game.scm index c9d1f42..17bce5d 100644 --- a/mudsync/run-game.scm +++ b/mudsync/run-game.scm @@ -20,7 +20,8 @@ #:use-module (mudsync game-master) #:use-module (8sync) #:use-module (8sync repl) - #:use-module (8sync debug) + #:use-module (fibers conditions) + ;; #:use-module (8sync debug) #:use-module (srfi srfi-1) #:use-module (ice-9 receive) #:use-module (ice-9 q) @@ -78,25 +79,33 @@ ;;; ================== (define* (run-demo game-spec default-room #:key repl-server) - (define hive (make-hive)) - (define new-conn-handler - (make-default-room-conn-handler default-room)) - (define gm - (bootstrap-actor-gimmie* hive "gm" - #:new-conn-handler new-conn-handler)) - (define injector - (bootstrap-actor hive - #:gm (actor-id gm))) + (run-hive + (lambda (hive) + (define new-conn-handler + (make-default-room-conn-handler default-room)) + (define gm + ;; (bootstrap-actor-gimmie* hive "gm" + ;; #:new-conn-handler new-conn-handler) + (create-actor* "gm" + #:new-conn-handler new-conn-handler)) + (define injector + (create-actor + #:gm gm)) - (define repl-manager - (bootstrap-actor* hive "repl" + (define repl-manager + (create-actor* "repl" #:subscribers (list injector))) - (set! %live-gm gm) - (set! %live-hive hive) + ;; (set! %live-gm gm) + (set! %live-hive hive) - (set! %inject-queue (make-q)) + (set! %inject-queue (make-q)) - (run-hive hive - (list (bootstrap-message hive (actor-id gm) 'init-world - #:game-spec game-spec)))) + (<- gm 'init-world + #:game-spec game-spec) + ;; (run-hive hive + ;; (list (bootstrap-message hive (actor-id gm) 'init-world + ;; #:game-spec game-spec))) + (wait (make-condition))) + ;; Just for testing / for now... + #:parallelism 1)) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index a00e7ac..6bdadca 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -21,6 +21,7 @@ (use-modules (mudsync) (mudsync container) (8sync) + (8sync daydream) (oop goops) (ice-9 control) (ice-9 format) @@ -82,8 +83,7 @@ (for-each (lambda (obj-sym) (define obj-id (dyn-ref gameobj obj-sym)) - (define goes-by - (mbody-val (<-wait obj-id 'goes-by))) + (define goes-by (<-wait obj-id 'goes-by)) (when (ci-member direct-obj goes-by) (<- obj-id 'cmd-take #:direct-obj direct-obj #:player player) (escape #f))) @@ -162,8 +162,7 @@ or 'skribe'? Now *that's* composition!")) (define* (sign-cmd-sign-in actor message #:key direct-obj indir-obj preposition) - (define old-name - (mbody-val (<-wait (message-from message) 'get-name))) + (define old-name (<-wait (message-from message) 'get-name)) (define name indir-obj) (if (valid-name? indir-obj) (begin @@ -193,8 +192,7 @@ character.\n"))) ;; and find out their name. We'll call *their* get-name message ;; handler... meanwhile, this procedure suspends until we get ;; their response. - (define who-rang - (mbody-val (<-wait (message-from message) 'get-name))) + (define who-rang (<-wait (message-from message) 'get-name)) ;; Now we'll invoke the "tell" message handler on the player ;; who rang us, displaying this text on their screen. @@ -446,10 +444,10 @@ from the statue a shining outline appears around it... and a completely separate, glowing copy of the disc materializes into your hands!"))) (<- (gameobj-loc gameobj) 'tell-room - #:text `(,(mbody-val (<-wait player 'get-name)) - " pulls on the shield of the statue, and a glowing " - "copy of it materializes into their hands!") - #:exclude player) + #:text `(,(<-wait player 'get-name) + " pulls on the shield of the statue, and a glowing " + "copy of it materializes into their hands!") + #:exclude player) (<- (gameobj-loc gameobj) 'tell-room #:text '(p "You hear a voice whisper: " @@ -477,8 +475,8 @@ labeled \"RL02.5\".") (player (message-from message))) (<- player 'tell #:text "You drop the glowing disc, and it shatters into a million pieces!") - (<- (mbody-val (<-wait player 'get-loc)) 'tell-room - #:text `(,(mbody-val (<-wait player 'get-name)) + (<- (<-wait player 'get-loc) 'tell-room + #:text `(,(<-wait player 'get-name) " drops a glowing disc, and it shatters into a million pieces!") #:exclude player) (gameobj-self-destruct gameobj)) @@ -616,10 +614,10 @@ platter! It has \"RL02.5\" written on it. It looks kind of loose." (<-wait player 'tell #:text '("You start the rube goldberg machine.")) (<-wait (gameobj-loc rgb-machine) 'tell-room - #:text `(,(mbody-val (<-wait player 'get-name)) + #:text `(,(<-wait player 'get-name) " runs the rube goldberg machine.") #:exclude player) - (8sleep 1) + (daydream 1) (match (.rgb-items rgb-machine) ((first-item rest ...) (<- (dyn-ref rgb-machine first-item) 'trigger)))) @@ -632,18 +630,18 @@ platter! It has \"RL02.5\" written on it. It looks kind of loose." (<-wait player 'tell #:text '("You reset the rube goldberg machine.")) (<-wait (gameobj-loc rgb-machine) 'tell-room - #:text `(,(mbody-val (<-wait player 'get-name)) + #:text `(,(<-wait player 'get-name) " resets the rube goldberg machine.") #:exclude player) (<-wait (gameobj-loc rgb-machine) 'tell-room #:text '("From a panel in the wall, a white gloved mechanical " "arm reaches out to reset all the " "rube goldberg components.")) - (8sleep (/ 1 2)) + (daydream (/ 1 2)) (for-each (lambda (rgb-item) (<- (dyn-ref rgb-machine rgb-item) 'reset) - (8sleep (/ 1 2))) + (daydream (/ 1 2))) (.rgb-items rgb-machine)) (<- (gameobj-loc rgb-machine) 'tell-room #:text "The machine's mechanical arm retreats into the wall!") @@ -684,7 +682,7 @@ platter! It has \"RL02.5\" written on it. It looks kind of loose." (<- room 'tell-room #:text str)) ;; A number? Sleep for that many secs ((? number? num) - (8sleep num)) + (daydream num)) ;; A symbol? That's another gameobj to look up dynamically ((? symbol? sym) (<- (dyn-ref rgb-item sym) 'trigger @@ -742,7 +740,7 @@ platter! It has \"RL02.5\" written on it. It looks kind of loose." (<- room 'tell-room #:text '((i "*kshhhhhh!*") " The water has boiled!")) - (8sleep .25) + (daydream .25) (set! (.state rgb-item) 'ran) ;; insert a cup of hot tea in the room (create-gameobj (gameobj-gm rgb-item) room) @@ -791,8 +789,8 @@ platter! It has \"RL02.5\" written on it. It looks kind of loose." (define (hot-tea-cmd-drink hot-tea message . _) (define player (message-from message)) - (define player-loc (mbody-val (<-wait player 'get-loc))) - (define player-name (mbody-val (<-wait player 'get-name))) + (define player-loc (<-wait player 'get-loc)) + (define player-name (<-wait player 'get-name)) (<- player 'tell #:text "You drink a steaming cup of hot tea all at once... hot hot hot!") (<- player-loc 'tell-room @@ -803,8 +801,8 @@ platter! It has \"RL02.5\" written on it. It looks kind of loose." (define (hot-tea-cmd-sip hot-tea message . _) (define player (message-from message)) - (define player-loc (mbody-val (<-wait player 'get-loc))) - (define player-name (mbody-val (<-wait player 'get-name))) + (define player-loc (<-wait player 'get-loc)) + (define player-name (<-wait player 'get-name)) (set! (.sips-left hot-tea) (- (.sips-left hot-tea) 1)) (<- player 'tell #:text "You take a sip of your steaming hot tea. How refined!") @@ -873,8 +871,7 @@ if this room is intended for children or child-like adults.") ,(if (eq? contents '()) " nothing! It's empty!" `(ul ,(map (lambda (occupant) - `(li ,(mbody-val - (<-wait occupant 'get-name)))) + `(li ,(<-wait occupant 'get-name))) (gameobj-occupants toy-chest)))))))) #:take-from-me? #t #:put-in-me? #t) @@ -907,8 +904,7 @@ if this room is intended for children or child-like adults.") ,(if (eq? contents '()) " nothing! It's empty!" `(ul ,(map (lambda (occupant) - `(li ,(mbody-val - (<-wait occupant 'get-name)))) + `(li ,(<-wait occupant 'get-name))) (gameobj-occupants toy-chest))))))))) ;; Things inside the toy chest @@ -1048,7 +1044,7 @@ What could happen if you started it?") (define* (furniture-cmd-sit actor message #:key direct-obj) (define player-name - (mbody-val (<-wait (message-from message) 'get-name))) + (<-wait (message-from message) 'get-name)) (<- (message-from message) 'tell #:text (format #f "You ~a ~a.\n" (slot-ref actor 'sit-phrase) @@ -1273,7 +1269,7 @@ You can ask me about the following: (define* (clerk-cmd-dismiss clerk message . _) (define player-name - (mbody-val (<-wait (message-from message) 'get-name))) + (<-wait (message-from message) 'get-name)) (match (slot-ref clerk 'state) ('on-duty (<- (gameobj-loc clerk) 'tell-room @@ -1335,7 +1331,7 @@ if you need further help.") (match (slot-ref clerk 'state) ('slacking (tell-room (random-choice clerk-slacking-texts)) - (8sleep (+ (random 20) 15)) + (daydream (+ (random 20) 15)) (loop-if-not-destructed)) ('on-duty (if (> (slot-ref clerk 'patience) 0) @@ -1344,7 +1340,7 @@ if you need further help.") (tell-room (random-choice clerk-working-impatience-texts)) (slot-set! clerk 'patience (- (slot-ref clerk 'patience) (+ (random 2) 1))) - (8sleep (+ (random 60) 40)) + (daydream (+ (random 60) 40)) (loop-if-not-destructed)) ;; Back to slacking (begin @@ -1354,7 +1350,7 @@ if you need further help.") (tell-room clerk-return-to-slacking-text) ;; annnnnd back to slacking (slot-set! clerk 'state 'slacking) - (8sleep (+ (random 30) 15)) + (daydream (+ (random 30) 15)) (loop-if-not-destructed)))))) @@ -1422,7 +1418,7 @@ the paint, but the wires themselves seem to be unusually sturdy." #:accessor .state)) (define (hard-drive-act-get-state hard-drive message) - (<-reply message (.state hard-drive))) + (.state hard-drive)) (define* (hard-drive-desc hard-drive #:optional whos-looking) `((p "The hard drive is labeled \"RL02.5\". It's a little under a meter tall.") @@ -1455,7 +1451,7 @@ the paint, but the wires themselves seem to be unusually sturdy." (cond ((ci-member direct-obj '("button" "load button" "load")) (tell-room-excluding-player - `(,(mbody-val (<-wait player 'get-name)) + `(,(<-wait player 'get-name) " presses the button on the hard disk.")) (<- player 'tell #:text "You press the button on the hard disk.") @@ -1465,14 +1461,14 @@ the paint, but the wires themselves seem to be unusually sturdy." ;; I have no idea what this drive did when you didn't have a platter ;; in it and pressed load, but I know there was a FAULT button. (tell-room "You hear some movement inside the hard drive...") - (8sleep 1.5) + (daydream 1.5) (tell-room '("... but then the FAULT button blinks a couple times. " "What could be missing?"))) ((with-disc) (set! (.state gameobj) 'loading) (tell-room "The hard disk begins to spin up!") - (8sleep 2) + (daydream 2) (set! (.state gameobj) 'ready) (tell-room "The READY light turns on!")) ((loading ready) @@ -1492,10 +1488,10 @@ the paint, but the wires themselves seem to be unusually sturdy." (call/ec (lambda (return) (for-each (lambda (occupant) - (define goes-by (mbody-val (<-wait occupant 'goes-by))) + (define goes-by (<-wait occupant 'goes-by)) (when (ci-member direct-obj goes-by) (return occupant))) - (mbody-val (<-wait player 'get-occupants))) + (<-wait player 'get-occupants)) ;; nothing found #f))) (cond @@ -1503,10 +1499,10 @@ the paint, but the wires themselves seem to be unusually sturdy." (<- player 'tell #:text `("You don't seem to have any such " ,direct-obj " to put " ,preposition " " ,our-name "."))) - ((not (mbody-val (<-wait this-thing 'get-prop 'hd-platter?))) + ((not (<-wait this-thing 'get-prop 'hd-platter?)) (<- player 'tell #:text `("It wouldn't make sense to put " - ,(mbody-val (<-wait this-thing 'get-name)) + ,(<-wait this-thing 'get-name) " " ,preposition " " ,our-name "."))) ((not (eq? (.state gameobj) 'empty)) (<- player 'tell @@ -1543,7 +1539,7 @@ the paint, but the wires themselves seem to be unusually sturdy." #:key direct-obj indir-obj preposition (player (message-from message))) (define (hd-state) - (mbody-val (<-wait (dyn-ref gameobj 'computer-room:hard-drive) 'get-state))) + (<-wait (dyn-ref gameobj 'computer-room:hard-drive) 'get-state)) (define (tell-room text) (<-wait (gameobj-loc gameobj) 'tell-room #:text text)) @@ -1557,7 +1553,7 @@ the paint, but the wires themselves seem to be unusually sturdy." (cond ((ci-member direct-obj '("program")) (tell-room-excluding-player - `(,(mbody-val (<-wait player 'get-name)) + `(,(<-wait player 'get-name) " runs the program loaded on the computer...")) (tell-player "You run the program on the computer...") @@ -1574,7 +1570,7 @@ the paint, but the wires themselves seem to be unusually sturdy." (define-actor () ;; TODO: Add "open" verb, since obviously people will try that ((open? (lambda (panel message) - (<-reply message (slot-ref panel 'open)))) + (slot-ref panel 'open))) (open-up floor-panel-open-up)) (open #:init-value #f)) @@ -1605,8 +1601,8 @@ the paint, but the wires themselves seem to be unusually sturdy." #:name "Computer Room" #:desc (lambda (gameobj whos-looking) (define panel-open - (mbody-val (<-wait (dyn-ref gameobj 'computer-room:floor-panel) - 'open?))) + (<-wait (dyn-ref gameobj 'computer-room:floor-panel) + 'open?)) `((p "A sizable computer cabinet covers a good portion of the left wall. It emits a pleasant hum which covers the room like a warm blanket. Connected to a computer is a large hard drive.") @@ -1626,8 +1622,8 @@ the paint, but the wires themselves seem to be unusually sturdy." #:traverse-check (lambda (exit room whos-exiting) (define panel-open - (mbody-val (<-wait (dyn-ref room 'computer-room:floor-panel) - 'open?))) + (<-wait (dyn-ref room 'computer-room:floor-panel) + 'open?)) (if panel-open (values #t "You descend the spiral staircase.") (values #f '("You'd love to go down, but the only way " -- 2.31.1