island.scm

   1 (import scheme
   2         (chicken base)
   3         (chicken string)
   4         (chicken io)
   5         srfi-1 srfi-13
   6         matchable
   7         actors)
   8
   9 ;; (enable-trace)
  10 (disable-trace)
  11 (restart)
  12
  13 (define (parse-input string)
  14   (map string->symbol (string-tokenize string)))
  15
  16 (define ((player-beh loc) self . message)
  17   (match message
  18     (('init)
  19      (send-message self 'query')
  20      'sleep)
  21     (('print string)
  22      (print string)
  23      (send-message self 'query)
  24      'sleep)
  25     (('query)
  26      (print* "==> ")
  27      (let ((new-message (parse-input (read-line))))
  28        (apply send-message (cons self new-message)))
  29      'sleep)
  30     ((or ('quit) ('q))
  31      (print "Bye!")
  32      'sleep)
  33     ;; Internal messages
  34     (('move-to new-loc)
  35      (send-message self 'look)
  36      (player-beh new-loc))
  37     (else
  38      (apply send-message (cons loc (cons player message)))
  39      'sleep)))
  40
  41 (define ((room-beh name description . exits) self . message)
  42   (match message
  43     (('add-exit exit)
  44      (set! exits (cons exit exits))
  45      'sleep)
  46     ((or (player 'look) (player 'l) (player 'x))
  47      (let* ((room-desc (conc name "\n" description))
  48             (accumulator (make-actor (accumulate-descrs player
  49                                                         exits
  50                                                         (list room-desc)))))
  51        (send-message accumulator 'init))
  52      'sleep)
  53     ((player x ...)
  54      (let ((exit-tryer (make-actor
  55                         (try-exits player exits x))))
  56        (send-message exit-tryer 'init))
  57      'sleep)
  58     (else ;ignore unknown messages
  59      'sleep)))
  60
  61 (define ((accumulate-descrs cust objects descrs) self . message)
  62   (match message
  63     (('init)
  64      (if (null? objects)
  65          (begin
  66            (send-message cust 'print (string-intersperse (reverse descrs) "\n"))
  67            'done)
  68          (begin
  69            (send-message (car objects) self 'look)
  70            (accumulate-descrs cust (cdr objects) descrs))))
  71     (('print descr)
  72      (let ((new-descrs (cons descr descrs)))
  73        (if (null? objects)
  74            (begin
  75              (send-message cust 'print (string-intersperse (reverse new-descrs) "\n"))
  76              'done)
  77            (begin
  78              (send-message (car objects) self 'look)
  79              (accumulate-descrs cust (cdr objects) new-descrs)))))))
  80
  81 (define ((try-exits player exits msg-to-send) self . message)
  82   (match message
  83     ((or ('init) ('no-match))
  84      (if (null? exits)
  85          (begin
  86            (send-message player 'print "I don't know how to do that.")
  87            'done)
  88          (begin
  89            (apply send-message (cons (car exits) (cons self msg-to-send)))
  90            (try-exits player (cdr exits) msg-to-send))))
  91     (('move-to dest)
  92      (apply send-message (cons player message))
  93      'done)))
  94
  95 (define ((exit-beh names description dest) self . message)
  96   (if (not (= (length message) 2))
  97       'sleep
  98       (let ((cust (car message))
  99             (arg (cadr message)))
 100         (cond
 101           ((eq? arg 'look)
 102            (send-message cust 'print description))
 103           ((memq arg names)
 104            (send-message cust 'move-to dest))
 105           (else
 106            (send-message cust 'no-match)))
 107         'sleep)))
 108
 109 (define (make-room title desc)
 110   (make-actor (room-beh title desc)))
 111
 112 (define (add-exit from to names desc)
 113   (send-message from 'add-exit (make-actor (exit-beh names desc to))))
 114
 115 (define shore
 116   (make-room "Rocky shore at night"
 117              (conc "You are standing on a rocky shore. Menacing waves crash periodically\n"
 118                    "against large bolders from all directions, occasionally spraying you\n"
 119                    "with salty ocean mist.")))
 120
 121 (define ocean
 122   (make-room "Cold ocean"
 123              "You are now in the water."))
 124
 125 (define underwater
 126   (make-room "Underwater"
 127              "You are now swimming near the ocean floor."))
 128
 129 (add-exit shore ocean '(west w)
 130           "A path leads west through the boulders down to the waves.")
 131
 132 (add-exit ocean shore '(east e)
 133           "The shore is to the east.")
 134
 135 (add-exit ocean underwater '(down d)
 136           "You can swim down here.")
 137
 138 (add-exit underwater ocean '(up u)
 139           "You can swim up from here.")
 140
 141 (define player (make-actor-with-address 'player (player-beh shore)))
 142
 143 (define (start)
 144   (send-message player 'init)
 145   (run))