Implemented beh hierarchy and behaviour macros.

[sam.git] / chat_client.scm

diff --git a/chat_client.scm b/chat_client.scm
index d500579..e6e205d 100644 (file)
--- a/chat_client.scm
+++ b/chat_client.scm
@@ -1,70 +1,68 @@
-(import matchable
-        srfi-13
-        (chicken process-context))
+(import sam-macros srfi-13 matchable)
 
 (define (make-client-beh system)
   (let ((name "name")
         (recipients '()))
-    (lambda (self . message)
-      (match message
-        (('start)
-         (send-message system 'print "Welcome to chat!\n"
-                       "Your client address is " (address->string self) ".\n"
-                       "Type '/help' for a list of commands.\n")
-         (send-message system 'read self))
-        (('show-msg from text)
-         (send-message system 'print from "> " text))
-        (((? string? str))
-         (if (string-prefix? "/" str)
-             (let* ((maybe-idx (string-index str #\space))
-                    (idx (if maybe-idx maybe-idx (string-length str)))
-                    (cmd (substring str 1 idx))
-                    (arg (string-trim (substring str idx))))
-               (match cmd
-                 ((or "h" "help")
-                  (send-message system 'print
-                                "Command          | Description\n"
-                                "------------------------------\n"
-                                "/help              List commands\n"
-                                "/name Name         Set name to use in chat.\n"
-                                "/join <address>    Join chat with specified client\n"
-                                "/clear             Clear recipients\n"
-                                "/list              List current recipients\n"
-                                "/quit              Quit chat"))
-                 ((or "j" "join")
-                  (if (string-null? arg)
-                      (send-message system 'print "Missing address of client.")
-                      (begin
-                        (set! recipients (cons (string->address arg) recipients))
-                        (send-message system 'print "Added recipient to chat."))))
-                 ((or "c" "clear")
-                  (set! recipients '())
-                  (send-message system 'print "Cleared recipient list."))
-                 ((or "n" "name")
-                  (set! name arg)
-                  (send-message system 'print "Name now set to '" name "'."))
-                 ((or "l" "list")
-                  (if (null? recipients)
-                      (send-message system 'print "Recipients list empty.")
-                      (begin
-                        (send-message system 'print "Current recipients:")
-                        (let loop ((recipients-left recipients))
-                          (unless (null? recipients-left)
-                            (send-message system 'print (address->string (car recipients-left)))
-                            (loop (cdr recipients-left)))))))
-                 ((or "q" "quit")
-                  (send-message system 'shutdown))
-                 (else
-                  (send-message system 'print "Unrecognised command '" cmd "'"))))
-             (if (null? recipients)
-                 (send-message system 'print "Speaking to the void.")
-                 (let loop ((recipients-left recipients))
-                   (unless (null? recipients-left)
-                     (send-message (car recipients-left) 'show-msg name str)
-                     (loop (cdr recipients-left))))))))
-      (send-message system 'read self)
-      'sleep)))
+    (make-beh (self)
+              (('start) =>
+               (send-message system 'print "Welcome to chat!\n"
+                             "Your client address is " (address->string self) ".\n"
+                             "Type '/help' for a list of commands.\n"))
+              (('show-msg from text) =>
+               (send-message system 'print from "> " text))
+              (((? string? str)) =>
+               (if (string-prefix? "/" str)
+                   (let* ((maybe-idx (string-index str #\space))
+                          (idx (if maybe-idx maybe-idx (string-length str)))
+                          (cmd (substring str 1 idx))
+                          (arg (string-trim (substring str idx))))
+                     (match cmd
+                       ((or "h" "help")
+                        (send-message system 'print
+                                      "Command          | Description\n"
+                                      "------------------------------\n"
+                                      "/help              List commands\n"
+                                      "/name Name         Set name to use in chat.\n"
+                                      "/join <address>    Join chat with specified client\n"
+                                      "/clear             Clear recipients\n"
+                                      "/list              List current recipients\n"
+                                      "/quit              Quit chat"))
+                       ((or "j" "join")
+                        (if (string-null? arg)
+                            (send-message system 'print "Missing address of client.")
+                            (begin
+                              (set! recipients (cons (string->address arg) recipients))
+                              (send-message system 'print "Added recipient to chat."))))
+                       ((or "c" "clear")
+                        (set! recipients '())
+                        (send-message system 'print "Cleared recipient list."))
+                       ((or "n" "name")
+                        (set! name arg)
+                        (send-message system 'print "Name now set to '" name "'."))
+                       ((or "l" "list")
+                        (if (null? recipients)
+                            (send-message system 'print "Recipients list empty.")
+                            (begin
+                              (send-message system 'print "Current recipients:")
+                              (let loop ((recipients-left recipients))
+                                (unless (null? recipients-left)
+                                  (send-message system 'print (address->string (car recipients-left)))
+                                  (loop (cdr recipients-left)))))))
+                       ((or "q" "quit")
+                        (send-message system 'shutdown))
+                       (else
+                        (send-message system 'print "Unrecognised command '" cmd "'"))))
+                   (if (null? recipients)
+                       (send-message system 'print "Speaking to the void.")
+                       (let loop ((recipients-left recipients))
+                         (unless (null? recipients-left)
+                           (send-message (car recipients-left) 'show-msg name str)
+                           (loop (cdr recipients-left)))))))
+              (finally
+               (send-message system 'read self)
+               'sleep))))
 
-(define (main-beh self system)
-  (send-message (make-actor (make-client-beh system)) 'start)
-  'done)
+(define-beh main-beh (self)
+  ((system) =>
+   (send-message (make-actor (make-client-beh system)) 'start)
+   'done))