Playing with using actors for IF.

[actors.git] / island.scm

diff --git a/island.scm b/island.scm
new file mode 100644 (file)
index 0000000..dbbd13d
--- /dev/null
+++ b/island.scm
@@ -0,0 +1,145 @@
+(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))