;;; 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) #: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)))) (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 (room-player-looks-around room player-id) "Handle looking around the room" (define room-text (format #f "**~a**\n~a\n" (slot-ref room 'name) (slot-ref room 'desc))) (<- room player-id 'tell #:text room-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))))