(import scheme (chicken base) (chicken string) (chicken io) srfi-1 srfi-13 matchable actors) ;; (enable-trace) (disable-trace) (restart) (define (parse-input string) (map string->symbol (string-tokenize string))) (define ((player-beh loc) self . message) (match message (('init) (send-message self 'query') 'sleep) (('print string) (print string) (send-message self 'query) 'sleep) (('query) (print* "==> ") (let ((new-message (parse-input (read-line)))) (apply send-message (cons self new-message))) 'sleep) ((or ('quit) ('q)) (print "Bye!") 'sleep) ;; Internal messages (('move-to new-loc) (send-message self 'look) (player-beh new-loc)) (else (apply send-message (cons loc (cons player message))) 'sleep))) (define ((room-beh name description . exits) self . message) (match message (('add-exit exit) (set! exits (cons exit exits)) 'sleep) ((or (player 'look) (player 'l) (player 'x)) (let* ((room-desc (conc name "\n" description)) (accumulator (make-actor (accumulate-descrs player exits (list room-desc))))) (send-message accumulator 'init)) 'sleep) ((player x ...) (let ((exit-tryer (make-actor (try-exits player exits x)))) (send-message exit-tryer 'init)) 'sleep) (else ;ignore unknown messages 'sleep))) (define ((accumulate-descrs cust objects descrs) self . message) (match message (('init) (if (null? objects) (begin (send-message cust 'print (string-intersperse (reverse descrs) "\n")) 'done) (begin (send-message (car objects) self 'look) (accumulate-descrs cust (cdr objects) descrs)))) (('print descr) (let ((new-descrs (cons descr descrs))) (if (null? objects) (begin (send-message cust 'print (string-intersperse (reverse new-descrs) "\n")) 'done) (begin (send-message (car objects) self 'look) (accumulate-descrs cust (cdr objects) new-descrs))))))) (define ((try-exits player exits msg-to-send) self . message) (match message ((or ('init) ('no-match)) (if (null? exits) (begin (send-message player 'print "I don't know how to do that.") 'done) (begin (apply send-message (cons (car exits) (cons self msg-to-send))) (try-exits player (cdr exits) msg-to-send)))) (('move-to dest) (apply send-message (cons player message)) 'done))) (define ((exit-beh names description dest) self . message) (if (not (= (length message) 2)) 'sleep (let ((cust (car message)) (arg (cadr message))) (cond ((eq? arg 'look) (send-message cust 'print description)) ((memq arg names) (send-message cust 'move-to dest)) (else (send-message cust 'no-match))) 'sleep))) (define (make-room title desc) (make-actor (room-beh title desc))) (define (add-exit from to names desc) (send-message from 'add-exit (make-actor (exit-beh names desc to)))) (define shore (make-room "Rocky shore at night" (conc "You are standing on a rocky shore. Menacing waves crash periodically\n" "against large bolders from all directions, occasionally spraying you\n" "with salty ocean mist."))) (define ocean (make-room "Cold ocean" "You are now in the water.")) (define underwater (make-room "Underwater" "You are now swimming near the ocean floor.")) (add-exit shore ocean '(west w) "A path leads west through the boulders down to the waves.") (add-exit ocean shore '(east e) "The shore is to the east.") (add-exit ocean underwater '(down d) "You can swim down here.") (add-exit underwater ocean '(up u) "You can swim up from here.") (define player (make-actor-with-address 'player (player-beh shore))) (define (start) (send-message player 'init) (run))