(special-dir #:init-thunk make-hash-table
#:getter gm-special-dir)
- ;; Room directory. Room symbols to locations.
- (room-dir #:init-thunk make-hash-table
- #:getter gm-room-dir)
-
;; A mapping of client ids to in-game actors
;; and a reverse ;p
(client-dir #:init-thunk make-hash-table
(make-action-dispatch
(init-world (wrap-apply gm-init-world))
(client-input (wrap-apply gm-handle-client-input))
- (lookup-room (wrap-apply gm-lookup-room))
+ (lookup-special (wrap-apply gm-lookup-special))
(new-client (wrap-apply gm-new-client))
(write-home (wrap-apply gm-write-home)))))
;; TODO
;; Init basic rooms / structure
- (gm-init-rooms gm (message-ref message 'room-spec))
+ (gm-init-game-spec gm (message-ref message 'game-spec))
;; Restore database-based actors
;; TODO
;; Set up the network
(gm-setup-network gm))
-(define (gm-init-rooms gm rooms-spec)
- "Initialize the prebuilt rooms"
- (define rooms
+(define (gm-init-game-spec gm game-spec)
+ "Initialize the prebuilt special objects"
+ (define set-locs '())
+ (define specials
(map
(match-lambda
- ((room-symbol room-class
- room-args ...)
- ;; initialize the room
- (let ((room
- (apply create-actor* gm room-class "room"
+ ((symbol class loc args ...)
+ ;; initialize the special object
+ (let ((special-obj
+ (apply create-actor* gm class
+ ;; set cookie to be the object's symbol
+ (symbol->string symbol)
#:gm (actor-id gm)
- room-args)))
- ;; register the room
- (hash-set! (gm-room-dir gm) room-symbol room)
+ args)))
+ ;; register the object
+ (hash-set! (gm-special-dir gm) symbol special-obj)
+ ;; Give ourselves an instruction to set the location
+ (set! set-locs (cons (cons special-obj loc) set-locs))
;; pass it back to the map
- room)))
- rooms-spec))
+ special-obj)))
+ game-spec))
- ;; now wire up all the exits
+ ;; Set all initial locations
+ (for-each
+ (match-lambda
+ ((special-obj . loc)
+ (if loc
+ (<-wait gm special-obj 'set-loc!
+ #:loc (hash-ref (gm-special-dir gm) loc)))))
+ set-locs)
+
+ ;; now init all the objects
(for-each
- (lambda (room)
- (format #t "Wiring up ~s...\n" (address->string room))
- (<-wait gm room 'wire-exits!))
- rooms))
+ (lambda (special-obj)
+ (format #t "Initializing ~s...\n" (address->string special-obj))
+ (<-wait gm special-obj 'init))
+ specials))
(define (gm-setup-network gm)
(<- actor player 'handle-input
#:input input))
-(define-mhandler (gm-lookup-room actor message symbol)
+(define-mhandler (gm-lookup-special actor message symbol)
(<-reply actor message
- #:room-id (hash-ref (slot-ref actor 'room-dir) symbol)))
+ #:room-id (hash-ref (slot-ref actor 'special-dir) symbol)))
(define-mhandler (gm-write-home actor message text)
(define client-id (hash-ref (gm-reverse-client-dir actor)
(let* ((guest-name (string-append "Guest-"
(number->string count)))
(room-id
- (hash-ref (gm-room-dir gm) default-room))
+ (hash-ref (gm-special-dir gm) default-room))
;; create and register the player
(player
(create-actor* gm (@@ (mudsync player) <player>) "player"
;;; Actions supported by all gameobj
(define gameobj-actions
(build-actions
+ (init (wrap-apply gameobj-init))
(get-commands (wrap-apply gameobj-get-commands))
(get-container-commands (wrap-apply gameobj-get-container-commands))
(get-occupants (wrap-apply gameobj-get-occupants))
(remove-occupant! (wrap-apply gameobj-remove-occupant!))
(set-loc! (wrap-apply gameobj-set-loc!))
(get-name (wrap-apply gameobj-get-name))
- (get-desc (wrap-apply gameobj-get-desc))
- ))
+ (get-desc (wrap-apply gameobj-get-desc))))
;;; *all* game components that talk to players should somehow
;;; derive from this class.
(reply-message actor message
#:val (slot-ref actor slot))))
+
+;; @@: This could be kind of a messy way of doing gameobj-init
+;; stuff. If only we had generic methods :(
+(define-mhandler (gameobj-init actor message)
+ "Your most basic game object init procedure. Does nothing."
+ #f)
+
(define (val-or-run val-or-proc)
"Evaluate if a procedure, or just return otherwise"
(if (procedure? val-or-proc)
(use-modules (mudsync)
- (oop goops))
+ (8sync systems actors)
+ (8sync agenda)
+ (oop goops)
+ (ice-9 format))
;; MEDIAGOBLIN HQ
;; .-------------.--.--------.-----------.-----------.
;; | Dootacenter | + codea | ballroom | | <- here be
;; | ==== ===== + | plex | | | gandaros
;; | ^-- chris's | ;--------'----+--,---' |
-;; | emacs ai == |@ | schendje's | |
+;; | emacs ai == |@ | [schendje's] | |
;; | server ==== | | graphic design | TOP SECRET |
;; '-------------' + sweatshop + LABORATORY |
;; .--------+-----. | | |
;; | cooridoor + _|_|_|_|_|_|_|_|_|
;; '--------------'
+\f
+;;; Game objects
+;;; ============
+
+;;; The fridge
+;;; ----------
+
+(define-class <fridge> (<gameobj>)
+ #:name "fridge"
+ #:desc "The refrigerator is humming. To you? To itself?
+Only the universe knows.")
+
+
+;;; The typewriter
+;;; --------------
+
+(define typewriter-commands
+ (list
+ (direct-command "type" 'cmd-type-gibberish)
+ (indir-command "type" 'cmd-type-something)
+ (direct-greedy-command "type" 'cmd-type-anything)))
+
+(define typewriter-actions
+ (build-actions
+ (cmd-type-gibberish (wrap-apply typewriter-cmd-type-gibberish))
+ (cmd-type-something (wrap-apply typewriter-cmd-type-something))
+ (cmd-type-anything (wrap-apply typewriter-cmd-type-anything))))
+
+(define typewriter-dispatch
+ (simple-dispatcher (append typewriter-actions
+ gameobj-actions)))
+
+(define-class <typewriter> (<gameobj>)
+ (name #:init-value "fancy typewriter")
+ (goes-by #:init-value '("typewriter"
+ "fancy typewriter"))
+ (commands #:init-value typewriter-commands)
+ (message-handler
+ #:init-value
+ (wrap-apply typewriter-dispatch)))
+
+(define-mhandler (typewriter-cmd-type-gibberish actor message)
+ (<- actor (message-from message) 'tell
+ #:text "*tikka takka!* *tikka takka!*
+You type some gibberish on the typewriter.\n"))
+
+(define (type-thing actor message type-text)
+ (<- actor (message-from message) 'tell
+ #:text
+ (format #f "You type out a note.\nThe note says: ~s"
+ type-text)))
+
+(define-mhandler (typewriter-cmd-type-something
+ actor message direct-obj indir-obj)
+ (type-thing actor message direct-obj))
+
+(define-mhandler (typewriter-cmd-type-anything
+ actor message direct-obj rest)
+ (type-thing actor message rest))
+
+
+\f
+;;; Rooms and stuff
+;;; ===============
+
(define wooden-unlocked-door "A wooden door. It appears to be unlocked.")
(define metal-stiff-door "A stiff metal door.
It looks like with a hard shove, you could step through it.")
-(define goblin-rooms
- `((server-room
- ,<room>
- #:name "The dootacenter"
- #:desc
- "You've entered the server room. The isles alternate between hot and cold
-here. It's not not very comfortable in here, and the combined noise of hundreds,
-maybe thousands, of fans and various computing mechanisms creates an unpleasant
-din. Who'd choose to work in such a place?
+;; list of lists
+(define-syntax-rule (lol (list-contents ...) ...)
+ (list (list list-contents ...) ...))
+(define goblin-rooms
+ (lol
+ ('room:server-room
+ <room> #f
+ #:name "The dootacenter"
+ #:desc
+ "You've entered the server room. The isles alternate between hot and
+cold here. It's not not very comfortable in here, and the combined
+noise of hundreds, maybe thousands, of fans and various computing
+mechanisms creates an unpleasant din. Who'd choose to work in such a
+place?
Still, you have to admit that all the machines look pretty nice."
- ;; TODO: Allow walking around further in the dootacenter.
- #:exits
- ,(list (make <exit>
- #:name "east"
- #:to-symbol 'north-hallway
- #:desc wooden-unlocked-door))) ; eventually make this locked so you have
- ; to kick it down, joeyh style!
- (north-hallway
- ,<room>
- #:name "North hallway"
- #:desc
- "You're at the north end of the hallway. An open window gives a nice breeze,
-and the curtains dance merrily in the wind. Outside appears to be a pleasant
-looking lawn.
-
-The hallway continues to the south."
- #:exits
- ,(list (make <exit>
- #:name "west"
- #:to-symbol 'server-room
- #:desc wooden-unlocked-door)
- (make <exit>
- #:name "east"
- #:to-symbol 'code-a-plex
- #:desc metal-stiff-door)
- ;; (make <exit>
- ;; #:name "south"
- ;; #:to-symbol 'center-hallway)
- ))
-
- (code-a-plex
- ,<room>
- #:name "Joar's Code-A-Plex"
- #:desc
- "You've entered Joar's Code-A-Plex. What that means is anyone's guess.
+ ;; TODO: Allow walking around further in the dootacenter.
+ #:exits
+ (list (make <exit>
+ #:name "east"
+ #:to-symbol 'room:north-hallway
+ #:desc wooden-unlocked-door))) ; eventually make this locked so you have
+ ; to kick it down, joeyh style!
+ ('room:north-hallway
+ <room> #f
+ #:name "North hallway"
+ #:desc
+ "You're at the north end of the hallway. An open window gives a nice
+ breeze, and the curtains dance merrily in the wind. Outside appears
+to be a pleasant looking lawn.
+The hallway continues to the south. There are some doors to the east
+and the west."
+ #:exits
+ (list (make <exit>
+ #:name "west"
+ #:to-symbol 'room:server-room
+ #:desc wooden-unlocked-door)
+ (make <exit>
+ #:name "east"
+ #:to-symbol 'room:code-a-plex
+ #:desc metal-stiff-door)
+ ;; (make <exit>
+ ;; #:name "south"
+ ;; #:to-symbol 'center-hallway)
+ ))
+
+ ('room:code-a-plex
+ <room> #f
+ #:name "Joar's Code-A-Plex"
+ #:desc
+ "You've entered Joar's Code-A-Plex. What that means is anyone's guess.
Joar apparently hangs out in here sometimes, but you don't see him here right
now.
-
There's a row of computer desks. Most of them have computers already on them,
But one looks invitingly empty."
- #:exits
- ,(list (make <exit>
- #:name "west"
- #:to-symbol 'north-hallway
- #:desc metal-stiff-door)))))
+ #:exits
+ (list (make <exit>
+ #:name "west"
+ #:to-symbol 'room:north-hallway
+ #:desc metal-stiff-door)))
+
+ ('thing:typewriter
+ <typewriter> 'room:code-a-plex)
+
+ ('thing:fridge
+ <fridge> 'room:code-a-plex)))
+
+;; (room:hallway-intersection
+;; ,<room>
+;; #:name "Hallway intersection"
+;; #:desc "You're at the hallway intersection. To the east is a door
+;; labeled \"get to work!\". The hallway continues to the west and to the
+;; south."
+;; #:exits
+;; ,(list (make <exit>
+;; #:name "east"
+;; #:to-symbol 'room:))
+;; )
(define (goblin-demo . args)
- (run-demo "/tmp/goblin-game.db" goblin-rooms 'north-hallway))
+ (run-demo "/tmp/goblin-game.db" goblin-rooms 'room:north-hallway))
projects / mudsync.git / commitdiff