sequence-dico.lisp

   1 (in-package :sequence-dico)
   2
   3 ;;; Store an object associated with the sequence in the sequence dictionary.
   4 ;;; If a prefix of sequence already names an object in the dictionary
   5 ;;; the existing object is removed.
   6
   7 (defgeneric (setf dico-object) (object sequence-dico sequence))
   8
   9 ;;; Search for a sequence in a sequence dictionary.
  10 ;;; This function returns three values: The first value
  11 ;;; is the object associated with the sequence, or nil
  12 ;;; if no such object exists.  The second value is a boolean
  13 ;;; which is t if the first value is the object associated with
  14 ;;; the sequence and nil otherwise.  The third value is t
  15 ;;; if the sequence is a (not necessarily proper) prefix of a sequence
  16 ;;; that has an associated object and nil otherwise.
  17
  18 (defgeneric dico-object (sequence-dico sequence))
  19
  20 (defclass sequence-dico () ())
  21
  22 (defclass standard-sequence-dico (sequence-dico)
  23   ((table :initarg :table :reader table)))
  24
  25 (defun make-sequence-dico (&key (test #'eql))
  26   (make-instance 'standard-sequence-dico
  27                  :table (make-hash-table :test test)))
  28
  29 (defmethod (setf dico-object) (object (sequence-dico standard-sequence-dico) sequence)
  30   (assert (not (null sequence)))
  31   (loop for subseq on sequence
  32         for elem in sequence
  33         and table = (table sequence-dico) then (gethash elem table)
  34         do (unless (hash-table-p (gethash elem table))
  35              (setf (gethash elem table)
  36                    (make-hash-table :test (hash-table-test (table sequence-dico)))))
  37         finally (setf (gethash elem table) object)))
  38
  39 (defmethod dico-object (sequence-dico sequence)
  40   (assert (not (null sequence)))
  41   (loop for subseq on sequence
  42         for elem in sequence
  43         for table-or-obj = (gethash elem (table sequence-dico))
  44         then (gethash elem table-or-obj)
  45         while (hash-table-p table-or-obj)
  46         finally (cond ((null table-or-obj) (return (values nil nil nil)))
  47                       ((hash-table-p table-or-obj) (return (values nil nil t)))
  48                       ((null (cdr subseq)) (return (values table-or-obj t t)))
  49                       (t (return (values nil nil nil))))))