mudsync/gameobj.scm

   1 ;;; Mudsync --- Live hackable MUD
   2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of Mudsync.
   5 ;;;
   6 ;;; Mudsync is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; Mudsync is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;; Game actor
  20 ;;; ==========
  21
  22 (define-module (mudsync gameobj)
  23   #:use-module (mudsync command)
  24   #:use-module (8sync systems actors)
  25   #:use-module (8sync agenda)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (ice-9 format)
  28   #:use-module (ice-9 match)
  29   #:use-module (oop goops)
  30   #:export (<gameobj>
  31
  32             gameobj-loc
  33             gameobj-gm
  34
  35             gameobj-act-init
  36             gameobj-set-loc!
  37             gameobj-occupants
  38             gameobj-actions
  39             gameobj-self-destruct
  40
  41             slot-ref-maybe-runcheck
  42             val-or-run
  43
  44             dyn-ref))
  45
  46 ;;; Gameobj
  47 ;;; =======
  48
  49
  50 ;;; Actions supported by all gameobj
  51 (define gameobj-actions
  52   (build-actions
  53    (init (wrap-apply gameobj-act-init))
  54    ;; Commands for co-occupants
  55    (get-commands (wrap-apply gameobj-get-commands))
  56    ;; Commands for participants in a room
  57    (get-container-commands (wrap-apply gameobj-get-container-commands))
  58    ;; Commands for inventory items, etc (occupants of the gameobj commanding)
  59    (get-contained-commands (wrap-apply gameobj-get-contained-commands))
  60    (get-occupants (wrap-apply gameobj-get-occupants))
  61    (add-occupant! (wrap-apply gameobj-add-occupant!))
  62    (remove-occupant! (wrap-apply gameobj-remove-occupant!))
  63    (get-loc (wrap-apply gameobj-act-get-loc))
  64    (set-loc! (wrap-apply gameobj-act-set-loc!))
  65    (get-name (wrap-apply gameobj-get-name))
  66    (set-name! (wrap-apply gameobj-act-set-name!))
  67    (get-desc (wrap-apply gameobj-get-desc))
  68    (goes-by (wrap-apply gameobj-act-goes-by))
  69    (visible-name (wrap-apply gameobj-visible-name))
  70    (self-destruct (wrap-apply gameobj-act-self-destruct))
  71    (tell (wrap-apply gameobj-tell-no-op))
  72    (assist-replace (wrap-apply gameobj-act-assist-replace))))
  73
  74 ;;; *all* game components that talk to players should somehow
  75 ;;; derive from this class.
  76 ;;; And all of them need a GM!
  77
  78 (define-class <gameobj> (<actor>)
  79   ;; location id
  80   (loc #:init-value #f
  81        #:getter gameobj-loc)
  82
  83   ;; Uses a hash table like a set (values ignored)
  84   (occupants #:init-thunk make-hash-table)
  85
  86   ;; game master id
  87   (gm #:init-keyword #:gm
  88       #:getter gameobj-gm)
  89   ;; a name to be known by
  90   (name #:init-keyword #:name
  91         #:init-value #f)
  92   (goes-by #:init-keyword #:goes-by
  93            #:init-value #f)
  94
  95   (desc #:init-value #f
  96         #:init-keyword #:desc)
  97
  98   ;; Commands we can handle
  99   (commands #:init-value '())
 100
 101   ;; Commands we can handle by being something's container
 102   (container-commands #:init-value '())
 103
 104   ;; Commands we can handle by being contained by something else
 105   (contained-commands #:init-value '())
 106
 107   (message-handler
 108    #:init-value
 109    (simple-dispatcher gameobj-actions))
 110
 111   ;; Most objects are generally visible by default
 112   (generally-visible #:init-value #t
 113                      #:init-keyword #:generally-visible)
 114   ;; @@: Would be preferable to be using generic methods for this...
 115   ;;   Hopefully we can port this to Guile 2.2 soon...
 116   (visible-to-player?
 117    #:init-value (wrap-apply gameobj-visible-to-player?))
 118
 119   ;; Set this on self-destruct
 120   ;; (checked by some "long running" game routines)
 121   (destructed #:init-value #f))
 122
 123
 124 ;;; gameobj message handlers
 125 ;;; ========================
 126
 127 ;; Kind of a useful utility, maybe?
 128 (define (simple-slot-getter slot)
 129   (lambda (actor message)
 130     (<-reply actor message (slot-ref actor slot))))
 131
 132 (define (gameobj-replace-step-occupants actor occupants)
 133   ;; Snarf all the occupants!
 134   (display "replacing occupant\n")
 135   (when occupants
 136     (for-each
 137      (lambda (occupant)
 138        (<-wait actor occupant 'set-loc!
 139                #:loc (actor-id actor)))
 140      occupants)))
 141
 142 (define gameobj-replace-steps*
 143   (list gameobj-replace-step-occupants))
 144
 145 (define (run-replacement actor replaces replace-steps)
 146   (when replaces
 147     (msg-receive (_ #:key occupants)
 148         (<-wait actor replaces 'assist-replace)
 149       (for-each
 150        (lambda (replace-step)
 151          (replace-step actor occupants))
 152        replace-steps))))
 153
 154 ;; @@: This could be kind of a messy way of doing gameobj-act-init
 155 ;;   stuff.  If only we had generic methods :(
 156 (define* (gameobj-act-init actor message #:key replace)
 157   "Your most basic game object init procedure.
 158 Assists in its replacement of occupants if necessary and nothing else."
 159   (run-replacement actor replace gameobj-replace-steps*))
 160
 161 (define (gameobj-goes-by gameobj)
 162   "Find the name we go by.  Defaults to #:name if nothing else provided."
 163   (cond ((slot-ref gameobj 'goes-by) =>
 164          identity)
 165         ((slot-ref gameobj 'name) =>
 166          (lambda (name)
 167            (list name)))
 168         (else '())))
 169
 170 (define (gameobj-act-goes-by actor message)
 171   "Reply to a message requesting what we go by."
 172   (<-reply actor message
 173            #:goes-by (gameobj-goes-by actor)))
 174
 175 (define (val-or-run val-or-proc)
 176   "Evaluate if a procedure, or just return otherwise"
 177   (if (procedure? val-or-proc)
 178       (val-or-proc)
 179       val-or-proc))
 180
 181 (define (filter-commands commands verb)
 182   (filter
 183    (lambda (cmd)
 184      (equal? (command-verbs cmd)
 185              verb))
 186    commands))
 187
 188 (define* (gameobj-get-commands actor message #:key verb)
 189   "Get commands a co-occupant of the room might execute for VERB"
 190   (define filtered-commands
 191     (filter-commands (val-or-run (slot-ref actor 'commands))
 192                      verb))
 193   (<-reply actor message
 194            #:commands filtered-commands
 195            #:goes-by (gameobj-goes-by actor)))
 196
 197 (define* (gameobj-get-container-commands actor message #:key verb)
 198   "Get commands as the container / room of message's sender"
 199   (define filtered-commands
 200     (filter-commands (val-or-run (slot-ref actor 'container-commands))
 201                      verb))
 202   (<-reply actor message #:commands filtered-commands))
 203
 204 (define* (gameobj-get-contained-commands actor message #:key verb)
 205   "Get commands as being contained (eg inventory) of commanding gameobj"
 206   (define filtered-commands
 207     (filter-commands (val-or-run (slot-ref actor 'contained-commands))
 208                      verb))
 209   (<-reply actor message
 210            #:commands filtered-commands
 211            #:goes-by (gameobj-goes-by actor)))
 212
 213 (define* (gameobj-add-occupant! actor message #:key who)
 214   "Add an actor to our list of present occupants"
 215   (hash-set! (slot-ref actor 'occupants)
 216              who #t))
 217
 218 (define* (gameobj-remove-occupant! actor message #:key who)
 219   "Remove an occupant from the room."
 220   (hash-remove! (slot-ref actor 'occupants) who))
 221
 222 (define* (gameobj-occupants gameobj #:key exclude)
 223   (hash-fold
 224    (lambda (occupant _ prev)
 225      (define exclude-it?
 226        (match exclude
 227          ;; Empty list and #f are non-exclusion
 228          (() #f)
 229          (#f #f)
 230          ;; A list of addresses... since our address object is (annoyingly)
 231          ;; currently a simple cons cell...
 232          ((exclude-1 ... exclude-rest)
 233           (pk 'failboat (member occupant (pk 'exclude-lst exclude))))
 234          ;; Must be an individual address!
 235          (_ (equal? occupant exclude))))
 236      (if exclude-it?
 237          prev
 238          (cons occupant prev)))
 239    '()
 240    (slot-ref gameobj 'occupants)))
 241
 242 (define* (gameobj-get-occupants actor message #:key exclude)
 243   "Get all present occupants of the room."
 244   (define occupants
 245     (gameobj-occupants actor #:exclude exclude))
 246
 247   (<-reply actor message
 248            #:occupants occupants))
 249
 250 (define (gameobj-act-get-loc actor message)
 251   (<-reply actor message (slot-ref actor 'loc)))
 252
 253 (define (gameobj-set-loc! gameobj loc)
 254   "Set the location of this object."
 255   (define old-loc (gameobj-loc gameobj))
 256   (format #t "DEBUG: Location set to ~s for ~s\n"
 257           loc (actor-id-actor gameobj))
 258
 259   (when (not (equal? old-loc loc))
 260     (slot-set! gameobj 'loc loc)
 261     ;; Change registation of where we currently are
 262     (if old-loc
 263         (<-wait gameobj old-loc 'remove-occupant! #:who (actor-id gameobj)))
 264     (if loc
 265         (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))))
 266
 267 ;; @@: Should it really be #:id ?  Maybe #:loc-id or #:loc?
 268 (define* (gameobj-act-set-loc! actor message #:key loc)
 269   "Action routine to set the location."
 270   (gameobj-set-loc! actor loc))
 271
 272 (define (slot-ref-maybe-runcheck gameobj slot whos-asking)
 273   "Do a slot-ref on gameobj, evaluating it including ourselves
 274 and whos-asking, and see if we should just return it or run it."
 275   (match (slot-ref gameobj slot)
 276     ((? procedure? slot-val-proc)
 277      (slot-val-proc gameobj whos-asking))
 278     (anything-else anything-else)))
 279
 280 (define gameobj-get-name (simple-slot-getter 'name))
 281
 282 (define* (gameobj-act-set-name! actor message val)
 283   (slot-set! actor 'name val))
 284
 285 (define* (gameobj-get-desc actor message #:key whos-looking)
 286   (define desc-text
 287     (match (slot-ref actor 'desc)
 288       ((? procedure? desc-proc)
 289        (desc-proc actor whos-looking))
 290       (desc desc)))
 291   (<-reply actor message desc-text))
 292
 293 (define (gameobj-visible-to-player? gameobj whos-looking)
 294   "Check to see whether we're visible to the player or not.
 295 By default, this is whether or not the generally-visible flag is set."
 296   (slot-ref gameobj 'generally-visible))
 297
 298 (define* (gameobj-visible-name actor message #:key whos-looking)
 299   ;; Are we visible?
 300   (define we-are-visible
 301     ((slot-ref actor 'visible-to-player?) actor whos-looking))
 302
 303   (define name-to-return
 304     (if we-are-visible
 305         ;; Return our name
 306         (match (slot-ref actor 'name)
 307           ((? procedure? name-proc)
 308            (name-proc actor whos-looking))
 309           ((? string? name)
 310            name)
 311           (#f #f))
 312         #f))
 313   (<-reply actor message #:text name-to-return))
 314
 315 (define (gameobj-self-destruct gameobj)
 316   "General gameobj self destruction routine"
 317   ;; Unregister from being in any particular room
 318   (gameobj-set-loc! gameobj #f)
 319   (slot-set! gameobj 'destructed #t)
 320   ;; Boom!
 321   (self-destruct gameobj))
 322
 323 (define (gameobj-act-self-destruct gameobj message)
 324   "Action routine for self destruction"
 325   (gameobj-self-destruct gameobj))
 326
 327 ;; Unless an actor has a tell message, we just ignore it
 328 (define gameobj-tell-no-op
 329   (const 'no-op))
 330
 331 (define (gameobj-replace-data-occupants actor)
 332   "The general purpose list of replacement data"
 333   (list #:occupants (hash-map->list (lambda (occupant _) occupant)
 334                                     (slot-ref actor 'occupants))))
 335
 336 (define (gameobj-replace-data* actor)
 337   ;; For now, just call gameobj-replace-data-occupants.
 338   ;; But there may be more in the future!
 339   (gameobj-replace-data-occupants actor))
 340
 341 ;; So sad that objects must assist in their replacement ;_;
 342 ;; But that's life in a live hacked game!
 343 (define (gameobj-act-assist-replace actor message)
 344   "Vanilla method for assisting in self-replacement for live hacking"
 345   (apply <-reply actor message
 346          (gameobj-replace-data* actor)))
 347
 348 \f
 349 ;;; Utilities every gameobj has
 350 ;;; ---------------------------
 351
 352 (define (dyn-ref gameobj special-symbol)
 353   "Dynamically look up a special object from the gm"
 354   (match special-symbol
 355     ;; if it's a symbol, look it up dynamically
 356     ((? symbol? _)
 357      (msg-val (<-wait gameobj (slot-ref gameobj 'gm) 'lookup-special
 358                       #:symbol special-symbol)))
 359     ;; if it's false, return nothing
 360     (#f #f)
 361     ;; otherwise it's probably an address, return it as-is
 362     (_ special-symbol)))