basic things, with the ability to pick them up (but not put them down, heh)
authorChristopher Allan Webber <cwebber@dustycloud.org>
Mon, 9 May 2016 15:03:57 +0000 (10:03 -0500)
committerChristopher Allan Webber <cwebber@dustycloud.org>
Mon, 9 May 2016 15:03:57 +0000 (10:03 -0500)
Makefile.am
mudsync.scm
mudsync/gameobj.scm
mudsync/player.scm
mudsync/thing.scm [new file with mode: 0644]
worlds/bricabrac.scm

index bccc8083792add47c7eeb942dd0c115967cc5e21..d78ab15f8f5c3b8d3135d9c96ff947a05cdbc8d7 100644 (file)
@@ -53,6 +53,7 @@ SOURCES =  \
        mudsync/player.scm \
        mudsync/room.scm \
        mudsync/run-game.scm \
+       mudsync/thing.scm \
        mudsync.scm
 
 # TESTS =                                                      \
index 31caf486acbfd8a470b947bef2df28fe6660ebe4..a3caaa17d8f30b85f998234853433d2fca7b17e1 100644 (file)
@@ -35,7 +35,8 @@
         command
         player
         room
-        run-game))
+        run-game
+        thing))
 
     (for-each (let ((i (module-public-interface (current-module))))
                 (lambda (m)
index 0f4d7043e96918251bc1f70d85a63fde16c4566f..b686e3cbd74a4d2d41825f0f5f5777290b8357f4 100644 (file)
             gameobj-loc
             gameobj-gm
 
+            gameobj-set-loc!
             gameobj-occupants
             gameobj-actions
             gameobj-self-destruct
 
+            slot-ref-maybe-runcheck
+            val-or-run
+
             dyn-ref))
 
 ;;; Gameobj
 (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!))
 
   ;; 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))
     (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)
index 6e4be5738b2f289ed93decb95a258f2df22f0073..d2fc76dd64d1cbb15a4cf079bb3c9de8317761e9 100644 (file)
@@ -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
 (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 <player> (<gameobj>)
   (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)))
 
 
                        (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
 ;;; ================
 
   ;; 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 (file)
index 0000000..341371f
--- /dev/null
@@ -0,0 +1,132 @@
+;;; Mudsync --- Live hackable MUD
+;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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>
+            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 <thing> (<gameobj>)
+  ;; 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))))
index 117e86af3af1d8351cf86fe002961d5adbddddbe..7679735f813317fc4bae729165a36415cc9b583d 100644 (file)
@@ -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 <exit>
             #:name "south"
             #:to 'room:lobby)
+          (make <exit>
+            #:name "west"
+            #:to 'room:playroom)
           (make <exit>
             #:name "east"
             #:to 'room:smoking-parlor)))
@@ -279,6 +281,24 @@ The inscription says \"St. Ignucius\".
 ;;; Playroom
 ;;; --------
 
+(define playroom
+  (lol
+   ('room:playroom
+    <room> #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 <exit>
+            #:name "east"
+            #:to 'room:grand-hallway)))
+   ('thing:playroom:cubey
+    <thing> 'room:playroom
+    #:name "cubey"
+    #:takeable #t
+    #:desc "  It's a little foam cube with googly eyes on it.  So cute!")))
+
+
 \f
 ;;; Writing room
 ;;; ------------
@@ -354,7 +374,7 @@ at the bar.  (editor's note: or will be soon :])"
     <furniture> '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
+
+   ))
 
 \f
 ;;; 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)