;;; -*- Syntax:Common-Lisp; Mode: LISP; Package: (TMS Lisp 1000.); Base: 10. -*-

(in-package 'tms)

"(c) Copyright 1986, 1987, 1988 Xerox Corporation.  All rights reserved.  Subject to
the following conditions, permission is granted to use and copy this
software and to prepare derivative works:  Such use, copying or
preparation of derivative works must be for non-commercial research or
educational purposes; each copy or derivative work must include this
copyright notice in full; a copy of each completed derivative work must
be returned to:  DEKLEER@XEROX.COM (Arpanet) or Johan de Kleer,
Xerox PARC, 3333 Coyote Hill Road, Palo Alto, CA 94304.  This software
is made available AS IS, and Xerox Corporation makes no warranty about
the software or its performance."

(defun walk-tree (function tree)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (if tree (walk-tree-1 function tree)))

(defun walk-tree-1 (function tree)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (cond ((atom tree) (funcall function tree))
	((dolist (entry tree) (walk-tree-1 function (cdr entry))))))
  
(defun count-tree (tree &aux (result 0))
  (walk-tree #'(lambda (ignore)
		 #+Symbolics
		 (declare (sys:downward-function))
		 (incf result))
	     tree)
  result)

;;; Allowable-misses is the number of assumptions we can pass not contained in
;;; the assumption set.
;;; Returns T if current tree is completely deleted.
(defun subsumed-tree (function allowable-misses as tree &aux au)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (cond ((null as) (walk-tree-1 function tree) T)
	((= 0 allowable-misses) (subsumed-tree-remove as tree function))
	(t (setq au (assumption-unique (car as)))
	   (do ((subtree tree)
		(delete nil)
		(entry nil)
		(previous nil))
	       ((null subtree))
	     (setq entry (car subtree))
	     ;; If the tree contains exactly the next assumption in order, we're golden.
	     (cond ((= au (car entry))
		    (setq delete
			  (subsumed-tree function allowable-misses (cdr as) (cdr entry))))
		   ;; We MUST find the assumption, or else things are pointless.
		   ;; Unique-id's goes down within the tree, so abort if we've gone too far.
		   ;; Wish tree were sorted for this ...
		   ((< (car entry) au))
		   ;; Take the current tree assumption as a miss, keep on looking.
		   (t (setq delete
			    (subsumed-tree function (1- allowable-misses)
					   as (cdr entry)))))
	     (cond (delete (cond ((null (cdr tree)) (return T))
				 (previous (rplacd previous (cdr subtree))
					   (setq subtree (cdr subtree)))
				 (t (rplaca subtree (cadr subtree))
				    (rplacd subtree (cddr subtree))))
			   (setq delete nil))
		   (t (setq previous subtree subtree (cdr subtree))))))))

(defun subsumed-tree-remove (as tree function &aux au)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (setq au (assumption-unique (car as)))
  (do ((subtree tree (cdr subtree))
       (previous nil subtree))
      ((null subtree) nil)
    (cond ((not (= au (caar subtree))))
	  ((or (when (not (listp (cdar subtree)))
		 (funcall function (cdar subtree))
		 T)
	       (subsumed-tree-remove (cdr as) (cdar subtree) function))
	   ;; Delete this subtree, except if its the only one.
	   (cond ((null (cdr tree)) (return T))
		 (previous (rplacd previous (cdr subtree)))
		 (t (rplaca subtree (cadr subtree))
		    (rplacd subtree (cddr subtree))))
	   (return nil))
	  (t (return nil)))))

;;; Note that there is an overriding assumption here that the set of
;;; assumptions are stored in order: descending unique-id's.

;;; ASSQ= or something whihc uses unique-ids'  Put unique-ids only in tree is
;;; probably faster anywyay???

;;; This can be cleverer by going down both simultaneously.
;;; Tree always looks like either a singleton env or a list of (<assumption> . tree)
;;; This has the built-in assumption everything is of the same length.

;;; This is somewhat bummed.
(defun subsumed-by-tree-1 (allowable-misses as tree &aux slot)
  (if (= 0 allowable-misses)
      ;; This changes into a straight lookup, if list runs out we succeeded.
      (dolist (a as)
	(or a (throw 'SUBSUMED tree))
	(unless (setq slot (assq a tree)) (return nil))
	(setq tree (cdr slot)))
      (subsumed-by-tree-3 allowable-misses as tree)))

(defun subsumed-by-tree-3 (allowable-misses as tree &aux slot)
  (dolist (entry tree)
    (do* ((as as (cdr as))
	  (allowable-misses allowable-misses (1- allowable-misses)))
	 ((= allowable-misses 0)
	  (when (= (car as) (car entry))
	    (setq tree (cdr entry))
	    (dolist (a (cdr as))
	      (or a (throw 'SUBSUMED tree))
	      (unless (setq slot (assq a tree)) (return nil))
	      (setq tree (cdr slot)))))
      (when (= (car entry) (car as))
	(unless (listp (cdr entry)) (throw 'SUBSUMED (cdr entry)))
	(subsumed-by-tree-1 allowable-misses (cdr as) (cdr entry))
	(return nil))
      (when (> (car entry) (car as))
	(return nil)))))

;;; Exactly like subsumed-by-tree-1 except that we know (- as a) itself is known to be
;;; not subsumed by the tree.  Therefore anything we look at must have a in it.
(defun subsumed-by-tree-2 (allowable-misses a as tree &aux slot it)
  (cond ((= 0 allowable-misses)
	 ;; This changes into a straight lookup.
	 (do nil (nil)
	   (unless (setq slot (assq (assumption-unique (car as)) tree)) (return nil))
	   (unless (listp (setq tree (cdr slot))) (return tree))
	   (unless (setq as (cdr as)) (error "Bad tree"))))
	(t (dolist (entry tree)
	     (do ((as as (cdr as))
		  (au)
		  (allowable-misses allowable-misses (1- allowable-misses)))
		 (nil)
	       (setq au (assumption-unique (car as)))
	       (when (= au (car entry))
		 (if (listp (cdr entry))
		     (if (setq it
			       (subsumed-by-tree-2 allowable-misses
						   (and a (not (= au a)) a)
						   (cdr as)
						   (cdr entry)))
			 (return-from SUBSUMED-BY-TREE-2 it)
			 ;; This strikes me as a bug as there might***
			 (return nil))
		     (return-from SUBSUMED-BY-TREE-2 (cdr entry))))
	       (when (> (car entry) au)
		 (return nil))
	       ;; **** Is this right---maybe a should be in it.
	       (if (eql au a) (return nil))
	       (if (= 0 allowable-misses) (return nil))
	       )))))

;;; Convert a list into a descrimination net.  (This assumes assumptions are ordered!?).
(defun tree-envs (l &aux tree)
  (when l
    (setq tree (insert-tree (car l) tree))
    (dolist (e (cdr l)) (insert-tree e tree)))
  tree)

;;; ASSQ is fast, but if there are lots of assumptios in the list we can do
;;; order it by unique-id.
;;; Remember all entries are of the same length!!

(defun insert-tree (e tree &aux as slot)
  (setq as (env-assumptions e))
  (prog  nil
	 (unless tree (return (build-tree as e)))
    loop (cond ((null (setq slot (assq (assumption-unique (car as)) tree)))
		(setq slot (build-tree as e))
		(rplacd slot (cdr tree))
		(rplacd tree slot)
		(return tree))
	       ((listp (cdr slot))
		(setq tree (cdr slot) as (cdr as))
		(go loop))
	       (t (error "Inserting ~A in tree, but ~A is there"
			 e (cdr slot))))))

(defun build-tree (as e)
  (if (null as) e (ncons (cons (assumption-unique (car as)) (build-tree (cdr as) e)))))

;;; Return T only when tree becomes empty.
;;; Assumes everything is the same length.
(defun remove-tree (e tree)
  (remove-tree-1 (env-assumptions e) tree))	

;;; ASSQ might be faster?***
;;; Returns T if as was the only thing found in the current tree.
(defun remove-tree-1 (as tree &aux au)
  (setq au (assumption-unique (car as)))
  (do ((subtree tree (cdr subtree))
       (previous nil subtree))
      ((null subtree) (error "Env not in tree"))
    (cond ((not (= au (caar subtree))))
	  ((or (not (listp (cdar subtree))) (remove-tree-1 (cdr as) (cdar subtree)))
	   ;; Delete this subtree, except if its the only one.
	   (cond ((null (cdr tree)) (return T))
		 (previous (rplacd previous (cdr subtree)))
		 (t (rplaca subtree (cadr subtree))
		    (rplacd subtree (cddr subtree))))
	   (return nil))
	  (t (return nil)))))



;;; Return all the environments in the tree.
(defun collect-tree (tree &aux result)
  (walk-tree #'(lambda (env)
		 #+Symbolics
		 (declare (sys:downward-function))
		 (push env result))
	     tree)
  result)

(defvar *result*)

;;; This is purely experimental.

;;; Exactly like subsumed-by-tree-2 except that the tree contains *ALL* sizes
;;; of environments/nogoods.  Each element of the tree looks like
;;; tree = nogood | ((assumption minimal-assumptions . tree) ...)

;;; This is a faster way of implementing the naive version.  Sorry for the bad Lisp.
(defun subsumed-by-tree-4 (size a as tree &aux au current-index)
  (prog nil
   loop (or tree (return nil))
        (when (> (cadar tree) size) (setq tree (cdr tree)) (go loop))
	(setq current-index (caar tree))
	(cond ((null (cdr tree))
	       (do ((tas as (cdr tas)))
		   (nil)
		 (setq au (car tas))
		 (unless au (return-from SUBSUMED-BY-TREE-4 nil))
		 (cond ((= current-index au)
			(setq tree (cddar tree))
			(unless (listp tree) (throw 'SUBSUMED tree))
			(setq as (cdr tas))
			(unless (car as) (return-from SUBSUMED-BY-TREE-4 nil))
			(and a (not (= au a)) (setq a nil))
			(go loop))
		       ((> current-index au) (return-from SUBSUMED-BY-TREE-4 nil)))))
	      (t (do ((tas as (cdr tas)))
		     (nil)
		   (setq au (car tas))
		   (unless au (return nil))
		   (cond ((= current-index au)
		   ;; We found entry with our next assumption in it.
	       
		   ;; Case 1 : We found an environment, return it as the subsumer.
			  (unless (listp (cddar tree)) (throw 'SUBSUMED (cddar tree)))
		   ;; Case 3 : We recurse.
			  (setq tas (cdr tas))
			  (unless (car tas) (return nil))
			  (subsumed-by-tree-4 size
					      (and a (not (= au a)) a)
					      tas
					      (cddar tree))
			  (return nil))
			 ((> current-index au) (return nil)))
		   (and a (= au a) (return nil)))
		 (setq tree (cdr tree))
		 (go loop)
		 ))))				

(defun walk-extended-tree (function tree)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (if tree (walk-extended-tree-1 function tree)))

(defun walk-extended-tree-1 (function tree)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (cond ((atom tree) (funcall function tree))
	((dolist (entry tree) (walk-extended-tree-1 function (cddr entry))))))

(defun subsumed-by-tree-5 (size a as tree &aux au it)
  (dolist (entry tree)
    ;; Case 2 : Make sure that our size is greater (or equal)**** can we find ourselve,
    ;; if not, we can make this a little faster) than the minimum size nogood.
    ;; As some callers expect to find themselves, this is a ">"
    (unless (> (cadr entry) size)
      (do ((as as (cdr as)))
	  ((null as))
	(setq au (assumption-unique (car as)))
	(cond ((= (car entry) au)
	       ;; We found entry with our next assumption in it.
	       
	       ;; Case 1 : We found an environment, return it as the subsumer.
	       (unless (listp (cddr entry)) (return-from SUBSUMED-BY-TREE-5 (cddr entry)))

	       ;; Case 3 : We recurse.
	       (if (setq it (subsumed-by-tree-5 size
						(and a (not (= au a)) a)
						(cdr as)
						(cddr entry)))
		   (return-from SUBSUMED-BY-TREE-5 it)
		   (return nil)))
	      ((> (car entry) au) (return nil)))
	(and a (= au a) (return nil))))))

(defun insert-tree-4 (e tree as &aux slot)
  (prog nil
	(unless tree (return (build-tree-4 as e)))
   loop (cond ((null (setq slot (assq (assumption-unique (car as)) tree)))
	       (setq slot (build-tree-4 as e))
	       (rplacd slot (cdr tree))
	       (rplacd tree slot)
	       (return tree))
	      ((not (listp (cddr slot)))
	       (error "Inserting ~A in tree, but ~A is there"
		      e (cddr slot)))
	      ((cdr as)
	       ;; Update minimum on this branch if necessary:
	       (if (> (cadr slot) (env-count e)) (rplaca (cdr slot) (env-count e)))
	       (setq tree (cddr slot) as (cdr as))
	       (go loop))
	      (t (format T "~% Removing ~A for ~A" (cddr slot) e)
		 (rplacd (cdr slot) e)
		 (rplaca (cdr slot) (env-count e))
		 (return tree)))))

;;; Returns T if current tree is completely deleted.
;;; Probably in this representation we should have minimum nogood down this branch
;;; stored too.  This has the bug that it removes itself from the tree.
(defun subsumed-tree-4 (function as tree &aux au)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (cond ((null as) (walk-tree-4 function tree) T)
	((atom tree) nil)
	(t (setq au (assumption-unique (car as)))
	   (do ((subtree tree)
		(delete nil)
		(entry nil)
		(previous nil))
	       ((null subtree))
	     (setq entry (car subtree))
	     ;; If the tree contains exactly the next assumption in order, we're golden.
	     (cond ((= au (car entry))
		    (setq delete
			  (subsumed-tree-4 function (cdr as) (cddr entry))))
		   ;; We MUST find the assumption, or else things are pointless.
		   ;; Unique-id's goes down within the tree, so abort if we've gone too far.
		   ;; Wish tree were sorted for this ...
		   ((< (car entry) au))
		   ;; Take the current tree assumption as a miss, keep on looking.
		   (t (setq delete
			    (subsumed-tree-4 function as (cddr entry)))))
	     (cond (delete (cond ((null (cdr tree)) (return T))
				 (previous (rplacd previous (cdr subtree))
					   (setq subtree (cdr subtree)))
				 (t (rplaca subtree (cadr subtree))
				    (rplacd subtree (cddr subtree))))
			   (setq delete nil))
		   (t (setq previous subtree subtree (cdr subtree))))))))

;;; If we knew the minimum nogood down this branch, we could ignore some branches.
(defun walk-tree-4 (function tree)
  #+Symbolics
  (declare (sys:downward-funarg function))
  (cond ((atom tree) (funcall function tree))
	((dolist (entry tree) (walk-tree-4 function (cddr entry))))))

(defun build-tree-4 (as e)
  (if (null as) e (ncons (cons (assumption-unique (car as))
			       (cons (env-count e)
				     (build-tree-4 (cdr as) e))))))

;(defun convert-nogoods ()
;  (setq *convert* nil)
;  (do ((i 3 (1+ i)))
;      ((> i *max-contra-count*))
;    (walk-tree #'(lambda (env)
;		   (if *convert*
;		       (insert-tree-4 env *convert*)
;		       (setq *convert* (insert-tree-4 env nil))))
;	       (aref *nogood-trees* i))))

;;; Pure diagnostics.
(defun testr (allowable-misses as tree &aux *result*)
  (find-supersets-in-tree allowable-misses as tree)
  *result*)

(defun qwalk (tree)
  (if (listp tree) (dolist (entry tree) (qwalk (cdr entry))) (push tree *result*)))

(defun find-supersets-in-tree (allowable-misses as tree &aux slot)
  (cond ((null as) (qwalk tree))
	((= 0 allowable-misses)
	 ;; This changes into a straight lookup.
	 (do nil (nil)
	   (unless (setq slot (assq (assumption-unique (car as)) tree)) (return nil))
	   (unless (listp (setq tree (cdr slot))) (push tree *result*) (return tree))
	   (unless (setq as (cdr as)) (error "Bad tree"))))
	(t (dolist (entry tree)
	           ;; If the tree contains exactly the next assumption in order, we're golden.
	     (cond ((= (assumption-unique (car as)) (car entry))
		    (find-supersets-in-tree allowable-misses (cdr as) (cdr entry)))
		   ;; We MUST find the assumption, or else things are pointless.
		   ;; Unique-id's goes down within the tree, so abort if we've gone too far.
		   ;; Wish tree were sorted for this ...
		   ((< (car entry) (assumption-unique (car as))))
		   ;; Take the current tree assumption as a miss, keep on looking.
		   (t (find-supersets-in-tree (1- allowable-misses) as (cdr entry))))))))