X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;f=mudsync%2Fplayer.scm;h=feb14f80a2375e9b67a4d6b4728ab558226c0c12;hb=a841e7c04e355dd1d25c0c0a5a254bbd185cdc38;hp=340fa3d7c16a0cfec98a630382ff38fcea20b4fb;hpb=c3e788ae7726f7e52a62ffeb30254bfa0f0da7cb;p=mudsync.git
diff --git a/mudsync/player.scm b/mudsync/player.scm
index 340fa3d..feb14f8 100644
--- a/mudsync/player.scm
+++ b/mudsync/player.scm
@@ -17,17 +17,30 @@
;;; along with Mudsync. If not, see .
(define-module (mudsync player)
+ #:use-module (mudsync command)
#:use-module (mudsync gameobj)
#:use-module (mudsync game-master)
+ #:use-module (mudsync parser)
#:use-module (8sync systems actors)
#:use-module (8sync agenda)
#:use-module (ice-9 format)
#:use-module (oop goops)
- #:export ())
+ #:use-module (srfi srfi-1)
+ #:export (
+ player-self-commands))
;;; 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)
@@ -41,23 +54,27 @@
(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))
(define-mhandler (player-handle-input player message input)
+ (define split-input (split-verb-and-rest input))
+ (define input-verb (pk 'input-verb (car split-input)))
+ (define input-rest (pk 'input-rest (cdr split-input)))
+
+ (define command-candidates
+ (pk 'candidates
+ (player-gather-command-handlers player input-verb)))
+
+ (define winner
+ (pk 'winner (find-command-winner command-candidates input-rest)))
+
(<- player (gameobj-gm player) 'write-home
#:text
(format #f "<~a>: ~s\n"
@@ -80,3 +97,6 @@
(format #f "**~a**\n~a\n" room-name room-desc))
(<- player (gameobj-gm player) 'write-home #:text message-text))
+
+
+