X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fgameobj.scm;h=ebd4db7276c44aecd5b307c10a43edc5f7b48486;hp=7abb448db99f608352b70a99b0003539f477e41b;hb=f22e3b3e60031ebb8ef6260692bf8c03dcce1c60;hpb=566bf50b08106fe68270c79420886a546666e786 diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 7abb448..ebd4db7 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -21,10 +21,12 @@ (define-module (mudsync gameobj) #:use-module (mudsync command) + #:use-module (mudsync utils) #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (8sync rmeta-slot) #:use-module (srfi srfi-1) + #:use-module (ice-9 control) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (oop goops) @@ -41,7 +43,11 @@ slot-ref-maybe-runcheck val-or-run - dyn-ref)) + dyn-ref + + ;; Some of the more common commands + cmd-take cmd-drop + cmd-take-from-no-op cmd-put-in-no-op)) ;;; Gameobj ;;; ======= @@ -75,11 +81,19 @@ ;; Commands we can handle (commands #:allocation #:each-subclass #:init-thunk (build-commands - ("take" ((direct-command cmd-take #:obvious? #f))))) + ("take" ((direct-command cmd-take) + (prep-indir-command cmd-take-from + '("from" "out of")))) + ("put" ((prep-indir-command cmd-put-in + '("in" "inside" "on")))))) ;; Commands we can handle by being something's container - (container-commands #:allocation #:each-subclass - #:init-thunk (build-commands)) + ;; dominant version (goes before everything) + (container-dom-commands #:allocation #:each-subclass + #:init-thunk (build-commands)) + ;; subordinate version (goes after everything) + (container-sub-commands #:allocation #:each-subclass + #:init-thunk (build-commands)) ;; Commands we can handle by being contained by something else (contained-commands #:allocation #:each-subclass @@ -88,21 +102,21 @@ ("drop" ((direct-command cmd-drop #:obvious? #f))))) ;; Most objects are generally visible by default - (generally-visible #:init-value #t - #:init-keyword #:generally-visible) - ;; @@: Would be preferable to be using generic methods for this... - ;; Hopefully we can port this to Guile 2.2 soon... + (invisible? #:init-value #f + #:init-keyword #:invisible?) + ;; TODO: Fold this into a procedure in invisible? similar + ;; to take-me? and etc (visible-to-player? #:init-value (wrap-apply gameobj-visible-to-player?)) - ;; 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) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting #:key from) + (take-me? #:init-value #f + #:init-keyword #:take-me?) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting where) + (drop-me? #:init-value #t + #:init-keyword #:drop-me?) ;; TODO: Remove this and use actor-alive? instead. ;; Set this on self-destruct @@ -117,7 +131,8 @@ ;; Commands for co-occupants (get-commands gameobj-get-commands) ;; Commands for participants in a room - (get-container-commands gameobj-get-container-commands) + (get-container-dom-commands gameobj-get-container-dom-commands) + (get-container-sub-commands gameobj-get-container-sub-commands) ;; Commands for inventory items, etc (occupants of the gameobj commanding) (get-contained-commands gameobj-get-contained-commands) @@ -134,11 +149,16 @@ (self-destruct gameobj-act-self-destruct) (tell gameobj-tell-no-op) (assist-replace gameobj-act-assist-replace) - (ok-to-drop-here? (const #t)) ; ok to drop by default + (ok-to-drop-here? (lambda (gameobj message . _) + (<-reply message #t))) ; ok to drop by default + (ok-to-be-taken-from? gameobj-ok-to-be-taken-from) + (ok-to-be-put-in? gameobj-ok-to-be-put-in) ;; Common commands (cmd-take cmd-take) - (cmd-drop cmd-drop)))) + (cmd-drop cmd-drop) + (cmd-take-from cmd-take-from-no-op) + (cmd-put-in cmd-put-in-no-op)))) ;;; gameobj message handlers @@ -189,7 +209,7 @@ Assists in its replacement of occupants if necessary and nothing else." (define (gameobj-act-goes-by actor message) "Reply to a message requesting what we go by." - (<-reply message #:goes-by (gameobj-goes-by actor))) + (<-reply message (gameobj-goes-by actor))) (define (val-or-run val-or-proc) "Evaluate if a procedure, or just return otherwise" @@ -209,10 +229,16 @@ Assists in its replacement of occupants if necessary and nothing else." #:commands candidate-commands #:goes-by (gameobj-goes-by actor))) -(define* (gameobj-get-container-commands actor message #:key verb) - "Get commands as the container / room of message's sender" +(define* (gameobj-get-container-dom-commands actor message #:key verb) + "Get (dominant) commands as the container / room of message's sender" + (define candidate-commands + (get-candidate-commands actor 'container-dom-commands verb)) + (<-reply message #:commands candidate-commands)) + +(define* (gameobj-get-container-sub-commands actor message #:key verb) + "Get (subordinate) commands as the container / room of message's sender" (define candidate-commands - (get-candidate-commands actor 'container-commands verb)) + (get-candidate-commands actor 'container-sub-commands verb)) (<-reply message #:commands candidate-commands)) (define* (gameobj-get-contained-commands actor message #:key verb) @@ -256,8 +282,7 @@ Assists in its replacement of occupants if necessary and nothing else." "Get all present occupants of the room." (define occupants (gameobj-occupants actor #:exclude exclude)) - - (<-reply message #:occupants occupants)) + (<-reply message occupants)) (define (gameobj-act-get-loc actor message) (<-reply message (slot-ref actor 'loc))) @@ -281,12 +306,12 @@ 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) +(define (slot-ref-maybe-runcheck gameobj slot whos-asking . other-args) "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)) + (apply slot-val-proc gameobj whos-asking other-args)) (anything-else anything-else))) (define gameobj-get-name (simple-slot-getter 'name)) @@ -305,7 +330,7 @@ and whos-asking, and see if we should just return it or run it." (define (gameobj-visible-to-player? gameobj whos-looking) "Check to see whether we're visible to the player or not. By default, this is whether or not the generally-visible flag is set." - (slot-ref gameobj 'generally-visible)) + (not (slot-ref gameobj 'invisible?))) (define* (gameobj-visible-name actor message #:key whos-looking) ;; Are we visible? @@ -340,22 +365,38 @@ By default, this is whether or not the generally-visible flag is set." (define gameobj-tell-no-op (const 'no-op)) -(define (gameobj-replace-data-occupants actor) +(define (gameobj-replace-data-occupants gameobj) "The general purpose list of replacement data" (list #:occupants (hash-map->list (lambda (occupant _) occupant) - (slot-ref actor 'occupants)))) + (slot-ref gameobj 'occupants)))) -(define (gameobj-replace-data* actor) +(define (gameobj-replace-data* gameobj) ;; For now, just call gameobj-replace-data-occupants. ;; But there may be more in the future! - (gameobj-replace-data-occupants actor)) + (gameobj-replace-data-occupants gameobj)) ;; So sad that objects must assist in their replacement ;_; ;; But that's life in a live hacked game! -(define (gameobj-act-assist-replace actor message) +(define (gameobj-act-assist-replace gameobj message) "Vanilla method for assisting in self-replacement for live hacking" (apply <-reply message - (gameobj-replace-data* actor))) + (gameobj-replace-data* gameobj))) + +(define (gameobj-ok-to-be-taken-from gameobj message whos-acting) + (call-with-values (lambda () + (slot-ref-maybe-runcheck gameobj 'take-me? + whos-acting #:from #t)) + ;; This allows this to reply with #:why-not if appropriate + (lambda args + (apply <-reply message args)))) + +(define (gameobj-ok-to-be-put-in gameobj message whos-acting where) + (call-with-values (lambda () + (slot-ref-maybe-runcheck gameobj 'drop-me? + whos-acting where)) + ;; This allows this to reply with #:why-not if appropriate + (lambda args + (apply <-reply message args)))) ;;; Utilities every gameobj has @@ -378,45 +419,49 @@ By default, this is whether or not the generally-visible flag is set." ;;; Basic actions ;;; ------------- -(define* (cmd-take gameobj message #:key direct-obj) - (define player (message-from message)) +(define* (cmd-take gameobj message + #:key direct-obj + (player (message-from message))) (define player-name (mbody-val (<-wait player 'get-name))) (define player-loc (mbody-val (<-wait player 'get-loc))) (define our-name (slot-ref gameobj 'name)) (define self-should-take - (slot-ref-maybe-runcheck gameobj 'takeable player)) + (slot-ref-maybe-runcheck gameobj 'take-me? player)) ;; @@: Is there any reason to allow the room to object in the way ;; that there is for dropping? It doesn't seem like it. - ;; TODO: Allow gameobj to customize - (if self-should-take - ;; Set the location to whoever's picking us up - (begin - (gameobj-set-loc! gameobj player) - (<- player 'tell - #:text (format #f "You pick up ~a.\n" - our-name)) - (<- player-loc 'tell-room - #:text (format #f "~a picks up ~a.\n" - player-name - our-name) - #:exclude player)) - (<- player 'tell - #:text (format #f "It doesn't seem like you can take ~a.\n" - our-name)))) - -(define* (cmd-drop gameobj message #:key direct-obj) - (define player (message-from message)) + (call-with-values (lambda () + (slot-ref-maybe-runcheck gameobj 'take-me? player)) + (lambda* (self-should-take #:key (why-not + `("It doesn't seem like you can take " + ,our-name "."))) + (if self-should-take + ;; Set the location to whoever's picking us up + (begin + (gameobj-set-loc! gameobj player) + (<- player 'tell + #:text (format #f "You pick up ~a.\n" + our-name)) + (<- player-loc 'tell-room + #:text (format #f "~a picks up ~a.\n" + player-name + our-name) + #:exclude player)) + (<- player 'tell #:text why-not))))) + +(define* (cmd-drop gameobj message + #:key direct-obj + (player (message-from message))) (define player-name (mbody-val (<-wait player 'get-name))) (define player-loc (mbody-val (<-wait player 'get-loc))) (define our-name (slot-ref gameobj 'name)) (define should-drop - (slot-ref-maybe-runcheck gameobj 'dropable player)) + (slot-ref-maybe-runcheck gameobj 'drop-me? player)) (define (room-objection-to-drop) - (mbody-receive (drop-ok? #:key why-not) ; does the room object to dropping? + (mbody-receive (_ drop-ok? #:key why-not) ; does the room object to dropping? (<-wait player-loc 'ok-to-drop-here? player (actor-id gameobj)) (and (not drop-ok?) ;; Either give the specified reason, or give a boilerplate one @@ -448,3 +493,19 @@ By default, this is whether or not the generally-visible flag is set." player-name our-name) #:exclude player)))) + +(define* (cmd-take-from-no-op gameobj message + #:key direct-obj indir-obj preposition + (player (message-from message))) + (<- player 'tell + #:text `("It doesn't seem like you can take anything " + ,preposition " " + ,(slot-ref gameobj 'name) "."))) + +(define* (cmd-put-in-no-op gameobj message + #:key direct-obj indir-obj preposition + (player (message-from message))) + (<- player 'tell + #:text `("It doesn't seem like you can put anything " + ,preposition " " + ,(slot-ref gameobj 'name) ".")))