Updating mudsync for 8sync suspendable-ports refactor

[mudsync.git] / mudsync / gameobj.scm

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index ec95e2c9f6278fe57ba840affc0cc7d3a10d9b7d..20fc291340198c25e12ad2c718c985e55ad35c42 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -24,6 +24,7 @@
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)
   #:use-module (srfi srfi-1)
   #:use-module (8sync systems actors)
   #:use-module (8sync agenda)
   #:use-module (srfi srfi-1)

+  #:use-module (ice-9 format)

   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:export (<gameobj>
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:export (<gameobj>


@@ -31,10 +32,15 @@
             gameobj-loc
             gameobj-gm
 
             gameobj-loc
             gameobj-gm
 

+            gameobj-act-init
+            gameobj-set-loc!

             gameobj-occupants
             gameobj-actions
             gameobj-self-destruct
 
             gameobj-occupants
             gameobj-actions
             gameobj-self-destruct
 

+            slot-ref-maybe-runcheck
+            val-or-run
+

             dyn-ref))
 
 ;;; Gameobj
             dyn-ref))
 
 ;;; Gameobj


@@ -44,12 +50,17 @@
 ;;; Actions supported by all gameobj
 (define gameobj-actions
   (build-actions
 ;;; Actions supported by all gameobj
 (define gameobj-actions
   (build-actions

-   (init (wrap-apply gameobj-init))
+   (init (wrap-apply gameobj-act-init))
+   ;; Commands for co-occupants

    (get-commands (wrap-apply gameobj-get-commands))
    (get-commands (wrap-apply gameobj-get-commands))

+   ;; Commands for participants in a room

    (get-container-commands (wrap-apply gameobj-get-container-commands))
    (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-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!))
    (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 +100,10 @@
 
   ;; Commands we can handle by being something's container
   (container-commands #:init-value '())
 
   ;; 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))
   (message-handler
    #:init-value
    (simple-dispatcher gameobj-actions))


@@ -99,7 +114,11 @@
   ;; @@: Would be preferable to be using generic methods for this...
   ;;   Hopefully we can port this to Guile 2.2 soon...
   (visible-to-player?
   ;; @@: Would be preferable to be using generic methods for this...
   ;;   Hopefully we can port this to Guile 2.2 soon...
   (visible-to-player?

-   #:init-value (wrap-apply gameobj-visible-to-player?)))
+   #:init-value (wrap-apply gameobj-visible-to-player?))
+
+  ;; Set this on self-destruct
+  ;; (checked by some "long running" game routines)
+  (destructed #:init-value #f))

 
 
 ;;; gameobj message handlers
 
 
 ;;; gameobj message handlers


@@ -111,7 +130,6 @@
     (reply-message actor message
                    #:val (slot-ref actor slot))))
 
     (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))
 (define (gameobj-replace-step-occupants actor replace-reply)
   (define occupants
     (message-ref replace-reply 'occupants #f))


@@ -137,12 +155,11 @@
          (replace-step actor replace-reply))
        replace-steps))))
 
          (replace-step actor replace-reply))
        replace-steps))))
 

-;; @@: This could be kind of a messy way of doing gameobj-init
+;; @@: This could be kind of a messy way of doing gameobj-act-init

 ;;   stuff.  If only we had generic methods :(
 ;;   stuff.  If only we had generic methods :(

-(define-mhandler (gameobj-init actor message)
+(define-mhandler (gameobj-act-init actor message)

   "Your most basic game object init procedure.
 Assists in its replacement of occupants if necessary and nothing else."
   "Your most basic game object init procedure.
 Assists in its replacement of occupants if necessary and nothing else."

-  (display "gameobj init!\n")

   (run-replacement actor message gameobj-replace-steps*))
 
 (define (gameobj-goes-by gameobj)
   (run-replacement actor message gameobj-replace-steps*))
 
 (define (gameobj-goes-by gameobj)


@@ -188,6 +205,15 @@ Assists in its replacement of occupants if necessary and nothing else."
                      verb))
   (<-reply actor message #:commands filtered-commands))
 
                      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)
 (define-mhandler (gameobj-add-occupant! actor message who)
   "Add an actor to our list of present occupants"
   (hash-set! (slot-ref actor 'occupants)


@@ -226,24 +252,37 @@ Assists in its replacement of occupants if necessary and nothing else."
   (<-reply actor message
            #:occupants occupants))
 
   (<-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))
   (format #t "DEBUG: Location set to ~s for ~s\n"
           loc (actor-id-actor gameobj))
 
 (define (gameobj-set-loc! gameobj loc)
   "Set the location of this object."
   (define old-loc (gameobj-loc gameobj))
   (format #t "DEBUG: Location set to ~s for ~s\n"
           loc (actor-id-actor gameobj))
 

-  (slot-set! gameobj 'loc loc)
-  ;; Change registation of where we currently are
-  (if loc
-      (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))
-  (if old-loc
-      (<-wait gameobj old-loc 'remove-occupant! #:who (actor-id gameobj))))
+  (when (not (equal? old-loc loc))
+    (slot-set! gameobj 'loc loc)
+    ;; Change registation of where we currently are
+    (if old-loc
+        (<-wait gameobj old-loc 'remove-occupant! #:who (actor-id gameobj)))
+    (if loc
+        (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))))

 
 ;; @@: Should it really be #:id ?  Maybe #:loc-id or #:loc?
 (define-mhandler (gameobj-act-set-loc! actor message loc)
   "Action routine to set the location."
   (gameobj-set-loc! actor loc))
 
 
 ;; @@: Should it really be #:id ?  Maybe #:loc-id or #:loc?
 (define-mhandler (gameobj-act-set-loc! actor message loc)
   "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)
 (define gameobj-get-name (simple-slot-getter 'name))
 
 (define-mhandler (gameobj-act-set-name! actor message val)


@@ -283,6 +322,7 @@ By default, this is whether or not the generally-visible flag is set."
   "General gameobj self destruction routine"
   ;; Unregister from being in any particular room
   (gameobj-set-loc! gameobj #f)
   "General gameobj self destruction routine"
   ;; Unregister from being in any particular room
   (gameobj-set-loc! gameobj #f)

+  (slot-set! gameobj 'destructed #t)

   ;; Boom!
   (self-destruct gameobj))
 
   ;; Boom!
   (self-destruct gameobj))
 


@@ -325,6 +365,6 @@ By default, this is whether or not the generally-visible flag is set."
               #:symbol special-symbol)
       'val))
     ;; if it's false, return nothing
               #:symbol special-symbol)
       'val))
     ;; if it's false, return nothing

-    ((#f #f))
+    (#f #f)

     ;; otherwise it's probably an address, return it as-is
     (_ special-symbol)))
     ;; otherwise it's probably an address, return it as-is
     (_ special-symbol)))