;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: genls-cache.lsp
;;;;    System: FIRE
;;;;   Version: v1
;;;;    Author: Ken Forbus & John Everett
;;;;   Created: January 1, 2001 10:35:58
;;;;   Purpose: Caching genls for speed
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Sunday, November 9, 2003 at 23:28:01 by ureel
;;;; ---------------------------------------------------------------------------

(in-package :fire)
  
;;; OVERVIEW
;;; ----------------------------------------------------------------------------
;;; One of the heavy costs in many reasoning systems is accessing
;;; the gensl/isa information.  Typically one wants to cache this information
;;; in RAM, even if it is stored in a persistent KB somewhere else.  And since
;;; it is common to want to see if something is a member of a collection, which
;;; requires crawling up the GENLS hierarchy, it is convenient to cache with
;;; each collection its allgenls, i.e., the full set.  (This is a Cyc trick
;;; from the 1980s.)  That means having a specialized set of datastructures
;;; for supporting genls.  This file defines those structures and procedures.

;;; API
;;; ----------------------------------------------------------------------------
;;;
;;; PUBLIC
;;; These are the only calls that should be used by systems that use FIRE
;;; that are worrying a lot about efficiency.  The default operation of the
;;; genls cache is automatic, and is fine for everyday research purposes.
;;;
;;; (cache-direct-genls-if-needed (kb))
;;; creates genls cache if it isn't there already, and initializes it.
;;; This can be via recomputing it from dbex, or loading it from files,
;;; if they are available.  (See genls-cache-dumper.lsp for details).
;;; Again, this isn't something that users need to call, nor most FIRE
;;; system developers.
;;;
;;; (reset-genls-cache (&optional (kb *kb*))
;;; You think your bug is due to the genls cache being stale?  Call
;;; this procedure and you'll get a new one.  Initialization happens on
;;; first use, not on reset.
;;;
;;; (compute-genls-cache <kb>)
;;; This is what actually gets called inside cache-direct-genls-if-needed
;;; to construct the basic information.
;;;
;;; (fill-genls-cache (&optional (kb *kb*)))
;;; useful only if you have a huge amount of RAM and want everything to be
;;; as fast as possible.  This precomputes the allgenls for every collection
;;; in the KB.  (Takes about ten minutes on QRG-DARPA KB, on a 500 mhz P3 with
;;; 512MB of RAM) Fair warning: Dumping a cache after doing this will certainly
;;; be faster next time, but significantly bloats the size of the files, as you
;;; might expect.  5.4MB for the .fasls for a dumped genls cache without any
;;; allgenls precomputed; just under 19MB for the .fasls with all allgenls
;;; precomputed.  

;;; DEBUGGING/STATISTICS
;;;
;;; (genls-cache-stats (&key (kb *kb*)(stream *standard-output*)))
;;; provides some basic stats (min, max, mean) for properties of the genls cache.
;;;
;;; (show-genls-cache (&optional (*kb* *kb*)))
;;; lists the existing cache entries and what allgenls information has already
;;; been computed for them.  Huge output.  Only good for low-level debugging
;;; of this code, and rarely even for that.
;;;
;;; (show-allgenls (cache &optional (stream *standard-output*))
;;; lists every allgenls, computing them for existing cache entries if necessary.
;;; Generally huge, dump this to file and use Emacs to prowl if you really
;;; have to do this (and I hope that you don't).
;;; 
;;; SEMI-PUBLIC
;;; Nothing outside FIRE should call this code.  Even code inside FIRE shouldn't
;;; call this code -- if you find yourself doing that, ask yourself why you
;;; aren't using the standard API in KB-API, since these procedures are
;;; semi-exposed only to support their use there.  
;;; However, if you are extending
;;; KB-API, then you'll need to know the intended ways to hook into this code.
;;; Here they are:
;;;
;;; (exists-in-low-level-genls-tables? <collection> <cache or KB>)
;;; returns non-NIL if there is an entry in the direct subs or direct genls
;;; for <collection>, i.e., it really is a collection as far as the KB is
;;; concerned.  Cheaper than asking (isa ?x Collection).
;;;
;;; (has-genls-cache-entry? <collection> <cache or KB>) returns non-NIL if
;;;  there is an existing entry for <collection> in the cache, NIL otherwise.
;;;
;;; (genls-cache-entry <collection> <cache or KB>) returns the entry for
;;; <collection>, creating one if it isn't there already.
;;;
;;; (retrieve-genls <col> <cache>) returns list of immediate genls for 
;;; <collection>
;;;
;;; (retrieve-subs <col> <cache>) returns list of immediate subsets for 
;;; <collection>
;;; 
;;; (allgenls <entry>) returns list of allgenls for the collection represented
;;; by <entry>
;;;
;;; (compute-all-subsets <entry>) returns list of all subsets of the collection
;;; represented by <entry>
;;;

;;; NOTES ON THE INTERNALS
;;; ----------------------------------------------------------------------------
;;; The basic structure is the GENLS-CACHE.  It is part of a KB, hence available
;;; to all reasoners that use that KB.  When a KB datastructure is first created
;;; in a Lisp, the genls-cache is initialized with all of the genls relations
;;; in it.  This is accomplished via a special dbex call, 
;;;   (dbex::extension-of-predicate <pred> <arity>) optimized for this.
;;; This information is used to create two hash tables,
;;;     collection --> immediate subsets
;;;     collection --> immediate genls
;;; This makes finding immediate subsets and genls quite quick.  
;;; Since any particular FIRE program may only use particular subsections
;;; of the KB, we minimize CPU startup time and storage by only computing
;;; allgenls on demand.  (Same with allsubsets, a call that is rare and 
;;; can easily be quite expensive.)  Results are stored in another table,
;;;     collection --> genls-cache-entry
;;;      where genls-cache-entry contains allgenls, allsubsets, depth
;;; 
;;; The allgenls/allsubsets computation is more annoying than one might expect
;;; because there can be cycles in the genls hierarchy.  

;;; ----------------------------------------------------------------------------



;;; CLASSES 
;;; ----------------------------------------------------------------------------
(defclass genls-cache ()
  ((table :type t :accessor table :initform (make-hash-table :test 'equal)
          :documentation "Table of genls cache entries, one per predicate")
   (roots :type t :accessor roots :initform nil
          :documentation "Roots of ontology.")
   (direct-genls :type t :accessor direct-genls
                 :initform (make-hash-table :test #'equal :size 50000)
                 :documentation "Direct genls for each predicate")
   (direct-subs :type t :accessor direct-subs
                :initform (make-hash-table :test #'equal :size 50000)
                :documentation "Direct subsets for each predicate.")
   (kb :type t :accessor kb
       :initarg :kb :documentation "KB this genls cache belongs to")
   (cache-initialized? :type t :accessor cache-initialized? :initform nil
                       :documentation "When non-nil, cache has been initialized")))

(defmethod print-object ((cache genls-cache) (stream t))
  (format stream "<Genls Cache with ~A entries>"
    (hash-table-count (table cache))))

(defmethod genls-cache? ((thing t)) nil)
(defmethod genls-cache? ((thing genls-cache)) t)

;;; GENLS-CACHE-ENTRY

(defclass genls-cache-entry ()
  ((predicate :type t :accessor predicate :initarg :predicate)
   (allgenls :type t :accessor the-allgenls :initform :unknown
             :initarg :allgenls)
   (allsubsets :type t :accessor the-allsubsets :initform :unknown
               :initarg :allsubsets)
   (depth :type integer :accessor depth :initform -1 :initarg :depth)
   (cache :type t :accessor cache :initarg :cache)))

;;; The contents of allgenls and allsubsets are
;;; genls-cache-entry objects, not predicates themselves.  This
;;; enables us to do an eql test instead of equal for NATs and NAPs.
;;; It also means we can sort the allgenls list by depth, and forces
;;; us to cons up a new list when returning values to the outside,
;;; thus preventing destructive operations from nuking the integrity
;;; of the cache.
;;;
;;; We used to store genls and subsets in these entries.  Pointless, since
;;; that information is stored in other tables in the cache.

(defmethod print-object ((entry genls-cache-entry) stream)
  (format stream "<~A:~A>" (predicate entry) (depth entry)))

(defmethod genls-cache-entry? ((thing t)) nil)
(defmethod genls-cache-entry? ((thing genls-cache-entry)) t)

(defmethod genls-cache-entry ((predicate t) (cache null))
  ;;need to ensure that *kb* is bound properly here.  
  (genls-cache-entry predicate 
                     (genls-cache (get-or-create-genls-cache))))

(defmethod genls-cache-entry ((predicate t) (cache knowledge-base))
  (genls-cache-entry predicate (genls-cache cache)))

;; Formerly genls-cache-entry?, but renamed to be consistent with
;; actual meaning.
(defmethod has-genls-cache-entry? ((predicate t) (cache knowledge-base))
  (has-genls-cache-entry? predicate (genls-cache cache)))

(defmethod has-genls-cache-entry? ((predicate t) (cache genls-cache))
  (gethash predicate (table cache)))

(defmethod genls-cache-entry ((predicate t) (cache genls-cache))
  (get-or-create-cache-entry predicate cache))

(defun get-or-create-cache-entry (col cache)
  "Does the minimum for setting up a genls cache entry."
  ;; Reason for doing the minimum is that filling everything
  ;; out can get expensive.
  (let ((cache-table (table cache)))
    (or (gethash col cache-table)
        (let ((new (make-instance 'genls-cache-entry :predicate col
                     :cache cache)))
          (setf (gethash col cache-table) new)
          new))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Entry points

(defun update-genls-cache (&optional (*kb* *kb*))
  "Loads all genls facts from active db into memory"
  (get-or-create-genls-cache)
  (cache-direct-genls-if-needed *kb*))

(defgeneric exists-in-low-level-genls-tables? (pred place)
  (:documentation "The first step of building the genls cache involves
                   grabbing all the genls facts int he entire KB and stashing
                   away the direct-genls and direct-subclasses of all the
                   collections.  This function can be used to determine
                   if a term is mentioned in these low-level tables.  This
                   is most useful for quickly determining if something is a 
                   collection."))

(defmethod exists-in-low-level-genls-tables? (pred (kb knowledge-base))
  (exists-in-low-level-genls-tables? pred (genls-cache kb)))

(defmethod exists-in-low-level-genls-tables? (pred (cache genls-cache))
  (or (gethash pred (direct-genls cache))
      (gethash pred (direct-subs  cache))))

;;; RETRIEVING GENLS FROM DATABASE
;;; ----------------------------------------------------------------------------
;;; It takes about 60 seconds to retrieve all GENLS from a cyc-sized KB.
;;; Consequently, we include two tables in the genls cache that store this
;;; information, the direct-genls and direct-subs.  Since this is associated with
;;; the KB, it costs zero for each new reasoner that is created.

(defun get-or-create-genls-cache (&optional (*kb* *kb*))
  (or (genls-cache *kb*)
      (reset-genls-cache *kb*)))

(defun reset-genls-cache (&optional (*kb* *kb*))            
  (setf (genls-cache *kb*) (make-instance 'genls-cache :kb *kb*)))

(defun cache-direct-genls-if-needed (kb)
  (let ((cache (genls-cache kb)))
    (unless (cache-initialized? cache)
      (cond ((genls-cache-files-stale? kb)
             (compute-genls-cache (kb cache)))
            (t (reconstruct-genls-cache kb))))))

(defun compute-genls-cache (kb)
  "Retrieve all db genls once, to minimize time spent getting data from disk"
  (let* ((cache (genls-cache kb))
         (genls-table (direct-genls cache))
         (subs-table (direct-subs cache))
         (sub nil)
         (super nil))
    (dolist (genl-propn (mp:with-process-lock ((lock kb))
                          (dbex:extension-of-predicate 'data::genls 2)))
      (setq sub (second genl-propn))
      (setq super (third genl-propn))
      (push sub (gethash super subs-table))
      (push super (gethash sub genls-table)))
    (setf (cache-initialized? cache) t)))

(defun fill-genls-cache (&optional (kb *kb*))
  ;; Assumes cache has been initialized
  ;; Do this just before saving genls cache files for FIRE-based applications
  (maphash #'(lambda (collection genls)
               (declare (ignore genls))
               (allgenls (genls-cache-entry collection kb)))
           (direct-genls (genls-cache kb))))

;;;; ACCESSING CACHE INFORMATION
;;;; ---------------------------------------------------------------------------

(defun retrieve-genls (col cache)
  "Fast retrieval of all immediate genls for collection"
  (gethash col (direct-genls cache)))

(defun retrieve-subs (col cache)
  "Fast retrieval of all immediate subsets for collection."
  (gethash col (direct-subs cache)))

(defun retrieve-genls-entries (col-entry cache)
  (mapcar #'(lambda (genl) (genls-cache-entry genl cache))
    (retrieve-genls (predicate col-entry) cache)))

(defun retrieve-subset-entries (col-entry cache)
  (mapcar #'(lambda (genl) (genls-cache-entry genl cache))
    (retrieve-subs (predicate col-entry) cache)))

(defun genls-root? (entity cache)
  "Is entity a root entry, by virtue of not having any genls?"
  (null (retrieve-genls entity cache)))

;;; ----------------------------------------------------------------------------
;;; FINDING AND CACHING ALLGENLS
;;; Want to do minimum work while still having consistent results.

(defun allgenls (entry)
  (when (eq (the-allgenls entry) :unknown)
    (compute-allgenls-for entry))
  (the-allgenls entry))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (proclaim '(special cl-user::entry cl-user::above cl-user::fringe)))
 
(defun compute-allgenls-for (entry)
  (let ((cache (cache entry))
        (above nil) (fringe nil))
    ;; First we create the entries for the collections up to the root(s).
    (cond ((all-direct-genls-allgenls-known? entry) 
           ;; This is the simple case.  All of its direct genls have already
           ;; been computed, so all we have to do is merge their results.
           ;; This will also handle queries regarding roots.
           (compute-allgenls-from-direct-genls entry cache))
          (t ;; The more complex case.  We have to walk upwards, find what has
           ;; already been computed, and then work back downwards, computing as
           ;; we go.  Since there are cycles, this is a bloody pain.
           ;; Since roots are caught by the previous clause, above must always be
           ;; non-empty.
           (setq above (gather-collections-upwards entry cache))
           ;; The fringe is the top of the surface of unknown elements above
           ;; the entry.  For the first entry, these are the roots that can be seen
           ;; from above.  But for subsequent calls, it's a bit closer down.
           (setq fringe (find-unknown-allgenls-fringe above cache))
           (cond ((null fringe)
                  ;; The nodes above all happen to be roots, which are themselves unknown.
                  ;; Yes, this can happen.  But we confirm it just in case...
                  (cond ((every #'(lambda (genl) (if (all-direct-genls-allgenls-known? genl)
                                                   (compute-allgenls-from-direct-genls genl cache)))
                                above)
                         (compute-allgenls-for entry))
                        (t ;; At this point we have some funky cycle. Being fancy isn't helping, so
                         ;; we're going to do brute force...
                         (setf (the-allgenls entry)
                           (mapcar #'(lambda (pred) (genls-cache-entry pred cache))
                             (allgenls-the-hard-way (predicate entry))))
                         (setf (depth entry) (1+ (apply 'max (mapcar 'depth (the-allgenls entry)))))
                         (setf (the-allgenls entry) (sort (the-allgenls entry) '> :key 'depth)))))
                 (t ;; More typical case: Lots of unknown stuff above.
                  (setq ****nodes-touched-during-allgenls-sweep**** nil)
                  ;; Cache nodes whose allgenls actually get changed, 
                  ;; because we need to sort them on the way out due to possible depth changes
                  ;; -- curse cycles anyway.
                  ;; March downward from fringe, updating allgenls in the subset
                  ;; we are dealing with as we go
                  (update-allgenls-downward fringe (cons entry above) cache)
                  ;;;; Once the stepping has been done, re-sort the allgenls
                  ;;;; for those nodes that have been touched.  Paranoid?  Not us.
                  (dolist (node ****nodes-touched-during-allgenls-sweep****)
                    (setf (the-allgenls node)
                      (sort (the-allgenls node) '> :key 'depth)))))))
           ;; By now the the-allgenls should have been set.  If not, we have a problem.
           (when (eq (the-allgenls entry) :unknown) 
             (format t "~% Entry = ~A, ~D above, ~D fringe."
               entry (length above) (length fringe))
             ;; Workaround for bugs in ACL6 debugger (grumble).
             (setq cl-user::entry entry cl-user::above above cl-user::fringe fringe)
             (break "Still unknown."))
    (the-allgenls entry)))

(defun silly-cycle? (entry above)
  (and (= (length above) 1)
       (let ((other-genls (retrieve-genls-entries (car above) (cache entry))))
         (and (= (length other-genls) 1)
              (eq (car other-genls) entry)))))
               
(defun handle-silly-cycle (entry above)
  ;; One of those cases where there are two isolated nodes, not tied to anything
  ;; else.  
  ;; So far, haven't found an entire isolated cycle.  But it is possible, and this code
  ;; won't handle that.  Ugh.
  (let ((other (car above)))
    (setf (the-allgenls entry) (list other))
    (setf (the-allgenls other) (list entry))
    (setf (depth entry) 1)
    (setf (depth other) 1)))
                        
(defun compute-allgenls-from-direct-genls (entry cache)
  ;;; Used when the allgenls have already been computed for the
  ;;; direct genls.
  (let* ((direct-genls (retrieve-genls-entries entry cache)))
    (cond ((null direct-genls) ;; We got a root.
           (setf (depth entry) 0)
           (setf (the-allgenls entry) nil)
           entry)
          ((or (some #'(lambda (entry) (eq (the-allgenls entry) :unknown)) direct-genls)
               (some #'(lambda (entry) (= (depth entry) -1)) direct-genls))
           ;; Really paranoid, but this is important.
           (error "Genls cache integrity violation in genls of ~A." entry))
          (t (setf (depth entry) (1+ (apply 'min (mapcar 'depth direct-genls))))
             (setf (the-allgenls entry) (merge-allgenls-lists entry
                                         (mapcar 'allgenls-or-nada direct-genls)))
             (setf (the-allgenls entry) (sort (the-allgenls entry) '> :key 'depth))
             entry))))

(defun gather-collections-upwards (entry cache)
  (do ((queue (retrieve-genls (predicate entry) cache)
              (append (cdr queue) new))
       (new nil nil)
       (above-entry nil)
       (above nil))
      ((null queue) (delete entry above)) ;; Avoid being screwed by cycles
    (setq above-entry (get-or-create-cache-entry (car queue) cache))
    (unless (member above-entry above)
      (push above-entry above)
      (setq new (retrieve-genls (car queue) cache)))))

(defun all-direct-genls-allgenls-known? (entry)
  (let ((cache (cache entry)))
    (every #'(lambda (x) (not (eq (the-allgenls (genls-cache-entry x cache))
                                  :unknown)))
           (retrieve-genls (predicate entry) cache))))

(defun find-unknown-allgenls-fringe (subset cache)
  (let ((fringe nil))
    (dolist (entry subset fringe)
      ;; Make sure roots are treated appropriately
      (when (and (null (retrieve-genls (predicate entry) cache))
                 (eq (the-allgenls entry) :unknown))
        (setf (depth entry) 0) ;; Got root
        (setf (the-allgenls entry) nil))
      ;; See if you're known, but one of your subs isn't.
      (when (and (not (eq (the-allgenls entry) :unknown))
                 (some #'(lambda (sub) (eq (the-allgenls sub) :unknown))
                       (subset-entries-for-predicates 
                        (retrieve-subs (predicate entry) cache) subset cache)))
        (pushnew entry fringe)))))

(defun subset-entries-for-predicates (predicates subset-of-entries cache)
  (let ((result nil))
    (dolist (predicate predicates result)
      (when (member predicate subset-of-entries
                    :test #'(lambda (pred entry)
                              (equal pred (predicate entry))))
        (push (genls-cache-entry predicate cache) result)))))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (proclaim '(special ****nodes-touched-during-allgenls-sweep****)))

(defun update-allgenls-downward (fringe subset cache)
  "Updates allgenls in SUBSET, starting from FRINGE, in CACHE."
  ;;; The fringe is the "highest" part of subset whose allgenls have not already
  ;;; been computed.  This procedure organizes the march downward exhaustively
  ;;; through SUBSET, ensuring that the allgenls are completely up-to-date.
  ;;; This is really subtle, so we walk down from each element of fringe,
  ;;; keeping track of our path along the way to avoid getting caught in loops.
  ;;; The depth we keep when reaching a node is the smallest depth we find, but
  ;;; we always merge our path so far because otherwise stuff gets left out.
  ;;; Tried to find a way to only update each node once, but with genls loops
  ;;; that simply isn't possible.
  (dolist (start fringe)
    (dolist (sub (retrieve-subset-entries start cache))
      (when (member sub subset)
        (walk-downward-allgenls sub (list start) (depth start) subset cache)))))

(defun walk-downward-allgenls (current path depth subset cache)
  (let* ((current-genls (retrieve-genls-entries current cache))
         (old-depth (depth current))
         (proposed-allgenls    ;; Merge them all, being very careful
          (merge-allgenls-lists current
                                (delete :unknown ;; Not all may be known yet.
                                        (cons (the-allgenls current)
                                              (mapcar 'allgenls-or-nada current-genls)))))
         (update-needed? (not (same-elements? 
                               (the-allgenls current) proposed-allgenls))))
    ;; [Aside: Somewhat similar to weave step in ATMS label propagation.]
    (when update-needed? (setf (the-allgenls current) proposed-allgenls))
    (if (or (= old-depth -1) ;; Uninitialized
            (< depth old-depth)) ;; got a closer path to root, so replace
      (setf (depth current) depth))
;;;  Leftover from gory debugging session.
;;;    (unless (member current subset)
;;;      (format t "~%WDG: ~D, ~A (~D), |path| = ~D"
;;;        depth current (depth current) (length path))
;;;      (break))
    (pushnew current ****nodes-touched-during-allgenls-sweep****)
    ;; Now we recurse, possibly
    (when update-needed?
      (let ((new-path (cons current path)))
        (dolist (sub (retrieve-subset-entries current cache))
          (cond ;; ((member sub new-path)) ;; Skip, already seen
           ;; Commented out the above on the theory that when there are cycles, one does
           ;; have to revisit them -- otherwise stuff on the loop isn't included.  Can this loop
           ;; infinitely?  No, because at some point, all of the branch points will have been gone
           ;; through, and we'll detect that because nothing new is added via the update.
                ((not (member sub subset))) ;; Outside of upward projection of start collection
                (t (walk-downward-allgenls sub new-path (1+ depth) subset cache))))))))
   
(defun same-elements? (list1 list2 &key (test 'eql))
  (unless (and (listp list1)
               (listp list2)
               (= (length list1) (length list2)))
    (return-from same-elements? (values nil)))
  (every #'(lambda (el1) (member el1 list2 :test test)) list1))
                                       
(defun allgenls-or-nada (entry)
  (cond ((eq (the-allgenls entry) :unknown) :unknown)
        (t (if (member entry (the-allgenls entry))
             (the-allgenls entry)
             (cons entry (the-allgenls entry))))))

(defun merge-allgenls-lists (current list-of-gces)
  (let ((result nil))
    ;; Not worth doing much here, given that we're going to re-sort
    ;; them all later anyway.  So just make sure they're unique.
    ;; Given that there are loops, the collection itself can show up in
    ;; the list.  We ensure here that it isn't there.
    (setq result (copy-list (car list-of-gces)))
    (dolist (other-list (cdr list-of-gces) (delete current result))
      (dolist (gce other-list) (pushnew gce result)))))
           
(defun ancestors-ready? (genls-entries)
  (every #'(lambda (entry) (not (eq (the-allgenls entry) :unknown)))
         genls-entries))



;;; TEST FUNCTIONS
;;; ----------------------------------------------------------------------------
(defvar *test-direct-genls-cache* nil)

(defun show-allgenls (cache &optional (stream *standard-output*))
  (maphash #'(lambda (pred entry)
               (format stream "~% ~A = ~A." pred (allgenls entry)))
           (table cache)))
 
(defun compute-all-subsets (entry)
  ;; This is probably very infrequently asked, so we only generate it
  ;; on demand.
  (when (not (eq (the-allsubsets entry) :unknown))
    (return-from compute-all-subsets
      (values (the-allsubsets entry))))
  ;; Need to compute it
  (do ((queue (retrieve-subset-entries entry (cache entry))
              (nconc (cdr queue) new-subsets))
       (allsubsets nil)
       (sub nil)
       (new-subsets nil nil))
      ((null queue)
       (setf (the-allsubsets entry) allsubsets)
       allsubsets)
    (setq sub (car queue))
    (unless (member sub allsubsets)
      (setq allsubsets
            (merge 'list (list sub) allsubsets '< :key 'depth))
      (dolist (new (retrieve-subset-entries sub (cache sub)))
        (push new new-subsets)))))

;;;; ---------------------------------------------------------------------------
;;; Display routines

(defun show-genls-cache (&optional (*kb* *kb*))
  (maphash #'(lambda (k v)
               (format t "~%~:@(~A~)~{~%   ~A~}~%" k (the-allgenls v)))
           (table (genls-cache *kb*))))

(defun genls-cache-stats (&key (kb *kb*)
                               (stream *standard-output*))
  (let ((cache (genls-cache kb)))
    (cond ((not (genls-cache? cache))
           (format stream "%No genls cache for ~A." kb))
          (t (format stream "~%For KB ~A:" kb)
             (format stream "~%  ~A entries in genls."
               (hash-table-count (direct-genls cache)))
             (format stream "~%  ~A entries in subs"
               (hash-table-count (direct-subs cache)))
             (let ((max-genls 0)
                   (min-genls 1000000)
                   (sum-genls 0)
                   (max-allgenls 0)
                   (min-allgenls 10000000)
                   (sum-allgenls 0)
                   (total 0))
               (maphash #'(lambda (key entry)
                            (declare (ignore key))
                            (let ((this (length
                                         (retrieve-genls 
                                          (predicate entry) cache)))) 
                              (incf sum-genls this)
                              (if (< this min-genls) (setq min-genls this))
                              (if (> this max-genls) (setq max-genls this))
                              (unless (eq (the-allgenls entry) :unknown)
                                (setq this (length (the-allgenls entry)))
                                (incf sum-allgenls this)
                                (if (< this min-allgenls) (setq min-allgenls this))
                                (if (> this max-allgenls) (setq max-allgenls this)))
                              (incf total)))
                        (table cache))
               (format stream "~%  ~D entries in table." total)
               (unless (= total 0)
                 (format stream "~% genls: min = ~D, max = ~D, mean = ~D"
                   min-genls max-genls (/ (float sum-genls) total))
                 (format stream "~% allgenls: min = ~D, max = ~D, mean = ~D"
                   min-allgenls max-allgenls (/ (float sum-allgenls) total))))))))

(eval-when (:load-toplevel :compile-toplevel)
  (proclaim '(special cl-user::c cl-user::e)))

(defun allgenls-stub ()
  ;; Assumes QRG-DARPA KB is open already
  (reset-genls-cache)
  (mark-genls-cache-files-stale *kb*)
  (compute-genls-cache *kb*)
  (setq cl-user::c (genls-cache *kb*))
  (setq cl-user::e (genls-cache-entry 'cl-user::Person
                                      cl-user::c)))

(defun allgenls-the-hard-way (predicate &optional (kb *kb*))
  (let ((allgenls nil)
        (cache (genls-cache kb)))
    (do ((queue (copy-list (retrieve-genls predicate cache))
                (nconc (cdr queue) new))
         (new nil nil))
        ((null queue) (delete predicate allgenls :test 'equal))
      (cond ((member (car queue) allgenls :test 'equal))
            (t (push (car queue) allgenls)
               (let ((these-genls (retrieve-genls (car queue) cache)))
                 (dolist (genl these-genls)
                   (unless (or (member genl queue :test 'equal)
                               (member genl allgenls :test 'equal))
                     (push genl new)))))))))

(eval-when (:load-toplevel :compile-toplevel :execute)
  ;; Globals for debugging
  (proclaim '(special cl-user::col cl-user::all-hard cl-user::all-cache cl-user::c)))

(defun stress-test-genls-cache (&optional (kb *kb*)
                                          (stream *standard-output*))
  (let ((losers nil)
        (min-cache-time 10000.0)
        (max-cache-time 0)
        (sum-cache-time 0.0)
        (min-hard-time 1.0e24)
        (max-hard-time 0.0)
        (sum-hard-time 0.0)
        (n-collections 0)
        (time-scale (float internal-time-units-per-second)))
    (map-collections #'(lambda (col)
                         (let* ((start-cache-time (get-internal-real-time))
                                (allgenls-cache (fire::all-genls col))
                                (cache-time (/ (- (get-internal-real-time) start-cache-time)
                                               time-scale))
                                (start-hard-time (get-internal-real-time))
                                (allgenls-hard (fire::allgenls-the-hard-way col))
                                (hard-time (/ (- (get-internal-real-time) start-hard-time)
                                              time-scale)))
                           (incf n-collections)
                           (incf sum-cache-time cache-time)
                           (incf sum-hard-time hard-time)
                           (if (> hard-time max-hard-time) (setq max-hard-time hard-time))
                           (if (< hard-time min-hard-time) (setq min-hard-time hard-time))
                           (if (> cache-time max-cache-time) (setq max-cache-time cache-time))
                           (if (< cache-time min-cache-time) (setq min-cache-time cache-time))
                           (unless (same-elements? allgenls-cache allgenls-hard
                                                   :test 'equal)
                             (format stream "~% Bug: ~A, ~D versus ~D." 
                               col (length allgenls-cache) (length allgenls-hard))
                             (setq cl-user::col col cl-user::all-hard allgenls-hard
                                 cl-user::all-cache allgenls-cache cl-user::c (genls-cache kb))
                             (break)
                             (push (list col allgenls-cache allgenls-hard) losers)))))
    (format stream "~%Genls cache test for ~A:" kb)
    (format stream "~% ~D collections, ~D discrepancies found." n-collections (length losers))
    (format stream "~% Hard way: Min = ~D, Max = ~D, Mean = ~D." 
      min-hard-time max-hard-time (/ sum-hard-time (float n-collections)))
    (format stream "~%    Cache: Min = ~D, Max = ~D, Mean = ~D." 
      min-cache-time max-cache-time (/ sum-cache-time (float n-collections)))
    losers))


(defun list-genls-unit-cycles (&optional (kb *kb*))
  (let ((cache (genls-cache kb))
        (unit-cycles nil))
    (map-collections #'(lambda (col)
                         (dolist (genl (retrieve-genls col cache))
                           (when (member col (retrieve-genls genl cache)
                                         :test 'equal)
                             (let ((entry (if (ltre::alphalessp genl col) (list genl col)
                                            (list col genl))))
                               (pushnew entry unit-cycles :test 'equal))))))
    unit-cycles))

(defun list-silly-cycles (&optional (kb *kb*))
  ;; Unit cycle not connected to anything else!
  ;; Two of them in material extracted from Cyc in pre-midterm-eval Kraken:
;;;  (((SubcollectionOfWithRelationToTypeFn Accident damages
;;;   TransportationDevice-Vehicle)
;;;  VehicleAccident)
;;; ((SubcollectionOfWithRelationToTypeFn Accident damages Automobile)
;;;  CarAccident))
  (let ((cache (genls-cache kb))
        (silly-cycles nil))
    (map-collections #'(lambda (col)
                         (when (= (length (retrieve-genls col cache)) 1)
                           (dolist (genl (retrieve-genls col cache))
                             (let ((these-genls (retrieve-genls genl cache)))
                               (when (= (length these-genls) 1)
                                 (when (member col these-genls
                                               :test 'equal)
                                   (let ((entry (if (ltre::alphalessp genl col) (list genl col)
                                                  (list col genl))))
                                     (pushnew entry silly-cycles :test 'equal)))))))))
    silly-cycles))

                           
;;;; Statistics from the above
;; Some interesting things to notice:
;; 1. The average case for the two algorithms the first time is surprisingly close.
;;    The max times are quite different, though.
;; 2. As expected, running it again without clearing gives a decided advantage to
;;    caching -- roughly an order of magnitude speed-up. 
;; 3. Surprisingly, there is some speedup in the brute-force algorithm as well. 
;;    GC artifact?  Disk caching in W2000?  Running it a third and fourth time drop it
;;    just a touch further, which makes me suspect disk caching.
;;;(time (fire::stress-test-genls-cache))
;;;
;;;Genls cache test for <KB: c:\qrg\FIRE\KBs\QRG-DARPA\QRG-DARPA:open:-1>:
;;; 16952 collections, 0 discrepancies found.
;;; Hard way: Min = 0.0, Max = 9.704, Mean = 7.005072e-4.
;;;    Cache: Min = 0.0, Max = 0.359, Mean = 5.784554e-4.
;;;; cpu time (non-gc) 10,876 msec user, 31 msec system
;;;; cpu time (gc)     12,264 msec user, 0 msec system
;;;; cpu time (total)  23,140 msec user, 31 msec system
;;;; real time  23,314 msec
;;;; space allocation:
;;;;  4,824,787 cons cells, 7,192,416 other bytes, 2808 static bytes
;;;nil
;;;cl-user(321): (time (fire::stress-test-genls-cache))
;;;
;;;Genls cache test for <KB: c:\qrg\FIRE\KBs\QRG-DARPA\QRG-DARPA:open:-1>:
;;; 16952 collections, 0 discrepancies found.
;;; Hard way: Min = 0.0, Max = 0.313, Mean = 1.6245885e-4.
;;;    Cache: Min = 0.0, Max = 0.016, Mean = 1.5632375e-5.
;;;; cpu time (non-gc) 3,548 msec user, 31 msec system
;;;; cpu time (gc)     858 msec user, 0 msec system
;;;; cpu time (total)  4,406 msec user, 31 msec system
;;;; real time  4,516 msec
;;;; space allocation:
;;;;  1,302,376 cons cells, 4,908,152 other bytes, 3384 static bytes




;;;; ---------------------------------------------------------------------------
;;; END OF CODE