X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fgameobj.scm;h=3957e0a4d40303898888af5828632f9e7f0525cb;hp=3bb743ac5101e09182c0c5e6020c931d73394e10;hb=HEAD;hpb=ca990b14f563fc450548954184ff6fc0e4792739 diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 3bb743a..fbf4a72 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -1,5 +1,5 @@ ;;; Mudsync --- Live hackable MUD -;;; Copyright © 2016 Christopher Allan Webber +;;; Copyright © 2016 Christine Lemmer-Webber ;;; ;;; This file is part of Mudsync. ;;; @@ -21,16 +21,21 @@ (define-module (mudsync gameobj) #:use-module (mudsync command) - #:use-module (8sync systems actors) + #: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) #:export ( + create-gameobj gameobj-loc gameobj-gm + gameobj-desc gameobj-act-init gameobj-set-loc! @@ -40,11 +45,18 @@ slot-ref-maybe-runcheck val-or-run - dyn-ref)) + build-props + dyn-ref + + ;; Some of the more common commands + cmd-look-at + cmd-take cmd-drop + cmd-take-from-no-op cmd-put-in-no-op)) ;;; Gameobj ;;; ======= +(define build-props build-rmeta-slot) ;;; *all* game components that talk to players should somehow ;;; derive from this class. @@ -61,6 +73,7 @@ ;; game master id (gm #:init-keyword #:gm #:getter gameobj-gm) + ;; a name to be known by (name #:init-keyword #:name #:init-value #f) @@ -70,38 +83,86 @@ (desc #:init-value #f #:init-keyword #:desc) + ;; @@: Maybe commands should be renamed to verbs, I dunno ;; Commands we can handle - (commands #:init-value '()) + (commands #:allocation #:each-subclass + #:init-thunk (build-commands + (("l" "look") ((direct-command cmd-look-at))) + ("take" ((direct-command cmd-take) + (prep-indir-command cmd-take-from + '("from" "out of")))) + ("put" ((prep-indir-command cmd-put-in + '("in" "inside" "into" "on")))))) ;; Commands we can handle by being something's container - (container-commands #:init-value '()) + ;; 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 #:init-value '()) + (contained-commands #:allocation #:each-subclass + #:init-thunk + (build-commands + (("l" "look") ((direct-command cmd-look-at))) + ("drop" ((direct-command cmd-drop #:obvious? #f))))) + + ;; The extremely squishy concept of "props"... properties! + ;; These are flags, etc etc of various types. This is a hashq table. + ;; These have upsides and downsides, but the big upside is that you can + ;; query a "prop" of a prospective gameobj without knowing what type of + ;; gameobj that is, and not fear some kind of breakage. + ;; + ;; props by default only have a 'get-prop read-only action handler; + ;; any coordination of setting a prop between actors must be + ;; added to that actor, to keep things from getting out of control. + (props #:init-thunk make-hash-table + #:init-keyword #:props) + ;; gameobjs may inherit an initial list of these via the + ;; initial-props slot, which must always have its + ;; #:allocation #:each-subclass and use (build-props) for the + ;; #:init-thunk. + ;; The vanilla gameobj has no props, on purpose. + (initial-props #:allocation #:each-subclass + #:init-thunk (build-props '())) ;; 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 + ;; (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 ;; (checked by some "long running" game routines) (destructed #:init-value #f) (actions #:allocation #:each-subclass ;;; Actions supported by all gameobj - #:init-value - (mhandlers + #:init-thunk + (build-actions (init gameobj-act-init) ;; 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) + (get-occupants gameobj-get-occupants) (add-occupant! gameobj-add-occupant!) (remove-occupant! gameobj-remove-occupant!) @@ -110,20 +171,53 @@ (get-name gameobj-get-name) (set-name! gameobj-act-set-name!) (get-desc gameobj-get-desc) + (get-prop gameobj-act-get-prop) (goes-by gameobj-act-goes-by) (visible-name gameobj-visible-name) (self-destruct gameobj-act-self-destruct) (tell gameobj-tell-no-op) - (assist-replace gameobj-act-assist-replace)))) + (assist-replace gameobj-act-assist-replace) + (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-look-at cmd-look-at) + (cmd-take cmd-take) + (cmd-drop cmd-drop) + (cmd-take-from cmd-take-from-no-op) + (cmd-put-in cmd-put-in-no-op)))) ;;; gameobj message handlers ;;; ======================== +;; TODO: This init stuff is a mess, and should be redone now that +;; we have the *init* action stuff. We've really spread out the +;; logic for creating a gameobj in several places, eg gm-inject-special! +(define (create-gameobj class gm loc . args) + "Create a gameobj of CLASS with GM and set to location LOC, applying rest of ARGS. +Note that this doesn't do any special dyn-ref of the location." + (let ((new-gameobj (apply create-actor (%current-actor) class + #:gm gm args))) + ;; Set the location + (<-wait new-gameobj 'set-loc! #:loc loc) + ;; Initialize the object + (<-wait new-gameobj 'init))) + +;; ;; @@: Should we also dyn-ref the loc here? We can do that, unlike with +;; ;; create-gameobj. +;; ;; Another route could be to have set-loc! itself know how to use the +;; ;; dyn-ref. +;; (define (gameobj-create-gameobj gameobj class loc . args) +;; "Like create-gameobj but saves the step of passing in the gm." +;; (apply create-gameobj class (gameobj-gm gameobj) loc args)) + ;; Kind of a useful utility, maybe? (define (simple-slot-getter slot) (lambda (actor message) - (<-reply actor message (slot-ref actor slot)))) + (<-reply message (slot-ref actor slot)))) (define (gameobj-replace-step-occupants actor occupants) ;; Snarf all the occupants! @@ -131,7 +225,7 @@ (when occupants (for-each (lambda (occupant) - (<-wait actor occupant 'set-loc! + (<-wait occupant 'set-loc! #:loc (actor-id actor))) occupants))) @@ -140,20 +234,45 @@ (define (run-replacement actor replaces replace-steps) (when replaces - (msg-receive (_ #:key occupants) - (<-wait actor replaces 'assist-replace) + (mbody-receive (_ #:key occupants) + (<-wait replaces 'assist-replace) (for-each (lambda (replace-step) (replace-step actor occupants)) replace-steps)))) -;; @@: This could be kind of a messy way of doing gameobj-act-init -;; stuff. If only we had generic methods :( +(define %nothing (cons '*the* '*nothing*)) +(define (gameobj-setup-props gameobj) + (define class (class-of gameobj)) + (define props (slot-ref gameobj 'props)) + (maybe-build-rmeta-slot-cache! class 'initial-props + eq? hashq-set! hashq-ref) + ;; Kind of a kludge... we read through the rmeta-slot-cache + ;; and use that to build up the table + (hash-for-each + (lambda (key value) + (when (eq? (hashq-ref props key %nothing) ; don't override init'ed instance values + %nothing) + (hashq-set! props key value))) + (rmeta-slot-cache (class-slot-ref class 'initial-props)))) + +;; TODO: Use the *init* action? +;; We could also use a generic method if they didn't have +;; what I'm pretty sure is O(n) dispatch in GOOPS... (define* (gameobj-act-init actor message #:key replace) - "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." + (gameobj-setup-props actor) (run-replacement actor replace gameobj-replace-steps*)) +(define* (gameobj-get-prop gameobj key #:optional dflt) + (hashq-ref (slot-ref gameobj 'props) key dflt)) + +(define* (gameobj-set-prop! gameobj key val) + (hashq-set! (slot-ref gameobj 'props) key val)) + +(define* (gameobj-act-get-prop actor message key #:optional dflt) + (<-reply message (gameobj-get-prop actor key dflt))) + (define (gameobj-goes-by gameobj) "Find the name we go by. Defaults to #:name if nothing else provided." (cond ((slot-ref gameobj 'goes-by) => @@ -165,8 +284,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 actor 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" @@ -174,36 +292,36 @@ Assists in its replacement of occupants if necessary and nothing else." (val-or-proc) val-or-proc)) -(define (filter-commands commands verb) - (filter - (lambda (cmd) - (equal? (command-verbs cmd) - verb)) - commands)) +(define (get-candidate-commands actor rmeta-sym verb) + (class-rmeta-ref (class-of actor) rmeta-sym verb + #:dflt '())) (define* (gameobj-get-commands actor message #:key verb) "Get commands a co-occupant of the room might execute for VERB" - (define filtered-commands - (filter-commands (val-or-run (slot-ref actor 'commands)) - verb)) - (<-reply actor message - #:commands filtered-commands + (define candidate-commands + (get-candidate-commands actor 'commands verb)) + (<-reply message + #: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 filtered-commands - (filter-commands (val-or-run (slot-ref actor 'container-commands)) - verb)) - (<-reply actor message #:commands filtered-commands)) +(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-sub-commands verb)) + (<-reply message #:commands candidate-commands)) (define* (gameobj-get-contained-commands actor message #:key 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 + (define candidate-commands + (get-candidate-commands actor 'contained-commands verb)) + (<-reply message + #:commands candidate-commands #:goes-by (gameobj-goes-by actor))) (define* (gameobj-add-occupant! actor message #:key who) @@ -226,7 +344,7 @@ Assists in its replacement of occupants if necessary and nothing else." ;; A list of addresses... since our address object is (annoyingly) ;; currently a simple cons cell... ((exclude-1 ... exclude-rest) - (pk 'failboat (member occupant (pk 'exclude-lst exclude)))) + (member occupant exclude)) ;; Must be an individual address! (_ (equal? occupant exclude)))) (if exclude-it? @@ -239,12 +357,10 @@ 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 actor message - #:occupants occupants)) + (<-reply message occupants)) (define (gameobj-act-get-loc actor message) - (<-reply actor message (slot-ref actor 'loc))) + (<-reply message (slot-ref actor 'loc))) (define (gameobj-set-loc! gameobj loc) "Set the location of this object." @@ -256,21 +372,21 @@ Assists in its replacement of occupants if necessary and nothing else." (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))) + (<-wait old-loc 'remove-occupant! #:who (actor-id gameobj))) (if loc - (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj))))) + (<-wait loc 'add-occupant! #:who (actor-id gameobj))))) ;; @@: Should it really be #:id ? Maybe #:loc-id or #:loc? (define* (gameobj-act-set-loc! actor message #:key loc) "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)) @@ -278,18 +394,20 @@ and whos-asking, and see if we should just return it or run it." (define* (gameobj-act-set-name! actor message val) (slot-set! actor 'name val)) +(define* (gameobj-desc gameobj #:key whos-looking) + (match (slot-ref gameobj 'desc) + ((? procedure? desc-proc) + (desc-proc gameobj whos-looking)) + (desc desc))) + (define* (gameobj-get-desc actor message #:key whos-looking) - (define desc-text - (match (slot-ref actor 'desc) - ((? procedure? desc-proc) - (desc-proc actor whos-looking)) - (desc desc))) - (<-reply actor message desc-text)) + "This is the action equivalent of the gameobj-desc getter" + (<-reply message (gameobj-desc actor #:whos-looking whos-looking))) (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? @@ -306,7 +424,7 @@ By default, this is whether or not the generally-visible flag is set." name) (#f #f)) #f)) - (<-reply actor message #:text name-to-return)) + (<-reply message #:text name-to-return)) (define (gameobj-self-destruct gameobj) "General gameobj self destruction routine" @@ -316,7 +434,7 @@ By default, this is whether or not the generally-visible flag is set." ;; Boom! (self-destruct gameobj)) -(define (gameobj-act-self-destruct gameobj message) +(define* (gameobj-act-self-destruct gameobj message #:key why) "Action routine for self destruction" (gameobj-self-destruct gameobj)) @@ -324,22 +442,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 actor message - (gameobj-replace-data* actor))) + (apply <-reply message + (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 @@ -350,9 +484,118 @@ By default, this is whether or not the generally-visible flag is set." (match special-symbol ;; if it's a symbol, look it up dynamically ((? symbol? _) - (msg-val (<-wait gameobj (slot-ref gameobj 'gm) 'lookup-special - #:symbol special-symbol))) + ;; TODO: If we get back an #f at this point, should we throw + ;; an error? Obviously #f is okay, but maybe not if + (mbody-val (<-wait (slot-ref gameobj 'gm) 'lookup-special + #:symbol special-symbol))) ;; if it's false, return nothing (#f #f) ;; otherwise it's probably an address, return it as-is (_ special-symbol))) + + + +;;; Basic actions +;;; ------------- + +(define %formless-desc + "You don't see anything special.") + +(define* (cmd-look-at gameobj message + #:key direct-obj + (player (message-from message))) + (let ((desc + (or (gameobj-desc gameobj #:whos-looking player) + %formless-desc))) + (<- player 'tell #:text desc))) + +(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 '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. + (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 'drop-me? player)) + (define (room-objection-to-drop) + (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 + (or why-not + `("You'd love to drop " ,our-name + " but for some reason it doesn't seem like you can" + " do that here."))))) + (cond + ((not player-loc) + (<- player 'tell + #:text `("It doesn't seem like you can drop " ,our-name + " here, because you don't seem to be anywhere?!?"))) + ;; TODO: Let ourselves supply a reason why not. + ((not should-drop) + (<- player 'tell + #:text (format #f "It doesn't seem like you can drop ~a.\n" + our-name))) + ((room-objection-to-drop) + (<- player 'tell + #:text room-objection-to-drop)) + (else + (gameobj-set-loc! gameobj player-loc) + ;; TODO: Allow more flavortext here. + (<- player 'tell + #:text (format #f "You drop ~a.\n" + our-name)) + (<- player-loc 'tell-room + #:text (format #f "~a drops ~a.\n" + 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) ".")))