[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[goldman@vaxa.isi.edu: Name Completion software]



    Does anyone have a non-proprietary lisp implementation of support
    for NAME-COMPLETION?  I am NOT particularly interested in a
    user interface (echoing, line-editing) for name complettion, but
    in the underlying support for keeping track of a moderately large
    (several 1000s) collection of names so that it can be rapidly
    indexed based on the leading string.

I don't know if this will help you. It is not documented and is not
exactly what you want but me be of some help and may point you
in the right direction. The purpose of this code which I wrote is
to alleviate the need to keep track of people's net address.
Some ZMail commands are added which keep track of a net address
data base and allow adding a to: or cc: field by name lookup
rather than net address. If you can't figure out what this code
does, let me know and I will document it and send you the documentation.
        Jeff

1;;; -*- Mode: LISP; Package: USER; Base: 10; Syntax: Common-lisp -*-

;;; LaHaShem HaAretz U'Mloah

0(defvar 2*CORRESPONDERS*0 :reload "A list of all corresponders")

(defvar 2*NAME-DELIMITERS*0 '(#\- #\_ #\space #\, #\.)
 "A list of characters which delimit words")

(defun 2CORRESPONDERS-PATHNAME0 ()
 (make-pathname :name "CORRESPONDERS"
                :type "TEXT"
                :defaults (user-homedir-pathname)))

(defun 2LOAD-CORRESPONDERS-IF-NECESSARY0 ()
 (if (eq *corresponders* :reload)
     (with-open-file (corresponders (corresponders-pathname) :direction :in)
       (setf *corresponders* (read corresponders)))))

(defun 2SAVE-CORRESPONDERS0 ()
 (if (not (eq *corresponders* :reload))
     (with-open-file (corresponders (corresponders-pathname) :direction :out)
       (write *corresponders* :stream corresponders))))

(defun 2SPLIT-NAME0 (name delimiters)
 (remove ""
         (loop with last-index = 0
               for index in
                   (append
                    (loop for index from 0 below (array-dimension name 0)
                          when (member (aref name index) delimiters
                                       :test #'char=)
                            collect index)
                    (list (array-dimension name 0)))
               collect (substring name last-index index)
               do (setf last-index (1+ index)))
         :test #'string=))

(defun 2NAMES-MATCH?0 (name1 name2)
 (let ((split-name1 (split-name name1 *name-delimiters*))
       (split-name2 (split-name name2 *name-delimiters*)))
   (every (lambda (word1)
            (member word1 split-name2
                    :test
                    (lambda (word1 word2)
                      (let ((length (length word1)))
                        (string-equal word1 word2
                                      :end1 length
                                      :end2 length)))))
          split-name1)))

(defun 2LOOKUP-NAME-IN-NAMESPACES0 (name namespaces)
 (map 'list
      (lambda (object)
        (let* ((personal-name (send object :get :personal-name))
               (mail-address (send object :get :mail-address))
               (name (first mail-address))
               (host (second mail-address))
               (original-string (format nil "~A <~A@~A>"
                                        personal-name
                                        name
                                        host)))
          (list :personal-name personal-name
                :name name
                :host host
                :original-string original-string)))
      (remove-if-not
       (lambda (object)
         (and (send object :get :personal-name)
              (send object :get :mail-address)
              (names-match? name (send object :get :personal-name))))
       (let ((net:*namespace-search-list* namespaces))
         (net:find-objects-from-property-list
          :user
          1;; the following is a crock
0          :personal-name name)))))

(defun 2LOOKUP-NAME-IN-CORRESPONDERS0 (name)
 (load-corresponders-if-necessary)
 (remove-if-not
  (lambda (corresponder)
    (names-match? name (getf corresponder :personal-name)))
  *corresponders*))

(defun 2LOOKUP-NAME-IN-SEQUENCES0 (name)
 (loop with corresponders = '()
       for sequence in
           (multiple-value-bind (buffers-alist collections-alist)
               (zwei:get-sequence-alists)
             (append (map 'list #'cdr buffers-alist)
                     (map 'list #'cdr collections-alist)))
       do
   (send sequence :map-over-msgs
         (lambda (msg)
           (loop for field in '(:from :cc :to)
                 do
             (loop for address in (getf (zwei:msg-status msg) field)
                   when (and (getf address :personal-name)
                             (names-match? name (getf address :personal-name)))
                     do (push address corresponders)))))
       finally (return corresponders)))

(defun 2SAME-NET-ADDRESS0 (address1 address2)
 (and (equal (getf address1 :name) (getf address2 :name))
      (if (and (listp (getf address1 :host))
               (listp (getf address2 :host)))
          (equal (getf address1 :host) (getf address2 :host))
          (eq (getf address1 :host) (getf address2 :host)))))

(defun 2LOOKUP-NAME-EVERYWHERE0 (name)
 (remove-duplicates
  (append
   (lookup-name-in-namespaces
    name (list (first net:*namespace-search-list*)))
   (lookup-name-in-corresponders name)
   (lookup-name-in-sequences name))
  :test #'same-net-address))

(defun 2LOOKUP-NAME0 (name)
 (let ((corresponders (lookup-name-everywhere name)))
   (cond ((null corresponders) nil)
         ((null (rest corresponders)) (first corresponders))
         (t (tv:menu-choose
             (map 'list
                  (lambda (corresponder)
                    (list (getf corresponder :original-string)
                          corresponder))
                  corresponders))))))

(zwei:defcom com-force-reload-of-corresponders
             "Force a reload of the corresponder data base"
             ()
  (setf *corresponders* :reload)
  zwei:dis-none)

(zwei:set-comtab zwei:*reply-comtab*
                 '(#\hyper-r com-force-reload-of-corresponders))
(zwei:set-comtab zwei:*zmail-comtab*
                 '(#\hyper-r com-force-reload-of-corresponders))

(zwei:defcom com-lookup-corresponder "Lookup corresponder" ()
  (let* ((name (zwei:typein-line-history-readline
                zwei:*replace-history* nil t "Corresponder to look up"))
         (corresponder (getf (lookup-name name) :original-string)))
    (if (null name)
        (zwei:barf)
        (zwei:typein-line corresponder))
    zwei:dis-none))

(zwei:set-comtab zwei:*reply-comtab* '(#\hyper-l com-lookup-corresponder))
(zwei:set-comtab zwei:*zmail-comtab* '(#\hyper-l com-lookup-corresponder))

(zwei:defcom com-insert-corresponder
             "Lookup and insert corresponder at point"
             ()
  (let* ((name (zwei:typein-line-history-readline
                zwei:*replace-history* nil t "Corresponder to look up"))
         (corresponder (getf (lookup-name name) :original-string)))
    (cond ((null name) (zwei:barf))
          (t (zwei:insert-thing (zwei:point) corresponder)
             (zwei:move-point
              (zwei:forward-char (zwei:point) (length corresponder)))))
    zwei:dis-text))

(zwei:set-comtab zwei:*reply-comtab* '(#\hyper-i com-insert-corresponder))

(defun 2ADD-HEADER0 (field corresponder)
 (send zwei:*draft-msg* :set-headers
       (zwei:parse-headers-interval zwei:*header-interval*))
 (send zwei:*draft-msg* :add-header
       field (append (getf (send zwei:*draft-msg* :headers) field)
                     (list corresponder))))

(zwei:defcom com-insert-corresponder-as-to-field
             "Lookup and insert corresponder as to field"
             ()
  (let* ((name (zwei:typein-line-history-readline
                zwei:*replace-history* nil t "Corresponder to look up"))
         (corresponder (lookup-name name)))
    (cond ((null name) (zwei:barf))
          (t (add-header :to corresponder)))
    zwei:dis-text))

(zwei:set-comtab zwei:*reply-comtab*
                 '(#\hyper-d com-insert-corresponder-as-to-field))

(zwei:defcom com-insert-corresponder-as-cc-field
             "Lookup and insert corresponder as cc field"
             ()
  (let* ((name (zwei:typein-line-history-readline
                zwei:*replace-history* nil t "Corresponder to look up"))
         (corresponder (lookup-name name)))
    (cond ((null name) (zwei:barf))
          (t (add-header :cc corresponder)))
    zwei:dis-text))

(zwei:set-comtab zwei:*reply-comtab*
                 '(#\hyper-c com-insert-corresponder-as-cc-field))

(defun 2ADD-NAMESPACES-TO-CORRESPONDERS0 (namespaces)
 (load-corresponders-if-necessary)
 (loop for object in (let ((net:*namespace-search-list* namespaces))
                       (net:find-objects-from-property-list :user))
       do
   (let* ((personal-name (send object :get :personal-name))
          (mail-address (send object :get :mail-address))
          (name (first mail-address))
          (host (second mail-address))
          (original-string (format nil "~A <~A@~A>"
                                   personal-name
                                   name
                                   host))
          (address
           (list
            :personal-name personal-name
            :name name
            :host (if host
                      (cons :domain
                            (split-name
                             (send (first (send host :names)) :string)
                             '(#\.))))
            :original-string original-string)))
     (if (and (getf address :personal-name)
              (getf address :mail-address)
              (not (member address *corresponders*
                           :test #'same-net-address)))
         (push address *corresponders*))))
 (save-corresponders)
 t)

(zwei:defcom com-add-corresponders
             "Adds all network address containing personal names appearing in
to/cc/from fields in the current Zmail sequence to the corresponders list"
             ()
  (load-corresponders-if-necessary)
  (send zwei:*sequence* :map-over-msgs
        (lambda (msg)
          (loop for field in '(:from :cc :to)
                do
            (loop for address in (getf (zwei:msg-status msg) field)
                  when (and (getf address :personal-name)
                            (not (member address *corresponders*
                                         :test #'same-net-address)))
                    do (push address *corresponders*)))))
  (save-corresponders)
  zwei:dis-none)

(zwei:set-comtab zwei:*zmail-comtab* '(#\hyper-a com-add-corresponders))

(zwei:defcom com-list-corresponders
             "Puts a list of all network address appearing in to/cc/from
fields in the current Zmail sequence into an editor buffer"
             ()
  (let ((corresponders (make-hash-table :test #'equal)))
    (send zwei:*sequence* :map-over-msgs
          (lambda (msg)
            (loop for from in (getf (zwei:msg-status msg) :from)
                  for id = (list (string-upcase (getf from :name))
                                 (map 'list
                                      (lambda (thing)
                                        (if (stringp thing)
                                            (string-upcase thing)
                                            thing))
                                      (getf from :host)))
                  for who = (getf from :original-string)
                  when (null (gethash id corresponders))
                    do (setf (gethash id corresponders) who))
            (loop for to in (getf (zwei:msg-status msg) :to)
                  for id = (list (string-upcase (getf to :name))
                                 (map 'list
                                      (lambda (thing)
                                        (if (stringp thing)
                                            (string-upcase thing)
                                            thing))
                                      (getf to :host)))
                  for who = (getf to :original-string)
                  when (null (gethash id corresponders))
                    do (setf (gethash id corresponders) who))
            (loop for cc in (getf (zwei:msg-status msg) :cc)
                  for id = (list (string-upcase (getf cc :name))
                                 (map 'list
                                      (lambda (thing)
                                        (if (stringp thing)
                                            (string-upcase thing)
                                            thing))
                                      (getf cc :host)))
                  for who = (getf cc :original-string)
                  when (null (gethash id corresponders))
                    do (setf (gethash id corresponders) who))))
    (with-open-stream
     (buffer (zwei:make-file-buffer-stream
              (make-pathname :name "CORRESPONDERS"
                             :type "TEXT"
                             :defaults (user-homedir-pathname))))
      (loop for who being the hash-elements of corresponders
            do (format buffer "~&~A" who))))
  zwei:dis-none)

(zwei:set-comtab zwei:*zmail-comtab* '(#\hyper-z com-list-corresponders))

1;;; Tam V'Nishlam Shevah L'El Borei Olam