Playing with using actors for IF.

diff --git a/actors.scm b/actors.scm
index 884920d..fc266a3 100644 (file)
--- a/actors.scm
+++ b/actors.scm
@@ -4,7 +4,9 @@
    send-message
    run
    send-and-run
-   trace-enabled)
+   restart
+   enable-trace
+   disable-trace)
 
   (import scheme
           (chicken base)
@@ -13,6 +15,12 @@
 
   (define trace-enabled #f) ;used for debugging
 
+  (define (enable-trace)
+    (set! trace-enabled #t))
+
+  (define (disable-trace)
+    (set! trace-enabled #f))
+
 
 ;;;
 ;;; Actor creation
@@ -139,4 +147,8 @@
 
   (define (send-and-run actor . message)
     (apply send-message (cons actor message))
-    (run)))
+    (run))
+
+  (define (restart)
+    (set! message-queue (make-fifo))
+    (set! actor-table (make-hash-table))))

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))

diff --git a/testing_counter.scm b/testing_counter.scm
index 0b25876..4ac1b79 100644 (file)
--- a/testing_counter.scm
+++ b/testing_counter.scm
@@ -1,6 +1,6 @@
 (import actors)
 
-(define trace-enabled #t)
+(enable-trace)
 
 (define ((make-counter-behaviour value) self customer . args)
   (match args

diff --git a/testing_factorial1.scm b/testing_factorial1.scm
index 188dc32..aa3d1f0 100644 (file)
--- a/testing_factorial1.scm
+++ b/testing_factorial1.scm
@@ -1,6 +1,6 @@
 (import actors)
 
-(define trace-enabled #t)
+(enable-trace)
 
 (define factorial
   (make-actor-with-address 'factorial

diff --git a/testing_factorial2.scm b/testing_factorial2.scm
index bba678e..958713d 100644 (file)
--- a/testing_factorial2.scm
+++ b/testing_factorial2.scm
@@ -1,6 +1,6 @@
 (import actors)
 
-(define trace-enabled #t)
+(enable-trace)
 
 (define factorial
   (make-actor-with-address 'factorial

diff --git a/testing_factorial3.scm b/testing_factorial3.scm
index 29d3f85..e809c84 100644 (file)
--- a/testing_factorial3.scm
+++ b/testing_factorial3.scm
@@ -1,6 +1,6 @@
 (import actors)
 
-(define trace-enabled #t)
+(enable-trace)
 
 (define factorial
   (make-actor-with-address