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

(in-package 'tms)

"(c) Copyright 1986, 1987, 1988, 1989, 1990, 1991 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 free-node? (node)
  (do ((free-node *free-nodes* (n-a-datum free-node)))
      ((null free-node) nil)
    (if (eq node free-node) (return T))))

(defconstant *structures-are-sequences* (typep (make-node) 'SEQUENCE))

;;; This is worth doing to stop having to update the label.
(defun reclaim-node (node)
  (when (and *reclaim-flag*
	     (eq (n-a-datum node) *temp-node-datum*)
	     (null (n-a-contradictory node))
	     (null (n-a-consequents node)))
    (dolist (e (n-a-envs node)) (setf (env-nodes e) (fdelq1 node (env-nodes e))))
    (setf (n-a-envs node) nil)
    (dolist (j (n-a-justifications node))
      (dolist (supporter (cdr j))
	(do ((cnsqnts (n-a-consequents supporter) (cdr cnsqnts))
	     (previous nil cnsqnts))
	    ((null cnsqnts))
	  (when (eq node (cnsqnt-result (car cnsqnts)))
	    (if previous
		(rplacd previous (cdr cnsqnts))
		(setf (n-a-consequents supporter) (cdr cnsqnts)))
	    (return nil)))))
    ;; For most systems it turns out to be much much more efficient to GC these ourselves.
    ;; This difference is only noticable on big problems.
    (cond (*structures-are-sequences* (fill node nil :start 1))
	  (t (setf (n-a-consequents node) nil
		   (n-a-unique node) nil
		   (n-a-envs node) nil
		   (n-a-contradictory node) nil
		   (n-a-justifications node) nil
		   (n-a-enqueued? node) nil
		   (n-a-justification-consumers node) nil
		   (n-a-env-consumers node) nil
		   (n-a-consumers node) nil
		   (n-a-status node) nil
		   (n-a-classes node) nil
		   (node-assumption node) nil
		   (node-negation node) nil
		   (node-unique-conditional node) nil)))
    (setf (n-a-datum node) *free-nodes*)
    (setq *free-nodes* node)
    'DONE
    ))

;;; This assumes everything is being reset.
(defun nuke-assumption (assumption)
  (cond (*structures-are-sequences* (fill assumption nil :start 1))
	(t (error "Unimplemented")))
  (setf (assumption-datum assumption) *free-assumptions*)
  (setq *free-assumptions* assumption)
  'DONE)

;;; Managing assumption storage ourselves improves performance on most Lisps.

(defun internal-make-assumption (unique variable value datum status gc-status &aux assumption)
  (cond (*free-assumptions*
	 (setq assumption *free-assumptions*
	       *free-assumptions* (assumption-datum assumption))
	 (setf (assumption-unique assumption) unique)
	 (setf (assumption-variable assumption) variable)
	 (setf (assumption-value assumption) value)
	 (setf (assumption-datum assumption) datum)
	 (setf (assumption-status assumption) status)
	 (setf (assumption-gc-status assumption) gc-status)
	 (setf (assumption-nbits assumption) 0)
	 ;;***** NOt right.
	 (setf (name-symbol-name-symbol assumption) 'ASSUMPTION)


	 )

	(t (setq assumption (make-assumption :UNIQUE unique
					     :VARIABLE variable
					     :VALUE value
					     :DATUM datum
					     :STATUS status
					     :GC-STATUS gc-status
					     :COUNT 0
					     :NBITS 0
					     #-(or :zl :cl-zl) :NAME-SYMBOL
					     #-(or :zl :cl-zl) 'ASSUMPTION))))
  (push assumption *assumptions*)
  (assure-assumption-size)
  assumption)

(defun internal-create-node (datum &aux node)
  (cond (*free-nodes*
	 (setq node *free-nodes* *free-nodes* (n-a-datum node))
	 (setf (n-a-datum node) datum
	       (n-a-unique node) (incf *node-counter*)
	       (n-a-status node) 'OUT
	       (n-a-nbits node) 0
	       ))
	(t 
;;; The Symbolics make-node is a piece of shit and sets each slot enough times to show
;;; up on the profiler.
;; Really, this should be + (CL-ZL ZL) on first set. CL on second.*****
#+Symbolics (setq node (make-array #.*node-size* :named-structure-symbol 'NODE))
#+Symbolics (setf (n-a-datum node) datum
		  (n-a-unique node) (incf *node-counter*)
		  (n-a-status node) 'OUT
		  (n-a-nbits node) 0
;; In CL-ZL remove this next line.
		  (name-symbol-name-symbol node) 'NODE)
#-Symbolics (setq node (make-node :DATUM datum
				  :UNIQUE (incf *node-counter*)
				  :STATUS 'OUT
				  :NAME-SYMBOL 'NODE))
            (push node *nodes*)))
  node)