basic things, with the ability to pick them up (but not put them down, heh)

[mudsync.git] / mudsync / thing.scm

diff --git a/mudsync/thing.scm b/mudsync/thing.scm
new file mode 100644 (file)
index 0000000..341371f
--- /dev/null
+++ b/mudsync/thing.scm
@@ -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))))