chat_client.scm

   1 (import sam-macros srfi-13 matchable)
   2
   3 (define (make-rollodex-beh system)
   4   (let ((recipients '()))
   5     (make-beh (self)
   6               (('list) =>
   7                (if (null? recipients)
   8                    (send-message system 'print "Recipients list empty.")
   9                    (begin
  10                      (send-message system 'print "Current recipients")
  11                      (let loop ((r recipients))
  12                        (unless (null? r)
  13                          (send-message system 'print (address->string (car r)))
  14                          (loop (cdr r)))))))
  15               (('clear) =>
  16                (set! recipients '())
  17                (send-message system 'print "Cleared recipient list."))
  18               (('add rstr) =>
  19                (set! recipients (cons (string->address rstr) recipients))
  20                (send-message system 'print "Added recipient to chat."))
  21               (('send name str) =>
  22                (if (null? recipients)
  23                    (send-message system 'print "Speaking to the void.")
  24                    (let loop ((recipients-left recipients))
  25                      (unless (null? recipients-left)
  26                        (send-message (car recipients-left) 'show-msg name str)
  27                        (loop (cdr recipients-left)))))))))
  28
  29 (define (make-receiver-beh system)
  30   (make-beh (self)
  31             (('show-msg from text) =>
  32              (send-message system 'print from "> " text))))
  33
  34
  35 (define (make-client-beh system)
  36   (let ((name "name")
  37         (rollodex (make-actor (make-rollodex-beh system)))
  38         (receiver (make-actor (make-receiver-beh system))))
  39     (make-beh (self)
  40               (('start) =>
  41                (send-message system 'print "Welcome to chat!\n"
  42                              "Your client address is " (address->string receiver) ".\n"
  43                              "Type '/help' for a list of commands.\n")
  44                (send-message system 'read self))
  45               (((? string? str)) =>
  46                (if (string-prefix? "/" str)
  47                    (let* ((maybe-idx (string-index str #\space))
  48                           (idx (if maybe-idx maybe-idx (string-length str)))
  49                           (cmd (substring str 1 idx))
  50                           (arg (string-trim (substring str idx))))
  51                      (match cmd
  52                        ((or "h" "help")
  53                         (send-message system 'print
  54                                       "Command          | Description\n"
  55                                       "------------------------------\n"
  56                                       "/help              List commands\n"
  57                                       "/name Name         Set name to use in chat.\n"
  58                                       "/add <address>     Add specified client as recipient\n"
  59                                       "/clear             Clear recipients\n"
  60                                       "/list              List current recipients\n"
  61                                       "/quit              Quit chat"))
  62                        ((or "a" "add")
  63                         (if (string-null? arg)
  64                             (send-message system 'print "Missing address of client.")
  65                             (send-message rollodex 'add arg)))
  66                        ((or "c" "clear")
  67                         (send-message rollodex 'clear))
  68                        ((or "n" "name")
  69                         (set! name arg)
  70                         (send-message system 'print "Name now set to '" name "'."))
  71                        ((or "l" "list")
  72                         (send-message rollodex 'list))
  73                        ((or "q" "quit")
  74                         (send-message system 'shutdown))
  75                        (else
  76                         (send-message system 'print "Unrecognised command '" cmd "'"))))
  77                    (send-message rollodex 'send name str))
  78                (send-message system 'read self)))))
  79
  80 (define-beh main-beh (self)
  81   ((system) =>
  82    (send-message (make-actor (make-client-beh system)) 'start)
  83    'done))