X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=sam.git;a=blobdiff_plain;f=chat_client.scm;h=48736a8e684fc656d70bc94d271c22bb0d0f1e9c;hp=947418f09d7be452767bcedfa7c9487469aa00c3;hb=HEAD;hpb=d9768084b4cde1dd4ac4edcbb432b7df4101bfc2 diff --git a/chat_client.scm b/chat_client.scm index 947418f..48736a8 100644 --- a/chat_client.scm +++ b/chat_client.scm @@ -1,93 +1,83 @@ -(import sam - matchable - srfi-13 - (chicken process-context)) +(import sam-macros srfi-13 matchable) + +(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 (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
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))) - -(define (main-beh self system) - (send-message (make-actor (make-client-beh system)) 'start) - 'done) - -(define (print-usage) - (print "Actor-driven chat client.\n") - (print "Usage: chat_client -h") - (print " chat_client [-p port_num] [-n host_name]")) - -(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))) - (((or "-n" "--hostname") hstr rest ...) - (loop rest hstr port)) - (() - (boot-sam host port main-beh)) - (else - (print "Unrecognised argument '" (car args) "'.\n") - (print-usage)))) + (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
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))