From: Christopher Allan Webber Date: Mon, 2 May 2016 18:20:03 +0000 (-0500) Subject: Split mudsync.scm out into multiple files X-Git-Tag: fosdem-2017~196 X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=commitdiff_plain;h=d13325f5f6eba20c808636948432dcdff4e138f6 Split mudsync.scm out into multiple files --- diff --git a/Makefile.am b/Makefile.am index 4ccc009..a9c186f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -45,7 +45,13 @@ moddir=$(prefix)/share/guile/site/2.0 godir=$(libdir)/guile/2.0/ccache SOURCES = \ + mudsync/game-master.scm \ + mudsync/gameobj.scm \ mudsync/networking.scm \ + mudsync/parser.scm \ + mudsync/player.scm \ + mudsync/room.scm \ + mudsync/run-game.scm \ mudsync.scm # TESTS = \ diff --git a/mudsync.scm b/mudsync.scm index a722633..84cb6d0 100644 --- a/mudsync.scm +++ b/mudsync.scm @@ -1,5 +1,6 @@ ;;; Mudsync --- Live hackable MUD ;;; Copyright © 2016 Christopher Allan Webber +;;; Copyright © 2012, 2014 Ludovic Courtès ;;; ;;; This file is part of Mudsync. ;;; @@ -23,402 +24,20 @@ #:use-module (ice-9 match) #:use-module (oop goops)) - -; (ez-run-hive hive (list (bootstrap-message hive (actor-id nm) 'start-listening))) - -;; (define-method (nm-close-port (nm ))) - - - -;;; The game master! Runs the world. -;;; ================================= - -;; @@: We could call this a "world builder" instead... -;; I kinda like calling it a GM though. - -(define-class () - ;; Directory of "special" objects. - (special-dir #:init-thunk make-hash-table - #:getter gm-special-dir) - - ;; Room directory. Room symbols to locations. - (room-dir #:init-thunk make-hash-table - #:getter gm-room-dir) - - ;; A mapping of client ids to in-game actors - ;; and a reverse ;p - (client-dir #:init-thunk make-hash-table - #:getter gm-client-dir) - (reverse-client-dir #:init-thunk make-hash-table - #:getter gm-reverse-client-dir) - - ;; Network manager - (network-manager #:accessor gm-network-manager - #:init-value #f) - - ;; How we get a new connection acclimated to the system - (new-conn-handler #:accessor gm-new-conn-handler - #:init-keyword #:new-conn-handler) - - (message-handler - #:init-value - (make-action-dispatch - (init-world (wrap-apply gm-init-world)) - (client-input (wrap-apply gm-handle-client-input)) - (lookup-room (wrap-apply gm-lookup-room)) - (new-client (wrap-apply gm-new-client)) - (write-home (wrap-apply gm-write-home))))) - - -;;; .. begin world init stuff .. - -(define (gm-init-world gm message) - ;; Load database - ;; TODO - - ;; Init basic rooms / structure - (gm-init-rooms gm (message-ref message 'room-spec)) - - ;; Restore database-based actors - ;; TODO - - ;; Set up the network - (gm-setup-network gm)) - -(define (gm-init-rooms gm rooms-spec) - "Initialize the prebuilt rooms" - ;; @@: Would it be nicer to just allow passing in - ;; #:exits to the room spec itself? - (define (exit-from-spec exit-spec) - "Take room exits syntax from the spec, turn it into exits" - (match exit-spec - ((name to-symbol desc) - (make - #:name name - #:to-symbol to-symbol - #:desc desc)))) - - (define rooms - (map - (match-lambda - ((room-symbol room-class - room-args ... - (room-exits ...)) - ;; initialize the room - (let ((room - (apply create-actor* gm room-class "room" - #:gm (actor-id gm) - #:exits (map exit-from-spec room-exits) - room-args))) - ;; register the room - (hash-set! (gm-room-dir gm) room-symbol room) - ;; pass it back to the map - room))) - rooms-spec)) - - ;; now wire up all the exits - (for-each - (lambda (room) - (format #t "Wiring up ~s...\n" (address->string room)) - (<-wait gm room 'wire-exits!)) - rooms)) - - -(define (gm-setup-network gm) - ;; Create a default network manager if none available - (set! (gm-network-manager gm) - (create-actor* gm "netman" - #:send-input-to (actor-id gm))) - - ;; TODO: Add host and port options - (<-wait gm (gm-network-manager gm) 'start-listening)) - -(define (gm-setup-database gm) - 'TODO) - -;;; .. end world init stuff ... - -(define-mhandler (gm-new-client actor message client) - ;; @@: Maybe more indirection than needed for this - ((gm-new-conn-handler actor) actor client)) - - -(define (gm-handle-client-input actor message) - "Handle input from a client." - (define client-id (message-ref message 'client)) - (define input (message-ref message 'data)) - (format #t "From ~s: ~s\n" client-id input) - (<- actor (gm-network-manager actor) 'send-to-client - #:client client-id - #:data "Thanks, we got it!\n")) - -(define-mhandler (gm-lookup-room actor message symbol) - (define room-id - (slot-ref (gm-room-dir actor) symbol)) - (<-reply actor message room-id)) - -(define-mhandler (gm-write-home actor message text) - (define client-id (hash-ref (gm-reverse-client-dir actor) - (message-from message))) - (<- actor (gm-network-manager actor) 'send-to-client - #:client client-id - #:data text)) - - -;;; GM utilities - -(define (gm-register-client! gm client-id player) - (hash-set! (gm-client-dir gm) client-id player) - (hash-set! (gm-reverse-client-dir gm) player client-id)) - -(define (gm-unregister-client! gm client-id) - "Remove a connection/player combo and ask them to self destruct" - (match (hash-remove! (gm-client-dir gm) client-id) ; Remove from our client dir - ((_ . player-id) - ;; Remove from reverse table too - (hash-remove! (gm-reverse-client-dir gm) client-id) - ;; Destroy player - (<- gm player-id 'destroy-self)) - (#f (throw 'no-client-to-unregister - "Can't unregister a client that doesn't exist?" - client-id)))) - -;;; An easy default - -(define (make-default-room-conn-handler default-room) - "Make a handler for a GM that dumps people in a default room -with an anonymous persona" - (let ((count 0)) - (lambda (gm client-id) - (define guest-name (string-append "Guest-" - (number->string count))) - (define room-id - (hash-ref (gm-room-dir gm) default-room)) - ;; create and register the player - (define player - (create-actor* gm "player" - #:username guest-name - #:gm (actor-id gm) - #:client client-id)) - - ;; Register the player in our database of players -> connections - (gm-register-client! gm client-id player) - ;; Dump the player into the default room - (<-wait gm player 'set-loc! #:id room-id) - ;; Initialize the player - (<- gm player 'init)))) - - -;;; Game actor -;;; ========== - -;;; *all* game components that talk to players should somehow -;;; derive from this class. -;;; And all of them need a GM! - -(define-class () - ;; location id - (loc #:init-value #f - #:accessor gameobj-loc) - ;; game master id - (gm #:init-keyword #:gm - #:getter gameobj-gm) - ;; a name to be known by - (name #:init-keyword #:name - #:accessor gameobj-name) - - ;; how to print our name - (name-f #:init-keyword #:name-f - #:getter gameobj-name-f - #:init-value (wrap gameobj-simple-name-f)) - - ;; Name aliases - (aliases #:init-keyword #:aliases - #:init-value '()) - - ;; Commands we can handle - (dirobj-commands #:init-value '()) - (indirobj-commands #:init-value '()) - - ;; Commands we can handle by being something's container - (contain-commands #:init-value #f)) - - -(define (gameobj-simple-name-f gameobj) - "Simplest version: return ourselves for our name." - (gameobj-name gameobj)) - - - -;;; Rooms -;;; ===== - -;; @@: Maybe make this into a record type when this congeals a bit? -;; I dunno? - -(define-class () - ;; Used for wiring - (to-symbol #:accessor exit-to-symbol - #:init-keyword #:to-symbol) - ;; The actual address we use - (to-address #:accessor exit-to-address - #:init-keyword #:address) - ;; Name of the room (@@: Should this be names?) - (name #:accessor exit-name - #:init-keyword #:name) - (desc #:accessor exit-desc - #:init-keyword #:desc) - - ;; *Note*: These two methods have an extra layer of indirection, but - ;; it's for a good reason. - (visible-check #:init-value (const #t) - #:init-keyword #:visible-check) - ;; By default all exits can be traversed - (traverse-check #:init-value (const #t) - #:init-keyword #:traverse-check)) - -(define* (exit-can-traverse? exit actor - #:optional (target-actor (actor-id actor))) - ((slot-ref exit 'traverse-check) exit actor target-actor)) - -(define* (exit-is-visible? exit actor - #:optional (target-actor (actor-id actor))) - ((slot-ref exit 'traverse-check) exit actor target-actor)) - - -;; Kind of a useful utility, maybe? -(define (simple-slot-getter slot) - (lambda (actor message) - (reply-message actor message - #:val (slot-ref actor slot)))) - -(define always (const #t)) - -;; TODO: remove hack -(define full-command list) - -;; TODO: fill these in -(define cmatch-just-verb #f) -(define cmatch-direct-verb #f) -(define cmatch-direct-obj #f) - -(define %room-contain-commands - (list - (full-command "look" cmatch-just-verb always 'look-room) - (full-command "look" cmatch-direct-obj always 'look-member) - (full-command "go" cmatch-just-verb always 'go-where) - (full-command "go" cmatch-direct-obj always 'go-exit))) - -;; TODO: Subclass from container? -(define-class () - (desc #:init-value "" - #:init-keyword #:desc) - ;; TODO: Switch this to be loc based - ;; Uses a hash table like a set (values ignored) - (occupants #:init-thunk make-hash-table) - ;; A list of - (exits #:init-value '() - #:getter room-exits) - ;; @@: Maybe eventually will inherit from some more general - ;; game object class - - (contain-commands - #:init-value %room-contain-commands) - - (message-handler - #:allocation #:each-subclass - #:init-value - (make-action-dispatch - ;; desc == description - (get-desc - (simple-slot-getter 'desc)) - (get-name - (simple-slot-getter 'name)) - ((register-occupant! actor message who) - "Register an actor as being a occupant of this room" - (hash-set! (slot-ref actor 'occupants) who #t)) - ((evict-occupant! actor message who) - "De-register an occupant removed from the room" - (hash-remove! (slot-ref actor 'occupants) who)) - (wire-exits! (wrap-apply room-wire-exits!))))) - -(define (room-wire-exits! room message) - "Actually hook up the rooms' exit addresses to the rooms they -claim to point to." - (for-each - (lambda (exit) - (define new-exit - (<-wait room (gameobj-gm room) 'lookup-room - #:symbol (exit-to-symbol exit))) - - (set! (exit-to-address exit) new-exit)) - - (room-exits room))) - - - -;;; Players -;;; ======= - -(define-class () - (username #:init-keyword #:username - #:accessor player-username) - ;; Connection id - (client #:accessor player-client) - - (self-commands - #:init-value '() - #:accessor player-self-commands) - - (message-handler - #:init-value - (make-action-dispatch - (set-loc! (wrap-apply player-set-loc!)) - (init (wrap-apply player-init!))))) - -;;; player message handlers - -(define-mhandler (player-set-loc! player message id) - (format #t "DEBUG: Location set to ~s for player ~s\n" - id (actor-id-actor player)) - (set! (gameobj-loc player) id)) - -(define-mhandler (player-init! player message) - (player-look-around player)) - -;;; player methods - -(define (player-look-around player) - (define room-name - (message-ref - (<-wait player (gameobj-loc player) 'get-name) - 'val)) - (define room-desc - (message-ref - (<-wait player (gameobj-loc player) 'get-desc) - 'val)) - (define message-text - (format #f "**~a**\n~a\n" room-name room-desc)) - - (<- player (gameobj-gm player) 'write-home #:text message-text)) - - -;;; Debugging stuff -;;; =============== - -(define %test-gm #f) - -(define (run-demo db-path room-spec default-room) - (define hive (make-hive)) - (define new-conn-handler - (make-default-room-conn-handler default-room)) - (define gm - (hive-create-actor-gimmie* hive "gm" - #:new-conn-handler new-conn-handler)) - (set! %test-gm gm) - ;; @@: Boy, wouldn't it be nice if the agenda could do things - ;; on interrupt :P - (ez-run-hive hive - (list (bootstrap-message hive (actor-id gm) 'init-world - #:room-spec room-spec)))) +;;; Composite model stuff borrowed from Guix. Thanks, Ludo! +(eval-when (eval load compile) + (begin + (define %public-modules + '(game-master + gameobj + networking + parser + player + room + run-game)) + + (for-each (let ((i (module-public-interface (current-module)))) + (lambda (m) + (module-use! i (resolve-interface `(mudsync ,m))))) + %public-modules))) diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm new file mode 100644 index 0000000..bb8756a --- /dev/null +++ b/mudsync/game-master.scm @@ -0,0 +1,204 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2016 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 game-master) + #:use-module (mudsync room) + #:use-module (mudsync player) + #:use-module (mudsync networking) + #:use-module (8sync systems actors) + #:use-module (8sync agenda) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:export ( + make-default-room-conn-handler)) + +;;; The game master! Runs the world. +;;; ================================= + +(define-class () + ;; Directory of "special" objects. + (special-dir #:init-thunk make-hash-table + #:getter gm-special-dir) + + ;; Room directory. Room symbols to locations. + (room-dir #:init-thunk make-hash-table + #:getter gm-room-dir) + + ;; A mapping of client ids to in-game actors + ;; and a reverse ;p + (client-dir #:init-thunk make-hash-table + #:getter gm-client-dir) + (reverse-client-dir #:init-thunk make-hash-table + #:getter gm-reverse-client-dir) + + ;; Network manager + (network-manager #:accessor gm-network-manager + #:init-value #f) + + ;; How we get a new connection acclimated to the system + (new-conn-handler #:accessor gm-new-conn-handler + #:init-keyword #:new-conn-handler) + + (message-handler + #:init-value + (make-action-dispatch + (init-world (wrap-apply gm-init-world)) + (client-input (wrap-apply gm-handle-client-input)) + (lookup-room (wrap-apply gm-lookup-room)) + (new-client (wrap-apply gm-new-client)) + (write-home (wrap-apply gm-write-home))))) + + +;;; .. begin world init stuff .. + +(define (gm-init-world gm message) + ;; Load database + ;; TODO + + ;; Init basic rooms / structure + (gm-init-rooms gm (message-ref message 'room-spec)) + + ;; Restore database-based actors + ;; TODO + + ;; Set up the network + (gm-setup-network gm)) + +(define (gm-init-rooms gm rooms-spec) + "Initialize the prebuilt rooms" + ;; @@: Would it be nicer to just allow passing in + ;; #:exits to the room spec itself? + (define (exit-from-spec exit-spec) + "Take room exits syntax from the spec, turn it into exits" + (match exit-spec + ((name to-symbol desc) + (make + #:name name + #:to-symbol to-symbol + #:desc desc)))) + + (define rooms + (map + (match-lambda + ((room-symbol room-class + room-args ... + (room-exits ...)) + ;; initialize the room + (let ((room + (apply create-actor* gm room-class "room" + #:gm (actor-id gm) + #:exits (map exit-from-spec room-exits) + room-args))) + ;; register the room + (hash-set! (gm-room-dir gm) room-symbol room) + ;; pass it back to the map + room))) + rooms-spec)) + + ;; now wire up all the exits + (for-each + (lambda (room) + (format #t "Wiring up ~s...\n" (address->string room)) + (<-wait gm room 'wire-exits!)) + rooms)) + + +(define (gm-setup-network gm) + ;; Create a default network manager if none available + (set! (gm-network-manager gm) + (create-actor* gm "netman" + #:send-input-to (actor-id gm))) + + ;; TODO: Add host and port options + (<-wait gm (gm-network-manager gm) 'start-listening)) + +(define (gm-setup-database gm) + 'TODO) + +;;; .. end world init stuff ... + +(define-mhandler (gm-new-client actor message client) + ;; @@: Maybe more indirection than needed for this + ((gm-new-conn-handler actor) actor client)) + + +(define (gm-handle-client-input actor message) + "Handle input from a client." + (define client-id (message-ref message 'client)) + (define input (message-ref message 'data)) + (format #t "From ~s: ~s\n" client-id input) + (<- actor (gm-network-manager actor) 'send-to-client + #:client client-id + #:data "Thanks, we got it!\n")) + +(define-mhandler (gm-lookup-room actor message symbol) + (define room-id + (slot-ref (gm-room-dir actor) symbol)) + (<-reply actor message room-id)) + +(define-mhandler (gm-write-home actor message text) + (define client-id (hash-ref (gm-reverse-client-dir actor) + (message-from message))) + (<- actor (gm-network-manager actor) 'send-to-client + #:client client-id + #:data text)) + + +;;; GM utilities + +(define (gm-register-client! gm client-id player) + (hash-set! (gm-client-dir gm) client-id player) + (hash-set! (gm-reverse-client-dir gm) player client-id)) + +(define (gm-unregister-client! gm client-id) + "Remove a connection/player combo and ask them to self destruct" + (match (hash-remove! (gm-client-dir gm) client-id) ; Remove from our client dir + ((_ . player-id) + ;; Remove from reverse table too + (hash-remove! (gm-reverse-client-dir gm) client-id) + ;; Destroy player + (<- gm player-id 'destroy-self)) + (#f (throw 'no-client-to-unregister + "Can't unregister a client that doesn't exist?" + client-id)))) + +;;; An easy default + +(define (make-default-room-conn-handler default-room) + "Make a handler for a GM that dumps people in a default room +with an anonymous persona" + (let ((count 0)) + (lambda (gm client-id) + (define guest-name (string-append "Guest-" + (number->string count))) + (define room-id + (hash-ref (gm-room-dir gm) default-room)) + ;; create and register the player + (define player + (create-actor* gm "player" + #:username guest-name + #:gm (actor-id gm) + #:client client-id)) + + ;; Register the player in our database of players -> connections + (gm-register-client! gm client-id player) + ;; Dump the player into the default room + (<-wait gm player 'set-loc! #:id room-id) + ;; Initialize the player + (<- gm player 'init)))) + diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm new file mode 100644 index 0000000..9651140 --- /dev/null +++ b/mudsync/gameobj.scm @@ -0,0 +1,71 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2016 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 . + +;;; Game actor +;;; ========== + +(define-module (mudsync gameobj) + #:use-module (8sync systems actors) + #:use-module (8sync agenda) + #:use-module (oop goops) + #:export ( + gameobj-simple-name-f + + gameobj-loc + gameobj-gm + gameobj-name + gameobj-name-f)) + + +;;; *all* game components that talk to players should somehow +;;; derive from this class. +;;; And all of them need a GM! + +(define-class () + ;; location id + (loc #:init-value #f + #:accessor gameobj-loc) + ;; game master id + (gm #:init-keyword #:gm + #:getter gameobj-gm) + ;; a name to be known by + (name #:init-keyword #:name + #:accessor gameobj-name) + + ;; how to print our name + (name-f #:init-keyword #:name-f + #:getter gameobj-name-f + #:init-value (wrap gameobj-simple-name-f)) + + ;; Name aliases + (aliases #:init-keyword #:aliases + #:init-value '()) + + ;; Commands we can handle + (dirobj-commands #:init-value '()) + (indirobj-commands #:init-value '()) + + ;; Commands we can handle by being something's container + (contain-commands #:init-value #f)) + + +(define (gameobj-simple-name-f gameobj) + "Simplest version: return ourselves for our name." + (gameobj-name gameobj)) + + diff --git a/mudsync/parser.scm b/mudsync/parser.scm index 51e07c8..3ad5b73 100644 --- a/mudsync/parser.scm +++ b/mudsync/parser.scm @@ -16,8 +16,10 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mudsync. If not, see . -(use-modules (rx irregex) - (ice-9 match)) +(define-module (mudsync parser) + #:use-module (rx irregex) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9)) (define (match-to-kwargs irx string) @@ -60,14 +62,29 @@ (? (: ,article (+ space))) ; possibly an article (ignored) (=> indirect-object (+ any))))) ; indirect object (kept) +(define (indirect-matcher phrase) + (match-to-kwargs indirect-irx phrase)) + (define direct-irx (sre->irregex `(: (? (: ,preposition (+ space))) ; possibly a preposition (ignored) (? (: ,article (+ space))) ; possibly an article (ignored) (=> direct-object (* any))))) ; direct object (kept) +(define (direct-matcher phrase) + (match-to-kwargs direct-irx phrase)) (define say-example "say I really need to get going.") (define attack-sword-example "hit goblin with sword") (define attack-simple-example "hit goblin") (define put-book-on-desk "put the book on the desk") + +(define-record-type + (make-command-handler matcher should-handle action) + command-handler? + (matcher command-handler-matcher) + (should-handle command-handler-should-handle?) + (action command-handler-action)) + +(define command-handler make-command-handler) + diff --git a/mudsync/player.scm b/mudsync/player.scm new file mode 100644 index 0000000..42359bd --- /dev/null +++ b/mudsync/player.scm @@ -0,0 +1,70 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2016 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 player) + #:use-module (mudsync gameobj) + #:use-module (8sync systems actors) + #:use-module (8sync agenda) + #:use-module (ice-9 format) + #:use-module (oop goops) + #:export ()) + +;;; Players +;;; ======= + +(define-class () + (username #:init-keyword #:username + #:accessor player-username) + ;; Connection id + (client #:accessor player-client) + + (self-commands + #:init-value '() + #:accessor player-self-commands) + + (message-handler + #:init-value + (make-action-dispatch + (set-loc! (wrap-apply player-set-loc!)) + (init (wrap-apply player-init!))))) + +;;; player message handlers + +(define-mhandler (player-set-loc! player message id) + (format #t "DEBUG: Location set to ~s for player ~s\n" + id (actor-id-actor player)) + (set! (gameobj-loc player) id)) + +(define-mhandler (player-init! player message) + (player-look-around player)) + +;;; player methods + +(define (player-look-around player) + (define room-name + (message-ref + (<-wait player (gameobj-loc player) 'get-name) + 'val)) + (define room-desc + (message-ref + (<-wait player (gameobj-loc player) 'get-desc) + 'val)) + (define message-text + (format #f "**~a**\n~a\n" room-name room-desc)) + + (<- player (gameobj-gm player) 'write-home #:text message-text)) diff --git a/mudsync/room.scm b/mudsync/room.scm new file mode 100644 index 0000000..b6164da --- /dev/null +++ b/mudsync/room.scm @@ -0,0 +1,128 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2016 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 room) + #:use-module (mudsync gameobj) + #:use-module (8sync systems actors) + #:use-module (8sync agenda) + #:use-module (oop goops) + #:export ( + )) + +;;; Rooms +;;; ===== + +(define-class () + ;; Used for wiring + (to-symbol #:accessor exit-to-symbol + #:init-keyword #:to-symbol) + ;; The actual address we use + (to-address #:accessor exit-to-address + #:init-keyword #:address) + ;; Name of the room (@@: Should this be names?) + (name #:accessor exit-name + #:init-keyword #:name) + (desc #:accessor exit-desc + #:init-keyword #:desc) + + ;; *Note*: These two methods have an extra layer of indirection, but + ;; it's for a good reason. + (visible-check #:init-value (const #t) + #:init-keyword #:visible-check) + ;; By default all exits can be traversed + (traverse-check #:init-value (const #t) + #:init-keyword #:traverse-check)) + +(define* (exit-can-traverse? exit actor + #:optional (target-actor (actor-id actor))) + ((slot-ref exit 'traverse-check) exit actor target-actor)) + +(define* (exit-is-visible? exit actor + #:optional (target-actor (actor-id actor))) + ((slot-ref exit 'traverse-check) exit actor target-actor)) + + +;; Kind of a useful utility, maybe? +(define (simple-slot-getter slot) + (lambda (actor message) + (reply-message actor message + #:val (slot-ref actor slot)))) + +(define always (const #t)) + +;; TODO: remove hack +(define full-command list) + +;; TODO: fill these in +(define cmatch-just-verb #f) +(define cmatch-direct-verb #f) +(define cmatch-direct-obj #f) + +(define %room-contain-commands + (list + (full-command "look" cmatch-just-verb always 'look-room) + (full-command "look" cmatch-direct-obj always 'look-member) + (full-command "go" cmatch-just-verb always 'go-where) + (full-command "go" cmatch-direct-obj always 'go-exit))) + +;; TODO: Subclass from container? +(define-class () + (desc #:init-value "" + #:init-keyword #:desc) + ;; TODO: Switch this to be loc based + ;; Uses a hash table like a set (values ignored) + (occupants #:init-thunk make-hash-table) + ;; A list of + (exits #:init-value '() + #:getter room-exits) + ;; @@: Maybe eventually will inherit from some more general + ;; game object class + + (contain-commands + #:init-value %room-contain-commands) + + (message-handler + #:allocation #:each-subclass + #:init-value + (make-action-dispatch + ;; desc == description + (get-desc + (simple-slot-getter 'desc)) + (get-name + (simple-slot-getter 'name)) + ((register-occupant! actor message who) + "Register an actor as being a occupant of this room" + (hash-set! (slot-ref actor 'occupants) who #t)) + ((evict-occupant! actor message who) + "De-register an occupant removed from the room" + (hash-remove! (slot-ref actor 'occupants) who)) + (wire-exits! (wrap-apply room-wire-exits!))))) + +(define (room-wire-exits! room message) + "Actually hook up the rooms' exit addresses to the rooms they +claim to point to." + (for-each + (lambda (exit) + (define new-exit + (<-wait room (gameobj-gm room) 'lookup-room + #:symbol (exit-to-symbol exit))) + + (set! (exit-to-address exit) new-exit)) + + (room-exits room))) + diff --git a/mudsync/run-game.scm b/mudsync/run-game.scm new file mode 100644 index 0000000..286ff7d --- /dev/null +++ b/mudsync/run-game.scm @@ -0,0 +1,45 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2016 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 run-game) + #:use-module (mudsync game-master) + #:use-module (8sync systems actors) + #:use-module (8sync systems actors debug) + #:export (run-demo + ;; Just temporarily + %test-gm)) + + +;;; Debugging stuff +;;; =============== + +(define %test-gm #f) + +(define (run-demo db-path room-spec default-room) + (define hive (make-hive)) + (define new-conn-handler + (make-default-room-conn-handler default-room)) + (define gm + (hive-create-actor-gimmie* hive "gm" + #:new-conn-handler new-conn-handler)) + (set! %test-gm gm) + ;; @@: Boy, wouldn't it be nice if the agenda could do things + ;; on interrupt :P + (ez-run-hive hive + (list (bootstrap-message hive (actor-id gm) 'init-world + #:room-spec room-spec))))