;;; 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 room) #:use-module (mudsync command) #:use-module (mudsync gameobj) #:use-module (8sync systems actors) #:use-module (8sync agenda) #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (ice-9 control) #:export ( room-actions room-actions* )) ;;; Exits ;;; ===== (define-class () ;; Used for wiring (to-symbol #:init-keyword #:to-symbol) ;; The actual address we use (to-address #:init-keyword #:address) ;; Name of the room (@@: Should this be names?) (name #:getter exit-name #:init-keyword #:name) (desc #:init-keyword #:desc #:init-value #f) ;; *Note*: These two methods have an extra layer of indirection, but ;; it's for a good reason. (visible-check #:init-value (const #t) #:init-keyword #:visible-check) ;; By default all exits can be traversed (traverse-check #:init-value (const #t) #:init-keyword #:traverse-check)) (define* (exit-can-traverse? exit actor #:optional (target-actor (actor-id actor))) ((slot-ref exit 'traverse-check) exit actor target-actor)) (define* (exit-is-visible? exit actor #:optional (target-actor (actor-id actor))) ((slot-ref exit 'traverse-check) exit actor target-actor)) ;;; Rooms ;;; ===== (define %room-contain-commands (list (loose-direct-command "look" 'cmd-look-at) (empty-command "look" 'cmd-look-room) (empty-command "go" 'cmd-go-where) (loose-direct-command "go" 'cmd-go))) (define room-actions (build-actions ;; desc == description (init (wrap-apply room-init)) (wire-exits! (wrap-apply room-wire-exits!)) (cmd-go (wrap-apply room-cmd-go)) (cmd-go-where (wrap-apply room-cmd-go-where)) (look-room (wrap-apply room-look-room)) ;; in this case the command is the same version as the normal ;; look-room version (cmd-look-room (wrap-apply room-look-room)) (cmd-look-at (wrap-apply room-look-at)))) (define room-actions* (append room-actions gameobj-actions)) (define room-action-dispatch (simple-dispatcher room-actions*)) ;; TODO: Subclass from container? (define-class () ;; A list of (exits #:init-value '() #:init-keyword #:exits #:getter room-exits) (container-commands #:init-value (wrap %room-contain-commands)) (message-handler #:allocation #:each-subclass ;; @@: Can remove this indirection once things settle #:init-value (wrap-apply room-action-dispatch))) (define (room-init room message) (room-wire-exits! room)) (define (room-wire-exits! room) "Actually hook up the rooms' exit addresses to the rooms they claim to point to." (for-each (lambda (exit) (define new-exit (message-ref (<-wait room (gameobj-gm room) 'lookup-special #:symbol (slot-ref exit 'to-symbol)) 'room-id)) (slot-set! exit 'to-address new-exit)) (room-exits room))) (define-mhandler (room-cmd-go room message direct-obj) (define exit (find (lambda (exit) (equal? (exit-name exit) direct-obj)) (room-exits room))) (cond (exit ;; Set the player's new location (<-wait room (message-from message) 'set-loc! #:loc (slot-ref exit 'to-address)) ;; Have the new room update the player to the new location (<- room (slot-ref exit 'to-address) 'look-room #:to-id (message-from message))) (else (<- room (message-from message) 'tell #:text "You don't see any way to go there.\n")))) (define-mhandler (room-cmd-go-where room message) (<- room (message-from message) 'tell #:text "Go where?\n")) ;;; look commands (define (list-words-as-string words) "A little utility for listing a bunch of words in an English-style list" ;; TODO: This could be made faster by traversing the O(n) ;; list once, not twice (let ((word-length (length words))) (cond ((eqv? word-length 0) "") ((eqv? word-length 1) (car words)) (else ;; TODO: and this is NOT efficient (string-append (string-join (drop-right words 1) ", ") " and " (last words)))))) (define (room-player-looks-around room player-id) "Handle looking around the room" ;; Get the room text (define room-text (format #f "**~a**\n~a\n" (slot-ref room 'name) (slot-ref room 'desc))) ;; Get a list of other things the player would see in the room (define occupant-names-all (map (lambda (occupant) (message-ref (<-wait room occupant 'visible-name #:whos-looking player-id) 'text)) (remove (lambda (x) (equal? x player-id)) (hash-map->list (lambda (x _) x) (slot-ref room 'occupants))))) ;; Strip out the #f responses (these aren't listed because they lack a name ;; or they aren't "obviously visible" to the player) (define occupant-names-filtered (filter identity occupant-names-all)) (define occupant-names-string (if (eq? occupant-names-filtered '()) #f (format #f "You see here: ~a.\n" (list-words-as-string occupant-names-filtered)))) (define final-text (if occupant-names-string (string-append room-text occupant-names-string) room-text)) (<- room player-id 'tell #:text final-text)) (define-mhandler (room-look-room room message) "Command: Player asks to look around the room" (room-player-looks-around room ;; Either send it to the #:to-id of the message, or to the ;; sender of the message (message-ref message 'to-id (message-from message)))) (define (room-find-thing-called room called-this) "Find something called CALLED-THIS in the room, if any." (call/ec (lambda (return) (for-each (lambda (occupant) (define goes-by (message-ref (<-wait room occupant 'goes-by) 'goes-by #f)) (display "here!\n") (if (member called-this goes-by) (return occupant))) (hash-map->list (lambda (key val) key) (slot-ref room 'occupants))) #f))) (define %formless-desc "You don't see anything special about it.") (define-mhandler (room-look-at room message direct-obj) "Look at a specific object in the room." (define matching-object (room-find-thing-called room direct-obj)) (cond (matching-object (let ((obj-desc (message-ref (<-wait room matching-object 'get-desc) 'val))) (if obj-desc (<- room (message-from message) 'tell #:text (string-append obj-desc "\n")) (<- room (message-from message) 'tell #:text (string-append %formless-desc "\n"))))) (else (<- room (message-from message) 'tell #:text "You don't see that here, so you can't look at it.\n"))))