;;; Mudsync --- Live hackable MUD ;;; Copyright © 2016 Christopher Allan Webber ;;; ;;; This file is part of Mudsync. ;;; ;;; Mudsync is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; Mudsync is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; 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 control) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:export ( player-self-commands)) ;;; Players ;;; ======= (define player-actions (build-actions (init (wrap-apply player-init)) (handle-input (wrap-apply player-handle-input)) (tell (wrap-apply player-tell)) (disconnect-self-destruct (wrap-apply player-disconnect-self-destruct)) (cmd-inventory (wrap-apply player-cmd-inventory)))) (define player-actions* (append player-actions gameobj-actions)) (define player-dispatcher (simple-dispatcher player-actions*)) (define player-self-commands (list (empty-command "inventory" 'cmd-inventory) ;; aliases... ;; @@: Should use an "alias" system for common aliases? (empty-command "inv" 'cmd-inventory) (empty-command "i" 'cmd-inventory))) (define-class () (username #:init-keyword #:username #:getter player-username) (self-commands #:init-value player-self-commands) (message-handler #:init-value (wrap-apply player-dispatcher))) ;;; player message handlers (define-mhandler (player-init player message) ;; Look around the room we're in (<- player (gameobj-loc player) 'look-room)) (define-mhandler (player-handle-input player message input) (define split-input (split-verb-and-rest input)) (define input-verb (car split-input)) (define input-rest (cdr split-input)) (define command-candidates (player-gather-command-handlers player input-verb)) (define winner (find-command-winner command-candidates input-rest)) (match winner ((cmd-action winner-id message-args) (apply send-message player winner-id cmd-action message-args)) (#f (<- player (gameobj-gm player) 'write-home #:text "Huh?\n")))) (define-mhandler (player-tell player message text) (<- player (gameobj-gm player) 'write-home #:text text)) (define-mhandler (player-disconnect-self-destruct player message) "Action routine for being told to disconnect and self destruct." (define loc (gameobj-loc player)) (when loc (<- player loc 'tell-room #:exclude (actor-id player) #:text (format #f "~a disappears in a puff of entropy!\n" (slot-ref player 'name)))) (gameobj-self-destruct player)) (define-mhandler (player-cmd-inventory player message) "Display the inventory for the player" (define inv-names (map (lambda (inv-item) (message-ref (<-wait player inv-item 'get-name) 'val)) (gameobj-occupants player))) (define text-to-show (if (eq? inv-names '()) "You aren't carrying anything.\n" (apply string-append "You are carrying:\n" (map (lambda (item-name) (string-append " * " item-name "\n")) inv-names)))) (<- player (actor-id player) 'tell #:text text-to-show)) ;;; Command handling ;;; ================ ;; @@: Hard to know whether this should be in player.scm or here... ;; @@: This could be more efficient as a stream...!? (define (player-gather-command-handlers player verb) (define player-loc (let ((result (gameobj-loc player))) (if result result (throw 'player-has-no-location "Player ~a has no location! How'd that happen?\n" #:player-id (actor-id player))))) ;; Ask the room for its commands (define room-commands ;; TODO: Map room id and sort (message-ref (<-wait player player-loc 'get-container-commands #:verb verb) 'commands)) ;; All the co-occupants of the room (not including ourself) (define co-occupants (remove (lambda (x) (equal? x (actor-id player))) (message-ref (<-wait player player-loc 'get-occupants) 'occupants))) ;; @@: There's a race condition here if someone leaves the room ;; during this, heh... ;; I'm not sure it can be solved, but "lag" on the race can be ;; reduced maybe? ;; Get all the co-occupants' commands (define co-occupant-commands (fold (lambda (co-occupant prev) (let* ((result (<-wait player co-occupant 'get-commands #:verb verb)) (commands (message-ref result 'commands)) (goes-by (message-ref result 'goes-by))) (append (map (lambda (command) (list command goes-by co-occupant)) commands) prev))) '() co-occupants)) ;; Append our own command handlers (define our-commands (filter (lambda (cmd) (equal? (command-verbs cmd) verb)) (val-or-run (slot-ref player 'self-commands)))) ;; Append our inventory's relevant command handlers (define inv-items (gameobj-occupants player)) (define inv-item-commands (fold (lambda (inv-item prev) (let* ((result (<-wait player inv-item 'get-contained-commands #:verb verb)) (commands (message-ref result 'commands)) (goes-by (message-ref result 'goes-by))) (append (map (lambda (command) (list command goes-by inv-item)) commands) prev))) '() inv-items)) ;; Now return a big ol sorted list of ((actor-id . command)) (append (sort-commands-append-actor room-commands player-loc '()) ; room doesn't go by anything (sort-commands-multi-actors co-occupant-commands) (sort-commands-append-actor our-commands (actor-id player) '()) ; nor does player (sort-commands-multi-actors inv-item-commands))) (define (sort-commands-append-actor commands actor-id goes-by) (sort-commands-multi-actors (map (lambda (command) (list command goes-by actor-id)) commands))) (define (sort-commands-multi-actors actors-and-commands) (sort actors-and-commands (lambda (x y) (> (command-priority (car x)) (command-priority (car y)))))) (define (find-command-winner sorted-candidates line) "Find a command winner from a sorted list of candidates" ;; A cache of results from matchers we've already seen ;; TODO: fill in this cache. This is a *critical* optimization! (define matcher-cache '()) (call/ec (lambda (return) (for-each (match-lambda ((command actor-goes-by actor-id) (let* ((matcher (command-matcher command)) (matched (matcher line))) (if (and matched ;; Great, it matched, but does it also pass ;; should-handle? (apply (command-should-handle command) actor-goes-by matched)) ; matched is kwargs if truthy (return (list (command-action command) actor-id matched)) #f)))) sorted-candidates) #f)))