-(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 "Message from " 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 (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 <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))
The Lambda Lab / projects / sam.git / blobdiff