Behaviours are now tagged lists.

[sam.git] / chat_client.scm

diff --git a/chat_client.scm b/chat_client.scm
index bb1fd28..48736a8 100644 (file)
--- a/chat_client.scm
+++ b/chat_client.scm
@@ -1,60 +1,83 @@
-(import sam
-        matchable
-        srfi-13)
+(import sam-macros srfi-13 matchable)
 
-(define client
-  (make-actor
-   (lambda (self . message)
-     (let ((name "name")
-           (recipients '()))
-       
-       (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 "Message from " from ": " text))
-         (((? string? str))
-          (if (string-prefix? "/" str)
-              (let* ((idx (string-index str #\space))
-                     (cmd (substring str 1 idx))
-                     (arg (substring str idx)))
-                (match cmd
-                  ("help"
-                   (send-message system 'print
-                                 "Command          | Description\n"
-                                 "------------------------------\n"
-                                 "\help              List commands\n"
-                                 "\join <address>    Join chat with specified client\n"
-                                 "\quit              Quit chat"))
-                  ("join"
-                   (set! recipients (cons (uri-reference arg) recipients))
-                   (send-message system 'print "Added recipient to chat."))
-                  ("quit"
-                   (send-message system 'exit))
-                  (else
-                   (send-message system 'print "Unrecognised command '" cmd "'"))))
-              (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))))
-                  
+(define (make-rollodex-beh system)
+  (let ((recipients '()))
+    (make-beh (self)
+              (('list) =>
+               (if (null? recipients)
+                   (send-message system 'print "Recipients list empty.")
+                   (begin
+                     (send-message system 'print "Current recipients")
+                     (let loop ((r recipients))
+                       (unless (null? r)
+                         (send-message system 'print (address->string (car r)))
+                         (loop (cdr r)))))))
+              (('clear) =>
+               (set! recipients '())
+               (send-message system 'print "Cleared recipient list."))
+              (('add rstr) =>
+               (set! recipients (cons (string->address rstr) recipients))
+               (send-message system 'print "Added recipient to chat."))
+              (('send name str) =>
+               (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)))))))))
+               
+(define (make-receiver-beh system)
+  (make-beh (self)
+            (('show-msg from text) =>
+             (send-message system 'print from "> " text))))
+            
 
-(define (main)
-  (let loop ((args (cdr (argv)))
-             (host "localhost")
-             (port 8000))
-    (match args
-      ((or "-h" "--help")
-       (print-usage))
-      (((or "-p" "--port") pstr rest ...)
-       (loop rest host (string->number pstr)))
-      (("--hostname" hstr rest ...)
-       (loop rest hstr port))
-      (()
-       (make-sam host port)
-       (send-message client 'start)))))
+(define (make-client-beh system)
+  (let ((name "name")
+        (rollodex (make-actor (make-rollodex-beh system)))
+        (receiver (make-actor (make-receiver-beh system))))          
+    (make-beh (self)
+              (('start) =>
+               (send-message system 'print "Welcome to chat!\n"
+                             "Your client address is " (address->string receiver) ".\n"
+                             "Type '/help' for a list of commands.\n")
+               (send-message system 'read self))
+              (((? 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"
+                                      "/add <address>     Add specified client as recipient\n"
+                                      "/clear             Clear recipients\n"
+                                      "/list              List current recipients\n"
+                                      "/quit              Quit chat"))
+                       ((or "a" "add")
+                        (if (string-null? arg)
+                            (send-message system 'print "Missing address of client.")
+                            (send-message rollodex 'add arg)))
+                       ((or "c" "clear")
+                        (send-message rollodex 'clear))
+                       ((or "n" "name")
+                        (set! name arg)
+                        (send-message system 'print "Name now set to '" name "'."))
+                       ((or "l" "list")
+                        (send-message rollodex 'list))
+                       ((or "q" "quit")
+                        (send-message system 'shutdown))
+                       (else
+                        (send-message system 'print "Unrecognised command '" cmd "'"))))
+                   (send-message rollodex 'send name str))
+               (send-message system 'read self)))))
+
+(define-beh main-beh (self)
+  ((system) =>
+   (send-message (make-actor (make-client-beh system)) 'start)
+   'done))