;;; ==========
(define-module (mudsync gameobj)
+ #:use-module (mudsync command)
#:use-module (8sync systems actors)
#:use-module (8sync agenda)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
#:use-module (oop goops)
#:export (<gameobj>
gameobj-simple-name-f
;;; Actions supported by all gameobj
(define gameobj-actions
(build-actions
+ (init (wrap-apply gameobj-init))
(get-commands (wrap-apply gameobj-get-commands))
(get-container-commands (wrap-apply gameobj-get-container-commands))
- (get-children (wrap-apply gameobj-get-children))
- (add-occupant! (wrap-apply gameobj-add-child!))
- (remove-occupant! (wrap-apply gameobj-remove-child!))
- (set-loc! (wrap-apply gameobj-set-loc!))))
+ (get-occupants (wrap-apply gameobj-get-occupants))
+ (add-occupant! (wrap-apply gameobj-add-occupant!))
+ (remove-occupant! (wrap-apply gameobj-remove-occupant!))
+ (set-loc! (wrap-apply gameobj-set-loc!))
+ (get-name (wrap-apply gameobj-get-name))
+ (get-desc (wrap-apply gameobj-get-desc))
+ (goes-by (wrap-apply gameobj-goes-by))))
;;; *all* game components that talk to players should somehow
;;; derive from this class.
(define-class <gameobj> (<actor>)
;; location id
(loc #:init-value #f
- #:accessor gameobj-loc)
+ #:getter gameobj-loc)
;; Uses a hash table like a set (values ignored)
(occupants #:init-thunk make-hash-table
- #:accessor gameobj-occupants)
+ #:getter gameobj-occupants)
;; game master id
(gm #:init-keyword #:gm
#:getter gameobj-gm)
;; a name to be known by
(name #:init-keyword #:name
- #:accessor gameobj-name)
+ #:init-value #f)
+ (goes-by #:init-keyword #:goes-by
+ #:init-value #f)
(desc #:init-value ""
#:init-keyword #:desc)
#:getter gameobj-name-f
#:init-value (wrap gameobj-simple-name-f))
- ;; Name aliases
- (aliases #:init-keyword #:aliases
- #:init-value '())
-
;; Commands we can handle
(commands #:init-value '())
;;; gameobj message handlers
;;; ========================
+;; Kind of a useful utility, maybe?
+(define (simple-slot-getter slot)
+ (lambda (actor message)
+ (reply-message actor message
+ #:val (slot-ref actor slot))))
+
+
+;; @@: This could be kind of a messy way of doing gameobj-init
+;; stuff. If only we had generic methods :(
+(define-mhandler (gameobj-init actor message)
+ "Your most basic game object init procedure. Does nothing."
+ #f)
+
+(define (gameobj-goes-by gameobj)
+ "Find the name we go by. Defaults to #:name if nothing else provided."
+ (cond ((slot-ref gameobj 'goes-by) =>
+ identity)
+ ((slot-ref gameobj 'name) =>
+ (lambda (name)
+ (list name)))
+ (else '())))
+
+(define (val-or-run val-or-proc)
+ "Evaluate if a procedure, or just return otherwise"
+ (if (procedure? val-or-proc)
+ (val-or-proc)
+ val-or-proc))
+
+(define (filter-commands commands verb)
+ (filter
+ (lambda (cmd)
+ (equal? (command-verbs cmd)
+ verb))
+ commands))
+
(define-mhandler (gameobj-get-commands actor message verb)
- (<-reply actor message #:commands (slot-ref actor 'commands)))
+ (define filtered-commands
+ (filter-commands (val-or-run (slot-ref actor 'commands))
+ verb))
+ (<-reply actor message
+ #:commands filtered-commands
+ #:goes-by (gameobj-goes-by actor)))
(define-mhandler (gameobj-get-container-commands actor message verb)
- (<-reply actor message #:commands (slot-ref actor 'container-commands)))
+ (define filtered-commands
+ (filter-commands (val-or-run (slot-ref actor 'container-commands))
+ verb))
+ (<-reply actor message #:commands filtered-commands))
+
+(define-mhandler (gameobj-add-occupant! actor message who)
+ (hash-set! (slot-ref actor 'occupants)
+ who #t))
-(define-mhandler (gameobj-get-children actor message)
- (define children
+(define-mhandler (gameobj-remove-occupant! actor message who)
+ (hash-remove! (slot-ref actor 'occupants) who))
+
+(define-mhandler (gameobj-get-occupants actor message)
+ (define occupants
(hash-map->list (lambda (key val) key)
- (gameobj-children actor)))
+ (gameobj-occupants actor)))
(<-reply actor message
- #:children children))
+ #:occupants occupants))
+
+;; @@: Should it really be #:id ? Maybe #:loc-id or #:loc?
+(define-mhandler (gameobj-set-loc! actor message loc)
+ (define old-loc (gameobj-loc actor))
+ (format #t "DEBUG: Location set to ~s for ~s\n"
+ loc (actor-id-actor actor))
-(define-mhandler (gameobj-set-loc! player message id)
- (format #t "DEBUG: Location set to ~s for player ~s\n"
- id (actor-id-actor player))
- (set! (gameobj-loc player) id))
+ (slot-set! actor 'loc loc)
+ ;; Change registation of where we currently are
+ (if loc
+ (<-wait actor loc 'add-occupant! #:who (actor-id actor)))
+ (if old-loc
+ (<-wait actor old-loc 'remove-occupant! #:who (actor-id actor))))
+(define gameobj-get-name (simple-slot-getter 'name))
+(define gameobj-get-desc (simple-slot-getter 'desc))
(define (gameobj-simple-name-f gameobj)
"Simplest version: return ourselves for our name."
(gameobj-name gameobj))
-
-