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 (8sync systems actors)
  24   #:use-module (8sync agenda)
  25   #:use-module (oop goops)
  26   #:export (<gameobj>
  27             gameobj-simple-name-f
  28
  29             gameobj-loc
  30             gameobj-gm
  31             gameobj-name
  32             gameobj-name-f
  33
  34             gameobj-actions))
  35
  36 ;;; Gameobj
  37 ;;; =======
  38
  39
  40 ;;; Actions supported by all gameobj
  41 (define gameobj-actions
  42   (build-actions
  43    (get-commands (wrap-apply gameobj-get-commands))
  44    (get-container-commands (wrap-apply gameobj-get-container-commands))
  45    (get-occupants (wrap-apply gameobj-get-occupants))
  46    (add-occupant! (wrap-apply gameobj-add-occupant!))
  47    (remove-occupant! (wrap-apply gameobj-remove-occupant!))
  48    (set-loc! (wrap-apply gameobj-set-loc!))
  49    (get-name (wrap-apply gameobj-get-name))
  50    (get-desc (wrap-apply gameobj-get-desc))
  51    ))
  52
  53 ;;; *all* game components that talk to players should somehow
  54 ;;; derive from this class.
  55 ;;; And all of them need a GM!
  56
  57 (define-class <gameobj> (<actor>)
  58   ;; location id
  59   (loc #:init-value #f
  60        #:accessor gameobj-loc)
  61
  62   ;; Uses a hash table like a set (values ignored)
  63   (occupants #:init-thunk make-hash-table
  64              #:accessor gameobj-occupants)
  65
  66   ;; game master id
  67   (gm #:init-keyword #:gm
  68       #:getter gameobj-gm)
  69   ;; a name to be known by
  70   (name #:init-keyword #:name
  71         #:accessor gameobj-name)
  72
  73   (desc #:init-value ""
  74         #:init-keyword #:desc)
  75
  76   ;; how to print our name
  77   (name-f #:init-keyword #:name-f
  78           #:getter gameobj-name-f
  79           #:init-value (wrap gameobj-simple-name-f))
  80
  81   ;; Name aliases
  82   (aliases #:init-keyword #:aliases
  83            #:init-value '())
  84
  85   ;; Commands we can handle
  86   (commands #:init-value '())
  87
  88   ;; Commands we can handle by being something's container
  89   (container-commands #:init-value '())
  90   (message-handler
  91    #:init-value
  92    (simple-dispatcher gameobj-actions)))
  93
  94
  95 ;;; gameobj message handlers
  96 ;;; ========================
  97
  98 ;; Kind of a useful utility, maybe?
  99 (define (simple-slot-getter slot)
 100   (lambda (actor message)
 101     (reply-message actor message
 102                    #:val (slot-ref actor slot))))
 103
 104 (define-mhandler (gameobj-get-commands actor message verb)
 105   (<-reply actor message #:commands (slot-ref actor 'commands)))
 106
 107 (define-mhandler (gameobj-get-container-commands actor message verb)
 108   (<-reply actor message #:commands (slot-ref actor 'container-commands)))
 109
 110 (define-mhandler (gameobj-add-occupant! actor message who)
 111   (hash-set! (slot-ref actor 'occupants)
 112              who #t))
 113
 114 (define-mhandler (gameobj-remove-occupant! actor message who)
 115   (hash-remove! (slot-ref actor 'occupants) who))
 116
 117 (define-mhandler (gameobj-get-occupants actor message)
 118   (define occupants
 119     (hash-map->list (lambda (key val) key)
 120                     (gameobj-occupants actor)))
 121
 122   (<-reply actor message
 123            #:occupants occupants))
 124
 125 ;; @@: Should it really be #:id ?  Maybe #:loc-id or #:loc?
 126 (define-mhandler (gameobj-set-loc! actor message loc)
 127   (define old-loc (gameobj-loc actor))
 128   (format #t "DEBUG: Location set to ~s for ~s\n"
 129           loc (actor-id-actor actor))
 130
 131   (set! (gameobj-loc actor) loc)
 132   ;; Change registation of where we currently are
 133   (if loc
 134       (<- actor loc 'add-occupant! #:who (actor-id actor)))
 135   (if old-loc
 136       (<- actor old-loc 'remove-occupant! #:who (actor-id actor))))
 137
 138 (define gameobj-get-name (simple-slot-getter 'name))
 139 (define gameobj-get-desc (simple-slot-getter 'desc))
 140
 141 (define (gameobj-simple-name-f gameobj)
 142   "Simplest version: return ourselves for our name."
 143   (gameobj-name gameobj))
 144
 145