From 7e11c67b59dc07a46576b2acaa4657ee533df7d5 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Mon, 9 May 2016 10:03:57 -0500 Subject: [PATCH 1/1] basic things, with the ability to pick them up (but not put them down, heh) --- Makefile.am | 1 + mudsync.scm | 3 +- mudsync/gameobj.scm | 35 +++++++++++- mudsync/player.scm | 40 +++++++++++-- mudsync/thing.scm | 132 +++++++++++++++++++++++++++++++++++++++++++ worlds/bricabrac.scm | 41 +++++++++++--- 6 files changed, 236 insertions(+), 16 deletions(-) create mode 100644 mudsync/thing.scm diff --git a/Makefile.am b/Makefile.am index bccc808..d78ab15 100644 --- a/Makefile.am +++ b/Makefile.am @@ -53,6 +53,7 @@ SOURCES = \ mudsync/player.scm \ mudsync/room.scm \ mudsync/run-game.scm \ + mudsync/thing.scm \ mudsync.scm # TESTS = \ diff --git a/mudsync.scm b/mudsync.scm index 31caf48..a3caaa1 100644 --- a/mudsync.scm +++ b/mudsync.scm @@ -35,7 +35,8 @@ command player room - run-game)) + run-game + thing)) (for-each (let ((i (module-public-interface (current-module)))) (lambda (m) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 0f4d704..b686e3c 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -31,10 +31,14 @@ gameobj-loc gameobj-gm + gameobj-set-loc! gameobj-occupants gameobj-actions gameobj-self-destruct + slot-ref-maybe-runcheck + val-or-run + dyn-ref)) ;;; Gameobj @@ -45,11 +49,16 @@ (define gameobj-actions (build-actions (init (wrap-apply gameobj-init)) + ;; Commands for co-occupants (get-commands (wrap-apply gameobj-get-commands)) + ;; Commands for participants in a room (get-container-commands (wrap-apply gameobj-get-container-commands)) + ;; Commands for inventory items, etc (occupants of the gameobj commanding) + (get-contained-commands (wrap-apply gameobj-get-contained-commands)) (get-occupants (wrap-apply gameobj-get-occupants)) (add-occupant! (wrap-apply gameobj-add-occupant!)) (remove-occupant! (wrap-apply gameobj-remove-occupant!)) + (get-loc (wrap-apply gameobj-act-get-loc)) (set-loc! (wrap-apply gameobj-act-set-loc!)) (get-name (wrap-apply gameobj-get-name)) (set-name! (wrap-apply gameobj-act-set-name!)) @@ -89,6 +98,10 @@ ;; Commands we can handle by being something's container (container-commands #:init-value '()) + + ;; Commands we can handle by being contained by something else + (contained-commands #:init-value '()) + (message-handler #:init-value (simple-dispatcher gameobj-actions)) @@ -111,7 +124,6 @@ (reply-message actor message #:val (slot-ref actor slot)))) - (define (gameobj-replace-step-occupants actor replace-reply) (define occupants (message-ref replace-reply 'occupants #f)) @@ -187,6 +199,15 @@ Assists in its replacement of occupants if necessary and nothing else." verb)) (<-reply actor message #:commands filtered-commands)) +(define-mhandler (gameobj-get-contained-commands actor message verb) + "Get commands as being contained (eg inventory) of commanding gameobj" + (define filtered-commands + (filter-commands (val-or-run (slot-ref actor 'contained-commands)) + verb)) + (<-reply actor message + #:commands filtered-commands + #:goes-by (gameobj-goes-by actor))) + (define-mhandler (gameobj-add-occupant! actor message who) "Add an actor to our list of present occupants" (hash-set! (slot-ref actor 'occupants) @@ -225,6 +246,10 @@ Assists in its replacement of occupants if necessary and nothing else." (<-reply actor message #:occupants occupants)) +(define-mhandler (gameobj-act-get-loc actor message) + (<-reply actor message + #:val (slot-ref actor 'loc))) + (define (gameobj-set-loc! gameobj loc) "Set the location of this object." (define old-loc (gameobj-loc gameobj)) @@ -243,6 +268,14 @@ Assists in its replacement of occupants if necessary and nothing else." "Action routine to set the location." (gameobj-set-loc! actor loc)) +(define (slot-ref-maybe-runcheck gameobj slot whos-asking) + "Do a slot-ref on gameobj, evaluating it including ourselves +and whos-asking, and see if we should just return it or run it." + (match (slot-ref gameobj slot) + ((? procedure? slot-val-proc) + (slot-val-proc gameobj whos-asking)) + (anything-else anything-else))) + (define gameobj-get-name (simple-slot-getter 'name)) (define-mhandler (gameobj-act-set-name! actor message val) diff --git a/mudsync/player.scm b/mudsync/player.scm index 6e4be57..d2fc76d 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -40,7 +40,8 @@ (init (wrap-apply player-init)) (handle-input (wrap-apply player-handle-input)) (tell (wrap-apply player-tell)) - (disconnect-self-destruct (wrap-apply player-disconnect-self-destruct)))) + (disconnect-self-destruct (wrap-apply player-disconnect-self-destruct)) + (cmd-inventory (wrap-apply player-cmd-inventory)))) (define player-actions* (append player-actions @@ -49,17 +50,22 @@ (define player-dispatcher (simple-dispatcher player-actions*)) +(define player-self-commands + (list + (empty-command "inventory" 'cmd-inventory) + ;; aliases... + ;; @@: Should use an "alias" system for common aliases? + (empty-command "inv" 'cmd-inventory) + (empty-command "i" 'cmd-inventory))) + (define-class () (username #:init-keyword #:username #:getter player-username) - (self-commands - #:init-value '() - #:getter player-self-commands) + (self-commands #:init-value player-self-commands) (message-handler #:init-value - ;; @@: We're gonna need action inheritance real awful soon, huh? (wrap-apply player-dispatcher))) @@ -102,6 +108,24 @@ (slot-ref player 'name)))) (gameobj-self-destruct player)) +(define-mhandler (player-cmd-inventory player message) + "Display the inventory for the player" + (define inv-names + (map + (lambda (inv-item) + (message-ref (<-wait player inv-item 'get-name) + 'val)) + (gameobj-occupants player))) + (define text-to-show + (if (eq? inv-names '()) + "You aren't carrying anything.\n" + (apply string-append + "You are carrying:\n" + (map (lambda (item-name) + (string-append " * " item-name "\n")) + inv-names)))) + (<- player (actor-id player) 'tell #:text text-to-show)) + ;;; Command handling ;;; ================ @@ -159,7 +183,11 @@ ;; Append our own command handlers (define our-commands - (player-self-commands player)) + (filter + (lambda (cmd) + (equal? (command-verbs cmd) verb)) + (val-or-run + (slot-ref player 'self-commands)))) ;; TODO: Append our inventory's relevant command handlers diff --git a/mudsync/thing.scm b/mudsync/thing.scm new file mode 100644 index 0000000..341371f --- /dev/null +++ b/mudsync/thing.scm @@ -0,0 +1,132 @@ +;;; 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 . + +;;; Common "things" and stuff you can do with things. + +(define-module (mudsync thing) + #:use-module (mudsync command) + #:use-module (mudsync gameobj) + #:use-module (8sync systems actors) + #:use-module (8sync agenda) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export ( + thing-commands + thing-contained-commands + thing-actions)) + +(define thing-commands + (list + (direct-command "take" 'cmd-take))) + +;;; Are these kinds of things useful? +;; ;; Doesn't inherit anything (gameobj has no commands) +;; ;; so it's an alias. +;; (define thing-commands* thing-commands) + +(define thing-contained-commands + (list + (empty-command "drop" 'cmd-drop))) + +;; ;; Doesn't inherit anything (gameobj has no contained-commands) +;; ;; so it's an alias. +;; (define thing-contained-commands* thing-contained-commands) + +(define thing-actions + (build-actions + (cmd-take (wrap-apply thing-cmd-take)) + (cmd-drop (wrap-apply thing-cmd-drop)))) + +(define thing-actions* + (append thing-actions + gameobj-actions)) + +(define thing-dispatcher + (simple-dispatcher thing-actions*)) + +(define-class () + ;; Can be a boolean or a procedure accepting two arguments + ;; (thing-actor whos-acting) + (takeable #:init-value #f + #:init-keyword #:takeable) + ;; Can be a boolean or a procedure accepting two arguments + ;; (thing-actor whos-dropping) + (dropable #:init-value #t + #:init-keyword #:dropable) + (commands + #:init-value (wrap thing-commands)) + (contained-commands + #:init-value (wrap thing-contained-commands)) + (message-handler + #:init-value + (wrap-apply thing-dispatcher))) + +(define-mhandler (thing-cmd-take thing message direct-obj) + (define player (message-from message)) + (define player-name + (message-ref + (<-wait thing player 'get-name) + 'val)) + (define thing-name (slot-ref thing 'name)) + (define should-take + (slot-ref-maybe-runcheck thing 'takeable player)) + (if should-take + ;; Set the location to whoever's picking us up + (begin + (gameobj-set-loc! thing player) + (<- thing player 'tell + #:text (format #f "You pick up ~a.\n" + thing-name)) + (<- thing (gameobj-loc thing) 'tell-room + #:text (format #f "~a picks up ~a.\n" + player-name + thing-name) + #:exclude player)) + (<- thing player 'tell + #:text (format #f "It doesn't seem like you can pick up ~a.\n" + thing-name)))) + +(define-mhandler (thing-cmd-drop thing message direct-obj) + (define player (message-from message)) + (define player-name + (message-ref + (<-wait thing player 'get-name) + 'val)) + (define player-loc + (message-ref + (<-wait thing player 'get-loc) + 'val)) + (define thing-name (slot-ref thing 'name)) + (define should-drop + (slot-ref-maybe-runcheck thing 'dropable player)) + (if player-loc + ;; Set the location to whoever's picking us up's location + (begin + (gameobj-set-loc! thing player-loc) + (<- thing player 'tell + #:text (format #f "You drop ~a.\n" + thing-name)) + (<- thing player-loc 'tell-room + #:text (format #f "~a drops ~a.\n" + player-name + thing-name) + #:exclude player)) + (<- thing player 'tell + #:text (format #f "It doesn't seem like you can drop ~a.\n" + thing-name)))) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 117e86a..7679735 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -160,9 +160,9 @@ or 'skribe'? Now *that's* composition!")) #:text (format #f "~a signs the form!\n~a is now known as ~a\n" old-name old-name name))) (<- actor (message-from message) 'tell - "Sorry, that's not a valid name. + #:text "Sorry, that's not a valid name. Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic -character."))) +character.\n"))) (define lobby @@ -257,13 +257,15 @@ Busts of serious looking people line the walls, but there's no clear indication that they have any logical relation to this place. In the center is a large statue of a bearded man. You wonder what that's all about? - To the south is the lobby. All around are various doors, but -they're all boarded up. One to the east goes to the smoking parlor, -though." + To the south is the lobby. A door to the east is labeled \"smoking +room\", while a door to the west is labeled \"playroom\"." #:exits (list (make #:name "south" #:to 'room:lobby) + (make + #:name "west" + #:to 'room:playroom) (make #:name "east" #:to 'room:smoking-parlor))) @@ -279,6 +281,24 @@ The inscription says \"St. Ignucius\". ;;; Playroom ;;; -------- +(define playroom + (lol + ('room:playroom + #f + #:name "The Playroom" + #:desc " There are toys scattered everywhere here. It's really unclear +if this room is intended for children or child-like adults." + #:exits + (list (make + #:name "east" + #:to 'room:grand-hallway))) + ('thing:playroom:cubey + 'room:playroom + #:name "cubey" + #:takeable #t + #:desc " It's a little foam cube with googly eyes on it. So cute!"))) + + ;;; Writing room ;;; ------------ @@ -354,7 +374,7 @@ at the bar. (editor's note: or will be soon :])" 'room:smoking-parlor #:name "a plush leather sofa" #:desc " That leather chair looks really comfy!" - #:goes-by '("leather sofa" "plush leather sofa" "chair" + #:goes-by '("leather sofa" "plush leather sofa" "sofa" "leather couch" "plush leather couch" "couch") #:sit-phrase "sprawl out on" #:sit-phrase-third-person "sprawls out on into" @@ -367,7 +387,11 @@ seat in the room, though." #:goes-by '("stool" "bar stool") #:sit-phrase "hop on" #:sit-phrase-third-person "hops onto" - #:sit-name "the bar stool"))) + #:sit-name "the bar stool") + + ;; TODO: Cigar dispenser + + )) ;;; Ennpie's Sea Lounge @@ -382,7 +406,8 @@ seat in the room, though." ;;; ---- (define game-spec - (append lobby grand-hallway smoking-parlor)) + (append lobby grand-hallway smoking-parlor + playroom)) ;; TODO: Provide command line args (define (run-game . args) -- 2.31.1