;;;; FILE: README
;;;; KM - The Knowledge Machine - Build Date:  Sun Apr 30 21:51:35 PDT 2006
#|======================================================================
	 KM - THE KNOWLEDGE MACHINE - INFERENCE ENGINE 2.0.29
======================================================================
Copyright (C) 1994-2006 Peter Clark and Bruce Porter

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

Contact information:
Peter Clark and Bruce Porter, m/s C0500, Dept Computer Science, 
Univ Texas at Austin, Austin, TX 78712, USA. {pclark,porter}@cs.utexas.edu

If you would like a copy of this software issued under a different license
(e.g., with different redistribution conditions) please contact the authors.

A copy of the GNU Lesser General Public Licence can be found at the end of 
this file (or in the file LICENCE if disassembled into its constitutent 
files), or by typing (license) at the Lisp or KM prompts when running KM.

======================================================================

The source code, manuals, and a test suite of examples for the most
recent version of KM are available at 

	http://www.cs.utexas.edu/users/mfkb/km/

Check this site for RELEASE NOTES and the CURRENT VERSION of KM.

======================================================================
		USING THIS FILE:
======================================================================

Save this file as (say) km.lisp, then load it into your favorite Lisp 
environment:
	% lisp
	> (load "km")

For greatly increased efficiency, make a compiled version of this file:
	% lisp
	> (compile-file "km")
	> (load "km")		
will load the faster, compiled version in future.

[Note: you no longer need to pre-load km.lisp before compiling, 
 as described in the manual]

To start the query interpreter running, type (km):
	> (km)
	KM> 

See the User Manual and Reference Manual for instructions on using KM,
and building knowledge bases. The manuals are available at:

	http://www.cs.utexas.edu/users/mfkb/km/

======================================================================
		READING/EDITING THE SOURCE:
======================================================================

The following file is a machine-built concatenation of the various files
in the KM inference system. It can be loaded or compiled directly into
Lisp, deconcatenation is not necessary for running KM.

Although you can read/edit the below code all in this one file, it is
very large and unweildy; you may prefer to break it up into the 
(approx 20) constituent files which it comprises. You can break it up
either manually, looking for the ";;; FILE: <file>" headers
below which denote the start of different files in this concatenation,
OR use the Perl unpacker below which automatically cut this big file 
into its consistutent files.

Warning: The code is largely undocumented! 

Peter Clark
pclark@cs.utexas.edu

======================================================================
	DISASSEMBLING THIS CONCATENATION INTO ITS CONSTITUENT FILES:
======================================================================

Note you don't have to disassemble km.lisp to use KM. However, if you
want to read/edit the code, you might find it helpful to break it up into
individual files. 

If you do disassmble the files, then the single file loadme.lisp contains 
(commented out) load commands to load all the other constituent files, for 
your convenience. (Don't forget to uncomment the load commands in this file).

If you don't disassemble the files and just work with km.lisp, then you can 
ignore all of this.

Option 1. (For Emacs users)
[Thanks to Joe Corneli for this piece of code!]

(save-excursion
  (let ((case-fold-search nil))
    (goto-char (point-min))
    (while (re-search-forward "^;;; FILE: +\\(.*\\)" nil t)
      (let* ((matched (match-string 1))
             (beg (match-beginning 0))
             (end (or (save-excursion
                        (when (search-forward-regexp "^;;; FILE: +.*" nil t)
                          (match-beginning 0)))
                      (point-max)))
             (str (buffer-substring beg end)))
          (with-temp-file matched
            (save-excursion (insert str))
            (next-line 1)
; uncomment the below lines if you want KM files to have KM package declaration
;            (insert (concat "(unless (find-package :km) (make-package :km))\n"
;                            "(in-package :km)\n"))
	)))))
             ^ position cursor behind the emacs lisp expression above and
               run M-x eval-last-sexp

Option 2. (For non-Emacs users)
  
  1. cut and paste the short Perl script below to a file, eg called
	"disassemble"
  2. Make sure the first line is
		X!/usr/local/bin/perl
     and edit this path /usr/local/bin/perl as needed to point to the 
	local version of Perl.
  3. Make the file executable:
	% chmod a+x disassemble
  4. Now disassemble km.lisp:
	% disassemble km.lisp

This will populate the current directory with the approx. 20 Lisp files
constituting the KM system.

------------------------------ cut here ------------------------------
X!/usr/local/bin/perl
X Splits file with internal file markers of the form:
X ;;; FILE: <filename>
X into individual files in the current directory.
X Outputs to stdout information about processing.
X require 5.0;
$lineno = 0 ;
if ($XARGV != 0) { die "Usage: $0 filename.";}	X 1 and only 1 arg
$fn = shift(@ARGV);

open(PACKED, "<$fn") XX die "Could not open file $fn\n ";
$_ = <PACKED>; $lineno += 1;	X Read first line, and count it
chop;
($junk, $outfile) = split (/:/);

unless ($junk != /^;;; FILE/o) {
	die "Missing file tag ;;; FILE: Line number $lineno."
}
X Open file for writing

unless (open (OUTFILE, ">$outfile")) {
	die "Could not open file $outfile for writing.";
	}
print "$outfile created\n";
while (<PACKED>) {
	$lineno += 1;
	($junk, $outfile) = split (/:/);
	if ($junk =~ /^;;; FILE/o) {	
		close (OUTFILE);
		chop($outfile);
		unless (open (OUTFILE, ">$outfile")) {
	die "Could not open file $outfile for writing.  Line number $lineno.";
		}
		print "$outfile created\n";
X uncomment the below line if you want KM files to have KM package declaration
X		print (OUTFILE "\n(unless (find-package :km) (make-package :km))\n");
	}
	else {
		print (OUTFILE $_);
	}
}
close(PACKED);
close(OUTFILE);
print "Completed without errors. Processed $lineno lines of input from $fn.\n";
------------------------------ cut here ------------------------------|#
;;;; FILE:  loadme.lisp
;;;; File: loadme.lisp
;;;; Purpose: load all the KM files, if you've disassembled the full KM
;;;; into its constituent files. 
;;;; Usage: Uncomment and load this file to compile and load the individual KM
;;;; files (assumed within the local directory)
;;;; ****NOTE**** You DON'T need to uncomment this part of the code
;;;; if you are simply working with the single file km.lisp. 
#| compile-and-load function
(defun cload (file) (load (user::compile-file-if-needed file :print nil)))

(cload "header")
(cload "htextify")
(cload "case")
(cload "interpreter")
(cload "get-slotvals")
(cload "frame-io")
(cload "trace")
(cload "lazy-unify")
(cload "constraints")
(cload "explain")
(cload "kbutils")
(cload "stack")
(cload "stats")
(cload "sadl")
(cload "anglify")
(cload "writer")
(cload "taxonomy")
(cload "subsumes")
(cload "prototypes")
(cload "think")
(cload "loadkb")
(cload "minimatch")
(cload "utils")
(cload "strings")
(cload "compiler")
(cload "compiled-handlers")
(cload "licence")
(cload "initkb")|#
;;;; FILE:  header.lisp
;;;; File: header.lisp
;;;; Purpose: Set some compilation flags etc.
;;;; Suggestion from Francis Leboutte for improving KM's speed
;;;; NOTE: This is left commented, as some users have requested to not
;;;; have this optimization (with subsequent tradeoffs) imposed on them.
;;;; Uncomment this for a tiny bit more speed, but at loss of some tracing
;;;; info etc.
;;;; (eval-when (:compile-toplevel)
;;;;   (proclaim '(optimize (speed 3) (safety 1) (space 0) (debug 0))))
#|======================================================================
		THE KM PACKAGE
======================================================================
KM is released with two versions 
   (i) without an explicit package definition ([1] below commented out).
       KM will be in which ever package it is loaded into.
  (ii) with an explicit package definition ([1] below uncommented). KM will
       always be in this package.

The variable *km-package* is set to the KM package name that KM is in.|#
;;;; COMMENT THIS OUT FOR THE PACKAGED VERSION OF KM
(TRACE-LISP (DEFVAR *USING-KM-PACKAGE* NIL))
#| ;;; [1] UNCOMMENT THIS FOR PACKAGED VERSION OF KM
(eval-when
 (:compile-toplevel :load-toplevel :execute)
 (unless (find-package :km) (make-package :km)))
(in-package :km)
(defvar *using-km-package* nil)
(setq *using-km-package* t)	; flag used by fastsave-kb|#
;;;; KM package is now the current package
(TRACE-LISP (DEFCONSTANT *KM-PACKAGE* *PACKAGE*))
;;;; ======================================================================
;;;; Personal preference
;;(setq *print-case* :downcase)
;;;; Dispatch mechanism not "compiled" be default, unless 
;;;; compiled-handlers.lisp is included.
(TRACE-LISP (DEFPARAMETER *COMPILE-HANDLERS* NIL))
;;;; ======================================================================
;;;;		DECLARATION OF CONSTANTS
;;;; ======================================================================
;;;; This is really a constant, but I *really* don't want to put the definition
;;;; here! It's setq'ed in interpreter.lisp.
(TRACE-LISP (DEFPARAMETER *KM-HANDLER-ALIST* NIL))
(TRACE-LISP (DEFCONSTANT *VAR-MARKER-CHAR* #\_))
(TRACE-LISP (DEFPARAMETER *VAR-MARKER-STRING* "_"))
(TRACE-LISP (DEFPARAMETER *PROTO-MARKER-STRING* (CONCATENATE 'STRING *VAR-MARKER-STRING* "Proto")))
;; ie. "_Proto"
(TRACE-LISP (DEFPARAMETER *FLUENT-INSTANCE-MARKER-STRING* (CONCATENATE 'STRING *VAR-MARKER-STRING* "Some")))
;; ie. "_Some"
(TRACE-LISP (DEFPARAMETER *KM-VERSION-STR* "2.0.29"))
(TRACE-LISP (DEFPARAMETER *YEAR* "2006"))
(TRACE-LISP (DEFPARAMETER *NEWLINE-STR* (CL-MAKE-STRING 1 :INITIAL-ELEMENT '#\Newline)))
(TRACE-LISP (DEFPARAMETER *KM-HANDLER-FUNCTION* NIL))
;; used in compiler.lisp
;; (defconstant *global-situation* ';$*Global)   ; Put in case.lisp, AFTER ;$ is defined. Note, need ;$ 
;; (defconstant *tag-slot* ';$:tag)		; to allow case-sensitivity to be switched off.
;;;; ------------------------------
;; from prototypes.lisp - move this to AFTER ;$ declaration in case.lisp
;;(defparameter *slots-not-to-clone-for* 
;; ';$(prototype-participant-of prototype-participants prototypes prototype-of ;;source;; instance-of cloned-from))
;;;; --------------------
;;;; Optimization flags: note which bits of machinery are in use.
;;;; --------------------
(TRACE-LISP (DEFPARAMETER *CLASSES-USING-ASSERTIONS-SLOT* NIL))
(TRACE-LISP (DEFPARAMETER *ARE-SOME-DEFINITIONS* NIL))
(TRACE-LISP (DEFPARAMETER *ARE-SOME-PROTOTYPES* NIL))
(TRACE-LISP (DEFPARAMETER *ARE-SOME-SUBSLOTS* NIL))
(TRACE-LISP (DEFPARAMETER *ARE-SOME-CONSTRAINTS* NIL))
(TRACE-LISP (DEFPARAMETER *ARE-SOME-TAGS* NIL))
(TRACE-LISP (DEFPARAMETER *ARE-SOME-DEFAULTS* NIL))
;;;; ======================================================================
;;;;		KM'S PARAMETERS
;;;; ======================================================================
;;;; The following are user-tunable, controlling KM's behavior
;;;; Most of these should never need to be changed by the user. The commented ones would
;;;; never be changed by the user, and are really internal.
(TRACE-LISP
 (DEFPARAMETER *KM-BEHAVIOR-PARAMETERS*
  '(*RECURSIVE-CLASSIFICATION*  *INDIRECT-CLASSIFICATION*  *RECURSIVE-PROTOTYPES*  *EAGERLY-UNIFY-PROTOTYPES*  *SANITY-CHECKS*  *SLOT-CHECKING-ENABLED* 
    *LOGGING*  *MAX-PADDING-INSTANCES*  *TOLERANCE*  *OUTPUT-PRECISION*  *INSTANCE-OF-IS-FLUENT*  *KM-DEPTH-LIMIT*  *LINEAR-PATHS* )))
(TRACE-LISP (DEFPARAMETER *RECURSIVE-CLASSIFICATION* T))
(TRACE-LISP (DEFPARAMETER *INDIRECT-CLASSIFICATION* T))
(TRACE-LISP (DEFPARAMETER *EAGERLY-UNIFY-PROTOTYPES* NIL))
(TRACE-LISP (DEFPARAMETER *RECURSIVE-PROTOTYPES* NIL))
(TRACE-LISP (DEFPARAMETER *SANITY-CHECKS* NIL))
;; see constraints.lisp to toggle these on and off
(TRACE-LISP (DEFPARAMETER *SLOT-CHECKING-ENABLED* NIL))
(TRACE-LISP (DEFPARAMETER *LOGGING* NIL))
(TRACE-LISP (DEFPARAMETER *MAX-PADDING-INSTANCES* 0))
;; [1]
(TRACE-LISP (DEFPARAMETER *TOLERANCE* 1.0E-4))
;; within this means the two numbers are the same
(TRACE-LISP (DEFPARAMETER *OUTPUT-PRECISION* 2))
;; for make-sentence
(TRACE-LISP (DEFPARAMETER *INSTANCE-OF-IS-FLUENT* NIL))
(TRACE-LISP (DEFPARAMETER *KM-DEPTH-LIMIT* NIL))
;; nil = no limit
(TRACE-LISP (DEFPARAMETER *LINEAR-PATHS* NIL))
;; DON'T recognize linear paths any more
(TRACE-LISP (DEFVAR *RECORD-EXPLANATIONS-FOR-CLONES* NIL))
;;;; [1] above: For (at-least n Class) and (exactly n Class) constraints. KM will generate missing
;;;; instances of Class if there are less than n on a slot, unless n > *max-padding-instances*.
;;;; Setting *max-padding-instances* to 0 thus disables this feature.
(TRACE-LISP (DEFCONSTANT *CLASSIFY-IN-LOCAL-SITUATIONS* T))
;; should never need to change
;;;; ----------------------------------------
;;;; The following are run-time state variables, computed automatically by KM
;;;; during KB load and KB execution, which the user doesn't need to set.
;;;; These are the variables that need to be preserved to restore the KM state.
(TRACE-LISP
 (DEFPARAMETER *KM-STATE-PARAMETERS*
  '(*KM-GENSYM-COUNTER* *VISIBLE-THEORIES*  *CURR-PROTOTYPE* *CURR-SITUATION* *CLASSES-USING-ASSERTIONS-SLOT* *ARE-SOME-DEFINITIONS*
    *ARE-SOME-PROTOTYPES* *ARE-SOME-SUBSLOTS* *ARE-SOME-CONSTRAINTS* *ARE-SOME-TAGS* *ARE-SOME-DEFAULTS* *AM-IN-SITUATIONS-MODE*)))
;;;; --------------------
(TRACE-LISP (DEFVAR *CURR-PROTOTYPE* NIL))
;; For prototype mode
(TRACE-LISP (DEFPARAMETER *SHOW-COMMENTS* T))
;; for tracing
(TRACE-LISP (DEFPARAMETER *USE-INHERITANCE* T))
;; Applied in get-slotvals.lisp
(TRACE-LISP (DEFPARAMETER *USE-PROTOTYPES* T))
;; Applied in get-slotvals.lisp
(TRACE-LISP (DEFPARAMETER *USE-NO-INHERITANCE-FLAG* NIL))
;; for Shaken
(TRACE-LISP (DEFVAR *TRACE* T))
;; Tracer is on/off ;; dmiles
(TRACE-LISP (DEFVAR *DEPTH* 0))
;; Tracing depth
(TRACE-LISP (DEFVAR *INTERNAL-LOGGING* NIL))
;; for internal backtracking
(TRACE-LISP (DEFVAR *AM-CLASSIFYING* NIL))
;; Don't classify while classifying
;; (defvar *backtrack-after-testing-unification* nil)   ; Obsolete parameter (always nil), but I'll leave the code there
;;;; New mechanism
(TRACE-LISP (DEFVAR *VISIBLE-THEORIES* NIL))
(TRACE-LISP
 (DEFPARAMETER *SPECIAL-SYMBOL-ALIST* '('"'" #'"#'" (UNQUOTE "#,") (UNQUOTE-SPLICE "#@") (BACKQUOTE "`") (BQ-COMMA ",")  (BQ-COMMA-ATSIGN ",@"))))
;;;; print _Car3 as: _Car3 ;;"a Car&Dog";;
(TRACE-LISP (DEFPARAMETER *ADD-COMMENTS-TO-NAMES* T))
;;;; Allow users to turn this off (to save memory)
(TRACE-LISP (DEFVAR *RECORD-EXPLANATIONS* T))
(TRACE-LISP (DEFPARAMETER *RECORD-SOURCES* T))
;;;; when t, exposes the source info on frame data structures (for debugging purposes)
(TRACE-LISP (DEFPARAMETER *DEVELOPER-MODE* T))
;;; dmiles
;;;; ----------------------------------------
;;;; encapsulate checking flag
(TRACE-LISP (DEFVAR *CHECK-KB* NIL))
(TRACE-LISP (DEFINE CHECKKBON NIL (trace-defun 'CHECKKBON NIL (RET (KM-SETQ '*CHECK-KB* T)))))
(TRACE-LISP (DEFINE CHECKKBOFF NIL (trace-defun 'CHECKKBOFF NIL (RET (KM-SETQ '*CHECK-KB* NIL)))))
(TRACE-LISP (DEFINE CHECKKBP NIL (trace-defun 'CHECKKBP NIL (RET *CHECK-KB*))))
;;;; ======================================================================
;;;;		STATISTICS COUNTERS
;;;; ======================================================================
(TRACE-LISP (DEFVAR *STATISTICS-CLASSIFICATION-INFERENCES* 0))
(TRACE-LISP (DEFVAR *STATISTICS-QUERY-DIRECTED-INFERENCES* 0))
(TRACE-LISP (DEFVAR *STATISTICS-KB-ACCESS* 0))
(TRACE-LISP (DEFVAR *STATISTICS-CPU-TIME* (GET-INTERNAL-RUN-TIME)))
(TRACE-LISP (DEFVAR *STATISTICS-SKOLEMS* 0))
(TRACE-LISP (DEFVAR *STATISTICS-MAX-DEPTH* 0))
(TRACE-LISP (DEFVAR *STATISTICS-UNIFICATIONS* 0))
(TRACE-LISP (DEFVAR *STATISTICS-CLASSIFICATIONS-ATTEMPTED* 0))
(TRACE-LISP (DEFVAR *STATISTICS-CLASSIFICATIONS-SUCCEEDED* 0))
(TRACE-LISP (DEFPARAMETER *USER-DEFINED-INFIX-OPERATORS* NIL))
;;;; Experiment with making them local - doesn't work so well though
(TRACE-LISP (DEFPARAMETER *CLONES-ARE-GLOBAL* T))
;;;; FILE:  htextify.lisp
;;;; File: htextify.lisp
;;;; Author: Peter Clark
;;;; Purpose: Dummy function, to suppress compiler warning.
;;;; This function is referenced but inaccessible in stand-alone KM.
(TRACE-LISP
 (DEFINE HTEXTIFY (CONCEPT &OPTIONAL CONCEPT-PHRASE &REST LKEYS)
  (trace-defun 'HTEXTIFY (CONCEPT CONCEPT-PHRASE LKEYS) (RET (CLET (ACTION WINDOW) (DECLARE (IGNORE CONCEPT CONCEPT-PHRASE ACTION WINDOW)))))))
;;;; FILE:  case.lisp
;;;; File: case.lisp
;;;; Author: Peter Clark
;;;; Purpose: Case-sensitive handling for KM
;;;; ======================================================================
;;;;			READING
;;;; ======================================================================
;;;; Thanks to Brian Mastenbrook for info on the usage of eval-when, which
;;;; avoids pre-loading km.lisp before compiling!
;;;; New version, thanks to Sunil Mishra (SRI)
;;;; This version uses unwind-protect to ensure that the readtable-case gets reset, 
;;;; and cerror to allow resuming km from the entered debugger with a :cont.
;;;; New version, extended to add a ;t construct - thanks to Francis Leboutte
;;;; The ;t construct (dispatch macro-character)
;;;; Francis Leboutte, 20Jul2005
#|Reader macro documentation:
Example:

(km 'X$(every Car has
              (wheel-count (4))
              (parts ((a Engine) (a Chassis)))))

(km 'X$(a Car))

To get the parts of a Car instance, below the various ways to write
the call to km.
Notice:
 in this example, the current package is the "USER" package and the km symbol
 accessible in the "USER" package

1. without using the X$ construct:

(let* ((car-instance
        (first (km '(km::XtheX km::Xall-instancesX km::XofX km::XCarX)))))
  (km `((km::XtheX km::XpartsX km::XofX ,USER::CAR-INSTANCE))))

2. with the X$ construct:

(let ((car-instance (first (km 'X$(the all-instances of Car)))))
  (km `(X$the X$parts X$of ,car-instance)))

3. with the X$ construct, other way
Notice in the second call to km, car-instance must be package qualified
and in majuscules:

(let ((car-instance (first (km 'X$(the all-instances of Car)))))
  (km `X$(the parts of ,USER::CAR-INSTANCE)))

4. with the X$ and Xt constructs.
Just write the km requests as they would be written at the KM prompt
and prefix any lisp variables with Xt. The case of letters of these
variables is unimportant:

(let ((car-instance (first (km 'X$(the all-instances of Car)))))
  (km `X$(the parts of ,Xtcar-instance)))


For another example of how to use the Xt construct, see the
property-mult-property and property-div-property functions.|#
(TRACE-LISP (DEFVAR *T-READTABLE* (COPY-READTABLE *READTABLE*)))
(TRACE-LISP
 (DEFINE HASH-T-READER (STREAM SUBCHAR ARG)
  (trace-defun 'HASH-T-READER (STREAM SUBCHAR ARG)
   (RET (TRACE-PROGN (DECLARE (IGNORE SUBCHAR ARG)) (CLET (  (*PACKAGE* *T-PACKAGE*) (*READTABLE* *T-READTABLE*)) (CL-READ STREAM T NIL T)))))))
;;;; (get-dispatch-macro-character ;\; ;\t)
(TRACE-LISP (SET-DISPATCH-MACRO-CHARACTER #\# #\t #'HASH-T-READER))
;;;; UPDATED DEFINITIONS
;;;; *******************
(TRACE-LISP
 (DEFINE CASE-SENSITIVE-READ-KM (&OPTIONAL STREAM EOF-ERR-P EOF-VAL REC-P)
  (trace-defun 'CASE-SENSITIVE-READ-KM (STREAM EOF-ERR-P EOF-VAL REC-P)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR EOF-ERR-P T)     
     (CLET ((*T-PACKAGE* *PACKAGE*) (*PACKAGE* *KM-PACKAGE*)) (CASE-SENSITIVE-READ STREAM EOF-ERR-P EOF-VAL REC-P)))))))
(TRACE-LISP
 (DEFINE CASE-SENSITIVE-READ (&OPTIONAL STREAM EOF-ERR-P EOF-VAL REC-P)
  (trace-defun 'CASE-SENSITIVE-READ (STREAM EOF-ERR-P EOF-VAL REC-P)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR EOF-ERR-P T)
     (CLET ((OLD-READTABLE-CASE (READTABLE-CASE *READTABLE*)))
      (CL-LOOP
       (HANDLER-CASE
        (CUNWIND-PROTECT (TRACE-PROGN (CSETF (READTABLE-CASE *READTABLE*) :PRESERVE) (RET (CL-READ STREAM EOF-ERR-P EOF-VAL REC-P)))
         (CSETF (READTABLE-CASE *READTABLE*) OLD-READTABLE-CASE))
        (ERROR (ERROR) 
         (CERROR "Ignore error and return."
          (IF (TYPEP ERROR 'END-OF-FILE) "During case-sensitive-read, certainly a premature end-of-file:~%~a" "During case-sensitive-read:~%~a")
          ERROR))))))))))
;;;; ======================================================================
(TRACE-LISP
 (DEFINE HASH-DOLLAR-READER (STREAM SUBCHAR ARG)
  (trace-defun 'HASH-DOLLAR-READER (STREAM SUBCHAR ARG)
   (RET (TRACE-PROGN (DECLARE (IGNORE SUBCHAR ARG)) (CASE-SENSITIVE-READ-KM STREAM T NIL T))))))
(TRACE-LISP (SET-DISPATCH-MACRO-CHARACTER #\# #\$ #'HASH-DOLLAR-READER))
(TRACE-LISP (DEFCONSTANT *GLOBAL-SITUATION* '|*Global|))
(TRACE-LISP
 (DEFPARAMETER *SLOTS-NOT-TO-CLONE-FOR*  '(|prototype-participant-of| |prototype-participants| |prototypes| |prototype-of| |instance-of| |cloned-from|)))
;;;; ======================================================================
;;;;			WRITING
;;;; ======================================================================
#|This version of format *doesn't* put XX around symbols, but *does* put
"" around strings. This is impossible to do with the normal format, as
XX and "" can only be suppressed in unison (via the *print-escape*
variable). There's no other way round that I can see besides the below.

> ([km-]format t "~a" (case-sensitive-read))
(The BIG big "car" 2)

produces:
  *case-sensitivity*  *print-case*	format ~a		km-format ~a		format ~s			km-format ~s
	t		:upcase		(The BIG big car 2)	(The BIG big "car" 2)   (XTheX BIG XbigX "car" 2)	(XTheX BIG XbigX "\"car\"" 2)
	t		:downcase	(the big big car 2)	(The BIG big "car" 2)
[	nil		:upcase		(THE BIG BIG car 2)	(THE BIG BIG "car" 2)]
[	nil		:downcase	(the big big car 2)	(the big big "car" 2)]

(defun test (x)
  (setq *print-case* :upcase)
  (km-format t "km-format: ~a~%" x)
  (format t "format:   ~a~%" x)
  (setq *print-case* :downcase)
  (km-format t "km-format: ~a~%" x)
  (format t "format:   ~a~%" x))|#
(TRACE-LISP
 (DEFINE KM-FORMAT (STREAM STRING &REST ARGS)
  (trace-defun 'KM-FORMAT (STREAM STRING ARGS)
   (RET
    (CLET ((OLD-PRINT-CASE *PRINT-CASE*))
     (PROG2 (CSETQ *PRINT-CASE* :UPCASE)  (APPLY #'FORMAT (CONS STREAM (CONS STRING (MAPCAR #'ADD-QUOTES ARGS))))
      (CSETQ *PRINT-CASE* OLD-PRINT-CASE)))))))
;;;; For prettiness, we normally remove ;; when printing. But, this has the side-effect of also
;;;; removing quotes, so we must add those back in -- and also add back in ;; if the symbol
;;;; contains special characters "() ,;:".
;;;; (the "cat") -> (the "\"cat\"")
(TRACE-LISP
 (DEFINE ADD-QUOTES (OBJ)
  (trace-defun 'ADD-QUOTES (OBJ)
   (RET
    (COND ((NULL OBJ) NIL) ((ACONSP OBJ) (CONS (ADD-QUOTES (FIRST OBJ)) (ADD-QUOTES (REST OBJ)))) ((LISTP OBJ) (MAPCAR #'ADD-QUOTES OBJ))
     ((STRINGP OBJ) (FORMAT NIL "~s" OBJ)) 
     ((AND (SYMBOLP OBJ)
       (CLET ((CHARS (EXPLODE (SYMBOL-NAME OBJ))))
        (OR (CL-INTERSECTION CHARS '(#\( #\) #\Space #\, #\; #\: #\' #\")) (CNOT (SET-DIFFERENCE CHARS '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))))
       (CONCAT "|" (SYMBOL-NAME OBJ) "|"))
     ((KEYWORDP OBJ) (CONCAT ":" (SYMBOL-NAME OBJ)))  (T OBJ))))))
;;;; ======================================================================
;;;;		BETTER FORMATTING
;;;; ======================================================================
;;;; (write-km-vals ';$(:seq _Car2 ;the Dog; (baz . bar) ;,(the ;'dog)))
;;;; -> (:seq _Car2 ;;"mike" "joe";; ;the Dog; (baz . bar) ;,(the ;'dog))
;;;; (write-km-vals ';$(:seq _Car2 ;;"mike" "joe";; ;the Dog; (foo baz . bar))) will give an error though
;;;;	[(length '(a b . c)) generates an error - ignore this case for now].
(TRACE-LISP
 (DEFINE WRITE-KM-VALS (VALS &OPTIONAL STREAM)
  (trace-defun 'WRITE-KM-VALS (VALS STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T)
     (CLET ((OLD-PRINT-CASE *PRINT-CASE*)) (PROG2 (CSETQ *PRINT-CASE* :UPCASE)  (WRITE-KM-VALS2 VALS STREAM) (CSETQ *PRINT-CASE* OLD-PRINT-CASE))))))))
(TRACE-LISP
 (DEFINE WRITE-KM-VALS2 (VALS &OPTIONAL STREAM)
  (trace-defun 'WRITE-KM-VALS2 (VALS STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T)
     (COND ((NULL VALS) (FORMAT STREAM "~a" NIL))
      ((AND (PAIRP VALS) (SYMBOLP (FIRST VALS)) (ASSOC (FIRST VALS) *SPECIAL-SYMBOL-ALIST*))
       (CLET ((SPECIAL-SYMBOL-STR (SECOND (ASSOC (FIRST VALS) *SPECIAL-SYMBOL-ALIST*)))) (FORMAT STREAM "~a" SPECIAL-SYMBOL-STR)
        (WRITE-KM-VALS2 (SECOND VALS) STREAM)))
      ((LISTP VALS) (WRITE-KM-LIST VALS STREAM)) ((STRINGP VALS) (FORMAT STREAM "~s" VALS)) ((KEYWORDP VALS) (FORMAT STREAM ":~a" VALS))
      ((AND (SYMBOLP VALS) (CL-INTERSECTION (EXPLODE (SYMBOL-NAME VALS)) '(#\( #\) #\Space #\, #\; #\:))) (FORMAT STREAM "|~a|" VALS))
      ((ANONYMOUS-INSTANCEP VALS) (FORMAT STREAM "~a" VALS)
       (CLET
        ((TAGS
          (REMOVE-CONSTRAINTS
           (APPEND (GET-VALS VALS '|called| :SITUATION *GLOBAL-SITUATION*) (GET-VALS VALS '|uniquely-called| :SITUATION *GLOBAL-SITUATION*)))))
        (COND (TAGS (TAG-WRITE TAGS))
         (T
          (CLET
           ((CLASSES (IMMEDIATE-CLASSES VALS)) (SKOLEM-ROOT (SKOLEM-ROOT (SYMBOL-NAME VALS)))
            (NAME-CLASS-STR
             (COND ((CL-STARTS-WITH SKOLEM-ROOT "_Proto") (SUBSEQ SKOLEM-ROOT 6 (LENGTH SKOLEM-ROOT)))
              ((CL-STARTS-WITH SKOLEM-ROOT "_Some") (SUBSEQ SKOLEM-ROOT 5 (LENGTH SKOLEM-ROOT))) (T (BUTFIRST-CHAR SKOLEM-ROOT))))
            (NAME-CLASS (INTERN NAME-CLASS-STR *KM-PACKAGE*)))
           (COND
            ((OR (>= (LENGTH CLASSES) 2) (NEQ NAME-CLASS (FIRST CLASSES)))
             (CLET ((NEW-TAG (CONCAT-LIST (CONS "a " (COMMAED-LIST (MAPCAR #'SYMBOL-NAME CLASSES) "&"))))) (TAG-WRITE (LIST NEW-TAG) STREAM)))))))))
      (T (FORMAT STREAM "~a" VALS))))))))
(TRACE-LISP
 (DEFINE WRITE-KM-LIST (LIST &OPTIONAL STREAM FIRST-TIME-THROUGH)
  (trace-defun 'WRITE-KM-LIST (LIST STREAM FIRST-TIME-THROUGH)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR FIRST-TIME-THROUGH T) (SUBLISP-INITVAR STREAM T)
     (COND ((NULL LIST) (FORMAT STREAM ")"))
      (T (COND (FIRST-TIME-THROUGH (FORMAT STREAM "(")) (T (FORMAT STREAM " ")))
       (COND ((ACONSP LIST) (WRITE-KM-VALS2 (FIRST LIST) STREAM) (FORMAT STREAM " . ") (WRITE-KM-VALS2 (REST LIST) STREAM) (FORMAT STREAM ")"))
        (T (WRITE-KM-VALS2 (FIRST LIST) STREAM) (WRITE-KM-LIST (REST LIST) STREAM NIL))))))))))
;; i.e. first-time-through = nil
(TRACE-LISP
 (DEFINE TAG-WRITE (TAGS &OPTIONAL STREAM FIRST-TIME-THROUGH)
  (trace-defun 'TAG-WRITE (TAGS STREAM FIRST-TIME-THROUGH)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR FIRST-TIME-THROUGH T) (SUBLISP-INITVAR STREAM T)
     (COND ((NULL TAGS) (FORMAT STREAM "|#"))
      (T (COND (FIRST-TIME-THROUGH (FORMAT STREAM " #|")) (T (FORMAT STREAM " "))) (FORMAT STREAM "~s" (FIRST TAGS))
       (TAG-WRITE (REST TAGS) STREAM NIL))))))))
;; i.e. first-time-through = nil
;;;; "_Car23" -> "_Car"
(TRACE-LISP
 (DEFINE SKOLEM-ROOT (STRING)
  (trace-defun 'SKOLEM-ROOT (STRING)
   (RET
    (COND ((STRING= STRING ""))
     ((CL-MEMBER (CL-LAST-CHAR STRING) '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :TEST #'CHAR=) (SKOLEM-ROOT (BUTLAST-CHAR STRING))) (T STRING))))))
;;;; ======================================================================
;;;; "Tool" -> ;Tool; (case-sensitivity on); [;TOOL; (case-sensitivity off)]
(TRACE-LISP
 (DEFINE STRING-TO-FRAME (STRING)
  (trace-defun 'STRING-TO-FRAME (STRING) (RET (COND ((STRING= STRING "") NIL) (T (INTERN STRING *KM-PACKAGE*)))))))
;;;; Inverse suffix must obey case-sensitive restrictions
(TRACE-LISP (DEFPARAMETER *INVERSE-SUFFIX* "-of"))
(TRACE-LISP (DEFPARAMETER *LENGTH-OF-INVERSE-SUFFIX* (LENGTH *INVERSE-SUFFIX*)))
#|======================================================================
		UNQUOTING: KM's own mechanism
		=============================
This isn't very elegant, I'd rather use the traditional `, Lisp syntax, but
this will have to do**. Note the complication that X, always returns a
LIST of instances, so we have to be careful to splice them in appropriately.
Added X@ to do splicing. (a X@b) = (a . X,b)

However, we need to make it a reader macro so that KM will respond to
embedded X, which would otherwise be unprocessed, eg. a handler for "," 
won't even reach the embedded unit in:
	KM> (Pete has (owns (`(a Car with (age ,(the Number)))))) 
	but a macro character will:
	KM> (Pete has (owns ('(a Car with (age X,(the Number))))))

** The mechanism needs to be vendor-independent, but the handling of `, is
vendor-specific. Allegro names these two symbols as excl:backquote and
excl:bq-comma; Harlequin preprocesses the expressions in the reader, so
that `(a b ,c) is pre-converted to (list 'a 'b c).

======================================================================

This *doesn't* require pairing with backquote `.
Usage:
KM> (:set (a Car) (a Car))
(_Car13 _Car14)

KM> '(:set (a Car) (a Car))
('(:set (a Car) (a Car)))

KM> '(:set (a Car) X,(a Car))
('(:set (a Car) (_Car16)))		<= note undesirable () around _Car16

KM> '(:set (a Car) . X,(a Car))		<= use . X, to slice item at end of list
('(:set (a Car) _Car17))|#
;;;; Thanks to Brian Mastenbrook for info on the usage of eval-when, which
;;;; avoids pre-loading km.lisp before compiling!
(TRACE-LISP
 (DEFINE HASH-COMMA-READER (STREAM SUBCHAR ARG)
  (trace-defun 'HASH-COMMA-READER (STREAM SUBCHAR ARG)
   (RET (TRACE-PROGN (DECLARE (IGNORE SUBCHAR ARG)) (LIST 'UNQUOTE (CASE-SENSITIVE-READ-KM STREAM T NIL T)))))))
(TRACE-LISP (SET-DISPATCH-MACRO-CHARACTER #\# #\, #'HASH-COMMA-READER))
;;;; FILE:  interpreter.lisp
;;;; File: interpreter.lisp
;;;; Author: Peter Clark
;;;; Date: July 1994
;;;; Purpose: KM Query Language interpreter
(TRACE-LISP (DEFPARAMETER *EXHAUSTIVE-FORWARD-CHAINING* NIL))
(TRACE-LISP (DEFPARAMETER *MULTIDEPTH-PATH-DEFAULT-SEARCHDEPTH* 5))
;;;; *additional-keywords* ARE allowed as slot names
(TRACE-LISP (DEFPARAMETER *ADDITIONAL-KEYWORDS* '(|TheValue| |TheValues| * |called| |uniquely-called| |Self| QUOTE UNQUOTE == /== > <)))
;; used for (scan-kb) in frame-io.lisp.
(TRACE-LISP (DEFPARAMETER *INFINITY* 999999))
(TRACE-LISP
 (DEFPARAMETER *RESERVED-KEYWORDS* 
  '(|a| |some| |must-be-a| |mustnt-be-a| |print| |format| |km-format| |an| |instance| @  |possible-values| |excluded-values| |spy| |unspy|
    |anonymous-instancep| |sanity-check| |every| |the| |the1| |the2| |the3| |theN| |theNth| |of| |forall| |forall2| |with| |where| |theoneof| |theoneof2|
    |forall-seq| |forall-seq2| |forall-bag| |forall-bag2| |the-class| |constraints-for| |rules-for| |the+| |a+| |evaluate-paths| |clone| |a-prototype|
    |oneof| |oneof2| |It| |It2| |if| |then| |else| |allof| |allof2| |and| |or| |not| |is| & && &? &+ #|&&?|# &! &&! = === /= + - / ^ >= <= |isa|
    #|expand-text add-clones-to in-which|# |append| |are| |includes| |thelast| :|set| :|seq| :|bag| :|args| :|triple| :|pair| :|function| |showme-here|
    |showme| |showme-all| |evaluate-all| |quote| |delete| |evaluate| |has-value| |andify| |make-sentence| |make-phrase| #|pluralize|# |every| |has|
    |also-has| |must| |is-superset-of| |covers| |subsumes| |has-definition| |numberp| |bag| |seq| #|override|# |no-inheritance| |comm| |trace| |untrace|
    |fluent-instancep| |at-least| |at-most| |exactly| |constraint| <> |reverse| |is-subsumed-by| |is-covered-by| |set-constraint| |set-filter|
    |in-situation| |in-every-situation| |end-situation| |do| |do-and-next| |in-theory| |end-theory| |see-theory| |hide-theory| |visible-theories|
    |curr-situation| |ignore-result| |do-script| |new-context| |do-plan|)))
(TRACE-LISP
 (DEFPARAMETER *KM-LISP-EXPRS*  
  '(SAVE-KB RESET-KB WRITE-KB FASTSAVE-KB FASTLOAD-KB LOAD-TRIPLES SHOW-CONTEXT CHECKKBON CHECKKBOFF SHOW-BINDINGS VERSION SHOW-OBJ-STACK CLEAR-OBJ-STACK
    RESET-DONE CLEAR-EVALUATION-CACHE INSTALL-ALL-SUBCLASSES CLEAN-TAXONOMY SCAN-KB DISABLE-CLASSIFICATION ENABLE-CLASSIFICATION EXPLAIN-ALL
    CLEAR-EXPLANATIONS DISABLE-INSTALLING-INVERSES ENABLE-INSTALLING-INVERSES START-LOGGING STOP-LOGGING NO-EXPLANATIONS EXPLANATIONS CLEAR-SITUATIONS
    SANITY-CHECKS NO-SANITY-CHECKS STORE-KB RESTORE-KB FAIL-QUIETLY FAIL-NOISILY REQUIRES-KM-VERSION CATCH-EXPLANATIONS SHOW-EXPLANATIONS
    SHOW-EXPLANATIONS-XML INSTANCE-OF-IS-FLUENT INSTANCE-OF-IS-NONFLUENT NO-SEARCH-CONTROL EVAL SETQ TRACEKM UNTRACEKM LICENSE ENABLE-SLOT-CHECKING
    DISABLE-SLOT-CHECKING COMMENTS NOCOMMENTS)))
(TRACE-LISP
 (DEFPARAMETER *DOWNCASE-KM-LISP-EXPRS*
  (MAPCAR #'(LAMBDA (EXPR) (trace-defun '#:G15590 (EXPR) (RET (INTERN (CL-STRING-DOWNCASE EXPR) *KM-PACKAGE*)))) *KM-LISP-EXPRS*)))
;;;; Don't strip out (@ ...) structures for lists beginning with these items.
(TRACE-LISP (DEFPARAMETER *NO-DECOMMENT-HEADWORDS* '(|comment| |show-comment| |explanation|)))
;;;; 10/28/02: These are calls where all the subcalls are direct calls to km0, so we can defer decommenting down to there for the elements
(TRACE-LISP (DEFPARAMETER *DECOMMENT-TOP-LEVEL-ONLY-HEADWORDS* '(:|set| |if|)))
;; from frame-io.lisp, as we want to reference it here
(TRACE-LISP (DEFPARAMETER *BUILT-IN-CLASSES-WITH-NONFLUENT-INSTANCES-RELATION* '(|Situation| |Slot| |Partition| |Theory|)))
;;;; --------------------
;;;; Change to 'error for test-suite
(TRACE-LISP (DEFPARAMETER *TOP-LEVEL-FAIL-MODE* 'FAIL))
(TRACE-LISP (DEFINE FAIL-NOISILY NIL (trace-defun 'FAIL-NOISILY NIL (RET (TRACE-PROGN (KM-SETQ '*TOP-LEVEL-FAIL-MODE* 'ERROR) T)))))
(TRACE-LISP (DEFINE FAIL-QUIETLY NIL (trace-defun 'FAIL-QUIETLY NIL (RET (TRACE-PROGN (KM-SETQ '*TOP-LEVEL-FAIL-MODE* 'FAIL) T)))))
(TRACE-LISP (DEFCONSTANT *DEFAULT-FAIL-MODE* 'FAIL))
;;;; --------------------
;;;; The top level call, either by person or machine
(TRACE-LISP
 (DEFINE KM (&OPTIONAL KMEXPR &REST LKEYS)
  (trace-defun 'KM (KMEXPR LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE *TOP-LEVEL-FAIL-MODE*) (SUBLISP-INITVAR KMEXPR 'ASK-USER) (RESET-INFERENCE-ENGINE)
     (COND ((EQ KMEXPR 'ASK-USER) (KM-READ-EVAL-PRINT)) (T (KM-EVAL KMEXPR :FAIL-MODE FAIL-MODE))))))))
;;;; ----------
;;;; April 05 -- why the old-backtrack stuff? Nowhere does *backtrack-after-testing-unification* get
;;;; changed in the code (permanently nil). This seems obsolete (dead) code.
;;(defun km-with-explanations (expr &key (fail-mode *top-level-fail-mode*))
;;  (catch-explanations)
;;  (let ( (old-backtrack *backtrack-after-testing-unification*) )
;;    (prog1
;;	(km expr :fail-mode fail-mode)
;;      (setq *backtrack-after-testing-unification* old-backtrack))))
;;;; ----------   
(TRACE-LISP (DEFVAR *LAST-QUESTION* NIL))
;; so we can simply ask "why" rather than "why" with a whole list of arguments
(TRACE-LISP (DEFVAR *LAST-ANSWER* NIL))
;; so we can simply ask "why" rather than "why" with a whole list of arguments
;;;; [1] We set-checkpoint here, rather than in km-eval-print, as (load-kb ... :verbose t) also calls km-eval-print, and we DON'T (?) want
;;;; checkpointing used there too.
(TRACE-LISP
 (DEFINE KM-READ-EVAL-PRINT NIL
  (trace-defun 'KM-READ-EVAL-PRINT NIL
   (RET
    (CL-LOOP (RESET-INFERENCE-ENGINE) (PRINT-KM-PROMPT) (FINISH-OUTPUT) 
     (CLET ((QUERY (CASE-SENSITIVE-READ-KM))) (COND ((MINIMATCH QUERY '(|the| |?slot| |of| |?expr|)) (CSETQ *LAST-QUESTION* QUERY)))
      (COND ((EQ QUERY '|q|) (RET))
       (T (COND ((CNOT (SKIP-CHECKPOINT QUERY)) (SET-CHECKPOINT QUERY))) 
        (MULTIPLE-VALUE-BIND (ANSWER ERROR) (KM-EVAL-PRINT QUERY) (COND ((MINIMATCH QUERY '(|the| |?slot| |of| |?expr|)) (CSETQ *LAST-ANSWER* ANSWER)))
         (VALUES ANSWER ERROR))))))))))
(TRACE-LISP
 (DEFINE SKIP-CHECKPOINT (QUERY)
  (trace-defun 'SKIP-CHECKPOINT (QUERY) (RET (AND (LISTP QUERY) (CL-MEMBER (FIRST QUERY) '(|showme| |undo| |why|)))))))
;;;; Print out answer...(also reset counters and checkpoint)
(TRACE-LISP
 (DEFINE KM-EVAL-PRINT (QUERY &REST LKEYS)
  (trace-defun 'KM-EVAL-PRINT (QUERY LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE *TOP-LEVEL-FAIL-MODE*)
     (COND ((NULL QUERY) NIL)
      ((CL-EQUAL QUERY '(|undo|))
       (COND ((UNDO-POSSIBLE) (CLET ((UNDONE-COMMAND (UNDO))) (KM-FORMAT T "Undone ~a...~%~%" UNDONE-COMMAND) '(|t|)))
        (T (KM-FORMAT T "Nothing more to undo!~%~%"))))
      (T 
       (MULTIPLE-VALUE-BIND (ANSWER ERROR) (KM-EVAL QUERY :FAIL-MODE FAIL-MODE)
        (COND (ERROR (FORMAT T "(Execution aborted)~%NIL~%")) (*ADD-COMMENTS-TO-NAMES* (WRITE-KM-VALS ANSWER) (TERPRI)) (T (KM-FORMAT T "~a~%" ANSWER)))
        (PRINC (REPORT-STATISTICS))  (TERPRI) (VALUES ANSWER ERROR)))))))))
;;;; reset-inference-engine done up in (km), or NOT, if called by load-kb (don't want to keep resetting counters)
;;;; also no checkpointing done
;;;; [1] New - see cache-problem.km in test-suite. (reset-done) might be rather inefficiently implemented (?). I wonder if it's too slow.
(TRACE-LISP
 (DEFINE KM-EVAL (KM-EXPR &REST LKEYS)
  (trace-defun 'KM-EVAL (KM-EXPR LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE *TOP-LEVEL-FAIL-MODE*) (RESET-DONE)
     (COND ((AM-IN-PROTOTYPE-MODE) (ADD-TO-PROTOTYPE-DEFINITION *CURR-PROTOTYPE* KM-EXPR)))
     (COND ((KM-ASSERTION-EXPR KM-EXPR) (RESET-DONE) (CLEAR-CACHED-EXPLANATIONS)))  (REMOVE-TEMPORARY-DISABLEMENT-OF-CLASSIFICATION) 
     (CLET
      ((ANSWER
        (CATCH 'KM-ABORT (PROG1 (DESOURCE (KM0 KM-EXPR :FAIL-MODE FAIL-MODE)) (COND (*EXHAUSTIVE-FORWARD-CHAINING* (EXHAUSTIVELY-FORWARD-CHAIN)))))))
      (COND ((AND (PAIRP ANSWER) (EQ (FIRST ANSWER) 'KM-ABORT))  (VALUES NIL (SECOND ANSWER))) (T ANSWER))))))))
;;;; ----------
(TRACE-LISP
 (DEFINE PRINT-KM-PROMPT (&OPTIONAL STREAM)
  (trace-defun 'PRINT-KM-PROMPT (STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T)
     (COND
      ((AND (AM-IN-LOCAL-SITUATION) (AM-IN-PROTOTYPE-MODE))
       (REPORT-ERROR 'USER-ERROR "You are in both prototype-mode and in a Situation, which isn't allowed!~%"))
      ((AND (AM-IN-LOCAL-THEORY) (AM-IN-PROTOTYPE-MODE))
       (REPORT-ERROR 'USER-ERROR "You are in both prototype-mode and in a Theory, which isn't allowed!~%"))
       ((AM-IN-PROTOTYPE-MODE) (KM-FORMAT STREAM "[prototype-mode] KM> ")) ((AM-IN-LOCAL-SITUATION) (KM-FORMAT STREAM "[~a] KM> " (CURR-SITUATION)))
      ((AM-IN-LOCAL-THEORY) (KM-FORMAT STREAM "{~a} KM> " (CURR-SITUATION))) (T (KM-FORMAT STREAM "KM> "))))))))
;;;; ======================================================================
;;;;		KM HANDLER METHODS
;;;;  (km0 <expr>) is the recursive to KM *internal* to the KM Engine
;;;; ======================================================================
;;;; 		(km0 <expr>) will evaluate <expr> 
;;;;
;;;; km evaluates the expression (a path) which is given to it, and returns a
;;;; list of instances which the path points to.
;;;; <expr> must be either an INSTANCE or a PATH. (NB: A list of instances is 
;;;; treated as a path. If you do want a set, you must precede the list by the 
;;;; keyword ":set")
;;;;
;;;; Fail-modes: If km fails to find a referent at the end of the path,
;;;; it can either fail quietly and return nil (), or
;;;; gives a warning (:fail-mode 'error). 'error is very useful for debugging
;;;; the KB.
(TRACE-LISP (DEFVAR *SPYPOINTS* NIL))
(TRACE-LISP (DEFVAR *SEARCH-CONTROL-POINTS* NIL))
#|Called by lazy-unify, where we want to look like trace-expr has gone through km0, with kmexpr as the subgoal,
even though this isn't literally true. 
In other words, this splices an extra step in the trace output which doesn't really exist in KM.
Rather than displaying:
	-> (_Car1 &? _Car2)
         -> ((a Engine) (a Chassis))
	 <- (_Engine1 _Chassis3)
         -> ((a Engine) (a Chassis))
	 <- (_Engine4 _Chassis5)
It displays:
	-> (_Car1 &? _Car2)
         -> (the parts of _Car1)
          -> ((a Engine) (a Chassis))
	  <- (_Engine1 _Chassis3)
         -> (the parts of _Car2)
          -> ((a Engine) (a Chassis))
	  <- (_Engine4 _Chassis5)
Note the "virtual" extra steps inserted. The (the parts of _Car1) are in fact done by a direct
get-vals in lazy-unify, rather than by a recursive call to KM, but we still want to show this to
the user.|#
(TRACE-LISP
 (DEFINE KM0-WITH-TRACE (TRACE-EXPR KMEXPR &REST LKEYS)
  (trace-defun 'KM0-WITH-TRACE (TRACE-EXPR KMEXPR LKEYS)
   (RET
    (CLET (FAIL-MODE CHECK-FOR-LOOPING TARGET) (init-keyval CHECK-FOR-LOOPING T) (init-keyval FAIL-MODE *DEFAULT-FAIL-MODE*)
     (PROG2 (KM-PUSH TRACE-EXPR)
      (CLET
       ((USERS-GOAL (KM-TRACE 'CALL "-> ~a" TRACE-EXPR))
        (ANSWER (COND ((EQ USERS-GOAL 'FAIL) NIL) (T (KM0 KMEXPR :FAIL-MODE FAIL-MODE :CHECK-FOR-LOOPING CHECK-FOR-LOOPING :TARGET TARGET))))
        (USERS-RESPONSE (COND (ANSWER (KM-TRACE 'EXIT "<- ~a~30T\"~a\"" ANSWER TRACE-EXPR)) (T (KM-TRACE 'FAIL "<- FAIL!~30T\"~a\"" TRACE-EXPR)))))
       (COND
        ((EQ USERS-RESPONSE 'REDO) (RESET-DONE)
         (KM0-WITH-TRACE TRACE-EXPR KMEXPR :FAIL-MODE FAIL-MODE :CHECK-FOR-LOOPING CHECK-FOR-LOOPING :TARGET TARGET))
        ((EQ USERS-RESPONSE 'FAIL) NIL) (T ANSWER)))
      (KM-POP)))))))
;;;; --------------------
;;;; Wrapper, to maintain a stack and check for looping
#| kmexpr-with-comments is the expression passed to km0. It may include comments, and may be an assignment :== statement.
 kmexpr is the ACTUAL expression to evaluate by km.
    This requires remove all comments, EXCEPT for assertion statements (has, a, some) in which only the TOP LEVEL comments are stripped
    (so that the sub-level comments get asserted in the KB)|#
(TRACE-LISP
 (DEFINE KM0 (KMEXPR-WITH-COMMENTS &REST LKEYS)
  (trace-defun 'KM0 (KMEXPR-WITH-COMMENTS LKEYS)
   (RET
    (CLET (FAIL-MODE CHECK-FOR-LOOPING TARGET) (init-keyval CHECK-FOR-LOOPING T) (init-keyval FAIL-MODE *DEFAULT-FAIL-MODE*)
     (CLET
      ((KMEXPR
        (COND
         ((OR (KM-ASSERTION-EXPR KMEXPR-WITH-COMMENTS)  (AND TARGET  (RECORD-EXPLANATION-LATER KMEXPR-WITH-COMMENTS)) 
           (AND (LISTP KMEXPR-WITH-COMMENTS) (CL-MEMBER (FIRST KMEXPR-WITH-COMMENTS) *DECOMMENT-TOP-LEVEL-ONLY-HEADWORDS*)))
          (DECOMMENT-TOP-LEVEL KMEXPR-WITH-COMMENTS))
         ((AND (LISTP KMEXPR-WITH-COMMENTS) 
           (OR (CL-MEMBER (FIRST KMEXPR-WITH-COMMENTS) *NO-DECOMMENT-HEADWORDS*)
            (AND (EQ (FIRST KMEXPR-WITH-COMMENTS) '|in-situation|) (LISTP (THIRD KMEXPR-WITH-COMMENTS))
             (CL-MEMBER (FIRST (THIRD KMEXPR-WITH-COMMENTS)) *NO-DECOMMENT-HEADWORDS*))))
          KMEXPR-WITH-COMMENTS)
         (T (DECOMMENT KMEXPR-WITH-COMMENTS)))))
        
      (COND
       ((AND *SPYPOINTS* (SOME #'(LAMBDA (SPYPOINT) (trace-defun '#:G15591 (SPYPOINT) (RET (MINIMATCH KMEXPR SPYPOINT)))) *SPYPOINTS*))
        (KM-FORMAT T "(Spypoint reached!)~%") (TRACEKM)))
      (COND
       ((AND *SEARCH-CONTROL-POINTS*
         (CLET
          ((SEARCH-CONTROL-POINT
            (FIND-IF
             #'(LAMBDA (SEARCH-CONTROL-POINT)
                (trace-defun '#:G15592 (SEARCH-CONTROL-POINT) (RET (MINIMATCH KMEXPR (FIRST SEARCH-CONTROL-POINT)))))
             *SEARCH-CONTROL-POINTS*))
           (MIN-DEPTH (THIRD SEARCH-CONTROL-POINT)) (MAX-DEPTH (FOURTH SEARCH-CONTROL-POINT)))
           
          (AND SEARCH-CONTROL-POINT (OR (CNOT (NUMBERP MIN-DEPTH)) (>= (1+ *DEPTH*) MIN-DEPTH))
           (OR (CNOT (NUMBERP MAX-DEPTH)) (<= (1+ *DEPTH*) MAX-DEPTH)))))
        (SEARCH-CONTROL KMEXPR))
       ((CL-MEMBER KMEXPR '((|tracekm|) (TRACEKM) (|trace|) (TRACE)) :TEST #'CL-EQUAL) (RESET-TRACE-DEPTH) (TRACEKM) '(|t|))
       ((CL-MEMBER KMEXPR '((|untracekm|) (UNTRACEKM) (|untrace|) (UNTRACE)) :TEST #'CL-EQUAL) (RESET-TRACE-DEPTH) (UNTRACEKM) '(|t|))
       ((AND (LISTP KMEXPR)  (CL-MEMBER (FIRST KMEXPR) '(LOAD-KB |load-kb| RELOAD-KB |reload-kb|))) (PROCESS-LOAD-EXPRESSION KMEXPR))
       ((AND (LISTP KMEXPR) (CL-MEMBER (FIRST KMEXPR) *KM-LISP-EXPRS*)) (EVAL KMEXPR) '(|t|))
       ((AND (LISTP KMEXPR) (CL-MEMBER (FIRST KMEXPR) *DOWNCASE-KM-LISP-EXPRS*))
        (EVAL (CONS (INTERN (STRING-UPCASE (FIRST KMEXPR)) *KM-PACKAGE*) (REST KMEXPR))) '(|t|))
       ((AND (AM-IN-LOCAL-SITUATION) (AM-IN-PROTOTYPE-MODE))
        (REPORT-ERROR 'USER-ERROR "You are in both prototype-mode and in a Situation, which isn't allowed!~%"))
       ((OR (NULL KMEXPR)  (EQ KMEXPR '|nil|)  (CONSTRAINT-EXPRP KMEXPR))
        (COND ((EQ FAIL-MODE 'ERROR) (REPORT-ERROR 'USER-ERROR "No values found for ~a!~%" KMEXPR)))
        (COND ((CONSTRAINT-EXPRP KMEXPR) (NOTE-ARE-CONSTRAINTS))) NIL)
       ((AND (ATOM KMEXPR) (CNOT (NO-RESERVED-KEYWORDS (LIST KMEXPR))))  NIL)
       ((KM-VARP KMEXPR) (REPORT-ERROR 'USER-ERROR "Unbound variable ~a encountered!~%" KMEXPR))
       ((AND (FULLY-EVALUATEDP KMEXPR)  (EQ (DEREFERENCE KMEXPR) KMEXPR)) 
        (COND ((KM-SETP KMEXPR) (SET-TO-LIST KMEXPR))
         ((AND (LISTP KMEXPR) (EQ (FIRST KMEXPR) ':|triple|) (NEQ (LENGTH (REST KMEXPR)) 3)
           (REPORT-ERROR 'USER-ERROR "~a: A triple should have exactly three elements!~%" KMEXPR)))
         ((AND (LISTP KMEXPR) (EQ (FIRST KMEXPR) ':|pair|) (NEQ (LENGTH (REST KMEXPR)) 2)
           (REPORT-ERROR 'USER-ERROR "~a: A pair should have exactly two elements!~%" KMEXPR)))
         (T (LIST KMEXPR))))
       ((INTERNAL-COMMENTP KMEXPR-WITH-COMMENTS)
        (CLET ((COMMENT-TAG (SECOND KMEXPR-WITH-COMMENTS)))
         (REPORT-ERROR 'USER-ERROR
          "Comment tag ~a was encountered as a free-standing
       slot-value in the KB - not allowed! It should be embedded within a KM expression.~%"
          COMMENT-TAG)))
       ((AND CHECK-FOR-LOOPING (LOOPING-ON KMEXPR-WITH-COMMENTS))  (KM-TRACE 'COMMENT "Looping on ~a!" KMEXPR) (HANDLE-LOOPING KMEXPR))
       ((AND *KM-DEPTH-LIMIT* (> *DEPTH* *KM-DEPTH-LIMIT*)) (KM-TRACE 'COMMENT "Maximum depth limit reached, doing ~a!" KMEXPR)
        (HANDLE-LOOPING KMEXPR :REASON 'DEPTH-LIMIT-REACHED))
       (T
        (CLET ((PID (NEW-PROOF-NODE-ID)))
         (PROG2 (KM-PUSH KMEXPR-WITH-COMMENTS PID) (KM1 KMEXPR KMEXPR-WITH-COMMENTS :FAIL-MODE FAIL-MODE :TARGET TARGET :PID PID) (KM-POP)))))))))))
;;;; ----------------------------------------
;;;;	Handling of loops - allow inductive completion of proofs
;;;; ----------------------------------------
;;;; reason = loop-detected OR depth-limit-reached
;;;; [2] Not having the correct target-situation specified seems like an error to me.
(TRACE-LISP
 (DEFINE HANDLE-LOOPING (KMEXPR &REST LKEYS)
  (trace-defun 'HANDLE-LOOPING (KMEXPR LKEYS)
   (RET
    (CLET (REASON) (init-keyval REASON 'LOOP-DETECTED)
     (CLET ((CEXPR (CANONICALIZE KMEXPR)))
      (COND
       ((AND (MINIMATCH CEXPR '(|the| |?slot| |of| |?instance|))  (SYMBOLP (SECOND CEXPR))   (KB-OBJECTP (FOURTH CEXPR))) 
        (CLET
         ((INSTANCE (FOURTH CEXPR)) (SLOT (SECOND CEXPR))  (VALS (GET-VALS INSTANCE SLOT :SITUATION (TARGET-SITUATION (CURR-SITUATION) INSTANCE SLOT)))) 
         (KM-TRACE 'COMMENT "Just using values found so far, = ~a..." VALS) 
         (COND ((EVERY #'FULLY-EVALUATEDP VALS) VALS)
          (T
           (CLET ((NEW-VALS (KM0 (VALS-TO-VAL VALS))))  (COND ((CNOT (DONT-CACHE-VALUES-SLOTP SLOT))   (PUT-VALS INSTANCE SLOT NEW-VALS)))  NEW-VALS)))))
       
       ((AND (LISTP KMEXPR)  (VAL-UNIFICATION-OPERATOR (SECOND KMEXPR))) 
        (COND
         ((CL-MEMBER (SECOND KMEXPR) '(&? &+?))
          (CASE REASON (LOOP-DETECTED (KM-TRACE 'COMMENT "Assuming ~a to prove ~a (ie. Inductive proof)" KMEXPR KMEXPR) '(|t|))
           (DEPTH-LIMIT-REACHED (KM-TRACE 'COMMENT "Assuming success...") '(|t|))))
         
         (T
          (CLET ((VAL (FIND-IF #'KB-OBJECTP (&-EXPR-TO-VALS KMEXPR)))) 
           (COND
            (VAL
             (CASE REASON (LOOP-DETECTED (KM-TRACE 'COMMENT "Assuming ~a to prove ~a (ie. Inductive proof)" KMEXPR KMEXPR))
              (DEPTH-LIMIT-REACHED (KM-TRACE 'COMMENT "Just using value found so far, = ~a..." VAL)))
             (LIST VAL)))))))
       ((&&-EXPRP KMEXPR)
        (CLET
         ((ANSWER (FIND-IF #'(LAMBDA (SET) (trace-defun '#:G15593 (SET) (RET (EVERY #'KB-OBJECTP SET)))) (&&-EXPRS-TO-VALSETS (LIST KMEXPR)))))
         (COND
          (ANSWER
           (CASE REASON (LOOPING-DETECTED (KM-TRACE 'COMMENT "Assuming ~a to prove ~a (ie. Inductive proof)" KMEXPR KMEXPR))
            (DEPTH-LIMIT-REACHED (KM-TRACE 'COMMENT "Just using value found so far, = ~a..." ANSWER)))
           ANSWER))))
       (T (KM-TRACE 'COMMENT "Giving up...)" KMEXPR) NIL))))))))
;;;; ----------------------------------------
;;;; Extensions for Jihie:
(TRACE-LISP (DEFVAR *TRACE-LOG* NIL))
;; **** NEW LINE
(TRACE-LISP (DEFVAR *TRACE-LOG-ON* NIL))
;; **** another NEW LINE
(TRACE-LISP (DEFVAR *PRINT-EXPLANATIONS* T))
;;; dmiles
(TRACE-LISP (DEFVAR *CATCH-EXPLANATIONS* NIL))
(TRACE-LISP (DEFVAR *CATCH-NEXT-EXPLANATIONS* NIL))
(TRACE-LISP (DEFVAR *EXPLANATIONS* T))
;;; dmiles
;;;; (km1 ...)
;;;; [1] Note we can't do a remove duplicates, as we often need duplicate
;;;; entries in. Eg. ("remove" _car1 "and put" _car1 "into the furnace")
;;;; target = the target slot and frame for the result, in the form ';$(the <slot> of <instance>). NIL if none known eg. top-level query
(TRACE-LISP
 (DEFINE KM1 (KMEXPR KMEXPR-WITH-COMMENTS &REST LKEYS)
  (trace-defun 'KM1 (KMEXPR KMEXPR-WITH-COMMENTS LKEYS)
   (RET
    (CLET (FAIL-MODE TARGET PID) (init-keyval FAIL-MODE *DEFAULT-FAIL-MODE*) (INCREMENT-INFERENCE-STATISTICS)
     (IF (AND *TRACE-LOG-ON* (CNOT *AM-CLASSIFYING*))  (CSETQ *TRACE-LOG* (CONS `(,(1+ *DEPTH*) CALL ,KMEXPR-WITH-COMMENTS) *TRACE-LOG*))) 
     (CLET
      ((USERS-GOAL (COND (TARGET (KM-TRACE 'CALL "-> ~a~40T [for ~a]"  KMEXPR-WITH-COMMENTS TARGET)) (T (KM-TRACE 'CALL "-> ~a" KMEXPR-WITH-COMMENTS))))
       (DUMMY (COND ((OR *CATCH-EXPLANATIONS* *PRINT-EXPLANATIONS*) (CATCH-EXPLANATION KMEXPR-WITH-COMMENTS 'CALL))))
       (KMEXPR-TO-CALL (COND ((AND TARGET (RECORD-EXPLANATION-LATER KMEXPR)) `(,TARGET :== ,KMEXPR))  (T KMEXPR))))
      (DECLARE (IGNORE DUMMY))
      (MULTIPLE-VALUE-BIND (ANSWER0 HANDLER-PATTERN) 
       (COND ((EQ USERS-GOAL 'FAIL) NIL) ((ATOM KMEXPR-TO-CALL) (LIST KMEXPR-TO-CALL)) 
        (*COMPILE-HANDLERS* (FUNCALL *KM-HANDLER-FUNCTION* FAIL-MODE KMEXPR-TO-CALL)) 
        (T
         (CLET
          ((HANDLER (FIND-HANDLER KMEXPR-TO-CALL *KM-HANDLER-ALIST*))  (ANSWER00 (APPLY (FIRST HANDLER) (CONS FAIL-MODE (SECOND HANDLER))))
           (PATTERN (THIRD HANDLER)))
          (VALUES ANSWER00 PATTERN))))
       (CLET ((ANSWER (REMOVE-DUP-INSTANCES (CL-REMOVE NIL ANSWER0)))) 
        (COND ((AND (NULL ANSWER) (EQ FAIL-MODE 'ERROR)) (REPORT-ERROR 'USER-ERROR "No values found for ~a!~%" KMEXPR-WITH-COMMENTS)))
        (PROCESS-KM1-RESULT ANSWER KMEXPR KMEXPR-WITH-COMMENTS :FAIL-MODE FAIL-MODE :TARGET TARGET :HANDLER-PATTERN HANDLER-PATTERN :PID PID)))))))))
(TRACE-LISP (DEFVAR *PROCESS-PROOF-NODE* NIL))
;;;; This allows handling of redo and fail options when tracing.
(TRACE-LISP
 (DEFINE PROCESS-KM1-RESULT (ANSWER KMEXPR KMEXPR-WITH-COMMENTS &REST LKEYS)
  (trace-defun 'PROCESS-KM1-RESULT (ANSWER KMEXPR KMEXPR-WITH-COMMENTS LKEYS)
   (RET
    (CLET (FAIL-MODE TARGET HANDLER-PATTERN PID) (init-keyval FAIL-MODE *DEFAULT-FAIL-MODE*)
     (CLET ((PARENT-PID (STACKED-ID (SECOND (KM-STACK)))))
      (COND (*PROCESS-PROOF-NODE* (PROCESS-PROOF-NODE PID PARENT-PID *DEPTH* (DESOURCE KMEXPR) ANSWER HANDLER-PATTERN))))
     (MAPC #'(LAMBDA (VAL) (trace-defun '#:G15594 (VAL) (RET (CACHE-EXPLANATION-FOR VAL KMEXPR)))) ANSWER) 
     (COND
      ((AND TARGET  *RECORD-EXPLANATIONS* (CNOT (RECORD-EXPLANATION-LATER KMEXPR-WITH-COMMENTS)))
       (MAPC #'(LAMBDA (VAL) (trace-defun '#:G15595 (VAL) (RET (RECORD-EXPLANATION-FOR TARGET VAL KMEXPR-WITH-COMMENTS)))) ANSWER)))
     (IF (AND *TRACE-LOG-ON* (CNOT *AM-CLASSIFYING*))  (CSETQ *TRACE-LOG* (CONS `(,*DEPTH* EXIT ,KMEXPR-WITH-COMMENTS ,ANSWER) *TRACE-LOG*))) 
     (COND ((OR *CATCH-EXPLANATIONS* *PRINT-EXPLANATIONS*) (CATCH-EXPLANATION KMEXPR-WITH-COMMENTS (COND (ANSWER 'EXIT) (T 'FAIL)))))
     (CLET
      ((USERS-RESPONSE
        (COND
         (ANSWER
          (COND (TARGET (KM-TRACE 'EXIT "<- ~a~40T [~a, for ~a]" ANSWER KMEXPR-WITH-COMMENTS TARGET))
           (T (KM-TRACE 'EXIT "<- ~a~40T [~a]" ANSWER KMEXPR-WITH-COMMENTS))))
         (T
          (COND (TARGET (KM-TRACE 'FAIL "<- FAIL!~40T [~a, for ~a]" KMEXPR-WITH-COMMENTS TARGET))
           (T (KM-TRACE 'FAIL "<- FAIL!~40T [~a]" KMEXPR-WITH-COMMENTS)))))))
      (COND ((EQ USERS-RESPONSE 'REDO) (RESET-DONE) (KM1 KMEXPR KMEXPR-WITH-COMMENTS :FAIL-MODE FAIL-MODE :TARGET TARGET :PID PID))
       ((EQ USERS-RESPONSE 'FAIL)  (INCREMENT-TRACE-DEPTH) 
        (PROCESS-KM1-RESULT NIL KMEXPR KMEXPR-WITH-COMMENTS :FAIL-MODE FAIL-MODE :TARGET TARGET :HANDLER-PATTERN :PID PID))
       (T ANSWER))))))))
;;;; Temp function
(TRACE-LISP
 (DEFINE PROCESS-PROOF-NODE (PID PARENT-PID DEPTH KMEXPR ANSWER HANDLER-PATTERN)
  (trace-defun 'PROCESS-PROOF-NODE (PID PARENT-PID DEPTH KMEXPR ANSWER HANDLER-PATTERN)
   (RET
    (KM-FORMAT T "PID~a: [parent PID~a]~25T ~a~vT~a = ~a ~100T [using rule for: ~a]~%" PID PARENT-PID DEPTH (+ DEPTH 30) KMEXPR ANSWER
     HANDLER-PATTERN)))))
;;;; ----------------------------------------
;;;; km-unique: Expected to return EXACTLY *one* value, otherwise a warning is generated.
;;;; ----------------------------------------
;;;; EXTERNAL, from some other application
(TRACE-LISP
 (DEFINE KM-UNIQUE (KMEXPR &REST LKEYS)
  (trace-defun 'KM-UNIQUE (KMEXPR LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE *TOP-LEVEL-FAIL-MODE*) (RESET-INFERENCE-ENGINE)
     (CLET ((ANSWER (CATCH 'KM-ABORT (KM-UNIQUE0 KMEXPR :FAIL-MODE FAIL-MODE))))
      (COND ((AND (PAIRP ANSWER) (EQ (FIRST ANSWER) 'KM-ABORT))  (VALUES NIL (SECOND ANSWER))) (T ANSWER))))))))
;;;; ----------
;;;; INTERNAL, from within KM itself.
(TRACE-LISP
 (DEFINE KM-UNIQUE0 (KMEXPR &REST LKEYS)
  (trace-defun 'KM-UNIQUE0 (KMEXPR LKEYS)
   (RET
    (CLET (FAIL-MODE TARGET) (init-keyval FAIL-MODE *DEFAULT-FAIL-MODE*)
     (CLET ((VALS (KM0 KMEXPR :FAIL-MODE FAIL-MODE :TARGET TARGET)))
      (COND ((SINGLETONP VALS) (FIRST VALS))
       (VALS
        (REPORT-ERROR 'USER-ERROR
         "Expression ~a was expected to return a single value,
but it returned multiple values ~a!
Just taking the first...(~a) ~%"
         KMEXPR VALS (FIRST VALS))
        (FIRST VALS))
       ((EQ FAIL-MODE 'ERROR) (REPORT-ERROR 'USER-ERROR "Expression ~a didn't return a value!~%" KMEXPR)))))))))
;;;; ======================================================================
;;;; Handle case-sensitivity and quoted morphism table in load-kb expression
;;;; (load-kb "foo.km" :verbose t :with-morphism '((a -> 1) (b -> 2)))
(TRACE-LISP
 (DEFINE PROCESS-LOAD-EXPRESSION (LOAD-EXPR0)
  (trace-defun 'PROCESS-LOAD-EXPRESSION (LOAD-EXPR0)
   (RET
    (CLET
     ((LOAD-EXPR
       (SUBLIS '((:|verbose| . :VERBOSE)  (:|eval-instances| . :EVAL-INSTANCES) (:|with-morphism| . :WITH-MORPHISM) (:|load-patterns| . :LOAD-PATTERNS))
        LOAD-EXPR0)))
     (CASE (FIRST LOAD-EXPR)
      ((CL-LOAD-KB |load-kb|)
       (MULTIPLE-VALUE-BIND (RESULT ERROR) (APPLY #'LOAD-KB0 (REST LOAD-EXPR)) (DECLARE (IGNORE RESULT))
        (COND (ERROR (PRINC ERROR) (THROW 'KM-ABORT (LIST 'KM-ABORT ERROR)))  (T '(|t|)))))
      ((RELOAD-KB |reload-kb|)
       (MULTIPLE-VALUE-BIND (RESULT ERROR) (APPLY #'RELOAD-KB0 (REST LOAD-EXPR)) (DECLARE (IGNORE RESULT))
        (COND (ERROR (PRINC ERROR) (THROW 'KM-ABORT (LIST 'KM-ABORT ERROR))) (T '(|t|)))))))))))
;;;; ======================================================================
;;;; The association list is a set of pairs of form (pattern function).
;;;; Function gets applied to the values of variables in pattern, the
;;;; values stored in a list in the order they were encountered 
;;;; when (depth-first) traversing the km expression.
;;;; Below: two alternative ways of embedding Lisp code
;;;; `,;'(lambda () ....) 	<- marginally faster, but can't be manipulated
;;;; '(lambda (...))
;;;; 4.15.99 Changed `(a ,frame with . ,slotsvals) to `(a ,frame with ,@slotsvals), as Lucid problem
;;;; for writing out the flattened-out code:
;;;; 	(write '`(a ,frame with . ,slotsvals)) -> `(A ,FRAME WITH EXCL::BQ-COMMA SLOTSVALS) = Lucid-specific!!
;;;; 	(write '`(a ,frame with ,@slotsvals)) -> `(A ,FRAME WITH ,@SLOTSVALS) = readable by other Lisps
;;;; v1.4.0 - order in terms of utility for speed!
(TRACE-LISP
 (CSETQ *KM-HANDLER-ALIST*
  '(      
    ((|the| ?SLOT |of| ?FRAMEADD)
     (LAMBDA (FMODE0 SLOT FRAMEADD) 
      (COND ((STRUCTURED-SLOTP SLOT) (FOLLOW-MULTIDEPTH-PATH (KM0 FRAMEADD :FAIL-MODE FMODE0)  SLOT '* :FAIL-MODE FMODE0)) 
       ((PATHP SLOT) (LET ((EVAL-SLOT (KM-UNIQUE0 SLOT :FAIL-MODE 'ERROR))) (KM0 `(|the| ,EVAL-SLOT |of| ,FRAMEADD) :FAIL-MODE FMODE0)))
       (T
        (LET*
         ((FMODE (COND ((BUILT-IN-AGGREGATION-SLOT SLOT) 'FAIL) (T FMODE0)))  
          (FRAMES
           (COND ((EVERY #'IS-SIMPLE-KM-TERM (VAL-TO-VALS FRAMEADD))   (REMOVE-DUP-INSTANCES (VAL-TO-VALS FRAMEADD))) 
            (T (KM0 FRAMEADD :FAIL-MODE FMODE :CHECK-FOR-LOOPING NIL)))))
          (COND ((EQ *DEPTH* 1) (SETQ *LAST-QUESTION* `(|the| ,SLOT |of| ,(VALS-TO-VAL FRAMES))))) 
         (COND
          ((NOT (EQUAL FRAMES (VAL-TO-VALS FRAMEADD))) (REMOVE-IF-NOT #'IS-KM-TERM (KM0 `(|the| ,SLOT |of| ,(VALS-TO-VAL FRAMES)) :FAIL-MODE FMODE))) 
          (T (REMOVE-IF-NOT #'IS-KM-TERM (KM-MULTI-SLOTVALS FRAMES SLOT :FAIL-MODE FMODE)))))))))
     ((|a| ?CLASS) (LAMBDA (_FMODE CLASS) (DECLARE (IGNORE _FMODE)) (LIST (CREATE-INSTANCE CLASS))))
    ((|a| ?CLASS |called| ?TAG)
     (LAMBDA (_FMODE CLASS TAG) (DECLARE (IGNORE _FMODE)) (KM-SETQ '*ARE-SOME-TAGS* T)
      (COND ((KM-TAGP TAG) (LIST (CREATE-INSTANCE CLASS `((|called| ,(VAL-TO-VALS TAG))))))
       (T (REPORT-ERROR 'USER-ERROR "~a~%    - The tag `~a' must be an atom or a constraint!" `(|a| ,CLASS |called| ,TAG) TAG)))))
    ((|a| ?CLASS |uniquely-called| ?TAG)
     (LAMBDA (_FMODE CLASS TAG) (DECLARE (IGNORE _FMODE)) (KM-SETQ '*ARE-SOME-CONSTRAINTS* T) (KM-SETQ '*ARE-SOME-TAGS* T)
      (COND ((KM-TAGP TAG) (LIST (CREATE-INSTANCE CLASS `((|uniquely-called| ,(VAL-TO-VALS TAG))))))
       (T (REPORT-ERROR 'USER-ERROR "~a~%    - The tag `~a' must be an atom or a constraint!" `(|a| ,CLASS |uniquely-called| ,TAG) TAG)))))
    ((|a| ?CLASS |with| &REST)
     (LAMBDA (_FMODE CLASS SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (COND
       ((ARE-SLOTSVALS SLOTSVALS)
        (LET ((INSTANCE (CREATE-INSTANCE CLASS (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS)))) (COND ((AM-IN-PROTOTYPE-MODE) (KM0 '(|evaluate-paths|))))
          (LIST INSTANCE))))))
    ((|a| ?CLASS |uniquely-called| ?TAG |with| &REST)
     (LAMBDA (_FMODE CLASS TAG SLOTSVALS) (DECLARE (IGNORE _FMODE)) (KM-SETQ '*ARE-SOME-CONSTRAINTS* T) (KM-SETQ '*ARE-SOME-TAGS* T)
      (COND
       ((NOT (KM-TAGP TAG))
        (REPORT-ERROR 'USER-ERROR "~a~%   - The tag `~a' must be an atom or a constraint!" `(|a| ,CLASS |uniquely-called| ,TAG |with| ,@SLOTSVALS) TAG))
       ((ARE-SLOTSVALS SLOTSVALS)
        (LET ((INSTANCE (CREATE-INSTANCE CLASS (CONS `(|uniquely-called| ,(VAL-TO-VALS TAG)) (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS)))))
         (COND ((AM-IN-PROTOTYPE-MODE) (KM0 '(|evaluate-paths|))))  (LIST INSTANCE))))))
    ((|a| ?CLASS |called| ?TAG |with| &REST)
     (LAMBDA (_FMODE CLASS TAG SLOTSVALS) (DECLARE (IGNORE _FMODE)) (KM-SETQ '*ARE-SOME-TAGS* T)
      (COND
       ((NOT (KM-TAGP TAG))
        (REPORT-ERROR 'USER-ERROR "~a~%   - The tag `~a' must be an atom or a constraint!" `(|a| ,CLASS |called| ,TAG |with| ,@SLOTSVALS) TAG))
       ((ARE-SLOTSVALS SLOTSVALS)
        (LET ((INSTANCE (CREATE-INSTANCE CLASS (CONS `(|called| ,(VAL-TO-VALS TAG)) (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS)))))
         (COND ((AM-IN-PROTOTYPE-MODE) (KM0 '(|evaluate-paths|))))  (LIST INSTANCE))))))
            
    #| 
Remove this now - require user to explicitly use "assertions" slot
;;; Special rewrite for situations:
;;;    (a Situation in-which '(Fred has (leg (*Broken))) '(Joe has (feeling (*Sad))))
;;; -> (a Situation with (assertions ('(Fred has (leg (*Broken))) '(Joe has (feeling (*Sad))))))
    ( (X$a ?situation-class X$in-which &rest)
      (lambda (fmode situation-class assertions)
;	(print assertions)
	(cond ((not (is-subclass-of situation-class 'X$Situation))
	       (report-error 'user-error "~a:~%   Can't do this! (~a is not a subclass of Situation!)~%" 
			     `X$(a ,SITUATION-CLASS in-which ,@ASSERTIONS) situation-class))
	      ((some X'(lambda (assertion) (not (quoted-expressionp assertion))) assertions)
	       (report-error 'user-error "~a:~%   `in-which' must be followed by a list of quoted assertions!
   e.g. (a Situation in-which '(Fred has (leg (*Broken))) '(Joe has (feeling (*Sad))))~%"
			     `X$(a ,SITUATION-CLASS in-which ,@ASSERTIONS) situation-class))
	      (t (km0 `X$(a ,SITUATION-CLASS with (assertions ,ASSERTIONS)) :fail-mode fmode)))))|#
                  ((|a-prototype| ?CLASS) (LAMBDA (FMODE CLASS) (KM0 `(|a-prototype| ,CLASS |with|) :FAIL-MODE FMODE))) 
    ((|a-prototype| ?CLASS |with| &REST)
     (LAMBDA (_FMODE CLASS SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (COND ((AM-IN-LOCAL-SITUATION) (REPORT-ERROR 'USER-ERROR "Can't enter prototype mode when in a Situation!~%"))
       ((AM-IN-PROTOTYPE-MODE)
        (REPORT-ERROR 'USER-ERROR
         "~a~%Attempt to enter prototype mode while already in prototype mode (not allowed)!~%Perhaps you are missing an (end-prototype)?"
         `(|a-prototype| ,CLASS |with| ,@SLOTSVALS)))
       ((ARE-SLOTSVALS SLOTSVALS) (NEW-CONTEXT)
        (KM-SETQ '*CURR-PROTOTYPE*
         (CREATE-INSTANCE CLASS
          `((|prototype-of| (,CLASS)) 
            ,(COND (SLOTSVALS `(|prototype-scope| ((|the-class| ,CLASS |with| ,@SLOTSVALS)))) (T `(|prototype-scope| (,CLASS)))) ,@SLOTSVALS)
          *PROTO-MARKER-STRING*  NIL))
         (ADD-VAL *CURR-PROTOTYPE* '|prototype-participants| *CURR-PROTOTYPE*)  (KM-SETQ '*ARE-SOME-PROTOTYPES* T) 
        (COND ((NULL SLOTSVALS) (ADD-TO-PROTOTYPE-DEFINITION *CURR-PROTOTYPE* `(|a-prototoype| ,CLASS)))
         (T (ADD-TO-PROTOTYPE-DEFINITION *CURR-PROTOTYPE* `(|a-prototype| ,CLASS |with| ,@SLOTSVALS))))
        (LIST *CURR-PROTOTYPE*)))))
    ((|end-prototype|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE))    (KM-SETQ '*CURR-PROTOTYPE* NIL) (GLOBAL-SITUATION) (NEW-CONTEXT) '(|t|)))
    ((|clone| ?EXPR)
     (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE)) (LET ((SOURCE (KM-UNIQUE0 EXPR :FAIL-MODE 'ERROR))) (COND (SOURCE (LIST (CLONE SOURCE)))))))
    #| Appears to be obsolete
    ( (X$add-clones-to ?expr)
      (lambda (fmode expr)
	(let ( (source (km-unique0 expr :fail-mode 'error)) )
	  (cond (source (unify-in-prototypes source)
			(list source))))) )|#
    ((|evaluate-paths|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (EVAL-INSTANCES) '(|t|)))  
    ((|fluent-instancep| ?EXPR)  (LAMBDA (FMODE EXPR) (COND ((FLUENT-INSTANCEP (KM-UNIQUE0 EXPR :FAIL-MODE FMODE)) '(|t|)))))
    ((|default-fluent-status| &REST) (LAMBDA (FMODE REST) (DECLARE (IGNORE FMODE)) (DEFAULT-FLUENT-STATUS (FIRST REST))))  
    ((|must-be-a| ?CLASS) (LAMBDA (_FMODE _CLASS) (DECLARE (IGNORE _FMODE _CLASS)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|possible-values| ?VALUES) (LAMBDA (_FMODE _VALUES) (DECLARE (IGNORE _FMODE _VALUES)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|excluded-values| ?VALUES) (LAMBDA (_FMODE _VALUES) (DECLARE (IGNORE _FMODE _VALUES)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|must-be-a| ?CLASS |with| &REST)
     (LAMBDA (_FMODE _CLASS SLOTSVALS) (DECLARE (IGNORE _FMODE _CLASS)) (ARE-SLOTSVALS SLOTSVALS)  (NOTE-ARE-CONSTRAINTS) NIL))
    ((|mustnt-be-a| ?CLASS) (LAMBDA (_FMODE _CLASS) (DECLARE (IGNORE _FMODE _CLASS)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|mustnt-be-a| ?CLASS |with| &REST)
     (LAMBDA (_FMODE _CLASS SLOTSVALS) (DECLARE (IGNORE _FMODE _CLASS)) (ARE-SLOTSVALS SLOTSVALS)  (NOTE-ARE-CONSTRAINTS) NIL))
     ((<> ?VAL) (LAMBDA (_FMODE _VAL) (DECLARE (IGNORE _FMODE _VAL)) (NOTE-ARE-CONSTRAINTS) NIL))   
    ((|no-inheritance|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE))) NIL)
    ((|constraint| ?EXPR)  (LAMBDA (_FMODE _EXPR) (DECLARE (IGNORE _FMODE _EXPR)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|set-constraint| ?EXPR)  (LAMBDA (_FMODE _EXPR) (DECLARE (IGNORE _FMODE _EXPR)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|set-filter| ?EXPR)  (LAMBDA (_FMODE _EXPR) (DECLARE (IGNORE _FMODE _EXPR)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|at-least| ?N ?CLASS) (LAMBDA (_FMODE _N _CLASS) (DECLARE (IGNORE _FMODE _N _CLASS)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|at-most| ?N ?CLASS) (LAMBDA (_FMODE _N _CLASS) (DECLARE (IGNORE _FMODE _N _CLASS)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|exactly| ?N ?CLASS) (LAMBDA (_FMODE _N _CLASS) (DECLARE (IGNORE _FMODE _N _CLASS)) (NOTE-ARE-CONSTRAINTS) NIL))
    ((|sanity-check| ?EXPR)  (LAMBDA (FMODE EXPR) (COND (*SANITY-CHECKS* (KM0 EXPR :FAIL-MODE FMODE)) (T '(|t|)))))    
    ((|every| ?CEXPR |has| &REST)
     (LAMBDA (_FMODE CEXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((CLASS (KM-UNIQUE0 CEXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP CLASS))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,CEXPR |has| ,@SLOTSVALS) CEXPR))
        ((ARE-SLOTSVALS SLOTSVALS) 
         (LET*
          ((SLOTSVALS00 (COND (*RECORD-SOURCES* (ANNOTATE-SLOTSVALS SLOTSVALS (MAKE-SOURCE CLASS))) (T SLOTSVALS)))
           (SLOTSVALS0 (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS00)))
          (ADD-SLOTSVALS CLASS SLOTSVALS0 :FACET 'MEMBER-PROPERTIES :INSTALL-INVERSESP NIL))
         (COND
          ((AND (ASSOC '|assertions| SLOTSVALS) (NOT (MEMBER CLASS *CLASSES-USING-ASSERTIONS-SLOT*)))
           (KM-SETQ '*CLASSES-USING-ASSERTIONS-SLOT* (CONS CLASS *CLASSES-USING-ASSERTIONS-SLOT*))))
         (MAPC #'UN-DONE (ALL-INSTANCES CLASS)) (LIST CLASS))))))
    ((|every| ?CEXPR |also-has| &REST)
     (LAMBDA (_FMODE CEXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((CLASS (KM-UNIQUE0 CEXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP CLASS))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,CEXPR |also-has| ,@SLOTSVALS) CEXPR))
        ((ARE-SLOTSVALS SLOTSVALS) 
         (LET*
          ((SLOTSVALS00 (COND (*RECORD-SOURCES* (ANNOTATE-SLOTSVALS SLOTSVALS (MAKE-SOURCE CLASS))) (T SLOTSVALS)))
           (SLOTSVALS0 (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS00)))
          (ADD-SLOTSVALS CLASS SLOTSVALS0 :FACET 'MEMBER-PROPERTIES :INSTALL-INVERSESP NIL :COMBINE-VALUES-BY 'APPENDING))
         (COND
          ((AND (ASSOC '|assertions| SLOTSVALS) (NOT (MEMBER CLASS *CLASSES-USING-ASSERTIONS-SLOT*)))  
           (KM-SETQ '*CLASSES-USING-ASSERTIONS-SLOT* (CONS CLASS *CLASSES-USING-ASSERTIONS-SLOT*))))
         (MAPC #'UN-DONE (ALL-INSTANCES CLASS)) (LIST CLASS))))))
    ((|every| ?CEXPR |now-has| &REST)
     (LAMBDA (_FMODE CEXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((CLASS (KM-UNIQUE0 CEXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP CLASS))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,CEXPR |now-has| ,@SLOTSVALS) CEXPR))
        ((ARE-SLOTSVALS SLOTSVALS) 
         (LET*
          ((SLOTSVALS00 (COND (*RECORD-SOURCES* (ANNOTATE-SLOTSVALS SLOTSVALS (MAKE-SOURCE CLASS))) (T SLOTSVALS)))
           (SLOTSVALS0 (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS00)))
          (ADD-SLOTSVALS CLASS SLOTSVALS0 :FACET 'MEMBER-PROPERTIES :INSTALL-INVERSESP NIL :COMBINE-VALUES-BY 'OVERWRITING))
         (COND
          ((AND (ASSOC '|assertions| SLOTSVALS) (NOT (MEMBER CLASS *CLASSES-USING-ASSERTIONS-SLOT*)))  
           (KM-SETQ '*CLASSES-USING-ASSERTIONS-SLOT* (CONS CLASS *CLASSES-USING-ASSERTIONS-SLOT*))))
         (MAPC #'UN-DONE (ALL-INSTANCES CLASS)) (LIST CLASS))))))
      
    ((?INSTANCE-EXPR |has| &REST)
     (LAMBDA (_FMODE INSTANCE-EXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((INSTANCE (KM-UNIQUE0 INSTANCE-EXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP INSTANCE))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,INSTANCE-EXPR |has| ,@SLOTSVALS) INSTANCE-EXPR))
        ((ARE-SLOTSVALS SLOTSVALS)  (ADD-SLOTSVALS INSTANCE (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS)) (MAKE-ASSERTIONS INSTANCE SLOTSVALS)
         (UN-DONE INSTANCE)  (CLASSIFY INSTANCE :SLOTS-THAT-CHANGED (MAPCAR #'SLOT-IN SLOTSVALS)) 
         (COND ((AM-IN-PROTOTYPE-MODE) (KM0 '(|evaluate-paths|))))  (LIST INSTANCE))))))
    ((?INSTANCE-EXPR |also-has| &REST)
     (LAMBDA (_FMODE INSTANCE-EXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((INSTANCE (KM-UNIQUE0 INSTANCE-EXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP INSTANCE))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,INSTANCE-EXPR |also-has| ,@SLOTSVALS) INSTANCE-EXPR))
        ((ARE-SLOTSVALS SLOTSVALS)  (ADD-SLOTSVALS INSTANCE (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS) :COMBINE-VALUES-BY 'APPENDING)
         (UN-DONE INSTANCE)  (CLASSIFY INSTANCE :SLOTS-THAT-CHANGED (MAPCAR #'SLOT-IN SLOTSVALS)) 
         (COND ((AM-IN-PROTOTYPE-MODE) (KM0 '(|evaluate-paths|))))  (LIST INSTANCE))))))
     
    ((?INSTANCE-EXPR |now-has| &REST)
     (LAMBDA (_FMODE INSTANCE-EXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((INSTANCE (KM-UNIQUE0 INSTANCE-EXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP INSTANCE))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,INSTANCE-EXPR |now-has| ,@SLOTSVALS) INSTANCE-EXPR))
        ((ARE-SLOTSVALS SLOTSVALS)  (ADD-SLOTSVALS INSTANCE (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS) :COMBINE-VALUES-BY 'OVERWRITING)      
         (LIST INSTANCE))))))
      
    ((?TARGET :== (?XS && &REST))
     (LAMBDA (FMODE TARGET XS REST) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,XS && ,@REST) :FAIL-MODE 'ERROR :JOINER '&& :TARGET TARGET)))
    ((?XS && &REST) (LAMBDA (FMODE XS REST) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,XS && ,@REST) :FAIL-MODE 'ERROR :JOINER '&&)))
    ((?TARGET :== (?X & &REST))
     (LAMBDA (FMODE TARGET X REST) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,X & ,@REST) :FAIL-MODE 'ERROR :JOINER '& :TARGET TARGET)))
    ((?X & &REST) (LAMBDA (FMODE X REST) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,X & ,@REST) :FAIL-MODE 'ERROR :JOINER '&)))
    ((?XS === &REST) (LAMBDA (FMODE XS REST) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,XS === ,@REST) :FAIL-MODE 'ERROR :JOINER '===)))
    ((?X == ?Y) (LAMBDA (FMODE X Y) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,X == ,Y) :FAIL-MODE 'ERROR :JOINER '==)))
    ((?X /== ?Y)
     (LAMBDA (FMODE X Y) (DECLARE (IGNORE FMODE))
      (LET ((XV (KM-UNIQUE0 X :FAIL-MODE 'ERROR)) (YV (KM-UNIQUE0 Y :FAIL-MODE 'ERROR)))
       (COND ((EQUAL XV YV) (REPORT-ERROR 'USER-ERROR "(~a /== ~a): ~a and ~a are the same object!~%" X Y X Y))
        ((KB-OBJECTP XV) (KM0 `(,XV |has| (/== (,YV))) :FAIL-MODE 'ERROR)) ((KB-OBJECTP YV) (KM0 `(,YV |has| (/== (,XV))) :FAIL-MODE 'ERROR))
        ('(|t|))))))
      ((?XS &&! &REST) (LAMBDA (FMODE XS REST) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,XS &&! ,@REST) :FAIL-MODE 'ERROR :JOINER '&&!)))
    ((?X &! &REST) (LAMBDA (FMODE X REST) (DECLARE (IGNORE FMODE)) (LAZY-UNIFY-&-EXPR `(,X &! ,@REST) :FAIL-MODE 'ERROR :JOINER '&!))) 
    ((?X &? ?Y) 
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (COND ((NULL X) '(|t|)) ((NULL Y) '(|t|))
       ((EXISTENTIAL-EXPRP Y) (LET ((XF (KM-UNIQUE0 X))) (COND ((NULL XF) '(|t|)) ((UNIFIABLE-WITH-EXISTENTIAL-EXPR XF Y) '(|t|)))))
       ((EXISTENTIAL-EXPRP X) (LET ((YF (KM-UNIQUE0 Y))) (COND ((NULL YF) '(|t|)) ((UNIFIABLE-WITH-EXISTENTIAL-EXPR YF X) '(|t|)))))
       (T
        (LET ((XV (KM-UNIQUE0 X)))
         (COND ((NULL XV) '(|t|)) (T (LET ((YV (KM-UNIQUE0 Y))) (COND ((NULL YV) '(|t|)) ((TRY-LAZY-UNIFY XV YV) '(|t|)))))))))))
     
    ((?X &+? ?Y) 
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (COND
       ((EXISTENTIAL-EXPRP Y) (LET ((XF (KM-UNIQUE0 X))) (COND ((NULL XF) '(|t|)) ((UNIFIABLE-WITH-EXISTENTIAL-EXPR XF Y :CLASSES-SUBSUMEP T) '(|t|)))))
       ((EXISTENTIAL-EXPRP X) (LET ((YF (KM-UNIQUE0 Y))) (COND ((NULL YF) '(|t|)) ((UNIFIABLE-WITH-EXISTENTIAL-EXPR YF X :CLASSES-SUBSUMEP T) '(|t|)))))
       (T
        (LET ((XV (KM-UNIQUE0 X)))
         (COND ((NULL XV) '(|t|)) (T (LET ((YV (KM-UNIQUE0 Y))) (COND ((NULL YV) '(|t|)) ((TRY-LAZY-UNIFY XV YV :CLASSES-SUBSUMEP T) '(|t|)))))))))))
          
    ((?TARGET :== (?X &+ ?Y))
     (LAMBDA (FMODE TARGET X Y)
      (LET ((UNIFICATION (LAZY-UNIFY-EXPRS X Y :CLASSES-SUBSUMEP T :FAIL-MODE FMODE :TARGET TARGET)))
       (COND (UNIFICATION (LIST UNIFICATION)) ((EQ FMODE 'ERROR) (REPORT-ERROR 'USER-ERROR "Unification (~a &+ ~a) failed!~%" X Y))))))
    ((?X &+ ?Y)
     (LAMBDA (FMODE X Y)
      (LET ((UNIFICATION (LAZY-UNIFY-EXPRS X Y :CLASSES-SUBSUMEP T :FAIL-MODE FMODE)))
       (COND (UNIFICATION (LIST UNIFICATION)) ((EQ FMODE 'ERROR) (REPORT-ERROR 'USER-ERROR "Unification (~a &+ ~a) failed!~%" X Y))))))
       
    ((?X = ?Y)
     (LAMBDA (FMODE X Y) (LET ((XV (KM0 X :FAIL-MODE FMODE)) (YV (KM0 Y :FAIL-MODE FMODE))) (COND ((KM-SET-EQUAL (DEREFERENCE XV) YV) '(|t|))))))
    
    ((?X /= ?Y)
     (LAMBDA (FMODE X Y) (LET ((XV (KM0 X :FAIL-MODE FMODE)) (YV (KM0 Y :FAIL-MODE FMODE))) (COND ((NOT (KM-SET-EQUAL (DEREFERENCE XV) YV)) '(|t|))))))
    
    ((|the| ?CLASS ?SLOT |of| ?FRAMEADD)
     (LAMBDA (FMODE0 CLASS SLOT FRAMEADD) 
      (COND ((STRUCTURED-SLOTP SLOT) (FOLLOW-MULTIDEPTH-PATH (KM0 FRAMEADD :FAIL-MODE FMODE0)  SLOT CLASS :FAIL-MODE FMODE0))
       ((PATHP SLOT) (LET ((EVAL-SLOT (KM-UNIQUE0 SLOT :FAIL-MODE 'ERROR))) (KM0 `(|the| ,CLASS ,EVAL-SLOT |of| ,FRAMEADD) :FAIL-MODE FMODE0)))
       (T
        (LET* ((FMODE (COND ((BUILT-IN-AGGREGATION-SLOT SLOT) 'FAIL) (T FMODE0))))
         (VALS-IN-CLASS (KM0 `(|the| ,SLOT |of| ,FRAMEADD) :FAIL-MODE FMODE) CLASS))))))
       ((|in-theory| ?THEORY-EXPR) (LAMBDA (_FMODE THEORY-EXPR) (DECLARE (IGNORE _FMODE)) (IN-THEORY THEORY-EXPR)))
    ((|in-theory| ?THEORY-EXPR ?KM-EXPR) (LAMBDA (_FMODE THEORY-EXPR KM-EXPR) (DECLARE (IGNORE _FMODE)) (IN-THEORY THEORY-EXPR KM-EXPR)))
    ((|hide-theory| ?THEORY-EXPR)
     (LAMBDA (_FMODE THEORY-EXPR) (DECLARE (IGNORE _FMODE)) (MAPC #'HIDE-THEORY (KM0 THEORY-EXPR)) (COND ((VISIBLE-THEORIES)) (T '(|t|)))))
    ((|see-theory| ?THEORY-EXPR) (LAMBDA (_FMODE THEORY-EXPR) (DECLARE (IGNORE _FMODE)) (MAPC #'SEE-THEORY (KM0 THEORY-EXPR)) (VISIBLE-THEORIES)))
    ((|end-theory|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (IN-SITUATION *GLOBAL-SITUATION*)))
    ((|visible-theories|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (VISIBLE-THEORIES)))    
    ((|in-situation| ?SITUATION-EXPR) (LAMBDA (_FMODE SITUATION-EXPR) (DECLARE (IGNORE _FMODE)) (IN-SITUATION SITUATION-EXPR)))
    ((|in-situation| ?SITUATION (|the| ?SLOT |of| ?FRAME)) 
     (LAMBDA (_FMODE SITUATION SLOT FRAME)  (DECLARE (IGNORE _FMODE)) 
      (COND
       ((AND (KB-OBJECTP SITUATION) (ISA SITUATION '|Situation|)  (ALREADY-DONE FRAME SLOT))  #|OLD|#
        (REMOVE-CONSTRAINTS (GET-VALS FRAME SLOT :SITUATION (TARGET-SITUATION SITUATION FRAME SLOT))))
         (T (IN-SITUATION SITUATION `(|the| ,SLOT |of| ,FRAME))))))
    ((|in-situation| ?SITUATION-EXPR ?KM-EXPR) (LAMBDA (_FMODE SITUATION-EXPR KM-EXPR) (DECLARE (IGNORE _FMODE)) (IN-SITUATION SITUATION-EXPR KM-EXPR)))
    ((|end-situation|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (IN-SITUATION *GLOBAL-SITUATION*)))
    ((|global-situation|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (IN-SITUATION *GLOBAL-SITUATION*)))
    ((|new-situation|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (NEW-SITUATION)))  
    ((|do| ?ACTION-EXPR) (LAMBDA (_FMODE ACTION-EXPR) (DECLARE (IGNORE _FMODE)) (LIST (DO-ACTION ACTION-EXPR)))) 
    ((|do-and-next| ?ACTION-EXPR) (LAMBDA (_FMODE ACTION-EXPR) (DECLARE (IGNORE _FMODE)) (LIST (DO-ACTION ACTION-EXPR :CHANGE-TO-NEXT-SITUATION T)))) 
    ((|try-do| ?ACTION-EXPR) (LAMBDA (_FMODE ACTION-EXPR) (DECLARE (IGNORE _FMODE)) (LIST (DO-ACTION ACTION-EXPR :TEST-OR-ASSERT-PCS 'TEST)))) 
    ((|try-do-and-next| ?ACTION-EXPR)
     (LAMBDA (_FMODE ACTION-EXPR) (DECLARE (IGNORE _FMODE)) (LIST (DO-ACTION ACTION-EXPR :CHANGE-TO-NEXT-SITUATION T :TEST-OR-ASSERT-PCS 'TEST))))
     ((|do-script| ?SCRIPT) (LAMBDA (FMODE SCRIPT) (KM0 `(|forall| (|the| |actions| |of| ,SCRIPT) (|do-and-next| |It|)) :FAIL-MODE FMODE)))
    ((|do-plan| ?PLAN-INSTANCE-EXPR)
     (LAMBDA (_FMODE PLAN-INSTANCE-EXPR) (DECLARE (IGNORE _FMODE)) (LET ((PLAN-INSTANCE (KM-UNIQUE PLAN-INSTANCE-EXPR))) (DO-PLAN PLAN-INSTANCE))))
      
    ((|assert| ?TRIPLE-EXPR)
     (LAMBDA (_FMODE TRIPLE-EXPR) (DECLARE (IGNORE _FMODE))
      (LET ((TRIPLE (KM-UNIQUE0 TRIPLE-EXPR)))
       (COND
        ((NOT (KM-TRIPLEP TRIPLE))
         (REPORT-ERROR 'USER-ERROR "(assert ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" TRIPLE-EXPR TRIPLE))
        (T (KM0 `(,(ARG1OF TRIPLE) |has| (,(ARG2OF TRIPLE) ,(VAL-TO-VALS (ARG3OF TRIPLE)))) :FAIL-MODE 'ERROR))))))
    ((|is-true| ?TRIPLE-EXPR)
     (LAMBDA (_FMODE TRIPLE-EXPR) (DECLARE (IGNORE _FMODE))
      (LET* ((TRIPLE (KM-UNIQUE0 TRIPLE-EXPR)))
       (COND
        ((NOT (KM-TRIPLEP TRIPLE))
         (REPORT-ERROR 'USER-ERROR "(is-true ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" TRIPLE-EXPR TRIPLE))
        ((COMPARISON-OPERATOR (ARG2OF TRIPLE)) (KM0 `(,(SECOND TRIPLE) ,(THIRD TRIPLE) ,(FOURTH TRIPLE))))
        (T
         (LET ((FRAME (KM-UNIQUE0 (SECOND TRIPLE) :FAIL-MODE 'ERROR)) (SLOT (KM-UNIQUE0 (THIRD TRIPLE) :FAIL-MODE 'ERROR)) (VALUE (FOURTH TRIPLE))) 
          (COND ((NULL VALUE) '(|t|)) ((KM0 `(,FRAME |is| '(|a| |Thing| |with| (,SLOT (,VALUE)))))))))))))
      
    ((|all-true| ?TRIPLES-EXPR)
     (LAMBDA (_FMODE TRIPLES-EXPR) (DECLARE (IGNORE _FMODE))
      (LET ((TRIPLES (KM0 TRIPLES-EXPR))) (COND ((EVERY #'(LAMBDA (TRIPLE) (KM0 `(|is-true| ,TRIPLE))) TRIPLES) '(|t|))))))
    ((|some-true| ?TRIPLES-EXPR)
     (LAMBDA (_FMODE TRIPLES-EXPR) (DECLARE (IGNORE _FMODE))
      (LET ((TRIPLES (KM0 TRIPLES-EXPR))) (COND ((SOME #'(LAMBDA (TRIPLE) (KM0 `(|is-true| ,TRIPLE))) TRIPLES) '(|t|))))))
    
    ((|next-situation|)
     (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE))
      (COND ((AM-IN-LOCAL-SITUATION) (LIST (DO-ACTION NIL :CHANGE-TO-NEXT-SITUATION T)))
       (T (REPORT-ERROR 'USER-ERROR "Can only do (next-situation) from within a situation!~%")))))
    ((|curr-situation|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (LIST (CURR-SITUATION))))
    ((|ignore-result| ?EXPR)  (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE)) (KM0 EXPR) NIL))
    ((|ignore| ?EXPR)  (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE EXPR)) NIL))  
    ((|in-every-situation| ?SITUATION-CLASS ?EXPR)
     (LAMBDA (FMODE SITUATION-CLASS KM-EXPR)
      (COND
       ((NOT (IS-SUBCLASS-OF SITUATION-CLASS '|Situation|))
        (REPORT-ERROR 'USER-ERROR "~a:~%   Can't do this! (~a is not a subclass of Situation!)~%" `(|in-every-situation| ,SITUATION-CLASS ,KM-EXPR)
         SITUATION-CLASS))
       (T
        (LET ((MODIFIED-EXPR (SUBLIS '((|TheSituation| UNQUOTE |Self|) (|Self| . |SubSelf|)) KM-EXPR)))
         (KM0 `(|in-situation| ,*GLOBAL-SITUATION* (|every| ,SITUATION-CLASS |has| (|assertions| (',MODIFIED-EXPR)))) :FAIL-MODE FMODE))))))
         ((|new-context|) (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) (CLEAR-OBJ-STACK)  '(|t|)))       
    ((|thelast| ?FRAME)
     (LAMBDA (_FMODE FRAME) (DECLARE (IGNORE _FMODE)) (LET ((LAST-INSTANCE (SEARCH-STACK FRAME))) (COND (LAST-INSTANCE (LIST LAST-INSTANCE))))))
       ((|every| ?FRAME) (LAMBDA (FMODE FRAME) (KM0 `(|every| ,FRAME |with|) :FAIL-MODE FMODE)))
    ((|every| ?FRAME |with| &REST)
     (LAMBDA (_FMODE FRAME SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (COND
       ((ARE-SLOTSVALS SLOTSVALS)
        (LET ((EXISTENTIAL-EXPR (COND ((AND (NULL SLOTSVALS) (PATHP FRAME))  (PATH-TO-EXISTENTIAL-EXPR FRAME)) (T `(|a| ,FRAME |with| ,@SLOTSVALS)))))
         (FIND-SUBSUMEES EXISTENTIAL-EXPR))))))
          
    ((|the| ?FRAME)
     (LAMBDA (FMODE FRAME) (DECLARE (IGNORE FMODE))
      (LET ((ANSWER (KM0 `(|every| ,FRAME))))
       (COND ((NULL ANSWER) (REPORT-ERROR 'USER-ERROR "No values found for expression ~a!~%" `(|the| ,FRAME)))
        ((NOT (SINGLETONP ANSWER))
         (REPORT-ERROR 'USER-ERROR "Expected a single value for expression ~a, but found multiple values ~a!~%" `(|the| ,FRAME) ANSWER))
        (T ANSWER)))))
    ((|the| ?FRAME |with| &REST)
     (LAMBDA (FMODE FRAME SLOTSVALS) (DECLARE (IGNORE FMODE))
      (LET ((ANSWER (KM0 `(|every| ,FRAME |with| ,@SLOTSVALS))))
       (COND ((NULL ANSWER) (REPORT-ERROR 'USER-ERROR "No values found for expression ~a!~%" `(|the| ,FRAME |with| ,@SLOTSVALS)))
        ((NOT (SINGLETONP ANSWER))
         (REPORT-ERROR 'USER-ERROR "Expected a single value for expression ~a, but found multiple values ~a!~%" `(|the| ,FRAME |with| ,@SLOTSVALS)
          ANSWER))
        (T ANSWER)))))
        
    ((|the+| ?SLOT |of| ?FRAMEADD)
     (LAMBDA (_FMODE SLOT FRAMEADD) (DECLARE (IGNORE _FMODE)) (KM0 `(|the+| |Thing| |with| (,(INVERT-SLOT SLOT) (,FRAMEADD))) :FAIL-MODE 'ERROR)))
    ((|the+| ?CLASS ?SLOT |of| ?FRAMEADD)
     (LAMBDA (_FMODE CLASS SLOT FRAMEADD) (DECLARE (IGNORE _FMODE)) (KM0 `(|the+| ,CLASS |with| (,(INVERT-SLOT SLOT) (,FRAMEADD))) :FAIL-MODE 'ERROR)))
    ((|the+| ?FRAME) (LAMBDA (FMODE FRAME) (KM0 `(|the+| ,FRAME |with|) :FAIL-MODE FMODE)))
    ((|the+| ?FRAME |with| &REST)
     (LAMBDA (_FMODE FRAME SLOTSVALS) (DECLARE (IGNORE _FMODE))  
      (LET ((VAL (KM-UNIQUE0 `(|every| ,FRAME |with| ,@SLOTSVALS)))) 
       (COND (VAL (LIST VAL))
        ((ARE-SLOTSVALS SLOTSVALS)
         (LET ((EXISTENTIAL-EXPR (COND ((AND (NULL SLOTSVALS) (PATHP FRAME))  (PATH-TO-EXISTENTIAL-EXPR FRAME)) (T `(|a| ,FRAME |with| ,@SLOTSVALS)))))
          (MAPCAR #'EVAL-INSTANCE (KM0 EXISTENTIAL-EXPR :FAIL-MODE 'ERROR))))))))
     ((|a+| &REST)  (LAMBDA (FMODE REST) (KM0 `(|the+| ,@REST) :FAIL-MODE FMODE)))       
    ((|every| ?CEXPR |has-definition| &REST)
     (LAMBDA (_FMODE CEXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((CLASS (KM-UNIQUE0 CEXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP CLASS))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,CEXPR |has-definition| ,@SLOTSVALS) CEXPR))
        ((ARE-SLOTSVALS SLOTSVALS)
         (LET*
          ((SLOTSVALS00 (COND (*RECORD-SOURCES* (ANNOTATE-SLOTSVALS SLOTSVALS (MAKE-SOURCE CLASS))) (T SLOTSVALS)))
           (SLOTSVALS0 (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS00))
           (PARENTS-OF-DEFINED-CONCEPT (DECOMMENT (VALS-IN (ASSOC '|instance-of| SLOTSVALS0)))))
          (COND
           ((NOT (EVERY #'KB-OBJECTP PARENTS-OF-DEFINED-CONCEPT))
            (REPORT-ERROR 'USER-ERROR "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%"
             `(|every| ,CEXPR |has-definition| ,@SLOTSVALS0)))
           ((NULL PARENTS-OF-DEFINED-CONCEPT)
            (REPORT-ERROR 'USER-ERROR "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%"
             `(|every| ,CEXPR |has-definition| ,@SLOTSVALS0)))
           (T (ADD-SLOTSVALS CLASS SLOTSVALS0 :FACET 'MEMBER-DEFINITION :INSTALL-INVERSESP NIL)
            (POINT-PARENTS-TO-DEFINED-CONCEPT CLASS PARENTS-OF-DEFINED-CONCEPT 'MEMBER-DEFINITION) (KM-SETQ '*ARE-SOME-DEFINITIONS* T)
            (MAPC #'UN-DONE (ALL-INSTANCES CLASS)) (LIST CLASS)))))))))
      
    ((?INSTANCE-EXPR |has-definition| &REST)
     (LAMBDA (_FMODE INSTANCE-EXPR SLOTSVALS) (DECLARE (IGNORE _FMODE))
      (LET ((INSTANCE (KM-UNIQUE0 INSTANCE-EXPR :FAIL-MODE 'ERROR)))
       (COND
        ((NOT (KB-OBJECTP INSTANCE))
         (REPORT-ERROR 'USER-ERROR "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(|every| ,INSTANCE-EXPR |has-definition| ,@SLOTSVALS)
          INSTANCE-EXPR))
        ((ARE-SLOTSVALS SLOTSVALS) 
         (LET* ((SLOTSVALS0 (DECOMMENT SLOTSVALS))  (PARENTS-OF-DEFINED-CONCEPT (DECOMMENT (VALS-IN (ASSOC '|instance-of| SLOTSVALS0)))))
          (COND
           ((NOT (EVERY #'KB-OBJECTP PARENTS-OF-DEFINED-CONCEPT))
            (REPORT-ERROR 'USER-ERROR "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%"
             `(,INSTANCE-EXPR |has-definition| ,@SLOTSVALS0)))
           ((NULL PARENTS-OF-DEFINED-CONCEPT)
            (REPORT-ERROR 'USER-ERROR "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%"
             `(,INSTANCE-EXPR |has-definition| ,@SLOTSVALS0)))
           (T (ADD-SLOTSVALS INSTANCE SLOTSVALS0 :FACET 'OWN-DEFINITION)
            (POINT-PARENTS-TO-DEFINED-CONCEPT INSTANCE PARENTS-OF-DEFINED-CONCEPT 'OWN-DEFINITION) (KM-SETQ '*ARE-SOME-DEFINITIONS* T) (UN-DONE INSTANCE)
             (CLASSIFY INSTANCE :SLOTS-THAT-CHANGED (MAPCAR #'SLOT-IN SLOTSVALS))  (LIST INSTANCE)))))))))
     ((|if| ?CONDITION |then| ?ACTION) (LAMBDA (FMODE CONDITION ACTION) (KM0 `(|if| ,CONDITION |then| ,ACTION |else| NIL) :FAIL-MODE FMODE)))
    ((|if| ?CONDITION |then| ?ACTION |else| ?ALTACTION)
     (LAMBDA (FMODE CONDITION ACTION ALTACTION)
      (LET ((TEST-RESULT (KM0 CONDITION)))
       (COND ((NOT (MEMBER TEST-RESULT '(NIL |f| F))) (KM0 ACTION :FAIL-MODE FMODE)) (T (KM0 ALTACTION :FAIL-MODE FMODE))))))
    ((?X > ?Y)
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (LET ((XVAL (KM-UNIQUE0 X :FAIL-MODE 'ERROR)) (YVAL (KM-UNIQUE0 Y :FAIL-MODE 'ERROR)))
       (COND ((AND (NUMBERP XVAL) (NUMBERP YVAL)) (COND ((> XVAL YVAL) '(|t|))))))))
    ((?X < ?Y)
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (LET ((XVAL (KM-UNIQUE0 X :FAIL-MODE 'ERROR)) (YVAL (KM-UNIQUE0 Y :FAIL-MODE 'ERROR)))
       (COND ((AND (NUMBERP XVAL) (NUMBERP YVAL)) (COND ((< XVAL YVAL) '(|t|))))))))
    ((?X >= ?Y)
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (LET ((XVAL (KM-UNIQUE0 X :FAIL-MODE 'ERROR)) (YVAL (KM-UNIQUE0 Y :FAIL-MODE 'ERROR)))
       (COND ((AND (NUMBERP XVAL) (NUMBERP YVAL)) (COND ((>= XVAL YVAL) '(|t|))))))))
    ((?X <= ?Y)
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (LET ((XVAL (KM-UNIQUE0 X :FAIL-MODE 'ERROR)) (YVAL (KM-UNIQUE0 Y :FAIL-MODE 'ERROR)))
       (COND ((AND (NUMBERP XVAL) (NUMBERP YVAL)) (COND ((<= XVAL YVAL) '(|t|))))))))
    ((?X = ?Y +/- ?Z)
     (LAMBDA (_FMODE X Y Z) (DECLARE (IGNORE _FMODE))
      (LET ((XVAL (KM-UNIQUE0 X :FAIL-MODE 'ERROR)) (YVAL (KM-UNIQUE0 Y :FAIL-MODE 'ERROR)) (ZVAL (KM-UNIQUE0 Z :FAIL-MODE 'ERROR)))
       (COND ((AND (NUMBERP XVAL) (NUMBERP YVAL) (NUMBERP ZVAL)) (COND ((<= (ABS (- XVAL YVAL)) (ABS ZVAL)) '(|t|))))))))
    ((?X = ?Y +/- ?Z %)
     (LAMBDA (_FMODE X Y Z) (DECLARE (IGNORE _FMODE))
      (LET ((XVAL (KM-UNIQUE0 X :FAIL-MODE 'ERROR)) (YVAL (KM-UNIQUE0 Y :FAIL-MODE 'ERROR)) (ZVAL (KM-UNIQUE0 Z :FAIL-MODE 'ERROR)))
       (COND
        ((AND (NUMBERP XVAL) (NUMBERP YVAL) (NUMBERP ZVAL)) (COND ((<= (ABS (- XVAL YVAL)) (* (MAX (ABS XVAL) (ABS YVAL)) (ABS ZVAL) 0.01)) '(|t|))))))))
    
    #|    ( (?x X$isa ?y) (lambda (fmode x y)
		      (let ( (xvals (km0 x)) )		; trap error later (below)
			(cond ((null xvals) 
			       (report-error 'user-error "Doing ~a:~% ~a evaluates to nil (should evaluate to an instance!)" `(,x X$isa ,y) x))
			      ((not (singletonp xvals))
			       (report-error 'user-error "Doing ~a:~% ~a evaluates to multiple values ~a (should evaluate to a single instance!)" 
					     `(,x X$isa ,y) x xvals))
			      ((atom y) (cond ((isa (first xvals) y) 'X$(t))))		; Quick try first
			      ((isa (first xvals) (km-unique0 y :fail-mode fmode)) 'X$(t))))) )|#
    
    ((?X |and| &REST)
     (LAMBDA (_FMODE X REST) (DECLARE (IGNORE _FMODE))
      (COND
       ((AND (LISTP X) (= (LENGTH X) 3) (EQ (SECOND X) '==)) 
        (LET* ((XX (FIRST X)) (YY (THIRD X)))
         (COND ((AND (KM-VARP XX) (KM-VARP YY)) (KM0 (SUBST XX YY REST)))  ((KM-VARP XX) (KM0 (SUBST (VALS-TO-VAL (KM0 YY)) XX REST)))
          ((KM-VARP YY) (KM0 (SUBST (VALS-TO-VAL (KM0 XX)) YY REST)))
          ((AND (LAZY-UNIFY-&-EXPR `(,XX == YY) :FAIL-MODE 'ERROR :JOINER '==) (KM0 REST))))))
       (T (AND (KM0 X) (KM0 REST))))))
    ((?X |or| &REST) (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE)) (OR (AND (NOT (ON-KM-STACKP X)) (KM0 X)) (KM0 Y))))
    ((|not| ?X) (LAMBDA (_FMODE X) (DECLARE (IGNORE _FMODE)) (COND ((NOT (KM0 X)) '(|t|)))))
    ((|numberp| ?X) (LAMBDA (_FMODE X) (DECLARE (IGNORE _FMODE)) (COND ((NUMBERP (KM-UNIQUE0 X)) '(|t|)))))   
    ((?X |is-subsumed-by| ?Y) (LAMBDA (FMODE X Y) (KM0 `(,Y |subsumes| ,X) :FAIL-MODE FMODE)))
    ((?X |subsumes| ?Y)
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (LET ((YV (KM0 Y))) (COND ((NULL YV) '(|t|)) (T (LET ((XV (KM0 X))) (COND ((AND (NOT (NULL XV)) (SUBSUMES XV YV)) '(|t|)))))))))
    ((?X |is-covered-by| ?Y) (LAMBDA (FMODE X Y) (KM0 `(,Y |covers| ,X) :FAIL-MODE FMODE)))           
    ((?X |covers| ?Y) (LAMBDA (FMODE X Y) (KM0 `(,Y |isa| ,X) :FAIL-MODE FMODE)))
    #|    ( (?y X$isa ?x)
      (lambda (_fmode y x)
	   (declare (ignore  _fmode))
	   (let ( (yv (km-unique0 y)) )
	     (cond ((null yv) 'X$(t))
		   (t (let ( (xv (km-unique0 x)) )
			(cond ((null xv) nil)
			      ((kb-objectp xv)
			       (cond ((isa yv xv) 'X$(t)))) ; quick test
			      ((covers (list xv) yv) 'X$(t)))))))) ) ; more complex test for expressions|#
    ((?Y |isa| ?X)
     (LAMBDA (_FMODE Y X) (DECLARE (IGNORE _FMODE))
      (LET* ((YVALS (KM0 Y)) (YV (FIRST YVALS)))
       (COND ((NULL YVALS) (REPORT-ERROR 'USER-ERROR "Doing ~a:~% ~a evaluates to nil (should evaluate to an instance!)" `(,Y |isa| ,X) Y))
        ((NOT (SINGLETONP YVALS))
         (REPORT-ERROR 'USER-ERROR "Doing ~a:~% ~a evaluates to multiple values ~a (should evaluate to a single instance!)" `(,Y |isa| ,X) Y YVALS))
        (T
         (LET* ((XVALS (KM0 X)) (XV (FIRST XVALS)))
          (COND ((NULL XVALS) (REPORT-ERROR 'USER-ERROR "Doing ~a:~% ~a evaluates to nil (should evaluate to something!)" `(,Y |isa| ,X) X))
           ((NOT (SINGLETONP XVALS))
            (REPORT-ERROR 'USER-ERROR "Doing ~a:~% ~a evaluates to multiple values ~a (should evaluate to a single object!)" `(,Y |isa| ,X) X XVALS))
           ((KB-OBJECTP XV) (COND ((ISA YV XV) '(|t|))))  ((COVERS (LIST XV) YV) '(|t|)))))))))
    
    ((?X |is| ?Y)
     (LAMBDA (_FMODE X Y) (DECLARE (IGNORE _FMODE))
      (LET ((XV (KM-UNIQUE0 X))) (COND ((NULL XV) NIL) (T (LET ((YV (KM-UNIQUE0 Y))) (COND ((AND (NOT (NULL YV)) (IS XV YV)) '(|t|)))))))))
    
    ((?XS |includes| ?Y)
     (LAMBDA (_FMODE XS Y) (DECLARE (IGNORE _FMODE))
      (LET ((XS-VALS (KM0 XS)) (Y-VAL (KM-UNIQUE0 Y :FAIL-MODE 'ERROR))) (COND ((MEMBER Y-VAL (DEREFERENCE XS-VALS) :TEST #'EQUAL) '(|t|))))))
    ((?XS |is-superset-of| ?YS)
     (LAMBDA (_FMODE XS YS) (DECLARE (IGNORE _FMODE))
      (LET ((XS-VALS (KM0 XS)) (YS-VALS (KM0 YS))) (COND ((SUBSETP YS-VALS (DEREFERENCE XS-VALS) :TEST #'EQUAL) '(|t|))))))
      
    ((?SEQ-EXPR1 |append| ?SEQ-EXPR2)
     (LAMBDA (_FMODE SEQ-EXPR1 SEQ-EXPR2) (DECLARE (IGNORE _FMODE))
      (LET*
       ((SEQ1 (KM-UNIQUE0 SEQ-EXPR1)) (SEQ2 (KM-UNIQUE0 SEQ-EXPR2))
        (ELTS1
         (COND ((OR (KM-SEQP SEQ1) (KM-BAGP SEQ1)) (SEQ-TO-LIST SEQ1)) ((NULL SEQ1) NIL) ((IS-KM-TERM SEQ1) (LIST SEQ1))
          (T (REPORT-ERROR 'USER-ERROR "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" SEQ-EXPR1 SEQ-EXPR2 SEQ-EXPR1))))
        (ELTS2
         (COND ((OR (KM-SEQP SEQ2) (KM-BAGP SEQ2)) (SEQ-TO-LIST SEQ2)) ((NULL SEQ2) NIL) ((IS-KM-TERM SEQ2) (LIST SEQ2))
          (T (REPORT-ERROR 'USER-ERROR "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" SEQ-EXPR1 SEQ-EXPR2 SEQ-EXPR2))))
        (RESULT-TYPE
         (COND
          ((OR (AND (KM-SEQP SEQ1) (KM-BAGP SEQ2)) (AND (KM-SEQP SEQ2) (KM-BAGP SEQ1)))
           (REPORT-ERROR 'USER-ERROR "(~a append ~a): Elements should be both sequences or both bags!" SEQ-EXPR1 SEQ-EXPR2) ':|seq|)
           ((OR (KM-BAGP SEQ1) (KM-BAGP SEQ2)) ':|bag|) (T ':|seq|))))
        `((,RESULT-TYPE ,@(APPEND ELTS1 ELTS2))))))
       
    ((?EXPR |called| ?TAG)
     (LAMBDA (FMODE EXPR TAG)
      (LET* ((VALS (KM0 EXPR))) (COND (VALS (KM-TRACE 'COMMENT "Now find just those value(s) whose tag = ~a..." TAG)))
       (LET*
        ((TAGS (VAL-TO-VALS TAG))
         (TARGET-VALS
          (REMOVE-IF
           #'(LAMBDA (VAL) (SET-DIFFERENCE TAGS (APPEND (KM0 `(|the| |called| |of| ,VAL)) (KM0 `(|the| |uniquely-called| |of| ,VAL))) :TEST #'EQUAL))
           VALS)))
        (COND
         ((NULL TARGET-VALS)
          (COND
           ((EQ FMODE 'ERROR)
            (REPORT-ERROR 'USER-ERROR "(~a called/uniquely-called ~a): No values of ~a (evaluates to ~a) is called/uniquely-called ~a!" EXPR TAG EXPR
             VALS (VAL-TO-VALS TAG)))
           ))
         (T TARGET-VALS))))))
     ((?EXPR |uniquely-called| ?TAG) (LAMBDA (FMODE EXPR TAG) (KM0 `(,EXPR |called| ,TAG) :FAIL-MODE FMODE)))    
    ((|allof| ?SET |where| ?TEST) (LAMBDA (FMODE SET TEST) (KM0 `(|forall| ,SET |where| ,TEST |It|) :FAIL-MODE FMODE)))  
    ((|allof| ?SET |must| ?TEST)
     (LAMBDA (FMODE SET TEST) (DECLARE (IGNORE FMODE)) (COND ((EVERY #'(LAMBDA (INSTANCE) (KM0 (SUBST INSTANCE '|It| TEST))) (KM0 SET)) '(|t|)))))
    
    ((|allof| ?SET |where| ?TEST2 |must| ?TEST)
     (LAMBDA (FMODE SET TEST2 TEST) (DECLARE (IGNORE FMODE))
      (COND ((EVERY #'(LAMBDA (INSTANCE) (KM0 (SUBST INSTANCE '|It| TEST))) (KM0 `(|allof| ,SET |where| ,TEST2))) '(|t|)))))
    ((|oneof| ?SET |where| ?TEST)
     (LAMBDA (FMODE SET TEST) (DECLARE (IGNORE FMODE))
      (LET ((ANSWER (FIND-IF #'(LAMBDA (MEMBER) (KM0 (SUBST MEMBER '|It| TEST))) (KM0 SET)))) (COND (ANSWER (LIST ANSWER))))))
    
    ((|theoneof| ?SET |where| ?TEST)
     (LAMBDA (FMODE SET TEST) (LET ((VAL (KM-UNIQUE0 `(|forall| ,SET |where| ,TEST |It|) :FAIL-MODE FMODE)))  (COND (VAL (LIST VAL))))))
    ((|forall| ?SET ?VALUE) (LAMBDA (FMODE SET VALUE) (KM0 `(|forall| ,SET |where| T ,VALUE) :FAIL-MODE FMODE)))  
    ((|forall-seq| ?SEQ ?VALUE) (LAMBDA (FMODE SEQ VALUE) (KM0 `(|forall-seq| ,SEQ |where| T ,VALUE) :FAIL-MODE FMODE))) 
    ((|forall-bag| ?BAG ?VALUE) (LAMBDA (FMODE BAG VALUE) (KM0 `(|forall-bag| ,BAG |where| T ,VALUE) :FAIL-MODE FMODE)))     
    ((|forall| ?SET |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE SET CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (REMOVE NIL (MY-MAPCAN #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER '|It| CONSTRAINT)) (KM0 (SUBST MEMBER '|It| VALUE))))) (KM0 SET)))))
     
    ((|forall-seq| ?SEQ |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE SEQ CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (LET ((SEQUENCES (KM0 SEQ)))
       (COND
        ((OR (NOT (SINGLETONP SEQUENCES)) (NOT (KM-SEQP (FIRST SEQUENCES))))
         (REPORT-ERROR 'USER-ERROR "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `(|forall-seq| ,SEQ |where| ,CONSTRAINT ,VALUE) SEQ))
        (T
         (LIST
          (CONS ':|seq|
           (REMOVE 'TO-REMOVE
            (MAPCAR #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER '|It| CONSTRAINT)) (VALS-TO-VAL (KM0 (SUBST MEMBER '|It| VALUE)))) (T 'TO-REMOVE)))
             (REST (FIRST SEQUENCES)))))))))))
    
    ((|forall-seq2| ?SEQ |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE SEQ CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (LET ((SEQUENCES (KM0 SEQ)))
       (COND
        ((OR (NOT (SINGLETONP SEQUENCES)) (NOT (KM-SEQP (FIRST SEQUENCES))))
         (REPORT-ERROR 'USER-ERROR "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `(|forall-seq2| ,SEQ |where| ,CONSTRAINT ,VALUE) SEQ))
        (T
         (LIST
          (CONS ':|seq|
           (REMOVE 'TO-REMOVE
            (MAPCAR #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER '|It2| CONSTRAINT)) (VALS-TO-VAL (KM0 (SUBST MEMBER '|It2| VALUE)))) (T 'TO-REMOVE)))
             (REST (FIRST SEQUENCES)))))))))))
      
    ((|forall-bag| ?BAG |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE BAG CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (LET ((BAGS (KM0 BAG)))
       (COND
        ((OR (NOT (SINGLETONP BAGS)) (NOT (KM-BAGP (FIRST BAGS))))
         (REPORT-ERROR 'USER-ERROR "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `(|forall-bag| ,BAG |where| ,CONSTRAINT ,VALUE) BAG))
        (T
         (LIST
          (CONS ':|bag|
           (REMOVE NIL
            (MAPCAR #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER '|It| CONSTRAINT)) (VALS-TO-VAL (KM0 (SUBST MEMBER '|It| VALUE))))))
             (REST (FIRST BAGS)))))))))))
    
    ((|forall-bag2| ?BAG |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE BAG CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (LET ((BAGS (KM0 BAG)))
       (COND
        ((OR (NOT (SINGLETONP BAGS)) (NOT (KM-BAGP (FIRST BAGS))))
         (REPORT-ERROR 'USER-ERROR "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `(|forall-bag2| ,BAG |where| ,CONSTRAINT ,VALUE) BAG))
        (T
         (LIST
          (CONS ':|bag|
           (REMOVE NIL
            (MAPCAR #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER '|It2| CONSTRAINT)) (VALS-TO-VAL (KM0 (SUBST MEMBER '|It2| VALUE))))))
             (REST (FIRST BAGS)))))))))))
       ((|allof2| ?SET |where| ?TEST) (LAMBDA (FMODE SET TEST) (KM0 `(|forall2| ,SET |where| ,TEST |It2|) :FAIL-MODE FMODE)))  
    ((|allof2| ?SET |must| ?TEST)
     (LAMBDA (FMODE SET TEST) (DECLARE (IGNORE FMODE)) (COND ((EVERY #'(LAMBDA (INSTANCE) (KM0 (SUBST INSTANCE '|It2| TEST))) (KM0 SET)) '(|t|)))))
    
    ((|allof2| ?SET |where| ?TEST2 |must| ?TEST)
     (LAMBDA (FMODE SET TEST2 TEST) (DECLARE (IGNORE FMODE))
      (COND ((EVERY #'(LAMBDA (INSTANCE) (KM0 (SUBST INSTANCE '|It2| TEST))) (KM0 `(|allof2| ,SET |where| ,TEST2))) '(|t|)))))
    ((|oneof2| ?SET |where| ?TEST)
     (LAMBDA (FMODE SET TEST) (DECLARE (IGNORE FMODE))
      (LET ((ANSWER (FIND-IF #'(LAMBDA (MEMBER) (KM0 (SUBST MEMBER '|It2| TEST))) (KM0 SET)))) (COND (ANSWER (LIST ANSWER))))))
    ((|forall2| ?SET ?VALUE) (LAMBDA (FMODE SET VALUE) (KM0 `(|forall2| ,SET |where| T ,VALUE) :FAIL-MODE FMODE))) 
    ((|forall-seq2| ?SEQ ?VALUE) (LAMBDA (FMODE SEQ VALUE) (KM0 `(|forall-seq2| ,SEQ |where| T ,VALUE) :FAIL-MODE FMODE))) 
    ((|forall-bag2| ?BAG ?VALUE) (LAMBDA (FMODE BAG VALUE) (KM0 `(|forall-bag2| ,BAG |where| T ,VALUE) :FAIL-MODE FMODE)))    
    ((|theoneof2| ?SET |where| ?TEST)
     (LAMBDA (FMODE SET TEST) (LET ((VAL (KM-UNIQUE0 `(|forall2| ,SET |where| ,TEST |It2|) :FAIL-MODE FMODE)))  (COND (VAL (LIST VAL))))))
    ((|forall2| ?SET |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE SET CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (REMOVE 'NIL (MY-MAPCAN #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER '|It2| CONSTRAINT)) (KM0 (SUBST MEMBER '|It2| VALUE))))) (KM0 SET)))))
             
    ((|allof| ?VAR |in| ?SET |where| ?TEST)
     (LAMBDA (FMODE VAR SET TEST)
      (COND
       ((NOT (KM-VARP VAR)) (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|allof| ,VAR |in| ,SET |where| ,TEST)))
       (T (KM0 `(|forall| ,VAR |in| ,SET |where| ,TEST ,VAR) :FAIL-MODE FMODE)))))
     ((|allof| ?VAR |in| ?SET |must| ?TEST) (LAMBDA (FMODE VAR SET TEST) (DECLARE (IGNORE FMODE)) (ALLOF-MUST VAR SET TEST)))
    ((|allof| ?VAR |in| ?SET |where| ?TEST2 |must| ?TEST)
     (LAMBDA (FMODE VAR SET TEST2 TEST) (DECLARE (IGNORE FMODE)) (ALLOF-WHERE-MUST VAR SET TEST2 TEST)))
    ((|oneof| ?VAR |in| ?SET |where| ?TEST) (LAMBDA (FMODE VAR SET TEST) (DECLARE (IGNORE FMODE)) (ONEOF-WHERE VAR SET TEST)))
    ((|theoneof| ?VAR |in| ?SET |where| ?TEST)
     (LAMBDA (FMODE VAR SET TEST)
      (COND
       ((NOT (KM-VARP VAR))
        (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|theoneof| ,VAR |in| ,SET |where| ,TEST)))
       (T (LET ((VAL (KM-UNIQUE0 `(|forall| ,VAR |in| ,SET |where| ,TEST ,VAR) :FAIL-MODE FMODE)))  (COND (VAL (LIST VAL))))))))
    ((|forall| ?VAR |in| ?SET ?VALUE)
     (LAMBDA (FMODE VAR SET VALUE)
      (COND ((NOT (KM-VARP VAR)) (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall| ,VAR |in| ,SET ,VALUE)))
       (T (KM0 `(|forall| ,VAR |in| ,SET |where| T ,VALUE) :FAIL-MODE FMODE)))))
    
    ((|forall-seq| ?VAR |in| ?SEQ ?VALUE)
     (LAMBDA (FMODE VAR SEQ VALUE)
      (COND
       ((NOT (KM-VARP VAR)) (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-seq| ,VAR |in| ,SEQ ,VALUE)))
       (T (KM0 `(|forall-seq| ,VAR |in| ,SEQ |where| T ,VALUE) :FAIL-MODE FMODE)))))
    
    ((|forall-bag| ?VAR |in| ?BAG ?VALUE)
     (LAMBDA (FMODE VAR BAG VALUE)
      (COND
       ((NOT (KM-VARP VAR)) (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-bag| ,VAR |in| ,BAG ,VALUE)))
       (T (KM0 `(|forall-bag| ,VAR |in| ,BAG |where| T ,VALUE) :FAIL-MODE FMODE)))))
    
    ((|forall| ?VAR |in| ?SET |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE VAR SET CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (COND
       ((NOT (KM-VARP VAR))
        (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall| ,VAR |in| ,SET |where| ,CONSTRAINT ,VALUE)))
       (T (REMOVE NIL (MY-MAPCAN #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER VAR CONSTRAINT)) (KM0 (SUBST MEMBER VAR VALUE))))) (KM0 SET)))))))
    ((|forall-bag| ?VAR |in| ?BAG |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE VAR BAG CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (COND
       ((NOT (KM-VARP VAR))
        (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-bag| ,VAR |in| ,BAG |where| ,CONSTRAINT ,VALUE)))
       (T
        (LET ((BAGS (KM0 BAG)))
         (COND
          ((OR (NOT (SINGLETONP BAGS)) (NOT (KM-BAGP (FIRST BAGS))))
           (REPORT-ERROR 'USER-ERROR "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `(|forall-bag| ,VAR |in| ,BAG |where| ,CONSTRAINT ,VALUE)
            BAG))
          (T
           (LIST
            (CONS ':|bag|
             (REMOVE NIL
              (MAPCAR #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER VAR CONSTRAINT)) (VALS-TO-VAL (KM0 (SUBST MEMBER VAR VALUE))))))
               (REST (FIRST BAGS)))))))))))))
    
    ((|forall-seq| ?VAR |in| ?SEQ |where| ?CONSTRAINT ?VALUE)
     (LAMBDA (_FMODE VAR SEQ CONSTRAINT VALUE) (DECLARE (IGNORE _FMODE))
      (COND
       ((NOT (KM-VARP VAR))
        (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-seq| ,VAR |in| ,SEQ |where| ,CONSTRAINT ,VALUE)))
       (T
        (LET ((SEQUENCES (KM0 SEQ)))
         (COND
          ((OR (NOT (SINGLETONP SEQUENCES)) (NOT (KM-SEQP (FIRST SEQUENCES))))
           (REPORT-ERROR 'USER-ERROR "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%"
            `(|forall-seq| ,VAR |in| ,SEQ |where| ,CONSTRAINT ,VALUE) SEQ))
          (T
           (LIST
            (CONS ':|seq|
             (REMOVE 'TO-REMOVE
              (MAPCAR #'(LAMBDA (MEMBER) (COND ((KM0 (SUBST MEMBER VAR CONSTRAINT)) (VALS-TO-VAL (KM0 (SUBST MEMBER VAR VALUE)))) (T 'TO-REMOVE)))
               (REST (FIRST SEQUENCES)))))))))))))
      
    (#'?LISPCODE 
     (LAMBDA (_FMODE LISPCODE) (DECLARE (IGNORE _FMODE))
      (LET* ((ANSWER0 (FUNCALL (EVAL (LIST 'FUNCTION LISPCODE))))  (ANSWER (LISTIFY ANSWER0)))
       (COND ((EVERY #'FULLY-EVALUATEDP ANSWER) ANSWER)
        (T
         (REPORT-ERROR 'USER-ERROR
          "In call to external Lisp procedure
  ~a
Lisp procedure should return a list of fully evaluated KM objects (e.g., 
instances, or :seq/:bag/:pair of instances), but instead returned:
   ~a~%"
          LISPCODE ANSWER0))))))
    ((|search-control| ?PATTERN ?VARS ?MINDEPTH ?MAXDEPTH ?RESULT)
     (LAMBDA (_FMODE PATTERN VARS MINDEPTH MAXDEPTH RESULT) (DECLARE (IGNORE _FMODE))
      (LET ((PATTERN0 (SUBST '&REST '|&rest| PATTERN)))
       (COND
        ((NOT (MEMBER PATTERN0 *SEARCH-CONTROL-POINTS* :TEST #'EQUAL))
         (SETQ *SEARCH-CONTROL-POINTS* (CONS (LIST PATTERN0 VARS MINDEPTH MAXDEPTH RESULT) *SEARCH-CONTROL-POINTS*))))
       (KM-FORMAT T "Search will be controlled at the following points:~%~{  ~a~%~}"
        (MAPCAR #'(LAMBDA (S) (LIST (FIRST S) '-> (FIFTH S))) *SEARCH-CONTROL-POINTS*))
        '(|t|))))
        ((|the1| ?SLOT |of| ?FRAMEADD) (LAMBDA (FMODE SLOT FRAMEADD) (KM0 `(|the1| |of| (|the| ,SLOT |of| ,FRAMEADD)) :FAIL-MODE FMODE)))
    ((|the2| ?SLOT |of| ?FRAMEADD) (LAMBDA (FMODE SLOT FRAMEADD) (KM0 `(|the2| |of| (|the| ,SLOT |of| ,FRAMEADD)) :FAIL-MODE FMODE)))
    ((|the3| ?SLOT |of| ?FRAMEADD) (LAMBDA (FMODE SLOT FRAMEADD) (KM0 `(|the3| |of| (|the| ,SLOT |of| ,FRAMEADD)) :FAIL-MODE FMODE)))  
    ((|the1| |of| ?FRAMEADD)
     (LAMBDA (FMODE FRAMEADD)
      (LET ((MULTIARGS (KM0 FRAMEADD :FAIL-MODE FMODE)))
       (KM0 (VALS-TO-VAL (MAPCAR #'(LAMBDA (MULTIARG) (COND ((KM-STRUCTURED-LIST-VALP MULTIARG) (ARG1OF MULTIARG)) (T MULTIARG)))  MULTIARGS))))))
      
    ((|the2| |of| ?FRAMEADD)
     (LAMBDA (FMODE FRAMEADD)
      (LET ((MULTIARGS (KM0 FRAMEADD :FAIL-MODE FMODE)))
       (KM0 (VALS-TO-VAL (MAPCAR #'(LAMBDA (MULTIARG) (COND ((KM-STRUCTURED-LIST-VALP MULTIARG) (ARG2OF MULTIARG))))  MULTIARGS))))))
      
    ((|the3| |of| ?FRAMEADD)
     (LAMBDA (FMODE FRAMEADD)
      (LET ((MULTIARGS (KM0 FRAMEADD :FAIL-MODE FMODE)))
       (KM0 (VALS-TO-VAL (MAPCAR #'(LAMBDA (MULTIARG) (COND ((KM-STRUCTURED-LIST-VALP MULTIARG) (ARG3OF MULTIARG))))  MULTIARGS))))))
      
    ((|theN| ?NEXPR |of| ?FRAMEADD)
     (LAMBDA (FMODE NEXPR FRAMEADD)
      (LET ((N (KM-UNIQUE0 NEXPR :FAIL-MODE 'ERROR)) (MULTIARGS (KM0 FRAMEADD :FAIL-MODE FMODE)))
       (COND
        ((OR (NOT (INTEGERP N)) (< N 1))
         (REPORT-ERROR 'USER-ERROR "Doing ~a. ~a should evaluate to a non-negative integer!~%" `(|the| ,NEXPR |of| ,FRAMEADD) NEXPR))
        (T
         (KM0
          (VALS-TO-VAL
           (MAPCAR #'(LAMBDA (MULTIARG) (COND ((AND (KM-STRUCTURED-LIST-VALP MULTIARG) (< N (LENGTH MULTIARG)))  (ELT MULTIARG N)) ((EQ N 1) MULTIARG))) 
            MULTIARGS))))))))
    
    ((|theNth| ?NEXPR |of| ?FRAMEADD)
     (LAMBDA (FMODE NEXPR FRAMEADD)
      (LET ((N (KM-UNIQUE0 NEXPR :FAIL-MODE 'ERROR)) (VALS (KM0 FRAMEADD :FAIL-MODE FMODE)))
       (COND
        ((OR (NOT (INTEGERP N)) (< N 1))
         (REPORT-ERROR 'USER-ERROR "Doing ~a. ~a should evaluate to a non-negative integer!~%" `(|the| ,NEXPR |of| ,FRAMEADD) NEXPR))
        ((AND (<= N (LENGTH VALS))  (ELT VALS (1- N))) (LIST (ELT VALS (1- N))))))))
              ((?X ^ ?Y ^ &REST) (LAMBDA (FM X Y REST) (KM0 `((,X ^ ,Y) ^ ,@REST) :FAIL-MODE FM)))
    ((?X ^ ?Y + &REST) (LAMBDA (FM X Y REST) (KM0 `((,X ^ ,Y) + ,@REST) :FAIL-MODE FM)))
    ((?X ^ ?Y - &REST) (LAMBDA (FM X Y REST) (KM0 `((,X ^ ,Y) - ,@REST) :FAIL-MODE FM)))
    ((?X ^ ?Y / &REST) (LAMBDA (FM X Y REST) (KM0 `((,X ^ ,Y) / ,@REST) :FAIL-MODE FM)))
    ((?X ^ ?Y * &REST) (LAMBDA (FM X Y REST) (KM0 `((,X ^ ,Y) * ,@REST) :FAIL-MODE FM)))
    ((?X / ?Y + &REST) (LAMBDA (FM X Y REST) (KM0 `((,X / ,Y) + ,@REST) :FAIL-MODE FM)))
    ((?X / ?Y - &REST) (LAMBDA (FM X Y REST) (KM0 `((,X / ,Y) - ,@REST) :FAIL-MODE FM)))
    ((?X / ?Y / &REST) (LAMBDA (FM X Y REST) (KM0 `((,X / ,Y) / ,@REST) :FAIL-MODE FM)))
    ((?X / ?Y * &REST) (LAMBDA (FM X Y REST) (KM0 `((,X / ,Y) * ,@REST) :FAIL-MODE FM)))
    ((?X * ?Y + &REST) (LAMBDA (FM X Y REST) (KM0 `((,X * ,Y) + ,@REST) :FAIL-MODE FM)))
    ((?X * ?Y - &REST) (LAMBDA (FM X Y REST) (KM0 `((,X * ,Y) - ,@REST) :FAIL-MODE FM)))
    ((?X * ?Y / &REST) (LAMBDA (FM X Y REST) (KM0 `((,X * ,Y) / ,@REST) :FAIL-MODE FM)))
    ((?X - ?Y - &REST) (LAMBDA (FM X Y REST) (KM0 `((,X - ,Y) - ,@REST) :FAIL-MODE FM)))
    ((?X - ?Y + &REST) (LAMBDA (FM X Y REST) (KM0 `((,X - ,Y) + ,@REST) :FAIL-MODE FM)))
    ((?X + ?Y - &REST) (LAMBDA (FM X Y REST) (KM0 `((,X + ,Y) - ,@REST) :FAIL-MODE FM))) 
    ((?EXPR + &REST)
     (LAMBDA (FMODE EXPR REST)
      (LET ((X (KM-UNIQUE0 EXPR :FAIL-MODE FMODE)) (Y (KM-UNIQUE0 REST :FAIL-MODE FMODE))) (COND ((AND (NUMBERP X) (NUMBERP Y)) (LIST (+ X Y)))))))
    ((?EXPR - &REST)
     (LAMBDA (FMODE EXPR REST)
      (LET ((X (KM-UNIQUE0 EXPR :FAIL-MODE FMODE)) (Y (KM-UNIQUE0 REST :FAIL-MODE FMODE))) (COND ((AND (NUMBERP X) (NUMBERP Y)) (LIST (- X Y)))))))
    ((?EXPR * &REST)
     (LAMBDA (FMODE EXPR REST)
      (LET ((X (KM-UNIQUE0 EXPR :FAIL-MODE FMODE)) (Y (KM-UNIQUE0 REST :FAIL-MODE FMODE))) (COND ((AND (NUMBERP X) (NUMBERP Y)) (LIST (* X Y)))))))
    ((?EXPR / &REST)
     (LAMBDA (FMODE EXPR REST)
      (LET ((X (KM-UNIQUE0 EXPR :FAIL-MODE FMODE)) (Y (KM-UNIQUE0 REST :FAIL-MODE FMODE)))
       (COND
        ((AND (NUMBERP X) (NUMBERP Y)) #|new|#
         (COND ((AND (ZEROP X) (ZEROP Y) (LIST 1))) #|new|# ((ZEROP X) (LIST 0)) #|new|# ((ZEROP Y) (LIST *INFINITY*))
          ((AND (NUMBERP X) (NUMBERP Y)) (LIST (/ X Y)))))))))
    ((?EXPR1 ^ ?EXPR2)
     (LAMBDA (FMODE EXPR1 EXPR2)
      (LET ((X (KM-UNIQUE0 EXPR1 :FAIL-MODE FMODE)) (Y (KM-UNIQUE0 EXPR2 :FAIL-MODE FMODE))) (COND ((AND (NUMBERP X) (NUMBERP Y)) (LIST (EXPT X Y)))))))
        (|nil| (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) NIL)) (NIL  (LAMBDA (_FMODE) (DECLARE (IGNORE _FMODE)) NIL))
    ((?TARGET :== (:|set| &REST))  (LAMBDA (FMODE TARGET EXPRS)  (DECLARE (IGNORE FMODE)) (MY-MAPCAN #'(LAMBDA (EXPR) (KM0 EXPR :TARGET TARGET)) EXPRS)))
    ((:|set| &REST)  (LAMBDA (FMODE EXPRS)  (DECLARE (IGNORE FMODE)) (MY-MAPCAN #'(LAMBDA (EXPR) (KM0 EXPR)) EXPRS)))
    ((:|seq| &REST) 
     (LAMBDA (FMODE EXPRS) (DECLARE (IGNORE FMODE))
      (LET ((SEQUENCE (MAPCAR #'(LAMBDA (EXPR) (VALS-TO-VAL (KM0 EXPR))) EXPRS))) (COND (SEQUENCE `((:|seq| ,@SEQUENCE)))))))
    ((:|bag| &REST) 
     (LAMBDA (FMODE EXPRS) (DECLARE (IGNORE FMODE))
      (LET ((BAG (MAPCAR #'(LAMBDA (EXPR) (VALS-TO-VAL (KM0 EXPR))) EXPRS))) (COND (BAG `((:|bag| ,@BAG)))))))
    ((:|function| &REST) 
     (LAMBDA (FMODE EXPRS) (DECLARE (IGNORE FMODE))
      (LET ((SEQUENCE (MAPCAR #'(LAMBDA (EXPR) (VALS-TO-VAL (KM0 EXPR))) EXPRS))) (COND (SEQUENCE `((:|function| ,@SEQUENCE)))))))
    ((:|pair| &REST) 
     (LAMBDA (FMODE EXPRS) (DECLARE (IGNORE FMODE))
      (COND ((NOT (PAIRP EXPRS)) (REPORT-ERROR 'USER-ERROR "~a: A pair should have exactly two elements!~%" `(:|pair| ,@EXPRS)))
       (T (LET ((SEQUENCE (MAPCAR #'(LAMBDA (EXPR) (VALS-TO-VAL (KM0 EXPR))) EXPRS))) (COND (SEQUENCE `((:|pair| ,@SEQUENCE)))))))))
       
    ((:|triple| ?FRAME-EXPR ?SLOT-EXPR ?VAL-EXPR) 
     (LAMBDA (_FMODE FRAME-EXPR SLOT-EXPR VAL-EXPR) (DECLARE (IGNORE _FMODE))
      (LET*
       ((SLOT (COND ((COMPARISON-OPERATOR SLOT-EXPR) SLOT-EXPR)  (T (KM-UNIQUE0 SLOT-EXPR :FAIL-MODE 'ERROR))))
        (FRAME
         (COND ((AND (COMPARISON-OPERATOR SLOT) (MINIMATCH FRAME-EXPR '(|the| |?x| |of| |?y|))) FRAME-EXPR) 
          (T (KM-UNIQUE0 FRAME-EXPR :FAIL-MODE 'ERROR))))
        (VAL
         (COND ((OR (CONSTRAINT-EXPRP VAL-EXPR) (EXISTENTIAL-EXPRP VAL-EXPR) (COMPARISON-OPERATOR SLOT)) VAL-EXPR)   (T (VALS-TO-VAL (KM0 VAL-EXPR))))))
       `((:|triple| ,FRAME ,SLOT ,VAL)))))
    ((:|args| &REST) 
     (LAMBDA (FMODE EXPRS) (DECLARE (IGNORE FMODE))
      (LET ((SEQUENCE (MAPCAR #'(LAMBDA (EXPR) (VALS-TO-VAL (KM0 EXPR))) EXPRS))) (COND (SEQUENCE `((:|args| ,@SEQUENCE)))))))
       ((|showme| ?KM-EXPR) (LAMBDA (_FMODE KM-EXPR) (DECLARE (IGNORE _FMODE)) (SHOWME KM-EXPR)))
    ((|showme| ?KM-EXPR ?FILE)
     (LAMBDA (_FMODE KM-EXPR FILE) (DECLARE (IGNORE _FMODE))
      (COND ((NOT (STRINGP FILE)) (REPORT-ERROR 'USER-ERROR "(showme <expr> <filename>): <filename> should be a string!~%"))
       (T
        (LET ((STREAM (TELL FILE)))
         (PROG1 (SHOWME KM-EXPR (ALL-SITUATIONS) (VISIBLE-THEORIES) STREAM) (COND ((STREAMP STREAM) (CLOSE STREAM)))
          (KM-FORMAT T "(Output sent to file ~a)~%" FILE)))))))
    ((|showme-all| ?KM-EXPR) (LAMBDA (_FMODE KM-EXPR) (DECLARE (IGNORE _FMODE)) (SHOWME-ALL KM-EXPR)))
    ((|evaluate-all| ?KM-EXPR) (LAMBDA (_FMODE KM-EXPR) (DECLARE (IGNORE _FMODE)) (EVALUATE-ALL KM-EXPR)))
    ((|showme-here| ?KM-EXPR) (LAMBDA (_FMODE KM-EXPR) (DECLARE (IGNORE _FMODE)) (SHOWME KM-EXPR (LIST (CURR-SITUATION)) (VISIBLE-THEORIES)))) 
    ((|the-class| ?CLASS) (LAMBDA (FMODE CLASS) (DECLARE (IGNORE FMODE))   #|NEW|# (PROCESS-UNQUOTES `((|the-class| ,CLASS))))) 
    ((|the-class| ?CLASS |with| &REST)
     (LAMBDA (FMODE CLASS SLOTSVALS) (DECLARE (IGNORE FMODE))
      (COND ((ARE-SLOTSVALS SLOTSVALS)  #|NEW|# (PROCESS-UNQUOTES `((|the-class| ,CLASS |with| ,@SLOTSVALS)))))))
     
    ((|constraints-for| (|the| ?SLOT |of| ?FRAMEADD))
     (LAMBDA (FMODE0 SLOT FRAMEADD) (DECLARE (IGNORE FMODE0))
      (LET ((FRAME (KM-UNIQUE0 FRAMEADD :FAIL-MODE 'ERROR))) (MAPCAR #'QUOTIFY (COLLECT-CONSTRAINTS-ON-INSTANCE FRAME SLOT)))))
    ((|rules-for| (|the| ?SLOT |of| ?FRAMEADD))
     (LAMBDA (FMODE0 SLOT FRAMEADD) (DECLARE (IGNORE FMODE0))
      (LET ((RULES (RULES-FOR SLOT FRAMEADD)))
       (COND ((NULL RULES) NIL) ((KM-SETP RULES) (MAPCAR #'QUOTIFY (SET-TO-LIST RULES))) (T (LIST (QUOTIFY RULES)))))))
     ((|why|) (LAMBDA (FMODE) (DECLARE (IGNORE FMODE)) (WHY)))
    ((|why| ?TRIPLE)
     (LAMBDA (FMODE TRIPLE) (DECLARE (IGNORE FMODE))
      (COND ((NOT (KM-TRIPLEP TRIPLE)) (REPORT-ERROR 'USER-ERROR "Bad argument to (why ...)! Should be of form (why (:triple <f> <s> <v>))!"))
       (T (WHY TRIPLE)))))
    ((|justify|) (LAMBDA (FMODE) (DECLARE (IGNORE FMODE)) (JUSTIFY)))
    ((|justify| ?TRIPLE) (LAMBDA (FMODE TRIPLE) (DECLARE (IGNORE FMODE)) (JUSTIFY TRIPLE)))
    ((|get-justification|)
     (LAMBDA (FMODE) (DECLARE (IGNORE FMODE)) (LIST (CONCAT-LIST (INSERT-DELIMETER (GET-JUSTIFICATION :FORMAT 'ASCII) *NEWLINE-STR*)))))
         
    ((|get-justification| ?TRIPLE)
     (LAMBDA (FMODE TRIPLE) (DECLARE (IGNORE FMODE))
      (LIST (CONCAT-LIST (INSERT-DELIMETER (GET-JUSTIFICATION :TRIPLE TRIPLE :FORMAT 'ASCII) *NEWLINE-STR*)))))
          
    ((|explanation| (:|triple| ?F ?S ?V) ?EXPLANATIONS)
     (LAMBDA (FMODE F S V EXPLANATIONS) (DECLARE (IGNORE FMODE))
      (MAPC #'(LAMBDA (EXPLANATION) (RECORD-EXPLANATION-FOR `(|the| ,S |of| ,F) V EXPLANATION :SITUATION *GLOBAL-SITUATION*)) EXPLANATIONS) '(|t|)))
    ((|comment| ?COMMENT-TAG &REST) (LAMBDA (FMODE COMMENT-TAG DATA) (DECLARE (IGNORE FMODE)) (COMMENT COMMENT-TAG DATA)))
    ((|show-comment| ?COMMENT-TAG) (LAMBDA (FMODE COMMENT-TAG) (DECLARE (IGNORE FMODE)) (SHOW-COMMENT COMMENT-TAG)))     
    ('?EXPR
     (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE))
      (LET ((PROCESSED-EXPR (PROCESS-UNQUOTES EXPR))) (COND (PROCESSED-EXPR (LIST (LIST 'QUOTE PROCESSED-EXPR)))))))
    ((UNQUOTE ?EXPR)
     (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE))
      (REPORT-ERROR 'USER-ERROR "Doing #,~a: You can't unquote something without it first being quoted!~%" EXPR)))
     ((|delete| ?KM-EXPR) (LAMBDA (FMODE KM-EXPR) (MAPCAR #'DELETE-FRAME (KM0 KM-EXPR :FAIL-MODE FMODE))))
    ((|evaluate| ?EXPR) 
     (LAMBDA (FMODE EXPR)
      (LET ((QUOTED-EXPRS (KM0 EXPR :FAIL-MODE FMODE)))
       (REMOVE NIL
        (MY-MAPCAN
         #'(LAMBDA (QUOTED-EXPR)
            (COND ((MEMBER QUOTED-EXPR '(|f| F)) NIL)
             ((AND (PAIRP QUOTED-EXPR) (EQ (FIRST QUOTED-EXPR) 'QUOTE)) (KM0 (SECOND QUOTED-EXPR) :FAIL-MODE FMODE))       
             (T (REPORT-ERROR 'USER-ERROR "(evaluate ~a)~%evaluate should be given a quoted expression to evaluate!~%" QUOTED-EXPR))))
         QUOTED-EXPRS)))))
    ((|exists| ?FRAME)
     (LAMBDA (FMODE FRAME)
      (REPORT-ERROR 'USER-WARNING
       "(exists ~a): (exists <expr>) has been renamed (has-value <expr>) in KM 1.4.~%       Please update your KB! Continuing...~%" FRAME)
      (KM0 `(|has-value| ,FRAME) :FAIL-MODE FMODE)))
    ((|has-value| ?FRAME) (LAMBDA (_FMODE FRAME) (DECLARE (IGNORE _FMODE)) (COND ((KM0 FRAME) '(|t|)))))
    ((|print| ?EXPR) (LAMBDA (_FMODE EXPR) (DECLARE (IGNORE _FMODE)) (LET ((VALS (KM0 EXPR))) (KM-FORMAT T "~a~%" VALS) VALS)))
    ((|format| ?FLAG ?STRING &REST)
     (LAMBDA (_FMODE FLAG STRING ARGUMENTS) (DECLARE (IGNORE _FMODE))
      (COND ((EQ FLAG '|t|) (APPLY #'FORMAT `(T ,STRING ,@(MAPCAR #'(LAMBDA (ARG) (KM0 ARG)) ARGUMENTS))) '(|t|))
       ((MEMBER FLAG '(|nil| NIL)) (LIST (APPLY #'FORMAT `(NIL ,STRING ,@(MAPCAR #'(LAMBDA (ARG) (KM0 ARG)) ARGUMENTS)))))
       (T (REPORT-ERROR 'USER-ERROR "~a: Second argument must be `t' or `nil', not `~a'!~%" `(|format| ,FLAG ,STRING ,@ARGUMENTS) FLAG)))))
    ((|km-format| ?FLAG ?STRING &REST)
     (LAMBDA (_FMODE FLAG STRING ARGUMENTS) (DECLARE (IGNORE _FMODE))
      (COND ((EQ FLAG '|t|) (APPLY #'KM-FORMAT `(T ,STRING ,@(MAPCAR #'(LAMBDA (ARG) (KM0 ARG)) ARGUMENTS))) '(|t|))
       ((MEMBER FLAG '(|nil| NIL)) (LIST (APPLY #'KM-FORMAT `(NIL ,STRING ,@(MAPCAR #'(LAMBDA (ARG) (KM0 ARG)) ARGUMENTS)))))
       (T (REPORT-ERROR 'USER-ERROR "~a: Second argument must be `t' or `nil', not `~a'!~%" `(|km-format| ,FLAG ,STRING ,@ARGUMENTS) FLAG)))))
            ((|andify| ?EXPR) (LAMBDA (FMODE EXPR) (LIST (CONS ':|seq| (ANDIFY (KM0 EXPR :FAIL-MODE FMODE))))))       
    ((|make-sentence| ?EXPR)
     (LAMBDA (_FMODE EXPR) (DECLARE (IGNORE _FMODE)) #|[1]|#
      (LET ((TEXT (KM0 EXPR)))  (MAKE-COMMENT "anglifying ~a" TEXT)  (LIST (MAKE-SENTENCE TEXT)))))
     
    ((|make-phrase| ?EXPR) 
     (LAMBDA (_FMODE EXPR) (DECLARE (IGNORE _FMODE)) (LET ((TEXT (KM0 EXPR)))  (MAKE-COMMENT "anglifying ~a" TEXT)  (LIST (MAKE-PHRASE TEXT)))))
      
    ((|pluralize| ?EXPR)
     (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE))
      (REPORT-ERROR 'USER-ERROR "(pluralize ~a): pluralize is no longer defined in KM1.4 - use \"-s\" suffix instead!~%" EXPR)))
       ((|spy| ?EXPR) (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE)) (SPY EXPR))) ((|spy|) (LAMBDA (FMODE) (DECLARE (IGNORE FMODE)) (SPY)))
    ((|unspy|) (LAMBDA (FMODE) (DECLARE (IGNORE FMODE)) (UNSPY)))   
    ((|taxonomy| &REST)
     (LAMBDA (FMODE ARGS) (DECLARE (IGNORE FMODE))
      (COND ((NULL ARGS) (TAXONOMY)) ((SINGLETONP ARGS) (TAXONOMY (KM-UNIQUE (FIRST ARGS))))
       ((PAIRP ARGS) (TAXONOMY (KM-UNIQUE (FIRST ARGS)) (KM-UNIQUE (SECOND ARGS))))
       (T (REPORT-ERROR 'USER-ERROR "Too many arguments to the taxonomy function! Format is (taxonomy <top-node> <relation-to-descend>)~%")))))
       ((|checkpoint|) (LAMBDA (FMODE) (DECLARE (IGNORE FMODE)) (SET-CHECKPOINT) '(|t|)))
    ((|checkpoint| ?CHECKPOINT-ID)
     (LAMBDA (FMODE CHECKPOINT-ID) (DECLARE (IGNORE FMODE))
      (COND ((NULL CHECKPOINT-ID) (REPORT-ERROR 'USER-ERROR "(checkpoint ~a): Argument to checkpoint can't be NIL!~%" CHECKPOINT-ID))
       (T (SET-CHECKPOINT CHECKPOINT-ID) '(|t|)))))
    ((|undo|)  (LAMBDA (FMODE) (DECLARE (IGNORE FMODE)) (COND ((UNDO) '(|t|))))) 
    ((|an| |instance| |of| ?EXPR) (LAMBDA (FMODE EXPR) (KM0 `(|an| |instance| |of| ,EXPR |with|) :FAIL-MODE FMODE)))
    ((|an| |instance| |of| ?EXPR |with| &REST)
     (LAMBDA (FMODE EXPR SLOTSVALS) (DECLARE (IGNORE FMODE))
      (COND
       ((ARE-SLOTSVALS SLOTSVALS)
        (LET*
         ((CLASSES (KM0 EXPR :FAIL-MODE 'ERROR)) (CLASS (FIRST CLASSES)) (CLASSES-IN-SLOTSVALS (VALS-IN (ASSOC '|instance-of| SLOTSVALS)))
          (NEW-SLOTSVALS
           (COND
            ((>= (LENGTH CLASSES) 2) (UPDATE-ASSOC-LIST SLOTSVALS `(|instance-of| ,(REMOVE-DUPLICATES (APPEND (REST CLASSES) CLASSES-IN-SLOTSVALS)))))
            (T SLOTSVALS))))
         (LIST (CREATE-INSTANCE CLASS NEW-SLOTSVALS)))))))
    ((|reverse| ?SEQ-EXPR)
     (LAMBDA (FMODE SEQ-EXPR)
      (LET ((SEQ (KM-UNIQUE0 SEQ-EXPR :FAIL-MODE FMODE)))
       (COND ((NULL SEQ) NIL) ((KM-SEQP SEQ) (LIST (CONS ':|seq| (REVERSE (REST SEQ)))))
        (T (REPORT-ERROR 'USER-ERROR "Attempting to reverse a non-sequence ~a!~%[Sequences should be of the form (:seq <e1> ... <en>)]~%" SEQ-EXPR))))))
    ((:|default| ?EXPR)  (LAMBDA (FMODE EXPR)  (DECLARE (IGNORE FMODE EXPR))  (KM-SETQ '*ARE-SOME-DEFAULTS* T) NIL)) 
    ((|sometimes| ?EXPR) (LAMBDA (FMODE EXPR) (KM0 EXPR :FAIL-MODE FMODE)))
    ((|anonymous-instancep| ?EXPR)
     (LAMBDA (FMODE EXPR) (DECLARE (IGNORE FMODE)) (COND ((ANONYMOUS-INSTANCEP (KM-UNIQUE0 EXPR :FAIL-MODE 'ERROR)) '(|t|)))))
       
    (?PATH
     (LAMBDA (FMODE0 PATH)
      (COND ((ATOM PATH)  (COND  ((NO-RESERVED-KEYWORDS (LIST PATH))  (LIST PATH))))
       ((NOT (LISTP PATH)) (REPORT-ERROR 'PROGRAM-ERROR "Failed to find km handler for ~a!~%" PATH)) 
       ((SINGLETONP PATH) (KM0 (FIRST PATH) :FAIL-MODE FMODE0))  
       ((AND (TRIPLEP PATH) (ASSOC (SECOND PATH) *USER-DEFINED-INFIX-OPERATORS*))
        (LET ((INFIX-IMPLEMENTATION-FN (SECOND (ASSOC (SECOND PATH) *USER-DEFINED-INFIX-OPERATORS*))))
         (COND
          ((NOT (FUNCTIONP INFIX-IMPLEMENTATION-FN))
           (REPORT-ERROR 'USER-ERROR
            "
The specified implementation of infix operator ~a is not a Lisp function! (missing \"#'\" prefix?)
The specified implementation was: ~a~%"
            (SECOND PATH) INFIX-IMPLEMENTATION-FN))
          (T
           (LET*
            ((X (VALS-TO-VAL (KM0 (FIRST PATH)))) (Y (VALS-TO-VAL (KM0 (THIRD PATH)))) (ANSWER0 (APPLY INFIX-IMPLEMENTATION-FN (LIST X Y)))
             (ANSWER (LISTIFY ANSWER0)))
            (COND ((EVERY #'FULLY-EVALUATEDP ANSWER) ANSWER)
             (T
              (REPORT-ERROR 'USER-ERROR
               "In call to external Lisp procedure
(~a ~a ~a)
Lisp procedure should return one/a list of fully evaluated KM objects (e.g., 
instances, or :seq/:bag/:pair of instances), but instead returned:
   ~a~%"
               INFIX-IMPLEMENTATION-FN X Y ANSWER0))))))))
       ((NOT *LINEAR-PATHS*) (REPORT-ERROR 'USER-ERROR "KM Syntax error: ~a is not a valid KM expression~%" PATH))
       ((NOT (NO-RESERVED-KEYWORDS PATH)) NIL) 
       ((ODDP (LENGTH PATH)) 
        (COND
         ((STRUCTURED-SLOTP (LAST-EL (BUTLAST PATH)))
          (FOLLOW-MULTIDEPTH-PATH  (KM0 (BUTLAST (BUTLAST PATH)) :FAIL-MODE FMODE0)  (LAST-EL (BUTLAST PATH))  (LAST-EL PATH)  :FAIL-MODE FMODE0))
         (T (VALS-IN-CLASS (KM0 (BUTLAST PATH) :FAIL-MODE FMODE0)  (LAST-EL PATH)))))
       ((EVENP (LENGTH PATH)) 
        (LET* ((FRAMEADD (COND ((PAIRP PATH) (FIRST PATH))  (T (BUTLAST PATH))))  (SLOT0 (LAST-EL PATH)))
         (COND ((STRUCTURED-SLOTP SLOT0) (FOLLOW-MULTIDEPTH-PATH (KM0 FRAMEADD :FAIL-MODE FMODE0) SLOT0 '* :FAIL-MODE FMODE0)) 
          (T
           (LET*
            ((SLOT (COND ((PATHP SLOT0) (KM-UNIQUE0 SLOT0 :FAIL-MODE 'ERROR)) (T SLOT0)))
             (FMODE (COND ((BUILT-IN-AGGREGATION-SLOT SLOT) 'FAIL) (T FMODE0))) (FRAMES (KM0 FRAMEADD :FAIL-MODE FMODE)))
            (COND ((NOT (EQUAL FRAMES (VAL-TO-VALS FRAMEADD))) (KM0 `(,(VALS-TO-VAL FRAMES) ,SLOT) :FAIL-MODE FMODE)) 
             (T (KM-MULTI-SLOTVALS FRAMES SLOT :FAIL-MODE FMODE))))))))))))))
;;;; ======================================================================
;;;;		QUOTED PATHS eg.  (Delta owns Plane (part *) Wing) 
;;;;
;;;; a quoted path is of form: 
;;;;		(...... <slot-structure> <target-class>)
;;;; where <slot-structure> is of the form 
;;;;		(<slot> *)
;;;;   or 	(<slot> * <depth-limit>)
;;;; ======================================================================
;;;; here path is necessarily an ODD length, thus the last element is a target CLASS.
(TRACE-LISP (DEFINE STRUCTURED-SLOTP (SLOT) (trace-defun 'STRUCTURED-SLOTP (SLOT) (RET (AND (LISTP SLOT) (EQ (SECOND SLOT) '*))))))
(TRACE-LISP
 (DEFINE FOLLOW-MULTIDEPTH-PATH (VALUES STRUCTURED-SLOT TARGET-CLASS &REST LKEYS)
  (trace-defun 'FOLLOW-MULTIDEPTH-PATH (VALUES STRUCTURED-SLOT TARGET-CLASS LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (CLET ((SLOT (FIRST STRUCTURED-SLOT)) (DEPTH-LIMIT (OR (THIRD STRUCTURED-SLOT) *MULTIDEPTH-PATH-DEFAULT-SEARCHDEPTH*)))
      (COND ((NULL VALUES) NIL)
       ((CNOT (INTEGERP DEPTH-LIMIT))
        (REPORT-ERROR 'USER-ERROR "Non-integer depth ~a given for slot-structure ~a in quoted path!~%" DEPTH-LIMIT STRUCTURED-SLOT))
       ((< DEPTH-LIMIT 1) (REPORT-ERROR 'USER-ERROR "Depth ~a given for slot-structure ~a in quoted path must be >= 1!~%" DEPTH-LIMIT STRUCTURED-SLOT))
       (T (KM0 (VALS-TO-VAL (MULTIDEPTH-PATH-EXPR (VALS-TO-VAL VALUES) SLOT TARGET-CLASS DEPTH-LIMIT)) :FAIL-MODE FAIL-MODE)))))))))
(TRACE-LISP
 (DEFINE MULTIDEPTH-PATH-EXPR (PATH SLOT TARGET-CLASS DEPTH-LIMIT)
  (trace-defun 'MULTIDEPTH-PATH-EXPR (PATH SLOT TARGET-CLASS DEPTH-LIMIT)
   (RET
    (COND ((<= DEPTH-LIMIT 0) NIL)
     ((NEQ TARGET-CLASS '*)
      (CONS `(|the| ,TARGET-CLASS ,SLOT |of| ,PATH) (MULTIDEPTH-PATH-EXPR `(|the| ,SLOT |of| ,PATH) SLOT TARGET-CLASS (1- DEPTH-LIMIT))))
     (T (CONS `(|the| ,SLOT |of| ,PATH) (MULTIDEPTH-PATH-EXPR `(|the| ,SLOT |of| ,PATH) SLOT TARGET-CLASS (1- DEPTH-LIMIT)))))))))
;;;; ======================================================================
;;;;		ACCESS TO THE KNOWLEDGE-BASE
;;;; These functions make the bridge between km expressions (see
;;;; *km-handler-alist* below) and the KB access function get-global.
;;;; ======================================================================
;;;; ---------------------------------------
;;;;   1. The basic routine for getting slot values is km-multi-slotvals.
;;;;	 It is given a *list* of frames, and gets their values.
;;;; ----------------------------------------
;;;; (km-multi-slotvals frames slot):
;;;; frames will always be a list.
;;;; Find and concatenate the vals of slot for frames.
;;;; MUST return a *list* of values.  <- ?? Oct 97: No!
;;;; Some special handling for slots like "sum" etc. which instead of
;;;; 	looking up values of frames they *sum* the frames (which of
;;;; 	course must thus be numbers)
(TRACE-LISP
 (DEFINE KM-MULTI-SLOTVALS (FRAMES0 SLOT &REST LKEYS)
  (trace-defun 'KM-MULTI-SLOTVALS (FRAMES0 SLOT LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL) (DECLARE (IGNORE FAIL-MODE))
     (CLET ((FRAMES (MAPCAR #'DEREFERENCE FRAMES0))) (COND ((NO-RESERVED-KEYWORDS FRAMES)  (KM-MULTI-SLOTVALS0 FRAMES SLOT)))))))))
;;;; Returns a *LIST* of values   ((car) && (joe bad xd))
(TRACE-LISP
 (DEFINE KM-MULTI-SLOTVALS0 (FRAMES SLOT)
  (trace-defun 'KM-MULTI-SLOTVALS0 (FRAMES SLOT)
   (RET
    (COND ((CNOT (CHECK-ISA-SLOT-OBJECT SLOT)) NIL) ((AND (EQ SLOT '|number|) (NULL FRAMES)) '(0)) 
     (T
      (CASE SLOT (|unification| (KM0 (VAL-SETS-TO-EXPR (MAPCAR #'LIST FRAMES) T)))  (|set-unification| (KM0 (VAL-SETS-TO-EXPR (MAPCAR #'LIST FRAMES)))) 
       (|first| (LIST (FIRST FRAMES))) (|second| (LIST (SECOND FRAMES))) (|third| (LIST (THIRD FRAMES))) (|fourth| (LIST (FOURTH FRAMES)))
       (|fifth| (LIST (FIFTH FRAMES))) (|last| (LAST FRAMES)) (|number| (LIST (LENGTH FRAMES))) (|bag| `((:|bag| ,@FRAMES))) (|seq| `((:|seq| ,@FRAMES)))
       (|append|
        (COND ((NULL FRAMES) NIL)
         ((AND (SINGLETONP FRAMES) (KM-SEQP (FIRST FRAMES))) (CLET ((APPENDED (APPEND-SEQS (FIRST FRAMES)))) (COND (APPENDED (LIST APPENDED)))))
         ((AND (SINGLETONP FRAMES) (KM-BAGP (FIRST FRAMES))) (CLET ((APPENDED (APPEND-BAGS (FIRST FRAMES)))) (COND (APPENDED (LIST APPENDED)))))
         (T (REPORT-ERROR 'USER-ERROR "(the append of ~a): value should be a single sequence of sequences, or bag of bags!" (VALS-TO-VAL FRAMES)))))
       (T
        (COND
         ((AND (CL-MEMBER SLOT '(|min| |max|))  (CNOT (SINGLETONP FRAMES)))
          (COND ((NULL FRAMES) (REPORT-ERROR 'USER-ERROR "(the ~a of NIL): ~a should be given at least one value to operate on!~%" SLOT SLOT))
           (T (CASE SLOT (|min| (AGGREGATE-VALS #'MIN FRAMES)) (|max| (AGGREGATE-VALS #'MAX FRAMES))))))
         ((AND (CL-MEMBER SLOT '(|sum| |average|)) (NULL FRAMES)) '(0))
         ((CL-ISA SLOT '|Set-Aggregation-Slot|)
          (CLET ((QUOTED-FUNCTION-NAME (KM-UNIQUE0 `(|the| |aggregation-function| |of| ,SLOT))))
           (COND ((CNOT QUOTED-FUNCTION-NAME) (REPORT-ERROR 'USER-ERROR "No aggregation-function definition given for the Aggregation-Slot ~a!~%" SLOT))
            ((CNOT (QUOTEP QUOTED-FUNCTION-NAME))
             (REPORT-ERROR 'USER-ERROR
              "Function definition for Aggregation-Slot ~a should be a~%quoted function (eg. \"(sum has (aggregation-function ('#'+)))\"~%" SLOT))
            (T
             (CLET (#'(EVAL (SECOND QUOTED-FUNCTION-NAME)))
              (COND
               ((CNOT (FUNCTIONP FUNCTION))
                (REPORT-ERROR 'USER-ERROR
                 "Function definition for Aggregation-Slot ~a should be~%a function! (eg. \"(sum has (aggregation-function ('#'+)))\"~%" SLOT))
               (T (LIST (APPLY FUNCTION (LIST FRAMES))))))))))
         ((NULL FRAMES) NIL) ((SINGLETONP FRAMES) (KM-SLOTVALS (FIRST FRAMES) SLOT))
         (T (MY-MAPCAN  #'(LAMBDA (FRAME) (trace-defun '#:G15596 (FRAME) (RET )))  FRAMES)))))))))))
;; by end of top-level km fn
(TRACE-LISP
 (DEFINE AGGREGATE-VALS #'VALS
  (trace-defun 'AGGREGATE-VALS #'VALS
   (RET
    (COND ((AND (NULL VALS) (CNOT (EQ FUNCTION #'+))) (KM0 '(|a| |Number|) :FAIL-MODE 'ERROR))  ((EVERY #'NUMBERP VALS) (LIST (APPLY FUNCTION VALS)))
     (T (KM0 '(|a| |Number|) :FAIL-MODE 'ERROR)))))))
;;;; ---------------------------------------
;;;;   2. The auxiliary routine for getting the value of a slot is km-slotvals,
;;;;	 which gets the slot values on a single frame. This is only used by
;;;;	 kulti-slotvals.
;;;; ----------------------------------------
;;;; (km-slotvals frame slot)
;;;;   - slot is atomic. Frame may be a kb-instance (including (:set ...) (:triple ...)) or a string or number
;;;;   - return the evaluated *list* of values for the slot of frame.
;;;; NOTE: frame is already assumed to be dereferenced (using dereference)
;;;;     before this procedure is called. 
;;;; This procedure first filters special cases, then calls km-slotvals-from-kb
;;;;	for handling standard queries.
(TRACE-LISP
 (DEFINE KM-SLOTVALS (FRAME SLOT &REST LKEYS)
  (trace-defun 'KM-SLOTVALS (FRAME SLOT LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (COND ((NULL FRAME) NIL)
      ((KM-TRIPLEP FRAME) 
       (CASE SLOT  (|name| (LIST (NAME FRAME)))     (T (REPORT-ERROR 'USER-ERROR "I don't know how to take the ~a of a triple ~a!~%" SLOT FRAME))))
      ((AND (CL-MEMBER SLOT '(|min| |max|))  (CNOT (KM-BAGP FRAME))) (LIST FRAME))
      ((CL-MEMBER SLOT '(|sum| |min| |max| |average| |difference| |product| |quotient|))
       (COND
        ((KM-BAGP FRAME)
         (CLET ((FRAMES (BAG-TO-LIST FRAME)))
          (CASE SLOT (|sum| (AGGREGATE-VALS #'+ FRAMES))
           (|average|
            (COND ((AND (EVERY #'NUMBERP FRAMES) (CNOT (NULL FRAMES))) (LIST (/ (FIRST (AGGREGATE-VALS #'+ FRAMES)) (LENGTH FRAMES))))
             (T (KM0 '(|a| |Number|) :FAIL-MODE 'ERROR))))
           (|min| (AGGREGATE-VALS #'MIN FRAMES)) (|max| (AGGREGATE-VALS #'MAX FRAMES)) (|product| (AGGREGATE-VALS #'* FRAMES))
           (|quotient| (AGGREGATE-VALS #'/ FRAMES)) (|difference| (AGGREGATE-VALS #'- FRAMES)))))
        (T
         (REPORT-ERROR 'USER-ERROR "(the ~a of ~a): ~a should be given a bag (:bag ...) as an argument!~% [(the bag of <set>) will convert sets to bags]"
          SLOT FRAME SLOT))))
      ((KM-ARGSP FRAME)  (KM0 `(|the| ,SLOT |of| ,(SECOND FRAME)) :FAIL-MODE FAIL-MODE))
      ((EQ SLOT '|elements|)
       (COND
        ((CNOT (KM-STRUCTURED-LIST-VALP FRAME))
         (REPORT-ERROR 'USER-ERROR "Trying to find the elements of a non-sequence/non-bag ~a!~%Continuing, returning (~a)...~%" FRAME FRAME)
         (LIST FRAME))
        (T (FLATTEN-SETS (SEQ-TO-LIST FRAME)))))
      
      ((EQ SLOT '|seq-length|)
       (COND
        ((CNOT (KM-STRUCTURED-LIST-VALP FRAME))
         (REPORT-ERROR 'USER-ERROR
          "Trying to find the length of a non-sequence ~a!~%       (Use `number' not `length' to find the number of elements in a set)~%" FRAME FRAME))
        (T (LIST (LENGTH (SEQ-TO-LIST FRAME))))))
      ((EQ SLOT '|bag-length|)
       (COND
        ((CNOT (KM-STRUCTURED-LIST-VALP FRAME))
         (REPORT-ERROR 'USER-ERROR
          "Trying to find the length of a non-bag ~a!~%       (Use `number' not `length' to find the number of elements in a set)~%" FRAME FRAME))
        (T (LIST (LENGTH (BAG-TO-LIST FRAME))))))
      ((KM-FUNCTIONP FRAME) (REPORT-ERROR 'USER-ERROR "Trying to take the slot of a function (not allowed!)~%     Doing (the ~a of ~a)~%" SLOT FRAME))
      ((KM-STRUCTURED-LIST-VALP FRAME) 
       (LIST (CONS (FIRST FRAME) (MY-MAPCAN #'(LAMBDA (EL) (KM0 `(|the| ,SLOT |of| ,EL) :FAIL-MODE FAIL-MODE)) (REST FRAME)))))
      ((CLASS-DESCRIPTIONP FRAME) 
       (CASE SLOT (|instance-of| '(|Class|)) (|superclasses| (LIST (FIRST (CLASS-DESCRIPTION-TO-CLASS+SLOTSVALS FRAME :FAIL-MODE 'ERROR))))
        (T (REPORT-ERROR 'USER-ERROR "Sorry! I don't know how to compute the ~a of the class ~a!~%" FRAME SLOT))))
      ((LISTP FRAME)
       (REPORT-ERROR 'USER-ERROR "Trying to get a slot value of a list of frames,~%rather than a single frame. slot: ~a. frame: ~a.~%" SLOT FRAME))
      ((CASE SLOT (|abs| (LIST (COND ((NUMBERP FRAME) (ABS FRAME)) (T FRAME)))) (|log| (LIST (COND ((NUMBERP FRAME) (LOG FRAME)) (T FRAME))))
        (|exp| (LIST (COND ((NUMBERP FRAME) (EXP FRAME)) (T FRAME)))) (|sqrt| (LIST (COND ((NUMBERP FRAME) (SQRT FRAME)) (T FRAME))))
        (|floor| (LIST (COND ((NUMBERP FRAME) (FLOOR FRAME)) (T FRAME))))
        ((|instance-of| |classes|) (REMOVE-SUBSUMERS (IMMEDIATE-CLASSES FRAME :ENFORCE-CONSTRAINTS T)))  (|instances| (IMMEDIATE-INSTANCES FRAME))
        (|superclasses| (REMOVE-SUBSUMERS (IMMEDIATE-SUPERCLASSES FRAME))) (|supersituations| (IMMEDIATE-SUPERSITUATIONS FRAME))
        (|all-instances| (CL-ALL-INSTANCES FRAME)) (|all-prototypes| (ALL-PROTOTYPES FRAME)) (|all-classes| (ALL-CLASSES FRAME))
        (|all-superclasses| (ALL-SUPERCLASSES FRAME)) (|all-subclasses| (ALL-SUBCLASSES FRAME)) (|all-supersituations| (ALL-SUPERSITUATIONS FRAME))
        (|all-subslots| (ALL-SUBSLOTS FRAME)) (|all-superslots| (ALL-SUPERSLOTS FRAME)) (|domain| (REMOVE-SUBSUMEES (DOMAINS-OF FRAME)))
        (|range| (REMOVE-SUBSUMEES (RANGES-OF FRAME))) (|inverse| (LIST (INVERT-SLOT FRAME)))
        (|called|
         (KM0
          (VALS-TO-VAL
           (APPEND (GET-VALS FRAME '|called| :SITUATION *GLOBAL-SITUATION*) (GET-VALS FRAME '|uniquely-called| :SITUATION *GLOBAL-SITUATION*)))))
         (|uniquely-called| (KM0 (GET-VALS FRAME '|uniquely-called| :SITUATION *GLOBAL-SITUATION*))) (|cardinality| (LISTIFY (CARDINALITY-OF FRAME)))
        (|fluent-status| (LISTIFY (FLUENT-STATUS FRAME)))))
      (T (KM-SLOTVALS2 FRAME SLOT :FAIL-MODE FAIL-MODE))))))))
(TRACE-LISP
 (DEFINE KM-SLOTVALS2 (FRAME SLOT &REST LKEYS)
  (trace-defun 'KM-SLOTVALS2 (FRAME SLOT LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (COND
      ((CNOT (KB-OBJECTP FRAME))
       (COND ((EQ SLOT '|name|) (LIST (NAME FRAME))) 
        (T (REPORT-ERROR 'USER-ERROR "(the ~a of ~a): Attempt to find a property of a non-kb-object ~a!~%" SLOT FRAME FRAME))))
      ((ALREADY-DONE FRAME SLOT) 
       (CLET ((VALUES (REMOVE-CONSTRAINTS (GET-VALS FRAME SLOT :SITUATION (TARGET-SITUATION (CURR-SITUATION) FRAME SLOT)))))
        (KM-TRACE 'COMMENT "(Retrieving answer computed and cached earlier:") (KM-TRACE 'COMMENT " (the ~a of ~a) = ~a))" SLOT FRAME VALUES) VALUES))
      ((CHECK-SITUATIONS-MODE FRAME SLOT) NIL) ((KM-SLOTVALS-FROM-KB FRAME SLOT :FAIL-MODE FAIL-MODE))
      ((EQ SLOT '|name|)  (CLET ((NAME (NAME FRAME))) (COND (NAME (PUT-VALS FRAME SLOT (LIST NAME) :INSTALL-INVERSESP NIL) (LIST NAME)))))))))))
;;;; ======================================================================
;;;;		GENERAL UTILITIES
;;;; ======================================================================
;;;; (vals-in-class vals class): Return only those vals which are in class.
(TRACE-LISP
 (DEFINE VALS-IN-CLASS (VALS CLASS)
  (trace-defun 'VALS-IN-CLASS (VALS CLASS)
   (RET (COND ((EQ CLASS '*) VALS) (T (REMOVE-IF-NOT #'(LAMBDA (VAL) (trace-defun '#:G15597 (VAL) (RET (CL-ISA VAL CLASS)))) VALS)))))))
;;;; returns t if no reserved keywords, nil otherwise
(TRACE-LISP
 (DEFINE NO-RESERVED-KEYWORDS (VALS)
  (trace-defun 'NO-RESERVED-KEYWORDS (VALS)
   (RET
    (COND ((CNOT (CL-INTERSECTION VALS *RESERVED-KEYWORDS*)))
     (T
      (REPORT-ERROR 'USER-ERROR
       "Keyword(s) ~a found where concept name(s) were expected, within a
list of ~a KM expressions: ~a
(Error = missing parentheses?)~%"
       (CONCAT-LIST (COMMAIFY (MAPCAR #'PRINC-TO-STRING (CL-INTERSECTION VALS *RESERVED-KEYWORDS*))))  (LENGTH VALS)
       (CONCAT-LIST (COMMAIFY (MAPCAR #'PRINC-TO-STRING VALS))))))))))
;;                         (mapcar ;'list vals)))))
;;;; ======================================================================
;;;;		Evaluate unquoted bits in a quoted expression:
;;;; ======================================================================
;;;; RETURNS a *single* km value (including possibly a (:set ...) expression)
(TRACE-LISP
 (DEFINE PROCESS-UNQUOTES (EXPR &REST LKEYS)
  (trace-defun 'PROCESS-UNQUOTES (EXPR LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (COND ((NULL EXPR) NIL) ((CNOT (LISTP EXPR)) EXPR)
      ((EQ (FIRST EXPR) 'UNQUOTE)
       (COND ((CNOT (PAIRP EXPR)) (REPORT-ERROR 'USER-ERROR "Unquoted structure ~a should be a pair!~%" EXPR))
        (T (VALS-TO-VAL (KM0 (SECOND EXPR) :FAIL-MODE FAIL-MODE)))))
      (T (CONS (PROCESS-UNQUOTES (FIRST EXPR)) (PROCESS-UNQUOTES (REST EXPR))))))))))
;;;; (append-seqs ';$(:seq (:seq 1 2) (:seq 3 4))) -> ;$(:;seq; 1 2 3 4)
(TRACE-LISP
 (DEFINE APPEND-SEQS (SEQ-OF-SEQS)
  (trace-defun 'APPEND-SEQS (SEQ-OF-SEQS)
   (RET
    (COND
     ((OR (CNOT (KM-SEQP SEQ-OF-SEQS)) (NOTEVERY #'KM-SEQP (SEQ-TO-LIST SEQ-OF-SEQS)))
      (REPORT-ERROR 'USER-ERROR "(the append of ~a): value should be a sequence of sequences!" SEQ-OF-SEQS))
     (T `(:|seq| ,@(MY-MAPCAN #'SEQ-TO-LIST (SEQ-TO-LIST SEQ-OF-SEQS)))))))))
(TRACE-LISP
 (DEFINE APPEND-BAGS (BAG-OF-BAGS)
  (trace-defun 'APPEND-BAGS (BAG-OF-BAGS)
   (RET
    (COND
     ((OR (CNOT (KM-BAGP BAG-OF-BAGS)) (NOTEVERY #'KM-BAGP (BAG-TO-LIST BAG-OF-BAGS)))
      (REPORT-ERROR 'USER-ERROR "(the append of ~a): value should be a bag of bags!" BAG-OF-BAGS))
     (T `(:|bag| ,@(MY-MAPCAN #'BAG-TO-LIST (BAG-TO-LIST BAG-OF-BAGS)))))))))
;;;; ----------
;;;; Spot ignored variables in *km-handler-alist*
;;;; Just used by me for tidying up the code
(TRACE-LISP
 (DEFINE FIND-IGNORED NIL
  (trace-defun 'FIND-IGNORED NIL
   (RET
    (TRACE-PROGN
     (MAPC
      #'(LAMBDA (ENTRY)
         (trace-defun '#:G15598 (ENTRY)
          (RET
           (CLET
            ((PATTERN+VARS+BODY (MINIMATCH ENTRY '(?PATTERN (LAMBDA ?VARS &REST)))) (PATTERN (FIRST PATTERN+VARS+BODY)) (VARS (SECOND PATTERN+VARS+BODY))
             (BODY (THIRD PATTERN+VARS+BODY)) (FLAT-BODY (CL-FLATTEN BODY))
             (IGNORED-VARS (REMOVE-IF #'(LAMBDA (VAR) (trace-defun '#:G15599 (VAR) (RET (CL-MEMBER VAR FLAT-BODY)))) VARS)))
            (MAPC
             #'(LAMBDA (IGNORED-VAR)
                (trace-defun '#:G15600 (IGNORED-VAR) (RET (KM-FORMAT T "pattern: ~a - variable ~a ignored~%" PATTERN IGNORED-VAR))))
             IGNORED-VARS)))))
      *KM-HANDLER-ALIST*)
     T)))))
;;;; ---------- for Jerome...
(TRACE-LISP
 (DEFINE RULES-FOR (SLOT FRAMEADD &REST LKEYS)
  (trace-defun 'RULES-FOR (SLOT FRAMEADD LKEYS)
   (RET
    (CLET (RETAIN-COMMENTSP)
     (CLET ((FRAME (KM-UNIQUE0 FRAMEADD :FAIL-MODE 'ERROR)))
      (VAL-SETS-TO-EXPR
       (APPEND (OWN-RULE-SETS FRAME SLOT :RETAIN-COMMENTSP RETAIN-COMMENTSP) (INHERITED-RULE-SETS FRAME SLOT :RETAIN-COMMENTSP RETAIN-COMMENTSP))
       (SINGLE-VALUED-SLOTP SLOT))))))))
;;;; ======================================================================
;;;;	QUANTIFICATION: I get bus errors if I include these verbatim in the handler-alist itself, and use KM in compiled mode.
;;;;	This is an Allegro bug. So I need to separate out the bodies here. It seems to be the ;'every and ;'find-if calls which cause the problem.
;;;; ======================================================================
(TRACE-LISP
 (DEFINE ALLOF-MUST (VAR SET TEST)
  (trace-defun 'ALLOF-MUST (VAR SET TEST)
   (RET
    (COND
     ((CNOT (KM-VARP VAR)) (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|allof| ,VAR |in| ,SET |must| ,TEST)))
     ((EVERY #'(LAMBDA (INSTANCE) (trace-defun '#:G15601 (INSTANCE) (RET (KM0 (SUBST INSTANCE VAR TEST))))) (KM0 SET)) '(|t|)))))))
(TRACE-LISP
 (DEFINE ALLOF-WHERE-MUST (VAR SET TEST2 TEST)
  (trace-defun 'ALLOF-WHERE-MUST (VAR SET TEST2 TEST)
   (RET
    (COND
     ((CNOT (KM-VARP VAR))
      (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|allof| ,VAR |in| ,SET |where| ,TEST2 |must| ,TEST)))
     ((EVERY #'(LAMBDA (INSTANCE) (trace-defun '#:G15602 (INSTANCE) (RET (KM0 (SUBST INSTANCE VAR TEST)))))
       (KM0 `(|allof| ,VAR |in| ,SET |where| ,TEST2)))
      '(|t|)))))))
(TRACE-LISP
 (DEFINE ONEOF-WHERE (VAR SET TEST)
  (trace-defun 'ONEOF-WHERE (VAR SET TEST)
   (RET
    (COND
     ((CNOT (KM-VARP VAR)) (REPORT-ERROR 'USER-ERROR "~a: Second argument should be a variable (e.g., ?x)!~%" `(|oneof| ,VAR |in| ,SET |where| ,TEST)))
     (T
      (CLET
       ((ANSWER
         (FIND-IF #'(LAMBDA (MEMBER) (trace-defun '#:G15603 (MEMBER) (RET (CLET ((TEST0 (SUBST CL-MEMBER VAR TEST))) (KM0 TEST0))))) (KM0 SET))))
       (COND (ANSWER (LIST ANSWER))))))))))
;;;; ======================================================================
;;;;		SEARCH CONTROL
;;;; *search-control-points* is a LIST of elements:
;;;;	(pattern vars mindepth maxdepth result)
;;;; ======================================================================
(TRACE-LISP
 (DEFINE NO-SEARCH-CONTROL NIL
  (trace-defun 'NO-SEARCH-CONTROL NIL
   (RET (TRACE-PROGN (CSETQ *SEARCH-CONTROL-POINTS* NIL) (FORMAT T "All search control points removed.~%") '(|t|))))))
(TRACE-LISP
 (DEFINE SEARCH-CONTROL (KMEXPR)
  (trace-defun 'SEARCH-CONTROL (KMEXPR)
   (RET
    (CLET
     ((SEARCH-CONTROL-POINT
       (FIND-IF
        #'(LAMBDA (SEARCH-CONTROL-POINT) (trace-defun '#:G15604 (SEARCH-CONTROL-POINT) (RET (MINIMATCH KMEXPR (FIRST SEARCH-CONTROL-POINT)))))
        *SEARCH-CONTROL-POINTS*)))
     (COND
      (SEARCH-CONTROL-POINT
       (CLET
        ((PATTERN (FIRST SEARCH-CONTROL-POINT)) (VARS (SECOND SEARCH-CONTROL-POINT)) (RESULT (FIFTH SEARCH-CONTROL-POINT))
         (MATCH (MINIMATCH KMEXPR PATTERN))
         (BINDINGS
          (MAPCAR #'(LAMBDA (PAIR) (trace-defun '#:G15605 (PAIR) (RET (CONS (FIRST PAIR) (SECOND PAIR)))))  (TRANSPOSE (LIST VARS MATCH))))
         (DEPTH (1+ *DEPTH*)))
         (COND (*TRACE* (FORMAT T "~a" DEPTH) (FORMAT T (SPACES (- (1+ DEPTH) (LENGTH (PRINC-TO-STRING DEPTH))))) (KM-FORMAT T "-> ~a~%" KMEXPR)))
        (MAKE-COMMENT "Search control: Expression ~a~%          caught by pattern ~a,~%          and evaluated as ~a (i.e., ~a)..." KMEXPR PATTERN RESULT
         (SUBLIS BINDINGS RESULT))
        (CLET ((ANSWER (KM0 (SUBLIS BINDINGS RESULT))))
         (COND (*TRACE* (FORMAT T "~a" DEPTH) (FORMAT T (SPACES (- (1+ DEPTH) (LENGTH (PRINC-TO-STRING DEPTH))))) (KM-FORMAT T "<- ~a~%" ANSWER)))
         ANSWER)))))))))
;;;; FILE:  get-slotvals.lisp
;;;; File: get-slotvals.lisp
;;;; Author: Peter Clark
;;;; Purpose: Basic searching for the value of a slot
;;;; ----------
;;;; Control use of inheritance...
;;(defparameter *use-inheritance* t)		; moved to header.lisp
;;(defparameter *use-prototypes* t)		; moved to header.lisp
(TRACE-LISP (DEFINE USE-INHERITANCE NIL (trace-defun 'USE-INHERITANCE NIL (RET (AND *USE-INHERITANCE* (CNOT (AM-IN-PROTOTYPE-MODE)))))))
;; no inheritance within prototype mode
(TRACE-LISP (DEFINE USE-PROTOTYPES NIL (trace-defun 'USE-PROTOTYPES NIL (RET (AND *USE-PROTOTYPES* (CNOT (AM-IN-PROTOTYPE-MODE)))))))
;; no inheritance within prototype mode
;;;; ----------
#|The length and ugliness of the below code is mainly due to the desire to
put in good tracing facilities for the user, rather than the get-slotvals
procedure being intrinsically complicated.

There are six sources of information for finding a slot's value:

  0. PROTOTYPES: special form of representation
  1. PROJECTION: from the previous situation
  2. SUBSLOTS: find values in the slot's subslots.
  3. SUPERSITUATIONS: Import value(s) from the current situation's supersituations
  4. LOCAL VALUES: currently on the slot
  5. INHERITANCE: inherit rules from the instance's classes.

There are two caveats:
  1. We want to make an intermediate save of the results of 1-4 before adding in 5,
	to avoid a special case of looping during subsumption checks.
  2. If the slot is single-valued, then the projected value (1) should not be 
	automatically combined in. Instead, (2-5) should first be computed, then
 	if (1) is consistent with the combination of (2-5), it should be then unified 
	in, otherwise discarded.
     The procedure which handles this special case of projection is maybe-project-value.

----------------------------------------

The procedure was rewritten in April 99 to show more clearly to the user what KM
was doing during the trace, although it makes the actual source code less clear (perhaps?).|#
;;;; ======================================================================
(TRACE-LISP
 (DEFINE KM-SLOTVALS-FROM-KB (INSTANCE0 SLOT &REST LKEYS)
  (trace-defun 'KM-SLOTVALS-FROM-KB (INSTANCE0 SLOT LKEYS)
   (RET
    (CLET (FAIL-MODE &AUX N) (init-keyval N 0)  (DECLARE (IGNORE FAIL-MODE))    
     (CLET
      ((SINGLE-VALUEDP (SINGLE-VALUED-SLOTP SLOT))  (MULTIVALUEDP (CNOT SINGLE-VALUEDP))   
       (_CLONES-DUMMY
        (COND
         ((AND *ARE-SOME-PROTOTYPES* (CNOT (CL-MEMBER SLOT *SLOTS-NOT-TO-CLONE-FOR*)) (USE-PROTOTYPES) (CNOT (PROTOINSTANCEP INSTANCE0))) 
          (UNIFY-IN-PROTOTYPES INSTANCE0 SLOT))))
       #|	  (_clones-dummy (cond ((am-in-theoryp)
				(not (frame-for instance))
				(pull-in-frame instance)
				(mark-frame-as-done instance))))		; so it's never pulled in a second time.
		Now it's pulled in, own-rule-sets will collect the data locally, not in *Global|#
         
       #|[1] Special case: 
	(every Transcribe has
	  (subevent ((a Copy with
			(next-event ((if <test> then (the Copy subevent of Self) else ...)))))))

;;; Here's the problem we want to avoid...
[_Situation1] KM> (the subevent of (a Transcribe))
(_Copy2)
[_Situation1] KM> (next-situation)
[_Situation2] KM> (the next-event of _Copy2)
NIL

Similarly, projecting from prev situation doesn't work, as we want to re-evaluate the next-event rule.
Hence we reify _Copy2 in the *Global situation. But we can only do this if subevent is a non-fluent ([2]) ?? - Do I really need this constraint?
I'm restricting the generality of my reification "solution" here. I need a good model of destruction for this to be okay.
Consider:
	(every Water has
	  (parts ((a Hydrogen with (bound-to ((the Oxygen parts of Self))))
		  (a Oxygen with (bound-to ((the Hydrogen parts of Self)))))))
If the Hydrogen and Oxygen can be removed as parts of the Water, then we must also be allowed to break
their bindings. Hmm...But we shouldn't be able to break the "parts" relation, though? I suppose we could
"switch" one Hydrogen for another, without violating the axiom, and then the bound-to relationship no
longer needs to hold for the old Hydrogen part. But that is rather strange.

[2] came up as Ken Barker wanted to be able to say things like:
	(every Person has (owns ((a Car))))
but not insist that it's the *same* car uniformly throughout their life. So we make owns a fluent.
Now:
	(every Person has (owns ((a Car with (parts ((a Engine)))))))
Suppose Fred owns _Car1 with _Engine1 in _Situation1. Now, in Situation2, there's no guarantee that
Fred still owns _Car1, and hence no guarantee that the constraint _Car1 parts _Engine1 still needs
to be enforced (?).|#
       (INSTANCE (DEREFERENCE INSTANCE0)) (TARGET `(|the| ,SLOT |of| ,INSTANCE)) (OWN-RULE-SETS0 (OWN-RULE-SETS INSTANCE SLOT :RETAIN-COMMENTSP T))
       (OWN-CONSTRAINTS (MAPCAN #'FIND-CONSTRAINTS-IN-EXPRS OWN-RULE-SETS0)) 
       (INHERITED-RULE-SETS 
        (COND
         ((USE-INHERITANCE)
          (COND
           ((AND (CNOT OWN-RULE-SETS0)  (AM-IN-LOCAL-SITUATION)  (CNOT (FLUENTP SLOT))) 
            (CLET
             ((GLOBAL-INHERITED-RULE-SETS (INHERITED-RULE-SETS INSTANCE SLOT :RETAIN-COMMENTSP T))
              (LOCAL-INHERITED-RULE-SETS (INHERITED-RULE-SETS INSTANCE SLOT :RETAIN-COMMENTSP T :CLIMB-SITUATION-HIERARCHYP NIL)))
             (APPEND LOCAL-INHERITED-RULE-SETS (REIFY-EXISTENTIALS-IN-RULE-SETS GLOBAL-INHERITED-RULE-SETS))))
           (T (INHERITED-RULE-SETS INSTANCE SLOT :RETAIN-COMMENTSP T))))))
        (INHERITED-CONSTRAINTS (MAPCAN #'FIND-CONSTRAINTS-IN-EXPRS INHERITED-RULE-SETS))  (CONSTRAINTS (APPEND INHERITED-CONSTRAINTS OWN-CONSTRAINTS))
       (NO-INHERITANCEP (AND *USE-NO-INHERITANCE-FLAG* (CL-MEMBER '(|no-inheritance|) CONSTRAINTS :TEST #'CL-EQUAL)))  
       (TRY-PROJECTIONP (AND (AM-IN-LOCAL-SITUATION) (PROJECTABLE SLOT INSTANCE) (PREV-SITUATION (CURR-SITUATION))))
       (PROJECTED-VALS0
        (COND
         (TRY-PROJECTIONP (COND ((TRACEP) (CSETQ N (1+ N)) (KM-TRACE 'COMMENT "(~a) Look in previous situation" N)))
          (KM-SLOTVALS-VIA-PROJECTION INSTANCE SLOT))))
       (PROJECTED-VALS
        (COND
         ((AND CONSTRAINTS PROJECTED-VALS0)
          (COND
           ((AND (TRACEP) (CNOT (TRACEUNIFYP))) (PROG2 (SUSPEND-TRACE) (FILTER-USING-CONSTRAINTS PROJECTED-VALS0 CONSTRAINTS SLOT) (UNSUSPEND-TRACE)))
           (T (KM-TRACE 'COMMENT "(~ab) Test projected values ~a against constraints ~a" N PROJECTED-VALS0 CONSTRAINTS)
            (FILTER-USING-CONSTRAINTS PROJECTED-VALS0 CONSTRAINTS SLOT))))
         (T PROJECTED-VALS0)))
       
       (_PROJECT1-DUMMY
        (COND
         ((AND (TRACEP) TRY-PROJECTIONP (CNOT (CL-EQUAL PROJECTED-VALS0 PROJECTED-VALS))
           (KM-TRACE 'COMMENT "    Discarding projected values ~a (conflicts with constraints ~a)" (SET-DIFFERENCE PROJECTED-VALS0 PROJECTED-VALS)
            CONSTRAINTS)))))
       (_PROJECT2-DUMMY
        (COND
         ((AND PROJECTED-VALS MULTIVALUEDP) 
          (CLET ((PREV-SITUATION (PREV-SITUATION (CURR-SITUATION))))
           (MAPC
            #'(LAMBDA (PROJECTED-VAL)
               (trace-defun '#:G15606 (PROJECTED-VAL) (RET (RECORD-EXPLANATION-FOR TARGET PROJECTED-VAL `(|projected-from| ,PREV-SITUATION)))))
            PROJECTED-VALS)
            (MAKE-COMMENT "Projected (the ~a of ~a) = ~a from ~a to ~a" SLOT INSTANCE PROJECTED-VALS PREV-SITUATION (CURR-SITUATION))))))
        (SUBSLOTS (IMMEDIATE-SUBSLOTS SLOT))
       (SUBSLOT-VALS
        (COND
         (SUBSLOTS
          (COND (NO-INHERITANCEP (KM-TRACE 'COMMENT "(Ignore subslots, as there is a `(no-inheritance)' constraint on this slot)"))
           (T (COND ((TRACEP) (CSETQ N (1+ N)) (KM-TRACE 'COMMENT "(~a) Look in subslot(s)" N)))     #|Correct|#
            (KM0 (VALS-TO-VAL (MAPCAR #'(LAMBDA (SUBSLOT) (trace-defun '#:G15607 (SUBSLOT) (RET `(|the| ,SUBSLOT |of| ,INSTANCE0)))) SUBSLOTS))
             :TARGET TARGET))))))
       
       #|[1] For non-fluents, although we ensure that values of slot will be stored in
*Global (by put-slotvals in frame-io.lisp), we must also ensure that any direct *side effects*
during the computation are *also* stored in *Global. This is because all the expr sets 
necessarily came from *Global in the first place, but we (below) skip doing the computation
in *Global by default for non-fluents.
[Note we don't *only* do the computation in *Global, as the local situation alone may have the
 extra information we need to compute the slot's values.]
The only side-effect I can think of is *instance creation* (with the side-effect of asserting
an instance-of link). So we check for the presence of this in the exprs (which necessarily
all come from *Global, as the slot is a non fluent).
Note indirect side-effects will be handled automatically by a recursive call to KM.|#
                 
       #|11/13/03: This bit of code is now redundant. Reasoning in a situation will NOT include switching to the parent
situation, as (for example) the parent situation might conclude opposite things given the closed-world
assumption. We'd already prevented this switching for *global-situation* (see code below), we now
extend it to ALL parent situations.

	  (supersituations0 (immediate-supersituations (curr-situation)))
	  (supersituations (cond (supersituations0
				  (remove *global-situation* supersituations0))
				 (t supersituations0)))
	  (supersituation-vals (cond ((and supersituations 
					   (or (fluentp slot)	; If the slot isn't a fluent, then supersituations won't contribute anything
					       (contains-some-existential-exprs inherited-rule-sets)
					       (contains-some-existential-exprs own-rule-sets0)))
				      (cond ((tracep)
					     (setq n (1+ n))
					     (km-trace 'comment "(~a) Look in supersituation(s)" n)))
; not used any more		      (remove-fluent-instances
				       (km0 (val-sets-to-expr
					   (mapcar X'(lambda (sitn) `X$((in-situation ,SITN (the ,SLOT of ,INSTANCE0))))
						   supersituations)
					   single-valuedp)
					 ))))|#
       (SUPERSITUATION-VALS NIL)  
       #|Now redundant - we move prototype unification in earlier, and then can compute own-rule-sets
immediately afterwards using the function specifically for this purpose, in frame-io.lisp.
This correction here is no longer needed.

;;; 11.15.00 MOVE THIS EARLIER -- BEFORE the supersituation access clobbers the rules on instances!!
;;; 11.16.00 No! Must come *AFTER* prototypes are folded in, in order to pick up their contributions
;;; 	     to the slot values!
          (own-rules 
	   (let ( (local-situation (target-situation (curr-situation) instance slot)) )
	     (bind-self
	      (or (get-vals instance slot :facet 'own-properties :situation local-situation)     ; This disjunct should be in get-vals-
		  (get-vals instance slot :facet 'own-definition :situation local-situation))    ; in-situation, not here,+ should be conj!
	      instance)))

;;; Same as own-rules, except here we must remove the fluent instances! NB *leave* the fluent
;;; instances in own-rules.
	  (supersituation-own-rule-sets (supersituation-own-rule-sets instance slot :retain-commentsp t))

;;; - own-rule-sets SUPERCEDES own-rule-sets0. It may contain extra data as a result of the prototypes being unified in.
	  (own-rule-sets (remove nil (cons own-rules supersituation-own-rule-sets)))

;	  (_dum (km-format t "own-rules = ~a, own-rule-sets = ~a~%" own-rules own-rule-sets))|#
       (OWN-RULE-SETS OWN-RULE-SETS0)      
       (LOCAL-VALS
        (COND
         (OWN-RULE-SETS
          (COND ((TRACEP)  (CSETQ N (1+ N))  (KM-TRACE 'COMMENT "(~a) Local value(s): ~a" N (VAL-SETS-TO-EXPR OWN-RULE-SETS SINGLE-VALUEDP))))
          (COND
           ((AND (SINGLETONP OWN-RULE-SETS)  (SINGLETONP (FIRST OWN-RULE-SETS)) (ATOM (FIRST (FIRST OWN-RULE-SETS)))
             (EQ (DEREFERENCE (FIRST (FIRST OWN-RULE-SETS))) (FIRST (FIRST OWN-RULE-SETS))))
            (FIRST OWN-RULE-SETS))
           (T   (KM0 (VAL-SETS-TO-EXPR OWN-RULE-SETS SINGLE-VALUEDP) :TARGET TARGET))))))
       
       (LOCAL-CONSTRAINTS
        (CLET ((LOCAL-SITUATION (TARGET-SITUATION (CURR-SITUATION) INSTANCE SLOT)))
         (FIND-CONSTRAINTS-IN-EXPRS (BIND-SELF (GET-VALS INSTANCE SLOT :SITUATION LOCAL-SITUATION) INSTANCE))))
       
       #| SPECIAL CASE: Storing intermediate result.
   Now we store the intermediate result, in case when applying the rules we need to see 
   what we've got so far. [Case in point: _Engine23 from supersituation, (a Engine with 
   (connects ((the parts of ...)))) from classes, and if we fail to show (a Engine.. ) 
   subsumes _Engine23 due to subsumption check, we still want to assert _Engine23].

[1] projecting a single-valued slot is done *later*|#
       (N-FIRST-SOURCE (COND ((AND TRY-PROJECTIONP SINGLE-VALUEDP) 2) (T 1)))     (N-SOURCES N) 
       (VAL-SETS
        (CL-REMOVE-DUPLICATES (CL-REMOVE NIL `(,(COND (MULTIVALUEDP PROJECTED-VALS))  ,SUBSLOT-VALS ,SUPERSITUATION-VALS ,LOCAL-VALS))  :TEST
         #'CL-EQUAL))
       
       #|POSSIBLY WANT CONSTRAINT CHECKING HERE TOO (TO AVOID INTERMEDIATE INCORRECT SAVE)
7/11/02: No kidding. Without this, it causes a problem when an (at-most 1 <M>) constraint should force unification
of the two values. But instead they get asserted as two values, which later can generate an
error. Let's patch this one, but JUST to check for forced unifications.|#
       (VALS
        (COND ((NULL VAL-SETS) NIL) 
         (T
          (CLET
           ((SINGLETONP-CONSTRAINTS
             (REMOVE-IF-NOT
              #'(LAMBDA (CONSTRAINT)
                 (trace-defun '#:G15608 (CONSTRAINT)
                  (RET (AND (CL-MEMBER (FIRST CONSTRAINT) '(|at-most| |exactly|)) (EQ (SECOND CONSTRAINT) 1)))))
              CONSTRAINTS)))
           (COND
            ((SINGLETONP VAL-SETS) 
             (COND
              ((CNOT (DONT-CACHE-VALUES-SLOTP SLOT))
               (CLET ((VALS0 (ENFORCE-SET-CONSTRAINTS (FIRST VAL-SETS) SINGLETONP-CONSTRAINTS INSTANCE))) (PUT-VALS INSTANCE SLOT VALS0) VALS0))
              (T (FIRST VAL-SETS))))
            (T
             (COND
              ((NEQ N-FIRST-SOURCE N-SOURCES) (KM-TRACE 'COMMENT "(~a-~a) Combine ~a-~a together" N-FIRST-SOURCE N-SOURCES N-FIRST-SOURCE N-SOURCES)))
             (CLET ((VALS0 (ENFORCE-SET-CONSTRAINTS (KM0 (VAL-SETS-TO-EXPR VAL-SETS SINGLE-VALUEDP) :TARGET TARGET) SINGLETONP-CONSTRAINTS INSTANCE)))
              (COND ((CNOT (DONT-CACHE-VALUES-SLOTP SLOT)) (PUT-VALS INSTANCE SLOT VALS0)))  VALS0)))))))
          
       (INHERITED-RULE-SETS00
        (COND
         (*ARE-SOME-DEFAULTS*
          (MAPCAR
           #'(LAMBDA (EXPR-SET)
              (trace-defun '#:G15609 (EXPR-SET)
               (RET (EVALUATE-AND-FILTER-DEFAULTS EXPR-SET CONSTRAINTS VALS SLOT :SINGLE-VALUEDP SINGLE-VALUEDP))))
            #|NEW|# (APPEND OWN-RULE-SETS INHERITED-RULE-SETS)))
         (T INHERITED-RULE-SETS)))
       (ALL-VALS00
        (COND ((CNOT (USE-INHERITANCE)) (KM-TRACE 'COMMENT "(No inherited rules (Inheritance is turned off))") VALS)
         (INHERITED-RULE-SETS00
          (COND (NO-INHERITANCEP (KM-TRACE 'COMMENT "(Ignore inherited rules, as there is a `(no-inheritance)' constraint on this slot)") VALS)
           ((AND VALS (INHERIT-WITH-OVERRIDES-SLOTP SLOT))
            (KM-TRACE 'COMMENT "(Ignore rules, as there are local values and the slot is an inherit-with-overrides slot)") VALS)
           (T 
            (COND
             ((TRACEP) (CSETQ N (1+ N))
              (COND
               ((INHERIT-WITH-OVERRIDES-SLOTP SLOT)
                (KM-TRACE 'COMMENT "(~a) Lowest rules, from inheritance with over-rides: ~a" N (VAL-SETS-TO-EXPR INHERITED-RULE-SETS00 SINGLE-VALUEDP)))
               (T (KM-TRACE 'COMMENT "(~a) From inheritance: ~a" N (VAL-SETS-TO-EXPR INHERITED-RULE-SETS00 SINGLE-VALUEDP))))))
            (COND (VALS (KM-TRACE 'COMMENT "(~a-~a) Combine ~a-~a together" N-FIRST-SOURCE N N-FIRST-SOURCE N)))
            (KM0 (VAL-SETS-TO-EXPR (CONS VALS INHERITED-RULE-SETS00) SINGLE-VALUEDP) :TARGET TARGET))))
         (T VALS)))
       
       (ALL-VALS0
        (COND
         ((AND ALL-VALS00 INHERITED-RULE-SETS00 (USE-INHERITANCE) (CNOT NO-INHERITANCEP) (CNOT (DONT-CACHE-VALUES-SLOTP SLOT)))
          (CLET
           ((RECURSIVE-RULESETS
             (REMOVE-IF-NOT #'(LAMBDA (RULESET) (trace-defun '#:G15610 (RULESET) (RET (RECURSIVE-RULESET INSTANCE SLOT RULESET))))
              INHERITED-RULE-SETS00)))
           (COND
            (RECURSIVE-RULESETS
             (KM-TRACE 'COMMENT "Recursive ruleset(s) ~a encountered~%...retrying them now some other values have been computed!" RECURSIVE-RULESETS)
             (PUT-VALS INSTANCE SLOT ALL-VALS00) (KM0 (VAL-SETS-TO-EXPR (CONS ALL-VALS00 INHERITED-RULE-SETS00) SINGLE-VALUEDP) :TARGET TARGET))
            (T ALL-VALS00))))
         (T ALL-VALS00)))
       
       (ALL-VALS1
        (COND (MULTIVALUEDP ALL-VALS0) 
         (T
          (CLET ((PROJECTED-VAL (MAYBE-PROJECT-VALUE PROJECTED-VALS  ALL-VALS0 SLOT INSTANCE N)))
           (COND
            (PROJECTED-VAL (RECORD-EXPLANATION-FOR TARGET PROJECTED-VAL `(|projected-from| ,(PREV-SITUATION (CURR-SITUATION)))) (LIST PROJECTED-VAL)) 
            (T ALL-VALS0))))))
         
       (ALL-VALS2
        (COND
         (CONSTRAINTS 
          (COND
           ((AND (TRACEP) (CNOT (TRACECONSTRAINTSP)))
            (PROG2 (SUSPEND-TRACE) (ENFORCE-CONSTRAINTS ALL-VALS1 CONSTRAINTS INSTANCE SLOT) (UNSUSPEND-TRACE)))
           (T (KM-TRACE 'COMMENT "(~ab) Test values against constraints ~a" N CONSTRAINTS) (ENFORCE-CONSTRAINTS ALL-VALS1 CONSTRAINTS INSTANCE SLOT))))
         (T ALL-VALS1)))
       (ALL-VALS
        (COND ((REMOVE-SUBSUMERS-SLOTP SLOT) (REMOVE-SUBSUMERS ALL-VALS2)) ((REMOVE-SUBSUMEES-SLOTP SLOT) (REMOVE-SUBSUMEES ALL-VALS2)) (T ALL-VALS2)))
       (ALL-VALS-AND-CONSTRAINTS
        (COND
         (LOCAL-CONSTRAINTS
          (COND (SINGLE-VALUEDP (VAL-TO-VALS (VALS-TO-&-EXPR (APPEND ALL-VALS LOCAL-CONSTRAINTS)))) (T (APPEND ALL-VALS LOCAL-CONSTRAINTS))))
         (T ALL-VALS))))
      (DECLARE (IGNORE _INHERITED-RULE-SETS-DUMMY _PROJECT1-DUMMY _PROJECT2-DUMMY _ALL-VALS-DUMMY _CLONES-DUMMY))
      (COND ((CNOT (DONT-CACHE-VALUES-SLOTP SLOT)) (PUT-VALS INSTANCE SLOT ALL-VALS-AND-CONSTRAINTS)))      (CHECK-SLOT INSTANCE SLOT ALL-VALS)    
      (CLET ((TARGET-SITUATION (TARGET-SITUATION (CURR-SITUATION) INSTANCE SLOT ALL-VALS)))
       (COND
        ((AND (NEQ TARGET-SITUATION *GLOBAL-SITUATION*) (CNOT (CL-EQUAL ALL-VALS-AND-CONSTRAINTS (GET-VALS INSTANCE SLOT :SITUATION TARGET-SITUATION))))
         (UN-DONE INSTANCE :SLOT SLOT :SITUATION (CURR-SITUATION)))))
       (COND ((CNOT (DONT-CACHE-VALUES-SLOTP SLOT)) (NOTE-DONE INSTANCE SLOT)))   
      #|    (cond ((and (am-in-local-situation) 
		     *record-explanations*)
		(mapc X'(lambda (aval0)
			    (mapc X'(lambda (global-explanation)
				      (let ( (i (first global-explanation))
					     (s (second global-explanation))
					     (v (third global-explanation))
					     (es (fourth global-explanation)) )
;					(km-format t "DEBUG: Copying ~a from *Global to ~a~%" global-explanation (curr-situation))
					(mapc X'(lambda (e)
						  (record-explanation-for `X$(the ,S of ,I) v e))	; re-assert in (curr-situation)
					      es)))
				  (get-explanations instance slot aval0 *global-situation*)))	; -> ((i s v es) (v invs i es'))
		      all-vals)))|#
      ALL-VALS))))))
;;; END OF km-slotvals-from-kb!!!
#| 
Special case: If looping, then all-vals-and-constraints might be a STRUCTURE, rather than kb-objects.
In this case, we must filter off the structures, as get-vals is required to return only kb-objects. We also
must defer noting this slot as done -- a future retry might enable these structures to evaluate. 

This patch was later moved elsewhere into the interpreter.lisp code, see (remove-if-not X'is-km-term ...) test in (X$the ?slot of X$expr).
See the example in test-suite/restaurant.km for the explanation of this patch.
    (cond ((every X'is-km-term all-vals) 
	   (check-slot instance slot all-vals)				; optional error-checking
	   (note-done instance slot)					; flag instance.slot done
	   all-vals)
	  (t (remove-if-not X'is-km-term all-vals)))))|#
;;;; (recursive-ruleset ';$_Car23 ';$parts ';$(_Engine3 (the parts of (the parts of _Car23))))
;;;; -> t
;;;; This is using cheap tricks to check for recursive rules! If it accidentally makes a 
;;;; mistake it's not an error, just an inefficiency.
(TRACE-LISP
 (DEFINE RECURSIVE-RULESET (INSTANCE SLOT RULESET)
  (trace-defun 'RECURSIVE-RULESET (INSTANCE SLOT RULESET) (RET (SEARCH `(,SLOT |of| ,INSTANCE) (CL-FLATTEN RULESET))))))
#|(defun recursive-ruleset (instance slot ruleset)
  (some X'(lambda (rule) (recursive-rule instance slot rule)) ruleset))

(defun recursive-rule (instance slot rule)
  (cond ((equal rule `X$(the ,SLOT of ,INSTANCE)))
	((and (listp rule) 
	      (some X'(lambda (rule-part) (recursive-rule instance slot rule-part)) rule)))))|#
;;;; ======================================================================
;;;;		TEMPORAL PROJECTION CODE
;;;; ======================================================================
#|Look up the slotvals from the previous situation (if any).
Assume test "(and (am-in-local-situation) (projectable slot instance))" has already been passed.
[1] 9/8/00 - We must ensure that EVENTS have non-inertial slot values, even if the user's failed to specify that these
		 slots are non-inertial fluents. 
	To ensure this, BOTH (Event slot Instance) and (Instance invslot Event) triples CANNOT be projected.
	[2] in projectable() removes the former, and [1] below removes the latter.|#
(TRACE-LISP (DEFINE KM-SLOTVALS-VIA-PROJECTION (INSTANCE SLOT) (trace-defun 'KM-SLOTVALS-VIA-PROJECTION (INSTANCE SLOT) (RET ))))
;;;; For single-valued slots only. Only project a value if it unifies with the local value.
;;;; Returns a singleton list of the resulting (possibly unified) value.
(TRACE-LISP
 (DEFINE MAYBE-PROJECT-VALUE (PROJECTED-VALUES LOCAL-VALUES SLOT INSTANCE N-SOURCES)
  (trace-defun 'MAYBE-PROJECT-VALUE (PROJECTED-VALUES LOCAL-VALUES SLOT INSTANCE N-SOURCES)
   (RET
    (COND ((NULL PROJECTED-VALUES) NIL) ((CL-EQUAL PROJECTED-VALUES LOCAL-VALUES) (FIRST PROJECTED-VALUES)) 
     (T
      (CLET ((PREV-SITUATION (PREV-SITUATION (CURR-SITUATION))) (PROJECTED-VALUE (FIRST PROJECTED-VALUES)) (LOCAL-VALUE (FIRST LOCAL-VALUES)))
       (COND
        ((>= (LENGTH PROJECTED-VALUES) 2)
         (KM-FORMAT T "ERROR! Projected multiple values ~a for the single-valued slot `~a' on instance ~a!~%" PROJECTED-VALUES SLOT INSTANCE)
         (KM-FORMAT T "ERROR! Discarding all but the first value (~a)...~%" (FIRST PROJECTED-VALUES))))
       (COND
        ((>= (LENGTH LOCAL-VALUES) 2)
         (KM-FORMAT T "ERROR! Found multiple values ~a for the single-valued slot `~a' on instance ~a!~%" LOCAL-VALUES SLOT INSTANCE)
         (KM-FORMAT T "ERROR! Discarding all but the first value (~a)...~%" (FIRST LOCAL-VALUES))))
       (COND
        ((NULL LOCAL-VALUE) (KM-TRACE 'COMMENT "(1-~a) Projecting (the ~a of ~a) = (~a) from ~a" N-SOURCES SLOT INSTANCE PROJECTED-VALUE PREV-SITUATION)
         (MAKE-COMMENT "Projected (the ~a of ~a) = (~a) from ~a to ~a" SLOT INSTANCE PROJECTED-VALUE PREV-SITUATION (CURR-SITUATION)) PROJECTED-VALUE)
        (T
         (CLET ((UNIFIED (LAZY-UNIFY PROJECTED-VALUE LOCAL-VALUE)))
          (COND
           (UNIFIED
            (KM-TRACE 'COMMENT "(1-~a) Projecting and unifying (the ~a of ~a) = (~a) from ~a" N-SOURCES SLOT INSTANCE PROJECTED-VALUE PREV-SITUATION)
            (MAKE-COMMENT "Projected (the ~a of ~a) = (~a) from ~a to ~a" SLOT INSTANCE PROJECTED-VALUE PREV-SITUATION (CURR-SITUATION)) UNIFIED)
           
           (T
            (KM-TRACE 'COMMENT "(1-~a) Discarding projected value (the ~a of ~a) = (~a) (conflicts with new value (~a))" N-SOURCES SLOT INSTANCE
             PROJECTED-VALUE LOCAL-VALUE)))))))))))))
;;;; If a slot has no value in a situation, and it's projectable, then assume the
;;;; value in the previous situation still applies.
;;;; Note that KM doesn't distinguish "unknown" vs. "no value". By default, 
;;;; no conclusion is taken to mean "unknown", unless the slot is labeled as
;;;; having property "complete", in which case it is taken to mean "no value",
;;;; and hence shouldn't be projected.
(TRACE-LISP
 (DEFINE PROJECTABLE (SLOT INSTANCE)
  (trace-defun 'PROJECTABLE (SLOT INSTANCE) (RET (TRACE-PROGN (DECLARE (IGNORE INSTANCE)) (INERTIAL-FLUENTP SLOT))))))
;;;; ========================================
;;;; See comment under "3/4. COLLECT ALL THE RULE DATA NEEDED" above
(TRACE-LISP
 (DEFINE REIFY-EXISTENTIALS-IN-RULE-SETS (RULE-SETS)
  (trace-defun 'REIFY-EXISTENTIALS-IN-RULE-SETS (RULE-SETS) (RET (MAPCAR #'REIFY-EXISTENTIALS-IN-RULE-SET RULE-SETS)))))
;;;; ((a Car) (the age of Fred)) -> (_Car23 (the age of Fred))
(TRACE-LISP
 (DEFINE REIFY-EXISTENTIALS-IN-RULE-SET (RULE-SET)
  (trace-defun 'REIFY-EXISTENTIALS-IN-RULE-SET (RULE-SET) (RET (MAPCAR #'REIFY-EXISTENTIALS-IN-EXPR RULE-SET)))))
(TRACE-LISP
 (DEFINE REIFY-EXISTENTIALS-IN-EXPR (EXPR)
  (trace-defun 'REIFY-EXISTENTIALS-IN-EXPR (EXPR)
   (RET
    (COND
     ((AND (EXISTENTIAL-EXPRP EXPR)
       (SOME #'(LAMBDA (SLOTVALS) (trace-defun '#:G15611 (SLOTVALS) (RET (FLUENTP (SLOT-IN SLOTVALS)))))
        (SECOND (BREAKUP-EXISTENTIAL-EXPR EXPR))))
      (KM-UNIQUE0 `(|in-situation| |*Global| ,EXPR) :FAIL-MODE 'ERROR))
     (T EXPR))))))
;;;; FILE:  frame-io.lisp
;;;; File: frame-io.lisp
;;;; Author: Peter Clark
;;;; Date: August 1994
;;;; Purpose: Low-level interface to the KM data structures
;;;; ======================================================================
;;;; Active situations - a little trick for adding efficiency.
;;;; Normally, when unifying, KM will unify in ALL situations, including defunct ones.
;;;; With *deactivate-old-situations* = t, a (new-situation) will reset the active situation list
;;;; and thus (hopefully!) speed up unification when many situations are being used.
;;;; Actually - it's hopelessly slow! Let's ignore this.
;;;; ======================================================================
;;; No longer used
(TRACE-LISP (DEFPARAMETER *DEACTIVATE-OLD-SITUATIONS* NIL))
(TRACE-LISP (DEFVAR *ALL-ACTIVE-SITUATIONS* NIL))
(TRACE-LISP
 (DEFINE ADD-TO-ACTIVE-SITUATIONS (SITUATION) (trace-defun 'ADD-TO-ACTIVE-SITUATIONS (SITUATION) (RET (DECLARE (IGNORE SITUATION))))))
;;(defun add-to-active-situations (situation)
;;  (km-setq '*all-active-situations* (cons situation *all-active-situations*)))
;;(defun all-active-situations () 
;;  (cond (*deactivate-old-situations* (remove-duplicates (dereference *all-active-situations*)))
;;	(t (all-situations))))
(TRACE-LISP (DEFINE ALL-ACTIVE-SITUATIONS NIL (trace-defun 'ALL-ACTIVE-SITUATIONS NIL (RET (ALL-SITUATIONS)))))
#|======================================================================
	PRIMARY EXPORTED FUNCTIONS (incomplete list)
======================================================================

set/get functions all operate on the *local* situation *only*. They
  are low-level calls to be used by the KM system, and should never be
  used directly unless you are *sure* you're only going to be ever working
  in the Global situation.
 	(add-val instance slot val [install-inversesp situation])
 	(delete-val instance slot val [uninstall-inversesp situation])	 ; not used by KM, but by auxiliary s/w
 	(delete-slot instance slot [facet situation])

	(get-vals instance slot [&key facet situation])
 	(put-vals instance slot vals [&key facet situation install-inversesp])

	(add-slotsvals instance slotsvals [facet situation install-inversesp combine-values-by bind-selfp])

	(get-slotsvals frame [&key facet situation dereferencep])
	(put-slotsvals frame slotsvals [&key facet situation install-inversesp])
	(point-parents-to-defined-concept frame slotsvals facet)
	(create-instance class [slotsvals prefix-string bind-selfp])

scan all supersituations and classes for rules:
	(own-rule-sets instance slot [start-situation retain-commentsp])
	(supersituation-own-rule-sets instance slot [start-situation retain-commentsp])	[- not used]
	(inherited-rule-sets instance slot [start-situation retain-commentsp])
	(inherited-rule-sets-on-classes classes slot [start-situation retain-commentsp])
	(collect-constraints-on-instance instance slot [start-situation retain-commentsp])
	(local-constraints instance slot [situation retain-commentsp])

other:
;	(exists frame [start-situation])	       ; look in local + accessible situations
	(known-frame frame)			       ; Replace "exists", to be more explicit about what exists means
	(has-situation-specific-info frame situation)  ; look in local situation only
	(instance-of instance class)
	(is-subclass-of subclass class)
	(immediate-classes instance)
	(immediate-superclasses class)
	(immediate-subclasses class)
	(immediate-supersituations situation)
	(immediate-subslots slot)
	(all-instances class)
	(all-prototypes class)
	(all-classes instance)
	(all-superclasses class)
	(all-subclasses class)
	(all-supersituations situation)
	(all-subslots slot)

======================================================================|#
;;;; [1] Intent below is defconstant, but SBCL doesn't like defconstants on lists
(TRACE-LISP (DEFPARAMETER *ALL-FACETS* '(OWN-PROPERTIES MEMBER-PROPERTIES OWN-DEFINITION MEMBER-DEFINITION)))
(TRACE-LISP (DEFPARAMETER *VALID-CARDINALITIES* '(|1-to-N| |1-to-1| |N-to-1| |N-to-N|)))
(TRACE-LISP (DEFPARAMETER *DEFAULT-CARDINALITY* '|N-to-N|))
(TRACE-LISP (DEFPARAMETER *INEQUALITY-RELATIONS* '(< > <= >= /=)))
;; for km-assert etc.
(TRACE-LISP (DEFPARAMETER *EQUALITY-RELATIONS* '(= &?)))
(TRACE-LISP
 (DEFINE INVERT-INEQUALITY-RELATION (INEQUALITY)
  (trace-defun 'INVERT-INEQUALITY-RELATION (INEQUALITY) (RET (CASE INEQUALITY (< '>=) (> '<=) (>= '<) (<= '>) (/= '=))))))
;;;; ======================================================================
;;;;	These classes/instances have delayed evaluation assertions
;;;;	attached, listed on their "assertions" slot. When a new
;;;;	instance is created, the assertions are made. Typically, it
;;;;     will be just Situation classes that have this property.
;;;; ======================================================================
;;;; Instances of these classes will have their assertions made at creation time
;; (defvar *classes-using-assertions-slot* nil) now in header.lisp
;;;; ======================================================================
;;;; 		DECLARE BUILT-IN OBJECTS
;;;; ======================================================================
(TRACE-LISP (DEFPARAMETER *BUILT-IN-BAG-AGGREGATION-SLOTS* '(|min| |max| |sum| |average| |difference| |product| |quotient|)))
;; maps (:bag ...) -> value
;;;; Francis Leboutte - need an eval-when for LispWorks as this defconstant has a non-evaluated argument and is used in a subsequent
;;;; defconstant, so we have to force evaluation.
(TRACE-LISP (DEFCONSTANT *BUILT-IN-SEQ-AGGREGATION-SLOTS* NIL))
;; maps (:seq ...) -> value
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-SET-AGGREGATION-SLOTS*  '(|first| |second| |third| |fourth| |fifth| |last| |unification| |set-unification| |append| |number|)))
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-AGGREGATION-SLOTS*
  (CL-REMOVE-DUPLICATES (APPEND *BUILT-IN-BAG-AGGREGATION-SLOTS* *BUILT-IN-SEQ-AGGREGATION-SLOTS* *BUILT-IN-SET-AGGREGATION-SLOTS*))))
;;;; These slots are ONLY placed on slot frames, and are used as a cue that a slot is being described
(TRACE-LISP
 (DEFPARAMETER *SLOTS-SLOTS*
  '(|domain| |range| |cardinality| |inverse| |inverse2| |inverse3| |inverse12| |fluent-status| |inherit-with-overrides| |aggregation-function|)))
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-SINGLE-VALUED-SLOTS*
  (APPEND
   '(#|domain range|# |cardinality| |aggregation-function| #|complete|# |ignore-inverses| |inverse| |inverse2| |inverse3| |remove-subsumers|
     |remove-subsumees| |inherit-with-overrides| |fluent-status| |seq-length| |bag-length| |prev-situation|  |after-situation-of|    
     |prototype-participant-of| #|prototype-of prototype-scope |# |combine-values-by-appending| |uniquely-called| |dont-cache-values| |abs| |log| |exp|
     |sqrt| |floor| |aggregation-function|)
   *BUILT-IN-AGGREGATION-SLOTS*)))
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-MULTIVALUED-SLOTS*
  '(|domain| |range| #|M-new|# |element-type| |superclasses| |subclasses| |instances| |instance-of| |add-list| |del-list| |pcs-list| |ncs-list|
    |supersituations| |subsituations| |subslots| |superslots| |slots-to-opportunistically-evaluate|  |next-situation| |block-projection-for|
    |before-situation-of|  |before-situation| |after-situation| |domain-of| |range-of| |fluent-status-of| |called| |prototype-participants| |prototypes|
    |prototype-of| |cloned-from| |has-clones| |prototype-scope| #|text|# #|name print-name <-- should be single-valued!!|# |name| 
    #|terms <- no longer built-in |# |elements|  |member-of| |members|  |classes| |all-instances| |all-prototypes| |all-classes| |all-superclasses|
    |all-subclasses| |all-supersituations| |all-subslots| |assertions| == /==  < >)))
;; NEW 11/6/00 for numeric inequality constraints
(TRACE-LISP (DEFPARAMETER *BUILT-IN-SLOTS* (APPEND *BUILT-IN-SINGLE-VALUED-SLOTS* *BUILT-IN-MULTIVALUED-SLOTS*)))
;;;; ======================================================================
#|(defparameter *built-in-complete-slots* 'X$(add-list del-list))
PROBLEM! if make them complete, then we get into trouble with
do-script, which with multiple actions assumes the actions (hence the
add-list and del-lists) will be projected accross multiple situations! |#
;;(defparameter *default-built-in-inertial-fluent-slots* nil)	; let's try this for now...
(TRACE-LISP (DEFPARAMETER *DEFAULT-BUILT-IN-INERTIAL-FLUENT-SLOTS* (COND ((CNOT *CLONES-ARE-GLOBAL*) '(|cloned-from|)))))
(TRACE-LISP (DEFPARAMETER *BUILT-IN-INERTIAL-FLUENT-SLOTS* *DEFAULT-BUILT-IN-INERTIAL-FLUENT-SLOTS*))
;;;; This can be over-ridden...
;;;; cloned-from = new!
(TRACE-LISP (DEFPARAMETER *BUILT-IN-NON-INERTIAL-FLUENT-SLOTS* '(|add-list| |del-list| |pcs-list| |ncs-list| |block-projection-for| #|cloned-from|#)))
;;;; the rest are all non-fluents
;;;; May be recomputed if built-in-inertial-fluent-slots changes (see instance-of-is-fluent)
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-NON-FLUENT-SLOTS*
  (SET-DIFFERENCE *BUILT-IN-SLOTS* (APPEND *BUILT-IN-INERTIAL-FLUENT-SLOTS* *BUILT-IN-NON-INERTIAL-FLUENT-SLOTS*))))
;;;; Let's allow the user to toggle these...
(TRACE-LISP
 (DEFINE INSTANCE-OF-IS-NONFLUENT NIL
  (trace-defun 'INSTANCE-OF-IS-NONFLUENT NIL
   (RET
    (TRACE-PROGN (KM-SETQ '*INSTANCE-OF-IS-FLUENT* NIL) (KM-SETQ '*BUILT-IN-INERTIAL-FLUENT-SLOTS* *DEFAULT-BUILT-IN-INERTIAL-FLUENT-SLOTS*)
     (KM-SETQ '*BUILT-IN-NON-FLUENT-SLOTS*
      (SET-DIFFERENCE *BUILT-IN-SLOTS* (APPEND *BUILT-IN-INERTIAL-FLUENT-SLOTS* *BUILT-IN-NON-INERTIAL-FLUENT-SLOTS*))))))))
(TRACE-LISP
 (DEFINE INSTANCE-OF-IS-FLUENT NIL
  (trace-defun 'INSTANCE-OF-IS-FLUENT NIL
   (RET
    (TRACE-PROGN (KM-SETQ '*INSTANCE-OF-IS-FLUENT* T)
     (KM-SETQ '*BUILT-IN-INERTIAL-FLUENT-SLOTS* (APPEND *DEFAULT-BUILT-IN-INERTIAL-FLUENT-SLOTS* '(|instance-of| |instances|)))
     (KM-SETQ '*BUILT-IN-NON-FLUENT-SLOTS*
      (SET-DIFFERENCE *BUILT-IN-SLOTS* (APPEND *BUILT-IN-INERTIAL-FLUENT-SLOTS* *BUILT-IN-NON-INERTIAL-FLUENT-SLOTS*))))))))
;;;; ----------
;;;; For instances of these classes, KM *assumes* that the instances/instance-of relation will *not*
;;;; vary between situations, and thus will only read and write to the global situation.
;; NOTE: put in interpreter.lisp, so it can be loaded before use
;;(defparameter *built-in-classes-with-nonfluent-instances-relation* ';$(Situation Slot Theory Partition))
;;;; the rest are all non-fluents
;;;; EXPRESSIONLESS SLOTS:
;;;; The following slots can't have KM expressions as values, only
;;;; atomic values. This is because they are accessed by optimized access methods
;;;; (get-vals) which assume atomic values and make no attempt to 
;;;; evaluate any expressions found there. Also, their values are not unified together,
;;;; they are set unioned, which means that find-vals will encounter a list of values,
;;;; not a to-be-unifed value expression.
;;;; NOTE: KM doesn't actually make the test of built-in-atomic-vals-only -- rather the assumptions of expressionlessness
;;;; 	  are hard-wired into the code itself.
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-ATOMIC-VALS-ONLY-SLOTS* 
  '(|domain| |range| |cardinality| #|complete|# |arity| |slots-to-opportunistically-evaluate| |inverse| |inverse2| |inverse3| |inherit-with-overrides|
    |superclasses| |subclasses| |instances| |instance-of| |supersituations| |members| |member-of| |cloned-from| |has-clones| |domain-of| |range-of|
    |remove-subsumers| |remove-subsumees| |subsituations| |subslots| |superslots| |id| |combine-values-by-appending| |dont-cache-values|
    |ignore-inverses| |fluent-status| |called| |uniquely-called| |block-projection-for| |prototypes| |prototypes-of| |prototype-participants|
    |prototype-participants-of| |assertions|)))
;;;; (every f has (s (v))), (every f has (s (v'))) -> (every f has (s (v v'))) NOT (every f has (s ((v) && (v'))))
;;;; Also - all INVERSE assertions are automatically by appending; sigh and urgh!
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-COMBINE-VALUES-BY-APPENDING-SLOTS*
  (APPEND '(> < /== == |add-list| |del-list| |pcs-list| |ncs-list| |prototype-scope|) *BUILT-IN-ATOMIC-VALS-ONLY-SLOTS*)))
;;;; REMOVE-SUBSUMERS-SLOTS:
;;;; These slots have classes as their values. For these slots, KM considers any subsuming values to
;;;; be redundant and remove them, eg. (Car Vehicle) -> (Car).
(TRACE-LISP (DEFPARAMETER *BUILT-IN-REMOVE-SUBSUMERS-SLOTS* '(|instance-of| |superclasses| |member-type|)))
;;;; REMOVE-SUBSUMEES-SLOTS:
;;;; These slots have classes as their values. For these slots, KM considers any subsumed values to
;;;; be redundant and remove them, eg. (Car Vehicle) -> (Vehicle).
(TRACE-LISP (DEFPARAMETER *BUILT-IN-REMOVE-SUBSUMEES-SLOTS* '(|subclasses| |prototype-of| |domain| |range|)))
;; latter new (8/14/02)
;;;; These better be complete!
;;(defparameter *built-in-complete-slots* ';$(prev-situation next-situation)
;;(defparameter *built-in-situation-specific-slots* ';$(add-list del-list pcs-list ncs-list))
;;;; Only these built-in slots are allowed to have constraint expressions on them
(TRACE-LISP (DEFPARAMETER *BUILT-IN-SLOTS-WITH-CONSTRAINTS* '(|instance-of| == < > |called| |uniquely-called|)))
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-CLASSES*
  '(|Integer| |Number| |Thing| |Slot| |Aggregate| |Aggregation-Slot| |Seq-Aggregation-Slot| |Bag-Aggregation-Slot| |Set-Aggregation-Slot| |String|
    |Class| |Situation| |Boolean| |Partition| |Exhaustive-Partition| |Cardinality| |Fluent-Status| |Pair| |Triple| |Sequence| |Bag| |Theory|)))
;;;; Otherwise, the built-in class has superclasses Thing 
;;;; UNLESS it's a *built-in-classes-with-no-built-in-superclasses*, in which case we check in the user KB first <- Now defunct
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-SUPERCLASS-LINKS*
  '((|Integer| |Number|) (|Pair| |Sequence|) (|Triple| |Sequence|) (|Exhaustive-Partition| |Partition|) (|Set-Aggregation-Slot| |Aggregation-Slot|)
    (|Seq-Aggregation-Slot| |Aggregation-Slot|) (|Bag-Aggregation-Slot| |Aggregation-Slot|) (|Aggregation-Slot| |Slot|))))
;;;; User can specify superclasses for these built in classes. If none, it'll be Thing.
(TRACE-LISP (DEFPARAMETER *BUILT-IN-CLASSES-WITH-NO-BUILT-IN-SUPERCLASSES* '(|Aggregate|)))
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-INSTANCE-OF-LINKS* 
  `((|t| |Boolean|) (|f| |Boolean|) (|*Fluent| |Fluent-Status|) (|*Non-Fluent| |Fluent-Status|) (|*Inertial-Fluent| |Fluent-Status|)
    (,*GLOBAL-SITUATION* |Situation|))))
;;;; Make a fn to allow reference in an earlier file without problem
(TRACE-LISP (DEFINE BUILT-IN-INSTANCE-OF-LINKS NIL (trace-defun 'BUILT-IN-INSTANCE-OF-LINKS NIL (RET *BUILT-IN-INSTANCE-OF-LINKS*))))
(TRACE-LISP (DEFPARAMETER *VALID-FLUENT-STATUSES* '(|*Fluent| |*Inertial-Fluent| |*Non-Fluent|)))
(TRACE-LISP (DEFPARAMETER *BUILT-IN-INSTANCES* (APPEND *VALID-CARDINALITIES* *VALID-FLUENT-STATUSES* `(|t| |f| ,*GLOBAL-SITUATION*))))
(TRACE-LISP (DEFPARAMETER *BUILT-IN-FRAMES* (APPEND *BUILT-IN-SLOTS* *BUILT-IN-CLASSES* *BUILT-IN-INSTANCES*)))
;;;; don't track inverses of these slots:
;;;; [1] This is important, to stop the clone source being added to the object stack as a side-effect.
(TRACE-LISP
 (DEFPARAMETER *NON-INVERSE-RECORDING-SLOT* 
  '(|prototype-scope| |cardinality| |aggregation-function| #|complete|# |add-list| |del-list| |pcs-list| |ncs-list| #|cloned-from|# #|label|# 
    |inherit-with-overrides| #|duplicate-valued|# |called| |uniquely-called| |arity| |block-projection-for| |remove-subsumers| |remove-subsumees|
    |combine-values-by-appending| |dont-cache-values| |ignore-inverses| |name| == #|text print-name terms|#)))
;;;; no! inverse2 inverse3
;;;; eg. DON'T record inverses for boolean T/F, eg. (T has (open-of (Box1))
(TRACE-LISP (DEFPARAMETER *NON-INVERSE-RECORDING-CONCEPT* *BUILT-IN-INSTANCES*))
;;;; Return a string
(TRACE-LISP (DEFINE BUILT-IN-CONCEPT (CONCEPT) (trace-defun 'BUILT-IN-CONCEPT (CONCEPT) (RET (CL-MEMBER CONCEPT *BUILT-IN-FRAMES*)))))
(TRACE-LISP (DEFINE BUILT-IN-SLOT (SLOT) (trace-defun 'BUILT-IN-SLOT (SLOT) (RET (CL-MEMBER SLOT *BUILT-IN-SLOTS*)))))
(TRACE-LISP
 (DEFINE BUILT-IN-BAG-AGGREGATION-SLOT (SLOT)
  (trace-defun 'BUILT-IN-BAG-AGGREGATION-SLOT (SLOT) (RET (CL-MEMBER SLOT *BUILT-IN-BAG-AGGREGATION-SLOTS*)))))
(TRACE-LISP
 (DEFINE BUILT-IN-SEQ-AGGREGATION-SLOT (SLOT)
  (trace-defun 'BUILT-IN-SEQ-AGGREGATION-SLOT (SLOT) (RET (CL-MEMBER SLOT *BUILT-IN-SEQ-AGGREGATION-SLOTS*)))))
(TRACE-LISP
 (DEFINE BUILT-IN-SET-AGGREGATION-SLOT (SLOT)
  (trace-defun 'BUILT-IN-SET-AGGREGATION-SLOT (SLOT) (RET (CL-MEMBER SLOT *BUILT-IN-SET-AGGREGATION-SLOTS*)))))
(TRACE-LISP
 (DEFINE BUILT-IN-AGGREGATION-SLOT (SLOT) (trace-defun 'BUILT-IN-AGGREGATION-SLOT (SLOT) (RET (CL-MEMBER SLOT *BUILT-IN-AGGREGATION-SLOTS*)))))
(TRACE-LISP
 (DEFINE NON-INVERSE-RECORDING-SLOT (SLOT)
  (trace-defun 'NON-INVERSE-RECORDING-SLOT (SLOT)
   (RET (OR (CL-MEMBER SLOT *NON-INVERSE-RECORDING-SLOT*) (GET-VALS SLOT '|ignore-inverses| :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL))))))
(TRACE-LISP
 (DEFINE NON-INVERSE-RECORDING-CONCEPT (CONCEPT)
  (trace-defun 'NON-INVERSE-RECORDING-CONCEPT (CONCEPT) (RET (CL-MEMBER CONCEPT *NON-INVERSE-RECORDING-CONCEPT*)))))
(TRACE-LISP (DEFINE UNIVERSALP (SLOT) (trace-defun 'UNIVERSALP (SLOT) (RET (CL-MEMBER SLOT *BUILT-IN-NON-FLUENT-SLOTS*)))))
(TRACE-LISP
 (DEFINE BUILT-IN-CONCEPT-TYPE (CONCEPT)
  (trace-defun 'BUILT-IN-CONCEPT-TYPE (CONCEPT)
   (RET
    (COND ((CL-MEMBER CONCEPT *BUILT-IN-SINGLE-VALUED-SLOTS*) "single-valued slot") ((CL-MEMBER CONCEPT *BUILT-IN-MULTIVALUED-SLOTS*) "multivalued slot")
     ((CL-MEMBER CONCEPT *BUILT-IN-CLASSES*) "class") ((CL-MEMBER CONCEPT *BUILT-IN-INSTANCES*) "instance"))))))
(TRACE-LISP
 (DEFINE COMBINE-VALUES-BY-APPENDING-SLOTP (SLOT)
  (trace-defun 'COMBINE-VALUES-BY-APPENDING-SLOTP (SLOT)
   (RET
    (OR (CL-MEMBER SLOT *BUILT-IN-COMBINE-VALUES-BY-APPENDING-SLOTS*)
     (GET-VALS SLOT '|combine-values-by-appending| :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL))))))
(TRACE-LISP
 (DEFINE REMOVE-SUBSUMERS-SLOTP (SLOT)
  (trace-defun 'REMOVE-SUBSUMERS-SLOTP (SLOT)
   (RET (OR (CL-MEMBER SLOT *BUILT-IN-REMOVE-SUBSUMERS-SLOTS*) (GET-VALS SLOT '|remove-subsumers| :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL))))))
(TRACE-LISP
 (DEFINE DONT-CACHE-VALUES-SLOTP (SLOT)
  (trace-defun 'DONT-CACHE-VALUES-SLOTP (SLOT) (RET (GET-VALS SLOT '|dont-cache-values| :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL)))))
(TRACE-LISP
 (DEFINE REMOVE-SUBSUMEES-SLOTP (SLOT)
  (trace-defun 'REMOVE-SUBSUMEES-SLOTP (SLOT)
   (RET (OR (CL-MEMBER SLOT *BUILT-IN-REMOVE-SUBSUMEES-SLOTS*) (GET-VALS SLOT '|remove-subsumees| :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL))))))
;;;; ======================================================================
(TRACE-LISP (DEFPARAMETER *VAL-CONSTRAINT-KEYWORDS* '(|must-be-a| |mustnt-be-a| <> |possible-values| |excluded-values| |constraint| |no-inheritance|)))
(TRACE-LISP (DEFPARAMETER *SET-CONSTRAINT-KEYWORDS* '(|at-least| |at-most| |exactly| |set-constraint| |sometimes| |set-filter|)))
(TRACE-LISP (DEFPARAMETER *CONSTRAINT-KEYWORDS* (APPEND *VAL-CONSTRAINT-KEYWORDS* *SET-CONSTRAINT-KEYWORDS*)))
(TRACE-LISP (DEFPARAMETER *CONSTRAINT-SLOTS* '(== /== < >)))
;;;; ======================================================================
;;;; Situations
(TRACE-LISP (DEFVAR *CURR-SITUATION* *GLOBAL-SITUATION*))
;;;; ======================================================================
(TRACE-LISP (DEFVAR *CLASSIFICATION-ENABLED* T))
(TRACE-LISP (DEFVAR *PROTOTYPE-CLASSIFICATION-ENABLED* T))
;; i.e."triggers" in AURA
(TRACE-LISP (DEFVAR *CLASSIFICATION-DISABLED-TEMPORARILY* NIL))
;; reset to nil at each KM call, in case KM bombs when it's set to t
(TRACE-LISP (DEFVAR *INSTALLING-INVERSES-ENABLED* T))
(TRACE-LISP
 (DEFINE ENABLE-CLASSIFICATION NIL
  (trace-defun 'ENABLE-CLASSIFICATION NIL
   (RET (TRACE-PROGN (KM-SETQ '*CLASSIFICATION-ENABLED* T) (KM-SETQ '*PROTOTYPE-CLASSIFICATION-ENABLED* T))))))
(TRACE-LISP
 (DEFINE DISABLE-CLASSIFICATION NIL
  (trace-defun 'DISABLE-CLASSIFICATION NIL
   (RET (TRACE-PROGN (KM-SETQ '*CLASSIFICATION-ENABLED* NIL) (KM-SETQ '*PROTOTYPE-CLASSIFICATION-ENABLED* NIL))))))
(TRACE-LISP
 (DEFINE CLASSIFICATION-ENABLED NIL
  (trace-defun 'CLASSIFICATION-ENABLED NIL (RET (AND *CLASSIFICATION-ENABLED* (CNOT *CLASSIFICATION-DISABLED-TEMPORARILY*))))))
(TRACE-LISP
 (DEFINE TEMPORARILY-DISABLE-CLASSIFICATION NIL
  (trace-defun 'TEMPORARILY-DISABLE-CLASSIFICATION NIL (RET (KM-SETQ '*CLASSIFICATION-DISABLED-TEMPORARILY* T)))))
(TRACE-LISP
 (DEFINE REMOVE-TEMPORARY-DISABLEMENT-OF-CLASSIFICATION NIL
  (trace-defun 'REMOVE-TEMPORARY-DISABLEMENT-OF-CLASSIFICATION NIL (RET (KM-SETQ '*CLASSIFICATION-DISABLED-TEMPORARILY* NIL)))))
(TRACE-LISP
 (DEFINE ENABLE-INSTALLING-INVERSES NIL
  (trace-defun 'ENABLE-INSTALLING-INVERSES NIL (RET (COND ((CNOT *INSTALLING-INVERSES-ENABLED*) (CSETQ *INSTALLING-INVERSES-ENABLED* T)))))))
(TRACE-LISP
 (DEFINE DISABLE-INSTALLING-INVERSES NIL (trace-defun 'DISABLE-INSTALLING-INVERSES NIL (RET (CSETQ *INSTALLING-INVERSES-ENABLED* NIL)))))
;;;; ======================================================================
;; (defvar *slot-checking-enabled* nil)	 ; in header.lisp
(TRACE-LISP
 (DEFINE ENABLE-SLOT-CHECKING NIL
  (trace-defun 'ENABLE-SLOT-CHECKING NIL
   (RET (TRACE-PROGN (KM-FORMAT T "(Run-time checking of slot domain/range constraints enabled)~%") (KM-SETQ '*SLOT-CHECKING-ENABLED* T) T)))))
(TRACE-LISP
 (DEFINE DISABLE-SLOT-CHECKING NIL
  (trace-defun 'DISABLE-SLOT-CHECKING NIL
   (RET
    (TRACE-PROGN
     (COND ((CNOT *SLOT-CHECKING-ENABLED*) (KM-FORMAT T "(Run-time checking of slot domain/range constraints already disabled)~%"))
      (T (KM-FORMAT T "(Run-time checking of slot domain/range constraints disabled)~%") (KM-SETQ '*SLOT-CHECKING-ENABLED* NIL)))
     T)))))
;;;; ======================================================================
;;;; Format ((<slot> <subslot-list>) (<slot> <subslot-list>) .... )
(TRACE-LISP (DEFCONSTANT *BUILT-IN-SUBSLOTS* NIL))
;; if change this, the EDIT immediate-subslots, immediate-superslots too!
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-INVERSES*
  '((|inverse| |inverse|)  (|inverse2| |inverse2|) (|inverse3| |inverse3|) (|instances| |instance-of|) (|instance-of| |instances|)
    (|subslots| |superslots|) (|superslots| |subslots|) (|subclasses| |superclasses|) (|superclasses| |subclasses|) (|supersituations| |subsituations|)
    (|subsituations| |supersituations|) (|prototypes| |prototype-of|) (|prototype-of| |prototypes|) (|members| |member-of|) (|member-of| |members|)
    (|prototype-participants| |prototype-participant-of|) (|prototype-participant-of| |prototype-participants|) (|next-situation| |prev-situation|)
    (|prev-situation| |next-situation|) (|cloned-from| |has-clones|)   (/== /==))))
;; new 10/3/00
(TRACE-LISP
 (DEFPARAMETER *BUILT-IN-INVERSE2S*
  '((|next-situation| |after-situation|)  (|after-situation| |next-situation|) (|prev-situation| |before-situation|) 
    (|before-situation| |prev-situation|))))
;;;; ======================================================================
;;;;			COREFERENTIALITY
;;;; ======================================================================
#|Some frames are, in fact, typed variables. They are denoted by having
a name which begins with "_", eg _person34 is a "variable frame" of type 
person. Variable frames can be bound to other frames. The unifier
(km/lazy-unify.lisp) is the thing which does the unifying.|#
;;;; bind: RESULT is irrelevant, only the side-effect is important.
;;;; [1] - check to prevent circular bindings
;;;; NOTE: frame2 is considered the result of the binding.
;;(defun bind (frame1 frame2) 
;;  (cond ((neq (dereference frame1) (dereference frame2))	; [1]
;;	 (km-setf frame1 'binding frame2)
;;	 (merge-cached-explanations frame1 frame2)
;;	 (merge-explanations frame1 frame2))))
;;;; REVISED To (optionally) allow ununification
(TRACE-LISP (DEFPARAMETER *ALLOW-UNUNIFY* NIL))
;;;; Actually, we only need to cache old2-slotsvals for where there's an old1-slotsvals.
;;;; Modified KM procedure.
;;;; NOTE: ununify is not designed to handle things like (bind _Thing1 (:seq 1 2 3)) 
;;;; (e.g., what would the ununify call look like in the first place?)
;;;; See km-notes/ununify-notes.txt for more info
(TRACE-LISP
 (DEFINE BIND (FRAME1 FRAME2)
  (trace-defun 'BIND (FRAME1 FRAME2)
   (RET
    (COND
     ((NEQ (DEREFERENCE FRAME1) (DEREFERENCE FRAME2)) 
      (COND
       ((AND *ALLOW-UNUNIFY* (KB-OBJECTP FRAME2))
        (CLET
         ((SITUATIONS (ALL-ACTIVE-SITUATIONS))
          (S+OLD2S
           (CL-REMOVE NIL
            (MAPCAR
             #'(LAMBDA (SITUATION)
                (trace-defun '#:G15612 (SITUATION)
                 (RET (CLET ((OLD2-SLOTSVALS (GET-SLOTSVALS FRAME2 :SITUATION SITUATION))) (COND (OLD2-SLOTSVALS (LIST SITUATION OLD2-SLOTSVALS)))))))
             SITUATIONS)))
          (OLD-UNUNIFY-DATA (GET FRAME2 'UNUNIFY-DATA)))
         (KM-SETF FRAME2 'UNUNIFY-DATA (CONS (LIST FRAME1 S+OLD2S) OLD-UNUNIFY-DATA)))))
      (KM-SETF FRAME1 'BINDING FRAME2) (MERGE-CACHED-EXPLANATIONS FRAME1 FRAME2) (MERGE-EXPLANATIONS FRAME1 FRAME2)))))))
(TRACE-LISP (DEFINE GET-BINDING (FRAME) (trace-defun 'GET-BINDING (FRAME) (RET (GET FRAME 'BINDING)))))
(TRACE-LISP (DEFINE BOUND (FRAME1) (trace-defun 'BOUND (FRAME1) (RET (GET FRAME1 'BINDING)))))
;;;; ----------
;;;; This version is marginally slower on small dbs, marginally faster on large ones, but does less cons'ing (better memory)
;;;; [1] frame may be a structure (eg. (:triple a b c), (x <- y), '(the size of _Situation23)) as well as an atom, hence recurse
(TRACE-LISP
 (DEFINE DEREFERENCE (FRAME) (trace-defun 'DEREFERENCE (FRAME) (RET (COND ((NEEDS-DEREFERENCING FRAME) (DEREFERENCE0 FRAME)) (T FRAME))))))
(TRACE-LISP
 (DEFINE DEREFERENCE0 (FRAME)
  (trace-defun 'DEREFERENCE0 (FRAME)
   (RET
    (COND ((SYMBOLP FRAME) (CLET ((BINDING (GET-BINDING FRAME))) (COND (BINDING (DEREFERENCE0 BINDING)) (T FRAME))))
     ((LISTP FRAME)  (MAPCAR #'DEREFERENCE0 FRAME)) (T FRAME))))))
(TRACE-LISP
 (DEFINE NEEDS-DEREFERENCING (FRAME)
  (trace-defun 'NEEDS-DEREFERENCING (FRAME)
   (RET (COND ((SYMBOLP FRAME) (GET-BINDING FRAME)) ((LISTP FRAME) (SOME #'NEEDS-DEREFERENCING FRAME)))))))
;;;; ----------
(TRACE-LISP
 (DEFINE SHOW-BINDINGS NIL (trace-defun 'SHOW-BINDINGS NIL (RET (TRACE-PROGN (MAPCAR #'SHOW-BINDING (GET-ALL-CONCEPTS)) (TERPRI) T)))))
(TRACE-LISP
 (DEFINE UNBIND NIL
  (trace-defun 'UNBIND NIL
   (RET (TRACE-PROGN (MAPCAR #'(LAMBDA (FRAME) (trace-defun '#:G15613 (FRAME) (RET (BIND FRAME NIL)))) (GET-ALL-CONCEPTS)) T)))))
(TRACE-LISP
 (DEFINE SHOW-BINDING (FRAME)
  (trace-defun 'SHOW-BINDING (FRAME) (RET (COND ((GET FRAME 'BINDING) (TERPRI) (KM-FORMAT T "~a" FRAME) (SHOW-BINDING0 (GET-BINDING FRAME))))))))
(TRACE-LISP
 (DEFINE SHOW-BINDING0 (FRAME)
  (trace-defun 'SHOW-BINDING0 (FRAME)
   (RET (COND (FRAME (KM-FORMAT T " -> ~a" FRAME) (COND ((SYMBOLP FRAME) (SHOW-BINDING0 (GET-BINDING FRAME))))))))))
;;;; ---------- UNUNIFICATION ---------- (new)
;;;; Test
(TRACE-LISP (DEFINE UNUNIFIABLE (FRAME2) (trace-defun 'UNUNIFIABLE (FRAME2) (RET (GET FRAME2 'UNUNIFY-DATA)))))
(TRACE-LISP
 (DEFINE UNUNIFY (FRAME2)
  (trace-defun 'UNUNIFY (FRAME2)
   (RET
    (CLET
     ((UNUNIFY-DATA (GET FRAME2 'UNUNIFY-DATA)) (CURR-SITUATION (CURR-SITUATION)) (F1+S-OLD2S (FIRST UNUNIFY-DATA)) (FRAME1 (FIRST F1+S-OLD2S))
      (S+OLD2S (SECOND F1+S-OLD2S)))
     (COND ((CNOT *ALLOW-UNUNIFY*) (MAKE-COMMENT "(ununify ~a): Ununification is turned off -- do (setq *allow-unify* t) to enable it.~%" FRAME2))
      ((NEQ FRAME2 (DEREFERENCE FRAME2)) (MAKE-COMMENT "~a doesn't exist any more - it become ~a through unification" FRAME2 (DEREFERENCE FRAME2)))
      ((NULL UNUNIFY-DATA) (MAKE-COMMENT "~a: No bindings left to ununify" FRAME2))
      (T (BIND FRAME1 NIL) 
       (CLET ((S+OLD2S-DEREF (DEREFERENCE S+OLD2S))) 
        (MAPC
         #'(LAMBDA (SITUATION)
            (trace-defun '#:G15614 (SITUATION)
             (RET
              (CLET
               ((S+OLD2 (ASSOC SITUATION S+OLD2S-DEREF)) (OLD1-SLOTSVALS (GET-SLOTSVALS FRAME1 :SITUATION SITUATION)) (OLD2-SLOTSVALS (SECOND S+OLD2))) 
               (COND
                (OLD1-SLOTSVALS (IN-SITUATION SITUATION) 
                 (MAPC
                  #'(LAMBDA (OLD1-SLOTVALS)
                     (trace-defun '#:G15615 (OLD1-SLOTVALS)
                      (RET
                       (CLET
                        ((SLOT (SLOT-IN OLD1-SLOTVALS)) (OLD2-SLOTVALS (ASSOC SLOT OLD2-SLOTSVALS)) (OLD1-VALS (KM-FLATTEN (VALS-IN OLD1-SLOTVALS)))
                         (OLD2-VALS (KM-FLATTEN (VALS-IN OLD2-SLOTVALS)))
                         (OLD1-ONLY-VALS
                          (REMOVE-IF-NOT
                           #'(LAMBDA (OLD1-VAL)
                              (trace-defun '#:G15616 (OLD1-VAL) (RET (AND (KB-OBJECTP OLD1-VAL) (CNOT (CL-MEMBER OLD1-VAL OLD2-VALS))))))
                           OLD1-VALS)))
                           
                        (MAPC #'(LAMBDA (OLD1-VAL) (trace-defun '#:G15617 (OLD1-VAL) (RET (DELETE-VAL FRAME2 SLOT OLD1-VAL)))) OLD1-ONLY-VALS) 
                        (INSTALL-INVERSES FRAME1 SLOT OLD1-VALS)))))
                  OLD1-SLOTSVALS)))))))
         (ALL-ACTIVE-SITUATIONS)))
       (KM-SETF FRAME2 'UNUNIFY-DATA (REST UNUNIFY-DATA)) (CHANGE-TO-SITUATION CURR-SITUATION)  T)))))))
;;;; Flattens any & and && structures
(TRACE-LISP (DEFINE KM-FLATTEN (VALS) (trace-defun 'KM-FLATTEN (VALS) (RET (FIND-EXPRS VALS :EXPR-TYPE 'NON-CONSTRAINT :PLURALITY 'PLURAL)))))
;;;; ======================================================================
;;;;		FRAME STRUCTURES (as defined in KM)
;;;; ======================================================================
;;;; A frame structure is the basic data structure which KM stores/retrieves
;;;; (using getobj/putobj, defined in km/myload.lisp). The data structures
;;;; are stored using LISP property lists, in the LISP property list DB.
;;;;
;;;;  SYMBOL   PROPERTY		VALUE (the slotsvals)
;;;;	car   own-properties	( (color (*red)) (wheels (4)) )
(TRACE-LISP (DEFINE SLOT-IN (SLOTVALS) (trace-defun 'SLOT-IN (SLOTVALS) (RET (FIRST SLOTVALS)))))
(TRACE-LISP
 (DEFINE VALS-IN (SLOTVALS)
  (trace-defun 'VALS-IN (SLOTVALS)
   (RET
    (COND ((LISTP (SECOND SLOTVALS)) (SECOND SLOTVALS))
     (T
      (REPORT-ERROR 'USER-ERROR
       "Somewhere in the KB, the slot `~a' was given a single value `~a'
rather than a list of values! (Missing parentheses?)~%"
       (FIRST SLOTVALS) (SECOND SLOTVALS))))))))
(TRACE-LISP (DEFINE MAKE-SLOTVALS (SLOT VALS) (trace-defun 'MAKE-SLOTVALS (SLOT VALS) (RET (LIST SLOT VALS)))))
(TRACE-LISP
 (DEFINE ARE-SLOTSVALS (SLOTSVALS)
  (trace-defun 'ARE-SLOTSVALS (SLOTSVALS)
   (RET
    (COND
     ((CNOT (LISTP SLOTSVALS))
      (REPORT-ERROR 'USER-ERROR "Bad structure ~a for list of slot-values!~%Should be of form (s1 (v1 ... vn)) (s2 (...)) ...)~%" SLOTSVALS))
     (T
      (EVERY
       #'(LAMBDA (SLOTVALS)
          (trace-defun '#:G15618 (SLOTVALS)
           (RET
            (COND
             ((CNOT (PAIRP SLOTVALS))
              (REPORT-ERROR 'USER-ERROR "Bad structure ~a for list of slot-values!~%Slot+values ~a should be a of the form (slot (v1 ... vn))~%"
               SLOTSVALS SLOTVALS))
             ((CNOT (SYMBOLP (SLOT-IN SLOTVALS)))
              (REPORT-ERROR 'USER-ERROR "Bad structure ~a for list of slot-values!~%Slot `~a' should be a symbol!~%" SLOTSVALS (SLOT-IN SLOTVALS)))
             ((CNOT (LISTP (SECOND SLOTVALS)))
              (REPORT-ERROR 'USER-ERROR "Bad structure ~a for list of slot-values!~%Values ~a for slot ~a should be a list!~%" SLOTSVALS
               (SECOND SLOTVALS) (SLOT-IN SLOTVALS)))
             ((CL-MEMBER (SLOT-IN SLOTVALS) *RESERVED-KEYWORDS*)
              (REPORT-ERROR 'USER-ERROR
               "Bad structure ~a for list of slot-values!~%The slot `~a' is a reserved KM keyword, and cannot be used as a slot name!~%" SLOTSVALS
               (SLOT-IN SLOTVALS)))
             ((NO-RESERVED-KEYWORDS (VALS-IN SLOTVALS)) 
              (COND
               ((OR
                 (SOME #'(LAMBDA (VAL) (trace-defun '#:G15619 (VAL) (RET (AND (LISTP VAL) (CL-MEMBER (FIRST VAL) *CONSTRAINT-KEYWORDS*)))))
                  (VALS-IN SLOTVALS))
                 (CL-MEMBER (SLOT-IN SLOTVALS) *CONSTRAINT-SLOTS*))
                (NOTE-ARE-CONSTRAINTS)))
              (COND ((SOME #'KM-DEFAULTP (VALS-IN SLOTVALS)) (KM-SETQ '*ARE-SOME-DEFAULTS* T)))
              (COND ((CL-MEMBER (SLOT-IN SLOTVALS) '(|called|)) (KM-SETQ '*ARE-SOME-TAGS* T)))
              (COND ((CL-MEMBER (SLOT-IN SLOTVALS) '(|uniquely-called|)) (KM-SETQ '*ARE-SOME-TAGS* T) (KM-SETQ '*ARE-SOME-CONSTRAINTS* T))) 
              (COND ((CL-MEMBER (SLOT-IN SLOTVALS) '(|subslots| |superslots|)) (KM-SETQ '*ARE-SOME-SUBSLOTS* T))) 
              (COND ((EQ (SLOT-IN SLOTVALS) '|prototype-of|) (KM-SETQ '*ARE-SOME-PROTOTYPES* T))) T)))))
       SLOTSVALS)))))))
;;;; ======================================================================
;;;; 		KB SET UTILITIES
;;;; Below is the only bit of code which defines the internal storage
;;;; of the KB -- for now, it's (setf <frame> 'kb <alist>).
;;;; ======================================================================
#|USED BY THESE FUNCTIONS
 - a-prototype ?class X$with &rest	   simple update of X$prototype-participants slot
 - create-named-instance 		   add-val newframe X$prototype-participant-of (curr-prototype)
 - try-classifying		           add-val instance 'X$instance-of `(<> ,possible-new-parent) ; add constraint, to prevent further retries
 - install-inverses0			   install inverse
 - clean-taxonomy		   put subclasses link back
 - enforce-val-constraint		   add-val val '/== excluded-value) for excluded values
 - unify-in-prototype			   add-val instance 'X$cloned-from prototype
 - clone0				   add-val instance 'X$cloned-from prototype|#
;;;; RETURNS: irrelevant and discarded
(TRACE-LISP
 (DEFINE ADD-VALS (INSTANCE SLOT VALS &OPTIONAL INSTALL-INVERSESP SITUATION)
  (trace-defun 'ADD-VALS (INSTANCE SLOT VALS INSTALL-INVERSESP SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION)) (SUBLISP-INITVAR INSTALL-INVERSESP T)
     (MAPC #'(LAMBDA (VAL) (trace-defun '#:G15620 (VAL) (RET (ADD-VAL INSTANCE SLOT VAL INSTALL-INVERSESP SITUATION)))) VALS))))))
;;;; add-val: add a value to a instance's slot. 
;;;; EXCEPT NB new value is simply added, not unified
;;;;   [Reason: Don't want *red:: color-of: ((_car1) && (_car2) && (_car3))]
;;;; [1] Unfortunately this won't catch all redundancies. Consider:
;;;;     Suppose I say x isa y1, then x is a y2, then y1 is a y2.
;;;;     The redundancy in x's superclasses won't be spotted. Soln = call (clean-taxonomy)
;;;;	to recompute the taxonomy without redundancy.
;;;; RETURNS: irrelevant and discarded
;;;; [2] remove-dup-instances very expensive if lots of oldvals, and also redundant as it's done again during retrieval
(TRACE-LISP
 (DEFINE ADD-VAL (INSTANCE SLOT VAL &OPTIONAL INSTALL-INVERSESP SITUATION)
  (trace-defun 'ADD-VAL (INSTANCE SLOT VAL INSTALL-INVERSESP SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION)) (SUBLISP-INITVAR INSTALL-INVERSESP T)
     (CLET ((OLDVALS1 (GET-VALS INSTANCE SLOT :SITUATION SITUATION))   (OLDVALS (COND ((SINGLE-VALUED-SLOTP SLOT) (UN-ANDIFY OLDVALS1)) (T OLDVALS1)))) 
      (COND
       ((NULL OLDVALS) (UN-DONE INSTANCE :SLOT SLOT :SITUATION SITUATION) 
        (PUT-VALS INSTANCE SLOT (LIST VAL) :INSTALL-INVERSESP INSTALL-INVERSESP :SITUATION SITUATION))
       ((CL-MEMBER VAL OLDVALS :TEST #'CL-EQUAL)) 
       ((SINGLE-VALUED-SLOTP SLOT) (UN-DONE INSTANCE :SLOT SLOT :SITUATION SITUATION) 
        (PUT-VALS INSTANCE SLOT (VAL-TO-VALS (VALS-TO-&-EXPR (APPEND OLDVALS (LIST VAL)))) :INSTALL-INVERSESP NIL  :SITUATION SITUATION)
        (COND (INSTALL-INVERSESP (INSTALL-INVERSES INSTANCE SLOT (LIST VAL) SITUATION))))
       
       ((REMOVE-SUBSUMERS-SLOTP SLOT) 
        (COND ((SOME #'(LAMBDA (OLDVAL) (trace-defun '#:G15621 (OLDVAL) (RET (IS-SUBCLASS-OF OLDVAL VAL)))) OLDVALS)) 
         (T #|NEW|# (UN-DONE INSTANCE :SLOT SLOT :SITUATION SITUATION)
          (PUT-VALS INSTANCE SLOT  #|NEW|# (CONS VAL (REMOVE-IF #'(LAMBDA (OLDVAL) (IS-SUBCLASS-OF VAL OLDVAL)) OLDVALS)) :INSTALL-INVERSESP
           INSTALL-INVERSESP :SITUATION SITUATION))))
       ((REMOVE-SUBSUMEES-SLOTP SLOT) 
        (COND ((SOME #'(LAMBDA (OLDVAL) (trace-defun '#:G15622 (OLDVAL) (RET (IS-SUBCLASS-OF VAL OLDVAL)))) OLDVALS)) 
         (T #|NEW|# (UN-DONE INSTANCE :SLOT SLOT :SITUATION SITUATION)
          (PUT-VALS INSTANCE SLOT  #|NEW|# (CONS VAL (REMOVE-IF #'(LAMBDA (OLDVAL) (IS-SUBCLASS-OF OLDVAL VAL)) OLDVALS)) :INSTALL-INVERSESP
           INSTALL-INVERSESP :SITUATION SITUATION))))
       ((&&-EXPRP OLDVALS)
        (CLET ((VALSETS (&&-EXPRS-TO-VALSETS OLDVALS)))
         (COND ((SOME #'(LAMBDA (VALSET) (trace-defun '#:G15623 (VALSET) (RET (CL-MEMBER VAL VALSET :TEST #'CL-EQUAL)))) VALSETS)) 
          (T (UN-DONE INSTANCE :SLOT SLOT :SITUATION SITUATION)
           (CLET ((NEW-VALSETS (VALSETS-TO-&&-EXPRS (APPEND (BUTLAST VALSETS) (LIST (APPEND (LAST-EL VALSETS) (LIST VAL)))))))
            (PUT-VALS INSTANCE SLOT NEW-VALSETS :INSTALL-INVERSESP INSTALL-INVERSESP :SITUATION SITUATION))))))
       (T (PUT-VALS INSTANCE SLOT (APPEND OLDVALS (LIST VAL)) :INSTALL-INVERSESP INSTALL-INVERSESP :SITUATION SITUATION)))))))))
;; preserve order (nicer)
;;;; ======================================================================
;;;; (put-vals instance slot vals [&key facet install-inversesp situation])
;;;; ======================================================================
#| USES OF put-vals:
frame-io.lisp:
 1. add-val - adding a value into a list of values/expressions.
 2. put-slotsvals: does (mapc X'put-vals slotsvals)
 3. delete-slot: (put-vals frame slot nil)
 4. delete-val: (not used in main KM)
 5. add-slotsvals
[ 6. add-immediate-class (after classification is done) - adds the recomputed classes. Later: changed to be add-vals ]
 7. immediate-classes: after computing new superclasses, put the *result* back in
 8. immediate-classes0: after doing projection. This is followed by a note-done
 9. prev-situation: store previous situation
10. before-situation: similar
11. uninstall-inverses
12. eval-constraints (as part of eval-instances)
13. remove-redundant-superclasses (part of install-subclasses)

interpreter.lisp:
 1. after looping, if expression is a (the x of y) then do a get-vals (rather than get-slotvals-from-kb), evaluate the result, and put-vals it back.
 2. if slot - name, then compute the name (using (name frame)) and cache the name using put-vals.

get-slotvals.lisp:
 1. for the intermediate save
 2. for recursive rulesets
 3. after you're finally done. note-done follows.

lazy-unify.lisp:
 1. if you compute values on a slot, then put the results back on the slot. Note this may clobber rules previously on the slot. Hmm...
 2. unify-with-slotsvals2, called by unify-with-existential-expression: putting the results of unification back into the KB

Now: which ones of these might result in an own-rule in the global situation being clobbered?|#
;;;; IF vals is nil, this will delete a slot (and its value) from a instance. Doesn't remove inverse links or
;;;; scan through situations. NOTE: vals can validly be NIL, in the case where (i) lazy-unify may put a *path* 
;;;; on an instance's slot, then (ii) it later is evaluated to NIL. So in that case, a put-vals with NIL will 
;;;; remove that cached path.
;;;; This DOESN'T require that the right situation has been identified, here the determination of target-situation is done WITHIN this procedure
(TRACE-LISP
 (DEFINE PUT-VALS (INSTANCE SLOT VALS &REST LKEYS)
  (trace-defun 'PUT-VALS (INSTANCE SLOT VALS LKEYS)
   (RET
    (CLET (FACET INSTALL-INVERSESP SITUATION) (init-keyval SITUATION (CURR-SITUATION)) (init-keyval INSTALL-INVERSESP T) (init-keyval FACET 'OWN-PROPERTIES)   
     (COND (*SLOT-CHECKING-ENABLED* (CHECK-DOMAIN-AND-RANGE INSTANCE SLOT VALS)))
     (COND
      ((CL-MEMBER INSTANCE *RESERVED-KEYWORDS*)
       (REPORT-ERROR 'USER-ERROR "Attempt to use keyword `~a' as the name of a frame/slot (not allowed!)~% Doing (~a has (~a ~a))~%" INSTANCE INSTANCE
        SLOT VALS))
      ((CNOT (KB-OBJECTP INSTANCE))
       (REPORT-ERROR 'PROGRAM-ERROR "Attempting to assert information on a non-kb-object ~a...~%Ignoring the slot-vals (~a ~a)~%" INSTANCE SLOT VALS))
      ((EQ SLOT '|complete|) 
       (REPORT-ERROR 'USER-ERROR
        "KM 1.4.0-beta36 and later: The `complete' slot has been renamed - you should change your KB as follows:~%       `(<slot> has (complete (t)))' should be replaced with `(<slot> has (fluent-status (*Fluent)))'!"))
      (T
       (COND
        ((CNOT (CL-ISA SLOT '|Slot|))  (ADD-VAL SLOT '|instance-of| '|Slot| T *GLOBAL-SITUATION*) 
         (COND ((CL-STARTS-WITH (SYMBOL-NAME SLOT) "some-associated-") (ADD-VAL SLOT '|fluent-status| '|*Non-Fluent| T *GLOBAL-SITUATION*)))))
       
       (CLET
        ((TARGET-SITUATION (TARGET-SITUATION SITUATION INSTANCE SLOT VALS)) 
         (OLD-SLOTSVALS (GET-SLOTSVALS INSTANCE :FACET FACET :SITUATION TARGET-SITUATION)) (OLD-VALS (VALS-IN (ASSOC SLOT OLD-SLOTSVALS))))
        (COND ((CL-EQUAL VALS OLD-VALS) VALS)
         (T
          (CLET ((PUTOBJ-FACET (CURR-SITUATION-FACET FACET TARGET-SITUATION))) (COND ((CNOT (KNOWN-FRAME INSTANCE)) (ADD-TO-STACK INSTANCE))) 
           (COND ((NULL VALS) (PUTOBJ INSTANCE (REMOVE-ASSOC-ENTRY SLOT OLD-SLOTSVALS) PUTOBJ-FACET))
            (T (PUTOBJ INSTANCE (UPDATE-ASSOC-LIST OLD-SLOTSVALS (MAKE-SLOTVALS SLOT VALS)) PUTOBJ-FACET)
             (COND
              ((AND (CL-MEMBER FACET '(OWN-DEFINITION OWN-PROPERTIES)) INSTALL-INVERSESP)
               (INSTALL-INVERSES INSTANCE SLOT (SET-DIFFERENCE VALS OLD-VALS) TARGET-SITUATION)))
               ))))))))
     INSTANCE)))))
;;;; This function now ONLY ever used by lazy-unify.lisp
(TRACE-LISP
 (DEFINE PUT-SLOTSVALS (FRAME SLOTSVALS &REST LKEYS)
  (trace-defun 'PUT-SLOTSVALS (FRAME SLOTSVALS LKEYS)
   (RET
    (CLET (FACET SITUATION INSTALL-INVERSESP) (init-keyval INSTALL-INVERSESP T) (init-keyval SITUATION (CURR-SITUATION)) (init-keyval FACET 'OWN-PROPERTIES)
     (MAPC
      #'(LAMBDA (SLOTVALS)
         (trace-defun '#:G15624 (SLOTVALS)
          (RET (PUT-VALS FRAME (SLOT-IN SLOTVALS) (VALS-IN SLOTVALS) :FACET FACET :INSTALL-INVERSESP INSTALL-INVERSESP :SITUATION SITUATION))))
      (REORDER-SLOTSVALS SLOTSVALS))
       FRAME)))))
;;;; Reorder the slotsvals, to make sure instance-of links are FIRST. This is important so that the domain/range checking knows the
;;;; correct instance-of links *before* the checking is done!
(TRACE-LISP
 (DEFINE REORDER-SLOTSVALS (SLOTSVALS)
  (trace-defun 'REORDER-SLOTSVALS (SLOTSVALS)
   (RET
    (CLET ((INSTANCE-OF-SLOTVALS (ASSOC '|instance-of| SLOTSVALS)))
     (COND (INSTANCE-OF-SLOTVALS (CONS INSTANCE-OF-SLOTVALS (REMOVE-IF #'(LAMBDA (SLOTVALS) (EQ (SLOT-IN SLOTVALS) '|instance-of|)) SLOTSVALS)))
      (T SLOTSVALS)))))))
;;;; --------------------
(TRACE-LISP
 (DEFINE DELETE-SLOT (INSTANCE SLOT &OPTIONAL FACET SITUATION)
  (trace-defun 'DELETE-SLOT (INSTANCE SLOT FACET SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION)) (SUBLISP-INITVAR FACET 'OWN-PROPERTIES)
     (PUT-VALS INSTANCE SLOT NIL :INSTALL-INVERSESP NIL :FACET FACET :SITUATION SITUATION))))))
;;;; ONLY used by KM itself to remove redundant superclasses, nowhere else
(TRACE-LISP
 (DEFINE DELETE-VAL (INSTANCE SLOT VAL &OPTIONAL UNINSTALL-INVERSESP SITUATION)
  (trace-defun 'DELETE-VAL (INSTANCE SLOT VAL UNINSTALL-INVERSESP SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (TARGET-SITUATION (CURR-SITUATION) INSTANCE SLOT)) (SUBLISP-INITVAR UNINSTALL-INVERSESP T)
     (CLET
      ((OLDVALS0 (GET-VALS INSTANCE SLOT :SITUATION SITUATION)) (OLDVALS1 (REMOVE-DUP-INSTANCES OLDVALS0)) 
       (OLDVALS (COND ((SINGLE-VALUED-SLOTP SLOT) (UN-ANDIFY OLDVALS1)) (T OLDVALS1))))
      (COND ((CNOT (CL-MEMBER VAL OLDVALS)) (KM-FORMAT T "Warning! Trying to delete non-existent value ~a on (the ~a of ~a)!~%" VAL SLOT INSTANCE))
       ((SINGLE-VALUED-SLOTP SLOT) (PUT-VALS INSTANCE SLOT (VALS-TO-&-EXPR (CL-REMOVE VAL OLDVALS)) :INSTALL-INVERSESP NIL :SITUATION SITUATION) 
        (COND (UNINSTALL-INVERSESP (UNINSTALL-INVERSES INSTANCE SLOT (LIST VAL) SITUATION)))  (UN-DONE INSTANCE :SITUATION SITUATION))
       
       (T (PUT-VALS INSTANCE SLOT (CL-REMOVE VAL OLDVALS) :INSTALL-INVERSESP NIL :SITUATION SITUATION)
        (COND (UNINSTALL-INVERSESP (UNINSTALL-INVERSES INSTANCE SLOT (LIST VAL) SITUATION)))))))))))
;; NOW do it manually for  new val
;;;; Simpler than delete-val above: just put a nil in for the to-be-deleted value. I *think* this is ok!
;;;; NOTE: This is NOT used anywhere in KM or outside, and so is not really tested.
(TRACE-LISP
 (DEFINE FAST-DELETE-VAL (INSTANCE SLOT VAL0 &OPTIONAL UNINSTALL-INVERSESP SITUATION)
  (trace-defun 'FAST-DELETE-VAL (INSTANCE SLOT VAL0 UNINSTALL-INVERSESP SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (TARGET-SITUATION (CURR-SITUATION) INSTANCE SLOT)) (SUBLISP-INITVAR UNINSTALL-INVERSESP T)
     (CLET ((VAL (DEREFERENCE VAL0)) (OLD-VALS (GET-VALS INSTANCE SLOT :SITUATION SITUATION)) (NEW-VALS (SUBST NIL VAL OLD-VALS)))
      (COND
       ((CNOT (CL-EQUAL NEW-VALS OLD-VALS)) (PUT-VALS INSTANCE SLOT NEW-VALS :INSTALL-INVERSESP NIL :SITUATION SITUATION)
        (COND (UNINSTALL-INVERSESP (UNINSTALL-INVERSE INSTANCE SLOT VAL SITUATION)))))))))))
;;;; Only used by fast-delete-val above
(TRACE-LISP
 (DEFINE UNINSTALL-INVERSE (FRAME SLOT VAL0 &OPTIONAL SITUATION)
  (trace-defun 'UNINSTALL-INVERSE (FRAME SLOT VAL0 SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (COND
      ((CNOT (NON-INVERSE-RECORDING-SLOT SLOT))
       (CLET ((INVSLOT (INVERT-SLOT SLOT)) (VAL (DEREFERENCE VAL0)))
        (COND
         ((AND (KB-OBJECTP VAL) (CNOT (NON-INVERSE-RECORDING-CONCEPT VAL))) 
          (CLET ((OLD-VALS (GET-VALS VAL INVSLOT :SITUATION SITUATION)) (NEW-VALS (SUBST NIL FRAME OLD-VALS)))
           (COND ((CNOT (CL-EQUAL NEW-VALS OLD-VALS)) (PUT-VALS VAL INVSLOT NEW-VALS :INSTALL-INVERSESP NIL :SITUATION SITUATION))))))))))))))
;;;; ----------------------------------------------------------------------
;;;;		IMPORTANT UTILITY
;;;; Want to find slot values in situation X? Get/Put from situation X'
;;;; ----------------------------------------------------------------------
#|--------------------
Known (but irrelevant) bug below:
KM> (instance-of-is-fluent)
[_Situation1] KM> (showme adf)
(adf has (instance-of (Slot)))
(in-situation _Situation1 (adf has (instance-of (Foo))))

KM> (the all-classes of adf)
(Thing Foo Slot)

KM> (showme adf)
(adf has (instance-of (Foo Slot)))	; Foo added in global!

(in-situation _Situation1 (adf has (instance-of (Foo))))

Because [1] we just need *one* val to be a *built-in-classes-with-nonfluent-instances-relation*, KM will
put *all* values up in global. (It'd be too complicated to put some values here, some elsewhere - the
extra effort is not worth solving this issue, only for the classes Slot, Partition, Theory, and Situation.)
--------------------|#
;;;; GIVEN: you're either putting frame slot vals, or getting from frame slot,
;;;; RETURN: the target situation to put/get vals to/from.
(TRACE-LISP
 (DEFINE TARGET-SITUATION (SITUATION INSTANCE SLOT &OPTIONAL VALS)
  (trace-defun 'TARGET-SITUATION (SITUATION INSTANCE SLOT VALS)
   (RET
    (COND ((EQ SITUATION *GLOBAL-SITUATION*) *GLOBAL-SITUATION*)  ((AND SLOT (UNIVERSALP SLOT)) *GLOBAL-SITUATION*) 
     ((AND SLOT (NOR (FLUENTP SLOT) (ISA-THEORY SITUATION))) *GLOBAL-SITUATION*) 
     ((AND (EQ SLOT '|instance-of|) 
       (SOME
        #'(LAMBDA (VAL)
           (trace-defun '#:G15625 (VAL)
            (RET
             (SOME #'(LAMBDA (CLASS) (trace-defun '#:G15626 (CLASS) (RET (IS-SUBCLASS-OF VAL CLASS)))) 
              *BUILT-IN-CLASSES-WITH-NONFLUENT-INSTANCES-RELATION*))))
         VALS))
      *GLOBAL-SITUATION*)
     ((AND (EQ SLOT '|instances|)
       (SOME #'(LAMBDA (CLASS) (trace-defun '#:G15627 (CLASS) (RET (IS-SUBCLASS-OF INSTANCE CLASS)))) 
        *BUILT-IN-CLASSES-WITH-NONFLUENT-INSTANCES-RELATION*))
       *GLOBAL-SITUATION*)
     (T SITUATION))))))
;;;; ======================================================================
;;;;		LOCAL ACCESS TO A SLOT'S VALUES
;;;; ======================================================================
;;;; This *doesn't* climb the supersituation hierarchy -- need to do this to stop looping
;;;; find-vals -> supersituation -> find-vals -> supersituation....
;;;; RETURNS A DEREFERENCED ANSWER (unless explicitly blocked from doing so)
;;;; NOTE: We assume a PREPROCESSOR has determined the right situation to get from, using a call to (target-situation situation frame slot)
;;;; [1] MODIFIED Feb04: add the target-situation finder here for the special case where situation is not specified
;; [1]  get-vals (frame slot &key (facet 'own-properties) (situation (curr-situation))                               (dereferencep t))
(TRACE-LISP
 (DEFINE GET-VALS (FRAME SLOT &REST LKEYS)
  (trace-defun 'GET-VALS (FRAME SLOT LKEYS)
   (RET
    (CLET (FACET SITUATION DEREFERENCEP) (init-keyval DEREFERENCEP T) (init-keyval SITUATION (TARGET-SITUATION (CURR-SITUATION) FRAME SLOT))
     (init-keyval FACET 'OWN-PROPERTIES)
     (COND
      ((AND (SYMBOLP SLOT)  (KB-OBJECTP FRAME))
       (COND (DEREFERENCEP (DEREFERENCE (VALS-IN (ASSOC SLOT (GET-SLOTSVALS FRAME :FACET FACET :SITUATION SITUATION :DEREFERENCEP NIL)))))
        (T (VALS-IN (ASSOC SLOT (GET-SLOTSVALS FRAME :FACET FACET :SITUATION SITUATION :DEREFERENCEP NIL))))))
      
      ((CNOT (SYMBOLP SLOT))
       (REPORT-ERROR 'USER-ERROR "Doing (the ~a of ~a) - the slot name `~a' should be a valid KB object (a non-keyword symbo)l!~%" SLOT FRAME SLOT))
      (T
       (REPORT-ERROR 'USER-ERROR "Doing (the ~a of ~a) - the frame name `~a' should be a valid KB object (a non-keyword symbol)!~%" SLOT FRAME
        FRAME))))))))
;;;; ----------
;; (defun get-unique-val (frame slot &key (facet 'own-properties) (situation (curr-situation)) (fail-mode 'fail))
(TRACE-LISP
 (DEFINE GET-UNIQUE-VAL (FRAME SLOT &REST LKEYS)
  (trace-defun 'GET-UNIQUE-VAL (FRAME SLOT LKEYS)
   (RET
    (CLET (FACET SITUATION FAIL-MODE) (init-keyval FAIL-MODE 'FAIL) (init-keyval SITUATION (TARGET-SITUATION (CURR-SITUATION) FRAME SLOT))
     (init-keyval FACET 'OWN-PROPERTIES)
     (CLET ((VALS (GET-VALS FRAME SLOT :FACET FACET :SITUATION SITUATION)))
      (COND ((SINGLETONP VALS) (FIRST VALS))
       (VALS
        (REPORT-ERROR 'USER-ERROR "(the ~a of ~a) should have at most one value,~%but it returned multiple values ~a!~%Just taking the first...(~a) ~%"
         SLOT FRAME VALS (FIRST VALS))
        (FIRST VALS))
       ((EQ FAIL-MODE 'ERROR) (REPORT-ERROR 'USER-ERROR "No value found for the ~a of ~a!~%" SLOT FRAME)))))))))
;;;; ----------
;;;; RETURNS A DEREFERENCED ANSWER (unless explicitly blocked from doing so)
(TRACE-LISP
 (DEFINE GET-SLOTSVALS (FRAME &REST LKEYS)
  (trace-defun 'GET-SLOTSVALS (FRAME LKEYS)
   (RET
    (CLET (FACET SITUATION DEREFERENCEP) (init-keyval DEREFERENCEP T) (init-keyval SITUATION (CURR-SITUATION)) (init-keyval FACET 'OWN-PROPERTIES)
     (COND (DEREFERENCEP (DEREFERENCE (GETOBJ FRAME (CURR-SITUATION-FACET FACET SITUATION))))
      (T (GETOBJ FRAME (CURR-SITUATION-FACET FACET SITUATION)))))))))
;;;; ----------------------------------------
;;;; NEW - same thing, but just deal with member properties. A "ruleset" is a list of expressions on 
;;;; some class's slot, which should be applied to instances of that class.
;;;; Here we collect both `assertional' and `definitional' rules; it'd be nice to ignore the definitional
;;;; rules, or just take them if no assertional rules, but that would be incomplete wrt. the intended
;;;; semantics.
;;;; We have to search in two dimensions: (1) up the isa hierarchy and (2) up the situation hierarchy.
#| 
NEW: IF   supersituation S1 yields the rule (a ...)
     AND  instance exists in S1
     THEN it is redundant to also evaluate the expression in situation,
	  as it will already have been evaluated in S1 and passed to instance through
          "situation inheritance".

So, we return two values:
  (<expr1> ...)		; exprs to evaluate in situation
  (<expr1> ...)		; redundant expressions (will already have been evaluated in supersituations)|#
;;;; ---------- search ALL situations and classes
(TRACE-LISP
 (DEFINE INHERITED-RULE-SETS (INSTANCE SLOT &REST LKEYS)
  (trace-defun 'INHERITED-RULE-SETS (INSTANCE SLOT LKEYS)
   (RET
    (CLET (SITUATION RETAIN-COMMENTSP CLIMB-SITUATION-HIERARCHYP) (init-keyval CLIMB-SITUATION-HIERARCHYP T) (init-keyval SITUATION (CURR-SITUATION))
     (CLET
      ((ALL-SITUATIONS
        (COND ((CNOT CLIMB-SITUATION-HIERARCHYP) (LIST SITUATION))
         ((AND (NEQ SITUATION *GLOBAL-SITUATION*) (FLUENTP SLOT)) (CONS SITUATION (ALL-SUPERSITUATIONS SITUATION))) (T (LIST *GLOBAL-SITUATION*))))
       (VISIBLE-THEORIES (VISIBLE-THEORIES)))
      (COND
       ((INHERIT-WITH-OVERRIDES-SLOTP SLOT)
        (DECOMMENT (BIND-SELF (INHERITED-RULE-SETS-WITH-OVERRIDES SLOT (IMMEDIATE-CLASSES INSTANCE) (APPEND ALL-SITUATIONS VISIBLE-THEORIES)) INSTANCE)
         :RETAIN-COMMENTSP RETAIN-COMMENTSP))
       (T
        (DECOMMENT (BIND-SELF (INHERITED-RULE-SETS2 SLOT (ALL-CLASSES INSTANCE) (APPEND ALL-SITUATIONS VISIBLE-THEORIES)) INSTANCE) :RETAIN-COMMENTSP
         RETAIN-COMMENTSP)))))))))
;;;; ---------- STOP after you've found something
;;;; Slots are declared to use this by setting their "inherit-with-overrides" property to t
;;;; REVISED 8.16.00:
;;;; With multiple inheritance, climb up all the branches stopping at the point(s) where you hit a rule.
;;;; REVISED 12.11.00: 
;;;; Don't bother also ascending situation hierarchy, instead use all situations immediately
;;;; RETURNS: A list of rule sets
(TRACE-LISP
 (DEFINE INHERITED-RULE-SETS-WITH-OVERRIDES (SLOT CLASSES ALL-SITUATIONS)
  (trace-defun 'INHERITED-RULE-SETS-WITH-OVERRIDES (SLOT CLASSES ALL-SITUATIONS)
   (RET
    (CL-REMOVE-DUPLICATES
     (CL-REMOVE NIL
      (MAPCAN #'(LAMBDA (CLASS) (trace-defun '#:G15628 (CLASS) (RET (INHERITED-RULE-SETS-WITH-OVERRIDES2 SLOT CLASS ALL-SITUATIONS)))) CLASSES))
     :TEST #'CL-EQUAL)))))
;;;; RETURNS: A list of rule sets. Is MAPCAN-SAFE
(TRACE-LISP
 (DEFINE INHERITED-RULE-SETS-WITH-OVERRIDES2 (SLOT CLASS ALL-SITUATIONS)
  (trace-defun 'INHERITED-RULE-SETS-WITH-OVERRIDES2 (SLOT CLASS ALL-SITUATIONS)
   (RET
    (COND ((INHERITED-RULE-SETS2 SLOT (LIST CLASS) ALL-SITUATIONS)) 
     ((NEQ CLASS '|Thing|) (INHERITED-RULE-SETS-WITH-OVERRIDES SLOT (IMMEDIATE-SUPERCLASSES CLASS) ALL-SITUATIONS)))))))
;;;; ----------
;;;; Find all the rule sets on all the classes in all the situations
;;;; Is MAPCAN SAFE
;;;; RETURNS: A list of rule-sets
(TRACE-LISP
 (DEFINE INHERITED-RULE-SETS2 (SLOT CLASSES SITUATIONS)
  (trace-defun 'INHERITED-RULE-SETS2 (SLOT CLASSES SITUATIONS)
   (RET
    (CL-REMOVE-DUPLICATES
     (CL-REMOVE NIL 
      (MAPCAN
       #'(LAMBDA (SITUATION)
          (trace-defun '#:G15629 (SITUATION)
           (RET (MAPCAN #'(LAMBDA (CLASS) (trace-defun '#:G15630 (CLASS) (RET (GET-RULE-SETS-IN-SITUATION CLASS SLOT SITUATION)))) CLASSES))))
       SITUATIONS))
      :TEST #'CL-EQUAL :FROM-END T)))))
#|(Essentially a synonym for get-vals)
IS MAPCAN-SAFE [due to &&-exprs-to-valsets, and &-expr-to-vals]
[1] UNPACK '&&' sets, ie. If one rule set is (set1 && set2), return (set1 set2), not (((set1 && set2)))
These && sets might be created by the user through multiple (every ... has ...) statements for the same slot,
or created by KM during unification.
USER(45): (mapcar X'list
		  (append (mapcan X'&-expr-to-vals '(1 2 (3 & 4)))
			  (mapcan X'&-expr-to-vals '((3 & 4)))))
((1) (2) (3) (4) (3) (4))|#
(TRACE-LISP
 (DEFINE GET-RULE-SETS-IN-SITUATION (CLASS SLOT SITUATION)
  (trace-defun 'GET-RULE-SETS-IN-SITUATION (CLASS SLOT SITUATION)
   (RET
    (COND
     ((SINGLE-VALUED-SLOTP SLOT)
      (MAPCAR #'LIST
       (CL-REMOVE-DUPLICATES
        (APPEND (MAPCAN #'&-EXPR-TO-VALS (GET-VALS CLASS SLOT :FACET 'MEMBER-PROPERTIES :SITUATION SITUATION))
         (MAPCAN #'&-EXPR-TO-VALS (GET-VALS CLASS SLOT :FACET 'MEMBER-DEFINITION :SITUATION SITUATION)))
        :TEST #'CL-EQUAL :FROM-END T)))
     (T
      (APPEND (&&-EXPRS-TO-VALSETS (GET-VALS CLASS SLOT :FACET 'MEMBER-PROPERTIES :SITUATION SITUATION))
       (&&-EXPRS-TO-VALSETS (GET-VALS CLASS SLOT :FACET 'MEMBER-DEFINITION :SITUATION SITUATION)))))))))
;;;; Climb up situation hierarchy collecting instance data
;;;; [1] should be "and" rather than "or", but let's use "or" for efficiency
;;;; Note, supersituation-own-rule-sets has the EXTRA FUNCTIONALITY of REMOVING fluent instances.
;;;; [2] Given this, we better make sure that for non-fluents, we start in the right situation (global),
;;;;	so we *don't* remove fluent instances then. Hmmm....
#|(defun own-rule-sets (instance slot &key (situation (curr-situation)) retain-commentsp)
 (let ( (start-situation (target-situation situation instance slot)) )		; [2]
  (decomment
   (bind-self
    (remove nil
     (cons
      (or (get-vals instance slot :facet 'own-properties :situation start-situation) 
	  (get-vals instance slot :facet 'own-definition :situation start-situation))
      (supersituation-own-rule-sets instance slot :situation start-situation :retain-commentsp retain-commentsp)))
    instance)
   :retain-commentsp retain-commentsp)))|#
(TRACE-LISP
 (DEFINE OWN-RULE-SETS (INSTANCE SLOT &REST LKEYS)
  (trace-defun 'OWN-RULE-SETS (INSTANCE SLOT LKEYS)
   (RET
    (CLET (SITUATION RETAIN-COMMENTSP) (init-keyval SITUATION (CURR-SITUATION))
     (CLET ((START-SITUATION (TARGET-SITUATION SITUATION INSTANCE SLOT))) 
      (DECOMMENT
       (BIND-SELF
        (CL-REMOVE NIL
         (APPEND
          (&&-EXPRS-TO-VALSETS
           (OR (GET-VALS INSTANCE SLOT :FACET 'OWN-PROPERTIES :SITUATION START-SITUATION)
            (GET-VALS INSTANCE SLOT :FACET 'OWN-DEFINITION :SITUATION START-SITUATION)))
          (SUPERSITUATION-OWN-RULE-SETS INSTANCE SLOT :SITUATION START-SITUATION :RETAIN-COMMENTSP RETAIN-COMMENTSP)))
        INSTANCE)
       :RETAIN-COMMENTSP RETAIN-COMMENTSP)))))))
#|Collect all the local expr-sets of slot from all supersituations of situation [*NOT* including situation itself]
This is similar to own-rule-sets, except it *doesn't* look in the current situation.
It also filters our fluent instances, which *shouldn't* be propogated down the taxonomy.
Presumably, own-rule-sets should do this too.
If situation = *Global, then this procedure just searches (visible-theories)
[1] Ie has a previous situation, it's not the first in the chain
[2] Special-purpose code for clones:
	ALL cloned info is put in the GLOBAL situation
        BUT we need to allow for the FLUENT cloned information to be RETRACTED. The only easy way of
	 doing this is to ONLY pass fluent cloned information from *Global to a local situation in the
	 FIRST situation in a situation chain. From then on, it will be passed by projection.|#
(TRACE-LISP
 (DEFINE SUPERSITUATION-OWN-RULE-SETS (INSTANCE SLOT &REST LKEYS)
  (trace-defun 'SUPERSITUATION-OWN-RULE-SETS (INSTANCE SLOT LKEYS)
   (RET
    (CLET (SITUATION RETAIN-COMMENTSP) (init-keyval SITUATION (CURR-SITUATION))
     (COND
      ((AND (ISA-CLONE INSTANCE)  (NEQ SITUATION *GLOBAL-SITUATION*) (INERTIAL-FLUENTP SLOT)
        (GET-VALS SITUATION '|prev-situation| :SITUATION *GLOBAL-SITUATION*))
        NIL)
      (T
       (CLET
        ((ALL-SUPERSITUATIONS (COND ((AND (NEQ SITUATION *GLOBAL-SITUATION*) (FLUENTP SLOT)) (ALL-SUPERSITUATIONS SITUATION))))
         (VISIBLE-THEORIES (VISIBLE-THEORIES)))
        (DECOMMENT
         (CL-REMOVE-DUPLICATES
          (CL-REMOVE NIL
           (MY-MAPCAN
            #'(LAMBDA (SITN)
               (trace-defun '#:G15631 (SITN)
                (RET
                 (&&-EXPRS-TO-VALSETS 
                  (OR (GET-VALS INSTANCE SLOT :FACET 'OWN-PROPERTIES :SITUATION SITN) 
                   (GET-VALS INSTANCE SLOT :FACET 'OWN-DEFINITION :SITUATION SITN))))))
             (APPEND ALL-SUPERSITUATIONS VISIBLE-THEORIES)))
          :TEST #'CL-EQUAL :FROM-END T)
         :RETAIN-COMMENTSP RETAIN-COMMENTSP)))))))))
;;;; ----------
;;;; Find all the constraints on an instance's slot.
;;;; NOTE: This won't collect constraints on subslots
;;;; [1] retain-commentsp t for efficiency, we'll remove them later.
;;;; [2] Actually, this decomment step is redundant because find-constraints-in-exprs ALWAYS does a decomment anyway!
(TRACE-LISP
 (DEFINE COLLECT-CONSTRAINTS-ON-INSTANCE (INSTANCE SLOT &REST LKEYS)
  (trace-defun 'COLLECT-CONSTRAINTS-ON-INSTANCE (INSTANCE SLOT LKEYS)
   (RET
    (CLET (SITUATION RETAIN-COMMENTSP) (init-keyval SITUATION (CURR-SITUATION))
     (COND
      ((AND *ARE-SOME-CONSTRAINTS*  (OR (CL-MEMBER SLOT *BUILT-IN-SLOTS-WITH-CONSTRAINTS*) (CNOT (CL-MEMBER SLOT *BUILT-IN-SLOTS*))))
       (CLET
        ((INHERITED-SETS (INHERITED-RULE-SETS INSTANCE SLOT :SITUATION SITUATION :RETAIN-COMMENTSP T)) 
         (INHERITED-CONSTRAINTS (MAPCAN #'FIND-CONSTRAINTS-IN-EXPRS INHERITED-SETS)) 
         (OWN-CONSTRAINTS (MAPCAN #'FIND-CONSTRAINTS-IN-EXPRS  (OWN-RULE-SETS INSTANCE SLOT :SITUATION SITUATION))))
        (DECOMMENT (CL-REMOVE-DUPLICATES (APPEND INHERITED-CONSTRAINTS OWN-CONSTRAINTS) :TEST #'CL-EQUAL) :RETAIN-COMMENTSP RETAIN-COMMENTSP)))))))))
;;;; Same, but start at classes
;;;; [1] all-superclasses0 like all-superclasses, except *excludes* Thing and includes classes.
;;;;	Perfect!
(TRACE-LISP
 (DEFINE INHERITED-RULE-SETS-ON-CLASSES (CLASSES SLOT &REST LKEYS)
  (trace-defun 'INHERITED-RULE-SETS-ON-CLASSES (CLASSES SLOT LKEYS)
   (RET
    (CLET (SITUATION RETAIN-COMMENTSP) (init-keyval SITUATION (CURR-SITUATION))
     (CLET
      ((ALL-SITUATIONS
        (COND ((AND (NEQ SITUATION *GLOBAL-SITUATION*) (FLUENTP SLOT)) (CONS SITUATION (ALL-SUPERSITUATIONS SITUATION))) (T (LIST *GLOBAL-SITUATION*))))
       (VISIBLE-THEORIES (VISIBLE-THEORIES)))
      (COND
       ((INHERIT-WITH-OVERRIDES-SLOTP SLOT)
        (DECOMMENT (INHERITED-RULE-SETS-WITH-OVERRIDES SLOT CLASSES (APPEND ALL-SITUATIONS VISIBLE-THEORIES)) :RETAIN-COMMENTSP RETAIN-COMMENTSP))
       (T
        (CLET ((ALL-CLASSES (MY-MAPCAN #'ALL-SUPERCLASSES0 CLASSES))) 
         (DECOMMENT
          (CL-REMOVE NIL 
           (MAPCAN
            #'(LAMBDA (SITN)
               (trace-defun '#:G15632 (SITN)
                (RET
                 (MAPCAN #'(LAMBDA (CLASS) (trace-defun '#:G15633 (CLASS) (RET (GET-RULE-SETS-IN-SITUATION CLASS SLOT SITN)))) ALL-CLASSES))))
            (APPEND ALL-SITUATIONS VISIBLE-THEORIES))
            :TEST #'CL-EQUAL :FROM-END T)
          :RETAIN-COMMENTSP RETAIN-COMMENTSP))))))))))
;;;; ----------
;;;; Local to the slot AND situation
(TRACE-LISP
 (DEFINE LOCAL-CONSTRAINTS (INSTANCE SLOT &REST LKEYS)
  (trace-defun 'LOCAL-CONSTRAINTS (INSTANCE SLOT LKEYS)
   (RET
    (CLET (SITUATION) (init-keyval SITUATION (CURR-SITUATION))
     (COND
      (*ARE-SOME-CONSTRAINTS* 
       (FIND-CONSTRAINTS-IN-EXPRS
        (BIND-SELF
         (OR (GET-VALS INSTANCE SLOT :FACET 'OWN-PROPERTIES :SITUATION SITUATION)  (GET-VALS INSTANCE SLOT :FACET 'OWN-DEFINITION :SITUATION SITUATION)) 
         INSTANCE)))))))))
;;;; ======================================================================
;;;; 		ADDITIONAL UTILITIES
;;;; ======================================================================
(TRACE-LISP
 (DEFINE HAS-SITUATION-SPECIFIC-INFO (FRAME SITUATION)
  (trace-defun 'HAS-SITUATION-SPECIFIC-INFO (FRAME SITUATION)
   (RET
    (SOME #'(LAMBDA (PROP-LIST) (trace-defun '#:G15634 (PROP-LIST) (RET (GETOBJ FRAME (CURR-SITUATION-FACET PROP-LIST SITUATION)))))
     *ALL-FACETS*)))))
;;;; ======================================================================
;;;;		SPECIAL FACET FOR BOOK-KEEPING OF DEFINITIONS
;;;; ======================================================================
(TRACE-LISP
 (DEFINE POINT-PARENTS-TO-DEFINED-CONCEPT (FRAME PARENTS FACET)
  (trace-defun 'POINT-PARENTS-TO-DEFINED-CONCEPT (FRAME PARENTS FACET)
   (RET
    (CLET ((DEFINED-CHILDREN-FACET (COND ((EQ FACET 'OWN-DEFINITION) 'DEFINED-INSTANCES) (T 'DEFINED-SUBCLASSES))))
     (COND
      ((NULL PARENTS)
       (REPORT-ERROR 'USER-ERROR
        "~a:
Definition for ~a must include an `instance-of' slot,
declaring the most general superclass of ~a.
Continuing, but ignoring definition...~%"
        FRAME FRAME FRAME))
      (T
       (MAPCAR
        #'(LAMBDA (PARENT)
           (trace-defun '#:G15635 (PARENT)
            (RET
             (CLET ((CHILDREN (GET PARENT DEFINED-CHILDREN-FACET)))      (MAKE-COMMENT "Noting definition for ~a..." FRAME)
              (COND ((CL-MEMBER FRAME CHILDREN))  (T   (KM-SETF PARENT DEFINED-CHILDREN-FACET (CONS FRAME CHILDREN))))))))
        PARENTS))))))))
;;;; ======================================================================
;;;; Adding (not replacing) new values to the originals...
;;;; ======================================================================
;;;; [1] Factor out 'Self' at load-time for own properties.
;;;; [2] Now compute-new-vals might return (old && new), we need to do install-inverses explicitly on new.
;;;; RETURNS: irrelevant.
;;;; [3] Extra condition: (greater-than has (instance-of (Relation)) (inverse (less-than)))
;;;; *don't* install (less-than has (instance-of (Slot))), which will happen otherwise
;;;; [4] Would use (not (non-inverse-recording-slot <i>)), but some assertions may not have been done by this point so would
;;;;     not yet be valid.
(TRACE-LISP
 (DEFINE ADD-SLOTSVALS (INSTANCE ADD-SLOTSVALS &REST LKEYS)
  (trace-defun 'ADD-SLOTSVALS (INSTANCE ADD-SLOTSVALS LKEYS)
   (RET
    (CLET (FACET INSTALL-INVERSESP SITUATION COMBINE-VALUES-BY BIND-SELFP) (init-keyval BIND-SELFP T) (init-keyval SITUATION (CURR-SITUATION))
     (init-keyval INSTALL-INVERSESP T) (init-keyval FACET 'OWN-PROPERTIES) 
     (CLET
      ((NEW-ADD-SLOTSVALS
        (COND ((AND (CL-MEMBER FACET '(OWN-PROPERTIES OWN-DEFINITION))  BIND-SELFP) (BIND-SELF ADD-SLOTSVALS INSTANCE)) (T ADD-SLOTSVALS))))
      (MAPC
       #'(LAMBDA (ADD-SLOTVALS)
          (trace-defun '#:G15636 (ADD-SLOTVALS)
           (RET
            (CLET
             ((SLOT (SLOT-IN ADD-SLOTVALS)) (ADD-VALS0 (VALS-IN ADD-SLOTVALS))
              (ADD-VALS
               (COND ((SINGLE-VALUED-SLOTP SLOT) (UN-ANDIFY ADD-VALS0)) ((REMOVE-SUBSUMERS-SLOTP SLOT) (REMOVE-SUBSUMERS ADD-VALS0))
                ((REMOVE-SUBSUMEES-SLOTP SLOT) (REMOVE-SUBSUMEES ADD-VALS0)) (T ADD-VALS0)))
              (SITUATION0 (TARGET-SITUATION SITUATION INSTANCE SLOT ADD-VALS))  (OLD-VALS (GET-VALS INSTANCE SLOT :FACET FACET :SITUATION SITUATION0)) 
              (NEW-VALS
               (COND ((NULL OLD-VALS) (COND ((SINGLE-VALUED-SLOTP SLOT) (VAL-TO-VALS (VALS-TO-&-EXPR ADD-VALS)))   (T ADD-VALS)))
                ((EQ COMBINE-VALUES-BY 'OVERWRITING)
                 (COND ((EQ FACET 'OWN-PROPERTIES) (UNINSTALL-INVERSES INSTANCE SLOT (SET-DIFFERENCE OLD-VALS ADD-VALS) SITUATION0)))
                 (COND ((SINGLE-VALUED-SLOTP SLOT) (VAL-TO-VALS (VALS-TO-&-EXPR ADD-VALS))) (T ADD-VALS)))
                (T (COMPUTE-NEW-VALS SLOT OLD-VALS ADD-VALS :COMBINE-VALUES-BY COMBINE-VALUES-BY)))))
                
             (COND
              ((OR NEW-VALS (EQ COMBINE-VALUES-BY 'OVERWRITING)) 
               (PUT-VALS INSTANCE SLOT NEW-VALS :FACET FACET :INSTALL-INVERSESP NIL :SITUATION SITUATION0) 
               (COND (INSTALL-INVERSESP  (INSTALL-INVERSES INSTANCE SLOT ADD-VALS SITUATION0)))))))))
        (REORDER-SLOTSVALS NEW-ADD-SLOTSVALS))
      
      (COND
       ((AND (EQ FACET 'OWN-PROPERTIES) (ASSOC '|domain| ADD-SLOTSVALS) (CNOT (NON-INVERSE-RECORDING-SLOT INSTANCE)))
        (ADD-VALS (INVERT-SLOT INSTANCE) '|range| (VALS-IN (ASSOC '|domain| ADD-SLOTSVALS)) :SITUATION *GLOBAL-SITUATION*)))
      (COND
       ((AND (EQ FACET 'OWN-PROPERTIES) (ASSOC '|range| ADD-SLOTSVALS) (CNOT (NON-INVERSE-RECORDING-SLOT INSTANCE)))
        (ADD-VALS (INVERT-SLOT INSTANCE) '|domain| (VALS-IN (ASSOC '|range| ADD-SLOTSVALS)) :SITUATION *GLOBAL-SITUATION*)))
      (COND
       ((AND
         (OR (SOME #'(LAMBDA (SLOTS-SLOT) (trace-defun '#:G15637 (SLOTS-SLOT) (RET (ASSOC SLOTS-SLOT ADD-SLOTSVALS)))) *SLOTS-SLOTS*)
          (CL-ISA INSTANCE '|Slot|))
         (EQ FACET 'OWN-PROPERTIES))
        
        (COND
         ((AND (CNOT (ASSOC '|instance-of| ADD-SLOTSVALS)) (CNOT (CL-ISA INSTANCE '|Slot|)))
          (ADD-VALS INSTANCE '|instance-of| '(|Slot|) :SITUATION *GLOBAL-SITUATION*)))
        (COND
         ((AND *INSTALLING-INVERSES-ENABLED* (CNOT (NON-INVERSE-RECORDING-SLOT INSTANCE))) 
          (ADD-VALS (INVERT-SLOT INSTANCE) '|instance-of| (OR (VALS-IN (ASSOC '|instance-of| ADD-SLOTSVALS)) '(|Slot|))  :SITUATION
           *GLOBAL-SITUATION*)))))))))))
;;    (cond ((assoc ';$instance-of add-slotsvals)				       				; view mechanism
;;	   (install-views instance (set-difference (immediate-classes instance) old-classes))))))
;;;; ======================================================================
#|NOTE: These are older comments from an earlier version compute-new-slotsvals, not compute-new-vals.
;;; NB: Preserves original ordering if no updates are required, so we can detect no change
> (compute-new-slotsvals '((s1 (a b)) (s2 (c d))) '((s2 (d e)) (s3 (f g))))
((s1 (a b)) (s2 (c d e)) (s3 (f g)))
>  (compute-new-slotsvals '((s1 (a b)) (s2 (c d e)) (s3 (f g))) '((s2 (d e)) (s3 (f g))))
((s1 (a b)) (s2 (c d e)) (s3 (f g)))
[1] This could be made more efficient by only doing pair-wise subsumption tests between old-vals and extra-vals,
    rather than all possible pairings. See more efficient version in add-val, earlier.
[2] Defined in subsumes.lisp. NB *only* do this check for own properties! 
	Why: Originally becuase the remove-subsuming-exprs check evaluates the expressions!
[3] Now we do a two-way check: if old-expr subsumes new-expr, or new-expr subsumes old-expr, then remove the subsumer.
    This is just a generalized case of remove-subsumers [1b], preserving which was in which set.

FILTER above at [2]:
More time consuming, but more thorough. Can skip this if you really want, to avoid this
rather unusual instance-specific problem.
IF there are any instances in old-vals AND a new-val expression subsumes that
instance THEN don't add the new-val expression to the description.
	KM> (Pete has (owns ((a Dog))))
	KM> (Pete owns)
	_Dog40
	KM> (Pete has (owns ((a Dog))))
	KM> (Pete owns)
	_Dog40				; was (_Dog40 _Dog41) in 1.3.7
	KM> (Pete has (owns ((a Dog) (a Dog))))
	(_Dog40 _Dog41)			; was just _Dog40 in beta version of 1.3.8

[2] Subtle bug: final-extra-vals should be computed using the REMAINDER of UNCOVERED old-vals, not old-vals neat. But we'll not worry
about it for now.
	 (*Pete has (owns ((a Car) (a Car))))
	 (*Pete has (owns ((a Car) (a Car) (a Car))))
 result: (*Pete has (owns ((a Car) (a Car))))		[non-subsumers=(a Car), final-extra-vals=(a car)]|#
;;;; REVISED APPROACH
;;;; Return new-vals, or NIL means no changes are needed
;;;; [1] only meaningful for remove-subsumers-slotp etc. cases, otherwise discard result.
(TRACE-LISP
 (DEFINE COMPUTE-NEW-VALS (SLOT OLD-VALS0 ADD-VALS &REST LKEYS)
  (trace-defun 'COMPUTE-NEW-VALS (SLOT OLD-VALS0 ADD-VALS LKEYS)
   (RET
    (CLET (COMBINE-VALUES-BY)
     (CLET
      ((OLD-VALS (COND ((SINGLE-VALUED-SLOTP SLOT) (UN-ANDIFY OLD-VALS0))  (T OLD-VALS0)))
       (EXTRA-VALS (CL-ORDERED-SET-DIFFERENCE ADD-VALS OLD-VALS :TEST #'CL-EQUAL)))
      (COND ((REMOVE-SUBSUMERS-SLOTP SLOT) (COND (EXTRA-VALS (REMOVE-SUBSUMERS (APPEND OLD-VALS EXTRA-VALS))) (T OLD-VALS0))) 
       ((REMOVE-SUBSUMEES-SLOTP SLOT) (COND (EXTRA-VALS (REMOVE-SUBSUMEES (APPEND OLD-VALS EXTRA-VALS))) (T OLD-VALS0)))
       ((COMBINE-VALUES-BY-APPENDING-SLOTP SLOT) (COND (EXTRA-VALS (REMOVE-DUP-INSTANCES (APPEND OLD-VALS EXTRA-VALS))) (T OLD-VALS0)))
       ((EQ COMBINE-VALUES-BY 'APPENDING)
        (COND ((SINGLE-VALUED-SLOTP SLOT) (VAL-TO-VALS (VALS-TO-&-EXPR (REMOVE-DUP-INSTANCES (APPEND OLD-VALS ADD-VALS)))))
         (T (REMOVE-DUP-INSTANCES (APPEND OLD-VALS ADD-VALS)))))
       ((SINGLE-VALUED-SLOTP SLOT)
        (COND ((CNOT (SET-DIFFERENCE ADD-VALS OLD-VALS)) NIL)  ((VALSET-SUBSUMES-VALSET ADD-VALS OLD-VALS) NIL)
         (T (VAL-TO-VALS (VALS-TO-&-EXPR (APPEND OLD-VALS ADD-VALS))))))
       (T
        (CLET ((VALSETS (&&-EXPRS-TO-VALSETS OLD-VALS))  (NVALSETS (LENGTH VALSETS)))
         (COND ((CL-MEMBER ADD-VALS VALSETS :TEST #'CL-EQUAL) NIL)   
          ((AND (<= NVALSETS 10) 
            (SOME #'(LAMBDA (VALSET) (trace-defun '#:G15638 (VALSET) (RET (VALSET-SUBSUMES-VALSET ADD-VALS VALSET))))  VALSETS))
           NIL)
          ((AND (EVERY #'CONSTRAINT-EXPRP ADD-VALS)  (SINGLETONP VALSETS))   (CL-REMOVE-DUPLICATES (APPEND (FIRST VALSETS) ADD-VALS) :TEST #'CL-EQUAL))
          (T   
           (CLET
            ((REDUCED-VALSETS
              (COND
               ((<= NVALSETS 10)
                (REMOVE-IF #'(LAMBDA (VALSET) (trace-defun '#:G15639 (VALSET) (RET (VALSET-SUBSUMES-VALSET VALSET ADD-VALS))))  VALSETS))
               (T VALSETS))))
            
            (VALSETS-TO-&&-EXPRS (CL-REMOVE-DUPLICATES (APPEND REDUCED-VALSETS (&&-EXPRS-TO-VALSETS ADD-VALS)) :TEST #'CL-EQUAL :FROM-END T))))))))))))))
;;;; ======================================================================
;;;;		NEW FRAME CREATION
;;;; create-instance -- just generate a new instance frame and hook it into the isa hierarchy.
;;;; ======================================================================
;;;; (create-instance 'person '((legs (3))))
;;;; creates a new instance of person eg. _person30, with slot-values:
;;;;		(generalizations (person)) (legs (3))
;;;;
;;;; `parent' can be either a symbol or a string
;;;; This creates a new, anonymous subframe of parent, and attaches slotsvals
;;;; to the new frame. :instance denotes that the frame is an instance, and
;;;; hence its name is prefixed with an instance marker (eg. "_" in "_person31")
;;;; Apr 99: If fluent-instancep is t, then a fluent instance is created, denoted by using
;;;; the prefix-string "_Some". Fluents aren't passed between situations (Strictly they
;;;; should be copied and renamed, but it's easier to simply rebuild them in the
;;;; new situation from the (some ...) expression).
(TRACE-LISP
 (DEFINE CL-CREATE-INSTANCE (PARENT0 &OPTIONAL SLOTSVALS0 PREFIX-STRING BIND-SELFP)
  (trace-defun 'CL-CREATE-INSTANCE (PARENT0 SLOTSVALS0 PREFIX-STRING BIND-SELFP)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR BIND-SELFP T)
     (SUBLISP-INITVAR PREFIX-STRING (COND ((AM-IN-PROTOTYPE-MODE) *PROTO-MARKER-STRING*) (T *VAR-MARKER-STRING*)))
     (CLET ((PARENT (DEREFERENCE PARENT0)) (SLOTSVALS (DEREFERENCE SLOTSVALS0)))
      (COND
       ((KB-OBJECTP PARENT)  (CSETQ *STATISTICS-SKOLEMS* (1+ *STATISTICS-SKOLEMS*))
        (CREATE-NAMED-INSTANCE (CREATE-INSTANCE-NAME PARENT PREFIX-STRING) PARENT SLOTSVALS BIND-SELFP))
       
       ((CLASS-DESCRIPTIONP PARENT)
        (CLET
         ((DCLASS+DSLOTSVALS (CLASS-DESCRIPTION-TO-CLASS+SLOTSVALS PARENT)) (DCLASS (FIRST DCLASS+DSLOTSVALS)) (DSLOTSVALS (SECOND DCLASS+DSLOTSVALS)))
         (CREATE-NAMED-INSTANCE (CREATE-INSTANCE-NAME DCLASS PREFIX-STRING) DCLASS (APPEND DSLOTSVALS SLOTSVALS) BIND-SELFP)))
       (T (REPORT-ERROR 'USER-ERROR "Class name must be a symbol or class description! (was ~a)~%" PARENT)))))))))
;;;; Here I know the name of the new frame to create
;;;; [1] to handle (a Car with (instance-of (Expensive-Thing)))
;;;; [2] Use add-slotsvals, rather than put-slotsvals, to make sure the non-fluent assertions are made in the global situation.
;;;;     In addition, unify-with-existential-expr calls this, even though the old instance exists.
;;;; [3] No - global assertions are on a slot-by-slot basis.
;;;; [4] Make sure we add instance-of Event first, so slots are later recognized as Event slots!
(TRACE-LISP
 (DEFINE CREATE-NAMED-INSTANCE (NEWFRAME PARENT &OPTIONAL SLOTSVALS0 BIND-SELFP)
  (trace-defun 'CREATE-NAMED-INSTANCE (NEWFRAME PARENT SLOTSVALS0 BIND-SELFP)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR BIND-SELFP T)
     (COND ((CNOT (KB-OBJECTP NEWFRAME)) (REPORT-ERROR 'USER-ERROR "Ignoring slots on non-kb-object ~a...~%Slots: ~a~%" NEWFRAME SLOTSVALS0))
      (T
       (CLET
        ((EXTRA-CLASSES (VALS-IN (ASSOC '|instance-of| SLOTSVALS0))) 
         (SLOTSVALS1 (UPDATE-ASSOC-LIST SLOTSVALS0 (LIST '|instance-of| (REMOVE-SUBSUMERS (CONS PARENT EXTRA-CLASSES)))))
         (SLOTSVALS (COND (BIND-SELFP (BIND-SELF SLOTSVALS1 NEWFRAME)) (T SLOTSVALS1))))
        (ADD-SLOTSVALS NEWFRAME SLOTSVALS :BIND-SELFP BIND-SELFP) 
        (COND ((AM-IN-PROTOTYPE-MODE) (ADD-VAL NEWFRAME '|prototype-participant-of| (CURR-PROTOTYPE) T *GLOBAL-SITUATION*)))  #|NEW|#
        (MAKE-ASSERTIONS NEWFRAME SLOTSVALS)  (UN-DONE NEWFRAME) 
        (CLET ((SLOTS-THAT-CHANGED (CL-REMOVE '|instance-of| (MAPCAR #'SLOT-IN SLOTSVALS)))) (CLASSIFY NEWFRAME :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED)) 
        (MAPC
         #'(LAMBDA (SLOT)
            (trace-defun '#:G15640 (SLOT)
             (RET
              (TRACE-PROGN (KM-TRACE 'COMMENT "New instance ~a: evaluating slot ~a opportunistically..." NEWFRAME SLOT)
               (KM0 `(|the| ,SLOT |of| ,NEWFRAME))))))
         (SLOTS-TO-OPPORTUNISTICALLY-EVALUATE NEWFRAME))
        NEWFRAME))))))))
;;;; [1] above: NOTE If *indirect-classification* is NIL, and there's a plain instance (a <C>), then slots-that-changed will be NIL, and
;;;; hence classification won't happen anyway.
;;;; ======================================================================
;;;; NEW - keep a local copy of the gensym counter, rather than use the Lisp internal counter,
;;;; to allow us to reset it (eg. after an "undo" operation)
(TRACE-LISP (DEFVAR *KM-GENSYM-COUNTER* 0))
;;;; [gentemp = gensym + intern in current package]
;;;; [1] Consider the user saves a KB, then reloads it in a new session. As the gentemp
;;;; counter starts form zero again, there's a small chance it will re-create the name
;;;; of an already used frame, so we need to check for this.
(TRACE-LISP
 (DEFINE CREATE-INSTANCE-NAME (PARENT &OPTIONAL PREFIX-STRING)
  (trace-defun 'CREATE-INSTANCE-NAME (PARENT PREFIX-STRING)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR PREFIX-STRING (COND ((AM-IN-PROTOTYPE-MODE) *PROTO-MARKER-STRING*) (T *VAR-MARKER-STRING*)))
     (COND ((AND (CHECKKBP) (CNOT (KNOWN-FRAME PARENT))) (REPORT-ERROR 'USER-WARNING "Class ~a not declared in KB.~%" PARENT))) 
     (KM-SETQ '*KM-GENSYM-COUNTER* (1+ *KM-GENSYM-COUNTER*)) 
     (CLET ((INSTANCE-NAME (INTERN (CONCAT PREFIX-STRING (SYMBOL-NAME PARENT) (PRINC-TO-STRING *KM-GENSYM-COUNTER*)) *KM-PACKAGE*)))
      (COND ((KNOWN-FRAME INSTANCE-NAME) (CREATE-INSTANCE-NAME PARENT PREFIX-STRING))  (T INSTANCE-NAME))))))))
;;;; ------------------------------
;;;;	NEW: If build a situation, make its assertions
;;;; ------------------------------
;;;; Generalized to cover any new instance. SubSelf is only used for Situations, as a holder for Self.
;;;; For situations, assertions are meant to be made *in* the situation they're in.
;;;; [1] (second ...) to strip off the (quote ...)
(TRACE-LISP
 (DEFINE MAKE-ASSERTIONS (INSTANCE &OPTIONAL SLOTSVALS)
  (trace-defun 'MAKE-ASSERTIONS (INSTANCE SLOTSVALS)
   (RET
    (COND
     ((OR (AND *CLASSES-USING-ASSERTIONS-SLOT* (CL-INTERSECTION (ALL-CLASSES INSTANCE) *CLASSES-USING-ASSERTIONS-SLOT*)) (ASSOC '|assertions| SLOTSVALS))
      
      (CLET ((ASSERTIONS (SUBST '|Self| '|SubSelf| (KM0 `(|the| |assertions| |of| ,INSTANCE))))) 
       (MAPC
        #'(LAMBDA (ASSERTION)
           (trace-defun '#:G15641 (ASSERTION)
            (RET
             (COND ((CNOT (QUOTEP ASSERTION)) (REPORT-ERROR 'USER-ERROR "Unquoted assertion ~a on ~a! Ignoring it...~%" ASSERTION INSTANCE))
              (T
               (CLET
                ((SITUATED-ASSERTION (COND ((CL-ISA INSTANCE '|Situation|) `(|in-situation| ,INSTANCE ,(UNQUOTE ASSERTION)))  (T (UNQUOTE ASSERTION)))))
                (MAKE-COMMENT "Evaluating ~a" SITUATED-ASSERTION) (KM0 SITUATED-ASSERTION :FAIL-MODE 'ERROR)))))))
        ASSERTIONS))))))))
;;;; ======================================================================
;;;;		THE DONE LIST
;;;; The purpose of this list is to prevent recomputation of cached values.
;;;; Here KM records which slot-values have been computed. If KM subsequently
;;;; need those slot-values, it just does a lookup rather than a recomputation.
;;;; note-done and reset-done are called by interpreter.lisp.
;;;; Aug 98: We have to note "done in a situation", note just "done". Just 
;;;; because KM knows X's age in Sitn1, doesn't mean it knows it in Sitn2!
;;;; ======================================================================
(TRACE-LISP (DEFVAR *NOTED-DONE* NIL))
;;;;    SYMBOL  PROPERTY  VALUE (list of already computed slots)
;;;;    _Car1   done     (age wheels)
;;;; Aug 98: Modify this so we note done in a situation, rather than globally done.
;;;;    SYMBOL  PROPERTY  VALUE (list of already computed slots and situations)
;;;;    _Car1   done     ((age *Global) (wheels Sitn1) (age Sitn1) (age Sitn2) (wheels *Global))
;;;; [1] When *internal-logging* = t, i.e., we know backtracking *will* occur, we DO allow rollback via undo.
;;;;     This avoids the more expensive alternative of calling reset-done after the undo.
;;;;     Currently internal logging is only used once in subsumes.lisp.
;;;; [2] May cause duplicates (one for each situation) but that's probably more efficient
(TRACE-LISP
 (DEFINE NOTE-DONE (FRAME SLOT &OPTIONAL SITUATION)
  (trace-defun 'NOTE-DONE (FRAME SLOT SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (TARGET-SITUATION (CURR-SITUATION) FRAME SLOT)) 
     (COND
      ((KB-OBJECTP FRAME)
       (CLET ((DONE-SO-FAR (GET FRAME 'DONE)))
        (COND ((CL-MEMBER (LIST SLOT SITUATION) DONE-SO-FAR :TEST #'CL-EQUAL))
         (*INTERNAL-LOGGING*  (PUSH FRAME *NOTED-DONE*)  (KM-SETF FRAME 'DONE (CONS (LIST SLOT SITUATION) DONE-SO-FAR)))
         (T (PUSH FRAME *NOTED-DONE*) (CSETF (GET FRAME 'DONE) (CONS (LIST SLOT SITUATION) DONE-SO-FAR))))))))))))
(TRACE-LISP
 (DEFINE ALREADY-DONE (FRAME SLOT &OPTIONAL SITUATION)
  (trace-defun 'ALREADY-DONE (FRAME SLOT SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (TARGET-SITUATION (CURR-SITUATION) FRAME SLOT))
     (AND (KB-OBJECTP FRAME) (CL-MEMBER (LIST SLOT SITUATION) (GET FRAME 'DONE) :TEST #'CL-EQUAL)))))))
;;;; ----------
#|There's a subtle special case here. Fluent instances are NOT projected, so if we have (*MyCar owner _SomePerson3) in S0,
then ask for (*MyCar owner) in S1, we get NIL, and then (*MyCar owner) is flagged as DONE in S1. Fine so far.
But suppose later _SomePerson3 becomes a non-fluent instance, by doing (_SomePerson3 & *Pete) - now it SHOULD be
projected to S1, which would require removing the DONE flag on (*MyCar owner) in S1. But of course this unification
will not remove the DONE flag on all the things which are in some relationship to _SomePerson3.
We can probably make it do that though with a (very) special purpose line of code in lazy-unify.lisp!|#
(TRACE-LISP
 (DEFINE UN-DONE (FRAME &REST LKEYS)
  (trace-defun 'UN-DONE (FRAME LKEYS)
   (RET
    (CLET (SLOT SITUATION)   
     (COND
      ((OR  (EQ SITUATION *GLOBAL-SITUATION*) (AND (NULL SITUATION) (AM-IN-GLOBAL-SITUATION)) (NULL SLOT) (AND SLOT (CNOT (FLUENTP SLOT))))
       (COND
        (SLOT
         (CLET ((DONE-SO-FAR (GET FRAME 'DONE)))
          (CSETF (GET FRAME 'DONE) (REMOVE-IF #'(LAMBDA (PAIR) (trace-defun '#:G15642 (PAIR) (RET (EQ (FIRST PAIR) SLOT)))) DONE-SO-FAR))))
        (T (REMPROP FRAME 'DONE))))
      (T
       (CLET ((DONE-SO-FAR (GET FRAME 'DONE)) (NEXT-SITUATIONS (ALL-NEXT-SITUATIONS (OR SITUATION (CURR-SITUATION))))) 
        (CSETF (GET FRAME 'DONE)
         (REMOVE-IF
          #'(LAMBDA (PAIR)
             (trace-defun '#:G15643 (PAIR) (RET (AND (CL-MEMBER (SECOND PAIR) NEXT-SITUATIONS) (OR (NULL SLOT) (EQ (FIRST PAIR) SLOT))))))
          DONE-SO-FAR))))))))))
#|Global un-done
(defun un-done (frame &key slot situation)
  (declare (ignore situation))
  (cond (slot (let ( (done-so-far (get frame 'done)) )
		(setf (get frame 'done) (remove-if X'(lambda (pair) (eq (first pair) slot)) done-so-far))))
	(t (remprop frame 'done))))|#
;;;; ----------
;;;; (defun reset-done () (mapc ;'un-done *done*) (setq *done* nil) t)
;;(defun reset-done () (mapc ;'un-done (get-all-concepts)) t)
;; More efficient
(TRACE-LISP (DEFINE RESET-DONE NIL (trace-defun 'RESET-DONE NIL (RET (TRACE-PROGN (MAPC #'UN-DONE *NOTED-DONE*) (CSETQ *NOTED-DONE* NIL) T)))))
(TRACE-LISP
 (DEFINE SHOW-DONE NIL
  (trace-defun 'SHOW-DONE NIL
   (RET
    (TRACE-PROGN
     (MAPC
      #'(LAMBDA (FRAME)
         (trace-defun '#:G15644 (FRAME)
          (RET
           (COND
            ((GET FRAME 'DONE) (KM-FORMAT T "~a:~%" FRAME)
             (MAPC
              #'(LAMBDA (SLOT+SITUATIONS)
                 (trace-defun '#:G15645 (SLOT+SITUATIONS)
                  (RET (KM-FORMAT T "     ~a~20T [in ~a]~%" (FIRST SLOT+SITUATIONS) (SECOND SLOT+SITUATIONS)))))
              (GATHER-BY-KEY (GET FRAME 'DONE))))))))
      (GET-ALL-CONCEPTS))
     T)))))
;;;; ======================================================================
;;;;	TESTING WHETHER A CLASS/INSTANCE IS USEFUL OR NOT...
;;;; Used to decide whether to do work in classification or not.
;;;; In practice, this isn't used now.
;;;; ======================================================================
(TRACE-LISP
 (DEFINE CLASS-HAS-SOMETHING-TO-SAY-ABOUT (INSTANCE SLOT &OPTIONAL SITUATION)
  (trace-defun 'CLASS-HAS-SOMETHING-TO-SAY-ABOUT (INSTANCE SLOT SITUATION)
   (RET (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION)) (FRAME-HAS-SOMETHING-TO-SAY-ABOUT INSTANCE SLOT 'MEMBER-PROPERTIES SITUATION))))))
;;;; We could be even more thorough here by also checking whether its classes have something to say about slot
(TRACE-LISP
 (DEFINE INSTANCE-HAS-SOMETHING-TO-SAY-ABOUT (INSTANCE SLOT &OPTIONAL SITUATION)
  (trace-defun 'INSTANCE-HAS-SOMETHING-TO-SAY-ABOUT (INSTANCE SLOT SITUATION)
   (RET (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION)) (FRAME-HAS-SOMETHING-TO-SAY-ABOUT INSTANCE SLOT 'OWN-PROPERTIES SITUATION))))))
(TRACE-LISP
 (DEFINE FRAME-HAS-SOMETHING-TO-SAY-ABOUT (FRAME SLOT FACET &OPTIONAL SITUATION)
  (trace-defun 'FRAME-HAS-SOMETHING-TO-SAY-ABOUT (FRAME SLOT FACET SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (CLET
      ((ALL-SITUATIONS
        (COND ((AND (NEQ SITUATION *GLOBAL-SITUATION*) (FLUENTP SLOT)) (CONS SITUATION (ALL-SUPERSITUATIONS SITUATION))) (T (LIST *GLOBAL-SITUATION*))))
       (VISIBLE-THEORIES (VISIBLE-THEORIES)))
      (SOME
       #'(LAMBDA (SITUATION)
          (trace-defun '#:G15646 (SITUATION)
           (RET
            (SOME #'(LAMBDA (SUBSLOT) (trace-defun '#:G15647 (SUBSLOT) (RET (GET-VALS FRAME SUBSLOT :FACET FACET :SITUATION SITUATION))))
             (CONS SLOT (ALL-SUBSLOTS SLOT))))))
       (APPEND ALL-SITUATIONS VISIBLE-THEORIES))))))))
;;;; ======================================================================
;;;;			(RE)CLASSIFICATION OF INSTANCES
;;;; ======================================================================
#|If it's a new/redefined frame, should classify it.
If it has extra values through unification, should reclassify it.
If it has an extra value through installation of inverses, do reclassify it
	(see kb/test1.kb)
If it is just having existing expressions computed into values, don't reclassify it.|#
;;;; Wrapper to limit tracing....
;;;; [1] slot-of-interest as option: classify is never called now giving this argument. But if it was, only consider 
;;;;     possible-new-parent classes which have something explicit to offer for slot's value. 10/23/00 drop 
;;;;     this for now.
;;;; [2] slot-that-changed: Only do reclassification work if slot-that-changed might directly affect the class.
;;;; NEW: 9/14/00 - ONLY do classification in the global situation
;;;; 4/13/01 - *am-classifying* - don't classify while classifying
;;;; [3] 'unspecified, to distinguish from :slots-that-changed NIL
(TRACE-LISP
 (DEFINE CLASSIFY (INSTANCE &REST LKEYS)
  (trace-defun 'CLASSIFY (INSTANCE LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED SLOT-OF-INTEREST) (init-keyval SLOTS-THAT-CHANGED 'UNSPECIFIED) 
     (COND
      ((AND (CLASSIFICATION-ENABLED) *ARE-SOME-DEFINITIONS* (OR (AM-IN-GLOBAL-SITUATION) *CLASSIFY-IN-LOCAL-SITUATIONS*)
        (OR *RECURSIVE-CLASSIFICATION* (CNOT *AM-CLASSIFYING*)))
       (CLET ((WAS-CLASSIFYING *AM-CLASSIFYING*)) (CSETQ *AM-CLASSIFYING* T)
        (COND
         ((AND (TRACEP) (CNOT (TRACECLASSIFYP))) (SUSPEND-TRACE)
          (CLASSIFY0 INSTANCE :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED :SLOT-OF-INTEREST SLOT-OF-INTEREST) (UNSUSPEND-TRACE))
         (T (CLASSIFY0 INSTANCE :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED :SLOT-OF-INTEREST SLOT-OF-INTEREST)))
        (CSETQ *AM-CLASSIFYING* WAS-CLASSIFYING)))))))))
(TRACE-LISP
 (DEFINE CLASSIFY0 (INSTANCE &REST LKEYS)
  (trace-defun 'CLASSIFY0 (INSTANCE LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED SLOT-OF-INTEREST)
     (COND ((CNOT (KB-OBJECTP INSTANCE)) (REPORT-ERROR 'USER-ERROR "Attempt to classify a non-kb-object ~a!~%" INSTANCE))
      ((IS-AN-INSTANCE INSTANCE) 
       (CLET ((ALL-PARENTS (ALL-CLASSES INSTANCE)))  
        (COND
         ((SOME
           #'(LAMBDA (PARENT)
              (trace-defun '#:G15648 (PARENT)
               (RET
                (OR (CLASSIFY-AS-MEMBER INSTANCE PARENT :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED :SLOT-OF-INTEREST SLOT-OF-INTEREST)
                 (CLASSIFY-AS-COREFERENTIAL INSTANCE PARENT :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED :SLOT-OF-INTEREST SLOT-OF-INTEREST)))))
           ALL-PARENTS)
           (CLASSIFY0 INSTANCE :SLOTS-THAT-CHANGED 'UNSPECIFIED  :SLOT-OF-INTEREST SLOT-OF-INTEREST)))))))))))
;;;; ----------------------------------------------------------------------
;;;; (I) CLASSIFY INSTANCE AS BEING A MEMBER OF A CLASS
;;;; ----------------------------------------------------------------------
;;;; [1] Efficiency - if instance is explicitly (<> Parent), or (<> SubParent) then don't go and test further.
;;;; [2] Quick lookahead check
(TRACE-LISP
 (DEFINE CLASSIFY-AS-MEMBER (INSTANCE PARENT &REST LKEYS)
  (trace-defun 'CLASSIFY-AS-MEMBER (INSTANCE PARENT LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED SLOT-OF-INTEREST)
     (SOME
      #'(LAMBDA (POSSIBLE-NEW-PARENT)
         (trace-defun '#:G15649 (POSSIBLE-NEW-PARENT)
          (RET
           (COND
            ((AND (MIGHT-BE-MEMBER INSTANCE POSSIBLE-NEW-PARENT) (CNOT (DISJOINT-CLASS-SETS0 (IMMEDIATE-CLASSES INSTANCE) (LIST POSSIBLE-NEW-PARENT))) 
              (CNOT (CL-ISA INSTANCE POSSIBLE-NEW-PARENT)) 
              (TEST-VAL-CONSTRAINTS POSSIBLE-NEW-PARENT  (EXTRACT-CONSTRAINTS (GET-VALS INSTANCE '|instance-of| :SITUATION *GLOBAL-SITUATION*))
               'REMOVE-SUBSUMERS-SLOT :MODE 'CONSISTENT)
              (OR (NULL SLOT-OF-INTEREST) (CLASS-HAS-SOMETHING-TO-SAY-ABOUT POSSIBLE-NEW-PARENT SLOT-OF-INTEREST)))
             (TRY-CLASSIFYING INSTANCE POSSIBLE-NEW-PARENT :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED))))))
      (GET PARENT 'DEFINED-SUBCLASSES)))))))
;;;; [1] e.g., slotsvals = ((instance-of (Chemical-Entity)) (has-chemical-name ("Tellurium")))
;;;; [1] or  = ((instance-of (Chemical)) (has-basic-structural-unit ((a Zn (@ Zn-Substance has-basic-structural-unit)))))
(TRACE-LISP (DEFINE MIGHT-BE-MEMBER (INSTANCE PARENT) (trace-defun 'MIGHT-BE-MEMBER (INSTANCE PARENT) (RET ))))
;;;; ----------
;;;; The hierarchy looks:       parent (eg. put)
;;;;                           /                \
;;;;                  instance (eg. _put12)      possible-new-parent (eg. tell)
;;;;
;;;; [1] Remove unifiable-with-expr -- this shortcut wasn't working as it doesn't check constraints on the classes (here Thing)
;;;; [2] must check class consistency also!
(TRACE-LISP
 (DEFINE TRY-CLASSIFYING (INSTANCE POSSIBLE-NEW-PARENT &REST LKEYS)
  (trace-defun 'TRY-CLASSIFYING (INSTANCE POSSIBLE-NEW-PARENT LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED)
     (MULTIPLE-VALUE-BIND (SATISFIEDP EXPLANATION) (SATISFIES-DEFINITION INSTANCE POSSIBLE-NEW-PARENT :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED)
      (COND
       (SATISFIEDP  
        (COND
         ((KM0
           `(,INSTANCE &?
             (|a| ,POSSIBLE-NEW-PARENT |with| ,@(GET-SLOTSVALS POSSIBLE-NEW-PARENT :FACET 'MEMBER-PROPERTIES :SITUATION *GLOBAL-SITUATION*))))
          
          (COND
           ((CHECK-CLASSIFICATION-WITH-USER INSTANCE POSSIBLE-NEW-PARENT)
            (CSETQ *STATISTICS-CLASSIFICATIONS-SUCCEEDED* (1+ *STATISTICS-CLASSIFICATIONS-SUCCEEDED*))
            (ADD-IMMEDIATE-CLASS INSTANCE POSSIBLE-NEW-PARENT EXPLANATION) T)
           (T (ADD-VAL INSTANCE '|instance-of| `(<> ,POSSIBLE-NEW-PARENT) NIL  (TARGET-SITUATION (CURR-SITUATION) INSTANCE '|instance-of|)) NIL)))
         (T (MAKE-COMMENT "~a satisfies definition of ~a," INSTANCE POSSIBLE-NEW-PARENT)
          (MAKE-COMMENT "...but classes/properties clash!! So reclassification not made.")))))))))))
;;;; This is a dummy procedure, which can then be redefined in applications where the interaction is required.
(TRACE-LISP
 (DEFINE CHECK-CLASSIFICATION-WITH-USER (INSTANCE POSSIBLE-NEW-PARENT)
  (trace-defun 'CHECK-CLASSIFICATION-WITH-USER (INSTANCE POSSIBLE-NEW-PARENT)
   (RET (TRACE-PROGN (DECLARE (IGNORE INSTANCE POSSIBLE-NEW-PARENT)) T)))))
;;;; explanation for X isa Car is of form (every Car has-definition (instance-of (Vehicle)) (parts ((a Wheel) (a Wheel))))
;;;; This is very different from the encoded explanations of a path + expression, i.e., here we record the expression directly.
(TRACE-LISP
 (DEFINE ADD-IMMEDIATE-CLASS (INSTANCE NEW-IMMEDIATE-PARENT EXPLANATION)
  (trace-defun 'ADD-IMMEDIATE-CLASS (INSTANCE NEW-IMMEDIATE-PARENT EXPLANATION)
   (RET
    (CLET ((OLD-CLASSES (IMMEDIATE-CLASSES INSTANCE)) (NEW-CLASSES (REMOVE-SUBSUMERS (CONS NEW-IMMEDIATE-PARENT OLD-CLASSES))))
     (MAKE-COMMENT "~a satisfies definition of ~a," INSTANCE NEW-IMMEDIATE-PARENT)
     (MAKE-COMMENT "so changing ~a's classes from ~a to ~a" INSTANCE OLD-CLASSES NEW-CLASSES) 
     (ADD-VAL INSTANCE '|instance-of| NEW-IMMEDIATE-PARENT T  (TARGET-SITUATION (CURR-SITUATION) INSTANCE '|instance-of| (LIST NEW-IMMEDIATE-PARENT))) 
     (RECORD-EXPLANATION-FOR `(|the| |instance-of| |of| ,INSTANCE) NEW-IMMEDIATE-PARENT EXPLANATION :SITUATION *GLOBAL-SITUATION*) 
     (MAKE-ASSERTIONS INSTANCE)  (UN-DONE INSTANCE))))))
;; all vals to be recomputed now - now in add-slotsvals; later: No!
;;;; (satisfies-definition '_get32 'db-lookup)
;;;; Can we make _get32, a specialization of get, into a specialization of
;;;; db-lookup?
;;;; Returns *two* values (i) a satisfied flag (ii) the definition that was satisfied (for explanatory purposes)
(TRACE-LISP
 (DEFINE SATISFIES-DEFINITION (INSTANCE CLASS &REST LKEYS)
  (trace-defun 'SATISFIES-DEFINITION (INSTANCE CLASS LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED)
     (CLET ((DEFINITIONAL-SLOTSVALS (BIND-SELF (GET-SLOTSVALS CLASS :FACET 'MEMBER-DEFINITION :SITUATION *GLOBAL-SITUATION*) INSTANCE)))
      (COND
       ((OR *INDIRECT-CLASSIFICATION* (EQ SLOTS-THAT-CHANGED 'UNSPECIFIED) 
         (CL-INTERSECTION SLOTS-THAT-CHANGED (MAPCAR #'SLOT-IN DEFINITIONAL-SLOTSVALS)))
         (KM-TRACE 'COMMENT "CLASSIFY: ~a has just been created/modified. Is ~a now a ~a?"  INSTANCE INSTANCE CLASS)
        (CSETQ *STATISTICS-CLASSIFICATIONS-ATTEMPTED* (1+ *STATISTICS-CLASSIFICATIONS-ATTEMPTED*))
        (CLET ((DESCRIPTION `'(|a| |Thing| |with| ,@DEFINITIONAL-SLOTSVALS)) (SATISFIEDP (KM0 `(,INSTANCE |is| ,DESCRIPTION))))
         (COND (*DEVELOPER-MODE* (KM-FORMAT T "#")))
         (COND (SATISFIEDP (KM-TRACE 'COMMENT "CLASSIFY: ~a *is* a ~a!" INSTANCE CLASS))
          (T (KM-TRACE 'COMMENT "CLASSIFY: ~a is not a ~a." INSTANCE CLASS)))
         (VALUES SATISFIEDP `(|every| ,CLASS |has-definition| ,@DEFINITIONAL-SLOTSVALS)))))))))))
;;;; ----------------------------------------------------------------------
;;;; (II) CLASSIFY INSTANCE AS BEING COREFERENTIAL WITH ANOTHER INSTANCE
;;;; ----------------------------------------------------------------------
#|This is for equating coreferential instances, eg.

	bright-color IS red

	(Red has
	   (definition (((Self isa Color) and ((Self is) = Bright)))))

	(a Color with (is (Bright)))
	-> _Color32 unifies with Red
	-> Red

BUT: Suppose an instance satisfies *two* different instances' definitions?
In fact, KM will prevent you doing this. The first classification will cause
_Color34 to be unified to Red. The second will classify Red as Another-red,
but the unification of these two isn't permitted.|#
(TRACE-LISP
 (DEFINE CLASSIFY-AS-COREFERENTIAL (INSTANCE0 PARENT &REST LKEYS)
  (trace-defun 'CLASSIFY-AS-COREFERENTIAL (INSTANCE0 PARENT LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED SLOT-OF-INTEREST)
     (CLET ((INSTANCE (DEREFERENCE INSTANCE0)))
      (SOME
       #'(LAMBDA (POSSIBLE-COREFERENTIAL-INSTANCE)
          (trace-defun '#:G15651 (POSSIBLE-COREFERENTIAL-INSTANCE)
           (RET
            (COND
             ((AND (CNOT (EQ INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE)) 
               (OR (NULL SLOT-OF-INTEREST) (INSTANCE-HAS-SOMETHING-TO-SAY-ABOUT POSSIBLE-COREFERENTIAL-INSTANCE SLOT-OF-INTEREST)))
              (TRY-EQUATING INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED))))))
       (GET PARENT 'DEFINED-INSTANCES))))))))
(TRACE-LISP
 (DEFINE TRY-EQUATING (INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE &REST LKEYS)
  (trace-defun 'TRY-EQUATING (INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED)
     (COND
      ((SATISFIES-DEFINITION2 INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE :SLOTS-THAT-CHANGED SLOTS-THAT-CHANGED)
       (UNIFY-WITH-INSTANCE INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE))))))))
;; [1]. Just doing (X & Y) doesn't fail, 
(TRACE-LISP
 (DEFINE UNIFY-WITH-INSTANCE (INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE)
  (trace-defun 'UNIFY-WITH-INSTANCE (INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE)
   (RET
    (TRACE-PROGN (MAKE-COMMENT "~a satisfies definition of ~a," INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE)
     (MAKE-COMMENT "so unifying ~a with ~a" INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE)
     (CSETQ *STATISTICS-CLASSIFICATIONS-SUCCEEDED* (1+ *STATISTICS-CLASSIFICATIONS-SUCCEEDED*))
     (COND ((KM0 `(,INSTANCE & ,POSSIBLE-COREFERENTIAL-INSTANCE))  (UN-DONE INSTANCE)) 
      (T (REPORT-ERROR 'USER-ERROR "~a satisfies definition of ~a but won't unify with it!~%" INSTANCE POSSIBLE-COREFERENTIAL-INSTANCE))))))))
(TRACE-LISP
 (DEFINE SATISFIES-DEFINITION2 (INSTANCE POSS-COREF-INSTANCE &REST LKEYS)
  (trace-defun 'SATISFIES-DEFINITION2 (INSTANCE POSS-COREF-INSTANCE LKEYS)
   (RET
    (CLET (SLOTS-THAT-CHANGED)
     (CLET ((DEFINITIONAL-SLOTSVALS (BIND-SELF (GET-SLOTSVALS POSS-COREF-INSTANCE :FACET 'OWN-DEFINITION :SITUATION *GLOBAL-SITUATION*) INSTANCE)))
      (COND
       ((OR *INDIRECT-CLASSIFICATION* (EQ SLOTS-THAT-CHANGED 'UNSPECIFIED)
         (CL-INTERSECTION SLOTS-THAT-CHANGED (MAPCAR #'SLOT-IN DEFINITIONAL-SLOTSVALS)))
        (KM-TRACE 'COMMENT "CLASSIFY: ~a has just been created/modified. Is ~a now = ~a?" INSTANCE INSTANCE POSS-COREF-INSTANCE)
        (CSETQ *STATISTICS-CLASSIFICATIONS-ATTEMPTED* (1+ *STATISTICS-CLASSIFICATIONS-ATTEMPTED*))
        (CLET ((DESCRIPTION `'(|a| |Thing| |with| ,@DEFINITIONAL-SLOTSVALS)) (SATISFIEDP (KM0 `(,INSTANCE |is| ,DESCRIPTION))))
         (COND (*DEVELOPER-MODE* (KM-FORMAT T "#")))
         (COND (SATISFIEDP (KM-TRACE 'COMMENT "CLASSIFY: ~a = ~a!" INSTANCE POSS-COREF-INSTANCE))
          (T (KM-TRACE 'COMMENT "CLASSIFY: ~a = ~a." INSTANCE POSS-COREF-INSTANCE)))
         SATISFIEDP)))))))))
;;;; ======================================================================
;;;;			TAXONOMIC OPERATIONS
;;;; ======================================================================
;;;; check frame isa genframe. Returns frame.
;;;; (isa x x)	returns nil
(TRACE-LISP
 (DEFINE CL-ISA (INSTANCE CLASS &OPTIONAL SITUATION)
  (trace-defun 'CL-ISA (INSTANCE CLASS SITUATION)
   (RET (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION)) (INSTANCE-OF INSTANCE CLASS SITUATION))))))
;; synonym
(TRACE-LISP
 (DEFINE INSTANCE-OF (INSTANCE TARGET-CLASS &OPTIONAL SITUATION)
  (trace-defun 'INSTANCE-OF (INSTANCE TARGET-CLASS SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (CLET ((ITS-CLASSES (IMMEDIATE-CLASSES INSTANCE :SITUATION SITUATION)))
      (COND ((CL-MEMBER TARGET-CLASS ITS-CLASSES) INSTANCE)
       ((AND (CNOT (NULL ITS-CLASSES))
         (SOME #'(LAMBDA (ITS-CLASS) (trace-defun '#:G15652 (ITS-CLASS) (RET (IS-SUBCLASS-OF ITS-CLASS TARGET-CLASS)))) ITS-CLASSES))
        INSTANCE))))))))
(TRACE-LISP
 (DEFINE IS-SUBCLASS-OF (CLASS TARGET-CLASS &REST LKEYS)
  (trace-defun 'IS-SUBCLASS-OF (CLASS TARGET-CLASS LKEYS)
   (RET
    (CLET (PATH-SO-FAR)
     (COND ((EQ CLASS TARGET-CLASS) CLASS) ((EQ CLASS '|Thing|) NIL)
      ((CL-MEMBER CLASS PATH-SO-FAR)
       (REPORT-ERROR 'USER-ERROR "You have a cycle in the taxonomy (not allowed)!~%~a~%" (COMMAED-LIST (REVERSE (CONS CLASS PATH-SO-FAR)) '->)))
      ((AND (KB-OBJECTP CLASS) (KB-OBJECTP TARGET-CLASS))
       (CLET ((SUPERCLASSES (IMMEDIATE-SUPERCLASSES CLASS)))
        (COND ((CL-MEMBER TARGET-CLASS SUPERCLASSES) CLASS)
         ((AND (CNOT (NULL SUPERCLASSES))
           (SOME
            #'(LAMBDA (SUPERCLASS)
               (trace-defun '#:G15653 (SUPERCLASS) (RET (IS-SUBCLASS-OF SUPERCLASS TARGET-CLASS :PATH-SO-FAR (CONS CLASS PATH-SO-FAR)))))
            SUPERCLASSES))
          CLASS))))))))))
;;;; Shadow of KM. Find immediate generalizations of a frame.
;;;; The top generalization is ;$Thing
;;;; [1] instance-of is treated as a *Non-Fluent for Slots and Situations, and so we must also check the global
;;;;     situation here. For cases where it's a fluent, it's value will be cached in the local situation.
;;;; [2] :enforce-constraints - if we always enforce constraints, the system will easily fall into infinite
;;;;	recursion. So we restrict how much this is allowed. Here we just allow it when the user explicitly
;;;;     requests it.
;;;; [3] enforce-constraints may change the parent classes, so we then must recheck what the parent
;;;;     classes are (this recursive call WITHOUT constraint checking this time, to prevent looping)
(TRACE-LISP
 (DEFINE IMMEDIATE-CLASSES (INSTANCE &REST LKEYS)
  (trace-defun 'IMMEDIATE-CLASSES (INSTANCE LKEYS)
   (RET
    (CLET (SITUATION ENFORCE-CONSTRAINTS) (init-keyval SITUATION (CURR-SITUATION))  (DECLARE (IGNORE ENFORCE-CONSTRAINTS))
     (COND ((INTEGERP INSTANCE) '(|Integer|)) ((NUMBERP INSTANCE) '(|Number|))
      ((ASSOC INSTANCE *BUILT-IN-INSTANCE-OF-LINKS*)  (LIST (SECOND (ASSOC INSTANCE *BUILT-IN-INSTANCE-OF-LINKS*)))) 
      ((CL-MEMBER INSTANCE *BUILT-IN-SET-AGGREGATION-SLOTS*) '(|Set-Aggregation-Slot|))
      ((CL-MEMBER INSTANCE *BUILT-IN-SEQ-AGGREGATION-SLOTS*) '(|Seq-Aggregation-Slot|))
      ((CL-MEMBER INSTANCE *BUILT-IN-BAG-AGGREGATION-SLOTS*) '(|Bag-Aggregation-Slot|)) ((CL-MEMBER INSTANCE *BUILT-IN-SLOTS*) '(|Slot|))
      ((CLASS-DESCRIPTIONP INSTANCE) '(|Class|)) ((QUOTED-EXPRESSIONP INSTANCE) '(|Quoted-Expression|)) ((STRINGP INSTANCE) '(|String|)) 
      ((KM-SEQP INSTANCE) '(|Sequence|)) ((KM-BAGP INSTANCE) '(|Bag|)) ((KM-PAIRP INSTANCE) '(|Pair|)) ((KM-TRIPLEP INSTANCE) '(|Triple|))
      ((KM-STRUCTURED-LIST-VALP INSTANCE)  (IMMEDIATE-CLASSES (ARG1OF INSTANCE)))  
      ((OR (CNOT (INERTIAL-FLUENTP '|instance-of|))  (EQ SITUATION *GLOBAL-SITUATION*)) 
       (CLET
        ((VALS+CONSTRAINTS
          (APPEND (COND (*ARE-SOME-DEFINITIONS* (GET-VALS INSTANCE '|instance-of| :FACET 'OWN-DEFINITION :SITUATION *GLOBAL-SITUATION*)))
           (GET-VALS INSTANCE '|instance-of| :FACET 'OWN-PROPERTIES :SITUATION *GLOBAL-SITUATION*)))
         (CONSTRAINTS (EXTRACT-CONSTRAINTS VALS+CONSTRAINTS)) (VALS0 (REMOVE-CONSTRAINTS VALS+CONSTRAINTS))
         (VALS
          (COND ((EVERY #'KB-OBJECTP VALS0) VALS0)
           (T (KM-TRACE 'COMMENT "Computing the parent classes of ~a..." INSTANCE)
            (CLET ((VALS1 (REMOVE-SUBSUMERS (KM0 (VALS-TO-VAL VALS0))))) (PUT-VALS INSTANCE '|instance-of| (APPEND VALS1 CONSTRAINTS))
             (NOTE-DONE INSTANCE '|instance-of|) VALS1)))))
        (COND     (VALS) ('(|Thing|)))))
      
      ((ALREADY-DONE INSTANCE '|instance-of|)
       (OR (REMOVE-CONSTRAINTS (GET-VALS INSTANCE '|instance-of| :SITUATION SITUATION))
        (REMOVE-CONSTRAINTS (GET-VALS INSTANCE '|instance-of| :SITUATION *GLOBAL-SITUATION*))  '(|Thing|)))
      (T (PROG1 (IMMEDIATE-CLASSES0 INSTANCE :SITUATION SITUATION)  (NOTE-DONE INSTANCE '|instance-of|)))))))))
;;;; REVISED: We must do more work here when there are situations.
(TRACE-LISP
 (DEFINE IMMEDIATE-CLASSES0 (INSTANCE &REST LKEYS)
  (trace-defun 'IMMEDIATE-CLASSES0 (INSTANCE LKEYS)
   (RET
    (CLET (SITUATION) (init-keyval SITUATION (CURR-SITUATION))
     (CLET
      ((LOCAL-CLASSES-AND-CONSTRAINTS (GET-VALS INSTANCE '|instance-of| :SITUATION SITUATION))
       (LOCAL-CONSTRAINTS (EXTRACT-CONSTRAINTS LOCAL-CLASSES-AND-CONSTRAINTS))
       (SUPERSITUATION-CLASSES
        (MY-MAPCAN
         #'(LAMBDA (SUPERSITUATION) (trace-defun '#:G15654 (SUPERSITUATION) (RET (IMMEDIATE-CLASSES INSTANCE :SITUATION SUPERSITUATION))))
         (IMMEDIATE-SUPERSITUATIONS SITUATION)))
       (PROJECTED-CLASSES (PROJECTED-CLASSES INSTANCE SITUATION LOCAL-CONSTRAINTS))
       (DEFINITIONAL-CLASSES (COND (*ARE-SOME-DEFINITIONS* (GET-VALS INSTANCE '|instance-of| :FACET 'OWN-DEFINITION :SITUATION SITUATION)))))
      (COND
       ((SOME #'(LAMBDA (CLASS) (trace-defun '#:G15655 (CLASS) (RET ))) (APPEND SUPERSITUATION-CLASSES PROJECTED-CLASSES DEFINITIONAL-CLASSES))
        (CLET
         ((LOCAL-CLASSES (REMOVE-CONSTRAINTS LOCAL-CLASSES-AND-CONSTRAINTS))
          (ALL-CLASSES (REMOVE-SUBSUMERS (APPEND LOCAL-CLASSES SUPERSITUATION-CLASSES PROJECTED-CLASSES DEFINITIONAL-CLASSES))))
         (PUT-VALS INSTANCE '|instance-of| (APPEND LOCAL-CONSTRAINTS ALL-CLASSES) :SITUATION SITUATION)  ALL-CLASSES))
       ((REMOVE-CONSTRAINTS LOCAL-CLASSES-AND-CONSTRAINTS)) 
       ((AND (CHECKKBP) (CNOT (KNOWN-FRAME INSTANCE))) (REPORT-ERROR 'USER-WARNING "Object ~a not declared in KB.~%" INSTANCE) '(|Thing|))    
       (T (COND ((CHECKKBP) (REPORT-ERROR 'USER-WARNING "Parent (superclasses/instance-of) for ~a not declared.~%" INSTANCE))) '(|Thing|)))))))))
(TRACE-LISP
 (DEFINE PROJECTED-CLASSES (INSTANCE SITUATION LOCAL-CLASSES-AND-CONSTRAINTS)
  (trace-defun 'PROJECTED-CLASSES (INSTANCE SITUATION LOCAL-CLASSES-AND-CONSTRAINTS)
   (RET
    (CLET ((PREV-SITUATION (PREV-SITUATION SITUATION)))
     (COND
      (PREV-SITUATION
       (FILTER-USING-CONSTRAINTS (IMMEDIATE-CLASSES INSTANCE :SITUATION PREV-SITUATION) LOCAL-CLASSES-AND-CONSTRAINTS '|prev-situation|))))))))
;;;; ======================================================================
(TRACE-LISP
 (DEFINE IMMEDIATE-SUPERCLASSES (CLASS)
  (trace-defun 'IMMEDIATE-SUPERCLASSES (CLASS)
   (RET
    (COND ((EQ CLASS '|Thing|) NIL)    
     #| Revised version below, makes Thing superclass be a default rather than hard-wired.
	((rest (assoc class *built-in-superclass-links*))		; e.g. (immediate-superclasses 'X$Integer) -> (Number)

	 (let ((new-class (rest (assoc class *built-in-superclass-links*)))
	       (old-class (cond ((and (member class *built-in-classes*)
				      (not (member class *built-in-classes-with-no-built-in-superclasses*))) ; Aggregate
				 (or (rest (assoc class *built-in-superclass-links*))		; e.g. (immediate-superclasses 'X$Integer) -> (Number)
				     'X$(Thing))))))
	   (cond ((neq old-class new-class) (km-format t "Old class = ~a, New class = ~a~%" old-class new-class)))
	   new-class))|#
      ((REST (ASSOC CLASS *BUILT-IN-SUPERCLASS-LINKS*)))  ((CLASS-DESCRIPTIONP CLASS) (LIST (FIRST (CLASS-DESCRIPTIONP CLASS)))) 
     ((CLET ((SUPERCLASSES (GET-VALS CLASS '|superclasses| :SITUATION *GLOBAL-SITUATION*)))
       (COND
        ((CL-MEMBER CLASS SUPERCLASSES) (REPORT-ERROR 'USER-ERROR "Cycle in the KB! ~a is its own superclass!" CLASS) (CL-REMOVE CLASS SUPERCLASSES))
        (T SUPERCLASSES))))
       ((AND (CHECKKBP) (CNOT (KNOWN-FRAME CLASS))) (REPORT-ERROR 'USER-WARNING "Class ~a not declared in KB.~%" CLASS) '(|Thing|)) 
     ((CHECKKBP) (REPORT-ERROR 'USER-WARNING "superclasses not declared for `~a'.~%I'll assume superclass `Thing'.~%" CLASS) '(|Thing|))
     (T '(|Thing|)))))))
;;;; ----------
(TRACE-LISP (DEFINE IMMEDIATE-SUBCLASSES (CLASS) (trace-defun 'IMMEDIATE-SUBCLASSES (CLASS) (RET ))))
;;;; ----------
;;;; Returns subclasses of Thing, excluding built-in classes which aren't ever used in the KB.
;;;; Here we infer subclasses for those unplaced classes.
;;;; [1,2,3] Three pieces of evidence that the object is a class: [1] it has subclasses [2] it has instances [3] it's a built-in class.
;;;; [4] These two built-in classes *don't* have Thing as their superclass.
;;;; [5] Special case: If Integer (say) is explicitly in the KB, but Number isn't, then we should introduce Number in the retrieved
;;;; 	taxonomy for printing and question-answering.
(TRACE-LISP
 (DEFINE SUBCLASSES-OF-THING NIL
  (trace-defun 'SUBCLASSES-OF-THING NIL
   (RET
    (CLET
     ((ALL-OBJECTS (REMOVE-IF-NOT #'KB-OBJECTP (DEREFERENCE (GET-ALL-CONCEPTS))))
      (UNPLACED-CLASSES+INSTANCES 
       (REMOVE-IF
        #'(LAMBDA (CONCEPT)
           (trace-defun '#:G15657 (CONCEPT)
            (RET
             (CLET ((SUPERCLASSES (GET-VALS CONCEPT '|superclasses| :SITUATION *GLOBAL-SITUATION*)))
              (OR (AND SUPERCLASSES (CNOT (CL-EQUAL SUPERCLASSES '(|Thing|))))  (ASSOC CONCEPT *BUILT-IN-SUPERCLASS-LINKS*))))))
         ALL-OBJECTS))
      
      (UNPLACED-CLASSES
       (REMOVE-IF-NOT
        #'(LAMBDA (CONCEPT)
           (trace-defun '#:G15658 (CONCEPT)
            (RET
             (OR (GET-VALS CONCEPT '|subclasses| :SITUATION *GLOBAL-SITUATION*)  (GET-VALS CONCEPT '|superclasses| :SITUATION *GLOBAL-SITUATION*)    
              (CL-MEMBER CONCEPT *BUILT-IN-CLASSES*)))))
         UNPLACED-CLASSES+INSTANCES))
      (EXTRA-CLASSES (MY-MAPCAN #'(LAMBDA (CLASS-SUPERCLASS) (trace-defun '#:G15659 (CLASS-SUPERCLASS) (RET ))) *BUILT-IN-SUPERCLASS-LINKS*)))
     (CL-REMOVE '|Thing| (APPEND EXTRA-CLASSES UNPLACED-CLASSES)))))))
;;;; ----------
;;(defun immediate-subslots (slot)
;;  (cond ((undeclared-slot slot) nil)		; supposed to be for efficiency, but slows it down!
;;	(t (find-vals slot ';$subslots))))
(TRACE-LISP
 (DEFINE IMMEDIATE-SUBSLOTS (SLOT)
  (trace-defun 'IMMEDIATE-SUBSLOTS (SLOT) (RET (COND  (*ARE-SOME-SUBSLOTS*  (GET-VALS SLOT '|subslots| :SITUATION *GLOBAL-SITUATION*)))))))
;;;; NB *doesn't* include slot.
(TRACE-LISP
 (DEFINE ALL-SUBSLOTS (SLOT)
  (trace-defun 'ALL-SUBSLOTS (SLOT)
   (RET (CLET ((IMMEDIATE-SUBSLOTS (IMMEDIATE-SUBSLOTS SLOT))) (APPEND IMMEDIATE-SUBSLOTS (MAPCAN #'ALL-SUBSLOTS IMMEDIATE-SUBSLOTS)))))))
(TRACE-LISP
 (DEFINE IMMEDIATE-SUPERSLOTS (SLOT)
  (trace-defun 'IMMEDIATE-SUPERSLOTS (SLOT) (RET (COND  (*ARE-SOME-SUBSLOTS*  (GET-VALS SLOT '|superslots| :SITUATION *GLOBAL-SITUATION*)))))))
;;;; This *doesn't* include slot in the list
(TRACE-LISP
 (DEFINE ALL-SUPERSLOTS (SLOT)
  (trace-defun 'ALL-SUPERSLOTS (SLOT)
   (RET (CLET ((IMMEDIATE-SUPERSLOTS (IMMEDIATE-SUPERSLOTS SLOT))) (APPEND IMMEDIATE-SUPERSLOTS (MAPCAN #'ALL-SUPERSLOTS IMMEDIATE-SUPERSLOTS)))))))
;;;; ======================================================================
#| [1] Misses inheritance! Probably not important, but better cover that case -> [2]
;;; [2] km-unique0, as may be a path there (unlikely!, did in previous test suites though)
;;; [3] Don't consider it an error to be missing a :args structure, so we can say (Y1999 has (next-situation (Y2000))) for short.
(defun prev-situation (situation)
; (let ( (prev-situation-args-structure 
;	          (get-vals situation 'X$prev-situation :situation *global-situation*)) ) ; eg ((:args _Sit23 _Action23)) [1]
  (let ( (prev-situation-args-structure 
	     (km-unique0 (get-unique-val situation 'X$prev-situation 
					:situation *global-situation* 
					) ; eg ((:args _Sit23 _Action23)) [2]
			)) )								; [3]
    (cond ((km-argsp prev-situation-args-structure)
	   (arg1of prev-situation-args-structure))
	  (t prev-situation-args-structure))))	|#
;;;; [1] Misses inheritance! Probably not important, but better cover that case -> [2]
;;;; [2] km-unique0, as may be a path there (unlikely!, did in previous test suites though)
;;;; [3] Don't consider it an error to be missing a :args structure, so we can say (Y1999 has (next-situation (Y2000))) for short.
;;;; RETURNS: NIL if no prev situation, the atomic prev situation otherwise
(TRACE-LISP
 (DEFINE PREV-SITUATION (SITUATION)
  (trace-defun 'PREV-SITUATION (SITUATION)
   (RET
    (CLET ((PREV-SITUATION-ARGS-STRUCTURES (GET-VALS SITUATION '|prev-situation| :SITUATION *GLOBAL-SITUATION*)))    
     (COND ((NULL PREV-SITUATION-ARGS-STRUCTURES) NIL)
      ((SINGLETONP PREV-SITUATION-ARGS-STRUCTURES)
       (CLET ((PREV-SITUATION-ARGS-STRUCTURE (KM-UNIQUE0 (FIRST PREV-SITUATION-ARGS-STRUCTURES))))
        (COND
         ((CNOT (CL-EQUAL PREV-SITUATION-ARGS-STRUCTURE (FIRST PREV-SITUATION-ARGS-STRUCTURES)))
          (PUT-VALS SITUATION '|prev-situation| (LIST PREV-SITUATION-ARGS-STRUCTURE) :SITUATION *GLOBAL-SITUATION*) 
          (NOTE-DONE SITUATION '|prev-situation|)))
        (COND ((KM-ARGSP PREV-SITUATION-ARGS-STRUCTURE)  (ARG1OF PREV-SITUATION-ARGS-STRUCTURE)) (T PREV-SITUATION-ARGS-STRUCTURE))))
      (T
       (REPORT-ERROR 'USER-ERROR "Situation ~a has multiple previous situations, but that isn't allowed!~%  (~a has (prev-situation ~a))~%" SITUATION
        SITUATION PREV-SITUATION-ARGS-STRUCTURES))))))))
;;; NB plural
;;;; Result is MAPCAN-SAFE
(TRACE-LISP
 (DEFINE NEXT-SITUATIONS (SITUATION)
  (trace-defun 'NEXT-SITUATIONS (SITUATION)
   (RET
    (CLET ((NEXT-SITUATION-ARGS-STRUCTURES (GET-VALS SITUATION '|next-situation| :SITUATION *GLOBAL-SITUATION*))) 
     (MAPCAR
      #'(LAMBDA (NEXT-SITUATION-ARGS-STRUCTURE)
         (trace-defun '#:G15660 (NEXT-SITUATION-ARGS-STRUCTURE)
          (RET
           (COND ((KM-ARGSP NEXT-SITUATION-ARGS-STRUCTURE) (ARG1OF NEXT-SITUATION-ARGS-STRUCTURE))
            ((KB-OBJECTP NEXT-SITUATION-ARGS-STRUCTURE) NEXT-SITUATION-ARGS-STRUCTURE)
            (T (REPORT-ERROR 'USER-ERROR "Can't work out next situation of ~a!" SITUATION))))))
      NEXT-SITUATION-ARGS-STRUCTURES))))))
;;;; INCLUDES situation
(TRACE-LISP
 (DEFINE ALL-NEXT-SITUATIONS (SITUATION)
  (trace-defun 'ALL-NEXT-SITUATIONS (SITUATION)
   (RET (COND ((NULL SITUATION) NIL) (T (CONS SITUATION (MAPCAN #'ALL-NEXT-SITUATIONS (NEXT-SITUATIONS SITUATION)))))))))
;;;; ========================================
;;;; before-situation of an event
(TRACE-LISP
 (DEFINE BEFORE-SITUATION (EVENT)
  (trace-defun 'BEFORE-SITUATION (EVENT)
   (RET
    (CLET ((BEFORE-SITUATION-ARGS-STRUCTURES (GET-VALS EVENT '|before-situation| :SITUATION *GLOBAL-SITUATION*)))    
     (COND ((NULL BEFORE-SITUATION-ARGS-STRUCTURES) NIL)
      ((SINGLETONP BEFORE-SITUATION-ARGS-STRUCTURES)
       (CLET ((BEFORE-SITUATION-ARGS-STRUCTURE (KM-UNIQUE0 (FIRST BEFORE-SITUATION-ARGS-STRUCTURES))))
        (COND
         ((CNOT (CL-EQUAL BEFORE-SITUATION-ARGS-STRUCTURE (FIRST BEFORE-SITUATION-ARGS-STRUCTURES)))
          (PUT-VALS EVENT '|before-situation| (LIST BEFORE-SITUATION-ARGS-STRUCTURE) :SITUATION *GLOBAL-SITUATION*) 
          (NOTE-DONE EVENT '|before-situation|)))
        (COND ((KM-ARGSP BEFORE-SITUATION-ARGS-STRUCTURE)  (ARG1OF BEFORE-SITUATION-ARGS-STRUCTURE)) (T BEFORE-SITUATION-ARGS-STRUCTURE))))
      (T
       (REPORT-ERROR 'USER-ERROR "Action ~a has multiple before situations, but that isn't allowed!~%  (~a has (before-situation ~a))~%" EVENT
        BEFORE-SITUATION-ARGS-STRUCTURES))))))))
;;;; ======================================================================
;;;;	BIND-SELF: Replace 'Self keyword with an instance name
;;;; 9/22/00 - but DON'T replace quoted Selfs
;;;; ======================================================================
#|Efficiency: bind-self1 appears, to my surprise, 1.5 times slower (2.2 sec/million) than 
bind-self2 (1.4 sec/million)!
(defun bind-self1 (expr self) (subst self 'Self expr))
(defun bind-self2 (frame self)
  (cond ((eq frame 'Self) self)
	((listp frame)				; [1]
	 (mapcar X'(lambda (x) (bind-self2 x self)) frame))
	(t frame)))

(defun test1 (n) (loop repeat n do (bind-self1 '(the cat sat on Self) 'test)))
(defun test2 (n) (loop repeat n do (bind-self2 '(the cat sat on Self) 'test)))|#
#|[1] a quoted expression has structure (quote <expr>) -- it should be guaranteed to be a pair, by the way the Lisp reader proceses "'" and "X,"
[2] Special case:
(a Person with (owns ('(a Car with (made-by (X,Self)))))) should return 
		... '(a Car with (made-by (_Person4)))
	not	... '(a Car with (made-by (X,_Person4)))

(showme (a Person with (likes ('(the age of X,Self)))))		-> (_Person15 has (likes ('(the age of _Person15))))
(showme (a Person with (likes ('X,Self))))			-> (_Person16 has (likes ('_Person16))
(showme (a Person with (likes ('(the sum of X,(1 + 1)))))) 	-> (_Person17 has (likes ('(the sum of X,(1 + 1)))))
(showme (a Person with (likes ('(the sum of X,(the age of (evaluate '(the likes of X,Self))))))))
		-> (_Person18 has (likes ('(the sum of X,(the age of (evaluate '(the likes of _Person18)))))))

[3] It turns out, you can sometimes have quotes within quotes, e.g. 
	(*definition-qn has
	  (answer-procedure ('X'(LAMBDA (CONCEPT) (SHOW-SLOT-VALUE CONCEPT 'text-def)))))
    So this isn't an error.
[4] SPECIAL CASE: (:triple ...) Self *doesn't* have to be explicitly unquoted, even though we treat it as if it's quoted.
    No special action is needed in the code here.|#
#|(defun bind-self (expr self &key in-quotes)
  (cond ((listp expr)				; [1]
	 (case (first expr)
	       (quote (list 'quote (bind-self (second expr) self :in-quotes t)))		; [3]
	       (unquote (cond (in-quotes (cond ((eq (second expr) 'X$Self) self)					; [2]
					       (t (list 'unquote (bind-self (second expr) self :in-quotes nil)))))	; [1]
			      (t (report-error 'user-error "An unquoted expression X,~a was encountered inside a non-quoted expression (not allowed!)~%"
					     (second expr)))))
	       (t (mapcar X'(lambda (x) (bind-self x self :in-quotes in-quotes)) expr))))
	((and (eq expr 'X$Self) (not in-quotes)) self)
	(t expr)))|#
;;;; EXECUTIVE DECISION 2/23/01 - Revert to the case where Self no longer has to be explicitly unquoted
(TRACE-LISP (DEFINE BIND-SELF (EXPR SELF) (trace-defun 'BIND-SELF (EXPR SELF) (RET (SUBST SELF '|Self| EXPR)))))
;;;; ======================================================================
;;;; Returns the most specific class(es) in a list
;;;; (remove-subsumers '(car vehicle car tree)) -> (car tree)
;;;; NOTE preserves order, so if there are no subsumers, then (remove-subsumers x) = x.
(TRACE-LISP
 (DEFINE REMOVE-SUBSUMERS (CLASSES)
  (trace-defun 'REMOVE-SUBSUMERS (CLASSES)
   (RET
    (CL-REMOVE-DUPLICATES
     (REMOVE-IF
      #'(LAMBDA (CLASS)
         (trace-defun '#:G15661 (CLASS)
          (RET
           (SOME
            #'(LAMBDA (OTHER-CLASS) (trace-defun '#:G15662 (OTHER-CLASS) (RET (AND (NEQ OTHER-CLASS CLASS) (IS-SUBCLASS-OF OTHER-CLASS CLASS)))))
            CLASSES))))
      CLASSES)
     :FROM-END T)))))
;;;; Returns the most general class(es) in a list
;;;; (remove-subsumees '(car vehicle car tree)) -> (vehicle tree)
;;;; NOTE preserves order, so if there are no subsumees, then (remove-subsumees x) = x.
(TRACE-LISP
 (DEFINE REMOVE-SUBSUMEES (CLASSES)
  (trace-defun 'REMOVE-SUBSUMEES (CLASSES)
   (RET
    (CL-REMOVE-DUPLICATES
     (REMOVE-IF
      #'(LAMBDA (CLASS)
         (trace-defun '#:G15663 (CLASS)
          (RET
           (SOME
            #'(LAMBDA (OTHER-CLASS) (trace-defun '#:G15664 (OTHER-CLASS) (RET (AND (NEQ OTHER-CLASS CLASS) (IS-SUBCLASS-OF CLASS OTHER-CLASS)))))
            CLASSES))))
      CLASSES)
     :FROM-END T)))))
;;;; (classes-subsume-classes '(vehicle expensive-thing) '(car very-expensive-thing))
;;;; AND
;;;; (classes-subsume-classes '(vehicle expensive-thing) '(car very-expensive-thing wheeled-thing))
;;;; case [1] should never be necessary, but just in case...
;;(defun classes-subsume-classes (classes1 classes2)
;;  (let ( (trimmed-classes2 (remove-subsumers classes2)) )	; [1] eg. (car thing) -> (car)
;;    (subsetp trimmed-classes2 (remove-subsumers (append classes1 trimmed-classes2)))))
;;;; Or more efficiently...every class1 has some class2 which is a subclass of it.
(TRACE-LISP
 (DEFINE CLASSES-SUBSUME-CLASSES (CLASSES1 CLASSES2)
  (trace-defun 'CLASSES-SUBSUME-CLASSES (CLASSES1 CLASSES2)
   (RET
    (EVERY
     #'(LAMBDA (CLASS1)
        (trace-defun '#:G15665 (CLASS1)
         (RET (SOME #'(LAMBDA (CLASS2) (trace-defun '#:G15666 (CLASS2) (RET (IS-SUBCLASS-OF CLASS2 CLASS1)))) CLASSES2))))
     CLASSES1)))))
;;;; ======================================================================
;;;;		AND FOR NORMAL SPECIALIZATION LINKS
;;;; ======================================================================
(TRACE-LISP
 (DEFINE ALL-CLASSES (INSTANCE)
  (trace-defun 'ALL-CLASSES (INSTANCE) (RET (CONS '|Thing| (REMOVE-DUPLICATES (MAPCAN #'ALL-SUPERCLASSES0 (IMMEDIATE-CLASSES INSTANCE))))))))
;;;; ----------
;;;; This *doesn't* include class in the list
(TRACE-LISP
 (DEFINE ALL-SUPERCLASSES (CLASS)
  (trace-defun 'ALL-SUPERCLASSES (CLASS)
   (RET (COND ((NEQ CLASS '|Thing|) (CONS '|Thing| (REMOVE-DUPLICATES (MY-MAPCAN #'ALL-SUPERCLASSES0 (IMMEDIATE-SUPERCLASSES CLASS))))))))))
;;;; Returns a *list* of superclasses, *including* class, but *not* including ;$Thing, and possibly with duplicates.
(TRACE-LISP
 (DEFINE ALL-SUPERCLASSES0 (CLASS &REST LKEYS)
  (trace-defun 'ALL-SUPERCLASSES0 (CLASS LKEYS)
   (RET
    (CLET (PATH-SO-FAR)
     (COND ((EQ CLASS '|Thing|) NIL) 
      ((CL-MEMBER CLASS PATH-SO-FAR)
       (REPORT-ERROR 'USER-ERROR "You have a cycle in the taxonomy (not allowed)!~%~a~%" (COMMAED-LIST (REVERSE (CONS CLASS PATH-SO-FAR)) '->)))
      (T (CONS CLASS (MY-MAPCAN #'(LAMBDA (C) (ALL-SUPERCLASSES0 C :PATH-SO-FAR (CONS CLASS PATH-SO-FAR))) (IMMEDIATE-SUPERCLASSES CLASS))))))))))
;;;; ----------
;;;; This *doesn't* include class in the list
(TRACE-LISP
 (DEFINE ALL-SUBCLASSES (CLASS)
  (trace-defun 'ALL-SUBCLASSES (CLASS) (RET (CL-REMOVE-DUPLICATES (MAPCAN #'ALL-SUBCLASSES0 (IMMEDIATE-SUBCLASSES CLASS)))))))
;;;; Returns a *list* of subclasses, *including* class, but *not* including ;$Thing, and possibly with duplicates.
(TRACE-LISP
 (DEFINE ALL-SUBCLASSES0 (CLASS &REST LKEYS)
  (trace-defun 'ALL-SUBCLASSES0 (CLASS LKEYS)
   (RET
    (CLET (PATH-SO-FAR)
     (COND
      ((CL-MEMBER CLASS PATH-SO-FAR)
       (REPORT-ERROR 'USER-ERROR "You have a cycle in the taxonomy (not allowed)!~%~a~%" (COMMAED-LIST (CONS CLASS PATH-SO-FAR) '->)))
      (T (CONS CLASS (MY-MAPCAN #'(LAMBDA (C) (ALL-SUBCLASSES0 C :PATH-SO-FAR (CONS CLASS PATH-SO-FAR))) (IMMEDIATE-SUBCLASSES CLASS))))))))))
#|Prob. more efficient, but doesn't spot cycles. 
(defun all-subclasses (class)
  (all-subclasses0 (list class)))

(defun all-subclasses0 (classes &optional subclasses-so-far)
  (cond 
   ((endp classes) subclasses-so-far)
   (t (let ( (class (first classes)) )
	(cond ((member class subclasses-so-far)
	       (all-subclasses0 (rest classes) subclasses-so-far))
	      (t (let ( (new-subclasses-so-far (all-subclasses0 (immediate-subclasses class) (cons class subclasses-so-far))) )
		   (all-subclasses0 (rest classes) new-subclasses-so-far))))))))|#
;;;; This *doesn't* include situation in the list
(TRACE-LISP
 (DEFINE ALL-SUPERSITUATIONS (SITUATION)
  (trace-defun 'ALL-SUPERSITUATIONS (SITUATION)
   (RET
    (COND
     ((NEQ SITUATION *GLOBAL-SITUATION*)
      (CONS *GLOBAL-SITUATION* (REMOVE-DUPLICATES (MAPCAN #'ALL-SUPERSITUATIONS0 (IMMEDIATE-SUPERSITUATIONS SITUATION))))))))))
;;;; Returns a *list* of situations, including situation but NOT including *global-situation*.
(TRACE-LISP
 (DEFINE ALL-SUPERSITUATIONS0 (SITUATION)
  (trace-defun 'ALL-SUPERSITUATIONS0 (SITUATION)
   (RET (COND ((EQ SITUATION *GLOBAL-SITUATION*) NIL)  (T (CONS SITUATION (MAPCAN #'ALL-SUPERSITUATIONS0 (IMMEDIATE-SUPERSITUATIONS SITUATION)))))))))
;;;; ======================================================================
;;;;			ALL-INSTANCES: find all instances of a class
;;;; ======================================================================
#|Includes dereferencing (in remove-dup-instances).
This is only used for:
	- (all-situations)
	- Handling a user's all-instances query
	- (mapc X'un-done (all-instances class))  after an (every ...) assertion. But this isn't quite
		right, we want to undo instances in class within a situation only too.
        - (all-instances 'X$Slot), for (showme-all instance) and (evaluate-all instance)
	- we should really use it for Partition also; sigh...
Thus, we can get away being inefficient!!|#
(TRACE-LISP
 (DEFINE CL-ALL-INSTANCES (CLASS)
  (trace-defun 'CL-ALL-INSTANCES (CLASS) (RET (CL-REMOVE-DUPLICATES (MY-MAPCAN #'IMMEDIATE-INSTANCES (CONS CLASS (ALL-SUBCLASSES CLASS))))))))
;; dereferencing done in immediate-instances
;;;; [1] This is probably redundant, as instances should never be declared a fluent. However, it used to be allowed as an option
;;;; a long time ago, so let's leave it there.
;;;; NOTE: We *won't* consider *Global to be an instance of Situation, as really Situation is meant to mean situation-specific situation
(TRACE-LISP
 (DEFINE IMMEDIATE-INSTANCES (CLASS)
  (trace-defun 'IMMEDIATE-INSTANCES (CLASS)
   (RET
    (REMOVE-IF-NOT #'KB-OBJECTP 
     (DEREFERENCE 
      (COND
       ((AND (NEQ CLASS '|Situation|)  (INV-ASSOC CLASS (BUILT-IN-INSTANCE-OF-LINKS))) 
        (MAPCAN
         #'(LAMBDA (INSTANCE+CLASS)
            (trace-defun '#:G15667 (INSTANCE+CLASS) (RET (COND ((EQ (SECOND INSTANCE+CLASS) CLASS) (LIST (FIRST INSTANCE+CLASS)))))))
         (BUILT-IN-INSTANCE-OF-LINKS)))
       ((OR (CNOT (FLUENTP '|instances|))
         (SOME #'(LAMBDA (CLASS2) (trace-defun '#:G15668 (CLASS2) (RET (IS-SUBCLASS-OF CLASS CLASS2))))
          *BUILT-IN-CLASSES-WITH-NONFLUENT-INSTANCES-RELATION*))
         (GET-VALS CLASS '|instances| :SITUATION *GLOBAL-SITUATION*))
       (T  (KM-SLOTVALS2 CLASS '|instances|)))))))))
;;;;  [1] does projection and constraint enforcement
;;;; ----------
(TRACE-LISP
 (DEFINE IMMEDIATE-PROTOTYPES (CLASS)
  (trace-defun 'IMMEDIATE-PROTOTYPES (CLASS) (RET (GET-VALS CLASS '|prototypes| :SITUATION *GLOBAL-SITUATION*)))))
(TRACE-LISP
 (DEFINE IMMEDIATE-PROTOINSTANCES (CLASS)
  (trace-defun 'IMMEDIATE-PROTOINSTANCES (CLASS) (RET (REMOVE-IF-NOT #'PROTOINSTANCEP (KM0 `(|the| |instances| |of| ,CLASS)))))))
(TRACE-LISP
 (DEFINE ALL-PROTOTYPES (CLASS)
  (trace-defun 'ALL-PROTOTYPES (CLASS)
   (RET
    (REMOVE-DUP-INSTANCES
     (APPEND (GET-VALS CLASS '|prototypes| :SITUATION *GLOBAL-SITUATION*) (MAPCAN #'ALL-PROTOTYPES (IMMEDIATE-SUBCLASSES CLASS))))))))
(TRACE-LISP
 (DEFINE ALL-PROTOINSTANCES (CLASS) (trace-defun 'ALL-PROTOINSTANCES (CLASS) (RET (REMOVE-IF-NOT #'PROTOINSTANCEP (CL-ALL-INSTANCES CLASS))))))
;;;; ----------------------------------------
;;;; Return a list of all situations used in the current session.
;;;; It includes doing dereferencing (in all-instances)
;;;; [1] Strictly, should be remove-dup-instances; however all-instances has already done this (including dereferencing), so we just need to make sure 
;;;;	we don't have *global-situation* in twice.
(TRACE-LISP
 (DEFINE ALL-SITUATIONS NIL
  (trace-defun 'ALL-SITUATIONS NIL
   (RET
    (COND ((AM-IN-GLOBAL-SITUATION) (CL-REMOVE-DUPLICATES (CONS *GLOBAL-SITUATION* (ALL-INSTANCES '|Situation|)) :FROM-END T)) 
     (T
      (CLET ((CURR-SITUATION (CURR-SITUATION))) (CHANGE-TO-SITUATION *GLOBAL-SITUATION*)
       (PROG1 (CL-REMOVE-DUPLICATES (CONS *GLOBAL-SITUATION* (ALL-INSTANCES '|Situation|)) :FROM-END T)  (CHANGE-TO-SITUATION CURR-SITUATION)))))))))
;;;; [1] NB Can't do a get-vals, as find-vals calls immediate-situations and we'd have a loop!
;;;; We assume all situation facts and relationships are asserted in the global situation.
;;;; A test in create-named-instance helps ensure this is maintained. We also check local for safety ([2]).
(TRACE-LISP
 (DEFINE IMMEDIATE-SUPERSITUATIONS (SITUATION)
  (trace-defun 'IMMEDIATE-SUPERSITUATIONS (SITUATION)
   (RET
    (COND ((EQ SITUATION *GLOBAL-SITUATION*) NIL) ((GET-VALS SITUATION '|supersituations| :SITUATION *GLOBAL-SITUATION*))
     (T (LIST *GLOBAL-SITUATION*)))))))
;; old
;;	(t (or (get-vals situation ';$supersituations :situation *global-situation*)
;;	       (get-vals situation ';$supersituations :situation (curr-situation))
;;	       (list *global-situation*)))))
;;;; ======================================================================
;;;;			SLOTS: Cardinalities
;;;; ======================================================================
;;(defconstant *default-default-fluent-status* ';$*Inertial-Fluent)	; this is the reset value after a (reset-kb)
(TRACE-LISP (DEFCONSTANT *DEFAULT-DEFAULT-FLUENT-STATUS* '|*Fluent|))
;; neah, don't change this!
(TRACE-LISP (DEFPARAMETER *DEFAULT-FLUENT-STATUS* *DEFAULT-DEFAULT-FLUENT-STATUS*))
;; user can change this
(TRACE-LISP
 (DEFINE DEFAULT-FLUENT-STATUS (&OPTIONAL STATUS)
  (trace-defun 'DEFAULT-FLUENT-STATUS (STATUS)
   (RET
    (COND ((NULL STATUS) (KM-FORMAT T "By default, slots have fluent-status = ~a.~%" *DEFAULT-FLUENT-STATUS*) '(|t|))
     ((CL-MEMBER STATUS *VALID-FLUENT-STATUSES*)   (KM-SETQ '*DEFAULT-FLUENT-STATUS* STATUS)
      (KM-FORMAT T "By default, slots now have fluent-status = ~a.~%" *DEFAULT-FLUENT-STATUS*) '(|t|))
     (T (REPORT-ERROR 'USER-ERROR "Invalid default-fluent-status `~a'! (Must be one of ~a)~%" STATUS *VALID-FLUENT-STATUSES*)))))))
;;;; ----------
;;;; [1] if slot is known as a fluent, then t. Else NIL.
;;;; [2] if slot is NOT known to be a non-fluent, then t.
(TRACE-LISP
 (DEFINE FLUENTP (SLOT)
  (trace-defun 'FLUENTP (SLOT)
   (RET
    (CASE *DEFAULT-FLUENT-STATUS* (|*Non-Fluent| (CL-MEMBER (FLUENT-STATUS SLOT) '(|*Fluent| |*Inertial-Fluent|))) 
     ((|*Fluent| |*Inertial-Fluent|) (NEQ (FLUENT-STATUS SLOT)  '|*Non-Fluent|)))))))
(TRACE-LISP
 (DEFINE INERTIAL-FLUENTP (SLOT)
  (trace-defun 'INERTIAL-FLUENTP (SLOT)
   (RET
    (CASE *DEFAULT-FLUENT-STATUS* ((|*Non-Fluent| |*Fluent|) (EQ (FLUENT-STATUS SLOT) '|*Inertial-Fluent|))
     (|*Inertial-Fluent| (CNOT (CL-MEMBER (FLUENT-STATUS SLOT) '(|*Non-Fluent| |*Fluent|)))))))))
;;;; ----------
;;;; [1] I could save a little CPU time with this
;;;; but this would remove the error check for inconsistent status. 
;;;; Even better would be to cache the whole fluentp result. But I don't think I need these
;;;; optimizations for now.
;;; [2] Provide *either* an instance *or* a set of classes (of a non-created instance) to 
;;;;	see if it's an event.
;;;; [3] These are add-list, del-list, pcs-list, ncs-list. In this case, allow user override if he/she wants - Eagh, let's hope he/she doesn't!!!
(TRACE-LISP
 (DEFINE FLUENT-STATUS (SLOT)
  (trace-defun 'FLUENT-STATUS (SLOT)
   (RET
    (COND ((CL-MEMBER SLOT *BUILT-IN-INERTIAL-FLUENT-SLOTS*) '|*Inertial-Fluent|) ((CL-MEMBER SLOT *BUILT-IN-NON-INERTIAL-FLUENT-SLOTS*) '|*Fluent|)
     ((CL-MEMBER SLOT *BUILT-IN-NON-FLUENT-SLOTS*) '|*Non-Fluent|)
     ((CLET
       ((FLUENT-STATUS1 (GET-UNIQUE-VAL SLOT '|fluent-status| :SITUATION *GLOBAL-SITUATION*))
        (FLUENT-STATUS2 #|(cond ((not fluent-status1) [1] |# (GET-UNIQUE-VAL (INVERT-SLOT SLOT) '|fluent-status| :SITUATION *GLOBAL-SITUATION*)))
       (COND
        ((AND FLUENT-STATUS1 (CNOT (CL-MEMBER FLUENT-STATUS1 *VALID-FLUENT-STATUSES*)))
         (REPORT-ERROR 'USER-ERROR "Invalid fluent-status `~a' on slot `~a'! (Should be one of: ~a)~%" FLUENT-STATUS1 SLOT *VALID-FLUENT-STATUSES*))
        ((AND FLUENT-STATUS2 (CNOT (CL-MEMBER FLUENT-STATUS2 *VALID-FLUENT-STATUSES*)))
         (REPORT-ERROR 'USER-ERROR "Invalid fluent-status `~a' on slot `~a'! (Should be one of: ~a)~%" FLUENT-STATUS2 (INVERT-SLOT SLOT)
          *VALID-FLUENT-STATUSES*))
        ((AND FLUENT-STATUS1 FLUENT-STATUS2 (NEQ FLUENT-STATUS1 FLUENT-STATUS2))
         (REPORT-ERROR 'USER-ERROR "Inconsistent declaration of fluent-status! ~a has fluent-status ~a, but ~a has fluent-status ~a.~%" SLOT
          FLUENT-STATUS1 (INVERT-SLOT SLOT) FLUENT-STATUS2))
        (T (OR FLUENT-STATUS1 FLUENT-STATUS2))))))))))
;;   ((member slot *built-in-non-inertial-fluent-slots*) ';$*Fluent)))		; [3]
;;;; ----------
(TRACE-LISP
 (DEFINE SINGLE-VALUED-SLOTP (SLOT) (trace-defun 'SINGLE-VALUED-SLOTP (SLOT) (RET (CL-MEMBER (CARDINALITY-OF SLOT) '(|1-to-1| |N-to-1|))))))
(TRACE-LISP (DEFINE MULTIVALUED-SLOTP (SLOT) (trace-defun 'MULTIVALUED-SLOTP (SLOT) (RET (CNOT (SINGLE-VALUED-SLOTP SLOT))))))
(TRACE-LISP
 (DEFINE INHERIT-WITH-OVERRIDES-SLOTP (SLOT)
  (trace-defun 'INHERIT-WITH-OVERRIDES-SLOTP (SLOT)
   (RET (GET-VALS SLOT '|inherit-with-overrides| :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL)))))
(TRACE-LISP
 (DEFINE SLOTS-TO-OPPORTUNISTICALLY-EVALUATE (INSTANCE)
  (trace-defun 'SLOTS-TO-OPPORTUNISTICALLY-EVALUATE (INSTANCE)
   (RET
    (CL-REMOVE-DUPLICATES
     (MY-MAPCAN
      #'(LAMBDA (CLASS)
         (trace-defun '#:G15669 (CLASS)
          (RET (GET-VALS CLASS '|slots-to-opportunistically-evaluate| :FACET 'MEMBER-PROPERTIES :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL))))
      (ALL-CLASSES INSTANCE)))))))
;;;; Rather inefficient, I shouldn't need to do 2 kb-accesses for every slot query to see if it's single-valued or not!
(TRACE-LISP
 (DEFINE CARDINALITY-OF (SLOT)
  (trace-defun 'CARDINALITY-OF (SLOT)
   (RET
    (COND ((CL-MEMBER SLOT *BUILT-IN-SINGLE-VALUED-SLOTS*) '|N-to-1|) ((CL-MEMBER SLOT *BUILT-IN-MULTIVALUED-SLOTS*) '|N-to-N|)
     ((OR (CARDINALITY-OF2 SLOT) (INVERT-CARDINALITY (CARDINALITY-OF2 (INVERT-SLOT SLOT))) *DEFAULT-CARDINALITY*)))))))
(TRACE-LISP
 (DEFINE CARDINALITY-OF2 (SLOT)
  (trace-defun 'CARDINALITY-OF2 (SLOT)
   (RET
    (CASE SLOT
     (T
      (CLET ((CARDINALITIES (GET-VALS SLOT '|cardinality| :SITUATION *GLOBAL-SITUATION* :DEREFERENCEP NIL)))
       (COND ((NULL CARDINALITIES) NIL) 
        (T
         (COND
          ((>= (LENGTH CARDINALITIES) 2)
           (REPORT-ERROR 'USER-ERROR "More than one cardinality ~a declared for slot ~a!Just taking the first ...~%" CARDINALITIES SLOT)))
         (COND
          ((CNOT (CL-MEMBER (FIRST CARDINALITIES) *VALID-CARDINALITIES*))
           (REPORT-ERROR 'USER-ERROR "Invalid cardinality ~a declared for slot ~a.~%(Should be one of ~a). Assuming default ~a instead~%"
            (FIRST CARDINALITIES) SLOT *VALID-CARDINALITIES* *DEFAULT-CARDINALITY*)
           *DEFAULT-CARDINALITY*)
          (T (FIRST CARDINALITIES))))))))))))
(TRACE-LISP
 (DEFINE INVERT-CARDINALITY (CARDINALITY)
  (trace-defun 'INVERT-CARDINALITY (CARDINALITY)
   (RET
    (COND ((EQ CARDINALITY NIL) NIL) ((EQ CARDINALITY '|1-to-N|) '|N-to-1|) ((EQ CARDINALITY '|N-to-1|) '|1-to-N|) ((EQ CARDINALITY '|N-to-N|) '|N-to-N|)
     ((EQ CARDINALITY '|1-to-1|) '|1-to-1|)
     (T (REPORT-ERROR 'USER-ERROR "Invalid cardinality ~a used in KB~%(Should be one of ~a)~%" CARDINALITY *VALID-CARDINALITIES*) CARDINALITY))))))
;;;; ======================================================================
;;;;			SLOTS: Inverses
;;;; ======================================================================
#|Automatic installation of inverse links:
eg. (install-inverses '*Fred 'loves '(*Sue))
will install the triple  (*Sue loves-of (*Fred)) in the KB.

[1] NOTE: special case for slot declarations:
	(install-inverses 'from 'inverse '(to))
want to assert   
	(to (inverse (from)) (instance-of (Slot)))
not just
	(to (inverse (from))) 		; KM think's its a Class by default
and also (situation-specific (t)) if the forward slot is situation-specific.
This is justified because we know inverse's domain and range are Slot.

[2] Complication with Situations and projection: 
  If   Fred loves {Sue,Mary}
  Then we km-assert Mike loves Mary,
  Then when we install-inverses, we assert Mary loves-of Mike, which over-rides
	(and prevents projection of) the old value of Mary loves-of Fred. So
  	we have to prevent installation of inverses for projected facts, or
	project the inverses also somehow.
  This has now been fixed; partial information is now merged with, rather than 
    	over-rides, projected information.

With multiargument values, this is rather intricate...
    (install-inverses Fred loves (:args Sue lots))
  -> (install-inverse (:args Sue lots) loved-by Fred)
   ->  (install-inverse Sue loved-by (:args Fred lots))				Assert
   AND POSSIBLY (install-inverse lots amount-of-love-given-to (:args Sue Fred))	Assert
   AND IF SO, ALSO (install-inverses lots amount-of-love-given-to (:args Sue Fred))
    ->  (install-inverse Sue receives-love-of-amount (:args lots Fred))		Assert
     AND POSSIBLY (install-inverse Fred gives-amount-of-love (:args lots Sue))
     AND IF SO, ALSO (install-inverses Fred gives-amount-of-love (:args lots Sue))
    -> ...
 |#
;;;; [1] put-vals for single-valued slots may be called with value (val & constraint), so must unpack this expression to make sure inverse is
;;;; installed.
;;;; RETURNS: irrelevant
(TRACE-LISP
 (DEFINE INSTALL-INVERSES (FRAME SLOT VALS &OPTIONAL SITUATION)
  (trace-defun 'INSTALL-INVERSES (FRAME SLOT VALS SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (COND ((CNOT *INSTALLING-INVERSES-ENABLED*)) 
      ((CNOT (LISTP VALS)) (REPORT-ERROR 'PROGRAM-ERROR "Non-list ~a passed to (install-inverses ~a ~a ~a)!~%" VALS FRAME SLOT VALS))
      ((CNOT (NON-INVERSE-RECORDING-SLOT SLOT))
       (CLET ((INVSLOT (INVERT-SLOT SLOT)))
        (MAPC
         #'(LAMBDA (VAL)
            (trace-defun '#:G15670 (VAL)
             (RET
              (COND ((OR (KB-OBJECTP VAL) (KM-ARGSP VAL)) (INSTALL-INVERSES0 VAL INVSLOT FRAME SLOT SITUATION))
               ((&-EXPRP VAL) (INSTALL-INVERSES FRAME SLOT (&-EXPR-TO-VALS VAL)) :SITUATION SITUATION)))))
          VALS)))))))))
#|Install a link (invframe0 invslot invval).
This basically does an add-val, except it also does:
;   1. If invframe0 is a Slot, and we're declaring an inverse, then KM also copies the situation-specific property
;   		from the invframe0's inverse to this frame.
   2. If invframe0 is a multi-argument structure (:args v1 v2), then as well as asserting (invframe0 invslot v1)
		we also assert (invframe0 inv2slot v2), and possibly (invframe0 inv3slot v3).
Note that to make sure inverses of inverse2's are installed, we set install-inversesp to t if invval is a (:args v1 v2)
  structure [1]. This will eventually terminate, as the "don't already know it" test fails:
		(not (member invval (find-vals invframe invslot 'own-properties situation) :test X'equal))) ; don't already know it
[2] Note: inverse, inverse2, inverse3 and situation-specific are all non-fluents, so we work in the global
situation for manipulating this data.
[3] This is redundant, now done by add-slotsvals more intelligently|#
(TRACE-LISP
 (DEFINE INSTALL-INVERSES0 (INVFRAME0 INVSLOT INVVAL SLOT &OPTIONAL SITUATION)
  (trace-defun 'INSTALL-INVERSES0 (INVFRAME0 INVSLOT INVVAL SLOT SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (CLET ((INVFRAME (DEREFERENCE INVFRAME0)))
      (COND
       ((AND (KB-OBJECTP INVFRAME) (CNOT (NON-INVERSE-RECORDING-CONCEPT INVFRAME)) 
         (CNOT (CL-MEMBER INVVAL (GET-VALS INVFRAME INVSLOT :SITUATION SITUATION) :TEST #'CL-EQUAL)))
         (CLET ((INSTALL-INVERSESP (KM-ARGSP INVVAL)))  (ADD-VAL INVFRAME INVSLOT INVVAL INSTALL-INVERSESP SITUATION))    
        (CLASSIFY INVFRAME :SLOTS-THAT-CHANGED (LIST INVSLOT)))
       ((KM-ARGSP INVFRAME)  (INSTALL-INVERSES0 (SECOND INVFRAME) INVSLOT  `(:|args| ,INVVAL ,@(REST (REST INVFRAME))) SLOT SITUATION)
        (COND
         ((AND (THIRD INVFRAME)  (OR (ASSOC SLOT *BUILT-IN-INVERSE2S*) (GET-UNIQUE-VAL SLOT '|inverse2| :SITUATION *GLOBAL-SITUATION*)))
          (CLET
           ((INV2SLOT (OR (SECOND (ASSOC SLOT *BUILT-IN-INVERSE2S*)) (GET-UNIQUE-VAL SLOT '|inverse2| :SITUATION *GLOBAL-SITUATION*)))
            (MODIFIED-ARGS `(:|args| ,(SECOND INVFRAME) ,INVVAL ,@(REST (REST (REST INVFRAME))))))
            (INSTALL-INVERSES0 (THIRD INVFRAME) INV2SLOT MODIFIED-ARGS SLOT SITUATION))))
        (COND
         ((AND (THIRD INVFRAME) (GET-UNIQUE-VAL SLOT '|inverse12| :SITUATION *GLOBAL-SITUATION*))
          (CLET
           ((INV12SLOT (GET-UNIQUE-VAL SLOT '|inverse12| :SITUATION *GLOBAL-SITUATION*))
            (MODIFIED-ARGS `(:|args| ,(ARG2OF INVFRAME) ,(ARG1OF INVFRAME) ,@(REST (REST (REST INVFRAME))))))
           (ADD-VAL INVVAL INV12SLOT MODIFIED-ARGS T SITUATION))))
        
        (COND
         ((AND (FOURTH INVFRAME)  (GET-UNIQUE-VAL SLOT '|inverse3| :SITUATION *GLOBAL-SITUATION*))
          (CLET
           ((INV3SLOT (GET-UNIQUE-VAL SLOT '|inverse3| :SITUATION *GLOBAL-SITUATION*))
            (MODIFIED-ARGS `(:|args| ,(SECOND INVFRAME) ,(THIRD INVFRAME) ,INVVAL ,@(REST (REST (REST (REST INVFRAME)))))))
           (INSTALL-INVERSES0 (FOURTH INVFRAME) INV3SLOT MODIFIED-ARGS SLOT SITUATION))))))))))))
;;;; ----------
;;;; Undo the operation:
(TRACE-LISP
 (DEFINE UNINSTALL-INVERSES (FRAME SLOT VALS &OPTIONAL SITUATION)
  (trace-defun 'UNINSTALL-INVERSES (FRAME SLOT VALS SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (COND
      ((CNOT (NON-INVERSE-RECORDING-SLOT SLOT))
       (CLET ((INVSLOT (INVERT-SLOT SLOT)))
        (MAPC
         #'(LAMBDA (VAL0)
            (trace-defun '#:G15671 (VAL0)
             (RET
              (CLET ((VAL (DEREFERENCE VAL0)))
               (COND
                ((AND (KB-OBJECTP VAL) (CNOT (NON-INVERSE-RECORDING-CONCEPT VAL))   (CL-MEMBER FRAME (GET-VALS VAL INVSLOT :SITUATION SITUATION)))
                 (CLET ((NEW-VALS (CL-REMOVE FRAME (GET-VALS VAL INVSLOT :SITUATION SITUATION))))
                  (PUT-VALS VAL INVSLOT NEW-VALS :INSTALL-INVERSESP NIL :SITUATION SITUATION))))))))
          VALS)))))))))
;;;; ----------
;;;; Evaluate local expressions, with the intension that inverses will
;;;; be installed. Used by forc function in interpreter.lisp
;;;; MUST return instance as a result.
;;;; We just deal with slotsvals in the current situation.
(TRACE-LISP
 (DEFINE EVAL-INSTANCE (INSTANCE) (trace-defun 'EVAL-INSTANCE (INSTANCE) (RET (TRACE-PROGN (EVAL-INSTANCES (LIST INSTANCE)) INSTANCE)))))
;;;; Note, we have to keep recurring until a stable state is reached. Just checking for newly created
;;;; instances isn't good enough -- some expansions may cause delayed unifications, without creating new instances.
(TRACE-LISP
 (DEFINE EVAL-INSTANCES (&OPTIONAL INSTANCES N)
  (trace-defun 'EVAL-INSTANCES (INSTANCES N)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR N 0) (SUBLISP-INITVAR INSTANCES (OBJ-STACK))
     (COND ((NULL INSTANCES) NIL)
      ((>= N 100) (REPORT-ERROR 'USER-ERROR "eval-instances in frame-io.lisp!~%Recursion is causing an infinite graph to be generated! Giving up...~%"))
      (T
       (CLET ((OBJ-STACK (OBJ-STACK))) (MAPC #'SIMPLE-EVAL-INSTANCE INSTANCES)
        (COND ( (USE-PROTOTYPES) (MAPC #'UNIFY-IN-PROTOTYPES INSTANCES) (MAPC #'CLASSIFY INSTANCES)) (T  (MAPC #'EVAL-CONSTRAINTS INSTANCES))) 
        (EVAL-INSTANCES (SET-DIFFERENCE (OBJ-STACK) OBJ-STACK) (1+ N))))))))))
;; process newly created instances
;;   (t (let ( (expansion-done? (remove nil (mapcar ;'simple-eval-instance instances))) )
;;	(cond (expansion-done? (eval-instances (obj-stack) (1+ n))))))))
(TRACE-LISP
 (DEFINE EVAL-CONSTRAINTS (INSTANCE)
  (trace-defun 'EVAL-CONSTRAINTS (INSTANCE)
   (RET
    (MAPC
     #'(LAMBDA (SLOTVALS)
        (trace-defun '#:G15672 (SLOTVALS)
         (RET
          (CLET
           ((NEW-VALS
             (MAPCAR
              #'(LAMBDA (VAL)
                 (trace-defun '#:G15673 (VAL)
                  (RET (COND ((AND (PAIRP VAL) (EQ (FIRST VAL) '<>)) (LIST '<> (KM-UNIQUE0 (SECOND VAL) :FAIL-MODE 'ERROR))) (T VAL)))))
              (VALS-IN SLOTVALS))))
           (COND ((CNOT (CL-EQUAL SLOTVALS NEW-VALS)) (PUT-VALS INSTANCE (SLOT-IN SLOTVALS) NEW-VALS :INSTALL-INVERSESP NIL)))))))
     (GET-SLOTSVALS INSTANCE))))))
;;;; [1] More conservative - only evaluate paths, rather than force inheritance when only atomic instances are present.
;;;; return t if some expansion was done, to make sure we get everything!
(TRACE-LISP
 (DEFINE SIMPLE-EVAL-INSTANCE (INSTANCE)
  (trace-defun 'SIMPLE-EVAL-INSTANCE (INSTANCE)
   (RET
    (CL-REMOVE NIL
     (MAPCAR
      #'(LAMBDA (SLOTVALS)
         (trace-defun '#:G15674 (SLOTVALS)
          (RET
           (COND
            ((SOME #'(LAMBDA (VAL) (trace-defun '#:G15675 (VAL) (RET (AND (CNOT (FULLY-EVALUATEDP VAL)) (CNOT (CONSTRAINT-EXPRP VAL)))))) 
              (VALS-IN SLOTVALS))
              (KM0 `(|the| ,(SLOT-IN SLOTVALS) |of| ,INSTANCE)) T)))))
      (GET-SLOTSVALS INSTANCE)))))))
;;;; ----------------------------------------
;;;; *inverse-suffix* = "-of" (case-sensitivity on) "-OF" (case-sensitivity off)
(TRACE-LISP
 (DEFINE INVERT-SLOT (SLOT)
  (trace-defun 'INVERT-SLOT (SLOT)
   (RET
    (COND ((SECOND (ASSOC SLOT *BUILT-IN-INVERSES*)))  ((CNOT (CHECK-ISA-SLOT-OBJECT SLOT)) NIL)
     ((GET-UNIQUE-VAL SLOT '|inverse| :SITUATION *GLOBAL-SITUATION*)) 
     (T
      (CLET ((STR-SLOT (SYMBOL-NAME SLOT))) 
       (COND
        ((AND (> (LENGTH STR-SLOT) 3) (CL-ENDS-WITH STR-SLOT *INVERSE-SUFFIX*)) 
         (INTERN (TRIM-FROM-END STR-SLOT *LENGTH-OF-INVERSE-SUFFIX*) *KM-PACKAGE*))
        (T (INTERN (CONCAT STR-SLOT *INVERSE-SUFFIX*) *KM-PACKAGE*))))))))))
;;;; Thanks to Ken Murray for this one:
(TRACE-LISP
 (DEFINE INVERT-PREDICATE (PREDICATE &OPTIONAL ARGNUM)
  (trace-defun 'INVERT-PREDICATE (PREDICATE ARGNUM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR ARGNUM 2)
     (CASE ARGNUM (1 PREDICATE) (2 (INVERT-SLOT PREDICATE)) (3 (KM-UNIQUE `(|the| |inverse2| |of| ,PREDICATE)))
      (4 (KM-UNIQUE `(|the| |inverse3| |of| ,PREDICATE)))))))))
;;;; ======================================================================
;;;;		SLOTS: Check conformance with slot declarations
;;;; ======================================================================
;;;; RETURNS: nil - simply checks for domain and range violations
#|Warning! Asserting (Pete has (location (Farm1 Farm2)))...
         Pete isn't a Place (violates the domain constraint for `location')
         Farm2 isn't a Place (violates the range constraint for `location')|#
(TRACE-LISP
 (DEFINE CHECK-DOMAIN-AND-RANGE (INSTANCE SLOT VALS)
  (trace-defun 'CHECK-DOMAIN-AND-RANGE (INSTANCE SLOT VALS)
   (RET
    (CLET
     ((DOMAINS (DOMAINS-OF SLOT)) (RANGES (RANGES-OF SLOT))
      (DOMAIN-VIOLATION
       (COND
        ((AND DOMAINS (NOTANY #'(LAMBDA (DOMAIN) (trace-defun '#:G15676 (DOMAIN) (RET (INSTANCE-OF INSTANCE DOMAIN)))) DOMAINS))
         (COND
          ((SOME #'(LAMBDA (DOMAIN) (trace-defun '#:G15677 (DOMAIN) (RET (COMPATIBLE-CLASSES :INSTANCE1 INSTANCE :CLASSES2 (LIST DOMAIN)))))
            DOMAINS))
          (T
           (REPORT-ERROR 'USER-ERROR "Attempt to access (the ~a of ~a), but ~a is incompatible with the domains of `~a' ~a!" SLOT INSTANCE INSTANCE SLOT
            DOMAINS))))))
      (RANGE-VIOLATIONS
       (COND
        (RANGES
         (REMOVE-IF-NOT
          #'(LAMBDA (VAL)
             (trace-defun '#:G15678 (VAL)
              (RET
               (COND
                ((AND (KB-OBJECTP VAL) (NOTANY #'(LAMBDA (RANGE) (trace-defun '#:G15679 (RANGE) (RET (INSTANCE-OF VAL RANGE)))) RANGES))
                 (COND
                  ((SOME #'(LAMBDA (RANGE) (trace-defun '#:G15680 (RANGE) (RET (COMPATIBLE-CLASSES :INSTANCE1 VAL :CLASSES2 (LIST RANGE)))))
                    RANGES)
                   VAL)
                  (T
                   (REPORT-ERROR 'USER-ERROR "Attempt to put ((the ~a of ~a) = ~a), but ~a is incompatible with the ranges of `~a' ~a!" SLOT INSTANCE VAL
                    VAL SLOT RANGES))))))))
          VALS)))))
     (COND
      ((OR DOMAIN-VIOLATION RANGE-VIOLATIONS) (KM-FORMAT T "Warning! Asserting (~a has (~a (~a))):~%" INSTANCE SLOT VALS)
       (COND (DOMAIN-VIOLATION (KM-FORMAT T "         ~a isn't one of  ~a (violates the domain constraint for `~a')~%" INSTANCE DOMAINS SLOT)))
       (MAPC
        #'(LAMBDA (RANGE-VIOLATION)
           (trace-defun '#:G15681 (RANGE-VIOLATION)
            (RET (KM-FORMAT T "         ~a isn't one of ~a (violates the range constraint for `~a')~%" RANGE-VIOLATION RANGES SLOT))))
        RANGE-VIOLATIONS))))))))
;;;; ----------
(TRACE-LISP
 (DEFINE CHECK-ISA-SLOT-OBJECT (SLOT)
  (trace-defun 'CHECK-ISA-SLOT-OBJECT (SLOT)
   (RET
    (COND ((LISTP SLOT) (REPORT-ERROR 'USER-ERROR "Non-atomic slot ~a encountered! (Missing parentheses in expression?)~%" SLOT))
     ((NUMBERP SLOT) (REPORT-ERROR 'USER-ERROR "Numbers can't be used as slots! (A slot named `~a' was encountered)~%" SLOT))
     ((CNOT (SLOT-OBJECTP SLOT)) (REPORT-ERROR 'USER-ERROR "Invalid slot name `~a' encountered! (Slots should be a non-nil symbol)~%" SLOT)) (T))))))
;; otherwise, it's a slot!
(TRACE-LISP
 (DEFINE CHECK-SLOT (FRAME SLOT VALUES)
  (trace-defun 'CHECK-SLOT (FRAME SLOT VALUES)
   (RET
    (TRACE-PROGN (DECLARE (IGNORE FRAME VALUES))
     (COND ((CNOT (CHECKKBP))) ((BUILT-IN-CONCEPT SLOT)) ((UNDECLARED-SLOT SLOT))
      (T
       (CLET ((DOMAINS (DOMAINS-OF SLOT)) (RANGES (RANGES-OF SLOT)))
        (COND ((CNOT DOMAINS) (REPORT-ERROR 'USER-WARNING "Domain for slot ~a not declared.~%" SLOT)))
        (MAPC
         #'(LAMBDA (DOMAIN)
            (trace-defun '#:G15682 (DOMAIN)
             (RET (COND ((CNOT (KNOWN-FRAME DOMAIN)) (REPORT-ERROR 'USER-WARNING "Domain ~a for slot ~a not declared in KB.~%" DOMAIN SLOT))))))
         DOMAINS)
        (COND ((CNOT RANGES) (REPORT-ERROR 'USER-WARNING "Range for slot ~a not declared.~%" SLOT)))
        (MAPC
         #'(LAMBDA (RANGE)
            (trace-defun '#:G15683 (RANGE)
             (RET (COND ((CNOT (KNOWN-FRAME RANGE)) (REPORT-ERROR 'USER-WARNING "Range ~a for slot ~a not declared in KB.~%" RANGE SLOT))))))
         RANGES)))))))))
(TRACE-LISP
 (DEFINE DOMAINS-OF (SLOT)
  (trace-defun 'DOMAINS-OF (SLOT)
   (RET (OR (GET-VALS SLOT '|domain| :SITUATION *GLOBAL-SITUATION*) (GET-VALS (INVERT-SLOT SLOT) '|range| :SITUATION *GLOBAL-SITUATION*))))))
(TRACE-LISP
 (DEFINE RANGES-OF (SLOT)
  (trace-defun 'RANGES-OF (SLOT)
   (RET (OR (GET-VALS SLOT '|range| :SITUATION *GLOBAL-SITUATION*) (GET-VALS (INVERT-SLOT SLOT) '|domain| :SITUATION *GLOBAL-SITUATION*))))))
(TRACE-LISP
 (DEFINE UNDECLARED-SLOT (SLOT)
  (trace-defun 'UNDECLARED-SLOT (SLOT)
   (RET
    (COND ((CNOT (SYMBOLP SLOT)) (REPORT-ERROR 'USER-ERROR "Non-slot ~a found where a slot was expected!~%" SLOT) T)
     ((AND (CNOT (KNOWN-FRAME SLOT)) (CNOT (KNOWN-FRAME (INVERT-SLOT SLOT))) (CNOT (BUILT-IN-CONCEPT SLOT)))
      (COND ((CHECKKBP) (REPORT-ERROR 'USER-WARNING "Slot ~a (or inverse ~a) not declared.~%" SLOT (INVERT-SLOT SLOT)))) T))))))
;;;; ======================================================================
;;;;		AND FOR NORMAL SPECIALIZATION LINKS
;;;; ======================================================================
#|We assume the superclasses are correctly installed.
put-vals will avoid most redundancy in the superclasses link, but unfortunately
not all (see comments on put-vals above).
The subclasses links can still get redundancies in, for example:
	KM> (Car has (superclasses (Vehicle)))
	KM> (Nissan has (superclasses (Vehicle)))
	KM> (Nissan has (superclasses (Car)))
	KM> (showme 'Nissan)
	(Nissan has (superclasses (Car)))		; OK
	KM> (showme 'Vehicle)
	(Vehicle has (subclasses (Nissan Car)))		; Not OK

Call (clean-taxonomy) to recompute the taxonomy without redundancies.

[1] strips all subclass links
[2] walks through every superclass link, installing respective subclass links
[3] final check for unconnected nodes|#
;;;; ----------------------------------------
(TRACE-LISP
 (DEFINE INSTALL-ALL-SUBCLASSES NIL
  (trace-defun 'INSTALL-ALL-SUBCLASSES NIL
   (RET (FORMAT T "(install-all-subclasses) has been renamed (clean-taxonomy). Please update your code!~%")))))
(TRACE-LISP
 (DEFINE CLEAN-TAXONOMY NIL
  (trace-defun 'CLEAN-TAXONOMY NIL
   (RET
    (TRACE-PROGN (FORMAT T "Removing redundant superclasses...~%") (MAPC #'REMOVE-REDUNDANT-SUPERCLASSES (GET-ALL-CONCEPTS)) 
     (FORMAT T "Removing redundant subclasses...~%") (MAPC #'REMOVE-REDUNDANT-SUBCLASSES (GET-ALL-CONCEPTS)) 
     (FORMAT T "Computing subclasses of Thing...~%")
     (MAPC #'(LAMBDA (VAL) (trace-defun '#:G15684 (VAL) (RET (ADD-VAL '|Thing| '|subclasses| VAL)))) (SUBCLASSES-OF-THING))  T)))))
;;;; ----------------------------------------
;;;; This is too slow to include in the loader for all superclass changes
#| <X C
X <X GenC    hence  X <X C, GenC
Now add C <X GenC, X <X GenC is redundant and should be removed, so foreach GenC's subclasses, check for
	redundancy in its superclasses link

ALSO:
C <X D
GenC <X D    hence   D subclasses C, GenC
Now add C <X GenC, C <X D is redundant and should be removed, so foreach C's superclasses, check for
	redundancy in its subclasses link|#
;;;; class's superclasses have just been updated to be superclasses
;;(defun remove-redundancies-in-superclasses (class superclasses)
;;  (declare (ignore class))
;;  (mapc ;'(lambda (superclass)
;;	    (mapc ;'remove-redundant-superclasses (immediate-subclasses superclass)) ; [1]
;;	    (remove-redundant-subclasses superclass))				     ; [2]
;;	superclasses))
;;;; ----------------------------------------
(TRACE-LISP
 (DEFINE REMOVE-REDUNDANT-SUPERCLASSES (CLASS)
  (trace-defun 'REMOVE-REDUNDANT-SUPERCLASSES (CLASS)
   (RET
    (CLET ((SUPERCLASSES (GET-VALS CLASS '|superclasses|)) (MINIMAL-SUPERCLASSES (REMOVE-SUBSUMERS SUPERCLASSES)))
     (COND
      ((CNOT (SET-EQUAL SUPERCLASSES MINIMAL-SUPERCLASSES))
       (MAPC
        #'(LAMBDA (REDUNDANT-SUPERCLASS)
           (trace-defun '#:G15685 (REDUNDANT-SUPERCLASS)
            (RET
             (TRACE-PROGN (DELETE-VAL CLASS '|superclasses| REDUNDANT-SUPERCLASS)
              (MAKE-COMMENT "Removing redundant superclass ~a in (~a has (superclasses (~a)))" REDUNDANT-SUPERCLASS CLASS SUPERCLASSES)))))
        (SET-DIFFERENCE SUPERCLASSES MINIMAL-SUPERCLASSES)))))))))
(TRACE-LISP
 (DEFINE REMOVE-REDUNDANT-SUBCLASSES (CLASS)
  (trace-defun 'REMOVE-REDUNDANT-SUBCLASSES (CLASS)
   (RET
    (CLET ((SUBCLASSES (GET-VALS CLASS '|subclasses|)) (MINIMAL-SUBCLASSES (REMOVE-SUBSUMEES SUBCLASSES)))
     (COND
      ((CNOT (SET-EQUAL SUBCLASSES MINIMAL-SUBCLASSES))
       (MAPC
        #'(LAMBDA (REDUNDANT-SUBCLASS)
           (trace-defun '#:G15686 (REDUNDANT-SUBCLASS)
            (RET
             (TRACE-PROGN (DELETE-VAL CLASS '|subclasses| REDUNDANT-SUBCLASS)
              (MAKE-COMMENT "Removing redundant subclass ~a in (~a has (subclasses (~a)))" REDUNDANT-SUBCLASS CLASS SUBCLASSES)))))
        (SET-DIFFERENCE SUBCLASSES MINIMAL-SUBCLASSES)))))))))
;;;; ======================================================================
;;;;			THE SITUATION MECHANISM
;;;; ======================================================================
;;;; [1] Note we don't dereference *curr-situation*, in case it's bound to *Global.
;;;; If it is bound to global, we want to (i) change *curr-situation* to point to
;;;; *Global directly and (ii) by a subtle interaction, (reset-kb) get's messed up
;;;; otherwise: If we leave *curr-situation* as (say) _S2, thinking it's *Global 
;;;; (as it's bound to *Global), but then do an (unbind), we're then left apparently
;;;; in a (now unbound) _S2!
;;;; Must return a list of values (here, just a singleton) for consistency
(TRACE-LISP
 (DEFINE GLOBAL-SITUATION NIL
  (trace-defun 'GLOBAL-SITUATION NIL
   (RET (COND ((NEQ *CURR-SITUATION* *GLOBAL-SITUATION*)  (IN-SITUATION *GLOBAL-SITUATION*)) (T (LIST *GLOBAL-SITUATION*)))))))
;;;; A KM function passed to Lisp:
;;;; NB 2.12.99 dereference added!!!
(TRACE-LISP (DEFINE CURR-SITUATION NIL (trace-defun 'CURR-SITUATION NIL (RET (DEREFERENCE *CURR-SITUATION*)))))
(TRACE-LISP
 (DEFINE IN-SITUATION (SITUATION-EXPR &OPTIONAL KM-EXPR THEORYP)
  (trace-defun 'IN-SITUATION (SITUATION-EXPR KM-EXPR THEORYP)
   (RET
    (COND ((AND (TRACEP) (CNOT (TRACEOTHERSITUATIONSP))) (PROG2 (SUSPEND-TRACE) (IN-SITUATION0 SITUATION-EXPR KM-EXPR THEORYP) (UNSUSPEND-TRACE)))
     (T (IN-SITUATION0 SITUATION-EXPR KM-EXPR THEORYP)))))))
;;;; [1] The special case which *is* allowed, of an (in-situation *Global ...) issued when within a prototype, will be caught earlier by [2].
(TRACE-LISP
 (DEFINE IN-SITUATION0 (SITUATION-EXPR &OPTIONAL KM-EXPR THEORYP)
  (trace-defun 'IN-SITUATION0 (SITUATION-EXPR KM-EXPR THEORYP)
   (RET
    (CLET
     ((SITUATION-STRUCTURE (KM-UNIQUE0 SITUATION-EXPR))
      (SITUATION (COND ((AND (CNOT THEORYP) (KM-ARGSP SITUATION-STRUCTURE)) (ARG1OF SITUATION-STRUCTURE))  (T SITUATION-STRUCTURE))) 
      (SITUATION-CLASS (COND (THEORYP '|Theory|) (T '|Situation|))))
     (COND ((AND (CNOT THEORYP) (NEQ SITUATION-EXPR *GLOBAL-SITUATION*)) (SET-SITUATIONS-MODE)))
     (COND
      ((EQ SITUATION (CURR-SITUATION))  (COND ((NEQ (CURR-SITUATION) *CURR-SITUATION*) (CHANGE-TO-SITUATION (CURR-SITUATION)))) 
       (COND (KM-EXPR (KM0 KM-EXPR)) (T (LIST (CURR-SITUATION)))))
      ((AM-IN-PROTOTYPE-MODE) 
       (REPORT-ERROR 'USER-ERROR "Trying to do ~a: Can't enter a ~a when you're in prototype mode!~%"
        (COND ((AND THEORYP KM-EXPR) `(|in-theory| ,SITUATION-EXPR ,KM-EXPR)) (KM-EXPR `(|in-situation| ,SITUATION-EXPR ,KM-EXPR))
         (THEORYP `(|in-theory| ,SITUATION-EXPR)) (T `(|in-situation| ,SITUATION-EXPR)))
        SITUATION-CLASS))
      ((OR (CNOT SITUATION) (CNOT (KB-OBJECTP SITUATION)))
       (REPORT-ERROR 'USER-ERROR "~a doesn't evaluate to a ~a (results in ~a instead)!~%" SITUATION-EXPR SITUATION-CLASS SITUATION-STRUCTURE))
      ((CNOT (CL-ISA SITUATION SITUATION-CLASS))
       (REPORT-ERROR 'USER-ERROR "~a doesn't evaluate to a ~a (~a isn't declared an instance of ~a)!~%" SITUATION-EXPR SITUATION-CLASS SITUATION
        SITUATION-CLASS))
      ((CNOT KM-EXPR)
       (COND
        ((AND (KB-OBJECTP SITUATION-EXPR) (NEQ SITUATION-EXPR SITUATION))
         (MAKE-COMMENT "~a ~a is bound to ~a" SITUATION-CLASS SITUATION-EXPR SITUATION)))
       (MAKE-COMMENT "Changing to ~a ~a" SITUATION-CLASS SITUATION) (LIST (CHANGE-TO-SITUATION SITUATION)))
      
      (T
       (CLET ((CURR-SITUATION (CURR-SITUATION))) (KM-TRACE 'COMMENT "")  (KM-TRACE 'COMMENT "Temporarily changing to ~a ~a..." SITUATION-CLASS SITUATION)
        (CHANGE-TO-SITUATION SITUATION)
        (PROG1 (KM0 KM-EXPR) (CHANGE-TO-SITUATION CURR-SITUATION)
         (KM-TRACE 'COMMENT "Exiting ~a ~a, and returning to ~a." SITUATION-CLASS SITUATION CURR-SITUATION) (KM-TRACE 'COMMENT ""))))))))))
(TRACE-LISP (DEFINE AM-IN-GLOBAL-SITUATION NIL (trace-defun 'AM-IN-GLOBAL-SITUATION NIL (RET (EQ (CURR-SITUATION) *GLOBAL-SITUATION*)))))
(TRACE-LISP
 (DEFINE AM-IN-LOCAL-SITUATION NIL
  (trace-defun 'AM-IN-LOCAL-SITUATION NIL (RET (AND (NEQ (CURR-SITUATION) *GLOBAL-SITUATION*) (CNOT (ISA-THEORY (CURR-SITUATION))))))))
(TRACE-LISP (DEFINE CHANGE-TO-SITUATION (SITUATION) (trace-defun 'CHANGE-TO-SITUATION (SITUATION) (RET ))))
;;;; next-situation will create a new situation which is at the next-situation relation
;;;; to the situation given. 
;;;; NOTE: if the future-pointing-slot is single-valued, then next-situation will
;;;; first try and FIND the next-situation rather than create a new one (which will
;;;; necessarily need to be unified in).
;;;; action is an INSTANCE (it better be!)
;;;; RETURNS: The next situation
(TRACE-LISP (DEFINE NEXT-SITUATION (ACTION) (trace-defun 'NEXT-SITUATION (ACTION) (RET ))))
;; inverse auto-installed
(TRACE-LISP (DEFINE NEW-SITUATION NIL (trace-defun 'NEW-SITUATION NIL (RET (IN-SITUATION (MAKE-NEW-SITUATION))))))
(TRACE-LISP
 (DEFINE MAKE-NEW-SITUATION NIL
  (trace-defun 'MAKE-NEW-SITUATION NIL
   (RET (KM-UNIQUE0 `(|a| |Situation| |with| (|supersituations| (,*GLOBAL-SITUATION*))) :FAIL-MODE 'ERROR)))))
;;;; always t for now -- disable this verification step
(TRACE-LISP
 (DEFINE ISA-SITUATION-FACET (SITUATION) (trace-defun 'ISA-SITUATION-FACET (SITUATION) (RET (TRACE-PROGN (DECLARE (IGNORE SITUATION)) T)))))
;;;; facet refers to a global property list, for storing data.
;;;; In the global situation, we refer to that facet directly. In a local
;;;; situation, we create a situation-specific property list storing that data.
;;;; The facet "own-properties" in _Sitn1 becomes "own-properties_Sitn1".
;;;; To avoid computing this symbol many times, I cache it using get/setf:
;;;;	SYMBOL		PROPERTY   VALUE
;;;;	own-properties  _Sitn1     own-properties_Sitn1
;;;; This simply caches the concatenation of these two symbols into a third
;;;; symbol, hopefully being more efficient than reconcatenating and interning
;;;; the symbols' strings!
;;;; 3.25.99 - time on test suite goes up from 20 to 37 secs without this caching!
;;;; Looks like it's doing something useful...
;;;; [1] is simply an optimization, so doesn't need to be undone with roll-back
(TRACE-LISP
 (DEFINE CURR-SITUATION-FACET (FACET &OPTIONAL CURR-SITUATION)
  (trace-defun 'CURR-SITUATION-FACET (FACET CURR-SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR CURR-SITUATION (CURR-SITUATION))
     (COND ((EQ CURR-SITUATION *GLOBAL-SITUATION*) FACET) ((GET FACET CURR-SITUATION))
      (T  (CSETF (GET FACET CURR-SITUATION)  (INTERN (CONCAT (SYMBOL-NAME FACET) (SYMBOL-NAME CURR-SITUATION)) *KM-PACKAGE*)))))))))
;;;; ======================================================================
;;;;		SITUATION TRANSITIONS:
;;;; ======================================================================
(TRACE-LISP (DEFVAR *USER-HAS-BEEN-WARNED* NIL))
(TRACE-LISP (DEFVAR *INTERACTIVE-PRECONDITIONS* NIL))
;;;; Effects can be either quoted propositions or :triple statements (take your pick!)
;;;;
;;;; a PROPOSITION is a structure of the form (:triple F S V), where V may be (:set a b)
;;;;
;;;; Note we must precompute all the effects *before* actually making them, to avoid one 
;;;; effect being considered as part of the initial situation for calculating another.
;;;; [2] Here we insist the user to make Events explicitly identifiable by KM.
;;;;     KM uses this information when computing projection, namely NEVER project slot-values for Events. 
;;;;     The reason for this is somewhat complicated.
;;;; [1] NOTE: consistency check &? in lazy-unify **DOESN'T** do projection, so better provoke it here!
;;;; [3] It shouldn't really matter where I compute add-list and del-list, although the later position is better (in case the pcs-list fails).
;;;;	HOWEVER: the "Forward propogate relevant facts" causes some undesirable unifications of values, which cause actions to be misunified
;;;;	together -- this is the familiar bug with &&'ing inverses together. If I move the test [3] earlier, then I can get the add- and del-list
;;;;	before this destruction is caused. Hack!
;;;;	Later: No, we must evaluate del-list AFTER the pcs-list have been asserted! Suppose the del-list says (forall <x> (:triple ...))
;;;;		  and the pcs-list asserts the existence of an <x>, we better make sure the pcs-list are evaluated first!
;;;; [4] 
;;;;	We need to allow for conditional add-list and del-list, which means that 
;;;;	(i) add-list etc. are changed to non-inertial fluents
;;;;     (ii) retrieval of the add-list etc. must be done in the situation BEFORE the action is performed, but AFTER any pcs have
;;;;			been assumed
;;;; [5] Must disable classification, or else assert -> classify -> premature computation of other slot-values, before other adds/dels have been done!
(TRACE-LISP
 (DEFINE DO-ACTION (ACTION-EXPR &REST LKEYS)
  (trace-defun 'DO-ACTION (ACTION-EXPR LKEYS)
   (RET
    (CLET (CHANGE-TO-NEXT-SITUATION TEST-OR-ASSERT-PCS) (init-keyval TEST-OR-ASSERT-PCS 'ASSERT) (TEMPORARILY-DISABLE-CLASSIFICATION) 
     (PROG1 (DO-ACTION0 ACTION-EXPR :CHANGE-TO-NEXT-SITUATION CHANGE-TO-NEXT-SITUATION :TEST-OR-ASSERT-PCS TEST-OR-ASSERT-PCS)
      (REMOVE-TEMPORARY-DISABLEMENT-OF-CLASSIFICATION)))))))
(TRACE-LISP
 (DEFINE DO-ACTION0 (ACTION-EXPR &REST LKEYS)
  (trace-defun 'DO-ACTION0 (ACTION-EXPR LKEYS)
   (RET
    (CLET (CHANGE-TO-NEXT-SITUATION TEST-OR-ASSERT-PCS) (init-keyval TEST-OR-ASSERT-PCS 'ASSERT)
     (COND
      ((CNOT *USER-HAS-BEEN-WARNED*)
       (KM-FORMAT T
        "
----------------------------------------------------------------------
	KM 1.4.0.51 and later: IMPORTANT CHANGE!!
	=========================================
The default fluent-status of slots is now *Fluent, *NOT* *Inertial-Fluent.
Make sure the fluent-status of your slots are set correctly -- See the 
KM Situations Manual, Section 6.2, p23-24 for the rules to follow.
----------------------------------------------------------------------
")
       (CSETQ *USER-HAS-BEEN-WARNED* T)))
     (COND
      ((AM-IN-GLOBAL-SITUATION) (MAKE-COMMENT "Ignoring (do-action ~a) in global situation:" ACTION-EXPR)
       (MAKE-COMMENT "Can only execute actions in local situations"))
      (T
       (CLET ((OLD-SITUATION (CURR-SITUATION)) (ACTION (COND (ACTION-EXPR (KM-UNIQUE0 ACTION-EXPR)))))
        (COND    
         (T
          (COND
           ((CNOT ACTION) (MAKE-COMMENT "Doing null action...") (IN-SITUATION (NEXT-SITUATION NIL))
            (PROG1 (CURR-SITUATION) (COND ((CNOT CHANGE-TO-NEXT-SITUATION) (IN-SITUATION OLD-SITUATION)))))
           (T (KM-TRACE 'COMMENT "Computing the preconditions and effects of action ~a..." ACTION)
            (CLET ((SEMI-EVALUATED-PCS-LIST (FIND-PROPOSITIONS ACTION '|pcs-list|)) (SEMI-EVALUATED-NCS-LIST (FIND-PROPOSITIONS ACTION '|ncs-list|))    )
             (COND
              ((OR SEMI-EVALUATED-PCS-LIST SEMI-EVALUATED-NCS-LIST) (KM-TRACE 'COMMENT "Forward propogate relevant facts from previous situation...") 
               (MAPC
                #'(LAMBDA (FRAME+SLOT)
                   (trace-defun '#:G15687 (FRAME+SLOT)
                    (RET
                     (CLET ((FRAME (FIRST FRAME+SLOT)) (SLOT (SECOND FRAME+SLOT)))
                      (COND ((COMPARISON-OPERATOR SLOT) (KM0 FRAME)) (T (KM0 `(|the| ,SLOT |of| ,FRAME))))))))
                (CL-REMOVE-DUPLICATES
                 (MAPCAR #'(LAMBDA (TRIPLE) (trace-defun '#:G15688 (TRIPLE) (RET (LIST (ARG1OF TRIPLE) (ARG2OF TRIPLE)))))
                  (APPEND SEMI-EVALUATED-PCS-LIST SEMI-EVALUATED-NCS-LIST))))))
             (COND
              ((OR SEMI-EVALUATED-NCS-LIST SEMI-EVALUATED-PCS-LIST)
               (KM-TRACE 'COMMENT "Preconditions of ~a which must be true in the old situation (~a)..." ACTION OLD-SITUATION)))
             (COND
              ((CONSISTENT-TO-DO-ACTION ACTION SEMI-EVALUATED-PCS-LIST SEMI-EVALUATED-NCS-LIST)
               (CLET ((UNSATISFIED-PCS (UNSATISFIED-PROPOSITIONS SEMI-EVALUATED-PCS-LIST)))
                (COND
                 ((OR (NULL UNSATISFIED-PCS) (EQ TEST-OR-ASSERT-PCS 'ASSERT)
                   (TRACE-PROGN
                    (KM-FORMAT T "(~a ~a):~%Can't do this action because these precondition(s) aren't satisfied:~%~{  ~a~%~}"
                     (COND (CHANGE-TO-NEXT-SITUATION '|try-do-and-next|) (T '|try-do|)) ACTION UNSATISFIED-PCS)
                    (COND (*INTERACTIVE-PRECONDITIONS* (EQ (YNREAD "Would you like me to assume these precondition(s) are true (y or n)? ") 'Y)))))
                  (MAPC #'(LAMBDA (NCS-ITEM) (trace-defun '#:G15689 (NCS-ITEM) (RET (KM-ASSERT NCS-ITEM ACTION :IN-LIST '|ncs-list|))))
                   SEMI-EVALUATED-NCS-LIST)
                  (MAPC
                   #'(LAMBDA (PCS-ITEM)
                      (trace-defun '#:G15690 (PCS-ITEM)
                       (RET
                        (TRACE-PROGN (MAKE-COMMENT "Assuming ~a, to do action ~a..." PCS-ITEM ACTION)
                         (KM-ASSERT PCS-ITEM ACTION :IN-LIST '|pcs-list|)))))
                   UNSATISFIED-PCS)
                     #| Do this instead |# (COND ((OR SEMI-EVALUATED-NCS-LIST UNSATISFIED-PCS) (UN-DONE ACTION :SITUATION (CURR-SITUATION))))
                  (CLET
                   ((NEXT-SITUATION (NEXT-SITUATION ACTION)) #|Now it's okay to have them here, see [4]|# #|tmp|#
                    (ADD-LIST (FIND-PROPOSITIONS ACTION '|add-list|)) #|tmp|# (DEL-LIST (FIND-PROPOSITIONS ACTION '|del-list|)) #|tmp|# #|[3]|#
                    (EVALUATED-ADD-LIST (MAPCAR #'EVALUATE-TRIPLE ADD-LIST)) #|tmp|# (EVALUATED-DEL-LIST (MAPCAR #'EVALUATE-TRIPLE DEL-LIST))
                    (ADD-BLK-LIST (BLOCK-LIST EVALUATED-ADD-LIST)))
                   (COND
                    ((OR DEL-LIST ADD-BLK-LIST ADD-LIST)
                     (KM-TRACE 'COMMENT "Now asserting effects of ~a in the new situation (~a)..." ACTION NEXT-SITUATION)))
                   (IN-SITUATION NEXT-SITUATION)
                   (MAPC #'(LAMBDA (DEL-ITEM) (trace-defun '#:G15691 (DEL-ITEM) (RET (KM-ASSERT DEL-ITEM ACTION :IN-LIST '|del-list|))))
                    EVALUATED-DEL-LIST)
                   (MAPC #'(LAMBDA (BLK-ITEM) (trace-defun '#:G15692 (BLK-ITEM) (RET (KM-ASSERT BLK-ITEM ACTION :IN-LIST '|add-list|))))
                    ADD-BLK-LIST)
                   (MAPC #'(LAMBDA (ADD-ITEM) (trace-defun '#:G15693 (ADD-ITEM) (RET (KM-ASSERT ADD-ITEM ACTION :IN-LIST '|add-list|))))
                    EVALUATED-ADD-LIST)
                   (PROG1 (CURR-SITUATION) (COND ((CNOT CHANGE-TO-NEXT-SITUATION) (IN-SITUATION OLD-SITUATION)))))))))))))))))))))))
;;;; ----------
;;;; (:triple fexpr sexpr vexpr) -> (:triple f s v), or possibly (:triple f s (:set v1 v2))
;;;; The *only* point of evaluate-triple is because find-propositions MAY not evaluate <v>, in the
;;;; two special cases when <v> = an existential or a constraint expr. See (:triple ...) in KM handlers.
(TRACE-LISP
 (DEFINE EVALUATE-TRIPLE (TRIPLE)
  (trace-defun 'EVALUATE-TRIPLE (TRIPLE)
   (RET
    (COND
     ((AND (PATHP (ARG3OF TRIPLE)) (CNOT (COMPARISON-OPERATOR (ARG2OF TRIPLE))))
      (KM-TRACE 'COMMENT "Evaluate the individual frame/slot/val paths in~%        ~a..." TRIPLE)
      `(:|triple| ,(KM-UNIQUE0 (ARG1OF TRIPLE) :FAIL-MODE 'ERROR) ,(KM-UNIQUE0 (ARG2OF TRIPLE) :FAIL-MODE 'ERROR) ,(VALS-TO-VAL (KM0 (ARG3OF TRIPLE)))))
     (T TRIPLE))))))
;;;; ----------------------------------------
#|[1] KM1.4.0-beta17: If slot is single-valued, and (F S OldV) in prev-situation, and (F S V)
    in new situation, then we must also add (OldV InvS (<> F)) otherwise (OldV InvS F) will
    be projected.
ADD LIST:
(F S OldV) = (*TrojanHorse location _Place125)		[later Place125 to be unified with *outside]
(F S V) = (*TrojanHorse location *inside)
location is single-valued.
So need to add: (_Place125 location-of (<> *TrojanHorse)) in the NEW situation. Fine.

But why do this for PCS also??????|#
(TRACE-LISP
 (DEFINE BLOCK-LIST (ADD-LIST)
  (trace-defun 'BLOCK-LIST (ADD-LIST)
   (RET (REMOVE-DUP-INSTANCES (MAPCAN #'(LAMBDA (PROPOSITION) (trace-defun '#:G15694 (PROPOSITION) (RET ))) ADD-LIST))))))
;;;; --------------------
;;;; PCS-LIST and NCS-LIST are assumed SEMI-EVALUATED, ie. <frame> and <slot> are already evaluated
(TRACE-LISP
 (DEFINE CONSISTENT-TO-DO-ACTION (ACTION PCS-LIST NCS-LIST)
  (trace-defun 'CONSISTENT-TO-DO-ACTION (ACTION PCS-LIST NCS-LIST)
   (RET
    (CLET
     ((INCONSISTENT-PCS (INCONSISTENT-PROPOSITIONS PCS-LIST :IN-LIST '|pcs-list|))
      (INCONSISTENT-NCS (INCONSISTENT-PROPOSITIONS NCS-LIST :IN-LIST '|ncs-list|)))
     (COND
      (INCONSISTENT-PCS
       (KM-FORMAT T "(do ~a): Can't do this action as it would be inconsistent to assert precondition(s):~%~{  ~a~%~}" ACTION INCONSISTENT-PCS)))
     (COND
      (INCONSISTENT-NCS
       (KM-FORMAT T "(do ~a): Can't do this action as it would be inconsistent to assert negated precondition(s):~%~{  ~a~%~}" ACTION INCONSISTENT-NCS)))
     (AND (NULL INCONSISTENT-PCS) (NULL INCONSISTENT-NCS)))))))
;; condition for success
(TRACE-LISP
 (DEFINE INCONSISTENT-PROPOSITIONS (PROPOSITIONS &REST LKEYS)
  (trace-defun 'INCONSISTENT-PROPOSITIONS (PROPOSITIONS LKEYS)
   (RET
    (CLET (IN-LIST)
     (COND
      (PROPOSITIONS
       (KM-TRACE 'COMMENT "Checking that the ~a propositions:~%~{  ~a~%~}   are not inconsistent with the current KB..." IN-LIST PROPOSITIONS)
       (REMOVE-IF #'(LAMBDA (PROPOSITION) (trace-defun '#:G15696 (PROPOSITION) (RET (IS-CONSISTENT-TO-ASSERT PROPOSITION :IN-LIST IN-LIST))))
        PROPOSITIONS))))))))
(TRACE-LISP
 (DEFINE IS-CONSISTENT-TO-ASSERT (PROPOSITION &REST LKEYS)
  (trace-defun 'IS-CONSISTENT-TO-ASSERT (PROPOSITION LKEYS)
   (RET
    (CLET (IN-LIST) 
     (COND
      ((KM-TRIPLEP PROPOSITION)
       (CLET ((FRAME (SECOND PROPOSITION))  (SLOT (THIRD PROPOSITION)) (INV-SLOT (INVERT-SLOT SLOT)) (VALUES (VAL-TO-VALS (FOURTH PROPOSITION)))) 
        (CASE IN-LIST
         ((|pcs-list| |add-list|)
          (COND
           ((CL-MEMBER SLOT *INEQUALITY-RELATIONS*) 
            (COND ((NULL VALUES)  (REPORT-ERROR 'USER-ERROR "Triple ~a: missing a value to compare against!" PROPOSITION))
             ((CNOT (SINGLETONP VALUES))
              (REPORT-ERROR 'USER-ERROR "Triple ~a: the last element must be a single value for a comparison operation!" PROPOSITION))
             ((MINIMATCH FRAME '(|the| |?x| |of| |?y|))
              (CLET ((X+Y (MINIMATCH FRAME '(|the| |?x| |of| |?y|))) (X (FIRST X+Y)) (Y (KM-UNIQUE0 (SECOND X+Y) :FAIL-MODE 'ERROR)))
               (KM0 `(,Y &? (|a| |Thing| |with| (,X ((|constraint| (|not| (|TheValue| ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION)))))))))))
             (T (KM0 `(|not| (,FRAME ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION)))))))
            (T (KM0 `(,FRAME &? (|a| |Thing| |with| (,SLOT ,VALUES)))))))
         
         ((|ncs-list| |del-list|)
          (EVERY
           #'(LAMBDA (VALUE)
              (trace-defun '#:G15697 (VALUE)
               (RET
                (AND  (KM0 `(,FRAME &? (|a| |Thing| |with| (,SLOT ((<> ,VALUE))))))
                 (COND
                  ((AND (KB-OBJECTP VALUE) (KB-OBJECTP SLOT) (CNOT (NON-INVERSE-RECORDING-SLOT SLOT)) (CNOT (NON-INVERSE-RECORDING-CONCEPT VALUE)))
                   (KM0 `(,VALUE &? (|a| |Thing| |with| (,INV-SLOT ((<> ,FRAME)))))))
                  (T))))))
           (KM0 (FOURTH PROPOSITION))))
          (T (REPORT-ERROR 'PROGRAM-ERROR "Unknown is-consistent-to-assert in-list type `~a'!~%" IN-LIST)))))
      (T (REPORT-ERROR 'USER-ERROR "~a contains a non-proposition `~a'!~%Ignoring it...~%" IN-LIST PROPOSITION))))))))
;;;; ----------
(TRACE-LISP (DEFINE UNSATISFIED-PROPOSITIONS (PROPOSITIONS) (trace-defun 'UNSATISFIED-PROPOSITIONS (PROPOSITIONS) (RET ))))
;;;; --------------------
;;;; NOTE: - for pcs-list, ncs-list, the first two elements in the proposition have already been evaluated by KM (by semi-evaluate-triple)
;;;;       - for add-list, del-list, the entire proposition has already been evaluated by KM (by evaluate-triple)
;;;; We also assume that the check that propositions don't include constraints for ncs-list and del-list
;;;; has already been done earlier (by find-propositions)
;;;; value can be NIL, or an atom, or a set.
;;;; [1] Don't use also-has!!!! also-has can only be safely used if Values are atomic, and as they are potentially unevaluated
;;;;	then we must use "has" instead and let the unification system deal with it.
(TRACE-LISP
 (DEFINE KM-ASSERT (PROPOSITION ACTION &REST LKEYS)
  (trace-defun 'KM-ASSERT (PROPOSITION ACTION LKEYS)
   (RET
    (CLET (IN-LIST) 
     (COND
      ((KM-TRIPLEP PROPOSITION)
       (CLET
        ((FRAME (SECOND PROPOSITION)) (SLOT (THIRD PROPOSITION)) (INV-SLOT (INVERT-SLOT SLOT)) 
         (VALUES (COND ((CNOT (CL-MEMBER SLOT *INEQUALITY-RELATIONS*))  (KM0 (FOURTH PROPOSITION))))) 
         (CONSTRAINTS (EXTRACT-CONSTRAINTS (VAL-TO-VALS (FOURTH PROPOSITION)))))
          
        (CASE IN-LIST
         ((|pcs-list| |add-list|)
          (COND
           ((CL-MEMBER SLOT *INEQUALITY-RELATIONS*)
            (COND
             ((MINIMATCH FRAME '(|the| |?x| |of| |?y|))
              (CLET ((X+Y (MINIMATCH FRAME '(|the| |?x| |of| |?y|))) (X (FIRST X+Y)) (Y (KM-UNIQUE0 (SECOND X+Y) :FAIL-MODE 'ERROR)))
               (KM0 `(,Y |also-has| (,X ((|constraint| (|not| (|TheValue| ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION))))))) :FAIL-MODE
                'ERROR)))))
            (T (KM0 `(,FRAME |has| (,SLOT ,(APPEND VALUES CONSTRAINTS))) :FAIL-MODE 'ERROR)))
          
          (MAPC
           #'(LAMBDA (VALUE)
              (trace-defun '#:G15699 (VALUE)
               (RET
                (CASE IN-LIST (|pcs-list| (RECORD-EXPLANATION-FOR `(|the| ,SLOT |of| ,FRAME) VALUE `(|precondition-for| ,ACTION)))
                 (|add-list| (RECORD-EXPLANATION-FOR `(|the| ,SLOT |of| ,FRAME) VALUE `(|result-of| ,ACTION)))
                 (T (REPORT-ERROR 'PROGRAM-ERROR "Bad in-list option ~a in km-assert (frame-io.lisp)!" IN-LIST))))))
           VALUES))
         ((|ncs-list| |del-list|)
          (MAPC
           #'(LAMBDA (VALUE)
              (trace-defun '#:G15700 (VALUE)
               (RET
                (TRACE-PROGN (KM0 `(,FRAME |also-has| (,SLOT ((<> ,VALUE)))) :FAIL-MODE 'ERROR)
                 (COND
                  ((AND (KB-OBJECTP VALUE) (KB-OBJECTP SLOT) (CNOT (NON-INVERSE-RECORDING-SLOT SLOT)) (CNOT (NON-INVERSE-RECORDING-CONCEPT VALUE)))
                   (KM0 `(,VALUE |also-has| (,INV-SLOT ((<> ,FRAME)))) :FAIL-MODE 'ERROR)))))))
           VALUES))
          (T (REPORT-ERROR 'PROGRAM-ERROR "Unknown km-assert in-list type `~a'!~%" IN-LIST)))))
      (T (REPORT-ERROR 'USER-ERROR "~a contains a non-proposition `~a'!~%Ignoring it...~%" IN-LIST PROPOSITION))))))))
;;;; Convert (a Triple with ...) to :triple notation.
;;;; slot is expected to be one of: ;$(pcs-list ncs-list add-list del-list)
;;;; RETURNS a list of KM triples (:triple expr expr expr)
;;;; For each (:triple <f> <s> <v>), <f>, <s> are evaluated, and <v> 
;;;; is evaluated UNLESS <v> = an existential or constraint expr.
;;;; This evaluation is done in handling (:triple ...) in interpreter.lisp itself
(TRACE-LISP
 (DEFINE FIND-PROPOSITIONS (ACTION SLOT)
  (trace-defun 'FIND-PROPOSITIONS (ACTION SLOT)
   (RET (CL-REMOVE NIL (MAPCAR #'(LAMBDA (TRIPLE) (trace-defun '#:G15701 (TRIPLE) (RET ))) (KM0 `(|the| ,SLOT |of| ,ACTION))))))))
#|(defun convert-to-triple (triple)
  (cond ((km-triplep triple) triple)
	((isa triple 'X$Triple)
	 (list 'X$:triple
	       (km-unique0 `X$(the frame of ,TRIPLE) :fail-mode 'error)
	       (km-unique0 `X$(the  slot of ,TRIPLE) :fail-mode 'error)
	       (vals-to-val (km0 `X$(the value of ,TRIPLE)))))
	(t (report-error 'user-error "Non-triple ~s found in add-list or del-list of an action!~%" triple))))|#
;;;; ======================================================================
;;;;		KM's THEORY MECHANISM 
;;;; ======================================================================
;;;; In header.lisp
;;;; (defvar *visible-theories* nil)
;;;; Note *DOESN'T* include *global-situation*
(TRACE-LISP (DEFINE VISIBLE-THEORIES NIL (trace-defun 'VISIBLE-THEORIES NIL (RET *VISIBLE-THEORIES*))))
(TRACE-LISP
 (DEFINE HIDE-THEORY (THEORY)
  (trace-defun 'HIDE-THEORY (THEORY)
   (RET
    (COND
     ((AND (CNOT (ISA-THEORY THEORY)) (CNOT (INSTANCE-OF THEORY '|Situation|)))
      (REPORT-ERROR 'USER-ERROR "(hide-theory ~a): ~a is not a theory!" THEORY THEORY))
     ((CNOT (CL-MEMBER THEORY *VISIBLE-THEORIES*)) (KM-TRACE 'COMMENT "[(hide-theory ~a): ~a is already hidden]" THEORY THEORY))
     (T (KM-SETQ '*VISIBLE-THEORIES* (CL-REMOVE THEORY *VISIBLE-THEORIES*))))))))
(TRACE-LISP
 (DEFINE SEE-THEORY (THEORY)
  (trace-defun 'SEE-THEORY (THEORY)
   (RET
    (COND
     ((AND (CNOT (ISA-THEORY THEORY)) (CNOT (INSTANCE-OF THEORY '|Situation|)))
      (REPORT-ERROR 'USER-ERROR "(see-theory ~a): ~a is not a theory!" THEORY THEORY))
     ((CL-MEMBER THEORY *VISIBLE-THEORIES*) (KM-TRACE 'COMMENT "[(see-theory ~a): ~a is already visible]" THEORY THEORY))
     (T (KM-SETQ '*VISIBLE-THEORIES* (CONS THEORY *VISIBLE-THEORIES*))))))))
;;;; Absolutely all theories
;;;; Optimized and to avoid looping. This won't allow a Theory class hierarchy though.
(TRACE-LISP (DEFINE ALL-THEORIES NIL (trace-defun 'ALL-THEORIES NIL (RET (GET-VALS '|Theory| '|instances| :SITUATION *GLOBAL-SITUATION*)))))
(TRACE-LISP (DEFINE ISA-THEORY (THEORY) (trace-defun 'ISA-THEORY (THEORY) (RET (CL-MEMBER THEORY (ALL-THEORIES))))))
(TRACE-LISP
 (DEFINE AM-IN-LOCAL-THEORY NIL
  (trace-defun 'AM-IN-LOCAL-THEORY NIL (RET (AND (NEQ (CURR-SITUATION) *GLOBAL-SITUATION*) (ISA-THEORY (CURR-SITUATION)))))))
(TRACE-LISP
 (DEFINE IN-THEORY (THEORY-EXPR &OPTIONAL KM-EXPR) (trace-defun 'IN-THEORY (THEORY-EXPR KM-EXPR) (RET (IN-SITUATION THEORY-EXPR KM-EXPR T)))))
;; theoryp = t
(TRACE-LISP
 (DEFINE ALL-SITUATIONS-AND-THEORIES NIL (trace-defun 'ALL-SITUATIONS-AND-THEORIES NIL (RET (APPEND (ALL-SITUATIONS) (ALL-THEORIES))))))
;;;; ======================================================================
;;;;			DELETING FRAMES
;;;; ======================================================================
;;;; Note that delete-frame will *ALSO* remove the bindings for it.
;;;; So if X is bound to Y, is bound to Z (X -> Y -> Z), and we delete frame Y,
;;;; then we also delete the binding that Y -> Z, and thus X is left hanging
;;;; (pointing to invisible Y). Thus must be very careful when deleting a single
;;;; frame!
(TRACE-LISP
 (DEFINE DELETE-FRAME (FRAME)
  (trace-defun 'DELETE-FRAME (FRAME)
   (RET
    (TRACE-PROGN
     (MAPC
      #'(LAMBDA (SITUATION)
         (trace-defun '#:G15702 (SITUATION)
          (RET
           (MAPC
            #'(LAMBDA (SLOTVALS)
               (trace-defun '#:G15703 (SLOTVALS)
                (RET (CLET ((SLOT (FIRST SLOTVALS)) (VALS (SECOND SLOTVALS))) (UNINSTALL-INVERSES FRAME SLOT VALS SITUATION)))))
            (GET-SLOTSVALS FRAME :SITUATION SITUATION)))))
      (ALL-SITUATIONS-AND-THEORIES))
     (REMOVE-FROM-STACK FRAME) (DELETE-FRAME-STRUCTURE FRAME))))))
(TRACE-LISP
 (DEFINE SCAN-KB NIL
  (trace-defun 'SCAN-KB NIL
   (RET
    (CLET
     ((DECLARED-SYMBOLS (GET-ALL-CONCEPTS))
      (ALL-OBJECTS
       (CL-FLATTEN
        (MAPCAR
         #'(LAMBDA (SITUATION)
            (trace-defun '#:G15704 (SITUATION)
             (RET
              (MAPCAR
               #'(LAMBDA (CONCEPT)
                  (trace-defun '#:G15705 (CONCEPT)
                   (RET
                    (MAPCAR #'(LAMBDA (FACET) (trace-defun '#:G15706 (FACET) (RET (GET-SLOTSVALS CONCEPT :FACET FACET :SITUATION SITUATION))))
                     *ALL-FACETS*))))
               DECLARED-SYMBOLS))))
         (ALL-SITUATIONS-AND-THEORIES))))
      (ALL-SYMBOLS (CL-REMOVE-DUPLICATES (REMOVE-IF-NOT #'KB-OBJECTP ALL-OBJECTS)))
      (USER-SYMBOLS
       (SET-DIFFERENCE ALL-SYMBOLS (APPEND *BUILT-IN-FRAMES* *KM-LISP-EXPRS* *DOWNCASE-KM-LISP-EXPRS* *RESERVED-KEYWORDS* *ADDITIONAL-KEYWORDS*)))
      (UNDECLARED-SYMBOLS
       (REMOVE-IF
        #'(LAMBDA (SYMBOL)
           (trace-defun '#:G15707 (SYMBOL)
            (RET (OR (CL-MEMBER SYMBOL DECLARED-SYMBOLS) (COMMENT-TAGP SYMBOL) (CL-MEMBER (INVERT-SLOT SYMBOL) DECLARED-SYMBOLS)))))
        USER-SYMBOLS)))
     (COND
      (UNDECLARED-SYMBOLS (KM-FORMAT T "A cursory check of the KB shows (at least) these symbols were undeclared:~%" (LENGTH UNDECLARED-SYMBOLS))
       (MAPC #'(LAMBDA (SYMBOL) (trace-defun '#:G15708 (SYMBOL) (RET (KM-FORMAT T "   ~a~%" SYMBOL))))
        (SORT UNDECLARED-SYMBOLS #'STRING< :KEY #'SYMBOL-NAME))
       (FORMAT T "----- end -----~%")))
       '(|t|))))))
;;;; ======================================================================
;;;;		SITUATIONS MODE
;;;; ======================================================================
(TRACE-LISP (DEFVAR *AM-IN-SITUATIONS-MODE* NIL))
(TRACE-LISP
 (DEFINE SET-SITUATIONS-MODE NIL
  (trace-defun 'SET-SITUATIONS-MODE NIL
   (RET (OR *AM-IN-SITUATIONS-MODE* (TRACE-PROGN (MAKE-COMMENT "Switching on situations mode for this KB") (KM-SETQ '*AM-IN-SITUATIONS-MODE* T)))))))
(TRACE-LISP (DEFINE AM-IN-SITUATIONS-MODE NIL (trace-defun 'AM-IN-SITUATIONS-MODE NIL (RET *AM-IN-SITUATIONS-MODE*))))
;;;; Under these special circumstances, DON'T compute the value of a slot
(TRACE-LISP
 (DEFINE IGNORE-SLOT-DUE-TO-SITUATIONS-MODE (SLOT)
  (trace-defun 'IGNORE-SLOT-DUE-TO-SITUATIONS-MODE (SLOT)
   (RET (AND *AM-IN-SITUATIONS-MODE* (AM-IN-GLOBAL-SITUATION) (CNOT (AM-IN-PROTOTYPE-MODE)) (FLUENTP SLOT))))))
;;;; returns t and print error if there's a violation
(TRACE-LISP
 (DEFINE CHECK-SITUATIONS-MODE (INSTANCE SLOT)
  (trace-defun 'CHECK-SITUATIONS-MODE (INSTANCE SLOT)
   (RET
    (COND
     ((IGNORE-SLOT-DUE-TO-SITUATIONS-MODE SLOT)
      (REPORT-ERROR 'USER-ERROR
       "Attempt to call (the ~a of ~a) in the global situation!
(Not allowed, as `~a' is a fluent and you're using KM's situation mechanism).
DEBUGGING HINTS:
 * IF you issued your query for the `~a' slot from the global situation
   THEN you shouldn't do this! You should only issue queries for a fluent slot from 
        within a situation, not from the global KB. 
   SOLUTIONS: 
     (i) Enter a situation by
		KM> (new-situation)
	 then reissue your query, or
    (ii) Declare the `~a' slot as a non-fluent (i.e. with time-independent values), by
	        KM> (~a has (fluent-status (*Non-Fluent)))~%
 * IF you issued your query from within a local situation
   THEN You may have a non-fluent slot depending on the value of a fluent slot (= bad!)
        and KM is trying to compute that non-fluent slot's values in the global situation.
   TO LOCATE THIS: Type `g' to see the goal hierarchy, and look for a 
		   non-fluent slot's value being computed from a fluent's value. 
   TO FIX THIS: Change the non-fluent to be a *Fluent/*Inertial-Fluent, or edit the 
		   dependency.~%"
       SLOT INSTANCE SLOT SLOT SLOT SLOT)
      T))))))
;; old error message
;;	 (report-error 'user-error "Attempt to call (the ~a of ~a) in the global situation!
;;As you are currently using KM's situations mechanism in your KB, you should only issue queries 
;;for a fluent slot (here `~a') from within a situation, not from the global KB. 
;; - To enter a situation, type (new-situation), or
;; - To declare the `~a' slot as a non-fluent (i.e. with time-independent values), enter
;;       (~a has (fluent-status (*Non-Fluent)))~%" slot instance slot slot slot)
;;;; FILE:  trace.lisp
;;;; File: trace.lisp
;;;; Author: Peter Clark
;;;; Purpose: Debugging facilities for KM
;;;; ======================================================================
;;;;		    FOR TRACING EXECUTION
;;;; ======================================================================
(TRACE-LISP (DEFVAR *TRACE-CLASSIFY* NIL))
(TRACE-LISP (DEFVAR *TRACE-OTHER-SITUATIONS* NIL))
(TRACE-LISP (DEFVAR *TRACE-UNIFY* NIL))
(TRACE-LISP (DEFVAR *TRACE-SUBSUMES* NIL))
(TRACE-LISP (DEFVAR *TRACE-CONSTRAINTS* NIL))
(TRACE-LISP (DEFVAR *SUSPENDED-TRACE* NIL))
(TRACE-LISP (DEFVAR *INTERACTIVE-TRACE* NIL))
;;(defvar *depth* 0)			; move earlier, to header.lisp
(TRACE-LISP
 (DEFINE TRACEKM NIL
  (trace-defun 'TRACEKM NIL
   (RET
    (TRACE-PROGN (RESET-TRACE)
     (COND (*TRACE* (FORMAT T "(Tracing of KM is already switched on)~%"))
      (T (FORMAT T "(Tracing of KM switched on)~%") (KM-SETQ '*TRACE* T) (CSETQ *INTERACTIVE-TRACE* T)))
     T)))))
(TRACE-LISP
 (DEFINE UNTRACEKM NIL
  (trace-defun 'UNTRACEKM NIL
   (RET
    (TRACE-PROGN (RESET-TRACE)
     (COND (*TRACE* (FORMAT T "(Tracing of KM switched off)~%") (CSETQ *TRACE* NIL) (CSETQ *INTERACTIVE-TRACE* NIL))
      (T (FORMAT T "(Tracing of KM is already switched off)~%")))
     T)))))
(TRACE-LISP
 (DEFINE RESET-TRACE NIL
  (trace-defun 'RESET-TRACE NIL
   (RET
    (TRACE-PROGN (COND ((OR *TRACE* *INTERACTIVE-TRACE*)  (CSETQ *INTERACTIVE-TRACE* T) (CSETQ *TRACE* T)))  (CSETQ *SUSPENDED-TRACE* NIL)
     (CSETQ *TRACE-CLASSIFY* NIL) (CSETQ *TRACE-SUBSUMES* NIL) (CSETQ *TRACE-OTHER-SITUATIONS* NIL) (CSETQ *TRACE-UNIFY* NIL)
     (CSETQ *TRACE-CONSTRAINTS* NIL) T)))))
(TRACE-LISP (DEFINE RESET-TRACE-DEPTH NIL (trace-defun 'RESET-TRACE-DEPTH NIL (RET (CSETQ *DEPTH* 0)))))
(TRACE-LISP (DEFINE TRACEP NIL (trace-defun 'TRACEP NIL (RET *TRACE*))))
(TRACE-LISP (DEFINE TRACEUNIFYP NIL (trace-defun 'TRACEUNIFYP NIL (RET *TRACE-UNIFY*))))
(TRACE-LISP (DEFINE TRACESUBSUMESP NIL (trace-defun 'TRACESUBSUMESP NIL (RET *TRACE-SUBSUMES*))))
(TRACE-LISP (DEFINE TRACECLASSIFYP NIL (trace-defun 'TRACECLASSIFYP NIL (RET *TRACE-CLASSIFY*))))
(TRACE-LISP (DEFINE TRACECONSTRAINTSP NIL (trace-defun 'TRACECONSTRAINTSP NIL (RET *TRACE-CONSTRAINTS*))))
(TRACE-LISP (DEFINE TRACEOTHERSITUATIONSP NIL (trace-defun 'TRACEOTHERSITUATIONSP NIL (RET *TRACE-OTHER-SITUATIONS*))))
;;;; ----------------------------------------
;;;;	SPY POINTS
;;;; ----------------------------------------
;;;; [1] minimatch expects &REST, but user will type &rest at KM prompt.
(TRACE-LISP
 (DEFINE SPY (&OPTIONAL EXPR0)
  (trace-defun 'SPY (EXPR0)
   (RET
    (CLET ((EXPR (SUBST '&REST '|&rest| EXPR0))) 
     (COND ((AND EXPR (CNOT (CL-MEMBER EXPR *SPYPOINTS* :TEST #'CL-EQUAL))) (CSETQ *SPYPOINTS* (CONS EXPR *SPYPOINTS*))))
     (COND
      (*SPYPOINTS*
       (KM-FORMAT T "The tracer will automatically switch on when evaluating these expressions/patterns:~%~{      ~a~%~}"
        (SUBST '|&rest| '&REST *SPYPOINTS*)))
      (T (KM-FORMAT T "(You have no spypoints declared)~%")))
     '(|t|))))))
(TRACE-LISP
 (DEFINE UNSPY NIL (trace-defun 'UNSPY NIL (RET (TRACE-PROGN (CSETQ *SPYPOINTS* NIL) (KM-FORMAT T "(All spypoints removed)~%") '(|t|))))))
;;;; ======================================================================
;;;;		     THE TRACE UTILITY
;;;; ======================================================================
#|OWN NOTES:
depth = 0
  call (the parts of *MyCar) -> depth = 1
NOW: suppose I type "s":
	- suspend-trace = 1, trace = nil
EXIT.
Next: if CALL then depth goes up to 2.
      if FAIL, or EXIT then depth stays 1, and suspend-trace -> nil, trace -> t.
	on exit, depth will go back down to 0.
      if COMMENT, depth is unchanged, and trace/suspend-trace is unchanged.

If I type "n", trace is permenantly switched off, EXCEPT *interactive-trace* is left on.
If I type "z", *interactive-trace* is switched permanently off, EXCEPT *trace* is left on.|#
(TRACE-LISP (DEFVAR *TRACE-GOAL-STACK* NIL))
(TRACE-LISP (DEFINE KM-TRACE (MODE STRING &REST ARGS) (trace-defun 'KM-TRACE (MODE STRING ARGS) (RET ))))
(TRACE-LISP (DEFINE KM-TRACE2 (MODE STRING ARGS) (trace-defun 'KM-TRACE2 (MODE STRING ARGS) (RET ))))
(TRACE-LISP
 (DEFINE INCREMENT-TRACE-DEPTH NIL
  (trace-defun 'INCREMENT-TRACE-DEPTH NIL
   (RET (TRACE-PROGN (COND ((>= *DEPTH* *STATISTICS-MAX-DEPTH*) (CSETQ *STATISTICS-MAX-DEPTH* (1+ *DEPTH*)))) (CSETQ *DEPTH* (1+ *DEPTH*)))))))
(TRACE-LISP (DEFINE DECREMENT-TRACE-DEPTH NIL (trace-defun 'DECREMENT-TRACE-DEPTH NIL (RET (CSETQ *DEPTH* (1- *DEPTH*))))))
#| Iterate again, making sure counters stay unchanged.
(defun retrace (mode string &optional args)
  (cond ((eq mode 'call) (setq *depth* (1- *depth*))))	   ; (<- as it will be immediately incremented again)  
  (apply X'km-trace `(,mode ,string . ,args)))		   ; ie. (km-trace mode string arg1 ... argn)|#
#|THIS IS WHAT QUINTUS PROLOG GIVES YOU
Debugging options:
 <cr>   creep      p      print         r [i]  retry i      @    command
  c     creep      w      write         f [i]  fail i       b    break
  l     leap       d      display                           a    abort
  s [i] skip i                                              h    help
  z     zip        g [n]  n ancestors   +      spy pred     ?    help
  n     nonstop    < [n]  set depth     -      nospy pred   =    debugging
  q     quasi-skip .      find defn     e      raise_exception|#
(TRACE-LISP
 (DEFINE PRINT-TRACE-OPTIONS NIL
  (trace-defun 'PRINT-TRACE-OPTIONS NIL
   (RET
    (FORMAT T
     "----------------------------------------
Debugging options during the trace:
 <cr>,c   creep       - single step forward
  g       goal stack  - print goal stack
  s       skip        - jump to completion of current subgoal
  w       where       - Show which frame the current rule came from
  S       big skip    - jump to completion of parent subgoal
  r       retry       - redo the current subgoal
  n       nonstop     - switch off trace for remainder of this query
  a       abort       - return to top-level prompt
  A       abort & off - return to top-level prompt AND switch off tracer
  o       trace off   - permenantly switch off trace 
  f       fail        - return NIL for current goal (use with caution!)
  z       zip         - complete query with noninterative trace
  d <f>   display <f> - display (showme) frame <f>
  h,?     help        - this message

Also to show additional detail (normally not shown) for this query *only*:
  +S      in other situation(s)
  +U      during unification
  +C      during constraint checking
  +X      during classification
  +A      trace absolutely everything
  +M	  during subsumption testing
  -S,-U,-C,-X,-A,-M to unshow

Or from the KM prompt: 
  KM> (trace)     switches on debugger
  KM> (untrace)   switches off the debugger
----------------------------------------
")))))
#|An abbreviated list:
Debugging options:                              Also show detailed inference:
 <cr>,c   creep      f    fail                  +C  during classification
  s       skip       z    zip (noninterative)   +S  in other situation(s)
  r       retry      g    show goal stack       +U  during unification
  n       nonstop    d F  display frame F       -C,-S,-U to unshow
  o       trace off  S    big skip (to completion of parent goal)
  h,?     help |#
#|NB MUSTN'T suspend/unsuspend unless trace was already on
This is ok:
  (cond ((and (tracep) (not (traceclassifyp))) (prog2 (suspend-trace) <foo> (unsuspend-trace)))
	(t <foo>))
This is not!
  (prog2 (suspend-trace) <foo> (unsuspend-trace))
because the (unsuspend-trace) will restart the trace, even if the 
trace was already off ie. (suspend-trace) had no effect.

NOTE!! <foo> MUSTN'T be a function returning multiple values! prog2 
seems to strip all but the first value off!|#
;;;; Suspend trace until exit the call at depth *depth*
(TRACE-LISP
 (DEFINE SUSPEND-TRACE (&OPTIONAL DEPTH)
  (trace-defun 'SUSPEND-TRACE (DEPTH) (RET (TRACE-PROGN (SUBLISP-INITVAR DEPTH *DEPTH*) (CSETQ *SUSPENDED-TRACE* DEPTH) (CSETQ *TRACE* NIL))))))
;;;; If we suspended the trace, but then the debugger kicked in again automatically, and
;;;; then we switched off the trace (option "n"), we *don't* want to switch it back on again!
(TRACE-LISP
 (DEFINE UNSUSPEND-TRACE NIL
  (trace-defun 'UNSUSPEND-TRACE NIL (RET (COND (*SUSPENDED-TRACE* (CSETQ *SUSPENDED-TRACE* NIL) (CSETQ *TRACE* T)))))))
;;;; ======================================================================
;;;;		COMMENTS
;;;; ======================================================================
(TRACE-LISP
 (DEFINE MAKE-COMMENT (STRING &REST ARGS)
  (trace-defun 'MAKE-COMMENT (STRING ARGS)
   (RET (COND (*SHOW-COMMENTS* (APPLY #'KM-FORMAT `(T ,(CONCAT "(COMMENT: " STRING ")~%") ,@(DESOURCE0 ARGS)))))))))
(TRACE-LISP
 (DEFINE COMMENTS NIL
  (trace-defun 'COMMENTS NIL
   (RET
    (TRACE-PROGN
     (COND (*SHOW-COMMENTS* (FORMAT T "(Display of comments is already switched on)~%"))
      (T (FORMAT T "(Display of comments is switched on)~%") (KM-SETQ '*SHOW-COMMENTS* T)))
     T)))))
(TRACE-LISP
 (DEFINE NOCOMMENTS NIL
  (trace-defun 'NOCOMMENTS NIL
   (RET
    (TRACE-PROGN
     (COND (*SHOW-COMMENTS* (FORMAT T "(Display of comments is switched off)~%") (KM-SETQ '*SHOW-COMMENTS* NIL))
      (T (FORMAT T "(Display of comments is already switched off)~%")))
     T)))))
;;;; ======================================================================
;;;;		ERRORS
;;;; ======================================================================
#|Behaviors on error:
 *error-report-silent*     - ignore the error and continue. Overrides abort-on-error-report
 *abort-on-error-report*   - report error and abort (NEW: now throwing the error message back too)
 otherwise		   - report error and switch on debugger at next opportunity

example:
(let ((*abort-on-error-report* t)           ; default is nil
      (*silently-abort-on-error-report* t)
      (*error-report-silent* nil))          ; default is nil
  (km `X$(the subclasses of Car)))
> 1. nil
  2. "ERROR! No values found for (the subclasses of Car)!"|#
;;;; For Jihie - to supress error reporting
;;;; [3] Thanks to Francis Leboutte for *silently-abort-on-error-report*
;;;;     Set or bind this variable to t in order to suppress the error message
;;;;     printed in the console when *abort-on-error-report* is t
(TRACE-LISP (DEFVAR *ERROR-REPORT-SILENT* NIL))
;; **** another NEW LINE
(TRACE-LISP (DEFVAR *ABORT-ON-ERROR-REPORT* NIL))
(TRACE-LISP (DEFVAR *SILENTLY-ABORT-ON-ERROR-REPORT* T))
;; [3] - new default is t
;;;; FLE 02Aug2005: the call to km-format is conditioned to the value of
;;;; *silently-abort-on-error-report*
(TRACE-LISP
 (DEFINE REPORT-ERROR (ERROR-TYPE STRING &REST ARGS)
  (trace-defun 'REPORT-ERROR (ERROR-TYPE STRING ARGS)
   (RET
    (FUNLESS *ERROR-REPORT-SILENT* 
     (CLET
      ((ERROR-STR-PREFIX
        (CASE ERROR-TYPE (USER-ERROR "ERROR! ") (USER-WARNING "WARNING! ") (PROGRAM-ERROR "PROGRAM ERROR! ") (NODEBUGGER-ERROR "ERROR! ")
         (ABORT-ERROR "ERROR! ") (T (FORMAT NIL "ERROR! Error in report-error! Unrecognized error type ~a!~%" ERROR-TYPE))))
       (ERROR-STR (CONCAT ERROR-STR-PREFIX (APPLY #'KM-FORMAT `(NIL ,STRING ,@(DESOURCE0 ARGS))))))
      (FORMAT T ERROR-STR)
      (COND ((CL-MEMBER ERROR-TYPE '(USER-WARNING NODEBUGGER-ERROR)) NIL) 
       ((OR *ABORT-ON-ERROR-REPORT* (EQ ERROR-TYPE 'ABORT-ERROR))  
        (FUNLESS *SILENTLY-ABORT-ON-ERROR-REPORT* (KM-FORMAT T "Throwing error...~a~%" ERROR-STR)) (THROW 'KM-ABORT (LIST 'KM-ABORT ERROR-STR)))
       ((CL-MEMBER ERROR-TYPE '(USER-ERROR PROGRAM-ERROR))
        (COND
         ((AND (CNOT *TRACE*) (CNOT *SUSPENDED-TRACE*))
          (FORMAT T
           "
	-------------------------
	**Switching on debugger** 
Options include:
  g: to see the goal stack
  r: to retry current goal
  a: to abort
  o: to switch off debugger
  A: abort & off - return to top-level prompt AND switch off tracer
  ?: to list more options
	-------------------------

")))
        (CSETQ *TRACE* T) (CSETQ *INTERACTIVE-TRACE* T) (CSETQ *SUSPENDED-TRACE* NIL) (COND (*DEVELOPER-MODE* (BREAK))) NIL)
        (T (WARN "Unknown KM error type: ~s" ERROR-TYPE) NIL))))))))
;;;; ======================================================================
;;;;		CATCHING THE TRACING INFORMATION
;;;; ======================================================================
(TRACE-LISP
 (DEFINE CATCH-EXPLANATIONS NIL
  (trace-defun 'CATCH-EXPLANATIONS NIL
   (RET
    (TRACE-PROGN (KM-FORMAT T "(KM will catch the explanations for the next KM call)~%") (CSETQ *EXPLANATIONS* NIL)
     (CSETQ *CATCH-NEXT-EXPLANATIONS* T))))))
;;;; [1] ((call [0]) (call [1]) (call [2]) (exit [2]) (fail [1]))
;;;; ->  ((call [0])
(TRACE-LISP
 (DEFINE CATCH-EXPLANATION (KMEXPR-WITH-COMMENTS MODE)
  (trace-defun 'CATCH-EXPLANATION (KMEXPR-WITH-COMMENTS MODE)
   (RET
    (COND
     ((CNOT (AND (LISTP KMEXPR-WITH-COMMENTS) (CL-MEMBER (FIRST KMEXPR-WITH-COMMENTS) *NO-DECOMMENT-HEADWORDS*)))
      (CLET
       ((COMMENT-TAGS (GET-COMMENT-TAGS KMEXPR-WITH-COMMENTS))
        (EXPLANATIONS
         (MAPCAR #'(LAMBDA (COMMENT-TAG) (trace-defun '#:G15710 (COMMENT-TAG) (RET (GET-COMMENT2 COMMENT-TAG MODE)))) COMMENT-TAGS)))
       (COND
        ((AND EXPLANATIONS *CATCH-EXPLANATIONS*)
         (CASE MODE ((CALL EXIT) (KM-SETQ '*EXPLANATIONS* (CONS `(,(1+ *DEPTH*) ,MODE ,COMMENT-TAGS ,EXPLANATIONS) *EXPLANATIONS*)))
          (FAIL (KM-SETQ '*EXPLANATIONS* (TRIM-FAILED-EXPLANATIONS *EXPLANATIONS* (1+ *DEPTH*) COMMENT-TAGS))))))
       (COND
        ((AND EXPLANATIONS *PRINT-EXPLANATIONS*)
         (MAPC
          #'(LAMBDA (EXPLANATION)
             (trace-defun '#:G15711 (EXPLANATION) (RET (KM-FORMAT T "~vT~a: ~a~%" *DEPTH* (STRING-UPCASE MODE) EXPLANATION))))
          EXPLANATIONS))))))))))
(TRACE-LISP
 (DEFINE TRIM-FAILED-EXPLANATIONS (EXPLANATIONS DEPTH COMMENT-TAGS)
  (trace-defun 'TRIM-FAILED-EXPLANATIONS (EXPLANATIONS DEPTH COMMENT-TAGS)
   (RET
    (COND
     ((ENDP EXPLANATIONS)
      (REPORT-ERROR 'PROGRAM-ERROR "Fail encountered in the explanation stack without a matching call!~%Depth ~a, comment-tags ~a~%" DEPTH COMMENT-TAGS))
     ((AND (EQ (FIRST (FIRST EXPLANATIONS)) DEPTH) (EQ (SECOND (FIRST EXPLANATIONS)) 'CALL) (CL-EQUAL (THIRD (FIRST EXPLANATIONS)) COMMENT-TAGS))
      (REST EXPLANATIONS))
     (T (TRIM-FAILED-EXPLANATIONS (REST EXPLANATIONS) DEPTH COMMENT-TAGS)))))))
(TRACE-LISP
 (DEFINE SHOW-EXPLANATIONS-XML (&REST LKEYS)
  (trace-defun 'SHOW-EXPLANATIONS-XML (LKEYS) (RET (CLET (STREAM) (init-keyval STREAM T) (SHOW-EXPLANATIONS :FORMAT 'XML :STREAM STREAM))))))
(TRACE-LISP
 (DEFINE SHOW-EXPLANATIONS-HTML (&REST LKEYS)
  (trace-defun 'SHOW-EXPLANATIONS-HTML (LKEYS) (RET (CLET (STREAM) (init-keyval STREAM T) (SHOW-EXPLANATIONS :FORMAT 'HTML :STREAM STREAM))))))
;;;; --------------------
(TRACE-LISP (DEFVAR *INDENT-LEVEL* 0))
(TRACE-LISP
 (DEFINE SHOW-EXPLANATIONS (&REST LKEYS)
  (trace-defun 'SHOW-EXPLANATIONS (LKEYS)
   (RET
    (CLET (EXPLANATIONS FORMAT STREAM) (init-keyval STREAM T) (init-keyval FORMAT 'ASCII) (init-keyval EXPLANATIONS *EXPLANATIONS*) (CSETQ *INDENT-LEVEL* 0)
     (COND ((EQ FORMAT 'XML) (FORMAT STREAM "<explanation-structure>~%")))
     (MAPC
      #'(LAMBDA (EXPLANATION-STR)
         (trace-defun '#:G15712 (EXPLANATION-STR)
          (RET
           (CLET
            ((DEPTH (FIRST EXPLANATION-STR)) (MODE (SECOND EXPLANATION-STR)) (COMMENT-TAGS (THIRD EXPLANATION-STR))
             (EXPLANATIONS (FOURTH EXPLANATION-STR)))
            (MAPC
             #'(LAMBDA (EXPLANATION)
                (trace-defun '#:G15713 (EXPLANATION) (RET (SHOW-EXPLANATION EXPLANATION DEPTH MODE COMMENT-TAGS :FORMAT FORMAT :STREAM STREAM))))
             EXPLANATIONS)))))
      (REVERSE EXPLANATIONS))
     (COND ((EQ FORMAT 'XML) (FORMAT STREAM "</explanation-structure>~%"))) T)))))
(TRACE-LISP
 (DEFINE SHOW-EXPLANATION (EXPLANATION DEPTH MODE COMMENT-TAGS &REST LKEYS)
  (trace-defun 'SHOW-EXPLANATION (EXPLANATION DEPTH MODE COMMENT-TAGS LKEYS)
   (RET
    (CLET (FORMAT STREAM) (init-keyval STREAM T) (DECLARE (IGNORE COMMENT-TAGS))
     (CLET ((SENTENCE (MAKE-PHRASE (KM EXPLANATION))) (NL (COND (STREAM *NEWLINE-STR*) (T ""))))
      (CASE FORMAT 
       (ASCII
        (PROG2 (COND ((EQ MODE 'CALL) (CSETQ *INDENT-LEVEL* (1+ *INDENT-LEVEL*))))
         (FORMAT STREAM (CONCAT (SPACES (* 2 *INDENT-LEVEL*)) "* " SENTENCE "~%"))
         (COND ((EQ MODE 'EXIT) (CSETQ *INDENT-LEVEL* (MAX 0 (1- *INDENT-LEVEL*)))))))
       (XML (FORMAT STREAM (CONCAT "<explanation depth=~a mode=~a>~a</explanation>" NL) DEPTH (CL-STRING-DOWNCASE MODE) SENTENCE))
       (HTML
        (CASE MODE (CALL (FORMAT STREAM (CONCAT "<ul><li>~a" NL) SENTENCE)) (EXIT (FORMAT STREAM (CONCAT "<li>~a</ul>" NL) SENTENCE))
         (T (REPORT-ERROR 'PROGRAM-ERROR "show-error: Unrecognized mode ~a~%" MODE))))
       (T (REPORT-ERROR 'PROGRAM-ERROR "show-explanation: Unrecognized format ~a!~%" MODE)))))))))
;;;; --------------------
(TRACE-LISP (DEFINE GRAB-EXPLANATIONS-XML NIL (trace-defun 'GRAB-EXPLANATIONS-XML NIL (RET (GRAB-EXPLANATIONS :FORMAT 'XML)))))
(TRACE-LISP (DEFINE GRAB-EXPLANATIONS-HTML NIL (trace-defun 'GRAB-EXPLANATIONS-HTML NIL (RET (GRAB-EXPLANATIONS :FORMAT 'HTML)))))
(TRACE-LISP
 (DEFINE GRAB-EXPLANATIONS (&REST LKEYS)
  (trace-defun 'GRAB-EXPLANATIONS (LKEYS)
   (RET
    (CLET (EXPLANATIONS FORMAT) (init-keyval FORMAT 'ASCII) (init-keyval EXPLANATIONS *EXPLANATIONS*) (CSETQ *INDENT-LEVEL* 0)
     (APPEND (COND ((EQ FORMAT 'XML) (LIST (FORMAT NIL "<explanation-structure>"))))
      (MAPCAN
       #'(LAMBDA (EXPLANATION-STR)
          (trace-defun '#:G15714 (EXPLANATION-STR)
           (RET
            (CLET
             ((DEPTH (FIRST EXPLANATION-STR)) (MODE (SECOND EXPLANATION-STR)) (COMMENT-TAGS (THIRD EXPLANATION-STR))
              (EXPLANATIONS (FOURTH EXPLANATION-STR)))
             (MAPCAR
              #'(LAMBDA (EXPLANATION)
                 (trace-defun '#:G15715 (EXPLANATION) (RET (SHOW-EXPLANATION EXPLANATION DEPTH MODE COMMENT-TAGS :FORMAT FORMAT :STREAM NIL))))
              EXPLANATIONS)))))
       (REVERSE EXPLANATIONS))
      (COND ((EQ FORMAT 'XML) (LIST (FORMAT NIL "</explanation-structure>"))))))))))
;;;; FILE:  lazy-unify.lisp
;;;; File: lazy-unify.lisp
;;;; Author: Peter Clark
;;;; Date: Sept 1994, revised (debugged!) Jan 1995, rewritten 1996.
;;;; Purpose: How do you unify two complex graphs which essentially connect
;;;; 	to the entire KB? This clever solution is based on delayed (lazy)
;;;;	evaluation of the unification.
(TRACE-LISP (DEFINE VAL-UNIFICATION-OPERATOR (X) (trace-defun 'VAL-UNIFICATION-OPERATOR (X) (RET (CL-MEMBER X '(& &? &! &+ &+? ==))))))
(TRACE-LISP (DEFINE SET-UNIFICATION-OPERATOR (X) (trace-defun 'SET-UNIFICATION-OPERATOR (X) (RET (CL-MEMBER X '(&& #|&&?|# &&! ===))))))
(TRACE-LISP
 (DEFINE UNIFICATION-OPERATOR (X) (trace-defun 'UNIFICATION-OPERATOR (X) (RET (CL-MEMBER X '(& &? &! && #|&&?|# &&! &+ &+? == ===))))))
;;;; Experimental modifications for HALO project
(TRACE-LISP (DEFVAR *LESS-AGGRESSIVE-CONSTRAINT-CHECKING* NIL))
#|MAIN ENTRY POINTS
=================
LAZY-UNIFY-&-EXPR -> lazy-unify-exprs -> lazy-unify: Use for &, &&
TRY-LAZY-UNIFY: Use for &?

Note there is no &&? operator any more. 

Also note lazy-unify is *NOT* a main entry point.
LAZY-UNIFY always takes ATOMIC atoms, not (:triple ...) etc.

TRY-LAZY-UNIFY2: Is a susidiary of TRY-LAZY-UNIFY and LAZY-UNIFY. Returns binding information,
  which is discarded by try-lazy-unify but used by lazy-unify.

(lazy-unify '_Person1 '_Professor1)
Returns NIL if they won't unify. Does a quick check on slot-val compatibility,
so that IF there's a single-valued slot AND there's a value on each instance
AND those values are atomic AND they are unifiable THEN the unification fails.

In addition, we add a classes-subsumep mode:
  If it's T (used for &&) then the classes of one instance must *subsume* the classes of another. 
	Thus cat & dog won't unify.
  If it's NIL (used for &) then the classes are assumed mergable, eg. pet & fish will unify
	to (superclasses (pet fish)).

eagerlyp: if true, then do eager rather than lazy unification, ie. don't leave any & or && residues on frames, 
 just atomic values.|#
(TRACE-LISP (DEFPARAMETER *SEE-UNIFICATIONS* NIL))
;;;; NOTE: instances are NOT structured values -- structures will have already been broken up by lazy-unify-exprs.
;;;; [1] Make sure that (_X == 1) will result in _X being added to *kb-objects* list. This is critical if we want
;;;;     to reset the KB and thus destroy the binding for _X!
;;;; NOTE: instancename1 OR instancename2 can be structured-list-vals, but NOT both
(TRACE-LISP
 (DEFINE LAZY-UNIFY (INSTANCENAME1 INSTANCENAME2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY (INSTANCENAME1 INSTANCENAME2 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)
     (CLET
      ((INSTANCE1 (DEREFERENCE INSTANCENAME1))  (INSTANCE2 (DEREFERENCE INSTANCENAME2))
       (UNIFICATION (LAZY-UNIFY0 INSTANCE1 INSTANCE2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)))
      (COND
       ((AND UNIFICATION  (CNOT (CL-EQUAL INSTANCE1 INSTANCE2)) (CNOT (NULL INSTANCE1)) (CNOT (NULL INSTANCE2))) 
        (MAKE-COMMENT "(~a ~a ~a) unified to be ~a" INSTANCENAME1 (COND (CLASSES-SUBSUMEP '&&) (EAGERLYP '&!) (T '&)) INSTANCENAME2 UNIFICATION) ))
      (COND ((AND (KB-OBJECTP INSTANCENAME1) (CNOT (KNOWN-FRAME INSTANCENAME1))) (KM-ADD-TO-KB-OBJECT-LIST INSTANCENAME1))) 
      (COND ((AND (KB-OBJECTP INSTANCENAME2) (CNOT (KNOWN-FRAME INSTANCENAME2))) (KM-ADD-TO-KB-OBJECT-LIST INSTANCENAME2))) UNIFICATION))))))
;;;; [1] NOTE failure to unify an element means the whole unification should fail
(TRACE-LISP
 (DEFINE LAZY-UNIFY0 (INSTANCENAME1 INSTANCENAME2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY0 (INSTANCENAME1 INSTANCENAME2 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)  
     (CLET ((INSTANCE1 INSTANCENAME1) (INSTANCE2 INSTANCENAME2))
      (COND ((CL-EQUAL INSTANCE1 INSTANCE2) INSTANCE1)  ((NULL INSTANCE1) INSTANCE2) ((NULL INSTANCE2) INSTANCE1)
       (T (LAZY-UNIFY2 INSTANCE1 INSTANCE2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)))))))))
;;;; ----------------------------------------
#|[3] This is where the result is finally stored in memory
[4] There's a subtle special case here. Fluent instances are NOT projected, so if we have (*MyCar owner _SomePerson3) in S0,
then ask for (*MyCar owner) in S1, we get NIL, and then (*MyCar owner) is flagged as DONE in S1. Fine so far.
But suppose later _SomePerson3 becomes a non-fluent instance, by doing (_SomePerson3 & *Pete) - now it SHOULD be
projected to S1, which would require removing the DONE flag on (*MyCar owner) in S1. But of course this unification
will not remove the DONE flag on all the things which are in some relationship to _SomePerson3.
We can probably make it do that though with a (very) special purpose line of code in lazy-unify.lisp!
[5] maybe-project-values i1 i2; i1 has a non-projected value in prev situation; i2 has the same value in curr situation.
    So i1 and i2 can unify, but we don't need to perform an un-done on i1.|#
(TRACE-LISP
 (DEFINE LAZY-UNIFY2 (INSTANCE1 INSTANCE2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY2 (INSTANCE1 INSTANCE2 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)
     (MULTIPLE-VALUE-BIND (UNIFIED-NAME SITN+SVS-PAIRS BINDING-LIST)
      (TRY-LAZY-UNIFY2 INSTANCE1 INSTANCE2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP) 
      (CLET ((CHANGE-MADE NIL))
       (COND
        (UNIFIED-NAME  (MAPC #'(LAMBDA (BINDING) (trace-defun '#:G15716 (BINDING) (RET ))) BINDING-LIST)
         (COND
          ((KB-OBJECTP UNIFIED-NAME) 
           (CLET ((CURR-SITUATION (CURR-SITUATION)))
            (MAPC
             #'(LAMBDA (SITN+SVS)
                (trace-defun '#:G15717 (SITN+SVS)
                 (RET
                  (TRACE-PROGN (CHANGE-TO-SITUATION (FIRST SITN+SVS))
                   (COND
                    ((OR CHANGE-MADE (CL-EQUAL (SECOND SITN+SVS) (GET-SLOTSVALS UNIFIED-NAME))
                      (AND (PREV-SITUATION (CURR-SITUATION)) (NULL (GET-SLOTSVALS UNIFIED-NAME))
                       (CL-SUBSETP (SECOND SITN+SVS) (GET-SLOTSVALS UNIFIED-NAME :SITUATION (PREV-SITUATION (CURR-SITUATION))) :TEST #'CL-EQUAL))))
                    (T       (CSETQ CHANGE-MADE T)))
                         (PUT-SLOTSVALS UNIFIED-NAME (SECOND SITN+SVS))))))
              SITN+SVS-PAIRS)
            (CHANGE-TO-SITUATION CURR-SITUATION))))
         (COND
          ((CL-ISA UNIFIED-NAME '|Situation|) (CSETQ CHANGE-MADE T)
           (COND
            ((AND (CL-ISA INSTANCE1 '|Situation|) (CL-ISA INSTANCE2 '|Situation|)) (MAKE-COMMENT "Unifying situations ~a & ~a" INSTANCE1 INSTANCE2)))
           (COPY-SITUATION-CONTENTS INSTANCE1 UNIFIED-NAME) (COPY-SITUATION-CONTENTS INSTANCE2 UNIFIED-NAME)))
         (COND
          ((AND (KB-OBJECTP UNIFIED-NAME) CHANGE-MADE)  (UN-DONE UNIFIED-NAME) 
           (COND
            ((X-OR (FLUENT-INSTANCEP INSTANCE1) (FLUENT-INSTANCEP INSTANCE2))  
             (CLET ((FLUENT-INSTANCE (COND ((FLUENT-INSTANCEP INSTANCE1) INSTANCE1) (T INSTANCE2)))) 
              (MAPC
               #'(LAMBDA (SITUATION)
                  (trace-defun '#:G15718 (SITUATION)
                   (RET
                    (MAPC
                     #'(LAMBDA (SLOTVALS)
                        (trace-defun '#:G15719 (SLOTVALS)
                         (RET
                          (CLET ((INVSLOT (INVERT-SLOT (SLOT-IN SLOTVALS))))
                           (MAPC
                            #'(LAMBDA (VAL)
                               (trace-defun '#:G15720 (VAL) (RET (COND ((KB-OBJECTP VAL) (UN-DONE VAL :SLOT INVSLOT :SITUATION SITUATION) )))))
                            (VALS-IN SLOTVALS))))))
                     (GET-SLOTSVALS FLUENT-INSTANCE :SITUATION SITUATION)))))
               (ALL-ACTIVE-SITUATIONS))
               )))
           (CLASSIFY UNIFIED-NAME) ))
         UNIFIED-NAME)))))))))
;;;; --------------------
#|try-lazy-unify: Is a main entry point into lazy unification.
Purpose is to simply check whether unification is possible for instances, which might include structured
values. Discards any binding information thus collected.

RETURNS: any non-nil value for success, NIL for failure.|#
(TRACE-LISP
 (DEFINE TRY-LAZY-UNIFY (INSTANCENAME1 INSTANCENAME2 &REST LKEYS)
  (trace-defun 'TRY-LAZY-UNIFY (INSTANCENAME1 INSTANCENAME2 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)
     (CLET ((INSTANCE1 (DEREFERENCE INSTANCENAME1))  (INSTANCE2 (DEREFERENCE INSTANCENAME2)))
      (COND ((KM-EQUAL INSTANCE1 INSTANCE2) INSTANCE1)  ((NULL INSTANCE1) INSTANCE2) ((NULL INSTANCE2) INSTANCE1)
       ((AND (KM-TRIPLEP INSTANCE1) (KM-TRIPLEP INSTANCE2))   NIL)        ((KM-SETP INSTANCE1))  ((KM-SETP INSTANCE2)) 
       ((OR (KM-STRUCTURED-LIST-VALP INSTANCE1) (KM-STRUCTURED-LIST-VALP INSTANCE2))
        (CLET ((D-INSTANCE1 (DESOURCE INSTANCE1))  (D-INSTANCE2 (DESOURCE INSTANCE2)))
         (COND
          ((CNOT (KM-STRUCTURED-LIST-VALP D-INSTANCE1))
           (REPORT-ERROR 'USER-ERROR "Attempt to unify an atomic object ~a with a sequence-like object ~a!" INSTANCE1 INSTANCE2)
           (TRY-LAZY-UNIFY (LIST (FIRST D-INSTANCE2) D-INSTANCE1) D-INSTANCE2  :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP
            CHECK-CONSTRAINTSP))
          ((CNOT (KM-STRUCTURED-LIST-VALP D-INSTANCE2))
           (REPORT-ERROR 'USER-ERROR "Attempt to unify a sequence-like object ~a with an atomic object ~a!" INSTANCE1 INSTANCE2)
           (TRY-LAZY-UNIFY D-INSTANCE1 (LIST (FIRST D-INSTANCE1) D-INSTANCE2)  :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP
            CHECK-CONSTRAINTSP))
          ((AND (EQ (FIRST D-INSTANCE1) (FIRST D-INSTANCE2)) (NEQ (FIRST D-INSTANCE1) ':|triple|)) 
           (EVERY
            #'(LAMBDA (PAIR)
               (trace-defun '#:G15721 (PAIR)
                (RET
                 (TRY-LAZY-UNIFY (FIRST PAIR) (SECOND PAIR) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP
                  CHECK-CONSTRAINTSP))))
            (REST (TRANSPOSE (LIST D-INSTANCE1 D-INSTANCE2))))))))
        (T (TRY-LAZY-UNIFY2 INSTANCE1 INSTANCE2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)))))))))
#|try-lazy-unify2: This function has no side effects.
Returns three values:
	1. the instancename of the unification
	2. a list of (situation slotsvals) pairs, of the unified structure for each situation
	3. a list of (instance1 instance2) variable binding pairs
OR nil if the unification fails. |#
(TRACE-LISP
 (DEFINE TRY-LAZY-UNIFY2 (INSTANCE1 INSTANCE2 &REST LKEYS)
  (trace-defun 'TRY-LAZY-UNIFY2 (INSTANCE1 INSTANCE2 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)
     (MULTIPLE-VALUE-BIND (UNIFIED-NAME BINDINGS) (UNIFY-NAMES INSTANCE1 INSTANCE2 CLASSES-SUBSUMEP)
      (COND
       (UNIFIED-NAME 
        (CLET
         ((SITN-SVS-PAIRS
           (UNIFIED-SVS INSTANCE1 INSTANCE2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)))
         
         (COND
          ((NEQ SITN-SVS-PAIRS 'FAIL) (CSETQ *STATISTICS-UNIFICATIONS* (1+ *STATISTICS-UNIFICATIONS*))
           (VALUES UNIFIED-NAME SITN-SVS-PAIRS BINDINGS))))))))))))
;;;; ----------------------------------------
;;;; Returns a list of (situation unified-svs) pairs for unifying i1 and i2
;;;;      OR 'fail, if a problem was encountered
;;;; PEC: 9/6/00 - this is inefficient, and confusing for debugging: KM should abort immediately a 'fail is encountered,
;;;; 	rather than continuing on to the bitter end.
;;;; OLD VERSION:
;;(defun unified-svs (i1 i2 &key (situations (all-active-situations)) classes-subsumep eagerlyp)
;;  (let ( (sitn-svs-pairs (mapcar ;'(lambda (situation)
;;				     (unified-svs-in-situation i1 i2 situation :classes-subsumep classes-subsumep :eagerlyp eagerlyp))
;;				 situations)) )
;;    (cond ((not (member 'fail sitn-svs-pairs)) sitn-svs-pairs)
;;	  (t 'fail))))
;;;; NEW VERSION - abort immediately a 'fail is encountered
(TRACE-LISP
 (DEFINE UNIFIED-SVS (I1 I2 &REST LKEYS)
  (trace-defun 'UNIFIED-SVS (I1 I2 LKEYS)
   (RET
    (CLET (SITUATIONS CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T) (init-keyval SITUATIONS (ALL-ACTIVE-SITUATIONS))
     (COND ((ENDP SITUATIONS) NIL)
      (T
       (CLET
        ((SITN-SVS-PAIR
          (UNIFIED-SVS-IN-SITUATION I1 I2 (FIRST SITUATIONS) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP
           CHECK-CONSTRAINTSP)))
        (COND ((EQ SITN-SVS-PAIR 'FAIL) 'FAIL)
         (T
          (CLET
           ((SITN-SVS-PAIRS
             (UNIFIED-SVS I1 I2 :SITUATIONS (REST SITUATIONS) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP
              CHECK-CONSTRAINTSP)))
           (COND ((EQ SITN-SVS-PAIRS 'FAIL) 'FAIL) (T (CONS SITN-SVS-PAIR SITN-SVS-PAIRS))))))))))))))
;;;; [1] This is critical, as lazy-unify-slotsvals drags in constraints from whatever the current situation is!
;;;; [2] change-to-situation doesn't make-comments.
;;;; [3] There must be *some* data on both objects. Note, we still check slot values if only ONE instance has values providing the OTHER 
;;;;		instance has at least some slot-values somewhere (including other slots).
(TRACE-LISP
 (DEFINE UNIFIED-SVS-IN-SITUATION (I1 I2 SITUATION &REST LKEYS)
  (trace-defun 'UNIFIED-SVS-IN-SITUATION (I1 I2 SITUATION LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)
     (CLET
      ((CURR-SITUATION (CURR-SITUATION)) (SLOTSVALS1 (GET-SLOTSVALS I1 :SITUATION SITUATION))  (SLOTSVALS2 (GET-SLOTSVALS I2 :SITUATION SITUATION)) )  
      (COND
       ((AND SLOTSVALS1 SLOTSVALS2)  (COND ((NEQ SITUATION CURR-SITUATION) (CHANGE-TO-SITUATION SITUATION))) 
        (MULTIPLE-VALUE-BIND (SUCCESSP UNIFIED-SVS)
         (LAZY-UNIFY-SLOTSVALS I1 I2 SLOTSVALS1 SLOTSVALS2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)
         (COND ((NEQ SITUATION CURR-SITUATION) (CHANGE-TO-SITUATION CURR-SITUATION)))  (COND (SUCCESSP (LIST SITUATION UNIFIED-SVS)) (T 'FAIL))))
       (T (LIST SITUATION (OR SLOTSVALS1 SLOTSVALS2))))))))))
;;;; ----------------------------------------
;;;; Returns (i) unified value (ii) extra binding list elements
;;;; In the case of two anonymous instances A and B, then B points to A, ie. get B->A,
;;;; not A->B. Three items of code depend on this ordering:
;;;;    1. (load-kb ...), so that a statement like (_X2 == _X1) binds _X1 
;;;;       to point to _X2, and not vice-versa. (The writer prints the master
;;;;	  object first, then the bound synonym second). 
;;;;	  Apr 01: Redundant now, the writer does dereferencing and no "==" writing.
;;;;    2. [overall-expr-for-slot, global-expr-for-slot, and local-expr-for-slot] now called
;;;;	  inherited-rule-sets, local-rule-sets,
;;;;	  in frame-io.lisp assumes this binding order (see that 
;;;;	  file for notes), putting *Global instances before situation-specific
;;;;	  ones.
;;;;    3. get-unified-all puts local instances before inherited expressions,
;;;;	  so that the local instance names persist.
;;;; [1] I don't know why, but I enforced the classes-subsumep constraint *always* for
;;;;     non-kb-objects. This means (100 & (a Coordinate)) fails, which I don't think it should.
;;;;     Apr 03: Relax this. The anonymous instance must either be blank, or have only an acceptable class definition
(TRACE-LISP
 (DEFINE UNIFY-NAMES (INSTANCE1 INSTANCE2 CLASSES-SUBSUMEP)
  (trace-defun 'UNIFY-NAMES (INSTANCE1 INSTANCE2 CLASSES-SUBSUMEP)
   (RET
    (COND ((EQ INSTANCE1 INSTANCE2) (VALUES INSTANCE1 NIL))  ((INCOMPATIBLE-INSTANCES INSTANCE1 INSTANCE2) NIL)
     ((AND (CNOT (KB-OBJECTP INSTANCE1))  (ANONYMOUS-INSTANCEP INSTANCE2))
      (COND ((IMMEDIATE-CLASSES-SUBSUME-IMMEDIATE-CLASSES INSTANCE2 INSTANCE1) (VALUES INSTANCE1 (LIST (LIST INSTANCE2 INSTANCE1))))))
     ((AND (CNOT (KB-OBJECTP INSTANCE2))  (ANONYMOUS-INSTANCEP INSTANCE1))
      (COND ((IMMEDIATE-CLASSES-SUBSUME-IMMEDIATE-CLASSES INSTANCE1 INSTANCE2) (VALUES INSTANCE2 (LIST (LIST INSTANCE1 INSTANCE2))))))
        
     ((COMPATIBLE-CLASSES :INSTANCE1 INSTANCE1 :INSTANCE2 INSTANCE2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP)  
      (COND 
       ((OR (NAMED-INSTANCEP INSTANCE2)  (AND (FLUENT-INSTANCEP INSTANCE1)  (ANONYMOUS-INSTANCEP INSTANCE2))
         (AND (CNOT (NAMED-INSTANCEP INSTANCE1))  (IMMEDIATE-CLASSES-SUBSUME-IMMEDIATE-CLASSES INSTANCE1 INSTANCE2 :PROPERP T)))
         (VALUES INSTANCE2 (LIST (LIST INSTANCE1 INSTANCE2))))
       (T (VALUES INSTANCE1 (LIST (LIST INSTANCE2 INSTANCE1)))))))))))
;; ELSE (X & Y) return X 
;;;; (immediate-classes-subsume-immediate-classes '123 '_number3)   -> t    because _number3 isa number
;;;; (immediate-classes-subsume-immediate-classes '_Car1 '_Vehicle3)   -> t
(TRACE-LISP
 (DEFINE IMMEDIATE-CLASSES-SUBSUME-IMMEDIATE-CLASSES (INSTANCE1 INSTANCE2 &REST LKEYS)
  (trace-defun 'IMMEDIATE-CLASSES-SUBSUME-IMMEDIATE-CLASSES (INSTANCE1 INSTANCE2 LKEYS)
   (RET
    (CLET (PROPERP)
     (CLET ((IMMEDIATE-CLASSES1 (IMMEDIATE-CLASSES INSTANCE1)) (IMMEDIATE-CLASSES2 (IMMEDIATE-CLASSES INSTANCE2)))
      (AND (CLASSES-SUBSUME-CLASSES IMMEDIATE-CLASSES1 IMMEDIATE-CLASSES2)
       (OR (CNOT PROPERP) (CNOT (SET-EQUAL IMMEDIATE-CLASSES1 IMMEDIATE-CLASSES2))))))))))
;;;; Check /== constraints
;;;; [1] :test ;'equal, to allow for  "cat" and _Animal-Name1 where (_Animal-Name1 (/== ("cat")))
;;;; [2] IF there is some equality constraints, AND the check-slotvals-constraints FAILS for them, 
;;;;	THEN the instances are incompatible
;;;; [3] I guess I'm assuming people will assert inequalities via KM> (x /== y), rather than such
;;;;     statements being put on frames themselves. But really, we should do (km0 `;$(the /== of ,INSTANCE1)) to 
;;;;     be safe (/== is also assumed to be an atomic values only slot).
;;;;     Let's leave it as a direct get-vals, for efficiency for now!
(TRACE-LISP
 (DEFINE INCOMPATIBLE-INSTANCES (INSTANCE1 INSTANCE2)
  (trace-defun 'INCOMPATIBLE-INSTANCES (INSTANCE1 INSTANCE2)
   (RET
    (COND ((AND (NAMED-INSTANCEP INSTANCE1) (NAMED-INSTANCEP INSTANCE2)  (NEQ INSTANCE1 INSTANCE2)))
     ((CLASSP INSTANCE1) (CNOT (CL-ISA INSTANCE2 '|Class|)))  ((CLASSP INSTANCE2) (CNOT (CL-ISA INSTANCE1 '|Class|))) 
     (*ARE-SOME-CONSTRAINTS*
      (CLET
       ((INSTANCE1-NEQ
         (COND
          ((AND (KB-OBJECTP INSTANCE1) #|quick lookahead|# (GET-VALS INSTANCE1 '/== :SITUATION *GLOBAL-SITUATION*)) 
           (KM0 `(|the| /== |of| ,INSTANCE1)))))
        (INSTANCE2-NEQ
         (COND
          ((AND (KB-OBJECTP INSTANCE2) #|quick lookahead|# (GET-VALS INSTANCE2 '/== :SITUATION *GLOBAL-SITUATION*))
           (KM0 `(|the| /== |of| ,INSTANCE2))))))
       (OR (CL-MEMBER INSTANCE2 INSTANCE1-NEQ :TEST #'CL-EQUAL)  (CL-MEMBER INSTANCE1 INSTANCE2-NEQ :TEST #'CL-EQUAL)
        (AND (NUMBERP INSTANCE1) (KB-OBJECTP INSTANCE2)
         (OR (SOME #'(LAMBDA (N) (trace-defun '#:G15722 (N) (RET (AND (NUMBERP N) (<= INSTANCE1 N))))) (KM0 `(|the| > |of| ,INSTANCE2)))
          (SOME #'(LAMBDA (N) (trace-defun '#:G15723 (N) (RET (AND (NUMBERP N) (>= INSTANCE1 N))))) (KM0 `(|the| < |of| ,INSTANCE2)))))
        (AND (NUMBERP INSTANCE2) (KB-OBJECTP INSTANCE1)
         (OR (SOME #'(LAMBDA (N) (trace-defun '#:G15724 (N) (RET (AND (NUMBERP N) (<= INSTANCE2 N))))) (KM0 `(|the| > |of| ,INSTANCE1)))
          (SOME #'(LAMBDA (N) (trace-defun '#:G15725 (N) (RET (AND (NUMBERP N) (>= INSTANCE2 N))))) (KM0 `(|the| < |of| ,INSTANCE1)))))
        (CLET
         ((INSTANCE1-EQ (COND ((KB-OBJECTP INSTANCE1) (GET-VALS INSTANCE1 '== :SITUATION *GLOBAL-SITUATION*))))
          (INSTANCE2-EQ (COND ((KB-OBJECTP INSTANCE2) (GET-VALS INSTANCE2 '== :SITUATION *GLOBAL-SITUATION*)))))
         (COND ((OR INSTANCE1-EQ INSTANCE2-EQ) (CNOT (CHECK-SLOTVALS-CONSTRAINTS '== INSTANCE1 INSTANCE2 INSTANCE1-EQ INSTANCE2-EQ)))))))))))))
;; [2]
;;;; ======================================================================
;;;;		UNIFICATION OF SLOTSVALS
;;;; ======================================================================
#|Unification with constraint checking:

_Person1			_Person2
--------			--------
  pets: Dog			  pets: Dog	(must-be-a Animal)
	---				---
 	  color: Red			  color: Blue

&&: Must check the first-level slots, that the values satisfy the
    constraints. The search for constraints is global, and if any are found
    then the search for values is global also. 
    If there are no constraints, then && is guaranteed to succeed and so 
    doesn't need to be computed.

&: As well as checking the first-level slot constraints, lazy-unify-vals does a
   &? check, which recursively checks that the second-level slot constraints
   are satisfied (eg. if color is single-valued, that Red and Blue are 
   unifiable). Note that a second-level check isn't needed with &&.

[1] As well as explicit constraints, there are also partition constraints which 
    must be checked for &, which means we must do an aggressive (the slot of X)
    for & operations, regardless of whether constraints are found or not.

Note we only check/perform unification for slots which explicitly occur on either
i1 or i2. All other slots are ignored.

lazy-unify-slotsvals
--------------------
Returns two values
 - t or nil, depending on whether unification was successful
   (If nil, then the unified slotsvals are partial and can be discarded)
 - the unified slotsvals
This was extended in Aug 99 to include constraint checking, so that the procedure
will fail if there's a constraint violation (even if only one instance actually has
a slot value).

[1] It's only with eagerlyp that lazy-unify-vals will evaluate the unification and squish out the constraints (thus they need to be reinstalled)|#
(TRACE-LISP
 (DEFINE LAZY-UNIFY-SLOTSVALS (I1 I2 SVS1 SVS2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-SLOTSVALS (I1 I2 SVS1 SVS2 LKEYS)
   (RET
    (CLET (CS1 CS2 CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)
     (COND ((AND (ENDP SVS1) (ENDP SVS2))) 
      (T
       (CLET
        ((SV1 (FIRST SVS1)) (SLOT (OR (SLOT-IN SV1)  (SLOT-IN (FIRST SVS2))))  (EXPRS1 (VALS-IN SV1)) (SV2 (ASSOC SLOT SVS2)) (EXPRS2 (VALS-IN SV2))
         (REST-SVS2 (REMOVE-IF #'(LAMBDA (A-SV2) (trace-defun '#:G15726 (A-SV2) (RET (EQ SLOT (SLOT-IN A-SV2))))) SVS2)))
        (COND
         ((AND (NULL EXPRS1) (NULL EXPRS2)) 
          (LAZY-UNIFY-SLOTSVALS I1 I2 (REST SVS1) REST-SVS2 :CS1 CS1 :CS2 CS2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP
           CHECK-CONSTRAINTSP))
         ((OR (CNOT CHECK-CONSTRAINTSP) (CHECK-SLOTVALS-CONSTRAINTS SLOT I1 I2 EXPRS1 EXPRS2 :CS1 CS1 :CS2 CS2 :EAGERLYP EAGERLYP))
          (MULTIPLE-VALUE-BIND (UNIFIED-VALS SUCCESSP1)
           (LAZY-UNIFY-VALS SLOT I1 I2 EXPRS1 EXPRS2 :CS1 CS1 :CS2 CS2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP)
           (COND
            (SUCCESSP1 
             (MULTIPLE-VALUE-BIND (SUCCESSP UNIFIED-REST)
              (LAZY-UNIFY-SLOTSVALS I1 I2 (REST SVS1) REST-SVS2 :CS1 CS1 :CS2 CS2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP
               :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)
              (VALUES SUCCESSP (COND (UNIFIED-VALS (CONS (LIST SLOT UNIFIED-VALS) UNIFIED-REST)) (T UNIFIED-REST)))))))))))))))))
#|======================================================================
	check-slotvals-constraints
======================================================================
This function has no side-effects. It's purpose is to check the unified slot values are consistent with
constraints. This requires KM doing a bit of work, both to find the constraints and find the slot values
themselves in some cases.

[2] suppose unify Group1 in S1 and S2. We are currently in S1, but Group1 only has location in S2.
while svs2 contains that location information, doing another query will get rid of it, so vs2 = nil, and hence the
unification is nil.
[2] ALSO for unifiable-with-slotsvals test
[3] We also allow this to be called with i1, i2 = NIL. This occurs
    when we want to just merge two structures together (from merge-slotsvals), or merge
    a structure with an instance (from unifiable/unify-with-existential-expr)
    IF WE DO THIS, THOUGH, then we *must* supply the class for the missing instance,
    so we can still gather the inherited constraints for the structure. This is done
    via cs1 and cs2.
BUT: we also have a problem. If we are dealing with a structure (i2 = nil), then we don't just 
     need the inherited constraints, we also need the inherited slot-values, as these may 
     clash with constraints on/inherited by i1.
     And suppose these inherited expressions refer to Self? We've no Self to evaluate them for!

	(a Person with			   &? (a Person-With-Favorite-Color-Red with
	  (likes ((<> *Red))))			   (likes ((the favorite-color of Self))))
								^^ need to evaluate this path!
SOLUTION might be to collect expr sets.
[6] What if EXPR contains Self? Simplest: Ignore them. This means the constraints will not be
tested, but we won't "lose things" in the KB. Better would be to add a tmp-i creation and
deletion again (sigh) to be thorough.
[5] What if EXPR contains an existential? Don't want to litter the KB with temporary instances!!
So ignore them again.

[4] We *only* want to pull in generalizations if we are checking constraints!
This is a compromise between always getting just the local values, and always pulling in the inherited values.
Version2 causes looping with unifying prototypes (see test-suite/outstanding/protobug.km), it's generally a dangerous and
expensive thing to do inheritance as part of unification computation.
[7] Note, we have to use (collect-constraints-on-instance i1...), rather than look in exprs1, because there may
    be constraints on i1 in a supersituation.
[8] exprs1, exprs2 are dereferenced, but the rule sets may not be.
[9] (_Color3 has 					(*Green)
	(== ((possible-values *Red *Blue))))		
[10] Darn, need to keep these in so that:
   (a Partition with (members (Thymine Adenine Guanine Cytosine)))
   ((a Bond with (holds ((a Guanine)))) &? (a Bond with (holds ((exactly 2 Thing) (a Adenine) (a Thymine))))) <- should fail
[11] Given: (check-slotvals-constraints parts _Car23 nil (_Engine23) nil :cs1 nil :cs2 Car)
            don't waste time checking the constraints on the "parts" slot. Note this may pull in additional
	    (here already implied) facts via inherited-rule-sets-on-classes.
[12] 8/18/05 - added (not (inherit-with-overrides-slotp slot)). If the slot is inherit-with-overrides, then clashes
	in the parent classes in general should not be a problem (although one can imagine pathological cases where they are)|#
;;(defun check-slotvals-constraints (slot i1 i2 exprs1 exprs2 &key cs1 cs2 eagerlyp)
;;  (cond (*backtrack-after-testing-unification*
;;	 (setq *internal-logging* t)
;;	 (let ( (checkpoint-id (gensym)) )
;;	   (set-checkpoint checkpoint-id)
;;	   (prog1
;;	       (check-slotvals-constraints0 slot i1 i2 exprs1 exprs2 :cs1 cs1 :cs2 cs2 :eagerlyp eagerlyp)
;;	     (undo checkpoint-id)		; undo, whatever
;;	     (setq *internal-logging* nil))))
;;	(t (check-slotvals-constraints0 slot i1 i2 exprs1 exprs2 :cs1 cs1 :cs2 cs2 :eagerlyp eagerlyp))))
(TRACE-LISP
 (DEFINE CHECK-SLOTVALS-CONSTRAINTS (SLOT I1 I2 EXPRS1 EXPRS2 &REST LKEYS)
  (trace-defun 'CHECK-SLOTVALS-CONSTRAINTS (SLOT I1 I2 EXPRS1 EXPRS2 LKEYS)
   (RET (CLET (CS1 CS2 EAGERLYP) (CHECK-SLOTVALS-CONSTRAINTS0 SLOT I1 I2 EXPRS1 EXPRS2 :CS1 CS1 :CS2 CS2 :EAGERLYP EAGERLYP))))))
(TRACE-LISP
 (DEFINE CHECK-SLOTVALS-CONSTRAINTS0 (SLOT I1 I2 EXPRS1 EXPRS2 &REST LKEYS)
  (trace-defun 'CHECK-SLOTVALS-CONSTRAINTS0 (SLOT I1 I2 EXPRS1 EXPRS2 LKEYS)
   (RET
    (CLET (CS1 CS2 EAGERLYP)
     (OR (EQ SLOT '/==)   (IGNORE-SLOT-DUE-TO-SITUATIONS-MODE SLOT)
      (AND I1 (NULL I2) (NULL EXPRS2) (EVERY #'(LAMBDA (C2) (trace-defun '#:G15727 (C2) (RET (CL-ISA I1 C2)))) CS2)) 
      (AND I2 (NULL I1) (NULL EXPRS1) (EVERY #'(LAMBDA (C1) (trace-defun '#:G15728 (C1) (RET (CL-ISA I2 C1)))) CS1)) 
      (CLET
       ((NO-INHERITANCEP
         (OR (AND I1 (CL-MEMBER '(|no-inheritance|) (FIND-CONSTRAINTS-IN-EXPRS EXPRS1) :TEST #'CL-EQUAL))
          (AND I2 (CL-MEMBER '(|no-inheritance|) (FIND-CONSTRAINTS-IN-EXPRS EXPRS2) :TEST #'CL-EQUAL))))
        (CS1-EXPR-SETS
         (COND
          (CS1
           (REMOVE-IF #'CONTAINS-SELF-KEYWORD 
            (CONS EXPRS1
             (COND
              ((AND (USE-INHERITANCE) (NOT NO-INHERITANCEP) (NOT (INHERIT-WITH-OVERRIDES-SLOTP SLOT))) 
               (INHERITED-RULE-SETS-ON-CLASSES CS1 SLOT :RETAIN-COMMENTSP T))))))
          (T
           (CONS EXPRS1
            (APPEND (SUPERSITUATION-OWN-RULE-SETS I1 SLOT :RETAIN-COMMENTSP T)
             (COND
              ((AND (USE-INHERITANCE) (NOT NO-INHERITANCEP) (NOT (INHERIT-WITH-OVERRIDES-SLOTP SLOT))) 
               (INHERITED-RULE-SETS I1 SLOT :RETAIN-COMMENTSP T))))))))
        
        (CS2-EXPR-SETS
         (COND
          (CS2
           (REMOVE-IF #'CONTAINS-SELF-KEYWORD
            (CONS EXPRS2
             (COND
              ((AND (USE-INHERITANCE) (NOT NO-INHERITANCEP) (NOT (INHERIT-WITH-OVERRIDES-SLOTP SLOT))) 
               (INHERITED-RULE-SETS-ON-CLASSES CS2 SLOT :RETAIN-COMMENTSP T))))))
          (T
           (CONS EXPRS2
            (APPEND (SUPERSITUATION-OWN-RULE-SETS I2 SLOT :RETAIN-COMMENTSP T)
             (COND
              ((AND (USE-INHERITANCE) (NOT NO-INHERITANCEP) (NOT (INHERIT-WITH-OVERRIDES-SLOTP SLOT))) 
               (INHERITED-RULE-SETS I2 SLOT :RETAIN-COMMENTSP T))))))))
        #|OLD    (constraints (remove-duplicates 
		    (append (cond (i1 (collect-constraints-on-instance i1 slot)) ; [3], [7]
				  (cs1 (mapcan X'find-constraints-in-exprs cs1-expr-sets))
				  (t (report-error 'program-error "Missing both instance1 and class1 in lazy-unify-slotsvals!~%")))
			    (cond (i2 (collect-constraints-on-instance i2 slot))
				  (cs2 (mapcan X'find-constraints-in-exprs cs2-expr-sets))
				  (t (report-error 'program-error "Missing both instance2 and class2 in lazy-unify-slotsvals!~%"))))
		    :test X'equal)) )|#
        #|NEW|# (CONSTRAINTS1 (MAPCAN #'FIND-CONSTRAINTS-IN-EXPRS CS1-EXPR-SETS)) (CONSTRAINTS2 (MAPCAN #'FIND-CONSTRAINTS-IN-EXPRS CS2-EXPR-SETS)) 
        (CONSTRAINTS
         (COND ((AND  (SINGLE-VALUED-SLOTP SLOT))  (CONS '(|exactly| 1 |Thing|)  (APPEND CONSTRAINTS1 CONSTRAINTS2)))
          (T (APPEND CONSTRAINTS1 CONSTRAINTS2)))))
                
       (COND ((AND (CNOT CONSTRAINTS) (CNOT EAGERLYP)))
        (T
         (COND
          ((AM-IN-LOCAL-SITUATION) 
           (COND ((AND I1 I2) (KM-TRACE 'COMMENT "(~a &? ~a): Checking constraints on the ~a slot in ~a..." I1 I2 SLOT (CURR-SITUATION))) 
            (I1
             (KM-TRACE 'COMMENT "(~a &? (a ~a with (~a ~a) ...): Checking constraints on the ~a slot in ~a..." I1 (DELISTIFY CS2) SLOT EXPRS2 SLOT
              (CURR-SITUATION)))
            
            (I2
             (KM-TRACE 'COMMENT "(~a &? (a ~a with (~a ~a) ...): Checking constraints on the ~a slot in ~a..." I2 (DELISTIFY CS1) SLOT EXPRS1 SLOT
              (CURR-SITUATION)))
            
            (T
             (KM-TRACE 'COMMENT "((a ~a with (~a ~a) ...) &? (a ~a with (~a ~a) ...):~%     Checking constraints on the ~a slot in ~a..." (DELISTIFY CS1)
              SLOT EXPRS1 (DELISTIFY CS2) SLOT EXPRS2 SLOT (CURR-SITUATION)))))
          (T
           (COND ((AND I1 I2) (KM-TRACE 'COMMENT "(~a &? ~a): Checking constraints on the ~a slot..." I1 I2 SLOT)) 
            (I1 (KM-TRACE 'COMMENT "(~a &? (a ~a with (~a ~a) ...): Checking constraints on the ~a slot..." I1 (DELISTIFY CS2) SLOT EXPRS2 SLOT)) 
            (I2 (KM-TRACE 'COMMENT "(~a &? (a ~a with (~a ~a) ...): Checking constraints on the ~a slot..." I2 (DELISTIFY CS1) SLOT EXPRS1 SLOT)) 
            (T
             (KM-TRACE 'COMMENT "((a ~a with (~a ~a) ...) &? (a ~a with (~a ~a) ...):~%     Checking constraints on the ~a slot..." (DELISTIFY CS1) SLOT
              EXPRS1 (DELISTIFY CS2) SLOT EXPRS2 SLOT)))))
              
         (CLET
          ((VS1
            (COND ((CL-MEMBER SLOT '(== < >)) (COND (I1 (LIST I1)))) 
             (I1
              (COND
               (*LESS-AGGRESSIVE-CONSTRAINT-CHECKING*
                (REMOVE-IF-NOT #'FULLY-EVALUATEDP (GET-VALS I1 SLOT :SITUATION (TARGET-SITUATION (CURR-SITUATION) I1 SLOT))))
               ((ALREADY-DONE I1 SLOT) (REMOVE-CONSTRAINTS (GET-VALS I1 SLOT :SITUATION (TARGET-SITUATION (CURR-SITUATION) I1 SLOT))))
               (T (KM0-WITH-TRACE `(|the| ,SLOT |of| ,I1) (VAL-SETS-TO-EXPR CS1-EXPR-SETS)))))
              (*LESS-AGGRESSIVE-CONSTRAINT-CHECKING* (REMOVE-IF-NOT #'FULLY-EVALUATEDP EXPRS1))
             (T
              (KM0-WITH-TRACE `(|the| ,SLOT |of| (|a| ,(VALS-TO-VAL CS1) |with| (,SLOT ,EXPRS1)))
               (VAL-SETS-TO-EXPR (REMOVE-IF #'CONTAINS-SOME-EXISTENTIAL-EXPRS CS1-EXPR-SETS)) ))))
           (VS2
            (COND ((CL-MEMBER SLOT '(== < >)) (COND (I2 (LIST I2)))) 
             (I2
              (COND
               (*LESS-AGGRESSIVE-CONSTRAINT-CHECKING*
                (REMOVE-IF-NOT #'FULLY-EVALUATEDP (GET-VALS I2 SLOT :SITUATION (TARGET-SITUATION (CURR-SITUATION) I2 SLOT))))
               ((ALREADY-DONE I2 SLOT) (REMOVE-CONSTRAINTS (GET-VALS I2 SLOT :SITUATION (TARGET-SITUATION (CURR-SITUATION) I2 SLOT))))
               (T (KM0-WITH-TRACE `(|the| ,SLOT |of| ,I2) (VAL-SETS-TO-EXPR CS2-EXPR-SETS)))))
              (*LESS-AGGRESSIVE-CONSTRAINT-CHECKING* (REMOVE-IF-NOT #'FULLY-EVALUATEDP EXPRS2))
             (T
              (KM0-WITH-TRACE `(|the| ,SLOT |of| (|a| ,(VALS-TO-VAL CS2) |with| (,SLOT ,EXPRS2)))
               (VAL-SETS-TO-EXPR (REMOVE-IF #'CONTAINS-SOME-EXISTENTIAL-EXPRS CS2-EXPR-SETS))))))
           )
                                      
          #|BUG:
KM> (reset-kb)
KM> (every Car has (parts ((a Engine) (mustnt-be-a Furry-Dice))))
KM> (a Car)
(_Car1)
KM> (a Car with (parts ((a Foosball))))
(_Car2)
KM> (_Car1 & _Car2)
(_Car1)
KM> (showme _Car1)
(_Car1 has 
  (instance-of (Car))
  (parts ((a Foosball))))		; the evaluated Foosball has been overwritten...
KM> (showme Foosball)
(Foosball has 
  (instances (_Foosball4)))		; but the Skolem instance is still lying around!
KM> (showme _Foosball4)
(_Foosball4 has 
  (instance-of (Foosball))
  (parts-of (_Car1)))			; part-of of _Car1...
KM> (the parts of _Car1)
(_Foosball6 _Engine7)			; but not one of _Car1's parts!|#
          #| OLD (pre-caching) version - revert back to doing this
;	       (format t "i1=~a, vs1=~a~%" i1 vs1)
	       (cond ((and i1 vs1 (not (dont-cache-values-slotp slot)))
		      (let* 
; BUG!			  ( (constraints1 (find-constraints-in-exprs cs1-expr-sets))
; unnecessarily many	  ( (constraints1 (my-mapcan X'find-constraints-in-exprs cs1-expr-sets))
; done earlier		  ( (constraints1 (find-constraints-in-exprs exprs1))
			  ( (constraints1-to-put (find-constraints-in-exprs exprs1))
			    (vs1+constraints1 (cond (constraints1-to-put
						     (cond ((single-valued-slotp slot) 
							    (val-to-vals (vals-to-&-expr (append vs1 constraints1-to-put))))
							   (t (append vs1 constraints1-to-put))))
						    (t vs1))) )
;			(km-format t "constraints1-to-put = ~a~%" constraints1-to-put)
			(put-vals i1 slot vs1+constraints1))))	; NB no note-done, as didn't use inheritance
;	       (format t "i2=~a, vs2=~a~%" i2 vs2)
	       (cond ((and i2 vs2 (not (dont-cache-values-slotp slot))) 
		      (let* 
; BUG!			  ( (constraints2 (find-constraints-in-exprs cs2-expr-sets))
; unnecessarily many	  ( (constraints2 (my-mapcan X'find-constraints-in-exprs cs2-expr-sets))
; done earlier		  ( (constraints2 (find-constraints-in-exprs exprs2))
			  ( (constraints2-to-put (find-constraints-in-exprs exprs2))
			    (vs2+constraints2 (cond (constraints2-to-put
						    (cond ((single-valued-slotp slot) 
							   (val-to-vals (vals-to-&-expr (append vs2 constraints2-to-put))))
							  (t (append vs2 constraints2-to-put))))
						    (t vs2))) )
;			(km-format t "constraints2-to-put = ~a~%" constraints2-to-put)
			(put-vals i2 slot vs2+constraints2))))	; NB no note-done, as didn't use inheritance|#
               
          (COND
           ((AND (ARE-CONSISTENT-WITH-CONSTRAINTS VS1 (SET-DIFFERENCE CONSTRAINTS2 CONSTRAINTS1 :TEST #'CL-EQUAL) SLOT)
             (ARE-CONSISTENT-WITH-CONSTRAINTS VS2 (SET-DIFFERENCE CONSTRAINTS1 CONSTRAINTS2 :TEST #'CL-EQUAL) SLOT)
             (TEST-SET-CONSTRAINTS VS1 VS2 (COND ((CNOT I1) CS1-EXPR-SETS))  (COND ((CNOT I2) CS2-EXPR-SETS))  CONSTRAINTS)))
           (T
            (COND ((AND I1 I2) (KM-TRACE 'COMMENT "Instances ~a and ~a won't unify [constraint violation on slot `~a':" I1 I2 SLOT))
             (I1 (KM-TRACE 'COMMENT "Instance ~a won't unify with (a ~a with (~a ~a) ...)" I1 (DELISTIFY CS2) SLOT EXPRS2))
             (I2 (KM-TRACE 'COMMENT "Instance ~a won't unify with (a ~a with (~a ~a) ...)" I2 (DELISTIFY CS1) SLOT EXPRS1))
             (T
              (KM-TRACE 'COMMENT "(a ~a with (~a ~a) ...) and (a ~a with (~a ~a) ...) won't unify~%     [constraint violation on slot `~a':"
               (DELISTIFY CS1) SLOT EXPRS1 (DELISTIFY CS2) SLOT EXPRS2 SLOT)))
            (KM-TRACE 'COMMENT "  constraints ~a violated by value(s) ~a on slot ~a.]" CONSTRAINTS (APPEND VS1 VS2) SLOT)))))))))))))
;;;; ======================================================================
;;;;		LAZY-UNIFY-VALS
;;;; ======================================================================
#|lazy-unify-vals: One of the vs1 or vs2 may be nil, **but not both**
RETURNS TWO values
  (i) The unified structure (NB may be NIL with eagerlyp option)
  (ii) A t/nil flag depending on whether the unification was successful or not
11/17/00: This *doesn't* catch single-valued slot constraints, when v1 is local and given, but v2 is
	  to be inherited and clashes with v1.
 	  SOLUTION: Move the single-valued-slotp test to check-slotvals-constraints.
		(age has  (instance-of (Slot)) (cardinality (N-to-1)))
		(_Person1 has (age (23))))
		(new-situation)
		(_Person2 has (age (24)))
		(_Person1 &? _Person2)		will incorrectly succeed in KM 1.4.1.6 and earlier

(_v1) (_v2) -> ((_v1 & _v2))
((a cat)) ((a hat)) -> (((a cat) & ((a hat)))
[1]: and-append returns a (singleton) LIST of expressions, but we just want to pass a SINGLE expression to KM.
[2] If this unification fails, it doesn't mean a KB error, it just means that the two parent instances can't be unified.
    The failure is passed up to lazy-unify-slotsvals above, and the unification aborted. lazy-unify-slotsvals returns successp NIL.
[3]: KM necessarily returns either NIL or a singleton list here.
[4]: In the special case of ((<> foo) &! (<> bar)), an answer of NIL from evaluating the expression *doesn't* constitute failure of the
	unification.
[5]: Not an error, but would like to tidy this up: ((<> foo) &&! (<> bar)) should be reduced to ((<> foo) (<> bar))
[6]: If classes-subsumep is TRUE, then we are doing SET unification.
     Thus, we should FAIL if we are forced to coerce vs1 and vs2 to unify, ie. if
	- slot is a single-valued
	- vs1 and vs2 do not satisfy the classes-subsumep test
[7]  USER(49): (lazy-unify-vals 'X$has-part '(1 2) '(2) :classes-subsumep t)
	        (((1 2) && (2)))
     This causes structures to grow every time unification happens - urgh! Do a subbagp test (below).
[8] Ignore worrying about values from multiple prototypes, for now!|#
(TRACE-LISP
 (DEFINE LAZY-UNIFY-VALS (SLOT I1 I2 VS1 VS2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-VALS (SLOT I1 I2 VS1 VS2 LKEYS)
   (RET
    (CLET (CS1 CS2 CLASSES-SUBSUMEP EAGERLYP) (DECLARE (IGNORE I1 I2 CS1 CS2))
     (COND ((NULL VS2) (VALUES VS1 T))  ((NULL VS1) (VALUES VS2 T))  ((KM-EQUAL VS1 VS2) (VALUES VS1 T))
      ((SUBBAGP VS1 VS2 :TEST #'CL-EQUAL) (VALUES VS2 T)) ((SUBBAGP VS2 VS1 :TEST #'CL-EQUAL) (VALUES VS1 T))
      ((REMOVE-SUBSUMERS-SLOTP SLOT) (VALUES (REMOVE-SUBSUMERS (APPEND VS1 VS2)) T)) 
      ((REMOVE-SUBSUMEES-SLOTP SLOT) (VALUES (REMOVE-SUBSUMEES (APPEND VS1 VS2)) T)) 
      ((COMBINE-VALUES-BY-APPENDING-SLOTP SLOT) (VALUES (REMOVE-DUP-INSTANCES (APPEND VS1 VS2)) T)) 
      ((SINGLE-VALUED-SLOTP SLOT)
       (COND
        ((OR (CNOT (SINGLETONP VS1)) (CNOT (SINGLETONP VS2)))
         (REPORT-ERROR 'USER-WARNING
          "A single-valued slot has multiple values!~%Doing unification (~a & ~a)
Continuing, assuming all these values should be unified together...~%"
          VS1 VS2)))
       
       (COND
        ((COND ((AND (IGNORE-SLOT-DUE-TO-SITUATIONS-MODE SLOT)  (CNOT (AND (ATOM (FIRST VS1)) (ATOM (FIRST VS2))))))
          (*LESS-AGGRESSIVE-CONSTRAINT-CHECKING* T) (CLASSES-SUBSUMEP (KM0 `(,(FIRST VS1) &+? ,(FIRST VS2))))  (T (KM0 `(,(FIRST VS1) &? ,(FIRST VS2)))))
         
         (COND
          (EAGERLYP
           (CLET ((NEW-VALS (KM0 (VALS-TO-VAL (AND-APPEND (LIST (FIRST VS1)) '&! (LIST (FIRST VS2)))) ))) 
            (COND ((CNOT *ARE-SOME-CONSTRAINTS*) (VALUES NEW-VALS T))
             ((OR NEW-VALS (AND (NULL (REMOVE-CONSTRAINTS VS1))  (NULL (REMOVE-CONSTRAINTS VS2))))
              (VALUES
               (VAL-TO-VALS
                (VALS-TO-&-EXPR
                 (CL-REMOVE-DUPLICATES (APPEND NEW-VALS (FIND-CONSTRAINTS-IN-EXPRS VS1) (FIND-CONSTRAINTS-IN-EXPRS VS2)) :TEST #'CL-EQUAL)))
               T)))))
          (T (VALUES (VAL-TO-VALS (VALS-TO-&-EXPR (CL-REMOVE-DUPLICATES (APPEND (UN-ANDIFY VS1) (UN-ANDIFY VS2)) :TEST #'CL-EQUAL))) T))))))
        #|NEW|#
      (EAGERLYP
       (CLET
        ((VS1-VALS (REMOVE-CONSTRAINTS VS1))  (VS2-VALS (REMOVE-CONSTRAINTS VS2)) (VS1-CONSTRAINTS (FIND-CONSTRAINTS-IN-EXPRS VS1))
         (VS2-CONSTRAINTS (FIND-CONSTRAINTS-IN-EXPRS VS2)))
        (COND ((NULL VS1-VALS) (VALUES (APPEND VS2-VALS VS1-CONSTRAINTS VS2-CONSTRAINTS) T))
         ((NULL VS2-VALS) (VALUES (APPEND VS1-VALS VS1-CONSTRAINTS VS2-CONSTRAINTS) T))  
         (T (VALUES (APPEND (KM0 (VALS-TO-VAL (AND-APPEND VS1 '&&! VS2))) VS1-CONSTRAINTS VS2-CONSTRAINTS) T)))))
      
      (T
       (VALUES (VALSETS-TO-&&-EXPRS (CL-REMOVE-DUPLICATES (APPEND (&&-EXPRS-TO-VALSETS VS1) (&&-EXPRS-TO-VALSETS VS2)) :TEST #'CL-EQUAL :FROM-END T))
        T))))))))
;;;; ---------
#| This function re-inserts the local constraints into the unified expressions
;;; [1] multi-valued slot, [2] single-valued slot
;;; [1] (reinstate-constraints 'X$foo '(x y) 'X$((<> z) (<> p)) 'X$((must-be-a C)))  -> X$(x y (<> z) (<> p) (must-be-a c))
;;; [2] (reinstate-constraints 'X$foo '((x & y)) 'X$((<> z) (<> p)) 'X$((must-be-a C))) -> ((x & y & (<> z) & (<> p) & (must-be-a c)))
(defun reinstate-constraints (slot unified-vals exprs1 exprs2)
  (let ( (local-constraints (append (find-constraints-in-exprs exprs1) (find-constraints-in-exprs exprs2))) )
    (cond ((not local-constraints) unified-vals)
	  ((single-valued-slotp slot) 
	   (val-to-vals (vals-to-&-expr (remove-duplicates (append (un-andify unified-vals) local-constraints) :test X'equal))))
	  (t (remove-duplicates (append unified-vals local-constraints) :test X'equal)))))|#
#| NEW:
	 (cond ((km0 `X$((the ,SLOT of ,I1) &?  (the ,SLOT of ,I2)))	; returns a shorter unification expression (or fails).
		(and-append (list (first vs1)) '& (list (first vs2))))))
; OLD	(t (km0 `(,vs1 &&? ,vs2)))))
; NEW:
	v1s the slot of i1
	v2s the slot of i2
	THEN do &&


	((km0 `X$((the ,SLOT of ,I1) &&? (the ,SLOT of ,I2)))
	 (and-append vs1 '&& vs2))))|#
;; OLD	   (let ( (v1 (first vs1))
;; OLD		  (v2 (first vs2)) )
;;;;NEW;;	   (km-trace 'comment "Seeing if values for single-valued slot `~a' are unifiable..." slot)
;;;;NEW;;	   (km-trace 'comment "(Values are: ~a and ~a)" (first vs1) (first vs2))
;;;;NEW;;	   (let ( (v1 (km-unique0 (first vs1)))
;;;;NEW;;		  (v2 (km-unique0 (first vs2))) )
;;	     (cond ((and (atom v1) (atom v2))		    ; Check for inconsistency
;;		    (let ( (vv1 (dereference v1))    ; just in this special case	; DEREF NOT NECESSARY WITH NEW
;;			   (vv2 (dereference v2)) )  ; of two named single values.
;;		      (cond ((and (named-instancep vv1)
;;				  (named-instancep vv2))
;;			     (cond ((equal vv1 vv2) (list vv1))))   ; else FAIL (nil)
;; OLD			    (t 
;;;;NEW;;			    ((km0 `(,vv1 &? ,vv2))	; test feasibility of unification
;;			     (and-append (list vv1) '& (list vv2))))))
;;		   (t (and-append (list v1) '& (list v2))))))))
;;;; ======================================================================
;;;; 		LAZY-UNIFY-EXPRS
;;;; Does a subsumption check first
;;;; ======================================================================
;;;; Must be an & expr, ie. either (a & b), or ((a b) && (c d))
;;;; The arguments to &/&& may themselves be &/&& expressions, 
;;;; 	eg. ((a & b) & c),  
;;;;	    ( (((a b) && (c d))) && (e f) )
;;;; [ Note  (  ((a b) && (c d))  && (e f) ) is illegal, as the args to && must be a *list* of expressions ]
;;;; ALWAYS returns a list of values (necessarily singleton, for '&)
;;;; **NOTE** No point in doing any classification *DURING* unification (?). Better to wait until finished, and THEN do 
;;;; unification. But...might be incomplete? Better leave it in.
;;;; [1] (disable-classification) will be permanent if KM bombs during the evaluation, while (temporarily-disable-classification) 
;;;; will be reset at the next KM call.
;;;; [2] Note (remove-temporary-disablement-of-classification) doesn't necc. imply (classification-enabled) - it's only enabled
;;;;     if the user hasn't called (disable-classification)
#|(defun lazy-unify-&-expr (expr &key (joiner '&) (fail-mode 'fail) target)
   (temporarily-disable-classification)				; [1]
   (let* ( ; (constraints (find-constraints expr))		OLD
	  (constraints nil)					; DISABLE now! - move to get-slotvals.lisp
	  (unified0 (lazy-unify-&-expr0 expr :joiner joiner :fail-mode fail-mode :target target))
	  (unified (cond ((val-unification-operator joiner) (list unified0)) 	; must listify for &
			 (t unified0)))
	  (result0 (cond (constraints (enforce-constraints unified constraints nil nil)) ; instance, slot = nil, as there's no known slot here
			 (t unified)))
	  (result (remove nil result0)) )
     (remove-temporary-disablement-of-classification)
     (cond ((classification-enabled) (mapc X'(lambda (x) (cond ((kb-objectp x) (classify x)))) result)))  ; [2]
     result)))|#
(TRACE-LISP
 (DEFINE LAZY-UNIFY-&-EXPR (EXPR &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-&-EXPR (EXPR LKEYS)
   (RET
    (CLET (JOINER FAIL-MODE TARGET) (init-keyval FAIL-MODE 'FAIL) (init-keyval JOINER '&)
     (CLET
      ( (CONSTRAINTS NIL)  (UNIFIED0 (LAZY-UNIFY-&-EXPR0 EXPR :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET))
       (UNIFIED (COND ((VAL-UNIFICATION-OPERATOR JOINER) (LIST UNIFIED0))  (T UNIFIED0)))
       (CHECKED (COND (CONSTRAINTS (ENFORCE-CONSTRAINTS UNIFIED CONSTRAINTS NIL NIL))  (T UNIFIED))))
      (CL-REMOVE NIL CHECKED)))))))
(TRACE-LISP
 (DEFINE LAZY-UNIFY-&-EXPR0 (EXPR &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-&-EXPR0 (EXPR LKEYS)
   (RET
    (CLET (JOINER FAIL-MODE TARGET) (init-keyval FAIL-MODE 'FAIL) (init-keyval JOINER '&)
     (COND
      ((AND (TRACEP) (CNOT (TRACEUNIFYP)))
       (PROG2 (SUSPEND-TRACE) (LAZY-UNIFY-&-EXPR1 EXPR :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET) (UNSUSPEND-TRACE)))
      (T (LAZY-UNIFY-&-EXPR1 EXPR :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET))))))))
;;;; Input: A & or && expression. Output: a value (&) or value set (&&)
(TRACE-LISP
 (DEFINE LAZY-UNIFY-&-EXPR1 (EXPR &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-&-EXPR1 (EXPR LKEYS)
   (RET
    (CLET (JOINER FAIL-MODE TARGET) (init-keyval FAIL-MODE 'FAIL) (init-keyval JOINER '&)
     (COND ((NULL EXPR) NIL)
      ((AND (LISTP EXPR) (EQ (SECOND EXPR) JOINER)) 
       (COND
        ((>= (LENGTH EXPR) 4)
         (COND ((NEQ (FOURTH EXPR) JOINER) (REPORT-ERROR 'USER-ERROR "Badly formed unification expression ~a encountered during unification!~%" EXPR)))
         (CLET
          ((REVISED-EXPR
            (COND  ((VAL-UNIFICATION-OPERATOR JOINER) `((,(FIRST EXPR) ,JOINER ,(THIRD EXPR)) ,JOINER ,@(REST (REST (REST (REST EXPR))))))
             ((SET-UNIFICATION-OPERATOR JOINER) `(((,(FIRST EXPR) ,JOINER ,(THIRD EXPR))) ,JOINER ,@(REST (REST (REST (REST EXPR)))))))))
          (LAZY-UNIFY-&-EXPR1 REVISED-EXPR :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET)))
        ((VAL-UNIFICATION-OPERATOR JOINER)
         (LAZY-UNIFY-EXPRS (LAZY-UNIFY-&-EXPR1 (FIRST EXPR) :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET)
          (LAZY-UNIFY-&-EXPR1 (THIRD EXPR) :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET) :EAGERLYP (EQ JOINER '&!) :FAIL-MODE FAIL-MODE :TARGET
          TARGET))
        
        ((SET-UNIFICATION-OPERATOR JOINER)
         (LAZY-UNIFY-EXPR-SETS (LAZY-UNIFY-&-EXPR1 (FIRST EXPR) :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET)
          (LAZY-UNIFY-&-EXPR1 (THIRD EXPR) :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET) :EAGERLYP (EQ JOINER '&&!) :FAIL-MODE FAIL-MODE :TARGET
          TARGET))))
      ((AND (SINGLETONP EXPR)  (LISTP (FIRST EXPR))  (SET-UNIFICATION-OPERATOR JOINER)  (EQ (SECOND (FIRST EXPR)) JOINER))
       (LAZY-UNIFY-&-EXPR1 (FIRST EXPR) :JOINER JOINER :FAIL-MODE FAIL-MODE :TARGET TARGET))
      (T EXPR)))))))
;;;; ======================================================================
;;;; 	    UNIFICATION OF TWO EXPRESSIONS
;;;; Returns an ATOM, or more strictly something which passes an is-km-term() test, eg. a triple.
;;;; This *DOESN'T* enforce type constraints
;;;; ======================================================================
;;;; [1] Classify does a &, then does (undone X), which rechecks the classification a second time.
;;;; Thus classify needs to know if & fails, or else it will loop repeatedly rechecking the classification.
;;;; Thus we make lazy-unify-exprs return NIL rather than have a recovery attempt if there's a problem.
;;;; [2] fail-mode = fail, not error here, as we want to report the error at the lazy-unify-exprs
;;;;	level, not here.
;;;; RETURNS a SINGLE ATOMIC VALUE
;;;; [3] Presumably we took this out to make sure that expressions in the <val> position didn't get evaluated, e.g.
;;;;	(:triple *Sue mood (a Mood))
(TRACE-LISP
 (DEFINE LAZY-UNIFY-EXPRS (X Y &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-EXPRS (X Y LKEYS)
   (RET
    (CLET (EAGERLYP CLASSES-SUBSUMEP FAIL-MODE TARGET) (init-keyval FAIL-MODE 'FAIL)
     (COND ((AND (NULL X) (NULL Y)) NIL) ((NULL X) (KM-UNIQUE0 Y :TARGET TARGET))  ((NULL Y) (KM-UNIQUE0 X :TARGET TARGET)) 
      ((KM-EQUAL X Y) (KM-UNIQUE0 X :TARGET TARGET)) ((AND (KM-TRIPLEP X) (KM-TRIPLEP Y))  NIL)
      ((OR (KM-STRUCTURED-LIST-VALP X) (KM-STRUCTURED-LIST-VALP Y))
       (CLET ((DX (DESOURCE X)) (DY (DESOURCE Y)))
        #|	 (cond ((not (km-structured-list-valp dx)) (lazy-unify-exprs (list (first dy) dx) dy  			; dx & (:args dx dy)
								    :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode
								    :target target))
	       ((not (km-structured-list-valp dy)) (lazy-unify-exprs dx (list (first dx) dy)			; (:args dx dy) & dx
								    :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode
								    :target target))|#
        (COND
         ((AND (KM-STRUCTURED-LIST-VALP DY) (CNOT (KM-STRUCTURED-LIST-VALP DX)))
          (CLET ((EDX (KM-UNIQUE0 DX)))
           (COND
            ((CNOT (KM-STRUCTURED-LIST-VALP EDX))
             (COND ((NULL EDX) (KM-UNIQUE0 DY)) 
              ((AND (ANONYMOUS-INSTANCEP EDX) )
               (CLET ((ANS (LAZY-UNIFY EDX (KM-UNIQUE0 DY))))
                (COND (ANS)
                 ((EQ FAIL-MODE 'ERROR)
                  (REPORT-ERROR 'USER-ERROR "Unification (~a ~a ~a) failed!~%" X (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) Y) NIL))))
              ((KM-ARGSP DY) (LAZY-UNIFY-EXPRS (LIST (FIRST DY) EDX) DY)) 
              ((EQ FAIL-MODE 'ERROR)
               (REPORT-ERROR 'USER-ERROR "Unification (~a ~a ~a) failed!~%" X (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) Y) NIL)))
            (T (LAZY-UNIFY-EXPRS EDX DY)))))
         ((AND (KM-STRUCTURED-LIST-VALP DX) (CNOT (KM-STRUCTURED-LIST-VALP DY)))
          (CLET ((EDY (KM-UNIQUE0 DY)))
           (COND
            ((CNOT (KM-STRUCTURED-LIST-VALP EDY))
             (COND ((NULL EDY) (KM-UNIQUE0 DX))
              ((AND (ANONYMOUS-INSTANCEP EDY) )
               (CLET ((ANS (LAZY-UNIFY (KM-UNIQUE0 DX) EDY)))
                (COND (ANS)
                 ((EQ FAIL-MODE 'ERROR)
                  (REPORT-ERROR 'USER-ERROR "Unification (~a ~a ~a) failed!~%" X (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) Y) NIL))))
              ((KM-ARGSP DX) (LAZY-UNIFY-EXPRS DX (LIST (FIRST DX) EDY))) 
              ((EQ FAIL-MODE 'ERROR)
               (REPORT-ERROR 'USER-ERROR "Unification (~a ~a ~a) failed!~%" X (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) Y) NIL)))
            (T (LAZY-UNIFY-EXPRS DX EDY)))))
         ((AND (LISTP DX) (LISTP DY) (EQ (FIRST DX) (FIRST DY)) (NEQ (FIRST DX) ':|triple|) 
           (UNIFY-STRUCTURED-LIST-VALS DX DY :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :FAIL-MODE FAIL-MODE)))
         ((EQ FAIL-MODE 'ERROR) (REPORT-ERROR 'USER-ERROR "Unification (~a ~a ~a) failed!~%" X (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) Y)
          NIL))))
      ((EXISTENTIAL-EXPRP Y)
       (CLET ((XF (KM-UNIQUE0 X :TARGET TARGET)))
        (COND ((NULL XF) (KM-UNIQUE0 Y :TARGET TARGET))
         (T (UNIFY-WITH-EXISTENTIAL-EXPR XF Y :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :FAIL-MODE FAIL-MODE :TARGET TARGET)))))
      ((EXISTENTIAL-EXPRP X)
       (CLET ((YF (KM-UNIQUE0 Y :TARGET TARGET)))
        (COND ((NULL YF) (KM-UNIQUE0 X :TARGET TARGET))
         (T (UNIFY-WITH-EXISTENTIAL-EXPR YF X :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :FAIL-MODE FAIL-MODE :TARGET TARGET)))))
      ((AND (KB-OBJECTP X) (EXPLAINED-BY X Y TARGET)) (KM-TRACE 'COMMENT "[ ~a was originally derived from ~a, so must unify with it! ]" X Y) X) 
      (T
       (CLET ((XF (KM-UNIQUE0 X :TARGET TARGET)) (YF (KM-UNIQUE0 Y :TARGET TARGET)))
        (COND ((NULL XF) YF) ((NULL YF) XF)
         ((OR (KM-STRUCTURED-LIST-VALP XF) (KM-STRUCTURED-LIST-VALP YF))
          (LAZY-UNIFY-EXPRS XF YF :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :FAIL-MODE FAIL-MODE :TARGET TARGET))
         ((AND (IS-KM-TERM XF) (IS-KM-TERM YF))
          (COND ((LAZY-UNIFY XF YF :EAGERLYP EAGERLYP :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))
           ((EQ FAIL-MODE 'ERROR) (REPORT-ERROR 'USER-ERROR "Unification (~a ~a ~a) failed!~%" XF (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) YF)
            #| NEW - give up [1] |# NIL)))
         ((EQ FAIL-MODE 'ERROR)
          (REPORT-ERROR 'USER-ERROR "Arguments in a unification expression should be unique KM objects!~%Doing (~a ~a ~a) [ie. (~a ~a ~a)]~%" X
           (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) Y XF (COND (EAGERLYP '&!) (CLASSES-SUBSUMEP '&+) (T '&)) YF)))))))))))
;;;;; e.g. _X is a concept with no properties
;;(defun no-properties (frame) (not (symbol-plist frame)))
(TRACE-LISP
 (DEFINE JUST-A-THING (INSTANCE)
  (trace-defun 'JUST-A-THING (INSTANCE)
   (RET
    (AND
     (OR (NULL (GET-SLOTSVALS INSTANCE :SITUATION *GLOBAL-SITUATION*))
      (CL-EQUAL (GET-SLOTSVALS INSTANCE :SITUATION *GLOBAL-SITUATION*) '((|instance-of| (|Thing|)))))
     (OR (AM-IN-GLOBAL-SITUATION) (NULL (GET-SLOTSVALS INSTANCE))))))))
;; no local situation values
;;;; ======================================================================
;;;; Called by lazy-unify-exprs
;;;; Break up structured instances, and feed back fragments to lazy-unify-exprs
;;;; [1] 3/13/01 - Bug! Need to check *all* unifications succeed before effecting them, not just one at a time!
;;;;	Correction is to add this up-front test. This is slightly redundant (KM will work out the unifications twice, once in the test
;;;;	and once when actually doing it), but that's ok.
;;;;	It's possible KM will *think* a unification's possible but then fail to actually do it. Yikes! In this case, KM will be stuck
;;;;	with a partly unified sequence. We'll live with that for now.
;;;; [2] Must pass through km0, as the elements may be expressions (not guaranteed to be atomic!)
;;;; [3] & of structured vals are only decommented at the top level by km0, so we need to do another decommenting here so that remaining
;;;;     comments aren't taken as actual values themselves!
(TRACE-LISP
 (DEFINE UNIFY-STRUCTURED-LIST-VALS (INSTANCE10 INSTANCE20 &REST LKEYS)
  (trace-defun 'UNIFY-STRUCTURED-LIST-VALS (INSTANCE10 INSTANCE20 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP FAIL-MODE)
     (CLET ((INSTANCE1 (DECOMMENT-TOP-LEVEL INSTANCE10))  (INSTANCE2 (DECOMMENT-TOP-LEVEL INSTANCE20)))
      (COND
       ((AND (LISTP INSTANCE1) (LISTP INSTANCE2) (EQ (FIRST INSTANCE1) (FIRST INSTANCE2)) 
         (EVERY #'(LAMBDA (PAIR) (trace-defun '#:G15729 (PAIR) (RET ))) (TRANSPOSE (LIST (REST INSTANCE1) (REST INSTANCE2)))))
        (CLET
         ((UNIFICATION
           (UNIFY-STRUCTURED-LIST-VALS2 (REST INSTANCE1) (REST INSTANCE2) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :FAIL-MODE FAIL-MODE)))
         (COND
          ((EQ UNIFICATION 'FAIL)
           (REPORT-ERROR 'NODEBUGGER-ERROR
            "Yikes! I partly unified two sequences ~a and ~a but then found they couldn't be unified!~%I'll continue and hope for the best (sorry!)...~%"
            INSTANCE1 INSTANCE2))
          (T (CONS (FIRST INSTANCE1) UNIFICATION))))))))))))
(TRACE-LISP
 (DEFINE UNIFY-STRUCTURED-LIST-VALS2 (ELEMENTS1 ELEMENTS2 &REST LKEYS)
  (trace-defun 'UNIFY-STRUCTURED-LIST-VALS2 (ELEMENTS1 ELEMENTS2 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP FAIL-MODE)
     (COND ((NULL ELEMENTS1) ELEMENTS2) ((NULL ELEMENTS2) ELEMENTS1)
      ((OR (KM-SETP (FIRST ELEMENTS1)) (KM-SETP (FIRST ELEMENTS2)))
       (CLET
        ((SET-ELEMENT1 (COND ((KM-SETP (FIRST ELEMENTS1)) (SET-TO-LIST (FIRST ELEMENTS1))) (T (LIST (FIRST ELEMENTS1)))))
         (SET-ELEMENT2 (COND ((KM-SETP (FIRST ELEMENTS2)) (SET-TO-LIST (FIRST ELEMENTS2))) (T (LIST (FIRST ELEMENTS2)))))
         (UNIFICATION (LAZY-UNIFY-EXPR-SETS SET-ELEMENT1 SET-ELEMENT2 #|:classes-subsumep classes-subsumep|# :EAGERLYP EAGERLYP)))
        (COND
         (UNIFICATION
          (CLET
           ((UNIFICATIONS
             (UNIFY-STRUCTURED-LIST-VALS2 (REST ELEMENTS1) (REST ELEMENTS2) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :FAIL-MODE FAIL-MODE)))
           (COND ((NEQ UNIFICATIONS 'FAIL) (CONS (VALS-TO-VAL UNIFICATION) UNIFICATIONS)) (T 'FAIL))))
         (T 'FAIL))))
      (T
       (CLET
        (  (E1 (FIRST ELEMENTS1)) (E2 (FIRST ELEMENTS2)) (UNIFICATION (LAZY-UNIFY-EXPRS E1 E2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP)))
        (COND
         ((OR UNIFICATION (KM-NULL E1)  (KM-NULL E2)  (AND (CNOT (EXISTENTIAL-EXPRP E1)) (NULL (KM-UNIQUE0 E1))) 
           (AND (CNOT (EXISTENTIAL-EXPRP E2)) (NULL (KM-UNIQUE0 E2))))
          (CLET
           ((UNIFICATIONS
             (UNIFY-STRUCTURED-LIST-VALS2 (REST ELEMENTS1) (REST ELEMENTS2) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP :FAIL-MODE FAIL-MODE)))
           (COND ((NEQ UNIFICATIONS 'FAIL) (CONS UNIFICATION UNIFICATIONS)) (T 'FAIL))))
         (T 'FAIL))))))))))
;;;; ======================================================================
;;;;		LAZY-UNIFY-EXPR-SETS
;;;; Handling of expressions: Here KM limits the evaluation of the second expression list,
;;;; so as to avoid creating unnecessary instances and simplify the proof trace.
;;;; HOWEVER: This is extremely cryptic to watch in the normal execution of KM,
;;;; so hide it from the user!!
;;;; ======================================================================
;;;; Allows us to switch off KM's heuristic unification mechanism
(TRACE-LISP (DEFPARAMETER *NO-HEURISTIC-UNIFICATION* NIL))
#|						((_Door178 _Door179 _Cat23 _Bumper176) && ((a Cat) (MyCar has-door) (a Door) (a Door))  
  [1] evaluate any non-existential exprs		((_Door178 _Door179 _Cat23 _Bumper176) && ((a Cat) _Door178 (a Door) (a Door)))
  [2] remove duplicates				(_Door178) APPEND ((_Door179 _Cat23 _Bumper176) && ((a Cat) (a Door) (a Door))
  [3] remove subsuming elements  		(_Door178 _Door179 _Cat23) APPEND ((_Bumper176) && ((a Door)))
  [4] evaluate the remaining exprs		(_Door178 _Door179 _Cat23) APPEND ((_Bumper176) && (_Door180))
  [5] unify the result				(_Door178 _Door179 _Cat23 _Bumper176 _Door180)

[6] NOTE this is guaranteed to succeed, as there are no constraints here (constraints are on expressions in situ on slots)

[7] Eager set unification: previous error:
	(_Move3 _Enter4) &&! (_Enter5)
     With :eagerlyp passed to lazy-unify-sets, thus to lazy-unify-vals, I *force* _Enter5 and _Move3 to unify, even if there's a 
	constraint violation. Urgh!
    Really I need a two-pass implementation:
	  (i) Do a &&
	  (ii) Evaluate the subexpression unifications & / &&
(((_Car1 with (color (_Red1 _Green1))) _Toy1) &&! ((_Car2 with (color (_Green2)))))
 -> ((_Car12 with (color (((_Red1 _Green1) &&! _Green2)))) _Toy1)
  -> need to map through all the slot-values of the unifications, looking for &&! and executing them.
     Will this catch them all? I *think* so.  Note &! CAN be executed within lazy-unify-slotvals, as this IS unambiguous, and thus
	we don't need this two-pass approach.
     I haven't accounted for multiple situations, though.

QUESTION: GIVEN: ((the parts of _Engine13)) && ((the parts of _Engine13) _Distributor14)
	  AND (the parts of _Engine13) include _Distributor12, then should _Distributor12 and _Distributor14 unify? Answer: no I think.
	  Any evaluation of a shared expression should *augment*, not *unify with* other values present.|#
(TRACE-LISP
 (DEFINE LAZY-UNIFY-EXPR-SETS (EXPRS1 EXPRS2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-EXPR-SETS (EXPRS1 EXPRS2 LKEYS)
   (RET
    (CLET (EAGERLYP FAIL-MODE TARGET) (init-keyval FAIL-MODE 'FAIL) (DECLARE (IGNORE FAIL-MODE)) 
     (COND
      ((OR (CNOT (LISTP EXPRS1)) (CNOT (LISTP EXPRS2)))
       (REPORT-ERROR 'USER-ERROR "(~a && ~a): Arguments should be *sets* of values, but just found a single value!~%" EXPRS1 EXPRS2))
      ((SUBBAGP EXPRS2 EXPRS1 :TEST #'CL-EQUAL) (KM0 (VALS-TO-VAL EXPRS1) :TARGET TARGET))
      (T
       (CLET ((SET1 (KM0 (VALS-TO-VAL EXPRS1) :TARGET TARGET)))
        (COND ((NULL SET1) (KM0 (VALS-TO-VAL EXPRS2) :TARGET TARGET)) 
         (T
          (MULTIPLE-VALUE-BIND (UNEXPLAINED-SET1 UNEXPLAINING-EXPRS2) (REMOVE-EXPLAINED-VALS SET1 (DEREFERENCE EXPRS2) :TARGET TARGET)
           (CLET ((SET2 (MY-MAPCAN #'(LAMBDA (EXPR) (trace-defun '#:G15730 (EXPR) (RET ))) UNEXPLAINING-EXPRS2)))     
            (MULTIPLE-VALUE-BIND (REDUCED-SET1 REDUCED-SET2)  (REMOVE-SHARED-ELEMENTS UNEXPLAINED-SET1 SET2 :TEST #'CL-EQUAL)
             (MULTIPLE-VALUE-BIND (MORE-REDUCED-SET1 MORE-REDUCED-SET2) 
              (DO-FORCED-UNIFICATIONS REDUCED-SET1 REDUCED-SET2 :EAGERLYP EAGERLYP :TARGET TARGET)
              (MULTIPLE-VALUE-BIND (REMAINDER-SET2 REMAINDER-SET1 SUBSUMED-SET1)    #|PC|#
               (REMOVE-SUBSUMING-EXPRS MORE-REDUCED-SET2 MORE-REDUCED-SET1 :ALLOW-COERCION T :TARGET TARGET)  #|[9]|# (DECLARE (IGNORE SUBSUMED-SET1))
               (CLET
                ((NEW-SET2 (MY-MAPCAN #'(LAMBDA (EXPR) (trace-defun '#:G15731 (EXPR) (RET ))) REMAINDER-SET2)) #| NEW |#
                 (UNIFIED (LAZY-UNIFY-SETS REMAINDER-SET1 NEW-SET2 :EAGERLYP EAGERLYP)) 
                 (FINAL-RESULT (REMOVE-DUP-INSTANCES (APPEND (DEREFERENCE SET1) (CL-ORDERED-SET-DIFFERENCE (DEREFERENCE UNIFIED) (DEREFERENCE SET1))))))
                (COND (EAGERLYP (MAPC #'EAGERLY-EVALUATE-EXPRS FINAL-RESULT))) FINAL-RESULT))))))))))))))))
;;;; ----------------------------------------------------------------------
#|RETURNS two values
 - vals which are unexplained by any of exprs
 - exprs which don't explain any vals
ALGORITHM:
  (i) find all the explanations of vals
 (ii) For each val,
	- if val is explained by (path1) (path2) (a C) (a C2) in exprs then:
		- remove val from list of unexplained vals
		- remove *all* explaining paths, i.e., path1, path2
		- remove *one* existential, e.g., (a C).
***Actually** in the current implementation of explanations-for, explanations are *necessarily* existential-exprs, but we allow for
the case when they're also not below, even though it never currently can happen.
 Later - neah, drop this
[1] NOTE: cache-explanations now LEAVES comments in, because if we have two rules:
	(a Wing with (has-logo (t)) (@ Airplane parts)))
	(a Wing with (has-logo (t)) (@ Jumbo parts)))
    Then these should *BOTH* be recorded as explanations for _Wing1. If we discard rule 2 as "already used" as _Wing1 is
    explained by rule 1, then we'll lose rule 2 as an explanation for _Wing1.
    HOWEVER: We really want some clever matching which will "realize" that these two rules match, i.e. a value explained by
    rule 1 is also covered by rule 2...and hence rule 2 can be removed, but ALSO noted as an explanation for that value.
    We can do this at a later time.|#
;;;; [2] Now *includes* source info
;;;; [3] cached-explanations may include (a Engine), existing recorded explanations may record (a Engine (@ Car parts)),
;;;; 	all-explanations may include explanation (a Engine (@ Vehicle parts)), so need to record this explanation too if we
;;;;     are going to drop the expr!
;;;; [4a] The existential explanation is removed on the way down; [4b] The path explanations are removed on the way back
;;(defun remove-explained-vals (vals exprs &key target)
;;  (declare (ignore target))
;;  (values vals exprs))
#|Problem before:
 (_Car1 _Car2)  ((a Car with (color (Red))) (a Car))
and suppose _Car1 is explained by (a Car)
This causes the ordering to be violated: 
	_Car1 matches (a Car)
	_Car2 matches (a Car with (color (Red)))
and this is bad for the Shaken system!

This reduced version insists the matching is sequential and exits otherwise [5].
Hmm... but doesn't seem to speed things up much, particularly because there are paths in the exprs (which aren't in the cache).

----------------------------------------
[6] Revised - we still insist on sequentiality, but now allow gaps to avoid the below problem.
(Parent-Stuff has (superclasses (Entity)))
(every Parent-Stuff has
   (location ((a Place)))
   (has-part ((a Entity))))

(Child-Thing has (superclasses (Parent-Stuff)))
(every Child-Thing has
   (has-part ((a Entity) (a Tangible-Entity) (a Physical-Object))))
(every Child-Thing has-definition
   (instance-of (Parent-Stuff))
   (has-part ((a Tangible-Entity))))

[_Situation6] KM> (a Parent-Stuff)
(_Parent-Stuff7)

[_Situation6] KM> (the has-part of _Parent-Stuff7)
(_Entity8)

[_Situation6] KM> (_Parent-Stuff7 also-has (has-part ((a Tangible-Entity))))
(_Parent-Stuff7 XX"a Child-Thing"XX)	; classified fine

;;; Problem - the also-has Tangible-Entity is unified with (a Entity) on Child-Thing.
[_Situation6] KM> (the has-part of _Parent-Stuff7)
(_Entity8 XX"a Tangible-Entity"XX _Tangible-Entity9 _Physical-Object10)|#
(TRACE-LISP
 (DEFINE REMOVE-EXPLAINED-VALS (VALS EXPRS &REST LKEYS)
  (trace-defun 'REMOVE-EXPLAINED-VALS (VALS EXPRS LKEYS)
   (RET
    (CLET (TARGET)
     (COND ((NULL VALS) (VALUES NIL EXPRS))
      (T
       (CLET ((VAL (FIRST VALS)) (EXPR (FIRST EXPRS)) (CACHED-EXPLANATIONS (CACHED-EXPLANATIONS-FOR VAL)))
        (COND
         ((CL-MEMBER (DESOURCE EXPR) CACHED-EXPLANATIONS :TEST #'CL-EQUAL)  (COND (TARGET (RECORD-EXPLANATION-FOR TARGET VAL EXPR))) 
          (COND ((EXISTENTIAL-EXPRP EXPR) (REMOVE-EXPLAINED-VALS (REST VALS) (REST EXPRS) :TARGET TARGET)) 
           (T
            (MULTIPLE-VALUE-BIND  (UNEXPLAINED-VALS UNEXPLAINING-EXPRS) (REMOVE-EXPLAINED-VALS (REST VALS) EXPRS :TARGET TARGET) 
             (VALUES UNEXPLAINED-VALS (CL-REMOVE EXPR UNEXPLAINING-EXPRS :TEST #'CL-EQUAL))))))
           
         (T
          (MULTIPLE-VALUE-BIND (UNEXPLAINED-VALS UNEXPLAINING-EXPRS) (REMOVE-EXPLAINED-VALS (REST VALS) EXPRS :TARGET TARGET)
           (VALUES (CONS VAL UNEXPLAINED-VALS) UNEXPLAINING-EXPRS))))))))))))
#|(defun remove-explained-vals (vals exprs &key target)
  (cond ((endp vals) (values nil exprs))
	(t (let* ( (val (first vals))
; correct!	   (explanations (intersection (cached-explanations-for val) exprs :test X'equal)) 	; [1]

; Temp - need to remove these for backward library compatibility...
;		   (cached-explanations (desource (cached-explanations-for val)))	; desource to be removed shortly...
		   (cached-explanations (cached-explanations-for val))	
		   (explanations (remove-if-not X'(lambda (expr) (member (desource expr) cached-explanations :test X'equal)) exprs)) ; [2]
		   (path-explanations (remove-if X'existential-exprp explanations))
		   (existential-explanation (find-if X'existential-exprp explanations)) 		; find just first...
		   (all-explanations (cond (existential-explanation (cons existential-explanation path-explanations))
					   (t path-explanations))) )
	     (cond (all-explanations
;		    (km-format t "~a removed as existing explanations for ~a = ~a!~%" all-explanations target val)
		    (km-trace 'comment "[ ~a is already known to be computed from ~a ]" val all-explanations)
		    (cond (target (mapc X'(lambda (explanation)
					    (record-explanation-for target val explanation))			; [3]
					all-explanations)))
		    (multiple-value-bind 
		     (unexplained-vals unexplaining-exprs)
		     (remove-explained-vals (rest vals) (remove existential-explanation exprs :test X'equal :count 1) :target target)  ; [4a]
		     (values unexplained-vals (ordered-set-difference unexplaining-exprs path-explanations :test X'equal))))	       ; [4b]
		   (t 
		    (multiple-value-bind 
		     (unexplained-vals unexplaining-exprs)
		     (remove-explained-vals (rest vals) exprs :target target)
		     (values (cons val unexplained-vals) unexplaining-exprs))))))))|#
;;;; ----------
;;;; This implements the eager evaluation of sub-unified expressions.
(TRACE-LISP
 (DEFINE EAGERLY-EVALUATE-EXPRS (INSTANCE &OPTIONAL SITUATION)
  (trace-defun 'EAGERLY-EVALUATE-EXPRS (INSTANCE SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (MAPC
      #'(LAMBDA (SLOTVALS)
         (trace-defun '#:G15732 (SLOTVALS)
          (RET (COND ((MINIMATCH (VALS-IN SLOTVALS) '((?X &&! ?Y) &REST)) (KM0 `(|the| ,(SLOT-IN SLOTVALS) |of| ,INSTANCE)))))))
      (GET-SLOTSVALS INSTANCE :SITUATION SITUATION)))))))
;;;; ======================================================================
;;;; Experimental patch, leave off for now. If on, the cloned-from tags are also used to align concepts
(TRACE-LISP (DEFPARAMETER *FORCE-WITH-CLONED-FROM* NIL))
#| 
INPUT: set1 set2
RETURNS: three values:
	- shorter set1
	- shorter set2
	- list of items which unified via forcing (through the :tag slot) |#
;;;; Dormant for a year, reinstated
(TRACE-LISP
 (DEFINE DO-FORCED-UNIFICATIONS (SET1 EXPRS2 &REST LKEYS)
  (trace-defun 'DO-FORCED-UNIFICATIONS (SET1 EXPRS2 LKEYS)
   (RET
    (CLET (EAGERLYP TARGET)
     (COND ((AND (CNOT *ARE-SOME-TAGS*) (CNOT *RECORD-EXPLANATIONS-FOR-CLONES*)) (VALUES SET1 EXPRS2 NIL))  ((ENDP SET1) (VALUES NIL EXPRS2 NIL))
      (T
       (CLET
        ((VAL1 (FIRST SET1))
         (VAL1-TAGS
          (COND
           ((KB-OBJECTP VAL1)
            (APPEND (COND (*FORCE-WITH-CLONED-FROM* (GET-VALS VAL1 '|cloned-from|))) (GET-VALS VAL1 '|called|) (GET-VALS VAL1 '|uniquely-called|)))))
         (MATCHES
          (REMOVE-IF-NOT
           #'(LAMBDA (EXPR)
              (trace-defun '#:G15733 (EXPR)
               (RET (CL-INTERSECTION (TAGS-IN-EXPR EXPR :USE-CLONED-FROM *FORCE-WITH-CLONED-FROM*) VAL1-TAGS :TEST #'CL-EQUAL))))
           EXPRS2))
         (VAL2 (FIRST MATCHES)) (VAL2-TAGS (COND (VAL2 (TAGS-IN-EXPR VAL2)))))
        
        (COND
         ((NULL MATCHES)
          (MULTIPLE-VALUE-BIND (REDUCED-SET1 REDUCED-EXPRS2 UNIFICATIONS) (DO-FORCED-UNIFICATIONS (REST SET1) EXPRS2)
           (VALUES (CONS VAL1 REDUCED-SET1) REDUCED-EXPRS2 UNIFICATIONS)))
         ((AND (>= (LENGTH MATCHES) 2) 
           (CLET
            ((REDUCED-VAL1-TAGS (COND ((KB-OBJECTP VAL1) (APPEND (GET-VALS VAL1 '|called|) (GET-VALS VAL1 '|uniquely-called|)))))
             (REDUCED-MATCHES
              (REMOVE-IF-NOT
               #'(LAMBDA (EXPR)
                  (trace-defun '#:G15734 (EXPR)
                   (RET (CL-INTERSECTION (TAGS-IN-EXPR EXPR :USE-CLONED-FROM NIL) REDUCED-VAL1-TAGS :TEST #'CL-EQUAL))))
               EXPRS2)))
            (>= (LENGTH REDUCED-MATCHES) 2)))
          (REPORT-ERROR 'USER-ERROR "Tagging error! ~a's tags ~a imply it should unify with multiple, distinct values:~%       ~a!~%" VAL1 VAL1-TAGS
           MATCHES))
         ((CNOT (IS-CONSISTENT (APPEND VAL1-TAGS VAL2-TAGS)))
          (REPORT-ERROR 'USER-ERROR "Tag inconsistency! ~a and ~a have tags both forcing and disallowing unification!~%       Tag sets were: ~a and ~a~%"
           VAL1 VAL2 VAL1-TAGS VAL2-TAGS))
         (T          
          (CLET
           ((UNIFICATION
             (COND ((EXISTENTIAL-EXPRP VAL2)  (UNIFY-WITH-EXISTENTIAL-EXPR VAL1 VAL2 :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP NIL :TARGET TARGET))  
              (T (LAZY-UNIFY VAL1 VAL2 :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP NIL)))))
           (COND
            ((CNOT UNIFICATION)
             (REPORT-ERROR 'USER-ERROR "Tagging error! tags ~a (on ~a) and ~a (on ~a) imply (~a & ~a) must be unified, but this unification fails!"
              VAL1-TAGS VAL1 VAL2-TAGS VAL2 VAL1 VAL2))))
          (MULTIPLE-VALUE-BIND (REDUCED-SET1 REDUCED-EXPRS2 UNIFICATIONS) (DO-FORCED-UNIFICATIONS (REST SET1) (CL-REMOVE VAL2 EXPRS2 :TEST #'CL-EQUAL))
           (VALUES REDUCED-SET1 REDUCED-EXPRS2 (CONS VAL1 UNIFICATIONS)))))))))))))
;;;; ----------
;;;; expr is necessarily an *instance* or an *existential expr*
(TRACE-LISP
 (DEFINE TAGS-IN-EXPR (EXPR &REST LKEYS)
  (trace-defun 'TAGS-IN-EXPR (EXPR LKEYS)
   (RET
    (CLET (USE-CLONED-FROM) (init-keyval USE-CLONED-FROM T)
     (COND
      ((KB-OBJECTP EXPR) (APPEND (COND (USE-CLONED-FROM (GET-VALS EXPR '|cloned-from|))) (GET-VALS EXPR '|called|) (GET-VALS EXPR '|uniquely-called|)))
      (T
       (CLET ((CLASS+SLOTSVALS (BREAKUP-EXISTENTIAL-EXPR EXPR)))
        (COND
         (CLASS+SLOTSVALS
          (APPEND (COND (USE-CLONED-FROM (VALS-IN (ASSOC '|cloned-from| (SECOND CLASS+SLOTSVALS))))) (VALS-IN (ASSOC '|called| (SECOND CLASS+SLOTSVALS)))
           (VALS-IN (ASSOC '|uniquely-called| (SECOND CLASS+SLOTSVALS))))))))))))))
;;;; ======================================================================
;;;;		LAZY-UNIFY-SETS
;;;; Here KM makes a plausible guess as to which members of the sets should
;;;; be coreferential.
;;;; Is an ***auxiliary function*** to lazy-unify-expr-sets, not called from
;;;; anywhere else in KM.
;;;; ======================================================================
#|(lazy-unify-sets set1 set2)
For the members which *will* unify, actually do the unification.
Below does not allow *different* set1s to unify with the *same* set2.
INPUT: Both sets must be lists of instances. They will already have been dereferenced before this point.
RETURNS: A list of instances.
[1] need :count 1, so that ((Open) && (Open Open)) = (Open Open), not just (Open)
[2] Need to first remove duplicate, named instances, so that
	((*MyCar) && (_Car2 *MyCar))  = (_Car2 *MyCar), not (*MyCar)
MAR99: Why just named?
	((_Car3) && (_Car2 _Car3))  = (_Car2 _Car3), not (_Car3)
INPUT: The members of the sets must be FULLY EVALUATED - it's an error otherwise.|#
(TRACE-LISP
 (DEFINE LAZY-UNIFY-SETS (SET1 SET2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-SETS (SET1 SET2 LKEYS)
   (RET
    (CLET (EAGERLYP)
     (COND (*NO-HEURISTIC-UNIFICATION* (REMOVE-DUP-ATOMIC-INSTANCES (APPEND SET1 SET2)))
      (T
       (CLET
        ((SHARED-ELEMENTS (CL-ORDERED-INTERSECTION SET1 SET2)) (RESTSET1 (CL-ORDERED-SET-DIFFERENCE SET1 SHARED-ELEMENTS))
         (RESTSET2 (CL-ORDERED-SET-DIFFERENCE SET2 SHARED-ELEMENTS)))
        (MULTIPLE-VALUE-BIND (UNIFIEDS REST2SET1 REST2SET2) (LAZY-UNIFY-SETS3 RESTSET1 RESTSET2 :EAGERLYP EAGERLYP)
         (CLET ((REMAINDER (LAZY-UNIFY-SETS2 REST2SET1 REST2SET2 :EAGERLYP EAGERLYP))) (APPEND SHARED-ELEMENTS UNIFIEDS REMAINDER)))))))))))
;;;; ----------
#| 
lazy-unify-sets3 introduced for the following:
(reset-kb)

(Ribosome has (superclasses (Organelle)))

(_DNA2 has (instance-of (DNA)))
(_Membrane3 has   (instance-of (Membrane)))
(_Organelle5 has   (instance-of (Organelle)))
(_Ribosome4 has   (instance-of (Ribosome)))

(_Organelle6 has  (instance-of (Organelle)))

;;; Check that (_Organelle5 & _Organelle6) is preferred to
;;; (_Ribosome5 && _Organelle6), even though Ribosome has superclasses
;;; Organelle. The new procedure lazy-unify-sets3 does this preference.
((_DNA2 _Membrane3 _Ribosome4 _Organelle5) && (_Organelle6))

(not (_Organelle6 isa Ribosome))|#
(TRACE-LISP
 (DEFINE LAZY-UNIFY-SETS3 (SET1 SET2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-SETS3 (SET1 SET2 LKEYS)
   (RET
    (CLET (EAGERLYP)
     (COND ((OR (ENDP SET1) (ENDP SET2)) (VALUES NIL SET1 SET2))
      (T
       (CLET
        ((UNIFIER (FIND-IF #'(LAMBDA (SET2EL) (trace-defun '#:G15735 (SET2EL) (RET (SLOTSVALS-SUBSET-OF-SLOTSVALS (FIRST SET1) SET2EL)))) SET2)))
        (COND
         (UNIFIER
          (CLET ((UNIFIED (KM-UNIQUE0 `(,(FIRST SET1) & ,UNIFIER) :FAIL-MODE 'ERROR)))
           (MULTIPLE-VALUE-BIND (UNIFIEDS RESTSET1 RESTSET2) (LAZY-UNIFY-SETS3 (REST SET1) (CL-REMOVE UNIFIER SET2 :COUNT 1) :EAGERLYP EAGERLYP)
            (VALUES (CONS UNIFIED UNIFIEDS) RESTSET1 RESTSET2))))
         (T
          (MULTIPLE-VALUE-BIND (UNIFIEDS RESTSET1 RESTSET2) (LAZY-UNIFY-SETS3 (REST SET1) SET2 :EAGERLYP EAGERLYP)
           (VALUES UNIFIEDS (CONS (FIRST SET1) RESTSET1) RESTSET2 :EAGERLYP EAGERLYP))))))))))))
(TRACE-LISP
 (DEFINE SLOTSVALS-SUBSET-OF-SLOTSVALS (I1 I2)
  (trace-defun 'SLOTSVALS-SUBSET-OF-SLOTSVALS (I1 I2)
   (RET
    (COND
     ((OR (ANONYMOUS-INSTANCEP I1) (ANONYMOUS-INSTANCEP I2)) 
      (CLET
       ((VS1 (APPEND (GET-SLOTSVALS I1) (COND ((AM-IN-LOCAL-SITUATION) (GET-SLOTSVALS I1 :SITUATION *GLOBAL-SITUATION*)))))
        (VS2 (APPEND (GET-SLOTSVALS I2) (COND ((AM-IN-LOCAL-SITUATION) (GET-SLOTSVALS I2 :SITUATION *GLOBAL-SITUATION*))))))
       (OR (NULL (SET-DIFFERENCE VS1 VS2 :TEST #'CL-EQUAL)) (NULL (SET-DIFFERENCE VS2 VS1 :TEST #'CL-EQUAL))))))))))
;;;; ----------
(TRACE-LISP
 (DEFINE LAZY-UNIFY-SETS2 (SET1 SET2 &REST LKEYS)
  (trace-defun 'LAZY-UNIFY-SETS2 (SET1 SET2 LKEYS)
   (RET
    (CLET (EAGERLYP)
     (COND ((ENDP SET1) SET2) ((ENDP SET2) SET1)           
      (T
       (CLET
        ((UNIFIER
          (FIND-IF
           #'(LAMBDA (SET2EL) (trace-defun '#:G15736 (SET2EL) (RET (LAZY-UNIFY (FIRST SET1) SET2EL :CLASSES-SUBSUMEP T :EAGERLYP EAGERLYP))))
           SET2)))
        
        (COND (UNIFIER (CONS UNIFIER (LAZY-UNIFY-SETS (REST SET1) (REMOVE UNIFIER SET2 :COUNT 1) :EAGERLYP EAGERLYP))) 
         (T (CONS (FIRST SET1) (LAZY-UNIFY-SETS (REST SET1) SET2 :EAGERLYP EAGERLYP))))))))))))
;;;; ======================================================================
;;;;	MACHINERY FOR REMOVING DUPLICATES WHEN &'ing TOGETHER STUFF
;;;; ======================================================================
#|and-append: 
 - Takes two *sets* of values. For &, those sets will necessarily be singletons.
 - Returns a *set* containing a *single* value, = the unification of those 
	two sets (either using & or && as specified in the call).

This simple task ends up being surprisingly tricky to implement correctly...

;;; without duplicates
(and-append '(a) '& '(b)) 		;-> ((a & b))
(and-append '(a) '& '((b & c))) 	;-> ((a & b & c))
(and-append '((a & b)) '& '((c & d))) 	;-> ((a & b & c & d))

;;; with duplicates
(and-append '(a) '& '((b & a))) 	;-> ((b & a))
(and-append '((b & a)) '& '(a)) 	;-> ((b & a))
(and-append '((a & b)) '& '((c & a))) 	;-> (( b & c & a))

The critical property is that repeated and'ing doesn't make the list grow indefinitely:
(and-append '(a) '& '(b))		;-> ((a & b))
(and-append '((a & b)) '& '(b))		;-> ((a & b))
(and-append '(a b) '&& '(c d))		;-> (((a b) && (c d)))
(and-append '(((a b) && (c d))) '&& '(c d)) ;-> (((a b) && (c d)))

Inputs get converted to call and-append2 as follows:
(((a b) && (c d)))      (((a b) && (e f))) [1a] -> ((a b) && (c d))     ((a b) && (e f))
((a & b))		((a & c))	   [1b] -> (a & b)		(a & c)
(((a b) && (c d)))      (a b)		   [2a] -> ((a b) && (c d))     ((a b))
((a & b))		(a)		   [2b] -> (a & b)		(a)
(a b)			(c d)		   [3a] -> returns  ((a b) && (c d))
(a)			(c)		   [3b] -> returns  (a & b)|#
(TRACE-LISP
 (DEFINE AND-APPEND (XS0 AND-SYMBOL YS0)
  (trace-defun 'AND-APPEND (XS0 AND-SYMBOL YS0)
   (RET
    (CLET ((XS (REMOVE-DUP-ATOMIC-INSTANCES XS0)) (YS (REMOVE-DUP-ATOMIC-INSTANCES YS0)))
     (COND ((CL-EQUAL XS YS) XS)
      ((AND (SINGLETONP XS)  (AND-LISTP (FIRST XS) AND-SYMBOL)  (SINGLETONP YS) (AND-LISTP (FIRST YS) AND-SYMBOL))
       (LIST (AND-APPEND2 (FIRST XS) AND-SYMBOL (FIRST YS))))
      ((AND (SINGLETONP XS)  (AND-LISTP (FIRST XS) AND-SYMBOL))  (LIST (AND-APPEND2 (FIRST XS) AND-SYMBOL (DO-SETIFY YS AND-SYMBOL))))
      ((AND (SINGLETONP YS)  (AND-LISTP (FIRST YS) AND-SYMBOL))  (LIST (AND-APPEND2 (DO-SETIFY XS AND-SYMBOL) AND-SYMBOL (FIRST YS))))
      ((SET-UNIFICATION-OPERATOR AND-SYMBOL)  (LIST (LIST XS AND-SYMBOL YS)))
      ((VAL-UNIFICATION-OPERATOR AND-SYMBOL)  (LIST (LIST (FIRST XS) AND-SYMBOL (FIRST YS))))
      (T (REPORT-ERROR 'USER-ERROR "Unknown case for (ands-append ~a ~a ~a)~%!" XS AND-SYMBOL YS))))))))
(TRACE-LISP
 (DEFINE DO-SETIFY (SET AND-SYMBOL)
  (trace-defun 'DO-SETIFY (SET AND-SYMBOL) (RET (COND ((SET-UNIFICATION-OPERATOR AND-SYMBOL) (LIST SET)) (T SET))))))
;;;; Here x and y are lists of conjoined values. Note how non-and-lists have been ()'ed
;;;; (and-append2 '(a)   '& '(a & b))
;;;; (and-append2 '((a)) '&& '((a) && (b)))
;;;; eg. (and-(a & b),  or (a)  but not  a
(TRACE-LISP
 (DEFINE AND-APPEND2 (X AND-SYMBOL Y)
  (trace-defun 'AND-APPEND2 (X AND-SYMBOL Y)
   (RET
    (COND ((NULL X) Y) 
     ((AND (CNOT (SINGLETONP X)) (CNOT (AND (> (LENGTH X) 2) (EQ (SECOND X) AND-SYMBOL))))
      (REPORT-ERROR 'PROGRAM-ERROR "and-append2 given a badly formed list (not an and-list!)~%Doing (and-append2 ~a ~a ~a)~%" X AND-SYMBOL Y))
     ((AND-MEMBER (FIRST X) Y AND-SYMBOL) (AND-APPEND2 (REST (REST X)) AND-SYMBOL Y))
     (T (CONS (FIRST X) (CONS AND-SYMBOL (AND-APPEND2 (REST (REST X)) AND-SYMBOL Y)))))))))
;; (and-listp '(a & b) '&)  -->   t
;; (and-listp '((a) && (b)) '&&)  -->   t
(TRACE-LISP
 (DEFINE AND-LISTP (LIST AND-SYMBOL)
  (trace-defun 'AND-LISTP (LIST AND-SYMBOL) (RET (AND (LISTP LIST) (> (LENGTH LIST) 2) (EQ (SECOND LIST) AND-SYMBOL))))))
(TRACE-LISP
 (DEFINE AND-MEMBER (EL LIST AND-SYMBOL)
  (trace-defun 'AND-MEMBER (EL LIST AND-SYMBOL)
   (RET
    (COND ((CL-EQUAL EL (FIRST LIST))) ((SINGLETONP LIST) NIL)
     ((AND (> (LENGTH LIST) 2) (EQ (SECOND LIST) AND-SYMBOL)) (AND-MEMBER EL (REST (REST LIST)) AND-SYMBOL))
     (T (REPORT-ERROR 'PROGRAM-ERROR "and-member given a badly formed list (not an and-list!)~%Doing (and-member ~a ~a ~a)~%" EL LIST AND-SYMBOL)))))))
;;;; ======================================================================
;;;;		UNIFYING SITUATIONS
;;;; ======================================================================
#|An extra step is required besides unifying the frames themselves, namely unifying
their situational contents.|#
;;;; source and target are instances
(TRACE-LISP
 (DEFINE COPY-SITUATION-CONTENTS (SOURCE-SITN TARGET-SITN)
  (trace-defun 'COPY-SITUATION-CONTENTS (SOURCE-SITN TARGET-SITN)
   (RET
    (COND ((EQ SOURCE-SITN TARGET-SITN)) ((CNOT (CL-ISA SOURCE-SITN '|Situation|)))
     ((CNOT (KB-OBJECTP TARGET-SITN))
      (REPORT-ERROR 'USER-ERROR "Can't copy ~a's contents to target situation ~a, as ~a isn't a KB object!~%" SOURCE-SITN TARGET-SITN TARGET-SITN))
     (T
      (CLET
       ((CURR-SITUATION (CURR-SITUATION))
        (OBJECTS-TO-COPY
         (REMOVE-IF-NOT #'(LAMBDA (INSTANCE) (trace-defun '#:G15737 (INSTANCE) (RET (HAS-SITUATION-SPECIFIC-INFO INSTANCE SOURCE-SITN))))
          (GET-ALL-CONCEPTS))))
        (IN-SITUATION TARGET-SITN) 
       (MAPC
        #'(LAMBDA (INSTANCE)
           (trace-defun '#:G15738 (INSTANCE)
            (RET
             (TRACE-PROGN (MERGE-SLOTSVALS INSTANCE SOURCE-SITN TARGET-SITN :FACET 'OWN-PROPERTIES)
              (MERGE-SLOTSVALS INSTANCE SOURCE-SITN TARGET-SITN :FACET 'MEMBER-PROPERTIES)))))
        OBJECTS-TO-COPY)
       (MAPC #'UN-DONE OBJECTS-TO-COPY)  (MAPC #'CLASSIFY OBJECTS-TO-COPY)  (IN-SITUATION CURR-SITUATION))))))))
;; Change back...
;;;; ----------
;;;; (No result passed back)
;;;; [1] The inverses will be installed anyway when the other frames in the situation are merged.
;;;; [2] here we just merge the *structures*, which is why i1 and i2 are nil
(TRACE-LISP
 (DEFINE MERGE-SLOTSVALS (INSTANCE SOURCE-SITN TARGET-SITN &REST LKEYS)
  (trace-defun 'MERGE-SLOTSVALS (INSTANCE SOURCE-SITN TARGET-SITN LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP FACET) (init-keyval FACET 'OWN-PROPERTIES)
     (CLET
      ((SOURCE-SVS (GET-SLOTSVALS INSTANCE :FACET FACET :SITUATION SOURCE-SITN))
       (TARGET-SVS (GET-SLOTSVALS INSTANCE :FACET FACET :SITUATION TARGET-SITN)))
      (COND
       (SOURCE-SVS
        (MULTIPLE-VALUE-BIND (SUCCESSP UNIFIED-SVS) 
         (LAZY-UNIFY-SLOTSVALS NIL NIL SOURCE-SVS TARGET-SVS  :CS1 (IMMEDIATE-CLASSES INSTANCE :SITUATION SOURCE-SITN) :CS2
          (IMMEDIATE-CLASSES INSTANCE :SITUATION TARGET-SITN) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :CHECK-CONSTRAINTSP NIL)
         (COND
          (SUCCESSP
           (COND
            ((CNOT (CL-EQUAL UNIFIED-SVS TARGET-SVS)) (PUT-SLOTSVALS INSTANCE UNIFIED-SVS :FACET FACET :SITUATION TARGET-SITN :INSTALL-INVERSESP NIL))))
          
          (T
           (REPORT-ERROR 'USER-ERROR "Failed to unify ~a's slot-values of ~a in ~a~%with its slot-values ~a in ~a!~%Dropping these values...~%" INSTANCE
            SOURCE-SVS SOURCE-SITN TARGET-SVS TARGET-SITN))))))))))))
;;;; ======================================================================
;;;;		UNIFIABLE-WITH-EXPR
;;;; ======================================================================
;;;; 5.3.00 remove this, replace with &? as it ignores constraints attached to class.
#|unifiable-with-existential-expr: This is like the &? operator, except its second argument is
an expression rather than an instance. It uses the same comparison machinery 
(lazy-unify-slotsvals) as &?, except enters it a bit lower down (lazy-unify-slotsvals,
rather than try-lazy-unify), and without actually creating a temporary Skolem 
instance denoting expr.

Unifiable - eventually should merge with subsumes.
EXPR = necessarily '(a Class with slotsvals)), for now
[1] Technically, we unify in *every* situation, but of course the existential-expr is invisible in other situations*** so we'd just
    be unifying instance with nil for all other situations = redundant.
    9/8/00 *** - no! It's also visible in all subsituations of the current situation and so should check them too!
[2] Merging an instance with a structure, so i2 = NIL
[3] for multiple classes in expr, e.g., (a Car with (instance-of (Expensive-Thing)) (...)):
		classes -> (Car Expensive-Thing)
		slotsvals ->  ((instance-of (Car Expensive-Thing)) ... 	, for constraint-checking by lazy-unify-slotsvals
[4] Optimization: (_Agent3 & (a Agent)) shouldn't test all the constraints on _Agent3's slots!
[5] Let's *try* and allow people to put expressions on instance-of slots|#
;;(defun unifiable-with-existential-expr (instance expr &key classes-subsumep)
;;  (cond (*backtrack-after-testing-unification*
;;	 (setq *internal-logging* t)
;;	 (let ( (checkpoint-id (gensym)) )
;;	   (set-checkpoint checkpoint-id)
;;	   (prog1
;;	       (unifiable-with-existential-expr0 instance expr :classes-subsumep classes-subsumep)
;;	     (undo checkpoint-id)		; undo, whatever
;;	     (setq *internal-logging* nil))))
;;	(t (unifiable-with-existential-expr0 instance expr :classes-subsumep classes-subsumep))))
(TRACE-LISP
 (DEFINE UNIFIABLE-WITH-EXISTENTIAL-EXPR (INSTANCE EXPR &REST LKEYS)
  (trace-defun 'UNIFIABLE-WITH-EXISTENTIAL-EXPR (INSTANCE EXPR LKEYS)
   (RET (CLET (CLASSES-SUBSUMEP) (UNIFIABLE-WITH-EXISTENTIAL-EXPR0 INSTANCE EXPR :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))))))
(TRACE-LISP
 (DEFINE UNIFIABLE-WITH-EXISTENTIAL-EXPR0 (INSTANCE EXPR &REST LKEYS)
  (trace-defun 'UNIFIABLE-WITH-EXISTENTIAL-EXPR0 (INSTANCE EXPR LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP)
     (COND ((EXPLAINED-BY INSTANCE EXPR) (KM-TRACE 'COMMENT "[ ~a was originally derived from ~a, so must unify with it! ]" INSTANCE EXPR) INSTANCE)
      (T
       (CLET ((CLASS+SLOTSVALS (BIND-SELF (BREAKUP-EXISTENTIAL-EXPR EXPR) INSTANCE))) 
        (COND
         (CLASS+SLOTSVALS 
          (CLET
           ((CLASS (FIRST CLASS+SLOTSVALS))  (SLOTSVALS0 (SECOND CLASS+SLOTSVALS))
            (CLASSES (CL-REMOVE-DUPLICATES (CONS CLASS (VALS-IN (ASSOC '|instance-of| SLOTSVALS0))))) 
            (SLOTSVALS (UPDATE-ASSOC-LIST SLOTSVALS0 `(|instance-of| ,CLASSES))))
            (ARE-SLOTSVALS SLOTSVALS) 
           (COND ((AND (NULL SLOTSVALS) (CL-ISA INSTANCE CLASS)) INSTANCE) 
            ((AND  (COMPATIBLE-CLASSES :INSTANCE1 INSTANCE :CLASSES2 (REMOVE-CONSTRAINTS CLASSES)  :CLASSES-SUBSUMEP CLASSES-SUBSUMEP)
              (COND
               ((AM-IN-LOCAL-SITUATION)
                (CLET
                 (  (GLOBAL (REMOVE-IF #'(LAMBDA (SLOTVALS) (trace-defun '#:G15739 (SLOTVALS) (RET (FLUENTP (SLOT-IN SLOTVALS))))) SLOTSVALS))
                  (CURR-SITUATION (CURR-SITUATION)))
                 (AND
                  (LAZY-UNIFY-SLOTSVALS INSTANCE NIL (GET-SLOTSVALS INSTANCE) SLOTSVALS   :CS2 (REMOVE-IF-NOT #'KB-OBJECTP CLASSES)  :CLASSES-SUBSUMEP
                   CLASSES-SUBSUMEP)
                  (PROG2 (CHANGE-TO-SITUATION *GLOBAL-SITUATION*)
                   (LAZY-UNIFY-SLOTSVALS INSTANCE NIL (GET-SLOTSVALS INSTANCE) GLOBAL  :CS2 (REMOVE-IF-NOT #'KB-OBJECTP CLASSES)  :CLASSES-SUBSUMEP
                    CLASSES-SUBSUMEP)
                   (CHANGE-TO-SITUATION CURR-SITUATION)))))
               (T
                (LAZY-UNIFY-SLOTSVALS INSTANCE NIL (GET-SLOTSVALS INSTANCE) SLOTSVALS  :CS2 (REMOVE-IF-NOT #'KB-OBJECTP CLASSES)  :CLASSES-SUBSUMEP
                 CLASSES-SUBSUMEP))))))))
         
         (T
          (REPORT-ERROR 'PROGRAM-ERROR "unifiable-with-existential-expr() in lazy-unify.lisp wasn't given an existential expr!~%   (was ~a instead)~%"
           EXPR)))))))))))
;;;; This unifies instance with an existential expr *without* creating then subsequently deleting a Skolem 
;;;; constant for that existential expr. It's rather a lot of code just to save extra instance creation,
;;;; but useful for must-be-a constraints. 
;;;; IF successful returns INSTANCE, if not returns NIL.
;;;; [1] creation routine is largely copied from create-named-instance in frame-io.lisp
;;;; [2] this subsumption test is new, from remove-subsuming-exprs. It avoids creating
;;;;     unnecessary structures e.g. if (Pete has (owns (_Car0))) then:
;;;;		(unify-with-existential-expr Pete ';$(a Person with (owns ((a Car)))))
;;;;	would otherwise have resulted in (Pete has (owns (((_Car0) && ((a Car)))))).
;;;; [2b]    PC  - beta48 - so why is that a problem? You just defer resolving the && until later!
;;;; [3] Merging an instance with a structure, so i2 = NIL
;;;; NOTE: This unification is *only* done in the local situation.
;;;; [4] Optimization: (_Agent3 & (a Agent)) shouldn't test all the constraints on _Agent3's slots!
;;;; [5] Let's *try* and allow people to put expressions on instance-of slots
(TRACE-LISP
 (DEFINE UNIFY-WITH-EXISTENTIAL-EXPR (INSTANCE EXPR &REST LKEYS)
  (trace-defun 'UNIFY-WITH-EXISTENTIAL-EXPR (INSTANCE EXPR LKEYS)
   (RET
    (CLET (EAGERLYP CLASSES-SUBSUMEP FAIL-MODE TARGET CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T) (init-keyval FAIL-MODE 'FAIL)
     (COND
      ((EXPLAINED-BY INSTANCE EXPR TARGET) (KM-TRACE 'COMMENT "[ ~a was originally derived from ~a, so must unify with it! ]" INSTANCE EXPR) INSTANCE)
      ((AND (FLUENT-INSTANCEP INSTANCE)  (NEQ (FIRST EXPR) '|some|))
       (CLET ((VAL (KM-UNIQUE0 EXPR :TARGET TARGET)))
        (COND (EAGERLYP (KM-UNIQUE0 `(,INSTANCE &! ,VAL) :FAIL-MODE FAIL-MODE)) (T (KM-UNIQUE0 `(,INSTANCE & ,VAL) :FAIL-MODE FAIL-MODE)))))
      
      (T
       (CLET ((CLASS+SLOTSVALS (BIND-SELF (BREAKUP-EXISTENTIAL-EXPR EXPR) INSTANCE))) 
        (COND
         (CLASS+SLOTSVALS 
          (CLET
           ((CLASS (FIRST CLASS+SLOTSVALS))  (SLOTSVALS0 (SECOND CLASS+SLOTSVALS)) (_DUMMY (ARE-SLOTSVALS SLOTSVALS0)) 
            (UNIFICATION
             (COND ((AND (NULL SLOTSVALS0) (CL-ISA INSTANCE CLASS)) INSTANCE) 
              ((COMPATIBLE-CLASSES :INSTANCE1 INSTANCE :CLASSES2 (LIST CLASS)  :CLASSES-SUBSUMEP CLASSES-SUBSUMEP)
               (COND ((CNOT (KB-OBJECTP INSTANCE)) INSTANCE) 
                (T
                 (CLET ((EXTRA-CLASSES (VALS-IN (ASSOC '|instance-of| SLOTSVALS0)))) 
                  (OR
                   (UNIFY-WITH-SLOTSVALS2 INSTANCE (CONS CLASS EXTRA-CLASSES) SLOTSVALS0 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP :EAGERLYP EAGERLYP
                    :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)
                   (COND ((EQ FAIL-MODE 'ERROR) (REPORT-ERROR 'USER-ERROR "Unification (~a & ~a) failed!~%" INSTANCE EXPR) NIL))))))))))
           (DECLARE (IGNORE _DUMMY))
           (COND
            (UNIFICATION (COND (TARGET (RECORD-EXPLANATION-FOR TARGET INSTANCE EXPR))) (CACHE-EXPLANATION-FOR INSTANCE EXPR) 
             (CSETQ *STATISTICS-UNIFICATIONS* (1+ *STATISTICS-UNIFICATIONS*)) UNIFICATION)
            ((EQ FAIL-MODE 'ERROR)
             (COND
              (CLASSES-SUBSUMEP
               (REPORT-ERROR 'USER-ERROR "Unification (~a &+ ~a) failed! (Classes of one do not subsume classes of the other)~%" INSTANCE EXPR))
              (T (REPORT-ERROR 'USER-ERROR "Unification (~a & ~a) failed! (Classes are incompatible)~%" INSTANCE EXPR)))))))
         (T
          (REPORT-ERROR 'PROGRAM-ERROR "unify-with-existential-expr() in lazy-unify.lisp wasn't given an existential expr!~%   (was ~a instead)~%"
           EXPR)))))))))))
(TRACE-LISP
 (DEFINE UNIFY-WITH-SLOTSVALS2 (INSTANCE CLASSES SLOTSVALS00 &REST LKEYS)
  (trace-defun 'UNIFY-WITH-SLOTSVALS2 (INSTANCE CLASSES SLOTSVALS00 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP EAGERLYP CHECK-CONSTRAINTSP) (init-keyval CHECK-CONSTRAINTSP T)
     (CLET ((SLOTSVALS (CONVERT-COMMENTS-TO-INTERNAL-FORM SLOTSVALS00))) 
      (COND
       ((AM-IN-LOCAL-SITUATION)
        (CLET
         ((LOCAL0 (REMOVE-IF-NOT #'(LAMBDA (SLOTVALS) (trace-defun '#:G15740 (SLOTVALS) (RET (FLUENTP (SLOT-IN SLOTVALS))))) SLOTSVALS))
          (GLOBAL0 (REMOVE-IF #'(LAMBDA (SLOTVALS) (trace-defun '#:G15741 (SLOTVALS) (RET (FLUENTP (SLOT-IN SLOTVALS))))) SLOTSVALS))
          (LOCAL (COND ((FLUENTP '|instance-of|) (UPDATE-ASSOC-LIST LOCAL0 `(|instance-of| ,CLASSES))) (T LOCAL0)))
          (GLOBAL (COND ((CNOT (FLUENTP '|instance-of|)) (UPDATE-ASSOC-LIST GLOBAL0 `(|instance-of| ,CLASSES))) (T GLOBAL0)))
          (CURR-SITUATION (CURR-SITUATION)))
         (MULTIPLE-VALUE-BIND (SUCCESSP1 UNIFIED-SVS1)
          (LAZY-UNIFY-SLOTSVALS INSTANCE NIL (GET-SLOTSVALS INSTANCE) LOCAL  :CS2 (REMOVE-IF-NOT #'KB-OBJECTP CLASSES)  :CLASSES-SUBSUMEP
           CLASSES-SUBSUMEP  :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)
          (COND
           (SUCCESSP1 (CHANGE-TO-SITUATION *GLOBAL-SITUATION*)
            (MULTIPLE-VALUE-BIND (SUCCESSP2 UNIFIED-SVS2)
             (LAZY-UNIFY-SLOTSVALS INSTANCE NIL (GET-SLOTSVALS INSTANCE) GLOBAL  :CS2 (REMOVE-IF-NOT #'KB-OBJECTP CLASSES)  :CLASSES-SUBSUMEP
              CLASSES-SUBSUMEP  :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)
             (COND
              ((AND SUCCESSP1 SUCCESSP2)
               (CLET ((LOCAL-CHANGE-MADE NIL) (GLOBAL-CHANGE-MADE NIL))
                (COND
                 ((CNOT (CL-EQUAL UNIFIED-SVS2 (GET-SLOTSVALS INSTANCE)))  (COND ((CNOT GLOBAL-CHANGE-MADE)   (CSETQ GLOBAL-CHANGE-MADE T))) 
                  (MAPC #'(LAMBDA (SLOTVALS) (trace-defun '#:G15742 (SLOTVALS) (RET (PUT-VALS INSTANCE (SLOT-IN SLOTVALS) (VALS-IN SLOTVALS)))))
                   UNIFIED-SVS2)
                  
                  (COND
                   ((SOME #'(LAMBDA (CLASS) (trace-defun '#:G15743 (CLASS) (RET (IS-SUBCLASS-OF CLASS '|Situation|)))) CLASSES)
                    (MAKE-ASSERTIONS INSTANCE UNIFIED-SVS2)))))
                (CHANGE-TO-SITUATION CURR-SITUATION)
                (COND
                 ((CNOT (CL-EQUAL UNIFIED-SVS1 (GET-SLOTSVALS INSTANCE)))  (COND ((CNOT LOCAL-CHANGE-MADE)   (CSETQ LOCAL-CHANGE-MADE T))) 
                  (MAPC #'(LAMBDA (SLOTVALS) (trace-defun '#:G15744 (SLOTVALS) (RET (PUT-VALS INSTANCE (SLOT-IN SLOTVALS) (VALS-IN SLOTVALS)))))
                   UNIFIED-SVS1)
                  
                  (COND
                   ((SOME #'(LAMBDA (CLASS) (trace-defun '#:G15745 (CLASS) (RET (IS-SUBCLASS-OF CLASS '|Situation|)))) CLASSES)
                    (MAKE-ASSERTIONS INSTANCE UNIFIED-SVS1)))))
                    
                (COND
                 (LOCAL-CHANGE-MADE
                  (MAPC #'(LAMBDA (SLOT) (trace-defun '#:G15746 (SLOT) (RET (UN-DONE INSTANCE :SLOT SLOT :SITUATION (CURR-SITUATION)))))
                   (MAPCAR #'SLOT-IN UNIFIED-SVS1))))
                (COND
                 (GLOBAL-CHANGE-MADE
                  (MAPC #'(LAMBDA (SLOT) (trace-defun '#:G15747 (SLOT) (RET (UN-DONE INSTANCE :SLOT SLOT :SITUATION *GLOBAL-SITUATION*))))
                   (MAPCAR #'SLOT-IN UNIFIED-SVS2))))
                (COND ((OR LOCAL-CHANGE-MADE GLOBAL-CHANGE-MADE) (CLASSIFY INSTANCE))))
                   INSTANCE)
              (T (CHANGE-TO-SITUATION CURR-SITUATION) NIL))))))))
       
       (T
        (MULTIPLE-VALUE-BIND (SUCCESSP UNIFIED-SVS)
         (LAZY-UNIFY-SLOTSVALS INSTANCE NIL (GET-SLOTSVALS INSTANCE) (UPDATE-ASSOC-LIST SLOTSVALS `(|instance-of| ,CLASSES))  :CS2
          (REMOVE-IF-NOT #'KB-OBJECTP CLASSES)  :CLASSES-SUBSUMEP CLASSES-SUBSUMEP  :EAGERLYP EAGERLYP :CHECK-CONSTRAINTSP CHECK-CONSTRAINTSP)
         (COND
          (SUCCESSP
           (CLET ((CHANGE-MADE NIL))
            (COND
             ((CNOT (CL-EQUAL UNIFIED-SVS (GET-SLOTSVALS INSTANCE)))
              (MAPC
               #'(LAMBDA (SLOTVALS)
                  (trace-defun '#:G15748 (SLOTVALS)
                   (RET (TRACE-PROGN (COND ((CNOT CHANGE-MADE)   (CSETQ CHANGE-MADE T)))  (PUT-VALS INSTANCE (SLOT-IN SLOTVALS) (VALS-IN SLOTVALS))))))
               UNIFIED-SVS)
              
              (COND
               ((SOME #'(LAMBDA (CLASS) (trace-defun '#:G15749 (CLASS) (RET (IS-SUBCLASS-OF CLASS '|Situation|)))) CLASSES)
                (MAKE-ASSERTIONS INSTANCE UNIFIED-SVS)))
                 
              (COND
               (CHANGE-MADE
                (MAPC #'(LAMBDA (SLOT) (trace-defun '#:G15750 (SLOT) (RET (UN-DONE INSTANCE :SLOT SLOT :SITUATION (CURR-SITUATION)))))
                 (MAPCAR #'SLOT-IN UNIFIED-SVS))
                (CLASSIFY INSTANCE))))))
           INSTANCE)))))))))))
;;;; Compatible: Classes mustn't be disjoint, and may have a subsumption requirement also.
;;;; IN ADDITION: As we also allow negated class values, we must also check consistency here, 
;;;; 	e.g. (instance-of (Car)) and (instance-of ((<> Car))) are incompatible.
;;;; 	Also, because instance-of is a *built-in-remove-subsumers-slots*, (instance-of (Car)) and (instance-of ((<> Vehicle))) are incompatible,
;;;; 			although (instance-of (Vehicle)) and (instance-of ((<> Car))) are not.
;;;; 	[This handling of types as values needs better facilities in KM]
;;;; HOWEVER: We **DEFER** this checking instead to check-slotvals-constraints instead, as this kind of check is already performed for other slots.
;;;; class constraints are simply ignored here as if they weren't there.
;;;; Note: The subsumption requirement isn't that the instance is subsumed by a class,
;;;;	  but that one set of classes is subsumed by another.
;;;; [2] This may miss some constraints if instance-of-is-fluent is true.
;;;; [3] New: classes-subsumep = 'exact-match, 't or nil. exact-match checks for identity.
(TRACE-LISP
 (DEFINE COMPATIBLE-CLASSES (&REST LKEYS)
  (trace-defun 'COMPATIBLE-CLASSES (LKEYS)
   (RET
    (CLET (INSTANCE1 INSTANCE2 CLASSES1 CLASSES2 CLASSES-SUBSUMEP)
     (CLET
      ((IMMEDIATE-CLASSES1
        (OR CLASSES1 (AND INSTANCE1 (IMMEDIATE-CLASSES INSTANCE1))
         (REPORT-ERROR 'PROGRAM-ERROR "compatible-classes: missing instance/classes for instance1!~%")))
       (IMMEDIATE-CLASSES2
        (OR CLASSES2 (AND INSTANCE2 (IMMEDIATE-CLASSES INSTANCE2))
         (REPORT-ERROR 'PROGRAM-ERROR "compatible-classes: missing instance/classes for instance2!~%"))))
      (COND ((EQ CLASSES-SUBSUMEP 'EXACT-MATCH)  (SET-EQUAL IMMEDIATE-CLASSES1 IMMEDIATE-CLASSES2))
       ((OR CLASSES-SUBSUMEP (CL-INTERSECTION IMMEDIATE-CLASSES1 '(|Sequence| |Pair| |Triple| |Bag|)) 
         (CL-INTERSECTION IMMEDIATE-CLASSES2 '(|Sequence| |Pair| |Triple| |Bag|)))
        (OR (CLASSES-SUBSUME-CLASSES IMMEDIATE-CLASSES1 IMMEDIATE-CLASSES2) (CLASSES-SUBSUME-CLASSES IMMEDIATE-CLASSES2 IMMEDIATE-CLASSES1)))
       (T (CNOT (DISJOINT-CLASS-SETS IMMEDIATE-CLASSES1 IMMEDIATE-CLASSES2 :INSTANCE1 INSTANCE1 :INSTANCE2 INSTANCE2))))))))))
;;;; ======================================================================
;;;;    HANDLING OF PARTITIONS - only used by the above function compatible-classes
;;;; ======================================================================
;;;; [1] all-superclasses0 is like all-superclasses, except it INCLUDES class, and MAY NOT 
;;;;     include Thing unless Thing is explicitly declared as a superclass. This is exactly 
;;;;     what we want here!
;;;; Returns NIL if the class sets are NOT disjoint (i.e. can be combined)
(TRACE-LISP
 (DEFINE DISJOINT-CLASS-SETS (IMMEDIATE-CLASSES1 IMMEDIATE-CLASSES2 &REST LKEYS)
  (trace-defun 'DISJOINT-CLASS-SETS (IMMEDIATE-CLASSES1 IMMEDIATE-CLASSES2 LKEYS)
   (RET
    (CLET (INSTANCE1 INSTANCE2)
     (DISJOINT-CLASS-SETS0 (CL-REMOVE-DUPLICATES (MY-MAPCAN #'ALL-SUPERCLASSES0 (CL-REMOVE '|Thing| IMMEDIATE-CLASSES1))) 
      (CL-REMOVE-DUPLICATES (MY-MAPCAN #'ALL-SUPERCLASSES0 (CL-REMOVE '|Thing| IMMEDIATE-CLASSES2)))  :INSTANCE1
      (OR INSTANCE1 `(|a| ,(VALS-TO-VAL IMMEDIATE-CLASSES1)))  :INSTANCE2 (OR INSTANCE2 `(|a| ,(VALS-TO-VAL IMMEDIATE-CLASSES2)))))))))
;; purely for tracing output
#|(disjoint-class-sets0 '(Na Substance) '(Zn Substance))
    Na -> Partition1, Zn -> Partition1 so there's a clash
But Substance -> Partition1, Substance -> Partition1 no clash
So we just need the UNIQUE elements of classes1, and see their partitions
   and the UNIQUE elements of classes2, and see their partitions
   and check for no overlap.
   Proof: UNIQUE means they are DIFFERENT values. And so they can't both belong to the same partition.|#
(TRACE-LISP
 (DEFINE DISJOINT-CLASS-SETS0 (CLASSES1 CLASSES2 &REST LKEYS)
  (trace-defun 'DISJOINT-CLASS-SETS0 (CLASSES1 CLASSES2 LKEYS)
   (RET
    (CLET (INSTANCE1 INSTANCE2) (DECLARE (IGNORE INSTANCE1 INSTANCE2))
     (AND (CNOT (CL-EQUAL CLASSES1 CLASSES2)) (CNOT (CL-SUBSETP CLASSES1 CLASSES2)) (CNOT (CL-SUBSETP CLASSES2 CLASSES1)) 
      (CLET
       ((PARTITIONS1
         (MY-MAPCAN #'(LAMBDA (C1) (trace-defun '#:G15751 (C1) (RET (GET-VALS C1 '|member-of|)))) (SET-DIFFERENCE CLASSES1 CLASSES2)))
        (PARTITIONS2
         (MY-MAPCAN #'(LAMBDA (C2) (trace-defun '#:G15752 (C2) (RET (GET-VALS C2 '|member-of|)))) (SET-DIFFERENCE CLASSES2 CLASSES1))))
       (CL-INTERSECTION PARTITIONS1 PARTITIONS2))))))))
#|(some X'(lambda (partition)
		 (let* ( (partition-members (get-vals partition 'X$members :situation *global-situation*)) 
			 (classes1-in-partition (intersection classes1 partition-members)) )

;;; Exhaustive partition check...
	       SEE BELOW
;;; Disjoint classes check
		   (cond ((null classes1-in-partition) nil)						; Non-mutually exhaustive partition - null is ok
			 ((not (singletonp classes1-in-partition))
			  (report-error 'user-error "An object ~a was encountered which was in mutually exclusive classes ~a!~%   [Partition was: (~a has (members ~a))]~%"
					instance1 classes1-in-partition partition partition-members))
			 ;;; We could also check partition2 like this, but don't bother
			 (t (intersection classes2 (remove (first classes1-in-partition) partition-members))))))   ; = classes1 & classes2 are
	     (all-instances 'X$Partition))))									   ;       disjoint|#
#|EXHAUSTIVE PARTITIONS -- needs some more work: They are only applicable if the instance is a member of the partition's PARENT, an as-yet
undefined slot.
	e.g. (a Exhaustive-Partition with (parent (Tangible)) (members (Solid Liquid Gas)))
 So it's OK if a Dream isn't in any of this partition's members, but not for _Dog23.  But it IS okay if _Tangible23 isn't in any members
 (ie. we haven't decided on which member it is in). But then, which instances DO we check for compulsory class membership for??

;;; Exhaustive partition check...
		   (cond ((isa partition 'X$Exhaustive-Partition)
			  (cond ((null classes1-in-partition)
				 (report-error 'user-error "Instance ~a must be in exactly one class in the below exhaustive partition!~%    (~a has (members ~a))~%    [~a is currently in classes ~a]~%" instance1 partition partition-members instance1 classes1))
				((null (intersection classes2 partition-members))
				 (report-error 'user-error "Instance ~a must be in exactly one class in the below exhaustive partition!~%    (~a has (members ~a))~%    [~a is currently in classes ~a]~%" instance2 partition partition-members instance2 classes2)))))|#
;;;; FILE:  constraints.lisp
;;;; File: constraints.lisp
;;;; Author: Peter Clark
;;;; Purpose: Constraint checking/enforcement mechanism for KM
#| ======================================================================
		  CONSTRAINT CHECKING / ENFORCEMENT
   ======================================================================

filter-using-constraints: remove vals which fail a constraint. Violations aren't an error. 
	Used solely to remove inconsistent projected vals in km-slotvals-from-kb.

(are-consistent-with-constraints vals constraints slot)		- lazy-unify
(satisfies-constraints vals constraints slot)			- subsumes
	returns t/nil if vals [can] satisfy constraints or not. Failure is not an error.
	Used by lazy-unify and subsumes, to check for consistency/satisfaction. No side effects.

enforce-constraints: Apply the constraints. Failure IS an error and will be reported.
	Used to process the values collected in km-slotvals-from-kb.|#
;;;; ======================================================================
(TRACE-LISP
 (DEFINE NOTE-ARE-CONSTRAINTS NIL (trace-defun 'NOTE-ARE-CONSTRAINTS NIL (RET (OR *ARE-SOME-CONSTRAINTS* (KM-SETQ '*ARE-SOME-CONSTRAINTS* T))))))
;;;; This will *REMOVE VIOLATORS* (but not necessarily fail) if a constraint is violated.
;;;; It should be used as a filter, not as a test. For a test, use
;;;; instead. It *DOESN'T* report violations.
;;;; This has no side-effects. Returns a reduced list of values.
;;;; It's solely used for filtering out projected values which conflict with current constraints.
;;;; THIS ASSUME VALS IS A LIST OF ATOMS, IE. ANY KM EVALUATION HAS ALREADY BEEN PERFORMED.
(TRACE-LISP
 (DEFINE FILTER-USING-CONSTRAINTS (VALS CONSTRAINTS &OPTIONAL SLOT)
  (trace-defun 'FILTER-USING-CONSTRAINTS (VALS CONSTRAINTS SLOT)
   (RET
    (COND ((NULL CONSTRAINTS) VALS)
     ((AND (TRACEP) (CNOT (TRACECONSTRAINTSP))) (PROG2 (SUSPEND-TRACE) (FILTER-USING-CONSTRAINTS0 VALS CONSTRAINTS SLOT) (UNSUSPEND-TRACE)))
     (T (KM-TRACE 'COMMENT "Testing constraints ~a" CONSTRAINTS) (FILTER-USING-CONSTRAINTS0 VALS CONSTRAINTS SLOT)))))))
(TRACE-LISP
 (DEFINE FILTER-USING-CONSTRAINTS0 (VALS CONSTRAINTS SLOT)
  (trace-defun 'FILTER-USING-CONSTRAINTS0 (VALS CONSTRAINTS SLOT)
   (RET
    (REMOVE-IF-NOT
     #'(LAMBDA (VAL)
        (trace-defun '#:G15753 (VAL) (RET (TEST-VAL-CONSTRAINTS VAL (DEREFERENCE CONSTRAINTS) (SPECIAL-SLOT-TYPE SLOT) :MODE 'CONSISTENT))))
     VALS)))))
;;;; ======================================================================
;;;;		ARE-CONSISTENT-WITH-CONSTRAINTS
;;;; ======================================================================
#|This will *FAIL* if a constraint is violated. Returns T/NIL.
8/16/00 - Extended to to handle special constraint handling for slots whose values are classes.
	(are-consistent-with-constraints 'X$(Car) 'X$((<> Vehicle)) 'X$instance-of)
   should FAIL, as X$instance-of is a remove-subsumers-slotp, but
	(are-consistent-with-constraints 'X$(Vehicle) 'X$((<> Car)) 'X$instance-of)
   should SUCCEED. Similarly, 
	(are-consistent-with-constraints 'X$(Vehicle) 'X$((<> Car)) 'X$subclasses
   should FAIL, as X$subclasses is a remove-subsumees-slotp, but
	(are-consistent-with-constraints 'X$(Car) 'X$((<> Vehicle)) 'X$subclasses)
   should SUCCEED.|#
(TRACE-LISP
 (DEFINE ARE-CONSISTENT-WITH-CONSTRAINTS (VALS0 CONSTRAINTS0 SLOT)
  (trace-defun 'ARE-CONSISTENT-WITH-CONSTRAINTS (VALS0 CONSTRAINTS0 SLOT) (RET (TEST-CONSTRAINTS VALS0 CONSTRAINTS0 SLOT :MODE 'CONSISTENT)))))
(TRACE-LISP
 (DEFINE SATISFIES-CONSTRAINTS (VALS0 CONSTRAINTS0 SLOT)
  (trace-defun 'SATISFIES-CONSTRAINTS (VALS0 CONSTRAINTS0 SLOT) (RET (TEST-CONSTRAINTS VALS0 CONSTRAINTS0 SLOT :MODE 'SATISFIES)))))
;;;; ----------------------------------------
(TRACE-LISP
 (DEFINE TEST-CONSTRAINTS (VALS0 CONSTRAINTS0 SLOT &REST LKEYS)
  (trace-defun 'TEST-CONSTRAINTS (VALS0 CONSTRAINTS0 SLOT LKEYS)
   (RET
    (CLET (MODE) 
     (COND ((NULL CONSTRAINTS0) T)
      (T
       (CLET ((VALS (REMOVE-DUP-INSTANCES VALS0))  (CONSTRAINTS (DEREFERENCE CONSTRAINTS0)) (SPECIAL-SLOT-TYPE (SPECIAL-SLOT-TYPE SLOT)))
        (AND
         (EVERY
          #'(LAMBDA (CONSTRAINT)
             (trace-defun '#:G15754 (CONSTRAINT)
              (RET (OR (CNOT (SET-CONSTRAINT-EXPRP CONSTRAINT)) (TEST-SET-CONSTRAINT VALS CONSTRAINT :MODE MODE)))))
          CONSTRAINTS)
         (EVERY #'(LAMBDA (VAL) (trace-defun '#:G15755 (VAL) (RET (TEST-VAL-CONSTRAINTS VAL CONSTRAINTS SPECIAL-SLOT-TYPE :MODE MODE))))
          VALS))))))))))
(TRACE-LISP
 (DEFINE SPECIAL-SLOT-TYPE (SLOT)
  (trace-defun 'SPECIAL-SLOT-TYPE (SLOT)
   (RET (COND ((NULL SLOT) NIL) ((REMOVE-SUBSUMERS-SLOTP SLOT) 'REMOVE-SUBSUMERS-SLOT) ((REMOVE-SUBSUMEES-SLOTP SLOT) 'REMOVE-SUBSUMEES-SLOT))))))
(TRACE-LISP
 (DEFINE TEST-VAL-CONSTRAINTS (VAL CONSTRAINTS SPECIAL-SLOT-TYPE &REST LKEYS)
  (trace-defun 'TEST-VAL-CONSTRAINTS (VAL CONSTRAINTS SPECIAL-SLOT-TYPE LKEYS)
   (RET
    (CLET (MODE)
     (AND VAL
      (EVERY
       #'(LAMBDA (CONSTRAINT)
          (trace-defun '#:G15756 (CONSTRAINT)
           (RET (OR (CNOT (VAL-CONSTRAINT-EXPRP CONSTRAINT)) (TEST-VAL-CONSTRAINT VAL CONSTRAINT SPECIAL-SLOT-TYPE :MODE MODE)))))
       CONSTRAINTS)))))))
;;;; [1] ignore for now - could look for mutually inconsistent constraints later
;;;; [2] Note we ASSUME for special-slot-types that the constraints are NECESSARILY of the form (<> ATOMIC-CLASS)
;;;; [3] Technically, this is a failure -- if there's no possible values. HOWEVER, KM may fail to find possible values if the
;;;;	system is looping, and so aborts the computation. See enforce-val-constraint also, for identical issue
(TRACE-LISP
 (DEFINE TEST-VAL-CONSTRAINT (VAL CONSTRAINT SPECIAL-SLOT-TYPE &REST LKEYS)
  (trace-defun 'TEST-VAL-CONSTRAINT (VAL CONSTRAINT SPECIAL-SLOT-TYPE LKEYS)
   (RET
    (CLET (MODE)
     (COND ((CONSTRAINT-EXPRP VAL)) 
      (T
       (CASE (FIRST CONSTRAINT) 
        (|must-be-a|
         (COND
          ((INSTANCE-OF VAL '|Aggregate|)
           (CLET ((ELEMENT-TYPE (KM0 `(|the| |element-type| |of| ,VAL))))
            (OR (NULL ELEMENT-TYPE) (COMPATIBLE-CLASSES :CLASSES1 ELEMENT-TYPE :CLASSES2 (LIST (SECOND CONSTRAINT))))))
               ((CL-EQUAL CONSTRAINT '(|must-be-a| |Thing|))) 
          (T (CASE MODE (CONSISTENT (KM0 `(,VAL &? (|a| ,@(REST CONSTRAINT))))) (SATISFIES (KM0 `(,VAL |is| '(|a| ,@(REST CONSTRAINT)))))))))
        (|mustnt-be-a| (KM0 `(|not| (,VAL |is| '(|a| ,@(REST CONSTRAINT))))))
        (<>
         (COND
          ((IS-KM-TERM (SECOND CONSTRAINT))
           (CASE SPECIAL-SLOT-TYPE (REMOVE-SUBSUMERS-SLOT (CNOT (IS-SUBCLASS-OF VAL (SECOND CONSTRAINT))))
            (REMOVE-SUBSUMEES-SLOT (CNOT (IS-SUBCLASS-OF (SECOND CONSTRAINT) VAL))) (T (CNOT (CL-EQUAL VAL (SECOND CONSTRAINT))))))
          (T (KM0 `(,VAL /= ,(SECOND CONSTRAINT))))))
        
        (|excluded-values|
         (CLET ((EXCLUDED-VALUES (KM0 (VALS-TO-VAL (REST CONSTRAINT)))))
          (COND ((NULL EXCLUDED-VALUES))
           ((EQ SPECIAL-SLOT-TYPE 'REMOVE-SUBSUMERS-SLOT)  (CNOT (CL-INTERSECTION (ALL-SUPERCLASSES0 VAL) EXCLUDED-VALUES))) 
           ((EQ SPECIAL-SLOT-TYPE 'REMOVE-SUBSUMEES-SLOT)  (CNOT (CL-INTERSECTION (ALL-SUBCLASSES0 VAL) EXCLUDED-VALUES))) 
           (T (CNOT (CL-MEMBER VAL EXCLUDED-VALUES))))))
        
        (|possible-values|
         (CLET ((POSSIBLE-VALUES (KM0 (VALS-TO-VAL (REST CONSTRAINT)))))  
          (COND
           (POSSIBLE-VALUES
            (CASE SPECIAL-SLOT-TYPE (REMOVE-SUBSUMERS-SLOT (CNOT (DISJOINT-CLASS-SETS (LIST VAL) POSSIBLE-VALUES)))
             (REMOVE-SUBSUMEES-SLOT (CNOT (DISJOINT-CLASS-SETS (LIST VAL) POSSIBLE-VALUES)))
             (T
              (CASE MODE
               (CONSISTENT
                (SOME #'(LAMBDA (POSSIBLE-VALUE) (trace-defun '#:G15757 (POSSIBLE-VALUE) (RET (KM0 `(,VAL &? ,POSSIBLE-VALUE)))))
                 POSSIBLE-VALUES))
               (SATISFIES (CL-MEMBER VAL POSSIBLE-VALUES :TEST #'CL-EQUAL))))))
           (T))))
         (|constraint| (KM0 (SUBST VAL '|TheValue| (SECOND CONSTRAINT))))  (|no-inheritance| T)
        (T (REPORT-ERROR 'USER-ERROR "Unrecognized form of constraint ~a~%" CONSTRAINT))))))))))
;;;; [1] this computation is seemingly (but insignificantly) inefficient here, and could be moved earlier.
;;;; But: it is a place-holder, where we might later want to check for mutually inconsistent constraints later.
;;;; [2] Efficiency - only do the length test if needed later
(TRACE-LISP
 (DEFINE TEST-SET-CONSTRAINT (VALS0 CONSTRAINT &REST LKEYS)
  (trace-defun 'TEST-SET-CONSTRAINT (VALS0 CONSTRAINT LKEYS)
   (RET
    (CLET (MODE)
     (CLET
      ((VALS (REMOVE-CONSTRAINTS VALS0))  (N (SECOND CONSTRAINT)) (CLASS (THIRD CONSTRAINT))
       (NVALS
        (COND
         ((OR (AND (EQ (FIRST CONSTRAINT) '|at-least|) (EQ MODE 'SATISFIES))  (CL-MEMBER (FIRST CONSTRAINT) '(|exactly| |at-most|)))
          (LENGTH (REMOVE-IF-NOT #'(LAMBDA (VAL) (trace-defun '#:G15758 (VAL) (RET (CL-ISA VAL CLASS)))) VALS))))))
      (CASE (FIRST CONSTRAINT) (|at-least| (CASE MODE (CONSISTENT T)  (SATISFIES (>= NVALS N))))
       (|exactly| (CASE MODE (CONSISTENT (<= NVALS N)) (SATISFIES (= NVALS N)))) (|at-most| (<= NVALS N))
       (|set-constraint| (KM0 (SUBST (VALS-TO-VAL VALS) '|TheValues| (SECOND CONSTRAINT))))      (|sometimes| T) (|set-filter| T)
       (T (REPORT-ERROR 'USER-ERROR "Unrecognized form of set constraint ~a~%" CONSTRAINT) VALS0))))))))
;;;; ======================================================================
;;;;		IS-CONSISTENT
;;;; ======================================================================
;;;; Returns T/NIL. Here, we have vals and constraints mixed, and in principle could check
;;;; constraints are mutually consistent also.
(TRACE-LISP
 (DEFINE IS-CONSISTENT (VALS+CONSTRAINTS0)
  (trace-defun 'IS-CONSISTENT (VALS+CONSTRAINTS0)
   (RET
    (COND ((NULL VALS+CONSTRAINTS0) T)
     (T
      (CLET ((VALS+CONSTRAINTS (REMOVE-DUP-INSTANCES VALS+CONSTRAINTS0)))
       (AND
        (EVERY
         #'(LAMBDA (CONSTRAINT)
            (trace-defun '#:G15759 (CONSTRAINT)
             (RET (OR (CNOT (SET-CONSTRAINT-EXPRP CONSTRAINT))  (TEST-SET-CONSTRAINT VALS+CONSTRAINTS CONSTRAINT :MODE 'CONSISTENT)))))
         VALS+CONSTRAINTS)
        (EVERY #'(LAMBDA (VAL) (trace-defun '#:G15760 (VAL) (RET (TEST-VAL-CONSTRAINTS VAL VALS+CONSTRAINTS NIL :MODE 'CONSISTENT))))
         VALS+CONSTRAINTS)))))))))
;;		  (every ;'(lambda (val) (is-consistent-with-val-constraints val vals+constraints)) vals+constraints))))))
;;;; ======================================================================
;;;;		ENFORCE-CONSTRAINTS
;;;; ======================================================================
;;;; Returns revised vals, after constraints have been enforced
;;;; This one will do coersion, as well as testing.
;;;; This assume vals is a list of atoms, ie. any km evaluation has already been performed.
;;;; It also ASSUMES vals and constraints are ALREADY dereferenced
(TRACE-LISP
 (DEFINE ENFORCE-CONSTRAINTS (VALS CONSTRAINTS INSTANCE SLOT)
  (trace-defun 'ENFORCE-CONSTRAINTS (VALS CONSTRAINTS INSTANCE SLOT)
   (RET
    (COND ((AND (TRACEP) (CNOT (TRACECONSTRAINTSP))) (PROG2 (SUSPEND-TRACE) (ENFORCE-CONSTRAINTS0 VALS CONSTRAINTS INSTANCE SLOT) (UNSUSPEND-TRACE)))
     (T (KM-TRACE 'COMMENT "Enforcing constraints ~a" CONSTRAINTS) (ENFORCE-CONSTRAINTS0 VALS CONSTRAINTS INSTANCE SLOT)))))))
;;;; ******* NOTE!! **********
;;;; 9/7/99: Disable the set-valued constraints! It's causing too many problems! See constraints.README
;;;; We now reduce it to are-consistent-with-constraints for set-valued constraints.
;;;; 9/17/99: Put it back again, then hurriedly take it out again (see enforcement-problem.km)
;;;; [1] 9/19/00: Should do set constraint checks first, as they may enforce coercion enabling later val checks to succeed.
;;;; ASSUME: Dereferencing has already been done
(TRACE-LISP
 (DEFINE ENFORCE-CONSTRAINTS0 (VALS CONSTRAINTS INSTANCE SLOT) (trace-defun 'ENFORCE-CONSTRAINTS0 (VALS CONSTRAINTS INSTANCE SLOT) (RET ))))
;; TESTING ONLY VERSION
;; (let ( (newvals (remove-if-not ;'(lambda (val) (enforce-val-constraints val constraints)) vals)) )
;;   (mapc ;'(lambda (constraint)				; test but don't enforce set constraints, for now
;;	     (cond ((not (set-constraint-exprp constraint)))
;;		   ((is-consistent-with-set-constraint newvals constraint))
;;		   (t (report-error 'user-error "Constraint violation! Values ~a conflict with constraint ~a!~%"
;;				    newvals constraint))))
;;	 constraints)
;;   newvals))
(TRACE-LISP
 (DEFINE ENFORCE-VAL-CONSTRAINTS (VAL CONSTRAINTS INSTANCE SPECIAL-SLOT-TYPE)
  (trace-defun 'ENFORCE-VAL-CONSTRAINTS (VAL CONSTRAINTS INSTANCE SPECIAL-SLOT-TYPE)
   (RET
    (AND VAL
     (EVERY
      #'(LAMBDA (CONSTRAINT)
         (trace-defun '#:G15762 (CONSTRAINT)
          (RET
           (OR (CNOT (VAL-CONSTRAINT-EXPRP CONSTRAINT)) (ENFORCE-VAL-CONSTRAINT VAL CONSTRAINT INSTANCE SPECIAL-SLOT-TYPE)
            (REPORT-ERROR 'USER-ERROR "Constraint violation! Discarding value ~a (conflicts with ~a)~%" VAL CONSTRAINT)))))
      CONSTRAINTS))))))
;;;; 5.3.00 add to report error later
;;;; [1] This is actually a check, rather than an enforcement. It's the best we can do for now.
;;;; [2] This could be more efficient - I only care if there's a unique solution or not
;;;; [3] Technically, this is a failure -- if there's no possible values. HOWEVER, KM may fail to find possible values if the
;;;;	system is looping, and so aborts the computation. See is-consistent-with-val-constraint also, for identical issue
;;;; [4] I'm not sure about this - leave it in for completeness for now.
(TRACE-LISP
 (DEFINE ENFORCE-VAL-CONSTRAINT (VAL CONSTRAINT INSTANCE SPECIAL-SLOT-TYPE)
  (trace-defun 'ENFORCE-VAL-CONSTRAINT (VAL CONSTRAINT INSTANCE SPECIAL-SLOT-TYPE)
   (RET
    (CASE (FIRST CONSTRAINT)
     (|must-be-a|
      (COND
       ((INSTANCE-OF VAL '|Aggregate|)  
        (CLET ((ELEMENT-TYPE (COND ((CNOT (KM-STRUCTURED-LIST-VALP VAL))  (KM0 `(|the| |element-type| |of| ,VAL))))))
         (OR (NULL ELEMENT-TYPE) (COMPATIBLE-CLASSES :CLASSES1 ELEMENT-TYPE :CLASSES2 (LIST (SECOND CONSTRAINT))))))
         ((CL-EQUAL CONSTRAINT '(|must-be-a| |Thing|)) VAL) (T (KM0 `(,VAL & (|a| ,@(REST CONSTRAINT)))))))
     (|mustnt-be-a| (KM0 `(|not| (,VAL |is| '(|a| ,@(REST CONSTRAINT))))))    (<> (KM0 `(,VAL /== ,(SECOND CONSTRAINT))))
     (|excluded-values|
      (CLET ((EXCLUDED-VALUES (KM0 (VALS-TO-VAL (REST CONSTRAINT))))) 
       (COND ((NULL EXCLUDED-VALUES)) ((EQ SPECIAL-SLOT-TYPE 'REMOVE-SUBSUMERS-SLOT)  (CNOT (CL-INTERSECTION (ALL-SUPERCLASSES0 VAL) EXCLUDED-VALUES))) 
        ((EQ SPECIAL-SLOT-TYPE 'REMOVE-SUBSUMEES-SLOT)  (CNOT (CL-INTERSECTION (ALL-SUBCLASSES0 VAL) EXCLUDED-VALUES))) 
        ((CL-MEMBER VAL EXCLUDED-VALUES) NIL) 
        (T (MAPCAR #'(LAMBDA (EXCLUDED-VALUE) (trace-defun '#:G15763 (EXCLUDED-VALUE) (RET ))) EXCLUDED-VALUES)))))
     (|possible-values|
      (CLET ((POSSIBLE-VALUES (KM0 (VALS-TO-VAL (REST CONSTRAINT))))) 
       (COND ((NULL POSSIBLE-VALUES)) 
        ((AND (EQ SPECIAL-SLOT-TYPE 'REMOVE-SUBSUMERS-SLOT) INSTANCE) 
         (COND ((CL-MEMBER VAL POSSIBLE-VALUES))
          ((SINGLETONP POSSIBLE-VALUES)
           (KM-TRACE 'COMMENT "~a: Only one possible value so enforcing ~a isa ~a!~%" `(|possible-values| ,@(REST CONSTRAINT)) INSTANCE
            (FIRST POSSIBLE-VALUES))
           (KM0 `(,INSTANCE == (|a| ,(FIRST POSSIBLE-VALUES)))))
          (T
           (CLET ((UNIFIABLE-VALUES (FIRST-N-UNIFIABLE-VALUES2 POSSIBLE-VALUES INSTANCE 2)))
            (COND
             ((SINGLETONP UNIFIABLE-VALUES)
              (KM-TRACE 'COMMENT "~a: Only one consistent, possible value so enforcing ~a isa ~a!~%" `(|possible-values| ,@(REST CONSTRAINT)) INSTANCE
               (FIRST UNIFIABLE-VALUES))
              (KM0 `(,INSTANCE == (|a| ,(FIRST UNIFIABLE-VALUES)))))
             (UNIFIABLE-VALUES T))))))
         ((CL-MEMBER SPECIAL-SLOT-TYPE '(REMOVE-SUBSUMERS-SLOT REMOVE-SUBSUMEES-SLOT))  (CNOT (DISJOINT-CLASS-SETS (LIST VAL) POSSIBLE-VALUES)))
        ((CL-MEMBER VAL POSSIBLE-VALUES))
        ((SINGLETONP POSSIBLE-VALUES)
         (KM-TRACE 'COMMENT "~a: Only one possible value so enforcing ~a == ~a!~%" `(|possible-values| ,@(REST CONSTRAINT)) VAL (FIRST POSSIBLE-VALUES))
         (KM0 `(,VAL == ,(FIRST POSSIBLE-VALUES))))
        (T
         (CLET ((NEW-CONSTRAINT `(|possible-values| ,@POSSIBLE-VALUES)) (UNIFIABLE-VALUES (FIRST-N-UNIFIABLE-VALUES POSSIBLE-VALUES VAL 2))) 
          (COND
           ((SINGLETONP UNIFIABLE-VALUES)
            (KM-TRACE 'COMMENT "~a: Only one consistent, possible value so enforcing ~a == ~a!~%" `(|possible-values| ,@(REST CONSTRAINT)) VAL
             (FIRST UNIFIABLE-VALUES))
            (KM0 `(,VAL == ,(FIRST UNIFIABLE-VALUES))))
           ((CNOT (NULL UNIFIABLE-VALUES))
            (OR (CL-MEMBER NEW-CONSTRAINT (GET-VALS VAL '== :SITUATION *GLOBAL-SITUATION*) :TEST #'CL-EQUAL)
             (KM0 `(,VAL |has| (== (,NEW-CONSTRAINT))) :FAIL-MODE 'ERROR)))))))))
      (|constraint| (KM0 (SUBST VAL '|TheValue| (SECOND CONSTRAINT))))  (|no-inheritance| T)
     (T (REPORT-ERROR 'USER-ERROR "Unrecognized form of constraint ~a~%" CONSTRAINT)))))))
;;;; Returns the first N possible-values which are unifiable with val.
;;;; This stops after the first N are found, and thus is a bit more efficient than doing:
;;;;    (remove-if-not ;'(lambda (possible-value) (km0 `(,val &? ,possible-value))) possible-values)
(TRACE-LISP
 (DEFINE FIRST-N-UNIFIABLE-VALUES (POSSIBLE-VALUES VAL N)
  (trace-defun 'FIRST-N-UNIFIABLE-VALUES (POSSIBLE-VALUES VAL N)
   (RET
    (COND ((ENDP POSSIBLE-VALUES) NIL) ((<= N 0) NIL)
     ((KM0 `(,VAL &? ,(FIRST POSSIBLE-VALUES))) (CONS (FIRST POSSIBLE-VALUES) (FIRST-N-UNIFIABLE-VALUES (REST POSSIBLE-VALUES) VAL (1- N))))
     (T (FIRST-N-UNIFIABLE-VALUES (REST POSSIBLE-VALUES) VAL N)))))))
(TRACE-LISP
 (DEFINE FIRST-N-UNIFIABLE-VALUES2 (POSSIBLE-VALUES INSTANCE N)
  (trace-defun 'FIRST-N-UNIFIABLE-VALUES2 (POSSIBLE-VALUES INSTANCE N)
   (RET
    (COND ((ENDP POSSIBLE-VALUES) NIL) ((<= N 0) NIL)
     ((KM0 `(,INSTANCE &? (|a| ,(FIRST POSSIBLE-VALUES))))
      (CONS (FIRST POSSIBLE-VALUES) (FIRST-N-UNIFIABLE-VALUES2 (REST POSSIBLE-VALUES) INSTANCE (1- N))))
     (T (FIRST-N-UNIFIABLE-VALUES2 (REST POSSIBLE-VALUES) INSTANCE (1- N))))))))
;;;; ----------------------------------------
(TRACE-LISP
 (DEFINE ENFORCE-SET-CONSTRAINTS (VALS CONSTRAINTS INSTANCE &OPTIONAL SPECIAL-SLOT-TYPE)
  (trace-defun 'ENFORCE-SET-CONSTRAINTS (VALS CONSTRAINTS INSTANCE SPECIAL-SLOT-TYPE) (RET ))))
;;;; Just do this reduced version
(TRACE-LISP
 (DEFINE ENFORCE-SET-CONSTRAINT (VALS CONSTRAINT INSTANCE SPECIAL-SLOT-TYPE)
  (trace-defun 'ENFORCE-SET-CONSTRAINT (VALS CONSTRAINT INSTANCE SPECIAL-SLOT-TYPE)
   (RET
    (TRACE-PROGN (DECLARE (IGNORE INSTANCE SPECIAL-SLOT-TYPE))
     (CLET
      ((FORCED-CLASS (FIRST (OR (MINIMATCH CONSTRAINT '(|at-most| 1 |?class|)) (MINIMATCH CONSTRAINT '(|exactly| 1 |?class|)))))
       (VALS-IN-CLASS (COND (FORCED-CLASS (REMOVE-IF-NOT #'(LAMBDA (VAL) (trace-defun '#:G15764 (VAL) (RET (CL-ISA VAL FORCED-CLASS)))) VALS)))))
      (COND
       ((> (LENGTH VALS-IN-CLASS) 1)  (MAKE-COMMENT "Unifying values ~a (forced by constraint (at-most 1 ~a)" VALS-IN-CLASS FORCED-CLASS)
        (CONS (KM-UNIQUE0 (VALS-TO-&-EXPR VALS-IN-CLASS) :FAIL-MODE 'ERROR) (SET-DIFFERENCE VALS VALS-IN-CLASS)))
       (T (ENFORCE-SET-CONSTRAINT2 VALS CONSTRAINT)))))))))
;;;; PROBLEMS! see test-suite/outstanding/enforcement-problem.km
;;;; Simplified to just do the test and report on the problems
(TRACE-LISP
 (DEFINE ENFORCE-SET-CONSTRAINT2 (VALS CONSTRAINT)
  (trace-defun 'ENFORCE-SET-CONSTRAINT2 (VALS CONSTRAINT)
   (RET
    (CLET
     ((N (SECOND CONSTRAINT)) (CLASS (THIRD CONSTRAINT))
      (COUNT (LENGTH (REMOVE-IF-NOT #'(LAMBDA (VAL) (trace-defun '#:G15765 (VAL) (RET (CL-ISA VAL CLASS)))) VALS))))
     (CASE (FIRST CONSTRAINT)  #|new|#
      (|at-least|
       (COND ((OR (> N *MAX-PADDING-INSTANCES*) #|new|# (>= COUNT N)) VALS)  #|new|#
        (T (APPEND VALS (CL-LOOP REPEAT (- N COUNT) COLLECT (KM-UNIQUE0 `(|a| ,CLASS) :FAIL-MODE 'ERROR))))))
      
      (|exactly|
       (COND  #|new|# ((= COUNT N) VALS)
        ((> COUNT N)
         (REPORT-ERROR 'USER-ERROR "set-constraint violation! Found ~a ~a(s), but should be~%exactly ~a! Values were: ~a. Ignoring extras...~%" COUNT
          CLASS N VALS)
         )
        #|new|# ((> N *MAX-PADDING-INSTANCES*) VALS)  #|new|#
        (T (APPEND VALS (CL-LOOP REPEAT (- N COUNT) COLLECT (KM-UNIQUE0 `(|a| ,CLASS) :FAIL-MODE 'ERROR)))) ))
      (|at-most|
       (COND ((<= COUNT N) VALS)
        (T
         (REPORT-ERROR 'USER-ERROR "set-constraint violation! Found ~a ~a(s), but should be~%at-most ~a! Values were: ~a. Ignoring extras...~%" COUNT
          CLASS N VALS)
         )))
      (|set-constraint|
       (COND ((KM0 (SUBST (VALS-TO-VAL VALS) '|TheValues| (SECOND CONSTRAINT))) VALS)
        (T (REPORT-ERROR 'USER-ERROR "set-constraint violation!~%~a failed test ~a. Continuing anyway...~%" VALS (SECOND CONSTRAINT)) VALS)))
      (|sometimes| T) (|set-filter| (CLET ((FILTER (SECOND CONSTRAINT))) (APPLY FILTER (LIST VALS)))) 
      (T (REPORT-ERROR 'USER-ERROR "Unrecognized form of set constraint ~a~%" CONSTRAINT) VALS)))))))
;;;; ======================================================================
;;;;		TEST-SET-CONSTRAINTS
;;;; This is a rather complicated bit of code, to avoid reifying all existential expressions
;;;; ======================================================================
#|This is a special case of constraint checking, used by lazy-unify.lisp
Checks that the number of (potentially) unified objects are below the specified maximum.
Takes as arguments: exprs1 exprs2 expr-sets1 expr-sets2, where exprs1 exprs2 are each a set of instances,
   expr-sets1 is list of expression sets (expr-set1 expr-set2 ...), and similarly for expr-sets2.
We want to estimate what (exprs1 && exprs2 && expr-set11 && expr-set12 && ... && expr-set21 && expr-set22 && ...)
  will produce.
The system creates "unifications" which is a single list of unified elements from each sets.
The result will be, say:
	unifications = ((v11 & expr111) (v12) (v13 & expr112 & expr211 & expr221) (v21 & expr121) ....)
But we drop the "&" sign from these lists for convenience, as we never actually compute the unification. 
 (We only care how many objects are in the final unification).

USER(109): (test-set-constraints 'X$(_Car1 _Car2) '(_Car2) 'X$( ((a Car)) ((a House) (a Dog)) ) nil 'X$((at-most 1 Thing)))   -> NIL
USER(110): (test-set-constraints 'X$(_Car1 _Car2) '(_Car2) 'X$( ((a Car)) ((a House) (a Dog)) ) nil 'X$((at-most 2 Car)))     -> T
USER(111): (test-set-constraints 'X$(_Car1 _Car2) '(_Car2) 'X$( ((a Car)) ((a House) (a Dog)) ) nil 'X$((at-most 1 House)))   -> T
USER(112): (test-set-constraints 'X$(_Car1 _Car2) '(_Car2) 'X$( ((a Car)) ((a House) (a Dog)) ) nil 'X$((at-most 3 Thing)))   -> T|#
#|(test-set-constraints 'X$(_Car1 _Car2) '(_Car2) 'X$( ((a Car)) ((a House) (a Dog)) ) nil 'X$((at-most 1 Thing)))
unification = ((_Car1 _Car2 (a Car)) ((a House)) ((a Dog)))
[1a] 3/16/01 - Can get confused: (_Car1 _Engine1) & (_Engine2) makes KM estimate that _Engine2 unifies with _Car1, which
	means there are now two engines resulting in an (incorrect) violation of a (exactly 1 Engine) constraint.
	Let's drop the vs for now. See outstanding/set-constraints.km
[1b] 5/23/01 - but no! (test-set-constraints '(_Tangible-Entity10 _Car11 _Tangible-Entity19) '(_Tangible-Entity26) nil nil '((exactly 1 Entity)))
	Should *succeed*, as (exactly 1 Entity) will force the three vs1 to be unified together, = ok!|#
(TRACE-LISP
 (DEFINE TEST-SET-CONSTRAINTS (VS1 VS2 EXPR-SETS1 EXPR-SETS2 CONSTRAINTS)
  (trace-defun 'TEST-SET-CONSTRAINTS (VS1 VS2 EXPR-SETS1 EXPR-SETS2 CONSTRAINTS) (RET ))))
(TRACE-LISP
 (DEFINE TEST-SET-CONSTRAINT0 (UNIFICATIONS CONSTRAINT)
  (trace-defun 'TEST-SET-CONSTRAINT0 (UNIFICATIONS CONSTRAINT)
   (RET (CASE (FIRST CONSTRAINT) ((|exactly| |at-most|) (TEST-SET-CONSTRAINT1 UNIFICATIONS (SECOND CONSTRAINT) (THIRD CONSTRAINT)))       (T T))))))
;;;; (test-set-constraint1 '(1 2 3) '(1 2) 2 ';$Thing) -> NIL
(TRACE-LISP
 (DEFINE TEST-SET-CONSTRAINT1 (UNIFICATIONS N CLASS)
  (trace-defun 'TEST-SET-CONSTRAINT1 (UNIFICATIONS N CLASS)
   (RET
    (CLET
     ((UNIFICATIONS-IN-CLASS
       (COND ((EQ CLASS '|Thing|) UNIFICATIONS)
        (T
         (REMOVE-IF-NOT #'(LAMBDA (UNIFICATION) (trace-defun '#:G15769 (UNIFICATION) (RET (UNIFICATION-IN-CLASS UNIFICATION CLASS))))
          UNIFICATIONS)))))
     (<= (LENGTH UNIFICATIONS-IN-CLASS) N))))))
#|======================================================================
	ESTIMATING UNIFICATIONS 
======================================================================
1. Given expr-sets, combine them into unification
2. Explore which members of unification are in a class|#
;; not used
;;(defun number-in-class (unifications class)
;;  (cond ((eq class ';$Thing) (length unifications))
;;	(t (length (remove-if-not ;'(lambda (unification)
;;				      (unifications-in-class unification class))
;;				  unifications)))))
(TRACE-LISP
 (DEFINE UNIFICATION-IN-CLASS (UNIFICATION CLASS)
  (trace-defun 'UNIFICATION-IN-CLASS (UNIFICATION CLASS)
   (RET
    (SOME
     #'(LAMBDA (ITEM)
        (trace-defun '#:G15770 (ITEM)
         (RET (COND ((EXISTENTIAL-EXPRP ITEM) (IS-SUBCLASS-OF (CLASS-IN-EXISTENTIAL-EXPR ITEM) CLASS)) (T (CL-ISA ITEM CLASS))))))
     UNIFICATION)))))
;;;; for testing purposes
#|(estimate-unifications 'X$((_Car13 _Dog14)  ((a Car) (a Dog))  ((a House)) 
			   ((a Big-House) (a Book)) (_House17) (_Car13 _Car16) ((a Undefined-Class))))
 => 5 unified items
    ((_Car13 (a Car) (a Undefined-Class))
     ((a House) (a Big-House) _House17) 
     (_Dog14 (a Dog))
     ((a Book)) 
     (_Car16))|#
;;;; 
(TRACE-LISP
 (DEFINE ESTIMATE-UNIFICATIONS (EXPR-SETS &OPTIONAL TALLY-SO-FAR)
  (trace-defun 'ESTIMATE-UNIFICATIONS (EXPR-SETS TALLY-SO-FAR)
   (RET
    (COND ((ENDP EXPR-SETS) TALLY-SO-FAR)
     (T (CLET ((NEW-TALLY (COMBINE-IN-EXPRS TALLY-SO-FAR (FIRST EXPR-SETS))))  (ESTIMATE-UNIFICATIONS (REST EXPR-SETS) NEW-TALLY))))))))
#|Given:
VALUE SETS 1: (_Car13 _Dog14)  ((a Car) (a Dog))  ((a House))
VALUE SETS 2: ((a Big-House) (a Book)) (_House17) (_Car13 _Car16)
SET-CONSTRAINTS: (at-most 3 Thing) (at-most 2 Car)
Are the set constraints satisfied? Urgh!

Need to combine these iteratively, and non-destructively, as:
(_Car2) 		(_Dog2)
(_Car2 (a Car)) 	(_Dog2 (a Dog)) 	((a House))
(_Car2 (a Car)) 	(_Dog2 (a Dog)) 	((a House) (a Big-House))
(_Car2 (a Car)) 	(_Dog2 (a Dog)) 	((a House) (a Big-House))		(a Book)
(_Car2 (a Car)) 	(_Dog2 (a Dog)) 	((a House) (a Big-House) _House6)	(a Book)
(_Car2 (a Car)) 	(_Dog2 (a Dog)) 	((a House) (a Big-House) _House6)	(a Book)	(_Car3)
Let's call this iteratively growing set a TALLY

USER(66): USER(66): USER(66): (test-tally)
Fold in (_Car13 _Dog14)...
Tally (length 2) = ((_Car13) (_Dog14))

Fold in ((a Car) (a Dog))...
Tally (length 2) = ((_Car13 (a Car)) (_Dog14 (a Dog)))

Fold in ((a House))...
Tally (length 3) = ((_Car13 (a Car)) (_Dog14 (a Dog)) ((a House)))

Fold in ((a Big-House) (a Book))...
Tally (length 4) = (((a House) (a Big-House)) (_Car13 (a Car))
                    (_Dog14 (a Dog)) ((a Book)))

Fold in (_House17)...
Tally (length 4) = (((a House) (a Big-House) _House17) (_Car13 (a Car))
                    (_Dog14 (a Dog)) ((a Book)))

Fold in (_Car13 _Car16)...
Tally (length 5) = ((_Car13 (a Car)) ((a House) (a Big-House) _House17)
                    (_Dog14 (a Dog)) ((a Book)) (_Car16))

Fold in ((a Undefined-Class))...
Tally (length 5) = ((_Car13 (a Car) (a Undefined-Class))
                    ((a House) (a Big-House) _House17) (_Dog14 (a Dog))
                    ((a Book)) (_Car16))|#
(TRACE-LISP
 (DEFINE COMBINE-IN-EXPRS (TALLY EXPRS)
  (trace-defun 'COMBINE-IN-EXPRS (TALLY EXPRS)
   (RET
    (MULTIPLE-VALUE-BIND (TALLY1 UNUSED-TALLY1 UNMATCHED-EXPRS1) (COMBINE-IN-EXPRS0 TALLY EXPRS :CLASSES-SUBSUMEP 'EXACT-MATCH)
     (MULTIPLE-VALUE-BIND (TALLY2 UNUSED-TALLY2 UNMATCHED-EXPRS2) (COMBINE-IN-EXPRS0 UNUSED-TALLY1 UNMATCHED-EXPRS1 :CLASSES-SUBSUMEP T)
      (MULTIPLE-VALUE-BIND (TALLY3 UNUSED-TALLY3 UNMATCHED-EXPRS3) (COMBINE-IN-EXPRS0 UNUSED-TALLY2 UNMATCHED-EXPRS2 :CLASSES-SUBSUMEP NIL)
       (APPEND TALLY1 TALLY2 TALLY3 UNUSED-TALLY3 (MAPCAR #'LIST UNMATCHED-EXPRS3)))))))))
;;;; Returns: used-tally unused-tally unmatched-exprs
(TRACE-LISP
 (DEFINE COMBINE-IN-EXPRS0 (TALLY EXPRS &REST LKEYS)
  (trace-defun 'COMBINE-IN-EXPRS0 (TALLY EXPRS LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP)
     (COND ((NULL EXPRS) (VALUES NIL TALLY NIL))
      (T
       (CLET
        ((EXPR (FIRST EXPRS))
         (MATCHING-TALLY-ITEM
          (FIND-IF
           #'(LAMBDA (TALLY-ITEM)
              (trace-defun '#:G15771 (TALLY-ITEM) (RET (TALLY-ITEM-MATCHES TALLY-ITEM EXPR :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))))
           TALLY)))
        (COND
         (MATCHING-TALLY-ITEM
          (MULTIPLE-VALUE-BIND (REST-TALLY UNUSED-TALLY UNMATCHED-EXPRS)
           (COMBINE-IN-EXPRS0 (CL-REMOVE MATCHING-TALLY-ITEM TALLY :TEST #'CL-EQUAL) (REST EXPRS) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP)
           (COND ((CL-MEMBER EXPR MATCHING-TALLY-ITEM :TEST #'CL-EQUAL) (VALUES (CONS MATCHING-TALLY-ITEM REST-TALLY) UNUSED-TALLY UNMATCHED-EXPRS))
            (T (VALUES (CONS (APPEND MATCHING-TALLY-ITEM (LIST EXPR)) REST-TALLY) UNUSED-TALLY UNMATCHED-EXPRS)))))
         (T
          (MULTIPLE-VALUE-BIND (REST-TALLY UNUSED-TALLY UNMATCHED-EXPRS) (COMBINE-IN-EXPRS0 TALLY (REST EXPRS) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP)
           (VALUES REST-TALLY UNUSED-TALLY (CONS EXPR UNMATCHED-EXPRS)))))))))))))
#|(defun combine-in-exprs (tally exprs)
  (cond ((null exprs) tally)
	((let* ( (expr (first exprs)) 
		 (matching-tally-item (or (find-if X'(lambda (tally-item)
						       (tally-item-matches tally-item expr :classes-subsumep 'exact-match))
						   tally)
					  (find-if X'(lambda (tally-item)
						       (tally-item-matches tally-item expr :classes-subsumep t))
						   tally)
					  (find-if X'(lambda (tally-item)
						       (tally-item-matches tally-item expr :classes-subsumep nil))
						   tally))) )
	   (cond (matching-tally-item
		  (cond ((member expr matching-tally-item :test X'equal)
			 (cons matching-tally-item (combine-in-exprs (remove matching-tally-item tally :test X'equal) (rest exprs))))
			(t (cons (append matching-tally-item (list expr)) 
				 (combine-in-exprs (remove matching-tally-item tally :test X'equal) (rest exprs))))))
		 (t (cons (list expr) (combine-in-exprs tally (rest exprs)))))))))|#
#| Note Cat and Dog are a Partition.
USER(41): (tally-item-matches 'X$((a Dog)) 'X$_Dog8) -> t
USER(42): (tally-item-matches 'X$((a Dog)) 'X$_Cat9) -> NIL
USER(43): (tally-item-matches 'X$((a Dog)) 'X$(a Dog)) -> t		
USER(44): (tally-item-matches 'X$((a Dog)) 'X$(a Cat)) -> NIL
USER(45): (tally-item-matches 'X$((a Dog) _Dog7) 'X$(a Cat)) -> NIL
USER(47): (tally-item-matches 'X$((a Dog) _Dog12) 'X$_Dog8) -> t
USER(48): (tally-item-matches 'X$((a Dog) _Cat9) 'X$_Dog8) -> NIL|#
(TRACE-LISP
 (DEFINE TALLY-ITEM-MATCHES (TALLY-EXPRS EXPR &REST LKEYS)
  (trace-defun 'TALLY-ITEM-MATCHES (TALLY-EXPRS EXPR LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP)
     (EVERY #'(LAMBDA (TALLY-EXPR) (trace-defun '#:G15772 (TALLY-EXPR) (RET (EXPRS-MATCH TALLY-EXPR EXPR :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))))
      TALLY-EXPRS))))))
#|subsumesp = t implies STRICTER compatibility testing. This is a slight work-around to PREVENT this misjudgement:
 (estimate-unifications '((_Airfoil-Body545 _Airfoil-Leading-Edge550 _Airfoil-Trailing-Edge551)
			  (_Airfoil-Leading-Edge547 _Airfoil-Trailing-Edge548 _Airfoil-Body553)))
   ->     ((_Airfoil-Body545 _Airfoil-Leading-Edge547) 
	   (_Airfoil-Trailing-Edge551 _Airfoil-Trailing-Edge548)
           (_Airfoil-Leading-Edge550 _Airfoil-Body553))|#
(TRACE-LISP
 (DEFINE EXPRS-MATCH (EXPR1 EXPR2 &REST LKEYS)
  (trace-defun 'EXPRS-MATCH (EXPR1 EXPR2 LKEYS)
   (RET
    (CLET (CLASSES-SUBSUMEP)
     (CLET ((IS-EXISTENTIALP1 (EXISTENTIAL-EXPRP EXPR2)) (IS-EXISTENTIALP2 (EXISTENTIAL-EXPRP EXPR1)))
      (COND ((CL-EQUAL EXPR1 EXPR2)) ((NULL EXPR1)) ((NULL EXPR2))
       ((KM-STRUCTURED-LIST-VALP EXPR1)
        (COND
         ((KM-STRUCTURED-LIST-VALP EXPR2)
          (EVERY
           #'(LAMBDA (PAIR) (trace-defun '#:G15773 (PAIR) (RET (EXPRS-MATCH (FIRST PAIR) (SECOND PAIR) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))))
           (TRANSPOSE (LIST (REST EXPR1) (REST EXPR2)))))
         (T (EXPRS-MATCH (SECOND EXPR1) EXPR2) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP)))
       ((KM-STRUCTURED-LIST-VALP EXPR2)  (EXPRS-MATCH EXPR1 (SECOND EXPR2) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))
       ((AND IS-EXISTENTIALP1 IS-EXISTENTIALP2)
        (COMPATIBLE-CLASSES :CLASSES1 (LIST (CLASS-IN-EXISTENTIAL-EXPR EXPR2)) :CLASSES2 (LIST (CLASS-IN-EXISTENTIAL-EXPR EXPR1)) :CLASSES-SUBSUMEP
         CLASSES-SUBSUMEP))
       ((AND IS-EXISTENTIALP1 (CNOT IS-EXISTENTIALP2))
        (COMPATIBLE-CLASSES :CLASSES1 (LIST (CLASS-IN-EXISTENTIAL-EXPR EXPR2)) :INSTANCE2 EXPR1 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))
       ((AND (CNOT IS-EXISTENTIALP1) IS-EXISTENTIALP2)
        (COMPATIBLE-CLASSES :INSTANCE1 EXPR2 :CLASSES2 (LIST (CLASS-IN-EXISTENTIAL-EXPR EXPR1)) :CLASSES-SUBSUMEP CLASSES-SUBSUMEP))
       ((AND (CNOT IS-EXISTENTIALP1) (CNOT IS-EXISTENTIALP2))
        (AND (COMPATIBLE-CLASSES :INSTANCE1 EXPR1 :INSTANCE2 EXPR2 :CLASSES-SUBSUMEP CLASSES-SUBSUMEP)
         (CNOT (INCOMPATIBLE-INSTANCES EXPR2 EXPR1)))))))))))
;; e.g. *Cat *Dog
;;;; --- end ---
;;;; ======================================================================
#|(defun evaluate-and-filter-defaults (expr-set constraints)
  (cond ((some X'km-defaultp expr-set)
	 (mapcan X'(lambda (expr)
		     (cond ((km-defaultp expr)
			    (let* ( (vals (km0 (second expr)))
				    (new-vals (filter-using-constraints vals constraints)) )
			      (cond ((and (tracep) (not (equal vals new-vals)))
				     (km-trace 'comment "Discarding ~a (conflicts with constraint(s) ~a)" expr constraints)))
			      new-vals))
			   (t (list expr))))
		 expr-set))
	(t expr-set)))|#
(TRACE-LISP
 (DEFINE EVALUATE-AND-FILTER-DEFAULTS (EXPR-SET CONSTRAINTS CURR-VALS SLOT &REST LKEYS)
  (trace-defun 'EVALUATE-AND-FILTER-DEFAULTS (EXPR-SET CONSTRAINTS CURR-VALS SLOT LKEYS)
   (RET
    (CLET (SINGLE-VALUEDP)
     (COND
      ((SOME #'KM-DEFAULTP EXPR-SET)
       (MAPCAN
        #'(LAMBDA (EXPR)
           (trace-defun '#:G15774 (EXPR)
            (RET
             (COND
              ((KM-DEFAULTP EXPR)
               (CLET
                ((VALS (KM0 (SECOND EXPR)))
                 (NEW-VALS
                  (COND ((AND SINGLE-VALUEDP CURR-VALS VALS (CNOT (KM0 `(,(FIRST CURR-VALS) &? ,(FIRST VALS))))) NIL)
                   (T
                    (REMOVE-IF-NOT
                     #'(LAMBDA (VAL)
                        (trace-defun '#:G15775 (VAL)
                         (RET (ARE-CONSISTENT-WITH-CONSTRAINTS (APPEND CURR-VALS (LIST VAL)) (DEREFERENCE CONSTRAINTS) SLOT))))
                     VALS)))))
                (COND
                 ((AND (TRACEP) (CNOT (CL-EQUAL VALS NEW-VALS))) (KM-TRACE 'COMMENT "Discarding ~a (conflicts with constraint(s) ~a)" EXPR CONSTRAINTS)))
                NEW-VALS))
              (T (LIST EXPR))))))
        EXPR-SET))
      (T EXPR-SET)))))))
;;;; ======================================================================
;;;;		TOGGLING THE CONSTRAINTS
;;;; ======================================================================
(TRACE-LISP
 (DEFINE SANITY-CHECKS NIL
  (trace-defun 'SANITY-CHECKS NIL
   (RET
    (TRACE-PROGN
     (COND (*SANITY-CHECKS* (FORMAT T "(Checking of `sanity-check' constraints is already switched on)~%"))
      (T (FORMAT T "(Checking of `sanity-check' constraints switched on)~%") (KM-SETQ '*SANITY-CHECKS* T)))
     '(|t|))))))
(TRACE-LISP
 (DEFINE NO-SANITY-CHECKS NIL
  (trace-defun 'NO-SANITY-CHECKS NIL
   (RET
    (TRACE-PROGN
     (COND ((CNOT *SANITY-CHECKS*) (FORMAT T "(Checking of `sanity-check' constraints is already switched off)~%"))
      (T (FORMAT T "(Checking of `sanity-check' constraints switched off)~%") (KM-SETQ '*SANITY-CHECKS* NIL)))
     '(|t|))))))
;;;; -------------------- for Shaken
;;;; (pair-filter ';$((:pair 1 *foot) (:pair 2 *foot) (:pair 1 *yard) (:pair 2 *yard)))
;;;; -> ((:;pair; 1 ;*foot;) (:;pair; 1 ;*yard;))
;;;; Retain just first item
(TRACE-LISP
 (DEFINE PAIR-FILTER (VALS &OPTIONAL SELECTED-SO-FAR)
  (trace-defun 'PAIR-FILTER (VALS SELECTED-SO-FAR)
   (RET
    (COND ((ENDP VALS) NIL)
     (T
      (CLET ((PAIR (FIRST VALS)) (UNITS (ARG2OF PAIR)))
       (COND
        ((OR (CNOT (KM-PAIRP PAIR)) (NOTANY #'(LAMBDA (SELECTED-PAIR) (trace-defun '#:G15776 (SELECTED-PAIR) (RET ))) SELECTED-SO-FAR))
         (CONS PAIR (PAIR-FILTER (REST VALS) (CONS PAIR SELECTED-SO-FAR))))
        (T (PAIR-FILTER (REST VALS) SELECTED-SO-FAR))))))))))
;;;; FILE:  explain.lisp
;;;; File: explain.lisp
;;;; Author: Peter Clark
;;;; Purpose: Have KM explain its reasoning
#|RECORDING EXPLANATIONS
  (record-explanation-for target val expr &key situation)
	target = (the <slot> of <instance>)

 - The explaining expr may include a "source" annotation about the origin of the
   expression e.g. (a Engine (@ Car parts))  
 - situation is the situation in which the computation was done, *not* necessarily
   *Global for non-fluent slots. [This might mean there's duplicate explanations in
   the KB, one in each situation, for non-fluent slots].
   WITH THE EXCEPTION of automatic classification, where instance-of explanations
   are stored globally. [SpecialCase] handles this below.

RETRIEVING EXPLANATIONS
 - (why [instance slot val situation]) 
   NEW: (why [triple situation]) 
   will print out an explanation for this triple, using the functions below.

 - (get-explanations instance slot val [situation])

   returns a list of EXPLANATIONS for this triple.
   An explanation has one of these two structures:
		 (instance slot val (<expr>*))
		 (val invslot instance (<expr>*))

   where each <expr> is one of the KM expressions deriving the triple.

 - (get-comments <expr>)

   GIVEN an EXPR, we can find the full KM rule and any comments about it as
   follows:

	(multiple-value-bind
	 (descriptions justifications rule path body)
	 (get-comments <expr>))

    where:
    - descriptions is a list of English translations of the rule
    - justifications is a list of English justifications of the rule
    - body is the expression which was evaluated, justifying the triple.
    - path is the location of that body, in the form of 
	(class1 slot1 class2 slot2 ...)
    - rule is a simple syntactic combination of the path + body, looking
      like this:
	(every class1 has 
	   (slot1 ((a class2 with
		      (slot2 (body))))))

 - (explain-all)

   List the *entire* explanation database (could be lots!!)

COMMENTS:
 a. (every Car has (parts ((a Engine [Car1]))))
 b. (a Car with (parts ((a Engine [Car1]))))  -> _Car12

For a., [Car1] is converted to structure (comm [Car1] Self) so that we
can catch "Self".

For b., [Car1] is converted to structure (comm [Car1] _Car12), again catching
Self -- this helps with prototypes also, so that as the prototype is cloned,
the comment is cloned also.|#
;;;; ======================================================================
;;;;		SOURCES:
;;;;  A source denotes the source of an expression.
;;;;		It's format is: (@ <class> <slot> ... )
;;;; ======================================================================
#|SOURCES *NOT* allowed on
	- &, &&, &+ structures
	- structured list vals (:triple ...)
		otherwise a (desource-top-level ...) doesn't prune them all

ALSO: I aggressively decomment and desource constraints in 
;(defun find-constraints-in-exprs (exprs) 
;  (decomment (find-constraints exprs 'plural)))

In an ideal world, it'd be better to pass these comments back with the constraints
for tracking down where they came from, but the constraint engine won't handle that
for now!|#
(TRACE-LISP (DEFINE SOURCEP (TAG) (trace-defun 'SOURCEP (TAG) (RET (AND (LISTP TAG) (EQ (FIRST TAG) '@))))))
;;;; (source-path '(@ Car parts Engine)) -> (Car parts Engine)
;;;; GIVEN: a source data structure
;;;; RETURN: the actual path the source denotes
;;;; ASSUME sourcep test has already been passed
(TRACE-LISP (DEFINE SOURCE-PATH (SOURCE) (trace-defun 'SOURCE-PATH (SOURCE) (RET (REST SOURCE)))))
;;;; Find the class of origin
(TRACE-LISP (DEFINE ORIGINATED-FROM-CLASS (SOURCE) (trace-defun 'ORIGINATED-FROM-CLASS (SOURCE) (RET (SECOND SOURCE)))))
;;;; Cat -> [@Cat]
(TRACE-LISP (DEFINE MAKE-SOURCE (CLASS) (trace-defun 'MAKE-SOURCE (CLASS) (RET (LIST '@ CLASS)))))
(TRACE-LISP (DEFINE ADD-TO-SOURCE (SOURCE ITEM) (trace-defun 'ADD-TO-SOURCE (SOURCE ITEM) (RET (APPEND SOURCE (LIST ITEM))))))
;;;; Neah, parenthesizing and deparenthesizing causes too many problems.
;;;; Just refuse to parenthesize stuff in the first place.
;;;; [1] we want to ALLOW SME to assert things like: (;$explanation (;$:triple ?f ?s ?v) ?explanations), which include the @.
;;;;     So in this special case, let the sources (@) go through.
(TRACE-LISP
 (DEFINE DESOURCE (EXPR)
  (trace-defun 'DESOURCE (EXPR)
   (RET (COND ((AND (LISTP EXPR) (OR *RECORD-EXPLANATIONS* *RECORD-SOURCES*)) (REMOVE-IF #'SOURCEP (MAPCAR #'DESOURCE EXPR))) (T EXPR))))))
;; in header.lisp
;; (defparameter *developer-mode* nil)
;;;; ----------
;;;; For my own debugging
(TRACE-LISP (DEFINE DESOURCE0 (EXPR) (trace-defun 'DESOURCE0 (EXPR) (RET (COND (*DEVELOPER-MODE* EXPR) (T (DESOURCE1 EXPR)))))))
(TRACE-LISP
 (DEFINE DESOURCE1 (EXPR)
  (trace-defun 'DESOURCE1 (EXPR)
   (RET
    (COND ((LISTP EXPR) (COND ((AND (EQ (LENGTH EXPR) 3)  (EQ (FIRST EXPR) '|comm|)) (SECOND EXPR)) (T (REMOVE-IF #'SOURCEP (MAPCAR #'DESOURCE1 EXPR)))))
     (T EXPR))))))
;;;; ----------
(TRACE-LISP (DEFINE SOURCES (EXPR) (trace-defun 'SOURCES (EXPR) (RET (COND ((LISTP EXPR) (REMOVE-IF-NOT #'SOURCEP EXPR)))))))
;;;; ======================================================================
;;;;		MANIPULATING COMMENTS
;;;; ======================================================================
(TRACE-LISP (DEFCONSTANT *COMMENT-MARKER-CHAR* #\[))
(TRACE-LISP (DEFINE COMMENT-TAGP (TAG) (trace-defun 'COMMENT-TAGP (TAG) (RET (OR (INTERNAL-COMMENTP TAG) (USER-COMMENTP TAG))))))
(TRACE-LISP
 (DEFINE COMMENT-OR-SOURCEP (TAG) (trace-defun 'COMMENT-OR-SOURCEP (TAG) (RET (OR (INTERNAL-COMMENTP TAG) (SOURCEP TAG) (USER-COMMENTP TAG))))))
(TRACE-LISP (DEFINE INTERNAL-COMMENTP (TAG) (trace-defun 'INTERNAL-COMMENTP (TAG) (RET (AND (LISTP TAG) (EQ (FIRST TAG) '|comm|))))))
(TRACE-LISP
 (DEFINE USER-COMMENTP (TAG)
  (trace-defun 'USER-COMMENTP (TAG) (RET (AND (SYMBOLP TAG) (CHAR= (CL-FIRST-CHAR (SYMBOL-NAME TAG)) *COMMENT-MARKER-CHAR*))))))
;;;; ----------
;;;; Only applied to slotsvals at load time, not to anything else
(TRACE-LISP
 (DEFINE CONVERT-COMMENTS-TO-INTERNAL-FORM (EXPR &OPTIONAL SELF)
  (trace-defun 'CONVERT-COMMENTS-TO-INTERNAL-FORM (EXPR SELF)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SELF '|Self|)
     (COND ((INTERNAL-COMMENTP EXPR) EXPR)  ((USER-COMMENTP EXPR) (CONVERT-COMMENT-TO-INTERNAL-FORM EXPR SELF))
      ((LISTP EXPR) (MAPCAR #'(LAMBDA (E) (trace-defun '#:G15777 (E) (RET (CONVERT-COMMENTS-TO-INTERNAL-FORM E SELF)))) EXPR)) (T EXPR)))))))
;;;; [Car1] -> (comm [Car1] Self)
(TRACE-LISP
 (DEFINE CONVERT-COMMENT-TO-INTERNAL-FORM (USER-COMMENT &OPTIONAL SELF)
  (trace-defun 'CONVERT-COMMENT-TO-INTERNAL-FORM (USER-COMMENT SELF)
   (RET (TRACE-PROGN (SUBLISP-INITVAR SELF '|Self|) `(|comm| ,USER-COMMENT ,SELF))))))
;;;; ----------
;;;; USER(3): (decomment '(cat [1] (dog [3] ([4] [45] man))))
;;;; (cat (dog (man)))
(TRACE-LISP
 (DEFINE DECOMMENT (EXPR &REST LKEYS)
  (trace-defun 'DECOMMENT (EXPR LKEYS)
   (RET
    (CLET (RETAIN-COMMENTSP) (COND ((AND (LISTP EXPR) (CNOT RETAIN-COMMENTSP)) (REMOVE-IF #'COMMENT-OR-SOURCEP (MAPCAR #'DECOMMENT EXPR))) (T EXPR)))))))
(TRACE-LISP
 (DEFINE DECOMMENT-TOP-LEVEL (EXPR)
  (trace-defun 'DECOMMENT-TOP-LEVEL (EXPR) (RET (COND ( (LISTP EXPR) (REMOVE-IF #'COMMENT-OR-SOURCEP EXPR)) (T EXPR))))))
;;;; ----------
(TRACE-LISP
 (DEFINE GET-COMMENT-TAGS (EXPR) (trace-defun 'GET-COMMENT-TAGS (EXPR) (RET (COND ((LISTP EXPR) (REMOVE-IF-NOT #'COMMENT-TAGP EXPR)))))))
(TRACE-LISP
 (DEFINE GET-COMMENT-TAGS-RECURSIVE (EXPR)
  (trace-defun 'GET-COMMENT-TAGS-RECURSIVE (EXPR)
   (RET (COND ((COMMENT-TAGP EXPR) (LIST EXPR)) ((LISTP EXPR) (MY-MAPCAN #'GET-COMMENT-TAGS-RECURSIVE EXPR)))))))
;;;; Returns five values
;;;; 	- list of English explanations
;;;;	- list of English justifications
;;;;	- the KM rule
;;;;	- the location part of the KM rule
;;;;	- the expression part of the KM rule
(TRACE-LISP
 (DEFINE GET-COMMENTS (EXPR)
  (trace-defun 'GET-COMMENTS (EXPR)
   (RET
    (COND
     ((LISTP EXPR)
      (CLET
       ((SOURCES (SOURCES EXPR)) (EXPR0 (DESOURCE EXPR)) (SOURCE-PATH (SOURCE-PATH (FIRST SOURCES))) (RULE (BUILD-RULE EXPR))
        (EXPLANATIONS+JUSTIFICATIONS (TRANSPOSE (MAPCAR #'GET-COMMENT (GET-COMMENT-TAGS EXPR)))))
       (COND ((>= (LENGTH SOURCES) 2) (REPORT-ERROR 'NODEBUGGER-ERROR "get-comments: More than one source path ~a (?). Just using first...~%" SOURCES)))
       (VALUES (CL-REMOVE NIL (FIRST EXPLANATIONS+JUSTIFICATIONS)) (CL-REMOVE NIL (SECOND EXPLANATIONS+JUSTIFICATIONS)) RULE SOURCE-PATH EXPR0))))))))
;;;; ----------
;;;; USER(22): (print (build-rule ';$(a Distributor (@ Car parts Engine parts))))
;;;; (every Car has (parts ((a Engine with (parts ((a Distributor)))))))
;;;;
;;;; [1] New: 1/10/01 - allow rules to be explicitly stored too (for Shaken) - result is then reflexive:
;;;; USER(22): (print (build-rule ';$(every Car has (parts ((a Engine with (parts ((a Distributor)))))))))
;;;; (every Car has (parts ((a Engine with (parts ((a Distributor)))))))
(TRACE-LISP
 (DEFINE BUILD-RULE (EXPR0)
  (trace-defun 'BUILD-RULE (EXPR0)
   (RET
    (COND ((EQ (FIRST EXPR0) '|every|) EXPR0) 
     (T
      (CLET ((SOURCE (FIRST (SOURCES EXPR0)))  (EXPR (DESOURCE EXPR0)) (SOURCE-PATH (SOURCE-PATH SOURCE)))
       (COND
        ((OR (NULL SOURCE-PATH) (ODDP (LENGTH SOURCE-PATH)))
         (COND
          ((ODDP (LENGTH SOURCE-PATH))
           (REPORT-ERROR 'NODEBUGGER-ERROR "build-rule: Odd path length for path ~a! Don't know how to build a rule...~%" SOURCE-PATH)))
         (LIST '|<location unknown>| EXPR))
        (T `(|every| ,(FIRST SOURCE-PATH) |has| (,(SECOND SOURCE-PATH) (,(BUILD-EMBEDDED-VAL (REST (REST SOURCE-PATH)) EXPR)))))))))))))
;;;; Returns an (a ... with ...) structure
(TRACE-LISP
 (DEFINE BUILD-EMBEDDED-VAL (PATH EXPR)
  (trace-defun 'BUILD-EMBEDDED-VAL (PATH EXPR)
   (RET (COND ((NULL PATH) EXPR) (T `(|a| ,(FIRST PATH) |with| (,(SECOND PATH) (,(BUILD-EMBEDDED-VAL (REST (REST PATH)) EXPR))))))))))
;;;; ------------------------------
(TRACE-LISP
 (DEFINE CL-COMMENT (COMMENT-TAG DATA)
  (trace-defun 'CL-COMMENT (COMMENT-TAG DATA)
   (RET
    (COND
     ((CNOT (COMMENT-TAGP COMMENT-TAG))
      (REPORT-ERROR 'USER-ERROR "~a~%       Comment tag ~a should be a symbol in square brackets, e.g. [Car1]!" `(|comment| ,COMMENT-TAG ,DATA)
       COMMENT-TAG))
     (T (KM-ADD-TO-KB-OBJECT-LIST COMMENT-TAG) (CSETF (GET COMMENT-TAG 'COMMENT) DATA)))))))
(TRACE-LISP
 (DEFINE SHOW-COMMENT (COMMENT-TAG)
  (trace-defun 'SHOW-COMMENT (COMMENT-TAG)
   (RET
    (COND
     ((CNOT (COMMENT-TAGP COMMENT-TAG))
      (REPORT-ERROR 'USER-ERROR "~a~%       Comment tag ~a should be a symbol in square brackets, e.g. [Car1]!" `(|show-comment| ,COMMENT-TAG)
       COMMENT-TAG))
     (T (GET COMMENT-TAG 'COMMENT)))))))
#|This version returns the *whole* ("a" "b" (:set (the part of Self))):
 
KM> (comment [x] "a" "b" (:set (the part of Self)))

USER: (get 'X[x]X 'comment)
("a" "b" (:set (the part of Self)))

CL-USER(19): (get-comment 'X$(comm [x] _Car1))		; internal form of comment
("a" "b" (:set (the part of _Car1)))		

CL-USER(20): (get-comment2 'X$(comm [x] _Car1) 'call)
"b"

CL-USER(21): (get-comment2 'X$(comm [x] _Car1) 'exit)
"a"|#
;;;; [1] Should no longer arise -- *all* comments are converted to internal form
(TRACE-LISP
 (DEFINE GET-COMMENT (COMMENT-TAG)
  (trace-defun 'GET-COMMENT (COMMENT-TAG)
   (RET
    (COND 
     ((INTERNAL-COMMENTP COMMENT-TAG)
      (CLET ((CL-COMMENT (GET (SECOND COMMENT-TAG) 'COMMENT)) (SELF (THIRD COMMENT-TAG))) (BIND-SELF CL-COMMENT SELF))))))))
;;;; This version you pass mode (call/exit/fail/subgoals), and the appropriate element of the (comment ...) list is returned
;;;; [1] Should no longer arise -- *all* comments are converted to internal form
(TRACE-LISP
 (DEFINE GET-COMMENT2 (COMMENT-TAG MODE)
  (trace-defun 'GET-COMMENT2 (COMMENT-TAG MODE)
   (RET
    (COND 
     ((INTERNAL-COMMENTP COMMENT-TAG)
      (CLET ((SELF (THIRD COMMENT-TAG)) (COMMENTS (BIND-SELF (GET (SECOND COMMENT-TAG) 'COMMENT) SELF)))
       (CASE MODE (CALL (SECOND COMMENTS)) ((EXIT FAIL) (FIRST COMMENTS)) (SUBGOALS (THIRD COMMENTS))))))))))
;;;; ======================================================================
;;;;		RECOGNIZING SPECIAL TYPES OF COMMENTS
;;;; ======================================================================
;;;; (x has ...)
;;;; (every x has ...)
;;;; (in-situation (x has ...))
(TRACE-LISP
 (DEFINE KM-ASSERTION-EXPR (EXPR)
  (trace-defun 'KM-ASSERTION-EXPR (EXPR)
   (RET
    (AND (LISTP EXPR)
     (OR (CL-INTERSECTION EXPR '(|a| |an| |some| |has| |has-definition| |now-has| == &)) 
      (AND (EQ (FIRST EXPR) '|in-situation|) (KM-ASSERTION-EXPR (THIRD EXPR)))))))))
;;;; In interpreter.lisp, we strip the assignment data off expressions EXCEPT for
;;;; certain special forms, where the data is stripped off lower down in the processing.
;;;; [PS Better make sure there are special handlers to deal with these cases!!]
;;;; These special forms are:
;;;;	1. (:set a b c)
;;;; NEW: No, we're going to remove handling of sets, so we consider "record it later" here, but then don't bother later.
;;;;	 Hmm...
(TRACE-LISP
 (DEFINE RECORD-EXPLANATION-LATER (EXPR)
  (trace-defun 'RECORD-EXPLANATION-LATER (EXPR)
   (RET (AND *RECORD-EXPLANATIONS* (OR (AND (KM-SETP EXPR) (NOTEVERY #'ATOM (REST EXPR)))  (AND (LISTP EXPR) (CL-MEMBER (SECOND EXPR) '(&& & &+)))))))))
;;;; ======================================================================
;;;; 		MAINTAINING THE EXPLANATION DATABASE ITSELF
;;;; ======================================================================
#|explanations are triples <slot val explanation>
target = (the <slot> of <instance>) - we ASSUME this is GUARANTEED by this point.
Or this? (defun record-explanation-for (target val expr &key (situation (cond ((existential-exprp expr) *global-situation*) 
										(t (curr-situation)))))
[1] If call (km0 'X$_Expose2), km0 *will* call km1 if 'X$_Expose2 dereferences to something else e.g. _Expose3. BUT we don't
want to record _Expose3 as an explanation for _Expose2, hence the listp test.
[2] was getting combinatorial: a b c ((:set m1) (:set m1 m2) (:set m1 m2 m3) ... (:set m1 m2 m3 c))
    No! We *do* need :set!
	(every Amino-Acid-Sequence has 
	  (has-region ((a Carboxyl-Terminus (@ Amino-Acid-Sequence has-region))
	               (a Amino-Terminus (@ Amino-Acid-Sequence has-region)))))

[_Situation21] KM> (the has-region of _Enzyme36)
1 -> (the has-region of _Enzyme36)
1  (2) From inheritance: (:set (a Carboxyl-Terminus) (a Amino-Terminus))
...
 0: (record-explanation-for (XtheX Xhas-regionX XofX X_Enzyme39X) X_Carboxyl-Terminus40X
                            (:XsetX (XaX XCarboxyl-TerminusX (@ XAmino-Acid-SequenceX Xhas-regionX))
                             (XaX XAmino-TerminusX (@ XAmino-Acid-SequenceX Xhas-regionX))))
We can't pair the right set member with the evaluated result, as this information is lost in the interpreter.

[3] Hmm...we remove the :sets if a more specific explanation is available, presumably from the :set being broken up.
new-explanation: (:set a b)   old-explanation (:set a b c)	-> store (:set a b), discard (:set a b c)
new-explanation: a	      old-explanation (:set a b c)	-> store a|#
(TRACE-LISP
 (DEFINE RECORD-EXPLANATION-FOR (TARGET VAL EXPR0 &REST LKEYS)
  (trace-defun 'RECORD-EXPLANATION-FOR (TARGET VAL EXPR0 LKEYS)
   (RET
    (CLET (SITUATION) (init-keyval SITUATION (CURR-SITUATION))
     (COND
      (*RECORD-EXPLANATIONS*
       (CLET ((EXPR (MODIFY-SET-EXPLANATION EXPR0)))
        (COND
         ((AND (LISTP EXPR)  VAL
           (OR (CNOT (KM-SETP EXPR))
            (NOTEVERY #'(LAMBDA (VAL) (trace-defun '#:G15778 (VAL) (RET (IS-KM-TERM (DESOURCE VAL))))) (SET-TO-LIST EXPR)))
            (OR (CNOT (KM-TRIPLEP VAL)) (CNOT (NULL (ARG3OF VAL)))))
          
          (CLET
           ((SLOT (SECOND TARGET)) (INSTANCE (FOURTH TARGET)) (EXPLANATION (LIST INSTANCE SLOT VAL EXPR))
            (OLD-EXPLANATIONS (GET-ALL-EXPLANATIONS INSTANCE SLOT :SITUATION SITUATION)))
           (NOTE-EXPR-IS-USED EXPR INSTANCE SLOT VAL SITUATION) 
           (COND ((CL-MEMBER EXPLANATION OLD-EXPLANATIONS :TEST #'CL-EQUAL)) 
            (T (PUT-EXPLANATIONS INSTANCE SLOT (UPDATE-EXPLANATIONS OLD-EXPLANATIONS EXPLANATION) :SITUATION SITUATION))))))))))))))
;;;; ----------
;;;; Slightly complex, to minimise storage of :sets
(TRACE-LISP
 (DEFINE UPDATE-EXPLANATIONS (OLD-EXPLANATIONS EXPLANATION)
  (trace-defun 'UPDATE-EXPLANATIONS (OLD-EXPLANATIONS EXPLANATION)
   (RET
    (COND ((ENDP OLD-EXPLANATIONS) (LIST EXPLANATION))
     (T
      (CLET ((OLD-EXPLANATION (FIRST OLD-EXPLANATIONS)))
       (COND
        ((CNOT (CL-EQUAL (SUBSEQ OLD-EXPLANATION 0 3) (SUBSEQ EXPLANATION 0 3)))
         (CONS OLD-EXPLANATION (UPDATE-EXPLANATIONS (REST OLD-EXPLANATIONS) EXPLANATION)))
        (T
         (CLET ((EXPR (FOURTH EXPLANATION)) (OLD-EXPR (FOURTH OLD-EXPLANATION)))
          (COND 
           ((KM-SETP EXPR) 
            (COND
             ((CNOT (KM-SETP OLD-EXPR)) 
              (COND ((CL-MEMBER (DESOURCE OLD-EXPR) EXPR :TEST #'CL-EQUAL) OLD-EXPLANATIONS) 
               (T (CONS OLD-EXPLANATION (UPDATE-EXPLANATIONS (REST OLD-EXPLANATIONS) EXPLANATION)))))
             ((CL-SUBSETP EXPR OLD-EXPR :TEST #'CL-EQUAL)  (UPDATE-EXPLANATIONS (REST OLD-EXPLANATIONS) EXPLANATION)) 
             (T (CONS OLD-EXPLANATION (UPDATE-EXPLANATIONS (REST OLD-EXPLANATIONS) EXPLANATION)))))
           ((AND (KM-SETP OLD-EXPR)  (CL-MEMBER (DESOURCE EXPR) OLD-EXPR :TEST #'CL-EQUAL)) (UPDATE-EXPLANATIONS (REST OLD-EXPLANATIONS) EXPLANATION)) 
           (T (CONS OLD-EXPLANATION (UPDATE-EXPLANATIONS (REST OLD-EXPLANATIONS) EXPLANATION))))))))))))))
;;;; (:set (a Cat (@ Person pet)) (a Dog (@ Person pet))) -> (:set (a Cat) (A Dog) (@ Person pet))
(TRACE-LISP
 (DEFINE MODIFY-SET-EXPLANATION (EXPR)
  (trace-defun 'MODIFY-SET-EXPLANATION (EXPR)
   (RET
    (COND
     ((KM-SETP EXPR)
      (CLET ((VALS (SET-TO-LIST EXPR)) (SOURCES (CL-REMOVE-DUPLICATES (MY-MAPCAN #'SOURCES VALS) :TEST #'CL-EQUAL)))
       (VALS-TO-VAL (APPEND (DESOURCE VALS) SOURCES))))
     (T EXPR))))))
(TRACE-LISP
 (DEFINE WHY (&OPTIONAL TRIPLE SITUATION)
  (trace-defun 'WHY (TRIPLE SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (COND ((AND (NULL TRIPLE) (NULL *LAST-ANSWER*)) (KM-FORMAT T "There are no answers to explain!~%"))
      ((NULL TRIPLE)
       (CLET
        ((SLOT+FRAMEADD (MINIMATCH *LAST-QUESTION* '(|the| |?slot| |of| |?frameadd|))) (SLOT (FIRST SLOT+FRAMEADD)) (FRAMEADD (SECOND SLOT+FRAMEADD)))
        (COND
         ((CNOT SLOT+FRAMEADD)
          (KM-FORMAT T
           "Which conclusion are you asking about? (Here, I can't guess). Enter in the form 
   	(why (:triple <instance> <slot> <value>))
e.g.
   KM> (why (:triple _Car1 parts _Engine1))~%"))
         (T
          (CLET ((VALUES *LAST-ANSWER*) (INSTANCES (KM0 FRAMEADD))) 
           (KM-FORMAT T "I'll assume you're asking me:~%Why ~a = ~a...~%~%" *LAST-QUESTION* VALUES)
           (MAPC
            #'(LAMBDA (INSTANCE)
               (trace-defun '#:G15779 (INSTANCE)
                (RET
                 (MAPC #'(LAMBDA (VALUE) (trace-defun '#:G15780 (VALUE) (RET (WHY0 `(:|triple| ,INSTANCE ,SLOT ,VALUE) SITUATION)))) VALUES))))
            INSTANCES)
           '(|t|))))))
      (T (WHY0 TRIPLE SITUATION))))))))
#|For example:

KM> (why (:triple *MyCar parts _Engine1))
(:triple *MyCar parts _Engine1 [in *Global]) because:
   ENGLISH: "All cars have engines"
   JUSTIFICATION: "Engines are required for propulsion"
   RULE: ([Fpp] a Engine with (parts ((a Spark-Plug [Vehicle2]))))

   ENGLISH: "A Car"
   JUSTIFICATION: "I said so"
   RULE: (a Engine [Car1])|#
(TRACE-LISP
 (DEFINE WHY0 (TRIPLE &OPTIONAL SITUATION)
  (trace-defun 'WHY0 (TRIPLE SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (CLET
      ((INSTANCE0 (ARG1OF TRIPLE)) (SLOT (ARG2OF TRIPLE)) (VAL0 (ARG3OF TRIPLE)) (INSTANCE (DEREFERENCE INSTANCE0)) (VAL (DEREFERENCE VAL0))
       (ISV-EXPLANATIONS (GET-EXPLANATIONS INSTANCE SLOT VAL SITUATION)))
       (COND ((CNOT (CL-EQUAL INSTANCE INSTANCE0)) (KM-FORMAT T "(~a is bound to ~a)~%" INSTANCE0 INSTANCE)))
      (COND ((CNOT (CL-EQUAL VAL VAL0)) (KM-FORMAT T "(~a is bound to ~a)~%" VAL0 VAL)))
      (COND ((NULL ISV-EXPLANATIONS) (KM-FORMAT T "(:triple ~a ~a ~a [in ~a]) because:~%  (no explanation available)~%" INSTANCE SLOT VAL SITUATION))
       (T
        (MAPC
         #'(LAMBDA (ISV-EXPLANATION)
            (trace-defun '#:G15781 (ISV-EXPLANATION)
             (RET
              (CLET ((I (FIRST ISV-EXPLANATION)) (S (SECOND ISV-EXPLANATION)) (V (THIRD ISV-EXPLANATION)) (EXPLANATIONS (FOURTH ISV-EXPLANATION)))
               (KM-FORMAT T "(:triple ~a ~a ~a [in ~a]) because:~%" I S V SITUATION)
               (MAPC
                #'(LAMBDA (EXPLANATION)
                   (trace-defun '#:G15782 (EXPLANATION)
                    (RET
                     (MULTIPLE-VALUE-BIND (ENGLISH JUSTIFICATION RULE PATH BODY) (GET-COMMENTS EXPLANATION) (DECLARE (IGNORE PATH BODY)) 
                      (COND (JUSTIFICATION (KM-FORMAT T "   ENTRY TEXT: ~a~%" JUSTIFICATION)))
                      (COND (ENGLISH (KM-FORMAT T "   EXIT TEXT: ~a~%" ENGLISH))) (KM-FORMAT T "   RULE: ~a~%" (DESOURCE0 RULE))))))
                EXPLANATIONS)
               (TERPRI)))))
         ISV-EXPLANATIONS)))
      '(|t|)))))))
;;;; ======================================================================
;;;;		GETTING THE EXPLANATIONS FOR A TRIPLE
;;;; ======================================================================
#|(get-explanations i s v) ->
	( (i    s v (<expr11> <expr12> ... <expr1m>))
	  (v invs i (<expr21> <expr22> ... <expr2n>)) )|#
;;;; Note: is **MAPCAN-SAFE**
(TRACE-LISP
 (DEFINE GET-EXPLANATIONS (INSTANCE SLOT VAL &OPTIONAL SITUATION)
  (trace-defun 'GET-EXPLANATIONS (INSTANCE SLOT VAL SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (CL-REMOVE NIL (LIST (GET-EXPLANATIONS0 INSTANCE SLOT VAL SITUATION) (GET-EXPLANATIONS0 VAL (INVERT-SLOT SLOT) INSTANCE SITUATION))))))))
;;;; Returns structure (<instance> <slot> <val> <explanations>)   where <explanations> = (expr*)
#|OLD
(defun get-explanations0 (instance slot val &optional (situation (curr-situation)))
  (let ( (explanations (remove-duplicates (get-explanations1 instance slot val situation) :test X'equal)) )
    (cond (explanations (list instance slot val explanations)))))|#
;;;; NEW: instance-of explanations are a special case, retrieved globally.
(TRACE-LISP
 (DEFINE GET-EXPLANATIONS0 (INSTANCE SLOT VAL &OPTIONAL SITUATION)
  (trace-defun 'GET-EXPLANATIONS0 (INSTANCE SLOT VAL SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (CLET (   (EXPLANATIONS (CL-REMOVE-DUPLICATES (GET-EXPLANATIONS1 INSTANCE SLOT VAL SITUATION) :TEST #'CL-EQUAL)))
      (COND (EXPLANATIONS (LIST INSTANCE SLOT VAL EXPLANATIONS)))))))))
(TRACE-LISP
 (DEFINE GET-EXPLANATIONS1 (INSTANCE SLOT VAL &OPTIONAL SITUATION)
  (trace-defun 'GET-EXPLANATIONS1 (INSTANCE SLOT VAL SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION))
     (CLET
      ((EXPLANATIONS
        (MAPCAR #'FOURTH
         (REMOVE-IF-NOT #'(LAMBDA (X) (trace-defun '#:G15783 (X) (RET (AND (EQ (SECOND X) SLOT) (CL-EQUAL (THIRD X) VAL)))))
          (GET-ALL-EXPLANATIONS INSTANCE SLOT :SITUATION SITUATION :DEREFERENCEP T))))
       (PROJECTED-FROM-SITUATION
        (SOME
         #'(LAMBDA (EXPLANATION)
            (trace-defun '#:G15784 (EXPLANATION)
             (RET (COND ((AND (LISTP EXPLANATION) (EQ (FIRST EXPLANATION) '|projected-from|)) (SECOND EXPLANATION))))))
          EXPLANATIONS)))
      (COND
       (PROJECTED-FROM-SITUATION
        (APPEND
         (REMOVE-IF
          #'(LAMBDA (EXPLANATION)
             (trace-defun '#:G15785 (EXPLANATION) (RET (AND (LISTP EXPLANATION) (EQ (FIRST EXPLANATION) '|projected-from|)))))
          EXPLANATIONS)
         (GET-EXPLANATIONS1 INSTANCE SLOT VAL PROJECTED-FROM-SITUATION)))
       (T EXPLANATIONS))))))))
;;;; ======================================================================
;;;;        API TO THE EXPLANATION DATABASE: low-level get/put:
;;;; ======================================================================
;;;; 1/11/02: NEW: This now looks *up* into the global situation too, to collect explanations attached to prototypes,
;;;; which get deposited in the global situation even if we're in KM situation-mode.
;;;; 2/8/02: No, this transfer from global to local is done in the interpreter, and only on a demand-driven basis
;;;; 4/13/06: No, let's go back to this, instead of doing the copying in km-slotvals-from-kb
;;;; NOTE: slot is solely to determine the target-situation to look in. slot can be NIL, in which case target-situation 
;;;; is the current situation.
;;;; NEW: Always do a dereferencep in case it's called from Lisp directly
(TRACE-LISP
 (DEFINE GET-ALL-EXPLANATIONS (INSTANCE SLOT &REST LKEYS)
  (trace-defun 'GET-ALL-EXPLANATIONS (INSTANCE SLOT LKEYS)
   (RET
    (CLET (SITUATION DEREFERENCEP) (init-keyval SITUATION (CURR-SITUATION)) (DECLARE (IGNORE DEREFERENCEP))
     (COND
      ((KB-OBJECTP INSTANCE)
       (CLET
        ((TARGET-SITUATION (TARGET-SITUATION SITUATION INSTANCE SLOT))
         (GLOBAL-EXPLANATIONS (GET INSTANCE (CURR-SITUATION-FACET 'EXPLANATION *GLOBAL-SITUATION*)))
         (ALL-EXPLANATIONS
          (COND ((EQ TARGET-SITUATION *GLOBAL-SITUATION*) GLOBAL-EXPLANATIONS)
           (T (APPEND (GET INSTANCE (CURR-SITUATION-FACET 'EXPLANATION TARGET-SITUATION)) GLOBAL-EXPLANATIONS)))))
        (CL-REMOVE-DUPLICATES (DEREFERENCE ALL-EXPLANATIONS) :TEST #'CL-EQUAL :FROM-END T)))))))))
;;	   (cond (dereferencep (remove-duplicates (dereference all-explanations) :test ;'equal :from-end t))
;;		 (t (remove-duplicates all-explanations :test ;'equal :from-end t)))))))
;; OLD VERSION
;;(defun get-all-explanations (instance slot &key (situation (curr-situation)) dereferencep)
;;  (cond ((kb-objectp instance)
;;	 (let ((target-situation (target-situation situation instance slot)))
;;	   (cond (dereferencep (dereference (get instance (curr-situation-facet 'explanation target-situation))))
;;		 (t (get instance (curr-situation-facet 'explanation target-situation))))))))
(TRACE-LISP
 (DEFINE PUT-EXPLANATIONS (INSTANCE SLOT EXPLANATIONS &REST LKEYS)
  (trace-defun 'PUT-EXPLANATIONS (INSTANCE SLOT EXPLANATIONS LKEYS)
   (RET
    (CLET (SITUATION) (init-keyval SITUATION (CURR-SITUATION))
     (COND ((CNOT (KB-OBJECTP INSTANCE)) (REPORT-ERROR 'PROGRAM-ERROR "Attempt to put an explanation associated with a non-kb-object ~a!~%" INSTANCE))
      (T (CSETF (GET INSTANCE (CURR-SITUATION-FACET 'EXPLANATION (TARGET-SITUATION SITUATION INSTANCE SLOT))) EXPLANATIONS))))))))
(TRACE-LISP
 (DEFINE DELETE-EXPLANATIONS (INSTANCE SLOT VAL &REST LKEYS)
  (trace-defun 'DELETE-EXPLANATIONS (INSTANCE SLOT VAL LKEYS)
   (RET
    (CLET (SITUATION) (init-keyval SITUATION (CURR-SITUATION))
     (COND
      ((KB-OBJECTP INSTANCE)
       (CLET
        ((EXPLANATIONS (GET-ALL-EXPLANATIONS INSTANCE SLOT :SITUATION SITUATION :DEREFERENCEP T))
         (NEW-EXPLANATIONS
          (REMOVE-IF
           #'(LAMBDA (EXPLANATION)
              (trace-defun '#:G15786 (EXPLANATION)
               (RET (AND (EQ (FIRST EXPLANATION) INSTANCE)  (EQ (SECOND EXPLANATION) SLOT) (EQ (THIRD EXPLANATION) VAL)))))
           EXPLANATIONS)))
        (PUT-EXPLANATIONS INSTANCE SLOT NEW-EXPLANATIONS)))))))))
;;;; ======================================================================
;;;;	UTILTIES - combine independently collected explanation structures
;;;; ======================================================================
;;;; Here we merge explanations for the SAME triple, but from DIFFERENT situations, into a single list.
;;;; USER(11): (combine-explanations '( (i s v (e1 e2)) (i s2 v2 (e3)) (i s v (e4 e1)) (i s2 v3 (e5)) (i s2 v2 (e3 e4))))
;;;; ((i s v (e2 e4 e1)) (i s2 v2 (e4 e3)) (i s2 v3 (e5)))
(TRACE-LISP
 (DEFINE COMBINE-EXPLANATIONS (EXPLANATIONS)
  (trace-defun 'COMBINE-EXPLANATIONS (EXPLANATIONS)
   (RET
    (COND ((ENDP EXPLANATIONS) NIL)
     (T
      (CLET
       ((EXPLANATION (FIRST EXPLANATIONS)) (INSTANCE (FIRST EXPLANATION)) (SLOT (SECOND EXPLANATION)) (VALUE (THIRD EXPLANATION))
        (EXPRS (FOURTH EXPLANATION))
        (ADDITIONAL-EXPLANATIONS
         (REMOVE-IF-NOT
          #'(LAMBDA (ADDITIONAL-EXPLANATION)
             (trace-defun '#:G15787 (ADDITIONAL-EXPLANATION)
              (RET
               (AND (EQ (FIRST ADDITIONAL-EXPLANATION) INSTANCE) (EQ (SECOND ADDITIONAL-EXPLANATION) SLOT) (EQ (THIRD ADDITIONAL-EXPLANATION) VALUE)))))
          (REST EXPLANATIONS))))
       (COND
        (ADDITIONAL-EXPLANATIONS
         (CONS (LIST INSTANCE SLOT VALUE (REMOVE-DUPLICATES (APPLY #'APPEND (CONS EXPRS (MAPCAR #'FOURTH ADDITIONAL-EXPLANATIONS))) :TEST #'EQUAL))
          (COMBINE-EXPLANATIONS (SET-DIFFERENCE (REST EXPLANATIONS) ADDITIONAL-EXPLANATIONS :TEST #'EQUAL))))
        (T (CONS EXPLANATION (COMBINE-EXPLANATIONS (REST EXPLANATIONS))))))))))))
;;;; ======================================================================
;;;;		MERGING EXPLANATIONS (AFTER UNIFICATION)
;;;; ======================================================================
#|When two instances get unified, we better unify their explanations too!|#
;;;; Done when (in fact, immediately after) i1 and i2 are bound together.
;;;; This procedure is (only) called by (bind i1 i2) in frame-io.lisp, binding i1 to point to i2.
;;;; Urgh - need to scan the entire space of situations. Could make this more efficient by some lazy method, but it'll do for now.
(TRACE-LISP
 (DEFINE MERGE-EXPLANATIONS (I1 I2)
  (trace-defun 'MERGE-EXPLANATIONS (I1 I2)
   (RET
    (COND
     ((AND (KB-OBJECTP I1) (KB-OBJECTP I2))
      (CLET ((DOMINANT-I (DEREFERENCE I1))  (RECESSIVE-I (FIRST (CL-REMOVE DOMINANT-I (LIST I1 I2)))))
       (COND ((NULL RECESSIVE-I) (REPORT-ERROR 'USER-WARNING "Null recessive-i encountered in merge-explanations!~%"))
        (T
         (MAPC
          #'(LAMBDA (SITUATION)
             (trace-defun '#:G15788 (SITUATION)
              (RET
               (CLET ((RECESSIVE-EXPLNS (GET-ALL-EXPLANATIONS RECESSIVE-I NIL :SITUATION SITUATION)))
                (COND
                 (RECESSIVE-EXPLNS
                  (CLET
                   ((DOMINANT-EXPLNS (GET-ALL-EXPLANATIONS DOMINANT-I NIL :SITUATION SITUATION))
                    (NEW-EXPLNS (SET-DIFFERENCE RECESSIVE-EXPLNS DOMINANT-EXPLNS :TEST #'CL-EQUAL)))
                   (COND (NEW-EXPLNS (PUT-EXPLANATIONS DOMINANT-I NIL (APPEND DOMINANT-EXPLNS NEW-EXPLNS) :SITUATION SITUATION))))))))))
          (ALL-ACTIVE-SITUATIONS)))))))))))
;;;; ----------  
(TRACE-LISP
 (DEFINE EXPLAIN-ALL (&REST LKEYS)
  (trace-defun 'EXPLAIN-ALL (LKEYS)
   (RET
    (CLET (INCLUDE-GLOBALP) (init-keyval INCLUDE-GLOBALP T)
     (MAPC
      #'(LAMBDA (INSTANCE)
         (trace-defun '#:G15789 (INSTANCE)
          (RET
           (MAPC
            #'(LAMBDA (SITUATION)
               (trace-defun '#:G15790 (SITUATION)
                (RET
                 (CLET
                  ((EXPLANATIONS (GET-ALL-EXPLANATIONS INSTANCE NIL :SITUATION SITUATION :DEREFERENCEP T))
                   (SLOTS (CL-REMOVE-DUPLICATES (MAPCAR #'SECOND EXPLANATIONS))))
                  (MAPC
                   #'(LAMBDA (SLOT)
                      (trace-defun '#:G15791 (SLOT)
                       (RET
                        (CLET
                         ((SLOT-EXPLANATIONS (REMOVE-IF-NOT #'(LAMBDA (X) (trace-defun '#:G15792 (X) (RET (EQ (SECOND X) SLOT)))) EXPLANATIONS))
                          (VALS (CL-REMOVE-DUPLICATES (MAPCAR #'THIRD SLOT-EXPLANATIONS))))
                         (MAPC
                          #'(LAMBDA (VAL)
                             (trace-defun '#:G15793 (VAL)
                              (RET
                               (KM-FORMAT T "~%(:triple ~a ~a ~a [in ~a]) because:~%~{   ~a~%~}" INSTANCE SLOT VAL SITUATION #|NEW|#
                                (MAPCAR #'BUILD-RULE
                                 (MAPCAR #'FOURTH
                                  (REMOVE-IF-NOT #'(LAMBDA (X) (trace-defun '#:G15794 (X) (RET (EQ (THIRD X) VAL)))) SLOT-EXPLANATIONS)))))))
                          VALS)))))
                   SLOTS)))))
            (COND (INCLUDE-GLOBALP (ALL-ACTIVE-SITUATIONS)) (T (CL-REMOVE *GLOBAL-SITUATION* (ALL-ACTIVE-SITUATIONS))))))))
      (GET-ALL-CONCEPTS))
     T)))))
#| [1] For Shaken, *leave* explanations on the prototypes. They should stay.
(defun clear-explanations ()
  (let ( (facets (cons 'explanation 
		       (mapcar X'(lambda (situation)
				   (curr-situation-facet 'explanation situation))
			       (all-situations)))) )
    (mapc X'(lambda (frame)
	      (cond ((not (protoinstancep frame))		; [1]
		     (mapc X'(lambda (facet)
			       (remprop frame facet))
			   facets))))
	  (get-all-concepts))
    t))

;;; *Leave* the prototype-style explanations, and also for Shaken the ((@ SME entered)) 
;;; explanation flag. Everything else can be removed.
(defun clear-explanations ()
  (let ( (explanation-facets (cons 'explanation
				   (mapcar X'(lambda (situation)
					       (curr-situation-facet 'explanation situation))
					   (all-situations))) )
    (mapc X'(lambda (frame)
	      (mapc X'(lambda (explanation-facet)
			(let* ( (old-explanations (get frame explanation-facet)) 
				(new-explanations 
				 (remove-if
				  X'(lambda (explanation)
				      (standard-explanation-expr (fourth explanation)))
				  old-explanations)) )
			  (cond ((not new-explanations) (remprop frame explanation-facet))
				((not (equal old-explanations new-explanations))
				 (setf (get frame explanation-facet) new-explanations)))))
		    explanation-facets))
	  (get-all-concepts))
    t))|#
;;;; REVISED (AGAIN): Just leave the *GLOBAL* explanations untouched (conditionally)
;;;; [1] For Shaken, *leave* explanations on the prototypes. They should stay.
(TRACE-LISP
 (DEFINE CLEAR-EXPLANATIONS (&REST LKEYS)
  (trace-defun 'CLEAR-EXPLANATIONS (LKEYS)
   (RET
    (CLET (CLEAR-GLOBALP)
     (CLET
      ((FACETS
        (MAPCAR #'(LAMBDA (SITUATION) (trace-defun '#:G15795 (SITUATION) (RET (CURR-SITUATION-FACET 'EXPLANATION SITUATION))))
         (COND (CLEAR-GLOBALP (ALL-SITUATIONS)) (T (CL-REMOVE *GLOBAL-SITUATION* (ALL-SITUATIONS)))))))
      (MAPC
       #'(LAMBDA (FRAME)
          (trace-defun '#:G15796 (FRAME)
           (RET (MAPC #'(LAMBDA (FACET) (trace-defun '#:G15797 (FACET) (RET (REMPROP FRAME FACET)))) FACETS))))
       (GET-ALL-CONCEPTS))
      T))))))
(TRACE-LISP (DEFINE EXPLANATIONS NIL (trace-defun 'EXPLANATIONS NIL (RET (CSETQ *RECORD-EXPLANATIONS* T)))))
(TRACE-LISP (DEFINE NO-EXPLANATIONS NIL (trace-defun 'NO-EXPLANATIONS NIL (RET (CSETQ *RECORD-EXPLANATIONS* NIL)))))
;;;; (a Engine (@ Car parts)) is standard, i.e. from a standard KB frame
;;;; (every Car has (parts ((a Engine)))) is not (comes from Shaken), neither is ((@ SME entered))
(TRACE-LISP
 (DEFINE STANDARD-EXPLANATION-EXPR (EXPR)
  (trace-defun 'STANDARD-EXPLANATION-EXPR (EXPR) (RET (AND (LISTP EXPR) (NEQ (FIRST EXPR) '|every|) (CNOT (SOURCEP (FIRST EXPR))))))))
;;;; ---------- 
;;;; New function (not used):
;;;; [1] For Shaken, *leave* explanations on the prototypes. They should stay. But clober everything else.
(TRACE-LISP
 (DEFINE CLEAR-ALL-EXPLANATIONS NIL
  (trace-defun 'CLEAR-ALL-EXPLANATIONS NIL
   (RET
    (CLET ((FACETS (CONS 'EXPLANATION (MAPCAR #'(LAMBDA (SITUATION) (CURR-SITUATION-FACET 'EXPLANATION SITUATION)) (ALL-SITUATIONS)))))
     (MAPC
      #'(LAMBDA (FRAME)
         (trace-defun '#:G15798 (FRAME)
          (RET
           (COND
            ((CNOT (PROTOINSTANCEP FRAME))  (MAPC #'(LAMBDA (FACET) (trace-defun '#:G15799 (FACET) (RET (REMPROP FRAME FACET)))) FACETS))))))
      (GET-ALL-CONCEPTS))
     T)))))
;;;; ======================================================================
;;;;		OLD METHOD FOR CACHING EXPLANATIONS - remove this, ultimately
;;;; ======================================================================
;;;; Handle for clear-cached-explanations
(TRACE-LISP (DEFVAR *INSTANCES-WITH-CACHED-EXPLANATIONS* NIL))
;;(defun cache-explanation-for (val expr0)
;;  (declare (ignore val expr0))
;;  nil)
(TRACE-LISP
 (DEFINE CACHE-EXPLANATION-FOR (VAL EXPR0)
  (trace-defun 'CACHE-EXPLANATION-FOR (VAL EXPR0)
   (RET
    (COND
     ((AND (KB-OBJECTP VAL) (EXISTENTIAL-EXPRP EXPR0)) 
      (CLET ((EXPLANATIONS (DEREFERENCE (GET VAL 'CACHED-EXPLANATIONS)))  (EXPR (DECOMMENT EXPR0)))
       (COND ((CNOT (CL-MEMBER VAL *INSTANCES-WITH-CACHED-EXPLANATIONS*)) (PUSH VAL *INSTANCES-WITH-CACHED-EXPLANATIONS*)))
       (OR (CL-MEMBER EXPR EXPLANATIONS :TEST #'CL-EQUAL) (KM-SETF VAL 'CACHED-EXPLANATIONS (CONS EXPR EXPLANATIONS))))))))))
;; TEMPORARY TEST
;;;; Disable for automatic system
(TRACE-LISP (DEFINE CLEAR-CACHED-EXPLANATIONS NIL (trace-defun 'CLEAR-CACHED-EXPLANATIONS NIL (RET NIL))))
;;  (mapc ;'(lambda (instance) 
;;	    (km-setf instance 'cached-explanations nil))
;;	*instances-with-cached-explanations*)
;;  (setq *instances-with-cached-explanations* nil))
;;;; Rename to avoid collisions.
(TRACE-LISP
 (DEFINE CLEAR-EVALUATION-CACHE NIL
  (trace-defun 'CLEAR-EVALUATION-CACHE NIL
   (RET
    (TRACE-PROGN
     (MAPC #'(LAMBDA (INSTANCE) (trace-defun '#:G15800 (INSTANCE) (RET (KM-SETF INSTANCE 'CACHED-EXPLANATIONS NIL))))
      *INSTANCES-WITH-CACHED-EXPLANATIONS*)
     (CSETQ *INSTANCES-WITH-CACHED-EXPLANATIONS* NIL))))))
;;;; RETURNED VALUE IS IRRELEVANT (just NIL / some value)
(TRACE-LISP
 (DEFINE EXPLAINED-BY (INSTANCE EXPR &OPTIONAL TARGET)
  (trace-defun 'EXPLAINED-BY (INSTANCE EXPR TARGET)
   (RET (TRACE-PROGN (DECLARE (IGNORE TARGET)) (CL-MEMBER (DECOMMENT EXPR) (CACHED-EXPLANATIONS-FOR INSTANCE) :TEST #'CL-EQUAL))))))
(TRACE-LISP
 (DEFINE CACHED-EXPLANATIONS-FOR (INSTANCE &OPTIONAL SITUATION)
  (trace-defun 'CACHED-EXPLANATIONS-FOR (INSTANCE SITUATION)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATION (CURR-SITUATION)) (DECLARE (IGNORE SITUATION))
     (COND ((KB-OBJECTP INSTANCE) (DEREFERENCE (GET INSTANCE 'CACHED-EXPLANATIONS)))))))))
;; TEMPORARY
;;;; Done when (in fact, immediately after) i1 and i2 are bound together
(TRACE-LISP
 (DEFINE MERGE-CACHED-EXPLANATIONS (I1 I2)
  (trace-defun 'MERGE-CACHED-EXPLANATIONS (I1 I2)
   (RET
    (COND
     ((AND (KB-OBJECTP I1) (KB-OBJECTP I2))
      (CLET
       ((MERGED-I (DEREFERENCE I1))
        (MERGED-CACHED-EXPLANATIONS
         (CL-REMOVE-DUPLICATES (APPEND (DEREFERENCE (GET I1 'CACHED-EXPLANATIONS)) (DEREFERENCE (GET I2 'CACHED-EXPLANATIONS))) :TEST #'CL-EQUAL)))
       (KM-SETF MERGED-I 'CACHED-EXPLANATIONS MERGED-CACHED-EXPLANATIONS))))))))
;;;; ======================================================================
;;;;		ANNOTATE WITH SOURCES
;;;; ======================================================================
#|GIVEN 
(annotate-every-expr 'X$
    (every Car has 
	(parts ((a Engine with 
		   (parts ((a Wheel)))))
 	       ((a Seat)))
        (engine ((the Engine parts of Self))))))

RETURN
      (every Car has 
	(parts ((a Engine with 
		   (parts ((a Wheel [@Car]))) [@Car]))
 	       ((a Seat [@Car])))
        (engine ((the Engine parts of Self [@Car]))))|#
;;;; [1] These slots are candidates for access via low-level get-vals, which doesn't filter out the
;;;; source tags.
(TRACE-LISP
 (DEFINE ANNOTATE-SLOTSVALS (SLOTSVALS SOURCE)
  (trace-defun 'ANNOTATE-SLOTSVALS (SLOTSVALS SOURCE)
   (RET
    (COND ((ENDP SLOTSVALS) NIL) ((NULL *RECORD-SOURCES*) SLOTSVALS)
     (T
      (CLET ((SLOTVALS (FIRST SLOTSVALS)))
       (COND
        ((OR (COMMENT-TAGP SLOTVALS) (CL-MEMBER (SLOT-IN SLOTVALS) *BUILT-IN-ATOMIC-VALS-ONLY-SLOTS*)) 
         (CONS SLOTVALS (ANNOTATE-SLOTSVALS (REST SLOTSVALS) SOURCE)))
        (T
         (CLET ((SLOT (SLOT-IN SLOTVALS)) (VALS (VALS-IN SLOTVALS)))
          `((,SLOT ,(ANNOTATE-VALS VALS (ADD-TO-SOURCE SOURCE SLOT))) ,@(ANNOTATE-SLOTSVALS (REST SLOTSVALS) SOURCE))))))))))))
(TRACE-LISP
 (DEFINE ANNOTATE-VALS (VALS SOURCE)
  (trace-defun 'ANNOTATE-VALS (VALS SOURCE)
   (RET (MAPCAR #'(LAMBDA (VAL) (trace-defun '#:G15801 (VAL) (RET (ANNOTATE-VAL VAL SOURCE)))) VALS)))))
#|EXAMPLES:
[1] USER(14): (annotate-val 'X$((a x) & (a y)) '(@))
((a x (@)) & (a y (@)))
[1] USER(15): (annotate-val 'X$((a x) & (a y) & (a z)) '(@))
((a x (@)) & (a y (@)) & (a z (@)))
[1] USER(16): (annotate-val 'X$(((a x)) && ((a y))) '(@))
(((a x (@))) && ((a y (@))))
[1] USER(17): (annotate-val 'X$(((a x)) && ((a y)) && ((a z))) '(@))
(((a x (@))) && ((a y) (@)) && ((a z (@))))
[1] USER(18): (annotate-val 'X$(a Car with (parts ((a Engine)))) '(@))
(a Car with (parts ((a Engine (@ Car parts)))) (@))


(annotate-val 'X$(_Break19 &+
                  (a Break with
                   (next-event
                    ((the some-associated-break-contact of _Car-Accident8))))) '(@))|#
;;;; Note: for &, &+, and && we DON'T record these expressions as justifications, rather their components. So we break them up here
;;;; also during annotation. For other expressions, we DO record them as justifications so DON'T break them up here.
;;;; [1a] (a & b & c) -> (annotate-val 'a) (annotate-val '(b & c))
;;;; [1b] (a & b) -> (annotate-val 'a) (annotate-vals '(b))
;;;; [2a] ((a) && (b) && (c)) -> (annotate-vals '(a)) (annotate-val '((b) && (c)))
;;;; [2b] ((a) && (b)) -> (annotate-vals '(a)) (annotate-vals '((b)))
;;;; [2c] ((a) && (b) [Car1]) -> not allowed!!
;;;; [3] It might be safe to put this back at some point, if we want to track where the constraints came from. But for now let's leave it.
;;;; [1] A few exotic forms still exist which are quoted but not class descriptions, e.g.,:
;;;;    (every Falling-Situation has
;;;;        (assertions ('(the agent of Self) has (feelings (*Scared)))))
(TRACE-LISP
 (DEFINE ANNOTATE-VAL (VAL SOURCE)
  (trace-defun 'ANNOTATE-VAL (VAL SOURCE)
   (RET
    (PROG1
     (COND
      ((OR   (AND (CNOT (LISTP VAL)) (CNOT (KB-OBJECTP VAL)))  (COMMENT-TAGP VAL) (DESCRIPTIONP VAL)  (QUOTED-EXPRESSIONP VAL) #|NEW|#
        (AND (KM-STRUCTURED-LIST-VALP VAL) (CNOT (KM-TRIPLEP VAL))) (CONSTRAINT-EXPRP VAL))
        VAL)
      ((KB-OBJECTP VAL) (ATTACH-SOURCE-TO-EXPR VAL SOURCE))
      ((AND (LISTP (DECOMMENT-TOP-LEVEL VAL)) (CL-MEMBER (FIRST (DECOMMENT-TOP-LEVEL VAL)) '(|a| |every|)))
       (CLET
        ((ANNOTATED-EVERY-EXPR (ANNOTATE-EVERY-EXPR VAL (ADD-TO-SOURCE SOURCE (SECOND (DECOMMENT-TOP-LEVEL VAL)))))
         (EVERY-EXPR-WITH-SOURCE (ATTACH-SOURCE-TO-EXPR ANNOTATED-EVERY-EXPR SOURCE)))
        (NOTE-EXPR-IS-IN-KB EVERY-EXPR-WITH-SOURCE) EVERY-EXPR-WITH-SOURCE))
      ((AND (LISTP VAL) (CL-MEMBER (SECOND VAL) '(& &+)))
       (COND ((CL-MEMBER (FOURTH VAL) '(& &+)) `(,(ANNOTATE-VAL (FIRST VAL) SOURCE) ,(SECOND VAL) ,@(ANNOTATE-VAL (REST (REST VAL)) SOURCE))) 
        (T `(,(ANNOTATE-VAL (FIRST VAL) SOURCE) ,(SECOND VAL) ,@(ANNOTATE-VALS (REST (REST VAL)) SOURCE)))))
      
      ((AND (LISTP VAL) (EQ (SECOND VAL) '&&))
       (COND ((EQ (FOURTH VAL) '&&) `(,(ANNOTATE-VALS (FIRST VAL) SOURCE) ,(SECOND VAL) ,@(ANNOTATE-VAL (REST (REST VAL)) SOURCE))) 
        ((NEQ (LENGTH VAL) 3) (REPORT-ERROR 'USER-ERROR "Badly formed && expr - should be (exprs && exprs) [no comments allowed!]~%   ~a~%" VAL) VAL)
        (T `(,(ANNOTATE-VALS (FIRST VAL) SOURCE) ,(SECOND VAL) ,(ANNOTATE-VALS (THIRD VAL) SOURCE)))))
       ((CL-INTERSECTION VAL '(& && &+)) VAL) 
      (T (CLET ((EXPR-WITH-SOURCE (ATTACH-SOURCE-TO-EXPR VAL SOURCE))) (NOTE-EXPR-IS-IN-KB EXPR-WITH-SOURCE) EXPR-WITH-SOURCE))))))))
(TRACE-LISP
 (DEFINE ATTACH-SOURCE-TO-EXPR (EXPR SOURCE)
  (trace-defun 'ATTACH-SOURCE-TO-EXPR (EXPR SOURCE)
   (RET (COND ((AND (LISTP EXPR) (CNOT (SOME #'SOURCEP EXPR)))  (APPEND EXPR (LIST SOURCE)))  (T  (LIST EXPR SOURCE)))))))
;; new, we DO annotate atomic values (for Halo)
;;;; expr = ';$(a ...) or ';$(every ...)
(TRACE-LISP
 (DEFINE ANNOTATE-EVERY-EXPR (EVERY-EXPR &OPTIONAL SOURCE SEARCH-FOR)
  (trace-defun 'ANNOTATE-EVERY-EXPR (EVERY-EXPR SOURCE SEARCH-FOR)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SEARCH-FOR 'EVERY)
     (OR (ANNOTATE-EVERY-EXPR0 EVERY-EXPR SOURCE SEARCH-FOR)
      (REPORT-ERROR 'USER-ERROR "annotate-every-expr: Badly structured every/a expression ~a!~%" EVERY-EXPR)))))))
(TRACE-LISP
 (DEFINE ANNOTATE-EVERY-EXPR0 (EVERY-EXPR &OPTIONAL SOURCE SEARCH-FOR)
  (trace-defun 'ANNOTATE-EVERY-EXPR0 (EVERY-EXPR SOURCE SEARCH-FOR)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SEARCH-FOR 'EVERY)
     (CLET ((FIRST-EL (FIRST EVERY-EXPR)))
      (COND ((NULL EVERY-EXPR) NIL) ((COMMENT-TAGP FIRST-EL) (CONS FIRST-EL (ANNOTATE-EVERY-EXPR0 (REST EVERY-EXPR) SOURCE SEARCH-FOR)))
       ((AND (EQ SEARCH-FOR 'EVERY) (CL-MEMBER FIRST-EL '(|a| |every|))) (CONS FIRST-EL (ANNOTATE-EVERY-EXPR0 (REST EVERY-EXPR) SOURCE 'CLASS)))
       ((EQ SEARCH-FOR 'CLASS)
        (CLET ((SOURCE0 (OR SOURCE (MAKE-SOURCE FIRST-EL)))) (CONS FIRST-EL (ANNOTATE-EVERY-EXPR0 (REST EVERY-EXPR) SOURCE0 'HAS))))
       ((AND (EQ SEARCH-FOR 'HAS) (CL-MEMBER FIRST-EL '(|called| |uniquely-called|)))
        (CONS FIRST-EL (CONS (SECOND EVERY-EXPR) (ANNOTATE-EVERY-EXPR0 (REST (REST EVERY-EXPR)) SOURCE 'HAS))))
       ((AND (EQ SEARCH-FOR 'HAS) (CL-MEMBER FIRST-EL '(|has| |with|))) (CONS FIRST-EL (ANNOTATE-SLOTSVALS (REST EVERY-EXPR) SOURCE)))
       (T
        (REPORT-ERROR 'USER-ERROR "Syntax error! Encountered at ~a~%  doing:~%  ~a~%" (APPEND '(|...|) EVERY-EXPR '(|...|))
         (STACKED-EXPR (LAST-EL (KM-STACK))))))))))))
;;;; ======================================================================
;;;;		FOR METRIC COLLECTION
;;;; ======================================================================
;;;; I'll leave note-expr-is-encountered here for backward compatibility for
;;;; Sunil, until he starts using note-expr-is-in-kb instead.
(TRACE-LISP (DEFINE NOTE-EXPR-IS-ENCOUNTERED (EXPR) (trace-defun 'NOTE-EXPR-IS-ENCOUNTERED (EXPR) (RET (DECLARE (IGNORE EXPR))))))
(TRACE-LISP (DEFINE NOTE-EXPR-IS-IN-KB (EXPR) (trace-defun 'NOTE-EXPR-IS-IN-KB (EXPR) (RET (NOTE-EXPR-IS-ENCOUNTERED EXPR)))))
;;(defun note-expr-is-in-kb (expr) 
;;  (km-format t "Encountered: ~a~%" (build-rule expr)))
(TRACE-LISP
 (DEFINE NOTE-EXPR-IS-USED (EXPR INSTANCE SLOT VAL SITUATION)
  (trace-defun 'NOTE-EXPR-IS-USED (EXPR INSTANCE SLOT VAL SITUATION) (RET (DECLARE (IGNORE EXPR INSTANCE SLOT VAL SITUATION))))))
;;(defun note-expr-is-used (expr instance slot val situation) 
;;  (declare (ignore instance slot val situation))
;;  (km-format t "Used: ~a~%" (build-rule expr)))
;;;; ======================================================================
;;;;		PLAN B FOR JUSTIFICATIONS
;;;; ======================================================================
;;;; This wrapper simply makes sure that the *last-question* and *last-answer* variables
;;;; don't get changed by the justification process itself!
;;;; e.g., (justify (:triple _Value1 value (:pair 0.45 *molar)))
(TRACE-LISP
 (DEFINE JUSTIFY (&OPTIONAL TRIPLE-EXPR &REST LKEYS)
  (trace-defun 'JUSTIFY (TRIPLE-EXPR LKEYS)
   (RET
    (CLET (SITUATION DEPTH STREAM) (init-keyval STREAM T) (init-keyval DEPTH 0) (init-keyval SITUATION (CURR-SITUATION))
     (MAPC #'(LAMBDA (STRING) (trace-defun '#:G15802 (STRING) (RET (TRACE-PROGN (FORMAT STREAM STRING) (TERPRI STREAM)))))
      (GET-JUSTIFICATION :TRIPLE TRIPLE-EXPR :SITUATION SITUATION :DEPTH DEPTH :FORMAT 'ASCII))
     '(|t|))))))
(TRACE-LISP
 (DEFINE GET-JUSTIFICATION (&REST LKEYS)
  (trace-defun 'GET-JUSTIFICATION (LKEYS)
   (RET
    (CLET (TRIPLE SITUATION DEPTH FORMAT) (init-keyval FORMAT 'XML) (init-keyval DEPTH 0) (init-keyval SITUATION (CURR-SITUATION))
     (CLET ((LAST-QUESTION *LAST-QUESTION*) (LAST-ANSWER *LAST-ANSWER*))
      (PROG1
       (CL-FLATTEN
        (LIST (COND ((EQ FORMAT 'XML) (LIST (FORMAT NIL "<explanation-structure>"))))
         (GET-JUSTIFICATION0 :TRIPLE TRIPLE :SITUATION SITUATION :DEPTH DEPTH :FORMAT FORMAT)
         (COND ((EQ FORMAT 'XML) (LIST (FORMAT NIL "</explanation-structure>"))))))
       (CSETQ *LAST-QUESTION* LAST-QUESTION) (CSETQ *LAST-ANSWER* LAST-ANSWER))))))))
(TRACE-LISP
 (DEFINE GET-JUSTIFICATION0 (&REST LKEYS)
  (trace-defun 'GET-JUSTIFICATION0 (LKEYS)
   (RET
    (CLET (TRIPLE SITUATION TAB DONE-TRIPLES DEPTH FORMAT) (init-keyval FORMAT 'XML) (init-keyval DEPTH 0) (init-keyval TAB 0) (init-keyval SITUATION (CURR-SITUATION))
     (COND
      ((AND TRIPLE (CNOT (KM-TRIPLEP TRIPLE)))
       (REPORT-ERROR 'USER-ERROR "(justify ~a): Argument should be a triple (justify (:triple <f> <s> <v>))!" TRIPLE))
      ((> DEPTH 20) (KM-FORMAT T "(depth limit for justification reached...no further details below this)~%"))
      (T
       (CLET
        ((TRIPLES (COMPUTE-TRIPLES TRIPLE))
         (COMMENT-TAGS 
          (CL-REMOVE-DUPLICATES
           (MAPCAN
            #'(LAMBDA (ATRIPLE)
               (trace-defun '#:G15803 (ATRIPLE)
                (RET
                 (COND ((CL-MEMBER ATRIPLE DONE-TRIPLES :TEST #'CL-EQUAL) NIL)
                  (T
                   (CLET
                    ((INSTANCE (ARG1OF ATRIPLE)) (SLOT (ARG2OF ATRIPLE)) (VALUE (ARG3OF ATRIPLE))
                     (ISV-EXPLANATIONS (GET-EXPLANATIONS0 INSTANCE SLOT VALUE SITUATION))  (EXPLANATIONS (FOURTH ISV-EXPLANATIONS))
                     (COMMENT-TAGS (MY-MAPCAN #'GET-COMMENT-TAGS-RECURSIVE EXPLANATIONS)))
                    (OR COMMENT-TAGS  (LIST (LIST ATRIPLE (MAPCAR #'BUILD-RULE EXPLANATIONS))))))))))
             TRIPLES)
           :TEST #'CL-EQUAL)))
        
        (MAPCAR
         #'(LAMBDA (COMMENT-TAG)
            (trace-defun '#:G15804 (COMMENT-TAG)
             (RET
              (COND
               ((COMMENT-TAGP COMMENT-TAG)
                (GET-COMMENT-JUSTIFICATION COMMENT-TAG TRIPLES :SITUATION SITUATION :TAB TAB :DONE-TRIPLES (APPEND TRIPLES DONE-TRIPLES) :DEPTH DEPTH
                 :FORMAT FORMAT))
               (T
                (CLET ((TRIPLE (FIRST COMMENT-TAG)) (RULES (SECOND COMMENT-TAG)))
                 (GET-RULES-JUSTIFICATION TRIPLE RULES :SITUATION SITUATION :TAB TAB :DONE-TRIPLES (APPEND TRIPLES DONE-TRIPLES) :DEPTH DEPTH :FORMAT
                  FORMAT)))))))
         COMMENT-TAGS)))))))))
;;;; --------------------
(TRACE-LISP
 (DEFINE GET-COMMENT-JUSTIFICATION (COMMENT-TAG TRIPLES &REST LKEYS)
  (trace-defun 'GET-COMMENT-JUSTIFICATION (COMMENT-TAG TRIPLES LKEYS)
   (RET
    (CLET (SITUATION TAB DONE-TRIPLES DEPTH FORMAT) (init-keyval FORMAT 'XML) (init-keyval DEPTH 0) (init-keyval TAB 0) (init-keyval SITUATION (CURR-SITUATION))
     (CLET ((CALLER (GET-COMMENT2 COMMENT-TAG 'CALL)) (EXITER (GET-COMMENT2 COMMENT-TAG 'EXIT)) (SUBGOALS (GET-COMMENT2 COMMENT-TAG 'SUBGOALS)))
      (LIST
       (COND
        (*DEVELOPER-MODE*
         (CASE FORMAT (ASCII (LIST (CONCAT (SPACES TAB) (KM-FORMAT NIL "(Doing triples: ~a)~%Entry text for ~a:" TRIPLES (DESOURCE1 COMMENT-TAG))))))))
       (CASE FORMAT
        (ASCII
         (CONCAT (SPACES TAB)
          (COND (CALLER (MAKE-PHRASE (KM0 CALLER :FAIL-MODE 'FAIL)))
           (T (KM-FORMAT NIL "(Missing entry text for comment tag ~a)" (DESOURCE1 COMMENT-TAG))))))
        (XML
         (CONCAT (FORMAT NIL "<explanation><call>")
          (COND (CALLER (XMLIFY (MAKE-PHRASE (KM0 CALLER :FAIL-MODE 'FAIL))))
           (T (XMLIFY (KM-FORMAT NIL "(Missing entry text for comment tag ~a)" (DESOURCE1 COMMENT-TAG)))))
          "</call>")))
       (MAPCAR
        #'(LAMBDA (SUBGOAL)
           (GET-JUSTIFICATION0 :TRIPLE SUBGOAL :SITUATION SITUATION :TAB (+ TAB 2) :DONE-TRIPLES DONE-TRIPLES :DEPTH (1+ DEPTH) :FORMAT FORMAT))
        (KM0 SUBGOALS))
       
       (COND
        (*DEVELOPER-MODE*
         (CASE FORMAT (ASCII (LIST (CONCAT (SPACES TAB) (KM-FORMAT NIL "(Doing triples: ~a)~%Exit text for ~a:" TRIPLES (DESOURCE1 COMMENT-TAG))))))))
       (CASE FORMAT
        (ASCII
         (CONCAT (SPACES TAB)
          (COND (EXITER (KM-FORMAT NIL (MAKE-PHRASE (KM0 EXITER)))) 
           (T (KM-FORMAT NIL "(Missing exit text for comment tag ~a)" (DESOURCE1 COMMENT-TAG))))))
        (XML
         (CONCAT (FORMAT NIL "<exit>")
          (COND (EXITER (XMLIFY (MAKE-PHRASE (KM0 EXITER)))) 
           (T (XMLIFY (KM-FORMAT NIL "(Missing exit text for comment tag ~a)" (DESOURCE1 COMMENT-TAG)))))
          "</exit></explanation>"))))))))))
;;;; If this is t, then a justification for leaf facts of the form <x> = <y> will be generated.
(TRACE-LISP (DEFVAR *JUSTIFY-LEAVES* NIL))
;;;; [1] only show rule(s) in developer mode and for ascii output
(TRACE-LISP
 (DEFINE GET-RULES-JUSTIFICATION (TRIPLE RULES &REST LKEYS)
  (trace-defun 'GET-RULES-JUSTIFICATION (TRIPLE RULES LKEYS)
   (RET
    (CLET (SITUATION TAB DONE-TRIPLES DEPTH FORMAT) (init-keyval FORMAT 'XML) (init-keyval DEPTH 0) (init-keyval TAB 0) (init-keyval SITUATION (CURR-SITUATION))
     (DECLARE (IGNORE DEPTH DONE-TRIPLES SITUATION))
     (COND
      (*DEVELOPER-MODE* 
       (CASE FORMAT
        (ASCII
         (COND
          (RULES
           (CONCAT-LIST
            `(,*NEWLINE-STR* ,(SPACES TAB) ,(KM-FORMAT NIL "subgoal ~a: Computed from:~%" TRIPLE)
              ,@(MAPCAN #'(LAMBDA (RULE) (trace-defun '#:G15805 (RULE) (RET (LIST (SPACES (+ TAB 2)) (KM-FORMAT NIL "~a~%" RULE))))) RULES))))
          (T (CONCAT-LIST `(,*NEWLINE-STR* ,(SPACES TAB) ,(KM-FORMAT NIL "subgoal ~a: Computed from: (unrecorded!)" TRIPLE))))))))
      (*JUSTIFY-LEAVES*
       (CLET ((INSTANCE (ARG1OF TRIPLE)) (SLOT (ARG2OF TRIPLE)) (VALUE (ARG3OF TRIPLE)))
        (CASE FORMAT
         (ASCII (CONCAT (SPACES TAB) (FORMAT NIL "The ~a of ~a = ~a." SLOT (MAKE-PHRASE (EXPAND-TEXT INSTANCE)) (MAKE-PHRASE (EXPAND-TEXT VALUE)))))
         (XML
          (CONCAT "<explanation><leaf>"
           (XMLIFY (FORMAT NIL "The ~a of ~a = ~a." SLOT (MAKE-PHRASE (EXPAND-TEXT INSTANCE)) (MAKE-PHRASE (EXPAND-TEXT VALUE))))
           "</leaf></explanation>")))))))))))
;;;; --------------------
(TRACE-LISP
 (DEFINE COMPUTE-TRIPLES (&OPTIONAL TRIPLE0)
  (trace-defun 'COMPUTE-TRIPLES (TRIPLE0)
   (RET
    (COND
     (TRIPLE0
      (CLET
       ((TRIPLE (KM-UNIQUE0 TRIPLE0)) (INSTANCE (ARG1OF TRIPLE)) (SLOT (ARG2OF TRIPLE)) (VALUE0 (ARG3OF TRIPLE))
        (VALUES (COND ((EQ VALUE0 '*) (KM0 `(|the| ,SLOT |of| ,INSTANCE)))  (T (VAL-TO-VALS VALUE0)))))
       (MAPCAR #'(LAMBDA (VALUE) (trace-defun '#:G15806 (VALUE) (RET (LIST ':|triple| INSTANCE SLOT VALUE)))) VALUES)))
     ((NULL *LAST-ANSWER*) (KM-FORMAT T "There's no recorded last answer, so I'm not sure what you're asking me to justify!~%"))
     (T
      (CLET
       ((SLOT+FRAMEADD (MINIMATCH *LAST-QUESTION* '(|the| |?slot| |of| |?frameadd|))) (SLOT (FIRST SLOT+FRAMEADD)) (FRAMEADD (SECOND SLOT+FRAMEADD)))
       (COND
        ((CNOT SLOT+FRAMEADD)
         (KM-FORMAT T
          "Which conclusion are you asking about? (Here, I can't guess). Enter in the form 
               (justify (:triple <instance> <slot> <value>))~%"))
        (T
         (CLET ((INSTANCES (KM0 FRAMEADD))  (VALUES *LAST-ANSWER*))
          (KM-FORMAT T "I'll assume you're asking me to justify:~%   ~a = ~a...~%~%" *LAST-QUESTION* VALUES)
          (MAPCAN
           #'(LAMBDA (INSTANCE)
              (trace-defun '#:G15807 (INSTANCE)
               (RET (MAPCAR #'(LAMBDA (VALUE) (trace-defun '#:G15808 (VALUE) (RET (LIST ':|triple| INSTANCE SLOT VALUE)))) VALUES))))
           INSTANCES)))))))))))
;;;; --------------------
#| [ideally should be in html.lisp]
;;; INPUT: A string, OUTPUT a string
;;; BEHAVIOR: Change <>& to &gt; &lt; &amp;
;;; (xmlify "<enter>") -> "&lt;enter&gt;"
(defun xmlify (string)
  (let ( (chars (explode string)) )
    (cond ((intersection chars '(X\< X\> X\&))
	   (concat-list (mapcar X'(lambda (char) 
				    (case char
					  (X\< "&lt;")
					  (X\> "&gt;")
					  (X\& "&amp;")
					  (t (string char))))
				chars)))
	  (t string))))|#
;;; Rewrite by Carl Shapiro:
;;; A space-conscious implementation of XMLIFY.  This recasting of
;;; XMLIFY should, in the worst case, have the same asymptotic
;;; complexity as the previous definition.  However, this version will
;;; only allocate memory when it must introduce escape sequences into
;;; the output string.  The overwhelming majority of strings pass
;;; through XMLIFY without quoting so this is worth special casing.
(TRACE-LISP
 (DEFINE XML-LENGTH (STRING)
  (trace-defun 'XML-LENGTH (STRING)
   (RET
    (CDO ((I 0 (1+ I)) (<-COUNT 0) (>-COUNT 0) (&-COUNT 0) (|'-COUNT| 0) (|"-COUNT| 0) (LENGTH (LENGTH STRING)))
     ((= I LENGTH) (+ LENGTH (* 3 <-COUNT) (* 3 >-COUNT) (* 4 &-COUNT) (* 5 |'-COUNT|) (* 5 |"-COUNT|)))
     (CASE (CHAR STRING I) (#\< (INCF <-COUNT)) (#\> (INCF >-COUNT)) (#\& (INCF &-COUNT)) (#\' (INCF |'-COUNT|)) (#\" (INCF |"-COUNT|))))))))
(TRACE-LISP (DEFINE XMLIFY-INTERNAL (STRING LENGTH NEW-STRING) (trace-defun 'XMLIFY-INTERNAL (STRING LENGTH NEW-STRING) (RET ))))
(TRACE-LISP
 (DEFINE XMLIFY (STRING)
  (trace-defun 'XMLIFY (STRING)
   (RET
    (CLET ((LENGTH (LENGTH STRING)) (NEW-LENGTH (XML-LENGTH STRING)))
     (IF (= LENGTH NEW-LENGTH) STRING (XMLIFY-INTERNAL STRING LENGTH (CL-MAKE-STRING NEW-LENGTH))))))))
;;;; FILE:  kbutils.lisp
;;;; File: kbutils.lisp
;;;; Author: Peter Clark
;;;; Date: Separated out Mar 1995
;;;; Purpose: Basic utilities for KM
;;;; ======================================================================
;;;; 		RECOGNITION OF INSTANCES
;;;; ======================================================================
(TRACE-LISP (DEFINE KM-NULL (KM-NIL) (trace-defun 'KM-NULL (KM-NIL) (RET (OR (NULL KM-NIL) (EQ KM-NIL '|nil|))))))
;;;; Only recognizes slots whose immediate class is Slot. I don't use this, the 
;;;; second is better.
(TRACE-LISP
 (DEFINE SIMPLE-SLOTP (SLOT)
  (trace-defun 'SIMPLE-SLOTP (SLOT) (RET (AND (SYMBOLP SLOT) (CL-MEMBER SLOT (GET-VALS '|Slot| '|instances| :SITUATION *GLOBAL-SITUATION*)))))))
(TRACE-LISP
 (DEFINE SLOTP (SLOT)
  (trace-defun 'SLOTP (SLOT)
   (RET (AND (SYMBOLP SLOT) (CL-INTERSECTION (CONS '|Slot| (ALL-SUBCLASSES '|Slot|)) (GET-VALS SLOT '|instance-of| :SITUATION *GLOBAL-SITUATION*)))))))
;;;; Check is' a valid slot
(TRACE-LISP (DEFINE SLOT-OBJECTP (SLOT) (trace-defun 'SLOT-OBJECTP (SLOT) (RET (AND (SYMBOLP SLOT) (CNOT (NULL SLOT)))))))
;;;; Rather crude approximation of a test...
(TRACE-LISP (DEFINE PATHP (PATH) (trace-defun 'PATHP (PATH) (RET (LISTP PATH)))))
;;;; Anything which is considered to be fully evaluated in KM. 
;;;; EXCEPT it ALSO includes constraints. Argh!
;;;; 345, "a", pete, ;'print, '(every Dog), (:triple Sue loves John), (<> 23)
(TRACE-LISP
 (DEFINE IS-KM-TERM (CONCEPT)
  (trace-defun 'IS-KM-TERM (CONCEPT)
   (RET
    (OR (ATOM CONCEPT)  (DESCRIPTIONP CONCEPT) (QUOTED-EXPRESSIONP CONCEPT) (KM-STRUCTURED-LIST-VALP CONCEPT) (KM-SETP CONCEPT) (FUNCTIONP CONCEPT)
     (CONSTRAINT-EXPRP CONCEPT))))))
(TRACE-LISP
 (DEFINE IS-SIMPLE-KM-TERM (CONCEPT)
  (trace-defun 'IS-SIMPLE-KM-TERM (CONCEPT)
   (RET (OR (AND (ATOM CONCEPT)  (CNOT (CL-MEMBER CONCEPT *RESERVED-KEYWORDS*))) (DESCRIPTIONP CONCEPT) (FUNCTIONP CONCEPT))))))
;;;; Anything which is considered to be fully evaluated in KM. 
;;;; Eventually, should get rid of is-km-term above
(TRACE-LISP
 (DEFINE FULLY-EVALUATEDP (CONCEPT &REST LKEYS)
  (trace-defun 'FULLY-EVALUATEDP (CONCEPT LKEYS)
   (RET
    (CLET (IN-STRUCTURED-EXPRP)
     (OR (AND (ATOM CONCEPT) (NEQ CONCEPT '*))  (AND (QUOTED-EXPRESSIONP CONCEPT) (CNOT (RECURSIVE-FIND 'UNQUOTE CONCEPT))) (THE-CLASS-EXPRP CONCEPT) 
      (AND (KM-SETP CONCEPT)  IN-STRUCTURED-EXPRP 
       (EVERY #'(LAMBDA (EL) (trace-defun '#:G15810 (EL) (RET (FULLY-EVALUATEDP EL :IN-STRUCTURED-EXPRP NIL)))) (VAL-TO-VALS CONCEPT)))
      (AND (KM-STRUCTURED-LIST-VALP CONCEPT)
       (EVERY #'(LAMBDA (EL) (trace-defun '#:G15811 (EL) (RET (FULLY-EVALUATEDP EL :IN-STRUCTURED-EXPRP T)))) (SEQ-TO-LIST CONCEPT)))))))))
;; No!!! if a function and/or constraint has been fully evaluated, then it will be NIL!
;;      (functionp concept)
;;      (constraint-exprp concept)))
;;; Proves that it's *definitely* a class; however, some other objects may also
;;; be classes too (eg. if they haven't been declared).
;;;; [1] This is optional, and here purely for efficiency. If we do find instance-of link, then it isn't
;;;;     a class [ignoring metaclasses for now], so we don't need to bother doing the tests for classp. 
;;;;	If we don't find one, or we miss one because instance-of is a fluent and we don't look for 
;;;;     situation-specific instance-of links, then that's okay, we just proceed on anyway to do the class 
;;;;     tests. Non-classes will fail these tests.
(TRACE-LISP
 (DEFINE CLASSP (CLASS)
  (trace-defun 'CLASSP (CLASS)
   (RET
    (OR (CL-MEMBER CLASS *BUILT-IN-CLASSES*)
     (AND (KB-OBJECTP CLASS)
      (OR (GET-VALS CLASS '|superclasses| :SITUATION *GLOBAL-SITUATION*)
       (AND (CNOT (GET-VALS CLASS '|instance-of| :SITUATION *GLOBAL-SITUATION*)) 
        (OR (GET-VALS CLASS '|instances| :SITUATION *GLOBAL-SITUATION*) (GET CLASS 'MEMBER-PROPERTIES) (GET CLASS 'MEMBER-DEFINITION)
         (GET-VALS CLASS '|subclasses| :SITUATION *GLOBAL-SITUATION*))))))))))
;;;; Proves (just about) it's definitely an instance, though there may
;;;; be other instances which fail this test.
;;;; [1] Note: We'll miss situation-specific instance-of links, in the case instance-of is a fluent.
;;;;	I hope that doesn't matter!!
(TRACE-LISP
 (DEFINE IS-AN-INSTANCE (INSTANCE)
  (trace-defun 'IS-AN-INSTANCE (INSTANCE)
   (RET
    (OR (ANONYMOUS-INSTANCEP INSTANCE) (NUMBERP INSTANCE) (STRINGP INSTANCE) (FUNCTIONP INSTANCE) (DESCRIPTIONP INSTANCE)
     (KM-STRUCTURED-LIST-VALP INSTANCE)
     (AND  (KB-OBJECTP INSTANCE)
      (OR (GET-VALS INSTANCE '|instance-of| :FACET 'OWN-PROPERTIES :SITUATION *GLOBAL-SITUATION*) 
       (GET-VALS INSTANCE '|instance-of| :FACET 'OWN-DEFINITION :SITUATION *GLOBAL-SITUATION*))))))))
;;; Time consuming!
;;	   (not (classp instance)))))   ; just in case ;$instance-of is a class-metaclass relation
;;;; _car12
(TRACE-LISP
 (DEFINE ANONYMOUS-INSTANCEP (INSTANCE0)
  (trace-defun 'ANONYMOUS-INSTANCEP (INSTANCE0)
   (RET (CLET ((INSTANCE (DEREFERENCE INSTANCE0))) (AND (SYMBOLP INSTANCE) (CHAR= (CL-FIRST-CHAR (SYMBOL-NAME INSTANCE)) *VAR-MARKER-CHAR*)))))))
;;;; 345, "a", pete, ;'print
(TRACE-LISP (DEFINE NAMED-INSTANCEP (INSTANCE) (trace-defun 'NAMED-INSTANCEP (INSTANCE) (RET (CNOT (ANONYMOUS-INSTANCEP INSTANCE))))))
;;;; Not used any more
(TRACE-LISP (DEFINE FLUENT-INSTANCEP (INSTANCE) (trace-defun 'FLUENT-INSTANCEP (INSTANCE) (RET (TRACE-PROGN (DECLARE (IGNORE INSTANCE)) NIL)))))
;;(defun fluent-instancep (instance)
;;  (and (symbolp instance)
;;       (starts-with (symbol-name instance) *fluent-instance-marker-string*)))
;; Not used any more
;;(defun remove-fluent-instances (instances) (remove-if ;'fluent-instancep instances))
;;;; (recursive-remove-fluent-instances ';$((_SomePerson813) && ((some Person))))
;;;; -> ((nil) && ((;some; ;Person;)))
;;;; Dec00 Revised to be -> (() && ((;some; ;Person;))) - yikes, but becomes (&& ((some Person)))!
;;;; Patched Jan01 - we simply splice out these things. 
;;;; BUT still a bug: (_Some23 & (a Car)) -> (& (a Car)), but should be just (a Car). Need to be more sophisticated.
;;;; Fixed Feb01
;;;; Apr02: Still bug: (:args nil _Car1) -> (:args _Car1) 
;;(defun recursive-remove-fluent-instances (instances)
;;  (cond ((&-exprp instances)
;;	 (vals-to-&-expr (recursive-remove-fluent-instances (&-expr-to-vals instances))))
;;	((&&-exprp instances)
;;	 (vals-to-val (valsets-to-&&-exprs (recursive-remove-fluent-instances (&&-exprs-to-valsets (val-to-vals instances))))))
;;	((listp instances)
;;	 (remove nil (mapcar ;'recursive-remove-fluent-instances instances)))
;;	((fluent-instancep instances) nil)
;;	(t instances)))
;;;; Objects which will have frames in the KB about them, e.g., *Pete, _Car12
;;; Rewrite by Carl Shapiro:
;;; An optimized KB-OBJECTP definition.  Profiling has shown that the
;;; out-of-line call to MEMBER is a huge performance drain on this
;;; frequently invoked predicate.  Since the list of test subjects is
;;; small, we can inline the comparisons by rewriting MEMBER in terms
;;; of CASE.
(TRACE-LISP
 (DEFINE KB-OBJECTP (INSTANCE)
  (trace-defun 'KB-OBJECTP (INSTANCE)
   (RET
    (AND INSTANCE (SYMBOLP INSTANCE) (CNOT (USER-COMMENTP INSTANCE)) 
     (CASE INSTANCE ((|nil| :|seq| :|bag| :|args| :|triple| :|pair| :|function|) NIL)  (T T)))))))
;;;; A *structured value* is a CONTAINER of values, collected together. It *doesn't*
;;;; include quoted expressions.
;;;; NOTE a SET isn't a structured value, it's a set of values!!
(TRACE-LISP
 (DEFINE KM-STRUCTURED-LIST-VALP (VAL)
  (trace-defun 'KM-STRUCTURED-LIST-VALP (VAL)
   (RET (AND (LISTP VAL) (CL-MEMBER (FIRST VAL) '(:|seq| :|bag| :|args| :|triple| :|pair| :|function|)))))))
(TRACE-LISP (DEFINE KM-FUNCTIONP (VAL) (trace-defun 'KM-FUNCTIONP (VAL) (RET (AND (LISTP VAL) (EQ (FIRST VAL) ':|function|))))))
(TRACE-LISP
 (DEFINE KM-TRIPLEP (TRIPLE)
  (trace-defun 'KM-TRIPLEP (TRIPLE) (RET (AND (LISTP TRIPLE) (EQ (FIRST TRIPLE) :|triple|) (= (LENGTH (DECOMMENT TRIPLE)) 4))))))
;;;; recognize sequences eg. (:seq a b c)
(TRACE-LISP (DEFINE KM-SEQP (SEQ) (trace-defun 'KM-SEQP (SEQ) (RET (AND (LISTP SEQ) (EQ (FIRST SEQ) ':|seq|))))))
(TRACE-LISP (DEFINE KM-BAGP (BAG) (trace-defun 'KM-BAGP (BAG) (RET (AND (LISTP BAG) (EQ (FIRST BAG) ':|bag|))))))
(TRACE-LISP (DEFINE KM-PAIRP (SEQ) (trace-defun 'KM-PAIRP (SEQ) (RET (AND (LISTP SEQ) (EQ (FIRST SEQ) ':|pair|))))))
;;;; '(:seq a b) -> (a b)
(TRACE-LISP (DEFINE BAG-TO-LIST (BAG) (trace-defun 'BAG-TO-LIST (BAG) (RET (REST BAG)))))
(TRACE-LISP (DEFINE SEQ-TO-LIST (SEQ) (trace-defun 'SEQ-TO-LIST (SEQ) (RET (REST SEQ)))))
(TRACE-LISP (DEFINE SET-TO-LIST (SET) (trace-defun 'SET-TO-LIST (SET) (RET (REST SET)))))
(TRACE-LISP (DEFINE PAIR-TO-LIST (PAIR) (trace-defun 'PAIR-TO-LIST (PAIR) (RET (REST PAIR)))))
;;;; ----------
;;;; NOTE: doesn't remove dups
;;;; Input: a LIST of values. Returns a LIST of values.
;;;; NOTE: (flatten-sets '((:set a b))) is OK
;;;; 	  (flatten-sets '(a b)) is OK
;;;;       (flatten-sets '(:set a b)) is NOT OK
;;;;       (flatten-sets 'b) is NOT OK
;;;; (flatten-sets ';$((:set a b (:set c (:set d e)) f (:set g h)))) -> (a b c d e f g h)
(TRACE-LISP (DEFINE FLATTEN-SETS (VALS) (trace-defun 'FLATTEN-SETS (VALS) (RET (MY-MAPCAN #'FLATTEN-SET VALS)))))
;;;; Given a SINGLE value, which might be a set, return either
;;;;	(1) a singleton list of that one value, if that value is NOT a set.
;;;;	(2) a list of the values in that set, if that value IS a set.
(TRACE-LISP
 (DEFINE FLATTEN-SET (SET)
  (trace-defun 'FLATTEN-SET (SET) (RET (COND ((KM-SETP SET) (MY-MAPCAN #'FLATTEN-SET (SET-TO-LIST SET))) (T (LIST SET)))))))
;;;; ----------
;;;; (km-varp ?x) -> t
(TRACE-LISP (DEFINE KM-VARP (VAR) (trace-defun 'KM-VARP (VAR) (RET (AND (SYMBOLP VAR) (CHAR= (CL-FIRST-CHAR (SYMBOL-NAME VAR)) #\?))))))
;;;; recognize a single expression as a set eg. (:set a b c)
(TRACE-LISP (DEFINE KM-SETP (SET) (trace-defun 'KM-SETP (SET) (RET (AND (LISTP SET) (EQ (FIRST SET) ':|set|))))))
;;;; e.g. (a Cat called "fido")
(TRACE-LISP
 (DEFINE KM-TAGP (TAG)
  (trace-defun 'KM-TAGP (TAG)
   (RET (OR (AND (ATOM TAG) (CNOT (NULL TAG))) (CONSTRAINT-EXPRP TAG) (AND (KM-SETP TAG) (EVERY #'KM-TAGP (SET-TO-LIST TAG))))))))
(TRACE-LISP (DEFINE KM-ARGSP (ARGS) (trace-defun 'KM-ARGSP (ARGS) (RET (AND (LISTP ARGS) (EQ (FIRST ARGS) ':|args|))))))
(TRACE-LISP (DEFINE KM-DEFAULTP (EXPR) (trace-defun 'KM-DEFAULTP (EXPR) (RET (AND (LISTP EXPR) (EQ (FIRST EXPR) ':|default|))))))
;;;; ----------------------------------------
(TRACE-LISP
 (DEFINE COMPARISON-OPERATOR (SLOT)
  (trace-defun 'COMPARISON-OPERATOR (SLOT)
   (RET (OR (CL-MEMBER SLOT *INEQUALITY-RELATIONS*) (CL-MEMBER SLOT *EQUALITY-RELATIONS*) (ASSOC SLOT *USER-DEFINED-INFIX-OPERATORS*))))))
;;;; ----------------------------------------
(TRACE-LISP (DEFINE &-EXPRP (EXPR) (trace-defun '&-EXPRP (EXPR) (RET (AND (LISTP EXPR) (CL-MEMBER (SECOND EXPR) '(& &! &+ ==)))))))
;; but not &? &+?
(TRACE-LISP (DEFINE &&-EXPRP (EXPR) (trace-defun '&&-EXPRP (EXPR) (RET (AND (LISTP EXPR) (CL-MEMBER (SECOND EXPR) '(&& &&! ===)))))))
;;;; ----------------------------------------
;;;; Accessing (:args ...) structures:
(TRACE-LISP (DEFINE ARG1OF (ARG-STRUCTURE) (trace-defun 'ARG1OF (ARG-STRUCTURE) (RET (SECOND ARG-STRUCTURE)))))
;; (:args a b) -> a
(TRACE-LISP (DEFINE ARG2OF (ARG-STRUCTURE) (trace-defun 'ARG2OF (ARG-STRUCTURE) (RET (THIRD ARG-STRUCTURE)))))
;; (:args a b) -> b
(TRACE-LISP (DEFINE ARG3OF (ARG-STRUCTURE) (trace-defun 'ARG3OF (ARG-STRUCTURE) (RET (FOURTH ARG-STRUCTURE)))))
;; (:args a b) -> b
;;;; [1] NOTE: avoids numeric and set testing 
;;;; 7/28/04: At some risk, replaced remove-duplicates with (destructive) delete-duplicates (which is 50% faster).
;;;; This change relies on the fact that (dereference ...) will create a copy of instances, which is necessarily a list.
(TRACE-LISP
 (DEFINE REMOVE-DUP-INSTANCES (INSTANCES)
  (trace-defun 'REMOVE-DUP-INSTANCES (INSTANCES) (RET (CL-DELETE-DUPLICATES (DEREFERENCE INSTANCES) :TEST #'KM-EQUAL :FROM-END T)))))
#|7/28/04 - playing with fire!! Let's not do this.
;;; delete-duplicates is twice as fast as remove-duplicates.
;;; It relies on the fact that (dereference ...) will create a copy of instances, which is necessarily a list... dangerous!!
(defun remove-dup-atomic-instances (instances)
 (delete-duplicates (dereference instances) :test X'km-equal :from-end t))|#
(TRACE-LISP
 (DEFINE REMOVE-DUP-ATOMIC-INSTANCES (INSTANCES) (trace-defun 'REMOVE-DUP-ATOMIC-INSTANCES (INSTANCES) (RET (REMOVE-DUP-INSTANCES INSTANCES)))))
;;;; ======================================================================
;;;;		DEFINITION OF EQUALITY
;;;; ======================================================================
;;;; "equal" isn't quite what we want, as we *don't* remove duplicate numeric entries. Is this a bad idea??
;;;; yes, use a bag if you want duplicate numbers
;;;; I suspect in other places in the code, duplicate numbers are removed as I've used equal not km-equal (eg. during lazy unify).
;;;; This compares SINGLE VALUES. Note: We DON'T expect to be given the test (:set 1) = 1,  (:set (:seq 1)) = (:seq 1)
;;(defun km-equal (i1 i2)
;;  (and (equal i1 i2) (not (numberp i1)) (not (existential-exprp i1))))
;;  (and (equal i1 i2) (not (existential-exprp i1))))
;;;; ----------------------------------------
#|[1] TOLERANCE:
Desired behavior:
 0.00001 /= 0.00002
 4.99999  = 5.00000
 499999  /= 500000

For large numbers, it is absolute, i.e., +/- 0.0001.
For small numbers, it is fractional, i.e., +/- 0.01%
Behavior: x = y if x = y +/- (0.0001 or 0.01% of max(x,y), whichever is smaller)|#
;;; Rewrite by Carl Shapiro:
;;; An optimized KM-EQUAL definition.  The comparisons against atomic
;;; types now occupy the beginning of the COND clause.  This saves us
;;; the out-of-line call to EQUAL and its expensive general equality
;;; test.  Profiling has shown that most comparisons are done against
;;; variables of an atomic type (symbols, mostly).  The added cost of
;;; explicity codifying the EQ tests done interally by EQUAL should be
;;; lost in the noise during aggregate (list) comparisons.
;;; [2] 11/1/04 - moved [2] up, as (km-equal NIL NIL) was incorrectly failing
(TRACE-LISP
 (DEFINE KM-EQUAL (I1 I2)
  (trace-defun 'KM-EQUAL (I1 I2)
   (RET
    (COND  ((EQ I1 I2))  ((NULL I1) (EQ I2 '|nil|)) ((NULL I2) (EQ I1 '|nil|)) 
     ((AND (NUMBERP I1) (NUMBERP I2) *TOLERANCE*) (<= (ABS (- I1 I2)) (MIN *TOLERANCE* (* (MAX (ABS I1) (ABS I2)) *TOLERANCE*))))  
     ((AND (CL-EQUAL I1 I2) (CNOT (EXISTENTIAL-EXPRP I1)))) ((AND (KM-SETP I1) (KM-SETP I2)) (KM-SET-EQUAL I1 I2))
     ((AND (KM-BAGP I1) (KM-BAGP I2)) (KM-BAG-EQUAL I1 I2)) ((AND (KM-SEQP I1) (KM-SEQP I2)) (KM-SEQ-EQUAL I1 I2))
     ((AND (KM-PAIRP I1) (KM-PAIRP I2)) (KM-SEQ-EQUAL I1 I2)))))))
(TRACE-LISP
 (DEFINE KM-SET-EQUAL (SET1 SET2) (trace-defun 'KM-SET-EQUAL (SET1 SET2) (RET (CNOT (SET-EXCLUSIVE-OR SET1 SET2 :TEST #'KM-EQUAL))))))
;;;; ----------
(TRACE-LISP
 (DEFINE KM-BAG-EQUAL (BAG1 BAG2)
  (trace-defun 'KM-BAG-EQUAL (BAG1 BAG2) (RET (AND (EQ (LENGTH BAG1) (LENGTH BAG2)) (KM-BAG-EQUAL0 BAG1 BAG2))))))
(TRACE-LISP
 (DEFINE KM-BAG-EQUAL0 (BAG1 BAG2)
  (trace-defun 'KM-BAG-EQUAL0 (BAG1 BAG2)
   (RET
    (COND ((CL-EQUAL BAG1 BAG2)) 
     ((CL-MEMBER (FIRST BAG1) BAG2 :TEST #'KM-EQUAL) (KM-BAG-EQUAL0 (REST BAG1) (CL-REMOVE (FIRST BAG1) BAG2 :TEST #'KM-EQUAL :COUNT 1))))))))
;;;; ----------
(TRACE-LISP
 (DEFINE KM-SEQ-EQUAL (SEQ1 SEQ2)
  (trace-defun 'KM-SEQ-EQUAL (SEQ1 SEQ2) (RET (AND (EQ (LENGTH SEQ1) (LENGTH SEQ2)) (KM-SEQ-EQUAL0 SEQ1 SEQ2))))))
(TRACE-LISP
 (DEFINE KM-SEQ-EQUAL0 (SEQ1 SEQ2)
  (trace-defun 'KM-SEQ-EQUAL0 (SEQ1 SEQ2)
   (RET (COND ((CL-EQUAL SEQ1 SEQ2)) ((AND (KM-EQUAL (FIRST SEQ1) (FIRST SEQ2)) (KM-SEQ-EQUAL0 (REST SEQ1) (REST SEQ2)))))))))
;;;; ======================================================================
;; Old def -- definition??
;;(defun km-equal (i1 i2)
;;  (and (equal i1 i2) 
;;       (or (symbolp i1)		; (kb-objectp i1)	ERROR! should remove dups for non-kb-objects t f!
;;	   (km-structured-list-valp i1))))
;;;; Only expressions of the form (a ... [with ...]) return a situation-invariant answer.
;;;; This is used to block passing these *expressions* between situations, to avoid redundant computation 
;;;;     of identities. The result of their evaluation *will* be passed between situations, still, of course.
(TRACE-LISP
 (DEFINE SITUATION-INVARIANT-EXPRP (EXPR) (trace-defun 'SITUATION-INVARIANT-EXPRP (EXPR) (RET (AND (LISTP EXPR) (EQ (FIRST EXPR) '|a|))))))
(TRACE-LISP
 (DEFINE CONSTRAINT-EXPRP (EXPR) (trace-defun 'CONSTRAINT-EXPRP (EXPR) (RET (OR (VAL-CONSTRAINT-EXPRP EXPR) (SET-CONSTRAINT-EXPRP EXPR))))))
(TRACE-LISP (DEFINE NON-CONSTRAINT-EXPRP (EXPR) (trace-defun 'NON-CONSTRAINT-EXPRP (EXPR) (RET (CNOT (CONSTRAINT-EXPRP EXPR))))))
(TRACE-LISP
 (DEFINE VAL-CONSTRAINT-EXPRP (EXPR)
  (trace-defun 'VAL-CONSTRAINT-EXPRP (EXPR) (RET (AND (LISTP EXPR) (CL-MEMBER (FIRST EXPR) *VAL-CONSTRAINT-KEYWORDS*))))))
(TRACE-LISP
 (DEFINE SET-CONSTRAINT-EXPRP (EXPR)
  (trace-defun 'SET-CONSTRAINT-EXPRP (EXPR) (RET (AND (LISTP EXPR) (CL-MEMBER (FIRST EXPR) *SET-CONSTRAINT-KEYWORDS*))))))
;;;; Experimental
(TRACE-LISP (DEFINE SOMETIMES-EXPRP (EXPR) (trace-defun 'SOMETIMES-EXPRP (EXPR) (RET (AND (LISTP EXPR) (EQ (FIRST EXPR) '|sometimes|))))))
;;;; Returns non-nil if expr contains (at least) one of symbols.
(TRACE-LISP
 (DEFINE CONTAINS-SOME-EXISTENTIAL-EXPRS (EXPRS)
  (trace-defun 'CONTAINS-SOME-EXISTENTIAL-EXPRS (EXPRS) (RET (CONTAINS-SOME EXPRS '(|a| |an| |some|))))))
;;(defun existential-exprp (expr) 
;;  (and (listp expr) (member (first expr) ';$(a some))))
;;;; NB "an" is NOT considered an existential structure, it needs preprocessing by the interpreter.
(TRACE-LISP
 (DEFINE EXISTENTIAL-EXPRP (EXPR)
  (trace-defun 'EXISTENTIAL-EXPRP (EXPR)
   (RET (AND (LISTP EXPR) (OR (CL-MEMBER (FIRST EXPR) '(|a| |some|)) (AND (COMMENT-TAGP (FIRST EXPR))  (EXISTENTIAL-EXPRP (REST EXPR)))))))))
;;;; (some <x>)
(TRACE-LISP
 (DEFINE FLUENT-INSTANCE-EXPRP (EXPR) (trace-defun 'FLUENT-INSTANCE-EXPRP (EXPR) (RET (AND (LISTP EXPR) (EQ (FIRST EXPR) '|some|))))))
;;;; ======================================================================
(TRACE-LISP
 (DEFINE VAL-TO-VALS (VAL)
  (trace-defun 'VAL-TO-VALS (VAL) (RET (COND ((NULL VAL) NIL) ((EQ VAL '|nil|) NIL) ((KM-SETP VAL) (SET-TO-LIST VAL)) (T (LIST VAL)))))))
;; val must be an atom (eg. _Car23) or a single expression, eg. (a Car) 
;; so we simply wrap it in a list (_Car23), or ((a Car))
(TRACE-LISP
 (DEFINE VALS-TO-VAL (VALS)
  (trace-defun 'VALS-TO-VAL (VALS)
   (RET
    (COND ((NULL VALS) NIL) ((SINGLETONP VALS) (FIRST VALS)) ((LISTP VALS) (CONS ':|set| VALS))
     (T (REPORT-ERROR 'USER-ERROR "Expecting a set of values, but just found a single value ~a!~%" VALS)))))))
;;;; ======================================================================
;;;; 		val-sets-to-expr
;;;; ======================================================================
;;;;     GIVEN a LIST of SETS of VALS (ie. some val-sets)
;;;;     RETURNS a *SINGLE* expression which KM can evaluate, denoting the combination.
;;;; single-valuedp = *:   (val-sets-to-expr '((a)) ) -> a
;;;; single-valuedp = *:   (val-sets-to-expr '((a b)) ) -> (:set a b)
;;;; single-valuedp = T:   (val-sets-to-expr '((a) (b) (c)) 't)  -> (a & b & c)
;;;; single-valuedp = T:   (val-sets-to-expr '((a b) (c)) 't) -> ERROR! and (a & c)
;;;; single-valuedp = NIL: (val-sets-to-expr '((a b) (b) (c d))) -> ((a b) && (b) && (c d))
(TRACE-LISP
 (DEFINE VAL-SETS-TO-EXPR (EXPRS0 &OPTIONAL SINGLE-VALUEDP)
  (trace-defun 'VAL-SETS-TO-EXPR (EXPRS0 SINGLE-VALUEDP)
   (RET
    (CLET ((EXPRS (CL-REMOVE-DUPLICATES (CL-REMOVE NIL EXPRS0) :TEST #'CL-EQUAL :FROM-END T)))
     (COND ((NULL EXPRS) NIL) ((SINGLETONP EXPRS) (VALS-TO-VAL (FIRST EXPRS))) (T (VAL-SETS-TO-EXPR0 EXPRS SINGLE-VALUEDP))))))))
(TRACE-LISP
 (DEFINE VAL-SETS-TO-EXPR0 (EXPRS &OPTIONAL SINGLE-VALUEDP)
  (trace-defun 'VAL-SETS-TO-EXPR0 (EXPRS SINGLE-VALUEDP)
   (RET
    (COND ((ENDP EXPRS) NIL) ((NULL (FIRST EXPRS)) (VAL-SETS-TO-EXPR0 (REST EXPRS) SINGLE-VALUEDP))
     ((CNOT (LISTP (FIRST EXPRS)))
      (REPORT-ERROR 'USER-ERROR "val-sets-to-expr0: Single value ~a found where list of values expected! Listifying it...~%" (FIRST EXPRS))
      (VAL-SETS-TO-EXPR0 (CONS (LIST (FIRST EXPRS)) (REST EXPRS))))
     (T
      (CLET
       ((FIRST-ITEM
         (COND
          (SINGLE-VALUEDP
           (COND
            ((CNOT (SINGLETONP (FIRST EXPRS))) 
             (KM-TRACE 'COMMENT "Multiple values ~a found for single-valued slot!~%Assuming they should be unified...~%" (FIRST EXPRS))
             (VALS-TO-&-EXPR (FIRST EXPRS)))
             (T (FIRST (FIRST EXPRS)))))
           (T (FIRST EXPRS))))
         (LINKED-REST (VAL-SETS-TO-EXPR0 (REST EXPRS) SINGLE-VALUEDP)) (JOINER (COND (SINGLE-VALUEDP '&) (T '&&))))
       (COND ((NULL LINKED-REST) (LIST FIRST-ITEM)) (T (CONS FIRST-ITEM (CONS JOINER LINKED-REST)))))))))))
;;;; ======================================================================
;;;;		FLATTENING '&' AND '&&' EXPRESSIONS
;;;; ======================================================================
;;;; vals should be either nil, or a SINGLETON list of one KM expression eg. (a), ((a & b)).
;;;; RETURNS the component values as a list, eg. (a), (a b)
(TRACE-LISP
 (DEFINE UN-ANDIFY (VALS)
  (trace-defun 'UN-ANDIFY (VALS)
   (RET
    (COND ((NULL VALS) NIL) ((SINGLETONP VALS) (&-EXPR-TO-VALS (FIRST VALS)))
     (T (KM-TRACE 'COMMENT "Multiple values ~a found for single-valued slot!~%Assuming they should be unified...~%" VALS)
      (MY-MAPCAN #'&-EXPR-TO-VALS VALS)))))))
;;;; (&-expr-to-vals '(x & y & z)) -> (x y z)
;;;; (&-expr-to-vals '((a Car) & (a Dog))) -> ((a Car) (a Dog)))
;;;; (&-expr-to-vals '(a Car)) -> ((a Car))	<- NB listify
;;;; (&-expr-to-vals 'x) -> (x)			<- NB listify
;;;; (&-expr-to-vals '((a & (b & d)) & (e & (f & g)))) -> (a b c d e f g)    <- NB nested 
;;;; (&-expr-to-vals '(x & y z))			<- ERROR!
(TRACE-LISP
 (DEFINE &-EXPR-TO-VALS (EXPR)
  (trace-defun '&-EXPR-TO-VALS (EXPR)
   (RET
    (COND ((NULL EXPR) NIL)
     ((&-EXPRP EXPR)
      (COND ( (VAL-UNIFICATION-OPERATOR (FOURTH EXPR)) (&-EXPR-TO-VALS `(,(FIRST EXPR) ,(FOURTH EXPR) ,(REST (REST EXPR)))))
       (T
        (COND
         ((NEQ (LENGTH EXPR) 3)
          (REPORT-ERROR 'USER-ERROR "Illegally formed expression ~a encountered!~%Continuing with just ~a...~%" EXPR (SUBSEQ EXPR 0 3))))
        (APPEND (&-EXPR-TO-VALS (FIRST EXPR)) (&-EXPR-TO-VALS (THIRD EXPR))))))
     (T (LIST EXPR)))))))
;;;; nil -> nil, (a) -> a, (a b c) -> (a & b & c)
(TRACE-LISP
 (DEFINE VALS-TO-&-EXPR (VALS &REST LKEYS)
  (trace-defun 'VALS-TO-&-EXPR (VALS LKEYS)
   (RET
    (CLET (JOINER FIRST-TIME-THROUGH) (init-keyval FIRST-TIME-THROUGH T) (init-keyval JOINER '&)
     (COND ((NULL VALS) NIL) ((SINGLETONP VALS) (COND (FIRST-TIME-THROUGH (FIRST VALS)) (T VALS)))
      (T `(,(FIRST VALS) ,JOINER ,@(VALS-TO-&-EXPR (REST VALS) :JOINER JOINER :FIRST-TIME-THROUGH NIL)))))))))
;;;; (valsets-to-&&-exprs '((a b) (c d) (e f))) -> (((a b) && (c d) && (e f)))
;;;; NOTE! (valsets-to-&&-exprs '((a b)) -> (a b)
(TRACE-LISP
 (DEFINE VALSETS-TO-&&-EXPRS (VALSETS)
  (trace-defun 'VALSETS-TO-&&-EXPRS (VALSETS)
   (RET (COND ((NULL VALSETS) NIL) ((SINGLETONP VALSETS) (FIRST VALSETS)) (T (VAL-TO-VALS (VALS-TO-&-EXPR VALSETS :JOINER '&&))))))))
;;;; (&&-exprs-to-valsets '(a b)) -> ((a b))
;;;; (&&-exprs-to-valsets '(((a b) && (c d)))) -> ((a b) (c d))
;;;; (&&-exprs-to-valsets '(((a b) && (c d) && (e f)))) -> ((a b) (c d) (e f))
;;;; (&&-exprs-to-valsets '(((a b) && (((c d) && (e f)))))) -> ((a b) (c d) (e f))
;;;; (&&-exprs-to-valsets '(((((a b) && (c d))) && (e f)))) -> ((a b) (c d) (e f))
;;;; (&&-exprs-to-valsets '(a ((a b) && (c d)))) -> ((a ((a b) && (c d))))
(TRACE-LISP
 (DEFINE &&-EXPRS-TO-VALSETS (EXPRS)
  (trace-defun '&&-EXPRS-TO-VALSETS (EXPRS)
   (RET
    (COND
     ((SINGLETONP EXPRS)
      (CLET ((EXPR (FIRST EXPRS)))
       (COND
        ((AND (LISTP EXPR) (SET-UNIFICATION-OPERATOR (SECOND EXPR)))
         (APPEND (&&-EXPRS-TO-VALSETS (FIRST EXPR))
          (COND ((TRIPLEP EXPR) (&&-EXPRS-TO-VALSETS (THIRD EXPR))) (T (&&-EXPRS-TO-VALSETS (LIST (REST (REST EXPR))))))))
        (T (LIST EXPRS)))))
     (T (LIST EXPRS)))))))
;;;; ----------------------------------------
;;;;	Digging out the constraints...
;;;; ----------------------------------------
#|Call with a SINGLE EXPRESSION. It will further call itself with either with
          (a) a single value, with :joiner = &
   or     (b) a list of values, with :joiner = &&
RETURNS the constraints embedded in the expression.

Shown below, where numbers denote things passing constraint-exprp test. 
A test procedure is in find-constraints.lisp, a multivalued version of the below.

	EXPRESSION				==>	CONSTRAINTS
	(a & 1 & 2)					(1 2)
	(a & 1 & 2 & (3 & d))				(1 2 3)
	(a & 1 & 2 & (3 & (d & 4)))			(1 2 3 4)
	((a 1) && (b 2))				(1 2)
	((a 1 b) && (c 2 d))				(1 2)
	((a 1 b) && (c 2 d) && (e f))			(1 2)
	((a 1 b) && (((c 2 d) && (e f))))		(1 2)
	((a 1 b) && (((c 2 d) && (e f 3))))		(1 2 3)
	((a 1 b) && (((c 2 d) && (e f 3) && (4))))	(1 2 3 4)
	a						nil
	((((a 1) && (b 2)) d e) && (c 3))		(3)
	((((a 1) && (b 2)) d 4) && (c 3))		(4 3)
	((((a 1) && (b 2))) && (c 3))			(1 2 3)|#
;;;; [1] aggressive decommenting of constraints
(TRACE-LISP (DEFINE FIND-CONSTRAINTS-IN-EXPRS (EXPRS) (trace-defun 'FIND-CONSTRAINTS-IN-EXPRS (EXPRS) (RET ))))
;; [1]
;;;; *MAPCAN-SAFE*
;;;; a, (a & b) (as && bs)   plurality = singular.
;;;; (a) 		    plurality = plural (1 member).
;;;; (a b) 		    plurality = plural (2 members).
;;;; ((a b)) 		    plurality = plural (1 member).
;;;; Note: (must-be-a Car)   plurality = singular   is a constraint,
;;;;   but (must-be-a Car)   plurality = plural    isn't a constraint, it's two values "must-be-a" and "Car".
;;;; Result is newly created list, so it is safe to mapcan over it.
;;;; [1]    (find-constraints ';$(_Shut-Out16 (((<> _Be-Shut-Out5)) && ((<> _Be-Shut-Out15)))) 'plural)
;;;; 	=> ((<> ;_Be-Shut-Out5;) (<> ;_Be-Shut-Out15;))
;;;; GENERALIZE THIS to find expressions of any type
(TRACE-LISP
 (DEFINE FIND-EXPRS (EXPR &REST LKEYS)
  (trace-defun 'FIND-EXPRS (EXPR LKEYS)
   (RET
    (CLET (EXPR-TYPE PLURALITY) (init-keyval PLURALITY 'SINGULAR) 
     (COND ((NULL EXPR) NIL)
      ((AND (LISTP EXPR) (UNIFICATION-OPERATOR (SECOND EXPR)))
       (COND
        ((>= (LENGTH EXPR) 4)
         (COND ((CNOT (UNIFICATION-OPERATOR (FOURTH EXPR))) (REPORT-ERROR 'USER-ERROR "Badly formed unification expression ~a!~%" EXPR)))
         (FIND-EXPRS `(,(FIRST EXPR) ,(SECOND EXPR) ,(REST (REST EXPR))) :EXPR-TYPE EXPR-TYPE :PLURALITY 'SINGULAR))
        
        (T
         (CLET ((NEXT-PLURALITY (COND ( (VAL-UNIFICATION-OPERATOR (SECOND EXPR)) 'SINGULAR) (T 'PLURAL))))
          (APPEND (FIND-EXPRS (FIRST EXPR) :EXPR-TYPE EXPR-TYPE :PLURALITY NEXT-PLURALITY)
           (FIND-EXPRS (THIRD EXPR) :EXPR-TYPE EXPR-TYPE :PLURALITY NEXT-PLURALITY))))))
      ((AND (EQ PLURALITY 'SINGULAR) 
        (CASE EXPR-TYPE (CONSTRAINT (CONSTRAINT-EXPRP EXPR)) (NON-CONSTRAINT (CNOT (CONSTRAINT-EXPRP EXPR))) (ANY T) 
         (T (REPORT-ERROR 'PROGRAM-ERROR "find-exprs: Unrecognized expr-type `~a'!~%" EXPR-TYPE))))
       (LIST EXPR))
      ((AND (EQ PLURALITY 'PLURAL)  (SINGLETONP EXPR)) (FIND-EXPRS (FIRST EXPR) :EXPR-TYPE EXPR-TYPE :PLURALITY 'SINGULAR))
      ((AND (EQ PLURALITY 'PLURAL)  (LISTP EXPR))
       (MAPCAN #'(LAMBDA (SUBEXPR) (trace-defun '#:G15812 (SUBEXPR) (RET (FIND-EXPRS SUBEXPR :EXPR-TYPE EXPR-TYPE :PLURALITY 'SINGULAR))))
        EXPR))))))))
;; [1]
;;;; ----------
;;;; This is to remove constraints from a POST-EVALUATED expression ONLY. A post-evaluated expression is
;;;;   single-valued slots: either a single value, or a single value &'ed with constraints
;;;;			   eg. (1) -> (1), ((a & (must-be x))) -> (a)
;;;;   multivalued slots:   a list of values + constraints eg. (1 2 (must-be y)) -> (1 2)
;;;; RETURNS: A list of values
;;;; (remove-constraints ';$((a & (must-be-a c)))) -> ';$(a)
;;;; (remove-constraints ';$(a b (must-be-a c))) -> ';$(a b)
(TRACE-LISP
 (DEFINE REMOVE-CONSTRAINTS (VALS)
  (trace-defun 'REMOVE-CONSTRAINTS (VALS)
   (RET
    (COND ((CNOT *ARE-SOME-CONSTRAINTS*) VALS) ((NULL VALS) NIL)
     ((AND (SINGLETONP VALS) (LISTP (FIRST VALS))  (VAL-UNIFICATION-OPERATOR (SECOND (FIRST VALS))))
      (REMOVE-IF #'CONSTRAINT-EXPRP (&-EXPR-TO-VALS (FIRST VALS))))
     (T (REMOVE-IF #'CONSTRAINT-EXPRP VALS)))))))
(TRACE-LISP
 (DEFINE EXTRACT-CONSTRAINTS (VALS)
  (trace-defun 'EXTRACT-CONSTRAINTS (VALS)
   (RET
    (COND ((CNOT *ARE-SOME-CONSTRAINTS*) NIL) ((NULL VALS) NIL)
     ((AND (SINGLETONP VALS) (LISTP (FIRST VALS))  (VAL-UNIFICATION-OPERATOR (SECOND (FIRST VALS))))
      (REMOVE-IF-NOT #'CONSTRAINT-EXPRP (&-EXPR-TO-VALS (FIRST VALS))))
     (T (REMOVE-IF-NOT #'CONSTRAINT-EXPRP VALS)))))))
;;;; ======================================================================
;;;;		RECOGNIZING DESCRIPTIONS
;;;; ======================================================================
(TRACE-LISP (DEFINE QUOTED-EXPRESSIONP (EXPR) (trace-defun 'QUOTED-EXPRESSIONP (EXPR) (RET (QUOTEP EXPR)))))
(TRACE-LISP
 (DEFINE QUOTED-DESCRIPTIONP (EXPR)
  (trace-defun 'QUOTED-DESCRIPTIONP (EXPR) (RET (AND (QUOTEP EXPR) (LISTP (UNQUOTE EXPR)) (EQ (FIRST (UNQUOTE EXPR)) '|every|))))))
;;;; '(every ...) or (the-class ...)
(TRACE-LISP (DEFINE DESCRIPTIONP (EXPR) (trace-defun 'DESCRIPTIONP (EXPR) (RET (OR (QUOTED-DESCRIPTIONP EXPR) (THE-CLASS-EXPRP EXPR))))))
(TRACE-LISP (DEFINE THE-CLASS-EXPRP (EXPR) (trace-defun 'THE-CLASS-EXPRP (EXPR) (RET (AND (LISTP EXPR) (EQ (FIRST EXPR) '|the-class|))))))
;;;; '(a Cat) -> t	   
(TRACE-LISP
 (DEFINE INSTANCE-DESCRIPTIONP (EXPR &REST LKEYS)
  (trace-defun 'INSTANCE-DESCRIPTIONP (EXPR LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (COND
      ((AND (QUOTED-EXPRESSIONP EXPR) (LISTP (UNQUOTE EXPR)))
       (COND ((EXISTENTIAL-EXPRP (UNQUOTE EXPR))) ((KM-TRIPLEP (UNQUOTE EXPR))) 
        ((EQ FAIL-MODE 'ERROR)
         (COND
          ((EQ (FIRST (UNQUOTE EXPR)) '|every|) 
           (REPORT-ERROR 'USER-ERROR "Expecting an instance description '(a ...), but found a class~%description ~a instead!~%" EXPR))
          (T (REPORT-ERROR 'USER-ERROR "Expecting an instance description '(a ...), but found~%description ~a instead!~%" EXPR))))))
      ((EQ FAIL-MODE 'ERROR)
       (REPORT-ERROR 'USER-ERROR "Expecting a quoted instance description '(a ...), but found an unquoted~%expression ~a instead!~%" EXPR))))))))
;;;; Returns the class + slotsvals (as a two-element list) , if expr is indeed a class description
(TRACE-LISP
 (DEFINE CLASS-DESCRIPTIONP (EXPR &REST LKEYS)
  (trace-defun 'CLASS-DESCRIPTIONP (EXPR LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (COND ((QUOTED-DESCRIPTIONP EXPR) (LIST (SECOND (UNQUOTE EXPR)) (REST (REST (REST (UNQUOTE EXPR))))))
      ((AND (LISTP EXPR) (EQ (FIRST EXPR) '|the-class|))
       (CLET
        ((CLASS (SECOND EXPR))
         (SLOTSVALS
          (COND ((EQ (THIRD EXPR) '|called|) `((|called| ,(LIST (FOURTH EXPR))) ,@(REST (REST (REST (REST (REST EXPR)))))))
           (T (REST (REST (REST EXPR)))))))
        (LIST CLASS SLOTSVALS)))
      ((AND (EQ FAIL-MODE 'ERROR) (QUOTEP EXPR) (EQ (FIRST (UNQUOTE EXPR)) '|a|)) 
       (REPORT-ERROR 'USER-ERROR "Expecting a class description '(every ...), but found an instance~%description ~a instead!~%" EXPR))
      ((EQ FAIL-MODE 'ERROR)
       (REPORT-ERROR 'USER-ERROR "Expecting a class description (the-class ...) or '(every ...), but found a different~%expression ~a instead!~%"
        EXPR))))))))
(TRACE-LISP
 (DEFINE CLASS-DESCRIPTION-TO-CLASS+SLOTSVALS (EXPR &REST LKEYS)
  (trace-defun 'CLASS-DESCRIPTION-TO-CLASS+SLOTSVALS (EXPR LKEYS)
   (RET (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL) (CLASS-DESCRIPTIONP EXPR :FAIL-MODE FAIL-MODE))))))
#|Note: slotp using isa causes recursion:

edit      ed   edit the source for the current stack frame
EOF            either :pop or :exit
error     err  print the last error message
evalmode  eval examine or set evaluation mode
exit      ex   exit and return to the shell
find      fin  find the stack frame calling the function `func'
focus     fo   focus the top level on a process
frame     fr   print info about current frame
[type return for next page or an integer to set the page length] 
function  fun  print and set * to the function object of this frame
help      he   print this text -- use `:help cmd-name' for more info
hide      hid  hide functions or types of stack frames
history   his  print the most recently typed user inputs
inspect   i    inspect a lisp object
kill      ki   kill a process
ld             load one or more files
ldb            Turn on/off low-level debugging
local     loc  print the value of a local (interpreted or compiled) variable
macroexpand ma call macroexpand on the argument, and pretty print it
optimize  opt  interactively set compiler optimizations
package   pa   go into a package
pop            pop up `n' (default 1) break levels
popd           cd into the previous entry on directory stack
printer-variables pri Interactively set printer control variables
processes pro  List all processes
prt            pop-and-retry the last expression which caused an error
pushd     pu   cd to a directory, pushing the directory on to the stack
pwd       pw   print the process current working directory
reset     res  return to the top-most break level
restart   rest restart the function in the current frame
return    ret  return values from the current frame
[type return for next page or an integer to set the page length] 
scont     sc   step `n' forms before stopping
set-local set-l  set the value of a local variable
sover     so   eval the current step form, with stepping turned off
step      st   turn on or off stepping
top       to   Zoom at the newest frame on the stack.
trace     tr   trace the function arguments
unarrest  unar revoke the debugging arrest reason on a process
unhide    unh  unhide functions or types of stack frames
untrace   untr stop tracing some or all functions
up             move up `n' (default 1) stack frames
who-binds who-b find bindings of a variable
who-calls who-c find callers of a function
who-references who-r find references to a variable
who-sets  who-s find setters of a variable
who-uses  who-u find references, bindings and settings of a variable
zoom      zo   print the runtime stack
[1c] USER(11): :zo 30
Error: &key list isn't even.
  [condition type: program-error]

Restart actions (select using :continue):
 0: continue computation
 1: Return to Top Level (an "abort" restart)
[2] USER(12): :pop
Previous error: Stack overflow (signal 1000)
If continued, continue computation
[1c] USER(12): :zo :depth 30
Error: Illegal keyword given: :depth.
  [condition type: program-error]

Restart actions (select using :continue):
 0: continue computation
 1: Return to Top Level (an "abort" restart)
[2] USER(13): :pop
Previous error: Stack overflow (signal 1000)
If continued, continue computation
[1c] USER(13): :zo :count 50
Evaluation stack:

... 10 more (possibly invisible) newer frames ...

   ((:internal immediate-classes0 0) X*GlobalX)
   (mapcar X<Closure X @ Xx85709ba> (X*GlobalX))
   (my-mapcan X<Closure X @ Xx85709ba> (X*GlobalX))
   (immediate-classes0 XBoxX X_Situation1X)
   (immediate-classes XBoxX)
   (instance-of XBoxX XSlotX)
   (isa XBoxX XSlotX)
   (slotp XBoxX)
   (stackable XBoxX)
   (add-to-stack XBoxX)
   (put-vals XBoxX Xinstance-ofX ...)
   (immediate-classes0 XBoxX X_Situation1X)
   (immediate-classes XBoxX)
   (instance-of XBoxX XSlotX)
   (isa XBoxX XSlotX)
   (slotp XBoxX)
   (stackable XBoxX)
   (add-to-stack XBoxX)
   (put-vals XBoxX Xinstance-ofX ...)
   (immediate-classes0 XBoxX X_Situation1X)
   (immediate-classes XBoxX)
   (instance-of XBoxX XSlotX)
   (isa XBoxX XSlotX)
   (slotp XBoxX)
   (stackable XBoxX)
 ->(add-to-stack XBoxX)
   (put-vals XBoxX Xinstance-ofX ...)
   (immediate-classes0 XBoxX X_Situation1X)
   (immediate-classes XBoxX)
   (instance-of XBoxX XSlotX)
   (isa XBoxX XSlotX)
   (slotp XBoxX)
   (stackable XBoxX)|#
;;;; FILE:  stack.lisp
;;;; File: stack.lisp
;;;; Author: Peter Clark
;;;; Date: 1994
;;;; Purpose: Maintenance of the stack
(TRACE-LISP (DEFVAR *OBJ-STACK* NIL))
(TRACE-LISP (DEFVAR *KM-STACK* NIL))
;;;; ----------
;;;; synonym
(TRACE-LISP (DEFINE NEW-CONTEXT NIL (trace-defun 'NEW-CONTEXT NIL (RET ))))
(TRACE-LISP (DEFINE CLEAR-KM-STACK NIL (trace-defun 'CLEAR-KM-STACK NIL (RET (CSETQ *KM-STACK* NIL)))))
;;(defun clear-obj-stack () (make-transaction '(setq *obj-stack* nil)))
(TRACE-LISP (DEFINE CLEAR-OBJ-STACK NIL (trace-defun 'CLEAR-OBJ-STACK NIL (RET (KM-SETQ '*OBJ-STACK* NIL)))))
(TRACE-LISP (DEFINE KM-STACK NIL (trace-defun 'KM-STACK NIL (RET *KM-STACK*))))
(TRACE-LISP (DEFINE TOP-LEVEL-GOAL NIL (trace-defun 'TOP-LEVEL-GOAL NIL (RET (FIRST (LAST-EL *KM-STACK*))))))
;;;; [1] Tiny bit slower, but allows spotting looping earlier (net loss timewise, gain inference wise)
;;;; ALSO: See looping-on later
(TRACE-LISP
 (DEFINE KM-PUSH (EXPR &OPTIONAL ID)
  (trace-defun 'KM-PUSH (EXPR ID) (RET (CSETQ *KM-STACK* (CONS (ITEM-TO-STACK (DECOMMENT EXPR) ID) *KM-STACK*))))))
;; [1]
;;;; e.g. (km-push-comment '(comment "Classifying ~a..." ;$_Car23))
(TRACE-LISP (DEFINE KM-PUSH-COMMENT (COMMENT) (trace-defun 'KM-PUSH-COMMENT (COMMENT) (RET (CSETQ *KM-STACK* (CONS COMMENT *KM-STACK*))))))
(TRACE-LISP (DEFINE KM-POP NIL (trace-defun 'KM-POP NIL (RET (PROG1 (FIRST *KM-STACK*) (CSETQ *KM-STACK* (REST *KM-STACK*)))))))
;;;; Can now add comments to the stack
(TRACE-LISP (DEFINE STACKED-COMMENTP (ITEM) (trace-defun 'STACKED-COMMENTP (ITEM) (RET (EQ (FIRST ITEM) 'COMMENT)))))
;;;; e.g. (print-stacked-comment '(comment "Classifying ~a..." ;$_Car23))
(TRACE-LISP
 (DEFINE PRINT-STACKED-COMMENT (COMMENT &OPTIONAL STREAM)
  (trace-defun 'PRINT-STACKED-COMMENT (COMMENT STREAM)
   (RET (TRACE-PROGN (SUBLISP-INITVAR STREAM T) (APPLY #'KM-FORMAT (CONS STREAM (REST COMMENT))))))))
;;;; ======================================================================
;;;; 		THE EXPRESSION STACK
;;;; ======================================================================
#| 
Looping problem with disjuncts!!! I failed to fix this
  Suppose we ask X, and X <- Y or Z, and Y <- X.
  KM will give up on Y, even if Z can compute it. This is a problem, because then
  Y might be projected from the previous situation!

The problem is that KM's triggers too easily. If, when calculating X, I hit a 
non-deterministic choice-point and take branch 1 of 2 (say), then hit a call to 
calculate X again, KM *should* continue, but this time take branch 2 of 2 at the 
same choice-point. Instead, KM just gives up. A fix would be to (i) identify 
non-deterministic choice-points (ii) mark them in the stack and (iii) steer as above.

We can do this with a REVISED LOOPING CHECK:
IF  the current call C' matches an earlier call C
THEN abort
UNLESS there is an "or" clause between C and C'.

X$or clauses: Select an option which ISN'T in the current stack (see interpreter.lisp).|#
;;;; [1] Tiny bit slower, but allows spotting looping earlier (net loss timewise, gain inference wise)
;;;; ALSO: See km-push, earlier
(TRACE-LISP (DEFINE LOOPING-ON (EXPR) (trace-defun 'LOOPING-ON (EXPR) (RET (ON-KM-STACKP (DECOMMENT EXPR))))))
;; [1] 
(TRACE-LISP
 (DEFINE ON-KM-STACKP (EXPR) (trace-defun 'ON-KM-STACKP (EXPR) (RET (CL-MEMBER (ITEM-TO-STACK EXPR) *KM-STACK* :TEST #'STACK-EQUAL)))))
;; more efficient
;;;; Note: non-canonicalized expressions (element 3 of itemN) are NOT compared
(TRACE-LISP
 (DEFINE STACK-EQUAL (ITEM1 ITEM2)
  (trace-defun 'STACK-EQUAL (ITEM1 ITEM2) (RET (AND (CL-EQUAL (FIRST ITEM1) (FIRST ITEM2))  (EQ (SECOND ITEM1) (SECOND ITEM2)))))))
;; match situation
#|Here we canonicalize the item for stacking.

Must add a note of the current situation.
[1] for &, the canonical form *isn't* situation-dependent as we unify in all situations, 
    hence returns 2nd element = *global-situation* rather than (curr-situation)|#
(TRACE-LISP
 (DEFINE ITEM-TO-STACK (EXPR &OPTIONAL ID)
  (trace-defun 'ITEM-TO-STACK (EXPR ID)
   (RET
    `(,(CANONICALIZE EXPR) ,(COND ((AND (LISTP EXPR) (UNIFICATION-OPERATOR (SECOND EXPR))) '|all situations|)  (T (CURR-SITUATION))) ,EXPR
      ,@(COND (ID (LIST ID))))))))
;;;; The three parts of an item on the stack
(TRACE-LISP (DEFINE STACKED-CANONICAL-EXPR (STACKED-ITEM) (trace-defun 'STACKED-CANONICAL-EXPR (STACKED-ITEM) (RET (FIRST STACKED-ITEM)))))
(TRACE-LISP (DEFINE STACKED-SITUATION (STACKED-ITEM) (trace-defun 'STACKED-SITUATION (STACKED-ITEM) (RET (SECOND STACKED-ITEM)))))
(TRACE-LISP (DEFINE STACKED-EXPR (STACKED-ITEM) (trace-defun 'STACKED-EXPR (STACKED-ITEM) (RET (THIRD STACKED-ITEM)))))
(TRACE-LISP (DEFINE STACKED-ID (STACKED-ITEM) (trace-defun 'STACKED-ID (STACKED-ITEM) (RET (FOURTH STACKED-ITEM)))))
;;;; [2] Must canonicalize the two forms of paths:
;;;;	(_Car23 parts) -> stack as (the parts of _Car23)
;;;; [3] Make (a & b), (b & a) into a canonical form. Strictly we should also do this for non-symbols,
;;;; 	but I don't want to do expensive structure1 @< structure2 tests to derive the canonical form.
(TRACE-LISP
 (DEFINE CANONICALIZE (EXPR)
  (trace-defun 'CANONICALIZE (EXPR)
   (RET
    (COND ((AND (PAIRP EXPR) (CNOT (CL-MEMBER (FIRST EXPR) *RESERVED-KEYWORDS*))) `(|the| ,(SECOND EXPR) |of| ,(FIRST EXPR)))
     ((AND (TRIPLEP EXPR) (SET-UNIFICATION-OPERATOR (SECOND EXPR)))  `(,(FIRST EXPR) UNIFIED-WITH ,(THIRD EXPR)))
     ((AND (TRIPLEP EXPR)  (VAL-UNIFICATION-OPERATOR (SECOND EXPR)) (NEQ (SECOND EXPR) '&+)) 
      (COND
       ((AND (SYMBOLP (FIRST EXPR)) (SYMBOLP (THIRD EXPR)) (STRING> (SYMBOL-NAME (FIRST EXPR)) (SYMBOL-NAME (THIRD EXPR))))
        `((,(THIRD EXPR)) UNIFIED-WITH (,(FIRST EXPR))))
       (T `((,(FIRST EXPR)) UNIFIED-WITH (,(THIRD EXPR))))))
     (T EXPR))))))
;;;; (a && b) (a & b) 
;;;; ----------------------------------------
;;;;	DISPLAY OF EXPRESSION STACK
;;;; ----------------------------------------
#|  <- (_Chassis70)             "(the body-parts of *MyCar)"
  (3) Look in supersituation(s)
  -> (in-situation *Global (the parts of *MyCar))g
----------------------------------------

 CURRENT GOAL STACK IS AS FOLLOWS:
 -> (the parts of *MyCar)                              [called in _Situation69]
  -> (in-situation *Global (the parts of *MyCar))      [called in _Situation69]|#
(TRACE-LISP
 (DEFINE SHOW-KM-STACK (&OPTIONAL STREAM)
  (trace-defun 'SHOW-KM-STACK (STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T)
     (CLET ((SHOW-SITUATIONSP (SOME #'(LAMBDA (ITEM) (trace-defun '#:G15813 (ITEM) (RET (NEQ (SECOND ITEM) *GLOBAL-SITUATION*)))) (KM-STACK))))
      (FORMAT STREAM "--------------------~%~%") (FORMAT STREAM " CURRENT GOAL STACK IS AS FOLLOWS:~%")
      (SHOW-KM-STACK2 (REVERSE (KM-STACK)) 1 SHOW-SITUATIONSP STREAM) (FORMAT STREAM "~%--------------------~%")))))))
(TRACE-LISP
 (DEFINE SHOW-KM-STACK2 (STACK DEPTH SHOW-SITUATIONSP &OPTIONAL STREAM)
  (trace-defun 'SHOW-KM-STACK2 (STACK DEPTH SHOW-SITUATIONSP STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T)
     (COND ((ENDP STACK) NIL)
      (T
       (CLET ((ITEM (FIRST STACK)))
        (COND
         ((STACKED-COMMENTP ITEM) (KM-FORMAT STREAM "~vT" DEPTH) (PRINT-STACKED-COMMENT ITEM STREAM) (FORMAT STREAM "~%")
          (SHOW-KM-STACK2 (REST STACK) DEPTH SHOW-SITUATIONSP STREAM))
         (T
          (CLET ( (EXPR (STACKED-EXPR ITEM)) (SITUATION (STACKED-SITUATION ITEM))) (KM-FORMAT STREAM "~vT-> ~a" DEPTH (DESOURCE EXPR))  
           (COND (SHOW-SITUATIONSP (KM-FORMAT STREAM "~vT[called in ~a]~%" 55 SITUATION)) (T (FORMAT STREAM "~%")))
           (SHOW-KM-STACK2 (REST STACK) (1+ DEPTH) SHOW-SITUATIONSP STREAM))))))))))))
;;;; ======================================================================
;;;;		THE OBJECT STACK
;;;; ======================================================================
;;;; Note we filter out duplicates and classes at access time (obj-stack), rather than 
;;;; build-time (here), for efficiency.
(TRACE-LISP
 (DEFINE ADD-TO-STACK (INSTANCE)
  (trace-defun 'ADD-TO-STACK (INSTANCE)
   (RET (COND ((AND (CNOT (CL-MEMBER INSTANCE *OBJ-STACK*)) (STACKABLE INSTANCE))  (CSETQ *OBJ-STACK* (CONS INSTANCE *OBJ-STACK*))))))))
;; don't need to unwind this
(TRACE-LISP (DEFPARAMETER *UNSTACKABLE-KB-INSTANCES* '(|t|)))
(TRACE-LISP
 (DEFINE STACKABLE (INSTANCE)
  (trace-defun 'STACKABLE (INSTANCE)
   (RET (AND (KB-OBJECTP INSTANCE) (CNOT (CLASSP INSTANCE)) (CNOT (SLOTP INSTANCE)) (CNOT (CL-MEMBER INSTANCE *UNSTACKABLE-KB-INSTANCES*)))))))
(TRACE-LISP (DEFINE REMOVE-FROM-STACK (INSTANCE) (trace-defun 'REMOVE-FROM-STACK (INSTANCE) (RET ))))
;; don't need to unwind this
;;;; ----------------------------------------
;;;; Find the first instance on *obj-stack* in class
(TRACE-LISP
 (DEFINE SEARCH-STACK (CLASS)
  (trace-defun 'SEARCH-STACK (CLASS)
   (RET (FIND-IF #'(LAMBDA (INSTANCE) (trace-defun '#:G15814 (INSTANCE) (RET (CL-ISA INSTANCE CLASS)))) *OBJ-STACK*)))))
;;;; ----------
;;;; (defun show-km-stack () ...)  See debug.lisp
(TRACE-LISP
 (DEFINE SHOW-OBJ-STACK NIL
  (trace-defun 'SHOW-OBJ-STACK NIL
   (RET (TRACE-PROGN (MAPCAR #'(LAMBDA (INSTANCE) (trace-defun '#:G15815 (INSTANCE) (RET (KM-FORMAT T "   ~a~%" INSTANCE)))) (OBJ-STACK)) T)))))
;;;; Obsolete now
(TRACE-LISP (DEFINE SHOW-CONTEXT NIL (trace-defun 'SHOW-CONTEXT NIL (RET (SHOW-OBJ-STACK)))))
;;;; Not used
;;(defun showme-context () (showme (vals-to-val (reverse (obj-stack)))) t)
(TRACE-LISP (DEFINE UNFILTERED-OBJ-STACK NIL (trace-defun 'UNFILTERED-OBJ-STACK NIL (RET *OBJ-STACK*))))
(TRACE-LISP
 (DEFINE OBJ-STACK NIL
  (trace-defun 'OBJ-STACK NIL
   (RET
    (CLET ((CLEAN-STACK (REMOVE-DUP-ATOMIC-INSTANCES *OBJ-STACK*))) (COND ((CNOT (CL-EQUAL CLEAN-STACK *OBJ-STACK*))  (CSETQ *OBJ-STACK* CLEAN-STACK)))
     CLEAN-STACK)))))
(TRACE-LISP
 (DEFINE SHOWME-STRINGS (KM-EXPR &OPTIONAL SITUATIONS THEORIES STREAM)
  (trace-defun 'SHOWME-STRINGS (KM-EXPR SITUATIONS THEORIES STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T) (SUBLISP-INITVAR THEORIES (ALL-THEORIES)) (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (SHOWME KM-EXPR SITUATIONS THEORIES STREAM T))))))
;;; [1] FLE 04Aug2005 - Updated by Francis Leboutte, return-strings-p flag
;;;; If t, returns a string or a list of strings of the output instead of the frames
(TRACE-LISP
 (DEFINE SHOWME (KM-EXPR &OPTIONAL SITUATIONS THEORIES STREAM RETURN-STRINGS-P)
  (trace-defun 'SHOWME (KM-EXPR SITUATIONS THEORIES STREAM RETURN-STRINGS-P)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T) (SUBLISP-INITVAR THEORIES (ALL-THEORIES)) (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (CLET ( (FRAMES (KM0 KM-EXPR)) (FRAME (FIRST FRAMES))  (RESULT NIL))
      (COND
       ((AND (SINGLETONP FRAMES) (NEQ KM-EXPR FRAME) (KB-OBJECTP KM-EXPR)  (IS-KM-TERM FRAME)) 
        (KM-FORMAT STREAM ";;; (~a is bound to ~a)~%~%" KM-EXPR FRAME)))
      (COND ((NULL FRAMES) (KM-FORMAT T ";;; (No frames to show: ~a evaluates to NIL)~%" KM-EXPR))
       ((SINGLETONP FRAMES) (CSETF RESULT (SHOWME-FRAME FRAME SITUATIONS THEORIES STREAM)))
       (T
        (MAPC
         #'(LAMBDA (FRAME)
            (trace-defun '#:G15816 (FRAME)
             (RET
              (TRACE-PROGN (PUSH (SHOWME-FRAME FRAME SITUATIONS THEORIES STREAM) RESULT) (PRINC ";;; ----------" STREAM) (TERPRI STREAM)
               (TERPRI STREAM)))))
         FRAMES)))
      (COND (RETURN-STRINGS-P RESULT) (T FRAMES))))))))
(TRACE-LISP
 (DEFINE SHOWME-FRAME (FRAME &OPTIONAL SITUATIONS THEORIES STREAM)
  (trace-defun 'SHOWME-FRAME (FRAME SITUATIONS THEORIES STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T) (SUBLISP-INITVAR THEORIES (ALL-THEORIES)) (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (COND
      ((CNOT (IS-KM-TERM FRAME)) (REPORT-ERROR 'NODEBUGGER-ERROR "Doing (showme-frame ~a) - the frame name `~a' should be a KB term!~%" FRAME FRAME))
      (T (PRINC (WRITE-FRAME FRAME :SITUATIONS SITUATIONS :THEORIES THEORIES) STREAM))))))))
;;;; ======================================================================
;;;; This shows all valid slots!
(TRACE-LISP
 (DEFINE SHOWME-ALL (KM-EXPR &OPTIONAL SITUATIONS)
  (trace-defun 'SHOWME-ALL (KM-EXPR SITUATIONS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (CLET ((FRAMES (KM0 KM-EXPR :FAIL-MODE 'ERROR)) (FRAME (FIRST FRAMES)))
      (COND
       ((AND (SINGLETONP FRAMES) (NEQ KM-EXPR FRAME) (KB-OBJECTP KM-EXPR)  (IS-KM-TERM FRAME)) 
        (KM-FORMAT T ";;; (~a is bound to ~a)~%~%" KM-EXPR FRAME)))
      (COND ((SINGLETONP FRAMES) (SHOWME-ALL-FRAME FRAME SITUATIONS))
       (T
        (MAPC
         #'(LAMBDA (FRAME)
            (trace-defun '#:G15817 (FRAME) (RET (TRACE-PROGN (SHOWME-ALL-FRAME FRAME SITUATIONS) (PRINC ";;; ----------") (TERPRI) (TERPRI)))))
         FRAMES)))
      FRAMES))))))
(TRACE-LISP
 (DEFINE SHOWME-ALL-FRAME (INSTANCE &OPTIONAL SITUATIONS)
  (trace-defun 'SHOWME-ALL-FRAME (INSTANCE SITUATIONS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (COND
      ((CNOT (IS-KM-TERM INSTANCE))
       (REPORT-ERROR 'NODEBUGGER-ERROR "Doing (showme-all-frame ~a) - the instance name `~a' should be a KB term!~%" INSTANCE INSTANCE))
      (T
       (MAPC
        #'(LAMBDA (SITUATION)
           (trace-defun '#:G15818 (SITUATION)
            (RET (TRACE-PROGN (SHOWME-OWN-SLOTS-IN-SITUATION INSTANCE SITUATION) (SHOWME-MEMBER-SLOTS-IN-SITUATION INSTANCE SITUATION)))))
        SITUATIONS)
       T)))))))
;;;; e.g. (Car has (superclasses (Vehicle))), (*MyCar has (instance-of (Car)))
;;;; [1] Bit inefficient, but simple:
(TRACE-LISP
 (DEFINE SHOWME-OWN-SLOTS-IN-SITUATION (INSTANCE SITUATION)
  (trace-defun 'SHOWME-OWN-SLOTS-IN-SITUATION (INSTANCE SITUATION)
   (RET
    (CLET
     ((OWN-SLOTS-TO-SHOW1 (MAPCAR #'USED-SLOT-IN (GET-SLOTSVALS INSTANCE :FACET 'OWN-PROPERTIES :SITUATION SITUATION))) 
      (OWN-SLOTS-TO-SHOW2 (MAPCAR #'USED-SLOT-IN (GET-SLOTSVALS INSTANCE :FACET 'OWN-DEFINITION :SITUATION SITUATION))) 
      (INHERITED-SLOTS-TO-SHOW
       (MY-MAPCAN
        #'(LAMBDA (CLASS)
           (trace-defun '#:G15819 (CLASS)
            (RET
             (MAPCAR #'USED-SLOT-IN
              (APPEND (GET-SLOTSVALS CLASS :FACET 'MEMBER-PROPERTIES :SITUATION SITUATION)
               (GET-SLOTSVALS CLASS :FACET 'MEMBER-DEFINITION :SITUATION SITUATION))))))
        (ALL-CLASSES INSTANCE)))
      (SLOTS-TO-SHOW (CL-REMOVE-DUPLICATES (APPEND OWN-SLOTS-TO-SHOW1 OWN-SLOTS-TO-SHOW2 INHERITED-SLOTS-TO-SHOW))))
     (COND
      (SLOTS-TO-SHOW
       (COND ((EQ SITUATION *GLOBAL-SITUATION*) (KM-FORMAT T "(~a has" INSTANCE)) (T (KM-FORMAT T "(in-situation ~a~% (~a has" SITUATION INSTANCE)))
       (MAPC
        #'(LAMBDA (SLOT)
           (trace-defun '#:G15820 (SLOT)
            (RET
             (CLET
              ((INHERITED-RULE-SETS (INHERITED-RULE-SETS2 SLOT (ALL-CLASSES INSTANCE) (LIST SITUATION)))
               (OWN-RULE-SETS
                (CL-REMOVE NIL
                 (LIST (GET-VALS INSTANCE SLOT :FACET 'OWN-PROPERTIES :SITUATION SITUATION)
                  (GET-VALS INSTANCE SLOT :FACET 'OWN-DEFINITION :SITUATION SITUATION))))
               (ALL-RULE-SETS
                (DESOURCE (BIND-SELF (CL-REMOVE-DUPLICATES (APPEND OWN-RULE-SETS INHERITED-RULE-SETS) :TEST #'CL-EQUAL :FROM-END T) INSTANCE)))
               (JOINER (COND ((SINGLE-VALUED-SLOTP SLOT) '&) (T '&&))))
              
              (COND ((SINGLETONP ALL-RULE-SETS) (KM-FORMAT T "~%  (~a " SLOT) (FORMAT T (EXPR2STRING (FIRST ALL-RULE-SETS))) (FORMAT T ")"))
               (T (PRINT-SLOT-EXPRS SLOT ALL-RULE-SETS JOINER)))))))
        (SORT (COPY-LIST SLOTS-TO-SHOW) #'STRING< :KEY #'SYMBOL-NAME))
       (COND ((EQ SITUATION *GLOBAL-SITUATION*) (KM-FORMAT T ")~%~%")) (T (KM-FORMAT T "))~%~%"))))))))))
;;;; e.g. (every Car has (parts ((a Wheel))))
(TRACE-LISP
 (DEFINE SHOWME-MEMBER-SLOTS-IN-SITUATION (CLASS SITUATION)
  (trace-defun 'SHOWME-MEMBER-SLOTS-IN-SITUATION (CLASS SITUATION)
   (RET
    (CLET
     ((ALL-CLASSES (CONS CLASS (ALL-SUPERCLASSES CLASS)))
      (SLOTS-TO-SHOW
       (CL-REMOVE-DUPLICATES
        (MY-MAPCAN
         #'(LAMBDA (CLASS)
            (trace-defun '#:G15821 (CLASS)
             (RET
              (MAPCAR #'USED-SLOT-IN
               (APPEND (GET-SLOTSVALS CLASS :FACET 'MEMBER-PROPERTIES :SITUATION SITUATION)
                (GET-SLOTSVALS CLASS :FACET 'MEMBER-DEFINITION :SITUATION SITUATION))))))
         ALL-CLASSES))))
     (COND
      (SLOTS-TO-SHOW
       (COND ((EQ SITUATION *GLOBAL-SITUATION*) (KM-FORMAT T "(every ~a has" CLASS))
        (T (KM-FORMAT T "(in-situation ~a~% (every ~a has" SITUATION CLASS)))
       (MAPC
        #'(LAMBDA (SLOT)
           (trace-defun '#:G15822 (SLOT)
            (RET
             (CLET
              ((ALL-RULE-SETS (DESOURCE (INHERITED-RULE-SETS2 SLOT ALL-CLASSES (LIST SITUATION)))) 
               (JOINER (COND ((SINGLE-VALUED-SLOTP SLOT) '&) (T '&&))))
              (COND ((SINGLETONP ALL-RULE-SETS) (KM-FORMAT T "~%  (~a " SLOT) (FORMAT T (EXPR2STRING (FIRST ALL-RULE-SETS))) (FORMAT T ")"))
               (T (PRINT-SLOT-EXPRS SLOT ALL-RULE-SETS JOINER)))))))
        (SORT (COPY-LIST SLOTS-TO-SHOW) #'STRING< :KEY #'SYMBOL-NAME))
       (COND ((EQ SITUATION *GLOBAL-SITUATION*) (KM-FORMAT T ")~%~%")) (T (KM-FORMAT T "))~%~%"))))))))))
;;;; (used-slot-in '(age (20))) -> age
;;;; (used-slot-in '(age ())) -> nil
(TRACE-LISP
 (DEFINE USED-SLOT-IN (SLOTVALS) (trace-defun 'USED-SLOT-IN (SLOTVALS) (RET (COND ((CNOT (NULL (VALS-IN SLOTVALS))) (SLOT-IN SLOTVALS)))))))
(TRACE-LISP
 (DEFINE PRINT-SLOT-EXPRS (SLOT ALL-RULE-SETS JOINER &REST LKEYS)
  (trace-defun 'PRINT-SLOT-EXPRS (SLOT ALL-RULE-SETS JOINER LKEYS)
   (RET
    (CLET (FIRST-TIME-THROUGH) (init-keyval FIRST-TIME-THROUGH T)
     (COND (FIRST-TIME-THROUGH (CASE JOINER (& (KM-FORMAT T "~%  (~a (  " SLOT)) (&& (KM-FORMAT T "~%  (~a (   " SLOT))))
      (T (KM-FORMAT T (SPACES (+ 5 (LENGTH (SYMBOL-NAME SLOT))))) (KM-FORMAT T "~a " JOINER)))
     (COND ((SINGLE-VALUED-SLOTP SLOT)  (FORMAT T (EXPR2STRING (VALS-TO-&-EXPR (FIRST ALL-RULE-SETS)))))
      (T  (FORMAT T (EXPR2STRING (FIRST ALL-RULE-SETS)))))
     
     (COND ((NULL ALL-RULE-SETS) (REPORT-ERROR 'PROGRAM-ERROR "Null all-rule-sets in print-slot-exprs (stack.lisp!)~%"))
      ((SINGLETONP ALL-RULE-SETS) (FORMAT T ")")) (T (FORMAT T "~%") (PRINT-SLOT-EXPRS SLOT (REST ALL-RULE-SETS) JOINER :FIRST-TIME-THROUGH NIL))))))))
;;;; ======================================================================
;;;; This shows all valid slots!
(TRACE-LISP
 (DEFINE EVALUATE-ALL (KM-EXPR &OPTIONAL SITUATIONS)
  (trace-defun 'EVALUATE-ALL (KM-EXPR SITUATIONS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (CLET ((FRAMES (KM0 KM-EXPR :FAIL-MODE 'ERROR)) (FRAME (FIRST FRAMES)))
      (COND
       ((AND (SINGLETONP FRAMES) (NEQ KM-EXPR FRAME) (KB-OBJECTP KM-EXPR)  (IS-KM-TERM FRAME)) 
        (KM-FORMAT T ";;; (~a is bound to ~a)~%~%" KM-EXPR FRAME)))
      (COND ((SINGLETONP FRAMES) (EVALUATE-ALL-FRAME FRAME SITUATIONS))
       (T
        (MAPC
         #'(LAMBDA (FRAME)
            (trace-defun '#:G15823 (FRAME) (RET (TRACE-PROGN (EVALUATE-ALL-FRAME FRAME SITUATIONS) (PRINC ";;; ----------") (TERPRI) (TERPRI)))))
         FRAMES)))
      FRAMES))))))
(TRACE-LISP
 (DEFINE EVALUATE-ALL-FRAME (INSTANCE &OPTIONAL SITUATIONS)
  (trace-defun 'EVALUATE-ALL-FRAME (INSTANCE SITUATIONS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (COND
      ((CNOT (IS-KM-TERM INSTANCE))
       (REPORT-ERROR 'NODEBUGGER-ERROR "Doing (evaluate-all-frame ~a) - the instance name `~a' should be a KB term!~%" INSTANCE INSTANCE))
      (T (MAPC #'(LAMBDA (SITUATION) (trace-defun '#:G15824 (SITUATION) (RET (EVALUATE-ALL-FRAME-IN-SITUATION INSTANCE SITUATION)))) SITUATIONS)
       T)))))))
(TRACE-LISP
 (DEFINE EVALUATE-ALL-FRAME-IN-SITUATION (INSTANCE SITUATION)
  (trace-defun 'EVALUATE-ALL-FRAME-IN-SITUATION (INSTANCE SITUATION)
   (RET
    (TRACE-PROGN
     (COND ((EQ SITUATION *GLOBAL-SITUATION*) (KM-FORMAT T "(~a has~%" INSTANCE)) (T (KM-FORMAT T "(in-situation ~a~% (~a has~%" SITUATION INSTANCE)))
     (MAPC
      #'(LAMBDA (SLOT)
         (trace-defun '#:G15825 (SLOT)
          (RET
           (CLET ((DOMAIN (OR (KM-UNIQUE0 `(|the| |domain| |of| ,SLOT)) '|Thing|)))
            (COND
             ((INSTANCE-OF INSTANCE DOMAIN)
              (CLET ((VALS (KM0 `(|the| ,SLOT |of| ,INSTANCE))))
               (COND ((NULL VALS) (KM-FORMAT T "  (~a ())~%" SLOT)) (T (KM-FORMAT T "  (~a ~a)~%" SLOT VALS))))))))))
      (SORT (COPY-LIST (CL-ALL-INSTANCES '|Slot|)) #'STRING< :KEY #'SYMBOL-NAME))
      (COND ((EQ SITUATION *GLOBAL-SITUATION*) (KM-FORMAT T ")~%~%")) (T (KM-FORMAT T "))~%~%"))))))))
;;;; ======================================================================
;;(defun new-proof-node-id () (gentemp "PID"))
(TRACE-LISP (DEFVAR *PID-COUNTER* 0))
(TRACE-LISP (DEFINE NEW-PROOF-NODE-ID NIL (trace-defun 'NEW-PROOF-NODE-ID NIL (RET (CSETQ *PID-COUNTER* (1+ *PID-COUNTER*))))))
;;;; FILE:  stats.lisp
;;;; File: stats.lisp
;;;; Author: Peter Clark
;;;; Date: August 1994
;;;; Purpose: Keep track and report various inference statistics
(TRACE-LISP (DEFVAR *RESET-STATISTICS-ENABLED* T))
(TRACE-LISP
 (DEFINE RESET-STATISTICS NIL
  (trace-defun 'RESET-STATISTICS NIL
   (RET
    (COND
     (*RESET-STATISTICS-ENABLED* (CSETQ *STATISTICS-CLASSIFICATION-INFERENCES* 0) (CSETQ *STATISTICS-QUERY-DIRECTED-INFERENCES* 0)
      (CSETQ *STATISTICS-KB-ACCESS* 0) (CSETQ *STATISTICS-CPU-TIME* (GET-INTERNAL-RUN-TIME)) (CSETQ *STATISTICS-MAX-DEPTH* 0)
      (CSETQ *STATISTICS-UNIFICATIONS* 0) (CSETQ *STATISTICS-SKOLEMS* 0) (CSETQ *STATISTICS-CLASSIFICATIONS-ATTEMPTED* 0)
      (CSETQ *STATISTICS-CLASSIFICATIONS-SUCCEEDED* 0)))))))
;;;; ----------
(TRACE-LISP
 (DEFINE REPORT-STATISTICS NIL
  (trace-defun 'REPORT-STATISTICS NIL
   (RET
    (CLET
     ((CPU-TIME (- (GET-INTERNAL-RUN-TIME) *STATISTICS-CPU-TIME*))
      (STATISTICS-INFERENCES (+ *STATISTICS-CLASSIFICATION-INFERENCES* *STATISTICS-QUERY-DIRECTED-INFERENCES*)))
     (CONCAT
      (FORMAT NIL "(~a inferences and ~a KB accesses in ~,1F sec" STATISTICS-INFERENCES *STATISTICS-KB-ACCESS*
       (/ CPU-TIME INTERNAL-TIME-UNITS-PER-SECOND))
      
      (COND
       ((CNOT (EQ CPU-TIME 0))
        (FORMAT NIL " [~a lips, ~a kaps])"  (FLOOR (/ (* INTERNAL-TIME-UNITS-PER-SECOND STATISTICS-INFERENCES) CPU-TIME))
         (FLOOR (/ (* INTERNAL-TIME-UNITS-PER-SECOND *STATISTICS-KB-ACCESS*) CPU-TIME)))))
      (FORMAT NIL ")~%")))))))
(TRACE-LISP
 (DEFINE REPORT-STATISTICS-LONG NIL
  (trace-defun 'REPORT-STATISTICS-LONG NIL
   (RET
    (CLET
     ((CPU-TIME (- (GET-INTERNAL-RUN-TIME) *STATISTICS-CPU-TIME*))
      (STATISTICS-INFERENCES (+ *STATISTICS-CLASSIFICATION-INFERENCES* *STATISTICS-QUERY-DIRECTED-INFERENCES*)))
     (CONCAT
      (FORMAT NIL "~a inferences (~a query-directed, ~a classification) and ~a KB accesses in ~,1F sec~%" STATISTICS-INFERENCES
       *STATISTICS-QUERY-DIRECTED-INFERENCES* *STATISTICS-CLASSIFICATION-INFERENCES* *STATISTICS-KB-ACCESS* (/ CPU-TIME INTERNAL-TIME-UNITS-PER-SECOND))
      
      (COND
       ((CNOT (EQ CPU-TIME 0))
        (FORMAT NIL " (~a inferences per second, ~a KB accesses per second).~%" 
         (FLOOR (/ (* INTERNAL-TIME-UNITS-PER-SECOND STATISTICS-INFERENCES) CPU-TIME))
         (FLOOR (/ (* INTERNAL-TIME-UNITS-PER-SECOND *STATISTICS-KB-ACCESS*) CPU-TIME)))))
      (FORMAT NIL "~a classifications attempted, of these ~a succeeded.~%" *STATISTICS-CLASSIFICATIONS-ATTEMPTED* *STATISTICS-CLASSIFICATIONS-SUCCEEDED*)
      (FORMAT NIL "~a Skolem instances created, " *STATISTICS-SKOLEMS*) (FORMAT NIL "~a unifications, " *STATISTICS-UNIFICATIONS*)
      (FORMAT NIL "maximum depth of reasoning was depth ~a.~%" *STATISTICS-MAX-DEPTH*)))))))
;;;; ======================================================================
;;;;		REPORTING INFERENCE SPEED
;;;; Set *inference-report-frequency* to a number to have KM report its spot run-time speed
;;;; ======================================================================
(TRACE-LISP (DEFPARAMETER *INFERENCE-REPORT-FREQUENCY* NIL))
(TRACE-LISP (DEFVAR *SPOT-RUNTIME* 0))
(TRACE-LISP
 (DEFINE INCREMENT-INFERENCE-STATISTICS NIL
  (trace-defun 'INCREMENT-INFERENCE-STATISTICS NIL
   (RET
    (TRACE-PROGN
     (COND (*AM-CLASSIFYING* (CSETQ *STATISTICS-CLASSIFICATION-INFERENCES* (1+ *STATISTICS-CLASSIFICATION-INFERENCES*)))
      (T (CSETQ *STATISTICS-QUERY-DIRECTED-INFERENCES* (1+ *STATISTICS-QUERY-DIRECTED-INFERENCES*))))
     (COND
      ((AND *INFERENCE-REPORT-FREQUENCY* (NUMBERP *INFERENCE-REPORT-FREQUENCY*) (> *INFERENCE-REPORT-FREQUENCY* 0))
       (CLET ((INFERENCES (+ *STATISTICS-CLASSIFICATION-INFERENCES* *STATISTICS-QUERY-DIRECTED-INFERENCES*)))
        (MULTIPLE-VALUE-BIND (NUMBER REMAINDER) (FLOOR (/ INFERENCES *INFERENCE-REPORT-FREQUENCY*)) (DECLARE (IGNORE NUMBER))
         (COND
          ((= REMAINDER 0)
           (FORMAT T "~a logical inferences done (spot speed: ~a lips)~%" INFERENCES
            (FLOOR (/ (* *INFERENCE-REPORT-FREQUENCY* INTERNAL-TIME-UNITS-PER-SECOND) (- (GET-INTERNAL-RUN-TIME) *SPOT-RUNTIME*))))
           (CSETQ *SPOT-RUNTIME* (GET-INTERNAL-RUN-TIME)))))))))))))
;;;; FILE:  sadl.lisp
;;;; File: sadl.lisp	(version 1.1)
;;;; Author: Peter Clark
;;;; Date: 2/23/01 updated 11/9/01 for direct incorporation into KM
;;;;       Totally rewritten and simplified 4/2/02 to be in line with the new SADL spec.
(TRACE-LISP
 (DEFINE DO-PLAN (EVENT-INSTANCE)
  (trace-defun 'DO-PLAN (EVENT-INSTANCE)
   (RET
    (CLET ((FIRST-SUBEVENT (KM-UNIQUE0 `(|the| |first-subevent| |of| ,EVENT-INSTANCE))))
     (COND ((NULL FIRST-SUBEVENT) (REPORT-ERROR 'USER-ERROR "do-plan: event ~a has no first-subevent, so I don't know where to start!" EVENT-INSTANCE))
      (T (FOLLOW-EVENT-CHAIN FIRST-SUBEVENT))))))))
(TRACE-LISP
 (DEFINE FOLLOW-EVENT-CHAIN (EVENT)
  (trace-defun 'FOLLOW-EVENT-CHAIN (EVENT)
   (RET
    (TRACE-PROGN (MAKE-COMMENT "Executing event ~a...~%" EVENT) (KM0 `(|do-and-next| ,EVENT) :FAIL-MODE 'ERROR)
     (CLET ((NEXT-EVENT (NEXT-EVENT EVENT)))
      (COND ((NULL NEXT-EVENT) (MAKE-COMMENT "No more next events: Finishing simulation.~%") (LIST (CURR-SITUATION)))
       (T (FOLLOW-EVENT-CHAIN NEXT-EVENT)))))))))
(TRACE-LISP
 (DEFINE NEXT-EVENT (EVENT)
  (trace-defun 'NEXT-EVENT (EVENT)
   (RET
    (CLET ((NEXT-EVENTS (KM0 `(|the| |next-event| |of| ,EVENT))) (NEXT-EVENT-TEST (KM-UNIQUE0 `(|the| |next-event-test| |of| ,EVENT))))
     (COND
      ((AND (CNOT NEXT-EVENT-TEST) (SOME #'KM-ARGSP NEXT-EVENTS))
       (REPORT-ERROR 'USER-ERROR "Missing a next-event-test on ~a!~%(It is needed to select the appropriate next-event from options: ~a)~%" EVENT
        NEXT-EVENTS))
      ((AND NEXT-EVENT-TEST (NOTEVERY #'KM-ARGSP NEXT-EVENTS))
       (REPORT-ERROR 'USER-ERROR
        "next-events for ~a should be a list of (:args <test-result> <next-event>) structures, as ~a has a next-event-test!~%(Was ~a instead)~%" EVENT
        EVENT NEXT-EVENTS))
      ((AND (CNOT NEXT-EVENT-TEST) (>= (LENGTH NEXT-EVENTS) 2))
       (REPORT-ERROR 'USER-ERROR "Multiple next-events ~a specified for event ~a! (Don't know how to handle this)~%" EVENT NEXT-EVENTS))
      ((CNOT NEXT-EVENT-TEST) (FIRST NEXT-EVENTS))
      (T 
       (CLET
        ((TEST-RESULT (KM-UNIQUE0 `(|evaluate| ,NEXT-EVENT-TEST)))
         (ACTUAL-NEXT-EVENTS
          (MAPCAR #'ARG2OF
           (REMOVE-IF-NOT #'(LAMBDA (NEXT-EVENT) (trace-defun '#:G15826 (NEXT-EVENT) (RET (CL-EQUAL (ARG1OF NEXT-EVENT) TEST-RESULT))))
            NEXT-EVENTS))))
         
        (COND ((SINGLETONP ACTUAL-NEXT-EVENTS) (FIRST ACTUAL-NEXT-EVENTS))
         ((>= (LENGTH ACTUAL-NEXT-EVENTS) 2)
          (REPORT-ERROR 'USER-ERROR "~a has multiple next-events ~a specified for the result ~a (of test ~a)~%(Don't know how to handle this)~%" EVENT
           ACTUAL-NEXT-EVENTS TEST-RESULT NEXT-EVENT-TEST))
         (T
          (MAKE-COMMENT "(No next-event of ~a matches the result ~a (of test ~a)~%(next-events were ~a)~%Ending simulation...~%" EVENT TEST-RESULT
           NEXT-EVENT-TEST NEXT-EVENTS)))))))))))
;;;; FILE:  anglify.lisp
;;;; File: anglify.lisp
;;;; Author: Peter Clark
;;;; Date: Separated out Aug 1994
;;;; Purpose: Concatenation and customisation of text-fragments
;; If nil then 3 -> "3". If t then 3 -> "the value 3"
(TRACE-LISP (DEFPARAMETER *VERBOSE-NUMBER-TO-TEXT* NIL))
;;;; ======================================================================
;;;;		CONCATENATING TEXT FRAGMENTS TOGETHER NICELY
;;;; ======================================================================
#|make-phrase/make-sentence:
INPUT: Can be either a single KM expression, or a :set / :seq of KM expressions -- make-sentence will
flatten them out and doesn't care. :set and :seq flags are ignored, and sequence is preserved.
RETURNS: A string built from these fragments, possibly capitalized and with a terminator added.

If a KM instance is included in the input, then this function will recursively replace it by (the name of <instance>)
until (the name of <instance>) just returns <instance>. This typically happens when <instance> is a class name:
	-> (the name of _Dog3) constructs (:seq "a" Dog), then calls itself again for instances in this expression
  	  -> (the name of Dog) -> Dog			; fixed point
	  <- Dog
	<- (:seq "a" Dog)

NOTE: :htmlify flag isn't used by KM, but might be by the user if (i) he/she makes a top-level call to 
	make-phrase/make-sentence, and (ii) he/she redefines (make-name ...) to respond to a :htmlify t flag.|#
(TRACE-LISP
 (DEFINE MAKE-PHRASE (TEXT &REST LKEYS)
  (trace-defun 'MAKE-PHRASE (TEXT LKEYS) (RET (CLET (HTMLIFY) (MAKE-SENTENCE TEXT :CAPITALIZE NIL :TERMINATOR "" :HTMLIFY HTMLIFY))))))
(TRACE-LISP
 (DEFINE MAKE-SENTENCE (TEXT &REST LKEYS)
  (trace-defun 'MAKE-SENTENCE (TEXT LKEYS)
   (RET
    (CLET (CAPITALIZE TERMINATOR HTMLIFY) (init-keyval TERMINATOR ".") (init-keyval CAPITALIZE T)
     (CLET
      ((NEW-STRING
        (CONCAT-LIST
         (SPACIFY
          (CL-REMOVE NIL
           (MAPCAR
            #'(LAMBDA (I)
               (trace-defun '#:G15827 (I)
                (RET
                 (COND ((NULL I) NIL) ((STRINGP I) I) ((NUMBERP I) (PRINC-TO-STRING I)) ((CL-MEMBER I '(:|seq| :|set| :|triple|)) NIL)
                  ((SYMBOLP I) (CL-STRING-DOWNCASE I))
                  (T (REPORT-ERROR 'USER-ERROR "make-sentence/phrase: Don't know how to convert ~a to a string!~%" I))))))
            (CL-FLATTEN (LISTIFY (EXPAND-TEXT TEXT :HTMLIFY HTMLIFY)))))))))
      (COND ((STRING= NEW-STRING "") "")
       (T
        (CLET ((TERMINATED-STRING (COND ((CNOT (CL-ENDS-WITH NEW-STRING TERMINATOR)) (CONCAT NEW-STRING TERMINATOR)) (T NEW-STRING))))
         (COND (CAPITALIZE (CAPITALIZE TERMINATED-STRING)) (T TERMINATED-STRING)))))))))))
#|expand-text: This function takes a KM structure or atom, eg. a (:seq ...) structure, and recursively expands
it to more primitive fragments using calls to (name ...). It eventually bottoms out when (name X) returns X. An
example of the expansion might be:
   (:seq _Engine23 "has purpose" _Purpose24)
-> (:seq (:seq "a" Engine) "has purpose" ("a" Propelling "whose object is" _Airplane25))
-> (:seq (:seq "a" Engine) "has purpose" ("a" Propelling "whose object is" (:seq "a" Airplane)))   [<= final result]
   
where (name _Engine23) -> (:seq "a" Engine)
      (name _Purpose24) -> ("a" Propelling "whose object is" _Airplane24)
      (name _Airplane25) -> (:seq "a" Airplane)|#
(TRACE-LISP
 (DEFINE EXPAND-TEXT (ITEM &REST LKEYS)
  (trace-defun 'EXPAND-TEXT (ITEM LKEYS)
   (RET
    (CLET (HTMLIFY DEPTH) (init-keyval DEPTH 0)
     (CLET ((EXPANDED (CL-REMOVE ':|seq| (CL-FLATTEN (EXPAND-TEXT0 ITEM :HTMLIFY HTMLIFY :DEPTH DEPTH)))))
      (COND ((NULL EXPANDED) NIL) ((SINGLETONP EXPANDED) (FIRST EXPANDED)) (T (CONS ':|seq| EXPANDED)))))))))
(TRACE-LISP
 (DEFINE EXPAND-TEXT0 (ITEM &REST LKEYS)
  (trace-defun 'EXPAND-TEXT0 (ITEM LKEYS)
   (RET
    (CLET (HTMLIFY DEPTH) (init-keyval DEPTH 0)
     (COND ((> DEPTH 100) (REPORT-ERROR 'USER-ERROR "make-sentence/phrase: Infinite recursion when generating name for ~a!~%" ITEM))
      ((STRINGP ITEM) ITEM)
      ((NUMBERP ITEM)
       (COND (*VERBOSE-NUMBER-TO-TEXT* (LIST "the value" ITEM)) ((INTEGERP ITEM) ITEM)
        (*OUTPUT-PRECISION*
         (COND ((>= ITEM 1.0) (FORMAT NIL (CONCAT "~," (PRINC-TO-STRING *OUTPUT-PRECISION*) "f") ITEM))
          ((>= ITEM (EXPT 10 (- *OUTPUT-PRECISION*))) (FORMAT NIL (CONCAT "~," (PRINC-TO-STRING (- *OUTPUT-PRECISION* (FLOOR (LOG ITEM 10)))) "f") ITEM))
          (T (FORMAT NIL (CONCAT "~," (PRINC-TO-STRING *OUTPUT-PRECISION*) "e") ITEM))))
        (T ITEM)))
       ((AND (NULL ITEM) *DEVELOPER-MODE*) (LIST "??"))
      ((LISTP ITEM) (MAPCAR #'(LAMBDA (I) (trace-defun '#:G15828 (I) (RET (EXPAND-TEXT0 I :HTMLIFY HTMLIFY :DEPTH (1+ DEPTH))))) ITEM))
      ((CL-MEMBER ITEM '(:|seq| :|set| :|bag| :|pair|)) ITEM)
      ((OR (KB-OBJECTP ITEM) (KM-TRIPLEP ITEM)) (CLET ((NAME (NAME ITEM))) (COND ((CL-EQUAL NAME ITEM) ITEM) (T (EXPAND-TEXT0 NAME :DEPTH (1+ DEPTH))))))
      (T (REPORT-ERROR 'USER-ERROR "make-sentence/phrase: Bad element `~a' encountered!!~%" ITEM))))))))
#| The htmlify flag is passed here in case the user wants to redefine make-name to actually do something with the flag!
(defun make-name (item &key htmlify)
  (declare (ignore htmlify))
  (let ( (names (km0 `X$(the name of ,ITEM))) )
    (cond ((singletonp names) 
	   (cond ((stringp (first names)) (first names))
		 (t (report-error 'user-error "make-sentence/phrase: (the name of ~a) should return a string,~%but it returned ~a instead!~%"
				  item (first names)))))
	  ((null names) "???")
	  (t (report-error 'user-error "make-sentence/phrase: (the name of ~a) should return a single string,~%but it returned ~a instead!~%"
			   item names)))))|#
(TRACE-LISP (DEFPARAMETER *NOSPACE-STRING* "nospace"))
;;;; This could be written a million times better!
;;;; words = A flattened list of strings.
;;;; Periods must be a separate string (".") for capitalization to work
;;;; properly.
(TRACE-LISP
 (DEFINE SPACIFY (WORDS)
  (trace-defun 'SPACIFY (WORDS)
   (RET
    (COND ((NULL WORDS) NIL) ((SINGLETONP WORDS) WORDS)
     ((WHITE-SPACE-P (SECOND WORDS) :WHITESPACE-CHARS '(#\Space #\Tab))  (SPACIFY (CONS (FIRST WORDS) (REST (REST WORDS)))))
     ((STRING= (FIRST WORDS) ".")
      (COND
       ((AND (STRING= (SECOND WORDS) (STRING #\Newline)) (CNOT (NULL (THIRD WORDS))))
        (CONS (FIRST WORDS) (CONS (SECOND WORDS) (SPACIFY (CONS (CAPITALIZE (THIRD WORDS)) (REST (REST (REST WORDS))))))))
       (T (CONS ". " (SPACIFY (CONS (CAPITALIZE (SECOND WORDS)) (REST (REST WORDS))))))))
         ((STRING= (FIRST WORDS) *NOSPACE-STRING*)  (SPACIFY (REST WORDS)))
     ((STRING= (SECOND WORDS) *NOSPACE-STRING*) (CONS (FIRST WORDS) (SPACIFY (REST (REST WORDS)))))
     (T (CONS (FIRST WORDS) (CONS (A-SPACE (FIRST WORDS) (SECOND WORDS)) (SPACIFY (REST WORDS))))))))))
;;;; "dog" -> "Dog"
(TRACE-LISP
 (DEFINE CAPITALIZE (STRING) (trace-defun 'CAPITALIZE (STRING) (RET (CONCAT (STRING-UPCASE (CL-FIRST-CHAR STRING)) (BUTFIRST-CHAR STRING))))))
;;;; Crude!
;;;; (a-space "cat" "dog") -> " "
;;;; (a-space "cat" " dog") -> ""
;;;; (a-space "cat " "dog") -> ""
(TRACE-LISP
 (DEFINE A-SPACE (WORD1 WORD2)
  (trace-defun 'A-SPACE (WORD1 WORD2)
   (RET (COND ((NO-FOLLOWING-SPACES (CL-LAST-CHAR WORD1)) "") ((NO-PRECEEDING-SPACES (CL-FIRST-CHAR WORD2)) "") (T " "))))))
(TRACE-LISP (DEFINE NO-FOLLOWING-SPACES (CHAR) (trace-defun 'NO-FOLLOWING-SPACES (CHAR) (RET (CL-MEMBER CHAR '(#\( #\Space))))))
(TRACE-LISP (DEFINE NO-PRECEEDING-SPACES (CHAR) (trace-defun 'NO-PRECEEDING-SPACES (CHAR) (RET (CL-MEMBER CHAR '(#\' #\) #\. #\, #\Space))))))
;;;; ======================================================================
;;;;			NAMES OF FRAMES
;;;; ======================================================================
#|Name returns a (possibly nested) list of fragments, which together produce a top-level name
for an object. name *doesn't* call itself recursively.

To recursively expand the name for objects, use make-phrase or make-sentence. These two functions
recursively convert symbols to their name structures, and then flatten, stringify, and concatenate 
the result.|#
(TRACE-LISP
 (DEFINE NAME (CONCEPT &REST LKEYS)
  (trace-defun 'NAME (CONCEPT LKEYS)
   (RET
    (CLET (HTMLIFY)
     (COND ((TRACEP) (PROG2 (SUSPEND-TRACE) (NAME0 CONCEPT :HTMLIFY HTMLIFY) (UNSUSPEND-TRACE))) (T (NAME0 CONCEPT :HTMLIFY HTMLIFY))))))))
;;;; [1] to prevent situation-specific instances all inheriting name "the thing" from the global situation!
;;;;     9/18/02 - this is no longer applicable, as KM no longer evaluates situation-specific stuff globally
;;;; [2] Ken Barker doesn't want this.
(TRACE-LISP
 (DEFINE NAME0 (CONCEPT &REST LKEYS)
  (trace-defun 'NAME0 (CONCEPT LKEYS)
   (RET
    (CLET (HTMLIFY)
     (COND ((STRINGP CONCEPT) CONCEPT) ((NUMBERP CONCEPT) (PRINC-TO-STRING CONCEPT))  ((KM-TRIPLEP CONCEPT) (TRIPLE-NAME CONCEPT))
      ((CLET ((NAME (KM0 `(|the| |name| |of| ,CONCEPT))))
        (COND ((SINGLETONP NAME) (FIRST NAME))
         ((CNOT (NULL NAME))
          (MAKE-COMMENT "Warning! ~a has multiple name expressions ~a!~%     Continuing just using the first (~a)..." CONCEPT NAME (FIRST NAME))
          (FIRST NAME)))))
      ((KM-UNIQUE0 `(|the| |name| |of| ,CONCEPT))) ((SYMBOL-STARTS-WITH CONCEPT #\*)  (BUTFIRST-CHAR (CL-STRING-DOWNCASE CONCEPT)))
      ((ANONYMOUS-INSTANCEP CONCEPT) (COND (T  (ANONYMOUS-INSTANCE-NAME CONCEPT :HTMLIFY HTMLIFY)))) ((ATOM CONCEPT) (CL-STRING-DOWNCASE CONCEPT))
      (T CONCEPT)))))))
(TRACE-LISP
 (DEFINE ANONYMOUS-INSTANCE-NAME (CONCEPT &REST LKEYS)
  (trace-defun 'ANONYMOUS-INSTANCE-NAME (CONCEPT LKEYS)
   (RET (CLET (HTMLIFY) (DECLARE (IGNORE HTMLIFY))  `(:|seq| "the" ,(NAME (FIRST (IMMEDIATE-CLASSES CONCEPT)))))))))
;;;; ----------
#|Not used any more
(defun prototype-name (concept &key htmlify)
  (declare (ignore htmlify))
  (cond ((not (protoinstancep concept))
	 (report-error 'user-error "Trying to generate prototype name of non-prototype ~a!~%" concept))
	((prototypep concept)
	 (or (km-unique0 `X$(the name of ,CONCEPT))
	     (let ( (parent (first (immediate-classes concept))) )
	       `(X$:seq "a" ,(name parent)))))
	(t `(X$:seq "the" ,(name (first (immediate-classes concept))) 
		  "of" ,(prototype-name (km-unique0 `X$(the prototype-participant-of of ,CONCEPT) :fail-mode 'error))))))|#
;;;; ----------
#|CL-USER> (triple-name 'X$(:triple *pete owns (:set *money *goods *food)))
(:XseqX "pete" XownsX (:XseqX "money" ", " "goods" ", and " "food"))
CL-USER> (triple-name 'X$(:triple *pete believes (:triple *joe owns *goods)))
(:XseqX "pete" XbelievesX (:XseqX "joe" XownsX "goods"))|#
(TRACE-LISP
 (DEFINE TRIPLE-NAME (TRIPLE &REST LKEYS)
  (trace-defun 'TRIPLE-NAME (TRIPLE LKEYS)
   (RET
    (CLET (HTMLIFY)
     (CLET ((VALS (VAL-TO-VALS (FOURTH TRIPLE))))
      (LIST ':|seq| (NAME (SECOND TRIPLE) :HTMLIFY HTMLIFY)  (NAME (THIRD TRIPLE) :HTMLIFY HTMLIFY) 
       (COND ((NULL VALS) NIL) ((SINGLETONP VALS) (NAME (FIRST VALS) :HTMLIFY HTMLIFY))
        (T (CONS ':|seq| (ANDIFY (MAPCAR #'(LAMBDA (V) (NAME V :HTMLIFY HTMLIFY)) VALS))))))))))))
;;;; FILE:  writer.lisp
;;;; File: writer.lisp
;;;; Author: Peter Clark
;;;; Date: Mar 1996 spliced out later
;;;; Purpose: Copy of updated write-frame from server/frame-dev.lisp
;;;; frame can be *any* valid KM term, including strings, numbers, sets, sequences, functions, and normal frames.
(TRACE-LISP
 (DEFINE WRITE-FRAME (FRAME &REST LKEYS)
  (trace-defun 'WRITE-FRAME (FRAME LKEYS)
   (RET
    (CLET (SITUATIONS THEORIES HTMLIFY NULLS-OKAYP) (init-keyval THEORIES (ALL-THEORIES)) (init-keyval SITUATIONS (ALL-SITUATIONS))
     (COND ((AND (KB-OBJECTP FRAME) (BOUND FRAME)) (KM-FORMAT NIL ";;; (~a is bound to ~a)~%~%" FRAME (DEREFERENCE FRAME)))
      (T
       (CLET ((FRAME-STRING (WRITE-FRAME0 FRAME SITUATIONS THEORIES HTMLIFY)))
        (COND ((STRING/= FRAME-STRING "") FRAME-STRING)
         ((BUILT-IN-CONCEPT-TYPE FRAME)
          (CONCAT (KM-FORMAT NIL ";;; (Concept ~a is a built-in " FRAME) (BUILT-IN-CONCEPT-TYPE FRAME) (FORMAT NIL ")~%~%")))
         (NULLS-OKAYP (KM-FORMAT NIL "(~a has)~%~%" FRAME))
         ((AND (NULL (SET-DIFFERENCE (ALL-SITUATIONS) SITUATIONS)) (NULL (SET-DIFFERENCE (ALL-THEORIES) THEORIES)))
          (KM-FORMAT NIL ";;; (Concept ~a is not declared anywhere in the KB)~%~%" FRAME))
         ((NULL (ALL-THEORIES)) (KM-FORMAT NIL ";;; (Concept ~a is not declared in the situations ~a)~%~%" FRAME SITUATIONS))
         (T (KM-FORMAT NIL ";;; (Concept ~a is not declared in the situations ~a nor the theories ~a)~%~%" FRAME SITUATIONS THEORIES)))))))))))
(TRACE-LISP
 (DEFINE WRITE-FRAME0 (FRAME &OPTIONAL SITUATIONS THEORIES HTMLIFY)
  (trace-defun 'WRITE-FRAME0 (FRAME SITUATIONS THEORIES HTMLIFY)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR THEORIES (ALL-THEORIES)) (SUBLISP-INITVAR SITUATIONS (ALL-SITUATIONS))
     (COND ((STRINGP FRAME) (KM-FORMAT NIL ";;; (~a is a string)~%~%" FRAME)) ((NUMBERP FRAME) (KM-FORMAT NIL ";;; (~a is a number)~%~%" FRAME))
      ((DESCRIPTIONP FRAME) (KM-FORMAT NIL ";;; (~a is a quoted expression)~%~%" FRAME))
      ((KM-SEQP FRAME) (KM-FORMAT NIL ";;; (~a is a sequence)~%~%" FRAME)) ((KM-SETP FRAME) (KM-FORMAT NIL ";;; (~a is a set)~%~%" FRAME))
      ((KM-ARGSP FRAME) (KM-FORMAT NIL ";;; (~a is an argument list)~%~%" FRAME))
      ((FUNCTIONP FRAME) (KM-FORMAT NIL ";;; (~a is a Lisp function)~%~%" FRAME))
      ((KB-OBJECTP FRAME)
       (CONCAT-LIST
        (CONS (COND ((MEMBER *GLOBAL-SITUATION* SITUATIONS)  (WRITE-FRAME-IN-SITUATION FRAME *GLOBAL-SITUATION* :HTMLIFY HTMLIFY)) (T ""))
         (APPEND
          (LET ((PROTOTYPES (GET-VALS FRAME '|prototypes| :SITUATION *GLOBAL-SITUATION*)))
           (COND
            (PROTOTYPES
             (APPEND (LIST (KM-FORMAT NIL "#|"))
              (MAPCAN
               #'(LAMBDA (PROTOTYPE)
                  (CONS (KM-FORMAT NIL "~%;;; Prototype ~a defined by:~%" PROTOTYPE)
                   (MAPCAR #'(LAMBDA (EXPR)  (CONCAT (EXPR2STRING EXPR HTMLIFY) (FORMAT NIL "~%"))) (DEREFERENCE (GET PROTOTYPE 'DEFINITION)))))
               PROTOTYPES)
              (LIST (KM-FORMAT NIL "|#~%~%"))))))
          (MAPCAR #'(LAMBDA (THEORY) (WRITE-FRAME-IN-SITUATION FRAME THEORY :HTMLIFY HTMLIFY :THEORYP T)) THEORIES)
          (APPEND (FLATTEN (WRITE-SITUATION-SPECIFIC-ASSERTIONS FRAME :HTMLIFY HTMLIFY))
           (MAPCAR #'(LAMBDA (SITUATION) (WRITE-FRAME-IN-SITUATION FRAME SITUATION :HTMLIFY HTMLIFY)) (REMOVE *GLOBAL-SITUATION* SITUATIONS)))))))
      (T (REPORT-ERROR 'USER-ERROR "~a is not a KB object!~%" FRAME))))))))
(TRACE-LISP
 (DEFINE WRITE-SITUATION-SPECIFIC-ASSERTIONS (SITUATION-CLASS &REST LKEYS)
  (trace-defun 'WRITE-SITUATION-SPECIFIC-ASSERTIONS (SITUATION-CLASS LKEYS)
   (RET
    (CLET (HTMLIFY)
     (COND
      ((IS-SUBCLASS-OF SITUATION-CLASS '|Situation|)
       (CLET
        ((ASSERTIONS (SECOND (ASSOC '|assertions| (DESOURCE0 (GET-SLOTSVALS SITUATION-CLASS :FACET 'MEMBER-PROPERTIES :SITUATION *GLOBAL-SITUATION*))))))
        (COND
         (ASSERTIONS
          (MAPCAR
           #'(LAMBDA (ASSERTION)
              (trace-defun '#:G15829 (ASSERTION)
               (RET
                (COND
                 ((CNOT (QUOTEP ASSERTION))
                  (REPORT-ERROR 'USER-ERROR "Unquoted assertion ~a in situation-class ~a! Ignoring it...~%" ASSERTION SITUATION-CLASS) "")
                 (T
                  (CLET ((MODIFIED-ASSERTION (SUBLIS '((|SubSelf| . |Self|) ((UNQUOTE |Self|) . |TheSituation|)) (SECOND ASSERTION) :TEST #'CL-EQUAL)))
                   (LIST (KM-FORMAT NIL "(in-every-situation ") (OBJWRITE SITUATION-CLASS HTMLIFY) (KM-FORMAT NIL "~%  ")
                    (OBJWRITE MODIFIED-ASSERTION HTMLIFY) (KM-FORMAT NIL ")~%~%"))))))))
           ASSERTIONS)))))))))))
;;;; If no data, then returns ""
(TRACE-LISP
 (DEFINE WRITE-FRAME-IN-SITUATION (FRAME SITUATION &REST LKEYS)
  (trace-defun 'WRITE-FRAME-IN-SITUATION (FRAME SITUATION LKEYS)
   (RET
    (CLET (HTMLIFY THEORYP)
     (CLET
      ((OWN-PROPS (DESOURCE0 (GET-SLOTSVALS FRAME :FACET 'OWN-PROPERTIES :SITUATION SITUATION)))
       (MBR-PROPS (DESOURCE0 (GET-SLOTSVALS FRAME :FACET 'MEMBER-PROPERTIES :SITUATION SITUATION)))
       (OWN-DEFN (DESOURCE0 (GET-SLOTSVALS FRAME :FACET 'OWN-DEFINITION :SITUATION SITUATION)))
       (MBR-DEFN (DESOURCE0 (GET-SLOTSVALS FRAME :FACET 'MEMBER-DEFINITION :SITUATION SITUATION))))
      (CONCAT
       (COND (OWN-DEFN (CONCAT-LIST (CL-FLATTEN (WRITE-FRAME2 FRAME SITUATION OWN-DEFN NIL '|has-definition| :HTMLIFY HTMLIFY :THEORYP THEORYP)))))
       (COND
        ((AND OWN-PROPS (CNOT (AND (SINGLETONP OWN-PROPS) (EQ (FIRST (FIRST OWN-PROPS)) '|assertions|)))) 
         (CONCAT-LIST (CL-FLATTEN (WRITE-FRAME2 FRAME SITUATION OWN-PROPS NIL '|has| :HTMLIFY HTMLIFY :THEORYP THEORYP)))))
       (COND (MBR-DEFN (CONCAT-LIST (CL-FLATTEN (WRITE-FRAME2 FRAME SITUATION MBR-DEFN '|every| '|has-definition| :HTMLIFY HTMLIFY :THEORYP THEORYP)))))
       (COND
        ((AND MBR-PROPS (CNOT (AND (SINGLETONP MBR-PROPS) (EQ (FIRST (FIRST MBR-PROPS)) '|assertions|)))) 
         (CONCAT-LIST (CL-FLATTEN (WRITE-FRAME2 FRAME SITUATION MBR-PROPS '|every| '|has| :HTMLIFY HTMLIFY :THEORYP THEORYP))))))))))))
;;;; theoryp = 'ignore suppresses the (in-theory ... ) wrapper, but we ignore that for now
(TRACE-LISP
 (DEFINE WRITE-FRAME2 (FRAME SITUATION SLOTSVALS0 QUANTIFIER JOINER &REST LKEYS)
  (trace-defun 'WRITE-FRAME2 (FRAME SITUATION SLOTSVALS0 QUANTIFIER JOINER LKEYS)
   (RET
    (CLET (HTMLIFY THEORYP)
     (CLET ((SLOTSVALS (DEREFERENCE SLOTSVALS0)) (TAB (COND ((EQ SITUATION *GLOBAL-SITUATION*) 0) (T 2))))
      (LIST
       (COND
        ((AND (NEQ SITUATION *GLOBAL-SITUATION*) (NEQ THEORYP 'IGNORE))
         (LIST (COND ((EQ THEORYP T) (KM-FORMAT NIL "(in-theory ")) (T (KM-FORMAT NIL "(in-situation "))) (OBJWRITE SITUATION HTMLIFY)
          (KM-FORMAT NIL "~%"))))
       (COND ((NOT (EQ TAB 0)) (FORMAT NIL "~vT" TAB)))  (COND (QUANTIFIER (KM-FORMAT NIL "(~a " QUANTIFIER))  (T "(")) (OBJWRITE FRAME HTMLIFY)
       (KM-FORMAT NIL " ~a " JOINER)  (WRITE-SLOTSVALS SLOTSVALS (+ TAB 2) HTMLIFY) ")"
       (COND ((AND (NEQ SITUATION *GLOBAL-SITUATION*) (NEQ THEORYP 'IGNORE)) ")")) (FORMAT NIL "~%~%"))))))))
(TRACE-LISP
 (DEFINE WRITE-SLOTSVALS (SLOTSVALS &OPTIONAL TAB HTMLIFY)
  (trace-defun 'WRITE-SLOTSVALS (SLOTSVALS TAB HTMLIFY)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TAB 2)
     (MAPCAR #'(LAMBDA (SLOTVALS) (trace-defun '#:G15830 (SLOTVALS) (RET (WRITE-SLOTVALS SLOTVALS TAB HTMLIFY)))) SLOTSVALS))))))
(TRACE-LISP
 (DEFINE WRITE-SLOTVALS (SLOTVALS &OPTIONAL TAB HTMLIFY)
  (trace-defun 'WRITE-SLOTVALS (SLOTVALS TAB HTMLIFY)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TAB 2)
     (COND ((NULL SLOTVALS) (FORMAT NIL " ()")) ((EQ (SLOT-IN SLOTVALS) '|assertions|) "")
      (T
       (LIST (FORMAT NIL "~%~vT(" TAB) (OBJWRITE (SLOT-IN SLOTVALS) HTMLIFY) " "
        (WRITE-VALS (REMOVE-DUP-INSTANCES (VALS-IN SLOTVALS)) (+ TAB 3 (LENGTH (KM-FORMAT NIL "~a" (SLOT-IN SLOTVALS)))) HTMLIFY)
        (COND ((> (LENGTH SLOTVALS) 2) (REPORT-ERROR 'USER-ERROR "Extra element(s) in slotvals list!~%~a. Ignoring them...~%" SLOTVALS))) ")"))))))))
(TRACE-LISP
 (DEFINE WRITE-VALS (VALS &OPTIONAL TAB HTMLIFY)
  (trace-defun 'WRITE-VALS (VALS TAB HTMLIFY)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TAB 2)
     (COND ((NULL VALS) "()")
      (T
       (LIST "(" (OBJWRITE (FIRST VALS) HTMLIFY) (MAPCAR #'(LAMBDA (VAL) (LIST (FORMAT NIL "~%~vT" TAB) (OBJWRITE VAL HTMLIFY))) (REST VALS)) ")"))))))))
(TRACE-LISP
 (DEFINE WRITE-KMEXPR (KMEXPR _TAB HTMLIFY)
  (trace-defun 'WRITE-KMEXPR (KMEXPR _TAB HTMLIFY) (RET (TRACE-PROGN (DECLARE (IGNORE _TAB)) (OBJWRITE KMEXPR HTMLIFY))))))
;;;; (expr2string ';$(the '(age of ;,person))) -> "(the '(age of ;,person))"
(TRACE-LISP
 (DEFINE EXPR2STRING (EXPR &OPTIONAL HTMLIFY)
  (trace-defun 'EXPR2STRING (EXPR HTMLIFY) (RET (CONCAT-LIST (CL-REMOVE NIL (CL-FLATTEN (OBJWRITE EXPR HTMLIFY))))))))
;;;; convert to strings to remove package info:
;;;; [1c] USER(143): (first '`(the ,car))
;;;; excl::backquote
(TRACE-LISP
 (DEFINE OBJWRITE (EXPR &OPTIONAL HTMLIFY)
  (trace-defun 'OBJWRITE (EXPR HTMLIFY)
   (RET
    (COND ((ATOM EXPR) (OBJWRITE2 EXPR HTMLIFY))
     ((AND (PAIRP EXPR) (SYMBOLP (FIRST EXPR)) (ASSOC (FIRST EXPR) *SPECIAL-SYMBOL-ALIST*))
      (CLET ((SPECIAL-SYMBOL-STR (SECOND (ASSOC (FIRST EXPR) *SPECIAL-SYMBOL-ALIST*)))) (LIST SPECIAL-SYMBOL-STR (OBJWRITE (SECOND EXPR) HTMLIFY))))
     ((LISTP EXPR) (LIST "(" (OBJWRITE (FIRST EXPR) HTMLIFY) (MAPCAR #'(LAMBDA (ITEM) (LIST " " (OBJWRITE ITEM HTMLIFY))) (REST EXPR)) ")"))
     (T (REPORT-ERROR 'USER-ERROR "Don't know how to (objwrite ~a)!~%" EXPR)))))))
;;;; Default server action, when interfaced with Web browser. Not used in KM stand-alone
(TRACE-LISP (DEFPARAMETER *HTML-ACTION* '"frame"))
;; (defparameter *html-window* '"target=right")
(TRACE-LISP (DEFPARAMETER *HTML-WINDOW* '""))
;;;; The primitive write operation
;;;; [1] Include ;;s: (symbol-name ';the dog;) -> "the dog", while (km-format nil "~a" ';the dog;) -> ";the dog;".
(TRACE-LISP
 (DEFINE OBJWRITE2 (EXPR HTMLIFY &REST LKEYS)
  (trace-defun 'OBJWRITE2 (EXPR HTMLIFY LKEYS)
   (RET
    (CLET (ACTION WINDOW) (init-keyval WINDOW *HTML-WINDOW*) (init-keyval ACTION *HTML-ACTION*)
     (COND ((AND HTMLIFY (KB-OBJECTP EXPR) (KNOWN-FRAME EXPR))  (HTEXTIFY EXPR (KM-FORMAT NIL "~a" EXPR) :ACTION ACTION :WINDOW WINDOW)) 
      ((EQ EXPR NIL) "()") (T (KM-FORMAT NIL "~a" EXPR))))))))
;;;; FILE:  taxonomy.lisp
;;;; File: taxonomy.lisp
;;;; Author: Peter Clark
;;;; Date: April 96
;;;; Purpose: Print out the frame hierarchy
;;;; Warning: Frighteningly inefficient.
(TRACE-LISP (DEFCONSTANT *INDENT-INCREMENT* 3))
(TRACE-LISP (DEFCONSTANT *PRUNE-POINTS* NIL))
(TRACE-LISP (DEFCONSTANT *IGNORE-ITEMS* NIL))
(TRACE-LISP (DEFCONSTANT *MAXDEPTH* 9999))
(TRACE-LISP
 (DEFINE TAXONOMY (&OPTIONAL CURRENT-NODE RELATION-TO-DESCEND HTMLIFY)
  (trace-defun 'TAXONOMY (CURRENT-NODE RELATION-TO-DESCEND HTMLIFY)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR RELATION-TO-DESCEND '|subclasses|) (SUBLISP-INITVAR CURRENT-NODE '|Thing|)
     (WRITE-LINES (MAKE-TAX CURRENT-NODE RELATION-TO-DESCEND HTMLIFY)) '(|t|))))))
;;;; Rather ugly -- returns two values
;;;; (i) a list of strings, = the taxonomy
;;;; (ii) a list of all the concepts processed (= all of them)
(TRACE-LISP
 (DEFINE MAKE-TAX (&OPTIONAL CURRENT-NODE RELATION-TO-DESCEND HTMLIFY)
  (trace-defun 'MAKE-TAX (CURRENT-NODE RELATION-TO-DESCEND HTMLIFY)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR RELATION-TO-DESCEND '|subclasses|) (SUBLISP-INITVAR CURRENT-NODE '|Thing|)
     (COND ((EQ RELATION-TO-DESCEND '|subclasses|) (CLEAN-TAXONOMY)))
     (COND
      ((AND (EQ CURRENT-NODE '|Thing|) (EQ RELATION-TO-DESCEND '|subclasses|))
       (CLET ((ALL-OBJECTS (DEREFERENCE (GET-ALL-CONCEPTS))) (TOP-CLASSES (IMMEDIATE-SUBCLASSES '|Thing|)))
        (MULTIPLE-VALUE-BIND (STRINGS ALL-NODES-DONE)
         (MAKE-TAXES (SORT (CL-REMOVE '|Thing| TOP-CLASSES) #'STRING< :KEY #'SYMBOL-NAME) RELATION-TO-DESCEND HTMLIFY NIL *INDENT-INCREMENT*)
         (CLET ((UNPLACEDS (REMOVE-IF-NOT #'NAMED-INSTANCEP (SET-DIFFERENCE ALL-OBJECTS (CONS '|Thing| ALL-NODES-DONE)))))
          (APPEND (CONS "Thing" STRINGS)
           (MAPCAR
            #'(LAMBDA (UNPLACED) (trace-defun '#:G15831 (UNPLACED) (RET (TAX-OBJ-WRITE UNPLACED *INDENT-INCREMENT* HTMLIFY :INSTANCEP '?))))
            (SORT UNPLACEDS #'STRING< :KEY #'SYMBOL-NAME)))))))
      (T (MAKE-TAX0 CURRENT-NODE RELATION-TO-DESCEND HTMLIFY))))))))
(TRACE-LISP
 (DEFINE MAKE-TAX0 (CURRENT-NODE RELATION-TO-DESCEND &OPTIONAL HTMLIFY NODES-DONE TAB)
  (trace-defun 'MAKE-TAX0 (CURRENT-NODE RELATION-TO-DESCEND HTMLIFY NODES-DONE TAB)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TAB 0)
     (CLET ((ITEM-TEXT (TAX-OBJ-WRITE CURRENT-NODE TAB HTMLIFY)))
      (COND
       ((CL-MEMBER CURRENT-NODE *IGNORE-ITEMS*) (VALUES (LIST ITEM-TEXT (FORMAT NIL "~vTignoring children..." (+ TAB *INDENT-INCREMENT*))) NODES-DONE))
       (T
        (CLET
         ((CL-ALL-INSTANCES (KM0 `(|the| |instances| |of| ,CURRENT-NODE))) (NAMED-INSTANCES (REMOVE-IF-NOT #'NAMED-INSTANCEP CL-ALL-INSTANCES))
          (INSTANCES-TEXT
           (MAPCAR
            #'(LAMBDA (INSTANCE)
               (trace-defun '#:G15832 (INSTANCE) (RET (TAX-OBJ-WRITE INSTANCE (+ TAB *INDENT-INCREMENT*) HTMLIFY :INSTANCEP T))))
            (SORT NAMED-INSTANCES #'STRING< :KEY #'SYMBOL-NAME)))
          (SPECS (SORT (KM0 `(|the| ,RELATION-TO-DESCEND |of| ,CURRENT-NODE)) #'STRING< :KEY #'SYMBOL-NAME)))
         
         (COND ((AND SPECS (CL-MEMBER CURRENT-NODE NODES-DONE)) (VALUES (LIST ITEM-TEXT (FORMAT NIL "~vT..." (+ TAB *INDENT-INCREMENT*))) NODES-DONE))
          (T
           (MULTIPLE-VALUE-BIND (STRING NEW-NODES-DONE)
            (MAKE-TAXES SPECS RELATION-TO-DESCEND HTMLIFY (CONS CURRENT-NODE (APPEND ALL-INSTANCES NODES-DONE)) (+ TAB *INDENT-INCREMENT*))
            (VALUES (CONS ITEM-TEXT (CONS INSTANCES-TEXT STRING)) NEW-NODES-DONE)))))))))))))
(TRACE-LISP
 (DEFINE MAKE-TAXES (CURRENT-NODES RELATION-TO-DESCEND &OPTIONAL HTMLIFY NODES-DONE TAB)
  (trace-defun 'MAKE-TAXES (CURRENT-NODES RELATION-TO-DESCEND HTMLIFY NODES-DONE TAB)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TAB 0)
     (COND ((CNOT (LISTP CURRENT-NODES)) (VALUES NIL NODES-DONE))  ((ENDP CURRENT-NODES) (VALUES NIL NODES-DONE))
      ((> (/ TAB *INDENT-INCREMENT*) *MAXDEPTH*) (VALUES (LIST (FORMAT NIL "~vT...more..." (+ TAB *INDENT-INCREMENT*))) NODES-DONE))
      ((CNOT (ATOM (FIRST CURRENT-NODES)))  (MAKE-TAXES (REST CURRENT-NODES) RELATION-TO-DESCEND HTMLIFY NODES-DONE TAB))
      ((AND (EQ RELATION-TO-DESCEND '|instance-of|) (OR (ANONYMOUS-INSTANCEP (FIRST CURRENT-NODES))  (CNOT (KB-OBJECTP (FIRST CURRENT-NODES))))) 
       (MAKE-TAXES (REST CURRENT-NODES) RELATION-TO-DESCEND HTMLIFY NODES-DONE TAB))
      (T
       (MULTIPLE-VALUE-BIND (STRING MID-NODES-DONE) (MAKE-TAX0 (FIRST CURRENT-NODES) RELATION-TO-DESCEND HTMLIFY NODES-DONE TAB)
        (MULTIPLE-VALUE-BIND (STRINGS NEW-NODES-DONE) (MAKE-TAXES (REST CURRENT-NODES) RELATION-TO-DESCEND HTMLIFY MID-NODES-DONE TAB)
         (VALUES (LIST STRING STRINGS) NEW-NODES-DONE))))))))))
(TRACE-LISP
 (DEFINE TAX-OBJ-WRITE (CONCEPT TAB HTMLIFY &REST LKEYS)
  (trace-defun 'TAX-OBJ-WRITE (CONCEPT TAB HTMLIFY LKEYS)
   (RET
    (CLET (INSTANCEP)
     (CONCAT
      (COND ((EQ TAB 0) "") ((EQ INSTANCEP '?) (FORMAT NIL "?~a" (SPACES (1- TAB))))  ((EQ INSTANCEP T) (FORMAT NIL "I~a" (SPACES (1- TAB)))) 
       (T (FORMAT NIL "~vT" TAB)))
       (OBJWRITE2 CONCEPT HTMLIFY)))))))
;;   (cond (htmlify (htextify concept (symbol-name concept) :action '"frame")) ; htmlify always nil for KM only
;;	 (t (km-format nil "~a" concept)))))
;;;; FILE:  subsumes.lisp
;;;; File: subsumes.lisp
;;;; Author: Peter Clark
;;;; Purpose: Checking subsumption. This is slightly tricky to do properly.
;;;; In this implementation, no unification is performed.
#|Note we want to distinguish between
 a. "The car owned by a person." (the car with (owner ((a person))))
 b. "The car owned by person23." (the car with (owner ( _person23)))

We could evaluate (a person) to create a Skolem, and then do unification
with a subsumption flag in, but this doesn't work -- case a. and b. are
indistinguishable, but we'd want unification with _person24 (say) to succeed 
in case a. and fail in b.

Handler for (the X with SVs) in interpreter.lisp:
-------------------------------------------------
  1. call subsumes (a X with SVs) to return an answer.
  2. If no answer returned, call (a X with SVs) to create it.

The base algorithm:
-------------------
;;; where subsumer-expr is form '(a Class with SlotsVals)
(defun is0 (subsumee-instance subsumer-expr)
1. find an object O of type Class (person)
2. for each slot S on person
    a. compute vals Vs of O.S
      for each expr in the value of person.S     
	 IF expr is of form "(a ?class)" or "(a ?class with &rest)"
	 THEN foreach V in Vs
		call (subsumes expr V) until success (removing V from Vs?)
	 ELSE i. evaluate expr to find OVs
	      ii. check OVs is a subset of Vs (and if so remove OVs from Vs?)
		  (Note we're *not* allowing unification to occur)
3. If success, then return Subsumee-Instance|#
;;;; > (find-subsumees '(a Car with (color (Red))))
(TRACE-LISP
 (DEFINE FIND-SUBSUMEES (EXISTENTIAL-EXPR &OPTIONAL CANDIDATES)
  (trace-defun 'FIND-SUBSUMEES (EXISTENTIAL-EXPR CANDIDATES)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR CANDIDATES (FIND-CANDIDATES EXISTENTIAL-EXPR))
     (REMOVE-IF-NOT #'(LAMBDA (CANDIDATE-INSTANCE) (trace-defun '#:G15833 (CANDIDATE-INSTANCE) (RET (IS0 CANDIDATE-INSTANCE EXISTENTIAL-EXPR))))
      CANDIDATES))))))
;;;; ------------------------------
#|Finding all candidate instances which the existential expression might be referring to.
There are two ways of doing this:
	(a Car with 
	   (owned-by (Porter))
	   (color (Brown))
	   (age (10))
  	   (parts ((a Steering-wheel with (color (Red))))))
  1. follow inverse links (Porter owns Car), (Brown color-of), (10 age-of)
     However, this is incomplete for two reasons:
	(i) the implicit (instance-of (Car)) relation isn't searched -- but we
		can add it in.
	(ii) it will miss some items starting with non-symbols, eg. (10 age-of).
  2. The answer(s) must be in the intersection of the answers returned, subject to:
	- we better also add (all-instance-of Car) to the set
	- if no instances are returned by a particular inversing, then we'll
		ignore it (assuming either it was a non-symbolic frame, or 
		the evaluator has somehow failed to cache the answer even though
		it's there).
     INCOMPLETENESS: Suppose (Brown color-of) *does* return some values, but
	  not including this Car (eg. this Car is an embedded unit? We'll
	  fail then. Depends on how complete/efficient we want this.
 Now we just do this simple version below:|#
(TRACE-LISP
 (DEFINE FIND-CANDIDATES (EXISTENTIAL-EXPR)
  (trace-defun 'FIND-CANDIDATES (EXISTENTIAL-EXPR)
   (RET
    (CLET
     ((CLASS+SLOTSVALS (BREAKUP-EXISTENTIAL-EXPR EXISTENTIAL-EXPR :FAIL-MODE 'ERROR))  (CLASS (FIRST CLASS+SLOTSVALS))
      (SLOTSVALS (SECOND CLASS+SLOTSVALS)))
     (MAPC #'(LAMBDA (SLOTVALS) (trace-defun '#:G15834 (SLOTVALS) (RET )))  SLOTSVALS)  
     (REMOVE-IF-NOT #'(LAMBDA (INSTANCE) (trace-defun '#:G15835 (INSTANCE) (RET (CL-ISA INSTANCE CLASS)))) (OBJ-STACK)))))))
;;;; STRIPPED VERSION:
;;;; [1] kb-objectp test to avoid (the part-number-of of 1)
;;;; PURPOSE: to force some evaluation of relevant frames
;;;; RETURNS: Irrelevant and discarded
(TRACE-LISP
 (DEFINE FIND-CANDIDATES2 (CLASS SLOTVALS)
  (trace-defun 'FIND-CANDIDATES2 (CLASS SLOTVALS)
   (RET
    (CLET ((SLOT (FIRST SLOTVALS)) (INVSLOT (INVERT-SLOT SLOT)) (VEXPRS (SECOND SLOTVALS)))
     (MAPC
      #'(LAMBDA (VEXPR)
         (trace-defun '#:G15836 (VEXPR)
          (RET
           (COND
            ((EXISTENTIAL-EXPRP VEXPR)
             (MAPC #'(LAMBDA (VAL) (trace-defun '#:G15837 (VAL) (RET (COND ((KB-OBJECTP VAL) (KM0 `(|the| ,CLASS ,INVSLOT |of| ,VAL))))))) 
              (FIND-SUBSUMEES VEXPR)))
            (T
             (CLET ((KB-VALS (REMOVE-IF-NOT #'KB-OBJECTP (KM0 VEXPR)))) 
              (COND (KB-VALS (KM0 `(|the| ,CLASS ,INVSLOT |of| ,(VALS-TO-VAL KB-VALS)))))))))))
       VEXPRS))))))
#| ======================================================================
		SUBSUMPTION TESTING
 ======================================================================

This below table gives the rules for transforming different forms of the expression
into the BASE IMPLEMENTATION for "is0":

SUBSUMES:
	('(every X) subsumes '(every Y))	== ('(a Y) is '(a X))
	('(every X) subsumes {I1,..,In})	== (allof {I1,..,In} must ('(every X) covers It))
	({I1,..,In} subsumes '(every Y))	== ERROR
	({I1,..,In} subsumes {J1,..,Jn})	== ({I1,..,In} is-superset-of {J1,..,Jn})
COVERS:
	('(every X) covers '(a Y))    ==    ('(a Y) is '(a X))
	('(every X) covers    I  )    ==    (I is '(a X))
	({I1,..,In} covers '(a Y))    ==    (has-value (oneof {I1,..,In} where (It is '(a Y))))
	({I1,..,In} covers    I  )    ==    ({I1,..,In} includes I)
IS:
	('(a Y) is '(a X))	 ==     gensym a YI, (YI is '(a X)), delete YI
	('(a Y) is   I   )	 ==     ERROR
	(  I    is '(a X))	 == 	*****BASE IMPLEMENTATION***** : (is0 I '(a X))
	(  I1   is   I2  )	 ==     (I1 = I2)

We also have to be careful: With (Animal subsumes Dog), we must be sure that the
set (Animal) is recognized as a class description, not a set of instances. To do 
this, we convert (say) Dog to '(every Dog).|#
(TRACE-LISP
 (DEFINE SUBSUMES (XS YS)
  (trace-defun 'SUBSUMES (XS YS)
   (RET
    (CLET ((X-DESC (VALS-TO-CLASS-DESCRIPTION XS)) (Y-DESC (VALS-TO-CLASS-DESCRIPTION YS)))
     (COND ((AND X-DESC Y-DESC)  (IS (EVERY-TO-A Y-DESC) (EVERY-TO-A X-DESC)))
      (X-DESC  (KM0 `(|allof| ,(VALS-TO-VAL YS) |must| (,X-DESC |covers| |It|)))) 
      (Y-DESC  (REPORT-ERROR 'USER-ERROR "Doing (~a subsumes ~a)~%Can't test if a set subsumes an expression!~%" XS YS))
      (T  (KM0 `(,(VALS-TO-VAL XS) |is-superset-of| ,(VALS-TO-VAL YS))))))))))
(TRACE-LISP
 (DEFINE COVERS (XS Y)
  (trace-defun 'COVERS (XS Y)
   (RET
    (CLET
     ((X-DESC (VALS-TO-CLASS-DESCRIPTION XS))
      (Y-DESC (COND ((AND (QUOTED-EXPRESSIONP Y) (LISTP (UNQUOTE Y)) (INSTANCE-DESCRIPTIONP Y :FAIL-MODE 'ERROR)) Y))))
     
     (COND ((AND X-DESC Y-DESC)  (KM0 `(,Y-DESC |is| ,(EVERY-TO-A X-DESC)))) (X-DESC  (KM0 `(,Y |is| ,(EVERY-TO-A X-DESC))))
      (Y-DESC  (KM0 `(|has-value| (|oneof| ,(VALS-TO-VAL XS) |where| (|It| |is| ,Y-DESC)))))  (T  (KM0 `(,(VALS-TO-VAL XS) |includes| ,Y)))))))))
;;;; [1]: Hmmm....We can't always guarantee KM will clean up after itself, as the computation [1a] may create additional 
;;;; instances which *aren't* deleted by the tidy-up [1b]. Could use a subsituation??
(TRACE-LISP
 (DEFINE IS (X Y)
  (trace-defun 'IS (X Y)
   (RET
    (COND
     ((CL-EQUAL Y ''(|a| |Class|)) 
      (COND ((OR (CLASS-DESCRIPTIONP X) (SYMBOLP X))) 
       (T (REPORT-ERROR 'USER-ERROR "Doing (~a is ~a)~%~a doesn't appear to be a class or class description.~%" X Y X))))
     (T
      (CLET
       ((X-DESC (COND ((AND (QUOTED-EXPRESSIONP X) (LISTP (UNQUOTE X)) (INSTANCE-DESCRIPTIONP X :FAIL-MODE 'ERROR)) X)))
        (Y-DESC (COND ((AND (QUOTED-EXPRESSIONP Y) (LISTP (UNQUOTE Y)) (INSTANCE-DESCRIPTIONP Y :FAIL-MODE 'ERROR)) Y))))
       (COND ((AND X-DESC Y-DESC)  (DESCRIPTION-SUBSUMES-DESCRIPTION X-DESC Y-DESC))
        (X-DESC  (REPORT-ERROR 'USER-ERROR "Doing (~a is ~a)~%Can't test if an expression is `subsumed' by an instance!~%" X Y))
        (Y-DESC  (IS0 X (UNQUOTE Y-DESC))) (T (KM0 `(,X = ,Y)))))))))))
;; (  I1   is   I2  )	 ==     (I1 = I2)
;;;; ----------------------------------------
;;;; Rewrite this to me more efficient - delete-frame is horrible for a large KB
;;;; ----------------------------------------
#| [1] NB Not set it to NIL, in case this is recursive, to avoid:
 logging on, checkpoint C1
   logging on (already on), checkpoint C2
   backtrack to C2, logging off (urgh!)
 backtrack to C1, but some logging has been missed!|#
(TRACE-LISP (DEFPARAMETER *REMOVE-TEMPORARY-VIA-BACKTRACKING* T))
(TRACE-LISP
 (DEFINE DESCRIPTION-SUBSUMES-DESCRIPTION (X-DESC Y-DESC)
  (trace-defun 'DESCRIPTION-SUBSUMES-DESCRIPTION (X-DESC Y-DESC)
   (RET
    (COND
     (*REMOVE-TEMPORARY-VIA-BACKTRACKING*
      (CLET ((OLD-INTERNAL-LOGGING *INTERNAL-LOGGING*) (CHECKPOINT-ID (GENSYM))) (CSETQ *INTERNAL-LOGGING* T) (SET-CHECKPOINT CHECKPOINT-ID)
       (PROG1 (CLET ((TMP-I (KM-UNIQUE0 (UNQUOTE X-DESC) :FAIL-MODE 'ERROR))) (KM0 `(,TMP-I |is| ,Y-DESC))) (UNDO CHECKPOINT-ID) 
        (CSETQ *INTERNAL-LOGGING* OLD-INTERNAL-LOGGING))))
      (T (CLET ((TMP-I (KM-UNIQUE0 (UNQUOTE X-DESC) :FAIL-MODE 'ERROR))) (PROG1 (KM0 `(,TMP-I |is| ,Y-DESC))  (DELETE-FRAME TMP-I)))))))))
;; VERY inefficient with a large KB
;;;; ----------------------------------------
;; [1] Causes problems with metaclasses!	   
(TRACE-LISP
 (DEFINE VALS-TO-CLASS-DESCRIPTION (CLASSES)
  (trace-defun 'VALS-TO-CLASS-DESCRIPTION (CLASSES)
   (RET
    (COND ((AND (SINGLETONP CLASSES) (KB-OBJECTP (FIRST CLASSES)))  `'(|every| ,(FIRST CLASSES))) 
     ((AND (SINGLETONP CLASSES) (DESCRIPTIONP (FIRST CLASSES)))
      (COND
       ((CLASS-DESCRIPTIONP (FIRST CLASSES))
        (CLET
         ((CLASS+SLOTSVALS (CLASS-DESCRIPTION-TO-CLASS+SLOTSVALS (FIRST CLASSES))) (CLASS (FIRST CLASS+SLOTSVALS)) (SLOTSVALS (SECOND CLASS+SLOTSVALS)))
         `'(|every| ,CLASS |with| ,@SLOTSVALS)))
       (T (REPORT-ERROR 'USER-ERROR "Subsumption with ~a:~%Don't know how to do subsumption with this kind of expression!~%" (FIRST CLASSES))))))))))
;;;; '(every Cat) -> '(a Cat)
;;(defun every-to-a (expr) `'(;$a ,@(rest (unquote expr))))
(TRACE-LISP
 (DEFINE EVERY-TO-A (EXPR)
  (trace-defun 'EVERY-TO-A (EXPR)
   (RET
    (CLET ((CLASS+SLOTSVALS (CLASS-DESCRIPTION-TO-CLASS+SLOTSVALS EXPR)) (CLASS (FIRST CLASS+SLOTSVALS)) (SLOTSVALS (SECOND CLASS+SLOTSVALS)))
     (COND (SLOTSVALS `'(|a| ,CLASS |with| ,@SLOTSVALS)) (T `'(|a| ,CLASS))))))))
;;;; ======================================================================
;;;;	BASE IMPLEMENTATION FOR SUBSUMPTION TESTING: COMPARE AN INSTANCE WITH A DESCRIPTION
;;;; ======================================================================
#|[1] bind-self done for queries like:
CL-USER> (is0 'X$_rectangle0
	      'X$(a rectangle with (length ((Self width))) 
				   (width ((Self length)))))

Later: CORRECTION! bind-self must be done *before* calling is0,
	as expr may be an embedded expression (thus Self refers to the 
	embedding frame).
[2] NB if no value in subsumer, then it *doesn't* subsume everything!!
NOTE: expr is UNQUOTED here, to allow easy recursive calling of is0

[3] del-list  
      expr     (:triple  Self   position (a Position))		    (a Position) is a single value
      instance (:triple _Light1 position (the position of _Light1)) is going to return a *list* of values for the third argument|#
(TRACE-LISP
 (DEFINE IS0 (INSTANCE EXPR)
  (trace-defun 'IS0 (INSTANCE EXPR)
   (RET
    (COND
     ((AND (KM-STRUCTURED-LIST-VALP INSTANCE) (KM-STRUCTURED-LIST-VALP EXPR) (EQ (LENGTH (DESOURCE INSTANCE)) (LENGTH (DESOURCE EXPR)))
       (EQ (FIRST INSTANCE) (FIRST EXPR)))
      (CLET ((D-INSTANCE (DESOURCE INSTANCE)) (D-EXPR (DESOURCE EXPR)))
       (COND
        ((KM-TRIPLEP D-INSTANCE)
         (AND (IS0 (SECOND D-INSTANCE) (SECOND D-EXPR)) (IS0 (THIRD D-INSTANCE) (THIRD D-EXPR))
          (SOME #'(LAMBDA (VAL) (trace-defun '#:G15838 (VAL) (RET (IS0 VAL (FOURTH D-EXPR)))))  (VAL-TO-VALS (FOURTH D-INSTANCE)))))
        (T
         (EVERY #'(LAMBDA (PAIR) (trace-defun '#:G15839 (PAIR) (RET (IS0 (FIRST PAIR) (SECOND PAIR)))))
          (REST (TRANSPOSE (LIST D-INSTANCE D-EXPR))))))))
            
     (T
      (CLET ((CLASS+SLOTSVALS (BIND-SELF (BREAKUP-EXISTENTIAL-EXPR EXPR) INSTANCE))) 
       (COND
        (CLASS+SLOTSVALS 
         (COND ((AND (FLUENT-INSTANCEP INSTANCE)  (EQ (FIRST EXPR) '|a|)) NIL) 
          (T
           (CLET ((CLASS (FIRST CLASS+SLOTSVALS))  (SLOTSVALS (SECOND CLASS+SLOTSVALS)))
            (AND (CL-ISA INSTANCE CLASS) (ARE-SLOTSVALS SLOTSVALS) 
             (EVERY #'(LAMBDA (SLOTVALS) (trace-defun '#:G15840 (SLOTVALS) (RET (SLOTVALS-SUBSUME SLOTVALS INSTANCE)))) SLOTSVALS))))))
        ((CONSTRAINT-EXPRP EXPR) (SATISFIES-CONSTRAINTS (LIST INSTANCE) (LIST EXPR) NIL))    
        (T (CLET ((DEFINITE-VAL (KM-UNIQUE0 EXPR)))  (COND ((NULL DEFINITE-VAL) NIL)  (T (CL-EQUAL DEFINITE-VAL INSTANCE)))))))))))))
;;;; Perhaps rather slow?
;;;; Returns 't' in the keyword 'Self' occurs in expr, nil otherwise.
(TRACE-LISP
 (DEFINE CONTAINS-SELF-KEYWORD (EXPR)
  (trace-defun 'CONTAINS-SELF-KEYWORD (EXPR)
   (RET (COND ((NULL EXPR) NIL) ((EQ EXPR '|Self|)) ((LISTP EXPR) (OR (CONTAINS-SELF-KEYWORD (FIRST EXPR)) (CONTAINS-SELF-KEYWORD (REST EXPR)))))))))
#|(slotvals-subsume <subsumer> <subsumee>
[1] is a quick, common lookahead, for calls like:
	(slotvals-subsume 'X$(connects ((the Engine parts of _Car23))) 'X$_Car23)
where the connects of _Car23 is exactly ((the Engine parts of _Car23)).
[2] Don't count constraints! eg. Want (<> 20) to subsume () !
    Thus, we abort if (the foo of Self) - NIL, on the assumption that (the foo of Self) will return at least one item (?).
	This assumption isn't valid! So simplify this to just count existentials.
    The only case this doesn't hold is for the special `tag' slot. And in any case, see-constraints have been already removed by the
	KM call at [4b]!
    But: Put it back. Reason is we want to stop this:
	KM> (_Car23 is '(a Car with (color ((the favorite-color of (the owner of Self))))))
	
	KM> (every Nice-Car has-definition
		  (instance-of (Car))
		  (color ((the favorite-color of (the owner of Self)))))

	KM> (a Car)
	CLASSIFY: _Car23 is a Nice-Car!
	
	This slightly violates the semantics of the KB (strictly null attribute
	values should be ignored), but we assume that the rule is there for a 
	reason and must return at least one value. 

[4a] Do a find-vals rather than a (km0 ...) call, as we *do* want to preserve constraints here in the
     special case of tags.
[5] Why ignore situation-specific slots? I'm confused why I put this constraint in. Let's remove it.|#
(TRACE-LISP
 (DEFINE SLOTVALS-SUBSUME (SLOTVALS INSTANCE)
  (trace-defun 'SLOTVALS-SUBSUME (SLOTVALS INSTANCE)
   (RET
    (CLET ((SLOT (FIRST SLOTVALS)) (SER-EXPRS (SECOND SLOTVALS)))
     (COND
      ((SOME #'(LAMBDA (SITUATION) (trace-defun '#:G15841 (SITUATION) (RET )))
        (CONS (CURR-SITUATION) (APPEND (ALL-SUPERSITUATIONS (CURR-SITUATION)) (VISIBLE-THEORIES)))))
       
      (T
       (COND   
        (T
         (CLET
          ((SEE-VALS
            (COND
             ((IGNORE-SLOT-DUE-TO-SITUATIONS-MODE SLOT)
              (KM-TRACE 'COMMENT
               "Subsumption test: Ignoring attempt to compute (the ~a of ~a) in the global~%    situation, as slot `~a' is a fluent (so can only take on situation-specific values)."
               SLOT INSTANCE SLOT))
             (T (KM0 `(|the| ,SLOT |of| ,INSTANCE))))))
          
          (COND
           ((<= (LENGTH (REMOVE-CONSTRAINTS SER-EXPRS)) (LENGTH SEE-VALS))  
            (COND ((EQ SLOT '|instance-of|)  (CLASSES-SUBSUME-CLASSES SER-EXPRS SEE-VALS)) 
             (T
              (CLET ((CONSTRAINTS (FIND-CONSTRAINTS-IN-EXPRS SER-EXPRS)))
               (AND (SATISFIES-CONSTRAINTS SEE-VALS CONSTRAINTS SLOT) 
                (VALS-SUBSUME (COND ((SINGLE-VALUED-SLOTP SLOT) (&-EXPR-TO-VALS (FIRST SER-EXPRS)))  (T SER-EXPRS)) SEE-VALS)))))))))))))))))
;;;; GIVEN: some expressions, and some values
;;;; RETURN t if *every* expression subsumes some (different) value in values.
;;;; Notes:
;;;; [1]: if expr includes, say, (a car), then consider it to subsume the first 
;;;; instance of car in the subsumee.
;;;; [2]: Don't remove ser-vals from see-vals, as subsumer may have several
;;;; exprs which evaluate to the *same* instance:
;;;; eg. in (expr1 expr2), expr1 evals to (x1 x2) and expr2 evaluates (x2 x3)
;;;; But if we remove (x1 x2) from see-vals (x1 x2 x3 x4) we get (x3 x4),
;;;; and now (subsetp '(x2 x3) '(x3 x4)) undesirably fails, even though x2
;;;; is known to be in the full set see-vals.
(TRACE-LISP
 (DEFINE VALS-SUBSUME (SER-EXPRS SEE-VALS)
  (trace-defun 'VALS-SUBSUME (SER-EXPRS SEE-VALS)
   (RET
    (COND ((ENDP SER-EXPRS))  ((CL-EQUAL SER-EXPRS SEE-VALS)) 
     (T
      (CLET ((SER-EXPR (FIRST SER-EXPRS)))
       (COND
        ((OR (EXISTENTIAL-EXPRP SER-EXPR) (KM-STRUCTURED-LIST-VALP SER-EXPR)) 
         (CLET ((SEE-VAL (FIRST (FIND-SUBSUMEES SER-EXPR SEE-VALS)))) 
          (COND (SEE-VAL (VALS-SUBSUME (REST SER-EXPRS) (CL-REMOVE SEE-VAL SEE-VALS :TEST #'CL-EQUAL))))))
        (T (CLET ((SER-VALS (KM0 SER-EXPR))) (COND ((CL-SUBSETP SER-VALS SEE-VALS :TEST #'CL-EQUAL) (VALS-SUBSUME (REST SER-EXPRS) SEE-VALS)))))))))))))
;; [2]
;;;; ======================================================================
;;;;		UTILS
;;;; ======================================================================
;;;; If expr is an existential expr, this returns a list (<class> <slotsvals>) of
;;;; the existential expr's structure.
;;;; (breakup-existential-expr '(a car with (age (old)))) ->  (car ((age (old))))
(TRACE-LISP
 (DEFINE BREAKUP-EXISTENTIAL-EXPR (EXPR0 &REST LKEYS)
  (trace-defun 'BREAKUP-EXISTENTIAL-EXPR (EXPR0 LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (CLET ((EXPR (DECOMMENT-TOP-LEVEL EXPR0)))
      (COND
       ((AND (LISTP EXPR) (CL-MEMBER (FIRST EXPR) '(|a| |some|)) (>= (LENGTH EXPR) 2))
        (COND ((PAIRP EXPR) (LIST (SECOND EXPR) NIL)) ((EQ (THIRD EXPR) '|with|) (LIST (SECOND EXPR) (REST (REST (REST EXPR)))))
         ((AND (EQ (THIRD EXPR) '|called|) (EQ (LENGTH EXPR) 4)) (LIST (SECOND EXPR) `((|called| (,(FOURTH EXPR))))))
         ((AND (EQ (THIRD EXPR) '|uniquely-called|) (EQ (LENGTH EXPR) 4)) (LIST (SECOND EXPR) `((|uniquely-called| (,(FOURTH EXPR))))))
         ((AND (EQ (THIRD EXPR) '|called|) (EQ (FIFTH EXPR) '|with|))
          (LIST (SECOND EXPR) (CONS `(|called| (,(FOURTH EXPR))) (REST (REST (REST (REST (REST EXPR))))))))
         ((AND (EQ (THIRD EXPR) '|uniquely-called|) (EQ (FIFTH EXPR) '|with|))
          (LIST (SECOND EXPR) (CONS `(|uniquely-called| (,(FOURTH EXPR))) (REST (REST (REST (REST (REST EXPR))))))))
         ((EQ FAIL-MODE 'ERROR)
          (REPORT-ERROR 'USER-ERROR "Bad expression in subsumption testing ~a~%(Should be one of (a ?class) or (a ?class with &rest)).~%" EXPR))))
       ((EQ FAIL-MODE 'ERROR)
        (REPORT-ERROR 'USER-ERROR "Bad expression in subsumption testing ~a~%(Should be one of (a ?class) or (a ?class with &rest)).~%" EXPR)))))))))
;;;; No error checking here
(TRACE-LISP
 (DEFINE CLASS-IN-EXISTENTIAL-EXPR (EXISTENTIAL-EXPR)
  (trace-defun 'CLASS-IN-EXISTENTIAL-EXPR (EXISTENTIAL-EXPR) (RET (SECOND EXISTENTIAL-EXPR)))))
;;;; ======================================================================
;;;; Syntactic sugar: 
;;;; Can say	(the (Self parts Wing parts Engine))	; the engine of a wing
;;;; as well as (and equivalently)
;;;;	        (the Engine with (parts-of ((a Wing with (parts-of (Self))))))
;;;; ======================================================================
#|> (path-to-existential-expr '(airplane01 parts wing))
(a wing with (parts-of (airplane01)))
> (path-to-existential-expr '(airplane01 parts wing parts edp))
(a edp with (parts-of ((a wing with (parts-of (airplane01))))))
> (path-to-existential-expr '(airplane01 parts wing parts))
(a thing with (parts-of ((a wing with (parts-of (airplane01))))))|#
(TRACE-LISP
 (DEFINE PATH-TO-EXISTENTIAL-EXPR (PATH &OPTIONAL PREP)
  (trace-defun 'PATH-TO-EXISTENTIAL-EXPR (PATH PREP)
   (RET (TRACE-PROGN (SUBLISP-INITVAR PREP '|a|) (PATH-TO-EXISTENTIAL-EXPR2 (REST PATH) (FIRST PATH) PREP))))))
(TRACE-LISP
 (DEFINE PATH-TO-EXISTENTIAL-EXPR2 (PATH EMBEDDED-UNIT PREP)
  (trace-defun 'PATH-TO-EXISTENTIAL-EXPR2 (PATH EMBEDDED-UNIT PREP)
   (RET
    (COND ((ENDP PATH) EMBEDDED-UNIT)
     (T
      (CLET
       ((SLOT (FIRST PATH)) (CLASS (COND ((EQ (SECOND PATH) '*) '|Thing|) ((SECOND PATH)) (T '|Thing|))) (REST-REST-PATH (REST (REST PATH)))
        (PREPOSITION (COND (REST-REST-PATH '|a|) (T PREP))) (NEW-EMBEDDED-UNIT `(,PREPOSITION ,CLASS WITH (,(INVERT-SLOT SLOT) (,EMBEDDED-UNIT)))))
       (PATH-TO-EXISTENTIAL-EXPR2 (REST (REST PATH)) NEW-EMBEDDED-UNIT PREP))))))))
;;;; ======================================================================
;;;;		REMOVE SUBSUMING EXPRESSIONS
;;;;	This is called by (compute-new-slotsvals old-slotsvals old-slotsvals) in frame-io.lisp
;;;; ======================================================================
#|remove-subsuming-exprs:
GIVEN: 
   "exprs"     - a set of existential exprs (plus some other exprs)
   "instances" - a set of instances (plus some other exprs)

 Returns three values: 
	   - the existential exprs (plus other exprs) not subsuming any instances
	   - the instances (plus other exprs) not subsumed by any existential expr
	   - the instances which were subsumed

CL-USER> (remove-subsuming-exprs 'X$((a Cat) (a Door))
				 'X$(_Door178 (a Elephant) _Bumper176))
((a Cat))
((a Elephant) _Bumper176)
(_Door178)
[1] an instance can only be subsumed by *one* expr
[2] route this query through the KM interpreter, so the user can trace it if necessary
    BUT: 9.8.99 is very confusing to the user! Hide it instead.

NOTE!! This routine should have NO SIDE EFFECTS, beyond evaluating definite paths already present.

Apr 99: What we'd also like is:
CL-USER> (remove-subsuming-exprs 'X$((a Cat) (a Door) (a Elephant))
				 'X$(_Door178 (a Elephant with (size (Big))) _Bumper176))
  CURRENT IMPLEMENTATION				DESIRED 
((a Cat) (a Elephant))			 	((a Cat))				  ; non-subsumers
((a Elephant with size (Big)) _Bumper176)	(_Bumper176)				  ; non-subsumed
(_Door178)					((a Elephant with (size (Big))) _Door178) ; subsumed

[3] is more aggressive, it will cause a "hidden" instance to be actually created for purposes of testing, then discarded

[4] This extra check to ensure (a Big-Engine) "subsumes" (_Engine23). This is modifying "subsuming" to mean
    "subsumes including allowing coercion". Note that (_Engine23) and (_Engine24) still *shouldn't* result in
    any removals, ie. we're *not* doing unification.
   eg. consider (Red color-of _Engine23) then (Red color-of _Engine24) ; don't want to unify the Engines.

[4b] NOTE We have to exclude subsumption checks which include reference to Self, because the answer to the
     subsumption check depends on the instance in question!
- PC This can only come with instances entered from the user, not from lazy-unifiable-expr-sets (where bind-self has
  PC necessarily already been conducted).

[5] Clean up the junk, so as not to pollute the object stack.

[6] Incorrect behaviour: 
 ('(a Car) is '(a Car with (age ((the foo of Self)))))  -> NIL	; correct
but
 (every Car has (age ((a Thing))))
 ('(a Car) is '(a Car with (age ((the foo of Self)))))  -> t    ; incorrect!
This is because KM treats this as equivalent to 
 ((a Car) is '(a Car with (age ((the foo of Self)))))
which is wrong!!!

[7a] It looks like we should record explanation here, but we don't need to as &+ takes care of it.
[7b] As far as I can tell this branch NEVER gets taken with &+, as Self will always be removed, allow-coercion is always t, and &+ is stronger than is.
	(So if &+ fails, `is' will too, necessarily)|#
(TRACE-LISP
 (DEFINE REMOVE-SUBSUMING-EXPRS (EXPRS INSTANCES &REST LKEYS)
  (trace-defun 'REMOVE-SUBSUMING-EXPRS (EXPRS INSTANCES LKEYS)
   (RET
    (CLET (ALLOW-COERCION TARGET)
     (COND
      ((AND (TRACEP) (CNOT (TRACESUBSUMESP))) (SUSPEND-TRACE)
       (MULTIPLE-VALUE-BIND (NON-SUBSUMERS NON-SUBSUMED SUBSUMED) (REMOVE-SUBSUMING-EXPRS0 EXPRS INSTANCES :ALLOW-COERCION ALLOW-COERCION :TARGET TARGET)
        (UNSUSPEND-TRACE) (VALUES NON-SUBSUMERS NON-SUBSUMED SUBSUMED)))
      (T (REMOVE-SUBSUMING-EXPRS0 EXPRS INSTANCES :ALLOW-COERCION ALLOW-COERCION :TARGET TARGET))))))))
(TRACE-LISP
 (DEFINE REMOVE-SUBSUMING-EXPRS0 (EXPRS INSTANCES &REST LKEYS)
  (trace-defun 'REMOVE-SUBSUMING-EXPRS0 (EXPRS INSTANCES LKEYS)
   (RET
    (CLET (ALLOW-COERCION TARGET)
     (COND ((OR (NULL EXPRS) (NULL INSTANCES)) (VALUES EXPRS INSTANCES NIL))
      (T
       (CLET
        ((SUBSUMED-INSTANCE
          (COND
           ((OR (EXISTENTIAL-EXPRP (FIRST EXPRS))  (KM-STRUCTURED-LIST-VALP (FIRST EXPRS)))
            (FIND-IF
             #'(LAMBDA (INSTANCE)
                (trace-defun '#:G15842 (INSTANCE)
                 (RET
                  (COND
                   ((IS-AN-INSTANCE INSTANCE) 
                    (OR   
                     (AND ALLOW-COERCION  #| hmm...|# (OR (EXISTENTIAL-EXPRP (FIRST EXPRS)) (KM-STRUCTURED-LIST-VALP (FIRST EXPRS)))
                      (CNOT (CONTAINS-SELF-KEYWORD (FIRST EXPRS)))  (KM0 `(,INSTANCE &+ ,(FIRST EXPRS)) :TARGET TARGET) )))
                   ((AND (EXISTENTIAL-EXPRP INSTANCE) (CNOT (CONTAINS-SELF-KEYWORD (FIRST EXPRS))))   (KM0 `(',INSTANCE |is| ',(FIRST EXPRS))))))))
               INSTANCES))))
         (INSTANCES0 (COND (SUBSUMED-INSTANCE (CL-REMOVE SUBSUMED-INSTANCE INSTANCES :TEST #'CL-EQUAL :COUNT 1)) (T INSTANCES))))
        (MULTIPLE-VALUE-BIND (UNUSED-EXPRS UNUSED-INSTANCES SUBSUMED-INSTANCES)
         (REMOVE-SUBSUMING-EXPRS0 (REST EXPRS) INSTANCES0 :ALLOW-COERCION ALLOW-COERCION :TARGET TARGET)
         (COND
          (SUBSUMED-INSTANCE (COND ((AND TARGET *RECORD-EXPLANATIONS*) (RECORD-EXPLANATION-FOR TARGET SUBSUMED-INSTANCE (FIRST EXPRS))))
           (VALUES UNUSED-EXPRS UNUSED-INSTANCES (CONS SUBSUMED-INSTANCE SUBSUMED-INSTANCES)))
          (T (VALUES (CONS (FIRST EXPRS) UNUSED-EXPRS) UNUSED-INSTANCES SUBSUMED-INSTANCES))))))))))))
;;;; Quick lookahead for _Engine23 (a Engine) : the immediate-classes of _Engine23 must subsume or be subsumed by Engine.
;;;; If this test fails, then we needn't proceed further.
;;;; expr is necessarily of the form (a <class>), or (a <class> with ...)
;;(defun classes-subsumep-test (instance expr)
;;  (let ( (i-classes (immediate-classes instance)) 
;;	 (e-classes (list (second expr))) )
;;    (or (classes-subsume-classes e-classes i-classes)
;;	(classes-subsume-classes i-classes e-classes))))
;;(defun classes-subsumep-test (i-classes e-classes)
;;  (or (equal i-classes e-classes)				; for efficiency
;;      (classes-subsume-classes e-classes i-classes)
;;      (classes-subsume-classes i-classes e-classes)))
;;;; ======================================================================
;;;; Compute most general specialization(s) of a concept description
;;;; Used for KM> (the-class-of ...) expressions.
;;;; Not used for now.
;;;; ======================================================================
#|The class has to be input as an instance expression.
mgs returns the most general class(es) subsumed by that expression.
The algorithm searches down the taxonomy (general-to-specific) from the
class provided, until it hits candidates. Instances are not searched.

The algorithm is similar to finding subsumed instances, except the 
candidates are classes, and we instant-ify them.

CL-USER> (mgs 'X$(a Physobj with (produces (*Electricity))))
(Power-Supply)

;;; Return most general class(es) subsumed by existential-expr.
(defun mgs (existential-expr)
  (let* 
    ( (class+slotsvals (breakup-existential-expr existential-expr :fail-mode 'error)) 
      (class (first class+slotsvals)) )
    (cond (class (remove-duplicates (mgs2 existential-expr class))))))

;;; Return most general subclass(es) of class subsumed by existential-expr.
(defun mgs2 (existential-expr class)
  (mapcan X'(lambda (subclass)					; WAS my-mapcan - X'mapcan safe here!
	      (cond ((is0 (km-unique0 `X$(a ,SUBCLASS) :fail-mode 'error) existential-expr) (list subclass))
		    (t (mgs2 existential-expr subclass))))	
  (km0 `X$(the subclasses of ,CLASS))))|#
;;;; ======================================================================
(TRACE-LISP
 (DEFINE VALSET-SUBSUMES-VALSET (VALSET1 VALSET2)
  (trace-defun 'VALSET-SUBSUMES-VALSET (VALSET1 VALSET2)
   (RET
    (COND ((ENDP VALSET1)) ((NULL VALSET2) NIL) 
     (T
      (CLET ((VAL1 (FIRST VALSET1)))
       (COND ((CL-MEMBER VAL1 VALSET2 :TEST #'CL-EQUAL) (VALSET-SUBSUMES-VALSET (REST VALSET1) (CL-REMOVE VAL1 VALSET2 :TEST #'CL-EQUAL :COUNT 1)))
        ((EXISTENTIAL-EXPRP VAL1)
         (CLET
          ((VAL2
            (FIND-IF
             #'(LAMBDA (VAL)
                (trace-defun '#:G15843 (VAL) (RET (COND ((IS-AN-INSTANCE VAL) (IS0 VAL VAL1))  ((EXISTENTIAL-EXPRP VAL) (IS `',VAL `',VAL1))))))
             VALSET2)))
          (COND (VAL2 (VALSET-SUBSUMES-VALSET (REST VALSET1) (CL-REMOVE VAL2 VALSET2 :TEST #'CL-EQUAL :COUNT 1))))))))))))))
#| More efficient but less thorough, expecting ordering to be preserved.
;;; val2 is more specific than val1
(defun valset-subsumes-valset (valset1 valset2)
  (cond 
   ((endp valset1))
   ((null valset2) nil)			; some valset2 without correlates in valset1
   (t (let ( (val1 (first valset1)) 
	     (val2 (first valset2)) )
	(cond ((equal val1 val2)
	       (valset-subsumes-valset (rest valset1) (rest valset2)))
	      ((existential-exprp val1)
	       (let ( (successp (cond ((is-an-instance val2) (is0 val2 val1))		; takes an instance and an (unquoted) expr
				      ((existential-exprp val2) (is `',val2 `',val1)))) )
		 (cond (successp (valset-subsumes-valset (rest valset1) (rest valset2)))))))))))|#
;;;; FILE:  prototypes.lisp
;;;; File: prototypes.lisp
;;;; Author: Peter Clark
;;;; Purpose: Knowledge Representation using Prototypes -- the answer to life!
;;;; Neah, don't do this for now, but leave it as an option. Move to header.lisp
;;(defvar *record-explanations-for-clones* nil)
;;;; Used for cloning itself: Don't follow these slots when cloning the prototype graph.
;;;; cloned-from NOT in this list, to allow clones to be added into prototypes
;;;; Make this a parameter (not constant), so user can change it
(TRACE-LISP
 (DEFPARAMETER *UNCLONABLE-SLOTS* '(|prototype-participant-of| |prototype-of| |prototype-participants| |prototypes| |prototype-scope| |has-clones|)))
;;;; We can tell if it's cloned or not like this
(TRACE-LISP
 (DEFINE ISA-CLONE (INSTANCE)
  (trace-defun 'ISA-CLONE (INSTANCE) (RET (AND (KB-OBJECTP INSTANCE) (GET-VALS INSTANCE '|cloned-from| :SITUATION *GLOBAL-SITUATION*))))))
;;;; ----------
;; (defvar *curr-prototype* nil)		; in header.lisp
(TRACE-LISP (DEFINE AM-IN-PROTOTYPE-MODE NIL (trace-defun 'AM-IN-PROTOTYPE-MODE NIL (RET *CURR-PROTOTYPE*))))
(TRACE-LISP (DEFINE CURR-PROTOTYPE NIL (trace-defun 'CURR-PROTOTYPE NIL (RET *CURR-PROTOTYPE*))))
(TRACE-LISP
 (DEFINE PROTOINSTANCEP (CONCEPT)
  (trace-defun 'PROTOINSTANCEP (CONCEPT) (RET (GET-UNIQUE-VAL CONCEPT '|prototype-participant-of| :SITUATION *GLOBAL-SITUATION*)))))
;;(defun prototypep (concept) (get-unique-val concept ';$prototype-of :situation *global-situation*))
(TRACE-LISP
 (DEFINE PROTOTYPEP (CONCEPT) (trace-defun 'PROTOTYPEP (CONCEPT) (RET (GET-VALS CONCEPT '|prototype-of| :SITUATION *GLOBAL-SITUATION*)))))
;; Not used any more.
;;;; concept /= generic, but a special case of it.
;;(defun qualified-prototypep (concept)
;;  (and (prototypep concept)
;;       (find-vals concept ';$activity-type)))
;;;; ======================================================================
;;;;			LAZY CLONING:
;;;;	We only clone prototypes which have a value for the slot of interest.
;;;; ======================================================================
;;;; If slot is nil, then all prototypes are unified in. Returned result is irrelevant (nil).
;;;; 9/22/03: New: return list of prototypes unified in
;;(defun unify-in-prototypes (instance0 &optional slot)
;;  (let* ( (instance (dereference instance0))				; identity may change with each iteration
;;	  (prototype (first-applicable-prototype instance slot)) )
;;    (cond (prototype (unify-in-prototype instance prototype slot)
;;		     (cons prototype (unify-in-prototypes instance slot))))))
;;;; MODIFICATION: [1] Prevent unifying prototypes while unifying in prototypes, for more efficiency -- with
;;;; lots of prototypes, the whole thing can grind to a halt.
;;;; This *seems* to be okay, although might be completeness problems?
(TRACE-LISP (DEFINE UNIFY-IN-PROTOTYPES (INSTANCE0 &OPTIONAL SLOT) (trace-defun 'UNIFY-IN-PROTOTYPES (INSTANCE0 SLOT) (RET ))))
(TRACE-LISP
 (DEFINE ALL-APPLICABLE-PROTOTYPES (INSTANCE &OPTIONAL SLOT)
  (trace-defun 'ALL-APPLICABLE-PROTOTYPES (INSTANCE SLOT)
   (RET
    (REMOVE-IF-NOT #'(LAMBDA (PROTOTYPE) (trace-defun '#:G15845 (PROTOTYPE) (RET )))
     (MY-MAPCAN #'(LAMBDA (CLASS) (trace-defun '#:G15846 (CLASS) (RET (GET-VALS CLASS '|prototypes| :SITUATION *GLOBAL-SITUATION*))))
      (ALL-CLASSES INSTANCE)))))))
;;;; ------------------------------
;;;; with eager unification, we can end up in an infinite loop with big KBs (e.g. aeronet.km) 
;;;; So make this toggleable
(TRACE-LISP (DEFVAR *TRACE-UNIFY-IN-PROTOTYPE* NIL))
;;;; [4] KM 1.4.0-beta32, we substantially simplified prototypes so that a prototype will never draw any external information in
;;;; when building a prototype, so the problem [3] never occurs.
;;;; The implementation of (obj-stack), called by remove-from-stack, is terrifyingly inefficient!!!!
;;;; sequential version no longer may get into these looping problems
;;;; [5] Neah, with situations we need to clone and merge for each situation, unfortunately.
;;;;	In particular, we want any CONSTRAINTS to be passed down to instances in EVERY situation, and constraints aren't projected.
;;;; RETURNS: Irrelevant
;;;; [6] We cannibalize the stack to make sure we don't unify a prototype as part of unifying the same prototype. The stack is
;;;;     searched in applicable-prototypes to check on this.
;;;; [7] If cloned-from is a non-fluent, so we only ever clone once, then we better unify in Global so any local values and 
;;;;     constraints are universally applicable
;;;; [8] If cloned-from is a non-fluent, then we only ever clone once. So we better put all the clone results in *Global, so that
;;;;     any constraints are universally applicable.
(TRACE-LISP (DEFINE UNIFY-IN-PROTOTYPE (INSTANCE PROTOTYPE &OPTIONAL SLOT) (trace-defun 'UNIFY-IN-PROTOTYPE (INSTANCE PROTOTYPE SLOT) (RET ))))
;;;; We only clone prototype roots, not things which are *in* a prototype
;;(defun find-and-clone-prototypes (instance slot)
;;  (mapcar ;'clone (applicable-prototypes instance slot)))
;;;; Returns a list of prototypes which can validly provide values of slot for instance
;;;; NB We must do the "already-done" test *after* the suitable-for-cloning work, because suitable-for-cloning may
;;;; itself create new prototypes when doing the subsumption check!
;;;; [1] If P1 and P2 are prototypes to clone, but P2 is already cloned from P1, then don't reclone P1!
;;;;     I assume you can't get mutual dependencies, where P1 is cloned from P2, is cloned from P1.
;;;; [2] return just the first one instead
;;(defun applicable-prototypes (instance slot)			; OLD [2]
;;  (remove-if-not ;'(lambda (prototype) 			; OLD [2]
(TRACE-LISP (DEFINE FIRST-APPLICABLE-PROTOTYPE (INSTANCE &OPTIONAL SLOT) (trace-defun 'FIRST-APPLICABLE-PROTOTYPE (INSTANCE SLOT) (RET ))))
;; No longer used
;;;; Returns a list of prototypes which can provide values of slot for instance, valid for a particular context only
;;(defun qualified-prototypes (instance slot)
;;  (let* ( (all-classes (all-classes instance))
;;	  (all-prototypes (remove-if-not ;'protoinstancep (my-mapcan ;'(lambda (class)
;;								     (find-vals class ';$instances))
;;								 all-classes)))
;;	  (qualified-prototypes (remove-if-not ;'(lambda (prototype)
;;						   (find-vals prototype slot))		
;;					       all-prototypes)) )
;;    qualified-prototypes))
;;;; Should we clone prototype to find the slot of instance?
;;;; [1] This is comparing just along one dimension of "context space"
;;;; [2] It's not obvious, but we only ever need to clone a prototype *once* per instance, namely in the highest supersituation in which that
;;;; 	instance is an instance-of the prototype class. In any next-situations, the values will then be projected. In any new-situations,
;;;;	the instance will have no known instance-of relationship, and thus the cloning wouldn't be valid anyway.
;;;; [6] This catastrophic kind of looping should *never* occur, but we better test for it anyway! See test-suite/protolooping2.km for
;;;;     a case where it might be necessary.
(TRACE-LISP
 (DEFINE SUITABLE-FOR-CLONING (INSTANCE SLOT PROTOTYPE)
  (trace-defun 'SUITABLE-FOR-CLONING (INSTANCE SLOT PROTOTYPE)
   (RET
    (AND (NEQ INSTANCE PROTOTYPE)  (PROTOTYPEP PROTOTYPE)  (OR  (NULL SLOT) (INSTANCE-HAS-SOMETHING-TO-SAY-ABOUT PROTOTYPE SLOT))
     (NEQ PROTOTYPE (CURR-PROTOTYPE)) 
     (COND
      (*CLONES-ARE-GLOBAL*
       (CNOT (CL-MEMBER PROTOTYPE (GET-VALS INSTANCE '|cloned-from| :SITUATION (TARGET-SITUATION (CURR-SITUATION) INSTANCE '|cloned-from|)))))
      (T (CNOT (CL-MEMBER PROTOTYPE (KM0 `(|the| |cloned-from| |of| ,INSTANCE))))))
       
     (TRACE-PROGN (KM-TRACE 'COMMENT "Seeing if prototype ~a is applicable to ~a..." PROTOTYPE INSTANCE)
      (SATISFIES-PROTOTYPE-DEFINITION INSTANCE PROTOTYPE)))))))
;;;; 1/16/04 - allow multiple prototype-scope statements
(TRACE-LISP
 (DEFINE SATISFIES-PROTOTYPE-DEFINITION (INSTANCE PROTOTYPE) (trace-defun 'SATISFIES-PROTOTYPE-DEFINITION (INSTANCE PROTOTYPE) (RET ))))
#| ======================================================================
			CLONING
A prototype is an anonymous prototype instance, connected to a network of other
instances, which can be both:
	- anonymous prototype instances
	- named instances

Cloning involves building a copy of this network, with prototype instances
replaced with new anonymous instances.

Note that cloning DOESN'T do any evaluation of expressions, they are just 
cloned as is.
 ======================================================================|#
;;(defvar *cloning* nil)
;;;; clone returns the cloned instance, and (if you're interested) the mapping-alist from proto-instances to cloned-instances.
(TRACE-LISP
 (DEFINE CLONE (PROTOTYPE)
  (trace-defun 'CLONE (PROTOTYPE)
   (RET
    (COND ((TRACEP) (SUSPEND-TRACE) (MULTIPLE-VALUE-BIND (CLONE MAPPING-ALIST) (CLONE0 PROTOTYPE) (UNSUSPEND-TRACE) (VALUES CLONE MAPPING-ALIST)))
     (T (CLONE0 PROTOTYPE)))))))
#|[1] prevents trying to clone P to find info about a clone of P.
Later: instead of flagging "nil" here, I added cloned-from as a non-inverse-recording slot, to prevent this problem in general.
For example: I1 & Clone1, where Clone1 has cloned-from X, results in X being added to the object stack when the unified result
is asserted into memory and the inverses are automatically installed.

[2] This call to km causes redundant work: Suppose my clone is
	(:set
	  (_ProtoCar1 has (parts (_ProtoEngine1)))			  ; (i)
	  (_ProtoEngine1 has (parts-of (_ProtoCar1 _ProtoTransmission1))) ; (ii)
	  ...)
(i) will assert both _ProtoCar1 and the inverse link (_ProtoEngine1 parts-of _ProtoCar1)
Then at (ii), because _ProtoEngine1 already has some slotsvals, KM will merge in rather than just assert the
given slotsvals. And this merging can be computationally complex (?) [though I think my optimizations filters these out]?
But worse: If we load a prototype while in prototype mode, (<i> has <slotsvals>) will be followed by an (evaluate-paths), 
which is killingly expensive and unnecessary!

A put-slotsvals will work fine here, it will clober any old values (eg. any earlier-installed inverses), but that's
fine as the new values should necessarily include those old values.

[3] It's not clear that we really need to keep these prototype-participant links, (they could be recomputed by a search algorithm if really
necessary). I'll leave them for now, as I went to all the trouble!.

RETURNS: two values: the clone name, and also the mappings from proto-instances to the cloned instances|#
(TRACE-LISP (DEFINE CLONE0 (PROTOTYPE) (trace-defun 'CLONE0 (PROTOTYPE) (RET ))))
;; return clone of prototype
#| ======================================================================
   build-clones: Redefined: rather than walking the clone graph,
   we know all the proto-instances already as they're stored on the prototype-participants slot of the
   clone root!
    Returns two values:
	- a list of (<clone-name> <slotsvals> <situation>) triples
	- the clone-instance mapping, a list of (<protoname> . <clone-name>) acons's.
====================================================================== |#
;;;; This was originally meant to allow prototypes to include some situation-specific components, but this generates errors when cloning!
(TRACE-LISP
 (DEFINE BUILD-CLONES (PROTOTYPE)
  (trace-defun 'BUILD-CLONES (PROTOTYPE)
   (RET
    (CLET
     ((PROTOTYPE-PARTICIPANTS (KM0 `(|the| |prototype-participants| |of| ,PROTOTYPE) :FAIL-MODE 'ERROR)) 
      (CLONE-NAMES
       (MAPCAR
        #'(LAMBDA (PROTOTYPE-PARTICIPANT)
           (trace-defun '#:G15857 (PROTOTYPE-PARTICIPANT)
            (RET
             (COND ((ANONYMOUS-INSTANCEP PROTOTYPE-PARTICIPANT) (CREATE-INSTANCE-NAME (FIRST (IMMEDIATE-CLASSES PROTOTYPE-PARTICIPANT))))
              (T PROTOTYPE-PARTICIPANT)))))
        PROTOTYPE-PARTICIPANTS))
      (MAPPING-ALIST (PAIRLIS PROTOTYPE-PARTICIPANTS CLONE-NAMES)))
     
     (VALUES
      (CL-REMOVE NIL (MAPCAR #'(LAMBDA (PROTOTYPE-PARTICIPANT) (trace-defun '#:G15858 (PROTOTYPE-PARTICIPANT) (RET )))  PROTOTYPE-PARTICIPANTS))
      MAPPING-ALIST))))))
;;;; Patch for prototype reasoning
(TRACE-LISP
 (DEFINE BUILD-CLONE (PROTOTYPE MAPPING-ALIST)
  (trace-defun 'BUILD-CLONE (PROTOTYPE MAPPING-ALIST)
   (RET
    (COND
     ((ANONYMOUS-INSTANCEP PROTOTYPE) 
      (CLET
       ((CLONE-NAME (REST (ASSOC PROTOTYPE MAPPING-ALIST))) (SLOTSVALS (GET-SLOTSVALS PROTOTYPE :SITUATION *GLOBAL-SITUATION*)) 
        (NEW-SLOTSVALS (REMOVE-IF #'(LAMBDA (SVS) (trace-defun '#:G15859 (SVS) (RET (CL-MEMBER (SLOT-IN SVS) *UNCLONABLE-SLOTS*)))) SLOTSVALS)))
       (COND (NEW-SLOTSVALS (LIST CLONE-NAME (SUBLIS MAPPING-ALIST (DEREFERENCE NEW-SLOTSVALS))))))))))))
;;;; ======================================================================
;;;; NOTE: This records the KM commands which created the prototype, purely as comments
;;;; for a showme command. These are *not* retained by (save-kb ...).
(TRACE-LISP
 (DEFINE ADD-TO-PROTOTYPE-DEFINITION (PROTOTYPE EXPR)
  (trace-defun 'ADD-TO-PROTOTYPE-DEFINITION (PROTOTYPE EXPR)
   (RET (CLET ((DEFINITION-SO-FAR (GET PROTOTYPE 'DEFINITION))) (KM-SETF PROTOTYPE 'DEFINITION (APPEND DEFINITION-SO-FAR (LIST EXPR))))))))
;;;; FILE:  think.lisp
;;;; File: think.lisp :-)
;;;; Author: Peter Clark
;;;; Purpose: Experimental, exhaustive forward-chaining on all instances in the object stack
(TRACE-LISP
 (DEFINE BUILD (KM-EXPR)
  (trace-defun 'BUILD (KM-EXPR)
   (RET
    (TRACE-PROGN (NEW-CONTEXT)
     (CLET ((SEED (KM-UNIQUE0 KM-EXPR :FAIL-MODE 'ERROR)))
      (COND ((OR (PROTOINSTANCEP SEED) (CNOT (ANONYMOUS-INSTANCEP SEED))) (KM-FORMAT T "ERROR! ~a should return an anonymous instance!~%" KM-EXPR))
       (T (EXHAUSTIVELY-FORWARD-CHAIN) (DEREFERENCE SEED)))))))))
;;;; This avoids inefficient recomputing of obj-stack each time
(TRACE-LISP
 (DEFINE EXHAUSTIVELY-FORWARD-CHAIN (&OPTIONAL TODO DONE)
  (trace-defun 'EXHAUSTIVELY-FORWARD-CHAIN (TODO DONE)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TODO (OBJ-STACK))
     (COND ((ENDP TODO)  (CLET ((NEW-TODO (SET-DIFFERENCE (OBJ-STACK) DONE))) (COND (NEW-TODO (EXHAUSTIVELY-FORWARD-CHAIN NEW-TODO DONE)))))
      (T
       (CLET ((NEXT-INSTANCE0 (FIRST TODO)) (NEXT-INSTANCE (DEREFERENCE NEXT-INSTANCE0)))
        (COND
         ((AND (CNOT (CL-MEMBER NEXT-INSTANCE DONE)) (ANONYMOUS-INSTANCEP NEXT-INSTANCE) (CNOT (PROTOINSTANCEP NEXT-INSTANCE)))
          (UNIFY-IN-PROTOTYPES NEXT-INSTANCE)))
        (EXHAUSTIVELY-FORWARD-CHAIN (REST TODO) (CONS NEXT-INSTANCE0 DONE))))))))))
;;;; FILE:  loadkb.lisp
;;;; File: loadkb.lisp
;;;; Author: Peter Clark
;;;; Date: 21st Oct 1994
(TRACE-LISP (DEFVAR *CURRENT-RENAMING-ALIST* NIL))
(TRACE-LISP (DEFVAR *STATS* NIL))
;; internal back door for keeping records
;;;; ======================================================================
;;;;			LOADING A KB
;;;; ======================================================================
#|load-kb Options:
   :verbose t	       		    - print out evaluation of expressions during load (useful for debugging a KB)
   :with-morphism <table> 	    - Experimental: table is a list of <old-symbol new-symbol> pairs.
				      Occurences of old-symbol are syntactically changed to new-symbol before 
				      evaluation. See note [1] below.
   :eval-instances t		    - Force recursive evaluation of the slot-val expressions on the instances. 
				      As a result, this creates the instance graph eagerly rather than lazily.
   :in-global t			    - Evaluate expressions in the global situation, not the current situation.

[1] SYMBOL RENAMING:
  This isn't quite right: a new symbol renaming table over-rides, rather than augments,
  any earlier symbol table. Also it's rather ugly with the global variable...update later...
  (load-kb "fred.km" :verbose t :with-morphism '((Node Elec-Device) (Arc Wire)))
  Symbol renaming is performed as a purely syntactic preprocessing step.|#
;;;; This is a top-level call by the user, issued from the USER> rather than KM>
;;;; prompt. As a result, we must mimic the initializations that the KM> prompt gives,
;;;; and in particular CATCH any throws from the user aborting from the debugger.
(TRACE-LISP
 (DEFINE CL-LOAD-KB (FILE &REST LKEYS)
  (trace-defun 'CL-LOAD-KB (FILE LKEYS)
   (RET
    (CLET (VERBOSE WITH-MORPHISM EVAL-INSTANCES LOAD-PATTERNS) (RESET-INFERENCE-ENGINE)
     (CLET ((WAS-LOGGING *LOGGING*))
      (CUNWIND-PROTECT 
       (TRACE-PROGN (STOP-LOGGING :WITH-COMMENT NIL)
        (MULTIPLE-VALUE-BIND (ANSWER ERROR)
         (LOAD-KB0 FILE :VERBOSE VERBOSE :WITH-MORPHISM WITH-MORPHISM :EVAL-INSTANCES EVAL-INSTANCES :LOAD-PATTERNS LOAD-PATTERNS)
         (DECLARE (IGNORE ANSWER))
         (COND (ERROR (FORMAT T "(Execution aborted)~%NIL~%") (VALUES NIL ERROR)) (T  (PRINC (REPORT-STATISTICS)) (TERPRI) '(|t|)))))
       (COND (WAS-LOGGING (START-LOGGING :WITH-COMMENT NIL))))))))))
;;;; This is the version called from the KM> prompt or load-kb (above). 
;;;; in-global is permenantly t, for now
(TRACE-LISP
 (DEFINE LOAD-KB0 (FILE &REST LKEYS)
  (trace-defun 'LOAD-KB0 (FILE LKEYS)
   (RET
    (CLET (VERBOSE WITH-MORPHISM EVAL-INSTANCES IN-GLOBAL LOAD-PATTERNS) (init-keyval IN-GLOBAL T) (FORMAT T "Loading ~a...~%" FILE)
     (CLET
      ((RENAMING-ALIST
        (COND (WITH-MORPHISM (CSETQ *CURRENT-RENAMING-ALIST* (TRIPLES-TO-ALIST WITH-MORPHISM)) *CURRENT-RENAMING-ALIST*) (T *CURRENT-RENAMING-ALIST*)))
       (STREAM (OPEN FILE :DIRECTION :INPUT :IF-DOES-NOT-EXIST NIL)))
      (COND ((NULL STREAM) (VALUES NIL (KM-FORMAT NIL "No such file ~a!~%" FILE)))
       (T (COND (IN-GLOBAL (GLOBAL-SITUATION))) 
        (MULTIPLE-VALUE-BIND (RESULT ERROR)
         (LOAD-EXPRS (CASE-SENSITIVE-READ-KM STREAM NIL NIL) STREAM VERBOSE RENAMING-ALIST EVAL-INSTANCES LOAD-PATTERNS) (CLOSE STREAM) (RESET-DONE) 
         (COND (WITH-MORPHISM (CSETQ *CURRENT-RENAMING-ALIST* NIL)))
         (COND (ERROR (FORMAT T "Loading of ~a aborted!~%" FILE)) (T (FORMAT T "~a loaded!~%" FILE))) (VALUES RESULT ERROR))))))))))
;;;; 1 March 06, Francis Leboutte
;;;; Rewritten non recursively (mostly - see new auxiliary function load-expr)
;;;;  o to fix a bug in LispWorks for Windows (stack overflow) when loading not that large
;;;;    KM files
;;;;  o this iterative version should be more efficient
;;;;  o Note: first returned value is ignored in the caller
;;;; 3/20/01 - rewritten to pass error back up to load-kb
(TRACE-LISP
 (DEFINE LOAD-EXPRS (EXPR STREAM &OPTIONAL VERBOSE RENAMING-ALIST EVAL-INSTANCES LOAD-PATTERNS)
  (trace-defun 'LOAD-EXPRS (EXPR STREAM VERBOSE RENAMING-ALIST EVAL-INSTANCES LOAD-PATTERNS)
   (RET
    (MULTIPLE-VALUE-BIND (RESULT ERROR) (LOAD-EXPR EXPR STREAM VERBOSE RENAMING-ALIST EVAL-INSTANCES LOAD-PATTERNS)
     (COND
      (RESULT
       (CL-LOOP
        (CLET ((EXPR (CASE-SENSITIVE-READ-KM STREAM NIL NIL)))
         (MULTIPLE-VALUE-BIND (RESULT ERROR) (LOAD-EXPR EXPR STREAM VERBOSE RENAMING-ALIST EVAL-INSTANCES LOAD-PATTERNS)
          (FUNLESS RESULT (RET (VALUES RESULT ERROR)))))))
      (T (VALUES RESULT ERROR))))))))
(TRACE-LISP
 (DEFINE LOAD-EXPR (EXPR STREAM &OPTIONAL VERBOSE RENAMING-ALIST EVAL-INSTANCES LOAD-PATTERNS)
  (trace-defun 'LOAD-EXPR (EXPR STREAM VERBOSE RENAMING-ALIST EVAL-INSTANCES LOAD-PATTERNS)
   (RET
    (CLET ((RENAMED-EXPR (RENAME-SYMBOLS EXPR RENAMING-ALIST)))
     (COND ((NULL RENAMED-EXPR) NIL)
      ((AND (LISTP RENAMED-EXPR) (EQ (FIRST RENAMED-EXPR) '|symbol-renaming-table|))
       (FORMAT T "(Symbol renaming table encountered and will be conformed to)~%")
       (LOAD-EXPR (CASE-SENSITIVE-READ-KM STREAM NIL NIL) STREAM VERBOSE (TRIPLES-TO-ALIST (SECOND RENAMED-EXPR)) EVAL-INSTANCES LOAD-PATTERNS))
      ((AND LOAD-PATTERNS (NOTANY #'(LAMBDA (PATTERN) (trace-defun '#:G15860 (PATTERN) (RET ))) LOAD-PATTERNS)) T)
      (VERBOSE (PRINT-KM-PROMPT) (KM-FORMAT T " ~a~%" RENAMED-EXPR) (RESET-INFERENCE-ENGINE)
       (MULTIPLE-VALUE-BIND (RESULTS ERROR) (KM-EVAL-PRINT RENAMED-EXPR :FAIL-MODE *TOP-LEVEL-FAIL-MODE*)
        (COND ((OR EVAL-INSTANCES (AM-IN-PROTOTYPE-MODE)) (EVAL-INSTANCES RESULTS))) (COND (ERROR (VALUES NIL ERROR)) (T T))))
      (T  (CSETQ *CATCH-EXPLANATIONS* NIL) 
       (COND (*CATCH-NEXT-EXPLANATIONS* (CSETQ *EXPLANATIONS* NIL) (CSETQ *CATCH-EXPLANATIONS* T) (CSETQ *CATCH-NEXT-EXPLANATIONS* NIL)))
       (MULTIPLE-VALUE-BIND (RESULTS ERROR) (KM-EVAL RENAMED-EXPR :FAIL-MODE *TOP-LEVEL-FAIL-MODE*)
        (COND ((OR EVAL-INSTANCES (AM-IN-PROTOTYPE-MODE)) (EVAL-INSTANCES RESULTS))) (COND (ERROR (VALUES NIL ERROR)) (T T))))))))))
;;;; ----------
(TRACE-LISP
 (DEFINE RENAME-SYMBOLS (EXPR RENAMING-ALIST) (trace-defun 'RENAME-SYMBOLS (EXPR RENAMING-ALIST) (RET (SUBLIS RENAMING-ALIST EXPR)))))
;;;; '((1 -> a) (2 -> b)) -> ((1 . a) (2 . b))
;;;;	                      ^   ^
;;;;		           local global 
;;;; We do this conversion so that we can use built-in sublis to do the symbol renaming.
(TRACE-LISP
 (DEFINE TRIPLES-TO-ALIST (TRIPLES)
  (trace-defun 'TRIPLES-TO-ALIST (TRIPLES)
   (RET
    (COND ((QUOTEP TRIPLES) (TRIPLES-TO-ALIST (UNQUOTE TRIPLES)))
     ((OR (CNOT (LISTP TRIPLES))
       (CNOT (EVERY #'(LAMBDA (X) (trace-defun '#:G15861 (X) (RET (AND (TRIPLEP X) (SYMBOLP (FIRST X)) (EQ (SECOND X) '->)))))  TRIPLES)))
      (REPORT-ERROR 'NODEBUGGER-ERROR
       ":with-morphism: renaming table should be a list of triples of the form~% ((OldS1 -> NewS1) (OldS2 -> NewS2) ...)~%"))
     (T
      (MAPCAR
       #'(LAMBDA (TRIPLE)
          (trace-defun '#:G15862 (TRIPLE)
           (RET
            (COND
             ((CNOT (TRIPLEP TRIPLE))
              (REPORT-ERROR 'NODEBUGGER-ERROR "Non-triple found in the symbol renaming table!~%Non-triple was: ~a. Ignoring it...~%" TRIPLE))
             (T (CONS (FIRST TRIPLE) (THIRD TRIPLE)))))))
       TRIPLES)))))))
;;;; ----------------------------------------
;;; Useful macro, callable from top-level prompt.
(TRACE-LISP
 (DEFINE RELOAD-KB (FILE &REST LKEYS)
  (trace-defun 'RELOAD-KB (FILE LKEYS)
   (RET
    (CLET (VERBOSE WITH-MORPHISM EVAL-INSTANCES LOAD-PATTERNS) (RESET-KB)
     (CL-LOAD-KB FILE :VERBOSE VERBOSE :WITH-MORPHISM WITH-MORPHISM :EVAL-INSTANCES EVAL-INSTANCES :LOAD-PATTERNS LOAD-PATTERNS))))))
;;;; Same, callable from within KM
(TRACE-LISP
 (DEFINE RELOAD-KB0 (FILE &REST LKEYS)
  (trace-defun 'RELOAD-KB0 (FILE LKEYS)
   (RET
    (CLET (VERBOSE WITH-MORPHISM EVAL-INSTANCES LOAD-PATTERNS) (RESET-KB)
     (LOAD-KB0 FILE :VERBOSE VERBOSE :WITH-MORPHISM WITH-MORPHISM :EVAL-INSTANCES EVAL-INSTANCES :LOAD-PATTERNS LOAD-PATTERNS))))))
;;;; ======================================================================
;;;;		LOWEST-LEVEL ACCESS TO THE PROPERTY LISTS
;;;; ======================================================================
;;;; Converted to using hash table for KB-objects thanks to Adam Farquhar
(TRACE-LISP (DEFVAR *KB-OBJECTS* (CL-MAKE-HASH-TABLE :TEST #'EQ)))
(TRACE-LISP
 (DEFINE GETOBJ (NAME FACET)
  (trace-defun 'GETOBJ (NAME FACET)
   (RET
    (COND
     ((AND (CNOT (CL-MEMBER FACET *ALL-FACETS*)) (CNOT (ISA-SITUATION-FACET FACET)))
      (REPORT-ERROR 'PROGRAM-ERROR "(getobj ~a ~a) Don't recognize facet ~a!~%(Should be one of ~a)~%" NAME FACET FACET *ALL-FACETS*))
     ((KB-OBJECTP NAME) (CSETQ *STATISTICS-KB-ACCESS* (1+ *STATISTICS-KB-ACCESS*)) (GET NAME FACET)) ((IS-KM-TERM NAME) NIL) 
     (T (REPORT-ERROR 'PROGRAM-ERROR "Accessing frame ~a - the frame name `~a' should be an atom!~%" NAME NAME)))))))
;;;; To DELETE an object, now use delete-frame (above).
;;;; (putobj nil won't remove object from *kb-objects*)
(TRACE-LISP
 (DEFINE PUTOBJ (FNAME SLOTSVALS FACET)
  (trace-defun 'PUTOBJ (FNAME SLOTSVALS FACET)
   (RET
    (COND
     ((AND (CNOT (CL-MEMBER FACET *ALL-FACETS*)) (CNOT (ISA-SITUATION-FACET FACET)))
      (REPORT-ERROR 'PROGRAM-ERROR "(putobj ~a ~a) Don't recognize facet ~a!~%(Should be one of ~a)~%" FNAME FACET FACET *ALL-FACETS*))
     (SLOTSVALS   (KM-SETF FNAME FACET SLOTSVALS) (COND ((CNOT (GETHASH FNAME *KB-OBJECTS*))   (KM-ADD-TO-KB-OBJECT-LIST FNAME))))
     (T (REMPROP FNAME FACET)))))))
;;;; ======================================================================
;;;;		ROLLBACK MECHANISM
;;;; ======================================================================
#|KM> (every man has (parts ((a Head))))
KM> (Pete has (instance-of (Man)))
KM> (undo)
Undone (Pete has (instance-of (Man)))...
KM> |#
(TRACE-LISP (DEFVAR *HISTORY* NIL))
;; (defvar *logging* nil) - in header.lisp
(TRACE-LISP (DEFINE RESET-HISTORY NIL (trace-defun 'RESET-HISTORY NIL (RET (CSETQ *HISTORY* NIL)))))
(TRACE-LISP (DEFCONSTANT *CHECKPOINT* 'CHECKPOINT))
(TRACE-LISP (DEFINE CHECKPOINT-P (X) (trace-defun 'CHECKPOINT-P (X) (RET (AND (PAIRP X) (CL-EQUAL (FIRST X) *CHECKPOINT*))))))
(TRACE-LISP (DEFINE CHECKPOINT-ID (X) (trace-defun 'CHECKPOINT-ID (X) (RET (SECOND X)))))
(TRACE-LISP
 (DEFINE SET-CHECKPOINT (&OPTIONAL CHECKPOINT-ID)
  (trace-defun 'SET-CHECKPOINT (CHECKPOINT-ID)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR CHECKPOINT-ID 'T) (COND ((OR *LOGGING* *INTERNAL-LOGGING*) (PUSH (LIST *CHECKPOINT* CHECKPOINT-ID) *HISTORY*) T)))))))
;;;; From Ken Murray
(TRACE-LISP
 (DEFINE NEXT-CHECKPOINT NIL (trace-defun 'NEXT-CHECKPOINT NIL (RET (SECOND (FIRST (CL-MEMBER *CHECKPOINT* *HISTORY* :KEY #'FIRST)))))))
(TRACE-LISP
 (DEFINE UNDO-POSSIBLE (&OPTIONAL CHECKPOINT-ID)
  (trace-defun 'UNDO-POSSIBLE (CHECKPOINT-ID)
   (RET (COND (CHECKPOINT-ID (CL-MEMBER (LIST *CHECKPOINT* CHECKPOINT-ID) *HISTORY* :TEST #'CL-EQUAL)) (T (ASSOC *CHECKPOINT* *HISTORY*)))))))
;;;; revise this: (undo <checkpoint-id>) will undo right back to <checkpoint-id> (if it exists)
;;;; Returns NIL if no undo possible, <checkpoint-id> if so.
;;;; If checkpoint-id = nil, then just undo to the last checkpoint.
;;;; [1] When called from a program, need to do this. When called from KM> prompt, this is done automatically anyway
;;;;     by (reset-inference-engine)
;;;; [2] With *internal-logging*, the done flags ARE on the history trace and so undo0 will undo them. This is better
;;;;     than undoing absolutely everything.
(TRACE-LISP
 (DEFINE UNDO (&OPTIONAL CHECKPOINT-ID)
  (trace-defun 'UNDO (CHECKPOINT-ID)
   (RET (COND ((UNDO-POSSIBLE CHECKPOINT-ID) (COND ((CNOT *INTERNAL-LOGGING*) (RESET-DONE)))  (PROG1 (UNDO0 *HISTORY* CHECKPOINT-ID))))))))
(TRACE-LISP
 (DEFINE UNDO0 (HISTORY CHECKPOINT-ID)
  (trace-defun 'UNDO0 (HISTORY CHECKPOINT-ID)
   (RET
    (COND ((NULL HISTORY)  (CSETQ *HISTORY* NIL) (KM-FORMAT T "Nothing more to undo!~%"))
     ((AND (CHECKPOINT-P (FIRST HISTORY)) (OR (NULL CHECKPOINT-ID) (CL-EQUAL CHECKPOINT-ID (CHECKPOINT-ID (FIRST HISTORY)))))
      (PROG1 (CHECKPOINT-ID (FIRST HISTORY))  (CSETQ *HISTORY* (REST HISTORY))))
     (T (COND ((CNOT (CHECKPOINT-P (FIRST HISTORY))) (UNDO1 (FIRST HISTORY)))) (UNDO0 (REST HISTORY) CHECKPOINT-ID)))))))
(TRACE-LISP (DEFINE UNDO1 (COMMAND) (trace-defun 'UNDO1 (COMMAND) (RET ))))
;;;; ----------
;;;; This is how setf works: (setf (get symbol property) new-values)
(TRACE-LISP
 (DEFINE LOG-UNDO-COMMAND (COMMAND)
  (trace-defun 'LOG-UNDO-COMMAND (COMMAND) (RET (COND ((OR *LOGGING* *INTERNAL-LOGGING*) (PUSH COMMAND *HISTORY*)))))))
(TRACE-LISP
 (DEFINE START-LOGGING (&REST LKEYS)
  (trace-defun 'START-LOGGING (LKEYS)
   (RET
    (CLET (WITH-COMMENT) (init-keyval WITH-COMMENT T)
     (COND (*LOGGING* (COND (WITH-COMMENT (FORMAT T "(Logging of KM commands is already switched on)~%"))))
      (T (COND (WITH-COMMENT (FORMAT T "(Started logging KM commands)~%"))) (CSETQ *LOGGING* T)))
     T)))))
(TRACE-LISP
 (DEFINE STOP-LOGGING (&REST LKEYS)
  (trace-defun 'STOP-LOGGING (LKEYS)
   (RET
    (CLET (WITH-COMMENT) (init-keyval WITH-COMMENT T)
     (COND ((CNOT *LOGGING*) (COND (WITH-COMMENT (FORMAT T "(Logging of KM commands is already switched off)~%"))))
      (T (COND (WITH-COMMENT (FORMAT T "(Stopping logging of KM commands)~%"))) (CSETQ *LOGGING* NIL) (CSETQ *HISTORY* NIL)))
     T)))))
;;;; ----------
;;;; Could optimize this if eval is too slow
(TRACE-LISP
 (DEFINE KM-SETQ (VARIABLE VALUE)
  (trace-defun 'KM-SETQ (VARIABLE VALUE)
   (RET
    (CLET ((OLD-VALUE (EVAL VARIABLE)))
     (COND ((CL-EQUAL OLD-VALUE VALUE)) (T (LOG-UNDO-COMMAND `(CSETQ ,VARIABLE ',OLD-VALUE)) (EVAL `(CSETQ ,VARIABLE ',VALUE)))))))))
;; need to unquote the variable
(TRACE-LISP
 (DEFINE KM-SETF (SYMBOL PROPERTY VALUE)
  (trace-defun 'KM-SETF (SYMBOL PROPERTY VALUE)
   (RET
    (CLET ((OLD-VALUE (GET SYMBOL PROPERTY)))
     (COND ((CL-EQUAL OLD-VALUE VALUE)) (T (LOG-UNDO-COMMAND `(CSETF (GET ',SYMBOL ',PROPERTY) ',OLD-VALUE)) (CSETF (GET SYMBOL PROPERTY) VALUE))))))))
(TRACE-LISP
 (DEFINE KM-ADD-TO-KB-OBJECT-LIST (FNAME)
  (trace-defun 'KM-ADD-TO-KB-OBJECT-LIST (FNAME)
   (RET
    (CLET ((OLD-VALUE (GETHASH FNAME *KB-OBJECTS*)))
     (COND (OLD-VALUE) (T (LOG-UNDO-COMMAND `(KM-DEL-FROM-KB-OBJECT-LIST ',FNAME)) (CSETF (GETHASH FNAME *KB-OBJECTS*) T))))))))
;;;; For undo only
(TRACE-LISP (DEFINE KM-DEL-FROM-KB-OBJECT-LIST (FNAME) (trace-defun 'KM-DEL-FROM-KB-OBJECT-LIST (FNAME) (RET (REMHASH FNAME *KB-OBJECTS*)))))
;;;; ======================================================================
;;;; NEW (using hash table)
;;;; NOTE: We *don't* do dereferencing here, because we want to delete the old concepts with a (reset-kb)
(TRACE-LISP
 (DEFINE GET-ALL-OBJECTS NIL
  (trace-defun 'GET-ALL-OBJECTS NIL
   (RET
    (CLET ((RESULTS NIL))
     (MAPHASH #'(LAMBDA (K V) (trace-defun '#:G15863 (K V) (RET (TRACE-PROGN (DECLARE (IGNORE V)) (PUSH K RESULTS))))) *KB-OBJECTS*) RESULTS)))))
;;;; EXCLUDES comment tags. Here we *do* do a dereference.
(TRACE-LISP
 (DEFINE GET-ALL-CONCEPTS NIL
  (trace-defun 'GET-ALL-CONCEPTS NIL
   (RET
    (CLET ((RESULTS NIL))
     (MAPHASH
      #'(LAMBDA (K V) (trace-defun '#:G15864 (K V) (RET (TRACE-PROGN (DECLARE (IGNORE V)) (COND ((CNOT (USER-COMMENTP K)) (PUSH K RESULTS)))))))
      *KB-OBJECTS*)
     (CL-REMOVE-DUPLICATES (DEREFERENCE RESULTS)))))))
(TRACE-LISP
 (DEFINE DELETE-FRAME-STRUCTURE (FNAME)
  (trace-defun 'DELETE-FRAME-STRUCTURE (FNAME) (RET (TRACE-PROGN (REMPROPS FNAME) (REMHASH FNAME *KB-OBJECTS*) FNAME)))))
;;;; Rename this from "exists"; it really means fname is a known frame (Is an error to try this check for numbers and strings)
(TRACE-LISP
 (DEFINE KNOWN-FRAME (FNAME)
  (trace-defun 'KNOWN-FRAME (FNAME)
   (RET
    (COND ((KB-OBJECTP FNAME) (OR (GETHASH FNAME *KB-OBJECTS*) (BUILT-IN-CONCEPT FNAME)))
     (T (REPORT-ERROR 'PROGRAM-ERROR "known-frame: Attempt to check if a non kb-object ~a is a frame!~%" FNAME)))))))
;;; --------------------
(TRACE-LISP
 (DEFINE RESET-KB NIL
  (trace-defun 'RESET-KB NIL
   (RET
    (TRACE-PROGN (GLOBAL-SITUATION) (INSTANCE-OF-IS-NONFLUENT)  (FORMAT T "Resetting KM...~%")
     (MAPC #'(LAMBDA (FRAME) (trace-defun '#:G15865 (FRAME) (RET (DELETE-FRAME-STRUCTURE FRAME)))) (GET-ALL-OBJECTS)) (CLEAR-OBJ-STACK)
     (CSETQ *CURR-PROTOTYPE* NIL) (CSETQ *CLASSES-USING-ASSERTIONS-SLOT* NIL)  (CSETQ *ARE-SOME-SUBSLOTS* NIL)  (CSETQ *ARE-SOME-PROTOTYPES* NIL) 
     (CSETQ *ARE-SOME-DEFINITIONS* NIL)  (CSETQ *ARE-SOME-CONSTRAINTS* NIL)  (CSETQ *ARE-SOME-TAGS* NIL)  (CSETQ *AM-IN-SITUATIONS-MODE* NIL)
     (CSETQ *VISIBLE-THEORIES* NIL) (CSETQ *DEFAULT-FLUENT-STATUS* *DEFAULT-DEFAULT-FLUENT-STATUS*) (CSETQ *KM-GENSYM-COUNTER* 0) (CSETQ *PID-COUNTER* 0)
     (CSETQ *MAX-PADDING-INSTANCES* 0) (CSETQ *INTERNAL-LOGGING* NIL)  (ENABLE-CLASSIFICATION) (RESET-HISTORY) (CLEAR-KM-STACK) (RESET-TRACE)
     (RESET-TRACE-DEPTH) (RESET-DONE) T)))))
;;;; [1] This should *always* be enabled EXCEPT during restoration of a saved-state.
;;;; To be sure, we re-enable it with a (reset-inference-engine) call in case somehow
;;;; there's an abort during a saved-state restoration, and we don't want to be left
;;;; with installing-inverses disabled.
(TRACE-LISP
 (DEFINE RESET-INFERENCE-ENGINE NIL
  (trace-defun 'RESET-INFERENCE-ENGINE NIL
   (RET
    (TRACE-PROGN (CSETQ *AM-CLASSIFYING* NIL) (CSETQ *CATCH-EXPLANATIONS* NIL) (CSETQ *INTERNAL-LOGGING* NIL)
     (COND (*CATCH-NEXT-EXPLANATIONS* (CSETQ *EXPLANATIONS* NIL) (CSETQ *CATCH-EXPLANATIONS* T) (CSETQ *CATCH-NEXT-EXPLANATIONS* NIL))) (CLEAR-KM-STACK)
     (RESET-STATISTICS) (RESET-TRACE) (RESET-TRACE-DEPTH) (ENABLE-INSTALLING-INVERSES))))))
;; [1]
(TRACE-LISP
 (DEFINE CLEAR-SITUATIONS NIL
  (trace-defun 'CLEAR-SITUATIONS NIL
   (RET
    (TRACE-PROGN (GLOBAL-SITUATION)
     (CLET
      ((FACETS
        (MY-MAPCAN
         #'(LAMBDA (SITUATION)
            (trace-defun '#:G15866 (SITUATION)
             (RET
              (MAPCAR #'(LAMBDA (FACET) (trace-defun '#:G15867 (FACET) (RET (CURR-SITUATION-FACET FACET SITUATION))))
               (CONS 'EXPLANATION *ALL-FACETS*)))))
         (CL-REMOVE *GLOBAL-SITUATION* (ALL-SITUATIONS)))))
      (MAPC
       #'(LAMBDA (FRAME)
          (trace-defun '#:G15868 (FRAME)
           (RET
            (COND ((CL-ISA FRAME '|Situation|) (DELETE-FRAME FRAME))
             ((CL-INTERSECTION (SYMBOL-PLIST FRAME) FACETS) 
              (MAPC #'(LAMBDA (FACET) (trace-defun '#:G15869 (FACET) (RET (REMPROP FRAME FACET)))) FACETS))))))
       (GET-ALL-CONCEPTS))
      T))))))
;;;; ======================================================================
;;;;			SAVING A KB
;;;; ======================================================================
(TRACE-LISP
 (DEFINE SAVE-KB (FILE)
  (trace-defun 'SAVE-KB (FILE) (RET (CLET ((STREAM (TELL FILE))) (WRITE-KB STREAM) (CLOSE STREAM) (FORMAT T "~a saved!~%" FILE) T)))))
;;;; [1] We disable installing inverses so that, when restoring the KB state, we guarantee that
;;;; the ordering of slot-vals on inverse slots is preserved (otherwise the install inverses
;;;; procedure may change the ordering, 
;;;; e.g. SAVED: fsv', f'sv', v'invs(f'f) would restore as fsv', f'sv', v'invs(ff') without this.
(TRACE-LISP
 (DEFINE WRITE-KB (&OPTIONAL STREAM OBJECTS SITUATIONS0)
  (trace-defun 'WRITE-KB (STREAM OBJECTS SITUATIONS0)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR OBJECTS (GET-ALL-OBJECTS)) (SUBLISP-INITVAR STREAM *STANDARD-OUTPUT*)
     (COND
      ((AND (CNOT (STREAMP STREAM)) (CNOT (EQ STREAM T)))
       (REPORT-ERROR 'NODEBUGGER-ERROR
        "write-kb given a non-stream as an argument!~%(Use (save-kb \"myfile\") to save KB to the file called \"myfile\")~%"))
      (T
       (CLET ((SITUATIONS (OR SITUATIONS0 (ALL-SITUATIONS))))
        (MULTIPLE-VALUE-BIND (CONCEPTS COMMENT-TAGS) (SORT-OBJECTS-FOR-WRITING OBJECTS)
         (FORMAT STREAM "~%;;; Current state of the KB (~a, KM ~a)~%" (NOW) *KM-VERSION-STR*)
         (COND ((SINGLETONP SITUATIONS0) (KM-FORMAT STREAM ";;; Showing data for situation ~a only.~%~%" (FIRST SITUATIONS0)))
          (SITUATIONS0 (KM-FORMAT STREAM "Showing data for situations ~a only.~%~%" SITUATIONS0))
          (T (FORMAT STREAM "~%(reset-kb)~%") (KM-FORMAT STREAM "~%(disable-slot-checking)       ;;; (Temporarily disable while rebuilding KB state)~%")
           (KM-FORMAT STREAM "~%(disable-installing-inverses) ;;; (Temporarily disable while rebuilding KB state)~%") 
           (COND (*ARE-SOME-DEFINITIONS* (KM-FORMAT STREAM "~%(disable-classification)     ;;; (Temporarily disable while rebuilding KB state)~%")))
           (COND (*BUILT-IN-INERTIAL-FLUENT-SLOTS* (KM-FORMAT STREAM "~%(instance-of-is-fluent)~%"))) (FORMAT STREAM "~%;;; ----------~%~%")))
         (MAPC
          #'(LAMBDA (CONCEPT)
             (trace-defun '#:G15870 (CONCEPT)
              (RET
               (COND
                ((CNOT (BOUND CONCEPT)) (PRINC (WRITE-FRAME CONCEPT :SITUATIONS SITUATIONS :NULLS-OKAYP T) STREAM) (PRINC ";;; ----------" STREAM)
                 (TERPRI STREAM) (TERPRI STREAM))))))
          CONCEPTS)
         (MAPC
          #'(LAMBDA (COMMENT-TAG)
             (trace-defun '#:G15871 (COMMENT-TAG)
              (RET
               (TRACE-PROGN (KM-FORMAT STREAM "~a~%~%" `(|comment| ,COMMENT-TAG ,@(GET COMMENT-TAG 'COMMENT))) (PRINC ";;; ----------" STREAM)
                (TERPRI STREAM) (TERPRI STREAM)))))
          COMMENT-TAGS)
         (WRITE-STATE-VARIABLES STREAM) (FORMAT STREAM ";;; --- end (~a frames written) ---~%~%" (LENGTH (REMOVE-IF #'BOUND OBJECTS))))))))))))
;;;; Various variables about the current state, to write back so we can pick up 
;;;; where we left off if we reload...
(TRACE-LISP
 (DEFINE WRITE-STATE-VARIABLES (&OPTIONAL STREAM)
  (trace-defun 'WRITE-STATE-VARIABLES (STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T)
     (KM-FORMAT STREAM
      "
;;; ----------------------------------------
;;;	KM'S INTERNAL PARAMETER VALUES
;;; ----------------------------------------

")
     (MAPC
      #'(LAMBDA (KM-PARAMETER)
         (trace-defun '#:G15872 (KM-PARAMETER) (RET (KM-FORMAT STREAM "(SETQ ~a '~a)~%" KM-PARAMETER (EVAL KM-PARAMETER)))))
      (APPEND *KM-BEHAVIOR-PARAMETERS* *KM-STATE-PARAMETERS*))
     (COND ((NEQ *DEFAULT-FLUENT-STATUS* *DEFAULT-DEFAULT-FLUENT-STATUS*) (KM-FORMAT STREAM "(default-fluent-status ~a)~%" *DEFAULT-FLUENT-STATUS*)))
     (COND (*INSTANCE-OF-IS-FLUENT* (KM-FORMAT STREAM "~%((instance-of-is-fluent))~%")))
     (COND (*ARE-SOME-DEFINITIONS* (KM-FORMAT STREAM "~%(enable-classification)     ;;; (Re-enable it after restoring KB state)~%")))
     (KM-FORMAT STREAM "~%(enable-installing-inverses) ;; (Re-enable it after restoring KB state)~%")
     (COND ((NEQ *CURR-SITUATION* *GLOBAL-SITUATION*) (KM-FORMAT STREAM "~%(in-situation ~a)~%" (CURR-SITUATION)))) (KM-FORMAT STREAM "~%"))))))
;;;; ------------------------------
;; [1] copy-seq as sort is destructive!
;; [2] When reading (in-situation <S> ...) KM will check S is a situation, we
;;     must ensure Situations are written out *first* so the check is passed at reload time.
(TRACE-LISP
 (DEFINE SORT-OBJECTS-FOR-WRITING (OBJECTS0)
  (trace-defun 'SORT-OBJECTS-FOR-WRITING (OBJECTS0)
   (RET
    (CLET
     ( (COMMENT-TAGS (REMOVE-IF-NOT #'USER-COMMENTP OBJECTS0)) (OBJECTS (REMOVE-IF #'USER-COMMENTP OBJECTS0))
      (SLOT-CLASSES (CL-INTERSECTION (CONS '|Slot| (ALL-SUBCLASSES '|Slot|)) OBJECTS)) (PROTOTYPES (REMOVE-IF-NOT #'PROTOTYPEP OBJECTS)) 
      (SITUATION-CLASSES (COND ((CL-MEMBER '|Situation| OBJECTS) (CONS '|Situation| (ALL-SUBCLASSES '|Situation|)))))
      (SITUATION-INSTANCES (REMOVE-IF-NOT #'(LAMBDA (SITUATION) (trace-defun '#:G15873 (SITUATION) (RET ))) OBJECTS))
      (THEORY-CLASSES (COND ((CL-MEMBER '|Theory| OBJECTS) (CL-INTERSECTION (CONS '|Theory| (ALL-SUBCLASSES '|Theory|)) OBJECTS))))
      (THEORY-INSTANCES (REMOVE-IF-NOT #'(LAMBDA (THEORY) (trace-defun '#:G15874 (THEORY) (RET ))) OBJECTS))
      (REST-OBJECTS
       (SET-DIFFERENCE OBJECTS0 (APPEND SLOT-CLASSES PROTOTYPES SITUATION-CLASSES SITUATION-INSTANCES THEORY-CLASSES THEORY-INSTANCES COMMENT-TAGS))))
     (VALUES
      (APPEND (SORT (COPY-SEQ SLOT-CLASSES) #'STRING-LESSP) (SORT (COPY-SEQ THEORY-CLASSES) #'STRING-LESSP)
       (SORT (COPY-SEQ THEORY-INSTANCES) #'STRING-LESSP) (SORT (COPY-SEQ SITUATION-CLASSES) #'STRING-LESSP)
       (SORT (COPY-SEQ SITUATION-INSTANCES) #'STRING-LESSP) (SORT (COPY-SEQ PROTOTYPES) #'STRING-LESSP) (SORT (COPY-SEQ REST-OBJECTS) #'STRING-LESSP))
      (SORT (COPY-SEQ COMMENT-TAGS) #'STRING-LESSP)))))))
;;;; ======================================================================
;;;;		SAVING THE KB TO MEMORY (RATHER THAN DISK)	
;;;; ======================================================================
(TRACE-LISP (DEFVAR *STORED-KB* NIL))
(TRACE-LISP
 (DEFINE STORE-KB NIL
  (trace-defun 'STORE-KB NIL
   (RET (CLET ((NOW (NOW))) (CSETQ *STORED-KB* (LIST NOW (GET-KB))) (FORMAT T "State of KB stored (~a)~%" NOW) '(|t|))))))
(TRACE-LISP
 (DEFINE RESTORE-KB NIL
  (trace-defun 'RESTORE-KB NIL
   (RET
    (COND ((NULL *STORED-KB*) (FORMAT T "No stored KB state to restore!~%"))
     (T (PUT-KB (SECOND *STORED-KB*)) (FORMAT T "State of KB restored to that stored at ~a.~%" (FIRST *STORED-KB*)) '(|t|)))))))
;;;; Return the KB as a massive data structure (!)
(TRACE-LISP
 (DEFINE GET-KB NIL
  (trace-defun 'GET-KB NIL
   (RET
    (APPEND '((RESET-KB))
     (MAPCAN
      #'(LAMBDA (CONCEPT)
         (trace-defun '#:G15875 (CONCEPT)
          (RET `((CSETF (SYMBOL-PLIST ',CONCEPT) ',(COPY-TREE (SYMBOL-PLIST CONCEPT))) (KM-ADD-TO-KB-OBJECT-LIST ',CONCEPT)))))
      (SORT (COPY-TREE (GET-ALL-OBJECTS)) #'STRING<))
     (MAPCAR #'(LAMBDA (KM-PARAMETER) (trace-defun '#:G15876 (KM-PARAMETER) (RET `(CSETQ ,KM-PARAMETER ',(EVAL KM-PARAMETER)))))
      (APPEND *KM-BEHAVIOR-PARAMETERS* *KM-STATE-PARAMETERS*))
     (COND (*INSTANCE-OF-IS-FLUENT* '((INSTANCE-OF-IS-FLUENT)))) (COND (*ARE-SOME-DEFINITIONS* '((ENABLE-CLASSIFICATION))))
     (COND ((NEQ *CURR-SITUATION* *GLOBAL-SITUATION*) `((IN-SITUATION ',*CURR-SITUATION*)))))))))
(TRACE-LISP
 (DEFINE PUT-KB (KB)
  (trace-defun 'PUT-KB (KB) (RET (TRACE-PROGN (FORMAT T "Restoring KB from stored state...~%") (MAPC #'EVAL (COPY-TREE KB)) T)))))
(TRACE-LISP
 (DEFINE FASTSAVE-KB (FILE)
  (trace-defun 'FASTSAVE-KB (FILE)
   (RET
    (CLET ((STREAM (TELL FILE))) (PRINT '(RESET-KB) STREAM)
     (MAPC
      #'(LAMBDA (CONCEPT)
         (trace-defun '#:G15877 (CONCEPT)
          (RET
           (TRACE-PROGN (COND (*USING-KM-PACKAGE* (PRINT '(IN-PACKAGE :KM) STREAM)))
            (PRINT `(CSETF (SYMBOL-PLIST ',CONCEPT) ',(SYMBOL-PLIST CONCEPT)) STREAM) (PRINT `(KM-ADD-TO-KB-OBJECT-LIST ',CONCEPT) STREAM)))))
      (SORT (COPY-TREE (GET-ALL-OBJECTS)) #'STRING<))
     (MAPC #'(LAMBDA (KM-PARAMETER) (trace-defun '#:G15878 (KM-PARAMETER) (RET (PRINT `(CSETQ ,KM-PARAMETER ',(EVAL KM-PARAMETER)) STREAM))))
      (APPEND *KM-BEHAVIOR-PARAMETERS* *KM-STATE-PARAMETERS*))
     (COND (*INSTANCE-OF-IS-FLUENT* (PRINT '(INSTANCE-OF-IS-FLUENT) STREAM))) (COND (*ARE-SOME-DEFINITIONS* (PRINT '(ENABLE-CLASSIFICATION) STREAM)))
     (COND ((NEQ *CURR-SITUATION* *GLOBAL-SITUATION*) (PRINT `(IN-SITUATION ',*CURR-SITUATION*) STREAM))) (CLOSE STREAM)
     (FORMAT T "~a saved!~%NOTE: Load this file using (fastload-kb ~s), not (load-kb ~s)~%" FILE FILE FILE) T)))))
;;;; Fastload is simply using the Lisp loader
(TRACE-LISP
 (DEFINE FASTLOAD-KB (FILE)
  (trace-defun 'FASTLOAD-KB (FILE) (RET (TRACE-PROGN (FORMAT T "Fast-loading ~a...~%" FILE) (LOAD FILE) (FORMAT T "~a loaded!~%" FILE))))))
;;;; ======================================================================
;;;;		FAST-LOADING OF FILES
;;;; ======================================================================
#|These fast-loading functions directly access the KB database, rather than through
calls to KM. This fast-loading is limited:
  (i) no inverses are installed. This includes subclass-superclass links!!
  (ii) detecting of redundant assertions by checking for duplicates, rather
	than subsumees.
  (iii) all slots asssumed multivalued|#
(TRACE-LISP
 (DEFINE SIMPLELOAD-KB (KM-FILE &REST LKEYS)
  (trace-defun 'SIMPLELOAD-KB (KM-FILE LKEYS)
   (RET
    (CLET (INSTALL-INVERSESP) (init-keyval INSTALL-INVERSESP T) (FORMAT T "Simple-loading ~a...~%" KM-FILE)
     (CLET ((STREAM (SEE KM-FILE))) (CL-LOOP WHILE (SIMPLELOAD-EXPR (CASE-SENSITIVE-READ-KM STREAM NIL NIL) :INSTALL-INVERSESP INSTALL-INVERSESP))
      (CLOSE STREAM))
     (FORMAT T "~a read!~%" KM-FILE))))))
(TRACE-LISP
 (DEFINE SIMPLELOAD-EXPR (ITEM &REST LKEYS)
  (trace-defun 'SIMPLELOAD-EXPR (ITEM LKEYS)
   (RET
    (CLET (INSTALL-INVERSESP) (init-keyval INSTALL-INVERSESP T)
     (COND ((NULL ITEM) NIL)
      ((CNOT (EQ (SECOND ITEM) '|has|)) (REPORT-ERROR 'NODEBUGGER-ERROR "simpleload-kb doesn't know how to process expression ~a! Ignoring it...~%" ITEM)
       T)
       (T (SIMPLE-ADD-SLOTSVALS (FIRST ITEM) (REST (REST ITEM)) :INSTALL-INVERSESP INSTALL-INVERSESP))))))))
;;;; Faster version of frame-io.lisp routine
(TRACE-LISP
 (DEFINE SIMPLE-ADD-SLOTSVALS (INSTANCE ADD-SLOTSVALS &REST LKEYS)
  (trace-defun 'SIMPLE-ADD-SLOTSVALS (INSTANCE ADD-SLOTSVALS LKEYS)
   (RET
    (CLET (INSTALL-INVERSESP) (init-keyval INSTALL-INVERSESP T)
     (CLET
      ((OLD-SLOTSVALS (GET INSTANCE 'OWN-PROPERTIES))
       (NEW-SLOTSVALS (SIMPLE-COMPUTE-NEW-SLOTSVALS INSTANCE OLD-SLOTSVALS ADD-SLOTSVALS :INSTALL-INVERSESP INSTALL-INVERSESP)))
      (COND ((AND (CL-EQUAL OLD-SLOTSVALS NEW-SLOTSVALS)  (CNOT (NULL ADD-SLOTSVALS))))
       (T (COND (NEW-SLOTSVALS (CSETF (GET INSTANCE 'OWN-PROPERTIES) NEW-SLOTSVALS)))))
      (COND ((CNOT (GETHASH INSTANCE *KB-OBJECTS*)) (CSETF (GETHASH INSTANCE *KB-OBJECTS*) T))))
     INSTANCE)))))
(TRACE-LISP
 (DEFINE SIMPLE-COMPUTE-NEW-SLOTSVALS (INSTANCE OLD-SLOTSVALS ADD-SLOTSVALS &REST LKEYS)
  (trace-defun 'SIMPLE-COMPUTE-NEW-SLOTSVALS (INSTANCE OLD-SLOTSVALS ADD-SLOTSVALS LKEYS)
   (RET
    (CLET (INSTALL-INVERSESP) (init-keyval INSTALL-INVERSESP T)
     (COND
      ((NULL OLD-SLOTSVALS)
       (COND
        (INSTALL-INVERSESP
         (MAPC
          #'(LAMBDA (SLOTVALS) (trace-defun '#:G15879 (SLOTVALS) (RET (SIMPLE-ADD-INVERSES INSTANCE (SLOT-IN SLOTVALS) (VALS-IN SLOTVALS)))))
          ADD-SLOTSVALS)))
       ADD-SLOTSVALS)
      (T
       (CLET
        ((OLD-SLOTVALS (FIRST OLD-SLOTSVALS)) (SLOT (SLOT-IN OLD-SLOTVALS)) (OLD-VALS (VALS-IN OLD-SLOTVALS))
         (ADD-VALS (VALS-IN (ASSOC SLOT ADD-SLOTSVALS))) (EXTRA-VALS (CL-ORDERED-SET-DIFFERENCE ADD-VALS OLD-VALS :TEST #'CL-EQUAL))
         (NEW-VALS (APPEND OLD-VALS EXTRA-VALS)))
         (COND ((AND EXTRA-VALS INSTALL-INVERSESP) (SIMPLE-ADD-INVERSES INSTANCE SLOT EXTRA-VALS)))
        (CONS (MAKE-SLOTVALS SLOT NEW-VALS)
         (SIMPLE-COMPUTE-NEW-SLOTSVALS INSTANCE (REST OLD-SLOTSVALS) (REMOVE-IF #'(LAMBDA (SV) (EQ (CAR SV) SLOT)) ADD-SLOTSVALS) :INSTALL-INVERSESP
          INSTALL-INVERSESP))))))))))
;;;; [1] New - install inverses too
(TRACE-LISP
 (DEFINE SIMPLE-ADD-INVERSES (INSTANCE SLOT EXTRA-VALS)
  (trace-defun 'SIMPLE-ADD-INVERSES (INSTANCE SLOT EXTRA-VALS)
   (RET
    (CLET ((INV-SLOT (INVERT-SLOT SLOT)))
     (MAPC
      #'(LAMBDA (EXTRA-VAL)
         (trace-defun '#:G15880 (EXTRA-VAL)
          (RET
           (COND
            ((KB-OBJECTP EXTRA-VAL)
             (CLET ((OLD-INVVALS (GET-VALS EXTRA-VAL INV-SLOT)))
              (COND
               ((CNOT (CL-MEMBER INSTANCE OLD-INVVALS))
                (CLET ((OLD-INVSLOTSVALS (GET EXTRA-VAL 'OWN-PROPERTIES)))   
                 (COND ((CNOT (GETHASH EXTRA-VAL *KB-OBJECTS*)) (CSETF (GETHASH EXTRA-VAL *KB-OBJECTS*) T)))
                 (CSETF (GET EXTRA-VAL 'OWN-PROPERTIES)
                  (UPDATE-ASSOC-LIST OLD-INVSLOTSVALS (MAKE-SLOTVALS INV-SLOT (CONS INSTANCE OLD-INVVALS)))))))))))))
      EXTRA-VALS))))))
;;;; ======================================================================
;;;;		KM VERSION NUMBER CONTROL
;;;; ======================================================================
(TRACE-LISP
 (DEFINE REQUIRES-KM-VERSION (VERSION-NUMBER-STR)
  (trace-defun 'REQUIRES-KM-VERSION (VERSION-NUMBER-STR)
   (RET
    (COND
     ((KM-VERSION-GREATER-THAN VERSION-NUMBER-STR *KM-VERSION-STR*) (FORMAT T "~%Sorry! This KB requires KM version ~a or later.~%" VERSION-NUMBER-STR)
      (FORMAT T "Please download the latest KM from the KM Web page at:~%") (FORMAT T "     http://www.cs.utexas.edu/users/mfkb/km/~%~%") (ABORT))
     (T '(|t|)))))))
;;;; (km-version-greater-than "1.4.1.2" "1.4.1") -> t
(TRACE-LISP
 (DEFINE KM-VERSION-GREATER-THAN (V1 V2)
  (trace-defun 'KM-VERSION-GREATER-THAN (V1 V2)
   (RET
    (COND
     ((CNOT (STRINGP V1)) (REPORT-ERROR 'USER-ERROR "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" V1))
     ((CNOT (STRINGP V2)) (REPORT-ERROR 'USER-ERROR "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" V2))
     (T
      (CLET ((V1-BITS (MAPCAR #'READ-FROM-STRING (BREAK-UP V1 '(#\.)))) (V2-BITS (MAPCAR #'READ-FROM-STRING (BREAK-UP V2 '(#\.)))))
       (COND
        ((NOTEVERY #'INTEGERP V1-BITS)
         (REPORT-ERROR 'USER-ERROR "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" V1))
        ((NOTEVERY #'INTEGERP V2-BITS)
         (REPORT-ERROR 'USER-ERROR "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" V2))
        (T (KM-VERSION-BITS-GREATER-THAN V1-BITS V2-BITS))))))))))
;;;; (km-version-bits-greater-than '(1 3 1) '(1 2 1 2)) -> t
;;;; (km-version-bits-greater-than '(1 3 1) '(1 3)) -> t
;;;; (km-version-bits-greater-than '(1 3) '(1 3)) -> NIL
;;;; (km-version-bits-greater-than '(1 3 1) '(1 4)) -> NIL
(TRACE-LISP
 (DEFINE KM-VERSION-BITS-GREATER-THAN (V1-BITS V2-BITS)
  (trace-defun 'KM-VERSION-BITS-GREATER-THAN (V1-BITS V2-BITS)
   (RET
    (COND ((CL-EQUAL V1-BITS V2-BITS) NIL)  ((NULL V2-BITS)) ((AND V1-BITS (> (FIRST V1-BITS) (FIRST V2-BITS))))
     ((AND V1-BITS (= (FIRST V1-BITS) (FIRST V2-BITS))) (KM-VERSION-BITS-GREATER-THAN (REST V1-BITS) (REST V2-BITS))))))))
;;;; ======================================================================
;;;;	NEW: load files authored using the triple notation
;;;; ======================================================================
;;;; e.g., (load-triples "physics1.triples")
(TRACE-LISP
 (DEFINE LOAD-TRIPLES (FILE)
  (trace-defun 'LOAD-TRIPLES (FILE)
   (RET
    (TRACE-PROGN (FORMAT T "Loading ~a...~%" FILE)
     (COND ((LOAD-TRIPLES0 (READ-FILE FILE 'CASE-SENSITIVE-SEXPR)) (FORMAT T "~a loaded!~%" FILE)) (T (FORMAT T "Loading of ~a aborted!~%" FILE))) T)))))
(TRACE-LISP
 (DEFINE LOAD-TRIPLES0 (TRIPLES)
  (trace-defun 'LOAD-TRIPLES0 (TRIPLES)
   (RET
    (CLET ((NON-TRIPLE (FIND-IF #'(LAMBDA (TRIPLE) (trace-defun '#:G15881 (TRIPLE) (RET (CNOT (TRIPLEP TRIPLE))))) TRIPLES)))
     (COND (NON-TRIPLE (REPORT-ERROR 'NODEBUGGER-ERROR "load-triples: Non-triple ~a encountered in file!~%" NON-TRIPLE))
      (T
       (CLET ((INSTANCES (CL-REMOVE-DUPLICATES (MAPCAR #'FIRST TRIPLES))))
        (MAPC
         #'(LAMBDA (INSTANCE)
            (trace-defun '#:G15882 (INSTANCE)
             (RET
              (CLET
               ((ITRIPLES (REMOVE-IF-NOT #'(LAMBDA (TRIPLE) (trace-defun '#:G15883 (TRIPLE) (RET (EQ (FIRST TRIPLE) INSTANCE)))) TRIPLES))
                (SLOTS (CL-REMOVE-DUPLICATES (MAPCAR #'SECOND ITRIPLES))))
               (MAPC
                #'(LAMBDA (SLOT)
                   (trace-defun '#:G15884 (SLOT)
                    (RET
                     (CLET
                      ((ISTRIPLES (REMOVE-IF-NOT #'(LAMBDA (TRIPLE) (trace-defun '#:G15885 (TRIPLE) (RET (EQ (SECOND TRIPLE) SLOT)))) ITRIPLES))
                       (VALUES (CL-REMOVE-DUPLICATES (MAPCAR #'THIRD ISTRIPLES))))
                      (COND ((KB-OBJECTP INSTANCE) (KM-UNIQUE `(,INSTANCE |has| (,SLOT ,VALUES)))) 
                       (T
                        (MAPCAR
                         #'(LAMBDA (VALUE)
                            (trace-defun '#:G15886 (VALUE)
                             (RET
                              (COND ((AND (KB-OBJECTP VALUE) (NEQ SLOT '|instance-of|)) (KM-UNIQUE `(,VALUE |has| (,(INVERT-SLOT SLOT) (,INSTANCE)))))
                               (T (REPORT-ERROR 'USER-WARNING "Unable to assert triple (~a ~a ~a)! Dropping it...~%" INSTANCE SLOT VALUE))))))
                         VALUES)))))))
                SLOTS)))))
         INSTANCES)
        T))))))))
;;;; FILE:  minimatch.lisp
;;;; File: minimatch.lisp
;;;; Author: Peter Clark
;;;; Date: August 1994
;;;; Purpose: Simplistic pattern-matching (see examples below)
;;;; The system matches items with variables, returning a list of the
;;;; matched items. All variables are anonymous.
;;;; Here where we know there's just ONE item
(TRACE-LISP (DEFINE MINIMATCH1 (ITEM PATTERN) (trace-defun 'MINIMATCH1 (ITEM PATTERN) (RET (FIRST (MINIMATCH ITEM PATTERN))))))
;;;; Mini-matching -- doesn't keep an explicit binding list, but just the
;;;; values which matched with variables, in order.
;;;; (minimatch 'x 'y) => nil
;;;; (minimatch '(a b c) '(a ?x ?y)) => (b c)
;;;; (minimatch '(a b c) '(a ?x ?x)) => (b c)
;;;; (minimatch '(a b) '(a b)) => t
;;;; (minimatch '(a b c (d e)) '(a b ?x (?y ?z))) => (c d e)
;;;; (minimatch '(a b c (d e)) '(a b ?x ?y)) => (c (d e))
;;;; (minimatch '(a b c (d e)) '(a b &rest) => ((c (d e)))
(TRACE-LISP (DEFINE MV-MINIMATCH (ITEM PATTERN) (trace-defun 'MV-MINIMATCH (ITEM PATTERN) (RET (VALUES-LIST (MINIMATCH ITEM PATTERN))))))
(TRACE-LISP (DEFINE ANONYMOUS-MINIMATCH-VARP (VAR) (trace-defun 'ANONYMOUS-MINIMATCH-VARP (VAR) (RET (CL-MEMBER VAR '(?ANY |?any| ?*))))))
(TRACE-LISP (DEFINE WILDCARD-VARP (VAR) (trace-defun 'WILDCARD-VARP (VAR) (RET (EQ VAR '?*)))))
;;;; Must distinguish failure (nil) and no bindings (t)
;;;; Mar'04 - use of wildcard variable ?*
;;;; CL-USER(28): (minimatch '(1 2 3 4 5 6 7 8) '(?* 3 ?x ?* 6 ?y ?z ?*))
;;;; (4 7 8)
(TRACE-LISP
 (DEFINE MINIMATCH (ITEM PATTERN)
  (trace-defun 'MINIMATCH (ITEM PATTERN)
   (RET
    (COND ((ANONYMOUS-MINIMATCH-VARP PATTERN) 'T) ((VARP PATTERN) (LIST ITEM)) ((CL-MEMBER PATTERN '((&REST) (|&rest|)) :TEST #'CL-EQUAL) (LIST ITEM))
     ((ATOM PATTERN) (COND ((CL-EQUAL ITEM PATTERN) 'T)))
     ((LISTP ITEM)
      (COND
       ((WILDCARD-VARP (FIRST PATTERN)) 
        (OR (MINIMATCH ITEM (REST PATTERN))  (AND ITEM (MINIMATCH (REST ITEM) (REST PATTERN)))  (AND ITEM (MINIMATCH (REST ITEM) PATTERN))))
       
       (ITEM
        (CLET ((CARMATCH (MINIMATCH (CAR ITEM) (CAR PATTERN)))) (COND (CARMATCH (JOIN-BINDS CARMATCH (MINIMATCH (CDR ITEM) (CDR PATTERN))))))))))))))
(TRACE-LISP
 (DEFINE JOIN-BINDS (BINDS1 BINDS2)
  (trace-defun 'JOIN-BINDS (BINDS1 BINDS2)
   (RET (COND ((NULL BINDS1) NIL) ((NULL BINDS2) NIL) ((CL-EQUAL BINDS1 'T) BINDS2) ((CL-EQUAL BINDS2 'T) BINDS1) (T (APPEND BINDS1 BINDS2)))))))
;;;; Modified faster version thanks to Adam Farquhar!
(TRACE-LISP (DEFINE VARP (VAR) (trace-defun 'VARP (VAR) (RET (AND (SYMBOLP VAR) (SYMBOL-STARTS-WITH VAR #\?))))))
(TRACE-LISP
 (DEFINE FIND-PATTERN (LIST PATTERN)
  (trace-defun 'FIND-PATTERN (LIST PATTERN)
   (RET (COND ((ENDP LIST) NIL) ((MINIMATCH (FIRST LIST) PATTERN)) (T (FIND-PATTERN (REST LIST) PATTERN)))))))
;;;; ======================================================================
;;;;	USE OF THE MINIMATCHER TO SELECT A LAMBDA EXPRESSION
;;;; ======================================================================
#|find-handler -- finds a (pattern function) pair where pattern matches the input
expr, and returns a LIST of THREE things:
  - function 
  - a list of values in expr which matched the variables in pattern
  - the entire pattern which the input expr matched

e.g., 
(find-handler '(the house of john) *km-handler-alist*) =>
    (X'(lambda (slot path) (getval slot path)) 
     (house john)
     (the ?slot of ?expr))|#
(TRACE-LISP
 (DEFINE FIND-HANDLER (EXPR HANDLER-ALIST &REST LKEYS)
  (trace-defun 'FIND-HANDLER (EXPR HANDLER-ALIST LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (COND ((ENDP HANDLER-ALIST) (COND ((EQ FAIL-MODE 'ERROR) (FORMAT T "ERROR! Can't find handler for expression ~a!~%" EXPR) NIL)))
      (T
       (CLET
        ((PATTERN+HANDLER (FIRST HANDLER-ALIST)) (PATTERN (FIRST PATTERN+HANDLER)) (HANDLER (SECOND PATTERN+HANDLER))
         (BINDINGS (MINIMATCH EXPR PATTERN)))
        (COND ((EQ BINDINGS 'T) (LIST HANDLER NIL PATTERN)) (BINDINGS (LIST HANDLER BINDINGS PATTERN))
         (T (FIND-HANDLER EXPR (REST HANDLER-ALIST) :FAIL-MODE FAIL-MODE)))))))))))
;;;; Default method of applying
;;;; Or could apply with extra args, eg.
;;;; 	(apply (first handler) (cons depth (second handler)))
(TRACE-LISP (DEFINE APPLY-HANDLER (HANDLER) (trace-defun 'APPLY-HANDLER (HANDLER) (RET (APPLY (FIRST HANDLER) (SECOND HANDLER))))))
(TRACE-LISP
 (DEFINE FIND-AND-APPLY-HANDLER (EXPR HANDLER-ALIST &REST LKEYS)
  (trace-defun 'FIND-AND-APPLY-HANDLER (EXPR HANDLER-ALIST LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (CLET ((HANDLER (FIND-HANDLER EXPR HANDLER-ALIST :FAIL-MODE FAIL-MODE))) (COND (HANDLER (APPLY-HANDLER HANDLER)))))))))
;;;; ======================================================================
;;;;		SAME, EXCEPT FOR STRINGS
;;;; ======================================================================
(TRACE-LISP
 (DEFINE MV-STRING-MATCH (STRING PATTERN) (trace-defun 'MV-STRING-MATCH (STRING PATTERN) (RET (VALUES-LIST (STRING-MATCH STRING PATTERN))))))
;;;; (string-match "the cat sat" '("the" ?cat "sat")) --> (" cat ")
;;;; (string-match "the cat sat" '(?var "the" ?cat "sat")) --> ("" " cat ")
(TRACE-LISP
 (DEFINE STRING-MATCH (STRING PATTERN)
  (trace-defun 'STRING-MATCH (STRING PATTERN)
   (RET
    (CLET ((PATTERN-EL (FIRST PATTERN)))
     (COND ((AND (NULL PATTERN) (STRING= STRING "")) 'T) ((CL-MEMBER PATTERN '((&REST) (|&rest|)) :TEST #'CL-EQUAL) (LIST STRING))
      ((STRINGP PATTERN-EL)
       (COND
        ((AND (>= (LENGTH STRING) (LENGTH PATTERN-EL)) (STRING= STRING PATTERN-EL :END1 (LENGTH PATTERN-EL)))
         (STRING-MATCH (SUBSEQ STRING (LENGTH PATTERN-EL)) (CDR PATTERN)))))
      ((AND (VARP PATTERN-EL) (SINGLETONP PATTERN)) (LIST STRING))
      ((AND (VARP PATTERN-EL) (STRINGP (SECOND PATTERN)))
       (CLET ((END-STRING-POSN (SEARCH (SECOND PATTERN) STRING)))
        (COND
         (END-STRING-POSN
          (CONS-BINDING (SUBSEQ STRING 0 END-STRING-POSN)
           (STRING-MATCH (SUBSEQ STRING (+ END-STRING-POSN (LENGTH (SECOND PATTERN)))) (CDDR PATTERN)))))))
      (T (FORMAT T "ERROR! (string-match ~s ~s) bad syntax!~%" STRING PATTERN) NIL)))))))
;;;; binding or bindings = nil imply match-failure
(TRACE-LISP
 (DEFINE CONS-BINDING (BINDING BINDINGS)
  (trace-defun 'CONS-BINDING (BINDING BINDINGS)
   (RET (COND ((NULL BINDINGS) NIL) ((NULL BINDING) NIL) ((CL-EQUAL BINDINGS 'T) (LIST BINDING)) (T (CONS BINDING BINDINGS)))))))
;;;; FILE:  utils.lisp
;;;; File: utils.lisp
;;;; Author: Peter Clark
;;;; Date: 1994
;;;; Purpose: General Lisp utilities
;;;; (flatten '((a b) (c (d e))))  ->  (a b c d e)
;;;; (flatten 'a) -> (a)
(TRACE-LISP
 (DEFINE CL-FLATTEN (LIST)
  (trace-defun 'CL-FLATTEN (LIST)
   (RET (COND ((NULL LIST) NIL) ((ATOM LIST) (LIST LIST)) ((ACONSP LIST) (LIST (FIRST LIST) (REST LIST)))  (T (MY-MAPCAN #'CL-FLATTEN LIST)))))))
;;;; ----------
(TRACE-LISP (DEFINE LISTIFY (ATOM) (trace-defun 'LISTIFY (ATOM) (RET (COND ((LISTP ATOM) ATOM) (T (LIST ATOM)))))))
;;;; (append-list '((1 2) (3 4))) => (1 2 3 4)
(TRACE-LISP (DEFINE APPEND-LIST (LIST) (trace-defun 'APPEND-LIST (LIST) (RET (APPLY #'APPEND LIST)))))
;;;; ----------------------------------------
#| (my-split-if '(1 2 3 4) X'evenp) => ((2 4) (1 3))
;;; (mapcar X'append-list (transpose (mapcar X'(lambda (seq) (my-split-if seq X'evenp)) '((1 2 3 4) (5 6 7 8) ...))))
;;; [PEC: ?? but why not just do (my-split-if (append '((1 2 3 4) (5 6 7 8) ...)) X'evenp) ?
;;; ((2 4 6 8) (1 3 5 7))
(defun my-split-if (sequence function)
  (cond ((endp sequence) nil)
	(t (let ( (pass+fail (my-split-if (rest sequence) function)) )
	     (cond ((funcall function (first sequence))
		    (list (cons (first sequence) (first pass+fail)) (second pass+fail)))
		   (t (list (first pass+fail) (cons (first sequence) (second pass+fail)))))))))|#
;;;; Rewrite and rename. This time, returns multiple values (i) those passing the text (ii) those failing
;;;; (partition '(1 2 3 4) ;'evenp) => (2 4) (1 3)
;;;; ((2 4 6 8) (1 3 5 7))
(TRACE-LISP
 (DEFINE PARTITION (SEQUENCE FUNCTION)
  (trace-defun 'PARTITION (SEQUENCE FUNCTION)
   (RET
    (COND ((ENDP SEQUENCE) NIL)
     (T
      (MULTIPLE-VALUE-BIND (PASS FAIL) (PARTITION (REST SEQUENCE) FUNCTION)
       (COND ((FUNCALL FUNCTION (FIRST SEQUENCE)) (VALUES (CONS (FIRST SEQUENCE) PASS) FAIL)) (T (VALUES PASS (CONS (FIRST SEQUENCE) FAIL)))))))))))
;;;; ======================================================================
;;;;			SOME *-EQUAL FUNCTIONS
;;;; ======================================================================
;;;; unlike assoc, item can be a structure
;;;; > (assoc-equal '(a b) '(((a b) c) (d e)))
(TRACE-LISP
 (DEFINE CL-ASSOC-EQUAL (ITEM ALIST)
  (trace-defun 'CL-ASSOC-EQUAL (ITEM ALIST)
   (RET (COND ((ENDP ALIST) NIL) ((CL-EQUAL ITEM (FIRST (FIRST ALIST))) (FIRST ALIST)) (T (CL-ASSOC-EQUAL ITEM (REST ALIST))))))))
(TRACE-LISP
 (DEFINE MEMBER-EQUAL (ITEM LIST)
  (trace-defun 'MEMBER-EQUAL (ITEM LIST)
   (RET (COND ((ENDP LIST) NIL) ((CL-EQUAL ITEM (FIRST LIST)) LIST) (T (MEMBER-EQUAL ITEM (REST LIST))))))))
;;;; ======================================================================
;;;;		MAPPING FUNCTIONS
;;;; ======================================================================
;;;; my-mapcan: non-destructive version of mapcan
(TRACE-LISP (DEFINE MY-MAPCAN #'ARGS (trace-defun 'MY-MAPCAN #'ARGS (RET (APPLY #'APPEND (MAPCAR FUNCTION ARGS))))))
;;; eg. (map-recursive ;'string-upcase '("as" ("asd" ("df" "df") "ff")))
;;;     ("AS" ("ASD" ("DF" "DF") "FF"))
(TRACE-LISP
 (DEFINE MAP-RECURSIVE #'TREE
  (trace-defun 'MAP-RECURSIVE #'TREE
   (RET
    (COND ((NULL TREE) NIL) ((CNOT (LISTP TREE)) (FUNCALL FUNCTION TREE))
     (T (CONS (MAP-RECURSIVE FUNCTION (CAR TREE)) (MAP-RECURSIVE FUNCTION (CDR TREE)))))))))
;;;; (recursive-find 'a '(1 2 (c 3) (a)))
(TRACE-LISP
 (DEFINE RECURSIVE-FIND (ITEM TREE)
  (trace-defun 'RECURSIVE-FIND (ITEM TREE)
   (RET
    (COND ((EQ ITEM TREE)) ((NULL TREE) NIL)
     ((LISTP TREE) (SOME #'(LAMBDA (SUBTREE) (trace-defun '#:G15887 (SUBTREE) (RET (RECURSIVE-FIND ITEM SUBTREE)))) TREE)))))))
;;;; ----------------------------------------
#|KM> (defun demo (x) (cond ((> x 0) (values x (* x x)))))
KM> (some X'demo '(-1 3 2))
3
KM> (multiple-value-some X'demo '(-1 3 2))
3
9|#
;;;; This just written for two-valued arguments
(TRACE-LISP
 (DEFINE MULTIPLE-VALUE-SOME (FN ARG-LIST)
  (trace-defun 'MULTIPLE-VALUE-SOME (FN ARG-LIST)
   (RET
    (COND ((ENDP ARG-LIST) NIL)
     (T (MULTIPLE-VALUE-BIND (X Y) (APPLY FN (LIST (FIRST ARG-LIST))) (COND (X (VALUES X Y)) (T (MULTIPLE-VALUE-SOME FN (REST ARG-LIST)))))))))))
;;;; ======================================================================
;;;;		GENERAL UTILITIES
;;;; ======================================================================
(TRACE-LISP (DEFVAR *TELL-STREAM* T))
(TRACE-LISP (DEFVAR *SEE-STREAM* T))
(TRACE-LISP (DEFVAR *APPEND-STREAM* T))
(TRACE-LISP (DEFINE FILE-EXISTS (FILE) (trace-defun 'FILE-EXISTS (FILE) (RET (OPEN FILE :DIRECTION :PROBE)))))
;;;; Check you don't close the stream "t"
(TRACE-LISP (DEFINE CLOSE-STREAM (STREAM) (trace-defun 'CLOSE-STREAM (STREAM) (RET (COND ((STREAMP STREAM) (CLOSE STREAM)))))))
;;;; (see) and (tell) open files with my standard default modes.
;;;; They also cache the stream, just in case an error occurs during
;;;; interpretation (otherwise you've lost the handle on the stream).
;;;; t will send to std output, nil will output to nothing.
(TRACE-LISP
 (DEFINE TELL (FILE)
  (trace-defun 'TELL (FILE)
   (RET
    (COND ((NULL FILE) NIL) ((EQ FILE T) (FORMAT T "(Sending output to standard output)~%") T)
     (T (CSETQ *TELL-STREAM* (OPEN FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))))))
(TRACE-LISP (DEFINE TOLD NIL (trace-defun 'TOLD NIL (RET (TRACE-PROGN (CLOSE-STREAM *TELL-STREAM*) (CSETQ *TELL-STREAM* T))))))
(TRACE-LISP (DEFINE SEE (FILE) (trace-defun 'SEE (FILE) (RET (COND ((EQ FILE T) T)  (T (CSETQ *SEE-STREAM* (OPEN FILE :DIRECTION :INPUT))))))))
(TRACE-LISP (DEFINE SEEN NIL (trace-defun 'SEEN NIL (RET (TRACE-PROGN (CLOSE-STREAM *SEE-STREAM*) (CSETQ *SEE-STREAM* T))))))
(TRACE-LISP
 (DEFINE TELL-APPEND (FILE)
  (trace-defun 'TELL-APPEND (FILE)
   (RET
    (COND ((NULL FILE) NIL) ((EQ FILE T) (FORMAT T "(Sending output to standard output)~%") T)
     (T (CSETQ *APPEND-STREAM* (OPEN FILE :DIRECTION :OUTPUT :IF-EXISTS :APPEND :IF-DOES-NOT-EXIST :CREATE))))))))
(TRACE-LISP
 (DEFINE TOLD-APPEND NIL (trace-defun 'TOLD-APPEND NIL (RET (TRACE-PROGN (CLOSE-STREAM *APPEND-STREAM*) (CSETQ *APPEND-STREAM* T))))))
;;;; Useful for finding mis-matching parentheses
(TRACE-LISP
 (DEFINE READ-AND-PRINT (FILE) (trace-defun 'READ-AND-PRINT (FILE) (RET (CLET ((STREAM (SEE FILE))) (READ-AND-PRINT2 STREAM) (CLOSE STREAM))))))
(TRACE-LISP
 (DEFINE READ-AND-PRINT2 (STREAM)
  (trace-defun 'READ-AND-PRINT2 (STREAM) (RET (CLET ((SEXPR (CL-READ STREAM NIL NIL))) (COND (SEXPR (PRINT SEXPR) (READ-AND-PRINT2 STREAM))))))))
;;;; Bug(?) in CL: (read-string <string> nil nil) should return nil if <string> is an incomplete s-expr (e.g. "\""cat")
;;;; but in practice generates an eof error regardless. (What I wanted to do was a read-string followed by integerp test).
(TRACE-LISP
 (DEFINE MY-PARSE-INTEGER (STRING)
  (trace-defun 'MY-PARSE-INTEGER (STRING)
   (RET
    (MULTIPLE-VALUE-BIND (INTEGER N-CHARS) (PARSE-INTEGER STRING :JUNK-ALLOWED T) (COND ((EQ (LENGTH (PRINC-TO-STRING INTEGER)) N-CHARS) INTEGER)))))))
;;;; ----------------------------------------
;;;; 	READ AN ENTIRE FILE INTO A LIST:
;;;; ----------------------------------------
;;;; Returns a list of strings
(TRACE-LISP
 (DEFINE READ-FILE (FILE &OPTIONAL TYPE)
  (trace-defun 'READ-FILE (FILE TYPE)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TYPE 'STRING)
     (COND ((CNOT (CL-MEMBER TYPE '(STRING SEXPR CASE-SENSITIVE-SEXPR))) (FORMAT T "ERROR! Unrecognized unit-type ~s in read-file!~%" TYPE))
      (T (READ-STREAM (SEE FILE) TYPE))))))))
(TRACE-LISP
 (DEFINE READ-STREAM (STREAM &OPTIONAL TYPE)
  (trace-defun 'READ-STREAM (STREAM TYPE)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TYPE 'STRING) (PROG1 (READ-LINES (READ-UNIT STREAM TYPE) STREAM TYPE) (COND ((STREAMP STREAM) (CLOSE STREAM)))))))))
(TRACE-LISP
 (DEFINE READ-LINES (LINE &OPTIONAL STREAM TYPE)
  (trace-defun 'READ-LINES (LINE STREAM TYPE)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TYPE 'STRING) (SUBLISP-INITVAR STREAM T)
     (COND ((NULL LINE) NIL) (T (CONS LINE (READ-LINES (READ-UNIT STREAM TYPE) STREAM TYPE)))))))))
(TRACE-LISP
 (DEFINE READ-UNIT (&OPTIONAL STREAM TYPE)
  (trace-defun 'READ-UNIT (STREAM TYPE)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR TYPE 'STRING) (SUBLISP-INITVAR STREAM T)
     (CASE TYPE (STRING (READ-LINE STREAM NIL NIL)) (SEXPR (CL-READ STREAM NIL NIL)) (CASE-SENSITIVE-SEXPR (CASE-SENSITIVE-READ STREAM NIL NIL))))))))
;; defined in case.lisp
;;;; ------------------------------
(TRACE-LISP
 (DEFINE WRITE-FILE (FILE LINES)
  (trace-defun 'WRITE-FILE (FILE LINES) (RET (CLET ((STREAM (TELL FILE))) (WRITE-LINES LINES STREAM) (CLOSE-STREAM STREAM))))))
#| Works, but apply-recursive can be *very* slow as it's interpreted
(defun write-lines (lines &optional (stream t))
  (apply-recursive X'(lambda (line)
		       (format stream "~a~%" line))
		   lines))|#
(TRACE-LISP
 (DEFINE WRITE-LINES (STRUCTURE &OPTIONAL STREAM)
  (trace-defun 'WRITE-LINES (STRUCTURE STREAM)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR STREAM T)
     (COND ((NULL STRUCTURE) NIL) ((ATOM STRUCTURE) (FORMAT STREAM "~a~%" STRUCTURE))
      ((AND (LISTP STRUCTURE) (NULL (FIRST STRUCTURE))) (WRITE-LINES (REST STRUCTURE) STREAM))
      ((LISTP STRUCTURE) (CONS (WRITE-LINES (FIRST STRUCTURE) STREAM) (WRITE-LINES (REST STRUCTURE) STREAM)))
      (T (FORMAT T "ERROR! Don't know how to do write-lines on structure:~%") (FORMAT T "ERROR! ~s~%" STRUCTURE))))))))
;;(defun write-lines (lines &optional (stream t))
;;  (cond
;;   ((null lines))
;;   ((atom lines) (format stream "~a~%" lines))
;;   ((listp lines)
;;    (write-lines (car lines) stream)
;;    (write-lines (cdr lines) stream))
;;   (t (format t "ERROR! Don't know how to do write-lines on structure:~%")
;;      (format t "ERROR! ~s~%" lines))))
;; ----------
(TRACE-LISP
 (DEFINE APPLY-RECURSIVE #'STRUCTURE
  (trace-defun 'APPLY-RECURSIVE #'STRUCTURE
   (RET
    (COND ((NULL STRUCTURE) NIL) ((ATOM STRUCTURE) (FUNCALL FUNCTION STRUCTURE))
     ((LISTP STRUCTURE) (CONS (APPLY-RECURSIVE FUNCTION (FIRST STRUCTURE)) (APPLY-RECURSIVE FUNCTION (REST STRUCTURE))))
     (T (FORMAT T "ERROR! Don't know how to apply-recursive on structure:~%") (FORMAT T "ERROR! ~s~%" STRUCTURE)))))))
;;;; ======================================================================
(TRACE-LISP (DEFINE PRINT-LIST (LIST) (trace-defun 'PRINT-LIST (LIST) (RET (TRACE-PROGN (MAPCAR #'PRINT LIST) T)))))
;;;; Below command means DON'T define neq in Mac CommonLisp (as it's a built-in)
;;;; but it is NOT defined in openmcl
;;;; ;-(and MCL (not openmcl))
;;;; REVISED: NEQ is now apparently defined in openmcl, so change the defn.
(TRACE-LISP (DEFINE NEQ (A B) (trace-defun 'NEQ (A B) (RET (CNOT (EQ A B))))))
;;;; (nlist 3) --> (1 2 3)
(TRACE-LISP
 (DEFINE NLIST (NMAX &OPTIONAL N)
  (trace-defun 'NLIST (NMAX N)
   (RET (TRACE-PROGN (SUBLISP-INITVAR N 1) (COND ((<= NMAX 0) NIL) ((>= N NMAX) (LIST N)) (T (CONS N (NLIST NMAX (1+ N))))))))))
;;;; (duplicate 'hi 2) ==> (hi hi)
(TRACE-LISP (DEFINE DUPLICATE (ITEM LENGTH) (trace-defun 'DUPLICATE (ITEM LENGTH) (RET (MAKE-SEQUENCE 'LIST LENGTH :INITIAL-ELEMENT ITEM)))))
;; Better: use ~vT directive in format
;; BUT!! Bug under Harlequin - column counter doesn't get reset by a <nl> from
;; user (as a result of a read-line or read).
(TRACE-LISP (DEFINE SPACES (N) (trace-defun 'SPACES (N) (RET (MAKE-SEQUENCE 'STRING N :INITIAL-ELEMENT #\Space)))))
;;
;; (defun tab (n &optional (stream t))
;;    (cond ((<= n 0) t)
;;          ( t (format stream " ") (tab (- n 1) stream))))
;;;; ======================================================================
(TRACE-LISP
 (DEFINE TRANSPOSE (LIST)
  (trace-defun 'TRANSPOSE (LIST) (RET (COND ((EVERY #'NULL LIST) NIL) (T (CONS (MAPCAR #'FIRST LIST) (TRANSPOSE (MAPCAR #'REST LIST)))))))))
;;;; (atranspose '((a b c) (c d e)))
;;;; ((A . C) (B . D) (C . E))
;;;; NOTE: must have at most two input lists (extra lists are ignored)
(TRACE-LISP
 (DEFINE ATRANSPOSE (LIST)
  (trace-defun 'ATRANSPOSE (LIST)
   (RET (COND ((EVERY #'NULL LIST) NIL) (T (CONS (CONS (FIRST (FIRST LIST)) (FIRST (SECOND LIST))) (ATRANSPOSE (MAPCAR #'REST LIST)))))))))
;;;; ======================================================================
;;;; 22nd Aug: had to rewrite this. Checking the cadr is non-null doesn't
;;;; reliably test there's a second element (eg. if the 2nd el is nil).
(TRACE-LISP (DEFINE SINGLETONP (LIST) (trace-defun 'SINGLETONP (LIST) (RET (AND (LISTP LIST) (EQ (LENGTH LIST) 1))))))
(TRACE-LISP (DEFINE PAIRP (LIST) (trace-defun 'PAIRP (LIST) (RET (AND (LISTP LIST) (EQ (LENGTH LIST) 2))))))
;; triple has different repn in KM, namely with a :triple prefix
(TRACE-LISP (DEFINE TRIPLEP (LIST) (trace-defun 'TRIPLEP (LIST) (RET (AND (LISTP LIST) (EQ (LENGTH LIST) 3))))))
;;;; ======================================================================
;;;; (a) -> a
(TRACE-LISP (DEFINE DELISTIFY (LIST) (trace-defun 'DELISTIFY (LIST) (RET (COND ((SINGLETONP LIST) (CAR LIST)) (T LIST))))))
(TRACE-LISP (DEFINE LAST-EL (LIST) (trace-defun 'LAST-EL (LIST) (RET (CAR (LAST LIST))))))
(TRACE-LISP (DEFINE LAST-BUT-ONE-EL (LIST) (trace-defun 'LAST-BUT-ONE-EL (LIST) (RET (CAR (LAST (BUTLAST LIST)))))))
;;;; (aconsp '(a . b)) -> t
(TRACE-LISP (DEFINE ACONSP (OBJ) (trace-defun 'ACONSP (OBJ) (RET (AND (LISTP OBJ) (CNOT (LISTP (REST OBJ))))))))
;;;; ======================================================================
;;;; (quotep ''hi) --> t
(TRACE-LISP (DEFINE QUOTEP (EXPR) (trace-defun 'QUOTEP (EXPR) (RET (COND ((AND (LISTP EXPR) (EQ (LENGTH EXPR) 2) (EQ (CAR EXPR) 'QUOTE))))))))
;;;; ======================================================================
;;;; Preserve order of list
;;;; (The basic Lisp function is set-difference)
(TRACE-LISP
 (DEFINE CL-ORDERED-SET-DIFFERENCE (LIST SET &REST LKEYS)
  (trace-defun 'CL-ORDERED-SET-DIFFERENCE (LIST SET LKEYS)
   (RET (CLET (TEST) (init-keyval TEST #'EQ) (REMOVE-IF #'(LAMBDA (EL) (trace-defun '#:G15888 (EL) (RET (CL-MEMBER EL SET :TEST TEST)))) LIST))))))
;;;; Preserve order of first list
(TRACE-LISP
 (DEFINE CL-ORDERED-INTERSECTION (LIST SET &REST LKEYS)
  (trace-defun 'CL-ORDERED-INTERSECTION (LIST SET LKEYS)
   (RET
    (CLET (TEST) (init-keyval TEST #'EQ) (REMOVE-IF-NOT #'(LAMBDA (EL) (trace-defun '#:G15889 (EL) (RET (CL-MEMBER EL SET :TEST TEST)))) LIST))))))
;;;; Returns the first elememt of set1 which is in set2, or nil otherwise.
(TRACE-LISP
 (DEFINE INTERSECTS (SET1 SET2)
  (trace-defun 'INTERSECTS (SET1 SET2)
   (RET (FIRST (SOME #'(LAMBDA (EL) (trace-defun '#:G15890 (EL) (RET (CL-MEMBER EL SET2)))) SET1))))))
;;;; (nreplace '(a b c d e) 2 'new)  -> (a b new d e)
(TRACE-LISP
 (DEFINE NREPLACE (LIST N NEW)
  (trace-defun 'NREPLACE (LIST N NEW)
   (RET (COND ((ENDP LIST) NIL) ((EQ N 0) (CONS NEW (REST LIST))) (T (CONS (FIRST LIST) (NREPLACE (REST LIST) (1- N) NEW))))))))
;;;; ======================================================================
;;;;		DICTIONARY FUNCTIONS
;;;; ======================================================================
;;;; Inefficient but non-destructive!
;;;; KM> (gather-by-key '((a 1) (b 2) (a 3) (b 4)))
;;;; ((b (4 2)) (a (3 1)))
;;;; KM> (gather-by-key '((a 1) (b 2) (a 3) (b 4) (c) (b)))
;;;; ((b (4 2)) (a (3 1))
(TRACE-LISP
 (DEFINE GATHER-BY-KEY (PAIRS &OPTIONAL DICT)
  (trace-defun 'GATHER-BY-KEY (PAIRS DICT)
   (RET
    (COND ((ENDP PAIRS) DICT)
     (T
      (CLET ((PAIR (FIRST PAIRS)) (KEY (FIRST PAIR)) (VAL (SECOND PAIR)))
       (COND
        (VAL
         (CLET
          ((VALS (FIRST (REST (ASSOC KEY DICT :TEST #'CL-EQUAL))))
           (RESTDICT (REMOVE-IF #'(LAMBDA (PAIR) (trace-defun '#:G15891 (PAIR) (RET (CL-EQUAL (FIRST PAIR) KEY)))) DICT)))
          (GATHER-BY-KEY (REST PAIRS) (CONS (LIST KEY (CONS VAL VALS)) RESTDICT))))
        (T (GATHER-BY-KEY (REST PAIRS) DICT))))))))))
;;;; Inefficient but non-destructive!
;;;; KM> (gather-by-akey '((a . 1) (b . 2) (a . 3) (b . 4)))
;;;; ((b . (4 2)) (a . (3 1)))
(TRACE-LISP
 (DEFINE GATHER-BY-AKEY (PAIRS &OPTIONAL DICT)
  (trace-defun 'GATHER-BY-AKEY (PAIRS DICT)
   (RET
    (COND ((ENDP PAIRS) DICT)
     (T
      (CLET ((PAIR (FIRST PAIRS)) (KEY (FIRST PAIR)) (VAL (REST PAIR)))
       (COND
        (VAL
         (CLET
          ((VALS (REST (ASSOC KEY DICT :TEST #'CL-EQUAL)))
           (RESTDICT (REMOVE-IF #'(LAMBDA (PAIR) (trace-defun '#:G15892 (PAIR) (RET (CL-EQUAL (FIRST PAIR) KEY)))) DICT)))
          (GATHER-BY-AKEY (REST PAIRS) (CONS (CONS KEY (CONS VAL VALS)) RESTDICT))))
        (T (GATHER-BY-AKEY (REST PAIRS) DICT))))))))))
;;;; ----------
;;;; Inefficient but non-destructive!
;;;; [1c] USER(31): (gathers-by-key '((a 1 2) (b 3 4) (a 5 6)))
;;;; ((a ((5 6) (1 2))) (b ((3 4))))
(TRACE-LISP
 (DEFINE GATHERS-BY-KEY (TUPLES &OPTIONAL DICT)
  (trace-defun 'GATHERS-BY-KEY (TUPLES DICT)
   (RET
    (COND ((ENDP TUPLES) DICT)
     (T
      (CLET
       ((TUPLE (FIRST TUPLES)) (KEY (FIRST TUPLE)) (VAL (REST TUPLE)) (VALS (FIRST (REST (ASSOC KEY DICT :TEST #'CL-EQUAL))))
        (RESTDICT (REMOVE-IF #'(LAMBDA (TUPLE) (trace-defun '#:G15893 (TUPLE) (RET (CL-EQUAL (FIRST TUPLE) KEY)))) DICT)))
       (COND (VAL (GATHERS-BY-KEY (REST TUPLES) (CONS (LIST KEY (CONS VAL VALS)) RESTDICT)))
        (T (GATHERS-BY-KEY (REST TUPLES) (CONS (LIST KEY VALS) RESTDICT)))))))))))
;;;; (ordered-gather-by-key '((a 1) (a 2) (b 3) (b 4) (c 5) (a 6) (a 7) (d 8)))
;;;;	-> ((a (1 2)) (b (3 4)) (c (5)) (a (6 7)) (d (8)))
;;;; NOTE duplicate (a ...) entries, if (a ...) entries aren't consecutive
(TRACE-LISP
 (DEFINE ORDERED-GATHER-BY-KEY (PAIRS)
  (trace-defun 'ORDERED-GATHER-BY-KEY (PAIRS)
   (RET
    (COND ((ENDP PAIRS) NIL)
     (T
      (CLET ((PAIR (FIRST PAIRS)))
       (COND
        ((CL-EQUAL (FIRST PAIR) (FIRST (SECOND PAIRS)))
         (CLET ((GATHERED-REST (ORDERED-GATHER-BY-KEY (REST PAIRS))) (NEXT-GATHERED-PAIR (FIRST GATHERED-REST)))
          (CONS (LIST (FIRST NEXT-GATHERED-PAIR)  (CONS (SECOND PAIR) (SECOND NEXT-GATHERED-PAIR))) (REST GATHERED-REST))))
        (T (CONS (LIST (FIRST PAIR) (REST PAIR))  (ORDERED-GATHER-BY-KEY (REST PAIRS))))))))))))
;;;; Takes an *ordered* list of items, and counts occurences of each one.
;;;; (ordered-count '("a" "a" "b" "c")) -> (("a" 2) ("b" 1) ("c" 1))
(TRACE-LISP
 (DEFINE ORDERED-COUNT (LIST &OPTIONAL COUNTS-SO-FAR)
  (trace-defun 'ORDERED-COUNT (LIST COUNTS-SO-FAR)
   (RET
    (COND ((ENDP LIST) (REVERSE COUNTS-SO-FAR))
     ((CL-EQUAL (FIRST LIST) (FIRST (FIRST COUNTS-SO-FAR)))
      (ORDERED-COUNT (REST LIST) (CONS (LIST (FIRST LIST) (1+ (SECOND (FIRST COUNTS-SO-FAR)))) (REST COUNTS-SO-FAR))))
     (T (ORDERED-COUNT (REST LIST) (CONS (LIST (FIRST LIST) 1) COUNTS-SO-FAR))))))))
;;;; ----------
(TRACE-LISP (DEFINE NUMBER-EQ (N1 N2) (trace-defun 'NUMBER-EQ (N1 N2) (RET (AND (NUMBERP N1) (NUMBERP N2) (< (ABS (- N1 N2)) 1.0E-24))))))
;;;; handle rounding errors
;;;; NOTE: Now should use zerop, with a numberp check first!
(TRACE-LISP (DEFINE ZERO (N) (trace-defun 'ZERO (N) (RET (AND (NUMBERP N) (<= N 1.0E-7) (>= N -1.0E-7))))))
(TRACE-LISP
 (DEFINE LIST-INTERSECTION (LIST)
  (trace-defun 'LIST-INTERSECTION (LIST)
   (RET
    (COND ((NULL LIST) NIL) ((SINGLETONP LIST) (FIRST LIST))
     (T (LIST-INTERSECTION (CONS (INTERSECTION (FIRST LIST) (SECOND LIST)) (REST (REST LIST))))))))))
;;;; ----------
;;;; (rank-sort list rank-function)
;;;; rank-function generates a rank (a number) for each element in list, and then list is returned sorted,
;;;; lowest rank first. This constrasts with Lisp's sort, where function is a *two* argument
;;;; predicate for comparing two elements in list.
;;;; rank-sort is non-destructive on list.
;;;; CL-USER> (rank-sort '("cat" "the" "elephant" "a") ;'length)
;;;; ("a" "cat" "the" "elephant")
(TRACE-LISP
 (DEFINE RANK-SORT (LIST FUNCTION)
  (trace-defun 'RANK-SORT (LIST FUNCTION) (RET (MAPCAR #'SECOND (ASSOC-SORT (TRANSPOSE (LIST (MAPCAR FUNCTION LIST) LIST))))))))
(TRACE-LISP (DEFINE ASSOC-SORT (LIST) (trace-defun 'ASSOC-SORT (LIST) (RET (SORT LIST #'PAIR-LESS-THAN)))))
(TRACE-LISP (DEFINE PAIR-LESS-THAN (PAIR1 PAIR2) (trace-defun 'PAIR-LESS-THAN (PAIR1 PAIR2) (RET (< (FIRST PAIR1) (FIRST PAIR2))))))
(TRACE-LISP
 (DEFINE SYMBOL-LESS-THAN (PAIR1 PAIR2) (trace-defun 'SYMBOL-LESS-THAN (PAIR1 PAIR2) (RET (STRING< (SYMBOL-NAME PAIR1) (SYMBOL-NAME PAIR2))))))
;;;; ----------
(TRACE-LISP (DEFVAR *TMP-COUNTER* 0))
(TRACE-LISP (DEFINE RESET-TRACE-AT-ITERATION NIL (trace-defun 'RESET-TRACE-AT-ITERATION NIL (RET (CSETQ *TMP-COUNTER* 0)))))
(TRACE-LISP
 (DEFINE TRACE-AT-ITERATION (N)
  (trace-defun 'TRACE-AT-ITERATION (N)
   (RET (TRACE-PROGN (CSETQ *TMP-COUNTER* (1+ *TMP-COUNTER*)) (COND ((EQ (MOD *TMP-COUNTER* N) 0) (FORMAT T "~a..." *TMP-COUNTER*))))))))
(TRACE-LISP (DEFINE CURR-ITERATION NIL (trace-defun 'CURR-ITERATION NIL (RET *TMP-COUNTER*))))
;;;; ======================================================================
;;;;		       PROPERTY LISTS
;;;; ======================================================================
;;;; Remove *all* properties on the property list
(TRACE-LISP
 (DEFINE REMPROPS (SYMBOL)
  (trace-defun 'REMPROPS (SYMBOL)
   (RET
    (MAPC #'(LAMBDA (INDICATOR) (trace-defun '#:G15894 (INDICATOR) (RET (REMPROP SYMBOL INDICATOR)))) (ODD-ELEMENTS (SYMBOL-PLIST SYMBOL)))))))
;;;; (odd-elements '(1 2 3 4 5)) -> (1 3 5)
(TRACE-LISP
 (DEFINE ODD-ELEMENTS (LIST)
  (trace-defun 'ODD-ELEMENTS (LIST) (RET (COND ((ENDP LIST) NIL) (T (CONS (FIRST LIST) (ODD-ELEMENTS (REST (REST LIST))))))))))
;;;; (even-elements '(1 2 3 4 5)) -> (2 4)
(TRACE-LISP (DEFINE EVEN-ELEMENTS (LIST) (trace-defun 'EVEN-ELEMENTS (LIST) (RET (ODD-ELEMENTS (REST LIST))))))
;;;; ======================================================================
;;;; (Could also define set-eq if I need it)
;;;; CL-USER> (set-equal '("a" b) '(b "a")) -> t
;;;; CL-USER> (set-equal '(a b) '(b a b))   -> nil
;;(defun set-equal (set1 set2)
;;  (cond ((and (endp set1) (endp set2)) t)
;;	((member (first set1) set2 :test ;'equal)
;;	 (set-equal (rest set1) (remove (first set1) set2 :test ;'equal :count 1)))))
;;;; (set-equal '(a b) '(b a)) -> t
;;;; (set-equal '("a" "b") '("b" "a")) -> t
;;;; (set-equal '("a" "b") '("b" "a" "a")) -> t
(TRACE-LISP (DEFINE SET-EQUAL (SET1 SET2) (trace-defun 'SET-EQUAL (SET1 SET2) (RET (CNOT (SET-EXCLUSIVE-OR SET1 SET2 :TEST #'CL-EQUAL))))))
(TRACE-LISP
 (DEFINE MULTIPLE-VALUE-MAPCAR #'LIST
  (trace-defun 'MULTIPLE-VALUE-MAPCAR #'LIST
   (RET
    (COND ((ENDP LIST) NIL)
     (T
      (MULTIPLE-VALUE-BIND (X Y) (FUNCALL FUNCTION (FIRST LIST))
       (MULTIPLE-VALUE-BIND (XS YS) (MULTIPLE-VALUE-MAPCAR FUNCTION (REST LIST)) (VALUES (CONS X XS) (CONS Y YS))))))))))
(TRACE-LISP
 (DEFINE UNQUOTE (EXPR)
  (trace-defun 'UNQUOTE (EXPR)
   (RET (COND ((QUOTEP EXPR) (SECOND EXPR)) (T (FORMAT T "Warning! Unquote received an already unquoted expression!~%") EXPR))))))
;;;dmiles (defun quotify (item) (list 'quote item))
(TRACE-LISP
 (DEFINE BAG-EQUAL (BAG1 BAG2) (trace-defun 'BAG-EQUAL (BAG1 BAG2) (RET (AND (EQ (LENGTH BAG1) (LENGTH BAG2)) (BAG-EQUAL0 BAG1 BAG2))))))
(TRACE-LISP
 (DEFINE BAG-EQUAL0 (BAG1 BAG2)
  (trace-defun 'BAG-EQUAL0 (BAG1 BAG2)
   (RET
    (COND ((CL-EQUAL BAG1 BAG2))
     ((CL-MEMBER (FIRST BAG1) BAG2 :TEST #'CL-EQUAL) (BAG-EQUAL0 (REST BAG1) (CL-REMOVE (FIRST BAG1) BAG2 :TEST #'CL-EQUAL :COUNT 1))))))))
;;;; ----------
(TRACE-LISP
 (DEFINE UPDATE-ASSOC-LIST (ASSOC-LIST NEW-PAIR)
  (trace-defun 'UPDATE-ASSOC-LIST (ASSOC-LIST NEW-PAIR)
   (RET
    (COND ((ENDP ASSOC-LIST) (LIST NEW-PAIR))  ((CL-EQUAL (FIRST (FIRST ASSOC-LIST)) (FIRST NEW-PAIR))  (CONS NEW-PAIR (REST ASSOC-LIST)))
     (T (CONS (FIRST ASSOC-LIST) (UPDATE-ASSOC-LIST (REST ASSOC-LIST) NEW-PAIR))))))))
;;;; Same, but matches with *second* argument
;;;; (assoc 'a '((a b) (c e))) -> (a b)
;;;; (inv-assoc 'b '((a b) (c e))) -> (a b)
;;;; NOTE!! Common Lisp rassoc might be a better choice, doing the same thing but with dotted pairs
;;;; (rassoc 'b '((a . b) (c . e))) -> (a . b)
(TRACE-LISP
 (DEFINE INV-ASSOC (KEY ASSOC-LIST &REST LKEYS)
  (trace-defun 'INV-ASSOC (KEY ASSOC-LIST LKEYS)
   (RET
    (CLET (TEST) (init-keyval TEST #'EQ)
     (COND ((ENDP ASSOC-LIST) NIL) ((APPLY TEST (LIST (SECOND (FIRST ASSOC-LIST)) KEY)) (FIRST ASSOC-LIST))
      (T (INV-ASSOC KEY (REST ASSOC-LIST) :TEST TEST))))))))
;;;; ----------
;;;; removes ALL the assoc-list entries with key. 
(TRACE-LISP
 (DEFINE REMOVE-ASSOC-ENTRY (KEY ASSOC-LIST)
  (trace-defun 'REMOVE-ASSOC-ENTRY (KEY ASSOC-LIST)
   (RET (REMOVE-IF #'(LAMBDA (ENTRY) (trace-defun '#:G15895 (ENTRY) (RET (EQ (FIRST ENTRY) KEY)))) ASSOC-LIST)))))
;;;; ----------
;;;; (insert-delimeter '(a b c) 'cat) -> (a cat b cat c)
(TRACE-LISP
 (DEFINE INSERT-DELIMETER (LIST DELIMETER)
  (trace-defun 'INSERT-DELIMETER (LIST DELIMETER)
   (RET (COND ((ENDP LIST) LIST) ((SINGLETONP LIST) LIST) ((CONS (FIRST LIST) (CONS DELIMETER (INSERT-DELIMETER (REST LIST) DELIMETER)))))))))
;;;; ----------
;;;; Returns non-nil if expr contains (at least) one of symbols.
;;;; (contains-some '(a b (c d)) '(d e))  -> true
(TRACE-LISP
 (DEFINE CONTAINS-SOME (EXPR SYMBOLS)
  (trace-defun 'CONTAINS-SOME (EXPR SYMBOLS)
   (RET
    (OR (CL-MEMBER EXPR SYMBOLS)
     (AND (LISTP EXPR) (SOME #'(LAMBDA (EL) (trace-defun '#:G15896 (EL) (RET (CONTAINS-SOME EL SYMBOLS)))) EXPR)))))))
;;;; ----------
;;;; xor clashes with CLISP
(TRACE-LISP (DEFINE X-OR (A B) (trace-defun 'X-OR (A B) (RET (AND (OR A B) (CNOT (AND A B)))))))
(TRACE-LISP (DEFINE NOR (A B) (trace-defun 'NOR (A B) (RET (CNOT (OR A B))))))
;; = (and (not a) (not b))
;;;; ----------
;;;; USER(60): (subbagp '(1 2 2) '(1 2 2 3)) -> t
;;;; USER(61): (subbagp '(1 2 2 2) '(1 2 2 3)) -> NIL
(TRACE-LISP
 (DEFINE SUBBAGP (SUBBAG BAG &REST LKEYS)
  (trace-defun 'SUBBAGP (SUBBAG BAG LKEYS)
   (RET
    (CLET (TEST) (init-keyval TEST #'EQ)
     (COND ((NULL SUBBAG)) ((CL-MEMBER (FIRST SUBBAG) BAG :TEST TEST) (SUBBAGP (REST SUBBAG) (CL-REMOVE (FIRST SUBBAG) BAG :TEST TEST :COUNT 1)))))))))
;;;; ----------
;;;; RETURNS THREE VALUES: shorterlist1 shorterlist2 shared
;;;; USER(63): (remove-shared-elements '(1 2 1 2 3) '(1 2 3 4 5))
;;;; (1 2)
;;;; (4 5)
;;;; (1 2 3)
;;;; USER(64): (remove-shared-elements '(1 2 1 2 1 3) '(1 2 3 1 4 5))
;;;; (2 1)
;;;; (4 5)
;;;; (1 2 1 3)
(TRACE-LISP
 (DEFINE REMOVE-SHARED-ELEMENTS (LIST1 LIST2 &REST LKEYS)
  (trace-defun 'REMOVE-SHARED-ELEMENTS (LIST1 LIST2 LKEYS)
   (RET
    (CLET (TEST) (init-keyval TEST #'EQ)
     (COND ((NULL LIST1) (VALUES NIL LIST2 NIL))
      ((CL-MEMBER (FIRST LIST1) LIST2 :TEST TEST)
       (MULTIPLE-VALUE-BIND (SHORTERLIST1 SHORTERLIST2 SHARED) (REMOVE-SHARED-ELEMENTS (REST LIST1) (CL-REMOVE (FIRST LIST1) LIST2 :TEST TEST :COUNT 1))
        (VALUES SHORTERLIST1 SHORTERLIST2 (CONS (FIRST LIST1) SHARED))))
      (T
       (MULTIPLE-VALUE-BIND (SHORTERLIST1 SHORTERLIST2 SHARED) (REMOVE-SHARED-ELEMENTS (REST LIST1) LIST2)
        (VALUES (CONS (FIRST LIST1) SHORTERLIST1) SHORTERLIST2 SHARED)))))))))
;;;; Remove element number n (first position = 0)
;;;; USER(58): (remove-element-n '(a b c) 2) -> (A C)
(TRACE-LISP
 (DEFINE REMOVE-ELEMENT-N (LIST N)
  (trace-defun 'REMOVE-ELEMENT-N (LIST N)
   (RET (COND ((OR (NULL LIST) (< N 0)) LIST) ((EQ N 0) (REST LIST)) (T (CONS (FIRST LIST) (REMOVE-ELEMENT-N (REST LIST) (1- N)))))))))
;;;; ----------------------------------------------------------------------
;;;; Move symbols from one package to another. Fairly crude implementation!
;;;; e.g. (port-to-package ... :old-package :sapir :new-package :user)
;;;; REVISED: Dec 2003 - don't care what the old package was
(TRACE-LISP
 (DEFINE PORT-TO-PACKAGE (TREE &REST LKEYS)
  (trace-defun 'PORT-TO-PACKAGE (TREE LKEYS)
   (RET
    (CLET (PACKAGE)
     (COND ((NULL TREE) NIL) ((LISTP TREE) (CONS (PORT-TO-PACKAGE (FIRST TREE) :PACKAGE PACKAGE) (PORT-TO-PACKAGE (REST TREE) :PACKAGE PACKAGE)))
      ((SYMBOLP TREE) (INTERN (SYMBOL-NAME TREE) PACKAGE)) (T TREE)))))))
;;;; ======================================================================
;;;; CL-USER(30): (permute '((a b) (1 2) (X Y)))
;;;; ((A 1 X) (A 1 Y) (A 2 X) (A 2 Y) (B 1 X) (B 1 Y) (B 2 X) (B 2 Y))
(TRACE-LISP
 (DEFINE CL-PERMUTE (LIST-OF-LISTS)
  (trace-defun 'CL-PERMUTE (LIST-OF-LISTS)
   (RET
    (COND ((ENDP LIST-OF-LISTS) (LIST NIL))
     (T
      (CLET ((PERMUTES (CL-PERMUTE (REST LIST-OF-LISTS))))
       (MAPCAN
        #'(LAMBDA (E)
           (trace-defun '#:G15897 (E)
            (RET (MAPCAR #'(LAMBDA (PERMUTE) (trace-defun '#:G15898 (PERMUTE) (RET (CONS E PERMUTE)))) PERMUTES))))
        (FIRST LIST-OF-LISTS)))))))))
;;;; (all-pairs '(a b c d))
;;;; ((A B) (A C) (A D) (B C) (B D) (C D))
(TRACE-LISP
 (DEFINE ALL-PAIRS (LIST)
  (trace-defun 'ALL-PAIRS (LIST)
   (RET
    (COND ((ENDP LIST) NIL)
     (T (APPEND (MAPCAR #'(LAMBDA (E) (trace-defun '#:G15899 (E) (RET (LIST (FIRST LIST) E)))) (REST LIST)) (ALL-PAIRS (REST LIST)))))))))
;;;; FILE:  strings.lisp
;;;; File: strings.lisp
;;;; Author: Peter Clark
;;;; Date: August 1994
;;;; Purpose: String manipulation with Lisp
#| Template for a file reader. Or just use (read-file <file> 'sexpr)
(defun <name> (&optional (file <default-file>))
  (let ( (stream (see file)) )
    (loop until (not (progn
      (let* ( (data (read stream nil nil)) )
	(cond 
	 ((null data) nil)
	 (t (<process-fn> data)
	    t))))))
    (cond ((streamp stream) (close stream)))
    t))

REVISED: Simply do: (apply-to-file-lines X'process-line "myfile.km")|#
(TRACE-LISP
 (DEFINE APPLY-TO-FILE-LINES #'FILE
  (trace-defun 'APPLY-TO-FILE-LINES #'FILE
   (RET
    (CLET ((STREAM (SEE FILE)))
     (CL-LOOP UNTIL (CNOT (TRACE-PROGN (CLET ((DATA (CL-READ STREAM NIL NIL))) (COND ((NULL DATA) NIL) (T (APPLY FUNCTION (LIST DATA)) T))))))
     (COND ((STREAMP STREAM) (CLOSE STREAM))) T)))))
;;;; words that shouldn't be pluralized or singularized
(TRACE-LISP (DEFPARAMETER *MASS-NOUNS* '("air" "water" "these" "asbestos" "always")))
(TRACE-LISP (DEFPARAMETER *PLURAL-WITH-S-WORDS* '("antennas")))
;; special cases: exceptions to exceptions where "s" should be stripped
(TRACE-LISP (DEFPARAMETER *TMP-SHELL-FILE* "/tmp/tmp-clarkp"))
;; (defparameter *max-concat-length* 500)	; Lisp implementation constraint - Lucid
;; (defconstant *max-concat-length* 255)	; Lisp implementation constraint - Harlequin!
(TRACE-LISP (DEFPARAMETER *WHITESPACE-CHARS* '(#\Space #\Tab #\Newline #\Return #\Newline #\Page)))
(TRACE-LISP (DEFPARAMETER *NEWLINE-STRING* (CL-MAKE-STRING 1 :INITIAL-ELEMENT '#\Newline)))
(TRACE-LISP (DEFPARAMETER *IRREGULAR-PLURALS* '(("person" "people") ("woman" "women") ("man" "men") ("wife" "wives") ("child" "children"))))
;;;; (a b) -> "(a b)"		       
(TRACE-LISP
 (DEFINE TRUNCATE-STRING (STRING &OPTIONAL MAXLEN)
  (trace-defun 'TRUNCATE-STRING (STRING MAXLEN)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR MAXLEN 60)
     (COND ((CNOT (STRINGP STRING)) (FORMAT T "ERROR! Non-string given to truncate-string in utils.lisp!~%") STRING) ((< (LENGTH STRING) MAXLEN) STRING)
      (T (CONCAT (SUBSEQ STRING 0 MAXLEN) "..."))))))))
;;;; ======================================================================
;;;; "[cat]" -> "cat", "\"cat\"" -> "cat"
(TRACE-LISP (DEFINE STRIP-ENDCHARS (STRING) (trace-defun 'STRIP-ENDCHARS (STRING) (RET (SUBSEQ STRING 1 (- (LENGTH STRING) 1))))))
;;;; t for "A", "B", "C", etc.
(TRACE-LISP
 (DEFINE UPPERCASE-LETTERP (WORD)
  (trace-defun 'UPPERCASE-LETTERP (WORD) (RET (AND (= (LENGTH WORD) 1) (ALPHA-CHAR-P (ELT WORD 0)) (UPPER-CASE-P (ELT WORD 0)))))))
;;;; (split-at "abcde" "bc") ---> "a" and "de"
;;;; (split-at "abcde" "xx") ---> nil
(TRACE-LISP
 (DEFINE SPLIT-AT (STRING SUBSTRING &REST LKEYS)
  (trace-defun 'SPLIT-AT (STRING SUBSTRING LKEYS)
   (RET
    (CLET (FROM-END)
     (CLET ((START0 (SEARCH SUBSTRING STRING :FROM-END FROM-END)))
      (COND (START0 (VALUES (SUBSEQ STRING 0 START0) (SUBSEQ STRING (+ START0 (LENGTH SUBSTRING))))))))))))
(TRACE-LISP (DEFINE CONTAINS (STRING SUBSTRING) (trace-defun 'CONTAINS (STRING SUBSTRING) (RET (SEARCH SUBSTRING STRING)))))
(TRACE-LISP
 (DEFINE RIGHT-OF (STRING SUBSTRING)
  (trace-defun 'RIGHT-OF (STRING SUBSTRING) (RET (MULTIPLE-VALUE-BIND (LEFT RIGHT) (SPLIT-AT STRING SUBSTRING) (DECLARE (IGNORE LEFT)) RIGHT)))))
(TRACE-LISP (DEFINE LEFT-OF (STRING SUBSTRING) (trace-defun 'LEFT-OF (STRING SUBSTRING) (RET (SPLIT-AT STRING SUBSTRING)))))
;; just ignore second return value
;;;; ASSUMES string has no trailing whitespace
(TRACE-LISP (DEFINE RIGHTMOST-WORD (STRING) (trace-defun 'RIGHTMOST-WORD (STRING) (RET (LAST-EL (STRING-TO-LIST STRING))))))
;;;; ======================================================================
;;;; shorthand
(TRACE-LISP (DEFINE CONCAT (&REST LIST) (trace-defun 'CONCAT (LIST) (RET (MY-CONCAT LIST)))))
(TRACE-LISP (DEFINE CONCAT-LIST (LIST) (trace-defun 'CONCAT-LIST (LIST) (RET (MY-CONCAT LIST)))))
;; Redefinition from Francis Leboutte to avoid the following error in some Lisp implementations:
;; Error: Argument list too long in APPLY: concatenate to (string...)
;; > (my-concat '("a" "b" "c" "d" "e" "f" "g" "h") 8)
;; "abcdefgh"
(TRACE-LISP
 (DEFINE MY-CONCAT (STRINGS)
  (trace-defun 'MY-CONCAT (STRINGS)
   (RET
    (IF (< (LENGTH STRINGS) CALL-ARGUMENTS-LIMIT) (APPLY #'CONCATENATE 'STRING STRINGS)
     (CLET ((RESULT (CL-MAKE-STRING (REDUCE #'+ (MAPCAR #'LENGTH STRINGS)))) (START 0))
      (CDOLIST (STRING STRINGS RESULT) (REPLACE RESULT STRING :START1 START) (INCF START (LENGTH STRING)))))))))
;;(defun my-concat (list len)
;;  (cond ((<= len *max-concat-length*) 
;;	 (apply ;'concatenate (cons 'string list)))
;;	(t (concatenate 'string
;;			(apply ;'concatenate (cons 'string (subseq list 0 *max-concat-length*)))
;;			(my-concat (subseq list *max-concat-length*)
;;				   (- len *max-concat-length*))))))
;; --------------------
;;;; contains only whitespace
(TRACE-LISP
 (DEFINE WHITE-SPACE-P (STRING &REST LKEYS)
  (trace-defun 'WHITE-SPACE-P (STRING LKEYS)
   (RET (CLET (WHITESPACE-CHARS) (init-keyval WHITESPACE-CHARS *WHITESPACE-CHARS*) (WHITE-SPACE2-P STRING 0 (LENGTH STRING) WHITESPACE-CHARS))))))
(TRACE-LISP
 (DEFINE WHITE-SPACE2-P (STRING N NMAX WHITESPACE-CHARS)
  (trace-defun 'WHITE-SPACE2-P (STRING N NMAX WHITESPACE-CHARS)
   (RET (COND ((EQ N NMAX)) ((CL-MEMBER (CHAR STRING N) WHITESPACE-CHARS :TEST #'CHAR=) (WHITE-SPACE2-P STRING (+ N 1) NMAX WHITESPACE-CHARS)))))))
;;;; ======================================================================
;;;;		STRING-TO-LIST   
;;;; This nifty little utility breaks a string up into its word
;;;; and delimeter components. Always starts with delimeter:
;;;; (string-to-list '"the cat, sat on t-he m/at ")
;;;; ==> ("" "the" " " "cat" ", " "sat" " " "on" " " "t-he" " " "m/at" " ")
;;;; ======================================================================
;;;; (string-to-words "the cat on the mat") -> ("the" "cat" "on" "the" "mat")
;;;; (string-to-words "the cat_n1 is big" :wordchars '(not whitespace)) -> ("the" "cat_n1" "is" "big")
(TRACE-LISP
 (DEFINE STRING-TO-WORDS (STRING &REST LKEYS)
  (trace-defun 'STRING-TO-WORDS (STRING LKEYS)
   (RET (CLET (WORDCHARS) (init-keyval WORDCHARS 'ALPHANUM) (REMOVE-DELIMETERS (STRING-TO-LIST STRING :WORDCHARS WORDCHARS)))))))
;;;; USER(3): (string-to-list "the cat sat")
;;;; ("" "the" " " "cat" " " "sat")
;;;; [1] This is a special-purpose bit of code which makes sure "." within
;;;;     a string (eg. "Section 2.2.1") is *not* categorized as a delimeter.
(TRACE-LISP
 (DEFINE STRING-TO-LIST (STRING &REST LKEYS)
  (trace-defun 'STRING-TO-LIST (STRING LKEYS)
   (RET (CLET (WORDCHARS) (init-keyval WORDCHARS 'ALPHANUM) (SCAN-TO WORDCHARS STRING 0 0 (LENGTH STRING)))))))
(TRACE-LISP
 (DEFINE SCAN-TO (DELIMETER STRING M N NMAX)
  (trace-defun 'SCAN-TO (DELIMETER STRING M N NMAX)
   (RET
    (COND ((EQ N NMAX) (LIST (SUBSEQ STRING M N))) 
     (T
      (CLET ((CURR-CHAR (CHAR STRING N)) (NEXT-CHAR (COND ((< (1+ N) NMAX) (CHAR STRING (1+ N))) (T #\Space))))
       (COND
        ((AND (IS-TYPE CURR-CHAR DELIMETER) (CNOT (AND (CHAR= CURR-CHAR #\.)  (ALPHANUMERICP NEXT-CHAR))))
         (CONS (SUBSEQ STRING M N) (SCAN-TO (INVERT-TYPE DELIMETER) STRING N N NMAX)))
        (T (SCAN-TO DELIMETER STRING M (1+ N) NMAX))))))))))
;;;; x -> (not x); (not x) -> x
(TRACE-LISP
 (DEFINE INVERT-TYPE (TYPE)
  (trace-defun 'INVERT-TYPE (TYPE) (RET (COND ((AND (LISTP TYPE) (EQ (FIRST TYPE) 'NOT)) (SECOND TYPE)) (T `(CNOT ,TYPE)))))))
;;(defun embedded-delimeter (curr-char next-char type)
;;  (declare (ignore type))
;;  (and (char= curr-char ;\.)
;;       (alphanumericp next-char)))
(TRACE-LISP
 (DEFINE IS-TYPE (CHAR TYPE)
  (trace-defun 'IS-TYPE (CHAR TYPE)
   (RET
    (COND ((AND (LISTP TYPE) (EQ (FIRST TYPE) 'NOT)) (CNOT (IS-TYPE CHAR (SECOND TYPE)))) ((EQ TYPE 'ALPHANUM) (CNOT (DELIMETER CHAR)))
     ((EQ TYPE 'WHITESPACE) (CL-MEMBER CHAR *WHITESPACE-CHARS* :TEST #'CHAR=))
     (T (FORMAT T "ERROR! is-type: Unrecognized delimeter type ~a!~%" TYPE)))))))
;;;; 5/7/99: *Do* want to break up software/hardware into two words.
;;;; (defun delimeter (char)
;;;;  (and (not (alphanumericp char))
;;;;       (not (char= char ;\-))
;;;;       (not (char= char ;\/))))
(TRACE-LISP (DEFINE DELIMETER (CHAR) (trace-defun 'DELIMETER (CHAR) (RET (CNOT (ALPHANUMERICP CHAR))))))
;;;; Remove the delimeter components:
(TRACE-LISP
 (DEFINE REMOVE-DELIMETERS (LIST)
  (trace-defun 'REMOVE-DELIMETERS (LIST) (RET (COND ((EQ (CDR LIST) NIL) NIL)  (T (CONS (CADR LIST) (REMOVE-DELIMETERS (CDDR LIST)))))))))
;;;; ----------
#|Break list of string fragments into lines
USER: (list-to-lines '("" "the" " " "cat" " " "sat" "
  " "on" " " "th" " " "emat" "
" "I" " " "think" "."))
-> ("the cat sat" "  on th emat" "I think.")|#
(TRACE-LISP
 (DEFINE LIST-TO-LINES (STRINGS &OPTIONAL REVERSE-LINE-BITS-SO-FAR)
  (trace-defun 'LIST-TO-LINES (STRINGS REVERSE-LINE-BITS-SO-FAR)
   (RET
    (COND ((ENDP STRINGS) (COND (REVERSE-LINE-BITS-SO-FAR (LIST (CONCAT-LIST (REVERSE REVERSE-LINE-BITS-SO-FAR)))))) 
     (T
      (MULTIPLE-VALUE-BIND (LEFT RIGHT) (SPLIT-AT (FIRST STRINGS) *NEWLINE-STRING*)
       (COND (LEFT (CONS (CONCAT-LIST (REVERSE (CONS LEFT REVERSE-LINE-BITS-SO-FAR))) (LIST-TO-LINES (CONS RIGHT (REST STRINGS)))))
        (T (LIST-TO-LINES (REST STRINGS) (CONS (FIRST STRINGS) REVERSE-LINE-BITS-SO-FAR)))))))))))
;;;; ======================================================================
;;; " a " -> "a "
;;; "  " -> ""
(TRACE-LISP
 (DEFINE REMOVE-LEADING-WHITESPACE (STRING)
  (trace-defun 'REMOVE-LEADING-WHITESPACE (STRING) (RET (STRING-LEFT-TRIM *WHITESPACE-CHARS* STRING)))))
(TRACE-LISP
 (DEFINE REMOVE-TRAILING-WHITESPACE (STRING)
  (trace-defun 'REMOVE-TRAILING-WHITESPACE (STRING) (RET (STRING-RIGHT-TRIM *WHITESPACE-CHARS* STRING)))))
;;;; " a " -> "a"
(TRACE-LISP (DEFINE CL-TRIM-WHITESPACE (STRING) (trace-defun 'CL-TRIM-WHITESPACE (STRING) (RET (STRING-TRIM *WHITESPACE-CHARS* STRING)))))
;;;; " a " -> t
(TRACE-LISP
 (DEFINE CONTAINS-WHITESPACE (STRING)
  (trace-defun 'CONTAINS-WHITESPACE (STRING)
   (RET (SOME #'(LAMBDA (CHAR) (trace-defun '#:G15900 (CHAR) (RET (FIND CHAR STRING)))) *WHITESPACE-CHARS*)))))
(TRACE-LISP (DEFINE WHITESPACE-CHAR (CHAR) (trace-defun 'WHITESPACE-CHAR (CHAR) (RET (CL-MEMBER CHAR *WHITESPACE-CHARS* :TEST #'CHAR=)))))
;;;; ======================================================================
;;;; mapchar; like mapcar, except it maps a function onto every
;;;; character of a string rather than every element in a list.
;;;; This should probably be a macro rather than a function.
(TRACE-LISP (DEFINE MAPCHAR #'STRING (trace-defun 'MAPCHAR #'STRING (RET (MAPCAR FUNCTION (EXPLODE STRING))))))
(TRACE-LISP
 (DEFINE EXPLODE (STRING) (trace-defun 'EXPLODE (STRING) (RET (CL-LOOP FOR I FROM 0 TO (1- (LENGTH STRING)) COLLECT (CHAR STRING I))))))
(TRACE-LISP (DEFINE IMPLODE (CHARLIST) (trace-defun 'IMPLODE (CHARLIST) (RET (COERCE CHARLIST 'STRING)))))
;;;; ======================================================================
;;;; copied from Denys, and modified...
(TRACE-LISP
 (DEFINE BREAK-STRING-AT (STRING BREAK-CHAR)
  (trace-defun 'BREAK-STRING-AT (STRING BREAK-CHAR)
   (RET
    (CL-LOOP FOR START0 = 0 THEN END AND END = 0 WHILE
     (CSETQ START0 (POSITION-IF-NOT #'(LAMBDA (CHAR) (trace-defun '#:G15901 (CHAR) (RET (CHAR= CHAR BREAK-CHAR)))) STRING :START START0)) CDO
     (CSETQ END (POSITION-IF #'(LAMBDA (CHAR) (trace-defun '#:G15902 (CHAR) (RET (CHAR= CHAR BREAK-CHAR)))) STRING :START START0)) COLLECTING
     (SUBSEQ STRING START0 END) WHILE END)))))
;;;; ======================================================================
;;;; (commaed-list '("a" "b" "c")) -> ("a" ", " "b" ", " "c")
(TRACE-LISP
 (DEFINE COMMAED-LIST (LIST &OPTIONAL DELIMETER)
  (trace-defun 'COMMAED-LIST (LIST DELIMETER)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR DELIMETER ", ")
     (COND ((ENDP LIST) NIL) ((SINGLETONP LIST) LIST) (T (CONS (CAR LIST) (CONS DELIMETER (COMMAED-LIST (CDR LIST) DELIMETER))))))))))
;;;; Previously called spaced-list  
;;;; (spaced-string '("a" "b" "c")) -> ("a b c")
(TRACE-LISP (DEFINE SPACED-STRING (LIST) (trace-defun 'SPACED-STRING (LIST) (RET (CONCAT-LIST (SPACED-LIST LIST))))))
(TRACE-LISP
 (DEFINE SPACED-LIST (LIST)
  (trace-defun 'SPACED-LIST (LIST)
   (RET (COND ((ENDP LIST) NIL) ((SINGLETONP LIST) LIST) (T (CONS (FIRST LIST) (CONS " " (SPACED-LIST (REST LIST))))))))))
;;;; ----------
(TRACE-LISP (DEFINE CL-FIRST-CHAR (STRING) (trace-defun 'CL-FIRST-CHAR (STRING) (RET (COND ((STRING/= STRING "") (CHAR STRING 0)))))))
(TRACE-LISP
 (DEFINE CL-LAST-CHAR (STRING) (trace-defun 'CL-LAST-CHAR (STRING) (RET (COND ((STRING/= STRING "") (CHAR STRING (- (LENGTH STRING) 1))))))))
;;;; (last-but-n-char "cat" 1) -> ;\a
(TRACE-LISP
 (DEFINE LAST-BUT-N-CHAR (STRING N)
  (trace-defun 'LAST-BUT-N-CHAR (STRING N) (RET (COND ((> (LENGTH STRING) N) (CHAR STRING (- (LENGTH STRING) (+ 1 N)))))))))
;;;; (butlast-char "cats") -> "cat"
(TRACE-LISP
 (DEFINE BUTLAST-CHAR (STRING) (trace-defun 'BUTLAST-CHAR (STRING) (RET (COND ((STRING/= STRING "") (SUBSEQ STRING 0 (1- (LENGTH STRING)))))))))
(TRACE-LISP
 (DEFINE BUTFIRST-CHAR (STRING) (trace-defun 'BUTFIRST-CHAR (STRING) (RET (COND ((STRING/= STRING "") (SUBSEQ STRING 1 (LENGTH STRING))))))))
;;;; (ends-with "abcde" "de") -> t
;;;; Modified June 1999, to work with lists too (ends-with '(a b c d) '(c d))
(TRACE-LISP
 (DEFINE CL-ENDS-WITH (STRING SUBSTR)
  (trace-defun 'CL-ENDS-WITH (STRING SUBSTR)
   (RET (AND (>= (LENGTH STRING) (LENGTH SUBSTR)) (CL-EQUAL (SUBSEQ STRING (- (LENGTH STRING) (LENGTH SUBSTR))) SUBSTR))))))
;;;; (starts-with "step 10" "step") -> t
;;;; Modified June 1999, to work with lists too (starts-with '(a b c d) '(a b))
(TRACE-LISP
 (DEFINE CL-STARTS-WITH (STRING SUBSTR)
  (trace-defun 'CL-STARTS-WITH (STRING SUBSTR)
   (RET (AND (>= (LENGTH STRING) (LENGTH SUBSTR)) (CL-EQUAL (SUBSEQ STRING 0 (LENGTH SUBSTR)) SUBSTR))))))
;;;; Trim n characters from the end of string
(TRACE-LISP (DEFINE TRIM-FROM-END (STRING N) (trace-defun 'TRIM-FROM-END (STRING N) (RET (SUBSEQ STRING 0 (- (LENGTH STRING) N))))))
(TRACE-LISP (DEFINE TRIM-FROM-START (STRING N) (trace-defun 'TRIM-FROM-START (STRING N) (RET (SUBSEQ STRING N (LENGTH STRING))))))
(TRACE-LISP
 (DEFINE SYMBOL-STARTS-WITH (SYMBOL CHAR) (trace-defun 'SYMBOL-STARTS-WITH (SYMBOL CHAR) (RET (CHAR= CHAR (CHAR (SYMBOL-NAME SYMBOL) 0))))))
;;;; USER(2): (remove-wrapper "(the cat)" "(" ")") -> "the cat"
(TRACE-LISP
 (DEFINE REMOVE-WRAPPER (STRING START0 END)
  (trace-defun 'REMOVE-WRAPPER (STRING START0 END)
   (RET
    (COND
     ((AND (CL-STARTS-WITH STRING START0) (CL-ENDS-WITH STRING END) (>= (LENGTH STRING) (+ (LENGTH START0) (LENGTH END))))
      (SUBSEQ STRING (LENGTH START0) (- (LENGTH STRING) (LENGTH END))))
     (T STRING))))))
;;;; ----------
(TRACE-LISP
 (DEFINE VARIANTS (WORD)
  (trace-defun 'VARIANTS (WORD)
   (RET
    (COND ((AND (CL-ENDS-WITH WORD "ing") (>= (LENGTH WORD) 7))  (LIST (TRIM-FROM-END WORD 3)))      
     (T (CL-REMOVE-DUPLICATES (LIST WORD (SINGULAR WORD) (PLURAL WORD) (GERUND (SINGULAR WORD))) :TEST #'STRING=)))))))
(TRACE-LISP
 (DEFINE ROOT-FORM (WORD) (trace-defun 'ROOT-FORM (WORD) (RET (COND ((CL-ENDS-WITH WORD "ing") (TRIM-FROM-END WORD 3)) (T (SINGULAR WORD)))))))
;;;; Input: plural of a word.
;;;; Very heuristic... We miss a few plural words whose singular form ends in a;i;o;u eg.
;;;; "macros", "silos", "emus", and singular a few singluar words ending with "es" eg.
;;;; "Les" (I can't think of a better example). Also things like "avionics" get the "s"
;;;; mistakenly (?) trimmed.
;;;; NOTE capitalized words are *not* trimmed - we'll assume they are acronyms.
(TRACE-LISP
 (DEFINE SINGULAR (WORD &REST LKEYS)
  (trace-defun 'SINGULAR (WORD LKEYS)
   (RET
    (CLET (EXTERNAL-MASS-NOUNP) (DECLARE (IGNORE EXTERNAL-MASS-NOUNP))
     (COND ((CL-MEMBER WORD *MASS-NOUNS* :TEST #'STRING=) WORD) 
      ((INV-ASSOC WORD *IRREGULAR-PLURALS* :TEST #'STRING=) (FIRST (INV-ASSOC WORD *IRREGULAR-PLURALS* :TEST #'STRING=)))
      ((CL-MEMBER (RIGHTMOST-WORD WORD) *PLURAL-WITH-S-WORDS* :TEST #'STRING=) (TRIM-FROM-END WORD 1)) 
      ((CL-ENDS-WITH WORD "sses") (TRIM-FROM-END WORD 2))  ((CL-ENDS-WITH WORD "ss") WORD)  ((CL-ENDS-WITH WORD "as") WORD) 
      ((CL-ENDS-WITH WORD "is") WORD)   ((CL-ENDS-WITH WORD "us") WORD) 
      ((AND (CL-ENDS-WITH WORD "ies") (>= (LENGTH WORD) 6))  (CONCAT (TRIM-FROM-END WORD 3) "y"))  ((CL-ENDS-WITH WORD "s") (TRIM-FROM-END WORD 1)) 
      (T WORD)))))))
;;;; ----------
(TRACE-LISP
 (DEFPARAMETER *IRREGULAR-PASSIVES*
  '(("make" "made") ("do" "done") ("have" "had") ("give" "given") ("sell" "sold") ("be" "be'ed") ("see" "seen") ("buy" "bought") ("bring" "brought")
    ("take" "taken") ("lose" "lost"))))
(TRACE-LISP
 (DEFINE PASSIVE (WORD)
  (trace-defun 'PASSIVE (WORD)
   (RET
    (COND ((SECOND (ASSOC WORD *IRREGULAR-PASSIVES* :TEST #'STRING=))) ((CHAR= (CL-LAST-CHAR WORD) #\e) (CONCAT WORD "d"))
     ((CHAR= (CL-LAST-CHAR WORD) #\y) (CONCAT (TRIM-FROM-END WORD 1) "ied")) (T (CONCAT WORD "ed")))))))
;;;; ----------
(TRACE-LISP
 (DEFINE PLURAL (WORD &REST LKEYS)
  (trace-defun 'PLURAL (WORD LKEYS)
   (RET
    (CLET (USE-MASS-NOUNP) (init-keyval USE-MASS-NOUNP T)  (DECLARE (IGNORE USE-MASS-NOUNP))
     (CLET ((DOWNCASE-WORD (CL-STRING-DOWNCASE WORD)))
      (COND 
       ((CLET ((IREG-PLURAL (SECOND (ASSOC DOWNCASE-WORD *IRREGULAR-PLURALS* :TEST #'STRING=))))
         (COND (IREG-PLURAL (COND ((STRING= WORD (STRING-CAPITALIZE WORD)) (STRING-CAPITALIZE IREG-PLURAL)) (T IREG-PLURAL))))))
        ((CL-ENDS-WITH DOWNCASE-WORD "s") (CONCAT WORD "es")) 
       ((AND (CL-ENDS-WITH DOWNCASE-WORD "y") (> (LENGTH DOWNCASE-WORD) 2)
         (CNOT (CL-MEMBER (LAST-BUT-N-CHAR DOWNCASE-WORD 1) '(#\a #\e #\i #\o #\u) :TEST #'CHAR=)))
        (CONCAT (TRIM-FROM-END WORD 1) "ies"))
         ((CL-MEMBER DOWNCASE-WORD *IRREGULAR-PLURALS* :TEST #'(LAMBDA (X Y) (trace-defun '#:G15903 (X Y) (RET (STRING= X (SECOND Y)))))) WORD)
       (T (CONCAT WORD "s")))))))))
;;;; expects singular of a word in.
(TRACE-LISP
 (DEFINE GERUND (WORD)
  (trace-defun 'GERUND (WORD)
   (RET (COND ((AND (CL-ENDS-WITH WORD "e") (>= (LENGTH WORD) 4))  (CONCAT (TRIM-FROM-END WORD 1) "ing"))  (T (CONCAT WORD "ing")))))))
;;;; If all capitals, then preserve case (eg. for acronyms). Otherwise, downcase it.
(TRACE-LISP
 (DEFINE NORMALIZE-CASE (WORD)
  (trace-defun 'NORMALIZE-CASE (WORD)
   (RET
    (COND ((STRING= WORD "A") "a")  ((STRING= WORD (STRING-UPCASE WORD)) WORD)
     ((AND (CHAR= (CL-LAST-CHAR WORD) #\s)  (STRING= (BUTLAST-CHAR WORD) (STRING-UPCASE (BUTLAST-CHAR WORD))) (STRING/= WORD "As") (STRING/= WORD "Is"))
      WORD)
     (T (CL-STRING-DOWNCASE WORD)))))))
(TRACE-LISP
 (DEFINE IS-ACRONYM (WORD)
  (trace-defun 'IS-ACRONYM (WORD) (RET (CLET ((SINGULAR-WORD (SINGULAR WORD))) (STRING= SINGULAR-WORD (STRING-UPCASE SINGULAR-WORD)))))))
;;;; ----------------------------------------
;;;; (double-quotify-list '("cat" "the big cat")) -> '("cat" "\"the big cat\"")
(TRACE-LISP
 (DEFINE DOUBLE-QUOTIFY-LIST (WORDS &OPTIONAL DELIM-CHARS)
  (trace-defun 'DOUBLE-QUOTIFY-LIST (WORDS DELIM-CHARS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR DELIM-CHARS '(#\Space))
     (COND ((STRINGP WORDS) (DOUBLE-QUOTIFY WORDS DELIM-CHARS))
      (T (MAPCAR #'(LAMBDA (WORD) (trace-defun '#:G15904 (WORD) (RET (DOUBLE-QUOTIFY WORD DELIM-CHARS)))) WORDS))))))))
(TRACE-LISP
 (DEFINE DOUBLE-QUOTIFY (WORD &OPTIONAL DELIM-CHARS)
  (trace-defun 'DOUBLE-QUOTIFY (WORD DELIM-CHARS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR DELIM-CHARS '(#\Space))
     (COND
      ((SOME #'(LAMBDA (CHAR) (trace-defun '#:G15905 (CHAR) (RET (CL-MEMBER CHAR DELIM-CHARS :TEST #'CHAR=)))) (EXPLODE WORD))
       (ADD-DOUBLEQUOTES WORD))
      (T WORD)))))))
(TRACE-LISP (DEFINE ADD-DOUBLEQUOTES (STRING) (trace-defun 'ADD-DOUBLEQUOTES (STRING) (RET (CONCAT "\"" STRING "\"")))))
;;;; ======================================================================
;;;;	Break up a string into pieces, preserving quoted adjacencies
;;;; 	and trimming leading/ending white-space.
;;;; ======================================================================
#| (break-up (string 'X    aadsf a  " " "" "the cat" 1/2 a"b"c  de"fX))
("aadsf" 
 "a" 
 " " 
 "the cat" 
 "1/2" 
 "a" 
 "b" 
 "c" 
 "de" 
 "f")|#
;;;; NOTE: delim-chars MUSTN'T be a '"'
(TRACE-LISP
 (DEFINE BREAK-UP (STRING &OPTIONAL DELIM-CHARS)
  (trace-defun 'BREAK-UP (STRING DELIM-CHARS)
   (RET (TRACE-PROGN (SUBLISP-INITVAR DELIM-CHARS '(#\Space)) (BREAK-UP2 STRING 0 0 (LENGTH STRING) NIL DELIM-CHARS))))))
;; nil means "not in quotes"
;;;; n is the current character (0 = first character)
;;;; m is the start of the current 'word' still being read. If n = m then a word was just done.
(TRACE-LISP
 (DEFINE BREAK-UP2 (STRING M N NMAX QUOTEP &OPTIONAL DELIM-CHARS)
  (trace-defun 'BREAK-UP2 (STRING M N NMAX QUOTEP DELIM-CHARS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR DELIM-CHARS '(#\Space))
     (COND ((AND (EQ N NMAX) (EQ M N)) NIL)  ((EQ N NMAX) (LIST (SUBSEQ STRING M N))) 
      (T
       (CLET ((CURR-CHAR (CHAR STRING N)))
        (COND ((AND (CNOT QUOTEP)  (CL-MEMBER CURR-CHAR DELIM-CHARS :TEST #'CHAR=) (EQ M N)) (BREAK-UP2 STRING (1+ N) (1+ N) NMAX QUOTEP DELIM-CHARS)) 
         ((AND (CNOT QUOTEP)  (CL-MEMBER CURR-CHAR DELIM-CHARS :TEST #'CHAR=))
          (COND ((EQ M N)  (BREAK-UP2 STRING (1+ N) (1+ N) NMAX QUOTEP DELIM-CHARS)) 
           (T (CONS (SUBSEQ STRING M N) (BREAK-UP2 STRING (1+ N) (1+ N) NMAX QUOTEP DELIM-CHARS)))))
         ((CHAR= CURR-CHAR #\")  (BREAK-UP2 STRING M (1+ N) NMAX (CNOT QUOTEP) DELIM-CHARS))
         (T (BREAK-UP2 STRING M (1+ N) NMAX QUOTEP DELIM-CHARS)))))))))))
;;;; ----------
;;;; (_car1) -> (_car1)
;;;; (_car1 _car2) -> (_car1 "and" _car2)
;;;; (_car1 _car2 _car3) -> (_car1 "," _car2 ", and" _car3)
(TRACE-LISP
 (DEFINE ANDIFY (VALS)
  (trace-defun 'ANDIFY (VALS)
   (RET
    (CASE (LENGTH VALS) (0 NIL) (1 VALS) (2 (LIST (FIRST VALS) " and " (SECOND VALS))) (3 (LIST (FIRST VALS) ", " (SECOND VALS) ", and " (THIRD VALS)))
     (T (CONS (FIRST VALS) (CONS ", " (ANDIFY (REST VALS))))))))))
(TRACE-LISP
 (DEFINE ORIFY (VALS)
  (trace-defun 'ORIFY (VALS)
   (RET
    (CASE (LENGTH VALS) (0 NIL) (1 VALS) (2 (LIST (FIRST VALS) " or " (SECOND VALS))) (3 (LIST (FIRST VALS) ", " (SECOND VALS) ", or " (THIRD VALS)))
     (T (CONS (FIRST VALS) (CONS ", " (ORIFY (REST VALS))))))))))
;;;; (commaify '(a b c d)) -> ("A, " "B, " "C, " "D")
(TRACE-LISP
 (DEFINE COMMAIFY (VALS)
  (trace-defun 'COMMAIFY (VALS)
   (RET
    (COND ((ENDP VALS) NIL) ((SINGLETONP VALS) (LIST (STRING (FIRST VALS)))) (T (CONS (CONCAT (STRING (FIRST VALS)) ", ") (COMMAIFY (REST VALS)))))))))
;;;; ----------
;;;; (add-escapes "a+b"" '(;\+ ;\") -> "a\+b\""
(TRACE-LISP
 (DEFINE ADD-ESCAPES (STRING SPECIALS)
  (trace-defun 'ADD-ESCAPES (STRING SPECIALS)
   (RET
    (COND ((CNOT (STRINGP STRING)) (FORMAT T "ERROR! add-escapes: argument ~s isn't a string!~%" STRING))
     (T
      (CONCAT-LIST
       (MAPCAR
        #'(LAMBDA (CHAR) (trace-defun '#:G15906 (CHAR) (RET (COND ((CL-MEMBER CHAR SPECIALS) (CONCAT "\\" (STRING CHAR))) (T (STRING CHAR))))))
        (EXPLODE STRING)))))))))
;;;; (now) -> "22/4/1999 11:49.24"
(TRACE-LISP
 (DEFINE NOW NIL
  (trace-defun 'NOW NIL (RET (MULTIPLE-VALUE-BIND (S M H D MO Y) (GET-DECODED-TIME) (FORMAT NIL "~s/~s/~s ~s:~s.~s" MO D Y H M S))))))
;;;; (common-startstring '("emergency" "emergencies")) -> "emergenc"
(TRACE-LISP
 (DEFINE COMMON-STARTSTRING (STRINGS)
  (trace-defun 'COMMON-STARTSTRING (STRINGS)
   (RET
    (COND ((SINGLETONP STRINGS) (FIRST STRINGS))
     (T
      (SUBSEQ (FIRST STRINGS) 0
       (CL-LOOP FOR I FROM 0 TO (1- (APPLY #'MIN (MAPCAR #'LENGTH STRINGS))) UNTIL
        (SOME #'(LAMBDA (STRING) (trace-defun '#:G15907 (STRING) (RET (CHAR/= (CHAR STRING I) (CHAR (FIRST STRINGS) I))))) (REST STRINGS))
        FINALLY (RET I)))))))))
;;;; "a b c" -> "c", "a" -> "a" 
(TRACE-LISP (DEFINE LAST-WORD (STRING) (trace-defun 'LAST-WORD (STRING) (RET (SUBSEQ STRING (1+ (OR (SEARCH " " STRING :FROM-END T) -1)))))))
;;;; ----------
;;;; ("cat" "dog") -> ("cat" " " "dog")
(TRACE-LISP (DEFINE INSERT-SPACES (WORDS) (trace-defun 'INSERT-SPACES (WORDS) (RET (INSERT-DELIMETER WORDS " ")))))
;; in utils.lisp
#|(defun insert-spaces (words) 
  (cond ((endp words) nil)
	((singletonp words) words)
	(t (cons (first words) (cons " " (insert-spaces (rest words)))))))|#
;;;; ----------
(TRACE-LISP
 (DEFINE YNREAD (&OPTIONAL QUESTION-STR)
  (trace-defun 'YNREAD (QUESTION-STR)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR QUESTION-STR "") (FORMAT T QUESTION-STR)
     (CLET ((ANSWER-STR (READ-LINE)))
      (COND ((STRING= ANSWER-STR "y") 'Y) ((STRING= ANSWER-STR "n") 'N) (T (FORMAT T "Please enter `y' or `n'!~%") (YNREAD QUESTION-STR)))))))))
;;;; ----------------------------------------
(TRACE-LISP (DEFINE NUMBER-STRINGP (STRING) (trace-defun 'NUMBER-STRINGP (STRING) (RET (CL-STRING-TO-NUMBER STRING)))))
(TRACE-LISP
 (DEFINE CL-STRING-TO-NUMBER (STRING &REST LKEYS)
  (trace-defun 'CL-STRING-TO-NUMBER (STRING LKEYS)
   (RET
    (CLET (FAIL-MODE) (init-keyval FAIL-MODE 'FAIL)
     (COND ((CNOT (STRINGP STRING)) (FORMAT T "; ERROR! (string-to-number ~s) should be given an ascii string as an argument!~%" STRING))
      ((STRING= STRING "") NIL)
      (T
       (MULTIPLE-VALUE-BIND (NUMBER UNREAD-CHAR-NO) (READ-FROM-STRING STRING)
        (COND
         ((OR (CNOT (NUMBERP NUMBER)) (< UNREAD-CHAR-NO (LENGTH STRING)))
          (COND
           ((EQ FAIL-MODE 'ERROR) (FORMAT T "; ERROR! (string-to-number ~s) should be given an ascii string representation of a number!~%" STRING))))
         (T NUMBER))))))))))
(TRACE-LISP (DEFINE CLEAR-SCREEN NIL (trace-defun 'CLEAR-SCREEN NIL (RET (FORMAT T "")))))
(TRACE-LISP (DEFINE PAUSE NIL (trace-defun 'PAUSE NIL (RET (TRACE-PROGN (FORMAT T "Press <RETURN> to continue...") (READ-LINE))))))
;;;; ----------------------------------------
;;;; USER(105): (remove-string "cat" "the cat on")
;;;; -> "the  on"
(TRACE-LISP
 (DEFINE REMOVE-STRING (BIT STRING)
  (trace-defun 'REMOVE-STRING (BIT STRING)
   (RET (MULTIPLE-VALUE-BIND (LEFT RIGHT) (SPLIT-AT STRING BIT) (COND (LEFT (CONCAT LEFT (REMOVE-STRING BIT RIGHT))) (T STRING)))))))
;;;; ======================================================================
#|SAPIR(133): (read-to "the cat; the mat" '(X\;))
"the cat"
" the mat"
X\;
SAPIR(134): (read-to "the cat; the mat" '(X\@))
"the cat; the mat"
""
nil
SAPIR(136): (read-to "the cat the mat;" '(X\;))
"the cat the mat"
""
X\|#
(TRACE-LISP
 (DEFINE READ-TO (STRING CHARS)
  (trace-defun 'READ-TO (STRING CHARS)
   (RET
    (CLET ((BREAK-POINT (CL-LOOP FOR I FROM 0 TO (1- (LENGTH STRING)) UNTIL (CL-MEMBER (ELT STRING I) CHARS :TEST #'CHAR=) FINALLY (RET I))))
     (COND ((= BREAK-POINT (LENGTH STRING)) (VALUES STRING "" NIL))
      (T (VALUES (SUBSEQ STRING 0 BREAK-POINT) (SUBSEQ STRING (1+ BREAK-POINT) (LENGTH STRING)) (ELT STRING BREAK-POINT)))))))))
;;;; ======================================================================
#|No! Already defined in minimatch.lisp!
;;; NOTE: This simply ignores the variables, and INSISTS that the pattern order is: (var string var string var ... var)
;;; (string-match "The <font color=red>hello</font> there" '(?x "<font color=red>" ?y "</font>" ?z)) -> ("The " "hello" " there")
;;; pattern *must* be odd length. Variables are just dummy fillers, and are ignored.
(defun string-match (string pattern)
  (cond ((singletonp pattern)			; tail variable.
	 (list string))
	(t (multiple-value-bind
	    (start0 rest-string)
	    (split-at string (second pattern))		; (first pattern) should be a variable (assumed!)
	    (cond (start0
		   (cons start0 (string-match rest-string (rest (rest pattern))))))))))|#
;;;; ======================================================================
;;;; Returns (i) the string without parenthetical comments, and (ii) a list of the parenthesized strings
;;;; USER(71): (remove-parentheticals "a (b) c (d) e")
;;;; "a c e"
;;;; ("b" "d")
(TRACE-LISP
 (DEFINE REMOVE-PARENTHETICALS (STRING &OPTIONAL PARENTHESIS)
  (trace-defun 'REMOVE-PARENTHETICALS (STRING PARENTHESIS)
   (RET
    (TRACE-PROGN (SUBLISP-INITVAR PARENTHESIS "(")
     (MULTIPLE-VALUE-BIND (PRE-PARENTHESIS POST-PARENTHESIS) (SPLIT-AT STRING PARENTHESIS)
      (COND
       ((AND PRE-PARENTHESIS (STRING= PARENTHESIS "("))
        (MULTIPLE-VALUE-BIND (REST-STRING PARENTHETICALS) (REMOVE-PARENTHETICALS POST-PARENTHESIS ")")
         (COND
          ((AND (CHAR= (CL-LAST-CHAR PRE-PARENTHESIS) #\Space)  (CHAR= (CL-FIRST-CHAR REST-STRING) #\Space)) 
           (VALUES (CONCAT PRE-PARENTHESIS (BUTFIRST-CHAR REST-STRING)) PARENTHETICALS))
          (T (VALUES (CONCAT PRE-PARENTHESIS REST-STRING) PARENTHETICALS)))))
       ((AND PRE-PARENTHESIS (STRING= PARENTHESIS ")"))
        (MULTIPLE-VALUE-BIND (REST-STRING PARENTHETICALS) (REMOVE-PARENTHETICALS POST-PARENTHESIS "(")
         (VALUES REST-STRING (CONS PRE-PARENTHESIS PARENTHETICALS))))
       (T STRING))))))))
;;;; ======================================================================
#|GIVEN a list of strings broken at arbitrary points
THEN concatenate and rebreak the strings at <nl> points only
AND truncate when max-document-size characters have been reached
	[1c] USER(9): (list-to-lines-with-size-limit '("the big" "cat sat " "on
	the" "mat I think today") :max-document-size 20)
returns TWO values
	("the bigcat sat on" "the")
	t				; max document size was reached|#
(TRACE-LISP
 (DEFINE LIST-TO-LINES-WITH-SIZE-LIMIT (STRINGS &REST LKEYS)
  (trace-defun 'LIST-TO-LINES-WITH-SIZE-LIMIT (STRINGS LKEYS)
   (RET
    (CLET (MAX-DOCUMENT-SIZE) (init-keyval MAX-DOCUMENT-SIZE 1000)
     (CLET
      ((REBROKEN-STRINGS (LIST-TO-LINES-WITH-SIZE-LIMIT0 STRINGS :MAX-DOCUMENT-SIZE MAX-DOCUMENT-SIZE))
       (MAX-DOCUMENT-SIZE-REACHED (>= (APPLY #'+ (MAPCAR #'LENGTH REBROKEN-STRINGS)) MAX-DOCUMENT-SIZE)))
      (VALUES REBROKEN-STRINGS MAX-DOCUMENT-SIZE-REACHED)))))))
(TRACE-LISP
 (DEFINE LIST-TO-LINES-WITH-SIZE-LIMIT0 (STRINGS &REST LKEYS)
  (trace-defun 'LIST-TO-LINES-WITH-SIZE-LIMIT0 (STRINGS LKEYS)
   (RET
    (CLET (MAX-DOCUMENT-SIZE LENGTH-SO-FAR REVERSE-LINE-BITS-SO-FAR) (init-keyval LENGTH-SO-FAR 0) (init-keyval MAX-DOCUMENT-SIZE 1000)
     (COND
      ((OR (ENDP STRINGS) (>= LENGTH-SO-FAR MAX-DOCUMENT-SIZE))
       (COND (REVERSE-LINE-BITS-SO-FAR (LIST (CONCAT-LIST (REVERSE REVERSE-LINE-BITS-SO-FAR))))))
      
      (T
       (MULTIPLE-VALUE-BIND (LEFT RIGHT) (SPLIT-AT (FIRST STRINGS) *NEWLINE-STRING*)
        (COND
         (LEFT
          (CONS (CONCAT-LIST (REVERSE (CONS LEFT REVERSE-LINE-BITS-SO-FAR)))
           (LIST-TO-LINES-WITH-SIZE-LIMIT0 (CONS RIGHT (REST STRINGS)) :MAX-DOCUMENT-SIZE MAX-DOCUMENT-SIZE :LENGTH-SO-FAR
            (+ LENGTH-SO-FAR (LENGTH LEFT)))))
         (T
          (LIST-TO-LINES-WITH-SIZE-LIMIT0 (REST STRINGS) :MAX-DOCUMENT-SIZE MAX-DOCUMENT-SIZE :LENGTH-SO-FAR (+ LENGTH-SO-FAR (LENGTH (FIRST STRINGS)))
           :REVERSE-LINE-BITS-SO-FAR (CONS (FIRST STRINGS) REVERSE-LINE-BITS-SO-FAR))))))))))))
;;;; "_Car23" -> "_Car"
(TRACE-LISP
 (DEFINE TRIM-NUMBERS (STRING)
  (trace-defun 'TRIM-NUMBERS (STRING)
   (RET
    (COND ((STRING= STRING "") (FORMAT T "; WARNING! Null string passed to trim-numbers!~%") "")
     ((DIGIT-CHAR-P (CL-LAST-CHAR STRING)) (TRIM-NUMBERS (BUTLAST-CHAR STRING))) (T STRING))))))
;;;; --------------------
;;;; directory can be a directory or include a pattern, e.g., 
;;;; (files-in-directory (concat *test-suite-directory* "*.lisp"))
;;;; [1] Allegro built-in
(TRACE-LISP
 (DEFINE FILES-IN-DIRECTORY (DIRECTORY)
  (trace-defun 'FILES-IN-DIRECTORY (DIRECTORY)
   (RET
    (MAPCAR
     #'(LAMBDA (PATHSTR)
        (trace-defun '#:G15908 (PATHSTR)
         (RET
          (MULTIPLE-VALUE-BIND (PATH FILE) (SPLIT-AT PATHSTR "/" :FROM-END T) (DECLARE (IGNORE PATH))
           (OR FILE (MULTIPLE-VALUE-BIND (PATH2 FILE2) (SPLIT-AT PATHSTR "\\" :FROM-END T) (DECLARE (IGNORE PATH2)) (OR FILE2 PATHSTR)))))))
     (MAPCAR #'NAMESTRING (DIRECTORY DIRECTORY)))))))
;; [1]
;;;; FILE: compiler.lisp
;;;; File: compiler.lisp
;;;; Author: Adam Farquhar (afarquhar@slb.com)
;;;; Purpose: Partially flatten the code for the KM dispatch mechanism, which 
;;;;	in limited tests gives a 10%-30% speed-up in execution speed.
;;;; Many thanks to Adam Farquhar for this neat bit of coding!!
(TRACE-LISP (DEFINE REUSE-CONS (A B AB) (trace-defun 'REUSE-CONS (A B AB) (RET (IF (AND (EQL A (CAR AB)) (EQL B (CDR AB))) AB (CONS A B))))))
(TRACE-LISP
 (DEFINE VARIABLES-IN (X)
  (trace-defun 'VARIABLES-IN (X)
   (RET
    (CLET ((VARS NIL))
     (LABELS ((VARS-IN (X) (COND ((CONSP X) (VARS-IN (FIRST X)) (VARS-IN (REST X))) ((VARP X) (PUSHNEW X VARS)) ((EQL X '&REST) (PUSHNEW 'REST VARS)))))
      (VARS-IN X) (NREVERSE VARS)))))))
(TRACE-LISP
 (DEFINE ARGS-TO-SYMBOL (&REST ARGS)
  (trace-defun 'ARGS-TO-SYMBOL (ARGS) (RET (INTERN (STRING-UPCASE (FORMAT NIL "~{~a~}" ARGS)) *KM-PACKAGE*)))))
(TRACE-LISP
 (DEFINE ADD-QUOTE-IF-NEEDED (X)
  (trace-defun 'ADD-QUOTE-IF-NEEDED (X)
   (RET (IF (OR (NUMBERP X) (STRINGP X) (AND (CONSP X) (EQL (FIRST X) 'QUOTE)) (KEYWORDP X)) X (LIST 'QUOTE X))))))
;;; See Norvig pg. 180ff for description of Delay, Force.
(TRACE-LISP (CL-DEFSTRUCT DELAY VALUE FUNCTION))
(TRACE-LISP
 (DEFMACRO DELAY (&REST BODY)
  (trace-defun 'DELAY (BODY) (RET `(MAKE-DELAY :FUNCTION #'(LAMBDA NIL (trace-defun '#:G15909 NIL (RET ,@BODY))))))))
(TRACE-LISP
 (DEFINE FORCE (X)
  (trace-defun 'FORCE (X)
   (RET
    (IF (CNOT (DELAY-P X)) X
     (TRACE-PROGN (WHEN (DELAY-FUNCTION X) (CSETF (DELAY-VALUE X) (FUNCALL (DELAY-FUNCTION X))) (CSETF (DELAY-FUNCTION X) NIL) (DELAY-VALUE X))))))))
;;;; Rule Compiler
;;;;
(TRACE-LISP (DEFVAR *BINDINGS* NIL "Alist (pattern-var . binding), used for rule compilation."))
(TRACE-LISP
 (DEFINE COMPILE-RULE (PATTERN CONSEQUENT VAR)
  (trace-defun 'COMPILE-RULE (PATTERN CONSEQUENT VAR)
   (RET (CLET ((*BINDINGS* NIL)) (LIST 'LAMBDA (LIST VAR) (COMPILE-EXPR VAR PATTERN CONSEQUENT)))))))
(TRACE-LISP
 (DEFINE COMPILE-RULES (RULES VAR)
  (trace-defun 'COMPILE-RULES (RULES VAR)
   (RET (REDUCE #'MERGE-CODE (CL-LOOP FOR (PATTERN CONSEQUENT) IN RULES COLLECT (COMPILE-RULE PATTERN CONSEQUENT VAR)))))))
(TRACE-LISP
 (DEFINE COMPILE-EXPR (VAR PATTERN CONSEQUENT)
  (trace-defun 'COMPILE-EXPR (VAR PATTERN CONSEQUENT)
   (RET
    (COND ((ASSOC PATTERN *BINDINGS* :TEST #'EQ) `(WHEN (CL-EQUAL ,VAR ,(CDR (ASSOC PATTERN *BINDINGS*))) ,(FORCE CONSEQUENT)))
     ((VARP PATTERN) (PUSH (CONS PATTERN VAR) *BINDINGS*)    (FORCE CONSEQUENT))
     ((ATOM PATTERN) `(WHEN (EQL ,VAR ,(ADD-QUOTE-IF-NEEDED PATTERN)) ,(FORCE CONSEQUENT))) (T (COMPILE-LIST VAR PATTERN CONSEQUENT)))))))
(TRACE-LISP
 (DEFINE COMPILE-LIST (VAR PATTERN CONSEQUENT)
  (trace-defun 'COMPILE-LIST (VAR PATTERN CONSEQUENT)
   (RET
    (CLET ((L (ARGS-TO-SYMBOL VAR 'L)) (R (ARGS-TO-SYMBOL VAR 'R)))
     (IF (CONSP PATTERN)
      (IF (CL-EQUAL PATTERN '(&REST)) (TRACE-PROGN  (PUSH (CONS 'REST VAR) *BINDINGS*) (FORCE CONSEQUENT))
       `(WHEN (CONSP ,VAR)
         (CLET ((,L (FIRST ,VAR)) (,R (REST ,VAR))) ,(COMPILE-EXPR L (FIRST PATTERN) (DELAY (COMPILE-EXPR R (REST PATTERN) CONSEQUENT))))))
      `(WHEN (NULL (CDR ,VAR)) (CLET ((,L (FIRST ,VAR))) ,(COMPILE-EXPR L (FIRST PATTERN) CONSEQUENT)))))))))
(TRACE-LISP (DEFINE MERGEABLE (A B) (trace-defun 'MERGEABLE (A B) (RET ))))
(TRACE-LISP (DEFINE MERGE-CODE (A B) (trace-defun 'MERGE-CODE (A B) (RET ))))
;;;;
;;;; KM Handler compilation
;;;;
#|+ignore(defun dereference-expr (x)
  ;; note depending on the compiler, this can be slow.
  (if (consp x)
      (reuse-cons
       (dereference-expr (first x))
       (dereference-expr (rest  x))
       x)
      (dereference x)))|#
#| Move to interpreter lisp
(defun dereference-expr (x)
  ;; This is fundamentally WRONG, but is the existing 1.2 behavior.
  (if (consp x)
      (mapcar X'dereference x)
      (dereference x)))|#
;; (defparameter *km-handler-function* nil) - now in header.lisp
;; no more (defparameter *custom-km-handler-function* nil)
(TRACE-LISP
 (DEFINE RESET-HANDLER-FUNCTIONS NIL
  (trace-defun 'RESET-HANDLER-FUNCTIONS NIL
   (RET
    (TRACE-PROGN (FORMAT T "Compiling KM dispatch mechanism...") (CSETQ *KM-HANDLER-FUNCTION* (COMPILE-HANDLERS *KM-HANDLER-ALIST*))
     (FORMAT T "done!~%"))))))
;; no more  (setq *custom-km-handler-function*
;; no more	(compile-handlers *custom-km-handlers*)))
(TRACE-LISP (DEFPARAMETER *TRACE-RULES* NIL))
(TRACE-LISP
 (DEFINE TRACE-RULE (RULE-PATTERN FACT BINDINGS)
  (trace-defun 'TRACE-RULE (RULE-PATTERN FACT BINDINGS)
   (RET (FORMAT *TRACE-OUTPUT* "Rule ~s is being applied to ~s with bindings ~s." RULE-PATTERN FACT BINDINGS)))))
(TRACE-LISP
 (DEFINE COMPILE-HANDLERS (HANDLERS &REST LKEYS)
  (trace-defun 'COMPILE-HANDLERS (HANDLERS LKEYS)
   (RET
    (CLET (CODE-ONLY)
     (IF (NULL HANDLERS)
      (IF CODE-ONLY NIL #'(LAMBDA (FMODE X) (trace-defun '#:G15911 (FMODE X) (RET (TRACE-PROGN (DECLARE (IGNORE X FMODE)) NIL)))))
      (CLET
       ((CODE
         (REDUCE #'MERGE-CODE
          (CL-LOOP FOR (PATTERN CLOSURE) IN HANDLERS COLLECT
           `(LAMBDA (F-MODE X)
             (trace-defun '#:G15912 (F-MODE X)
              (RET
               (BLOCK KM-HANDLER .
                ,(CDDR
                  (COMPILE-RULE PATTERN
                   (DELAY        #|NEW|# `(RETURN-FROM KM-HANDLER (VALUES (FUNCALL #',CLOSURE F-MODE  ,@(BINDINGS-FOR PATTERN)) ',PATTERN))) 'X))))))))))
       (IF CODE-ONLY CODE (COMPILE NIL CODE)))))))))
(TRACE-LISP
 (DEFINE BINDINGS-FOR (PATTERN)
  (trace-defun 'BINDINGS-FOR (PATTERN) (RET (CL-LOOP FOR VAR IN (VARIABLES-IN PATTERN) COLLECT (CDR (ASSOC VAR *BINDINGS*)))))))
#| AUX FUNCTIONS FROM KM SOURCE
;;; This is defined in km.lisp already. Need this for stand-alone compiler.
(defun varp (var)
  (and (symbolp var)
       (char=
       X\?
       (char (the string (symbol-name (the symbol var))) 0))))|#
(TRACE-LISP (DEFPARAMETER *COMPILED-HANDLERS-FILE* "compiled-handlers.lisp"))
;;;; [1] Note, don't make this universal, as we lose debugging info (which users would like). Lispworks has constraints which
;;;; make the full compilation without this setting a problem.
(TRACE-LISP
 (DEFINE WRITE-COMPILED-HANDLERS NIL
  (trace-defun 'WRITE-COMPILED-HANDLERS NIL
   (RET
    (CLET
     ((ANONYMOUS-FUNCTION (COMPILE-HANDLERS *KM-HANDLER-ALIST* :CODE-ONLY T))
      (NAMED-FUNCTION `(DEFINE COMPILED-KM-HANDLER-FUNCTION (F-MODE X) (trace-defun 'COMPILED-KM-HANDLER-FUNCTION (F-MODE X) (RET )))) 
      (STREAM (TELL *COMPILED-HANDLERS-FILE*)))
     (FORMAT STREAM
      "
;;; File: compiled-handlers.lisp
;;; Author: MACHINE GENERATED FILE, generated by compiler.lisp (author Adam Farquahar)
;;; This file was generated by (write-compiled-handlers) in compiler.lisp.
;;; This partially flattens the code assigned to *km-handler-list*, which results in
;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, 
;;; KM will be slower if it's not loaded. For the legible, unflattened source of this
;;; flattened code, see the file interpreter.lisp.
;;;
;;; NOTE: manually insert the line after compiled-km-handler-function for KM release:
;;;
;;; (defun compiled-km-handler-function (f-mode x)
;;;   #+harlequin-pc-lisp (declare (optimize (debug 0)))     ; patch for Lispworks from Fancis Leboutte [1]
;;;  (block km-handler
;;;	...
;;;
;;; ==================== START OF MACHINE-GENERATED FILE ====================

(setq *compile-handlers* t)

")
     (WRITE NAMED-FUNCTION :STREAM STREAM)
     (FORMAT STREAM
      "

(setq *km-handler-function* #'compiled-km-handler-function)

;;; This file was generated by (write-compiled-handlers) in compiler.lisp.
;;; This partially flattens the code assigned to *km-handler-list*, which results in
;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, 
;;; KM will be slower if it's not loaded. For the legible, unflattened source of this
;;; flattened code, see the file interpreter.lisp.

;;; ==================== END OF MACHINE-GENERATED FILE ====================

")
     (CLOSE STREAM) (FORMAT T "Compiled handlers written to the file ~a~%" *COMPILED-HANDLERS-FILE*))))))
;;;; FILE: compiled-handlers.lisp
;;;; File: compiled-handlers.lisp
;;;; Author: MACHINE GENERATED FILE, generated by compiler.lisp (author Adam Farquahar)
;;;; This file was generated by (write-compiled-handlers) in compiler.lisp.
;;;; This partially flattens the code assigned to *km-handler-list*, which results in
;;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, 
;;;; KM will be slower if it's not loaded. For the legible, unflattened source of this
;;;; flattened code, see the file interpreter.lisp.
;;;;
;;;; NOTE: manually insert the line after compiled-km-handler-function for KM release:
;;;;
;;;; (defun compiled-km-handler-function (f-mode x)
;;;;   ;+harlequin-pc-lisp (declare (optimize (debug 0)))     ; patch for Lispworks from Fancis Leboutte [1]
;;;;  (block km-handler
;;;;	...
;;;;
;;;; ==================== START OF MACHINE-GENERATED FILE ====================
(TRACE-LISP (CSETQ *COMPILE-HANDLERS* T))
(TRACE-LISP (DEFINE COMPILED-KM-HANDLER-FUNCTION (F-MODE X) (trace-defun 'COMPILED-KM-HANDLER-FUNCTION (F-MODE X) (RET ))))
(TRACE-LISP (CSETQ *KM-HANDLER-FUNCTION* #'COMPILED-KM-HANDLER-FUNCTION))
;;;; This file was generated by (write-compiled-handlers) in compiler.lisp.
;;;; This partially flattens the code assigned to *km-handler-list*, which results in
;;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, 
;;;; KM will be slower if it's not loaded. For the legible, unflattened source of this
;;;; flattened code, see the file interpreter.lisp.
;;;; ==================== END OF MACHINE-GENERATED FILE ====================
;;;; FILE: licence.lisp
;;;; File: licence.lisp
;;;; Author: Peter Clark
;;;; Purpose: Recite GPL to the user.
;;;; English spelling!
(TRACE-LISP (DEFINE LICENCE NIL (trace-defun 'LICENCE NIL (RET (LICENSE)))))
(TRACE-LISP
 (DEFINE LICENSE NIL
  (trace-defun 'LICENSE NIL
   (RET
    (FORMAT T
     "
		  GNU LESSER GENERAL PUBLIC LICENSE
		       Version 2.1, February 1999

 Copyright (C) 1991, 1999 Free Software Foundation, Inc.
     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

[This is the first released version of the Lesser GPL.  It also counts
 as the successor of the GNU Library Public License, version 2, hence
 the version number 2.1.]

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.

  This license, the Lesser General Public License, applies to some
specially designated software packages--typically libraries--of the
Free Software Foundation and other authors who decide to use it.  You
can use it too, but we suggest you first think carefully about whether
this license or the ordinary General Public License is the better
strategy to use in any particular case, based on the explanations below.

  When we speak of free software, we are referring to freedom of use,
not price.  Our General Public Licenses are designed to make sure that
you have the freedom to distribute copies of free software (and charge
for this service if you wish); that you receive source code or can get
it if you want it; that you can change the software and use pieces of
it in new free programs; and that you are informed that you can do
these things.

  To protect your rights, we need to make restrictions that forbid
distributors to deny you these rights or to ask you to surrender these
rights.  These restrictions translate to certain responsibilities for
you if you distribute copies of the library or if you modify it.

  For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you.  You must make sure that they, too, receive or can get the source
code.  If you link other code with the library, you must provide
complete object files to the recipients, so that they can relink them
with the library after making changes to the library and recompiling
it.  And you must show them these terms so they know their rights.

  We protect your rights with a two-step method: (1) we copyright the
library, and (2) we offer you this license, which gives you legal
permission to copy, distribute and/or modify the library.

  To protect each distributor, we want to make it very clear that
there is no warranty for the free library.  Also, if the library is
modified by someone else and passed on, the recipients should know
that what they have is not the original version, so that the original
author's reputation will not be affected by problems that might be
introduced by others.

  Finally, software patents pose a constant threat to the existence of
any free program.  We wish to make sure that a company cannot
effectively restrict the users of a free program by obtaining a
restrictive license from a patent holder.  Therefore, we insist that
any patent license obtained for a version of the library must be
consistent with the full freedom of use specified in this license.

  Most GNU software, including some libraries, is covered by the
ordinary GNU General Public License.  This license, the GNU Lesser
General Public License, applies to certain designated libraries, and
is quite different from the ordinary General Public License.  We use
this license for certain libraries in order to permit linking those
libraries into non-free programs.

  When a program is linked with a library, whether statically or using
a shared library, the combination of the two is legally speaking a
combined work, a derivative of the original library.  The ordinary
General Public License therefore permits such linking only if the
entire combination fits its criteria of freedom.  The Lesser General
Public License permits more lax criteria for linking other code with
the library.

  We call this license the \"Lesser\" General Public License because it
does Less to protect the user's freedom than the ordinary General
Public License.  It also provides other free software developers Less
of an advantage over competing non-free programs.  These disadvantages
are the reason we use the ordinary General Public License for many
libraries.  However, the Lesser license provides advantages in certain
special circumstances.

  For example, on rare occasions, there may be a special need to
encourage the widest possible use of a certain library, so that it becomes
a de-facto standard.  To achieve this, non-free programs must be
allowed to use the library.  A more frequent case is that a free
library does the same job as widely used non-free libraries.  In this
case, there is little to gain by limiting the free library to free
software only, so we use the Lesser General Public License.

  In other cases, permission to use a particular library in non-free
programs enables a greater number of people to use a large body of
free software.  For example, permission to use the GNU C Library in
non-free programs enables many more people to use the whole GNU
operating system, as well as its variant, the GNU/Linux operating
system.

  Although the Lesser General Public License is Less protective of the
users' freedom, it does ensure that the user of a program that is
linked with the Library has the freedom and the wherewithal to run
that program using a modified version of the Library.

  The precise terms and conditions for copying, distribution and
modification follow.  Pay close attention to the difference between a
\"work based on the library\" and a \"work that uses the library\".  The
former contains code derived from the library, whereas the latter must
be combined with the library in order to run.

		  GNU LESSER GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License Agreement applies to any software library or other
program which contains a notice placed by the copyright holder or
other authorized party saying it may be distributed under the terms of
this Lesser General Public License (also called \"this License\").
Each licensee is addressed as \"you\".

  A \"library\" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.

  The \"Library\", below, refers to any such software library or work
which has been distributed under these terms.  A \"work based on the
Library\" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language.  (Hereinafter, translation is
included without limitation in the term \"modification\".)

  \"Source code\" for a work means the preferred form of the work for
making modifications to it.  For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.

  Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it).  Whether that is true depends on what the Library does
and what the program that uses the Library does.
  
  1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.

  You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.

  2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) The modified work must itself be a software library.

    b) You must cause the files modified to carry prominent notices
    stating that you changed the files and the date of any change.

    c) You must cause the whole of the work to be licensed at no
    charge to all third parties under the terms of this License.

    d) If a facility in the modified Library refers to a function or a
    table of data to be supplied by an application program that uses
    the facility, other than as an argument passed when the facility
    is invoked, then you must make a good faith effort to ensure that,
    in the event an application does not supply such function or
    table, the facility still operates, and performs whatever part of
    its purpose remains meaningful.

    (For example, a function in a library to compute square roots has
    a purpose that is entirely well-defined independent of the
    application.  Therefore, Subsection 2d requires that any
    application-supplied function or table used by this function must
    be optional: if the application does not supply it, the square
    root function must still compute square roots.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.

In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library.  To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License.  (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.)  Do not make any other change in
these notices.

  Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.

  This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.

  4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.

  If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.

  5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a \"work that uses the Library\".  Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.

  However, linking a \"work that uses the Library\" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a \"work that uses the
library\".  The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.

  When a \"work that uses the Library\" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library.  The
threshold for this to be true is not precisely defined by law.

  If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work.  (Executables containing this object code plus portions of the
Library will still fall under Section 6.)

  Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.

  6. As an exception to the Sections above, you may also combine or
link a \"work that uses the Library\" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.

  You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License.  You must supply a copy of this License.  If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License.  Also, you must do one
of these things:

    a) Accompany the work with the complete corresponding
    machine-readable source code for the Library including whatever
    changes were used in the work (which must be distributed under
    Sections 1 and 2 above); and, if the work is an executable linked
    with the Library, with the complete machine-readable \"work that
    uses the Library\", as object code and/or source code, so that the
    user can modify the Library and then relink to produce a modified
    executable containing the modified Library.  (It is understood
    that the user who changes the contents of definitions files in the
    Library will not necessarily be able to recompile the application
    to use the modified definitions.)

    b) Use a suitable shared library mechanism for linking with the
    Library.  A suitable mechanism is one that (1) uses at run time a
    copy of the library already present on the user's computer system,
    rather than copying library functions into the executable, and (2)
    will operate properly with a modified version of the library, if
    the user installs one, as long as the modified version is
    interface-compatible with the version that the work was made with.

    c) Accompany the work with a written offer, valid for at
    least three years, to give the same user the materials
    specified in Subsection 6a, above, for a charge no more
    than the cost of performing this distribution.

    d) If distribution of the work is made by offering access to copy
    from a designated place, offer equivalent access to copy the above
    specified materials from the same place.

    e) Verify that the user has already received a copy of these
    materials or that you have already sent this user a copy.

  For an executable, the required form of the \"work that uses the
Library\" must include any data and utility programs needed for
reproducing the executable from it.  However, as a special exception,
the materials to be distributed need not include anything that is
normally distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.

  It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system.  Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.

  7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:

    a) Accompany the combined library with a copy of the same work
    based on the Library, uncombined with any other library
    facilities.  This must be distributed under the terms of the
    Sections above.

    b) Give prominent notice with the combined library of the fact
    that part of it is a work based on the Library, and explaining
    where to find the accompanying uncombined form of the same work.

  8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License.  Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License.  However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.

  9. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Library or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.

  10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties with
this License.

  11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all.  For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.

If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded.  In such case, this License incorporates the limitation as if
written in the body of this License.

  13. The Free Software Foundation may publish revised and/or new
versions of the Lesser General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.

Each version is given a distinguishing version number.  If the Library
specifies a version number of this License which applies to it and
\"any later version\", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation.  If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.

  14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission.  For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this.  Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.

			    NO WARRANTY

  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.

		     END OF TERMS AND CONDITIONS
")))))
;;;; FILE: LICENCE
#|		  GNU LESSER GENERAL PUBLIC LICENSE
		       Version 2.1, February 1999

 Copyright (C) 1991, 1999 Free Software Foundation, Inc.
     59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

[This is the first released version of the Lesser GPL.  It also counts
 as the successor of the GNU Library Public License, version 2, hence
 the version number 2.1.]

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.

  This license, the Lesser General Public License, applies to some
specially designated software packages--typically libraries--of the
Free Software Foundation and other authors who decide to use it.  You
can use it too, but we suggest you first think carefully about whether
this license or the ordinary General Public License is the better
strategy to use in any particular case, based on the explanations below.

  When we speak of free software, we are referring to freedom of use,
not price.  Our General Public Licenses are designed to make sure that
you have the freedom to distribute copies of free software (and charge
for this service if you wish); that you receive source code or can get
it if you want it; that you can change the software and use pieces of
it in new free programs; and that you are informed that you can do
these things.

  To protect your rights, we need to make restrictions that forbid
distributors to deny you these rights or to ask you to surrender these
rights.  These restrictions translate to certain responsibilities for
you if you distribute copies of the library or if you modify it.

  For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you.  You must make sure that they, too, receive or can get the source
code.  If you link other code with the library, you must provide
complete object files to the recipients, so that they can relink them
with the library after making changes to the library and recompiling
it.  And you must show them these terms so they know their rights.

  We protect your rights with a two-step method: (1) we copyright the
library, and (2) we offer you this license, which gives you legal
permission to copy, distribute and/or modify the library.

  To protect each distributor, we want to make it very clear that
there is no warranty for the free library.  Also, if the library is
modified by someone else and passed on, the recipients should know
that what they have is not the original version, so that the original
author's reputation will not be affected by problems that might be
introduced by others.

  Finally, software patents pose a constant threat to the existence of
any free program.  We wish to make sure that a company cannot
effectively restrict the users of a free program by obtaining a
restrictive license from a patent holder.  Therefore, we insist that
any patent license obtained for a version of the library must be
consistent with the full freedom of use specified in this license.

  Most GNU software, including some libraries, is covered by the
ordinary GNU General Public License.  This license, the GNU Lesser
General Public License, applies to certain designated libraries, and
is quite different from the ordinary General Public License.  We use
this license for certain libraries in order to permit linking those
libraries into non-free programs.

  When a program is linked with a library, whether statically or using
a shared library, the combination of the two is legally speaking a
combined work, a derivative of the original library.  The ordinary
General Public License therefore permits such linking only if the
entire combination fits its criteria of freedom.  The Lesser General
Public License permits more lax criteria for linking other code with
the library.

  We call this license the "Lesser" General Public License because it
does Less to protect the user's freedom than the ordinary General
Public License.  It also provides other free software developers Less
of an advantage over competing non-free programs.  These disadvantages
are the reason we use the ordinary General Public License for many
libraries.  However, the Lesser license provides advantages in certain
special circumstances.

  For example, on rare occasions, there may be a special need to
encourage the widest possible use of a certain library, so that it becomes
a de-facto standard.  To achieve this, non-free programs must be
allowed to use the library.  A more frequent case is that a free
library does the same job as widely used non-free libraries.  In this
case, there is little to gain by limiting the free library to free
software only, so we use the Lesser General Public License.

  In other cases, permission to use a particular library in non-free
programs enables a greater number of people to use a large body of
free software.  For example, permission to use the GNU C Library in
non-free programs enables many more people to use the whole GNU
operating system, as well as its variant, the GNU/Linux operating
system.

  Although the Lesser General Public License is Less protective of the
users' freedom, it does ensure that the user of a program that is
linked with the Library has the freedom and the wherewithal to run
that program using a modified version of the Library.

  The precise terms and conditions for copying, distribution and
modification follow.  Pay close attention to the difference between a
"work based on the library" and a "work that uses the library".  The
former contains code derived from the library, whereas the latter must
be combined with the library in order to run.

		  GNU LESSER GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License Agreement applies to any software library or other
program which contains a notice placed by the copyright holder or
other authorized party saying it may be distributed under the terms of
this Lesser General Public License (also called "this License").
Each licensee is addressed as "you".

  A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.

  The "Library", below, refers to any such software library or work
which has been distributed under these terms.  A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language.  (Hereinafter, translation is
included without limitation in the term "modification".)

  "Source code" for a work means the preferred form of the work for
making modifications to it.  For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.

  Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it).  Whether that is true depends on what the Library does
and what the program that uses the Library does.
  
  1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.

  You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.

  2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) The modified work must itself be a software library.

    b) You must cause the files modified to carry prominent notices
    stating that you changed the files and the date of any change.

    c) You must cause the whole of the work to be licensed at no
    charge to all third parties under the terms of this License.

    d) If a facility in the modified Library refers to a function or a
    table of data to be supplied by an application program that uses
    the facility, other than as an argument passed when the facility
    is invoked, then you must make a good faith effort to ensure that,
    in the event an application does not supply such function or
    table, the facility still operates, and performs whatever part of
    its purpose remains meaningful.

    (For example, a function in a library to compute square roots has
    a purpose that is entirely well-defined independent of the
    application.  Therefore, Subsection 2d requires that any
    application-supplied function or table used by this function must
    be optional: if the application does not supply it, the square
    root function must still compute square roots.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.

In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library.  To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License.  (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.)  Do not make any other change in
these notices.

  Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.

  This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.

  4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.

  If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.

  5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library".  Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.

  However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library".  The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.

  When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library.  The
threshold for this to be true is not precisely defined by law.

  If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work.  (Executables containing this object code plus portions of the
Library will still fall under Section 6.)

  Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.

  6. As an exception to the Sections above, you may also combine or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.

  You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License.  You must supply a copy of this License.  If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License.  Also, you must do one
of these things:

    a) Accompany the work with the complete corresponding
    machine-readable source code for the Library including whatever
    changes were used in the work (which must be distributed under
    Sections 1 and 2 above); and, if the work is an executable linked
    with the Library, with the complete machine-readable "work that
    uses the Library", as object code and/or source code, so that the
    user can modify the Library and then relink to produce a modified
    executable containing the modified Library.  (It is understood
    that the user who changes the contents of definitions files in the
    Library will not necessarily be able to recompile the application
    to use the modified definitions.)

    b) Use a suitable shared library mechanism for linking with the
    Library.  A suitable mechanism is one that (1) uses at run time a
    copy of the library already present on the user's computer system,
    rather than copying library functions into the executable, and (2)
    will operate properly with a modified version of the library, if
    the user installs one, as long as the modified version is
    interface-compatible with the version that the work was made with.

    c) Accompany the work with a written offer, valid for at
    least three years, to give the same user the materials
    specified in Subsection 6a, above, for a charge no more
    than the cost of performing this distribution.

    d) If distribution of the work is made by offering access to copy
    from a designated place, offer equivalent access to copy the above
    specified materials from the same place.

    e) Verify that the user has already received a copy of these
    materials or that you have already sent this user a copy.

  For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it.  However, as a special exception,
the materials to be distributed need not include anything that is
normally distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.

  It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system.  Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.

  7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:

    a) Accompany the combined library with a copy of the same work
    based on the Library, uncombined with any other library
    facilities.  This must be distributed under the terms of the
    Sections above.

    b) Give prominent notice with the combined library of the fact
    that part of it is a work based on the Library, and explaining
    where to find the accompanying uncombined form of the same work.

  8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License.  Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License.  However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.

  9. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Library or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.

  10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties with
this License.

  11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all.  For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.

If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded.  In such case, this License incorporates the limitation as if
written in the body of this License.

  13. The Free Software Foundation may publish revised and/or new
versions of the Lesser General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.

Each version is given a distinguishing version number.  If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation.  If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.

  14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission.  For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this.  Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.

			    NO WARRANTY

  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.

		     END OF TERMS AND CONDITIONS|#
;;;; FILE: initkb.lisp
;;;; File: initkb.lisp
;;;; Author: Peter Clark
;;;; Purpose: Initialize the KB (directive). This file is loaded last.
(TRACE-LISP (RESET-KB))
(TRACE-LISP
 (DEFINE VERSION NIL
  (trace-defun 'VERSION NIL
   (RET
    (TRACE-PROGN (FORMAT T "      ====================================================~%")
     (FORMAT T "      KM - THE KNOWLEDGE MACHINE - INFERENCE ENGINE v~a~%" *KM-VERSION-STR*)
     (FORMAT T "      ====================================================~%")
     (FORMAT T "Copyright (C) 1994-~a Peter Clark and Bruce Porter. KM comes with ABSOLUTELY~%" *YEAR*)
     (FORMAT T "NO WARRANTY. This is free software, and you are welcome to redistribute it~%")
     (FORMAT T "under certain conditions. Type (license) for details.~%~%") T)))))
(TRACE-LISP (VERSION))
(TRACE-LISP (FORMAT T "Documentation at http://www.cs.utexas.edu/users/mfkb/km/~%"))
(TRACE-LISP (FORMAT T "Type (km) for the KM interpreter prompt!~%"))