From 060a48dce227e8c53e007941cc673b494ca36024 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Tue, 3 May 2016 13:50:26 -0500 Subject: [PATCH 1/1] big refactor to players, rooms, gameobj stuff --- mudsync/gameobj.scm | 53 +++++++++++++++++++++++++++++++++++++++++++-- mudsync/player.scm | 20 +++++++++-------- mudsync/room.scm | 40 ++++++++++++++++------------------ 3 files changed, 81 insertions(+), 32 deletions(-) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 2c39706..6a5e369 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -29,8 +29,23 @@ gameobj-loc gameobj-gm gameobj-name - gameobj-name-f)) + gameobj-name-f + gameobj-actions)) + +;;; Gameobj +;;; ======= + + +;;; Actions supported by all gameobj +(define gameobj-actions + (build-actions + (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!)))) ;;; *all* game components that talk to players should somehow ;;; derive from this class. @@ -40,6 +55,11 @@ ;; location id (loc #:init-value #f #:accessor gameobj-loc) + + ;; Uses a hash table like a set (values ignored) + (occupants #:init-thunk make-hash-table + #:accessor gameobj-occupants) + ;; game master id (gm #:init-keyword #:gm #:getter gameobj-gm) @@ -47,6 +67,9 @@ (name #:init-keyword #:name #:accessor gameobj-name) + (desc #:init-value "" + #:init-keyword #:desc) + ;; how to print our name (name-f #:init-keyword #:name-f #:getter gameobj-name-f @@ -60,7 +83,33 @@ (commands #:init-value '()) ;; Commands we can handle by being something's container - (contain-commands #:init-value '())) + (container-commands #:init-value '()) + (message-handler + #:init-value + (simple-dispatcher gameobj-actions))) + + +;;; gameobj message handlers +;;; ======================== + +(define-mhandler (gameobj-get-commands actor message verb) + (<-reply actor message #:commands (slot-ref actor 'commands))) + +(define-mhandler (gameobj-get-container-commands actor message verb) + (<-reply actor message #:commands (slot-ref actor 'container-commands))) + +(define-mhandler (gameobj-get-children actor message) + (define children + (hash-map->list (lambda (key val) key) + (gameobj-children actor))) + + (<-reply actor message + #:children children)) + +(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)) (define (gameobj-simple-name-f gameobj) diff --git a/mudsync/player.scm b/mudsync/player.scm index fece716..feb14f8 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -32,6 +32,15 @@ ;;; Players ;;; ======= +(define player-actions + (build-actions + (init (wrap-apply player-init!)) + (handle-input (wrap-apply player-handle-input)))) + +(define player-actions* + (append player-actions + gameobj-actions)) + (define-class () (username #:init-keyword #:username #:accessor player-username) @@ -45,17 +54,10 @@ (message-handler #:init-value ;; @@: We're gonna need action inheritance real awful soon, huh? - (make-action-dispatch - (set-loc! (wrap-apply player-set-loc!)) - (init (wrap-apply player-init!)) - (handle-input (wrap-apply player-handle-input))))) + (simple-dispatcher player-actions*))) -;;; player message handlers -(define-mhandler (player-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)) +;;; player message handlers (define-mhandler (player-init! player message) (player-look-around player)) diff --git a/mudsync/room.scm b/mudsync/room.scm index b6164da..09ebdcb 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -22,6 +22,9 @@ #:use-module (8sync agenda) #:use-module (oop goops) #:export ( + room-actions + room-actions* + )) ;;; Rooms @@ -80,38 +83,33 @@ (full-command "go" cmatch-just-verb always 'go-where) (full-command "go" cmatch-direct-obj always 'go-exit))) + ;; TODO: Subclass from container? (define-class () - (desc #:init-value "" - #:init-keyword #:desc) - ;; TODO: Switch this to be loc based - ;; Uses a hash table like a set (values ignored) - (occupants #:init-thunk make-hash-table) ;; A list of (exits #:init-value '() #:getter room-exits) - ;; @@: Maybe eventually will inherit from some more general - ;; game object class (contain-commands #:init-value %room-contain-commands) (message-handler #:allocation #:each-subclass - #:init-value - (make-action-dispatch - ;; desc == description - (get-desc - (simple-slot-getter 'desc)) - (get-name - (simple-slot-getter 'name)) - ((register-occupant! actor message who) - "Register an actor as being a occupant of this room" - (hash-set! (slot-ref actor 'occupants) who #t)) - ((evict-occupant! actor message who) - "De-register an occupant removed from the room" - (hash-remove! (slot-ref actor 'occupants) who)) - (wire-exits! (wrap-apply room-wire-exits!))))) + ;; @@: Can remove this indirection once things settle + #:init-value (wrap-apply room-action-dispatch))) + + +(define room-actions + (build-actions + ;; desc == description + (wire-exits! (wrap-apply room-wire-exits!)))) + +(define room-actions* + (append room-actions gameobj-actions)) + +(define room-action-dispatch + (simple-dispatcher room-actions*)) + (define (room-wire-exits! room message) "Actually hook up the rooms' exit addresses to the rooms they -- 2.31.1