src/TeXmacs/progs/remote/chat-edit.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : chat-edit.scm
   5 ;; DESCRIPTION : editing routines for chatting
   6 ;; COPYRIGHT   : (C) 2006  Joris van der Hoeven
   7 ;;
   8 ;; This software falls under the GNU general public license version 3 or later.
   9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  11 ;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (texmacs-module (remote chat-edit)
  15   (:use (utils library tree)
  16         (utils library cursor)
  17         (remote client)))
  18
  19 (define chat-connected (make-ahash-table))
  20 (define chat-last-modification (make-ahash-table))
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;; Basic subroutines for chatting
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25
  26 (tm-define (chat-session)
  27   (:synopsis "Get the current chat session tree.")
  28   (tree-innermost 'chat-session))
  29
  30 (tm-define (chat-input)
  31   (and-with session (chat-session)
  32     (with last (tm-ref session 1 :last)
  33       (and (tree-is? last 'chat-input) last))))
  34
  35 (tm-define (chat-field)
  36   (or (tree-innermost 'chat-input)
  37       (tree-innermost 'chat-output)))
  38
  39 (tm-define (chat-room)
  40   (and-with session (chat-session)
  41     (tree->string (tree-ref session 0))))
  42
  43 (tm-define (chat-user)
  44   (and-with input (chat-input)
  45     (tree->string (tree-ref input 0))))
  46
  47 (tm-define (chat-user*)
  48   (and-with field (chat-field)
  49     (tree->string (tree-ref field 0))))
  50
  51 (tm-define (chat-connected?)
  52   (:synopsis "Are we inside a session and connected?")
  53   (and-with room (chat-room)
  54     (and-with user (chat-user)
  55       (ahash-ref chat-connected (cons room user)))))
  56
  57 (define (chat-convert field)
  58   (with (nr user contents) field
  59     `(chat-output ,user ,(stree->tree contents))))
  60
  61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62 ;; Chatroom administration
  63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64
  65 (define (chat-server . opt-rooms)
  66   (or (get-server) (default-server)))
  67
  68 (tm-define (chat-list-administrated-rooms)
  69   (with-server (chat-server)
  70     (with l (remote-request '(chat-list-administrated-rooms))
  71       (and l (nnull? l) l))))
  72
  73 (tm-define (chatroom-create room)
  74   (:synopsis "Create a chat room.")
  75   (:argument room "Chat room")
  76   (when (chat-connect room)
  77     (with-server (chat-server room)
  78       (remote-request `(new-chatroom ,room)))))
  79
  80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81 ;; Routines for chatting
  82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83
  84 (tm-define (chat-list-rooms)
  85   (with-server (chat-server)
  86     (with l (remote-request '(chat-list-rooms))
  87       (and l (nnull? l) l))))
  88
  89 (tm-define (chat-connect room)
  90   (:synopsis "Connect to a chat room.")
  91   (:argument room "Chat room")
  92   (and-let* ((user (remote-user))
  93              (can-insert (not (chat-session)))
  94              (not-busy (not (ahash-ref chat-connected (cons user room)))))
  95     (with-server (chat-server room)
  96       (and-let* ((new (remote-request `(chat-connect ,room ,user)))
  97                  (out (map chat-convert new))
  98                  (in `(chat-input ,user (document ""))))
  99         (init-add-package "chat")
 100         (ahash-set! chat-connected (cons room user) #t)
 101         (insert-go-to `(chat-session ,room (document ,@out ,in))
 102                       (list 1 (length new) 1 0 0))
 103         (chat-refresh-handler room user (tree-innermost 'chat-session))
 104         #t))))
 105
 106 (tm-define (chat-catch-up)
 107   (:synopsis "Catch up with the discussion.")
 108   (and-let* ((room (chat-room))
 109              (user (chat-user))
 110              (session (chat-session))
 111              (ok (not (chat-connected?))))
 112     (with-server (chat-server room)
 113       (and-let* ((new (remote-request `(chat-connect ,room ,user)))
 114                  (out (map chat-convert new))
 115                  (in `(chat-input ,user (document ""))))
 116         (ahash-set! chat-connected (cons room user) #t)
 117         (tree-set! session 1 `(document ,@out ,in))
 118         (tree-go-to session 1 :last 1 :end)
 119         (chat-refresh-handler room user (tree-innermost 'chat-session))))))
 120
 121 (tm-define (chat-hang-up)
 122   (:synopsis "Quit the chat room.")
 123   (and-let* ((room (chat-room))
 124              (user (chat-user))
 125              (ok (chat-connected?)))
 126     (with-server (chat-server room)
 127       (remote-request `(chat-hang-up ,room ,user))
 128       (ahash-remove! chat-connected (cons room user))
 129       (ahash-remove! chat-last-modification (cons room user)))))
 130
 131 (tm-define (kbd-return)
 132   (:inside chat-input)
 133   (and-let* ((room (chat-room))
 134              (user (chat-user))
 135              (input (chat-input))
 136              (emit (tree->stree (tree-ref input 1)))
 137              (ok (chat-connected?)))
 138     (with-server (chat-server room)
 139       (chat-wake-up room user #f)
 140       (tree-set! input 1 '(document ""))
 141       (remote-request `(chat-emit ,room ,user ,emit)))))
 142
 143 (tm-define (kbd-return)
 144   (:inside chat-output)
 145   (and-let* ((room (chat-room))
 146              (user (chat-user*))
 147              (field (chat-field))
 148              (nr (tree-index field))
 149              (emit (tree->stree (tree-ref field 1)))
 150              (ok (and (chat-connected?) (== user (chat-user)))))
 151     (with-server (chat-server room)
 152       (chat-wake-up room user #f)
 153       (remote-request `(chat-update ,room ,user ,nr ,emit)))))
 154
 155 (define (chat-update t field)
 156   ;;(display* "Update " field "\n")
 157   (with (nr user contents) field
 158     (while (>= nr (- (tree-arity t) 1))
 159       (tree-insert! t (- (tree-arity t) 1) '("")))
 160     (tree-set! t nr (chat-convert field))))
 161
 162 (define (chat-wake-up room user ring?)
 163   (with last (ahash-ref chat-last-modification (cons room user))
 164     (when (and ring? last (> (texmacs-time) (+ last 300000)))
 165       (delayed
 166         (:pause 500)
 167         (system-1 "play" "$TEXMACS_PATH/misc/sounds/phone.wav")
 168         (delayed
 169           (:pause 2500)
 170           (system-1 "play" "$TEXMACS_PATH/misc/sounds/phone.wav")
 171           (delayed
 172             (:pause 2500)
 173             (system-1 "play" "$TEXMACS_PATH/misc/sounds/phone.wav")))))
 174     (ahash-set! chat-last-modification (cons room user) (texmacs-time))))
 175
 176 (tm-define (chat-refresh-handler room user t)
 177   (chat-wake-up room user #f)
 178   (with ptr (tree->tree-pointer t)
 179     (delayed
 180       (:pause 1000)
 181       (:every 2000)
 182       (:clean (tree-pointer-detach ptr))
 183       (:while (ahash-ref chat-connected (cons room user)))
 184       (with-server (chat-server room)
 185         (with new (remote-request `(chat-synchronize ,room ,user))
 186           (if (and new (nnull? new))
 187               (with u (tree-pointer->tree ptr)
 188                 (when (tm-func? u 'chat-session)
 189                   (chat-wake-up room user #t)
 190                   (for-each (lambda (x) (chat-update (tree-ref u 1) x))
 191                             new)))))))))