;;; FILE: README.txt
;;; KM - The Knowledge Machine - Build Date:  Tue Apr 19 14:20:01 PDT 2011 
#|
======================================================================
	 KM - THE KNOWLEDGE MACHINE - INFERENCE ENGINE 2.5.33
======================================================================

This software is released under the Simplified BSD Licence (below). If you would like a 
copy of this software issued under a different license please contact the authors.

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

Copyright (c) 1994-2011 Peter Clark and Bruce Porter. All rights reserved.

Redistribution and use in source and binary forms, with or without modification, are
permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice, this list of
      conditions and the following disclaimer.

   2. Redistributions in binary form must reproduce the above copyright notice, this list
      of conditions and the following disclaimer in the documentation and/or other materials
      provided with the distribution.

THIS SOFTWARE IS PROVIDED BY PETER CLARK AND BRUCE PORTER ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL PETER CLARK AND BRUCE PORTER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

The views and conclusions contained in the software and documentation are those of the
authors and should not be interpreted as representing official policies, either expressed
or implied, of Peter Clark and Bruce Porter.

Contact information:
Peter Clark (peterc@vulcan.com)
Bruce Porter (porter@cs.utexas.edu)

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

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.

Peter Clark
peterclark425@gmail.com

======================================================================
	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!]
[(1) Ignore end-of-line whitespace - thanks to Nate Blaylock]
[(2) Thanks to Dan Tecuci pointing out "-" needs to be the last character in
     the regexp, otherwise it has the meaning of a character range delimeter.]

(save-excursion
  (let ((case-fold-search nil))
    (goto-char (point-min))
;   (while (re-search-forward "^;;; FILE: +\\(.*\\)" nil t) [see (1) above]
;   (while (re-search-forward "^;;; FILE: +\\([a-zA-Z-\\._]+\\)" nil t) [(2)]
    (while (re-search-forward "^;;; FILE: +\\([a-zA-Z\\._-]+\\)" 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 :use '(:common-lisp)))\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
		#!/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 ------------------------------
#!/usr/local/bin/perl
# Splits file with internal file markers of the form:
# ;;; FILE: <filename>
# into individual files in the current directory.
# Outputs to stdout information about processing.
# require 5.0;
$lineno = 0 ;
if ($#ARGV != 0) { die "Usage: $0 filename.";}	# 1 and only 1 arg
$fn = shift(@ARGV);

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

unless ($junk != /^;;; FILE/o) {
	die "Missing file tag ;;; FILE: Line number $lineno."
}
# 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";
# uncomment the below line if you want KM files to have KM package declaration
		print (OUTFILE "\n(unless (find-package :km) (make-package :km :use '(:common-lisp)))\n");
		print (OUTFILE "(in-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 "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.
|#

;;; From Tim Menzies: Suppress style warnings under SBCL (Mac and Linux)
#+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS CL:STYLE-WARNING))

;;; COMMENT THIS OUT FOR THE PACKAGED VERSION OF KM
; (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 :use '(:common-lisp))))
(in-package :km)
(defvar *using-km-package* nil)
(setq *using-km-package* t)	; flag used by fastsave-kb

;;; KM defines neq (in utils.lisp), except for Mac CommonLisp where it's
;;; a built-in. However, in MCL it's in the ccl not cl package, and so with
;;; KM's packaged version we need to explicitly import it to KM, in addition
;;; to the normal importing via :use '(:common-lisp) above
#+MCL
(eval-when (:compile-toplevel :load-toplevel :execute)
   (import 'ccl:neq))


;;; KM package is now the current package
(eval-when
 (:compile-toplevel :load-toplevel :execute)
 (defconstant *km-package* *package*))

;;; Define and switch to *km-readtable* a copy of *readtable* which (normally)
;;; points to the built-in, read-only system readtable.
;;; The purpose of this is that *km-readtable* can then be modified for the
;;; #$ macro, while (in some Lisps) the build-in system read-table cannot be.
(eval-when (:execute :load-toplevel :compile-toplevel)
   (defvar  *ACL-readtable* *readtable*)  ;; just to save a pointer to ACL's readtable
   (defvar *km-readtable* (copy-readtable *readtable*)))

;;; ======================================================================

;;; Personal preference
;(setq *print-case* :downcase)

;;; Dispatch mechanism not "compiled" be default, unless 
;;; compiled-handlers.lisp is included.
(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.
(defparameter *km-handler-alist1* nil)
(defparameter *km-handler-alist2* nil)
(defparameter *km-handler-alist* nil)

(defconstant *var-marker-char* #\_)
(defparameter *var-marker-string* "_")
(defparameter *proto-marker-string* (concatenate 'string *var-marker-string* "Proto"))		; ie. "_Proto"
(defparameter *fluent-instance-marker-string* (concatenate 'string *var-marker-string* "Some"))	; ie. "_Some"
(defparameter *km-version-str* "2.5.33")
(defparameter *year* "2011")
(defparameter *newline-str* (make-string 1 :initial-element '#\Newline))	

(defparameter *km-handler-function* nil) ; used in compiler.lisp

; (defconstant *global-situation* '|*Global|)
; Correction to allow compilation in CLisp (Thanks to Francis Leboutte).
(eval-when (:compile-toplevel :load-toplevel :execute)
   (defconstant *global-situation* '|*Global|))

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


; from prototypes.lisp
(defparameter *slots-not-to-clone-for* 	; Intent is defconstant, but SBCL doesn't like defconstants on lists
  '(|prototype-participant-of| |prototype-participants|
       |prototypes| |prototype-of| |instance-of| |cloned-from| |has-clones| |clone-built-from| |has-built-clones|))

;;; --------------------
;;; Optimization flags: note which bits of machinery are in use.
;;; --------------------

(defparameter *classes-using-assertions-slot* nil)
(defparameter *are-some-definitions* nil)	
(defparameter *are-some-prototype-definitions* nil)	
(defparameter *are-some-prototypes* nil)
(defparameter *are-some-subslots* nil)
(defparameter *are-some-constraints* nil)
(defparameter *are-some-tags* nil)
(defparameter *are-some-defaults* nil)
(defparameter *deleted-frames* 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.
(defparameter *km-behavior-parameters*
  '(*recursive-classification*		; default t
    *indirect-classification*		; default t
    *recursive-prototypes*		; default nil
    *eagerly-unify-prototypes* 		; default t
    *sanity-checks*			; default t
    *slot-checking-enabled*		; default nil
    *logging*				; default nil
    *max-padding-instances*		; default 0
    *tolerance*				; default 0.001
    *output-precision*			; default 3
    *instance-of-is-fluent*		; default nil
    *km-depth-limit*			; default nil
    *linear-paths*			; default nil
    *project-cached-values-only*	; default nil
    *record-explanations-for-clones*    ; default nil
    *coerce-undeclared-slots*		; default nil
    *record-explanations*		; default t
    *record-sources*			; default t
    *add-comments-to-names*		; t - print _Car3 as: _Car3 #|"a Car&Dog"|#
    *check-kb*				; default nil    
    *classify-slotless-instances*	; default t
    *built-in-remove-subsumers-slots*	; #$(instance-of classes superclasses member-type) (is changed in AURA appn)
    *built-in-remove-subsumees-slots*	; #$(subclasses prototype-of domain range) 	 (is changed in AURA appn)
    *default-fluent-status*		; #$*Fluent
    *active-obj-stack*			; nil
    *on-error*				; default = debug
    ;;; Formatting of justifications
    *justify-leaves*			; nil = by default, DON'T explain things that DON'T have comment tags
    *start-justifications-with-because* ; default t. If t, start justification text with "The s of f = v because:".
    ;;; Classification control
    *classification-enabled* 
    *prototype-classification-enabled* 
    *use-inheritance*
    *use-prototypes*
    *developer-mode*
    *unclonable-slots*			; may be extended (e.g., in AURA)
    *called-forces-unification*		; default t
    ))

(defparameter *recursive-classification* t)
(defparameter *indirect-classification* t)
(defparameter *recursive-prototypes* nil)
(defparameter *eagerly-unify-prototypes* t)
(defparameter *sanity-checks* nil)	; see constraints.lisp to toggle these on and off
(defparameter *slot-checking-enabled* nil)
(defparameter *logging* nil)
(defparameter *max-padding-instances* 0) ; [1]
(defparameter *tolerance* 0.0001)	; within this means the two numbers are the same
(defparameter *output-precision* 3)	; for make-sentence
(defparameter *instance-of-is-fluent* nil)
(defparameter *km-depth-limit* nil)	; nil = no limit
(defparameter *linear-paths* nil)	; DON'T recognize linear paths any more
(defparameter *project-cached-values-only* nil)
(defparameter *record-explanations-for-clones* t)	; change
(defparameter *coerce-undeclared-slots* nil) ; if t and slot isn't declared, assert it as (instance-of (Slot))
(defvar *record-explanations* t)    ; Allow users to turn this off (to save memory)
(defparameter *record-sources* t)	; Allow users to turn this off (to save memory)
(defparameter *add-comments-to-names* t) ; print _Car3 as: _Car3 #|"a Car&Dog"|#
(defvar *check-kb* nil)
; (defvar *classify-slotless-instances* t) - in frame-io.lisp
; (defparameter *built-in-remove-subsumers-slots* '#$(instance-of classes superclasses member-type)) - in frame-io.lisp
; (defparameter *built-in-remove-subsumees-slots* '#$(subclasses prototype-of domain range)) - in frame-io.lisp

; In frame-io.lisp
;(defconstant *default-default-fluent-status* '#$*Fluent) ; neah, don't change this!
;(defparameter *default-fluent-status* *default-default-fluent-status*)	; user can change this
(defparameter *active-obj-stack* nil)
(defparameter *called-forces-unification* t)

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

;;; [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.

(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.
(defparameter *km-state-parameters*
    '(*km-gensym-counter*
;      *clone-operation-id-counter*
    *visible-theories*
;   *obj-stack*			neah, this doesn't need to be saved.
    *curr-prototype*
    *curr-situation*
    *classes-using-assertions-slot*
    *are-some-definitions*
    *are-some-prototype-definitions*
    *are-some-prototypes*
    *are-some-subslots*
    *are-some-constraints*
    *are-some-tags*
    *are-some-defaults*
    *am-in-situations-mode*
;    *abort-on-error-report*
;    *error-report-silent*
;   *user-defined-infix-operators*	- these don't write out properly so ignore these
    ))

;;; These are internal during system development and are now fixed. They are parameters created
;;; during system development to allow easy switching off of new features if they break something.
(defparameter *km-fixed-parameters*
    '(*add-cloned-from-links*		; t
      *propogate-explanations-to-clones* ; t
;      *prototype-bookkeeping-slots*
      *installing-inverses-enabled*
      *less-aggressive-constraint-checking*
      *overriding-in-prototypes*
;     *clones-are-global*
      *force-with-cloned-from*		; take cloned-from as a tagging slot
      *classify-in-local-situations*
      ))
      
;;; Additional query-specific parameters. These change *during* reasoning.
(defparameter *km-runtime-variables* 
    '(*trace*
      *depth*
      *internal-logging*
      *am-classifying*
      *looping*
      *spypoints*
      *profiling*
      *print-explanations*
      *show-comments*
      *deleted-frames*
      *partially-included-prototype*
      ))

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

(defvar *curr-prototype* nil)		; For prototype mode
; (defvar *unifying-in-prototype* nil)	; New flag, so lazy-unify-vals knows when a prototype is being merged in
(defparameter *show-comments* t)	; for tracing
(defparameter *use-inheritance* t)	; Applied in get-slotvals.lisp
(defparameter *use-prototypes* t)	; Applied in get-slotvals.lisp
(defparameter *use-no-inheritance-flag* nil)	; for Shaken

(defvar *trace* nil)			; Tracer is on/off
(defvar *depth* 0)			; Tracing depth
(defvar *internal-logging* nil)		; for internal backtracking
(defvar *am-classifying* nil)		; Don't classify while classifying
(defvar *dereferencing-on* t)		; Allows dereferencing to be turned off when not needed, e.g., cloning
(defvar *partially-included-prototype* nil)

; (defvar *backtrack-after-testing-unification* nil)   ; Obsolete parameter (always nil), but I'll leave the code there

;;; New mechanism
(defvar *visible-theories* nil)
;(defvar *clone-operation-id-counter* 0)

(defparameter *special-symbol-alist*
  '( (quote "'")
     (function "#'")
     (unquote "#,")
     (unquote-splice "#@")
     (#+allegro excl::backquote #-allegro backquote "`")
     (#+allegro excl::bq-comma #-allegro bq-comma ",")			; I'm not sure of the non-Allegro implementation
     (#+allegro excl::bq-comma-atsign #-allegro bq-comma-atsign ",@") ))

;;; when t, exposes the source info on frame data structures (for debugging purposes)
(defparameter *developer-mode* nil)

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

;;; encapsulate checking flag
; (defvar *check-kb* nil) - put earlier
(defun checkkbon ()  (km-setq '*check-kb* t))
(defun checkkboff () (km-setq '*check-kb* nil))
(defun checkkbp () *check-kb*)

;;; ======================================================================
;;;		STATISTICS COUNTERS
;;; ======================================================================

(defvar *statistics-classification-inferences* 0)
(defvar *statistics-query-directed-inferences* 0)
(defvar *statistics-kb-access* 0)
(defvar *statistics-cpu-time* (get-internal-run-time))
(defvar *statistics-skolems* 0)
(defvar *statistics-max-depth* 0)
(defvar *statistics-unifications* 0)
(defvar *statistics-classifications-attempted* 0)
(defvar *statistics-classifications-succeeded* 0)

(defparameter *user-defined-infix-operators* nil)

;;; Experiment with making them local - doesn't work so well though
; (defparameter *clones-are-global* t)
; 7/24/08: NEW: No equate *clones-are-global* with *am-in-situations-mode*

;;; Used in get-slotvals.lisp and explain.lisp
(defparameter *subslot-comment-tag* '|[subslot-reasoning]|)

;;; 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.

(defun htextify (concept &optional concept-phrase &key action window)
  (declare (ignore concept concept-phrase action window)))



;;; FILE: case.lisp

;;; File: case.lisp
;;; Author: Peter Clark
;;; Purpose: Case-sensitive handling for KM

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *case-preserving-readtable* (copy-readtable *readtable*))
  (setf (readtable-case *case-preserving-readtable*) :preserve))

;;; ======================================================================
;;;			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 '#$(every Car has
              (wheel-count (4))
              (parts ((a Engine) (a Chassis)))))

(km '#$(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 #$ construct:

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

2. with the #$ construct:

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

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

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

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

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


For another example of how to use the #t construct, see the
property-mult-property and property-div-property functions.
|#

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *t-readtable* (copy-readtable *readtable*))
  ;; standard CL mode:
; (setf (readtable-case *t-readtable*) :upcase)
  (defvar *t-package* nil))

(eval-when (:compile-toplevel :load-toplevel :execute)   
  (defun hash-t-reader (stream subchar arg)
    (declare (ignore subchar arg))
    (let (;; bind *package* to the package that was in effect outside the
          ;; form prefixed by #$
          (*package* *t-package*)
          (*readtable* *t-readtable*))
      (read stream t nil t))))

;; DEW: 2010/05/05  this call and the other calls to set-dispatch-macro-character
;;   break in Allegro 8.2.  The code as is, is unfriendly - it changes the base-lisp 
;  readtable so that whenever a Lisp READ  comes across "#t" (or #$ #,)
; it will flip to performing the read using a readtable stored by KM 
;; (which is a copy of whatever readtable was current when KM was loaded) 
;; instead of whatever readtable might have been let bound by someone else's code.

;; we now define these in *km-readtable*,
;; files that use these dispatch characters must use *km-readtable*
;;   which must be set within a (eval-when (:execute :load-toplevel :compile-toplevel)...)
;;   (eg interpreter.lisp) or the compiler will use the standard readtable.

;;; (get-dispatch-macro-character #\# #\t)
;;; Only used in the context of #$ (*case-preserving-readtable*) environment
(eval-when (:compile-toplevel :load-toplevel :execute)
  (set-dispatch-macro-character #\# #\t #'hash-t-reader *case-preserving-readtable*))

 ;;; UPDATED DEFINITIONS
;;; *******************

;;; Like case-sensitive-read, except ALSO ensures all symbols are read into the
;;; KM package (rather than whatever the current package is)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun case-sensitive-read-km (&optional stream (eof-err-p t) eof-val rec-p)
    ;; FLE 29Jul2005
    ;; bind *t-package* to the current package, to be used in the #t construct
    ;; It doesn't hurt if *package* is already bound to *km-package*
    ;; (which is :km or a "current" package, usually :user).
    ;; BTW, I think KM should always be packaged (:km package)
    (let ((*t-package* *package*)
          (*package* *km-package*))
      (case-sensitive-read stream eof-err-p eof-val rec-p))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun case-sensitive-read (&optional stream (eof-err-p t) eof-val rec-p)
    (loop
      (handler-case
	  (unwind-protect
	      (progn
		(let* ((*readtable* *case-preserving-readtable*))
		  (return (read stream eof-err-p eof-val rec-p)))))
	(error
	    (error)
          ;; FLE 25Jul2005: more understandable error message (typep and ~a)
          (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))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun case-sensitive-read-from-string (&optional (eof-err-p t) eof-val)
    (loop
      (handler-case
	  (unwind-protect
	      (progn
		(let ((*readtable* *case-preserving-readtable*))
		  (return (read-from-string eof-err-p eof-val)))))
	(error
	    (error)
          ;; FLE 25Jul2005: more understandable error message (typep and ~a)
          (cerror "Ignore error and return."
                  (if (typep error 'end-of-file)
                      "During case-sensitive-read-from-string, certainly a premature end-of-file:~%~a"
                    "During case-sensitive-read-from-string:~%~a")
                  error))))))

#| OLD
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun case-sensitive-read (&optional stream (eof-err-p t) eof-val rec-p)
    (let ((old-readtable-case (readtable-case *readtable*)))
      (loop
       (handler-case
           (unwind-protect
               (progn
                 (setf (readtable-case *readtable*) :preserve)
                 (return (read stream eof-err-p eof-val rec-p)))
             (setf (readtable-case *readtable*) old-readtable-case))
         (error
          (error)
          ;; FLE 25Jul2005: more understandable error message (typep and ~a)
          (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)))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun case-sensitive-read-from-string (&optional (eof-err-p t) eof-val)
    (let ((old-readtable-case (readtable-case *readtable*)))
      (loop
       (handler-case
           (unwind-protect
               (progn
                 (setf (readtable-case *readtable*) :preserve)
                 (return (read-from-string eof-err-p eof-val)))
             (setf (readtable-case *readtable*) old-readtable-case))
         (error
          (error)
          ;; FLE 25Jul2005: more understandable error message (typep and ~a)
          (cerror "Ignore error and return."
                  (if (typep error 'end-of-file)
                      "During case-sensitive-read-from-string, certainly a premature end-of-file:~%~a"
                    "During case-sensitive-read-from-string:~%~a")
                  error)))))))
|#
;;; ======================================================================

(eval-when
 (:compile-toplevel :load-toplevel :execute)
 (defun hash-dollar-reader (stream subchar arg)
   (declare (ignore subchar arg))
   (case-sensitive-read-km stream t nil t)))

;;; set #$ when using *km-readtable*
(eval-when
 (:compile-toplevel :load-toplevel :execute)
 (set-dispatch-macro-character #\# #\$ #'hash-dollar-reader *km-readtable*))

;;; set #$ when using *case-preserving-readtable*
;;; #$ might be used in a #$ (*case-preserving-readtable*) environment. Strictly,
;;; it's redundant to do this, but we need to accomodate any users' redundancies!
(eval-when (:compile-toplevel :load-toplevel :execute)
 (set-dispatch-macro-character #\# #\$ #'hash-dollar-reader *case-preserving-readtable*))

;;; ======================================================================
;;;			WRITING
;;; ======================================================================

#|
This version of format *doesn't* put || around symbols, but *does* put
"" around strings. This is impossible to do with the normal format, as
|| 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)   (|The| BIG |big| "car" 2)	(|The| BIG |big| "\"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))
|#

(defun km-format (stream string &rest args)
  (let ( (old-print-case *print-case*) )
    (prog2
	(setq *print-case* :upcase)	; :upcase really means "case-sensitively"
	(apply #'format (cons stream 
			      (cons string (mapcar #'add-quotes args))))
      (setq *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\"")

(defun add-quotes (obj)
  (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)) 		; (concat "\"" obj "\"") <- Insufficient for "a\"b"
	((and (symbolp obj)
	      (let ( (chars (explode (symbol-name obj))) )
		(or (intersection chars '(#\( #\) #\  #\, #\; #\: #\' #\"))
		    (not (set-difference chars '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))))	;  e.g. |1943|, the symbol
	 (concat "|" (symbol-name obj) "|"))
	((keywordp obj) (concat ":" (symbol-name obj)))		; better!
	(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].
(defun write-km-vals (vals &optional (stream t))
  (let ( (old-print-case *print-case*) )
    (prog2
	(setq *print-case* :upcase)	; :upcase really means "case-sensitively"
	(write-km-vals2 vals stream)
      (setq *print-case* old-print-case))))

(defun write-km-vals2 (vals &optional (stream t))
  (cond ((null vals) (format stream "~a" nil))
	((and (pairp vals) 
	      (symbolp (first vals))
	      (assoc (first vals) *special-symbol-alist*))
	 (let ( (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)
	      (intersection (explode (symbol-name vals)) '(#\( #\) #\  #\, #\; #\:)))
	 (format stream "|~a|" vals))
	((anonymous-instancep vals)
	 (format stream "~a" vals)
	 (let ( (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 (let* ( (classes (remove-subsumers (immediate-classes vals)))
			    (skolem-root (skolem-root (symbol-name vals)))
			    (name-class-str (cond ((starts-with skolem-root "_Proto") (subseq skolem-root 6 (length skolem-root)))
						  ((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)))
			     (let ( (new-tag (concat-list (cons "a " (commaed-list (mapcar #'symbol-name classes) "&")))) )
			       (tag-write (list new-tag) stream)))))))))
	(t (format stream "~a" vals))))

(defun write-km-list (list &optional (stream t) (first-time-through 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
	   
(defun tag-write (tags &optional (stream t) (first-time-through 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"
(defun skolem-root (string)
  (cond 
   ((string= string ""))
   ((member (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)]
(defun string-to-frame (string)
  (cond ((string= string "") nil)
	(t (intern string *km-package*))))

;;; Inverse suffix must obey case-sensitive restrictions
(defparameter *inverse-suffix* "-of")
(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 #, always returns a
LIST of instances, so we have to be careful to splice them in appropriately.
Added #@ to do splicing. (a #@b) = (a . #,b)

However, we need to make it a reader macro so that KM will respond to
embedded #, 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 #,(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) #,(a Car))
('(:set (a Car) (_Car16)))		<= note undesirable () around _Car16

KM> '(:set (a Car) . #,(a Car))		<= use . #, 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!
(eval-when
 (:compile-toplevel :load-toplevel :execute)
 (defun hash-comma-reader (stream subchar arg)
   (declare (ignore subchar arg))
;  (list 'unquote (case-sensitive-read-km stream t nil t))))
;  (list 'unquote (case-sensitive-read stream t nil t))))
   (list 'unquote (read stream t nil t))))

;;; #, can only be used within the scope of a #$, as #$ switches the readtable to *case-preserving-readtable*
(eval-when
 (:compile-toplevel :load-toplevel :execute)
 (set-dispatch-macro-character #\# #\, #'hash-comma-reader *case-preserving-readtable*))

;;; Utility so users can have #$ recognized in the Lisp window.
;;; Note that users have to explicitly call this function themselves from the Lisp prompt for it to work :-(
(defun hash-dollar () (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

;;; For backward compatibility with earlier Allegro versions
;;; Under Allegro-v8.2 the below command is illegal, as the initial *readtable* is read-only and not changable.
;;; #- means *don't* call the below for Allegro 8.2 or later.
#-(and allegro-version>= (version>= 8 2))
(eval-when
    (:compile-toplevel :load-toplevel :execute)
  (set-dispatch-macro-character #\# #\$ #'hash-dollar-reader *readtable*))
;;; FILE: interpreter.lisp

;;; File: interpreter.lisp
;;; Author: Peter Clark
;;; Date: July 1994
;;; Purpose: KM Query Language interpreter

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

(defvar *looping* nil)
(defvar *warnings* nil)
(defvar *errors* nil)
(defvar *error-structures* nil)

(defparameter *multidepth-path-default-searchdepth* 5)

;;; *additional-keywords* ARE allowed as slot names
(defparameter *additional-keywords* 
  '#$(TheValue TheValues * called uniquely-called Self QUOTE UNQUOTE == /== > <))	; used for (scan-kb) in frame-io.lisp.
(defparameter *infinity* 999999)

(defparameter *structured-list-val-keywords* '#$(:seq :bag :args :triple :pair :function))

(defparameter *reserved-keywords* 			 ; NOT allowed as class or slot names
  '#$(a some must-be-a mustnt-be-a print format km-format an instance @ retain-expr
;	sometimes
	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 :default
	showme-here showme showme-all evaluate-all quote
	delete evaluate has-value andify make-sentence make-phrase #|pluralize|#
	every has now-has also-has also-hasnt now-has-definition
	must is-superset-of covers subsumes has-definition numberp bag seq #|override|#
	no-inheritance comm get-justification
	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))

(defparameter *km-lisp-exprs*  		;; KM functions which should function both at the KM> and Lisp prompt.
					;; Note these ALL RETURN (t), hence new-situation and global-situation are not here.
  '(save-kb reset-kb write-kb fastsave-kb fastload-kb faslsave-kb load-newest-kb load-triples orphans
    show-context checkkbon checkkboff show-bindings version dereference-kb
    show-obj-stack clear-obj-stack reset-done kb-size
    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 set-checkpoint
    start-creations-logging stop-creations-logging set-creations-checkpoint undo-creations
    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 
    eval setq tracekm untracekm license enable-slot-checking disable-slot-checking
    comments nocomments 
    trace-to-file-on trace-to-file-off t2f-on t2f-off     ;;; From Raphael Van Dyck, for switching tracing on to a file
    ))

(defparameter *downcase-km-lisp-exprs* 
    (mapcar #'(lambda (expr) (intern (string-downcase expr) *km-package*)) *km-lisp-exprs*))

;;; Directs KM to use process-load-expression for these commands used at the KM prompt
(defparameter *loadsave-commands-with-keywords*
    '(load-kb #$load-kb reload-kb #$reload-kb save-kb #$save-kb fastsave-kb #$fastsave-kb
      fastload-kb #$fastload-kb faslsave-kb #$faslsave-kb write-kb #$write-kb load-newest-kb #$load-newest-kb))

;;; Don't strip out (@ ...) structures for lists beginning with these items.
(defparameter *no-decomment-headwords* '#$(comment show-comment explanation))

;;; 10/28/02: These are calls where all the subcalls are direct calls to km-int, so we can defer decommenting down 
;;; to there for the elements. i.e., we DON'T decomment the embedded structures when passing to km-int
;;; (defparameter *decomment-top-level-only-headwords* '#$(:set if))
(defparameter *decomment-top-level-only-headwords* 
    '#$(if forall allof oneof theoneof forall-seq forall-bag
	forall2 allof2 oneof2 theoneof2 forall-seq2 forall-bag2
	:set :seq :bag :args :triple :pair :function
	))

; from frame-io.lisp, as we want to reference it here
(defparameter *built-in-classes-with-nonfluent-instances-relation* '#$(Situation Slot Partition Theory))
(defparameter *built-in-nonfluent-lookup-only-slots* nil)  ; then setq it later in frame-io.lisp

; No longer used...
;;; For annotation in explain.lisp
;;; Format (<pattern> <vars-to-annotate>). Note a var will only be annotated providing it's a list.
;(defvar *patterns-to-annotate* 
;    '#$(((the ?x of ?y) (?y))
;	((the ?x ?y of ?z) (?z))))

;;; --------------------
;;; Change to 'error for test-suite
(defparameter *top-level-fail-mode* 'fail)
(defun fail-noisily () (km-setq '*top-level-fail-mode* 'error) t)
(defun fail-quietly () (km-setq '*top-level-fail-mode* 'fail) t)

(defconstant *default-fail-mode* 'fail)
(defvar *am-reasoning* nil)

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

;;; Backwards-compatibility: (km0 ...) now synonymous with (km ...)
(defun km0 (&optional (kmexpr 'ask-user) &key (fail-mode (cond (*am-reasoning* *default-fail-mode*)
							       (t *top-level-fail-mode*))))
  (km kmexpr :fail-mode fail-mode))

;;; The top level call, either by person or machine
;;; RETURNS 3 values:
;;;        - result of evaluating <expr>
;;;	   - if an error occurred, a string describing it
;;;	   - if an error occurred, a structure describing it
;;; NOTE: If *am-reasoning*, then km is equivalent to km-int
;;; [1] NOTE: internal calls WILL do the dereferencing automatically, but the TOP LEVEL call may not, so need to
;;;	do it here. Otherwise, the looping detector will trigger, as looping-on now (KM 2.3.4) does a dereference:
;;;		1 -> (the parts of _X)
;;;		2  -> (the parts of _Engine1)
;;;		      Looping on the parts of _Engine1!
(defun km (&optional (kmexpr 'ask-user) &key (fail-mode (cond (*am-reasoning* *default-fail-mode*)
							      (t *top-level-fail-mode*))) 
					     (reset-statistics t))
; (km-format t "fail-mode = ~a~%" fail-mode)
  (cond 
   ((eq kmexpr 'ask-user) (km-read-eval-print))
   (*am-reasoning* (km-int kmexpr :fail-mode fail-mode)) ; km -> km-int if *am-reasoning* already
   (t (let ((*am-reasoning* t)		; so must be top-level KM call
	    (*warnings* nil)
	    (*errors* nil)
	    (*error-structures* nil))
	(reset-for-top-level-call kmexpr :reset-statistics reset-statistics)
	(let* ((answer0 (catch 'km-abort (desource (km-int (dereference kmexpr) :fail-mode fail-mode))))  ; [1]
	       (answer (cond ((and (listp answer0) (eq (first answer0) 'km-abort)) 
			      (km-format t "(Execution aborted)~%")
			      nil)	; user or KM abort
			     (t answer0))))
	  (cond ((and (null *errors*)
		      (null *error-structures*)
		      (null *warnings*))
		 answer)
		(t (values answer (reverse *errors*) (reverse *error-structures*) (reverse *warnings*)))))))))

;;; [1] See cache-problem.km in test-suite. (reset-done) might be rather inefficiently implemented (?).
;;; [2] For load-kb, load-kb does a (reset-inference-engine) right at the start, and then for specific KM calls
;;;	within load-kb we keep statistics counters going (skip redoing (reset-inference-engine) for each KM call)
(defun reset-for-top-level-call (km-expr &key (reset-statistics t))
;  (km-format t "Resetting for top level call...~%")
  (cond (reset-statistics (reset-inference-engine)))	; [2]
  (cond (*looping*			; better: Only need to reset the cache if you were looping.
	 (reset-done) (setq *looping* nil)))
  (cond ((and km-expr (am-in-prototype-mode)) ; cosmetic: Store prototype build commands and print out if you do a save-kb
	 (add-to-prototype-definition *curr-prototype* km-expr))) 
  (cond ((and km-expr (km-assertion-expr km-expr)) (reset-done) #|(clear-cached-explanations)|#))) ; [1]

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

(defvar *last-question* nil)		; so we can simply ask "why" rather than "why" with a whole list of arguments
(defvar *last-answer* nil)		; so we can simply ask "why" rather than "why" with a whole list of arguments

#|
21Aug2006
Thanks to Raphael Van Dyck for these improvements!

The KM read-eval-print loop doesn't work well in Lispworks, especially when km
enters the debugger.
The problem arises because a T stream argument is often used in km functions and a T stream
hasn't the same meaning in all the IO CL functions: 
- For the CL function format, a stream agument of t means writing to the standard output.
- For the CL functions write, prin1, print, pprint and princ, a stream argument of t means
writing to the terminal.
- For the CL function read, a stream argument of t means reading from the terminal.

The km read-eval-print loop should probably always write to the standard output and
read from the standard input.
Consequently this patch passes a stream argument of nil instead of t to the
functions write, prin1, print, pprint, princ and read.
This patch also adds a fresh-line after the case-sensitive-read-km in the rep loop. This
is because in Lispworks the read function returns as soon as the expression is complete,
causing the value of the expression to be printed on the same line as the expression.

Note
Maybe some other KM functions will need to be fixed in the same way.

[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.
|#
(defun km-read-eval-print ()
  (loop
   (reset-inference-engine)
   (print-km-prompt)
   (finish-output)			; flush output if stream is buffered
   (let ( (query (case-sensitive-read-km)) )
     ;; RVA 21Aug2006
     ;; added fresh-line because in lispworks the read function returns the expression as soon as it is complete,
     ;; before the user has pressed the return key
     (fresh-line)
     (cond ((minimatch query '#$(the ?slot of ?expr)) (setq *last-question* query)))
     (cond ((eq query '#$q) (return))
	   (t (cond ((not (skip-checkpoint query)) (set-checkpoint query)))		; [1]
	      (multiple-value-bind
	       (answer error)
	       (km-eval-print query)
	       (values answer error)))))))

(defun skip-checkpoint (query)
  (and (listp query)
       (member (first query) '#$(showme undo why))))

;;; Print out answer...(also reset counters and checkpoint)
(defun km-eval-print (query &key (fail-mode *top-level-fail-mode*))
  (cond ((null query) nil)
	((equal query '#$(undo))
	 (cond ((undo-possible)
		(let* ( (undone-command (undo)) )
		  (km-format t "Undone ~a...~%~%" undone-command) '#$(t)))
	       (t (km-format t "Nothing more to undo!~%~%"))))
       (t ; (reset-done) ;;; moved to km-eval, below. Calls to km-eval and km-eval-print MUST have same behavior!
	   (multiple-value-bind
	       (answer error error-str)
;	       (km-eval query :fail-mode fail-mode)
	       (km query :fail-mode fail-mode)		; phase out km-eval
	     (declare (ignore error-str))
	     (cond (*add-comments-to-names* (write-km-vals answer))
		   (t (km-format t "~a" answer)))
	     (cond (error (format t "   ; (WARNING: Errors occurred during reasoning)~%"))
		   (t (terpri)))
	     (princ (report-statistics))
;;;        (cond (*frame-accessp* (report-frame-access-count)))
	    (terpri)
	    (cond ((minimatch query '#$(the ?slot of ?expr)) (setq *last-answer* answer)))
	    (values answer error)))))

#|
Call to km-int: 
answer = EITHER the answer
         OR a list of three things: (km-abort <error-str> <error-struct>)
RETURNS 3 values:
        - result of evaluating <expr>
	- if an error occurred, a string describing it
	- if an error occurred, a structure describing it
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.
|#

;;; NEW: Make km-eval synonymous with km. Phase out km-eval in the code at a later time
; (defun km-eval (km-expr &key (fail-mode *top-level-fail-mode*)) (km km-expr :fail-mode fail-mode))

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

(defun print-km-prompt (&optional (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!~%"))
;  (cond ((and (am-in-prototype-mode) (am-in-local-situation)) (km-format stream "[prototype-mode, ~a] KM> " (curr-situation)))
        ((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
;;;  (km-int <expr>) is the recursive to KM *internal* to the KM Engine
;;; ======================================================================

;;; 		(km-int <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.

(defvar *spypoints* nil)
(defvar *profiling* nil)

;;; For Jason Chaw. Accessors in trace.lisp
(defvar *silent-spypoints* nil)
(defvar *silent-spypoints-log* nil)
(push '*silent-spypoints* *km-runtime-variables*)
(push '*silent-spypoints-log* *km-runtime-variables*)

#|
Called by lazy-unify, where we want to look like trace-expr has gone through km-int, 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.
|#
(defun km-int-with-trace (trace-expr kmexpr &key (fail-mode *default-fail-mode*) (check-for-looping t) target)
  (prog2
      (push-to-goal-stack trace-expr :target target)
      (let* ((users-goal (km-trace 'call "-> ~a" trace-expr))
	     (answer (cond ((eq users-goal 'fail) nil)
			   (t (km-int kmexpr :fail-mode fail-mode :check-for-looping check-for-looping :target target))))
	     (users-response (cond ((or answer 		
					(not (km-boolean-exprp kmexpr)))
				    (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)
	       (km-int-with-trace trace-expr kmexpr :fail-mode fail-mode :check-for-looping check-for-looping :target target))
	      ((eq users-response 'fail) nil)
	      (t answer)))
    (pop-from-goal-stack)))

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

;;; Wrapper, to maintain a stack and check for looping
#|
 kmexpr-with-comments is the expression passed to km-int. It may include comments.
 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)
|#
(defun km-int (kmexpr-with-comments &key (fail-mode (cond (*am-reasoning* *default-fail-mode*)
							  (t *top-level-fail-mode*))) 
					 (check-for-looping t) target rewritep)
;  (cond ((null kmexpr-with-comments) (break)))
  (cond 
   ((null *am-reasoning*) (km kmexpr-with-comments :fail-mode fail-mode)) ; eg. top-level (in-situation <x>) calls km-int

;;;   FAILED similification
   (t (let*
	  ((kmexpr 
	     (cond ((km-assertion-expr kmexpr-with-comments) ; (every Car has (parts ((a Engine [Car1])))
		    (desource+decomment-top-level kmexpr-with-comments)) ; NB leave embedded comments in here
		   ((and (listp kmexpr-with-comments) ; (comment [Cat1] "a cat" "people like cats")
			 (or (member (first kmexpr-with-comments) *no-decomment-headwords*)
			     (and (eq (first kmexpr-with-comments) '#$in-situation)
				  (listp (third kmexpr-with-comments))
				  (member (first (third kmexpr-with-comments)) *no-decomment-headwords*))))
		    kmexpr-with-comments)
		   ((or			; for these cases we DON'T want to decomment the embedded comments, they're 
					; need as the expr is broken up
		     (and target	; target= (the pets of Pete)
			  (record-explanation-later kmexpr-with-comments)) ; ((a Cat [Cat1]) & (a Pet [Pet1]))
		     (and (listp kmexpr-with-comments)
			  (member (first kmexpr-with-comments) *decomment-top-level-only-headwords*)))
		    (desource+decomment-top-level kmexpr-with-comments))
;;; NEW: Decomment *everything* ONLY at the top level		   
		   (t (desource-top-level (decomment kmexpr-with-comments))))

;;; Why did I comment this out? Reinstate bits of it above...
	#|
             (cond ((or (km-assertion-expr kmexpr-with-comments) ; (every Car has (parts ((a Engine [Car1])))
			     (and target 							; target=(the pets of Pete)
				  (record-explanation-later kmexpr-with-comments))  		; ((a Cat [Cat1]) & (a Pet [Pet1]))
			     (and (listp kmexpr-with-comments)
				  (member (first kmexpr-with-comments) *decomment-top-level-only-headwords*))
;			     (let ((kmexpr0 (desource+decomment-top-level kmexpr-with-comments)))
;			       (some #'(lambda (pattern+vars) ; patterns by definition don't have top-level annotated
;					 (minimatch kmexpr0 (first pattern+vars)))
;				     *patterns-to-annotate*))
			     )
			   (desource+decomment-top-level kmexpr-with-comments))
		     ((and (listp kmexpr-with-comments) ; (comment [Cat1] "a cat" "people like cats")
			   (or (member (first kmexpr-with-comments) *no-decomment-headwords*)
			       (and (eq (first kmexpr-with-comments) '#$in-situation)
				    (listp (third kmexpr-with-comments))
				    (member (first (third kmexpr-with-comments)) *no-decomment-headwords*))))
		      kmexpr-with-comments)
		     (t (desource+decomment kmexpr-with-comments)))
|#
        ))

;    (km-format t "~%kmexpr-with-comments:~%  ~a~%" kmexpr-with-comments)
;    (km-format t "kmexpr-without-assignment:~% ~a~%" kmexpr-without-assignment)
;    (km-format t "kmexpr (to actually process):~% ~a~%" kmexpr)
  (cond ((and *spypoints*
	      (some #'(lambda (spypoint) (minimatch kmexpr spypoint)) *spypoints*))
	 (km-format t "(Spypoint reached!)~%")
	 (tracekm)))
  (cond ((and *silent-spypoints*
	      (some #'(lambda (spypoint) (minimatch kmexpr spypoint)) *silent-spypoints*))
	 (push kmexpr *silent-spypoints-log*)))
  (cond ((and (not *are-some-constraints*) (constraint-exprp kmexpr)) (note-are-constraints)))
  (cond
   ((member kmexpr '#$((tracekm) (TRACEKM) (trace) (TRACE)) :test #'equal) 
    (reset-trace-depth)
    (tracekm)
    '#$(t))
   ((member kmexpr '#$((untracekm) (UNTRACEKM) (untrace) (UNTRACE)) :test #'equal) 
    (reset-trace-depth)
    (untracekm)
    '#$(t))
   ((and (listp kmexpr)				; handle case-sensitivity for keywords in load-kb
	 (member (first kmexpr) *loadsave-commands-with-keywords*))
    (process-load-expression kmexpr))
   ((and (listp kmexpr) (member (first kmexpr) *km-lisp-exprs*)) 
;   (eval kmexpr) '#$(t) ; old
    (let ((answer (listify (eval kmexpr))))
      (cond ((and (null answer) 
		  (eq fail-mode 'error)
		  (not (and (triplep kmexpr) (eq (first kmexpr) 'setq))))
	     (report-error 'user-error "No values found for ~a!~%" kmexpr)))
      answer))
   ((and (listp kmexpr) (member (first kmexpr) *downcase-km-lisp-exprs*)) 
;   (eval (cons (intern (string-upcase (first kmexpr)) *km-package*) (rest kmexpr))) '#$(t) ; old
    (let ((answer (listify (eval (cons (intern (string-upcase (first kmexpr)) *km-package*) (rest kmexpr)))))) ; new
      (cond ((and (null answer) 
		  (eq fail-mode 'error)
		  (not (and (triplep kmexpr) (eq (first kmexpr) '#$setq))))	     
	     (report-error 'user-error "No values found for ~a!~%" kmexpr)))
      answer))
   ((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!~%"))
   ((or (null kmexpr)   	 ; fast handling of these special cases, copied from *km-handler-function*
	(eq kmexpr '#$nil)	 ; This IS allowed to fail quietly
	(and (constraint-exprp kmexpr)
	     (not (retain-exprp kmexpr))))
    (cond ((eq fail-mode 'error) (report-error 'user-error "No values found for ~a!~%" kmexpr)))
    nil)
   ((and (atom kmexpr)
	 (not (no-reserved-keywords (list kmexpr))))	; User error! Contains keywords, so fail out
    nil)
   ((km-varp kmexpr)
    (report-error 'user-error "Unbound variable ~a encountered!~%" kmexpr))
   ((and  ; (fully-evaluatedp kmexpr)  ; fast handling, & don't clutter up the program trace with reflexive calls
	    (fully-evaluatedp kmexpr-with-comments) ; NEW: Need to pass through interpreter to catch explanation
     (eql (dereference kmexpr) kmexpr))	; Is this the reflexive case? see
    (cond ((km-setp kmexpr) (set-to-list kmexpr))
	  ((and (listp kmexpr) 
		(eq (first kmexpr) '#$:triple)
		(not (= (length (rest kmexpr)) 3))
		(report-error 'user-error "~a: A triple should have exactly three elements!~%" kmexpr)))
	  ((and (listp kmexpr) 
		(eq (first kmexpr) '#$:pair)
		(not (= (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)
    (let ( (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))			; LOOPING! Defined in stack.lisp
    (km-trace 'comment "Looping on ~a!" kmexpr)
;    (break)
    (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 (prog2
	  (push-to-goal-stack kmexpr-with-comments :target target)
	  (km1 kmexpr kmexpr-with-comments :fail-mode fail-mode :target target :rewritep rewritep)
	(pop-from-goal-stack))))))))

;;; ----------------------------------------
;;;	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.
(defun handle-looping (kmexpr &key (reason 'loop-detected))
  (setq *looping* t)
  (let ( (cexpr (canonicalize kmexpr)) )
    (cond ((and (minimatch cexpr '#$(the ?slot of ?instance))  ; SPECIAL CASE: (the <slot> of <instance>)
		(symbolp (second cexpr))			 ; Do the best you can (even if incomplete!)
;	        (is-km-term (fourth cexpr)))		; [1] (see below)
		(kb-objectp (fourth cexpr)))		; [1] (see below)
	   (let* ( (instance (fourth cexpr))
		   (slot (second cexpr))
; [2]		   (vals (get-vals instance slot)) )	; no remove-constraints, as [1] prevents exprs with constraints in ; 5/3/01 - how???
		   (vals (get-vals instance slot :situation (target-situation (curr-situation) instance slot))) ) ; no remove-constraints, as [1] prevents exprs 
	     (km-trace 'comment "Just using values found so far, = ~a..." vals)					  ; with constraints in ; 5/3/01 - how???
	     (cond ((every #'fully-evaluatedp vals) vals)
		   (t (let ((kmexpr2 (vals-to-val vals))) ; vals may be an expression! ? see test-suite/looping.km
			(cond ((not (looping-on kmexpr2))  ; very important!!!!
			       (let ((new-vals (km-int kmexpr2))) 

;			       (let ((new-vals (prog2   ; No  don't stack - will ALWAYS seem like looping!
;						   (push-to-goal-stack kmexpr2)    ; NOTE: must stack to spot looping during looping
;						   (km-int kmexpr2)	; recovery
;						 (pop-from-goal-stack))))

				 (cond ((not (dont-cache-values-slotp slot))
;			       (put-vals instance slot new-vals :install-inversesp nil))) ; constraints will be added + note-done when loop is unwound
;;; No: The "nil" causes a bug - see inverses-bug.km in test-suite
					(put-vals instance slot new-vals))) ; constraints will be added + note-done when loop is unwound
				 new-vals)))))))) ;						to upper calling level
	  ((and (listp kmexpr)		; &-exprp too specific; want to include &? and &+? also
		(val-unification-operator (second kmexpr))) ; (a &/&?/&! b): Inductive proof: Can assume (X &? Y) when proving (X &? Y)
	   (cond ((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))))			; Very questionable assumption!
		 (t (let ( (val (find-if #'kb-objectp (&-expr-to-vals kmexpr))) )	; find first fully evaluated val
		      (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)
	   (let ( (answer (find-if #'(lambda (set) (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:
;(defvar *trace-log* nil)		 ; **** NEW LINE
;(defvar *trace-log-on* nil)		 ; **** another NEW LINE

(defvar *print-explanations* nil)
(defvar *catch-explanations* nil)
(defvar *catch-next-explanations* nil)
(defvar *explanations* nil)

;;; (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
(defun km1 (kmexpr kmexpr-with-comments &key (fail-mode *default-fail-mode*) target rewritep)
  (increment-inference-statistics)
  (cond (*profiling* (profile-call (desource kmexpr))))
;  (if (and *trace-log-on* (not *am-classifying*))								; **** another NEW LINE
;      (setq *trace-log* (cons `(,(1+ *depth*) call ,kmexpr-with-comments) *trace-log*))) ; **** NEW LINE
  (let* ( 
	(users-goal (cond (target (km-trace 'call "-> ~a~40T [for ~a]"  				; "-> (a Car)  [for (the parts of _Car3)]"
				     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)))))
    (declare (ignore dummy))
    (multiple-value-bind
     (answer0 handler-pattern)				; handler-pattern now used
     (cond ((eq users-goal 'fail) nil)
	   ((atom kmexpr) (list kmexpr))		; [2]: Checks for keywords and add-to-obj-stack in km [1] above
	   (*compile-handlers* (funcall *km-handler-function* fail-mode target kmexpr)) ; COMPILED DISPATCH MECHANISM
	   (t (let* ( (handler (find-handler kmexpr *km-handler-alist*))  ; INTERPRETED DISPATCH MECHANISM
		      (answer00 (apply (first handler) `(,fail-mode ,target ,@(second handler))))
		      (pattern (third handler)) )
		(values answer00 pattern))))
     (let ( (answer (remove-dup-instances (remove nil answer0))))		; NOTE includes dereferencing
       (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 :rewritep rewritep)))))

;;; This allows handling of redo and fail options when tracing.
(defun process-km1-result (answer kmexpr kmexpr-with-comments &key (fail-mode *default-fail-mode*) target handler-pattern rewritep)
 (mapc #'(lambda (val) (cache-explanation-for val kmexpr)) answer) ; NOW: store the *decommented* version. NB kmexpr isn't
 (cond ((and target						   ;      fully decommented for (a ... with ...) exprs
	     (not rewritep)				; don't record all the rewrites
	     *record-explanations*
	     (not (record-explanation-later kmexpr-with-comments)) )
	(mapc #'(lambda (val) (record-explanation-for target val kmexpr-with-comments)) answer)))
 (cond ((and (not rewritep)
	     *record-explanations*
	     (existential-exprp kmexpr))
	(cond 
	 ((not (singletonp answer))
	  (report-error 'program-error "Multiple values from an existential expr ~a!~%" kmexpr))
	 (t (let ((class (second kmexpr))) ; (a Car [with ...])
	      (record-explanation-for `#$(the instance-of of ,(FIRST ANSWER)) class kmexpr-with-comments)))))) 
; (if (and *trace-log-on* (not *am-classifying*)) ; **** another NEW LINE
;      (setq *trace-log* (cons `(,*depth* exit ,kmexpr-with-comments ,answer) *trace-log*))) ; **** NEW LINE
 (cond ((or *catch-explanations* *print-explanations*) (catch-explanation kmexpr-with-comments (cond (answer 'exit) (t 'fail)))))
 (cond (*profiling* (profile-exit (desource kmexpr))))
 (let ( (users-response
	 (cond ((or answer (not (km-boolean-exprp kmexpr)))
		(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 :rewritep rewritep))
	  ((eq users-response 'fail)					; resets answer to be NIL [doesn't destroy cached non-nil answers though!]
	   (increment-trace-depth)					; put *depth* back to where it was
	   (process-km1-result nil kmexpr kmexpr-with-comments 
			       :fail-mode fail-mode :target target :handler-pattern handler-pattern))
	  (t answer))))

;;; ----------------------------------------
;;; km-unique: Expected to return EXACTLY *one* value, otherwise a warning is generated.
;;; ----------------------------------------

;;; Backwards-compatibility: (km-unique0 ...) now synonymous with (km-unique ...)
(defun km-unique0 (kmexpr &key (fail-mode (cond (*am-reasoning* *default-fail-mode*)
							       (t *top-level-fail-mode*))))
  (km-unique kmexpr :fail-mode fail-mode))

;;; EXTERNAL, from some other application - rewritten 1/19/08 to be identical in structure to (defun km ...)
;;; [1] must dereference top-level call to make sure looping isn't accidentally mis-triggered [see (defun km ...) comment]
(defun km-unique (kmexpr &key (fail-mode (cond (*am-reasoning* *default-fail-mode*)
					       (t *top-level-fail-mode*)))) 
  (cond
   (*am-reasoning* (km-unique-int kmexpr :fail-mode fail-mode)) ; km-unique -> km-unique-int if *am-reasoning* already
   (t (let ((*am-reasoning* t)		; so must be top-level KM call
	    (*warnings* nil))
	(reset-for-top-level-call kmexpr)
	(let ((answer (catch 'km-abort (desource (km-unique-int (dereference kmexpr) :fail-mode fail-mode))))) ; [1]
	  (cond ((and (listp answer)
		      (eq (first answer) 'km-abort)) ; error encountered
		 (values nil (second answer) (third answer) (reverse *warnings*)))
		(*warnings* (values answer nil nil (reverse *warnings*)))
		(t answer)))))))

#|
;;; EXTERNAL, from some other application
(defun km-unique (kmexpr &key (fail-mode *top-level-fail-mode*))
  (reset-inference-engine)
  (let ( (answer (catch 'km-abort (km-unique-int kmexpr :fail-mode fail-mode))) )
    (cond ((and (pairp answer)
		(eq (first answer) 'km-abort))		; error encountered
	   (values nil (second answer)))
	  (t answer))))
|#

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

;;; INTERNAL, from within KM itself.
(defun km-unique-int (kmexpr &key (fail-mode (cond (*am-reasoning* *default-fail-mode*)
						   (t *top-level-fail-mode*))) 
				  target rewritep)
  (cond 
   ((null *am-reasoning*) (km-unique kmexpr :fail-mode fail-mode))  ; if called from top-level call (in-situation ...) say
   (t (let ( (vals (km-int kmexpr :fail-mode fail-mode :target target :rewritep rewritep)) )
    (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)))
(defun process-load-expression (load-expr0)
  (let* ((load-expr1 (sublis '((#$:verbose . :verbose)				; :verbose -> :VERBOSE etc.
			       (#$:eval-instances . :eval-instances)
			       (#$:with-morphism . :with-morphism)
			       (#$:load-patterns . :load-patterns)
			       (#$:reset-kb . :reset-kb)
			       (#$:force-fkm . :force-fkm)
			       (#$:compile . :compile)
			       (#$:include-explanationsp . :include-explanationsp)
			       (#$t . t))
			     load-expr0))
	(load-expr (cons (intern (string-upcase (first load-expr1)) *km-package*) ; (|load-kb| ...) -> (LOAD-KB ...)
			 (rest load-expr1))))
;    (km-format t "load-expr = ~a~%" load-expr)
    (multiple-value-bind
	(result error)
	(eval load-expr)
      (declare (ignore result))
      (cond (error (princ error) (throw 'km-abort (list 'km-abort error))) ; (format t "~/home") gives format 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!

;; split this list initialization into 2, since ABCL can't handle such a long structure def
(setf
  *km-handler-alist1*
  '(
;;; [1] NEW: Here make another top level call, so 
;;;	(i) the trace is easier to follow during debugging
;;;	(ii) the looping checker jumps in at the right moment
;;; [2] This is a bit of a hack; with looping, e.g. another query higher in the stack for (((a Cat)) && (the cats of Sue)),
;;;     KM may possibly return structured answers e.g. ((a Cat) (the cats of Sue)). Need to remove the non-evaluated ones (urgh).
;;;     See test-suite/restaurant.km for the source of this patch.
;;; [3] New! Remove the transitivity incompleteness described in the user manual
    ( (#$the ?slot #$of ?frameadd)  
      (lambda (fmode0 _target slot frameadd)
	(declare (ignore _target))
;	(cond ((neq slot '#$instances) (check-situations-mode))) ; allow query for instances to slip through, for internal (all-instances) queries
	(cond ((structured-slotp slot)
	       (follow-multidepth-path (km-int frameadd :fail-mode fmode0)   ; start-values
				   slot '* :fail-mode fmode0))	     ; target-class = *
	      ((pathp slot)
	       (let ( (eval-slot (km-unique-int slot :fail-mode 'error)) )
		 (km-int `#$(the ,EVAL-SLOT of ,FRAMEADD) :fail-mode fmode0)))
	 (t  ; (km-format t "frameadd = ~a~%" frameadd)
	  (let* ( (fmode (cond ((built-in-aggregation-slot slot) 'fail)
				      (t fmode0)))
; OLD			 (frames (km-int frameadd :fail-mode fmode)) )
; Now we at least see the looping and collect cached values
 			 (frames (cond ((every #'is-simple-km-term (val-to-vals frameadd))		; [4]
;					(km-format t "Infinite recursion avoided for ~a!~%" `#$(the ,SLOT of ,FRAMEADD))   
					(remove-dup-instances (val-to-vals frameadd)))		; includes dereferencing
				       (t (km-int frameadd :fail-mode fmode :check-for-looping nil)))) ) 	; [3]
		   (cond ((= *depth* 1) (setq *last-question* `(#$the ,slot #$of ,(vals-to-val frames)))))	; for explanation
		   (cond ((not (equal frames (val-to-vals frameadd)))
			  (remove-if-not #'is-km-term (km-int `#$(the ,SLOT of ,(VALS-TO-VAL FRAMES)) :fail-mode fmode)))	; [1], [2]
			 (t (remove-if-not #'is-km-term (km-multi-slotvals frames slot :fail-mode fmode)))))))) )	; [2]

; No, filter needs to be on ALL retrieved values, not just (the <slot> of <x>) expressions
;		   (let ((vals (cond ((not (equal frames (val-to-vals frameadd)))
;				      (remove-if-not #'is-km-term 
;					 (km-int `#$(the ,SLOT of ,(VALS-TO-VAL FRAMES)) :fail-mode fmode))) ; [1], [2]
;				     (t (remove-if-not #'is-km-term 
;						       (km-multi-slotvals frames slot :fail-mode fmode)))))) ; [2]
;		     (case slot
;		       (#$nowexists vals)
;		       (t (remove-if-not #'nowexists vals)))))))) )

    ( (#$a ?class)
      (lambda (_fmode target class) 
	(declare (ignore  _fmode)) 
	(list (create-instance class nil :target target))) )

    ( (#$a ?class #$called ?tag)
      (lambda (_fmode target class tag) 
	(declare (ignore  _fmode)) 
	(km-setq '*are-some-tags* t)
	(cond ((km-tagp tag) (list (create-instance class `((#$called ,(VAL-TO-VALS TAG))) :target target)))
	      (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 target 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))) :target target)))
	      (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 target class slotsvals) 
	   (declare (ignore _fmode)) 
	   (cond ((are-slotsvals slotsvals)
		  (let ( (instance (create-instance class (convert-comments-to-internal-form slotsvals) :target target)) )
		    (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths))))	; route through interpreter for tracing + loop detection
		    (list instance))))) )

    ( (#$a ?class #$uniquely-called ?tag #$with &rest)
      (lambda (_fmode target 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)) 
						    :target target)) )
		    (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths))))	; route through interpreter for tracing + loop detection
		    (list instance))))) )

    ( (#$a ?class #$called ?tag #$with &rest)
      (lambda (_fmode target 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))
						    :target target)) )
		    (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths))))	; route through interpreter for tracing + loop detection
		    (list instance))))) )

;;; ======================================================================
;;;		PROTOTYPES
;;; ======================================================================

    ( (#$a-prototype ?class)
      (lambda (fmode target class) 
	(km-int `#$(a-prototype ,CLASS with) :fail-mode fmode :target target :rewritep t)) )  ; rewrite, errors caught below

    ( (#$a-prototype ?class #$with &rest)
      (lambda (_fmode _target class slotsvals) 
	   (declare (ignore  _fmode _target)) 
	   (cond ((am-in-local-situation)
		  (report-error 'user-error "Can't enter prototype mode when in a Situation!~%"))
	         ((am-in-local-theory)
		  (report-error 'user-error "Can't enter prototype mode when in a Theory!~%"))	    
		 ((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 ('(a ,CLASS with ,@SLOTSVALS))))
						 ,(COND (SLOTSVALS `(prototype-scope ((the-class ,CLASS with ,@SLOTSVALS))))
							(T `(prototype-scope (,CLASS))))
						 ,@SLOTSVALS)
					     :prefix-string *proto-marker-string*	; ie. "_Proto"
					     :bind-selfp nil))				; bind-selfp = nil - PRESERVE "Self" in prototype-scope
		  (add-val *curr-prototype* '#$prototype-participants *curr-prototype*)		; consistency
		  (km-setq '*are-some-prototypes* t)		; optimization flag
		  (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 _target)
	(declare (ignore _fmode _target))
	(km-setq '*curr-prototype* nil)
	(global-situation)
	(new-context)
	'#$(t)) )

    ( (#$clone ?expr)
      (lambda (_fmode _target expr)
	(declare (ignore _fmode _target))
	(let ( (source (km-unique-int expr :fail-mode 'error)) )
	  (cond (source (list (clone source)))))) )

    ( (#$evaluate-paths) 
      (lambda (_fmode _target)
	(declare (ignore _fmode _target))
	(eval-instances)
	'#$(t)) )

    ( (#$default-fluent-status &rest)
      (lambda (_fmode _target rest)
	(declare (ignore _fmode _target))
	(default-fluent-status (first rest))) )

;;; ----------------------------------------------------------------------
;;; Type constraints don't get evaluated.

    ( (#$must-be-a ?class) 
      (lambda (_fmode _target _class) (declare (ignore  _fmode _target _class)) (note-are-constraints) nil))
    ( (#$possible-values ?values) 
      (lambda (_fmode _target _values) (declare (ignore  _fmode _target _values)) (note-are-constraints) nil))
    ( (#$excluded-values ?values) 
      (lambda (_fmode _target _values) (declare (ignore  _fmode _target _values)) (note-are-constraints) nil))

    ( (#$must-be-a ?class #$with &rest)
      (lambda (_fmode _target _class slotsvals) 
	   (declare (ignore  _fmode _target _class)) 
	   (are-slotsvals slotsvals)				; Syntax check
	   (note-are-constraints)
	   nil))

    ( (#$mustnt-be-a ?class) 
      (lambda (_fmode _target _class) 
	(declare (ignore  _fmode _target _class)) 
	(note-are-constraints) nil) )

    ( (#$mustnt-be-a ?class #$with &rest)
      (lambda (_fmode _target _class slotsvals) 
	   (declare (ignore  _fmode _target _class)) 
	   (are-slotsvals slotsvals)				; Syntax check
	   (note-are-constraints)
	   nil))

;;; New 1.4.0-beta10:
    ( (<> ?val) ; ie. means isn't val
      (lambda (_fmode _target _val) (declare (ignore  _fmode _target _val)) (note-are-constraints) nil)) 

    ( (#$no-inheritance) (lambda (_fmode _target) (declare (ignore _fmode _target))) nil )

    ( (#$constraint ?expr)			; constraints tested elsewhere
      (lambda (_fmode _target _expr)
	(declare (ignore _fmode _target _expr))
	(note-are-constraints) nil) )

    ( (#$set-constraint ?expr)			; constraints tested elsewhere
      (lambda (_fmode _target _expr)
	(declare (ignore _fmode _target _expr))
	(note-are-constraints) nil) )

    ( (#$set-filter ?expr)			; constraints tested elsewhere
      (lambda (_fmode _target _expr)
	(declare (ignore _fmode _target _expr))
	(note-are-constraints) nil) )

    ( (#$at-least ?n ?class)
      (lambda (_fmode _target _n _class)
	(declare (ignore _fmode _target _n _class))
	(note-are-constraints) nil) )

    ( (#$at-most ?n ?class)
      (lambda (_fmode _target _n _class)
	(declare (ignore _fmode _target _n _class))
	(note-are-constraints) nil) )

    ( (#$exactly ?n ?class)
      (lambda (_fmode _target _n _class)
	(declare (ignore _fmode _target _n _class))
	(note-are-constraints) nil) )

    ( (#$sanity-check ?expr)			; toggleable wrapper around constraints
      (lambda (fmode target expr)
	(cond (*sanity-checks* (km-int expr :fail-mode fmode :target target))
	 (t '#$(t)))) )
    
    ((#$retain-expr ?expr)
     (lambda (fmode target expr)
       (let ((instance (fourth target))
	     (slot (second target)))
	 (cond ((or (null target)
		    (notany #'(lambda (isv-explanation)
				(let ((explanation (explanation-in isv-explanation)))
				  (equal explanation `(#$retain-expr ,expr))))
			    (get-all-explanations instance slot)))
		(km-int expr :fail-mode fmode :target target))))) )

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

    ; ============================
    ; AUGMENTING MEMBER PROPERTIES
    ; ============================

    ( (#$every ?cexpr #$has &rest)
      (lambda (_fmode _target cexpr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (class (km-unique-int 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)		; check
		    (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 _target cexpr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (class (km-unique-int 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)		; check
		    (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*)))
;			   (setq *classes-using-assertions-slot* (cons class *classes-using-assertions-slot*))))
;			   (make-transaction `(setq *classes-using-assertions-slot* ,(cons 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 _target cexpr slotsvals)
	   (declare (ignore _fmode _target))
	   (let ( (class (km-unique-int 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)		; check
		    (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*)))
;			   (setq *classes-using-assertions-slot* (cons class *classes-using-assertions-slot*))))
;			   (make-transaction `(setq *classes-using-assertions-slot* ,(cons 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))))) )

    ; =========================
    ; AUGMENTING OWN PROPERTIES
    ; =========================

    ( (?instance-expr #$has &rest)
      (lambda (_fmode _target instance-expr slotsvals)
	   (declare (ignore _fmode _target))
	   (let ( (instance (km-unique-int 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)	; check
		    (add-slotsvals instance (convert-comments-to-internal-form slotsvals))
		    (make-assertions instance slotsvals)
		    (un-done instance)		; In case redefinition	  - now in put-slotsvals; Later: No!!
		    (classify instance :slots-that-changed (mapcar #'slot-in slotsvals))		; Because it's an instance
		    (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths))))	; route through interpreter for tracing + loop detection
		    (list instance))))) )
    )) ;; end part 1 of list init

(setf
 *km-handler-alist2* ;; part 2 of the list
 '(
    ( (?instance-expr #$also-has &rest)
      (lambda (_fmode _target instance-expr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (instance (km-unique-int 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)	; check
		    (add-slotsvals instance (convert-comments-to-internal-form slotsvals) :combine-values-by 'appending)
		    (un-done instance)		; In case redefinition	  - now in put-slotsvals; Later: No!!
		    (classify instance :slots-that-changed (mapcar #'slot-in slotsvals))		; Because it's an instance
		    (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths))))	; route through interpreter for tracing + loop detection
		    (list instance))))) )
    
    ((#$every ?instance-expr #$also-hasnt &rest)
     (lambda (_fmode _target instance-expr slotsvals)
       (declare (ignore  _fmode _target))
       (report-error 'user-error "~a:~%Can't use also-hasnt with an \"every\" expression (can only use it with instances, not classes)~%" `(#$every ,instance-expr #$also-hasnt ,@slotsvals))))

    ;;; USE WITH EXTREME CAUTION
    ( (?instance-expr #$also-hasnt &rest)
      (lambda (_fmode _target instance-expr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (instance (km-unique-int 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) ; check
		    (mapc #'(lambda (slotvals)
			      (let ((slot (slot-in slotvals))
				    (vals (vals-in slotvals)))
				(mapc #'(lambda (val)
					  (delete-val instance slot val))
				      vals)))
			  slotsvals)
		    (un-done instance)	; In case redefinition	  - now in put-slotsvals; Later: No!!
		    (list instance))))) )

;;; New, explicitly for Shaken. The new slotsvals OVERWRITE the old slotsvals, so must be used with extreme caution!
;;; Old inverses will also uninstalled providing they are fully-evaluated KB objects.
    ( (?instance-expr #$now-has &rest)
      (lambda (_fmode _target instance-expr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (instance (km-unique-int 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)	; check
		    (add-slotsvals instance (convert-comments-to-internal-form slotsvals) :combine-values-by 'overwriting)
; Neah, let's assume these things better not change!!
		    (un-done instance)		; In case redefinition	  - now in put-slotsvals; Later: No!!
		    (classify instance)		; Because it's an instance
;#|new|#	    (cond ((am-in-prototype-mode) 
;			   ; (eval-instances)
;			   (km-int '#$(evaluate-paths) :fail-mode 'error)))	; new: route through query interpreter for tracing and also loop detection
		    (list instance))))) )

    ;;; ----------------------------------------------------------------------
    ;;;	 UNIFICIATION - now off-load to special procedure in lazy-unify.lisp
    ;;; ----------------------------------------------------------------------

    ( (?xs && &rest)
      (lambda (fmode target xs rest)
	(declare (ignore fmode))
;	(km-format t "xs = ~a~%rest = ~a~%" xs rest)
	(lazy-unify-&-expr `(,xs && ,@rest) :fail-mode 'error :joiner '&& :target target)) )

    ( (?x & &rest)
      (lambda (fmode target x rest)
	(declare (ignore fmode))
	(lazy-unify-&-expr `(,x & ,@rest) :fail-mode 'error :joiner '& :target target)) )

    ( (?xs === &rest)
      (lambda (fmode target xs rest)
	(declare (ignore fmode))
	(lazy-unify-&-expr `(,xs === ,@rest) :fail-mode 'error :joiner '=== :target target)) )

    ( (?x == ?y)
      (lambda (fmode target x y)
	(declare (ignore fmode))
	(lazy-unify-&-expr `(,x == ,y) :fail-mode 'error :joiner '== :target target)) )

    ( (?x /== ?y)
      (lambda (fmode target x y)
	(declare (ignore fmode target))
	(let ( (xv (km-unique-int x :fail-mode 'error))
	       (yv (km-unique-int 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) (km-int `#$(,XV has (/== (,YV))) :fail-mode 'error))
		((kb-objectp yv) (km-int `#$(,YV has (/== (,XV))) :fail-mode 'error))
		('#$(t))))) )		; two distinct, non-KB objects eg. ("cat" /== "dog")

;;; These variants do eager unification
    ( (?xs &&! &rest)
      (lambda (fmode target xs rest)
	(declare (ignore fmode))
	(lazy-unify-&-expr `(,xs &&! ,@rest) :fail-mode 'error :joiner '&&! :target target)) )

    ( (?x &! &rest)
      (lambda (fmode target x rest)
	(declare (ignore fmode))
	(lazy-unify-&-expr `(,x &! ,@rest) :fail-mode 'error :joiner '&! :target target)) )

;;; NEW VERSION: Avoids creating then deleting the temporary frame
    ( (?x &? ?y)			; *tests* unification. No side effects. Returns a better unification expression if successful.
      (lambda (_fmode target x y)
	(declare (ignore _fmode target))
	(cond ((null x) '#$(t))
	      ((null y) '#$(t))
	      ((existential-exprp y) (let ( (xf (km-unique-int x)) )
					(cond ((null xf) '#$(t))
					      ((unifiable-with-existential-expr xf y) '#$(t)))))
	      ((existential-exprp x) (let ( (yf (km-unique-int y)) )
					(cond ((null yf) '#$(t))
					      ((unifiable-with-existential-expr yf x) '#$(t)))))
	      (t (let ( (xv (km-unique-int x)) )
		   (cond ((null xv) '#$(t))
			 (t (let ( (yv (km-unique-int y)) )
			      (cond ((null yv) '#$(t))
				    ((try-lazy-unify xv yv) '#$(t)))))))))))		; return "t" if successful

;;; SAME, but insist on classes-subsume constraint turned ON...

    ( (?x &+? ?y)			; *tests* unification. No side effects. Returns a better unification expression if successful.
      (lambda (_fmode target x y)
	(declare (ignore _fmode target))
	(cond ((existential-exprp y) (let ( (xf (km-unique-int x)) )
					(cond ((null xf) '#$(t))
					      ((unifiable-with-existential-expr xf y :classes-subsumep t) '#$(t)))))
	      ((existential-exprp x) (let ( (yf (km-unique-int y)) )
					(cond ((null yf) '#$(t))
					      ((unifiable-with-existential-expr yf x :classes-subsumep t) '#$(t)))))
	      (t (let ( (xv (km-unique-int x)) )
		   (cond ((null xv) '#$(t))
			 (t (let ( (yv (km-unique-int y)) )
			      (cond ((null yv) '#$(t))
				    ((try-lazy-unify xv yv :classes-subsumep t) '#$(t)))))))))))		; return "t" if successful

;;; ---------- Unification, but with classes-subsumep constraint turned ON

;;;; Unification, but with classes-subsumep constraint turned ON
;;; If unification fails, it returns NIL but no error is printed out.
;;; &+ is more restricted than & (at least for now), it won't nicely break up nested
;;; expressions.
    ( (?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))))) )

; No, test first before doing it, else you might leave side effects.
; **NOTE** Unlike &!, &+! *is* allowed to quietly fail   
    ((?x &+! ?y)
     (lambda (fmode target x y)
       (cond ((km-int `(,x &+? ,y) :target target :fail-mode fmode) ; must test before doing it, 
	      (km-int `(,x &! ,y) :target target :fail-mode 'error)) ; If &+? succeeds, route through query interpreter so pending-equality is seen. &! *must* succeed if &+? succeeds
	     ((eq fmode 'error) 
	      (report-error 'user-error "Unification (~a &+! ~a) failed!~%" x y)))))

; Attempt 2 
;    ((?x &+! ?y)
;     (lambda (fmode target x y)
;       (cond ((km-int `(,x &+? ,y) :target target :fail-mode fmode) ; must test before doing it, 
;	      (let ((unification (lazy-unify-exprs x y :classes-subsumep t :eagerlyp t :fail-mode fmode :target target)) )
;		(cond (unification (list unification))
;		      ((eq fmode 'error) 
;		       (report-error 'user-error "Unification (~a &+! ~a) failed!~%" x y))))))))

; Attempt 1 
;    ((?x &+! ?y)
;     (lambda (fmode target x y)
;	(let ( (unification (lazy-unify-exprs x y :classes-subsumep t :eagerlyp t :fail-mode fmode :target target)) )
;	  (cond (unification (list unification))
;		((eq fmode 'error) 
;		 (report-error 'user-error "Unification (~a &+! ~a) failed!~%" x y))))) )

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

;;; This is a special case where we do allow delistification.
;;;	"(the x of y) = z" is okay [strictly should be (the x of y) = (:set z)]
;;; [1] In computing yv, the binding of xv may have changed!
    ( (?x = ?y) (lambda (fmode target x y)
		     (declare (ignore target))
		     (let ( (xv (km-int x :fail-mode fmode))
			    (yv (km-int y :fail-mode fmode)) )
		       (cond ((km-set-equal (dereference xv) yv) '(#$t))))) )	; [1]

    ( (?x /= ?y) (lambda (fmode target x y)
		     (declare (ignore target))
		     (let ( (xv (km-int x :fail-mode fmode))
			    (yv (km-int y :fail-mode fmode)) )
		       (cond ((not (km-set-equal (dereference xv) yv)) '(#$t))))) )	; [1]

    ( (#$the ?class ?slot #$of ?frameadd)
      (lambda (fmode0 target class slot frameadd)
;	(cond ((neq slot '#$instances) (check-situations-mode))) ; allow query for instances to slip through, for internal (all-instances) queries
	   (cond ((structured-slotp slot)
		  (follow-multidepth-path (km-int frameadd :fail-mode fmode0 :target target :rewritep t)   ; start-values
				      slot class :fail-mode fmode0))
		 ((pathp slot)
		  (let ( (eval-slot (km-unique-int slot :fail-mode 'error)) )
		    (km-int `#$(the ,CLASS ,EVAL-SLOT of ,FRAMEADD) :fail-mode fmode0 :target target :rewritep t)))
		 (t (let* ( (fmode (cond ((built-in-aggregation-slot slot) 'fail)
					 (t fmode0))) )
		      (vals-in-class (km-int `#$(the ,SLOT of ,FRAMEADD) :fail-mode fmode :target target :rewritep t)
				     class))))) )

;;; ======================================================================
;;;		THEORIES - NEW 
;;; ======================================================================

    ( (#$in-theory ?theory-expr)
      (lambda (_fmode _target theory-expr)
	   (declare (ignore _fmode _target))
	   (in-theory theory-expr)) )

    ( (#$in-theory ?theory-expr ?km-expr)
      (lambda (_fmode _target theory-expr km-expr)
	   (declare (ignore _fmode _target))
	   (in-theory theory-expr km-expr)) )

    ( (#$hide-theory ?theory-expr)
      (lambda (_fmode _target theory-expr)
	(declare (ignore _fmode _target))
	(mapc #'hide-theory (km-int theory-expr))
	(cond ((visible-theories))
	      (t '#$(t))))) 

    ( (#$see-theory ?theory-expr)
      (lambda (_fmode _target theory-expr)
	(declare (ignore _fmode _target))
	(mapc #'see-theory (km-int theory-expr))
	(visible-theories)) )

    ( (#$end-theory)
      (lambda (_fmode _target)
	(declare (ignore _fmode _target))
	(in-situation *global-situation*)) )

    ( (#$visible-theories)
      (lambda (_fmode _target)
	(declare (ignore _fmode _target))
	(visible-theories)) )

;;; ======================================================================
;;;		SITUATIONS: Pass these KM commands straight to Lisp
;;; Note if these are issued directly from Lisp, then the KM exprs have to be quoted.
;;; ======================================================================

    ( (#$in-situation ?situation-expr)
      (lambda (_fmode _target situation-expr)
	   (declare (ignore _fmode _target))
	   (in-situation situation-expr)) )

    ( (#$in-situation ?situation (#$the ?slot #$of ?frame))	; special fast handling of this: If
      (lambda (_fmode _target situation slot frame)		; the slot-vals are already computed ([1])
	   (declare (ignore _fmode _target))			; then just do a lookup ([2])
	   (cond ((and (kb-objectp situation)
		       (isa situation '#$Situation)
; APR30		       (already-done frame slot situation))			; [1] 
		       (already-done frame slot))			; [1] 
#|OLD|#		  (remove-constraints (get-vals frame slot :situation (target-situation situation frame slot))))	; [2]
;#|NEW|#	  (get-vals-in-cache frame slot :situation situation))
		 (t (in-situation situation `#$(the ,SLOT of ,FRAME))))) )

    ( (#$in-situation ?situation-expr ?km-expr)
      (lambda (_fmode _target situation-expr km-expr)
	   (declare (ignore _fmode _target))
	   (in-situation situation-expr km-expr)) )

    ( (#$end-situation)
      (lambda (_fmode _target)
	(declare (ignore _fmode _target))
	(in-situation *global-situation*)) )

    ( (#$global-situation)
      (lambda (_fmode _target)
	(declare (ignore _fmode _target))
	(in-situation *global-situation*)) )

    ( (#$new-situation)
      (lambda (_fmode _target)
	(declare (ignore _fmode _target))
	(new-situation)) )			; NB returns a singleton list containing the new situation

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

    ( (#$do ?action-expr)
      (lambda (_fmode _target action-expr)
	   (declare (ignore _fmode _target))
	   (list (do-action action-expr))) )			; NB do-action returns a SINGLE value (a situation), not a list.

    ( (#$do ?action-expr ?next-situation)
      (lambda (_fmode _target action-expr next-situation)
	(declare (ignore _fmode _target))
	(cond ((not (instance-of next-situation '#$Situation))
	       (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" 
			     action-expr next-situation next-situation))
	      (t (list (do-action action-expr :next-situation next-situation))))) )
    
    ( (#$do-and-next ?action-expr)
      (lambda (_fmode _target action-expr)
	   (declare (ignore _fmode _target))
	   (list (do-action action-expr :change-to-next-situation t))) )

    ( (#$do-and-next ?action-expr ?next-situation)
      (lambda (_fmode _target action-expr next-situation)
	   (declare (ignore _fmode _target))
	(cond ((not (instance-of next-situation '#$Situation))
	       (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" 
			     action-expr next-situation next-situation))
	      (t (list (do-action action-expr :next-situation next-situation :change-to-next-situation t))))) )

;;; New
    ( (#$try-do ?action-expr)
      (lambda (_fmode _target action-expr)
	   (declare (ignore _fmode _target))
	   (list (do-action action-expr :test-or-assert-pcs 'test))) )		; NB do-action returns a SINGLE value (a situation), not a list.

    ( (#$try-do ?action-expr ?next-situation)
      (lambda (_fmode _target action-expr next-situation)
	(declare (ignore _fmode _target))
	(cond ((not (instance-of next-situation '#$Situation))
	       (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" 
			     action-expr next-situation next-situation))
	      (t (list (do-action action-expr :next-situation next-situation :test-or-assert-pcs 'test))))) )

    ( (#$try-do-and-next ?action-expr)
      (lambda (_fmode _target action-expr)
	   (declare (ignore _fmode _target))
	   (list (do-action action-expr :change-to-next-situation t :test-or-assert-pcs 'test))) )

    ( (#$try-do-and-next ?action-expr ?next-situation)
      (lambda (_fmode _target action-expr next-situation)
	(declare (ignore _fmode _target))
	(cond ((not (instance-of next-situation '#$Situation))
	       (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" 
			     action-expr next-situation next-situation))
	      (t (list (do-action action-expr :next-situation next-situation :change-to-next-situation t :test-or-assert-pcs 'test))))) )
    
    ( (#$do-concurrently ?action-expr)
     (lambda (_fmode _target action-expr)
       (declare (ignore _fmode _target))
       (let* ((actions (km-int action-expr))
	      (next-situation (km-unique-int `#$(do ,(FIRST ACTIONS)))))
	 (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) (rest actions))
	 (list next-situation))) )

    ( (#$do-concurrently ?action-expr ?next-situation)
     (lambda (_fmode _target action-expr next-situation)
       (declare (ignore _fmode _target))
	(cond ((not (instance-of next-situation '#$Situation))
	       (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" 
			     action-expr next-situation next-situation))
	      (t (let ((actions (km-int action-expr)))
		   (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) actions)
		   (list next-situation))))) )

    ( (#$do-concurrently-and-next ?action-expr)
     (lambda (_fmode _target action-expr)
       (declare (ignore _fmode _target))
       (let* ((actions (km-int action-expr))
	      (next-situation (km-unique-int `#$(do ,(FIRST ACTIONS)))))
	 (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) (rest actions))
	 (in-situation next-situation)
	 (list next-situation))) )

    ( (#$do-concurrently-and-next ?action-expr ?next-situation)
     (lambda (_fmode _target action-expr next-situation)
       (declare (ignore _fmode _target))
	(cond ((not (instance-of next-situation '#$Situation))
	       (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" 
			     action-expr next-situation next-situation))
	      (t (let ((actions (km-int action-expr)))
		   (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) actions)
		   (in-situation next-situation)
		   (list next-situation))))) )

;;; Now returns the list of successful actions
    ( (#$do-script ?script)
      (lambda (fmode target script)
	   (km-int `#$(forall (the actions of ,SCRIPT) (do-and-next It)) 
	       :fail-mode fmode :target target :rewritep t)) )

    ( (#$do-plan ?plan-instance-expr)
      (lambda (_fmode _target plan-instance-expr)
	(declare (ignore _fmode _target))
	(let ( (plan-instance (km-unique plan-instance-expr)) )
	  (do-plan plan-instance))) )			; defined in sadl.lisp

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

;;; Should even work for constraints
   ( (#$assert ?triple-expr)
      (lambda (_fmode _target triple-expr)
	(declare (ignore _fmode _target))
	(let ( (triple (km-unique-int 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 (km-int `#$(,(ARG1OF TRIPLE) has (,(ARG2OF TRIPLE) ,(VAL-TO-VALS (ARG3OF TRIPLE)))) :fail-mode 'error))))) )

    ( (#$is-true ?triple-expr)
      (lambda (_fmode _target triple-expr)
	(declare (ignore _fmode _target))
	(let* ( (triple (km-unique-int 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))
	    (km-int `#$(,(SECOND TRIPLE) ,(THIRD TRIPLE) ,(FOURTH TRIPLE))))
	   (t (let ( (frame (km-unique-int (second triple) :fail-mode 'error))
		     (slot  (km-unique-int (third triple) :fail-mode 'error))
		     (value (fourth triple)) )			; don't evaluate this!
		(cond 
		 ((null value) '#$(t))
		 ((km-int `#$(,FRAME is '(a Thing with (,SLOT (,VALUE)))))))))))) )

;		 ((constraint-exprp value)
;		  (km-int `#$(,FRAME &? (a Thing with (,SLOT (,VALUE))))))
;		 (t (km-int `#$((the ,SLOT of ,FRAME) includes ,VALUE))))))))) )

    ( (#$all-true ?triples-expr)
      (lambda (_fmode _target triples-expr)
	(declare (ignore _fmode _target))
	(let ( (triples (km-int triples-expr)) )
	  (cond ((every #'(lambda (triple)
			    (km-int `#$(is-true ,TRIPLE)))
			triples)
		 '#$(t))))))

    ( (#$some-true ?triples-expr)
      (lambda (_fmode _target triples-expr)
	(declare (ignore _fmode _target))
	(let ( (triples (km-int triples-expr)) )
	  (cond ((some #'(lambda (triple)
			   (km-int `#$(is-true ,TRIPLE)))
		       triples)
		 '#$(t))))))

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

    ( #$(next-situation)
	(lambda (_fmode _target)
	     (declare (ignore _fmode _target))
	     (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 _target)
	     (declare (ignore _fmode _target))
	     (list (curr-situation))) )

    ( (#$ignore-result ?expr)		; return t always
      (lambda (fmode target expr)
	(declare (ignore fmode target))
	(km-int expr) nil))

    ( (#$ignore ?expr)		; return t always
      (lambda (fmode target expr)
	(declare (ignore fmode target expr))
	nil))

    ; Important v1.3.8 addition!
    ; expr should be an assertional expression
    ( (#$in-every-situation ?situation-class ?expr)
      (lambda (fmode target 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 . #,Self) (Self . SubSelf)) km-expr)) )
		      (km-int `#$(in-situation ,*GLOBAL-SITUATION*
				(every ,SITUATION-CLASS has (assertions (',MODIFIED-EXPR)))) :fail-mode fmode
						:target target :rewritep t))))) )

;;; ======================================================================
;;;		CONTEXTS - Very experimental!!
;;; These are distinct from situations. A situation is a version of the KB.
;;; A context is where just the participant instances are visible.
;;; ======================================================================

    ( #$(new-context)
	(lambda (_fmode _target)
	     (declare (ignore _fmode _target))
	     (clear-obj-stack)			; NEW. Let obj-stack be the context
	     '#$(t)) )

;;; ======================================================================
;;;	the ordering of the remaining handers is arbitrary
;;; ======================================================================

;;; ========================================
;;;	QUICK SEARCH OF THE STACK (previously was "the" rather than "that")
;;; ========================================

;;; Now merged into the single framework of subsumption checking.
    ( (#$thelast ?frame)
      (lambda (_fmode _target frame) (declare (ignore  _fmode _target)) 
	   (let ( (last-instance (search-stack frame)) )
	     (cond (last-instance (list last-instance))))) )

;;; ========================================
;;;  FIND OBJECTS BY SUBSUMPTION CHECKING
;;; ========================================

    ( (#$every ?frame)
      (lambda (fmode target frame) (km-int `(#$every ,frame #$with) :fail-mode fmode :target target :rewritep t)) )

    ( (#$every ?frame #$with &rest)
      (lambda (_fmode _target frame slotsvals) 
	   (declare (ignore  _fmode _target))
	   (cond 
	    ((are-slotsvals slotsvals)
	     (let ( (existential-expr
		          (cond ((and (null slotsvals) (pathp frame)) 	  ; eg. (the (porter owns car))
				 (path-to-existential-expr frame))
				(t `(#$a ,frame #$with ,@slotsvals)))) )
	       (find-subsumees-on-object-stack existential-expr))))) )

;;; (the ...)  -- expects a unique answer

;;; REDEFINITIONS: 
;;;	(the ...) -> (find-the ...)
;;;	(forc (the ...)) -> (the ...)

;;; 2.29.00 - the below is more verbose,  to give better error messages during debugging.
;;; (The earlier version just send (the X) -> (the X with ...) -> (km-unique-int (every X with ...)), but then error messages were unintuitive)

    ( (#$the ?frame)
      (lambda (fmode target frame) 
	(declare (ignore fmode target))
	(let ( (answer (km-int `(#$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 target frame slotsvals)
	(declare (ignore fmode target))
	   (let ( (answer (km-int `(#$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)))))

;;; Find-or-create Three forms for forc:
;;; (forc (the (porter owns car)))		; (forc (the ...)) and (forc (a ...)) are synonymous
;;; (forc (the car with (owns-by (porter))))
;;; (forc (porter owns car)

;;; Rewrites, to allow path notation to be used...
    ( (#$the+ ?slot #$of ?frameadd)  
      (lambda (_fmode target slot frameadd)
	(declare (ignore _fmode))
	(km-int `#$(the+ Thing with (,(INVERT-SLOT SLOT) (,FRAMEADD))) :fail-mode 'error :target target :rewritep t)))

    ( (#$the+ ?class ?slot #$of ?frameadd)
      (lambda (_fmode target class slot frameadd)
	(declare (ignore _fmode))
	(km-int `#$(the+ ,CLASS with (,(INVERT-SLOT SLOT) (,FRAMEADD))) :fail-mode 'error :target target :rewritep t)))

   ( (#$the+ ?frame)
     (lambda (fmode target frame) (km-int `(#$the+ ,frame #$with) :fail-mode fmode :target target :rewritep t)) )

    ( (#$the+ ?frame #$with &rest)
      (lambda (_fmode _target frame slotsvals) 
	    (declare (ignore  _fmode _target))
;	    (cond 
;	     ((km-int `(#$the ,frame #$with ,@slotsvals)))	  ; OLD: (the ... with ...) *always* generates error on failure, so bypass this.
	    (let ( (val (km-unique-int `(#$every ,frame #$with ,@slotsvals))) )	; NEW		; PS don't surpress error for (the ...)!
	      (cond 
	       (val (list val))
	       ((are-slotsvals slotsvals)
		(let ( (existential-expr
			(cond ((and (null slotsvals) (pathp frame)) 	  ; eg. (a (porter owns car))
			       (path-to-existential-expr frame))
			      (t `(#$a ,frame #$with ,@slotsvals)))) )
		  (mapcar #'eval-instance (km-int existential-expr :fail-mode 'error))))))) )	; [1]

   ( (#$a+ &rest)							; a+ is synonym for the+
     (lambda (fmode target rest) (km-int `(#$the+ ,@rest) :fail-mode fmode :target target :rewritep t)) )

;;; [1] above: Do an eval-instance forces inverses in! For example, doing 
;;;    (the+ Leg with (part-of ((the Dog with (owned-by (Bruce))))))
;;; should not just return _Leg2, but also add (Bruce owns _Dog3), and (_Dog3 parts _Leg2)

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

    ; ==========================
    ; DEFINING MEMBER PROPERTIES
    ; ==========================

    ( (#$every ?cexpr #$has-definition &rest)
      (lambda (_fmode _target cexpr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (class (km-unique-int 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 
			    (desource+decomment (vals-in (assoc '#$instance-of slotsvals0)) :delistifyp nil)) )
		      (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)))))))) )

;;; Note: Unlike now-has, we clobber *all* the slots, not just the ones mentioned in the definition
   ( (#$every ?cexpr #$now-has-definition &rest)
      (lambda (_fmode _target cexpr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (class (km-unique-int 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-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 
			    (desource+decomment (vals-in (assoc '#$instance-of slotsvals0)) :delistifyp nil)) )
		      (cond ((not (every #'kb-objectp parents-of-defined-concept))
			     (report-error 'user-error "~a~%The `instance-of' slot-filler(s) in a now-has-definition must be atomic class name(s) only.~%"
					   `(#$every ,cexpr #$now-has-definition ,@slotsvals0)))
			    ((and (null parents-of-defined-concept) 
				  slotsvals0) ; But (every X now-has-definition) is ok as a way to REMOVE a definition
			     (report-error 'user-error 
					   "~a~%You must specify an `instance-of' slot value for a now-has-definition, pointing to the parent class(es)!~%"
					   `(#$every ,cexpr #$now-has-definition ,@slotsvals0)))

			    (t ; [1] Delete old definition:
			       (let ((member-definition-parents (get-vals class '#$instance-of :facet 'member-definition)))
				 (cond (member-definition-parents 
					(unpoint-parents-to-defined-concept class member-definition-parents 'member-definition))))
			       (mapc #'(lambda (situation)
					 (mapc #'(lambda (slotvals)
						   (let ((slot (slot-in slotvals)))
						     (put-vals class slot nil :facet 'member-definition :situation situation)))
					       (get-slotsvals class :situation situation :facet 'member-definition)))
				     (all-situations-and-theories))

			       ; [2] Assert new definition. NB if parents-of-defined-concept is NIL, then there is no new definition.
			       (cond (parents-of-defined-concept ; might be NIL if you are DELETING a definition
				      (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)))))))) )

    ; =======================
    ; DEFINING OWN PROPERTIES
    ; =======================

    ( (?instance-expr #$has-definition &rest)
      (lambda (_fmode _target instance-expr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (instance (km-unique-int 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)	; check
		    (let* ((slotsvals0 (desource+decomment slotsvals)) ; Can't handle comments on instances yet, so strip 
			   				 ; them off and throw them out, unlike for (every ... has-def...)
			   (parents-of-defined-concept (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)		; In case redefinition	- now in put-slotsvals; Later: no!!!
			       (classify instance :slots-that-changed (mapcar #'slot-in slotsvals))		; Because it's an instance
			       (list instance)))))))) )

    ( (?instance-expr #$now-has-definition &rest)
      (lambda (_fmode _target instance-expr slotsvals)
	   (declare (ignore  _fmode _target))
	   (let ( (instance (km-unique-int 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 #$now-has-definition ,@slotsvals) instance-expr))
		   ((are-slotsvals slotsvals)	; check
		    (let* ((slotsvals0 (desource+decomment slotsvals)) ; Can't handle comments on instances yet, so strip 
			   				 ; them off and throw them out, unlike for (every ... now-has-def...)
			   (parents-of-defined-concept (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 now-has-definition must be atomic class name(s) only.~%"
					   `(,instance-expr #$now-has-definition ,@slotsvals0)))
			    ((and (null parents-of-defined-concept)
				  slotsvals0)
			     (report-error 'user-error 
					   "~a~%You must specify an `instance-of' slot value for a now-has-definition, pointing to the parent class(es)!~%"
					   `(,instance-expr #$now-has-definition ,@slotsvals0)))
			    
			    (t ; [1] Delete old definition:
			       (let ((own-definition-parents (get-vals instance '#$instance-of :facet 'own-definition)))
				 (cond (own-definition-parents 
					(unpoint-parents-to-defined-concept instance own-definition-parents 'own-definition))))
			       (mapc #'(lambda (situation)
					 (mapc #'(lambda (slotvals)
						   (let ((slot (slot-in slotvals))
							 (vals (vals-in slotvals)))
						     (uninstall-inverses instance slot vals situation)
						     (put-vals instance slot nil :facet 'own-definition :situation situation)))
					       (get-slotsvals instance :situation situation :facet 'own-definition)))
				     (all-situations-and-theories))
			       
			       ; [2] Assert new definition. NB if parents-of-defined-concept is NIL, then there is no new definition.
			       (cond (parents-of-defined-concept ; might be NIL if you are DELETING a definition			       
				      (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) ; In case redefinition	- now in put-slotsvals; Later: no!!!
				      (classify instance :slots-that-changed (mapcar #'slot-in slotsvals)))) ; Because it's an instance
			       (list instance)))))))) )

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

    ( (#$if ?condition #$then ?action)
      (lambda (fmode target condition action)
	   (km-int `(#$if ,condition #$then ,action #$else nil) :fail-mode fmode :target target :rewritep t)) )

    ( (#$if ?condition #$then ?action #$else ?altaction)
      (lambda (fmode target condition action altaction)
	(declare (ignore target))
	   (let ( (test-result (km-int condition)) )
	     (cond ((not (member test-result '#$(NIL f F))) (km-int action :fail-mode fmode))
		   (t (km-int altaction :fail-mode fmode))))))

    ( (?x > ?y) (lambda (_fmode _target x y)
		     (declare (ignore  _fmode _target))
		     (let ( (xval (km-unique-int x :fail-mode 'error))
			    (yval (km-unique-int y :fail-mode 'error)) )
		       (cond ((and (numberp xval) (numberp yval)) 
			      (cond ((> xval yval) '#$(t))))))))

    ( (?x < ?y) (lambda (_fmode _target x y)
		     (declare (ignore  _fmode _target))
		     (let ( (xval (km-unique-int x :fail-mode 'error))
			    (yval (km-unique-int y :fail-mode 'error)) )
		       (cond ((and (numberp xval) (numberp yval))
			      (cond ((< xval yval) '#$(t))))))))

    ( (?x >= ?y) (lambda (_fmode _target x y)
		     (declare (ignore  _fmode _target))
		     (let ( (xval (km-unique-int x :fail-mode 'error))
			    (yval (km-unique-int y :fail-mode 'error)) )
		       (cond ((and (numberp xval) (numberp yval))
			      (cond ((>= xval yval) '#$(t))))))))

    ( (?x <= ?y) (lambda (_fmode _target x y)
		     (declare (ignore  _fmode _target))
		     (let ( (xval (km-unique-int x :fail-mode 'error))
			    (yval (km-unique-int y :fail-mode 'error)) )
		       (cond ((and (numberp xval) (numberp yval))
			      (cond ((<= xval yval) '#$(t))))))))

    ( (?x = ?y +/- ?z) (lambda (_fmode _target x y z)
		     (declare (ignore  _fmode _target))
		     (let ( (xval (km-unique-int x :fail-mode 'error))
			    (yval (km-unique-int y :fail-mode 'error))
			    (zval (km-unique-int z :fail-mode 'error)) )
		       (cond ((and (numberp xval) (numberp yval) (numberp zval))
			      (cond ((<= (abs (- xval yval)) (abs zval)) '#$(t))))))) )

    ( (?x = ?y +/- ?z %) (lambda (_fmode _target x y z)
		     (declare (ignore  _fmode _target))
		     (let ( (xval (km-unique-int x :fail-mode 'error))
			    (yval (km-unique-int y :fail-mode 'error))
			    (zval (km-unique-int 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 #$and &rest) 
      (lambda (_fmode _target x rest)
	(declare (ignore  _fmode _target))
	(cond ((and (listp x)
		    (= (length x) 3)
		    (eq (second x) '==))		; special handling for ((?x == <expr>) and ...)
	       (let* ( (xx (first x))
		       (yy (third x)) )
		 (cond ((and (km-varp xx)
			     (km-varp yy))
			(km-int (subst xx yy rest)))		; or perhaps should be an error
		       ((km-varp xx) (km-int (subst (vals-to-val (km-int yy)) xx rest)))
		       ((km-varp yy) (km-int (subst (vals-to-val (km-int xx)) yy rest)))
		       ((and (lazy-unify-&-expr `(,xx == yy) :fail-mode 'error :joiner '==)
			     (km-int rest))))))
	      (t (and (km-int x)
		      (km-int rest))))) )

    ( (?x #$or &rest) (lambda (_fmode _target x y)
			 (declare (ignore  _fmode _target))
			 (or (and (not (on-goal-stackp x))
				  (km-int x))
			     (km-int y))) )

    ( (#$not ?x) (lambda (_fmode _target x)
		      (declare (ignore  _fmode _target))
		      (cond ((not (km-int x)) '#$(t)))) )

    ( (#$numberp ?x) (lambda (_fmode _target x)
			  (declare (ignore  _fmode _target))
			  (cond ((numberp (km-unique-int x)) '#$(t)))) )

;;; ======================================================================
;;;		SUBSUMPTION TESTING
;;; ======================================================================

    ( (?x #$is-subsumed-by ?y) 
      (lambda (fmode target x y)
	(km-int `(,y #$subsumes ,x) :fail-mode fmode :target target :rewritep t)) )

    ( (?x #$subsumes ?y) 
      (lambda (_fmode _target x y)
	   (declare (ignore  _fmode _target))
	   (let ( (yv (km-int y)) )
	     (cond ((null yv) '#$(t))
		   (t (let ( (xv (km-int x)) )
			(cond ((and (not (null xv))
				    (subsumes xv yv))
			       '#$(t)))))))))

    ( (?x #$is-covered-by ?y) 
      (lambda (fmode target x y)
	(km-int `(,y #$covers ,x) :fail-mode fmode :target target :rewritep t)) )

; replace with generalized isa
;    ( (?x #$covers ?y) 
;      (lambda (_fmode x y)
;	   (declare (ignore  _fmode))
;	   (let ( (yv (km-unique-int y)) )
;	     (cond ((null yv) '#$(t))
;		   (t (let ( (xv (km-int x)) )
;			(cond ((and (not (null xv))
;				    (covers xv yv))
;			       '#$(t)))))))))

;;; Obsolete, but keep for backward compatibility
    ( (?x #$covers ?y)
      (lambda (fmode target x y)
	(km-int `(,y #$isa ,x) :fail-mode fmode :target target :rewritep t)) )

    ( (?y #$isa ?x)
      (lambda (_fmode _target y x)
	   (declare (ignore  _fmode _target))
	   (let* ( (yvals (km-int 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 (km-int 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)))) ; quick test
			      ((covers (list xv) yv) '#$(t)))))))) ) ; more complex test for expressions
    
    ( (?x #$is ?y) 
      (lambda (_fmode _target x y)
	   (declare (ignore  _fmode _target))
	   (let ( (xv (km-unique-int x)) )
	     (cond ((null xv) nil)
		   (t (let ( (yv (km-unique-int y)) )
			(cond ((and (not (null yv))
				    (is xv yv)) '#$(t)))))))))

;;; ======================================================================

    ( (?xs #$includes ?y) 
      (lambda (_fmode _target xs y)
	   (declare (ignore  _fmode _target))
	   (let ((xs-vals (km-int xs))
;		 (y-val (km-unique-int y :fail-mode 'error)) ; no, I think it's ok for this to return NIL 
		 (y-val (km-unique-int y)))	     
	     (cond ((member y-val (dereference xs-vals) :test #'equal) '#$(t))))))

    ( (?xs #$is-superset-of ?ys) 
      (lambda (_fmode _target xs ys)
	   (declare (ignore  _fmode _target))
	   (let ( (xs-vals (km-int xs))
		  (ys-vals (km-int ys)) )
	     (cond ((subsetp ys-vals (dereference xs-vals) :test #'equal) '#$(t))))) )
			   
;;; ======================================================================
;;;		SEQUENCE MANIPULATION
;;; ======================================================================

    ( (?seq-expr1 #$append ?seq-expr2)
      (lambda (_fmode _target seq-expr1 seq-expr2)
	(declare (ignore  _fmode _target))
	(let* ( (seq1 (km-unique-int seq-expr1))
		(seq2 (km-unique-int 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)						; result on failure
				   ((or (km-bagp seq1) (km-bagp seq2)) '#$:bag)
				   (t '#$:seq))) )					; default
	  `((,result-type ,@(append elts1 elts2))))) )

;;; ======================================================================
;;;		ALLOF/ONEOF etc.
;;; ======================================================================

;;; New. NOTE: fails quietly if it can't find any values. That's fine.
    ( (?expr #$called ?tag)
      (lambda (fmode _target expr tag)
	(declare (ignore _target))
	(let* ( (vals (km-int 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 (km-int `#$(the called of ,VAL))
									   (km-int `#$(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 (make-comment "Warning: Can't find any (~a called/uniquely-called ~a)" expr tag))
			 ))
		  (t target-vals))))) )

; synonym
    ( (?expr #$uniquely-called ?tag)
      (lambda (fmode target expr tag)
	(km-int `(,expr #$called ,tag) :fail-mode fmode :target target :rewritep t)) )

;;; > (a man with (parts ((a arm) (a leg) (a arm))))
;;; _man1187
;;; > (allof ((_man1187 parts)) where (it isa arm))
;;; (_arm1188 _arm1190) 
    ( (#$allof ?set #$where ?test)	
      (lambda (fmode target set test)
	   (km-int `(#$forall ,set #$where ,test #$It) :fail-mode fmode :target target :rewritep t)))  ; equivalent

;;; New for KM1.4.0 beta-12    
    ( (#$allof ?set #$must ?test)	
      (lambda (fmode target set test)
	(declare (ignore fmode target))
	(cond ((every #'(lambda (instance) 
			  (km-int (subst Instance '#$It test))) 
		      (km-int set))
	       '#$(t)))))

;;; New for KM1.4.0 beta-18
    ( (#$allof ?set #$where ?test2 #$must ?test)	
      (lambda (fmode target set test2 test)
	(declare (ignore fmode target))
	(cond ((every #'(lambda (instance) 
			  (km-int (subst Instance '#$It test)))
		      (km-int `#$(allof ,SET where ,TEST2)))
	       '#$(t)))))

    ( (#$oneof ?set #$where ?test)	
      (lambda (fmode target set test)
	(declare (ignore fmode target))
	(let ( (answer (find-if #'(lambda (member)
				    (km-int (subst member '#$It test)))
				(km-int set))) )
	  (cond (answer (list answer))))) )

;;; New  1.4 - check to ensure there's a single value
    ( (#$theoneof ?set #$where ?test)	
      (lambda (fmode target set test)
	   (let ( (val (km-unique-int `(#$forall ,set #$where ,test #$It) :fail-mode fmode :target target :rewritep t)) )  ; equivalent
	     (cond (val (list val))))) )

    ( (#$forall ?set ?value)
      (lambda (fmode target set value)
	   (km-int `(#$forall ,set #$where t ,value) :fail-mode fmode :target target :rewritep t)))  ; equivalent

;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results.
    ( (#$forall-seq ?seq ?value)
      (lambda (fmode target seq value)
	   (km-int `(#$forall-seq ,seq #$where t ,value) :fail-mode fmode :target target :rewritep t)))  ; equivalent

    ( (#$forall-bag ?bag ?value)
      (lambda (fmode target bag value)
	   (km-int `(#$forall-bag ,bag #$where t ,value) :fail-mode fmode :target target :rewritep t)))  ; equivalent

    ( (#$forall ?set #$where ?constraint ?value)
      (lambda (_fmode _target set constraint value)
	   (declare (ignore  _fmode _target))
	   (remove nil
	    (my-mapcan #'(lambda (member)
			   (cond ((km-int (subst member '#$It constraint))
				  (km-int (subst member '#$It value)))))
		       (km-int set)))) )

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

;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results.
    ( (#$forall-seq ?seq #$where ?constraint ?value)
      (lambda (_fmode _target seq constraint value)
	   (declare (ignore  _fmode _target))
	   (let ( (sequences (km-int seq)) )
	     (cond ((null sequences) nil)
	           ((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 ((km-int (subst member '#$It constraint))
						(vals-to-val (km-int (subst member '#$It value))))
					       (t 'to-remove)))
				     (rest (first sequences)))))))))) )	; ((:seq a b)) -> map over (a b)

    ( (#$forall-seq2 ?seq #$where ?constraint ?value)
      (lambda (_fmode _target seq constraint value)
	   (declare (ignore  _fmode _target))
	   (let ( (sequences (km-int seq)) )
	     (cond ((null sequences) nil)	     
		   ((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 ((km-int (subst member '#$It2 constraint))
						(vals-to-val (km-int (subst member '#$It2 value))))
					       (t 'to-remove)))
				     (rest (first sequences)))))))))) )	; ((:seq a b)) -> map over (a b)

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

;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results.
    ( (#$forall-bag ?bag #$where ?constraint ?value)
      (lambda (_fmode _target bag constraint value)
	   (declare (ignore  _fmode _target))
	   (let ( (bags (km-int bag)) )
	     (cond ((null bags) nil)
		   ((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 ((km-int (subst member '#$It constraint))
							(vals-to-val (km-int (subst member '#$It value))))))
					     (rest (first bags)))))))))) )	; ((:bag a b)) -> map over (a b)

    ( (#$forall-bag2 ?bag #$where ?constraint ?value)
      (lambda (_fmode _target bag constraint value)
	   (declare (ignore  _fmode _target))
	   (let ( (bags (km-int bag)) )
	     (cond ((null bags) nil)
		   ((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 ((km-int (subst member '#$It2 constraint))
							(vals-to-val (km-int (subst member '#$It2 value))))))
					     (rest (first bags)))))))))) )	; ((:bag a b)) -> map over (a b)

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

;;; To allow nesting, we also have forall2, whose referents are "it2"
    ( (#$allof2 ?set #$where ?test)	
      (lambda (fmode target set test)
	   (km-int `(#$forall2 ,set #$where ,test #$It2) :fail-mode fmode :target target :rewritep t)))  ; equivalent

;;; New for KM1.4.0 beta-12    
    ( (#$allof2 ?set #$must ?test)	
      (lambda (fmode target set test)
	(declare (ignore fmode target))
	(cond ((every #'(lambda (instance) 
			  (km-int (subst Instance '#$It2 test))) 
		      (km-int set))
	       '#$(t)))))

;;; New for KM1.4.0 beta-18
    ( (#$allof2 ?set #$where ?test2 #$must ?test)	
      (lambda (fmode target set test2 test)
	(declare (ignore fmode target))
	(cond ((every #'(lambda (instance) 
			  (km-int (subst Instance '#$It2 test)))
		      (km-int `#$(allof2 ,SET where ,TEST2)))
	       '#$(t)))))

    ( (#$oneof2 ?set #$where ?test)	
      (lambda (fmode target set test)
	(declare (ignore fmode target))
	(let ( (answer (find-if #'(lambda (member)
				    (km-int (subst member '#$It2 test)))
				(km-int set))) )
	  (cond (answer (list answer))))) )

    ( (#$forall2 ?set ?value)
      (lambda (fmode target set value)
	   (km-int `(#$forall2 ,set #$where t ,value) :fail-mode fmode :target target :rewritep t)))  ; equivalent

    ( (#$forall-seq2 ?seq ?value)
      (lambda (fmode target seq value)
	   (km-int `(#$forall-seq2 ,seq #$where t ,value) :fail-mode fmode :target target :rewritep t)))  ; equivalent

    ( (#$forall-bag2 ?bag ?value)
      (lambda (fmode target bag value)
	   (km-int `(#$forall-bag2 ,bag #$where t ,value) :fail-mode fmode :target target :rewritep t)))  ; equivalent

    ( (#$theoneof2 ?set #$where ?test)	
      (lambda (fmode target set test)
	   (let ( (val (km-unique-int `(#$forall2 ,set #$where ,test #$It2) :fail-mode fmode :target target :rewritep t)) )  ; equivalent
	     (cond (val (list val))))) )

    ( (#$forall2 ?set #$where ?constraint ?value)
      (lambda (_fmode _target set constraint value)
	   (declare (ignore  _fmode _target))
	   (remove 'nil
	    (my-mapcan #'(lambda (member)
			   (cond ((km-int (subst member '#$It2 constraint))
				  (km-int (subst member '#$It2 value)))))
		       (km-int set)))) )

;;; ======================================================================
;;;			NEW: VARIABLES!!!
;;; ======================================================================

    ( (#$allof ?var #$in  ?set #$where ?test)	
      (lambda (fmode target 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 (km-int `(#$forall ,var #$in ,set #$where ,test ,var) :fail-mode fmode :target target :rewritep t)))) )  ; equivalent

    ( (#$allof ?var #$in ?set #$must ?test)	
      (lambda (fmode target var set test)
	(declare (ignore fmode target))
	(allof-must var set test)) )

    ( (#$allof ?var #$in ?set #$where ?test2 #$must ?test)	
      (lambda (fmode target var set test2 test)
	(declare (ignore fmode target))
	(allof-where-must var set test2 test)) )

    ( (#$oneof ?var #$in ?set #$where ?test)	
      (lambda (fmode target var set test)
	(declare (ignore fmode target))
	(oneof-where var set test)) )

    ( (#$theoneof ?var #$in ?set #$where ?test)	
      (lambda (fmode target 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-unique-int `(#$forall ,var #$in ,set #$where ,test ,var) :fail-mode fmode :target target :rewritep t)) )  ; equivalent
		   (cond (val (list val))))))) )

    ( (#$forall ?var #$in ?set ?value)
      (lambda (fmode target 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 (km-int `(#$forall ,var #$in ,set #$where t ,value) :fail-mode fmode :target target :rewritep t)))) )  ; equivalent

    ( (#$forall-seq ?var #$in ?seq ?value)
      (lambda (fmode target 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 (km-int `(#$forall-seq ,var #$in ,seq #$where t ,value) :fail-mode fmode :target target :rewritep t)))) )  ; equivalent

    ( (#$forall-bag ?var #$in ?bag ?value)
      (lambda (fmode target 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 (km-int `(#$forall-bag ,var #$in ,bag #$where t ,value) :fail-mode fmode :target target :rewritep t)))) )  ; equivalent

    ( (#$forall ?var #$in ?set #$where ?constraint ?value)
      (lambda (_fmode _target var set constraint value)
	   (declare (ignore  _fmode _target))
	   (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 ((km-int (subst member var constraint))
						  (km-int (subst member var value)))))
				       (km-int set)))))) )

    ( (#$forall-bag ?var #$in ?bag #$where ?constraint ?value)
      (lambda (_fmode _target var bag constraint value)
	   (declare (ignore  _fmode _target))
	   (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 (km-int 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 ((km-int (subst member var constraint))
								 (vals-to-val (km-int (subst member var value))))))
						      (rest (first bags)))))))))))) )	; ((:bag a b)) -> map over (a b)

    ( (#$forall-seq ?var #$in ?seq #$where ?constraint ?value)
      (lambda (_fmode _target var seq constraint value)
	   (declare (ignore  _fmode _target))
	   (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 (km-int 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 ((km-int (subst member var constraint))
								 (vals-to-val (km-int (subst member var value))))
								(t 'to-remove)))
						      (rest (first sequences)))))))))))) )	; ((:seq a b)) -> map over (a b)

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

;;; Given a function with zero arguments, KM will automatically evalute it.
    ( (function ?lispcode)		;;; NB NOT #$function, as we mean Lisp FUNCTION (#')
      (lambda (_fmode _target lispcode) 
	(declare (ignore  _fmode _target))
;	(km-format t "CALLING FUNCTION~%")
	   (let* ( (answer0 (funcall (eval (list 'function lispcode)))) ; lispcode can return a val, or list of vals
		   (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))))) )

;;; ======================================================================
;;;		MULTIARGUMENT PREDICATES
;;; ======================================================================

;;; Shorthands
    ( (#$the1 ?slot #$of ?frameadd)  
      (lambda (fmode target slot frameadd)
	(km-int `#$(the1 of (the ,SLOT of ,FRAMEADD)) :fail-mode fmode :target target :rewritep t)) )

    ( (#$the2 ?slot #$of ?frameadd)  
      (lambda (fmode target slot frameadd)
	(km-int `#$(the2 of (the ,SLOT of ,FRAMEADD)) :fail-mode fmode :target target :rewritep t)) )

    ( (#$the3 ?slot #$of ?frameadd)  
      (lambda (fmode target slot frameadd)
	(km-int `#$(the3 of (the ,SLOT of ,FRAMEADD)) :fail-mode fmode :target target :rewritep t)) )

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

;;; [1] New: tolerate (the1 of x), where x isn't structured
    ( (#$the1 #$of ?frameadd)  
      (lambda (fmode target frameadd)
	(let ( (multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)) )
	  (km-int (vals-to-val
		(mapcar #'(lambda (multiarg)
			    (cond ((km-structured-list-valp multiarg) (arg1of multiarg))
				  (t multiarg)))							; [1]
			multiargs))))) )
;	  (cond ((every #'km-structured-list-valp multiargs) (mapcar #'arg1of multiargs))
;		(t (report-error 'user-error "~a! the1 expects multi-argument values for ~a, but got ~a instead!~%"
;				 `#$(the1 of ,FRAMEADD)  frameadd multiargs))))) )

    ( (#$the2 #$of ?frameadd)  
      (lambda (fmode target frameadd)
	(let ( (multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)) )
	 (km-int (vals-to-val
	  (mapcar #'(lambda (multiarg)
		      (cond ((km-structured-list-valp multiarg) (arg2of multiarg))))		; nil otherwise
		  multiargs))))) )
;	  (cond ((every #'km-structured-list-valp multiargs) (mapcar #'arg2of multiargs))
;		(t (report-error 'user-error "~a! the2 expects multi-argument values for ~a, but got ~a instead!~%"
;				 `#$(the2 of ,FRAMEADD)  frameadd multiargs))))) )

    ( (#$the3 #$of ?frameadd)  
      (lambda (fmode target frameadd)
	(let ( (multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)) )
	  (km-int (vals-to-val
		(mapcar #'(lambda (multiarg)
		      (cond ((km-structured-list-valp multiarg) (arg3of multiarg))))	; nil otherwise
		  multiargs))))) )

;	  (cond ((every #'km-structured-list-valp multiargs) (mapcar #'arg3of multiargs))
;		(t (report-error 'user-error "~a! the3 expects multi-argument values for ~a, but got ~a instead!~%"
;				 `#$(the3 of ,FRAMEADD)  frameadd multiargs))))) )

    ( (#$theN ?nexpr #$of ?frameadd)  
      (lambda (fmode target nexpr frameadd)
	(let ( (n (km-unique-int nexpr :fail-mode 'error))
	       (multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)) )
	  (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 (km-int (vals-to-val
		    (mapcar #'(lambda (multiarg)
			       (cond ((and (km-structured-list-valp multiarg) 
					   (< n (length multiarg)))		; elt returns error if n out of range under Mac CommonLisp
				      (elt multiarg n))
				     ((= n 1) multiarg)))					; nil otherwise
			   multiargs))))))) )

;;; This is slightly bad naming but oh well. theN is used for a SINGLE structured value. theNth is used for multiple values (sets).
    ( (#$theNth ?nexpr #$of ?frameadd)  
      (lambda (fmode target nexpr frameadd)
	(let ( (n (km-unique-int nexpr :fail-mode 'error))
	       (vals (km-int frameadd :fail-mode fmode :target target :rewritep t)) )
	  (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 returns error if n out of range under Mac CommonLisp
		      (elt vals (1- n)))
		 (list (elt vals (1- n))))))) )

;	        ((every #'km-structured-list-valp multiargs) 
;		 (mapcar #'(lambda (seq) (and (< n (length seq)) 		; NB (:seq 1 2 3) has 3 (not 4) elements
;					      (elt seq n))) multiargs))
;		(t (report-error 'user-error "~a! theN expects multi-argument values for ~a, but got ~a instead!~%"
;			      `#$(the3 of ,FRAMEADD)  frameadd multiargs))))) )

;;; ======================================================================
;;;		ARITHMETIC
;;; ======================================================================

;;; Change default right-association precidence to left-association precedence, for
;;; cases where it makes a difference and appropriate:
   ( (?x ^ ?y ^ &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x ^ ,y) ^ ,@rest) :fail-mode fm)) )
   ( (?x ^ ?y + &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x ^ ,y) + ,@rest) :fail-mode fm)) )
   ( (?x ^ ?y - &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x ^ ,y) - ,@rest) :fail-mode fm)) )
   ( (?x ^ ?y / &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x ^ ,y) / ,@rest) :fail-mode fm)) )
   ( (?x ^ ?y * &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x ^ ,y) * ,@rest) :fail-mode fm)) )

   ( (?x / ?y + &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x / ,y) + ,@rest) :fail-mode fm)) )
   ( (?x / ?y - &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x / ,y) - ,@rest) :fail-mode fm)) )
   ( (?x / ?y / &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x / ,y) / ,@rest) :fail-mode fm)) )
   ( (?x / ?y * &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x / ,y) * ,@rest) :fail-mode fm)) )

   ( (?x * ?y + &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x * ,y) + ,@rest) :fail-mode fm)) )
   ( (?x * ?y - &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x * ,y) - ,@rest) :fail-mode fm)) )
   ( (?x * ?y / &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x * ,y) / ,@rest) :fail-mode fm)) )

   ( (?x - ?y - &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x - ,y) - ,@rest) :fail-mode fm)) )
   ( (?x - ?y + &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x - ,y) + ,@rest) :fail-mode fm)) )

   ( (?x + ?y - &rest) (lambda (fm tg x y rest) (declare (ignore tg)) (km-int `((,x + ,y) - ,@rest) :fail-mode fm)) )

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

   ( (?expr + &rest) (lambda (fmode target expr rest) 
			  (let ( (x (km-unique-int expr :fail-mode fmode :target target :rewritep t)) 
				 (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)) )
			    (cond ((and (numberp x) (numberp y)) (list (+ x y)))))))
   ( (?expr - &rest) (lambda (fmode target expr rest) 
			  (let ( (x (km-unique-int expr :fail-mode fmode :target target :rewritep t)) 
				 (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)) )
			    (cond ((and (numberp x) (numberp y)) (list (- x y)))))))
   ( (?expr * &rest) (lambda (fmode target expr rest) 
			  (let ( (x (km-unique-int expr :fail-mode fmode :target target :rewritep t)) 
				 (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)) )
			    (cond ((and (numberp x) (numberp y)) (list (* x y)))))))
   ( (?expr / &rest) (lambda (fmode target expr rest) 
			  (let ( (x (km-unique-int expr :fail-mode fmode :target target :rewritep t)) 
				 (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)) )
			    (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 target expr1 expr2) 
			  (let ( (x (km-unique-int expr1 :fail-mode fmode :target target :rewritep t)) 
				 (y (km-unique-int expr2 :fail-mode fmode :target target :rewritep t)) )
			    (cond ((and (numberp x) (numberp y)) (list (expt x y)))))))

; shouldn't be needed now
;    ( #$:set
;      (lambda (_fmode) (declare (ignore _fmode)) nil) )

;;; also handled in faster mechanism directly in km1. Leave it here for completeness
    ( #$nil 
      (lambda (_fmode _target) (declare (ignore _fmode _target)) nil) )

    ( nil		; ie. NIL
      (lambda (_fmode _target) (declare (ignore _fmode _target)) nil) )

    ( (#$:set &rest)					; for :set, just remove :set tag to return a list
      (lambda (fmode target exprs) 				; km will do the dereferencing and remove the duplicates later
	   (declare (ignore fmode))
	   (my-mapcan #'(lambda (expr) (km-int expr :target target)) exprs)) )


   ;;; NOTE: These are NOT rewrites, they are breaking up a goal into subgoals
    ( (#$:seq &rest)					; for :seq, build a one-element long structure
      (lambda (fmode target exprs) 
	   (declare (ignore target fmode))
	   (let ( (sequence (mapcar #'(lambda (expr)  
					(vals-to-val (km-int expr #|:target target :rewritep t|#))) exprs)) )
	     (cond (sequence `#$((:seq ,@SEQUENCE)))))) )

    ( (#$:bag &rest)					; for :bag, build a one-element long structure
      (lambda (fmode target exprs) 
	   (declare (ignore target fmode))
	   (let ( (bag (mapcar #'(lambda (expr)  
				   (vals-to-val (km-int expr #|:target target :rewritep t|#))) 
			       exprs)) )
	     (cond (bag `#$((:bag ,@BAG)))))) )

    ( (#$:function &rest)				; Identical code for functions...
      (lambda (fmode target exprs) 
	   (declare (ignore target fmode))
	   (let ( (sequence (mapcar #'(lambda (expr)  (vals-to-val (km-int expr #|:target target :rewritep t|#))) exprs)) )
	     (cond (sequence `#$((:function ,@SEQUENCE)))))) )

    ( (#$:pair &rest)					; for :seq, build a one-element long structure
      (lambda (fmode target exprs) 
	   (declare (ignore target 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 (km-int expr #|:target target :rewritep t|#))) exprs)) )
		 (cond (sequence `#$((:pair ,@SEQUENCE)))))))) )

;;; Dec 00 - make this reflexive
;;; Apr 01 - Put evaluation back again -- but not quite! Argh, can't quite put this back to normal, 
;;; 	     because I want to account for subsumption with triples like 
;;; 		(:triple *Pete owns (a House)) and (:triple *Pete owns (mustnt-be-a House))
    ( (#$:triple ?frame-expr ?slot-expr ?val-expr)					; for :seq, build a one-element long structure
      (lambda (_fmode _target frame-expr slot-expr val-expr)
	(declare (ignore _fmode _target))
	(let* ((slot (cond ((comparison-operator slot-expr) slot-expr) 	; can't pass >= etc. to km-unique-int (it's a keyword)
			   (t (km-unique-int slot-expr :fail-mode 'error))))
	       (frame (cond ((and (comparison-operator slot)
				  (minimatch frame-expr '#$(the ?x of ?y))) frame-expr)		; very special case - retain structure 
			    (t (km-unique-int frame-expr :fail-mode 'error))))
	       (val-expr0 (desource+decomment val-expr))	; There shouldn't be any comments here, but just in case!
	       (val (cond ((or (constraint-exprp val-expr0)  ; NB better decomment or else comment
			       (existential-exprp val-expr0) ;    may cause failure.
			       (comparison-operator slot)) 
			   val-expr0)	; preserve expressions (a House) or (mustnt-be-a House) or
					;  		(:triple (the age of X) < (the age of Y))
			  (t (vals-to-val (km-int val-expr))))) )
	  `#$((:triple ,FRAME ,SLOT ,VAL)))) )

    ( (#$:args &rest)					; for :seq, build a one-element long structure
      (lambda (fmode target exprs) 
	   (declare (ignore fmode target))
	   (let ( (sequence (mapcar #'(lambda (expr)  (vals-to-val (km-int expr))) exprs)) )
	     (cond (sequence `#$((:args ,@SEQUENCE)))))) )
; Neah, not this:
;	   (let ( (sequence (my-mapcan #'(lambda (expr)  (km-int expr)) exprs)) )
;	     (cond (sequence `#$((:args ,@SEQUENCE)))))) )

    ( (#$showme ?km-expr)
      (lambda (_fmode _target km-expr)
	   (declare (ignore _fmode _target))
	   (showme km-expr)) )

    ( (#$showme ?km-expr ?file)
      (lambda (_fmode _target km-expr file)
	   (declare (ignore _fmode _target))
	   (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 _target km-expr)
	   (declare (ignore _fmode _target))
	   (showme-all km-expr)) )

    ( (#$evaluate-all ?km-expr)
      (lambda (_fmode _target km-expr)
	   (declare (ignore _fmode _target))
	   (evaluate-all km-expr)) )

    ( (#$showme-here ?km-expr)
      (lambda (_fmode _target km-expr)
	   (declare (ignore _fmode _target))
	   (showme km-expr (list (curr-situation)) (visible-theories))) )

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

    ( (#$the-class ?class)
      (lambda (fmode target class)
	(declare (ignore fmode target))
;	(km-int class :fail-mode fmode)) )
;	`((#$the-class ,class))) )
#|NEW|#	(process-unquotes `((#$the-class ,class)))) )
;	`('(#$every ,class))) )


    ( (#$the-class ?class #$with &rest)
      (lambda (fmode target class slotsvals)
	(declare (ignore fmode target))
	(cond ((are-slotsvals slotsvals)
;	       `((#$the-class ,class #$with ,@slotsvals))))) )
#|NEW|#		(process-unquotes `((#$the-class ,class #$with ,@slotsvals)))))) )
;	       `('(#$every ,class #$with ,@slotsvals))))) )

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

    ( (#$constraints-for (#$the ?slot #$of ?frameadd))
      (lambda (fmode0 target slot frameadd)
	(declare (ignore fmode0 target))
	(let ( (frame (km-unique-int frameadd :fail-mode 'error)) )
	  (mapcar #'quotify (collect-constraints-on-instance frame slot)))) )
      
    ( (#$rules-for (#$the ?slot #$of ?frameadd))
      (lambda (fmode0 target slot frameadd)
	(declare (ignore fmode0 target))
	(let ( (rules (rules-for slot frameadd)) )
	  (cond ((null rules) nil)
		((km-setp rules)
		 (mapcar #'quotify (set-to-list rules)))
		(t (list (quotify rules)))))) )		; otherwise

    ( (#$why)
      (lambda (fmode target)
	(declare (ignore fmode target))
	(why)) )

    ( (#$why ?triple)
      (lambda (fmode target triple)
	(declare (ignore fmode target))
	(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 target)
	(declare (ignore fmode target))
	(justify))) 

    ( (#$justify ?triple)
      (lambda (fmode target triple)
	(declare (ignore fmode target))
	(justify triple)))

    ( (#$get-justification)
      (lambda (fmode target)
	(declare (ignore fmode target))
	(list (concat-list (insert-delimeter (get-justification :format 'ascii) *newline-str*)))) )
; 8/9/05 Remove "----"s
;	(list
;	 (concat-list
;	  (cons (format nil "--------------------~%")
;		(append (insert-delimeter (get-justification :format 'ascii) *newline-str*)
;			(list (format nil "~%-------------------~%"))))))) )

    ( (#$get-justification ?triple)
      (lambda (fmode target triple)
	(declare (ignore fmode target))
	(list (concat-list (insert-delimeter (get-justification :triple triple :format 'ascii) *newline-str*)))) )
; 8/9/05 Remove "----"s
;	(list 
;	 (concat-list
;	  (cons (format nil "--------------------~%")
;		(append (insert-delimeter (get-justification :triple triple :format 'ascii) *newline-str*)
;			(list (format nil "~%-------------------~%"))))))) )

;;; NEW: allow explanations to be re-read in from a .km file. Useful for explanations for prototype pieces.
    ( (#$explanation (#$:triple ?f0 ?s ?v0) ?explanations)
      (lambda (fmode target f0 s v0 explanations)
	(declare (ignore fmode target))
	(let ((f (dereference f0))
	      (v (dereference v0)))
	  (mapc #'(lambda (explanation)
		    (record-explanation-for `#$(the ,S of ,F) v explanation :situation *global-situation*
					    :ignore-clone-cycles t))
		(dereference explanations)))
	'#$(t)) )
   
    ( (#$explained-by ?instance ?expr)
     (lambda (fmode target instance expr)
       (declare (ignore fmode target))
       (explained-by instance expr)) )
	
    ( (#$comment ?comment-tag &rest)
      (lambda (fmode target comment-tag data)
	(declare (ignore fmode target))
	(comment comment-tag data)) )

    ( (#$show-comment ?comment-tag)
      (lambda (fmode target comment-tag)
	(declare (ignore fmode target))
	(show-comment comment-tag)) )

    ( (quote ?expr)
       (lambda (fmode target expr) 
	(declare (ignore fmode target))
	 (let ( (processed-expr (process-unquotes expr)) )
	   (cond (processed-expr (list (list 'quote processed-expr)))))) )

    ( (unquote ?expr)
       (lambda (fmode target expr) 
	(declare (ignore fmode target))
	 (report-error 'user-error "Doing #,~a: You can't unquote something without it first being quoted!~%" expr)) )

;;; For Adam Farquhar - 12/9/98 now it *does* delete inverses
    ( (#$delete ?km-expr)
       (lambda (fmode target km-expr)
	 (mapc #'delete-frame (km-int km-expr :fail-mode fmode :target target :rewritep t))
	 '#$(t)))

    ( (#$evaluate ?expr)		; Can't use eval, as that's a Lisp call!
       (lambda (fmode target expr) 
	    (let ( (quoted-exprs (km-int expr :fail-mode fmode :target target :rewritep t)) )
	      (remove nil
	      (my-mapcan #'(lambda (quoted-expr)
			     (cond ((member quoted-expr '#$(f F)) nil)
				   ((and (pairp quoted-expr)
					 (eq (first quoted-expr) 'quote))
				    (km-int (second quoted-expr) :fail-mode fmode))
; Neah, don't do this.
;				   ((km-triplep quoted-expr)					; NEW
;				    (let ( (frame (km-unique-int (second quoted-expr) :fail-mode 'error))
;					   (slot (km-unique-int (third quoted-expr) :fail-mode 'error))
;					   (val (cond ((constraint-exprp (fourth quoted-expr)) (fourth quoted-expr)) ; NEW: constraints *preserved*
;						      (t (vals-to-val (km-int (fourth quoted-expr)))))) ) ; allow val to be NIL, atom, :set
;				      `#$((:triple ,FRAME ,SLOT ,VAL))))
				   (t (report-error 'user-error 
						    "(evaluate ~a)~%evaluate should be given a quoted expression to evaluate!~%"
						    quoted-expr))))
			 quoted-exprs)))) )

    ( (#$exists ?frame)
      (lambda (fmode target 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)
	(km-int `#$(has-value ,FRAME) :fail-mode fmode :target target :rewritep t)) )

    ( (#$has-value ?frame)
      (lambda (_fmode _target frame) (declare (ignore  _fmode _target)) (cond ((km-int frame) '#$(t)))) )

    ( (#$print ?expr)
      (lambda (_fmode _target expr) 
	(declare (ignore _fmode _target)) 
	(let ( (vals (km-int expr)) )
	  (km-format t "~a~%" vals)
	  vals )))

    ( (#$format ?flag ?string &rest)
      (lambda (_fmode _target flag string arguments) 
	(declare (ignore _fmode _target)) 
	(cond ((eq flag '#$t)
	       (apply #'format `(t ,string ,@(mapcar #'(lambda (arg) (km-int arg)) arguments)))
	      '#$(t))
	      ((member flag '#$(nil NIL))
	       (list (apply #'format `(nil ,string ,@(mapcar #'(lambda (arg) (km-int 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 _target flag string arguments) 
	(declare (ignore _fmode _target)) 
	(cond ((eq flag '#$t)
	       (apply #'km-format `(t ,string ,@(mapcar #'(lambda (arg) (km-int arg)) arguments)))
	      '#$(t))
	      ((member flag '#$(nil NIL))
	       (list (apply #'km-format `(nil ,string ,@(mapcar #'(lambda (arg) (km-int arg)) arguments)))))
	      (t (report-error 'user-error "~a: Second argument must be `t' or `nil', not `~a'!~%" 
			       `(#$km-format ,flag ,string ,@arguments) flag)))) )
	       
;;; (_car1) -> (_car1)
;;; (_car1 _car2) -> (_car1 "and" _car2)
;;; (_car1 _car2 _car3) -> (_car1 "," _car2 ", and" _car3)
    ( (#$andify ?expr)			
      (lambda (fmode target expr) 
	(list (cons '#$:seq (andify (km-int expr :fail-mode fmode :target target :rewritep t))))) ) ; to avoid removing duplicate ", "s

;;; [1] 6.9.00 - allow the subquery to fail quietly. The parent call can handle it as an error, if it so desires.
    ( (#$make-sentence ?expr)
      (lambda (_fmode _target expr)
	   (declare (ignore _fmode _target))
#|[1]|#	   (let ( (text (km-int expr)) )		; should now return zero or more sequences ((:seq "Print" ..) (:seq ...))
	     (make-comment "anglifying ~a" text)	; show the user the original
	     (list (make-sentence text)))) )					; return the concatenation
;	     (mapcar #'make-sentence text))) )	; return the concatenation

    ( (#$make-phrase ?expr)			; This version *doesn't* capitalize
      (lambda (_fmode _target expr)
	   (declare (ignore _fmode _target))
	   (let ( (text (km-int expr)) )	; should now return zero or more sequences ((:seq "Print" ..) (:seq ...))
	     (make-comment "anglifying ~a" text)	; show the user the original
	     (list (make-phrase text)))) )
;	     (mapcar #'(lambda (item)
;			 (make-phrase item))
;		     text))) )			; return the concatenation

    ( (#$pluralize ?expr)
      (lambda (fmode target expr)
	(declare (ignore fmode target))
	(report-error 'user-error 
		      "(pluralize ~a): pluralize is no longer defined in KM1.4 - use \"-s\" suffix instead!~%" expr)) )

;;; ======================================================================
;;;		SPYPOINT MECHANISM
;;; ======================================================================

    ( (#$spy ?expr)
      (lambda (fmode target expr)
	(declare (ignore fmode target))
	(spy expr)) )

    ( (#$spy)
      (lambda (fmode target)
	(declare (ignore fmode target))
	(spy)) )

    ( (#$unspy)
      (lambda (fmode target)
	(declare (ignore fmode target))
	(unspy)) )
    
    ((#$profile ?expr)
     (lambda (fmode target expr)
       (declare (ignore fmode target))
       (let ((*profiling* t))
	 (profile-reset)
	 (let ((answer (km-int expr)))
	   (km-format t "~a~%" answer)
	   (profile-report)
	   answer))) )

    ( (#$profile-report)
      (lambda (fmode target)
	(declare (ignore fmode target))
	(profile-report)
	'#$(t)) )

    ( (#$profile-report ?n)
      (lambda (fmode target n)
	(declare (ignore fmode target))
	(profile-report n)
	'#$(t)) )

;;; ======================================================================
;;;		TAXONOMY
;;; ======================================================================

    ( (#$taxonomy &rest)
      (lambda (fmode target args)
	(declare (ignore fmode target))
	(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>)~%")))) )

;;; ======================================================================
;;;		ROLLBACK MECHANISM
;;; ======================================================================

    ( (#$checkpoint) 
      (lambda (fmode target) 
	(declare (ignore fmode target)) 
	(set-checkpoint) '#$(t)) )

    ( (#$checkpoint ?checkpoint-id)
      (lambda (fmode target checkpoint-id)
	(declare (ignore fmode target)) 
	(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)					; called only from within a program (km ...), NOT from the KM prompt
      (lambda (fmode target) 
	(declare (ignore fmode target)) 
	(cond ((undo) '#$(t)))) )

;;; This is rather an ugly macro...oh well, let's leave it here
    ( (#$an #$instance #$of ?expr)
      (lambda (fmode target expr)
	(km-int `(#$an #$instance #$of ,expr #$with) :fail-mode fmode :target target :rewritep t)) )

    ( (#$an #$instance #$of ?expr #$with &rest)
      (lambda (fmode target expr slotsvals)
	(declare (ignore  fmode target))
	(cond ((are-slotsvals slotsvals)
	       (let* ( ; (classes (km-int expr :fail-mode 'error)) - OLD
		       (classes (km-int expr)) ; NEW - don't abort
		       (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))) )
		 (cond ((or classes classes-in-slotsvals)	; if expr = NIL, return NIL (rather than error)
			(list (create-instance class new-slotsvals)))))))) )

    ( (#$reverse ?seq-expr)
      (lambda (fmode target seq-expr)
	(let ( (seq (km-unique-int seq-expr :fail-mode fmode :target target :rewritep t)) )
	  (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)			 ; strip off and ignore :default flag
      (lambda (fmode target expr)
;;;	(km-int expr :fail-mode fmode :target target :rewritep t)) )
	(declare (ignore fmode target expr))		; no - now ignore them
	(km-setq '*are-some-defaults* t)
	nil ))


;;; New and inert...
    ( (#$sometimes ?expr)
      (lambda (fmode target expr)
	(km-int expr :fail-mode fmode :target target :rewritep t)) )

    ( (#$anonymous-instancep ?expr)
      (lambda (fmode target expr)
	(declare (ignore fmode target))
	(cond ((anonymous-instancep (km-unique-int expr :fail-mode 'error)) '#$(t)))) )

;;; [1] below: NEW: Here make another top level call, so 
;;;	(i) the trace is easier to follow during debugging
;;;	(ii) the looping checker jumps in at the right moment
;;; [1] e.g., user may want extra parentheses around maths: ((2 + 3) + (4)) should be a valid expression
 
    ( ?path
      (lambda (fmode0 target path)
	(declare (ignore target))
	   (cond ((atom path) 					; An instance/class evaluates to itself
                  (cond						; (This case is duplicated in km1 for efficiency)
		        ((no-reserved-keywords (list path)) 	; else no-reserved-keywords prints error
			 (list path))))
		 ((not (listp path))
		  (report-error 'program-error "Failed to find km handler for ~a!~%" path))	; should never happen!
		 ((singletonp path) (km-int (first path) :fail-mode fmode0))	; well...we'll let this linear path through, I guess :-( [1]

;; USER FUNCTIONS
		 ((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 (km-int (first path))))
				(y (vals-to-val (km-int (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)	; ie. check that there are no reserved keywords
		     ((oddp (length path))      ; ODDP case: (last-el path) is a class, which filters the values
		      (cond ((structured-slotp (last-el (butlast path)))
			     (follow-multidepth-path 				        ; QUOTED PATH
			      (km-int (butlast (butlast path)) :fail-mode fmode0)    ; start-values
			      (last-el (butlast path))			        ; slot
			      (last-el path)				        ; target-class
			      :fail-mode fmode0))
			    (t (vals-in-class (km-int (butlast path) :fail-mode fmode0) ; REGULAR PATH
					      (last-el path)))))
		     ((evenp (length path))     ; EVENP case: (last-el path) is a slot, which generates values
		      (let* ( (frameadd (cond ((pairp path) (first path))		; (f s) -> f
					      (t (butlast path))))			; (f s f' s') -> (f s f')
			      (slot0 (last-el path)) )
			(cond ((structured-slotp slot0)
			       (follow-multidepth-path (km-int frameadd :fail-mode fmode0) 
						       slot0 '* :fail-mode fmode0))   ; target-class = *
			      (t (let* ( (slot (cond ((pathp slot0) (km-unique-int slot0 :fail-mode 'error))
						     (t slot0))) 
					 (fmode (cond ((built-in-aggregation-slot slot) 'fail)
						      (t fmode0))) 
					 (frames (km-int frameadd :fail-mode fmode)) )
				   (cond ((not (equal frames (val-to-vals frameadd)))
					  (km-int `#$(,(VALS-TO-VAL FRAMES) ,SLOT) :fail-mode fmode))	; [1]
					 (t (km-multi-slotvals frames slot :fail-mode fmode)))))))))) )

    )
  ) ;; end part 2 of list

;; put the 2 lists together to create the big list
(setq
 *km-handler-alist*
 (append *km-handler-alist1* *km-handler-alist2*))


;;; ======================================================================
;;;		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.
(defun structured-slotp (slot) 
  (and (listp slot) (eq (second slot) '*)))

(defun follow-multidepth-path (values structured-slot target-class &key (fail-mode 'fail))
  (declare (ignore fail-mode))
  (let ( (slot (first structured-slot))
	 (depth-limit (or (third structured-slot) *multidepth-path-default-searchdepth*)) )
    (cond ((null values) nil)
	  ((not (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 (vals-in-class (follow-multidepth-path0 values slot depth-limit) target-class)))))

; Note: The start-values AREN'T necessarily part of the solution, hence the extra :start-values keyword
(defun follow-multidepth-path0 (values slot depth-limit &key (start-values values) values-so-far)
  (cond ((<= depth-limit 0) values-so-far)
	((null values) values-so-far)
	(t (let* ((new-values (km-int `#$(the ,SLOT of ,(VALS-TO-VAL VALUES)) :fail-mode 'fail))
		  (novel-new-values (ordered-set-difference new-values (append start-values values-so-far) 
							    :test #'equal)))
	     (follow-multidepth-path0 novel-new-values slot (1- depth-limit)
				      :start-values values :values-so-far (append values-so-far novel-new-values))))))

;;; ======================================================================
;;;		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)
(defun km-multi-slotvals (frames0 slot &key (fail-mode 'fail))
  (declare (ignore fail-mode))
  (let ( (frames (mapcar #'dereference frames0)) )
    (cond ((no-reserved-keywords frames)		; check for syntax errors
	   (km-multi-slotvals0 frames slot)))))

;;; Returns a *LIST* of values   ((car) && (joe bad xd))
(defun km-multi-slotvals0 (frames slot)   
  (cond 
   ((not (check-isa-slot-object slot)) nil)
   ((and (eq slot '#$number) (null frames)) '(0))
;  ((null frames) nil)		No! Let aggregation of zero items continue
   (t (case slot
	(#$unification (km-int (val-sets-to-expr (mapcar #'list frames) :single-valuedp t)))
	(#$set-unification (km-int (val-sets-to-expr (mapcar #'list frames))))	; less aggressive; not really getting sets
	(#$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)))
	(#$most-specific (remove-subsumers frames))
	(#$most-general (remove-subsumees frames))
	(#$bag2seq (cond ((and (singletonp frames) (km-bagp (first frames)))
			  (list (cons '#$:seq (bag-to-list (first frames)))))
			 (t (report-error 'user-error
					  "(the bag2seq of ~a): argument should be a single bag." (vals-to-val frames)))))
	(#$seq2bag (cond ((and (singletonp frames) (km-seqp (first frames)))
			  (list (cons '#$:bag (seq-to-list (first frames)))))
			 (t (report-error 'user-error
					  "(the seq2bag of ~a): argument should be a single seq." (vals-to-val frames)))))
	(#$append (cond ((null frames) nil)
			((and (singletonp frames) (km-seqp (first frames)))
			 (let ( (appended (append-seqs (first frames))) )
			   (cond (appended (list appended)))))
			((and (singletonp frames) (km-bagp (first frames)))
			 (let ( (appended (append-bags (first frames))) )
			   (cond (appended (list appended)))))
			(t (report-error 'user-error 
					 "(the append of ~a): argument should be a single sequence of sequences, or bag of bags!"
					 (vals-to-val frames)))))
	(t (cond 
	    ((and (member slot '#$(min max))				; can apply this to sets, as well as bags
		  (not (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 (member slot '#$(sum average))
		  (null frames))
	     '(0))
	    ((isa slot '#$Set-Aggregation-Slot)
	     (let ( (quoted-function-name (km-unique-int `#$(the aggregation-function of ,SLOT))) )
	       (cond 
		((not quoted-function-name)
		 (report-error 'user-error "No aggregation-function definition given for the Aggregation-Slot ~a!~%" slot))
		((not (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 (let ( (function (eval (second quoted-function-name))) )
		     (cond 
		      ((not (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 				 ; Deduping and dereferencing done later
		#'(lambda (frame)
;;; OLD		    (km-slotvals frame slot))
;		    (km-format t "Here! frames = ~a, frame = ~a, slot = ~a~%" frames frame slot)
#|NEW|#		    (km-int `#$(the ,SLOT of ,FRAME))) ; NEW: Route via top-level KM call for clarity during tracing
		frames))))))))				       ; by end of top-level km fn

(defun aggregate-vals (function vals)
  (cond ((and (null vals) (not (eq function #'+))) (km-int '#$(a Number) :fail-mode 'error))	; just for #'+, allow zero arguments.
	((every #'numberp vals) (list (apply function vals)))
	(t (km-int '#$(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.
(defun km-slotvals (frame slot &key (fail-mode 'fail))
  (cond ((null frame) nil)
	((or (km-triplep frame)		; special handling for triples, eg.
	     (km-pairp frame)
	     (km-functionp frame)
	     (quoted-expressionp frame))
	 (case slot 				 ; (the name of (:triple *john wants *cash))
	   (#$name  (list (km-name frame))) ; returns "john wants cash"
	   (#$(instance-of classes) (tidy-classes slot (immediate-classes frame :enforce-constraints t))) ; synonyms	   
	   (#$all-classes           (all-classes frame))	   
; No, just fail quietly I think.
;	   (t       (report-error 'user-error "I don't know how to take the ~a of a triple ~a!~%" slot frame))
	   ))
	((and (member slot '#$(min max))			; (the min of 3.5) = 3.5p
	      (not (km-bagp frame)))
	 (list frame))
	((member slot '#$(sum min max average difference product quotient))
	 (cond ((km-bagp frame)
		(let ( (frames (bag-to-list frame)) )
		  (case slot 
			(#$sum (aggregate-vals #'+ frames))
			(#$average (cond ((and (every #'numberp frames)
					       (not (null frames)))
					  (list (/ (first (aggregate-vals #'+ frames)) (length frames))))
					 (t (km-int '#$(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)						; (the age of (:args Pete Clark)) -> (the age of Pete)
	 (km-int `#$(the ,SLOT of ,(SECOND FRAME)) :fail-mode fail-mode))	
	((eq slot '#$elements)
	 (cond ((not (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)))))			; strip :seq off
	((eq slot '#$seq-length)
	 (cond ((not (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 ((not (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)			; :triple, :args, :function handled earlier
	 (list (cons (first frame) (my-mapcan #'(lambda (el) 
						  (km-int `#$(the ,SLOT of ,EL) :fail-mode fail-mode)) 
					      (rest frame)))))
	((class-descriptionp frame)			; eg. '(every Dog)
	 (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) (tidy-classes slot (immediate-classes frame :enforce-constraints t)))	; synonyms
	       (#$superclasses          (tidy-classes slot (immediate-superclasses frame)))
	       (#$subclasses            (tidy-classes slot (immediate-subclasses frame)))
	       (#$instances 	        (immediate-instances frame))
	       (#$supersituations       (immediate-supersituations frame))
	       (#$all-instances         (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))
       	       (#$full-all-instances    (full-all-instances frame))	; full-all-instances = all-instances + all-prototypes
	       (#$domain 	        (tidy-classes slot (domains-of frame)))
	       (#$range 	        (tidy-classes slot (ranges-of frame)))
	       (#$inverse 	        (list (invert-slot frame)))
	       (#$called	        (km-int (vals-to-val (append (get-vals frame '#$called :situation *global-situation*)
								  (get-vals frame '#$uniquely-called :situation *global-situation*)))
					     ))		; e.g. ((:set a b (<> c)))  -> (a b)
	       (#$uniquely-called       (km-int (get-vals frame '#$uniquely-called :situation *global-situation*)))
	       (#$cardinality	        (listify (cardinality-of frame)))
	       (#$fluent-status         (listify (fluent-status frame)))))
	((member slot *built-in-nonfluent-lookup-only-slots*)
	 (get-vals frame slot :situation *global-situation*))
	(t (km-slotvals2 frame slot :fail-mode fail-mode))))

(defun tidy-classes (slot vals)
  (cond ((remove-subsumers-slotp slot) (remove-subsumers vals))
	((remove-subsumees-slotp slot) (remove-subsumees vals))
	(t vals)))

(defun km-slotvals2 (frame slot &key (fail-mode 'fail))
  (cond ((not (kb-objectp frame))
	 (cond ((eq slot '#$name) (list (km-name frame)))		; special case, e.g., (the name of "cat")
	       (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)		; Already done! So just retrieve cached value [NB Make sure you get it from the right situation!]...
	 (let ( (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)
;;; New check added to make sure there's no inferencing attempted on prototypes (unless in prototype mode)	
	((and (protoinstancep frame)
	      (not (am-in-prototype-mode)))
	 (report-error 'user-warning
		       "Attempt to do inference on a protoinstance ~a when not in prototype mode!~%         Doing (the ~a of ~a). Continuing, just doing a get-vals rather than full inference...~%" frame slot frame frame slot)
	 (let ((vals (remove-constraints (get-vals frame slot :situation *global-situation*))))
	   (cond ((notevery #'fully-evaluatedp vals)
		  (report-error 'user-error
				"The (get-vals '#$~a '#$~a :situation *global-situation*) returned a structure which isn't fully evaluated!~%        ~a~%"
				slot frame (desource+decomment vals))))
	   vals))
	((prog1 
	     (km-slotvals-from-kb frame slot :fail-mode fail-mode)
	   (do-postponed-classifications frame slot)))
	((eq slot '#$name)			; failed to compute it so generate it
	 (let ( (name (km-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.
(defun vals-in-class (vals class)
  (cond ((eq class '*) vals)
	(t (remove-if-not #'(lambda (val) (isa val class)) vals :from-end t))))

;;; returns t if no reserved keywords, nil otherwise
(defun no-reserved-keywords (vals)
  (cond ((not (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 (intersection vals *reserved-keywords*))))
;			 (mapcar #'list (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)
(defun process-unquotes (expr &key (fail-mode 'fail))
  (cond ((null expr) nil)
	((not (listp expr)) expr)
	((eq (first expr) 'unquote)
	 (cond ((not (pairp expr))
		(report-error 'user-error "Unquoted structure ~a should be a pair!~%" expr))
	       (t (vals-to-val (km-int (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)
(defun append-seqs (seq-of-seqs)
  (cond ((or (not (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))))))

(defun append-bags (bag-of-bags)
  (cond ((or (not (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
(defun find-ignored ()
  (mapc #'(lambda (entry)
	    (let* ( (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 (flatten body)) 
		    (ignored-vars (remove-if #'(lambda (var) (member var flat-body)) vars)) )
	      (mapc #'(lambda (ignored-var)
			(km-format t "pattern: ~a - variable ~a ignored~%" pattern ignored-var))
		    ignored-vars)))
	*km-handler-alist*)
  t)
	      

;;; ---------- for Jerome...

(defun rules-for (slot frameadd &key retain-commentsp)
  (let* ( (frame (km-unique-int 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-valuedp (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.
;;; ======================================================================

(defun allof-must (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 #$must ,test)))
	((every #'(lambda (instance) 
		    (km-int (subst instance var test)))
		(km-int set))
	 '#$(t))))

(defun allof-where-must (var set test2 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 ,test2 #$must ,test)))
	((every #'(lambda (instance) 
		    (km-int (subst instance var test)))
		(km-int `#$(allof ,VAR in ,SET where ,TEST2)))
	 '#$(t))))

(defun oneof-where (var set test)
	(cond ((not (km-varp var))
	       (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$oneof ,var #$in ,set #$where ,test)))
	      (t (let* ( (answer (find-if #'(lambda (member)
					      (let ( (test0 (subst member var test)) )
						(km-int test0)))
					  (km-int set))) )
		   (cond (answer (list answer)))))))


;;; FILE: get-slotvals.lisp

;;; File: get-slotvals.lisp
;;; Author: Peter Clark
;;; Purpose: Basic searching for the value of a slot

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

;;; ----------
;;; Control use of inheritance...
;(defparameter *use-inheritance* t)		; moved to header.lisp
;(defparameter *use-prototypes* t)		; moved to header.lisp

(defun use-inheritance ()
  (and *use-inheritance*
       (not (am-in-prototype-mode))))	; no inheritance within prototype mode

(defun use-prototypes ()
  (and *use-prototypes*
       (not (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?).
|#

;;; ======================================================================
		     
(defun km-slotvals-from-kb (instance0 slot &key fail-mode &aux (n 0))	; n for tracing purposes
 (declare (ignore fail-mode))

;;; New pre-classify...
; Neah, not really more efficient...
;  (classify instance0 :slot-of-interest slot)
								; PRELIMINARIES
  (let* ((single-valuedp (single-valued-slotp slot))		; (i) get the slot type
	 (multivaluedp (not single-valuedp))
	 (combine-values-by-appendingp (combine-values-by-appending-slotp slot))

;;; WAS 3 1/2, but move here because prototypes may override inheritance, including subslots.
;;; They may also contribute extra slot values and constraints
;;; ---------- 0 1/2. MERGE IN RELEVANT PROTOTYPES ----------

	  (_clones-dummy (cond ((and *are-some-prototypes*
				     (not (member slot *slots-not-to-clone-for*))
				     (use-prototypes)
				     (not (protoinstancep instance0)))			; NEW: Don't clone a prototype onto another prototype!
				(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
|#	  

;;; ---------- 0 3/4. COLLECT ALL THE RULE DATA NEEDED ----------

;;; NOTE: These basic parameters are computed *after* adding in prototypes, in case the prototypes extended
;;; some of data (specifically, own rules and constraints).
#|
[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))
	  (_check-prototype (cond ((and (protoinstancep instance)
	  			        (not (am-in-prototype-mode)))
			          (report-error 'user-error 
				  "Attempt to query a protoinstance ~a when not in prototype mode!~%         Doing (the ~a of ~a)~%"
				  instance slot instance))))
	  (target `(#$the ,slot #$of ,instance))
	  (own-rule-sets (own-rule-sets instance slot :retain-commentsp t))
	  (own-constraints (mapcan #'find-constraints-in-exprs own-rule-sets))     ; from instance in curr-situation AND its supersituations

	  (inherited-rule-sets-x			; [1]
	   (cond ((use-inheritance)
		  (cond ((and (not own-rule-sets)	; avoid doing this multiple times: If the rule's already fired, don't need to re-refer to 
			      (am-in-local-situation) 					; the Skolem object		
			      (not (fluentp slot)))	; [2]
			 (let ( (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))))))  ; 2D search up classes and sitns

	  (inherited-rule-sets 
	  	(cond (combine-values-by-appendingp 
		       (let ((xx (apply #'append inherited-rule-sets-x)))
		         (cond (xx (list xx)))))
		      (t inherited-rule-sets-x)))
		
	  (inherited-rule-sets-all 	; for constraints with inherits-with-overrides, need ALL constraints still!
	      (cond ((and (use-inheritance)
	                  (not (inherit-with-overrides-slotp slot)))
		     inherited-rule-sets)
		    (t (inherited-rule-sets instance slot :retain-commentsp t 
		                            :ignore-inherit-with-overrides-restriction t))))
	  (inherited-constraints (mapcan #'find-constraints-in-exprs inherited-rule-sets-all))   ; from classes	   

	  (constraints (append inherited-constraints own-constraints))
	  (no-inheritancep (and *use-no-inheritance-flag* (member '#$(no-inheritance) constraints :test #'equal)))

;;; ---------- 1. PROJECTION ----------
;;; [1] NB subslots of prev-situation used for hypothetical reasoning

	  (try-projectionp (and (am-in-local-situation)
				(projectable slot instance)
				(prev-situation (curr-situation) instance)))
  	  (projected-vals0 (cond (try-projectionp
				  (cond ((tracep)
					 (setq 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) (not (traceunifyp)))
				           (let ((*trace* nil))
					     (filter-using-constraints projected-vals0 constraints slot)))
;				           (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)))

;;; [1] explanations for SINGLE-valued slots recorded later
	  (_project1-dummy (cond ((and (tracep)
				       try-projectionp
				       (not (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)		; projection may fail later for single-valued slots (see maybe-project-val below)
				  (let ( (prev-situation (prev-situation (curr-situation) instance)) )
  				           (mapc #'(lambda (projected-val) 
					      (record-explanation-for target projected-val `(#$projected-from ,prev-situation))) 
					  projected-vals)	; [1]
				    (make-comment "Projected (the ~a of ~a) = ~a from ~a to ~a"
							     slot instance projected-vals prev-situation (curr-situation))))))

;;; ---------- 2. SUBSLOTS ----------

	  (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)
					       (setq n (1+ n))
					       (km-trace 'comment "(~a) Look in subslot(s)" n)))
#|Correct|#		       	        (km-int (vals-to-val
				     	      (mapcar #'(lambda (subslot) `#$(the ,SUBSLOT of ,INSTANCE0 (comm ,*SUBSLOT-COMMENT-TAG* Self ,SUBSLOT))) subslots))
				    	     :target target))))))

;;; ---------- 3. SUPERSITUATIONS ----------

#|
[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.
|#
;;; [2] If the slot's a fluent, then we should apply the rules in the global situation to
;;;     make sure the global situation gets updated.
;;;     If it isn't, then we don't need to bother as the result will be posted back to
;;;     the global situation anyway. We collect the "global values" and "global rules" 
;;;     later on and apply them locally here. *EXCEPT* for Events -- where we might not
;;;     apply the global rules locally (if the action's not been carried out yet). 
;;;   QN: What about unactualized actions, where we want to test preconditions? We may
;;;       want to apply global rules to local data to find the action's slot-values, but
;;;	  we block this later at [**]. So we'll miss some info.
;;;     For Events, although their slots are non-fluents, we still might want to collect
;;; blocked, so in this special case we must look up 

#|
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-sets)))
				      (cond ((tracep)
					     (setq n (1+ n))
					     (km-trace 'comment "(~a) Look in supersituation(s)" n)))
; not used any more		      (remove-fluent-instances
				       (km-int (val-sets-to-expr
						(mapcar #'(lambda (sitn) 
							    `#$((in-situation ,SITN (the ,SLOT of ,INSTANCE0))))
							supersituations)
						:combine-values-by-appendingp combine-values-by-appendingp
						:single-valuedp single-valuedp)
					 ))))
|#
	  (supersituation-vals nil)		; disabled now

;;; ---------- 4. LOCAL VALUES ----------

	  (local-vals (cond (own-rule-sets
			      (cond ((tracep)				 ;     val, eg. from lazy unification)
				     (setq n (1+ n))
;				     (km-format t "own-rule-sets = ~a~%" own-rule-sets)
				     (km-trace 'comment "(~a) Local value(s): ~a" n 
					  (val-sets-to-expr own-rule-sets :single-valuedp single-valuedp))))
			      (cond ((and (singletonp own-rule-sets)			 ; (a) no evaluation necessary
					  (singletonp (first own-rule-sets))		; just ONE set of ONE item
					  (atom (first (first own-rule-sets)))
					  (neq (first (first own-rule-sets)) '#$:incomplete)
					  (eql (dereference (first (first own-rule-sets)))
					      (first (first own-rule-sets))))
				      (first own-rule-sets))
				    (t 				 ; (b) some evaluation necesary (eg. path in local slot)
				    (km-int (val-sets-to-expr own-rule-sets 
				    		:combine-values-by-appendingp combine-values-by-appendingp
				    		:single-valuedp single-valuedp) 
					    :target target))))))
	
;;; Need to get these before the intermediate save, which may clobber them!
	  (local-constraints (let ( (local-situation (target-situation (curr-situation) instance slot)) )
			       (find-constraints-in-exprs (bind-self (get-vals instance slot :situation local-situation) instance))))

;;; ---------- (1 or 2)-4. INTERMEDIATE COMBINE AND SAVE OF VALS (but not rules) ----------

#| 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)))   ; [1]
;	  (n-sources (length 
;		      (remove nil 
;			      (list try-projectionp subslots supersituations own-rule-sets inherited-rule-sets))))
	  (n-sources n)			; why bother computing them? Some may be nil, but that's fine.
	  (val-sets (remove-duplicates
		     (remove nil `(,(cond (multivaluedp projected-vals))  ; val-sets *EXCLUDES* inherited-rule-sets
				   ,subslot-vals		
				   ,supersituation-vals
				   ,local-vals))
;				   ,@cloned-valsets))		; now merged in at set 3 1/2
		     :test #'equal))

;	  (_dummy4 (km-format t "DEBUG: val-sets = ~a~%" val-sets))

#|
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)		  	             ; NO val sets found
	    (t (let ( (singletonp-constraints (remove-if-not #'(lambda (constraint)
								 (and (listp constraint)	 ; ignore :incomplete keyword
								      (member (first constraint) '#$(at-most exactly))
								      (= (second constraint) 1)))
							     constraints)) )
		 (cond ((singletonp val-sets)			             ; ONE val set found
			(cond ((not (dont-cache-values-slotp slot))
			(let ( (vals0 (enforce-set-constraints 
					(remove '#$:incomplete (first val-sets)) singletonp-constraints :target target)) )
				 (put-vals instance slot vals0)
				 vals0))
			      (t (first val-sets))))
		       (t (cond ((not (= n-first-source n-sources))
				 (km-trace 'comment "(~a-~a) CombineX ~a-~a together" 
					   n-first-source n-sources n-first-source n-sources)))
			  (let ( (vals0 (enforce-set-constraints
			  			(km-int (val-sets-to-expr val-sets 
				  				:combine-values-by-appendingp combine-values-by-appendingp
						  		:single-valuedp single-valuedp) 
							:target target)
						 singletonp-constraints :target target)) )
					 (cond ((not (dont-cache-values-slotp slot))
				   (put-vals instance slot vals0))) 	          ; <== the intermediate save!!!
			    vals0)))))))

;;; ---------- (1 or 2)-4 & 5. FOLD IN RULES ----------

;;; Execute inherited rule sets
;;; [1] NOTE: local-vals = evaluation of own-rule-sets EXCEPT that :default entries are SKIPPED
;;;     So we'll pick them up again here as if they were inherited
             (inherited-rule-sets00 
	      (cond (*are-some-defaults*
		      (mapcar #'(lambda (expr-set) 
		                      (evaluate-and-filter-defaults expr-set constraints vals slot 
				                                   :single-valuedp single-valuedp))
;			      inherited-rule-sets))
;	  	              (append own-rule-sets inherited-rule-sets)))	; [1]
                              (append (remove nil
                              	       (mapcar #'(lambda (own-rules) ; [1]
						  (find-exprs own-rules :expr-type 'default :plurality 'plural))
					      own-rule-sets))
				      inherited-rule-sets)))	
                    (t inherited-rule-sets)))

;          (_d0 (km-format t "~%instance = ~a, slot = ~a~%" instance slot))		    
;          (_d1 (km-format t "inherited-rule-sets = ~a~%" inherited-rule-sets))
;	  (_d2 (km-format t "inherited-rule-sets00 = ~a~%" inherited-rule-sets00))
;	  (_d3 (km-format t "vals = ~a~%" vals))
;	  (_d4 (km-format t "local-vals = ~a~%" local-vals))	  
;	  (_d5 (km-format t "own-rule-sets = ~a~%" own-rule-sets))
;	  (_d6 (km-format t "constraints = ~a~%" constraints))
	  (all-vals00 
	   (cond ((not (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)
; 8/29/07 - inherit-with-overrides change in semantics - now ALWAYS inherit, even if there's a local value
; NEW: Turn this back on for simple cases					
			((and vals (simple-inherit-with-overrides-slotp slot))
			 (km-trace 'comment "(Ignore rules, as there are local values and the slot is a simple-inherit-with-overrides slot)") 
			 vals)
			(t 				;		(NB inherited-constraints are necessarily in inherited-rule-sets!)
			 (cond ((tracep) 
				(setq 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 single-valuedp)))
				      (t (km-trace 'comment "(~a) From inheritance: ~a" n (val-sets-to-expr inherited-rule-sets00 :single-valuedp single-valuedp))))))
			 (cond (vals (km-trace 'comment "(~a-~a) CombineY ~a-~a together" n-first-source n n-first-source n)))
; 8/29/07 - inherit-with-overrides change in semantics - discard inherited info only if clashes with any local value
			 (cond 
			 ((and vals (inherit-with-overrides-slotp slot))
;			  (km-format t "DEBUG: ~a ~a (~a &? ~a)~%" instance slot vals inherited-rule-sets00)
			    (cond (single-valuedp
;                             (km-format t "constraints = ~a~%" constraints)
	 		      (let ((loc-vals (km-int (vals-to-&-expr vals) :target target)))
			            (km-trace 'comment "See if inherited info is consistent with local vals...")
			            (cond ((km-int `(,loc-vals &? 
 				                  ,(val-sets-to-expr inherited-rule-sets00 :single-valuedp t)))
			    		   (km-trace 'comment "...yes! Inherited info is consistent with local vals. Unifying it in...")		
					   (km-int `(,loc-vals & 
					          ,(val-sets-to-expr inherited-rule-sets00 :single-valuedp t)) 
						  :target target))
					  (t (km-trace 'comment "...no, inherited info isn't consistent with local info, so dropping inherited info.")
					     loc-vals))))   ; drop inherited value if inconsistent with local
				 (multivaluedp
			          (km-trace 'comment "See if inherited info is consistent with local vals...")
				  (let* ((loc-vals (km-int (val-sets-to-expr (list vals)) :target target))
				         (locgen-vals (km-int (val-sets-to-expr (cons loc-vals inherited-rule-sets00))
 				                          :target target)))
				    (cond ((satisfies-constraints locgen-vals constraints slot) 
			    		   (km-trace 'comment "...yes! Inherited info is consistent with local vals. Unifying it in...")		
 				            locgen-vals)
					  (t (km-trace 'comment "...no, inherited info isn't consistent with local info, so dropping inherited info.")
					     loc-vals))))))
			       (t (km-int (val-sets-to-expr (cons vals inherited-rule-sets00) 
				                         :single-valuedp single-valuedp) :target target)))
			 )))
		 (t vals)))

;;; If the rules are recursive, reiterate (just once more)
	 (all-vals0
	  (cond ((and all-vals00 inherited-rule-sets00 (use-inheritance) (not no-inheritancep) (not (dont-cache-values-slotp slot)))
		 (let ( (recursive-rulesets (remove-if-not #'(lambda (ruleset)
							       (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)
		     (km-int (val-sets-to-expr (cons all-vals00 inherited-rule-sets00) :single-valuedp single-valuedp)
			 :target target))
		    (t all-vals00))))
		(t all-vals00)))

;;; ---------- 1-5. CONDITIONAL PROJECTION OF SINGLE-VALUED SLOT'S VALUE ----------

	  (all-vals1
	     (cond (multivaluedp 
		    all-vals0)		; multivalued case: already handled
		   (t (let ( (projected-val (maybe-project-value projected-vals 		; single-valued case: combine only if compatible
								 all-vals0 slot instance n)) )
			(cond (projected-val
			       (record-explanation-for target projected-val `(#$projected-from ,(prev-situation (curr-situation) instance)))
			       (list projected-val))	; EITHER all-vals0 = nil OR all-vals0 & projected-val unified together
			      (t all-vals0))))))			; projection failed - all-vals0 dominated.

;; No! Constraint-checking done in && procedure
;; Later: Yes! Do it here! && misses constraint-checking for non-&& cases
;;;
;; NOTE: all-vals1 can be nil; we might coerce new vals to appear! 
;; LATER: 1/22/08: how can we coerce new vals to appear?? 
;;;		   Maybe I was thinking of when *max-padding-instances* > 0?? Let's add that in as an extra condition.
           (all-vals2 (cond ((and constraints
	                          (or all-vals1 (> *max-padding-instances* 0))		; NEW 1/22/08 
				  )
	                     (cond ((and (tracep) (not (traceconstraintsp)))
			            (let ((*trace* nil))
				      (enforce-constraints all-vals1 constraints :target target)))
				   (t (km-trace 'comment "(~ab) Test values against constraints ~a" n constraints)
				      (enforce-constraints all-vals1 constraints :target target))))
			  (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 _check-prototype _project1-dummy _project2-dummy _clones-dummy))

    (cond ((not (dont-cache-values-slotp slot)) 
           (put-vals instance slot all-vals-and-constraints)		; store result, even if NIL [2]
	   ; NOTE: process-km1-results will record the explanation for vals, but NOT for constraints, so let's do that here
	   (cond (*record-explanations*
;	   (km-format t "target = ~a, vals = ~a, local-constraints = ~a~%" target 
;			   (mapcar #'desource+decomment local-constraints) local-constraints)
		  (mapc #'(lambda (local-constraint)	; local-constraint includes source info
		             (let ((val (desource+decomment local-constraint)))
			       (cond ((not (equal val local-constraint))	; i.e., local-constraint has source info
			              (record-explanation-for target val local-constraint))))) ; so SKIP (constraint ...) 
			local-constraints)))))						; exprs (they're unannotated)
	   
;  Why was classify removed in earlier versions?
;    (classify instance)
; Remove it again. Only at instance creation, and addition of facts via has, do we reclassify

;   (km-format t "Now! all-vals = ~a~%" all-vals)
    (check-slot instance slot all-vals)				; optional error-checking

;   (cond ((am-in-local-situation)
;	   (un-done instance :slot slot :situation (curr-situation))))	; remove flags in all future situations, if there are any
; BETTER:
    (let ( (target-situation (target-situation (curr-situation) instance slot all-vals)) )
      (cond ((and (neq target-situation *global-situation*)
		  (not (equal all-vals-and-constraints (get-vals instance slot :situation target-situation))))
	     (un-done instance :slot slot :situation (curr-situation)))))	; remove flags in all future situations, if there are any

    (cond ((not (dont-cache-values-slotp slot)) (note-done instance slot)))    ; flag instance.slot done in curr situation

    all-vals))

;;; ======================================================================
;;; 			END OF km-slotvals-from-kb!!!
;;; ======================================================================
   
;;; (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.
(defun recursive-ruleset (instance slot ruleset)
  (search `#$(,SLOT of ,INSTANCE) (flatten ruleset)))

;;; ======================================================================
;;;		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.
|#

(defun km-slotvals-via-projection (instance slot)
  (let ((prev-situation (cond (*project-cached-values-only* (prev-situation-with-vals (curr-situation) instance slot))
			      (t (prev-situation (curr-situation) instance)))))
    (cond (prev-situation 
	   (km-int `#$(in-situation ,PREV-SITUATION (the ,SLOT of ,INSTANCE))))
	  ((tracep) (km-trace 'comment "    (Can't compute what ~a's previous situation is)" (curr-situation))))))
  
;;; 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.
(defun maybe-project-value (projected-values local-values slot instance n-sources)
  (cond 
   ((null projected-values) nil)
   ((equal projected-values local-values) (first projected-values))		; NB assume projected-values is a singleton list
   (t (let ( (prev-situation (prev-situation (curr-situation) instance))
	     (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 (let ( (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)		; return projected-value if can unify...
			 (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.
(defun projectable (slot instance)
  (declare (ignore instance))
  (inertial-fluentp slot))

;;; ========================================

;;; See comment under "3/4. COLLECT ALL THE RULE DATA NEEDED" above
(defun reify-existentials-in-rule-sets (rule-sets)
  (mapcar #'reify-existentials-in-rule-set rule-sets))

;;; ((a Car) (the age of Fred)) -> (_Car23 (the age of Fred))
(defun reify-existentials-in-rule-set (rule-set)
  (mapcar #'reify-existentials-in-expr rule-set))

(defun reify-existentials-in-expr (expr)
  (cond ((and (existential-exprp expr)
	      (some #'(lambda (slotvals)
			(fluentp (slot-in slotvals)))
		    (second (breakup-existential-expr expr))))
	 (km-unique-int `#$(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

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

;;; ======================================================================
;;; 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
; (defparameter *deactivate-old-situations* nil)
;(defvar *all-active-situations* nil)
(defvar *classify-slotless-instances* t)

;;; *coerce-undeclared-slot* = t: If see a slot that isn't declared, assert it as (instance-of (Slot))
; (defvar *coerce-undeclared-slots* nil) - in header.lisp

(defun add-to-active-situations (situation) (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))))

(defun all-active-situations () (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 [&key prefix-string bind-selfp target])

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-prototype 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
(defparameter *all-facets* '(own-properties member-properties own-definition member-definition))
(defparameter *valid-cardinalities* '#$(1-to-N 1-to-1 N-to-1 N-to-N))
(defparameter *default-cardinality* '#$N-to-N)

(defparameter *inequality-relations* '(< > <= >= /=))	; for km-assert etc.
(defparameter *equality-relations* '(= &?))

(defun invert-inequality-relation (inequality)
  (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
;;; ======================================================================

(eval-when (:compile-toplevel :load-toplevel :execute)
(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.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant *built-in-seq-aggregation-slots* nil)		; maps (:seq ...) -> value
)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *built-in-set-aggregation-slots*  				  ; maps (:set ...) -> value
  '#$(first second third fourth fifth
      last unification set-unification append number))
)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *built-in-aggregation-slots*
  (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
(defparameter *slots-slots* '#$(domain range cardinality inverse inverse2 inverse3 inverse12 
			      fluent-status inherit-with-overrides simple-inherit-with-overrides aggregation-function))

(eval-when (:compile-toplevel :load-toplevel :execute)
(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 
			simple-inherit-with-overrides fluent-status seq-length bag-length
	      #|prev-situation|# ; but not next-situation (S can have multiple S'-A pairs)
	      after-situation-of ; but not before-situation-of (S can be before multiple A-S' pairs)
; NEW: Now allow actions to be performed more than once, so these are now multivalued
;	      before-situation 
;             after-situation 
	      prototype-participant-of #|prototype-of prototype-scope |#
	      combine-values-by-appending uniquely-called dont-cache-values nowexists
	      abs log exp sqrt floor)
   *built-in-aggregation-slots*))
)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *built-in-multivalued-slots* 
  '#$(domain range #|M-new|# element-type element-type-of
      superclasses subclasses instances instance-of add-list del-list pcs-list ncs-list
      supersituations subsituations subslots superslots 
      slots-to-opportunistically-evaluate
;	      as views useful-views				; for view mechanism
      prev-situation		; modified for Andreas
      next-situation block-projection-for
	      before-situation-of 
; NEW: Now allow actions to be performed more than once, so these are now multivalued
	      before-situation 
	      after-situation 
      domain-of range-of fluent-status-of called
      prototype-participants prototypes prototype-of cloned-from clone-built-from has-built-clones 
      has-clones prototype-scope
      #|text|# #|name print-name <-- should be single-valued!!|# 
      name		; 3.6.00 now allow structures for name, to be stringified later by make-sentence
      #|terms <- no longer built-in |#
      elements ;;; for busting up sequences into their elements
      member-of members  ;;; (used for defining Partitions)
      classes all-instances all-prototypes all-classes all-superclasses all-subclasses all-supersituations all-subslots
      most-specific most-general
      assertions
      == /== 			; NEW 10/3/00 for recording equality and inequality constraint
      < > ))			; NEW 11/6/00 for numeric inequality constraints
)

(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *built-in-slots*
  (append *built-in-single-valued-slots* 
	  *built-in-multivalued-slots*))
)

;;; ======================================================================

#|
(defparameter *built-in-complete-slots* '#$(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* 
    (cond ; ((not *clones-are-global*) '#$(nowexists cloned-from))
	  (t '#$(nowexists))))
(defparameter *built-in-inertial-fluent-slots* *default-built-in-inertial-fluent-slots*)

;;; This can be over-ridden...
;;; cloned-from = new!
(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

;;; Thank you to Roger Corman for this nice bit of code!
;;; Computes the list of non-fluent slots.
;;; As a side effect, it adds the non-fluent slots to the property list of
;;; all the slot names, under the property NON-FLUENT-SLOT (set to true).
;;;
(defun compute-built-in-non-fluent-slots ()
  (let ((ht (make-hash-table :test 'eq :size 200))
        (slots (set-difference *built-in-slots* 
                               (append *built-in-inertial-fluent-slots* *built-in-non-inertial-fluent-slots*))))
    (dolist (x slots)
      (setf (gethash x ht) t))
    ht))
 
;;; May be recomputed if built-in-inertial-fluent-slots changes (see instance-of-is-fluent)
(defparameter *built-in-non-fluent-slots*
    (compute-built-in-non-fluent-slots))

;;; Let's allow the user to toggle these...
(defun instance-of-is-nonfluent () 
  (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*
	(compute-built-in-non-fluent-slots)))

(defun instance-of-is-fluent () 
  (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*
	(compute-built-in-non-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.
(defparameter *built-in-atomic-vals-only-slots* 
; no longer used  (cons *tag-slot*
	'#$(domain range cardinality #|complete|# arity slots-to-opportunistically-evaluate
		   inverse inverse2 inverse3 inherit-with-overrides simple-inherit-with-overrides
		   superclasses subclasses instances
		   instance-of ; (in fact may have constraints, but is handled in immediate-classes so it's as if atomic)
		   supersituations members member-of
		   prototypes prototypes-of 
		   prototype-participants prototype-participant-of 
		   clone-built-from has-built-clones
		   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
		   ; assertions - no, needs to be processed, could have an arbitrary structure including #, etc.
		   ))

;;; DON'T attempt reasoning for these slots, just do a get-vals in the GLOBAL situation and you're done!
;;; They're essentially the *built-in-atomic-vals-only-slots* where inheritance is never expected.
;;; (Note: we might expect domain/range to inherit from slot classes, but let's assume not).
;;; NOTE: if instance-of is fluent, then we'd need to remove it from this list.
;;; (defparameter it earlier, as it's used earlier)
(setq *built-in-nonfluent-lookup-only-slots* 
  (cons '#$prototype-scope 
	(set-difference *built-in-atomic-vals-only-slots*
			'#$(members	   ; may be computed (e.g., in test-suite/constraints.km)
			    assertions)))) ; test-suite.km includes a assertion using #, so must process

;;; (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!
(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).
(defparameter *built-in-remove-subsumers-slots* '#$(instance-of classes 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).
(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
(defparameter *built-in-slots-with-constraints* '#$(instance-of == < > called uniquely-called))

(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 Function))

;;; 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
(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.
(defparameter *built-in-classes-with-no-built-in-superclasses* '#$(Aggregate))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *built-in-instance-of-links*	; in addition to built-in Slots, which are instance-of Slot
  `#$((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
(defun built-in-instance-of-links () *built-in-instance-of-links*)	

(defparameter *valid-fluent-statuses* '#$(*Fluent *Inertial-Fluent *Non-Fluent))

(defparameter *built-in-instances*
  (append *valid-cardinalities* *valid-fluent-statuses* `#$(t f ,*GLOBAL-SITUATION*)))

(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.
(defparameter *non-inverse-recording-slot*
; no longer used  (cons *tag-slot*
	'#$(prototype-scope cardinality aggregation-function #|complete|# add-list del-list pcs-list ncs-list
	     #|cloned-from|# #|label|# 							; [1]
	     inherit-with-overrides simple-inherit-with-overrides #|duplicate-valued|# 
	     called uniquely-called arity nowexists
	     block-projection-for remove-subsumers remove-subsumees :incomplete
	     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))
(defparameter *non-inverse-recording-concept* *built-in-instances*)

;;; Return a string
(defun built-in-concept (concept) (member concept *built-in-frames*))

(defun built-in-slot (slot) (member slot *built-in-slots*))

(defun built-in-bag-aggregation-slot (slot) (member slot *built-in-bag-aggregation-slots*))
(defun built-in-seq-aggregation-slot (slot) (member slot *built-in-seq-aggregation-slots*))
(defun built-in-set-aggregation-slot (slot) (member slot *built-in-set-aggregation-slots*))
(defun built-in-aggregation-slot (slot) (member slot *built-in-aggregation-slots*))

(defun non-inverse-recording-slot (slot) 
  (or (member slot *non-inverse-recording-slot*)
      (get-vals slot '#$ignore-inverses :situation *global-situation* :dereferencep nil)))

(defun non-inverse-recording-concept (concept) (member concept *non-inverse-recording-concept*))

(defun universalp (slot) 
  (gethash slot *built-in-non-fluent-slots*))

(defun built-in-concept-type (concept)
  (cond ((member concept *built-in-single-valued-slots*) "single-valued slot")
	((member concept *built-in-multivalued-slots*) "multivalued slot")
	((member concept *built-in-classes*) "class")
	((member concept *built-in-instances*) "instance")))

(defun combine-values-by-appending-slotp (slot) 
  (or (member slot *built-in-combine-values-by-appending-slots*)
      (get-vals slot '#$combine-values-by-appending :situation *global-situation* :dereferencep nil)))

(defun remove-subsumers-slotp (slot) 
  (or (member slot *built-in-remove-subsumers-slots*)
      (get-vals slot '#$remove-subsumers :situation *global-situation* :dereferencep nil)))

(defun dont-cache-values-slotp (slot)
  (get-vals slot '#$dont-cache-values :situation *global-situation* :dereferencep nil))

(defun remove-subsumees-slotp (slot) 
  (or (member slot *built-in-remove-subsumees-slots*)
      (get-vals slot '#$remove-subsumees :situation *global-situation* :dereferencep nil)))

;;; ======================================================================

(defparameter *val-constraint-keywords* '#$(must-be-a mustnt-be-a <> possible-values excluded-values
						     constraint no-inheritance retain-expr))
(defparameter *set-constraint-keywords* '#$(at-least at-most exactly set-constraint sometimes set-filter))
(defparameter *constraint-keywords* (append *val-constraint-keywords* *set-constraint-keywords*))
(defparameter *constraint-slots* '(== /== < >))			

;;; ======================================================================

;;; Situations
(defvar *curr-situation* *global-situation*)

;;; ======================================================================

(defvar *classification-enabled* t)
;(defvar *postpone-classification* nil)
(defvar *postponed-classifications* nil)
(defvar *prototype-classification-enabled* t)		; i.e."triggers" in AURA
;(defvar *classification-disabled-temporarily* nil)	; reset to nil at each KM call, in case KM bombs when it's set to t
(defvar *installing-inverses-enabled* t)

(defun enable-classification () 
  (km-setq '*classification-enabled* t)
  (km-setq '*prototype-classification-enabled* t)
  '#$(t))

(defun disable-classification () 
  (km-setq '*classification-enabled* nil)
  (km-setq '*prototype-classification-enabled* nil)
  '#$(t))

(defun classification-enabled () *classification-enabled*)
;  (and *classification-enabled* (not *classification-disabled-temporarily*)))

;(defun temporarily-disable-classification () (km-setq '*classification-disabled-temporarily* t))
;(defun remove-temporary-disablement-of-classification ()
;  (km-setq '*classification-disabled-temporarily* nil))

(defun enable-installing-inverses () (cond ((not *installing-inverses-enabled*)
					    (setq *installing-inverses-enabled* t))) '#$(t))
(defun disable-installing-inverses() (setq *installing-inverses-enabled* nil) '#$(t))

;;; ======================================================================

; (defvar *slot-checking-enabled* nil)	 ; in header.lisp

(defun enable-slot-checking () 
  (km-format t "(Run-time checking of slot domain/range constraints enabled)~%")
  (km-setq '*slot-checking-enabled* t)
  t)

(defun disable-slot-checking () 
  (cond ((not *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>) .... )
(defconstant *built-in-subslots* nil)	; if change this, the EDIT immediate-subslots, immediate-superslots too!

(defparameter *built-in-inverses*
  '#$((inverse inverse)				; important!!
      (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)
      (has-clones cloned-from)
      (clone-built-from has-built-clones)
      (has-built-clones clone-built-from)
;      (views as)
;      (as views)
      (/== /==)))				; new 10/3/00

(defparameter *built-in-inverse2s* '#$(
      (next-situation after-situation)		; <S S' A>  -> <A S' S>
      (after-situation next-situation)
      (prev-situation before-situation)		; <S' S A> -> <A S S'>
      (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 km-bind (frame1 frame2) 
;  (cond ((not (eql (dereference frame1) (dereference frame2)))	; [1]
;	 (km-setf frame1 'binding frame2)
;	 (merge-cached-explanations frame1 frame2)
;	 (merge-explanations frame1 frame2))))

;;; REVISED To (optionally) allow ununification
(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 (km-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
;;; [1] NOTE: We delete the frame contents but KEEP it as a known frame, as it has a binding still
(defun km-bind (frame1 frame2) 
  (cond ((not (eql (dereference frame1) (dereference frame2))) ; [1]
	 (cond 
	  ((and *allow-ununify* (kb-objectp frame2))
	   (let* ((situations (all-active-situations))
		  (s+old2s (remove nil
				 (mapcar #'(lambda (situation)
					     (let ((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)		; NEW: Move AFTER the explanations are merged
	 (merge-cached-explanations frame1 frame2)
	 (merge-explanations frame1 frame2)
	 (delete-frame-structure frame1 :remove-from-kb-object-list nil) 	; Note is reversible, with an (undo) [1]
	 (km-setf frame1 'binding frame2)
	 )))

; Optimized version from Francis Leboutte
;(defun get-binding (frame) (get frame 'binding))
(defun get-binding (frame)
  (declare (type symbol frame))
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (get frame 'binding))

(defun bound (frame1) (get frame1 'binding))

;;; RENAMING CLASSES - not called directly from KM
(defun rename-class (old-class new-class)
  (cond ((eq old-class new-class)
	 (make-comment "(rename-class ~a ~a) - The two classes are identical (ignoring)!~%" old-class new-class))
	((neq (dereference old-class) old-class)
	 (report-error 'user-error
		       "(rename-class ~a ~a) - ~a has already been renamed (to ~a), so can't rename it again!~%" 
		       old-class new-class old-class (dereference old-class)))
	((unusable-frame-name new-class)
	 (report-error 'user-error "(rename-class ~a ~a) - ~a is already in use, so can't rename to it!~%"
		       old-class new-class new-class))
	(t (km-put-list new-class (subst new-class old-class (km-symbol-plist old-class)))
	   (km-setf old-class 'binding new-class)
	   (km-add-to-kb-object-list new-class))))

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

;;; 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
(defun dereference (frame)
  (cond ((and *dereferencing-on* (needs-dereferencing frame)) (dereference0 frame))
	(t frame)))

 (defun dereference0 (frame)
  (declare (optimize (speed 3) (safety 0)))
  (cond ((null frame) nil)
	((symbolp frame)
	 (let ((binding (get-binding frame)))
 	   (cond (binding (dereference0 binding))
		 (frame))))
 	((listp frame)			; [1]
	 (let* ((frame0 (car frame))
		(rframe (cdr frame))
		(dframe0 (dereference0 frame0))
		(drframe (dereference0 rframe)))
	   (if (and (eql frame0 dframe0) (eql rframe drframe))
	       frame
	     (cons dframe0 drframe))))
 	(t frame)))
 
(defun needs-dereferencing (frame)
  (declare (optimize (speed 3) (safety 0)))
  (cond ((symbolp frame) (get-binding frame))
	((listp frame) (list-needs-dereferencing frame))))

(defun list-needs-dereferencing (list)
  (declare (optimize (speed 3) (safety 0))
	   (list list))
  (cond ((null list) nil)
	((symbolp list) (get-binding list))	 ; for recursive call when list = (a . b)
	(t (let ((list0 (car list))
		 (list1 (cdr list)))
	     (or (cond ((symbolp list0) (get-binding list0))
		       ((listp list0) (list-needs-dereferencing list0)))
		 (list-needs-dereferencing list1))))))

;;; dereference things, INCLUDING nullifying deleted frames
;;; Note: deleted frames are NOT KB concepts, but may still be mentioned elsewhere in the KB.
;;; They should have no internal structure, as delete-frame deleted it all.
(defun dereference-kb ()
  (let ((deleted-frame-alist (mapcar #'(lambda (f) `(,f . nil)) *deleted-frames*)))
    (mapc #'(lambda (concept)
	      (let* ((symbol-plist (symbol-plist concept))
		     (new-symbol-plist (sublis deleted-frame-alist (dereference symbol-plist))))
		(cond ((not (equal symbol-plist new-symbol-plist))
		       (setf (symbol-plist concept) new-symbol-plist)))))
;	  (get-all-concepts)	- no, misses comments
	  (mapcar #'dereference (get-all-objects)))	; note that comments also need to be dereferenced
    (mapc #'(lambda (concept)
	      (cond ((bound concept) (delete-frame-structure concept))))
	  (get-all-objects))		; non-dereferenced list, includes things bound to other things
    (setq *deleted-frames* nil)
    t))

#|
OLD LESS EFFICIENT
(defun dereference0 (frame)
  (cond ((symbolp frame)
	 (let ( (binding (get-binding frame)) )
	   (cond (binding (dereference0 binding))
		 (t frame))))
	((listp frame)				; [1]
	 (mapcar #'dereference0 frame))
	(t frame)))

(defun needs-dereferencing (frame)
  (cond ((symbolp frame) (get-binding frame))
	((listp frame) (some #'needs-dereferencing frame))))
|#
;;; ----------

(defun show-bindings ()
  (mapcar #'show-binding (get-all-objects)) (terpri) t)

; No - this won't unmerge explanations! See ununify below for more sophisticated but untested approach
;(defun unbind ()
;  (mapcar #'(lambda (frame) (km-bind frame  nil)) (get-all-objects)) t)

;;; _X -> _Y, then we (delete-frame _Y), means any old references to _X in the KB should now return nil.
;;; NOTE: 'deleted is a flag that we DO assert a value, and dereference returns NIL as a result.
; (defun bind-to-nil (frame) (km-bind frame 'deleted) t)

(defun show-binding (frame)
  (cond ((get frame 'binding) 
	 (terpri) (km-format t "~a" frame) (show-binding0 (get-binding frame)))))

(defun show-binding0 (frame)
  (cond (frame (km-format t " -> ~a" frame)
	       (cond ((symbolp frame) (show-binding0 (get-binding frame)))))))

;;; ---------- UNUNIFICATION ---------- (new)

;;; Test
(defun ununifiable (frame2) (get frame2 'ununify-data))

(defun ununify (frame2)
  (let* 
      ((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
     ((not *allow-ununify*)
      (make-comment "(ununify ~a): Ununification is turned off -- do (setq *allow-ununify* t) to enable it.~%" frame2))
     ((not (eql 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 (km-bind frame1 nil)		; unbind
	(let ((s+old2s-deref (dereference s+old2s))) ; important (and  do after unbind)
	  (mapc #'(lambda (situation)
		    (let* ((s+old2 (assoc situation s+old2s-deref))
			   (old1-slotsvals (get-slotsvals frame1 :situation situation))
			   (old2-slotsvals (second s+old2))) ; may be nil
		      (cond
		       (old1-slotsvals
			(in-situation situation) ; for each situation		    
			(mapc #'(lambda (old1-slotvals)
				  (let* ((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)
									    (and (kb-objectp old1-val)
										 (not (member old1-val old2-vals))))
									old1-vals))
					 )
;				    (km-format t "old1-vals = ~a~%" old1-vals)
;				    (km-format t "old2-vals = ~a~%" old2-vals)
;				    (km-format t "old1-only-vals = ~a~%" old1-only-vals)
; Remove old1-val from new2-vals inc inverses.
; NOTE: fast-delete-val in case old1-val is embedded in a ((_X) && (<old1-val>)) structure of the like
				    (mapc #'(lambda (old1-val) (fast-delete-val frame2 slot old1-val)) old1-only-vals)
; re-establish pointers back to frame1 (were removed after binding frame1 -> frame2)
				    (install-inverses frame1 slot old1-vals)
				    ))
			      old1-slotsvals)))))
		(all-active-situations)))
	(km-setf frame2 'ununify-data (rest ununify-data))
	(change-to-situation curr-situation) ; Revert back to original situation
	t))))

;;; Flattens any & and && structures
(defun km-flatten (vals) (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)) )

(defun slot-in (slotvals) (first slotvals))

; Optimized version below from Francis Leboutte
;(defun vals-in (slotvals)
;  (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)))))
(defun vals-in (slotvals)
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (let ((second (second slotvals)))
    (if (listp second)
      second
      (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))))

(defun make-slotvals (slot vals) (list slot vals))

(defun are-slotsvals (slotsvals)
  (cond 
   ((not (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)
	     (cond
		((not (pairp slotvals))
		 (report-error 'user-error "Bad structure ~a for slot+values!~%Slot+values should be of the form (slot (v1 ... vn))~%" slotvals))
		((not (symbolp (slot-in slotvals)))
		 (report-error 'user-error "Bad structure ~a for slot+values!~%Slot `~a' should be a symbol!~%"
			       slotvals (slot-in slotvals)))
		((not (listp (second slotvals)))
		 (report-error 'user-error "Bad structure ~a for slot+values!~%Values ~a for slot ~a should be a list!~%"
			       slotvals (second slotvals) (slot-in slotvals)))
		((member (slot-in slotvals) *reserved-keywords*)
		 (report-error 'user-error "Bad structure ~a for slot+values!~%The slot `~a' is a reserved KM keyword, and cannot be used as a slot name!~%" 
			       slotvals (slot-in slotvals)))
		((no-reserved-keywords (vals-in slotvals))		; generates its own error otherwise
		 (cond ((or (some #'(lambda (val) (and (listp val) (member (first val) *constraint-keywords*))) (vals-in slotvals))
			    (member (slot-in slotvals) *constraint-slots*))
			(note-are-constraints)))
		 (cond ((some #'km-defaultp (vals-in slotvals)) (km-setq '*are-some-defaults* t)))
		 (cond ((member (slot-in slotvals) '#$(called)) (km-setq '*are-some-tags* t)))
		 (cond ((member (slot-in slotvals) '#$(uniquely-called)) (km-setq '*are-some-tags* t) (km-setq '*are-some-constraints* t)))
;		 (cond ((member (slot-in slotvals) '#$(useful-views views)) (km-setq '*are-some-views* t)))
		 (cond ((member (slot-in slotvals) '#$(subslots superslots)) (km-setq '*are-some-subslots* t)))     ; optimization flag
		 (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 #$with &rest	   simple update of #$prototype-participants slot
 - create-named-instance 		   add-val newframe #$prototype-participant-of (curr-prototype)
 - try-classifying		           add-val instance '#$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 '#$cloned-from prototype
 - clone0				   add-val instance '#$cloned-from prototype
|#

;;; RETURNS: irrelevant and discarded
; (defun add-vals (instance slot vals &optional (install-inversesp t) (situation (curr-situation)))
(defun   add-vals (instance slot vals &optional (install-inversesp t) (situation (target-situation (curr-situation) instance slot)))
  (mapc #'(lambda (val)
	    (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
;(defun add-val (instance slot val &optional (install-inversesp t) (situation (curr-situation)))
(defun  add-val (instance slot val &optional (install-inversesp t) (situation (target-situation (curr-situation) instance slot)))
  (let* ( (oldvals1 (get-vals instance slot :situation situation))	 ; includes dereferencing
; [2]	  (oldvals1 (remove-dup-instances oldvals0))    ; rem-dups does dereference also    - very inefficient if lots of values, and redundant!
	  (oldvals (cond ((single-valued-slotp slot) (un-andify oldvals1))
			 (t oldvals1))) )
;   (km-format t "add-val: oldvals1 = ~a, oldvals = ~a~%" oldvals1 oldvals)
    (cond 
     ((null oldvals) 
      (un-done instance :slot slot :situation situation)	; [rather than just (un-done instance)]
      (put-vals instance slot (list val) :install-inversesp install-inversesp :situation situation))
     ((member val oldvals :test #'equal))		; val is already there, everything uptodate
     ((single-valued-slotp slot) 
           (un-done instance :slot slot :situation situation)  ; [rather than just (un-done instance)]
	   (put-vals instance slot 
		     (val-to-vals (vals-to-&-expr (append oldvals (list val))))
		     :install-inversesp nil 		 ; install-inversesp would be ineffective here, as we've a STRUCTURE 
		     :situation situation)		
	   (cond (install-inversesp 
		  (install-inverses instance slot (list val) situation))))	  ; NOW do it manually for the new value...
     ((remove-subsumers-slotp slot)	  				  ; eg. instance-of, superclasses. See [1]
      (cond ((some #'(lambda (oldval) (is-subclass-of oldval val)) oldvals)) ; don't need it
	    (t #|NEW|#	   (un-done instance :slot slot :situation situation)
	       (put-vals instance slot 
;;; Unnecessary overwork! ->  (remove-subsumers (cons val oldvals))
#|NEW|#			      (cons val (remove-if #'(lambda (oldval) (is-subclass-of val oldval)) oldvals))
			      :install-inversesp install-inversesp :situation situation)
	       )))
     ((remove-subsumees-slotp slot)					  ; eg. subclasses
      (cond ((some #'(lambda (oldval) (is-subclass-of val oldval)) oldvals)) ; don't need it!
	    (t #|NEW|#	   (un-done instance :slot slot :situation situation)
	       (put-vals instance slot 
;;; Unnecessary overwork! ->  (remove-subsumees (cons val oldvals)) 
#|NEW|#			      (cons val (remove-if #'(lambda (oldval) (is-subclass-of oldval val)) oldvals))
			      :install-inversesp install-inversesp :situation situation))))
     ((&&-exprp oldvals)
      (let ( (valsets (&&-exprs-to-valsets oldvals)) )
	  (cond 
	   ((some #'(lambda (valset) (member val valset :test #'equal)) valsets))	 ; already there
	   (t (un-done instance :slot slot :situation situation)
	      (let ( (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 #'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. 
If vals is non-nil, the new vals will overwrite the old vals.
	**NOTE** DOESN'T remove inverse links or scan through situations for any deleted old vals, so you shouldn't
	use put-vals to destructively change vals unless you are absolutely sure no inverses need removing. (Instead,
	use (X now-has Y) which does handle inverses)
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
[1] NOTE: Normally:
     (km '#$(_Cat1 has (color ((*black [comment1])))))
will assert
     (_Car1 has (color (*black)))	and an explanation (_Car1 color *black) (*black [comment1])
This is fine, with one exception: 
     (km '#$(_Cat1 has (prototype-scope ((the-class Cat [comment1])))))
When we assert this, we DO need to retain the comment tags, as when testing prototype-scope, we:
	(i) check a new instance is covered by the prototype-scope
	(ii) call (record-explanation-for instance new-class `(,instance isa ,prototype-scope)) in prototypes.lisp
In the latter case, we need to retain the comments in the prototype-scope expression.
|#
(defvar *trace-prototype-assertions* nil)

;(defun put-vals (instance slot vals0 &key (facet 'own-properties) (install-inversesp t) (situation (curr-situation)))
(defun  put-vals (instance slot vals0 &key (facet 'own-properties) (install-inversesp t) (situation (target-situation (curr-situation) instance slot)))
  (cond 
   ((and (some #'protoinstancep (cons instance vals0))
	 (neq situation *global-situation*))
    (report-error 'user-warning
			 "Attempt to assert fact about protoinstance(s) ~a in a local situation (~a) - not allowed!
         All protoinstance facts should be asserted in the global situation.
         I was asserting (~a has (~a ~a)) in ~a.
         I will recover by asserting this fact in the global situation (*Global) instead....~%"
			 (delistify (remove-if-not #'protoinstancep (cons instance vals0))) situation
			 instance slot vals0 situation)
    (put-vals instance slot vals0 :facet facet :install-inversesp install-inversesp :situation *global-situation*))
   (t (cond ((and *trace-prototype-assertions*	; This error check is purely for debugging. Only switch on when changes to prototypes are *NOT* being made.
		(some #'protoinstancep (cons instance vals0))
		(not (am-in-prototype-mode))
		(anonymous-instancep instance)
		(not (member slot '#$(instances ; instance-of
				    prototypes ; prototype-of
;				    prototype-scope      
				    has-clones cloned-from
				    has-built-clones clone-built-from 
;				    prototype-participants prototype-participant-of 
				    ))))
	     (report-error 'user-error 
			 "Attempt to assert with protoinstance(s) ~a when not in prototype mode!~%         Doing (the ~a of ~a) = ~a~%"
			 (delistify (remove-if-not #'protoinstancep (cons instance vals0)))
			 slot instance vals0)))
      (let* ((vals (cond ((and (member facet '(own-properties own-definition))
			       (not (eql slot '#$prototype-scope))) ; [1]
			  (remove-sources-from-vals instance slot vals0))
			 (t vals0)))
	     (class-vals (cond ((eq slot '#$superclasses) (cons instance vals)) ; specifically for disjointness test, to spot
			       (t vals)))) ; (X superclasses Y) violates Partition {X Y}
	(cond (*slot-checking-enabled* (check-domain-and-range instance slot vals)))
	(cond 
	 ((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))
	 ((not (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))
	 ((and (member slot '#$(instance-of superclasses))
	       (disjoint-classes (remove-if-not #'kb-objectp class-vals)))
	  (let* ((violated-partitions
		  (remove-duplicates (remove-singletons (disjoint-classes (remove-if-not #'kb-objectp class-vals))))))
	    (report-error 'user-error `(|partition-violation| ,instance ,slot ,class-vals ,violated-partitions)
			  "Partition violation! ~a ~a ~a:~%Some of these classes are mutually exclusive, partition(s) ~a were violated.~%"
			  instance slot vals (delistify violated-partitions))))
	 (t 
	  (cond ((and (not (isa slot '#$Slot)) ; Do this *after* checking instance-of above!
		      *coerce-undeclared-slots*)
		 (add-val slot '#$instance-of '#$Slot t *global-situation*))) ; install-inversesp = t
	  (let* ( ; (target-situation (target-situation situation instance slot vals)) ; compute target situation AFTER potentially changing fluent status
		 (target-situation situation) ; 1/24/11 - PEC No, that's overly complex and not needed I think
		 (old-slotsvals (get-slotsvals instance :facet facet :situation target-situation)) 
		 (old-vals (vals-in (assoc slot old-slotsvals))) )

;;; Below is too slow with a large KB, so make it switchable (default off). We do this in case obj stack is flushed
;;; (requested by Andre Renard)	
	    (cond (*active-obj-stack* (mapc #'push-to-obj-stack `(,instance ,@vals))))
	    
	    (cond 
	     ((equal vals old-vals) vals)
	     (t (let ( (putobj-facet (curr-situation-facet facet target-situation)) )
		  (cond ((not (known-frame instance)) (push-to-obj-stack instance))) ; new, 3.7.00
		  (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 ((eq slot '#$prototype-scope)
				  (mapc #'(lambda (val)
					    (let ((parent-classes
						   (cond ((kb-objectp val) (list val)) ; Cat
							 ((class-descriptionp val :fail-mode 'error) ; (the-class Cat)  - KB error otherwise!
;						      (list (first (class-description-to-class+slotsvals val)))
							  (classes-in-description val)) ; better - get *all* the classes (the-class C1 with (instance-of (C2)))
							 )))
					  ;;; NOTE: Nov 2009: Added this so that (classify ...) also considers unifying
					  ;;; in prototypes, hence doing eager classification with prototypes.
					  ;;; Note that even single class prototype-scopes are registered here, as they
					  ;;; are still considered worth unifying in.
					  ;;; In addition, all-applicable-prototypes was modified to use this info.
					      (point-parents-to-defined-concept instance parent-classes
										'prototype-definition
										:simple-classp (kb-objectp val))))
					vals)))
			   (cond ((and (member facet '(own-definition own-properties))
				       install-inversesp)
				  (install-inverses instance slot (ordered-set-difference vals old-vals) target-situation)))
;		       (cond ((and *are-some-views*
;				   (eq slot '#$instance-of))
;			      (install-views instance (remove-if #'constraint-exprp (set-difference vals old-vals)))))
			   ))))))))
	instance))))

;;; This function now ONLY ever used by lazy-unify.lisp
(defun put-slotsvals (frame slotsvals &key (facet 'own-properties) (install-inversesp t) (situation (curr-situation)))
    (mapc #'(lambda (slotvals)
	      (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!
(defun reorder-slotsvals (slotsvals)
  (let ( (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))))
  
;;; --------------------

;;; ONLY used by KM itself to remove redundant superclasses, nowhere else within KM (though outside applications my use it)
(defun delete-val (instance slot val &optional (uninstall-inversesp t)
  						(situation (target-situation (curr-situation) instance slot)))
  (let* ( (oldvals0 (get-vals instance slot :situation situation))
	  (oldvals1 (remove-dup-instances oldvals0))    ; rem-dups does dereference also
	  (oldvals (cond ((single-valued-slotp slot) (un-andify oldvals1))
			 (t oldvals1))) )
    (cond ((not (member val oldvals :test #'equal))
	   (km-format t "Warning! Trying to delete non-existent value ~a on (the ~a of ~a)!~%" val slot instance))
	  ((single-valued-slotp slot) 
	   (let ((new-val (vals-to-&-expr (remove val oldvals :test #'equal))))
	     (put-vals instance slot (cond (new-val (list new-val))) :install-inversesp nil :situation situation))
					; uninstall-inversesp would be ineffective here, as we've a STRUCTURE 
	   (delete-explanation instance slot val :explanation-to-delete 'all :situation situation)
	   (cond (uninstall-inversesp 
		  (uninstall-inverses instance slot (list val) situation) ; NOW do it manually for the new val
; Moved to uninstall-inverses
; 		  (delete-explanation val (invert-slot slot) instance :explanation-to-delete 'all :situation situation)
		  ))
	   (un-done instance :situation situation) ; 1.4.0-beta8: Don't forget this! Important!!
	   t)
	  (t (put-vals instance slot (remove val oldvals :test #'equal) :install-inversesp nil :situation situation)
	     (delete-explanation instance slot val :explanation-to-delete 'all :situation situation)	     
	     (cond (uninstall-inversesp 
		    (uninstall-inverses instance slot (list val) situation) ; NOW do it manually for  new val
		    (delete-explanation val (invert-slot slot) instance :explanation-to-delete 'all :situation situation)))
	     (un-done instance :slot slot :situation situation)	; 3/28/08 - for good measure 
	     t))))

;;; 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.
(defun fast-delete-val (instance slot val0 &optional (uninstall-inversesp t) 
						(situation (target-situation (curr-situation) instance slot)))
  (let* ((val (dereference val0))
	 (old-vals (get-vals instance slot :situation situation))
	 (new-vals (subst nil val old-vals)))
    (cond ((not (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
; (defun uninstall-inverse (frame slot val0 &optional (situation (curr-situation)))
(defun   uninstall-inverse (frame slot val0 &optional (situation (target-situation (curr-situation) frame slot)))
  (cond ((not (non-inverse-recording-slot slot))		
	 (let ((invslot (invert-slot slot)) 
	       (val (dereference val0)))
	   (cond ((and (kb-objectp val)
		       (not (non-inverse-recording-concept val))) ; eg. don't want boolean (T has (open-of (Box1))
		  (let* ((old-vals (get-vals val invslot :situation situation))
			 (new-vals (subst nil frame old-vals)))
		    (cond ((not (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.
(defun target-situation (situation instance slot &optional vals)
  (cond ((eq situation *global-situation*) *global-situation*)	; efficiency: Avoid needless lookups for (fluentp slot)
	((and slot (universalp slot)) *global-situation*) ; NB fluent -> non-universal, by definition
	((and slot (protoinstancep instance)) *global-situation*) ; All prototype info is in global
	((and slot
	      (nor (fluentp slot)
		   (isa-theory situation))) *global-situation*) ; instance-of will normally pass this test
	((and (eq slot '#$instance-of)				; special handling for when (instance-of-is-fluent) is true
	      (some #'(lambda (val)
			(some #'(lambda (class) (is-subclass-of val class)) 	; e.g. (put-vals _Sit1 instance-of Situation)
			      *built-in-classes-with-nonfluent-instances-relation*)) ;				   ^^ val ^^
		    vals))
	 *global-situation*)
	((and (eq slot '#$instances)
	      (some #'(lambda (class) (is-subclass-of instance class))		; e.g. (put-vals Situation instances _Sit1)
		    *built-in-classes-with-nonfluent-instances-relation*))	;		 ^instance^
	 *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))
(defun get-vals (frame slot &key (facet 'own-properties) (situation (target-situation (curr-situation) frame slot)) (dereferencep t))
  (cond ((and (symbolp slot) 
;	      (is-km-term frame))		; bug
	      (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)))))) ; deref=nil
	((not (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))))

;;; Get from multiple frames:
(defun gets-vals (frames slot &key (facet 'own-properties) (situation (target-situation (curr-situation) (first frames) slot)) (dereferencep t))
  (remove-duplicates
   (my-mapcan #'(lambda (frame)
		  (get-vals frame slot :facet facet :situation situation :dereferencep dereferencep))
	      frames)
   :test #'equal
   :from-end t))

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

; (defun get-unique-val (frame slot &key (facet 'own-properties) (situation (curr-situation)) (fail-mode 'fail))
(defun get-unique-val (frame slot &key (facet 'own-properties) (situation (target-situation (curr-situation) frame slot)) (fail-mode 'fail))
  (let ( (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)
(defun get-slotsvals (frame &key (facet 'own-properties) (situation (curr-situation)) (dereferencep t))
  (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

;(defun inherited-rule-sets (instance slot &key (situation (curr-situation)) 
(defun  inherited-rule-sets (instance slot &key (situation (target-situation (curr-situation) instance slot))
					       retain-commentsp (climb-situation-hierarchyp t) 
					       ignore-inherit-with-overrides-restriction)
  (let ((rulesets+classes (inherited-rulesets+classes instance slot :situation situation 
						      :retain-commentsp retain-commentsp 
						      :climb-situation-hierarchyp climb-situation-hierarchyp
						      :ignore-inherit-with-overrides-restriction
						      ignore-inherit-with-overrides-restriction
						      )))
    (remove-duplicates (apply #'append (mapcar #'first rulesets+classes)) ; strip off classes
		       :test #'equal :from-end t)))

;;; RETURNS: a list of (<class> (<ruleset1> <ruleset2>...)) 
(defun inherited-rulesets+classes (instance0 slot &key ; (situation (curr-situation)) 
						         (situation (target-situation (curr-situation) instance0 slot))
							 retain-commentsp 
							 (climb-situation-hierarchyp t) ignore-inherit-with-overrides-restriction)
  (let* ((instance (dereference instance0))
	 (all-situations (cond ((not 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 ((and (inherit-with-overrides-slotp slot) (not ignore-inherit-with-overrides-restriction))
	   (desource+decomment
	    (bind-self (inherited-rule-sets+classes-with-overrides slot (immediate-classes instance) (append all-situations visible-theories)) instance)
	    :retain-commentsp retain-commentsp))
	  (t (desource+decomment 
	      (bind-self (inherited-rule-sets+classes2 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 rulesets+class pairs
(defun inherited-rule-sets+classes-with-overrides (slot classes all-situations)
  (mapcan #'(lambda (class)
	      (inherited-rule-sets+classes-with-overrides2 slot class all-situations))
	  classes))

;;; Simpler version, strip off classes
(defun inherited-rule-sets-with-overrides (slot classes all-situations)
  (let ((rulesets+classes (inherited-rule-sets+classes-with-overrides slot classes all-situations)))
    (remove-duplicates (apply #'append (mapcar #'first rulesets+classes)) ; strip off classes
		       :test #'equal :from-end t)))

;;; RETURNS: A list of rule sets. Is MAPCAN-SAFE
;;; [1] e.g., rule-sets+classes = (((((mustnt-be-a Formula))) Hydrocarbon-Molecule))
(defun inherited-rule-sets+classes-with-overrides2 (slot class all-situations)
  (let ((rule-sets+classes (inherited-rule-sets+classes2 slot (list class) all-situations)))   ; [1]
    (cond (
	   (some #'(lambda (rule-sets+class)
		     (some #'(lambda (rule-set)
			       (some #'(lambda (rule)
					 (not (constraint-exprp rule)))
				     rule-set))
			   (first rule-sets+class)))
		 rule-sets+classes)
	   rule-sets+classes)	; found something (which isn't just a constraint)! So stop along this (upward) branch.
	  ((neq class '#$Thing)
	   (inherited-rule-sets+classes-with-overrides slot (immediate-superclasses class) all-situations)))))

;;; ----------
(defun inherited-rule-sets2 (slot classes situations)
  (let ((rulesets+classes (inherited-rule-sets+classes2 slot classes situations)))
    (remove-duplicates (apply #'append (mapcar #'first rulesets+classes)) ; strip off classes
		       :test #'equal :from-end t)))
  
;;; Find all the rule sets on all the classes in all the situations
;;; Is MAPCAN SAFE
;;; RETURNS: A list of rulesets+class pairs
(defun inherited-rule-sets+classes2 (slot classes situations)
  (remove nil				; tidy up answer...
   (mapcar #'(lambda (class)
	       (let ((rule-sets (remove-duplicates
				 (remove nil (mapcan #'(lambda (situation)
							 (get-rule-sets-in-situation class slot situation))
						     situations))
				 :test #'equal)))
		 (cond (rule-sets (list rule-sets class)))))
	   classes)))			; (includes situation)

#|
RETURNS: a LIST of VALUE-SETS
(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 #'list
		  (append (mapcan #'&-expr-to-vals '(1 2 (3 & 4)))
			  (mapcan #'&-expr-to-vals '((3 & 4)))))
((1) (2) (3) (4) (3) (4))
|#
(defun get-rule-sets-in-situation (class slot situation)
  (cond ((single-valued-slotp slot)
	 (mapcar #'list
		 (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 #'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 retain-commentsp (situation (curr-situation)))
 (let ( (start-situation (target-situation situation instance slot)) )		; [2]
  (desource+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)))
|#

;(defun own-rule-sets (instance slot &key retain-commentsp (situation (curr-situation)))
(defun  own-rule-sets (instance slot &key retain-commentsp (situation (target-situation (curr-situation) instance slot)))
 (let ( (start-situation (target-situation situation instance slot)) )		; [2]
  (desource+decomment
   (bind-self
    (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.
|#
;(defun supersituation-own-rule-sets (instance slot &key retain-commentsp (situation (curr-situation)))
(defun supersituation-own-rule-sets (instance slot &key retain-commentsp (situation (target-situation (curr-situation) instance slot)))
  (cond 
   ((and (isa-clone instance)								; [2]
	 (neq situation *global-situation*)
	 (inertial-fluentp slot)
	 (get-vals situation '#$prev-situation :situation *global-situation*))   ; [1]
    nil)
   (t (let ( (all-supersituations (cond ((and (neq situation *global-situation*)
					      (fluentp slot))
					 (all-supersituations situation))))
	     (visible-theories (visible-theories)) )
	(desource+decomment
	 (remove-duplicates
	  (remove nil
		  (my-mapcan #'(lambda (sitn)
				 (&&-exprs-to-valsets
; Not used any more		  (recursive-remove-fluent-instances	; in case of ((_someCar1 & (must-be-a Car))
				   (or (get-vals instance slot :facet 'own-properties :situation sitn)     ; This disjunct should be in get-vals-
				       (get-vals instance slot :facet 'own-definition :situation sitn))))  ; in-situation, not here,+ should be conj!
			     (append all-supersituations visible-theories)))
	  :test #'equal :from-end t)
	 :retain-commentsp retain-commentsp)))))

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

;;; Find all the constraints on an instance's slot.
;;; RETURNS: a list of constraint expressions
;;; 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!
(defun collect-constraints-on-instance (instance slot &key retain-commentsp ignore-prototypes 
;							   (situation (curr-situation)))
							   (situation (target-situation (curr-situation) instance slot)))
  (let ((constraints+sources
	 (collect-constraints+sources-on-instance instance slot :situation situation :retain-commentsp retain-commentsp
						  :ignore-prototypes ignore-prototypes)))
    (remove-duplicates (mapcar #'first constraints+sources) :test #'equal :from-end t)))

;;; RETURNS: a list of (<constraint> <sources>) where <sources> is a list of sources where <constraint> was found
;;; Each <source> in <sources> is either a CLASS or an INSTANCE or (cloned-from <prototype-root> <clone-root>)
;;; For constraints from UNCLONED prototypes, <source> is simply CLASS of the prototype
;;; Used for AURA - see aura-api.txt
(defun collect-constraints+sources-on-instance (instance slot &key ; (situation (curr-situation)) 
							             (situation (target-situation (curr-situation) instance slot))
								     retain-commentsp ignore-prototypes)
  (cond ((and *are-some-constraints*								; optimization flag
	      (or (member slot *built-in-slots-with-constraints*)
		  (not (member slot *built-in-slots*))))
; HLO-2308: make sure constraints on prototypes are unified in:
; 	 (cond (*are-some-prototypes* (km `(#$the ,slot #$of ,instance)))) 
; HLO-2325: The above line is too aggressive, and causes infinite reasoning. Let's try something simpler at [2]
	 (let* ((inherited-rulesets+classes
		 (inherited-rulesets+classes instance slot :situation situation :retain-commentsp t)) 
		(inherited-constraints+classes	; list of (class constraints)
		 (mapcan #'(lambda (rulesets+class)
			     (let* ((rulesets (first rulesets+class))
				    (class (second rulesets+class))
				    (constraints (remove nil (mapcan #'find-constraints-in-exprs rulesets))))
			       (mapcar #'(lambda (constraint) (list constraint class)) constraints)))
			 inherited-rulesets+classes))
		(own-constraints (remove-duplicates
				  (mapcan #'find-constraints-in-exprs ; from instance in curr-sitn + its supersituations
					  (own-rule-sets instance slot :situation situation))
				  :test #'equal))
		(own-constraints+sources
		 (mapcan #'(lambda (own-constraint)	; [1] NB get-explanations also looks in *Global
			     (let ((isv-explanations (get-explanations instance slot own-constraint situation))) ;[1]
			       (or (remove nil
				    (mapcar #'(lambda (explanation)
						(cond ((and (eq (explanation-type explanation) '#$cloned-from)
							    (not (member (second explanation) ignore-prototypes)))
						       (list own-constraint (simplify-cloned-from explanation)))))
					    (my-mapcan #'explanation-in isv-explanations)))
				   (list (list own-constraint instance)))))	; new
			 own-constraints))
#|[2]|#		(prototype-constraints+sources (prototype-constraints+sources instance slot 
									      :ignore-prototypes ignore-prototypes)))
	   (mapcar #'(lambda (key+vals)  ; remove duplicates from vals
		       (list (first key+vals) (remove-duplicates (second key+vals) :test #'equal :from-end t)))
		   (gather-by-key (desource+decomment (append inherited-constraints+classes own-constraints+sources
						      prototype-constraints+sources)
					      :retain-commentsp retain-commentsp)))))))

;;; [1] Simply discard constraints that refer to prototype instances (other than the root)
;;; This means some complex constraints won't be found, but hope that's good enough. HLO-2308 just needs simple
;;; ones like (exactly 46 Chromosome)
;;; Below there are 2 ways of finding applicable prototypes:
;;; (i) climb the isa hierarchy
;;; (ii) see what prototype nodes were already cloned onto instance.
;;; It might seem like these are redundant with own-constraints+sources above, as prototype-based constraints will
;;; already have been cloned in. BUT: we need to account for the fact that (i) cloning of the prototype may not have
;;; yet been triggered and (ii) the user might have locally deleted the constraint (happens in AURA) so need to
;;; reinstate it.
(defun prototype-constraints+sources (instance slot &key ignore-prototypes)
  (let* ((prototypes (my-mapcan #'(lambda (class) (get-vals class '#$prototypes)) (all-classes instance)))   ; (i)
	 (protoinstances (get-vals instance '#$cloned-from))) ; (ii)
;    (km-format t "prototypes = ~a, protoinstances = ~a~%" prototypes protoinstances)
    (my-mapcan #'(lambda (protoinstance)
		(let* ((constraints 
			(find-constraints-in-exprs (get-vals protoinstance slot :situation *global-situation*)))
		       (ok-constraints	; [1]
			(remove-if #'(lambda (constraint)
				       (some #'(lambda (instance)
						 (and (kb-objectp instance)
						      (protoinstancep instance)))
					     (flatten constraint)))
				   (subst instance protoinstance constraints)))
		       (prototype-roots (ordered-set-difference (get-vals protoinstance '#$prototype-participant-of)
							ignore-prototypes)))
		  (cond ((and ok-constraints
			      prototype-roots
			      (or (member protoinstance protoinstances)
				  (satisfies-prototype-definition instance protoinstance)))
			 (let ((classes (my-mapcan #'immediate-classes prototype-roots)))
			   (mapcan #'(lambda (class)
				       (mapcan #'(lambda (constraint)
						   `((,constraint ,class)))
					       ok-constraints))
				   classes))))))
	       (remove-duplicates (append prototypes protoinstances) :from-end t))))
#|
(defun prototype-constraints+sources (instance slot &key ignore-prototypes)
  (let* ((classes (all-classes instance)))
    (mapcan #'(lambda (class)
		(let ((prototypes (get-vals class '#$prototypes)))
		  (mapcan #'(lambda (prototype)
			      (let* ((constraints 
				      (find-constraints-in-exprs (get-vals prototype slot :situation *global-situation*)))
				     (ok-constraints ; [1]
				      (remove-if #'(lambda (constraint)
						     (some #'(lambda (instance)
							       (and (kb-objectp instance)
								    (protoinstancep instance)))
							   (flatten constraint)))
						 (subst instance prototype constraints))))
				(cond ((and ok-constraints (satisfies-prototype-definition instance prototype))
				       (mapcan #'(lambda (constraint)
						   `((,constraint ,class)))
					       ok-constraints)))))
			  prototypes)))
	    classes)))
|#
;;; Same, but start at classes
;;; [1] all-superclasses0 like all-superclasses, except *excludes* Thing and includes classes.
;;;	Perfect!
(defun inherited-rule-sets-on-classes (classes slot &key (situation (curr-situation)) 
							 retain-commentsp
							 ignore-inherit-with-overrides-restriction)
  (let* ( (all-situations (cond ((and (neq situation *global-situation*)
				      (fluentp slot))
				 (cons situation (all-supersituations situation)))
				(t (list *global-situation*))))
		   (visible-theories (visible-theories)) )
    (cond ((and (inherit-with-overrides-slotp slot) (not ignore-inherit-with-overrides-restriction))
	   (desource+decomment
	    (inherited-rule-sets-with-overrides slot classes (append all-situations visible-theories))
	    :retain-commentsp retain-commentsp))
	  (t (let ((all-classes (my-mapcan #'all-superclasses0 classes)))    ; [1]
	       (desource+decomment
		(remove nil 				; tidy up answer...
			(mapcan #'(lambda (sitn)
				    (mapcan #'(lambda (class) (get-rule-sets-in-situation class slot sitn)) all-classes))
				(append all-situations visible-theories))		; (includes situation)
			:test #'equal :from-end t)
		:retain-commentsp retain-commentsp))))))

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

;;; Local to the slot AND situation
;(defun local-constraints (instance slot &key (situation (curr-situation)))
(defun  local-constraints (instance slot &key (situation (target-situation (curr-situation) instance slot)))
  (cond 
   (*are-some-constraints*								; optimization flag
    (find-constraints-in-exprs (bind-self
				(or (get-vals instance slot :facet 'own-properties :situation situation)     ; This disjunct should be in get-vals-
				    (get-vals instance slot :facet 'own-definition :situation situation))    ; in-situation, not here,+ should be conj!
				instance)))))

;;; ======================================================================
;;; 		ADDITIONAL UTILITIES
;;; ======================================================================

(defun has-situation-specific-info (frame situation)
  (some #'(lambda (prop-list) 
	    (getobj frame (curr-situation-facet prop-list situation)))
	*all-facets*))

;;; ======================================================================
;;;		SPECIAL FACET FOR BOOK-KEEPING OF DEFINITIONS
;;; ======================================================================

;;; For now, "defined-prototypes" points to both those with AND without definitions. simple-classp means no definitions.
(defun point-parents-to-defined-concept (frame parents facet &key simple-classp)
  (let ((defined-children-facet (case facet
				  (own-definition 'defined-instances)
				  (member-definition 'defined-subclasses)
				  (prototype-definition 'defined-prototypes))))
    (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 (mapc #'(lambda (parent)
		 (let ( (children (get parent defined-children-facet)) )
; Below. NO! This can cause redundant superclasses to be added based on load order.
; at time of load, parent is NOT a redundant superclass. But later load a X <| superclass link and parent
; BECOMES redundant :-(. Better not to assert it in the first place. 			   
;			   (cond ((eq facet 'member-definition)   ; Prologue: add the implied taxonomic link
;				  (km-int `(,frame #$has (#$superclasses (,parent))) :fail-mode 'error)))
		   (cond 
		    ((member frame children)) ; already got this definition
		    (t (case defined-children-facet 
			 ((defined-instances defined-subclasses)
				    ;(setf (get parent defined-children-facet) (cons frame children))
;				    (make-transaction `(setf ,parent ,defined-children-facet ,(cons frame children)))
				  ;;; NEW: Must try most specific classifications first! HLO bug
			  (make-comment "Noting a definition for ~a..." frame)
			  (km-setf parent defined-children-facet (most-specific-first (cons frame children))))
			 (defined-prototypes 
			  (km-setf parent defined-children-facet (most-specific-prototype-scopes-first 
								                      (cons frame children)))
			     (cond ((not simple-classp)
				    (make-comment "Noting a definition for prototype ~a..." frame)
				    (km-setq '*are-some-prototype-definitions* t))))
			 (t (report-error 'program-error
				    "point-parents-to-defined-concept: Unknown defined-children-facet ~a!~%" facet)))))))
		   parents)))))

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

;;; (most-specific-first '#$(Create Protein-synthesis Action)) -> (|Protein-synthesis| |Create| |Action|)
;;; If the ordering is not unique (e.g., no subsumption relationship exists) then that part of the ordering will be
;;; arbitrary.
(defun most-specific-first (classes) (reverse (most-general-first classes)))

(defun most-general-first (classes &key looping-at)
  (cond
   ((endp classes) nil)
   (t (let* ((class (first classes))
	     (superclasses (all-superclasses class)))
	(cond ((eq class looping-at)
	       (km-format t "ERROR! Looping in most-general-first! Stopping...~%") classes)
	      ((not (intersection superclasses (rest classes))) ; class is a most general concept
	       (cons class (most-general-first (rest classes))))
	      (t (most-general-first (append (rest classes) (list class)) :looping-at (or looping-at class))))))))

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

;;; (most-specific-prototype-scopes-first '#$(_Synthesis7901 _Protein-synthesis161)) 
;;;	-> (|_Protein-synthesis161| |_Synthesis7901|)
(defun most-specific-prototype-scopes-first (protoroots)
  (let* ((class+protoroot-pairs	; e.g., ((Synthesis _Synthesis7901) (Protein-synthesis _Protein-synthesis161))
	 (mapcan #'(lambda (protoroot)
		     (let ((scope-classes 
			    (remove-subsumers
			     (mapcar #'(lambda (scope)
					 (cond ((class-descriptionp scope)
						(first (class-description-to-class+slotsvals scope :fail-mode 'error)))
					       (t scope)))
				     (get-vals protoroot '#$prototype-scope)))))
		       (mapcar #'(lambda (scope-class)
				   (list scope-class protoroot))
			       scope-classes)))
		 protoroots))
	 (ordered-classes (most-specific-first (remove-duplicates (mapcar #'first class+protoroot-pairs)))))
    (collect-prototypes-for-classes ordered-classes (gather-by-key class+protoroot-pairs))))

;;; (COLLECT-PROTOTYPES-FOR-CLASSES 
;;;   '#$(Protein-synthesis Synthesis) '#$((Synthesis (_Synthesis7901)) (Protein-synthesis (_Protein-synthesis161))))
;;; -> (_Protein-synthesis161 _Synthesis7901)
(defun collect-prototypes-for-classes (ordered-classes class+protoroots-list &key collected-so-far)
  (cond
   ((endp ordered-classes) collected-so-far)
   (t (let* ((class (first ordered-classes))
	     (protoroots-at-class (second (assoc class class+protoroots-list)))
	     (uncollected (ordered-set-difference protoroots-at-class collected-so-far)) ; may be nil, of course
	     (new-collected (append collected-so-far uncollected)))
	(collect-prototypes-for-classes (rest ordered-classes) class+protoroots-list :collected-so-far new-collected)))))
	
;;; ----------

;;; Undo the above
(defun unpoint-parents-to-defined-concept (frame parents facet)
  (let ((defined-children-facet (case facet
				  (own-definition 'defined-instances)
				  (member-definition 'defined-subclasses)
				  (prototype-definition 'defined-prototypes))))
    (mapc #'(lambda (parent)
		(let ((children (get parent defined-children-facet)))
		  (km-setf parent defined-children-facet (remove frame children))))
	  parents)
    t))

;;; ======================================================================
;;; 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.
(defun add-slotsvals (instance add-slotsvals &key (facet 'own-properties) (install-inversesp t) 
						  (situation (curr-situation)) combine-values-by (bind-selfp t))
;  (let ( (old-classes (cond ((assoc '#$instance-of add-slotsvals) (immediate-classes instance)))) )	; for view mechanism
  (cond ((or (not (known-frame instance)) *active-obj-stack*) (push-to-obj-stack instance))) ; new 3/28/08
  (let* ( (new-add-slotsvals (cond ((and (member facet '(own-properties own-definition)) ; [1]
					 bind-selfp)
				    (bind-self add-slotsvals instance))
				   (t add-slotsvals))) )
    (mapc #'(lambda (add-slotvals)
	      (let* ( (slot (slot-in add-slotvals))
		      (add-vals0 (vals-in add-slotvals))
		     (add-vals (cond ((single-valued-slotp slot) (un-andify add-vals0))
				     ;;; Suppose add-vals0 have same values but different source info?
				     ;;; '((Pet (@ Self Cat parts)) (Pet (@ Self Cat size)))
				     ;;; For now I guess we'll just leave both in
				      ((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))	; (situation0 really should be built into
		      (old-vals (get-vals instance slot :facet facet :situation situation0))	;  get-vals directly)
		      (new-vals (cond ((null old-vals) 
				       (cond ((single-valued-slotp slot) (val-to-vals (vals-to-&-expr add-vals)))
; move earlier				     ((remove-subsumers-slotp slot) (remove-subsumers add-vals))
;					     ((remove-subsumees-slotp slot) (remove-subsumees add-vals))
					     (t add-vals)))
				      ((eq combine-values-by 'overwriting)
				       (cond ((eq facet 'own-properties)
					      (uninstall-inverses instance slot (ordered-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)))) )
;		(km-format t "add-vals0 = ~a~%" add-vals0)
;		(km-format t "add-vals = ~a~%" add-vals)
;		(km-format t "old-vals = ~a~%" old-vals)
					;		(km-format t "new-vals = ~a~%" new-vals)
		(cond (*active-obj-stack* (mapc #'push-to-obj-stack add-vals)))
		(cond ((or new-vals (eq combine-values-by 'overwriting))		; null new-vals means no change
		       (put-vals instance slot new-vals :facet facet :install-inversesp nil :situation situation0)
;		       (km-format t "add-slotsvals = ~a~%" add-slotsvals)
		       (cond (install-inversesp 
;			      (install-inverses instance slot new-vals situation0)))))))		; [2]
			      (install-inverses instance slot add-vals situation0)))))))		; [2]
	  (reorder-slotsvals new-add-slotsvals))
;;; NB do this here, after the inverse slot has been declared and asserted
    (cond ((and (eq facet 'own-properties) (assoc '#$domain add-slotsvals) (not (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) (not (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)
			      (assoc slots-slot add-slotsvals))
			  *slots-slots*)
		    (isa instance '#$Slot))
		(eq facet 'own-properties))		; don't do this for Slot classes!
	   (cond ((and (not (assoc '#$instance-of add-slotsvals)) 
		       (not (isa instance '#$Slot))
		       *coerce-undeclared-slots*)
		  (add-vals instance '#$instance-of '#$(Slot) :situation *global-situation*)))
	   (cond ((and *installing-inverses-enabled*
		       (not (non-inverse-recording-slot instance)) ; avoid instance=situation-specific -> assert (situation-specific-of has ...)
		       (or *coerce-undeclared-slots*
			   (isa instance '#$Slot)			; forward WAS declared, so declare inverse also
			   (assoc '#$instance-of add-slotsvals))) 			   
		  (add-vals (invert-slot instance) '#$instance-of 
; 			    (or (vals-in (assoc '#$instance-of add-slotsvals)) '#$(Slot)) 		; I don't think this is justified!
; No - not okay. slot1 has instance-of Entity-to-Value ===> invslot1 has instance-of Value-to-Entity
			    '#$(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.
(defun compute-new-vals (slot old-vals0 add-vals &key combine-values-by)
  (let* ( (old-vals (cond ((single-valued-slotp slot) (un-andify old-vals0))		; ((a & b)) -> (a b)
			  (t old-vals0))) 
	  (extra-vals   (ordered-set-difference add-vals old-vals :test #'equal)) )		
    (cond ((remove-subsumers-slotp slot) (cond (extra-vals (remove-subsumers (append old-vals extra-vals))) (t old-vals0))) ; [1]
	  ((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 ((not (set-difference add-vals old-vals)) nil)			; all add-vals are in old-vals already
		 ((valset-subsumes-valset add-vals old-vals) nil)
		 (t (val-to-vals (vals-to-&-expr (append old-vals add-vals))))))
	  (t (let* ( (valsets (&&-exprs-to-valsets old-vals)) 	     ; (((a b) && (c d))) -> ((a b) (c d))
		     (nvalsets (length valsets)) )
	       (cond ((member add-vals valsets :test #'equal) nil)
;		     ((km-format t "length valsets = ~a..~%" (length valsets)))
;		     ((km-format t "~{  ~a~%~}" valsets))
;		     ((km-format t "trying some...~%"))
		     ((and (<= nvalsets 10)				; efficiency bound
			   (some #'(lambda (valset)
				     (valset-subsumes-valset add-vals valset))		; i.e. add-vals is redundant
				 valsets)) nil)
		     ((and (every #'constraint-exprp add-vals)		; Efficiency and prettier (x) && (c) -> (x c) not ((x) && (c))
			   (singletonp valsets))
;		      (km-format t "~%compute-new-vals: new-valset = ~a, valsets = ~a, result = ~a~%~%" add-vals valsets 
;				 (remove-duplicates (append (first valsets) add-vals) :test #'equal))
		      (remove-duplicates (append (first valsets) add-vals) :test #'equal))
		     (t ; (km-format t "~%compute-new-vals: new-valset = ~a, valsets = ~a, result = ~a~%~%" add-vals valsets 
			;	   (valsets-to-&&-exprs (append valsets (list add-vals))))
;		      (km-format t "trying reduced...~%")
		      (let ( (reduced-valsets (cond ((<= nvalsets 10)
						     (remove-if #'(lambda (valset)
								    (valset-subsumes-valset valset add-vals)) ; i.e. valset is redundant
								valsets))
						    (t valsets))) )
; old			(valsets-to-&&-exprs (append reduced-valsets (list add-vals)))
			(valsets-to-&&-exprs (remove-duplicates (append reduced-valsets (&&-exprs-to-valsets add-vals))
								:test #'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).

(defun create-instance (parent0 slotsvals0 &key
				          (prefix-string (cond ((am-in-prototype-mode) *proto-marker-string*) (t *var-marker-string*)))
					  (bind-selfp t)
					  target)
  (let ( (parent (dereference parent0))
	 (slotsvals (dereference slotsvals0)) )
    (cond 
        ((kb-objectp parent) 
;	     (eq parent '#$Number))	; the one valid class which *isn't* a KB object	; WHY NOT???
	 (setq *statistics-skolems* (1+ *statistics-skolems*))
	 (create-named-instance (create-instance-name parent prefix-string) parent slotsvals 
				:bind-selfp bind-selfp :target target))
;;; NEW 2.29.00: Handle descriptions as class objects
	((class-descriptionp parent)
	 (let* ((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 bind-selfp :target target)))
	(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!
[5] remove-subsumers is redundant, as it's done anyway in add-slotsvals (and better add-slotsvals checks that
    instance-of is a remove-subsumers slot)
|#
(defun create-named-instance (newframe parent slotsvals0 &key (bind-selfp t) target)
  (cond 
   ((not (kb-objectp newframe))
    (report-error 'user-error "Ignoring slots on non-kb-object ~a...~%Slots: ~a~%" newframe slotsvals0))
   (t (let* ((extra-classes (vals-in (assoc '#$instance-of slotsvals0))) ; [1]
	     (all-classes (remove-duplicates `(,parent ,@extra-classes)))
	     (slotsvals1 (update-assoc-list slotsvals0 (list '#$instance-of all-classes)))
; [5]					    (list '#$instance-of (remove-subsumers (cons parent extra-classes))))) ; [5]
	     (slotsvals2 (cond (bind-selfp (bind-self slotsvals1 newframe))
			       (t slotsvals1))) 
	     (slotsvals (mapcar #'(lambda (slotvals)
				    (let ((slot (slot-in slotvals))
					  (vals (vals-in slotvals)))
	                              (list slot (remove-sources-from-vals newframe slot vals))))
				slotsvals2))
	     )
;	(km-format t "slotsvals1 = ~a, slotsvals2 = ~a, slotsvals = ~a~%" slotsvals1 slotsvals2 slotsvals)
	(add-slotsvals newframe slotsvals :bind-selfp bind-selfp) ; allow Self to preserved in exceptional circumstances (prototype-scope)

	(cond ((am-in-prototype-mode) 
	       (add-val newframe '#$prototype-participant-of (curr-prototype) t *global-situation*)))  ; install-inverses = t; Note in GLOBAL situation
#|NEW|#	(make-assertions newframe slotsvals)	; MOVED from situations only
	(un-done newframe)		; in case it's a redefinition	MOVED to put-slotsvals Later: No!
	(let ( (slots-that-changed (remove '#$instance-of (mapcar #'slot-in slotsvals))) )
	  (cond (target (push (list target newframe) *postponed-classifications*))
		(t (classify newframe :slots-that-changed slots-that-changed)))) ; with *indirect-classification* on, see 
										 ; note [1] below
	(mapc #'(lambda (slot)
		  (km-trace 'comment "New instance ~a: evaluating slot ~a opportunistically..." newframe slot)
		  (km-int `#$(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.

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

#|
KM> (a Engine with (parts ((*Cylinder2 (@ Car parts Engine parts)))))
    want the (@ Car ...) filtered out and just *Cylinder2 stored (i) so that inverses are also installed and
    (ii) so redundant unification is avoided:
	KM> (a Foo with (parts ((*C1 (@ Foo parts))))) -> (_Foo6)
	KM> (a Foo2 with (parts ((*C1 (@ Foo2 parts))))) -> (_Foo28 #|"a Foo2"|#)
	KM> (_Foo6 & _Foo28) -> (_Foo6 #|"a Foo&Foo2"|#)
	KM> (showme _Foo6)
	(_Foo6 has (parts ((((*C1 (@ Foo parts))) && ((*C1 (@ Foo2 parts)))))))	<============== undesirable, avoided by [2]

OLD: (desource+decomment-top-level (*black (comm [Comment1] _Dog1))) USED TO -> (*black):
(defun remove-sources-from-vals (instance slot vals)
  (mapcar #'(lambda (valexp0)
	      (let* ((valexp (desource+decomment-top-level valexp0))
		     (val (cond ((and (singletonp valexp)
				      (fully-evaluatedp (first valexp))
				      (not (member (first valexp) ; special keywords which should remain listified
						   (cons '#$no-inheritance *structured-list-val-keywords*))))
				 (first valexp)))))
;		(km-format t "valexp0 = ~a, valexp = ~a, val = ~a~%" valexp0 valexp val)
		(cond ((and val (not (equal val valexp0)))
		       (record-explanation-for `#$(the ,SLOT of ,INSTANCE) val valexp0)
		       val)
		      (t valexp0))))
	  vals))
|#

; NEW: (desource+decomment-top-level (*black (comm [Comment1] _Dog1))) NOW -> *black:
(defun remove-sources-from-vals (instance slot vals)
  (mapcar #'(lambda (valexp)
	      (let* ((val (desource+decomment-top-level valexp)))
		(cond ((and val 
			    (fully-evaluatedp val) 
			    (not (equal val valexp)))
		       (record-explanation-for `#$(the ,SLOT of ,INSTANCE) val valexp)
		       val)
		      (t valexp))))
	  vals))

;;; ======================================================================

;;; 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)
(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.
(defun create-instance-name (parent &optional (prefix-string (cond ((am-in-prototype-mode) *proto-marker-string*) 
								   (t *var-marker-string*))))
  (cond ((and (checkkbp) (not (known-frame parent)))
	 (report-error 'user-warning "Class ~a not declared in KB.~%" parent)))
; (make-transaction `(setq *km-gensym-counter* ,(1+ *km-gensym-counter*)))
  (km-setq '*km-gensym-counter* (1+ *km-gensym-counter*))
;  (let ( (instance-name (gentemp (concat prefix-string (symbol-name parent)))) )
  (let ( (instance-name (intern (concat prefix-string (symbol-name parent) (princ-to-string *km-gensym-counter*)) *km-package*)) )
    (cond ((unusable-frame-name instance-name) (create-instance-name parent prefix-string))		; [1]
	  (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 ...)
(defun make-assertions (instance &optional slotsvals)
  (cond ((or (and *classes-using-assertions-slot*
		  (intersection (all-classes instance) *classes-using-assertions-slot*))
	     (assoc '#$assertions slotsvals))			; has local assertions
	 (let ( (assertions (subst '#$Self '#$SubSelf (km-int `#$(the assertions of ,INSTANCE)))) )	; SubSelf becomes Self
	   (mapc #'(lambda (assertion) 
		     (cond ((not (quotep assertion))
			    (report-error 'user-error "Unquoted assertion ~a on ~a! Ignoring it...~%" assertion instance))
			   (t (let ( (situated-assertion (cond ((isa instance '#$Situation) `#$(in-situation ,INSTANCE ,(UNQUOTE ASSERTION))) ; [1]
							       (t (unquote assertion)))) )
				(make-comment "Evaluating ~a" situated-assertion)
				(km-int 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!
;;; ======================================================================

;(defvar *caching* t)			; if NIL then blocks noted-done
;(defun caching-on () (setq *caching* t))
;(defun caching-off () (setq *caching* nil))
;(defun caching-p () *caching*)

(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
(defun note-done (frame slot &optional (situation (target-situation (curr-situation) frame slot)))
; (km-format t "note-done: situation = ~a, curr-situation = ~a~%" situation (curr-situation))
  (cond (; (and (caching-p)
	 (and (kb-objectp frame)
	      *use-inheritance*	; NOTE: If we're *not* doing inference, then we can't consider the computed value as "done"
	      *use-prototypes*)
	 (let ( (done-so-far (get frame 'done)) )
	   (cond ((member (list slot situation)  done-so-far :test #'equal))
		 (*internal-logging*							; [1]
		  (push frame *noted-done*)						; [2]
		  (km-setf frame 'done (cons (list slot situation) done-so-far)))
		 (t (push frame *noted-done*)
		    (setf (get frame 'done) (cons (list slot situation) done-so-far))))))))

(defun already-done (frame slot &optional (situation (target-situation (curr-situation) frame slot)))
   (and (kb-objectp frame) 
;       (member (list slot situation) (get frame 'done) :test #'equal)  - old - less efficient
#|new|# (member-if (lambda (item)		; More efficient version, thanks to Sunil Mishra!
		    (and (consp item)
			 (null (cddr item))
			 (eq (car item) slot)
			 (eq (cadr item) situation)))
		  (get frame 'done))
       ))

;;; ----------
#|
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!
|#
;;; [1] in principle, classification can indirectly affect ANY prior computation, including ones not
;;; directly on instance. Here we make a guess and remove caching on the instance and it's immediate
;;; slot-values.
(defun un-done (frame &key slot situation)
  (cond ((eq slot '#$instance-of)	; will affect all other slots if instance-of changes [1]
;	 (showme frame)
;	 (km-format t "remprop on ~a~%" frame)
	 (remprop frame 'done)
	 (mapc #'(lambda (instance) 
		   (cond ((kb-objectp instance) 
;			  (km-format t "also remprop on ~a~%" instance)
			  (remprop instance 'done))))
	       (my-mapcan #'(lambda (situation)
			      (my-mapcan #'vals-in (get-slotsvals frame :situation situation)))
			  (all-situations-and-theories))))
	((or (eq situation *global-situation*)
	     (and (null situation) (am-in-global-situation))
	     (null slot)
	     (and slot (not (fluentp slot))))
	 (cond (slot (let ( (done-so-far (get frame 'done)) )
		       (setf (get frame 'done) (remove-if #'(lambda (pair) (eq (first pair) slot)) done-so-far))))
	       (t (remprop frame 'done))))
	(t (let* ( (done-so-far (get frame 'done))
		   (next-situations (all-next-situations (or situation (curr-situation)))) )
	     (setf (get frame 'done) (remove-if #'(lambda (pair) 
						    (and (member (second pair) next-situations)
							 (or (null slot) (eq (first pair) slot))))
						done-so-far))))))

#|
;;; KM 2.0.35 and earlier
(defun un-done (frame &key slot situation)
  (cond ((or ; (am-in-global-situation) 
	     (eq situation *global-situation*)
	     (and (null situation) (am-in-global-situation))
	     (null slot)
	     (and slot (not (fluentp slot))))
	 (cond (slot (let ( (done-so-far (get frame 'done)) )
		       (setf (get frame 'done) (remove-if #'(lambda (pair) (eq (first pair) slot)) done-so-far))))
	       (t (remprop frame 'done))))
	(t (let* ( (done-so-far (get frame 'done))
		   (next-situations (all-next-situations (or situation (curr-situation)))) )
;	     (km-format t "next-situations = ~a~%" next-situations)
	     (setf (get frame 'done) (remove-if #'(lambda (pair) 
						    (and (member (second pair) next-situations)
							 (or (null slot) (eq (first pair) slot))))
						done-so-far))))))
|#

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

;;; (defun reset-done () (mapc #'un-done *done*) (setq *done* nil) t)
;(defun reset-done () (mapc #'un-done (get-all-concepts)) t)
; More efficient
(defun reset-done () (mapc #'un-done *noted-done*) (setq *noted-done* nil) t)

(defun show-done ()
  (mapc #'(lambda (frame)
	    (cond ((get frame 'done)
		   (km-format t "~a:~%" frame)
		   (mapc #'(lambda (slot+situations) 
			     (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.
;;; ======================================================================

(defun class-has-something-to-say-about (instance slot &optional (situation (target-situation (curr-situation) instance slot)))
  (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
(defun instance-has-something-to-say-about (instance slot &optional (situation (target-situation (curr-situation) instance slot)))
  (frame-has-something-to-say-about instance slot 'own-properties situation))

(defun frame-has-something-to-say-about (frame slot facet &optional (situation (target-situation (curr-situation) frame slot)))
  (let ( (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)
	      (some #'(lambda (subslot)
			(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.
;;;	Note: If *indirect-classification* = t, then slot-that-changed is NOT used
;;; 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
;;; [1] Don't classify prototypes unless in prototype mode. Simply blocking classification is
;;; preferable to throwing an error and making the user wrap the assertion in a (disable-classification)
;;; ...(enable-classification) wrapper.
(defun classify (instance &key (slots-that-changed 'unspecified) slot-of-interest) ; [3]
  (cond ((and (classification-enabled)
	      (or (not (protoinstancep instance))	; [1]
		  (am-in-prototype-mode))
	      (not (equal slots-that-changed '(/==)))		; don't let this trigger reclassification work	      
	      (or *classify-slotless-instances*
		  slots-that-changed)		; may be NIL, as opposed to unspecified
	      (or *are-some-definitions*
		  (and *are-some-prototype-definitions* *prototype-classification-enabled*))
	      (or (am-in-global-situation) 
		  *classify-in-local-situations*)
	      (and (or *recursive-classification* (not *am-classifying*))
		   (neq *am-classifying* instance)))
	 (let ((*am-classifying* instance))
	   (cond ((and (tracep) (not (traceclassifyp)))
		  (let ((*trace* nil))
		    (classify0 instance :slots-that-changed slots-that-changed :slot-of-interest slot-of-interest)))
		 (t (classify0 instance :slots-that-changed slots-that-changed :slot-of-interest slot-of-interest)))))))

;;; Question: Does the order of which classifications are attempted matter?
;;; The current implementation tries the more specific classes up to the more general ones. 
;;; A comment in point-parents-to-defined-concept reads:
;;; 		"NEW: Must try most specific classifications first! HLO bug"
;;; So obviously the specific-to-general ordering is important!!
;;; (The ordering is effected by most-specific-first in point-parents-to-defined-concept).
(defun classify0 (instance &key slots-that-changed slot-of-interest)
  (cond 
   ((not (kb-objectp instance))
    (report-error 'user-error "Attempt to classify a non-kb-object ~a!~%" instance))
   ((is-an-instance instance)				; NEW: Don't try classifying Classes!
    (let ( (all-parents  (all-classes instance)) )  ; (immediate-classes ...) would
						      ; be faster but incomplete
	(cond ((some #'(lambda (parent)
			 (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)
			     (classify-as-prototype instance parent :slots-that-changed slots-that-changed 
							:slot-of-interest slot-of-interest)))
			 all-parents)	; if success, then must re-iterate, as the success
	       (classify0 instance 
			  :slots-that-changed 'unspecified	 	; may make previously failed classifications now succeed
			  :slot-of-interest slot-of-interest)))))))    

;(defun do-postponed-classifications ()
;  (mapc #'(lambda (postponed-classification)
;	    (let ((instance (first postponed-classification))
;		  (slots-that-changed (second postponed-classification))
;		  (slot-of-interest (third postponed-classification)))
;	      (classify instance :slots-that-changed slots-that-changed :slot-of-interest slot-of-interest)))
;	*postponed-classifications*)
;  (setq *postponed-classifications* nil))

(defun do-postponed-classifications (instance slot)
  (cond (*postponed-classifications*
	 (let ((target `(#$the ,slot #$of ,instance)))
;	       (old-length (length *postponed-classifications*)))
	   (setq *postponed-classifications*
	     (remove nil (mapcar #'(lambda (postponed-classification)
				     (let ((target2 (first postponed-classification))
					   (instance2 (second postponed-classification)))
				       (cond ((equal target target2) (classify instance2) nil)
					     (t postponed-classification))))
				 *postponed-classifications*)))))))
;    (let ((new-length (length *postponed-classifications*)))
;      (km-format t "DEBUG: Did ~a postponed classifications (~a remain)~%" (- old-length new-length) new-length))))

;;; ----------------------------------------------------------------------
;;; (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
;;; [3] More rigorous lookahead - Hmm... in my earlier tests I thought this helped, but later it seems not
(defun classify-as-member (instance parent &key slots-that-changed slot-of-interest)
 (cond (*are-some-definitions*
  (some #'(lambda (possible-new-parent)
	    (cond ((and	(might-be-member instance possible-new-parent)
			(not (disjoint-class-sets0 (immediate-classes instance) (list possible-new-parent))) ; [2]
			(not (isa instance possible-new-parent)) ; already done!
			(test-val-constraints possible-new-parent ; [1]
					      (extract-constraints (get-vals instance '#$instance-of :situation *global-situation*))
					      'remove-subsumers-slot
					      :mode 'consistent)
			(not (disjoint-class-sets (immediate-classes instance) (list possible-new-parent))) ; [3]
			(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")))
(defun might-be-member (instance parent)
;  (km-format t "(might-be-member ~a ~a)? " instance parent)
  (let* ((defn-slotsvals (append (get-slotsvals parent :facet 'member-definition :situation *global-situation*)
				 (cond ((am-in-local-situation) (get-slotsvals parent :facet 'member-definition))))))
    (might-have-slotsvals instance defn-slotsvals)))

(defun might-have-slotsvals (instance defn-slotsvals)
  (let* ((missing-required-info		; if instance doesn't have some required info AND is already-done (i.e., no more
	  (some #'(lambda (defn-slotvals)	; computational possible) THEN don't even try classifying
		    (let* ((dslot (slot-in defn-slotvals))
			   (dvals (vals-in defn-slotvals))
			   (ivals (get-vals instance dslot)))
;		      (km-format t "dslot = ~a, dvals = ~a, ivals = ~a, already-done = ~a~%" dslot dvals ivals
;				 (already-done instance dslot))
		      (and (already-done instance dslot)
			   (not (remove-subsumers-slotp dslot))	; can have different, named vals and still subsume
			   (not (remove-subsumees-slotp dslot))
			   (or (and (some #'non-constraint-exprp dvals) (null ivals)) ; defn has a val, instance no val
			       (and (every #'named-instancep ivals)		      ; ival all named
				    (some #'(lambda (dval)			      ; there's a dval that's named and
					      (and (atom dval)			      ; not in ivals
						   (named-instancep dval)             ; (named check to prevent unif)
						   (not (member dval ivals :test #'equal))))
					  dvals))))))
		defn-slotsvals)))
    (and (not missing-required-info)
	 ;;; [1] we optimize for this specific defn pattern ((instance-of (Chemical)) (has-basic-structural-unit ((a Zn))))
	 (let* ((rest+dslot+class (minimatch defn-slotsvals '#$((instance-of &rest) (?slot ((a ?class &rest))) &rest)));[1]
		(dslot (second rest+dslot+class))
		(class (third rest+dslot+class))
		(ivals (cond (dslot (get-vals instance dslot)))))
	   (cond ((and rest+dslot+class			; IF just need a class
		       (already-done instance dslot)
		       (singletonp ivals) ; and already got an instance
		       (kb-objectp (first ivals))) ; not a constraint e.g., dslot = instance-of, ivals = ((<> *ShinerBock))
		  (isa (first ivals) class)) ; check class membership		  
		 (t))))))

;;; ----------
		      
;;; 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!
(defun try-classifying (instance possible-new-parent &key slots-that-changed)
  (multiple-value-bind
   (satisfiedp explanation)
   (satisfies-definition instance possible-new-parent :slots-that-changed slots-that-changed)
   (cond (satisfiedp
; 	  (cond ((unifiable-with-expr instance `#$(a Thing with . ,(FIND-SLOTSVALS POSSIBLE-NEW-PARENT 'MEMBER-PROPERTIES)))	; New test!
;	  (cond ((km-int `#$(,INSTANCE &? (a Thing with . ,(FIND-SLOTSVALS POSSIBLE-NEW-PARENT 'MEMBER-PROPERTIES))))  ; new test [1]
	  (cond ((km-int `#$(,INSTANCE &? (a ,POSSIBLE-NEW-PARENT with 
					  ,@(GET-SLOTSVALS POSSIBLE-NEW-PARENT :FACET 'MEMBER-PROPERTIES :SITUATION *GLOBAL-SITUATION*))))  ; new test [1,2]
		 (cond ((check-classification-with-user instance possible-new-parent)
			(setq *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		; add constraint, to prevent further retries
				   (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.
(defun check-classification-with-user (instance possible-new-parent)
  (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.
(defun add-immediate-class (instance0 new-immediate-parent explanation)
  (let* ((instance (dereference instance0))
	 (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)
;  (put-vals instance '#$instance-of new-classes)
   (add-val instance '#$instance-of new-immediate-parent t 		; install-inverses = t
	    (target-situation (curr-situation) instance '#$instance-of (list new-immediate-parent)))	; target situation
   (record-explanation-for `#$(the instance-of of ,INSTANCE) new-immediate-parent explanation :situation *global-situation*)
;  (cond ((isa instance '#$Situation) (make-situation-specific-assertions instance)))
   (make-assertions instance)	; test later	
   (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)
;;; [1] Note we don't need to say (a Parent-Class with...), as instance is already known to be a member of Parent-Class
;;;     (that's how we found the definition to test in the first place)
;;;     Also note the Class in the definition is stored as (instance-of (Class)) rather than (the-class Class with ...)
(defun satisfies-definition (instance class &key slots-that-changed)
  (let ( (definitional-slotsvals (bind-self (get-slotsvals class :facet 'member-definition :situation *global-situation*) instance)) )
    (cond 
     ((or *indirect-classification*
 	  (eq slots-that-changed 'unspecified)		; distinct from NIL, means no slots changed
	  (intersection slots-that-changed (mapcar #'slot-in definitional-slotsvals)))	; i.e. slots-that-changed must have something 
      (km-trace 'comment "CLASSIFY: ~a has just been created/modified. Is ~a now a ~a?" 		   ; affecting the definition
	instance instance class)
      (setq *statistics-classifications-attempted* (1+ *statistics-classifications-attempted*)) 
      (let* ( (description `'#$(a Thing with ,@DEFINITIONAL-SLOTSVALS))    ; [1] 
	      (satisfiedp (km-int `#$(,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.
|#

(defun classify-as-coreferential (instance0 parent &key slots-that-changed slot-of-interest)
 (cond (*are-some-definitions*
  (let ( (instance (dereference instance0)) )
    (some #'(lambda (possible-coreferential-instance)
	      (cond ((and (not (eql instance possible-coreferential-instance))   ; already done!
			  (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))))))

(defun try-equating (instance possible-coreferential-instance &key 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, 
(defun unify-with-instance (instance possible-coreferential-instance)
  (make-comment "~a satisfies definition of ~a," instance possible-coreferential-instance)
  (make-comment "so unifying ~a with ~a" instance possible-coreferential-instance)
  (setq *statistics-classifications-succeeded* (1+ *statistics-classifications-succeeded*)) 
  (cond ((km-int `(,instance & ,possible-coreferential-instance))		; so failure gets reported below instead
	 (un-done instance))		; all vals to be recomputed now - now in put-slotsvals via lazy-unify. Later: no!
	(t (report-error 'user-error "~a satisfies definition of ~a but won't unify with it!~%"
			 instance possible-coreferential-instance))))

(defun satisfies-definition2 (instance poss-coref-instance &key slots-that-changed)
  (let ( (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)
	  (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)
      (setq *statistics-classifications-attempted* (1+ *statistics-classifications-attempted*)) 
      (let* ( (description `'#$(a Thing with ,@DEFINITIONAL-SLOTSVALS))
	      (satisfiedp (km-int `#$(,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)))))

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

#|
Note: the 'defined-prototypes for the below will be logged on Cell:
(get '#$Cell 'defined-prototypes) -> (|_Euk-cell14|)
(_Euk-cell14 has 
  (instance-of (Euk-cell))
  (prototype-of (Euk-cell))
  (prototype-scope (Euk-cell
                    (the-class Cell with (has-part ((a Nucleus))))))

; Though we also got in the original conception of prototypes:
(_Red-Wine1 has 
   (instance-of (Wine)) 
   (prototype-of (Wine))	    
   (prototype-scope ((the-class Wine with (color (*Red))))))

So what class do we assign then when the classification succeeds?
|#
(defun classify-as-prototype (instance parent &key slots-that-changed slot-of-interest)
  (declare (ignore slots-that-changed slot-of-interest))
  (cond
   ((and *are-some-prototypes* *prototype-classification-enabled*)
    (some #'(lambda (protoroot)
	      (classify-as-prototype0 instance protoroot))
	  (get parent 'defined-prototypes)))))

(defun classify-as-prototype0 (instance protoroot)
  (let ((class-definitions (subst '#$Self protoroot
				  (remove-if-not #'the-class-exprp (get-vals protoroot '#$prototype-scope))))
	(protoclasses (remove-subsumers 	; Ug - remove-subsumers because AURA allows redundant classes e.g., (instance-of (Cell Tangible-Entity))
		       (get-vals protoroot '#$instance-of)))) ; I guess...rather than '#$prototype-of, which may be overly general as used for indexing

    (cond
     ((and class-definitions
	   (notany #'(lambda (protoclass) (instance-of instance protoclass)) protoclasses)) ; already done!
      (some #'(lambda (class-definition)
		(let* ((class+slotsvals (class-description-to-class+slotsvals class-definition))
		       (class (first class+slotsvals))
		       (slotsvals (decomment (second class+slotsvals))))
;		  (km-format t "class+slotsvals = ~a~%" class+slotsvals)
;		  (km-format t "slotsvals = ~a~%" slotsvals)


; [2] these lookaheads copied from classify-as-member, don't know if we really need them
; [3] Don't bother when the prototype class isn't reified, e.g., in the Wine example above.		  
		  (cond ((and (not (member class protoclasses)) ; [3]
			      (might-have-slotsvals instance slotsvals) ; [2]
			      (not (disjoint-class-sets (immediate-classes instance) protoclasses))) ; [2]
			 (try-classifying-as-prototype instance protoclasses class-definition)))))
	    class-definitions)))))

;;; The has-definition version of this function included an &? test first to make sure of unifiability, but we 
;;; don't do that for prototypes. I *think* the &? test is merely to check for KB consistency, which we'll assume here.
(defun try-classifying-as-prototype (instance protoclasses class-definition)
  (push-to-goal-stack `(,instance #$isa ,(first protoclasses)))  ; to avoid cloning the same prototype for this classfn
  (multiple-value-bind
      (satisfiedp explanation)
      (satisfies-class-definition instance class-definition protoclasses)
    (prog1
	(cond (satisfiedp
	       (setq *statistics-classifications-succeeded* (1+ *statistics-classifications-succeeded*))
	       (mapc #'(lambda (protoclass)
			 (add-immediate-class instance protoclass explanation))
		     protoclasses)
	       t))
      (pop-from-goal-stack))))

;;; This procedure solely does (km-int `#$(,INSTANCE isa ,CLASS-DEFINITION)) wrapped in a lot of tracing info
(defun satisfies-class-definition (instance class-definition conclusion-classes)
  (km-trace 'comment "CLASSIFY: ~a has just been created/modified. Is ~a now a ~a?" 
	    instance instance (delistify conclusion-classes))
  (setq *statistics-classifications-attempted* (1+ *statistics-classifications-attempted*))
  (let* ((satisfiedp (km-int `#$(,INSTANCE isa ,CLASS-DEFINITION))))
    (cond (*developer-mode* (km-format t "#")))
    (cond (satisfiedp 
	   (km-trace 'comment "CLASSIFY: ~a *is* a ~a!" instance (delistify conclusion-classes))
	   (let* ((class+slotsvals (class-description-to-class+slotsvals class-definition))
		  (class (first class+slotsvals))
		  (slotsvals (second class+slotsvals)))
	     (values satisfiedp
		     (subst instance '#$Self
			    `#$(every ,(FIRST CONCLUSION-CLASSES) has-definition (instance-of (,CLASS)) ,@SLOTSVALS)))))
	  (t (km-trace 'comment "CLASSIFY: ~a is not a ~a." instance (delistify conclusion-classes))
	     nil))))

;;; ======================================================================
;;;			TAXONOMIC OPERATIONS
;;; ======================================================================


;;; check frame isa genframe. Returns frame.
;;; (isa x x)	returns nil
(defun isa (instance class &optional (situation (curr-situation)))
  (instance-of instance class situation))	; synonym

;;; [1] Still some cases where test-suite passes non-class arguments, need a bit more work to filter them out
(defun instance-of (instance target-class &optional (situation (curr-situation)))
  (let ((its-classes (immediate-classes instance :situation situation)))
    (cond ;((not (kb-objectp target-class))	; [1]
	  ; (report-error 'user-error "Doing (instance-of ~a ~a): Encountered a non-KB object ~a (illegal!)"
	  ;		 instance target-class target-class))
	  ((member target-class its-classes) instance)
	  ((and (not (null its-classes))
		(some #'(lambda (its-class) (is-subclass-of its-class target-class))
		      its-classes))
	   instance))))

;;; [1] There are still cases where we want to not break, e.g., constraints or comment tags passed
;;;     I need to do more work to properly filter out these cases elsewhere in the code
(defun is-subclass-of (class target-class &key path-so-far)
    (cond ;((not (kb-objectp target-class)) - [1]
	  ; (report-error 'user-error "Doing (is-subclass-of ~a ~a): Encountered a non-KB object ~a (illegal!)"
	  ;		 class target-class target-class))
          ((eq class target-class) class)
	  ((eq class '#$Thing) nil)
	  ((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))
	   (let ( (superclasses (immediate-superclasses class)) )
	     (cond ((member target-class superclasses) class)
		   ((and (not (null superclasses))
			 (some #'(lambda (superclass) (is-subclass-of superclass target-class :path-so-far (cons class path-so-far)))
			       superclasses))
		    class))))))

;;; Identical code structure to is-subclass-of above
(defun is-subslot-of (slot target-slot &key path-so-far)
    (cond ((eq slot target-slot) slot)
	  ((member slot path-so-far)
	   (report-error 'user-error "You have a cycle in the slot hierarchy (not allowed)!~%~a~%" 
			 (commaed-list (reverse (cons slot path-so-far)) '->)))	   
	  ((and (kb-objectp slot)
		(kb-objectp target-slot))
	   (let ( (superslots (immediate-superslots slot)) )
	     (cond ((member target-slot superslots) slot)
		   ((and (not (null superslots))
			 (some #'(lambda (superslot) (is-subslot-of superslot target-slot :path-so-far (cons slot path-so-far)))
			       superslots))
		    slot))))))

;;; Shadow of KM. Find immediate generalizations of a frame.
;;; NOTE: This does *NOT* remove redundant superclasses (there shouldn't be any there)
;;; 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)
(defun immediate-classes (instance &key (situation (curr-situation)) enforce-constraints) ; [2]
  (declare (optimize (speed 3) (safety 0)) (ignore enforce-constraints))
  (macrolet ((fassoc (item alist)
	       `(case ,item
		  ,@(mapcar (lambda (pair) (list (car pair) (list 'quote (list (cadr pair)))))
			    (symbol-value alist))))
	     (fmember (item list)
	       `(case ,item
		  (,(symbol-value list) t))))
    (cond ((integerp instance) '(#$Integer))
	  ((numberp instance) '(#$Number))
	  ((fassoc instance *built-in-instance-of-links*)) ; e.g. t -> Boolean
					;	((eq instance '#$*Global) '(#$Situation))
	  ((fmember instance *built-in-set-aggregation-slots*) '#$(Set-Aggregation-Slot))
	  ((fmember instance *built-in-seq-aggregation-slots*) '#$(Seq-Aggregation-Slot))
	  ((fmember instance *built-in-bag-aggregation-slots*) '#$(Bag-Aggregation-Slot))
	  ((fmember instance *built-in-slots*) '#$(Slot))
	  ((class-descriptionp instance) '#$(Class))
	  ((quoted-expressionp instance) '#$(Quoted-Expression))
	  ((stringp instance) '(#$String))

					; 8/19/05 - the following added for these special classes, to allow (a Sequence) & (:seq 1 2) to unify
	  ((km-seqp instance) '#$(Sequence))
	  ((km-bagp instance) '#$(Bag))
	  ((km-pairp instance) '#$(Pair))
	  ((km-triplep instance) '#$(Triple))
	  ((km-functionp instance) '#$(Function))

	  ((km-structured-list-valp instance) ; Hmm.... (the classes of (:seq A B)) should really return #$Sequence
	   (immediate-classes (arg1of instance))) ; But (the classes of (:args _Pipe1 _Tank2)) should be #$Pipe (?)
					; Called by constraints.lisp to test expressions like (exactly 1 Thing)
	  ((not (kb-objectp instance))
	   (report-error 'user-error "ERROR! Attempt to find the instance-of of an non-KB object ~a -- ~a should be a non-keyword symbol!"
			 instance instance)
	   '#$(Thing))
	  
	  ((or (not (inertial-fluentp '#$instance-of)) ; allow redefinition of this thing
	       (eq situation *global-situation*))
	   

;;; 9/28/00 Rewrite this to explicitly test instance-of constraints [this test is bypassed by interpreter.lisp]
	   (let* ( (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)
				  (let ( (vals1 (remove-subsumers (km-int (vals-to-val vals0)))) )
				    (put-vals instance '#$instance-of (append vals1 constraints))
				    (note-done instance '#$instance-of)
				    vals1)))) )
	     (cond 
					;	         (nil 	; NEW!!!!!! DISABLE THIS FUNCTION, IT CAUSES TOO MANY PROBLEMS!!
					;		  (and enforce-constraints constraints)
					;		  (enforce-constraints vals constraints instance '#$instance-of)  ; [3]
					;		  (immediate-classes instance :situation situation))
	       (vals)
	       ('#$(Thing)))
	     ))

					;APR30	((already-done instance '#$instance-of situation) 
	  ((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*)) ; [1]
	       '#$(Thing)))

	  (t (prog1
		 (immediate-classes0 instance :situation situation)
					;APR30	     (note-done instance '#$instance-of situation)))))
	       (note-done instance '#$instance-of))))))

;;; REVISED: We must do more work here when there are situations.
(defun immediate-classes0 (instance &key (situation (curr-situation)))
  (let* ( (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)
						 (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)				;	 [1] Local Classes are *NOT* a complete list
		     (and (neq class '#$Thing)
			  (not (member class local-classes-and-constraints))))
		 (append supersituation-classes projected-classes definitional-classes))
	   (let* ( (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)		; note-done is done above
	     all-classes))
	  ((remove-constraints local-classes-and-constraints))			; [2] Local Classes *ARE* a complete list
	  ((and (checkkbp) (not (known-frame instance)))
	   (report-error 'user-warning "Object ~a not declared in KB.~%" instance)
	   '(#$Thing))
; Hmm...can we get rid of automatically computed meta-classes?
;	  ((find-vals instance '#$superclasses) 
;	   (put-vals instance '#$instance-of '(#$Class) :situation situation)		; note-done is done above
;	   '(#$Class))
	  (t (cond ((checkkbp) 
		    (report-error 'user-warning "Parent (superclasses/instance-of) for ~a not declared.~%" instance)))
	     '(#$Thing)))))

(defun projected-classes (instance situation local-classes-and-constraints)
  (let ( (prev-situation (prev-situation situation instance)) )
    (cond (prev-situation (filter-using-constraints (immediate-classes instance :situation prev-situation) local-classes-and-constraints '#$prev-situation)))))

;;; ======================================================================

(defun immediate-superclasses (class)
  (cond ((eq class '#$Thing) nil)

;	((and (member class *built-in-classes*)
;	      (not (member class *built-in-classes-with-no-built-in-superclasses*)))
;	 (or (rest (assoc class *built-in-superclass-links*))		; e.g. (immediate-superclasses '#$Integer) -> (Number)
;	     '#$(Thing)))

#|
;;; Revised version below, makes Thing superclass be a default rather than hard-wired.
	((rest (assoc class *built-in-superclass-links*))		; e.g. (immediate-superclasses '#$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 '#$Integer) -> (Number)
				     '#$(Thing))))))
	   (cond ((neq old-class new-class) (km-format t "Old class = ~a, New class = ~a~%" old-class new-class)))
	   new-class))
|#

;;; Even simpler. Default "Thing" is reached later, ONLY if user doesn't define his/her own superclass link first
	((rest (assoc class *built-in-superclass-links*)))		; e.g. (immediate-superclasses '#$Integer) -> (Number)

	((class-descriptionp class) 
	 (list (first (class-descriptionp class))))			; (the-class Remove with ...) -> (Remove)
	((let ( (superclasses (get-vals class '#$superclasses)) )
	   (cond ((member class superclasses)
		  (report-error 'user-error "Cycle in the KB! ~a is its own superclass!" class)
		  (remove class superclasses))
		 (t superclasses))))
;		  (note-statistics-for class '#$superclasses superclasses)
;		  superclasses))))
	((and (checkkbp) (not (known-frame class)))
	 (report-error 'user-warning "Class ~a not declared in KB.~%" class)
	 '(#$Thing))
;	((is-an-instance class) nil)
	((checkkbp) 
	 (report-error 'user-warning "superclasses not declared for `~a'.~%I'll assume superclass `Thing'.~%" class)
	 '(#$Thing))
	(t '(#$Thing))))

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

#|
Returns the FIRST cycle found, if there are any in the taxonomy, NIL otherwise.
A cycle is a list of classes where each class is a superclass of the previous,
and the first and last elements of the list are the same.
CL-USER(18): (km '#$(Vehicle has (superclasses (Car))))
CL-USER(19): (km '#$(Device has (superclasses (Vehicle))))
CL-USER(20): (km '#$(Car has (superclasses (Device))))
CL-USER(21): (check-for-cycles)
(|Car| |Device| |Vehicle| |Car|)
|#
(defun check-for-cycles () 
  (let ((all-classes (remove-if-not #'(lambda (concept)
					(or (get-vals concept '#$subclasses)
					    (get-vals concept '#$superclasses)))
				    (get-all-concepts))))
    (some #'check-for-cycles0 all-classes)))

(defun check-for-cycles0 (class &key done)
  (cond ((member class done) (append (member class (reverse done)) (list class)))
	(t (some #'(lambda (superclass) 
		     (check-for-cycles0 superclass :done (cons class done))) 
		 (or (rest (assoc class *built-in-superclass-links*))
		     (get-vals class '#$superclasses))))))

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

(defun immediate-subclasses (class)
;  (find-vals class '#$subclasses))
  (cond ((eq class '#$Thing) (subclasses-of-thing))
	((let ( (subclasses (get-vals class '#$subclasses :situation *global-situation*)) )
	   (cond ((member class subclasses)
		  (report-error 'user-error "Cycle in the KB! ~a is its own subclass!" class)
		  (remove class subclasses))
		 (t subclasses))))
	((inv-assoc class *built-in-superclass-links*) 				; e.g. (immediate-subclasses '#$Number) -> (Integer)
	 (mapcar #'first (remove-if-not #'(lambda (pair) (eq (second pair) class)) *built-in-superclass-links*)))))

;;; ----------
;;; 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.
(defun subclasses-of-thing ()
  (let* ( (all-objects (remove-if-not #'kb-objectp (dereference (get-all-concepts))))
	  (unplaced-classes+instances				; + includes classes explicitly directly under Thing
	   (remove-if #'(lambda (concept)
			  (let ( (superclasses (get-vals concept '#$superclasses :situation *global-situation*)) )
			    (or (and superclasses 
				     (not (equal superclasses '#$(Thing))))		   ; ie. is placed (and not under Thing)
				(assoc concept *built-in-superclass-links*))))   	   ; [4], e.g. Integer, Aggregation-Slot
		      all-objects))
;	  (all-situations-and-theories (all-situations-and-theories))
	 (unplaced-classes (remove-if-not #'(lambda (concept)
					      (or (get-vals concept '#$subclasses)
						  (get-vals concept '#$superclasses)
						  (member concept *built-in-classes*))) ; [3]
					  unplaced-classes+instances)) 
	 (extra-classes (my-mapcan #'(lambda (class-superclass) ; [5]
					(cond ((and (member (first class-superclass) all-objects)
						    (not (member (second class-superclass) unplaced-classes)))
					       (rest class-superclass))))
				    *built-in-superclass-links*)) 
	  )
    (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))))

(defun immediate-subslots (slot)
  (cond ; there are none yet ! ((second (assoc slot *built-in-subslots*)))
	(*are-some-subslots* 			; optimization flag (worth it?)
	 (get-vals slot '#$subslots :situation *global-situation*))))

;;; NB *doesn't* include slot.
(defun all-subslots (slot)
  (let ( (immediate-subslots (immediate-subslots slot)) )
    (append immediate-subslots (mapcan #'all-subslots immediate-subslots))))

(defun immediate-superslots (slot)
  (cond ; there are none yet ! ((second (assoc slot *built-in-subslots*)))
	(*are-some-subslots* 			; optimization flag (worth it?)
	 (get-vals slot '#$superslots :situation *global-situation*))))

;;; This *doesn't* include slot in the list
(defun all-superslots (slot)
  (let ( (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-unique-int, 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
(defun prev-situation (situation &optional instance)
  (declare (ignore instance))
  (let* ((prev-situation-args-structures0 (get-vals situation '#$prev-situation)) ; eg ((:args _Sit23 _Action23)) [2]
	 (prev-situation-args-structures (km-int (vals-to-val prev-situation-args-structures0)))
	 (prev-situation-args-structure (first prev-situation-args-structures)))
    (cond ((>= (length prev-situation-args-structures) 2)
	   (km-trace 'comment "Warning! (the prev-situation of ~a) Multiple previous situations ~a found! Taking just the first (~a)..."
		     situation prev-situation-args-structures prev-situation-args-structure)))
    (cond ((not (equal prev-situation-args-structures0 prev-situation-args-structures)) 
	   (put-vals situation '#$prev-situation prev-situation-args-structures)
;APR30		   (note-done situation '#$prev-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))))

;;; Rather than going back to the previous situation, go back to the previous situation which has a 
;;; value for instance's slot.
(defun prev-situation-with-vals (situation instance slot)
  (let ((prev-situation (prev-situation situation instance)))
    (cond (prev-situation
	   (cond ((get-vals instance slot :situation prev-situation) prev-situation)
		 (t (prev-situation-with-vals prev-situation instance slot)))))))

;(defun next-situations (situation)
; (let ( (next-situation-args-structures 
;     (get-vals situation '#$next-situation :situation *global-situation*)) ) ; eg ((:args _Sit23 _Action23)) [1]
;   (mapcar #'(lambda (next-situation-args-structure)
;	       (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)))

;;; REVISION: from Francis Leboutte: Old version was producing very long lists with duplicates.
;;; Result is MAPCAN-SAFE
(defun next-situations (situation)
  (let ((next-situation-args-structures
         ;; eg ((:args _Sit23 _Action23)) [1]
         (get-vals situation '#$next-situation :situation *global-situation*)))
    ;; RVA 29Mar2007
    ;; make sure the returned list doesn't contain duplicate situations
    ;; especially important when using do-concurrently-and-next
    (let ((acc nil))
      (loop for next-situation-args-structure in next-situation-args-structures
            as next-situation =
            (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)))
            do (pushnew next-situation acc :test #'eq))
      acc)))
      
;;; INCLUDES situation
;;; Optimized version from Francis Leboutte
;(defun all-next-situations (situation) 
;  (cond ((null situation) nil)
;	(t (cons situation (mapcan #'all-next-situations (next-situations situation))))))
(defun all-next-situations (situation)
  (declare (type symbol situation))
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) 
  (cons situation
        (loop for situation in (next-situations situation)
              nconc (all-next-situations situation))))

;;; ========================================

;;; before-situation of an event
(defun before-situation (event)
 (let ( (before-situation-args-structures 
	          (get-vals event '#$before-situation :situation *global-situation*)) ) ; eg ((:args _Sit23 _Action23)) [1]
;  (let ( (before-situation-args-structure 
;	     (km-unique-int (find-unique-val event '#$before-situation :situation *global-situation*) ; eg ((:args _Sit23 _Action23)) [2]
;			)) )										; [3]
   (cond ((null before-situation-args-structures) nil)
	 ((singletonp before-situation-args-structures)
	  (let ( (before-situation-args-structure (km-unique-int (first before-situation-args-structures))) )
	    (cond ((not (equal before-situation-args-structure 
			       (first before-situation-args-structures)))
		   (put-vals event '#$before-situation (list before-situation-args-structure)
			     :situation *global-situation*)
;APR30		   (note-done event '#$before-situation *global-situation*)))
		   (note-done event '#$before-situation)))
	    (cond ((km-argsp before-situation-args-structure)
;		   (km-format t "before-situation-args-structures = ~a~%" before-situation-args-structures)
		   (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 #'(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 "#,"
[2] Special case:
(a Person with (owns ('(a Car with (made-by (#,Self)))))) should return 
		... '(a Car with (made-by (_Person4)))
	not	... '(a Car with (made-by (#,_Person4)))

(showme (a Person with (likes ('(the age of #,Self)))))		-> (_Person15 has (likes ('(the age of _Person15))))
(showme (a Person with (likes ('#,Self))))			-> (_Person16 has (likes ('_Person16))
(showme (a Person with (likes ('(the sum of #,(1 + 1)))))) 	-> (_Person17 has (likes ('(the sum of #,(1 + 1)))))
(showme (a Person with (likes ('(the sum of #,(the age of (evaluate '(the likes of #,Self))))))))
		-> (_Person18 has (likes ('(the sum of #,(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 ('#'(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) '#$Self) self)				; [2]
					       (t (list 'unquote (bind-self (second expr) self :in-quotes nil))))) ; [1]
			      (t (report-error 'user-error "An unquoted expression #,~a was encountered inside a non-quoted expression (not allowed!)~%"
					     (second expr)))))
	       (t (mapcar #'(lambda (x) (bind-self x self :in-quotes in-quotes)) expr))))
	((and (eq expr '#$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
(defun bind-self (expr self) (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.
(defun remove-subsumers (classes)
  (let ((nodup-classes (remove-duplicates classes :from-end t)))	; much more efficient, reduces combinatorics
   (remove-if #'(lambda (class)
		  (some #'(lambda (other-class) 
			    (and (neq other-class class)
				 (not (constraint-exprp class)) ; constraints allowed as class values
				 (not (constraint-exprp other-class))	; constraints allowed as class values
				 (is-subclass-of other-class class)))	 
			nodup-classes))
	      nodup-classes)))

;;; 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.
(defun remove-subsumees (classes)
  (remove-duplicates
   (remove-if #'(lambda (class)
		  (some #'(lambda (other-class) 
			    (and (neq other-class class)
				 (not (constraint-exprp class)) ; constraints allowed as class values
				 (not (constraint-exprp other-class)) ; constraints allowed as class values
				 (is-subclass-of class other-class)))	 classes))
	      classes)
   :from-end t))

;;; (classes-subsumes-classes classes1 classes2)
;;; TRUE if EVERY classes1 subsume SOME classes2. The intuition here is that 
;;;    (remove-subsumers (append classes1 classes2)) -> classes2 (or more precisely -> (remove-subsumers classes2))
;;; This function still works if there are redundant classes in the list.
;;;
;;; (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.
(defun classes-subsume-classes (classes1 classes2)
  (every #'(lambda (class1)
	     (some #'(lambda (class2) (is-subclass-of class2 class1))
		   classes2))
	 classes1))

;;; ======================================================================
;;;		AND FOR NORMAL SPECIALIZATION LINKS
;;; ======================================================================

(defun all-classes (instance)
  (cons '#$Thing (remove-duplicates (mapcan #'all-superclasses0 (immediate-classes instance)))))

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

;;; This *doesn't* include class in the list
(defun all-superclasses (class) 
  (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.
(defun all-superclasses0 (class &key path-so-far)
  (cond ((eq class '#$Thing) nil)		; for efficiency. #$Thing is added by all-superclasses above
	((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
(defun all-subclasses (class) 
  (remove-duplicates (mapcan #'all-subclasses0 (immediate-subclasses class))))

;;; Returns a *list* of subclasses, *including* class, but *not* including #$Thing, and possibly with duplicates.
(defun all-subclasses0 (class &key path-so-far)
  (cond ((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
(defun all-supersituations (situation) 
  (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*.
(defun all-supersituations0 (situation)
  (cond ((eq situation *global-situation*) nil)	  ; For efficiency. *global-situation* is added by all-supersituations
	(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 #'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 '#$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!!

[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
[2] immediate-instances vs. full-immediate-instances
    CLib has a few statements that involve (the instances of ...) and 
    (the all-instances of ...), e.g., on Time-Instant and Time-Interval.
    These are problematic with prototypes as currently a protoinstance is also 
    an instance, and so these statements collect and start reasoning on 
    protoinstances (not allowed!). It's a little schizophrenic, though,
    as the instance-of assertions are still there in the KB, just hidden
    from    (the instances of ...)
	    (the all-instances of ...)
    and the Lisp equivalents
            (all-instances <class>)
	    (immediate-instances <class>)
    i.e., one can view the above as meaning (the real-instances of ...) etc.
|#
(defun immediate-protoinstances (class) (remove-if-not #'protoinstancep (full-immediate-instances class)))
(defun all-protoinstances (class) (remove-if-not #'protoinstancep (full-all-instances class)))

(defun immediate-instances (class) (remove-if #'protoinstancep (full-immediate-instances class)))
(defun all-instances (class) (remove-if #'protoinstancep (full-all-instances class)))

(defun full-all-instances (class)
  (remove-duplicates
   (my-mapcan #'full-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
(defun full-immediate-instances (class)
  (remove-if-not #'kb-objectp			; object might be unified to a string
   (dereference		 			; Don't know if is neccesary, but put in to be safe!
    (cond ((and (neq class '#$Situation)					; Situation needs to collect ADDITIONAL user-created situations too (in next cond clause)
		(inv-assoc class (built-in-instance-of-links)))	  	; e.g. Boolean -> {t,f}
	   (mapcan #'(lambda (instance+class) (cond ((eq (second instance+class) class) (list (first instance+class))))) (built-in-instance-of-links)))
	  ((or (not (fluentp '#$instances))
	       (some #'(lambda (class2) (is-subclass-of class class2)) *built-in-classes-with-nonfluent-instances-relation*))   ; i.e. (Situation Slot Partition)
	   (get-vals class '#$instances :situation *global-situation*))
	  (t 				; instances is a fluent slot (NOT the default)
	   (km-slotvals2 class '#$instances))))))   ;;;  [1] does projection and constraint enforcement

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

(defun immediate-prototypes (class) (get-vals class '#$prototypes :situation *global-situation*))
(defun all-prototypes (class)
  (remove-dup-instances
   (append (get-vals class '#$prototypes :situation *global-situation*)
	   (mapcan #'all-prototypes (immediate-subclasses 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.
(defun all-situations () 
  (cond ((am-in-global-situation)
	 (remove-duplicates (cons *global-situation* (all-instances '#$Situation)) :from-end t))		; [1]
	(t (let ( (curr-situation (curr-situation)) )
	     (change-to-situation *global-situation*)
	     (prog1
		 (remove-duplicates (cons *global-situation* (all-instances '#$Situation)) :from-end t)	; [1]
	       (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]).
;(defun immediate-supersituations (situation)
;  (cond ((eq situation *global-situation*) nil)
;	((get-vals situation '#$supersituations :situation *global-situation*))
;	(t (list *global-situation*))))

;;; Modified by Fabien Dubail to include handling an expression in Supersituations 
(defun immediate-supersituations (situation)
    (cond ((eq situation *global-situation*) nil)
          ((let ((supersits (get-vals situation '#$supersituations :situation *global-situation*)))
      						      ; get-vals > (|*Global| (|the| |world| |of| *S1))
	    (remove nil                        ; (km-int `#$(,SIT)) can be Nil
                    (mapcar #'(lambda (sit)
		            (cond ((kb-objectp sit) sit)            
                                   (t (first (km-int `#$(,SIT))))))
                    supersits))))               
        (t (list *global-situation*))
        ))

;;; ======================================================================
;;;			SLOTS: Cardinalities
;;; ======================================================================

(defconstant *default-default-fluent-status* '#$*Fluent) ; neah, don't change this!
(defparameter *default-fluent-status* *default-default-fluent-status*)	; user can change this

(defun default-fluent-status (&optional status)
  (cond ((null status) 
	 (km-format t "By default, slots have fluent-status = ~a.~%" *default-fluent-status*)
	 '#$(t))
        ((member status *valid-fluent-statuses*) 
;	 (setq *default-fluent-status* status)
;	 (make-transaction `(setq *default-fluent-status* ,status))
	 (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.
(defun fluentp (slot)
  (case *default-fluent-status* 
	(#$*Non-Fluent 		      (member (fluent-status slot)
					      '#$(*Fluent *Inertial-Fluent)))	; [1]
	(#$(*Fluent *Inertial-Fluent) (neq (fluent-status slot)			; [2]
					   '#$*Non-Fluent))))

(defun inertial-fluentp (slot)
  (case *default-fluent-status* 
	(#$(*Non-Fluent *Fluent) (eq (fluent-status slot)
				     '#$*Inertial-Fluent))
	(#$*Inertial-Fluent      (not (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!!!
(defun fluent-status (slot)
  (cond 
   ((member slot *built-in-inertial-fluent-slots*) '#$*Inertial-Fluent)
   ((member slot *built-in-non-inertial-fluent-slots*) '#$*Fluent)
   ((universalp slot) '#$*Non-Fluent)
   ((let ( (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 (not (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 (not (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]

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

(defun single-valued-slotp (slot) 
  (member (cardinality-of slot) '#$(1-to-1 N-to-1)))

(defun multivalued-slotp (slot) (not (single-valued-slotp slot)))

(defun inherit-with-overrides-slotp (slot) 
  (or (get-vals slot '#$inherit-with-overrides :situation *global-situation* :dereferencep nil)
      (get-vals slot '#$simple-inherit-with-overrides :situation *global-situation* :dereferencep nil)))

(defun simple-inherit-with-overrides-slotp (slot) 
  (get-vals slot '#$simple-inherit-with-overrides :situation *global-situation* :dereferencep nil))

(defun slots-to-opportunistically-evaluate (instance)
  (remove-duplicates
   (my-mapcan #'(lambda (class)
		  (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!
(defun cardinality-of (slot)
  (cond 
   ((member slot *built-in-single-valued-slots*) '#$N-to-1)
   ((member slot *built-in-multivalued-slots*) '#$N-to-N)
   ((or (cardinality-of2 slot)
	(invert-cardinality (cardinality-of2 (invert-slot slot)))
	*default-cardinality*))))

(defun cardinality-of2 (slot)
  (case slot
    (t (let ( (cardinalities (get-vals slot '#$cardinality :situation *global-situation* :dereferencep nil)) )
	 (cond ((null cardinalities) nil) 		; was *default-cardinality* - but I need to check the slot's inverse first!
	       (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 ((not (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)))))))))

(defun invert-cardinality (cardinality)
  (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
(defun install-inverses (frame slot vals &optional (situation (target-situation (curr-situation) frame slot)))
  (cond  ((not *installing-inverses-enabled*))		; skip otherwise
	 ((not (listp vals))
	 (report-error 'program-error "Non-list ~a passed to (install-inverses ~a ~a ~a)!~%" vals frame slot vals))
        ((not (non-inverse-recording-slot slot))
	 (let ( (invslot (invert-slot slot)) )
	   (mapc #'(lambda (val)
		     (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))) ; [1] otherwise ignore it 
		 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 #'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
|#
(defun install-inverses0 (invframe0 invslot invval slot &optional (situation (target-situation (curr-situation) invframe0 invslot)))
  (let ( (invframe (dereference invframe0)) )
    (cond ((and (kb-objectp invframe)
		(not (non-inverse-recording-concept invframe))    		; eg. don't want boolean (T has (open-of (Box1))
		(not (member invval (get-vals invframe invslot :situation situation) :test #'equal)))  ; don't already know it
	   (let ( (install-inversesp (km-argsp invval)) )			    ; [1] nil, unless a :args structure, in which case iterate
	     (add-val invframe invslot invval install-inversesp situation))	    ;     so all inverses are installed.
; NEW: see [3]
;	   (cond ((member slot '#$(inverse inverse2 inverse3))			    ; See earlier [2]
;		  (add-val invframe '#$instance-of '#$Slot t *global-situation*)))
	   (classify invframe :slots-that-changed (list invslot))
	   )
	  ((km-argsp invframe)							; multiargument value, eg. Fred loves (:args Sue lots)
	   (install-inverses0 (second invframe) invslot 			; do first argument...    Sue loved-by (:args Fred lots)
			    `#$(:args ,INVVAL ,@(REST (REST INVFRAME))) slot situation)   
	   (cond ((and (third invframe)						; do second argument...    lots love-given-to (:args Sue Fred)
		       (or (assoc slot *built-in-inverse2s*)
			   (get-unique-val slot '#$inverse2 :situation *global-situation*)))
		  (let ( (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))))) )	;  (:args Sue Fred)
		    (install-inverses0 (third invframe) inv2slot modified-args slot situation))))
	   (cond ((and (third invframe)
		       (get-unique-val slot '#$inverse12 :situation *global-situation*))
		  (let ( (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))))		; install-inversesp = t
	   (cond ((and (fourth invframe)							; do third argument
		       (get-unique-val slot '#$inverse3 :situation *global-situation*))
		  (let ( (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 install operation, INCLUDING deleting explanations.
(defun uninstall-inverses (frame slot vals &optional (situation (target-situation (curr-situation) frame slot)))
  (cond ((not (non-inverse-recording-slot slot))		
	 (let ( (invslot (invert-slot slot)) )
	   (mapc #'(lambda (val0)
		     (let ( (val (dereference val0)) )
		       (cond ((and (kb-objectp val)
				   (not (non-inverse-recording-concept val))    ; eg. don't want boolean
				   						; (T has (open-of (Box1))
				   (member frame (get-vals val invslot :situation situation)))
			      (let ( (new-vals (remove frame (get-vals val invslot :situation situation))) )
				(delete-explanation val invslot frame :explanation-to-delete 'all :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.

(defun eval-instance (instance)
  (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.
(defun eval-instances (&optional (instances (obj-stack)) &key (n 0))
  (cond 
   ((null instances))
   ((>= n 100) 
    (report-error 'user-error "eval-instances in frame-io.lisp!~%Recursion is causing an infinite graph to be generated! Giving up...~%"))
   (t (let ( (obj-stack (obj-stack)) )
	(mapc #'simple-eval-instance instances)
	(cond (;(not (am-in-prototype-mode))
	       (use-prototypes)
	       (mapc #'unify-in-prototypes instances)
	       (mapc #'classify instances))
	      (t 			; ie. (am-in-prototype-mode)
	       (mapc #'eval-constraints instances))) ; expand (<> (the Car)) -> (<> _ProtoCar23)
	(eval-instances (ordered-set-difference (obj-stack) obj-stack) ; process newly created instances
			:n (1+ n))))))

;   (t (let ( (expansion-done? (remove nil (mapcar #'simple-eval-instance instances))) )
;	(cond (expansion-done? (eval-instances (obj-stack) (1+ n))))))))

(defun eval-constraints (instance)
  (mapc #'(lambda (slotvals)
	    (let ( (new-vals (mapcar #'(lambda (val)
					 (cond ((and (pairp val)
						     (eq (first val) '<>))
						(list '<> (km-unique-int (second val) :fail-mode 'error)))
					       (t val)))
				     (vals-in slotvals))) )
	      (cond ((not (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!
(defun simple-eval-instance (instance) 
  (remove nil
	  (mapcar #'(lambda (slotvals) 
		      (cond ((some #'(lambda (val) 
				       (and (not (fully-evaluatedp val))
					    (not (constraint-exprp val))))
; for debugging				    (or (km-format t "expanding (~a has (~a (~a)))...~%" instance (slot-in slotvals) val) t)
				   (vals-in slotvals))	; [1]

			     (km-int `#$(the ,(SLOT-IN SLOTVALS) of ,INSTANCE))
			     t)))
		  (get-slotsvals instance))))

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

;;; *inverse-suffix* = "-of" (case-sensitivity on) "-OF" (case-sensitivity off)
(defun invert-slot (slot)
  (cond	((second (assoc slot *built-in-inverses*)))	; use built-in declarations
	((not (check-isa-slot-object slot)) nil)
        ((get-unique-val slot '#$inverse :situation *global-situation*))	; look up declared inverse
	(t (let ( (str-slot (symbol-name slot)) )		; default computation of inverse
	     (cond ((and (> (length str-slot) 3)
			 (ends-with str-slot *inverse-suffix*)) 		; "parts-of"
		    (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:
(defun invert-predicate (predicate &optional (argnum 2))
  "return the inverse variant of PREDICATE such that
   the first and ARGNUMth args have been swapped." 
  (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')
|#
(defun check-domain-and-range (instance slot vals)
  (let* ( (domains (domains-of slot)) 
	  (ranges (ranges-of slot)) 
	  (domain-violation 
	   (cond ((and domains 
		       (notany #'(lambda (domain) (instance-of instance domain)) domains))
		  (cond ((some #'(lambda (domain) (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)
				     (cond ((and (kb-objectp val)
						 (notany #'(lambda (range) (instance-of val range)) ranges))
					    (cond ((some #'(lambda (range) (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)
		     (km-format t "         ~a isn't one of ~a (violates the range constraint for `~a')~%" range-violation ranges slot))
		 range-violations)))))

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

(defun check-isa-slot-object (slot)
  (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))
	((not (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!

(defun check-slot (frame slot values)
  (declare (ignore frame values))
  (cond 
   ((not (checkkbp)))
   ((built-in-concept slot))
   ((undeclared-slot slot))
   (t (let ( (domains (domains-of slot))
	     (ranges (ranges-of slot)) )
	(cond ((not domains) (report-error 'user-warning "Domain for slot ~a not declared.~%" slot)))
	(mapc #'(lambda (domain)
		  (cond ((not (known-frame domain)) 
			 (report-error 'user-warning "Domain ~a for slot ~a not declared in KB.~%" domain slot))))
	      domains)
	(cond ((not ranges) (report-error 'user-warning "Range for slot ~a not declared.~%" slot)))
	(mapc #'(lambda (range)
		  (cond ((not (known-frame range)) 
			 (report-error 'user-warning "Range ~a for slot ~a not declared in KB.~%" range slot))))
	      ranges)))))

(defun domains-of (slot)
  (or (get-vals slot '#$domain :situation *global-situation*)
      (get-vals (invert-slot slot) '#$range :situation *global-situation*)))

(defun ranges-of (slot)
  (or (get-vals slot '#$range :situation *global-situation*)
      (get-vals (invert-slot slot) '#$domain :situation *global-situation*)))

(defun undeclared-slot (slot)
  (cond ((not (symbolp slot)) 
	 (report-error 'user-error "Non-slot ~a found where a slot was expected!~%" slot) t)
	((and (not (known-frame slot)) 
	      (not (known-frame (invert-slot slot)))
	      (not (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
|#
;;; ----------------------------------------

(defun install-all-subclasses ()
  (format t "(install-all-subclasses) has been renamed (clean-taxonomy). Please update your code!~%"))

(defun clean-taxonomy (&key silentp)
  (cond ((not silentp) (format t "Removing redundant superclasses...~%")))
  (mapc #'remove-redundant-superclasses (get-all-concepts)) ; [2]
  (cond ((not silentp) (format t "Removing redundant subclasses...~%")))
  (mapc #'remove-redundant-subclasses (get-all-concepts)) ; [2]
  (cond ((not silentp) (format t "Computing subclasses of Thing...~%")))
  (mapc #'(lambda (val) (add-val '#$Thing '#$subclasses val)) (subclasses-of-thing)) ; [3]
  t)

;;; ----------------------------------------
;;; This is too slow to include in the loader for all superclass changes
#|
X <| C
X <| GenC    hence  X <| C, GenC
Now add C <| GenC, X <| GenC is redundant and should be removed, so foreach GenC's subclasses, check for
	redundancy in its superclasses link

ALSO:
C <| D
GenC <| D    hence   D subclasses C, GenC
Now add C <| GenC, C <| 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))

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

(defun remove-redundant-superclasses (class)
  (let* ((superclasses (get-vals class '#$superclasses))
	 (minimal-superclasses (remove-subsumers superclasses)))
    (cond ((not (set-equal superclasses minimal-superclasses))
	   (mapc #'(lambda (redundant-superclass)
		     (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))))))

(defun remove-redundant-subclasses (class)
  (let* ((subclasses (get-vals class '#$subclasses))
	 (minimal-subclasses (remove-subsumees subclasses)))
    (cond ((not (set-equal subclasses minimal-subclasses))
	   (mapc #'(lambda (redundant-subclass)
		     (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
(defun global-situation () 
  (cond ((neq *curr-situation* *global-situation*)		; [1]
	 (in-situation *global-situation*))
	(t (list *global-situation*))))

;;; A KM function passed to Lisp:
;;; NB 2.12.99 dereference added!!!
(defun curr-situation () (dereference *curr-situation*))

(defun in-situation (situation-expr &optional km-expr theoryp)
  (cond ((and (tracep) (not (traceothersituationsp)))
	 (let* ((*trace* nil))
	   (in-situation0 situation-expr km-expr theoryp)))
;	 (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].
(defun in-situation0 (situation-expr &optional km-expr theoryp)
  (let* ( (situation-structure (km-unique-int situation-expr))
	  (situation (cond ((and (not theoryp)
				 (km-argsp situation-structure)) (arg1of situation-structure))	; e.g. situation-expr = (the next-situation of ...)
			   (t situation-structure))) 						; e.g. situation-expr = (a Situation)
	  (situation-class (cond (theoryp '#$Theory)
				 (t '#$Situation))) )
    (cond ((and (not theoryp) (neq situation-expr *global-situation*)) (set-situations-mode)))
    (cond ((eq situation (curr-situation))			; [2]
	   (cond ((neq (curr-situation) *curr-situation*)
		  (change-to-situation (curr-situation))))	; in case *curr-situation* is bound, but not eq, to (curr-situation)
	   (cond (km-expr (km-int km-expr))
		 (t (list (curr-situation)))))
	  ((am-in-prototype-mode)				; [1]
	   (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 (not situation) 
	       (not (kb-objectp situation)))
	   (report-error 'user-error "~a doesn't evaluate to a ~a (results in ~a instead)!~%" 
			 situation-expr situation-class situation-structure))
	  ((not (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))
	  ((not 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)))		; must return a list of values, for consistency
	  (t (let ( (curr-situation (curr-situation)) )
	       (km-trace 'comment "")			; does a nl
	       (km-trace 'comment "Temporarily changing to ~a ~a..." situation-class situation)
	       (change-to-situation situation)
	       (prog1
		   (km-int 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 "")))))))


(defun am-in-global-situation () (eq (curr-situation) *global-situation*))
(defun am-in-local-situation () (and (neq (curr-situation) *global-situation*)
				     (not (isa-theory (curr-situation)))))
(defun change-to-situation (situation) 
;  (make-transaction `(setq *curr-situation* ,situation)))
  (km-setq '*curr-situation* situation))

(defun am-in-local-situation-or-theory () (neq (curr-situation) *global-situation*))

;;; next-situation will create a new situation which is at the next-situation relation
;;; to the situation given. 
;;; action is an INSTANCE (it better be!)
;;; RETURNS: The next situation
(defun next-situation (action &key next-situation)
    (cond ((am-in-global-situation)
	   (report-error 'user-error "You must be in a Situation to create a next-situation!~%"))
	  (t (let ((curr-situation (curr-situation))
		   (new-situation (or next-situation (make-new-situation))))
;; changed by Fabien Dubail from "has" to "also-has" to avoid unification of anonymous actions
	       (km-unique-int `#$(,NEW-SITUATION also-has                       
		(instance-of (Situation))
	 	(prev-situation ((:args ,CURR-SITUATION ,ACTION)))) :fail-mode 'error))))) ; inverse auto-installed

(defun new-situation () 
  (in-situation (make-new-situation)))

(defun make-new-situation () 
  (km-unique-int `#$(a Situation with (supersituations (,*GLOBAL-SITUATION*))) :fail-mode 'error))
    
;;; always t for now -- disable this verification step
(defun isa-situation-facet (situation) (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

;;; Optimized version from Francis Leboutte
(defun curr-situation-facet (facet &optional (curr-situation (curr-situation)))
  (declare (type symbol facet))
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (cond ((eq curr-situation *global-situation*) facet)
	((get facet curr-situation))
	(t
         (setf (get facet curr-situation) 				; [1]
               (intern (concatenate 'string
                                    (symbol-name facet)
                                    (symbol-name curr-situation))
                       *km-package*)))))

;(defun curr-situation-facet (facet &optional (curr-situation (curr-situation)))
;  (cond ((eq curr-situation *global-situation*) facet)
;	((get facet curr-situation))
;	(t ; (km-format t "making a new facet...~%")
;	   (setf (get facet curr-situation) 				; [1]
;		 (intern (concat (symbol-name facet) (symbol-name curr-situation)) *km-package*)))))

;;; ======================================================================
;;;		SITUATION TRANSITIONS:
;;; ======================================================================

(defvar *user-has-been-warned* nil)

(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!
(defun do-action (action-expr &key next-situation change-to-next-situation (test-or-assert-pcs 'assert))
 (let ((*classification-enabled* nil))	; [5]
   (cond ((not *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.
----------------------------------------------------------------------
")
	 (setq *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 (let ( (old-situation (curr-situation))
	     (action (cond (action-expr (km-unique-int action-expr)))) )
	(cond
;	 ((and action (not (isa action '#$Event)))		; NEW! [2]
;	  (report-error 'user-error "KM 1.4.0.51 and later: ***Actions must now be instances of the built-in class Event***~%       I can't do ~a as it is not an instance of Event (or one of Event's subclasses)!~%       Please update your taxonomy!~%" action))
;	 ((get-vals action '#$after-situation :situation *global-situation*)
;	  (report-error 'user-error "You can't do the same action ~a twice! You should create a new action instance instead!~%" action))
	 (t (cond ((not action)
		   (make-comment "Doing null action...")
		   (in-situation (next-situation nil :next-situation next-situation))
		   (prog1
		       (curr-situation)
		     (cond ((not change-to-next-situation) (in-situation old-situation)))))
		  (t (km-trace 'comment "Computing the preconditions and effects of action ~a..." action)
		     (let* ( (semi-evaluated-pcs-list (find-propositions action '#$pcs-list))	
			     (semi-evaluated-ncs-list (find-propositions action '#$ncs-list))
					; Result = ((:triple expr expr expr) ... (: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
			     )
		       
		       (cond ((or semi-evaluated-pcs-list semi-evaluated-ncs-list)
			      (km-trace 'comment "Forward propogate relevant facts from previous situation...")	; [1]
			      (mapc #'(lambda (frame+slot) 
					(let ( (frame (first frame+slot))
					       (slot (second frame+slot)) )
					  (cond ((comparison-operator slot)
						 (km-int frame))
						(t (km-int `#$(the ,SLOT of ,FRAME))))))
				    (remove-duplicates (mapcar #'(lambda (triple)
								   (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)
			      (let ( (unsatisfied-pcs (unsatisfied-propositions semi-evaluated-pcs-list)) )
				(cond ((or (null unsatisfied-pcs)
					   (eq test-or-assert-pcs 'assert)
					   (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 
								   (desource+decomment 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) (km-assert ncs-item action :in-list '#$ncs-list)) semi-evaluated-ncs-list)
				       (mapc #'(lambda (pcs-item) 
						 (make-comment "Assuming ~a, to do action ~a..." pcs-item action)
						 (km-assert pcs-item action :in-list '#$pcs-list)) 
					     unsatisfied-pcs)

; [4] PC - This isn't drastic enough: see test-suite/cache.km
;				       (un-done action :slot '#$add-list :situation (curr-situation))	; (in case asserting pcs/ncs has changed them)
;				       (un-done action :slot '#$del-list :situation (curr-situation))
#| Do this instead |#		       (cond ((or semi-evaluated-ncs-list unsatisfied-pcs) (un-done action :situation (curr-situation))))

				       (let* ( (next-situation0 (next-situation action :next-situation next-situation))	
#|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-situation0)))
					 (in-situation next-situation0)
					 (mapc #'(lambda (del-item) (km-assert del-item action :in-list '#$del-list)) evaluated-del-list)
					 (mapc #'(lambda (blk-item) (km-assert blk-item action :in-list '#$add-list)) add-blk-list)
					 (mapc #'(lambda (add-item) (km-assert add-item action :in-list '#$add-list)) evaluated-add-list)
					 (prog1
					     (curr-situation)
					   (cond ((not 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.
(defun evaluate-triple (triple)
  (cond ((and (pathp (arg3of triple))
	      (not (comparison-operator (arg2of triple))))
	 (km-trace 'comment "Evaluate the individual frame/slot/val paths in~%        ~a..." triple)
	 `(#$:triple ,(km-unique-int (arg1of triple) :fail-mode 'error) 
		     ,(km-unique-int (arg2of triple) :fail-mode 'error) 
		     ,(vals-to-val (km-int (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??????
|#
(defun block-list (add-list)
  (remove-dup-instances
   (mapcan #'(lambda (proposition)				; [1]
	       (let ( (frame (second proposition))
		      (slot (third proposition))
		      (val (fourth proposition)) )	; necessarily a singleton, if slot is single-valued
		 (cond ((and (single-valued-slotp slot)
			     (not (constraint-exprp val)))
			(cond ((km-setp val)
			       (report-error 'user-error 
				     "do-action trying to assert multiple values for single-valued slot!~%Trying to assert ~a for (the ~a of ~a)!~%" 
				     (val-to-vals val) slot frame))
			      (t (mapcan #'(lambda (val0)
					     (cond ((kb-objectp val0)
						    `((#$:triple ,val0 ,(invert-slot slot) (<> ,frame))))))
					 (remove val (km-int `#$(the ,SLOT of ,FRAME))))))))))
	   add-list)))

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

;;; PCS-LIST and NCS-LIST are assumed SEMI-EVALUATED, ie. <frame> and <slot> are already evaluated
(defun consistent-to-do-action (action pcs-list ncs-list)
  (let ( (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 (desource+decomment 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 (desource+decomment inconsistent-ncs))))
    (and (null inconsistent-pcs) 
	 (null inconsistent-ncs))))	; condition for success
		       
(defun inconsistent-propositions (propositions &key 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) (is-consistent-to-assert proposition :in-list in-list)) propositions))))

(defun is-consistent-to-assert (proposition &key in-list)		; in-list = '#$add or '#$del
  (cond ((km-triplep proposition)
	 (let* ( (frame (second proposition))				; assumes frame and slot are already evaluated
		 (slot  (third proposition))
		 (inv-slot (invert-slot slot))
		 (values (val-to-vals (fourth proposition))) )		; NB don't evaluate - leave it to the later KM 
	   (case in-list
		 (#$(pcs-list add-list) 
		    (cond ((member slot *inequality-relations*)		; In this case, values will be unevaluated (see handling of :triple in
			   (cond ((null values)				;			interpreter.lisp)
				  (report-error 'user-error "Triple ~a: missing a value to compare against!" proposition))
				 ((not (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))
				  (let* ( (x+y (minimatch frame '#$(the ?x of ?y)))
					  (x (first x+y))
					  (y (km-unique-int (second x+y) :fail-mode 'error)) )
				    (km-int `#$(,Y &? (a Thing with 
						      (,X ((constraint (not (TheValue ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION))))))))
					)))
				 (t (km-int `#$(not (,FRAME ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION))) 
					))))	 ; just test it.
			  (t (km-int `#$(,FRAME &? (a Thing with (,SLOT ,VALUES)))))))	 ; inverses installed automatically.
		 (#$(ncs-list del-list) (every #'(lambda (value)
						   (and ; (neq value '*)
						        (km-int `#$(,FRAME &? (a Thing with (,SLOT ((<> ,VALUE))))))
							(cond ((and (kb-objectp value)
								    (kb-objectp slot)
								    (not (non-inverse-recording-slot slot))
								    (not (non-inverse-recording-concept value)))
							       (km-int `#$(,VALUE &? (a Thing with (,INV-SLOT ((<> ,FRAME)))))))
							      (t))))
					       (km-int (fourth proposition))))
		 			       ; values))	OLD
		 (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))))

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

(defun unsatisfied-propositions (propositions)		; just pcs-list
  (cond (propositions
	 (km-trace 'comment "Checking that propositions:~%~{   ~a~%~}    are satisfied..." propositions)
	 (remove-if #'(lambda (proposition) (km-int `#$(is-true ,PROPOSITION))) propositions))))

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

;;; 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.
(defun km-assert (proposition action &key in-list)	; in-list = '#$add-list or '#$del-list. action is purely for explanation facility.
  (cond 
   ((km-triplep proposition)
    (let* ( (frame (second proposition))
	    (slot  (third proposition))
	    (inv-slot (invert-slot slot))
;	    (values (val-to-vals (fourth proposition))) )		
	    (values 
	     (cond ((not (member slot *inequality-relations*))	 ; (if slot IS in *inequality-reliations*, then values is NOT used below)
		    (km-int (fourth proposition))))) ; NO!! Need to preserve constraints here!! But we *do* want to evaluate, so the
	    (constraints (extract-constraints 
			  (val-to-vals (fourth proposition)))) )	; inverses get installed. We'll ignore this incompleteness for now 
      									; (only for pcs-list). New: Let's fold constraints back in. We need to
      									; evaluate values for storage in the explanations.
      (case in-list
	    (#$(pcs-list add-list) 
	       (cond 
		((member slot *inequality-relations*)
		 (cond ((minimatch frame '#$(the ?x of ?y))
			(let* ( (x+y (minimatch frame '#$(the ?x of ?y)))
				(x (first x+y))
				(y (km-unique-int (second x+y) :fail-mode 'error)) )
			  (km-int `#$(,Y also-has 
				      (,X ((constraint (not (TheValue ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION))))))) :fail-mode 'error)))))
		; ELSE: nothing to assert, but constraint would have already been tested by is-consistent-to-assert 
		(t (km-int `#$(,FRAME has (,SLOT ,(APPEND VALUES CONSTRAINTS))) :fail-mode 'error)))	 ; inverses installed automatically.  [1]
	       (mapc #'(lambda (value)
			 (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)
					     (km-int `#$(,FRAME also-has (,SLOT ((<> ,VALUE)))) :fail-mode 'error)
					     (cond ((and (kb-objectp value)
							 (kb-objectp slot)
							 (not (non-inverse-recording-slot slot))
							 (not (non-inverse-recording-concept value)))
						    (km-int `#$(,VALUE also-has (,INV-SLOT ((<> ,FRAME)))) :fail-mode 'error))))
					 values))
;					 (km-int (fourth proposition))))
	    (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
(defun find-propositions (action slot)
  (remove nil
   (mapcar #'(lambda (triple)
;	       (km-format t "triple = ~a...~%" triple)
	       (cond ((km-triplep triple)
		      (cond ((and (member slot '#$(ncs-list del-list))
				  (constraint-exprp (fourth triple)))
			     (report-error 'user-error "~a found in (the ~a of ~a)~%   You can't include constraints in the triples of a ~a!"
					   triple slot action slot)
			     nil)
			    (t triple)))
		     (t (report-error 'user-error "Non-triple ~a found in (the ~a of ~a)" triple slot action)
			nil)))
	   (km-int `#$(the ,SLOT of ,ACTION)))))

#|
(defun convert-to-triple (triple)
  (cond ((km-triplep triple) triple)
	((isa triple '#$Triple)
	 (list '#$:triple
	       (km-unique-int `#$(the frame of ,TRIPLE) :fail-mode 'error)
	       (km-unique-int `#$(the  slot of ,TRIPLE) :fail-mode 'error)
	       (vals-to-val (km-int `#$(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*
(defun visible-theories () *visible-theories*)

(defun hide-theory (theory)
  (cond ((and (not (isa-theory theory))
	      (not (instance-of theory '#$Situation)))
	 (report-error 'user-error "(hide-theory ~a): ~a is not a theory!" theory theory))
	((not (member theory *visible-theories*))
	 (km-trace 'comment "[(hide-theory ~a): ~a is already hidden]" theory theory))
	(t (reset-done)			; note, answers may change when a theory becomes hidden
	   (km-setq '*visible-theories* (remove theory *visible-theories*)))))

(defun see-theory (theory)
  (cond ((and (not (isa-theory theory))
	      (not (instance-of theory '#$Situation)))
	 (report-error 'user-error "(see-theory ~a): ~a is not a theory!" theory theory))
	((member theory *visible-theories*)
	 (km-trace 'comment "[(see-theory ~a): ~a is already visible]" theory theory))
	(t (reset-done)		; note, answers may change when a theory becomes visible
	   (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.
(defun all-theories () (get-vals '#$Theory '#$instances :situation *global-situation*))

(defun isa-theory (theory) (member theory (all-theories)))

(defun am-in-local-theory () (and (neq (curr-situation) *global-situation*) (isa-theory (curr-situation))))

(defun in-theory (theory-expr &optional km-expr) 
  (in-situation theory-expr km-expr t))					; theoryp = t

(defun all-situations-and-theories () (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!
NEW: Only allow deletion of known (valid) frames, to avoid this problem.
NOTE: Suppose X -> Y and we delete Y: We better be sure that no X's are lying around in memory. 
I *think* we are ok though: Consider:
	(Foo has (r (X)))
	(X has (invr (Foo)))	; [1]
	(Y == X)		; thus there's a binding X -> Y, and KM will have rebuild [1] as:
	(Y has (invr (Foo)))
Now (delete-frame Y) will trigger (uninstall-inverses Y invr (Foo)). 
And as uninstall-inverses does a get-vals on Foo, *including a dereference*, X will be dereferenced.
For this reason we have to delete the inverses BEFORE deleting the frame itself.

What about this, though:
	(Foo has (r ((_X & _X2))))  ; [2] no inverses in this case
	(_Y == _X)	  	    ; thus there's a binding X -> Y, and KM will have rebuild [1] as:
	(delete-frame _Y)
Unfortunately [2] leaves a spurious concept _X lying around in [2], pointing to non-existent _Y. [2] becomes:
	(Foo has (r ((_Y & _X2))))
In fact, we get away with this because _Y is a null frame, i.e., is equivalent to NIL. Thus
(_Y & _X2) = (NIL & _X2) = _X2, so we are okay.
If we now recreate a new _Y, though, we'd now have problems as the pointer to the old Y is lying around.
The safest way would be to rebind _X to nil, done at the end.

NOTE: We *will* be in trouble if the user then attempts to re-use the Skolem name.
So do a (dereference-kb) to clean up the old junk.
|#
(defun delete-frame (frame0 &key (delete-inversesp t))
  (let ((frame (dereference frame0)))
  (cond ((known-frame frame)
	 ;;; Delete definition pointers
	 (cond (*are-some-definitions* 
		(let ((own-definition-parents (get-vals frame '#$instance-of :facet 'own-definition))
		      (member-definition-parents (get-vals frame '#$instance-of :facet 'member-definition)))
		  (cond (own-definition-parents 
			 (unpoint-parents-to-defined-concept frame own-definition-parents 'own-definition)))
		  (cond (member-definition-parents 
			 (unpoint-parents-to-defined-concept frame member-definition-parents 'member-definition))))))
 	 ;;; Delete inverse links
	 (cond (delete-inversesp
		(mapc #'(lambda (situation)
			  (mapc #'(lambda (facet)
				    (mapc #'(lambda (slotvals)
					      (let ((slot (slot-in slotvals))
						    (vals (vals-in slotvals)))
						(uninstall-inverses frame slot vals situation)))
					  (get-slotsvals frame :situation situation :facet facet)))
				(cond (*are-some-definitions* '(own-properties own-definition))
				      (t '(own-properties)))))
		      (all-situations-and-theories))))
	 ;;; Delete from the object stack
	 (remove-from-stack frame)
	 ;;; Delete frame itself
	 (delete-frame-structure frame)	; maybe other legacy references to frame, or to instances bound to frame
	 (push frame *deleted-frames*)	; keep a note of these. dereference-kb will clean these up
	 t)
	(t (report-error 'user-error "(delete-frame ~a): ~a is not a known frame.~%" frame frame)))))

(defun delete-slot (frame0 slot &key (delete-inversesp t) (situation (target-situation (curr-situation) frame0 slot)))
  (let ((frame (dereference frame0)))
  (cond ((known-frame frame)
 	 ;;; Delete inverse links
	 (cond (delete-inversesp
		(let* ((vals0 (get-vals frame slot :situation situation))
		       (vals (cond ((single-valued-slotp slot) (un-andify vals0)) ; ((a & b)) -> (a b)
				   (t vals0))))
		  (uninstall-inverses frame slot vals situation)))) ; includes explanations
	 (put-vals frame slot nil :situation situation) ; delete the vals
	 (delete-explanation frame slot '* :explanation-to-delete 'all :situation situation)	 
	 t)
	(t (report-error 'user-error "(delete-frame ~a): ~a is not a known frame.~%" frame frame)))))

;;; No taxonomic information.
(defun orphans () (remove-if-not #'orphanp (get-all-concepts)))

(defun scan-kb ()
  (let* ( (declared-symbols (get-all-concepts))
	  (all-objects (flatten-to-kb-objs (mapcar #'(lambda (situation)
					  (mapcar #'(lambda (concept)
						      (mapcar #'(lambda (facet)
								  (get-slotsvals concept :facet facet :situation situation))
							      *all-facets*))
						  declared-symbols))
				      (all-situations-and-theories))))
	  (all-symbols (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) 
					    (or (member symbol declared-symbols)
						(assoc symbol *user-defined-infix-operators*) ; elements are (<sym> <fn>)
						(comment-tagp symbol)
						(dotted-slot symbol)	; e.g., |agent...|, used in explain
						(km-varp symbol)
						(member (invert-slot symbol) declared-symbols)))
					user-symbols)) 
	 (missing-classes (remove-if #'(lambda (symbol)
					 (or (get-vals symbol '#$instance-of)
					     (get-vals symbol '#$superclasses)
					     (member symbol *built-in-frames*)))
				     declared-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) (km-format t "   ~a~%" symbol)) 
		 (sort (copy-list undeclared-symbols) #'string< :key #'symbol-name))
	   (format t "----- end -----~%")))
    (cond (missing-classes
	   (km-format t "The following ~a symbols have no instance-of or superclasses defined for them:~%"
		      (length missing-classes))
	   (mapc #'(lambda (symbol) (km-format t "   ~a~%" symbol)) 
		 (sort (copy-list missing-classes) #'string< :key #'symbol-name))
	   (format t "----- end -----~%")))
    '#$(t)))

;;; This removes quoted parts, e.g., (flatten-to-kb-objs '(a b (quote c) d)) -> (a b d)
;;; Note (flatten-to-kb-objs 'a) -> (a); 
;;; apairs become normal pairs  (flatten-to-kb-objs '(a b c . d)) -> '(a b c d)
(defun flatten-to-kb-objs (expr)
  (cond
   ((not (listp expr)) (list expr))
   ((null expr) nil)
   ((apairp (last expr)) `(,@(flatten-to-kb-objs (butlast expr)) ,(first (last expr)) ,(rest (last expr))))
   ((member (first expr) '(quote function lambda)) nil) ; #'(lambda (x) ...)= (function (lambda (x) ...))
   (t (my-mapcan #'flatten-to-kb-objs expr))))

;;; ======================================================================
;;;		SITUATIONS MODE
;;; ======================================================================

(defvar *am-in-situations-mode* nil)

(defun set-situations-mode ()
  (or *am-in-situations-mode*
      (progn (make-comment "Switching on situations mode for this KB")
	     (km-setq '*am-in-situations-mode* t))))

(defun am-in-situations-mode () *am-in-situations-mode*)

#|
Under these special circumstances, DON'T compute the value of a slot
Specifically: You're in the global situation, but the slot is a fluent (so can only take on situation-specific values).
   Also you are working with situations mode on (*am-in-situations-mode*=t). If that was nil, then everything's in global and 
   the fluent-status is irrelevant.
|#
(defun ignore-slot-due-to-situations-mode (slot)
  (and *am-in-situations-mode*
       (am-in-global-situation)
       (not (am-in-prototype-mode))
       (fluentp slot)))

;;; returns t and print error if there's a violation
(defun check-situations-mode (instance slot)
  (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)


;;; ======================================================================
;;;		NOWEXISTENCE - experimental
;;; ======================================================================

(defun nowexists (frame)
  (cond ((not (kb-objectp frame)) t)
	((not (am-in-local-situation)) t)
	(t (neq (nowexists-val frame) '#$f))))

(defun nowexists-val (frame &key (situation (curr-situation)))
  (cond ((get-unique-val frame '#$nowexists :situation situation))
	(t (let ((prev-situation (prev-situation situation frame)))
	     (cond (prev-situation (nowexists-val frame :situation prev-situation))
		   (t (let ((inherited-rule-sets (inherited-rule-sets frame '#$nowexists)))
			(some #'(lambda (inherited-rule-set)
				  (some #'(lambda (rule)
					    (cond ((equal rule '#$(:default t)) '#$t)
						  ((equal rule '#$(:default f)) '#$f)
						  (t (report-error 'user-error
								   "Illegal inherited expression on nowexists slot for ~a (Only allowed values are (:default t) or (:default f)~%" frame))))
					inherited-rule-set))
			      inherited-rule-sets))))))))

;;; FILE: trace.lisp

;;; File: trace.lisp
;;; Author: Peter Clark
;;; Purpose: Debugging facilities for KM

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

;;; ======================================================================
;;;		    FOR TRACING EXECUTION
;;; ======================================================================

(defvar *trace-classify* nil)
(defvar *trace-other-situations* nil)
(defvar *trace-unify* nil)
(defvar *trace-subsumes* nil)
(defvar *trace-constraints* nil)
(defvar *suspended-trace* nil)
(defvar *interactive-trace* nil)

;;; new global variable
(defvar *trace-to-file?* nil
  "if true, the km traces are sent to the trace file
   set by (trace-to-file-on [<filename>]) and (trace-to-file-off) from lisp
   set by (t2f-on [<filename>]) and (t2f-off) from km")

;;; ---------------------------------------- 
;;; Thanks to Raphael Van Dyck for this extension to allow tracing output
;;; to be directed to a file.

;;; new global variable
(defvar *trace-file* "%trace.km"
  "default trace file")

;;; new function
(defun trace-to-file-on (&optional filename)
  (setf *trace-to-file?* t)
  (when filename
    (setf *trace-file* filename))
  (format t "(Trace-to-file switched on)~%")
  '#$(t))

;;; new function
(defun trace-to-file-off ()
  (setf *trace-to-file?* nil)
  (format t "(Trace-to-file switched off)~%")
  '#$(t))

;;; Synonyms
(defun t2f-on (&optional filename) (trace-to-file-on filename))
(defun t2f-off () (trace-to-file-off))

;;; ---------- error recording ----------

(defun tracekm () 
  (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) (setq *interactive-trace* t)))
  t)

(defun untracekm () 
  (reset-trace)
  (cond (*trace* (format t "(Tracing of KM switched off)~%") (setq *trace* nil) (setq *interactive-trace* nil))
	(t (format t "(Tracing of KM is already switched off)~%")))
  t)

(defun reset-trace () 
  (cond ((or *trace* *interactive-trace*)   ; user may have temporarily switched off either of these during last tracing.
	 (setq *interactive-trace* t)
	 (setq *trace* t)))
;  (setq *depth* 0) 			; new - trace might be reset in middle of computation, so don't do this!
  (setq *suspended-trace* nil) 
  (setq *trace-classify* nil)
  (setq *trace-subsumes* nil)
  (setq *trace-other-situations* nil)
  (setq *trace-unify* nil)
  (setq *trace-constraints* nil)
  t)

(defun reset-trace-depth ()
  (setq *depth* 0))

(defun tracep () *trace*)
(defun traceunifyp () *trace-unify*)
(defun tracesubsumesp () *trace-subsumes*)
(defun traceclassifyp () *trace-classify*)
(defun traceconstraintsp () *trace-constraints*)
(defun traceothersituationsp () *trace-other-situations*)


;;; ----------------------------------------
;;;	SPY POINTS
;;; ----------------------------------------

;;; [1] minimatch expects &REST, but user will type &rest at KM prompt.
(defun spy (&optional expr0)
  (let ( (expr (subst '&rest '#$&rest expr0)) )			; [1]
    (cond ((and expr
		(not (member expr *spypoints* :test #'equal)))
	   (setq *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)))

(defun unspy ()
  (setq *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.
|#

(defvar *trace-goal-stack* nil)

;;; RETURNS: 'redo or 'fail
(defun km-trace (mode string &rest args)
; (km-format t "Current situation = ~a~%" (curr-situation))
  (cond ((eq mode 'call) (increment-trace-depth)))
; The below condition is now achievable, if an error triggers the debugger to be switched on.
; (cond ((and *suspended-trace* (< *depth* *suspended-trace*))		; debug message
;	 (report-error 'program-error "trace depth somehow crept below that at which trace was suspended! Continuing...~%")))
  (cond ((and (not *trace*)
	      (not (eq mode 'comment))
	      *suspended-trace*
	      (<= *depth* *suspended-trace*))	; would be eq, but I want to continue if debug message above sounds.
	 (unsuspend-trace)))
  (prog1				; reset *depth* for FAIL/EXIT *after* messages, but return result of messages.
      (cond (*trace-goal-stack* (clear-screen) (show-goal-stack) nil)
	    (*trace* (let ((stream (cond (*trace-to-file?* (open *trace-file*
								 :direction :output
								 :if-does-not-exist :create
								 :if-exists :append))
					 (t))))
		       (prog1
			   (km-trace2 mode string args :stream stream)
			 (cond ((streamp stream) (close stream)))))))
    (cond ((or (eq mode 'exit)(eq mode 'fail)) (decrement-trace-depth)))))

(defun km-trace2 (mode string args &key (stream t))
; (format t "~vT" *depth*)			; Bug in Harlequin lisp causes this not to tab properly!
  (print-trace-message mode string args :stream stream)
  (cond ((and #|(not *trace-to-file?*)|# *interactive-trace* (neq mode 'comment))
	 (cond ((neq stream t) (print-trace-message mode string args :stream t)))	; repeat to TTY, if writing to file
	 (finish-output)			; flush output if stream is buffered
	 (let ( (debug-option
                 ;; RVA 21Aug2006 fix km rep loop input output problem
                 ;; reading line from nil (*standard-input*) instead of t (*terminal-io*)
                 (read-line nil nil nil)) )
	   (cond ((string= debug-option "s")
		  (cond ((eq mode 'call) 		   ; don't suspend on an EXIT, or depth will immediately creep below
			 (suspend-trace))))		   ; the suspended depth
		 ((string= debug-option "S")
		  (cond ((eq mode 'call) 		   
			 (suspend-trace (1- *depth*)))))
		 ((string= debug-option "o") (untracekm))
		 ((string= debug-option "-A")
		  (format t "(Will no longer trace absolutely everything)~%")
		  (setq *trace-classify* nil)
		  (setq *trace-subsumes* nil)
		  (setq *trace-other-situations* nil)
		  (setq *trace-unify* nil)
		  (setq *trace-constraints* nil)
		  (km-trace2 mode string args :stream stream))
		 ((string= debug-option "a") (throw 'km-abort (list 'km-abort "User aborted from the debugger")))
		 ((string= debug-option "A") (untracekm) (throw 'km-abort (list 'km-abort "User aborted from the debugger")))
		 ((string= debug-option "r")
		  (cond ((eq mode 'call)   		   ; strictly redundant to redo on a call (ie. before it's even been tried)
			 (km-trace2 mode string args :stream stream))
			(t 'redo)))
		 ((string= debug-option "n") (setq *trace* nil) (setq *suspended-trace* nil))
		 ((string= debug-option "f") 'fail)
		 ((string= debug-option "g") (show-goal-stack) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "w") 
		  (let* ( (last-expr (stacked-expr (first (goal-stack))))
			  (exprs (cond ((and (listp last-expr) (eq (second last-expr) '&)) (&-expr-to-vals last-expr))
				       ((and (listp last-expr) (eq (second last-expr) '&&)) (apply #'append (&&-exprs-to-valsets (list last-expr))))
				       (t (list last-expr)))) )
		    (mapc #'(lambda (expr)
			      (let ( (paths (mapcar #'source-path (sources expr))) )
				(cond (paths (km-format t "~%Expression ~a originated from:~%~{   ~a~%~}" (desource-for-printing expr) paths))
				      (t (km-format t "~%(I don't know where expression ~a originated from)~%" expr)))))
			  exprs))
		  (terpri)
		  (km-trace2 mode string args :stream stream))
		 ((string= debug-option "z") (setq *interactive-trace* nil))

		 ((string= debug-option "+A") 
		  (format t "(Will now trace absolutely everything)~%")
		  (setq *trace-other-situations* t)
		  (setq *trace-subsumes* t)
		  (setq *trace-unify* t)
		  (setq *trace-constraints* t)
		  (setq *trace-classify* t)
		  (km-trace2 mode string args :stream stream))
		 ((string= debug-option "+S") 
		  (format t "(Will now show more detailed trace in other situations)~%")
		  (setq *trace-other-situations*   t) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "-S") 
		  (format t "(Will no longer show a detailed trace in other situations)~%")
		  (setq *trace-other-situations* nil) (km-trace2 mode string args :stream stream))

		 ; This is for my own debugging, and not advertised to the user
		 ((string= debug-option "+M") 
		  (format t "(Will now show more detailed trace for some subsumption tests)~%")
		  (setq *trace-subsumes*   t) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "-M") 
		  (format t "(Will no longer show more detailed trace for some subsumption tests)~%")
		  (setq *trace-subsumes* nil) (km-trace2 mode string args :stream stream))

		 ((string= debug-option "+U") 
		  (format t "(Will now show a more detailed trace during unification)~%")
		  (setq *trace-unify*   t) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "-U") 
		  (format t "(Will no longer show a detailed trace during unification)~%")
		  (setq *trace-unify* nil) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "+C") 
		  (format t "(Will now show a more detailed trace during constraint checking)~%")
		  (setq *trace-constraints* t) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "-C") 
		  (format t "(Will no longer show a detailed trace during constraint checking)~%")
		  (setq *trace-constraints* nil) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "+X") 
		  (format t "(Will now show more detailed trace during classification)~%")
		  (setq *trace-classify*   t) (km-trace2 mode string args :stream stream))
		 ((string= debug-option "-X") 
		  (format t "(Will no longer show a detailed trace during classification)~%")
		  (setq *trace-classify* nil) (km-trace2 mode string args :stream stream))

		 ((starts-with debug-option "d ")
		  (format t "----------------------------------------~%~%")
		  (showme-frame (intern (trim-from-start debug-option 2) *km-package*))
		  (format t "----------------------------------------~%")
		  (km-trace2 mode string args :stream stream))
		 ((and (string/= debug-option "")
		       (string/= debug-option "c")) 
		  (print-trace-options) 
		  (km-trace2 mode string args :stream stream)))))
	(t (format stream "~%"))))

(defun print-trace-message (mode string args &key (stream t))
  (format stream "~a" *depth*)
  (format stream (spaces (- (1+ *depth*) (length (princ-to-string *depth*)))))
  (cond ((eq mode 'comment) (format stream " ")))		   ; extra space tabulation for comments
  (case mode
	((call redo comment) (apply #'km-format `(,stream ,string . ,(desource-for-printing args))))   ; ie. (km-format t string arg1 ... argn)
	((exit fail) 
	 (format stream (truncate-string (apply #'km-format `(nil ,string . ,(desource-for-printing args))) 80)))	; TRUNCATE these particular strings, and add ""
	(t (report-error 'program-error "km-trace2: Unknown trace mode ~a!~%" mode))))

(defun increment-trace-depth () 
  (cond ((>= *depth* *statistics-max-depth*) (setq *statistics-max-depth* (1+ *depth*))))
  (setq *depth* (1+ *depth*)))
(defun decrement-trace-depth () (setq *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 #'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
|#

(defun print-trace-options ()
  (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*
(defun suspend-trace (&optional (depth *depth*))
  (setq *suspended-trace* depth)
  (setq *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!
(defun unsuspend-trace ()
  (cond (*suspended-trace* 
	 (setq *suspended-trace* nil)
	 (setq *trace* t))))

;;; ======================================================================
;;;		COMMENTS
;;; ======================================================================

(defun make-comment (string &rest args)
  (cond (*show-comments* (apply #'km-format `(t ,(concat "(COMMENT: " string ")~%") ,@(desource-for-printing args))))))

(defun comments () 
  (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)

(defun nocomments () 
  (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
;;; ======================================================================
#|
OLD Behaviors on error - KM 2.1 
  *error-report-silent*     - t: ignore the error and continue. Overrides abort-on-error-report
  *abort-on-error-report*   - t: report error and abort (NEW: now throwing the error message back too)
 			    - NIL: report error and switch on debugger at next opportunity

REVISED: 4/30/08 - KM 2.2 and later
*on-error*
	abort    	(report error and do not continue, instead immediately return NIL)
	abort-silently  (don't report error and do not continue, instead immediately return NIL)
	debug    	(report error and turn on KM debugger)
	break    	(report error and break to Lisp)
	continue 	(report error and continue)
	ignore   	(don't report error and do continue)

example:
(let ((*abort-on-error-report* t)           ; default is nil
      (*silently-abort-on-error-report* t)
      (*error-report-silent* nil))          ; default is nil
  (km `#$(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
;(defvar *error-report-silent* nil)		 ; **** another NEW LINE
;(defvar *abort-on-error-report* nil)
;(defvar *silently-abort-on-error-report* t)	 ; [3] - new default is t

(defvar *on-error* 'debug)		; default mode
(defun on-error () *on-error*)


;;; FLE 02Aug2005: the call to km-format is conditioned to the value of
;;; *silently-abort-on-error-report*
;;; RETURNS: NIL
(defun report-error (error-type string0 &rest args0)
  ;;; We've changed report-error to allow an optional FIRST argument, giving the error DATA as a structure
  ;;; If that happens, then identification of the other arguments have to be shifted 1 right:
  (let ((error-data (cond ((stringp string0)	; if the structure isn't supplied, then use the top of the goal stack
			   (stacked-expr (first (goal-stack))))
			  (t string0)))
	(string (cond ((stringp string0) string0)
		      (t (first args0))))
	(args (cond ((stringp string0) args0)
		    (t (rest args0)))))
;  (unless *error-report-silent*
;  (unless (member (on-error) '(continue-silently ignore))
     (let* ((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))))
	    (continuation (cond ((eq (on-error) 'continue) "[Will continue though] ")
				(t "")))
	    (error-str (concat error-str-prefix continuation 
			       (apply #'km-format `(nil ,string ,@(desource-for-printing args))))))
; 1. Print error message
       (cond ((not (member (on-error) '(continue-silently ignore abort-silently))) (format t error-str)))
; 2. Store error data
       (cond ((eq error-type 'user-warning) (push (trim-whitespace error-str) *warnings*))
	     (t (push (trim-whitespace error-str) *errors*)
		(push error-data *error-structures*)))
; 3. Further actions 
;       (km-format t "(on-error) = ~a~%" (on-error))
       (cond ((member error-type '(user-warning nodebugger-error)) nil) ; no action
	     ((member (on-error) '(ignore continue-silently)) nil) ; no action
	     ((or			; *abort-on-error-report* 
		 (member (on-error) '(abort abort-silently))
		 (eq error-type 'abort-error))
             ;; FLE 02Aug2005: when using (km `#$(...)) this message is generally
             ;; useless
;             (unless (eq (on-error) 'abort-silently) ; *silently-abort-on-error-report*
;               (km-format t "Throwing error...~a~%" error-str))
	      (throw 'km-abort (list 'km-abort error-str error-data))) ; now redundant throwing error-str, error-data back
							        ; Instead it's returned by *errors* and *error-structures*
	     ((eq (on-error) 'continue) nil)
	     ((and (member (on-error) '(debug break))
		   (member error-type '(user-error program-error)))
	      (cond ((and (not *trace*)
			  (not *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
	-------------------------

")))
	     (setq *trace* t) 
	     (setq *interactive-trace* t) 
	     (setq *suspended-trace* nil)
	     (cond ((or (eq (on-error) 'break) *developer-mode*) (break)))
	     nil)
	     ((not (member *on-error* '(abort abort-silently debug continue continue-silently ignore break)))
	      (km-format t "ERROR! *on-error* = ~a, but must be one of:
	debug    	  (report error and turn on debugger)
	abort    	  (report error and do not continue, instead immediately return NIL)
	abort-silently    (don't report error and do not continue, instead immediately return NIL)
	continue 	  (report error and continue)
	continue-silently (don't report error and continue)
	ignore		         [synonym for continue-silently]
	break    	  (report error and break to Lisp)
Aborting (as I don't know what error reporting mode to use for reporting an error with the error reporting mode!)~%"
		      *on-error*)
	      (abort))
            ;; FLE 03Aug2005, add this:
            (t (warn "Unknown KM error type: ~s" error-type)
               nil)))))

;;; ======================================================================
;;;		CATCHING THE TRACING INFORMATION
;;; ======================================================================

(defun catch-explanations ()
  (km-format t "(KM will catch the explanations for the next KM call)~%")
  (setq *explanations* nil)
  (setq *catch-next-explanations* t))

;;; [1] ((call [0]) (call [1]) (call [2]) (exit [2]) (fail [1]))
;;; ->  ((call [0])
(defun catch-explanation (kmexpr-with-comments mode)
  (cond 
   ((not (and (listp kmexpr-with-comments) 
	      (member (first kmexpr-with-comments) *no-decomment-headwords*)))
    (let* ( (comment-tags (get-comment-tags kmexpr-with-comments)) 
	    (explanations (mapcar #'(lambda (comment-tag) (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)
		       (km-format t "~vT~a: ~a~%" *depth* (string-upcase mode) explanation))
		   explanations)))))))

(defun trim-failed-explanations (explanations depth comment-tags)
  (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 (= (first (first explanations)) depth)
	      (eq (second (first explanations)) 'call)
	      (equal (third (first explanations)) comment-tags))
	 (rest explanations))
	(t (trim-failed-explanations (rest explanations) depth comment-tags))))

; [1] 'html-format rather than 'html because 'html symbol clashes with new.html.generator :-(
(defun show-explanations-xml (&key (stream t)) (show-explanations :format 'xml :stream stream))
(defun show-explanations-html (&key (stream t)) (show-explanations :format 'html-format :stream stream)) ; [1]

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

(defvar *indent-level* 0)

(defun show-explanations (&key (explanations *explanations*) (format 'ascii) (stream t))
  (setq *indent-level* 0)
  (cond ((eq format 'xml) (format stream "<explanation-structure>~%")))
  (mapc #'(lambda (explanation-str)
	    (let ( (depth (first explanation-str))
		   (mode (second explanation-str))
		   (comment-tags (third explanation-str))
		   (explanations (fourth explanation-str)) )
	      (mapc #'(lambda (explanation) (show-explanation explanation depth mode comment-tags
							      :format format :stream stream)) explanations)))
	(reverse explanations))
  (cond ((eq format 'xml) (format stream "</explanation-structure>~%")))
  t)

(defun show-explanation (explanation depth mode comment-tags &key format (stream t))
  (declare (ignore comment-tags))
  (let ( (sentence (make-phrase (km explanation))) 
	 (nl (cond (stream *newline-str*) (t ""))) )
    (case format
;	  (ascii (km-format stream (concat "~vT~a: ~a" nl) depth (string-upcase mode) sentence))
	  (ascii (prog2
		     (cond ((eq mode 'call) (setq *indent-level* (1+ *indent-level*))))
		     (format stream (concat (spaces (* 2 *indent-level*)) "* " sentence "~%"))
		   (cond ((eq mode 'exit) (setq *indent-level* (max 0 (1- *indent-level*)))))))
	  (xml (format stream (concat "<explanation depth=~a mode=~a>~a</explanation>" nl)
		       depth (string-downcase mode) sentence))
	  (html-format (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)))))

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

(defun grab-explanations-xml () (grab-explanations :format 'xml))
(defun grab-explanations-html () (grab-explanations :format 'html-format))

(defun grab-explanations (&key (explanations *explanations*) (format 'ascii))
  (setq *indent-level* 0)
  (append
   (cond ((eq format 'xml) (list (format nil "<explanation-structure>"))))
   (mapcan #'(lambda (explanation-str)
	      (let ( (depth (first explanation-str))
		     (mode (second explanation-str))
		     (comment-tags (third explanation-str))
		     (explanations (fourth explanation-str)) )
		(mapcar #'(lambda (explanation) 
			    (show-explanation explanation depth mode comment-tags
					      :format format :stream nil))
			explanations)))
	   (reverse explanations))
   (cond ((eq format 'xml) (list (format nil "</explanation-structure>"))))))

;;; ----------------------------------------
;;;	SPY POINTS - for Jason Chaw
;;; ----------------------------------------

;;; [1] minimatch expects &REST, but user will type &rest at KM prompt.
(defun silent-spy (&optional expr0)
  (let ( (expr (subst '&rest '#$&rest expr0)) )			; [1]
    (cond ((and expr
		(not (member expr *silent-spypoints* :test #'equal)))
	   (setq *silent-spypoints* (cons expr *silent-spypoints*))))
    (cond (*silent-spypoints* (km-format t "KM will log subgoals when evaluating these expressions/patterns:~%~{      ~a~%~}" 
				  (subst '#$&rest '&rest *silent-spypoints*)))
	  (t (km-format t "(You have no silent spypoints declared)~%")))
    '#$(t)))

(defun silent-unspy ()
  (setq *silent-spypoints* nil)
  (km-format t "(All silent spypoints removed)~%")
  '#$(t))

(defun inspect-silent-spy-log()
  *silent-spypoints-log*)

(defun clear-silent-spy-log()
  (setq *silent-spypoints-log* nil))

;;; 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.

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

; Note: &+! isn't a primitive unification operator, it's decomposed in interpreter.lisp into &+? plus &!
; Also: &+ is a strange operator as (unlike &) it's by default allowed to fail.
(defun equality-assertion-operator (x) (member x '(& &+ &+! &! ==)))
(defun val-unification-operator (x)    (member x '(& &+ &+! &! == &+? &?)))
(defun set-unification-operator (x)    (member x '(&& &&! ===)))
(defun unification-operator (x)        (member x '(& &? &! && &&! &+ &+! &+? == ===)))
; OLD
; (defun unification-operator (x)        (member x '(& &? &! && &&! &+ &+? == ===)))

;;; Experimental modifications for HALO project
(defvar *less-aggressive-constraint-checking* nil)
(defvar *overriding-in-prototypes* t)	; experimental new bit of code
(defvar *trace-merge-prototype-vals* nil)	; for debugging

#|
MAIN ENTRY POINTS
=================
1. TESTING UNIFIABILITY:
try-lazy-unify: Use for &?

2. DOING UNIFICATION:
lazy-unify-&-expr:
	-> lazy-unify-exprs, the main procedure for & and &+
	-> lazy-unify-expr-sets, the main procedure for &&
  Note, lazy-unify-&-expr *MUST* succeed, otherwise it's an error, except for &+ which is allowed
	to quietly return NIL (bit horrible but ok)

NOTE: & and &! *must* succeed, and will generate an error if it fails.   
HOWEVER: &+ and &+! are *allowed* to fail. If they does so, it has no side-effects.
	 [ To avoid side-effects for &+!, the handler in interpreter.lisp does &+? then &! ]

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.
	  HOWEVER: If lazy-unify fails and :eagerlyp = t, then there may be bad sub-unifications left :-(
|#
(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
(defun lazy-unify (instancename1 instancename2 &key classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
 (let* ((instance1 (dereference instancename1))		; Might be redundant to deref, but just in case!
	(instance2 (dereference instancename2)) 
	(unification (lazy-unify0 instance1 instance2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp
				  :fail-mode fail-mode)) )
    (cond ((and unification 
;		*see-unifications*
		(not (equal instance1 instance2))
		(not (null instance1))
		(not (null instance2)))
;	   (tracekm)
	   (make-comment "(~a ~a ~a) unified to be ~a" instancename1 
			 (cond ((and eagerlyp classes-subsumep) '&+!)
			       (eagerlyp '&!) (classes-subsumep '&+) (t '&))			       
		       instancename2 unification)
;	   (break)))
	   ))
    (cond ((and (kb-objectp instancename1) (not (known-frame instancename1))) (km-add-to-kb-object-list instancename1)))  ; [1]
    (cond ((and (kb-objectp instancename2) (not (known-frame instancename2))) (km-add-to-kb-object-list instancename2)))
    (cond ((and (null unification)
		(eq fail-mode 'error))
	   (report-error 'user-error "Unification (~a ~a ~a) failed!~%" instance1 
			 (cond ((and eagerlyp classes-subsumep) '&+!)
			       (eagerlyp '&!) (classes-subsumep '&+) (t '&)) instance2)))
    unification))

;;; [1] NOTE failure to unify an element means the whole unification should fail
(defun lazy-unify0 (instancename1 instancename2 &key classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
; (let ( (instance1 (dereference instancename1))		; Might be redundant to deref, but just in case!
;	(instance2 (dereference instancename2)) )		; DONE EARLIER NOW
  (let ( (instance1 instancename1)
	 (instance2 instancename2) )
  (cond 
   ((equal instance1 instance2) instance1)	; already unified
   ((null instance1) instance2)
   ((null instance2) instance1)
   (t (lazy-unify2 instance1 instance2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp
		   :fail-mode fail-mode)))))

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

#|
[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.
|#
(defun lazy-unify2 (instance1 instance2 &key classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
  (multiple-value-bind
      (unified-name sitn+svs-pairs binding-list) ; binding-list is just a singleton e.g., ((i1 . i2)), from unify-names
      (try-lazy-unify2 instance1 instance2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp 
		       :fail-mode fail-mode) ; (1) TRY IT...
  (let ( (change-made nil) )
   (cond (unified-name										; (2) DO IT!
	  (mapc #'(lambda (binding)				; 1.4.00 Try this here (rather than later, see below)
		    (km-bind (first binding) (second binding))) binding-list)
	  (cond ((kb-objectp unified-name)   ; don't do stuff for numbers & strings!
		 (let ( (curr-situation (curr-situation)) )
		   (mapc #'(lambda (sitn+svs)
			     (change-to-situation (first sitn+svs))
			     (cond ((or change-made
					(equal (second sitn+svs) (get-slotsvals unified-name))
					(and (prev-situation (curr-situation) unified-name)
					     (null (get-slotsvals unified-name))
					     (subsetp (second sitn+svs) 
						      (get-slotsvals unified-name :situation (prev-situation (curr-situation) unified-name))
						      :test #'equal))))
				   (t (setq change-made t)))
			     (put-slotsvals unified-name (second sitn+svs)))     	; [3]
			 sitn+svs-pairs)
		   (change-to-situation curr-situation))))
	  (cond ((isa unified-name '#$Situation)
		 (setq change-made t)
		 (cond ((and (isa instance1 '#$Situation) (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)			; NEW 9/10/02
		 (un-done unified-name)   ; all vals to be recomputed now - now in put-slotsvals; Later: no!
		 (cond ((x-or (fluent-instancep instance1) (fluent-instancep instance2))		; [4] A very unusual case
;			(km-format t "Dealing with very unusual special case of un-done")
			(let ( (fluent-instance (cond ((fluent-instancep instance1) instance1) (t instance2))) )
;			  (km-format t "Scanning situations....")
			  (mapc #'(lambda (situation)
				    (mapc #'(lambda (slotvals)
					      (let ( (invslot (invert-slot (slot-in slotvals))) )
						(mapc #'(lambda (val)
							  (cond ((kb-objectp val) (un-done val :slot invslot :situation situation)
;								 (format t ".")
								 )))
						      (vals-in slotvals))))
					  (get-slotsvals fluent-instance :situation situation)))
				(all-situations-and-theories))
;			  (km-format t "..done!~%")
;			  (terpri)
			  )))
		 (classify unified-name)  ; reclassify
		 ))
	  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.

NOTE: It is not allowed to call try-lazy-unify with :eagerlyp t, as this would leave side-effects
after the unification test. I've disabled this keyword even as an option.
|#
(defun try-lazy-unify (instancename1 instancename2 &key classes-subsumep #|eagerlyp|# (check-constraintsp t))
 (let ((instance1 (dereference instancename1))		; Might be redundant to deref, but just in case!
       (instance2 (dereference instancename2)))
  (cond 
   ((km-equal instance1 instance2) instance1)	; already unified
   ((null instance1) instance2)
   ((null instance2) instance1)
   ((and (km-triplep instance1) (km-triplep instance2)) 		; See [*] below
;    (km-format t "ERROR! Attempt to unify triples ~a and ~a!~%" instance1 instance2)
    nil)		; no, fail quietly. KM might try this, and the result should just be an append [Why?]
;  ((and (km-triplep instance1) (km-triplep instance2))
;    (and (try-lazy-unify2 (second instance1) (second instance2) :classes-subsumep classes-subsumep :eagerlyp eagerlyp)
;	 (try-lazy-unify2 (third instance1) (third instance2) :classes-subsumep classes-subsumep :eagerlyp eagerlyp)
;	 (cond ((or (constraint-exprp (fourth instance1)) (constraint-exprp (fourth instance2)))
;		(equal (fourth instance1) (fourth instance2)))
;	       (t (try-lazy-unify (fourth instance1) (fourth instance2) :classes-subsumep classes-subsumep :eagerlyp eagerlyp)))))
   ((km-setp instance1))				; structured-lists call try-lazy-unify recursively. Here account for (:seq 1 (:set 2 3))
   ((km-setp instance2))				; type structures
   ((or (km-structured-list-valp instance1)
	(km-structured-list-valp instance2))
    (let ((d-instance1 (desource instance1))		; (:seq 1 2 (@ Car)) -> (:seq 1 2)
	  (d-instance2 (desource instance2)) )
      (cond ((or (not (km-structured-list-valp d-instance1))	; revised, so (_Car1 &? (:pair 1 2)) quietly fails
		 (not (km-structured-list-valp d-instance2)))
	     (unify-names d-instance1 d-instance2 :classes-subsumep classes-subsumep #|:eagerlyp eagerlyp|#))

;            ((not (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 ; x & (:args x y)
;			   :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp))
;	    ((not (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) ; (:args x y) & x
;			     :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp))

	    ((and (eq (first d-instance1) (first d-instance2))
		  (neq (first d-instance1) '#$:triple))			;; Why did I exclude :triples??? Similarly above at [*]
	   (every #'(lambda (pair)
		      (try-lazy-unify (first pair) (second pair) 
				      :classes-subsumep classes-subsumep #|:eagerlyp eagerlyp|# :check-constraintsp check-constraintsp))
		  (rest (transpose (list d-instance1 d-instance2))))))))	; ((:seq :seq) (i1 e1) (i2 e2) ... )
   (t (try-lazy-unify2 instance1 instance2 :classes-subsumep classes-subsumep #|:eagerlyp eagerlyp|# :check-constraintsp check-constraintsp :fail-mode 'fail)))))

#|
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. 
|#
(defun try-lazy-unify2 (instance1 instance2 &key classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
  (cond ((and (eq fail-mode 'fail) eagerlyp) (report-error 'program-error "try-lazy-unify2: :fail-mode 'fail and :eagerlyp t can't both be set at the same time!")))
  (multiple-value-bind
      (unified-name bindings)
      (unify-names instance1 instance2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp)
    (cond (unified-name
;	   (km-format t "computing sitn-svs-pairs...")
	   (let ( (sitn-svs-pairs (unified-svs instance1 instance2 
					       :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp :fail-mode fail-mode)) )
;	     (km-format t "..done!~%")
	     (cond ((neq sitn-svs-pairs 'fail) 
		    (setq *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
(defun unified-svs (i1 i2 &key (situations (all-situations-and-theories)) classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
  (cond ((endp situations) nil)
	(t (let ( (sitn-svs-pair (unified-svs-in-situation i1 i2 (first situations) 
							   :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp :fail-mode fail-mode)) )
	     (cond ((eq sitn-svs-pair 'fail) 'fail)
		   (t (let ( (sitn-svs-pairs (unified-svs i1 i2 :situations (rest situations) 
							  :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp :fail-mode fail-mode)) )
			(cond ((eq sitn-svs-pairs 'fail) 'fail)
			      (sitn-svs-pair (cons sitn-svs-pair sitn-svs-pairs))	; NEW: May be nil
			      (t 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).
(defun unified-svs-in-situation (i1 i2 situation &key classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
  (let ( (curr-situation (curr-situation)) 
	 (slotsvals1 (get-slotsvals i1 :situation situation))    ; (don't need bind-self as frames are instances
	 (slotsvals2 (get-slotsvals i2 :situation situation))    ; (don't need bind-self as frames are instances
	 )
;   (km-format t "CALLING (unified-svs-in-situation ~a ~a ~a slotsvals1=~a, slotsvals2=~a)~%"
;	       i1 i2 situation slotsvals1 slotsvals2)

    (cond ((and (x-or slotsvals1 slotsvals2)
		(eq situation *global-situation*))		; only in *GLOBAL* situation can we skip. In local, maybe global X + local Y values which conflict
	   (list situation (or slotsvals1 slotsvals2)))		; See GLOBAL+LOCAL in test-suite/unification.km
	  ((or slotsvals1 slotsvals2)								; [3]
	   (cond ((neq situation curr-situation) (change-to-situation situation)))			; [1], [2]
	   (multiple-value-bind
	    (successp unified-svs)
	    (lazy-unify-slotsvals i1 i2 
				  slotsvals1 slotsvals2 
				  :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp :fail-mode fail-mode)
	    (cond ((neq situation curr-situation) (change-to-situation curr-situation)))		; [1]
	    (cond (successp (list situation unified-svs))
		  (t 'fail)))))))

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

;;; 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
(defun unify-names (instance1 instance2 &key classes-subsumep eagerlyp)
 (let ((fail-mode (cond (eagerlyp 'error) (t 'fail))))
  (cond 
   ((eq  instance1 instance2) (values instance1 nil)) 			; (*car2 & *car2)
   ((incompatible-instances instance1 instance2)
    (cond ((eq fail-mode 'error)
	   (report-error 'user-error "Unification (~a ~a ~a) failed!~%       Problem was: ~a~%" instance1 
			 (cond ((and eagerlyp classes-subsumep) '&+!)
			       (eagerlyp '&!) (classes-subsumep '&+) (t '&)) instance2
			       (incompatible-instances instance1 instance2))))	; returns description of problem
    nil)
   ((and (not (kb-objectp instance1))					; ("a" & _string23) [1]
	 (anonymous-instancep instance2))
    (cond ((immediate-classes-subsume-immediate-classes instance2 instance1)
	   (values instance1 (list (list instance2 instance1))))))
   ((and (not (kb-objectp instance2))					; (_string23 & "a") [1]
	 (anonymous-instancep instance1))
    (cond ((immediate-classes-subsume-immediate-classes instance1 instance2)
	   (values instance2 (list (list instance1 instance2))))))
					    ;;; else, if it's not of the above special 
					    ;;; cases, check they are unifiable (based on classes)
; Now in incompatible instances check below
;	((and (named-instancep instance1) (named-instancep instance2)) nil)	; (*f & *g), ("a" & "b") FAILS
   ((compatible-classes :instance1 instance1 :instance2 instance2 :classes-subsumep classes-subsumep) ; two KB objects, >= 1 anonymous
										; then create binding list as needed.
    (cond 									; (X & Y): special cases where Y takes precidence:
     ((or (named-instancep instance2)					; (_person12 & *fred)	return *fred
	  (and (fluent-instancep instance1) 					; (_someCar12 & _Car2)  return _Car2
	       (anonymous-instancep instance2))
	  (and (not (named-instancep instance1))				; EXCLUDE  *Fred & _Person3 -> _Person3
	       (immediate-classes-subsume-immediate-classes instance1 instance2 :properp t)))		; 4/17/01: daring!!!!!
      (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
;;; [1] tests equality but only works if there are no redundant classes in the class lists.
;;; [2] is a little bit less efficient but WILL handle redundant classes in the class lists.
(defun immediate-classes-subsume-immediate-classes (instance1 instance2 &key properp)
  (let ( (immediate-classes1 (immediate-classes instance1)) 
	 (immediate-classes2 (immediate-classes instance2)) )
    (and (classes-subsume-classes immediate-classes1 immediate-classes2)
	 (or (not properp)
	     (cond ((remove-subsumers-slotp '#$instance-of)
		    (not (set-equal immediate-classes1 immediate-classes2)))			; [1]
		   (t (not (classes-subsume-classes immediate-classes2 immediate-classes1))))))))  ; [2]

#|
Check /== constraints. Note does *NOT* check Partitions, use compatible-classes for that.
RETURNS: A string describing the problem
 [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 (km-int `#$(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!
|#
(defun incompatible-instances (instance1 instance2)
  (cond ; ((not (atomp instance1))
	;  (report-error 'program-error "non-atom ~a passed to incompatible-instances!~%" instance1))
        ((equal instance1 instance2) nil)
        ((and (named-instancep instance1) 
	      (named-instancep instance2)	; (*f & *g) FAILS
	      (neq instance1 instance2)))
	((classp instance1) 
	 (cond ((not (isa instance2 '#$Class)) (km-format nil "~a is a class, but ~a isn't" instance1 instance2))))
	((classp instance2) 
	 (cond ((not (isa instance1 '#$Class)) (km-format nil "~a is a class, but ~a isn't" instance2 instance1))))
	(*are-some-constraints*
	 (let ( (instance1-neq (cond ((and (kb-objectp instance1)
#|quick lookahead|#			   (get-vals instance1 '/== :situation *global-situation*))	; why not (km-int ...)? [3]
				      (km-int `#$(the /== of ,INSTANCE1)))))
		(instance2-neq (cond ((and (kb-objectp instance2)
#|quick lookahead|#			   (get-vals instance2 '/== :situation *global-situation*))
				      (km-int `#$(the /== of ,INSTANCE2)))))
	       )
	   (cond
	    ((member instance2 instance1-neq :test #'equal)
	     (km-format nil "~a has a constraint /== ~a on it." instance1 instance2))
	    ((member instance1 instance2-neq :test #'equal)
	     (km-format nil "~a has a constraint /== ~a on it." instance2 instance1))	   
	    ((and (numberp instance1)
		  (kb-objectp instance2)
		  (some #'(lambda (n) (and (numberp n) (<= instance1 n)))  (km-int `#$(the > of ,INSTANCE2))))
	     (km-format nil "~a has a constraint > ~a on it." instance2 (km-int `#$(the > of ,INSTANCE2))))
	    ((and (numberp instance1)
		  (kb-objectp instance2)
		  (some #'(lambda (n) (and (numberp n) (>= instance1 n)))  (km-int `#$(the < of ,INSTANCE2))))
	     (km-format nil "~a has a constraint < ~a on it." instance2 (km-int `#$(the < of ,INSTANCE2))))
	    ((and (numberp instance2)
		  (kb-objectp instance1)
		  (some #'(lambda (n) (and (numberp n) (<= instance2 n)))  (km-int `#$(the > of ,INSTANCE1))))
	     (km-format nil "~a has a constraint > ~a on it." instance1 (km-int `#$(the > of ,INSTANCE1))))
	    ((and (numberp instance2)
		  (kb-objectp instance1)		  
		  (some #'(lambda (n) (and (numberp n) (>= instance2 n)))  (km-int `#$(the < of ,INSTANCE1))))
	     (km-format nil "~a has a constraint < ~a on it." instance1 (km-int `#$(the < of ,INSTANCE1))))	     
	    ((let ((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 ((and (or instance1-eq instance2-eq)
			   (not (check-slotvals-constraints '== instance1 instance2 instance1-eq instance2-eq))) ; [2]
		      (km-format nil "Some equality constraint violation (~a == ~a, ~a == ~a)"
				 instance1 instance1-eq instance2 instance2-eq)))))
	    )))))

#| old version
           (or (member instance2 instance1-neq :test #'equal)		; [1]
	       (member instance1 instance2-neq :test #'equal)
	       (and (numberp instance1)
		    (kb-objectp instance2)
		    (or (some #'(lambda (n) (and (numberp n) (<= instance1 n)))  (km-int `#$(the > of ,INSTANCE2)))
			(some #'(lambda (n) (and (numberp n) (>= instance1 n)))  (km-int `#$(the < of ,INSTANCE2)))))
	       (and (numberp instance2)
		    (kb-objectp instance1)
		    (or (some #'(lambda (n) (and (numberp n) (<= instance2 n)))  (km-int `#$(the > of ,INSTANCE1)))
			(some #'(lambda (n) (and (numberp n) (>= instance2 n)))  (km-int `#$(the < of ,INSTANCE1)))))
	       (let ( (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)
			(not (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)

If :fail-mode is 'fail, then the calling procedure is *TESTING* unification, not actually *DOING* it. 

eagerlyp   fail-mode
  nil        fail 	    test, no side effects. When used for &+, unification will follow if successful.
[  t         fail  ]        not allowed (will leave side effects) 	
  nil        error 	    Used for &.  No side effects; forced unification will follow anyway in the calling procedure if *on-error* = 'continue
   t         error	    side effects; forced unification will follow anyway in the calling procedure if *on-error* = 'continue

If :eagerlyp = t, then there are side effects down in the details when unifying prototypes. So :error-mode better be 'error in tihs case.
|#
(defun lazy-unify-slotsvals (i1 i2 svs1 svs2 &key cs1 cs2 classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
  (cond
   ((and (endp svs1)
	 (endp svs2)))	; ie. return (values t nil)
   (t (let* ( (test-p (eq fail-mode 'fail))     ; if :fail-mode 'fail, then it's just a test so it's ok to not complete it
	      (sv1  (first svs1))
	      (slot (or (slot-in sv1) 		; work through svs1 first. When done, 
			(slot-in (first svs2))))	; work through remaining svs2.
	      (exprs1 (vals-in sv1))
	      (sv2 (assoc slot svs2))
	      (exprs2 (vals-in sv2))
	      (rest-svs2 (remove-if #'(lambda (a-sv2)
					(eq slot (slot-in a-sv2)))
				    svs2)) )
	(cond ((and (null exprs1) (null exprs2)) ; vals both null, so drop the slot
	       (lazy-unify-slotsvals i1 i2 (rest svs1) rest-svs2 :cs1 cs1 :cs2 cs2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp
				     :check-constraintsp check-constraintsp :fail-mode fail-mode))
	      ((or (not check-constraintsp)
		   
;;; SPECIAL CASE FOR UNIFYING PROTOTYPES: 
;;; If unifying prototypes (signified by eagerlyp) AND inherit-with-overrides AND no anonymous instances
;;; THEN existing value (= from more specific prototype clone) takes precedence		   
;;; See test-suite/prototypes4.km and RELEASE-NOTES for KM 2.1.10.
;;; The goal of the below is to SKIP the constraint check, and have lazy-unify-vals handle any conflicting values
;;; there instead.
;;; [10] with looping, eagerly unifying prototypes may still leave a residual & structure in the result, even though
;;;      KM is evaluating eagerly.		   
;;; [11] We *could* add this as an extra constraint in, but seems like we don't need it.		   
		   (and ; eagerlyp [10]
			*overriding-in-prototypes*
			(inherit-with-overrides-slotp slot)
;			(not (format t "exprs1 = ~a, exprs2 = ~a~%" exprs1 exprs2))
			(notany #'kb-objectp exprs1)
			(notany #'kb-objectp exprs2)		   
;			(every #'fully-evaluatedp vs1) ; [11] DON'T drop expr2 for eg. (_Val22 & (if <..> then ...)) 
;			(every #'fully-evaluatedp vs2)	      		   
			)
		   (check-slotvals-constraints slot i1 i2 exprs1 exprs2 :cs1 cs1 :cs2 cs2 
					       :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode)
		   (not test-p)		; if constraints violated, but it's a forced unification, then keep going regardless
		   )
	       (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			;; else fail (return NIL)
			(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
					       :fail-mode fail-mode)
			 (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)
     [13] 7/24/08 - No, skipping a full call to KM fails with prototypes. For HLO-2225, we end up with

9          (_HI-Substance2474 &? _Bronsted-Lowry-Acid2578): Checking constraints on the electrolyte-status slot...     
10         -> (the electrolyte-status of _HI-Substance2474)
10         <- FAIL!                      "(the electrolyte-status of _HI-Substance2474)"
10         -> (the electrolyte-status of _Bronsted-Lowry-Acid2578)
10         <- (_Electrolyte-Status-Value2568) "(the electrolyte-status of _Bronsted-Lowry-A...

In a different variant of this, &? should fail because HI-Substance has a different (incompatible) electrolyte-status
to the BL-Acid, acquired through prototype unification. But without the full call to KM, we don't trigger the
prototype unification, so HI-Substance has no electrolyte-status, then unifies with BL-Acid acquiring the wrong
status.
|#
;(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))))

(defun check-slotvals-constraints (slot i1 i2 exprs1 exprs2 &key cs1 cs2 classes-subsumep eagerlyp (fail-mode 'fail))
  (cond ((eq (dereference i1) (dereference i2)) 	; note, a subcall might unify these, including making some
	 t)						; note-dones, which will mess up if we continue
	(t (check-slotvals-constraints0 slot i1 i2 exprs1 exprs2 :cs1 cs1 :cs2 cs2 
					:classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode))))

;;; NOTE: :eagerlyp argument used solely for formatting error messages (write &+!/&! rather than &+/&)
(defun check-slotvals-constraints0 (slot i1 i2 exprs1 exprs2 &key cs1 cs2 classes-subsumep eagerlyp (fail-mode 'fail))
;  (declare (ignore classes-subsumep eagerlyp))
  (cond ((and eagerlyp (eq fail-mode 'fail))
	 (report-error 'program-error "Calling check-slotvals-constraints0 with :eagerlyp t and :fail-mode 'fail (not allowed!)~%")))
;(let ((fail-mode (cond (eagerlyp 'error) (t 'fail))))
 (or 
  (eq slot '/==)			; don't check constraints on /== slot, it's done earlier in unify-names
; (eq slot '#$instance-of)
  (ignore-slot-due-to-situations-mode slot)
  (and i1 (null i2) (null exprs2) (every #'(lambda (c2) (isa i1 c2)) cs2))	; [11]
  (and i2 (null i1) (null exprs1) (every #'(lambda (c1) (isa i2 c1)) cs1))	; [11]
  (let* 
    ((no-inheritance-flagp (or (and i1 (member '#$(no-inheritance) (find-constraints-in-exprs exprs1) :test #'equal))
			       (and i2 (member '#$(no-inheritance) (find-constraints-in-exprs exprs2) :test #'equal))))
     (use-inheritance (and (use-inheritance) 
			   (not no-inheritance-flagp) 
			   (not (inherit-with-overrides-slotp slot)))) ; [12]
     (cs1-expr-sets 
      (cond (cs1 (remove-if #'contains-self-keyword ; [6]
			    (cons exprs1 (cond (use-inheritance
						(inherited-rule-sets-on-classes cs1 slot :retain-commentsp t))))))
	    (t (cons exprs1 (append (supersituation-own-rule-sets i1 slot :retain-commentsp t)
				    (cond (use-inheritance
					   (inherited-rule-sets i1 slot :retain-commentsp t)))))))) ; NB deref already done
     (cs2-expr-sets 
      (cond (cs2 (remove-if #'contains-self-keyword
			    (cons exprs2 (cond (use-inheritance
						(inherited-rule-sets-on-classes cs2 slot :retain-commentsp t))))))
	    (t (cons exprs2 (append (supersituation-own-rule-sets i2 slot :retain-commentsp t)
				    (cond (use-inheritance
					   (inherited-rule-sets i2 slot :retain-commentsp t))))))))

;;; cs1-expr-sets-all is SOLELY for the purpose of finding constraints. These *are* inherited, even for
;;; inherits-with-overrides slots.     
     (cs1-expr-sets-all
      (cond (use-inheritance cs1-expr-sets)
	    (cs1 (remove-if #'contains-self-keyword ; [6]
			    (cons exprs1 (inherited-rule-sets-on-classes cs1 slot :retain-commentsp t
									 :ignore-inherit-with-overrides-restriction t))))
	    (t (cons exprs1 (append (supersituation-own-rule-sets i1 slot :retain-commentsp t)
				    (inherited-rule-sets i1 slot :retain-commentsp t
							 :ignore-inherit-with-overrides-restriction t))))))
     (cs2-expr-sets-all
      (cond (use-inheritance cs2-expr-sets)
	    (cs2 (remove-if #'contains-self-keyword
			    (cons exprs2 (inherited-rule-sets-on-classes cs2 slot :retain-commentsp t
	         							 :ignore-inherit-with-overrides-restriction t))))
	    (t (cons exprs2 (append (supersituation-own-rule-sets i2 slot :retain-commentsp t)
				    (inherited-rule-sets i2 slot :retain-commentsp t
     							 :ignore-inherit-with-overrides-restriction t))))))

#|
OLD    (constraints (remove-duplicates 
		    (append (cond (i1 (collect-constraints-on-instance i1 slot)) ; [3], [7]
				  (cs1 (mapcan #'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 #'find-constraints-in-exprs cs2-expr-sets))
				  (t (report-error 'program-error "Missing both instance2 and class2 in lazy-unify-slotsvals!~%"))))
		    :test #'equal)) )
|#
; 1/22/10 Note: desource, otherwise two functionally identical constraints will look different (sources now include the 
; destination instance, as well as the originating class)
#|NEW|# (constraints1 (desource (mapcan #'find-constraints-in-exprs cs1-expr-sets-all)))
	(constraints2 (desource (mapcan #'find-constraints-in-exprs cs2-expr-sets-all)))

;;; These are to TEST
        (constraints (cond ((and ; (am-in-local-situation) NOT ANY MORE! -> ; in global situation, lazy-unify-vals will catch this. For locals,
				 (single-valued-slotp slot))		; need to do a bit more work, see age (23) age (24) example 
			    (remove-duplicates (cons '#$(exactly 1 Thing) ; in test-suite/constraints.km for a case where we need this work.
						     (append constraints1 constraints2)) :test #'equal :from-end t))
			   (t (remove-duplicates (append constraints1 constraints2) :test #'equal :from-end t)))))

;    (km-format t "cs1-expr-sets = ~a~%" cs1-expr-sets)
;    (km-format t "cs2-expr-sets = ~a~%" cs2-expr-sets)
;    (km-format t "constraints1 = ~a~%constraints2 = ~a~%constraints = ~a~%" constraints1 constraints2 constraints)

;   (cond ((and (not constraints0)				; no constraints...
;		(or (multivalued-slotp slot)		
;		    (null exprs1)   ; [1] for single-valued, may be partition constraints 
;		    (null exprs2)  ;  to check if there are *both* exprs1 and exprs2. Here I'm
;				    ; not looking for & checking inferred values (incompleteness)
;		(not eagerlyp)))
; rewrite this a bit more simply:
    (cond ((and (not constraints)
;		(not eagerlyp)
		))
	  (t (cond ((am-in-local-situation-or-theory)		; RATHER VERBOSE SET OF CHOSING TRACING INFO!
		    (cond ((and i1 i2) (km-trace 'comment "(~a &? ~a): Checking constraints on the ~a slot in ~a..." i1 i2 slot (curr-situation))) ; [4]
			  (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))) ; [4]
			  (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)))	; [4]
			  (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))	; [4]
			    (i1 (km-trace 'comment "(~a &? (a ~a with (~a ~a) ...): Checking constraints on the ~a slot..." 
					  i1 (delistify cs2) slot exprs2 slot)) ; [4]
			    (i2 (km-trace 'comment "(~a &? (a ~a with (~a ~a) ...): Checking constraints on the ~a slot..." 
					  i2 (delistify cs1) slot exprs1 slot))	; [4]
			    (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)))))
;	     (km-format t "i1 = ~a, slot = ~a, cs1-expr-sets = ~a~%" i1 slot cs1-expr-sets)
;	     (km-format t "i2 = ~a, slot = ~a, cs2-expr-sets = ~a~%" i2 slot cs2-expr-sets)


;;; ---------- X-START ----------
;;: Was deleted, but now I think we put it back to avoid all the heartache of evaluating expressions on (a ...) expressions
;;; NOTE: [11] we do a (km-int ...) on the val-sets, but *NOT* a call to (km-int `(the ,SLOT of ,I1)), because we *don't* want
;;; to invoke projection. This caused a crippling bug (see end of test-suite/johns-location.km).


	     (let* ( (vs1 (cond ((member slot '(== < >)) (cond (i1 (list i1))))		; [9]
				(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))))
					  (cs1-expr-sets (km-int-with-trace `#$(the ,SLOT of ,I1) (val-sets-to-expr cs1-expr-sets))) ; [11]
					  (t (let ((*am-classifying* nil)) ; or else it'll be chaos?
					       (km-int `#$(the ,SLOT of ,I1) :target `#$(the ,SLOT of ,I1)))))) ; [13]
				(*less-aggressive-constraint-checking* (remove-if-not #'fully-evaluatedp exprs1))
				;;; No, this gives a very confusing trace:
				;;; (km-int-with-trace '#$(the holds of (a Bond with (holds ((a Adenine) (a Thymine))))) NIL) 
				;;;      2  -> (the holds of (a Bond with (holds ((exactly 2 Thing) (a Adenine) (a Thymine)))))
				;;;	 2  <- NIL
;				(t (km-int-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)) ; [5]
				(t (let ((exprs-to-evaluate (remove-if #'contains-some-existential-exprs cs1-expr-sets)))
				     (cond (exprs-to-evaluate (km-int-with-trace `#$(the ,SLOT of (a ,(VALS-TO-VAL CS1) with (,SLOT ,EXPRS-TO-EVALUATE)))
										 (val-sets-to-expr exprs-to-evaluate))))
				      ))))
		     (vs2 (cond ((member slot '(== < >)) (cond (i2 (list i2))))		; [9]
				(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))))
					  (cs2-expr-sets (km-int-with-trace `#$(the ,SLOT of ,I2) (val-sets-to-expr cs2-expr-sets))) ; [11]
					  (t (let ((*am-classifying* nil)) ; or else it'll be chaos?  
					       (km-int `#$(the ,SLOT of ,I2) :target `#$(the ,SLOT of ,I2)))))) ; [13]
				(*less-aggressive-constraint-checking* (remove-if-not #'fully-evaluatedp exprs2))
;				(t (km-int-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))
				(t (let ((exprs-to-evaluate (remove-if #'contains-some-existential-exprs cs2-expr-sets)))
				     (cond (exprs-to-evaluate (km-int-with-trace `#$(the ,SLOT of (a ,(VALS-TO-VAL CS2) with (,SLOT ,EXPRS-TO-EVALUATE)))
										 (val-sets-to-expr exprs-to-evaluate))))
				      ))))
;		     (_d (km-format t "vs1 = ~a, vs2 = ~a~%" vs1 vs2))
		     )

;;; ---------- X-END ----------


;;; ---------- Y-START ----------
;;; Simpler version - but computationally more expensive!
;
;	     (let* ( (vs1 (cond ((eq slot '==) (cond (i1 (list i1))))		; [9]
;				(t (cond (i1 (km-trace 'comment "Computing (the ~a of ~a), for constraint checking..." slot i1))
;					 (t (km-trace 'comment "Computing the ~a of the first expression, for constraint checking..." slot)))
;				   (km-int (val-sets-to-expr cs1-expr-sets)))))
;		     (vs2 (cond ((eq slot '==) (cond (i2 (list i2))))		; [9]
;				(t (cond (i2 (km-trace 'comment "Computing (the ~a of ~a), for constraint checking..." slot i2))
;					 (t (km-trace 'comment "Computing the ~a of the second expression, for constraint checking..." slot)))
;				   (km-int (val-sets-to-expr cs2-expr-sets)))))
;;		     (_d (km-format t "vs1 = ~a, vs2 = ~a~%" vs1 vs2))
;		     )
;;; ---------- Y-END ----------

;;; -- start -- 

;;;	       (cond ((and i1 vs1) (add-vals i1 slot vs1)))		; put the answers back
;;;	       (cond ((and i2 vs2) (add-vals i2 slot vs2)))
;;;
;;; Above, No! This is a disasterous typo'/conceputual error in the patch - 
;;; Originally, in some circumstances, I did (km-int `#$(the ,SLOT of ,I1)) to compute vs1. But this was
;;; overly agressive, invoking projection, inheritance etc. 
;;; To tame this down, I just evaluate the expressions on the slot. But I should put-vals, not add-vals
;;; back, and if I do that, I need to make sure I do all the book-keeping necessary (in particular
;;; deleting the old expressions, and folding constraints back in. Any other things I've forgotten??
;;; Let's try this instead:

;;; 5/28/02 - It's not clear why I need to do put-vals at all; it seems that anything I put-vals here gets
;;; clobbered anyway by the parent put-vals at the end of lazy-unify. So let's experimentally try removing this
;;; whole section of code (?).
#|
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 #'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 #'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
|#

;;; REVISED 11/29/00 
;;; REMOVED 5/10/01 - cache no longer used - return to old version above.
;	       (cond ((and i1 vs1) (put-vals-in-cache i1 slot vs1)))	; constraints left in the non-cache
;	       (cond ((and i2 vs2) (put-vals-in-cache i2 slot vs2)))	; constraints left in the non-cache

;;; -- end -- 

;	       (km-format t "constraints1 = ~a~%" constraints1)
;	       (km-format t "constraints2 = ~a~%" constraints2)
;	       (km-format t "constraints = ~a~%" constraints)
;	       (cond 
;	        ((and (are-consistent-with-constraints vs1 (set-difference constraints2 constraints1 :test #'equal) slot)
;		      (are-consistent-with-constraints vs2 (set-difference constraints1 constraints2 :test #'equal) slot)
;		      (test-set-constraints vs1 vs2 
;	       (km-format t "vs1 = ~a~%" vs1)
;	       (km-format t "vs2 = ~a~%" vs2)
;	       (km-format t "cs1-expr-sets = ~a~%" cs1-expr-sets)
;              (km-format t "cs2-expr-sets = ~a~%" cs2-expr-sets)
	       (let* ((expr-sets (remove nil
			          `(,vs1 ,vs2 ,@(cond ((not i1) cs1-expr-sets))     ; to get the existentials in cs1-expr-sets if ignored earlier at [5]
				  	      ,@(cond ((not i2) cs2-expr-sets)))))  ; to get the existentials in cs1-expr-sets if ignored earlier at [5]			  
		      (constraint-violation		; (constraint+vals)
	       	       (or (violated-constraints vs1 (set-difference constraints2 constraints1 :test #'equal) slot :mode 'consistent)
		           (violated-constraints vs2 (set-difference constraints1 constraints2 :test #'equal) slot :mode 'consistent)
			   (violated-set-constraints expr-sets constraints))))
;		(km-format t "expr-sets = ~a~%" expr-sets)
	        (cond
		 ((not constraint-violation))	; continue				    
                 (t (let* ((i1-str (or i1 `(#$a ,@cs1 #$with (,slot ,exprs1))))
			   (i2-str (or i2 `(#$a ,@cs2 #$with (,slot ,exprs2))))
			   (violated-constraint (first constraint-violation)) ; e.g., (at-most 1 Cell)
			   (violating-vals (second constraint-violation))
			   (i1-self-inconsistency (cond ((set-constraint-exprp violated-constraint)
			   				 (violated-set-constraints (remove nil `(,vs1 ,@(cond ((not i1) cs1-expr-sets))))
										   constraints1))))
			   (i2-self-inconsistency (cond ((set-constraint-exprp violated-constraint)
							 (violated-set-constraints (remove nil `(,vs2 ,@(cond ((not i2) cs2-expr-sets)))) 
							                           constraints2))))
			   )
		      (cond
		       (i1-self-inconsistency 
			(cond (i1 (report-error 'user-warning "Self-inconsistent instance encountered! (found when testing the unifiability of ~a and ~a)!
      (~a has (~a ~a))~%" i1 i2-str i1 slot (append (remove nil vs1) (list violated-constraint)))))
			(cond (i1 (km-trace 'comment "Instances ~a and ~a won't unify:
   ~a is a self-inconsistent object, so won't unify with anything!
   Self-inconsistency is: 
      (~a has (~a ~a))~%" i1 i2-str i1 i1 slot (append (remove nil vs1) (list violated-constraint))))
			      (t (km-trace 'comment "Instances ~a and ~a won't unify:
   ~a is a self-inconsistent object, so won't unify with anything!~%"
					   `(#$a ,@cs1 #$with (,slot (,@exprs1 ,violated-constraint)))
					   i2-str
					   `(#$a ,@cs1 #$with (,slot (,@exprs1 ,violated-constraint)))))))
		       (i2-self-inconsistency 
			(cond (i2 (report-error 'user-warning "Self-inconsistent instance encountered! (found when testing the unifiability of ~a and ~a)!
      (~a has (~a ~a))~%" i1-str i2 i2 slot (append (remove nil vs2) (list violated-constraint)))))
			(cond (i2 (km-trace 'comment "Instances ~a and ~a won't unify:
   ~a is a self-inconsistent object, so won't unify with anything!
   Self-inconsistency is: 
      (~a has (~a ~a))~%" i1-str i2 i2 i2 slot (append (remove nil vs2) (list violated-constraint))))
			      (t (km-trace 'comment "Instances ~a and ~a won't unify:
   ~a is a self-inconsistent object, so won't unify with anything!~%"
					   i1-str
					   `(#$a ,@cs2 #$with (,slot (,@exprs2 ,violated-constraint)))
					   `(#$a ,@cs2 #$with (,slot (,@exprs1 ,violated-constraint)))))))
		       (t (case fail-mode
		     ;;; Note: :fail-mode fail does *not* imply a KB error, this is just a tracing message	  
			    (fail (km-trace 'comment "Instances ~a and ~a won't unify~%   Constraint ~a violated by value(s) ~a on slot '~a'.~%"
					    i1-str i2-str violated-constraint violating-vals slot))
			    (error (report-error 'user-error "Unification (~a ~a ~a) failed!~%  Constraint ~a violated by value(s) ~a on slot '~a'.
  To debug: Do (showme ~a) and (showme ~a) and check the values on the '~a' slot.~%"		     
					   i1-str 
					   (cond ((and eagerlyp classes-subsumep) '&+!)
						 (eagerlyp '&!) (classes-subsumep '&+) (t '&)) 
					   i2-str
					   violated-constraint violating-vals slot i1-str i2-str slot))))))
			)))))))))


;;; ======================================================================
;;;		LAZY-UNIFY-VALS
;;; ======================================================================

#|
lazy-unify-vals: One of the vs1 or vs2 may be nil, **but not both**
INPUT: vs1, vs2 may include arbitrary KM expressions, including constraint expressions
       i2 MAY be NIL, with cs2 instantiated instead, if called by unify-with-slotsvals2. For now, I'm just going
	to ignore pulling constraints with eagerlyp for that situation.
RETURNS TWO values
  (i) The unified structure (NB may be NIL with eagerlyp option), denoting the unified vals
 (ii) A t/nil flag depending on whether the unification was successful or not

**NOTE** If eagerlyp = t, then the unification *must* succeed. But if not, it is allowed to fail.
	i.e., (i1 &+? i2), (i1 &? i2), and (i1 & i2) all use this (for failure in the last case, it's reported after this procedure exits)
        but   (i1 &+! i2) is never called here, as the interpreter calls (i1 &+? i2) followed by (i1 &! i2). 

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 '#$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!
[9] 
  -> (the Plasma-membrane has-part of (the Diploid-cell object of (a Nuclear-Division))) [called in *Global]
   -> (the has-part of (the Diploid-cell object of (a Nuclear-Division))) [called in *Global]
    -> (the has-part of _Diploid-cell4237)             [called in *Global]
     -> (unify-with-clone-of _Diploid-cell270)         [called in *Global]
      -> (_Diploid-cell4237 &! _Diploid-cell4391)      [called in |all situations|]
       -> (the has-part of _Diploid-cell4237)          [called in *Global]
        -> ((_Plasma-membrane4187...) && (_Plasma-membrane4347...))
 (lazy-unify-vals |is-part-of| |_Plasma-membrane4187| |_Plasma-membrane4347|
                        (|_Diploid-cell4237| |_Living-Entity4192| |_Living-Entity4191| |_Living-Entity4190| |_Living-Entity4189|)
                        (|_Diploid-cell4237| |_Living-Entity4355| |_Living-Entity4354| |_Living-Entity4353| |_Living-Entity4352|)
         :classes-subsumep t
         :eagerlyp nil)
 *Note* Here that although we are unifying in a clone, the recursion has left :eagerlyp nil. However, here we *do* want 
 to heuristically unify the Living-Entities, as they both originated from the same prototype.
|#
(defun lazy-unify-vals (slot i1 i2 vs1 vs2 &key cs1 cs2 classes-subsumep eagerlyp)
 ; (declare (ignore cs1 cs2))
  (cond  ((null vs2) (values vs1 t))	; NB With more aggressive constraint checking, we won't just deal with local values but 
	((null vs1) (values vs2 t))	;    compute global values, to check there's no constraint violation. = too expensive??
	((km-equal vs1 vs2) (values vs1 t))
	((subbagp vs1 vs2 :test #'equal) (values vs2 t))
	((subbagp vs2 vs1 :test #'equal) (values vs1 t))
	((remove-subsumers-slotp slot) (values (remove-subsumers (append vs1 vs2)) t)) ; eg. instance-of, superclasses
	((remove-subsumees-slotp slot) (values (remove-subsumees (append vs1 vs2)) t)) ; eg. subclasses

; BELOW: But with prototype instances we DO want unification (HLO-2366 - problem!) (see test-suite/hlo2366.km)
; 	((combine-values-by-appending-slotp slot) (values (remove-dup-instances (append vs1 vs2)) t))
; We can restrict this so that only if vs2 are (non-cloned) atomic instances -- vs2 are the things being ADDED
; to vs1, hence the asymmetry -- then we append, otherwise we DO unification so that protoinstances ARE unified 
; (HLO-2366)
 	((or (member slot *built-in-combine-values-by-appending-slots*) ;*built-in-atomic-vals-only-slots* MUSTN'T be &&ed
					; AND same for the other built-in-combine-values-by-appending-slots* too, namely
					; > < /== == add-list del-list pcs-list ncs-list prototype-scope
	     (and (combine-values-by-appending-slotp slot)
; NEAH...	  (not eagerlyp)	; for prototype unification we *DO* want to &&, hlo2366.  [4]
;;; [4] above: Note for the calls EXPLICITLY merging parts of prototypes, we don't do combine-values-by-appending.
;;;	       But any subgoals, we DO do combine-values-by-appending. The way to tell the difference is
;;;	       if :eagerlyp=t, then it's a direct part of the prototype merging (a somewhat hacky and indirect soln :-().
;;; ***ALSO** See [5] below for another part.
;;;
;;; BELOW:
;;; IF   the thing being unified in is completely a prototype [i.e., all Skolems are clones]
;;; THEN SKIP the append, and do a normal unification		  
;;; 11/2/09 - NO, this causes an error!!! See test-suite/combine-values-by-appending2.km for a description		  
;		  (let ((skolems (remove-if-not #'anonymous-instancep (flatten vs2))))
;		    (or (null skolems)			 ; not prototype if no Skolems
;			(notevery #'isa-clone skolems))) ; not prototype if some non-clone Skolem exists
		  ))
	 (let ((new-vals (cond  ; [8] No, still doesn't work. See comments at merge-prototype-vals below
			  ((and eagerlyp ; doing prototype unification
			        i1 i2
				; [10] if unifying in a (clone of a) prototype that is already partially included 
				;      in the instance graph, then consider &&'ing the prototype vals
				*partially-included-prototype*
				(member *partially-included-prototype*  ; [10]
					(mapcar #'(lambda (protoinstance)
						    (get-unique-val protoinstance '#$prototype-participant-of))
						(append (get-vals i1 '#$cloned-from)
							(get-vals i2 '#$cloned-from))))
				(not (member slot *built-in-combine-values-by-appending-slots*)))
			   (remove-dup-instances (merge-prototype-vals slot i1 i2 vs1 vs2)))
			  (t (remove-dup-instances (append vs1 vs2))))))
	   (values new-vals t)))		; optimized access methods assume atomic values only.	
	
;;; SPECIAL CASE FOR UNIFYING PROTOTYPES: 
;;; If unifying prototypes (signified by eagerlyp) [ AND clash (check-slotvals-constraints failed) <- NO! See below ]
;;; AND inherit-with-overrides AND no anonymous instances, THEN existing value (= from more specific prototype clone)
;;; takes precedence.
;;; [10] with looping, eagerly unifying prototypes may still leave a residual & structure in the result, even though
;;;      KM is evaluating eagerly.		   
;;; [11] We *could* add this as an extra constraint in, but seems like we don't need it.		   
	((and				; eagerlyp  [10]
	      *overriding-in-prototypes*
;	      (not (format t "vs1 = ~a, vs2 = ~a~%" vs1 vs2))
	      (inherit-with-overrides-slotp slot)
	      (notany #'kb-objectp vs1)
	      (notany #'kb-objectp vs2)
;	      (every #'fully-evaluatedp vs1)   ; [11] DON'T drop expr2 for eg. (_Val22 & (if <..> then ...)) 
;	      (every #'fully-evaluatedp vs2)	      
; No, let vs1 ALWAYS take precedence, even if no clash
;	      (not (check-slotvals-constraints slot i1 i2 vs1 vs2 :cs1 cs1 :cs2 cs2 :eagerlyp eagerlyp))
	      )
	 (let ((vs1-vals (remove-constraints vs1))
	       (vs2-vals (remove-constraints vs2))
	       (vs1-constraints (find-constraints-in-exprs vs1)))
	   (make-comment "Prototype unification: Dropping value ~a on slot ~a (~a overrides it)"
			 (delistify vs2-vals) slot (delistify vs1-vals)) 
	   (values (append (km-int vs1) vs1-constraints)	   
		   t)))
	       	
	((single-valued-slotp slot)
	 (cond ((or (not (singletonp vs1))
		    (not (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))) ; But incompleteness - we only check unifiability on the first slot...
	 (let ((unifiablep
		(cond ((and (ignore-slot-due-to-situations-mode slot) ; **IF** these conditions hold....
			    (not (and (atom (first vs1))
				      (atom (first vs2))))))
		      (*less-aggressive-constraint-checking* t)
		      (classes-subsumep 
		       (km-trace 'comment "Checking unifiability of values on the ~a slot of ~a and ~a" slot i1 i2)
		       (km-int `(,(first vs1) &+? ,(first vs2)) ; [2], [6]
; Neah, not really a target for &? tests
			       :target (cond (i2 `(#$the ,slot #$of (,i1 &+/&+? ,i2)))	; i2 may be nil, see doc above
					     (t `(#$the ,slot #$of ,i1)))
					     ))
		      (t (km-trace 'comment "Checking unifiability of values on the ~a slot of ~a and ~a" slot i1 i2)
			 (km-int `(,(first vs1) &? ,(first vs2)) ; [2], [6]
; Neah, not really a target for &? tests				 
				 :target (cond (i2 `(#$the ,slot #$of (,i1 &/&? ,i2)))
					       (t `(#$the ,slot #$of ,i1)))
					       )))))
	   (cond
	    (unifiablep
	     (cond (eagerlyp 
		       (km-trace 'comment "Eagerly unifying values on the ~a slot of ~a and ~a" slot i1 i2)
		       (let ((new-vals 
			      (km-int (vals-to-val 
				       (and-append (list (first vs1)) '&! (list (first vs2)))) ; eagerly -> do it!  [1],[3]
				      :target (cond (i2 `(#$the ,slot #$of (,i1 &! ,i2)))
						    (t `(#$the ,slot #$of ,i1))
						    )))) ; [4]
			 (values
			  (val-to-vals (vals-to-&-expr (remove-duplicates (append new-vals
										  (find-constraints-in-exprs vs1) 
										  (find-constraints-in-exprs vs2))
									  :test #'equal)))
			  t)))
		   (t (values
			  (val-to-vals (vals-to-&-expr (remove-duplicates (append (un-andify vs1) (un-andify vs2)) :test #'equal)))
			  t)))))))
					; THEN lazy unify them
;;	(eagerlyp (and-append vs1 '&&! vs2))						; [5]
#|NEW|#	(eagerlyp	; NOTE: if :eagerlyp = t, then it's a FORCED unification 
 	   	  (let* ((vs1-vals (remove-constraints vs1)) ; see note [7] under lazy-unify-expr-sets
			 (vs2-vals (remove-constraints vs2))
			 (local-vs1-constraints (find-constraints-in-exprs vs1))
			 (local-vs2-constraints (find-constraints-in-exprs vs2))) 
			
		    (cond ((null vs1-vals) (values (append vs2-vals local-vs1-constraints local-vs2-constraints) t))
			  ((null vs2-vals) (values (append vs1-vals local-vs1-constraints local-vs2-constraints) t))
#| Now redundant [inaccessible] because of test earlier, see HLO-2366 notes above.
			  ((and (combine-values-by-appending-slotp slot)
				;;; If one of the vs1-vals or vs2-vals is anonymous-instance-free, then && them.
				;;; In other words, only append them if they BOTH have anonymous instances.
				;;; See test-suite/hlo2366.km.
				;;; It's a bit hacky here to get around this special case.
				(some #'anonymous-instancep (flatten vs1-vals))
				(some #'anonymous-instancep (flatten vs2-vals)))
			   (values (append (km-int (vals-to-val (append vs1 vs2))) ; NOTE just simple appending
			   		local-vs1-constraints local-vs2-constraints)
				   t))
|#			  (t ; Else if we are merging values we better APPLY the constraints now (as eagerlyp = t)
			   (let* ((inherited-vs1-expr-sets 
				   (cond (i1 (inherited-rule-sets i1 slot :retain-commentsp t
								  :ignore-inherit-with-overrides-restriction t))))
				  (inherited-vs2-expr-sets 
				   (cond (i2 (inherited-rule-sets i2 slot :retain-commentsp t
								  :ignore-inherit-with-overrides-restriction t))))
				  (inherited-vs1-constraints (mapcan #'find-constraints-in-exprs inherited-vs1-expr-sets))
				  (inherited-vs2-constraints (mapcan #'find-constraints-in-exprs inherited-vs2-expr-sets))
				  (all-vs1-constraints (append local-vs1-constraints inherited-vs1-constraints))
				  (all-vs2-constraints (append local-vs2-constraints inherited-vs2-constraints))
				  (all-constraints (remove-duplicates (append all-vs1-constraints all-vs2-constraints)
								      :test #'equal)))
			     (km-trace 'comment "Eagerly unifying values on the ~a slot of ~a and ~a" slot i1 i2)
			     (let ((vs12 (km-int (vals-to-val (and-append vs1 '&&! vs2)) 
						 :target (cond (i2 `(#$the ,slot #$of (,i1 &! ,i2)))
							       (t `(#$the ,slot #$of ,i1))
							       )))) ; [4]
			       (cond
				((not all-constraints) (values vs12 t))
				((are-consistent-with-constraints vs12 all-constraints slot)
				 (let ((post-constraint-enforcement-values 
					(enforce-constraints vs12 all-constraints
							     :target `#$(the ,SLOT of ,I1)))) ; I1 not used in enf-c
				   (values (append post-constraint-enforcement-values 
						   (remove-duplicates 
						    (append local-vs1-constraints local-vs2-constraints)
						    :test #'equal))
					   t)))
				(t	; failure not allowed for :eagerlyp, so report error
				 (let ((violated-constraint
					(violated-constraints vs12 all-constraints slot :mode 'consistent)))
				   (report-error 'user-error
						 "Unification (~a ~a ~a) failed on slot ~a with combined values 
~a:
Constraint ~a was violated by value(s) ~a.~%"
						 (or i1 `(#$a ,@cs1 #$with (,slot ,vs1)))
						 (cond ((and eagerlyp classes-subsumep) '&+!)
						       (eagerlyp '&!) (classes-subsumep '&+) (t '&))
						 (or i2 `(#$a ,@cs2 #$with (,slot ,vs2)))
						 slot vs12
					       (first violated-constraint) (second violated-constraint))))
				)))))))
;       (t (and-append vs1 '&& vs2))))
         (t (values (valsets-to-&&-exprs (remove-duplicates (append (&&-exprs-to-valsets vs1)
								    (&&-exprs-to-valsets vs2))
							    :test #'equal :from-end t))
		    t))))

#| 
See test-suite/combine-values-by-appending2.km, combine-values-by-appending3.km, 

This is for the special case of merging cloned values on a combine-values-by-appending slot.
For this special case we *do*, sometimes, need to &! the values. ;-(
This is when a prototype has been trimmed, or extended, and so we reunify in the prototype.
As a result, we need to detect if any new values V2 are a RE-CLONED VERSIONS of v1, and thus should be unified.
If we don't do this, then the set of values will grow and grow, see combine-values-by-appending2.km

Thus:
(merge-prototype-vals (a b) (c d)) -> (a (b &! c) d)   if b and c have intersecting cloned-from tags AND are same classes.
This is really hacky, but I don't know what else to do!!

1/18/10: No, still get bad unifications. See test-suite/combine-values-by-appending4.km
         We could weaken this by using &&!, but then we'd have to rely on KB constraints to block bad
		unifications. However, there may not be KB constraints to block the unification,
		it was only by luck that I spotted it in combine-values-by-appending4.km due to a KB
		constraint.
         As a result I've strengthened the test for the rare case of a desirable unification:
	 	 v1 and v2 were cloned both from the same protoinstance from the same prototype
	  *AND*	 i1 and i2 were cloned both from the same protoinstance from the same prototype
	Seems like enough evidence now to decide that v2 is a RE-CLONED VERSION of v1, and thus should be unified.

	RESULT: combine-values-by-appending4.km - gets further now, but STILL has a problem.
	I give up! Is it really such a problem with trimming prototypes?

(defvar *ordered-scored-pairs* nil)

(defun merge-prototype-vals (slot i1 i2 vs1 vs2)
  (let ((expr (prototype-merge-expr slot i1 i2 vs1 vs2)))
    (cond ((member '&! (flatten expr))
	   (cond  (nil ; or t
		   (km-format t "(merge-prototype-vals ~a ~a ~a ~a ~a)~%" slot i1 i2 vs1 vs2)
		   (km-format t " <- ~a~%" expr)
		   (km-format t "ordered-scored-pairs were:~%~{    ~a~%~}" *ordered-scored-pairs*)
		   (cond ((/= (length *ordered-scored-pairs*) (length (remove-duplicates (mapcar #'first *ordered-scored-pairs*))))
			  (km-format t "WARNING!! Ambiguity in the pairings!~%")))))
	   (km-int (vals-to-val expr) :target `(#$the ,slot #$of (,i1 &! ,i2))))
	  (t expr))))
|#
(defun merge-prototype-vals (slot i1 i2 vs1 vs2)
  (let* (
;	 (i1-source-protoinstances (get-vals i1 '#$cloned-from))	       
	 (i1-source-protoinstances (node-cloned-from* i1))
	 (i1-source-protoroots (my-mapcan #'(lambda (i)
					      (get-vals i '#$prototype-participant-of))
					  i1-source-protoinstances))
;	 (i2-source-protoinstances (get-vals i2 '#$cloned-from))	       
	 (i2-source-protoinstances (node-cloned-from* i2))	 
	 (i2-source-protoroots (my-mapcan #'(lambda (i)
					      (get-vals i '#$prototype-participant-of))
					  i2-source-protoinstances))
	 (i12-source-protoroots (intersection i1-source-protoroots i2-source-protoroots))
	 (i1-source-protoinstances-in-protoroots
	  (remove-if-not #'(lambda (i)
			     (intersection i12-source-protoroots (get-vals i '#$prototype-participant-of)))
			 i1-source-protoinstances))
	 (i2-source-protoinstances-in-protoroots
	  (remove-if-not #'(lambda (i)
			     (intersection i12-source-protoroots (get-vals i '#$prototype-participant-of)))
			 i2-source-protoinstances)))
    (cond (*trace-merge-prototype-vals*
	   (km-format t "i1-source-protoroots = ~a~%" i1-source-protoroots)
	   (km-format t "i2-source-protoroots = ~a~%" i2-source-protoroots)
	   (km-format t "intersection = ~a~%" i12-source-protoroots)
	   (km-format t "i1-source-protoinstances-in-protoroots = ~a~%" i1-source-protoinstances-in-protoroots)
	   (km-format t "i2-source-protoinstances-in-protoroots = ~a~%" i2-source-protoinstances-in-protoroots)
	   (km-format t "intersection = ~a~%" (intersection i1-source-protoinstances-in-protoroots 
							    i2-source-protoinstances-in-protoroots))))
    (cond
     ((and i12-source-protoroots		; i1 and i2 were cloned from the same prototype..
	   (intersection i1-source-protoinstances-in-protoroots   ; ...and even more so, were cloned from the same NODE
			 i2-source-protoinstances-in-protoroots)) ; in the same prototype...
      (prototype-merge-expr1 slot i1 i2 vs1 vs2 :source-protoroots i12-source-protoroots))
     (t (append vs1 vs2)))))

#|
======================================================================
 Find any &! equalities that should be applied, representing duplicated (non-trimmed) parts of the prototype
 =====================================================================
 
ALGORITHM for pairing up vs1 and vs2, e.g.,   (a b c (a Foo)) (c d a e (a Bar))  
1. [remove-equal-items] 
   Remove items that equal, or pending equal, each other, and also non-kb-objects 
			(b) (d e)   
2. [within prototype-merge-expr1]
   Find, score, and order (best to worst) all possible permutations  -> possible-unifications 
									((b e 4)
									 (b d 3))
3. [prototype-merge-expr2]
   Walk through the original vs1 list again. For each v1 in turn: 
     a. If the v1 item is a non-kb-object, add v1 to the new-vs1.
     b. If the v1 item is equal/pending-equal to a v2 item, remove the v2 item from vs2. Add v1 to the new-vs1.
     c. If (v1 &! ?v2) is in the possible-unifications, and v2 is still in vs2,
        then add the first (v1 &! v2) (= the best) to new-vs1, and remove v2 from vs2.
     d. Else add v1 to new-vs1.
4. Append any remaining vs2 to the list.	

In this example, the result will be: (a (b &! d) c (a Foo) e (a Bar))	[ or same, with b and d switched ]
|#
;;; (prototype-merge-expr1 '#$(a b c (a Foo)) '#$(c d a e (a Bar))) 
;;; -> (a (b &! d) c (a Foo) e (a Bar))
(defun prototype-merge-expr1 (slot i1 i2 vs1 vs2 &key source-protoroots)
  (multiple-value-bind
      (uneq-vs1 uneq-vs2)
      (remove-equal-items vs1 vs2)
    (let* ((all-pairs (permute (list uneq-vs1 uneq-vs2))) ;(permute '((a b c) (d e)))->((a d) (a e) (b d) (b e) (c d) (c e))
	   (scored-pairs (remove nil 
			  (mapcar #'(lambda (pair) 
				      (score-pair (first pair) (second pair) :source-protoroots source-protoroots)) 
				  all-pairs)))
	   (ordered-scored-pairs (sort scored-pairs #'> :key #'third))
	   (unifications (prototype-merge-expr2 ordered-scored-pairs vs1 vs2 i1 i2 slot)))
      (cond (unifications 
	     (let ((expr (append (mapcar #'(lambda (v1)
					     (or (assoc v1 unifications) ; assoc returns (v1 &! v2)
						 v1))
					 vs1)
				 (ordered-set-difference vs2 (mapcar #'third unifications)))))
	       (cond  (*trace-merge-prototype-vals*
			 (km-format t "(merge-prototype-vals ~a ~a ~a ~a ~a)~%" slot i1 i2 vs1 vs2)
			 (km-format t " <- ~a~%" expr)
			 (km-format t "ordered-scored-pairs were:~%~{    ~a~%~}" ordered-scored-pairs)
			 (cond ((/= (length ordered-scored-pairs) (length (remove-duplicates (mapcar #'first ordered-scored-pairs))))
				(km-format t "WARNING!! Ambiguity in the pairings!~%")))))
		 (km-int (vals-to-val expr) :target `(#$the ,slot #$of (,i1 &! ,i2)))))
	    (t (append vs1 vs2))))))

;;; Returns just the unifications (v1 &! v2) in no particular order. The ununified elements are NOT returned -- we do 
;;; postprocessing above to reorder the unifications and put the unused elements back in.
(defun prototype-merge-expr2 (ordered-scored-pairs vs1 vs2 i1 i2 slot)
  (cond
   ((endp ordered-scored-pairs) nil)
   (t (let* ((best-pair (first ordered-scored-pairs))
	     (v1 (first  best-pair))
	     (v2 (second best-pair)))
	(cond
	 ((and (member v1 vs1)		; not already done
	       (member v2 vs2)
	       (km-int `(,v1 &? ,v2) :target `(#$the ,slot #$of (,i1 &! ,i2)))) ; check it's actually possiblep
	  `((,v1 &! ,v2)
	    ,@(prototype-merge-expr2 (rest ordered-scored-pairs) (remove v1 vs1) (remove v2 vs2) i1 i2 slot)))
	 (t (prototype-merge-expr2 (rest ordered-scored-pairs) vs1 vs2 i1 i2 slot)))))))

#|
(remove-equal-items '#$(a b c (a Foo)) '#$(c d a e (a Bar))) -> (b) (d e)
RETURNS: TWO values 
  - vs1 with equalities and non-kb-objects removed
  - vs2 with equalities and non-kb-objects removed
Note that there may be duplicates in vs1 and vs2 which should be removed too :-(
(REMOVE-EQUAL-ITEMS '#$(_Redox-Reaction161 _Redox-Reaction161) '#$(_Oxidation206 _Redox-Reaction210))
|#
(defun remove-equal-items (vs1 vs2) 
  (remove-equal-items0 (remove-if-not #'kb-objectp vs1) (remove-if-not #'kb-objectp vs2)))

(defun remove-equal-items0 (vs1 vs2 &key rev-new-vs1 equal-vs2-so-far)
  (let ((v1 (first vs1)))
    (cond 
     ((endp vs1) (values (reverse rev-new-vs1) (remove-if #'(lambda (v2) (member v2 equal-vs2-so-far :test #'equal)) vs2)))
     (t (let ((equal-vs2 (remove-if-not #'(lambda (v2)
					    (or (equal v1 v2)
						(pending-equality v1 v2)))	; if (v1 & v2) is on the goal stack
					vs2)))
	  (cond (equal-vs2 (remove-equal-items0 (rest vs1) vs2 :rev-new-vs1 rev-new-vs1 :equal-vs2-so-far (append equal-vs2 equal-vs2-so-far)))
		(t (remove-equal-items0 (rest vs1) vs2 :rev-new-vs1 (cons v1 rev-new-vs1)))))))))

#|
(defun remove-equal-items (vs1 vs2 &key rev-new-vs1)
  (let ((v1 (first vs1)))
    (cond 
     ((endp vs1) (values (reverse rev-new-vs1) (remove-if-not #'kb-objectp vs2)))
     ((not (kb-objectp v1)) (remove-equal-items (rest vs1) vs2 :rev-new-vs1 rev-new-vs1))
     (t (let ((v2 (find-equal-element v1 vs2)))
	  (cond (v2 (remove-equal-items (rest vs1) (remove v2 vs2 :count 1) :rev-new-vs1 rev-new-vs1))	; :count 1 should be unnecessary
		(t (remove-equal-items (rest vs1) vs2 :rev-new-vs1 (cons v1 rev-new-vs1)))))))))

;;; a (a b c) -> a
;;; a (x b c) -> x   if (a & x) is on the goal stack
(defun find-equal-element (v1 vs2)
  (cond ((member v1 vs2 :test #'equal) v1)
	(t (find-if #'(lambda (v2)
			(pending-equality v1 v2))
		    vs2))))
|#
#|
======================================================================
	VALIDATING AND SCORING A POSSIBLE PAIRWISE MATCH
======================================================================

Suppose we have [[_ProtoX]] -s-> [_ProtoY]
		     |		     |
		     v		     v
		   _CloneX  -s->    V1

v1-source-protoinstances = _ProtoY
v1-source-protoinstances = _ProtoX		   

vs1 = 
_Living-Entity5068 -cloned-from*-> (_Living-Entity3351 _Living-Entity4321 _Living-Entity150)
_Living-Entity5069 -cloned-from*-> (_Living-Entity3350 _Living-Entity4322 _Living-Entity85)
_Living-Entity5073 -cloned-from*-> (_Living-Entity3349 _Living-Entity4323 _Living-Entity402 _Living-Entity85)
_Living-Entity5074 -cloned-from*-> (_Living-Entity3348 _Living-Entity4324 _Living-Entity404 _Living-Entity150)
_Diploid-cell5093 -cloned-from*-> (_Diploid-cell3268 _Diploid-cell5227 _Diploid-cell159 _Diploid-cell270 _Eukaryotic-cell26 _Cell140)
_Living-Entity5138 -cloned-from*-> (_Living-Entity3095 _Living-Entity4324 _Living-Entity404 _Living-Entity150)
_Living-Entity5139 -cloned-from*-> (_Living-Entity3096 _Living-Entity4323 _Living-Entity402 _Living-Entity85)
_Living-Entity5140 -cloned-from*-> (_Living-Entity3097 _Living-Entity4322 _Living-Entity85)
_Living-Entity5141 -cloned-from*-> (_Living-Entity3098 _Living-Entity4321 _Living-Entity150)

vs2 = 
_Diploid-cell5093 -cloned-from*-> (_Diploid-cell3268 _Diploid-cell5227 _Diploid-cell159 _Diploid-cell270 _Eukaryotic-cell26 _Cell140)
_Living-Entity5267 -cloned-from*-> (_Living-Entity4321 _Living-Entity150)
_Living-Entity5266 -cloned-from*-> (_Living-Entity4322 _Living-Entity85)
_Living-Entity5265 -cloned-from*-> (_Living-Entity4323 _Living-Entity402 _Living-Entity85)
_Living-Entity5264 -cloned-from*-> (_Living-Entity4324 _Living-Entity404 _Living-Entity150)

Given a v1, pair it with the v2 with the greatest (and > 0) overlap in the cloned-from* values.
|#
;;; If (v1 &! v2) is valid, return (v1 v2 <score>), where a higher score is more preferred
(defun score-pair (v1 v2 &key source-protoroots)
  (let* ((v1-classes (get-vals v1 '#$instance-of))
	 (v1-source-protoinstances (node-cloned-from* v1))
	 (v1-source-protoroots (my-mapcan #'(lambda (i)
					      (get-vals i '#$prototype-participant-of))
					  v1-source-protoinstances)))
    (cond
     ((intersection v1-source-protoroots source-protoroots)
      (let* ((v2-classes (get-vals v2 '#$instance-of))
	     (v2-source-protoinstances (node-cloned-from* v2))
	     (v2-source-protoroots (my-mapcan #'(lambda (i)
						  (get-vals i '#$prototype-participant-of))
					      v2-source-protoinstances)))
	(cond ((and (intersection    source-protoroots v2-source-protoroots)
		    (intersection v1-source-protoroots v2-source-protoroots)
		    (intersection v1-source-protoinstances v2-source-protoinstances)
		    (intersection v2-classes v1-classes))
	       ;;; Add extra test after yet another failure :-(
	       ;;; A clone should have a subset of the original's classes. See below for the problem.
	       (let ((v1-all-classes (remove-duplicates (my-mapcan #'all-superclasses (remove-subsumers v1-classes))))
		     (v2-all-classes (remove-duplicates (my-mapcan #'all-superclasses (remove-subsumers v2-classes)))))
		 (cond ((or (is-subset-of v1-all-classes v2-all-classes)
			    (is-subset-of v2-all-classes v1-all-classes))		
			(list v1 v2 (length (intersection v1-source-protoinstances v2-source-protoinstances)))))))))))))

#|
The unexpanded KB has:

Synthesis-Of-ATP-By-Oxidative-Phosphorylation
  agent: ATP-Synthase[1]
  subevent: Oxidative-Phosphorylation 
  	       agent: ATP-Synthase[1]


Oxidative-Phosphorylation 
  agent: ATP-Synthase[1]
  subevent: Chemiosmosis
 	      agent: ATP-Synthase[1]

These should be assembled into:
	      
Synthesis-Of-ATP-By-Oxidative-Phosphorylation
  agent: ATP-Synthase[1]
  subevent: Oxidative-Phosphorylation 
  	       agent: ATP-Synthase[1]
  	       subevent: Chemiosmosis
	       		    agent: ATP-Synthase[1]

Note that ATP-Synthase is the agent of *three* events in the taxonomy.
merge-prototype-vals causes 
  Synthesis-Of-ATP-By-Oxidative-Phosphorylation &? Chemiosmosis to be unified,
as it passes the test for being cloned from the same node.
a result, the sub-sub-event is unified with the event, and we end up with
a subevent cycle ;-(

Here's the bad behavior. Note Channel-Protein is the Skolem name for ATP-Synthase:

[1c] KM(65): (MERGE-PROTOTYPE-VALS '|agent-of| '|_Channel-Protein548| '|_Channel-Protein616|
                      '(|_Oxidative-Phosphorylation546| |_Synthesis-Of-ATP-By-Oxidative-Phosphorylation544|
                       |_Synthesis-Of-ATP-By-Oxidative-Phosphorylation544|)
                      '(|_Add605| |_Oxidative-Phosphorylation615| |_Chemiosmosis619|))
i1-source-protoroots = (_Oxidative-Phosphorylation2918 _Movement-Of-Entity-Across-Biomembrane-Using-Channel-Protein741 _ATP-Synthase10773
                        _Facilitated-Diffusion31 _Enzyme739 _Metabolic-Pathway15 _Channel-Protein457 _Transport-Protein16144
                        _Membrane-Protein12408 _Biomembrane376 _Protein181 _Polymer35474 _Amphipathic-Molecule8633 _Organic-Molecule27159
                        _Molecule22316 _Synthesis-Of-ATP-By-Oxidative-Phosphorylation18012)
i2-source-protoroots = (_Movement-Of-Entity-Across-Biomembrane-Using-Channel-Protein741 _ATP-Synthase10773 _Facilitated-Diffusion31
                        _Enzyme739 _Metabolic-Pathway15 _Channel-Protein457 _Transport-Protein16144 _Membrane-Protein12408 _Biomembrane376
                        _Protein181 _Polymer35474 _Amphipathic-Molecule8633 _Organic-Molecule27159 _Molecule22316
                        _Synthesis-Of-ATP-By-Oxidative-Phosphorylation18012 _Oxidative-Phosphorylation2918)
intersection = (_Synthesis-Of-ATP-By-Oxidative-Phosphorylation18012 _Molecule22316 _Organic-Molecule27159 _Amphipathic-Molecule8633
                _Polymer35474 _Protein181 _Biomembrane376 _Membrane-Protein12408 _Transport-Protein16144 _Channel-Protein457
                _Metabolic-Pathway15 _Enzyme739 _Facilitated-Diffusion31 _ATP-Synthase10773
                _Movement-Of-Entity-Across-Biomembrane-Using-Channel-Protein741 _Oxidative-Phosphorylation2918)
i1-source-protoinstances-in-protoroots = (_Enzyme615 _Channel-Protein1033 _ATP-Synthase10773 _Entity1915 _Enzyme739 _Enzyme1156
                                          _Channel-Protein457 _Transport-Protein16144 _Membrane-Protein12408 _Integral-Protein10289
                                          _Protein181 _Polymer35474 _Amphipathic-Molecule8633 _Organic-Molecule27159 _Molecule22316
                                          _Enzyme18220)
i2-source-protoinstances-in-protoroots = (_Channel-Protein1033 _ATP-Synthase10773 _Entity1915 _Enzyme739 _Enzyme1156 _Channel-Protein457
                                          _Transport-Protein16144 _Membrane-Protein12408 _Integral-Protein10289 _Protein181 _Polymer35474
                                          _Amphipathic-Molecule8633 _Organic-Molecule27159 _Molecule22316 _Enzyme18220 _Enzyme615)
intersection = (_Enzyme18220 _Molecule22316 _Organic-Molecule27159 _Amphipathic-Molecule8633 _Polymer35474 _Protein181
                _Integral-Protein10289 _Membrane-Protein12408 _Transport-Protein16144 _Channel-Protein457 _Enzyme1156 _Enzyme739
                _Entity1915 _ATP-Synthase10773 _Channel-Protein1033 _Enzyme615)

----------
(score-pair _Synthesis-Of-ATP-By-Oxidative-Phosphorylation544 _Chemiosmosis619):
v1-source-protoroots = (_ATP-Synthase10773 _Synthesis-of-ATP525 _Exergonic-Reaction5501 _Anabolic-Pathway41 _Cellular-Process22803
                        _Synthesis19719 _Metabolic-Pathway15 _Synthesis-Of-ATP-By-Oxidative-Phosphorylation18012 _Endergonic-Reaction1412
                        _Create5251 _Spontaneous-Change1085 _Chemical-Reaction2833 _Non-Spontaneous-Change1104)
v2-source-protoroots = (_Oxidative-Phosphorylation2918 _Movement-Of-Entity-Across-Biomembrane-Using-Channel-Protein741
                        _Facilitated-Diffusion31 _Diffusion539 _Passive-Transport-Across-Biomembrane1159 _Cellular-Process22803
                        _Directed-Motion490 _Passive-Transport672 _Spontaneous-Change1085)
source-protoroots = (_Synthesis-Of-ATP-By-Oxidative-Phosphorylation18012 _Molecule22316 _Organic-Molecule27159 _Amphipathic-Molecule8633
                     _Polymer35474 _Protein181 _Biomembrane376 _Membrane-Protein12408 _Transport-Protein16144 _Channel-Protein457
                     _Metabolic-Pathway15 _Enzyme739 _Facilitated-Diffusion31 _ATP-Synthase10773
                     _Movement-Of-Entity-Across-Biomembrane-Using-Channel-Protein741 _Oxidative-Phosphorylation2918)
v1-source-protoinstances = (_Chemical-Reaction11055 _Synthesis-of-ATP525 _Exergonic-Reaction5501 _Anabolic-Pathway41 _Cellular-Process22803
                            _Synthesis19719 _Metabolic-Pathway15 _Synthesis-Of-ATP-By-Oxidative-Phosphorylation18012
                            _Endergonic-Reaction1412 _Create5251 _Spontaneous-Change1085 _Chemical-Reaction2833 _Non-Spontaneous-Change1104)
v2-source-protoinstances = (_Chemiosmosis16979 _Movement-Of-Entity-Across-Biomembrane-Using-Channel-Protein741 _Facilitated-Diffusion31
                            _Diffusion539 _Passive-Transport-Across-Biomembrane1159 _Cellular-Process22803 _Directed-Motion490
                            _Passive-Transport672 _Spontaneous-Change1085)
v1-classes = (Synthesis-Of-ATP-By-Oxidative-Phosphorylation Synthesis-of-ATP Endergonic-Reaction Non-Spontaneous-Change Create
              Metabolic-Pathway Spontaneous-Change Cellular-Process)
v2-classes = (Chemiosmosis Event Facilitated-Diffusion Passive-Transport-Across-Biomembrane
              Movement-Of-Entity-Across-Biomembrane-Using-Channel-Protein Cellular-Process Life-Cycle-Process)
(intersection v1-source-protoinstances v2-source-protoinstances) = (_Spontaneous-Change1085 _Cellular-Process22803)
----------
ordered-scored-pairs were:
    (_Synthesis-Of-ATP-By-Oxidative-Phosphorylation544 _Chemiosmosis619 2)

Note that as both _Synthesis-Of-ATP-By-Oxidative-Phosphorylation544 and _Chemiosmosis619 were cloned from 
_Cellular-Process22803, it looks like they are equal. But that can't be the case as their classes aren't
subset/superset of each other, so v2 isn't just a recloning of v1. I'm not completely sure this test
is foolproof but seeks ok :-)
|#

;;; ======================================================================
;;; 		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.
(defun lazy-unify-&-expr (expr &key (joiner '&) (fail-mode 'fail) target)
  (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)))
	  (checked (cond (constraints (enforce-constraints unified constraints :target target)) 
			 (t unified))) )
    (remove nil checked)))

(defun lazy-unify-&-expr0 (expr &key (joiner '&) (fail-mode 'fail) target)
  (cond ((and (tracep) (not (traceunifyp)))

	 (let ((*trace* nil))
	   (lazy-unify-&-expr1 expr :joiner joiner :fail-mode fail-mode :target target)))
;	 (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 (&&)
(defun lazy-unify-&-expr1 (expr &key (joiner '&) (fail-mode 'fail) target)
  (cond ((null expr) nil)
	((and (listp expr)
	      (eq (second expr) joiner))		; either (a & b) or (a & b & c)
	 (cond ((>= (length expr) 4)
		(cond ((neq (fourth expr) joiner)
		       (report-error 'user-error "Badly formed unification expression ~a encountered during unification!~%" expr)))
		(let ( (revised-expr (cond		 ; (a & b & c) -> ((a & b) & c),  (as && bs && cc) -> (((as && bs)) & c)  [NB extra () for &&]
				      ((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))				; [1]
	       ((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)				; special case: (((a b) && (c d))) [NB double parentheses] -> (a b c d) 
	      (listp (first expr))			; This comes if I do (((set1 && set2)) && set3)
	      (set-unification-operator joiner)		; Note: ((set1 && set2) && set3) is badly formed! (&& takes a *set* of expressions)
	      (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))
(defun lazy-unify-exprs (x y &key eagerlyp classes-subsumep (fail-mode 'fail) target)
  (cond ((and (or (protoinstancep x)
		  (protoinstancep y))
	      (not (am-in-prototype-mode)))
	 (report-error 'user-error 
			"Attempted unification with protoinstance(s) ~a when not in prototype mode!~%         Doing (~a ~a ~a)~%"
			(delistify (remove nil `(,(cond ((protoinstancep x) x))
						 ,(cond ((protoinstancep y) y)))))
			x
			(cond ((and eagerlyp classes-subsumep) '&+!)
			      (eagerlyp '&!) (classes-subsumep '&+) (t '&))			       		       
			y)))
  (cond ((and (null x) (null y)) nil)
	((null x) (km-unique-int y :target target))		; [2]
	((null y) (km-unique-int x :target target))
;#|bug|#((equal x y) x)
	((km-equal x y) (km-unique-int x :target target))
	((and (km-triplep x) (km-triplep y))		; [3]
	 nil)
	((or (km-structured-list-valp x)
	     (km-structured-list-valp y))
	 (let ( (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)
		     (not (km-structured-list-valp dx)))
		(let ( (edx (km-unique-int dx)) )
		  (cond ((not (km-structured-list-valp edx))
			 (cond ((null edx) (km-unique-int dy))		; dy is the structured item, edx is the evaluated 
			       ((anonymous-instancep edx)
				(let ((ans (lazy-unify edx (km-unique-int dy) :fail-mode fail-mode)))
				  (cond (ans)
					((eq fail-mode 'error)
					 (report-error 'user-error "Unification (~a ~a ~a) failed!~%" x 
						       (cond ((and eagerlyp classes-subsumep) '&+!)
							     (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y)
					 nil))))
			       ((km-argsp dy)
				(lazy-unify-exprs (list (first dy) edx) dy :fail-mode fail-mode))  			; dx & (:args dx dy)
			       ((eq fail-mode 'error)
				(report-error 'user-error "Unification (~a ~a ~a) failed!~%" x 
					      (cond ((and eagerlyp classes-subsumep) '&+!)
						    (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y)
				nil)))
			(t (lazy-unify-exprs edx dy :fail-mode fail-mode)))))
	       ((and (km-structured-list-valp dx)
		     (not (km-structured-list-valp dy)))
		(let ( (edy (km-unique-int dy)) )
		  (cond ((not (km-structured-list-valp edy))
			 (cond ((null edy) (km-unique-int dx))
			       ((and (anonymous-instancep edy)
;				     (just-a-thing edy)		; special case
				     )
				(let ((ans (lazy-unify (km-unique-int dx) edy :fail-mode fail-mode)))
				  (cond (ans)
					((eq fail-mode 'error)
					 (report-error 'user-error "Unification (~a ~a ~a) failed!~%" x 
						       (cond ((and eagerlyp classes-subsumep) '&+!)
							     (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y)
					 nil))))
			       ((km-argsp dx)			
				(lazy-unify-exprs dx (list (first dx) edy) :fail-mode fail-mode))  			; dx & (:args dx dy)
			       ((eq fail-mode 'error)
				(report-error 'user-error "Unification (~a ~a ~a) failed!~%" x 
					      (cond ((and eagerlyp classes-subsumep) '&+!)
						    (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y)
				nil)))
			(t (lazy-unify-exprs dx edy :fail-mode fail-mode)))))
	       ((and (listp dx) (listp dy)
		     (eql (first dx) (first dy))
		     (neq (first dx) '#$:triple)	; [3]
		     (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 ((and eagerlyp classes-subsumep) '&+!)
				    (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y)
		nil))))
	((existential-exprp y)
	 (let ( (xf (km-unique-int x :target target)) )
	   (cond ((null xf) (km-unique-int 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)
	 (let ( (yf (km-unique-int y :target target)) )
	   (cond ((null yf) (km-unique-int 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)				; NEW
	(t (let ( (xf (km-unique-int x :target target))
		  (yf (km-unique-int 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 :fail-mode fail-mode))
		     ((eq fail-mode 'error)
		      (report-error 'user-error "Unification (~a ~a ~a) failed!~%" xf 
				    (cond ((and eagerlyp classes-subsumep) '&+!)
					  (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 ((and eagerlyp classes-subsumep) '&+!)
				     (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y
			     xf (cond ((and eagerlyp classes-subsumep) '&+!)
				      (eagerlyp '&!) (classes-subsumep '&+) (t '&)) yf)))))))

;;;; e.g. _X is a concept with no properties
;(defun no-properties (frame) (not (symbol-plist frame)))
;(defun just-a-thing (instance)
;  (and (or (null (get-slotsvals instance :situation *global-situation*))
;	   (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 km-int, as the elements may be expressions (not guaranteed to be atomic!)
;;; [3] & of structured vals are only decommented at the top level by km-int, so we need to do another decommenting here so that remaining
;;;     comments aren't taken as actual values themselves!
(defun unify-structured-list-vals (instance10 instance20 &key classes-subsumep eagerlyp fail-mode)
 (let ( (instance1 (desource+decomment-top-level instance10))		; [3]
	(instance2 (desource+decomment-top-level instance20)) )
  (cond ((and (listp instance1) (listp instance2)
	      (eql (first instance1) (first instance2))
;	      (try-lazy-unify instance1 instance2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp))	; [1]
	      (every #'(lambda (pair)										; [2]
			 (or (km-setp (first pair))			; ((:set a) &? _X), also ((:set a b) &? NIL) should succeed
			     (km-setp (second pair))
			     (km-int `(,(first pair) ,(cond (classes-subsumep '&+?) (t '&?)) ,(second pair)))))
		     (transpose (list (rest instance1) (rest instance2)))))
	 (let ( (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))))))))

(defun unify-structured-list-vals2 (elements1 elements2 &key classes-subsumep eagerlyp fail-mode)
  (cond ((null elements1) elements2)
	((null elements2) elements1)
	((or (km-setp (first elements1))
	     (km-setp (first elements2)))
	 (let* ( (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 (let ( (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 (let* ( 
;		   (e1 (km-unique-int (first elements1)))	; - not necc to evaluate!
;		   (e2 (km-unique-int (first elements2)))
		   (e1 (first elements1))
		   (e2 (first elements2))
		   (unification (lazy-unify-exprs e1 e2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode)) )
	     (cond ((or unification 
			(km-null e1)				; if e1 or e2 is NIL, or evaluates to NIL, then the
			(km-null e2)				; unification necessarily MUST succeed (inc. nil & nil -> nil)
			(and (not (existential-exprp e1)) (null (km-unique-int e1)))   ; efficiency: existentials can never be nil
			(and (not (existential-exprp e2)) (null (km-unique-int e2))))
		    (let ( (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
(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.
|#

(defun lazy-unify-expr-sets (exprs1 exprs2 &key eagerlyp (fail-mode 'fail) target)
  (declare (ignore fail-mode))		; [6]
  (cond 
   ((or (not (listp exprs1)) (not (listp exprs2)))
    (report-error 'user-error "(~a && ~a): Arguments should be *sets* of values, but just found a single value!~%"
		  exprs1 exprs2))
   (t (cond ((and (or (some #'protoinstancep exprs1)
		      (some #'protoinstancep exprs2))
		  (not (am-in-prototype-mode)))
	     (report-error 'user-error 
			   "Attempt to unify protoinstance(s) ~a when not in prototype mode!~%         Doing (~a ~a ~a)~%"
			   (delistify `(,@(remove-if-not #'protoinstancep exprs1)
					,@(remove-if-not #'protoinstancep exprs2)))
			   exprs1
			   (cond (eagerlyp '&&!) (t '&&))
			   exprs2)))
      (cond
       ((subbagp exprs2 exprs1 :test #'equal) (km-int (vals-to-val exprs1) :target target))
       (t (let ( (set1 (km-int (vals-to-val exprs1) :target target)) )
	    (cond 
	      ((null set1) 
	       (km-int (vals-to-val exprs2) :target target))	; i.e. evaluated exprs1 is a subbag of exprs2
	      (t 
	       (multiple-value-bind
		(unexplained-set1 unexplaining-exprs2)
		(remove-explained-vals set1 (dereference exprs2) :target target)
		(let* ( (set2 (remove-dup-instances
			       (my-mapcan #'(lambda (expr) ; [1] evaluate definite exprs in set2
					     (cond ((or (and (not (existential-exprp expr))
							     (not (km-structured-list-valp expr)))
							*no-heuristic-unification*)
						    (km-int expr :target target))
						   (t (list expr))))
					 unexplaining-exprs2))))
;	                (_dummy (km-format t "set1 = ~a, exprs2 = ~a, explained-set1 = ~a, unexplained-set1 = ~a, unexplaining-exprs2 = ~a~%"
;					 set1 exprs2 explained-set1 unexplained-set1 unexplaining-exprs2))
;	                (shared-elements (ordered-intersection unexplained-set1 set2 :test #'equal))		; [2]
;	                (reduced-set1 (ordered-set-difference unexplained-set1 shared-elements :test #'equal))	
;	                (reduced-set2 (ordered-set-difference set2 shared-elements :test #'equal)) )
;		  (km-format t "unexplaining-exprs2 = ~a, set2 = ~a~%" unexplaining-exprs2 set2)
	          (multiple-value-bind
		   (reduced-set1 reduced-set2)						; don't need shared elements: added back in at [9] below
		      (remove-shared-elements unexplained-set1 set2 :test #'equal)
;		    (km-format t "reduced-set2 = ~a~%" reduced-set2)
		   (multiple-value-bind
		    (more-reduced-set1 more-reduced-set2)				; don't need shared elements: added back in at [9] below
		    (do-forced-unifications reduced-set1 reduced-set2 :eagerlyp eagerlyp :target target)
		    (multiple-value-bind
		     (remainder-set2 remainder-set1 subsumed-set1)			; [3]
; PC	             (remove-subsuming-exprs more-reduced-set2 more-reduced-set1)	; (expects exprs first, instances next)
; PC - Can I get away with :allow-coeercion t?? What will the effect be?
#|PC|#	             (remove-subsuming-exprs more-reduced-set2 more-reduced-set1 
			     :allow-coercion t :target target :eagerlyp eagerlyp) ; more-reduced-set1 is already eval'd
#|[9]|#	             (declare (ignore subsumed-set1))

                     (let* ( (new-set2 (my-mapcan #'(lambda (expr)			; [4] now evaluate (remaining) existential exprs in set2
						      (cond ((or (existential-exprp expr)		; i.e., opposite of [1]
								 (km-structured-list-valp expr))
							     (km-int expr :target target))
							    (t (list expr))))
						  remainder-set2))
#| NEW |#	            (unified (lazy-unify-sets remainder-set1 new-set2 :eagerlyp eagerlyp :target target))
; [9] preserve ordering as best as possible:
; NOTE: unified contains (possibly reordered) set1 elements followed by ununified and STILL ORDERED remaining set2 elements
; Doing (dereference set1) is a clever way of preserving the original set1 orderings after doing the unifications.
;                            (final-result (remove-dup-instances (append (dereference set1) 
;									(ordered-set-difference (dereference unified) (dereference set1))))) )
; [9] preserve ordering as best as possible:
; NEW: unified contains (possibly reordered) UNIFIED set1 & set2 elements *ONLY* (no ununified elements)
; Doing (dereference set1) is a clever way of preserving the original set1 orderings after doing the unifications.
                            (final-result (remove-dup-instances (append (dereference set1) 
									(ordered-set-difference (dereference new-set2) (dereference unified))))))
		       (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 #|"a Child-Thing"|#)	; 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 #|"a Tangible-Entity"|# _Tangible-Entity9 _Physical-Object10)
|#
(defun remove-explained-vals (vals exprs &key target)
  (cond ((null vals) (values nil exprs))
	(t (let* ( (val (first vals))
		   (expr (first exprs)) 
		   (cached-explanations (cached-explanations-for val)) )
	     (cond ((member (desource expr) cached-explanations :test #'equal)		; first val explained by first expr...
		    (cond (target (record-explanation-for target val expr)))		; [3]
		    (cond ((existential-exprp expr)
			   (remove-explained-vals (rest vals) (rest exprs) :target target))  ; [4a]
			  (t (multiple-value-bind 					     ; expr is a path
			      (unexplained-vals unexplaining-exprs)
			      (remove-explained-vals (rest vals) exprs :target target)       ; [4a]
			      (values unexplained-vals (remove expr unexplaining-exprs :test #'equal))))))	       ; [4b]

;		   (t (values vals exprs)))))))						; [5]
; NEW: *do* continue recursively -- preserve order, but allow gaps [6]
		   (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 #'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 #'(lambda (expr) (member (desource expr) cached-explanations :test #'equal)) exprs)) ; [2]
		   (path-explanations (remove-if #'existential-exprp explanations))
		   (existential-explanation (find-if #'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 #'(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 #'equal :count 1) :target target)  ; [4a]
		     (values unexplained-vals (ordered-set-difference unexplaining-exprs path-explanations :test #'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.
(defun eagerly-evaluate-exprs (instance &optional (situation (curr-situation)))
  (mapc #'(lambda (slotvals)
	    (let ((slot (slot-in slotvals))
		  (vals (vals-in slotvals)))
	      (cond ((minimatch vals '((?x &&! ?y) &rest))
		     (km-int `#$(the ,SLOT 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
(defparameter *force-with-cloned-from* t)

#| 
INPUT: set1 set2
RETURNS: three values:
	- shorter set1
	- shorter set2
	- list of items which unified via forcing (through "called" tags)

[1] Remove clone-built-from from tag list, to prevent
 _ProtoChemical1 -> _H2
 _ProtoChemical1 -> _O2
;;; Manually entered:
 (_Reaction1 has
   (raw-material (((_H2) && (_O2)))))
but then we don't want _H2 and _O2 to unify simply because they come from the same clone.
Changed this so only use cloned-from which DON'T include clone-built-from.
ALSO: Changed the unification to require constraint checking AND classes-subsumep (was nil before)
ALSO: We'll add in a check so that the unificiation is allowed to fail and KM will still recover.

[2] More problems, in a similar vein:
(ProtoHusband has (wife (ProtoWife)))
then:
(Husband1 has (wife (Sue [&ed with cloned of ProtoWife])))
(Husband2 has (wife (Mary [&ed with cloned of ProtoWife])))
(Fred has (friends ((Sue) && (Mary))))
We don't want to force Sue and mary to simply because they were cloned from the same clone participant.
It's entirely possible that multiple, different clones of a participant will end up in the same slot.

We deal with this by allowing "forced" unifications to fail, and only gently try and unify them
(with :subsumesp t). Thus the tags are really preference heuristics, and allowed to fail.

This is how it would be done with Skolem functions:
?x:husband -> ?x(wife->_1:woman(?x))

fred(wife->_1(fred))
john(wife->_1(john))
mike(friends->{fred.wife, john.wife})
mike(friends->{_1(fred),_1(john))
|#
;;; Dormant for a year, reinstated
(defun do-forced-unifications (set1 exprs2 &key eagerlyp target)
  (cond ((and (not *are-some-tags*) 
;	      (not *record-explanations-for-clones*)
	      (or (not *are-some-prototypes*)
		  (not *force-with-cloned-from*)))
	 (values set1 exprs2 nil))	; optimization
	((endp set1) (values nil exprs2 nil))
	(t (let* ((val1 (first set1))
		  (val1-tags (cond ((kb-objectp val1) 
				    (append (cond (*force-with-cloned-from* 
						   (ordered-set-difference (get-vals val1 '#$cloned-from) ; [1]
									   (get-vals val1 '#$clone-built-from))))
					    (cond (*called-forces-unification* 
						   (append (get-vals val1 '#$called) 
							   (get-vals val1 '#$uniquely-called))))))))
		  (matches (or 
			       (remove-if-not #'(lambda (val2)
						  (and (kb-objectp val2)
						       (pending-equality val1 val2)))
					      exprs2)
			       (remove-if-not #'(lambda (expr) 
						  (intersection (tags-in-expr expr :use-cloned-from *force-with-cloned-from*) 
								val1-tags :test #'equal))
					      exprs2)
			       ))
		  (val2 (first matches))
		  (val2-tags (cond (val2 (tags-in-expr val2 :use-cloned-from *force-with-cloned-from*)))) )
; 	     (km-format t "val1 = ~a, val1-tags = ~a, matches = ~a, val2 = ~a, val2-tags = ~a~%" val1 val1-tags matches val2 val2-tags)
	     (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)))
	      ((not (is-consistent (append val1-tags val2-tags))) ; Note, this is consistency of the TAGS not the VALUES
	       (report-error 'user-error 			  ;       themselves.
			     "Tag inconsistency! ~a and ~a have tags both forcing and disallowing unification!~%       Tag sets were: ~a and ~a~%"
			     val1 val2 val1-tags val2-tags)
	       ;;; Don't do the forced unification in this case if *on-error* = 'continue.
	       (multiple-value-bind
		   (reduced-set1 reduced-exprs2 unifications)
		   (do-forced-unifications (rest set1) exprs2)
		 (values (cons val1 reduced-set1) reduced-exprs2 unifications)))
	      (t ;;; New: allow continuation if *on-error* = 'continue
    	         (cond ((and (>= (length matches) 2) 	    ; [2] This is an apparent inconsistency: val1 matches > 1 things
					; BUT: We now allow > 1 matches if ONLY cloned-from tags (i.e., it's ok to have >1 match with cloned-from tags)
			     *called-forces-unification*
			     (let* ((reduced-val1-tags (cond ((kb-objectp val1) 
							      (append (get-vals val1 '#$called)
								      (get-vals val1 '#$uniquely-called)))))
				    (reduced-matches (remove-if-not #'(lambda (expr)
								   (intersection (tags-in-expr expr :use-cloned-from nil)
										 reduced-val1-tags :test #'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)
  	 	        ;;; If *on-error* = 'continue
			(report-error 'user-error "Will attempt to continue, taking the first value (~a)...~%" 
				      (first matches))))
;		      (cond ((existential-exprp val2)							; UNIFY! Result = val1
;;; No, the is0 test is too expensive!
;			     (cond ((is0 val1 val2)							; val2 subsumes val1, so no unification needed....
;				    (cond ((set-difference val2-tags val1-tags :test #'equal)		; ...except for tranferring the tags.
;					   (cond (target (record-explanation-for target val1 val2)))
;					   (km-int `(,val1 #$has (,'#$called ,val2-tags)) :fail-mode 'error))))
;				   (t (lazy-unify val1 (km-unique-int val2 :fail-mode 'error :target target) :eagerlyp eagerlyp))))		; otherwise we do unify them
; try 2			     (lazy-unify val1 (km-unique-int val2 :fail-mode 'error :target target) 
					;					 :eagerlyp eagerlyp :check-constraintsp nil))			; otherwise we do unify them
;		    (km-format t "DEBUG: Forced unification ~a with ~a~%" val1 val2)
		    (let ( (unification (cond ((existential-exprp val2)							; UNIFY! Result = val1
					       (unify-with-existential-expr val1 val2 
						    :eagerlyp eagerlyp 
						    :classes-subsumep t ; NEW: Feb 07 - allow for failure
						    :fail-mode 'fail
						    ; :check-constraintsp nil   ; NEW: commented out Feb 07
						    :target target)) ; allow :fail-mode 'fail so error is caught below
					; otherwise we do unify them
					      (eagerlyp (km-int `(,val1 &+! ,val2) :target target)) ; Route through query interpreter for &!, so pending unifications seen. 
					     							    ; Note &+! *is* allowed to quietly fail.
					      (t (lazy-unify val1 val2 
						     :eagerlyp eagerlyp 
						     :classes-subsumep t ; NEW: Feb 07 - allow for failure
						     :fail-mode 'fail
						     ; :check-constraintsp nil  ; NEW: commented out Feb 07
						     )))) )
		      (cond ((not unification)

; [2] NEW: We *allow* failure of unification of tagged items, for special cases described above.
; In other words, we now consider tags as preference heuristics (hence the :classes-subsumep t flag above), rather
; than a full forcing of 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		; NEW: Feb 07 - allow recovery if failure
				 (reduced-set1 reduced-exprs2 unifications)
				 (do-forced-unifications (rest set1) exprs2)
			       (values (cons val1 reduced-set1) reduced-exprs2 unifications)))
			    (t (multiple-value-bind
				   (reduced-set1 reduced-exprs2 unifications)
				   (do-forced-unifications (rest set1) (remove val2 exprs2 :test #'equal))
				 (values reduced-set1 reduced-exprs2 (cons val1 unifications))))))))))))

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

;;; expr is necessarily an *instance* or an *existential expr*
(defun tags-in-expr (expr &key (use-cloned-from t))
  (cond ((kb-objectp expr) (append (cond (use-cloned-from 
					  (ordered-set-difference (get-vals expr '#$cloned-from)
								  (get-vals expr '#$clone-built-from))))
				   (cond (*called-forces-unification*
					  (append (get-vals expr '#$called)
						  (get-vals expr '#$uniquely-called))))))
	(t (let ( (class+slotsvals (breakup-existential-expr expr)) )
	     (cond (class+slotsvals (append (cond (use-cloned-from
						   (ordered-set-difference
						    (vals-in (assoc '#$cloned-from (second class+slotsvals)))
						    (vals-in (assoc '#$clone-built-from (second class+slotsvals))))))
					    (cond (*called-forces-unification*
						   (append
						    (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.
;;; INPUT: Both sets must be lists of instances. They will already have been dereferenced before this point.
;;; ======================================================================

#|
(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: ONE value (only), namely a list of unified instances (possibly NIL).
         The ORDER of the unified instances is irrelevant (we reorder them in the calling procedure)
NOTE: This procedure is only used once earlier, which does a reordering. The only assumption in the earlier
      use is that the ordering of any set2 elements which are NOT unified with set1 is preserved. The
      ordering of the unifications does not matter, as they will be reordered again earlier.

[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.
|#
#|
(defun lazy-unify-sets (set1 set2 &key eagerlyp target)
  (cond 
   (*no-heuristic-unification* nil)
   (t ; (km-format t "----------~%(~a && ~a):~%" set1 set2)
      (let* ((shared-elements (ordered-intersection set1 set2))
	     (restset1 (ordered-set-difference set1 shared-elements))
	     (restset2 (ordered-set-difference set2 shared-elements)))
	; (km-format t "1. ~a + (~a && ~a)~%" shared-elements restset1 restset2)
	(multiple-value-bind
	    (unifieds rest2set1 rest2set2)
	    (lazy-unify-sets2 restset1 restset2 :eagerlyp eagerlyp :heuristic 'same-class-and-slots :target target)
	  ; (km-format t "2. ~a + (~a && ~a)~%" unifieds rest2set1 rest2set2)
	  (multiple-value-bind
	      (unifieds2 rest3set1 rest3set2)
	      (lazy-unify-sets2 rest2set1 rest2set2 :eagerlyp eagerlyp :heuristic 'same-class :target target)
	    ; (km-format t "3. ~a + (~a && ~a)~%" unifieds2 rest3set1 rest3set2)
	    (multiple-value-bind
		(unifieds3 rest4set1 rest4set2)
		(lazy-unify-sets2 rest3set1 rest3set2 :eagerlyp eagerlyp :heuristic 'normal :target target)
	      ; (km-format t "4. ~a + (~a && ~a)~%" unifieds3 rest4set1 rest4set2)
	      (let ((all-unifieds (append shared-elements unifieds unifieds2 unifieds3)))
		; (km-format t "RESULT = ~a~%````----------~%" (append all-unifieds rest4set1 rest4set2))
		(append all-unifieds rest4set1 rest4set2)))))))))
|#
;;; ======================================================================

#|
lazy-unify-sets2:
RETURNS: THREE values
 - the unified set12 values
 - the remainder of set1
 - the remainder of set2

[1] HLO-2366 (see hlo2366 example in test-suite/unification.km):
  Prefer unification if SAME immediate classes, so below the 2 Exert-Forces and the 2 ExertForceByEarth unify.
  ((_Exert-Force39_c11 _ExertForceByEarth40_c11) && (_ExertForceByEarth89 _Exert-Force88))

[2] for HLO-2358:  
(_Move-It5 has  (object (_Device6 _Device7)))
(_Device6 has   (has-part (_Artifact8)))
(_Device7 has   (material (_Substance9)))

(_Move-It_c1 has  (object (_Device_c3 _Device_c2)))  ; note, reverse order. Want KM to reorder these for unification!
(_Device_c2 has   (has-part (_Artifact_c4)))	     ; Do this by preferring instances with same used slots [3]
(_Device_c3 has   (material (_Substance_c5)))

(_Move-It5 &! _Move-It_c1)

;;; One of these should be null
(print (the has-part of _Device6))
(print (the has-part of _Device7))

[4] Route &! through query interpreter, so we record that the unification is pending
|#
#|
(defun lazy-unify-sets2 (set1 set2 &key eagerlyp heuristic target)
  (cond 
   ((or (endp set1) (endp set2))
    (values nil set1 set2))
   (t (let* ((unifier 
	      (case heuristic
		(same-class-and-slots
		 (find-if #'(lambda (set2el) ; [2]
			      (and (equal (immediate-classes (first set1)) (immediate-classes set2el))
				   (set-equal (mapcar #'slot-in (get-slotsvals (first set1))) ; [3]
					      (mapcar #'slot-in (get-slotsvals set2el)))
;				   (or (not eagerlyp) (try-lazy-unify (first set1) set2el :classes-subsumep t))
;				   (lazy-unify (first set1) set2el :classes-subsumep t :eagerlyp eagerlyp)))
				   (cond (eagerlyp (cond ((try-lazy-unify (first set1) set2el :classes-subsumep t) ; Test...
							  (km-int `(,(first set1) &! ,set2el) :target target)))) ; then do...[4]
					 (t (lazy-unify (first set1) set2el :classes-subsumep t :fail-mode 'fail)))))  ; Test and do if test succeeds.
			  set2))
		(same-class
		 (find-if #'(lambda (set2el) ; [1]
			      (and (equal (immediate-classes (first set1)) (immediate-classes set2el))
;				   (or (not eagerlyp) (try-lazy-unify (first set1) set2el :classes-subsumep t))
;				   (lazy-unify (first set1) set2el :classes-subsumep t :eagerlyp eagerlyp))
				   (cond (eagerlyp (cond ((try-lazy-unify (first set1) set2el :classes-subsumep t) ; Test...
							  (km-int `(,(first set1) &! ,set2el) :target target)))) ; then do...[4]
					 (t (lazy-unify (first set1) set2el :classes-subsumep t :fail-mode 'fail))))) ; Test and do if test succeeds.			  
			  set2))
		(normal
		 (find-if #'(lambda (set2el)
;			      (and (or (not eagerlyp) (try-lazy-unify (first set1) set2el :classes-subsumep t))
;				   (lazy-unify (first set1) set2el :classes-subsumep t :eagerlyp eagerlyp))
			      (cond (eagerlyp (cond ((try-lazy-unify (first set1) set2el :classes-subsumep t) ; Test...
						     (km-int `(,(first set1) &! ,set2el) :target target)))) ; then do...[4]
				    (t (lazy-unify (first set1) set2el :classes-subsumep t :fail-mode 'fail)))) ; Test and do if test succeeds.			  
			  set2)))))
					; back to original code...
	     (cond ((and unifier eagerlyp) (simple-eval-instance unifier)))	; [4]
	     (cond (unifier 
		    (multiple-value-bind
			(unifieds restset1 restset2)
			(lazy-unify-sets2 (rest set1) 
					 (remove unifier set2 :count 1)
					 :eagerlyp eagerlyp :heuristic heuristic :target target) ; [1]
		      (values (cons unifier unifieds) restset1 restset2)))
		   (t (multiple-value-bind
			  (unifieds restset1 restset2)
			  (lazy-unify-sets2 (rest set1) set2
					   :eagerlyp eagerlyp :heuristic heuristic :target target)
			(values unifieds (cons (first set1) restset1) restset2))))))))

|#

;;; set1 and set2 necessarily don't have shared elements (they'll have been removed earlier)
(defun lazy-unify-sets (set1 set2 &key eagerlyp target)
  (cond
   ((null set1) nil)
   ((null set2) nil)
   (*no-heuristic-unification* nil)
   (t (let* ((all-pairs (permute (list set1 set2))) ;(permute '((a b c) (d e)))->((a d) (a e) (b d) (b e) (c d) (c e))
	     (cloned-from-sources 
	      (cond (*are-some-prototypes* 
		     (remove nil (mapcar #'(lambda (i) 
					     (cond ((anonymous-instancep i) (list i (cloned-from* i))))) 
					 (append set1 set2))))))
	     (scored-pairs 
	      (cond ((singletonp all-pairs) `((,@(first all-pairs) 0)))
		    (t (mapcar #'(lambda (pair) 
				   `(,@pair ,(rank-unification (first pair) (second pair) :cloned-from-sources cloned-from-sources)))
			       all-pairs))))
	     (ordered-scored-pairs (sort scored-pairs #'> :key #'third)))
; Debug only
;	(let* ((gathered (gathers-by-key ordered-scored-pairs))
;	       (ambiguous-bindings (remove-if #'(lambda (x) (singletonp (second x))) gathered)))
;	  (cond (ambiguous-bindings
;		 (show-goal-stack)
;		 (km-format t "Ambiguous bindings for ~a:~%" target)
;		 (mapc #'(lambda (x) (km-format t "   ~a -> ~a~%" (first x) (second x))) ambiguous-bindings)
;		 (mapc #'showme (mapcar #'first ambiguous-bindings))
;		 (mapc #'showme (remove-duplicates (remove-if-not #'anonymous-instancep (flatten (mapcar #'second ambiguous-bindings)))))
;		 (break)
;		 )))
;	(km-format t "ordered-scored-pairs = ~a~%" ordered-scored-pairs)
	(lazy-unify-sets2 ordered-scored-pairs set1 set2 :eagerlyp eagerlyp :target target)))))

(defun lazy-unify-sets2 (ordered-scored-pairs set1 set2 &key eagerlyp target)
  (cond
   ((endp ordered-scored-pairs) nil)
   (t (let* ((best-pair (first ordered-scored-pairs))
	     (v1 (first  best-pair))
	     (v2 (second best-pair)))
	(cond
	 ((and (member v1 set1)		; not already done
	       (member v2 set2)
	       (cond (eagerlyp (cond ((try-lazy-unify v1 v2 :classes-subsumep t)  ; try
				      (km-int `(,v1 &! ,v2) :target target)))) ; then do...[4]
		     (t (lazy-unify v1 v2 :classes-subsumep t :fail-mode 'fail)))) ; Test and do if test succeeds.			  
	  `(,v1  ; the unified result
	    ,@(lazy-unify-sets2 (rest ordered-scored-pairs) (remove v1 set1) (remove v2 set2) :eagerlyp eagerlyp :target target)))
	 (t (lazy-unify-sets2 (rest ordered-scored-pairs) set1 set2 :eagerlyp eagerlyp :target target)))))))

(defun rank-unification (i1 i2 &key cloned-from-sources)
  (let ((n-overlap
	 (cond (cloned-from-sources
		(length (intersection (second (assoc i1 cloned-from-sources))
				      (second (assoc i2 cloned-from-sources)))))
	       (t 0))))
    (+ n-overlap
       (cond ((set-equal (immediate-classes i1) (immediate-classes i2))
	      (cond ((set-equal (mapcar #'slot-in (get-slotsvals i1)) ; [3]
				(mapcar #'slot-in (get-slotsvals i2)))  100)
		    (t 50)))
	     (t 0)))))

;;; ======================================================================
;;;	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)
|#
(defun and-append (xs0 and-symbol ys0)
  (let ( (xs (remove-dup-atomic-instances xs0))
	 (ys (remove-dup-atomic-instances ys0)) )
  (cond ((equal xs ys) xs)
	((and (singletonp xs) 			; (((a b) && (c d)))    (((a b) && (e f))) [1a]
	      (and-listp (first xs) and-symbol) ; ((a & b))		((a & c))	   [1b]
	      (singletonp ys) 
	      (and-listp (first ys) and-symbol))
	 (list (and-append2 (first xs) and-symbol (first ys))))
	((and (singletonp xs) 			; (((a b) && (c d)))    (a b)		   [2a]
	      (and-listp (first xs) and-symbol)) ; ((a & b))		(a)		   [2b]
	 (list (and-append2 (first xs) and-symbol (do-setify ys and-symbol))))
	((and (singletonp ys) 			; (a b)			(((a b) && (c d))) [2a]
	      (and-listp (first ys) and-symbol)) ; (a)			((a & b))	   [2b]
	 (list (and-append2 (do-setify xs and-symbol) and-symbol (first ys))))
	((set-unification-operator and-symbol)	; (a b)			(c d)		   [3a]
	 (list (list xs and-symbol ys)))
	((val-unification-operator and-symbol)	; (a)			(c)		   [3b]
	 (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)))))

(defun do-setify (set and-symbol)
  (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
(defun and-append2 (x and-symbol y)
  (cond ((null x) y)					; termination
	((and (not (singletonp x))
	      (not (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
(defun and-listp (list and-symbol) 
  (and (listp list)
       (> (length list) 2)
       (eq (second list) and-symbol)))

(defun and-member (el list and-symbol)
  (cond ((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
(defun copy-situation-contents (source-sitn target-sitn)
  (cond ((eq source-sitn target-sitn))
	((not (isa source-sitn '#$Situation)))
	((not (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 (let ( (curr-situation (curr-situation))
		  (objects-to-copy (remove-if-not #'(lambda (instance) 
						      (has-situation-specific-info instance source-sitn))
						  (get-all-concepts))) )
;	     (km-format t "Changing to the target-sitn = ~a...~%" target-sitn)
	     (in-situation target-sitn)			; Change to target...
	     (mapc #'(lambda (instance)
		       (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)	; - now in put-slotsvals via merge-slotsvals; Later: No!
	     (mapc #'classify objects-to-copy)
;	     (km-format t "Changing back the curr-sitn = ~a...~%" curr-situation)
	     (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
(defun merge-slotsvals (instance source-sitn target-sitn &key classes-subsumep (facet 'own-properties))
  (let ( (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 			; [2]
			     :cs1 (immediate-classes instance :situation source-sitn)
			     :cs2 (immediate-classes instance :situation target-sitn)
			     :classes-subsumep classes-subsumep 
			     :check-constraintsp nil
			     :fail-mode 'error)
       (cond (successp 
	      (cond ((not (equal unified-svs target-svs))
		     (put-slotsvals instance unified-svs :facet facet :situation target-sitn :install-inversesp nil))))	; install-inversesp = nil [1]
	     (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))))

(defun unifiable-with-existential-expr (instance expr &key classes-subsumep)
  (unifiable-with-existential-expr0 instance expr :classes-subsumep classes-subsumep))

(defun unifiable-with-existential-expr0 (instance expr &key 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 
   (let ( (class+slotsvals (bind-self (breakup-existential-expr expr) instance)) )   ; [1]
    (cond (class+slotsvals				;;; 1. An INDEFINITE expression
	   (let* ( (class (first class+slotsvals))		;;;    (so do subsumption)
		   (slotsvals0 (second class+slotsvals)) 
		   (classes (remove-duplicates (cons class (vals-in (assoc '#$instance-of slotsvals0)))))  ; [3]
		   (slotsvals (update-assoc-list slotsvals0 `(#$instance-of ,classes))) )		   ; [3]
	     (are-slotsvals slotsvals)						; inc. look for constraints in slots 
	     (cond 
	      ((and (null slotsvals)
		    (isa instance class)) instance)	; [4]
	      ((and ;(can-be-a instance class)
		(compatible-classes :instance1 instance :classes2 (remove-constraints classes)	; incomplete [no constraint checking] lookahead
				    :classes-subsumep classes-subsumep)
		(cond ((am-in-local-situation-or-theory)
			(let ( ; (local (remove-if-not #'(lambda (slotvals) 
			       ;			 (fluentp (slot-in slotvals))) slotsvals))
			       (global (remove-if #'(lambda (slotvals)
						      (fluentp (slot-in slotvals))) slotsvals)) 
			       (curr-situation (curr-situation)) )
			  (and (lazy-unify-slotsvals instance nil (get-slotsvals instance) slotsvals	; was "local", not "slotsvals" [1]*** 
;						     :cs2 (remove-constraints classes)
						     :cs2 (remove-if-not #'kb-objectp classes)   ; [5]
						     :classes-subsumep classes-subsumep :fail-mode 'fail)
			       (prog2
				   (change-to-situation *global-situation*)
				   (lazy-unify-slotsvals instance nil (get-slotsvals instance) global
;						     :cs2 (remove-constraints classes)
						     :cs2 (remove-if-not #'kb-objectp classes)   ; [5]
						     :classes-subsumep classes-subsumep :fail-mode 'fail)
				 (change-to-situation curr-situation)))))
		      (t (lazy-unify-slotsvals instance nil (get-slotsvals instance) slotsvals 
;					       :cs2 (remove-constraints classes)
					       :cs2 (remove-if-not #'kb-objectp classes)   ; [5]
					       :classes-subsumep classes-subsumep :fail-mode 'fail))))))))	; only unify in curr sitn [1], [2]
	  (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. [Note: Failure is allowed]
;;; [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
;;; [6] (u-w-e-e '#$_Fish1 '#$(a Pet (@ _Person3 Person owns)) - don't want to lose explanation for _Fish1 instance-of Pet
(defun unify-with-existential-expr (instance expr 
				    &key eagerlyp classes-subsumep (fail-mode 'fail) target (check-constraintsp t))
  (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)			; special case: (_SomePerson23 & (a Person)) -> _Person35, a definite object
	 (neq (first expr) '#$some))
    (let ((val (km-unique-int expr :target target)) 
	  (joiner (cond ((and eagerlyp classes-subsumep) '&+!)
			(eagerlyp '&!) (classes-subsumep '&+) (t '&))))
      (km-unique-int `(,instance ,joiner ,val) :fail-mode fail-mode)))
;  ((km-int `#$(,INSTANCE is ',EXPR)) instance))   	; [2], [2b]
   (t (let ( (class+slotsvals (bind-self (breakup-existential-expr expr) instance)) )   ; [1]
	(cond 
	 (class+slotsvals				;;; 1. An INDEFINITE expression
	  (let* ((class (first class+slotsvals))		;;;    (so do subsumption)
		 (slotsvals0 (second class+slotsvals)) 
		 (_dummy (are-slotsvals slotsvals0)) ; inc. look for constraints in slots 
		 (extra-classes (vals-in (assoc '#$instance-of slotsvals0))) ; [1]
		 (all-new-classes (cons class extra-classes))
		 (unification
		    (cond 
		       ((and (null slotsvals0)			      ; [4] - optional optimization (in practice doesn't
			     (isa instance class)		      ; make much difference)
			     (remove-subsumers-slotp '#$instance-of)) ; NOTE: Otherwise instance-of assertions *do* need 
								      ; updating in the KB.
			instance)
		       (t (multiple-value-bind 
			      (compatiblep violated-partitions)
			      (compatible-classes :instance1 instance :classes2 (list class) ; incomplete [no constraint checking], quick lookahead 
						  :classes-subsumep classes-subsumep)
			    (cond 
			     (compatiblep 
			      (cond ((not (kb-objectp instance)) instance) ; e.g. (1 & (a Coordinate))
				    (t (or (unify-with-slotsvals2 instance all-new-classes
								  slotsvals0 :classes-subsumep classes-subsumep
								  :eagerlyp eagerlyp :check-constraintsp check-constraintsp :fail-mode fail-mode)
					   (cond ((eq fail-mode 'error)
						  (report-error 'user-error 
								"Unification (~a ~a ~a) failed! (Some slot-values are incompatible)~%"
								instance 
								(cond ((and eagerlyp classes-subsumep) '&+!)
								      (eagerlyp '&!) (classes-subsumep '&+) (t '&))
								expr)
						  nil))))))
			     ((eq fail-mode 'error)
			      (cond
			       (violated-partitions
				(report-error 'user-error "Unification (~a ~a ~a) failed! The classes were found to be incompatible.~%Partition(s) ~a was violated:~%~{~a~}"
					      instance 
					      (cond ((and eagerlyp classes-subsumep) '&+!)
						    (eagerlyp '&!) (classes-subsumep '&+) (t '&))
					      expr
					      (delistify violated-partitions)
					      (mapcar #'write-frame violated-partitions)))
			       (t (report-error 'user-error "Unification (~a ~a ~a) failed! The classes were found to be incompatible.~%"
					      instance 
					      (cond ((and eagerlyp classes-subsumep) '&+!)
						    (eagerlyp '&!) (classes-subsumep '&+) (t '&))
					      expr))))))))))
	    (declare (ignore _dummy))
;	    (km-format t "DEBUG: ~a~%" `(record-explanation-for ,target ,instance ,expr))
	    (cond (unification (cond (target (record-explanation-for target instance expr)))
			       (cond ((kb-objectp instance)
				      (mapc #'(lambda (new-class) ; [6]
  					        (record-explanation-for `#$(the instance-of of ,INSTANCE) new-class expr))
					    all-new-classes)))
			       (cache-explanation-for instance expr)		; new - missed this first time round
			       (setq *statistics-unifications* (1+ *statistics-unifications*))
			       unification))))
; No, error reporting done earlier now
;		  ((eq fail-mode 'error)
;		   (report-error 'user-error "Unification (~a ~a ~a) failed! (Some slot-values are incompatible)~%" 
;				 instance 
;				 (cond ((and eagerlyp classes-subsumep) '&+!)
;				       (eagerlyp '&!) (classes-subsumep '&+) (t '&))
;				 expr))
	 (t (report-error 'program-error "unify-with-existential-expr() in lazy-unify.lisp wasn't given an existential expr!~%   (was ~a instead)~%"
			  expr)))))))

(defun unify-with-slotsvals2 (instance classes slotsvals00 
			      &key classes-subsumep eagerlyp (check-constraintsp t) (fail-mode 'fail))
 (let ((slotsvals (convert-comments-to-internal-form slotsvals00)))   ; new!
  (cond 
   ((am-in-local-situation-or-theory)
    (let* ( (local0 (remove-if-not #'(lambda (slotvals) (fluentp (slot-in slotvals))) slotsvals))
	    (global0 (remove-if #'(lambda (slotvals) (fluentp (slot-in slotvals))) slotsvals))
	    (local (cond ((fluentp '#$instance-of)
			  (update-assoc-list local0 `#$(instance-of ,CLASSES)))
			 (t local0)))
	    (global (cond ((not (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-constraints classes)
			     :cs2 (remove-if-not #'kb-objectp classes)   ; [5]
			     :classes-subsumep classes-subsumep ; [3]
			     :eagerlyp eagerlyp
			     :check-constraintsp check-constraintsp
			     :fail-mode fail-mode)
       (cond 
	(successp1
	 (change-to-situation *global-situation*)
	 (multiple-value-bind
	  (successp2 unified-svs2)
	  (lazy-unify-slotsvals instance nil (get-slotsvals instance) global
;				:cs2 (remove-constraints classes)
				:cs2 (remove-if-not #'kb-objectp classes)   ; [5]
				:classes-subsumep classes-subsumep ; [3]
				:eagerlyp eagerlyp
				:check-constraintsp check-constraintsp
				:fail-mode fail-mode)
	 (cond 
	  ((and successp1 successp2)
	   (let ( (local-change-made nil) 
		  (global-change-made nil) )
	    (cond ((not (equal unified-svs2 (get-slotsvals instance)))			; GLOBAL SITUATION
		   (cond ((not global-change-made) 
;			  (km-format t "unified-svs2 = ~a~%" unified-svs2)
;			  (km-format t "(get-slotsvals ~a) = ~a~%" instance (get-slotsvals instance))
			  (setq global-change-made t)))
;		   (km-format t "tracepoint 1: ~a~%" unified-svs2)
		   (mapc #'(lambda (slotvals) (put-vals instance (slot-in slotvals) 
							(vals-in slotvals))) unified-svs2) ; [1]		   
		   (cond ((some #'(lambda (class) (is-subclass-of class '#$Situation)) classes)
			  (make-assertions instance unified-svs2)))))
	    (change-to-situation curr-situation)
	    (cond ((not (equal unified-svs1 (get-slotsvals instance)))			; LOCAL SITUATION
		   (cond ((not local-change-made) 
;			  (km-format t "unified-svs1 = ~a~%" unified-svs1)
;			  (km-format t "(get-slotsvals ~a) = ~a~%" instance (get-slotsvals instance))
			  (setq local-change-made t)))
;		   (km-format t "tracepoint 2: ~a~%" unified-svs1)
		   (mapc #'(lambda (slotvals) (put-vals instance (slot-in slotvals) 
							(vals-in slotvals))) unified-svs1) ; [1]
		   (cond ((some #'(lambda (class) (is-subclass-of class '#$Situation)) classes)
			  (make-assertions instance unified-svs1)))))
;	    (un-done instance)
; It looks like slotsvals are adequate, but no: 
; i1 & (a Move with (object (...))) may, as a side effect, include OTHER changes on OTHER slots on i1 too,
; inherited from Move or its superclasses. So we better undo all of these!
;	    (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in slotsvals))
	    (cond (local-change-made
		   (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in unified-svs1))))
	    (cond (global-change-made
		   (mapc #'(lambda (slot) (un-done instance :slot slot :situation *global-situation*)) (mapcar #'slot-in unified-svs2))))
	    (cond ((or local-change-made global-change-made)
		   (classify instance))))

; OLD VERSION
;	    (cond (change-made
;		   (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in unified-svs1))
;		   (classify instance))))

	   instance)
	  (t (change-to-situation curr-situation) nil))))))))	; oops! Must change back again even after failure!
   (t (multiple-value-bind
       (successp unified-svs)
       (lazy-unify-slotsvals instance nil (get-slotsvals instance)
			     (update-assoc-list slotsvals `#$(instance-of ,CLASSES))
;			     :cs2 (remove-constraints classes)
			     :cs2 (remove-if-not #'kb-objectp classes)   ; [5]
			     :classes-subsumep classes-subsumep ; [3]
			     :eagerlyp eagerlyp
			     :check-constraintsp check-constraintsp
			     :fail-mode fail-mode)
      (cond (successp 
	     (let ( (change-made nil) )
	      (cond ((not (equal unified-svs (get-slotsvals instance)))
		     (mapc #'(lambda (slotvals) 
			       (cond ((not change-made) 
;				      (km-format t "unified-svs = ~a~%" unified-svs)
;				      (km-format t "(get-slotsvals ~a) = ~a~%" instance (get-slotsvals instance))
				      (setq change-made t)))
					;			       (km-format t "tracepoint 3: ~a~%" slotvals)
			       (put-vals instance (slot-in slotvals) (vals-in slotvals))) 
			   unified-svs)	; [1]
		     (cond ((some #'(lambda (class) (is-subclass-of class '#$Situation)) classes)
			    (make-assertions instance unified-svs)))
;		     (un-done instance)
; It looks like slotsvals are adequate, but no: 
; i1 & (a Move with (object (...))) may, as a side effect, include OTHER changes on OTHER slots on i1 too,
; inherited from Move or its superclasses. So we better undo all of these!
		     (cond (change-made
			    (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in unified-svs))
			    (classify instance)))
		     )))
	     instance)))))))

;;; ======================================================================

#|
INPUT: you can give either classes1, or instance1 (in which case classes1 is looked up)
TEST: "compatibilty", i.e., Classes mustn't be disjoint, and may have a subsumption requirement also.
RETURNS: TWO values
 - non-NIL if the classes are compatible, NIL if they are incompatible
 - A list of the partitions that were violated, if any.

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.
|#
(defun compatible-classes (&key instance1 instance2 classes1 classes2 classes-subsumep)
  (let ( (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)					; [3]
	   (set-equal immediate-classes1 immediate-classes2))
	  ((or classes-subsumep 
	       (intersection immediate-classes1 '#$(Sequence Pair Triple Bag))		; force subsumep test on these types of objects
	       (intersection immediate-classes2 '#$(Sequence Pair Triple Bag)))
	   (or (classes-subsume-classes immediate-classes1 immediate-classes2)
	       (classes-subsume-classes immediate-classes2 immediate-classes1)))
	  (t (let ((violated-partitions (disjoint-class-sets immediate-classes1 immediate-classes2 :instance1 instance1 :instance2 instance2)))
	       (cond ((null violated-partitions) t)
		     (t (values nil violated-partitions))))))))
#|
======================================================================
    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:
  - A list of Partitions that an instance in both immediate-classes1 and immediate-classes2 violates      
    or NIL of no Partition is violated (i.e. the two class sets are NOT disjoint and can be combined.
|#
(defun disjoint-class-sets (immediate-classes1 immediate-classes2 &key instance1 instance2)
  (disjoint-class-sets0 (remove-duplicates (my-mapcan #'all-superclasses0 (remove '#$Thing immediate-classes1))) ; [1]
			(remove-duplicates (my-mapcan #'all-superclasses0 (remove '#$Thing immediate-classes2))) ; [1]
			:instance1 (or instance1 `#$(a ,(VALS-TO-VAL IMMEDIATE-CLASSES1))) ; purely for tracing output
			:instance2 (or instance2 `#$(a ,(VALS-TO-VAL IMMEDIATE-CLASSES2))))) ; purely for tracing output

#|
[1] all-superclasses0 retains class, excludes Thing
RETURNS: the partitions; removing singletons will show which partitions were violated.
|#
(defun disjoint-classes (classes)
  (cond
   ((null classes) nil)
   ((singletonp classes) nil)
   (t (let* ((all-classes (remove-duplicates (my-mapcan #'all-superclasses0 classes)))
	     (all-partitions (my-mapcan #'(lambda (c) (get-vals c '#$member-of)) all-classes)))
	(cond ((not (= (length all-partitions) (length (remove-duplicates all-partitions)))) all-partitions))))))
		; duplicates -> disjoint (dups can only arise if multiple, different classes point to same partition)

#|
RETURNS: A list of partitions that are violated by an instance that is an instance-of both classes1 and classes2
(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.
|# 

(defun disjoint-class-sets0 (classes1 classes2 &key instance1 instance2)
  (declare (ignore instance1 instance2))
  (and (not (equal classes1 classes2))
       (not (subsetp classes1 classes2))
       (not (subsetp classes2 classes1))
       ;;; Much more efficient implementation of partition checking with large partitions
       (let ((partitions1 (my-mapcan #'(lambda (c1) (get-vals c1 '#$member-of)) (set-difference classes1 classes2)))
             (partitions2 (my-mapcan #'(lambda (c2) (get-vals c2 '#$member-of)) (set-difference classes2 classes1))))
	 (intersection partitions1 partitions2))))

#|
(some #'(lambda (partition)
		 (let* ( (partition-members (get-vals partition '#$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 '#$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 '#$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

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

#| ======================================================================
		  CONSTRAINT CHECKING / ENFORCEMENT
   ======================================================================

SATISFIABILITY vs CONSISTENCY: Used for has-definition, 
	e.g., (a Person) doesn't SATISFY (every House-Owner has-definition (instance-of (Person)) (owns ((at-least 1 House))))
		       but is CONSISTENT with it.

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.
	It ASSUMES vals are fully evaluated. It does naive counting, so will FAIL given
	    constraints which can be forcibly met, e.g.,:
	KM: (satisfies-constraints '#$(_House20 _House21) '#$((exactly 1 House)) '#$owns)
	nil
	Ug.

enforce-constraints: Apply the constraints. Failure IS an error and will be reported.
Used to process the values collected in km-slotvals-from-kb.

test-constraints calls test-set-constraint: 
	used by is0 (subsumes.lisp), in mode SATISFIES
	used by check-slotvals-constraints (lazy-unify.lisp), in mode CONSISTENT

test-set-constraints calls test-set-constraint0: This is used ONLY by check-slotvals-constraints in lazy-unify.lisp.
  This only does a consistent check, not a satisfied check.
|#

;;; If t, then automatically delete vals which violate constraints. If not, keep going regardless.
;;; This is only significant if *error-report-silent* is t, otherwise KM will throw an error if there's a violation.
;;; PEC 11/14/10: This can probably be removed now and made a constant.
(defparameter *remove-violating-instances* nil)

;;; ======================================================================

(defun note-are-constraints ()
  (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.
(defun filter-using-constraints (vals constraints &optional slot)
  (cond ((null constraints) vals)
	((and (tracep) (not (traceconstraintsp))) 
	 (let ((*trace* nil))
	   (filter-using-constraints0 vals constraints slot)))
;	 (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))))

(defun filter-using-constraints0 (vals constraints slot)
  (remove-if-not #'(lambda (val) (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 '#$(Car) '#$((<> Vehicle)) '#$instance-of)
   should FAIL, as #$instance-of is a remove-subsumers-slotp, but
	(are-consistent-with-constraints '#$(Vehicle) '#$((<> Car)) '#$instance-of)
   should SUCCEED. Similarly, 
	(are-consistent-with-constraints '#$(Vehicle) '#$((<> Car)) '#$subclasses
   should FAIL, as #$subclasses is a remove-subsumees-slotp, but
	(are-consistent-with-constraints '#$(Car) '#$((<> Vehicle)) '#$subclasses)
   should SUCCEED.
|#
(defun are-consistent-with-constraints (vals0 constraints0 slot)
  (not (violated-constraints vals0 constraints0 slot :mode 'consistent)))

(defun satisfies-constraints (vals0 constraints0 slot &key incompletep)
  (not (violated-constraints vals0 constraints0 slot :mode 'satisfies :incompletep incompletep)))

;;; [1] Could later be improved to be (violated-set-constraint ...) which returns (constraint violating-vals) directly
(defun violated-constraints (vals0 constraints0 slot &key mode incompletep)
  (cond ((null constraints0) nil)
	(t (let ((vals (remove-dup-instances vals0)) 		; does dereferencing etc.
		 (constraints (dereference (desource+decomment constraints0)))
		 (special-slot-type (special-slot-type slot))) 
	     (or (case mode
		   (consistent (violated-set-constraints (list vals) constraints))
		   (satisfies (some #'(lambda (constraint)
					(cond ((and (set-constraint-exprp constraint)
						    (not (set-constraint-satisfied vals constraint :incompletep incompletep))) ; [1]
					       (list constraint vals))))
				    constraints)))
		 (some #'(lambda (val) 
			   (violated-val-constraints val constraints special-slot-type :mode mode))
		       vals))))))

(defun special-slot-type (slot)
  (cond ((null slot) nil)
	((remove-subsumers-slotp slot) 'remove-subsumers-slot)
	((remove-subsumees-slotp slot) 'remove-subsumees-slot)))

(defun test-val-constraints (val constraints special-slot-type &key mode)
  (not (violated-val-constraints val constraints special-slot-type :mode mode)))

(defun violated-val-constraints (val constraints special-slot-type &key mode)
  (some #'(lambda (constraint) 
	    (cond ((and (val-constraint-exprp constraint)
			(not (test-val-constraint val constraint special-slot-type :mode mode))) ; i.e., test fails
		   (list constraint val))))
	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)
;;; [3b] Technically, if there's no possible values this is a failure. 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
;;; [4] Important not to abort if looping on constraints
(defun test-val-constraint (val constraint special-slot-type &key mode)
  (cond ((constraint-exprp val))	; [1]
	(t (case (first constraint)
;  	     (#$must-be-a (unifiable-with-expr val `#$(a ,@(REST CONSTRAINT))))	; not complete enough, and may loop!!
	     (#$retain-expr t)
	     (#$must-be-a (cond ((instance-of val '#$Aggregate)
				 (let ( (element-type (cond ((not (km-structured-list-valp val)) ; NEW ADDED TEST
							     (km-int `#$(the element-type of ,VAL))))) )
				   (or (null element-type)
					   (compatible-classes :classes1 element-type :classes2 (list (second constraint))))))
													; ignore any "with ..." part, as 
													; disjoint-class-sets can't handle it.
;				     (every #'(lambda (element-type) 
;						(km-int `#$(,ELEMENT-TYPE is-subsumed-by (the-class ,@(REST CONSTRAINT)))))
;					    (km-int `#$(the element-type of ,VAL))))
				    ((equal constraint '#$(must-be-a Thing)))		; t
				    (t (case mode
					     (consistent (km-int `#$(,VAL &? (a ,@(REST CONSTRAINT)))))
					     (satisfies  (km-int `#$(,VAL is '(a ,@(REST CONSTRAINT)))))))))
		 (#$mustnt-be-a (km-int `#$(not (,VAL is '(a ,@(REST CONSTRAINT))))))
		 (<> (cond ((is-km-term (second constraint))
			    (case special-slot-type
				  (remove-subsumers-slot (not (is-subclass-of val (second constraint))))
				  (remove-subsumees-slot (not (is-subclass-of (second constraint) val)))
				  (t (not (equal val (second constraint))))))
			   (t (km-int `#$(,VAL /= ,(SECOND CONSTRAINT))))))	; [2]
		 (#$excluded-values 
		  (let ( (excluded-values (km-int (vals-to-val (rest constraint)))) )
		    (cond 
		     ((null excluded-values))
		     ((eq special-slot-type 'remove-subsumers-slot) ; #$instance-of	; val = Animal, excluded-values = (Tiger) OK
		      (not (intersection (all-superclasses0 val) excluded-values)))	; val = Tiger, excluded-values = (Animal) NOT OK
		     ((eq special-slot-type 'remove-subsumees-slot) ; #$subclasses	; val = Animal, excluded-values = (Tiger) NOT OK  [4]
		      (not (intersection (all-subclasses0 val) excluded-values)))	; val = Tiger, excluded-values = (Animal) OK
		     (t (not (member val excluded-values))))))			; test it
		 (#$possible-values 
		  (let ( (possible-values (km-int (vals-to-val (rest constraint)))) )		; [3]
;		    (km-format t "possible-values = ~a~%" possible-values)
		    (cond (possible-values
			   (case special-slot-type
				 (remove-subsumers-slot (not (disjoint-class-sets (list val) possible-values)))
				 (remove-subsumees-slot (not (disjoint-class-sets (list val) possible-values)))
				 (t (case mode
					  (consistent (some #'(lambda (possible-value)
								 (km-int `(,val &? ,possible-value)))
							     possible-values))
					  (satisfies (member val possible-values :test #'equal))))))
			  (t))))	; [3b] fail, not succeed -- may be no vals due to looping, not really values 
		 (#$constraint 
		  (let ((constraint-expr (subst val '#$TheValue (second constraint))))
		    (cond ((looping-on constraint-expr) t) ; Don't abort if looping!
			  (t (km-int constraint-expr)))))
;		 (#$override t)
		 (#$no-inheritance t)
		 (t (report-error 'user-error "Unrecognized form of constraint ~a~%" constraint))))))

;;; Test for SATISFIABILITY not CONSISTENCY. Used for has-definition, 
;;;		e.g., (a Person) doesn't SATISFY (every House-Owner has-definition (owns ((at-least 1 House))))
;;;		       but is CONSISTENT with it.
;;; [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
;;  [3] Copy this special case from enforce-set-constraints: want to allow possible unifications for singleton values. 
(defun set-constraint-satisfied (vals0 constraint &key incompletep)
  (cond
   ((eq constraint '#$:incomplete) t)
   (t (let*
	 ((vals (remove-constraints vals0)) 	; [1]
	  (n (second constraint))
	  (class (third constraint)) 
	  (nvals (cond ((member (first constraint) '#$(at-least exactly at-most))
			(length (remove-if-not #'(lambda (val) (isa val class)) vals))))) 
	  (forced-class (or (minimatch1 constraint '#$(at-most 1 ?class)) 	 ; [3]
			    (minimatch1 constraint '#$(exactly 1 ?class))))
	  (vals-in-class (cond (forced-class (remove-if-not #'(lambda (val) (isa val forced-class)) vals)))))
	(cond 
          ((> (length vals-in-class) 1)	; necc. 0 if no forced class
  	   (every #'(lambda (pair) (km-int `(,(first pair) &? ,(second pair)))) (all-adjacent-pairs vals-in-class)))
	  (t (case (first constraint)
	       (#$at-least (>= nvals n))
	       (#$exactly  (and (not incompletep) (= nvals n)))  ; else more vals might be added later
	       (#$at-most  (and (not incompletep) (<= nvals n))) ; else more vals might be added later
	       (#$set-constraint (km-int (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.
(defun is-consistent (vals+constraints)
  (let ((constraints (remove-if-not #'constraint-exprp vals+constraints))
	(vals (remove-if #'constraint-exprp vals+constraints)))
    (not (violated-constraints vals constraints nil :mode 'consistent))))

;(defun is-consistent (vals+constraints0)
;  (cond ((null vals+constraints0) t)
;	(t (let ( (vals+constraints (remove-dup-instances (desource+decomment vals+constraints0))) )
;	     (and (every #'(lambda (constraint)
;			     (or (not (set-constraint-exprp constraint))
;				 (test-set-constraint vals+constraints constraint :mode 'consistent)))
;			 vals+constraints)
;	     (every #'(lambda (val) (test-val-constraints val vals+constraints nil :mode 'consistent)) 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
;;; IF constraints can't be satisfied THEN this throws an error (report-error), i.e., we ASSUME that
;;;    passability has already been tested via satisfies-constraints.
(defun enforce-constraints (vals constraints &key target)
    (cond ((and (tracep) (not (traceconstraintsp)))
	   (let ((*trace* nil)) 
	     (enforce-constraints0 vals constraints :target target)))
;	 (prog2 (suspend-trace) (enforce-constraints0 vals constraints instance slot) (unsuspend-trace)))
	  (t (km-trace 'comment "Enforcing constraints ~a" constraints)
	     (enforce-constraints0 vals constraints :target target))))

;;; ******* 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
(defun enforce-constraints0 (vals constraints &key target)
; ENFORCEMENT VERSION
;  (enforce-set-constraints
;   (remove-if-not #'(lambda (val) (enforce-val-constraints val constraints slot)) vals)		; revised vals
;   constraints))
  (let* ((slot (second target))
	 (instance (fourth target))
	 (special-slot-type (cond ((remove-subsumers-slotp slot) 'remove-subsumers-slot)
				  ((remove-subsumees-slotp slot) 'remove-subsumees-slot)))
	 (vals2 (enforce-set-constraints vals constraints :target target))
	 (vals-to-keep (remove-if-not #'(lambda (val) ; [1]
					  (enforce-val-constraints val constraints special-slot-type :target target))
				      vals2))
	 (vals-to-drop (set-difference vals2 vals-to-keep)))
    (cond
     (*remove-violating-instances*
      (cond (target (mapc #'(lambda (val-to-drop) 
			      (delete-val instance slot val-to-drop))
			  vals-to-drop)))
      vals-to-keep)
     (t vals2))))

; 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))
  
(defun enforce-val-constraints (val constraints special-slot-type &key target)
  (let ((slot (second target))
	(instance (fourth target)))
    (and val (every #'(lambda (constraint) 
			(or (not (val-constraint-exprp constraint))
			    (enforce-val-constraint val constraint instance slot special-slot-type)
			    (report-error 'user-error 
					  `(|val-constraint| ,instance ,slot ,val ,constraint)
					  "Constraint violation! Value ~a conflicts with ~a!~%"
					  val constraint)))
		    constraints))))

;;; RETURNS: non-nil OR NIL if there's an error in the enforcement
;;; 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.
;;; [5] Add target, to allow recording of explanation
(defun enforce-val-constraint (val constraint0 instance slot special-slot-type)
 (declare (ignore slot))
 (let ((constraint (desource+decomment constraint0)))
  (case (first constraint)
    (#$retain-expr t)
    (#$must-be-a (cond ((instance-of val '#$Aggregate) ; NB constraints on the aggregates elements should be implemented at KB, not KM, level. Here we only do a test, not an enforcement
;			(let ( (element-type (km-int `#$(the element-type of ,VAL))) )
			(let ( (element-type (cond ((not (km-structured-list-valp val))		; NEW ADDED TEST
						    (km-int `#$(the element-type of ,VAL))))) )
			  (or (null element-type)
			      (compatible-classes :classes1 element-type :classes2 (list (second constraint))))))
										; ignore any "with ..." part, as 
										; disjoint-class-sets can't handle it.
		       ((equal constraint '#$(must-be-a Thing)) val)
;		       (t (km-int `#$(,VAL & (a ,@(REST CONSTRAINT))) :target `#$(the ,SLOT of ,INSTANCE)))))  ; [5]
; REVISION: (a <x>) constraint should be applied to the (instance instance-of <x>) link, not (instance slot val) link.
; This is implemented now as a separate record-explanation-for sep in in process-km1-result.
		       (t (km-int `#$(,VAL & (a ,@(REST CONSTRAINT0)))))))	; NOTE *KEEP* source info here
    (#$mustnt-be-a (km-int `#$(not (,VAL is '(a ,@(REST CONSTRAINT0))))))
;    (<> (cond ((is-km-term (second constraint))
;	       (cond ((not (equal val (second constraint)))		; check constraint
;	      (t (km-int `#$(,VAL /= ,(SECOND CONSTRAINT))))))
    (<> (km-int `#$(,VAL /== ,(SECOND CONSTRAINT))))
    (#$excluded-values 
     (let ( (excluded-values (km-int (vals-to-val (rest constraint)))) )		; [1]
       (cond 
	((null excluded-values))
	((eq special-slot-type 'remove-subsumers-slot)		; #$instance-of	;val=Animal, excluded-values=(Tiger) OK
	 (not (intersection (all-superclasses0 val) excluded-values)))		;val=Tiger, excluded-values=(Animal) NOT OK
	((eq special-slot-type 'remove-subsumees-slot)	; [4]	; #$subclasses	;val=Animal, excluded-values=(Tiger) NOT OK
	 (not (intersection (all-subclasses0 val) excluded-values)))		;val=Tiger, excluded-values=(Animal) OK
	((member val excluded-values) nil)			; test it
	(t (mapcar #'(lambda (excluded-value)			; assert it
		       (add-val val '/== excluded-value))
		   excluded-values)))))
    (#$possible-values 
     (let ( (possible-values (km-int (vals-to-val (rest constraint)))) )		; [3]
       (cond 
	((null possible-values))				; [3] - Not necc. failure -- could fail due to looping!

;; The below is rather obtuse code to handle a special case something like:
;;			    (_Car1 has (instance-of ((possible-values Car Truck))))
	((and (eq special-slot-type 'remove-subsumers-slot) instance) ; instance /= nil
	 (cond ((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))
		(km-int `(,instance == (#$a ,(first possible-values)))))
	       (t (let ( (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))
			   (km-int `(,instance == (#$a ,(first unifiable-values)))))
			  (unifiable-values t))))))		; if some unifiable values, constraint is satisfied
	((member special-slot-type '(remove-subsumers-slot remove-subsumees-slot))	; '#$instance-of
	 (not (disjoint-class-sets (list val) possible-values)))

	((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))
	 (km-int `(,val == ,(first possible-values))))
	(t (let ( (new-constraint `#$(possible-values ,@POSSIBLE-VALUES))
		  (unifiable-values (first-N-unifiable-values possible-values val 2)) )
;	     (km-format t "unifiable-values = ~a~%" unifiable-values)
	     (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))
		    (km-int `(,val == ,(first unifiable-values))))
		   ((not (null unifiable-values))
		    (or (member new-constraint (get-vals val '== :situation *global-situation*) :test #'equal)
			(km-int `#$(,VAL has (== (,NEW-CONSTRAINT))) :fail-mode 'error)))))))))		; assert it
    (#$constraint (let ((constraint-expr (subst val '#$TheValue (second constraint))))
		    (cond ((looping-on constraint-expr) t) ; Don't abort if looping!
			  (t (km-int constraint-expr)))))
;   (#$override t)
    (#$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) (km-int `(,val &? ,possible-value))) possible-values)
(defun first-N-unifiable-values (possible-values val n)
  (cond ((endp possible-values) nil)
	((<= n 0) nil)
	((km-int `(,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))))

(defun first-N-unifiable-values2 (possible-values instance n)
  (cond ((endp possible-values) nil)
	((<= n 0) nil)
	((km-int `(,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)))))

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

(defun enforce-set-constraints (vals constraints &key target)
  (enforce-set-constraints0 (remove-pending-equalities vals) constraints :target target))

#| Remove pending equalities for this problem:
(a DNA-elongation) gives a wrong KM error:
     DNA1 &! DNA2
       (has-part (x y))  (has-part (a b))
   -> looping: Assuming (y &! b) to prove (y &! b)
   <-  has-part (x y b)		; NOTE: The assumption doesn't actually *do* the (y &! b), so we don't get obvious duplicates in the results
       FAIL constraint (exactly 2 DNA-strand)
|#
(defun remove-pending-equalities (vals)
  (cond ((endp vals) nil)
	(t (let ((val (first vals)))
	     (cond ((some #'(lambda (val2) (pending-equality val val2)) (rest vals))
		    (remove-pending-equalities (rest vals)))
		   (t (cons val (remove-pending-equalities (rest vals)))))))))

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

(defun enforce-set-constraints0 (vals constraints &key target)
  (cond ((endp constraints) vals)
	((val-constraint-exprp (first constraints))		; skip these
	 (enforce-set-constraints0 vals (rest constraints) :target target))
	(t (enforce-set-constraints0 (enforce-set-constraint vals (first constraints) :target target)
				     (rest constraints) :target target))))

;;; Just do this reduced version. RETURN: the modified vals
(defun enforce-set-constraint (vals constraint0 &key target)
  (let* ((constraint (desource+decomment constraint0))
	 (slot (second target))
	 (instance (fourth target))
	 (forced-class (or (minimatch1 constraint '#$(at-most 1 ?class)) 	
			   (minimatch1 constraint '#$(exactly 1 ?class))))
	 (vals-in-class (cond (forced-class (remove-if-not #'(lambda (val) (isa val forced-class)) vals)))) )
    (cond ((eq constraint '#$:incomplete) vals)		; ignore this flag
          ((> (length vals-in-class) 1)	; necc. 0 if no forced class
	   (cond 
	    ((every #'(lambda (pair) (km-int `(,(first pair) &? ,(second pair)))) (all-adjacent-pairs vals))
	     (make-comment "Unifying values ~a (forced by constraint (at-most 1 ~a)"
			   vals-in-class forced-class)
	     (cons (km-unique-int (vals-to-&-expr vals-in-class) :fail-mode 'error)
		   (ordered-set-difference vals vals-in-class)))
	    (t (report-error 'user-error
			     `(|set-constraint| ,instance ,slot ,vals-in-class ,constraint)
;			     "set-constraint violation!~%Found ~a ~a(s), but should be (at-most 1 ~a) and they can't be unified!~%Values were: ~a. Ignoring extras...~%" 
			     "set-constraint violation!~%Found ~a ~a(s), but should be (~a 1 ~a) and they can't be unified!~%Values were: ~a.~%"
			     (length vals-in-class) forced-class (cond ((minimatch1 constraint '#$(at-most 1 ?class)) '#$at-most)
								       ((minimatch1 constraint '#$(exactly 1 ?class)) '#$exactly)
								       (t '#$??))
			     forced-class vals)
	       vals)))
	  (t (enforce-set-constraint2 vals constraint :target target)))))

;;; PROBLEMS! see test-suite/outstanding/enforcement-problem.km
;;; Simplified to just do the test and report on the problems
(defun enforce-set-constraint2 (vals constraint &key target)
  (let* ((slot (second target))
	 (instance (fourth target))
	 (n (second constraint))
	 (class (third constraint))
	 (count (length (remove-if-not #'(lambda (val) (isa val class)) vals))))
    (case (first constraint)
	  (#$at-least (cond ((or (> n *max-padding-instances*)
				 (>= count n)) vals)		; avoid (at-least 3455 Gene)
			    (t (append vals (loop repeat (- n count) 
						collect (km-unique-int `#$(a ,CLASS) :fail-mode 'error)))))) ; classes missing so create them!!
	  (#$exactly (cond ((= count n) vals)
			   ((> count n)	;  no, you can always unify instances to get the desired # :-(
			    (report-error 'user-error
					  `(|set-constraint| ,instance ,slot ,vals ,constraint)
			     "set-constraint violation!~%Found ~a ~a(s), but should be exactly ~a!~%Values were: ~a.~%" 
			       count class n vals)
; If *error-report-silent*, then this is the continuing behavior...
			    (cond (*remove-violating-instances*
				   (remove-if #'(lambda (val) 
						  (cond ((isa val class)
							 (cond (target (delete-val instance slot val))) ; Inverse may already
							 t))) ; be asserted so must delete also
					      vals))
				  (t vals)))
			   ((> n *max-padding-instances*) vals) ; avoid (at-least 3455 Gene) - (< count n) is necc. true
			   (t (append vals (loop repeat (- n count) 
					       collect (km-unique-int `#$(a ,CLASS) :fail-mode 'error)))))) ; classes missing so create them!!
	  (#$at-most (cond ((<= count n) vals)
			   (t (report-error 'user-error 
					    `(|set-constraint| ,instance ,slot ,vals ,constraint)
					    "set-constraint violation!~%Found ~a ~a(s), but should be at-most ~a!~%Values were: ~a.~%"
					    count class n vals)
			      (cond
			       (*remove-violating-instances*
				(remove-if #'(lambda (val) 
					       (cond ((isa val class)
						      (cond (target (delete-val instance slot val))) ; Inverse may already
						      t))) ; be asserted so must delete also
					   vals))
			       (t vals)))
			   ))
	  (#$set-constraint (cond ((km-int (subst (vals-to-val vals) '#$TheValues (second constraint))) vals)
				  (t (report-error 'user-error 
						   `(|set-constraint| ,instance ,slot ,vals ,constraint)
						   "set-constraint violation!~%~a failed test ~a.~%" 
						   vals (second constraint))
				     vals)))
	  (#$sometimes t)
	  (#$set-filter (let* ((filter (second constraint))
			       (vals-to-keep (apply filter (list vals))) ; return modified list of vals
			       (vals-to-drop (set-difference vals vals-to-keep)))
			    (cond
			     (*remove-violating-instances*
			      (cond (target (mapc #'(lambda (val-to-drop) 
						      (delete-val instance slot val-to-drop))
						  vals-to-drop)))
			      vals-to-keep)
			     (t vals))))
			   
	  (t (report-error 'user-error "Unrecognized form of set constraint ~a~%" constraint)
	     vals))))


;;; ======================================================================
;;;		VIOLATED-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).

(violated-set-constraints '#$((_Car1 _Car2) (_Car2) ( ((a Car)) ((a House) (a Dog)) ) )  '#$((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!
|#

;;; Returns the first constraint violated (or NIL if all passed)
;;; For now, we only work with the vs1 and vs2. These are necessarily atomic
(defun violated-set-constraints (expr-sets constraints0)
  (let ((constraints (remove '#$:incomplete constraints0)))
    (some #'(lambda (constraint) 
	      (case (first constraint)
		(#$at-least nil)
		(#$(exactly at-most) (violated-cardinality-constraint expr-sets constraint))
;		(#$set-constraint (not (km-int (subst (vals-to-val vals) '#$TheValues (second constraint)))))			
		(#$set-constraint (not (km-int (subst (vals-to-val (valsets-to-&&-exprs expr-sets)) '#$TheValues (second constraint)))))
		(#$sometimes nil)
		(#$set-filter nil)		 
; No, constraints might include value constraints also		
;		(t (report-error 'user-error "Unrecognized form of set constraint ~a~%" constraint) nil)
		))
	  constraints)))

;;; [1] NOTE: There is a special case if N = 1, namely all the elements of all the expr-sets must be unifiable together.   
(defun violated-cardinality-constraint (expr-sets constraint)
  (cond ((null expr-sets) nil)		; quick lookahead
	((and (singletonp expr-sets)
	      (<= (length (first expr-sets)) (second constraint))) nil) ; quick lookahead
	((and (eq (third constraint) '#$Thing)
	      (<= (length (remove-duplicates (remove-if #'constraint-exprp (apply #'append expr-sets)))) (second constraint))) 
;	 (km-format t "list = ~a~%" (remove-duplicates (remove-if #'constraint-exprp (apply #'append expr-sets))))
	 nil)		; lookahead
	(t (let* ((n (second constraint))
		  (class (third constraint)) ; Nucleus  
		  (expr-sets-in-class (remove nil (mapcar #'(lambda (exprs) (extract-exprs-in-class exprs class)) expr-sets)))
		  (exprs-in-class (remove-duplicates (apply #'append expr-sets-in-class) :test #'equal)))	; #'equal ok? (a Atom) (a Atom) I think so
	     (cond
	      ((<= (length exprs-in-class) (second constraint)) nil)
	      (t (let ((non-unifiable-pairs (non-unifiable-pairs exprs-in-class)))
		   (cond ((< (length non-unifiable-pairs) n) nil)			; e.g., n = 2, so 1 bad pair is ok but 2 may not be
			 ((eq n 1) (list constraint (remove-duplicates (apply #'append non-unifiable-pairs) :test #'equal))) ; must all be unif if n = 1
			 (t (let ((groups (group-vals-unifiably exprs-in-class non-unifiable-pairs)))
			      (cond ((> (length groups) n)
				     (list constraint (remove-duplicates (apply #'append non-unifiable-pairs) :test #'equal))))))))))))))


;;; (group-vals-unifiably '(a b c d e) '((a b) (c d) (a c))) -> (a d e) (b c))
(defun group-vals-unifiably (vals non-unifiable-pairs)
  (group-vals-unifiably0 vals nil non-unifiable-pairs))

(defun group-vals-unifiably0 (vals groups-so-far non-unifiable-pairs)    
  (cond
   ((endp vals) groups-so-far)
   (t (let* ((val (first vals))
	     (new-groups (add-val-to-group val groups-so-far non-unifiable-pairs)))
	(group-vals-unifiably0 (rest vals) new-groups non-unifiable-pairs)))))

(defun add-val-to-group (val groups non-unifiable-pairs)
  (cond 
   ((null groups) (list (list val)))
   (t (let ((group (first groups)))
	(cond ((notany #'(lambda (group-val)
			   (or (member (list val group-val) non-unifiable-pairs :test #'equal)
			       (member (list group-val val) non-unifiable-pairs :test #'equal)))
		       group)
	       `((,val ,@group) ,@(rest groups)))
	      (t (cons group (add-val-to-group val (rest groups) non-unifiable-pairs))))))))

;;; ======================================================================
;;;		OLD APPROACH - doesn't handle (x x x (at-most 2 x))
;;; ======================================================================
#|
The old approach was abandoned from this motivating example in Biology-KB-v224.fkm:

(a DNA-elongation) gives a wrong KM error:
     DNA1 &! DNA2
       (has-part (x y))  (has-part (a b))
   -> looping: Assuming (y &! b) to prove (y &! b)
   <-  has-part (x y b)		; NOTE: The assumption doesn't actually *do* the (y &! b), so we don't get obvious duplicates in the results
       FAIL constraint (exactly 2 DNA-strand)
I think we need to relax the constraint check to allow unifiability.
|#

#|
;;; [1] NOTE: There is a special case if N = 1, namely all the elements of all the expr-sets must be unifiable together.   
(defun violated-cardinality-constraint (expr-sets constraint)
  (cond ((null expr-sets) nil)		; quick lookahead
	((and (singletonp expr-sets)
	      (<= (length (first expr-sets)) (second constraint))) nil) ; quick lookahead
	((and (eq (third constraint) '#$Thing)
	      (<= (length (remove-duplicates (remove-if #'constraint-exprp (apply #'append expr-sets)))) (second constraint))) 
;	 (km-format t "list = ~a~%" (remove-duplicates (remove-if #'constraint-exprp (apply #'append expr-sets))))
	 nil)		; lookahead
	(t (let* ((n (second constraint))
		  (class (third constraint)) ; Nucleus  
		  (expr-sets-in-class (remove nil (mapcar #'(lambda (exprs) (extract-exprs-in-class exprs class)) expr-sets))))
	     (cond
	      ((<= (length (remove-duplicates (apply #'append expr-sets-in-class))) (second constraint)) nil)
	      (t (let ((bad-pair (some-are-not-unifiable (apply #'append expr-sets-in-class))))
		   (cond ((null bad-pair) nil)			; everything's unifiable, so don't need to go further!
			 ((eq n 1) (list constraint bad-pair))	; failure, so stop
			 (t (violated-cardinality-constraint1 	; more sophisticated computation
			     (mapcar #'list (first expr-sets-in-class)) (rest expr-sets-in-class) constraint))))))))))
|#

(defun extract-exprs-in-class (exprs class)
  (remove-if-not #'(lambda (expr)
		     (cond ((existential-exprp expr)
			    (is-subclass-of (class-in-existential-expr expr) class))
			   ((fully-evaluatedp expr)
			    (isa expr class)))) ; includes numbers, sequences, etc.
		 exprs))

;;; Return a pair of ununifiable objects, if there are any
; (defun some-are-not-unifiable (vals)
;   (find-if #'(lambda (pair) (not (simple-unifiable (first pair) (second pair)))) (all-pairs vals))) ; or (all-adjacent-pairs <vals>) for speed

(defun non-unifiable-pairs (vals)
  (remove-if #'(lambda (pair) (simple-unifiable (first pair) (second pair))) (all-pairs vals))) ; or (all-adjacent-pairs <vals>) for speed

#|
INPUTS: 
   constraint = (exactly N Class) or (at-most N Class)
   expr-sets = a set of sets that are to be unified together AND are all deemed to be in Class, e.g., ((_Atom1 _Atom2) (_Atom3) (_Atom4 _Atom5 _Atom6))
   combined: We gradually construct a representation of the && of the expr-sets, = a list where each element is a LIST of the unifiable entities, e.g.,
   	((_Atom1 & _Atom3) (_Atom2))
   However, for simplicity we don't include the "&" and just represent the list:
   	((_Atom1 _Atom3) (_Atom2))
   The length of the list = the expected length of the unification of the elements.
   Initially, combined = the listification of the FIRST entry in expr-sets, i.e., 
   	((_Atom1) (_Atom2))
   We then add to it.
RETURNS: (constraint vals) where vals is a subset of the values in expr-sets which violates constraint (and will then be reported to the user)

NOTE: There is a special case if N = 1, namely all the elements of all the expr-sets must be unifiable together, see [1] above

(defun violated-cardinality-constraint1 (combined expr-sets constraint)
  (let ((n (second constraint)))
    (cond ((> (length combined) n) (list constraint (apply #'append combined))) ; violated!
	  (expr-sets
	   (let* ((exprs (first expr-sets))
		  (all-pairs (permute (list combined exprs))) ;(permute '((a b c) (d e)))->((a d) (a e) (b d) (b e) (c d) (c e))
		  (scored-pairs (remove nil 
					(mapcar #'(lambda (pair) 
						    (sc-score-pair (first pair) (second pair)))
						all-pairs)))
		  (ordered-scored-pairs (sort scored-pairs #'> :key #'third))
		  (new-combined (select-pairings ordered-scored-pairs combined exprs)))
	     (violated-cardinality-constraint1 new-combined (rest expr-sets) constraint))))))

;;; INPUT: xs = a list of to-be-unified objects (_Atom1 & _Atom2)
;;;      	For simplicity, we represent this just as (_Atom1 _Atom2)
;;;        y = another entity, e.g., _Atom3, that we'd like to add to the list.
;;; RETURNS: either a score for how "good" the unification would be, or NIL if it can't be done.
;;;      NOTE: We don't do a full &? test, but rather just test there are no violated constraints (partitions or /==).
;;;      Thus this is an "optimistic" guestimate about the unifiability of y into xs.
(defun sc-score-pair (xs y)
  (let ((scores (mapcar #'(lambda (x) (simple-unifiable x y)) xs)))
    (cond ((member nil scores) nil)	; some x and y are incompatible
	  (t `(,xs ,y ,(apply #'max scores))))))
|#

;;; INPUT: Two s-exprs
;;; RETURNS: either a score for how "good" the unification would be, or NIL if it can't be done.
(defun simple-unifiable (x y)
  (cond ((equal x y) 100)
	((and (atom y)
	      (atom x) 
	      (incompatible-instances x y))
	 nil)
	(t (let* ((x-classes (cond ((kb-objectp x) (immediate-classes x))
				   ((existential-exprp x) (listify (class-in-existential-expr x)))))
		  (y-classes (cond ((kb-objectp y) (immediate-classes y))
				   ((existential-exprp y) (listify (class-in-existential-expr y))))))
	     (cond ((and x-classes y-classes (not (compatible-classes :classes1 x-classes :classes2 y-classes))) nil)
		   ((set-equal x-classes y-classes) 60)
		   ((intersection x-classes y-classes) 30)
		   ((some #'(lambda (x-class) 
			      (some #'(lambda (y-class)
					(or (is-subclass-of x-class y-class)
					    (is-subclass-of y-class x-class)))
				    y-classes))
			  x-classes)
		    10)
		   (t 5))))))

#|
;;; vs1 is actually a list of lists
;;; RETURNS: ( <proposed bindings of V1s & V2s elements> <remainder of V1s and V2s> )
;;; Match up V1s = (x) with V2s = (y z).   (x y) has a higher score for a pairing
;;; e.g., (select-pairings (((x) y 60) ((x) z 10)) ((x)) (y z) )  -> ((x y) (z))
;;; NOTE: It won't check within-slot unifications, e.g., (y & z) will not be considered.
(defun select-pairings (ordered-scored-pairs vsets1 vs2)
  (cond
   ((endp ordered-scored-pairs) (append vsets1 (mapcar #'list vs2)))
   (t (let* ((best-pair (first ordered-scored-pairs))
	     (vs1 (first  best-pair))		; (x)
	     (v2 (second best-pair)))		; y
	(cond
	 ((and (member vs1 vsets1)		; not already done
	       (member v2 vs2))
	  `((,@vs1 ,v2)
	    ,@(select-pairings (rest ordered-scored-pairs) (remove vs1 vsets1 :test #'equal :count 1) (remove v2 vs2 :test #'equal :count 1))))
	 (t (select-pairings (rest ordered-scored-pairs) vsets1 vs2)))))))
|#
;;; ======================================================================

;;; USED only once by km-slotvals-from-kb in get-slotvals.lisp
;;; INPUT: An expr-set
;;; RETURNS: The expression set with (:default <expr>) statements removed, replaced with either
;;;	     the evaluation of <expr> or NIL depending on whether the evaluation is consistent with constraints or not
(defun evaluate-and-filter-defaults (expr-set constraints curr-vals slot &key single-valuedp)
  (cond ((some #'km-defaultp expr-set)
	 (mapcan #'(lambda (expr)
		     (cond ((km-defaultp expr)
			    (let* ( (vals (km-int (second expr)))
				    (new-vals (cond ((and single-valuedp curr-vals vals 
							  (not (km-int `(,(first curr-vals) &? ,(first vals)))))
						     nil)
						    (t (remove-if-not #'(lambda (val) 
									  (are-consistent-with-constraints (append curr-vals (list val))
													   (dereference constraints)
													   slot))
								      vals)))) )
			      (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)))


;;; ======================================================================
;;;		TOGGLING THE CONSTRAINTS
;;; ======================================================================

(defun sanity-checks () 
  (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))

(defun no-sanity-checks () 
  (cond ((not *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
(defun pair-filter (vals &optional selected-so-far)
  (cond ((endp vals) nil)
	(t (let* ( (pair (first vals)) 
		   (units (arg2of pair)) )
	     (cond ((or (not (km-pairp pair))
			(notany #'(lambda (selected-pair)		; not selected a pair in this unit yet
				    (eq (arg2of selected-pair) units))
				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

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

;;; These constraints are annotated with source info, but not other constraints
(defparameter *annotated-constraints* '#$(must-be-a exactly at-most at-least))
; (defparameter *subslot-comment-tag* '|[subslot-reasoning]|) - move to header.lisp as is used in get-slotvals.lisp
(defparameter *subslot-comment* 		; built-in comment tag
    '#$(comment [subslot-reasoning] "" 
		(:seq "The" TheSubslot "of" Value1 "=" Value2 ", and" TheSubslot "is a subslot of" TheSlot) 
		(:triple Value1 TheSubslot Value2)))

#|
TERMINOLOGY:
A COMMENT is a tag [cat], converted internally to (comm [cat] Self), denoting a comment tag for
	explanation purposes. 
        Special case: for subslot queries, the internal comment tag form has an extra argument: (comm [subslot-reasoning] Self <subslot>), see get-slotvals.lisp
A SOURCE is a structure (@ _Car1 Car parts Engine), embedded in an expression as the LAST element, denoting the frame
	where the expression originally came from.

Both COMMENTS and SOURCES are embedded WITHIN KM expressions, e.g,
	(a Engine [cat])	
	(a Engine (@ _Car1 Car parts))
	(*engine2 [cat])
	(*engine2 (@ _Car1 Car parts))	

;;; ======================================================================	

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.

   NOTE:
   STORING explanations for (f s v) are put just under f.
   (setf f 'explanation-<situation> ((f s1 v1 exp11) (f s1 v1 exp12) ... (f s2 v2 expn21) (f s2 v2 expn22)...))

   RETRIEVING explanations for (f s v) will LOOK in both f and v for (f s v) and (v inverse-s f) respectively.

   An example of the explanation structure on the property list is:
   (get '#$_Drive-With-Passenger1 'explanation) ->
     ((_Drive-With-Passenger1 instance-of Drive-With-Passenger (cloned-from _Drive-With-Passenger6 _Drive-With-Passenger1))
      (_Drive-With-Passenger1 object _Car3 (cloned-from _Drive-With-Passenger6 _Drive-With-Passenger1))
      (_Drive-With-Passenger1 object _Car3 (cloned-from _Drive3 _Drive-With-Passenger1))
      (_Drive-With-Passenger1 instance-of Drive (cloned-from _Drive3 _Drive-With-Passenger1))
      )

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 ISV-MULTI-EXPLANATIONS for this triple.
   An isv-explanation has one of these two structures:
		 (instance slot val (<explanation>*))
		 (val invslot instance (<explanation>*))
   [ **NOTE** The *internal* storage are individual entries (instance slot val <explanation>) - no list ]

   3/17/08: This seems slightly arcane to include both forward and backward directions. However, there's one
   type of explanation which is directional, namely the (every X has ....) explanations. We could add a flag
   to show the directionality, e.g.,
	   (explanation (:triple _Control1 object _Device2)    ((a Device (@ _Drive1 Control object))))
           (explanation (:triple _Device2 object-of _Control1) ((inverse (a Device (@ _Drive1 Control object)))))
   
   where <explanation> is one of the KM expressions deriving the triple, with FOUR different possible forms:
     - (cloned-from _ProtoDrive1 _Drive1 _ProtoCar1)   ; cloned from _ProtoCar1 in _ProtoDrive1 to _Drive1
     - (added-at Drive-With-Passenger "Here's my comment")  ; manually added
     - (projected-from _Situation3)
     - The first element of a traditional KM expr, which could be anything eg.:
          (a Device (@ _Drive1 Control object))		    ; traditional (every Control has (object ((a Device))))
	  (1 + 1)
	  ((a Dog))					    ; if user accidentally put too many parentheses
	  (retain-expr (a Old))

NOTE: 
  get-explanations AGGREGATES (i s v expln1) (i s v expln2) ... into (i s v expln*)
  (get-all-explanations instance slot) & (get-explanation-data instance) does NOT aggregate the explanations together.

  NOTE: We'll call the structure returned by get-all-explanations ISV-EXPLANATIONS to make the distinction.

  - (get-comments <explanation>)

   GIVEN <explanation>, 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.
|#
; Moved to interpreter.lisp
;(defvar *patterns-to-annotate* 
;    '#$(((the ?x of ?y) (?y))
;	((the ?x ?y of ?z) (?z))))

;;; (explanation-type <explanation>) -> #$added-at, #$cloned-from, #$projected-from, or the first element of a KM expr
(defun explanation-type (explanation) (first explanation))

;;; (explanation-in '(f s v explanation)) -> explanation
;;; (explanations-in '(f s v explanations)) -> explanations
(defun explanation-in (isv-explanation) (fourth isv-explanation)) 		; returned by get-all-explanations
(defun explanations-in (isv-multi-explanation) (fourth isv-multi-explanation))	; returned by get-explanations

;;; (explanation-in '(f s v explanation)) -> (f s v)
(defun triple-in (isv-explanation) (subseq isv-explanation 0 3))

;;; ======================================================================
;;;		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) 
;  (desource+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!
|#
(defun sourcep (tag)
 (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
;(defun source-path (source) (rest source))
(defun source-path (source) (rest (rest source)))	; revised

;;; Find the class of origin - backwards compatible with Shaken
;(defun originated-from-class (source) (second source))
(defun originated-from-class (source) (third source))

(defun inherited-to-instance (source) (second source)) ; new!

#|
8/2/08 - I don't *THINK* this can ever be more than one class (?)
Find classes of origin: NOTE: argument is an EXPRESSION not a SOURCE (different to originated-from-class)
INPUT: expr is an element of the list returned by (get-explanations1 f s v). Three types:
  - (cloned-from _Drive3 _Drive1) 			 ; cloned from protoype _Drive3
  - (a Device (@ _Drive1 Control object))		 ; traditional (every Control has (object ((a Device))))
  - (added-at Drive-With-Passenger "Here's my comment")  ; manually added
  - (projected-from _Situation3)
|#
(defun originated-from-classes (expr)
  (cond ((and (eq (explanation-type expr) '#$cloned-from)
	      (known-frame (third expr)))	; NEW: If node leading to triple is deleted, skip the originating class
	 (let ((source-protoroot (second expr)))
;	   (km-int `#$(the classes of ,SOURCE-PROTOINSTANCE))
;	   (immediate-classes source-protoroot)))
	   (prototype-classes source-protoroot))) ; NOTE: immediate-classes may contain redundant classes in AURA
						  ;       as *built-in-remove-subsumers-slots* = nil
	((eq (explanation-type expr) '#$added-at) ; (added-at '#$MyClass <comment>)  is an expln
	 (list (second expr)))
	((eq (explanation-type expr) '#$projected-from) nil)
	(t (mapcar #'originated-from-class (sources expr)))))

;;; Cat -> [@Cat]
;;; NEW: Include Self so we can track the instance inheriting the expression
;(defun make-source (class) (list '@ class))
(defun make-source (class) (list '@ '#$Self class))

(defun add-to-source (source item) (append source (list item)))

;;; DESOURCE - removes sources
;;; Neah, parenthesizing and deparenthesizing causes too many problems.
;;; Just refuse to parenthesize stuff in the first place.
;;; [1] (desource '(a Wheel with (position ((front (@ Car has-part Wheel position)))))
;;; should go to (a Wheel with (position ( front )))
;;;          not (a Wheel with (position ((front))))
;;; [2] Unusual to have a null :seq but possible (and is in rkf-clib-one.km)
(defun desource (expr) 
  (cond ((delistifiable-sourced-pairp expr)
	 (desource (first expr)))
        ((listp expr)
;	      (or *record-explanations* *record-sources*))	; assume is ALWAYS true
	 (remove-if #'sourcep (mapcar #'desource expr)))
	(t expr)))

; OLD: - well, may was well keep this as it simplifies the expressions a little
; [1] Special case: we DO allow freestanding comments on instance-of,
; so want (instance-of (Car [comm1])) -> (instance-of (Car)), not (instance-of Car)
; [2] :nodelistification t:: ((x [com1]) && (y)) -> ((x) && (y)) NOT (x && (y))
(defun decomment (expr &key (no-delistification t))
  (cond ((and (delistifiable-commented-pairp expr)  
	      (not no-delistification))
	 (decomment (first expr)))
	((and (listp expr)
	      (eq (first expr) '#$instance-of)) ; [1]
	 (remove-if #'comment-tagp (mapcar #'(lambda (x) (decomment x :no-delistification t)) expr)))
        ((listp expr)
;	      (or *record-explanations* *record-sources*))	; assume is ALWAYS true
;	 (remove-if #'comment-tagp (mapcar #'decomment expr)))
	 (remove-if #'comment-tagp (mapcar #'(lambda (x) (decomment x :no-delistification t)) expr)))  ; [2]
	(t expr)))

#|
;;; REVISION:
;;; Unlike sources, comments can be freestanding and KM never adds parens to contain them, so we should never need
;;; to strip off those parens again.
(defun decomment (expr)
  (cond ((listp expr) (remove-if #'comment-tagp (mapcar #'decomment expr)))
	(t expr)))
|#

; OLD
;(defun desource (expr)
;  (cond ((and (listp expr)
;	      (or *record-explanations* *record-sources*))
;	 (remove-if #'sourcep (mapcar #'desource expr)))
;	(t expr)))

; in header.lisp
; (defparameter *developer-mode* nil)

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

;;; DESOURCE0 - removes sources AND converts comments back into the non-internal form for presentation purposes
;;; For my own debugging
(defun desource-for-printing (expr)
  (cond (*developer-mode* expr)
	(t (desource1 expr))))

;;; (desource1 '#$(comm [cat] _Cat3)) -> [cat]
(defun desource1 (expr)
  (cond ((listp expr)
	 (cond ((and (= (length expr) 3)			; (comm [cat] _Cat3) -> [cat]
		     (eq (first expr) '#$comm))
		(second expr))
	       ((delistifiable-sourced-pairp expr)
		(desource1 (first expr)))
	       (t (remove-if #'sourcep (mapcar #'desource1 expr)))))
	(t expr)))

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

(defun sources (expr) (cond ((listp expr) (remove-if-not #'sourcep expr))))

;;; ======================================================================
;;;		MANIPULATING COMMENTS
;;; ======================================================================

(defconstant *comment-marker-char* #\[)

(defun comment-tagp (tag) 
  (or (internal-commentp tag) 
      (user-commentp tag)))

(defun comment-or-sourcep (tag) 
  (or (internal-commentp tag) 	; (comm [cat] Self)
      (sourcep tag)		; (@ _Car1 Cat parts)
      (user-commentp tag)))	; [cat]

;;; e.g., (comm [cat] Self)
(defun internal-commentp (tag)	
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))  ; optimized by Francis Leboutte
  (and (listp tag)
       (eq (first tag) '#$comm)))

;(defun user-commentp (tag) (and (symbolp tag) (char= (first-char (symbol-name tag)) *comment-marker-char*)))
; Optimized by Francis Leboutte
; Extended by Sunil Mishra to include additional test for a closing ] as well as opening [
(defun user-commentp (tag)
   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
   (and (symbolp tag)
        (let ((name (symbol-name tag)))
         (and (char= (schar name 0) #\[)
              (char= (schar name (1- (length name))) #\])))))


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

;;; Only applied to slotsvals at load time, not to anything else
(defun convert-comments-to-internal-form (expr &optional (self '#$Self))
  (cond ((internal-commentp expr) expr)		; avoid repeatedly doing this
        ((user-commentp expr) (convert-comment-to-internal-form expr self))
	((listp expr) (mapcar #'(lambda (e) (convert-comments-to-internal-form e self)) expr))
	(t expr)))

;;; [Car1] -> (comm [Car1] Self)
(defun convert-comment-to-internal-form (user-comment &optional (self '#$Self))
  `(#$comm ,user-comment ,self))

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

; Less efficient implementation; improved version below thanks to Sunil Mishra.
;(defun desource+decomment (expr &key retain-commentsp)
;  (cond ((and (listp expr) 
;	      (not retain-commentsp))
;	 (remove-if #'comment-or-sourcep (mapcar #'desource+decomment expr)))
;	(t expr)))

;;; desource+decomment: DECOMMENTS *AND* DESOURCES
;;; USER(3): (desource+decomment '(cat [1] (dog [3] ([4] [45] man))))
;;; (cat (dog (man)))
;;; [1] :delistifyp NEW RULE: If remove a comment/source AND the result is a singleton list THEN delistify.
;;; 	(desource+decomment '(a Man with (size (((a [2] Large)))) [1])) -> (a Man with (size (((a Large)))))
;;; 	(desource+decomment '(a Man with (size (([2] *large))) [1])) -> (a Man with (size (*Large)))
;;; The one exception to this is comments on the top-level of instance-of slots, where comment tags ARE allowed
;;; to be "naked".
;;; NOTE: If retain-commentsp = t, then this function has NO EFFECT
(defun desource+decomment (expr &key retain-commentsp (delistifyp t))
  (cond (retain-commentsp expr)
	(t (multiple-value-bind
	       (decommented-expr comment-foundp)
	       (desource+decomment1 expr)
	     (cond ((and delistifyp
			 comment-foundp 
			 (not (km-structured-list-valp expr))
			 (not (eql (first expr) '#$no-inheritance))) ; no longer used, but must stay listified
		    (delistify decommented-expr)) ; (*cat [1]) -> *cat not (*cat)
		   (t decommented-expr))))))

;;; [1] (desource+decomment '#$(instance-of (Thing [cat]))) -> (instance-of (Thing))   (*don't* delistify (Thing))
(defun desource+decomment1 (expr)
  (declare (optimize (speed 3) (safety 0)))
  (cond ((null expr) nil)
	((listp expr)
	 (let ((car-expr (car expr))
	       (cdr-expr (cdr expr)))
	   (cond ((comment-or-sourcep car-expr)
		  (values (desource+decomment1 cdr-expr) t))
		 ((and (pairp expr)
		       (eq car-expr '#$instance-of))	; Special case: DO allow freestanding comments on instance-of
;		  (km-format t "here! cdr-expr = ~a~%" cdr-expr)
		  (list car-expr (desource+decomment1 (first cdr-expr)))) ; [1] desource+decomment1 DOESN'T delistify
		 (t (let ((car-result (desource+decomment (car expr))))
		      (multiple-value-bind
			  (cdr-result comment-foundp)
			  (desource+decomment1 (cdr expr))
			(if (and (eql car-result (car expr))
				 (eql cdr-result (cdr expr)))
			    expr
			  (values (cons car-result cdr-result) comment-foundp))))))))
	(t expr)))

;;; Much simpler: (decomment-list #'(Engine [Engine-1])) -> (Engine).
;;; Used for removing comments from instance-of slot-values. (There are no sources on instance-of links)
;(defun decomment-list (list) (remove-if #'comment-tagp list))

#|
(defun desource+decomment (expr &key retain-commentsp)
  (declare (optimize (speed 3) (safety 0)))
   (if retain-commentsp
       expr
       (cond ((null expr) nil)
	    ((listp expr)
	     (let ((car-expr (car expr))
		   (cdr-expr (cdr expr)))
	       (if (comment-or-sourcep car-expr)
		   (desource+decomment cdr-expr)
		   (let ((car-result (desource+decomment (car expr)))
			 (cdr-result (desource+decomment (cdr expr))))
		     (if (and (eql car-result (car expr))
			      (eql cdr-result (cdr expr)))
			 expr
	               (cons car-result cdr-result))))))
	    (t expr))))
|#
;;; For the mistake of using extra parens, (Y has (slot ( ((a X)) ) rather than (Y has (slot ((a X))):
;;; [1] don't do ((a X (@ _Car2)) (@ _Car1)) -> (a X (@ Car2)), as then this will fail to match a handler and give
;;; a wierd message. Instead have it -> ((a X (@ Car2)))
(defun desource-top-level (expr)
  (cond ((delistifiable-sourced-pairp expr)
	 (desource-top-level (first expr)))
	((listp expr)
	 (remove-if #'sourcep expr))
	(t expr)))

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

#|
     (*black [comment1]) -> *black, not (*black)
 But (:seq [comment1]) -> (:seq)
 and (no-inheritance [comment1]) -> (no-inheritance)
 [1] (desource '(a Wheel with (position ((front (@ Car has-part Wheel position)))))
      should go to (a Wheel with (position ( front )))
          not (a Wheel with (position ((front))))
 [2] Unusual to have a null :seq but possible (and is in rkf-clib-one.km)
|#
(defun delistifiable-commented-or-sourced-pairp (expr)
  (and (pairp expr)			; [1]
       (comment-or-sourcep (second expr))
       (not (km-structured-list-valp expr)) ; note (:seq (@ p)) -> (:seq), not :seq [2]
       (not (eql (first expr) '#$no-inheritance)))) ; no longer used, but must stay listified  

(defun delistifiable-sourced-pairp (expr)
  (and (pairp expr)			; [1]
       (sourcep (second expr))
       (not (km-structured-list-valp expr)) ; note (:seq (@ p)) -> (:seq), not :seq [2]
       (not (eql (first expr) '#$no-inheritance)))) ; no longer used, but must stay listified  

(defun delistifiable-commented-pairp (expr)
  (and (pairp expr)			; [1]
       (comment-tagp (second expr))
       (not (km-structured-list-valp expr)) ; note (:seq (@ p)) -> (:seq), not :seq [2]
       (not (eql (first expr) '#$no-inheritance)))) ; no longer used, but must stay listified  

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

;;; NEW: (desource+decomment-top-level (*black (comm [Comment1] _Dog1))) -> *black, not (*black)
(defun desource+decomment-top-level (expr)
  (cond ((delistifiable-commented-or-sourced-pairp expr)
	 (first expr))
	((listp expr)
	 (remove-if #'comment-or-sourcep expr))
	(t expr)))

;;; Opposite - don't store all the embedded sources for the explanation database
;;; (a (b (@ x)) (@ y)) -> (a b (@ y))

(defun desource-all-but-top-level (expr)
  (cond ((listp expr) (mapcar #'desource expr))	
	(t expr)))

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

(defun get-comment-tags (expr)
  (cond ((listp expr) (remove-if-not #'comment-tagp expr))))

(defun get-comment-tags-recursive (expr)
  (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
(defun get-comments (expr)
  (cond ((listp expr)
	 (let* ( (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 (remove nil (first  explanations+justifications)) 
		   (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)))))))
;;; REMOVED: 12/19/07
;;; :ignore-constraintsp - any rule which comes from a must-be-a constraint is ignored (dropped).
(defun build-rule (expr0 &key ignore-constraintsp)
  (cond 
;  ((eq (explanation-type expr0) '#$every) expr0)			; [1]
   ((eq (explanation-type expr0) '#$cloned-from) expr0)
   ((eq (explanation-type expr0) '#$added-at) expr0)
   ((eq (explanation-type expr0) '#$projected-from) expr0)
   (t (let* ((source (first (sources expr0)))  ; should never be multiple sources, but just in case!
	     (expr (desource expr0))
	     (source-path (source-path source)))
	(cond 
	 ((and ignore-constraintsp (intersection *annotated-constraints* (flatten source-path) :test #'equal)) nil)
;	 ((and ignore-constraintsp (member '#$must-be-a (flatten source-path) :test #'equal)) nil)
	 ((or (null source-path)
	      (oddp (length source-path)))
	  (cond ((oddp (length source-path))
		 (report-error 'nodebugger-error "build-rule: Even path length for path ~a! Don't know how to build a rule...~%" source-path)))
	  (list '|<location unknown>| expr))
	 (t (build-embedded-val source-path expr :every-a '#$every :has-with '#$has)))))))
;	 (t `(#$every ,(first source-path) #$has (,(second source-path) (,(build-embedded-val (rest (rest source-path)) expr))))))))))

;;; Returns an (a ... with ...) structure
;;; e.g., (build-embedded-val '#$(Leg parts) '#$(a Toe)) -> (a Leg with (parts ((a Toe))))
(defun build-embedded-val (path expr &key (every-a '#$a) (has-with '#$with))
  (cond ((null path)
	 (cond ((and (eq every-a '#$must-be-a) (listp expr) (eq (first expr) '#$a)) ; (a Toe) -> (must-be-a Toe)
		`(#$must-be-a ,@(rest expr)))
	       (t expr)))
;	((and (listp (first path))	; REVISED
;	      (eq (first (first path)) '#$must-be-a))
;	 `(#$must-be-a ,(second (first path)) 
;	   		#$with (,(second path) (,(build-embedded-val (rest (rest path)) expr)))))
	(t (let* ((class (first path))
		  (slot0 (second path))
		  (must-be-a-p (and (pairp slot0) (eq (second slot0) '#$must-be-a))) ; e.g, (parts must-be-a)
		  (slot (cond (must-be-a-p (first slot0))
			      (t slot0))))
;	     (km-format t "slot0 = ~a~%" slot0)
;	     (km-format t "slot = ~a~%" slot)
	     `(,every-a ,class ,has-with
			(,slot (,(build-embedded-val (rest (rest path)) expr 
						     :every-a (cond (must-be-a-p '#$must-be-a) 
								    (t '#$a))))))))))

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

(defun comment (comment-tag data)
  (cond ((not (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)
	   (setf (get comment-tag 'comment) data))))

(defun show-comment (comment-tag)
  (cond ((not (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]| 'comment)
("a" "b" (:set (the part of Self)))

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

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

CL-USER(21): (get-comment2 '#$(comm [x] _Car1) 'exit)
"a"
|#
;;; [1] Should no longer arise -- *all* comments are converted to internal form
(defun get-comment (comment-tag)
  (cond ; ((user-commentp comment-tag) (get comment-tag 'comment)) ; [1]
	((internal-commentp comment-tag) 
	 (let ( (comment (get (second comment-tag) 'comment))
		(self (third comment-tag)) )
	   (bind-self 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
(defun get-comment2 (comment-tag mode)
  (cond ; ((user-commentp comment-tag) (get comment-tag 'comment)) [1]
	((internal-commentp comment-tag) 
	 (let* ((self (third comment-tag)) 
		(comments (cond ((eq (second comment-tag) *subslot-comment-tag*) (rest (rest *subslot-comment*)))
				(t (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 ...))
(defun km-assertion-expr (expr)
  (and (listp expr)
       (or (intersection expr '#$(a an some has has-definition now-has == &))	; new: add now-has (missed in 1.4.5.83)
	   (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...
(defun record-explanation-later (expr)
  (and *record-explanations*
       (or (and (km-setp expr)
	   	(notevery #'atom (rest expr)))			; if all atoms, then don't pass it further down
	   (and (listp expr)
		(unification-operator (second expr))))))
;		(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 (km-int '#$_Expose2), km-int *will* call km1 if '#$_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 (|the| |has-region| |of| |_Enzyme39|) |_Carboxyl-Terminus40|
                            (:|set| (|a| |Carboxyl-Terminus| (@ |Amino-Acid-Sequence| |has-region|))
                             (|a| |Amino-Terminus| (@ |Amino-Acid-Sequence| |has-region|))))
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

[4] 
KM> (every Car has (parts ((a Engine) (a Wheel))))
KM> (the parts of (a Car))
CL-USER(31): (get-explanation-data '#$_Car520)
((_Car520 parts _Wheel522 (a Wheel (@ _Car520 Car parts)))
 (_Car520 parts _Engine521 (a Engine (@ _Car520 Car parts))) 
 (_Car520 instance-of Car (a Car)))
CL-USER(32): (reset-done)
KM> (the parts of _Car520)	; same query
CL-USER(33): (get-explanation-data '#$_Car520)
((_Car520 parts _Wheel522 (:set _Engine521 _Wheel522)) 	; <------- we really don't want these new ones!
 (_Car520 parts _Engine521 (:set _Engine521 _Wheel522)) 	; <------- we really don't want these new ones!
 (_Car520 parts _Wheel522 (a Wheel (@ _Car520 Car parts)))
 (_Car520 parts _Engine521 (a Engine (@ _Car520 Car parts))) 
 (_Car520 instance-of Car (a Car)))

NOTE: record-explanation-for doesn't get called for unification (&, &&, etc.) operators -- in process-km1-result,
record-explanation-later is t for such expressions and hence record-explanation-for is postponed (and in fact
never gets called in the end for such exprs)
|#
(defun record-explanation-for (target val expr0 &key (situation (curr-situation)) ignore-clone-cycles)
 (cond ((or *record-explanations*
	    (and *record-explanations-for-clones* 
		 (member (explanation-type expr0) '#$(cloned-from added-at))))	; two clone-based explanation structures
	(let* ((slot (second target))
	       (expr1 (modify-set-explanation expr0)) 
	       (expr (desource-all-but-top-level expr1)))	; don't need to store embedded sources in expln database
	  (cond 
	   ((and (listp *record-explanations*) ; Now can be a LIST of slots worth recording explanations for
		 (not (member slot *record-explanations*))	; i.e., is not worth recording explanation 
		 (not (member (invert-slot slot) *record-explanations*)))
	    nil)
	   ((and (listp target)		; lazy-unify sometimes now gives :target (the <slot> of (i1 &! i2))
		 (not (kb-objectp (fourth target)))) nil)
	   ((and (km-setp expr) 
		 (notevery #'(lambda (val) (is-km-term (desource val))) (set-to-list expr)))
	    (report-error 'program-error
			  "A not-fully-evaluated :set was unexpectedly passed as an explanation to ~a.~%" 
			  `(record-explanation-for ,target ,val ,expr)))
	   ((and (listp expr) 		; [1]
		 val
		 (not (km-setp expr))	; NEW: *ignore* sets. These arise from [4]
;		 (or (not (km-setp expr))	- should never be :set any more
;		     (notevery #'(lambda (val) (is-km-term (desource val))) (set-to-list expr))) ; 	:set must have at least one path in it...
		 (or (not (km-triplep val)) (not (null (arg3of val))))) ; ignore (:triple x y NIL) computations
	    (let* ((instance (fourth target))
		   (isv-explanation (list instance slot val expr))
		   (old-isv-explanations (get-all-explanations instance slot :situation situation
							       :ignore-clone-cycles ignore-clone-cycles)) )
	      (cond ((member isv-explanation old-isv-explanations :test #'equal)) ; a	       a    -> a
		    (t (put-explanations instance slot (cons isv-explanation old-isv-explanations)
					 :situation situation)))
; Disable until Sunil says go ahead (HLO-2022)
	      ;;; NEW: (record-explanation-for '#$(the parts of _Car1) '#$_Engine1 '#$(a Engine (@ _Car1 Car parts)))
	      ;;; Explanation supports TWO assertions: (i) Exists x parts(_Car1,x)  and (ii) instance-of(x,Engine)
	      ;;; So we need to make sure the explanation for this 2nd assertion is ALSO recorded
	      (cond ((and (neq slot '#$instance-of)
			  (kb-objectp val)
			  (existential-exprp expr))
		     (let ((class (second (desource expr))))	; (a Car) -> Car
		       (record-explanation-for `#$(the instance-of of ,VAL) class expr :situation situation
					       :ignore-clone-cycles ignore-clone-cycles
					       ))))
	      )))))))

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

#|
REDUNDANT NOW: :set explanations are never stored.
;;; Slightly complex, to minimise storage of :sets
(defun update-isv-explanations (old-isv-explanations isv-explanation)
  (cond 
   ((endp old-isv-explanations) (list isv-explanation))
   (t (let ( (old-isv-explanation (first old-isv-explanations)) )
	(cond ((not (equal (triple-in old-isv-explanation) (triple-in isv-explanation)))
	       (cons old-isv-explanation (update-isv-explanations (rest old-isv-explanations) isv-explanation)))
	      (t (let ( (explanation (explanation-in isv-explanation))
			(old-explanation (explanation-in old-isv-explanation)) )
		   (cond ; ((equal explanation old-explanation) old-explanations)	; (tested for earlier)
		    ((km-setp explanation) ; EXPR       OLD-EPXR
		     (km-format t "DEBUG: Found a set explanation doing ~a!~%"
				`(update-isv-explanations ,old-isv-explanations ,isv-explanation))
		     (cond ((not (km-setp old-explanation)) ; (:set a b)   a    -> a
			    (cond ((member (desource old-explanation) explanation :test #'equal) old-isv-explanations) ; DROP explanation
				  (t (cons old-isv-explanation (update-isv-explanations (rest old-isv-explanations) isv-explanation)))))
			   ((subsetp explanation old-explanation :test #'equal) ; (:set a b) (:set a b c) -> (:set a b)
			    (update-isv-explanations (rest old-isv-explanations) isv-explanation)) ; DROP old-isv-explanation
			   (t (cons old-isv-explanation (update-isv-explanations (rest old-isv-explanations) isv-explanation)))))
		    ((and (km-setp old-explanation) ; a  	      (:set a b)  -> a
			  (member (desource explanation) old-explanation :test #'equal))
		     (update-isv-explanations (rest old-isv-explanations) isv-explanation)) ; DROP old-isv-explanation
		    (t (cons old-isv-explanation (update-isv-explanations (rest old-isv-explanations) isv-explanation)))))))))))
|#

;;; (:set (a Cat (@ Person pet)) (a Dog (@ Person pet))) -> (:set (a Cat) (A Dog) (@ Person pet))
(defun modify-set-explanation (expr)
  (cond ((km-setp expr)
	 (let* ( (vals (set-to-list expr))
		 (sources (remove-duplicates (my-mapcan #'sources vals) :test #'equal)) )
	   (vals-to-val (append (desource vals) sources))))
	(t expr)))

(defun why (&optional triple (situation (curr-situation)))
  (cond ((and (null triple)
	      (null *last-answer*))
	 (km-format t "There are no answers to explain!~%"))
	((null triple)
	 (let* ( (slot+frameadd (minimatch *last-question* '#$(the ?slot of ?frameadd))) 
		 (slot (first slot+frameadd))
		 (frameadd (second slot+frameadd)) )
	   (cond 
	    ((not 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 (let ( (values *last-answer*)
		      (instances (km-int frameadd)) )	; if *last-answer*, then frames necc. not null
		 (km-format t "I'll assume you're asking me:~%Why ~a = ~a...~%~%" *last-question* values)
		 (mapc #'(lambda (instance) 
			   (mapc #'(lambda (value)
				     (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])
|#
(defun why0 (triple &optional (situation (curr-situation)))
  (let* ( (instance0 (arg1of triple))
	  (slot (arg2of triple))
	  (val0 (arg3of triple))
	  (instance (dereference instance0))
	  (val (dereference val0))
	  (isv-multi-explanations (get-explanations instance slot val situation)) )	; returns two, forward and back
    (cond ((not (equal instance instance0)) (km-format t "(~a is bound to ~a)~%" instance0 instance)))
    (cond ((not (equal val val0)) (km-format t "(~a is bound to ~a)~%" val0 val)))
    (cond 
     ((null isv-multi-explanations)
      (km-format t "(:triple ~a ~a ~a [in ~a]) because:~%  (no explanation available)~%" instance slot val situation))
     (t (mapc #'(lambda (isv-explanation)
		  (let ( (i (first isv-explanation))
			 (s (second isv-explanation))
			 (v (third isv-explanation))
			 (explanations (explanation-in isv-explanation)) )
		    (km-format t "(:triple ~a ~a ~a [in ~a]) because:~%" i s v situation)
		    (mapc #'(lambda (explanation)
			      (multiple-value-bind
			       (english justification rule path body)
			       (get-comments explanation)
			       (declare (ignore path body))			; is always included in rule anyway
			       (cond (justification (km-format t "   ENTRY TEXT: ~a~%" justification)))
			       (cond (english (km-format t "   EXIT TEXT: ~a~%" english)))
			       (km-format t "   RULE: ~a~%" (desource-for-printing rule))))
			  explanations)
		    (terpri)))
	      isv-multi-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>)) )

Each element in this (max length 2) list has the structure:
(<instance> <slot> <val> <explanations>)   where <explanations> = (<explanation>*)

Each <explanation> describes how (i s v) or (v invs i) was computed, and has 4 different forms:
  - (a Device (@ _Drive1 Control object))	; traditional, e.g., (every Control has (object ((a Device))))
    (a Device)					; traditional (the source frame could not be located through)
  - (cloned-from _Drive3 _Drive1)		; cloned from protoype _Drive3
  - (added-at Drive-With-Passenger "Here's my comment") ; manually added
  - (projected-from _Situation3)		; 	

Note: is **MAPCAN-SAFE**
|#
(defun get-explanations (instance slot val &optional (situation (curr-situation)))
  (remove nil (list (get-explanations0 instance slot val situation)
		    (get-explanations0 val (invert-slot slot) instance situation))))

;;; OLD
;;; (defun get-explanations0 (instance slot val &optional (situation (curr-situation)))
;;;   (let ( (explanations (remove-duplicates (get-explanations1 instance slot val situation) :test #'equal)) )
;;;    (cond (explanations (list instance slot val explanations)))))
;;;
;;; NEW: instance-of explanations are a special case, retrieved globally.
;;; RETURNS: an (i s v explanations) structure.
;;;    If you just want the explanations only, use get-explanations1
(defun get-explanations0 (instance slot val &optional (situation (curr-situation)))
  (let* ((explanations (get-explanations1 instance slot val situation)))
    (cond (explanations (list instance slot val explanations)))))

;;; RETURNS: List of explanations, 
;;; 	where an explanation = (every ...), (cloned-from ...), (added-at ...), (projected-from ...)
(defun get-explanations1 (instance0 slot val0 &optional (situation (curr-situation)))
  (let* ((instance (dereference instance0))
	 (val (dereference val0))
	 (explanations (mapcar #'fourth (remove-if-not #'(lambda (x) 
							   (and (eq (second x) slot)
								(equal (third x) val)))
;								 (is-subslot-of (second x) slot)))	; has-part is explanation for has-structure
						       (get-all-explanations instance slot :situation situation))))
	 (projected-from-situation (some #'(lambda (explanation)
					      (cond ((and (listp explanation)
							  (eq (explanation-type explanation) '#$projected-from))
						     (second explanation))))		 ; i.e. return the source situation
					  explanations)) )
    (cond (projected-from-situation
	   (remove-duplicates
	    (append (remove-if #'(lambda (explanation)
				   (and (listp explanation)
					(eq (explanation-type explanation) '#$projected-from)))
			       explanations)
		    (get-explanations1 instance slot val projected-from-situation))
	    :test #'equal))
	  (t (remove-duplicates explanations :test #'equal)))))

;;; ======================================================================
;;;        API TO THE EXPLANATION DATABASE: low-level get/put:
;;; ======================================================================
#|
RETURNS: a list of (i s v explanation)
NOTE: Will return multiple (i s v explanation) for the same i-s-v if >1 expln (explanations aren't aggregated)
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
NOTES: 
  - Can switch of ignore-clone-cycles check for when loading the KB, where load order matters.
  - Will *not* return subslot explanations, e.g., (get-all-explanations _Cell1 has-structure) will not return has-part 
    explanations (where has-part is a subslot of has-structure). Rather, the subslot agglomeration is handled
    in get-explanations above.
|#
(defun get-all-explanations (instance0 slot &key (situation (curr-situation)) ignore-clone-cycles)
;  (cond ((eq instance0 '|_Finger5|) (break)))
 (let ((instance (dereference instance0)))
  (cond ((kb-objectp instance)
	 (let* ((target-situation (target-situation situation instance slot))
		(global-isv-explanations (get-explanation-data instance :situation *global-situation*))
		(decycled-global-isv-explanations 
		 (cond (ignore-clone-cycles (dereference global-isv-explanations))
		       (t (remove-clone-cycles (dereference global-isv-explanations)))))
		(all-isv-explanations (cond ((eq target-situation *global-situation*) decycled-global-isv-explanations)
					    (t (append (dereference
							(get-explanation-data instance :situation target-situation))
						       decycled-global-isv-explanations)))))
	   (cond ((not (equal global-isv-explanations decycled-global-isv-explanations))
		  (put-explanations instance slot decycled-global-isv-explanations :situation *global-situation*)))
	   (remove-duplicates all-isv-explanations :test #'equal :from-end t))))))

;;; slot is representative of the isv-explanations, and determines which target situation the explanations go in.
;;; If slot = nil, then they go in the current situation.
(defun put-explanations (instance slot isv-explanations &key (situation (curr-situation)))
  (cond ((not (kb-objectp instance))
	 (report-error 'program-error "Attempt to put an explanation associated with a non-kb-object ~a!~%" instance))
	(t (put-explanation-data instance isv-explanations :situation (target-situation situation instance slot)))))

;;; ----------
;;; Low level get/put. NOTE No dereferencing!
(defun get-explanation-data (instance &key (situation (curr-situation)) dereference)
  (cond (dereference (dereference (get instance (curr-situation-facet 'explanation situation))))
	(t (get instance (curr-situation-facet 'explanation situation)))))

;;; Allow suppression when running tester.
(defvar *report-explanation-clone-warnings* nil)

;;; [1] Note, it's critical that explanations for non-fluents are put in *Global, as get-explanation-data
;;; does not even look in local for non-fluent explanations. This was causing some explanations to be unseen
;;; by get-supports earlier.
(defun put-explanation-data (instance isv-explanations &key (situation (curr-situation)))
  (cond 
   (*report-explanation-clone-warnings*
    (mapc #'(lambda (isv-explanation)
	    (let ((explanation (explanation-in isv-explanation)))
	      (cond ((and (eq (explanation-type explanation) '#$cloned-from)
			  (not (prototypep (second explanation))))
		     (report-error 'user-warning 
	   "Attempt to explain a triple as cloned-from a non-prototype!~%    ~a~%   I'll assert it anyway (I'll assume the source prototype is to be loaded later, but if not this might be indicative of a KB error)~%"	isv-explanation)))))
	  isv-explanations)))
  (cond
   ((eq situation '#$*Global)
    (km-setf instance (curr-situation-facet 'explanation situation) isv-explanations))
   (t (let ((globals (remove-if #'(lambda (isv-explanation)			; [1]
				    (fluentp (second isv-explanation)))
				isv-explanations))
	    (locals (remove-if-not #'(lambda (isv-explanation)
				       (fluentp (second isv-explanation)))
				   isv-explanations)))
	(km-setf instance (curr-situation-facet 'explanation situation) locals)
	(km-setf instance (curr-situation-facet 'explanation '#$*Global) globals)))))

#|
======================================================================
	DELETING (cloned-from ....) EXPLANATIONS
======================================================================

Suppose (_MyPet breathes *yes) is cloned-from both (_Pet1 breathes *yes) and (_Fish1 breathes *yes).
This info will be stored in the explanation database. 
Suppose then (_Fish1 breathes *yes) is deleted; we need to remove the support on _MyPet.
Can do this like this:
   (delete-support-by-prototypes-in-class '#$(_MyPet breathes *yes) '#$Fish)
or equivalently like this:
   (delete-support-by-prototypes '#$(_MyPet breathes *yes) '#$(_Fish1))   

These functions do a simple update (removal) from the explanation database of the (cloned-from _Fish1 _MyPet) 
   record.

See knowledge-revision/delete-triples/test-delete-triple2.lisp for full example.

RETURNED VALUE: (Irrelevant)
|#   
(defun delete-support-by-prototypes-in-class (triple class &key (situation (curr-situation)) (explanation-types-to-delete '#$(cloned-from)))
  (delete-support-by-prototypes triple (get-vals class '#$prototypes) :situation situation :explanation-types-to-delete explanation-types-to-delete))

(defun delete-support-by-prototypes (triple prototype-roots &key (situation (curr-situation)) (explanation-types-to-delete '#$(cloned-from)))
  (cond 
   ((or (not (listp explanation-types-to-delete))
	(set-difference explanation-types-to-delete '#$(cloned-from added-at)))
    (report-error 'user-error "delete-support-by-prototypes: :explanation-types-to-delete must be a list whose values are a subset of (cloned-from added-at).
	Instead was :explanation-types-to-delete '~a~%" explanation-types-to-delete))
   (t (let* 
        ((prototype-classes (my-mapcan #'(lambda (protoroot) (get-vals protoroot '#$prototype-of)) prototype-roots))
	 (f (first triple))
	 (s (second triple))
	 (v (third triple))
	 (isv-multi-explanations (get-explanations f s v situation)) ; (i s v explanation*)
	 (isv-explanations-supported-by-prototypes	; list of (i s v (cloned-from <proto-root> <n>))
	  (mapcan #'(lambda (isv-multi-explanation) ; (i s v explanation*)
		      (let* ((triple0 (triple-in isv-multi-explanation))
			     (explanations (explanation-in isv-multi-explanation))
			     (explanations-supported-by-prototypes
			      (remove-if-not #'(lambda (explanation) ; (cloned-from <proto-root> <clone>)
						 (cond
						  ((member (explanation-type explanation) explanation-types-to-delete)
						   (case (explanation-type explanation)
						     (#$cloned-from (member (second explanation) prototype-roots))
						     (#$added-at (member (second explanation) prototype-classes))))))
					     explanations)))
;			(km-format t "triple0 = ~a, explanations = ~a~%" triple0 explanations)
			(mapcar #'(lambda (explanation-supported-by-prototypes)
				    `(,@triple0 ,explanation-supported-by-prototypes))
				explanations-supported-by-prototypes)))
		  isv-multi-explanations)))
	(delete-isv-explanations isv-explanations-supported-by-prototypes :situation situation)))))

(defun delete-isv-explanations (isv-explanations &key (situation (curr-situation)))
  (mapcar #'(lambda (isv-explanation) (delete-isv-explanation isv-explanation :situation situation)) isv-explanations))

(defun delete-isv-explanation (isv-explanation &key (situation (curr-situation)))
  (cond ((null isv-explanation)
	 (report-error 'program-error "NIL passed to delete-isv-explanation (not allowed!)"))
	(t (let ((f (first isv-explanation))
		 (s (second isv-explanation))
		 (v (third isv-explanation))
		 (explanation (explanation-in isv-explanation)))
	     (cond ((null explanation)
		    (report-error 'program-error "Null explanation passed to delete-isv-explanation (not allowed!)"))
		   (t (delete-explanation f s v :explanation-to-delete explanation :situation situation)))))))
    
;;; ----------
;;; explanation-to-delete = 'all -> delete ALL explanations for (f s v)
;;; NOTE: This assumes that explanation-to-delete is stored on (instance slot val), not (val invslot instance)
;;; val can be '* meaning ALL
(defun delete-explanation (instance0 slot val0 &key explanation-to-delete (situation (curr-situation)))
  (cond ((null explanation-to-delete)
	 (report-error 'program-error "Null explanation passed to (delete-explanation ~a ~a ~a :explanation-to-delete ~a) (not allowed!)" instance0 slot val0 explanation-to-delete))
	((kb-objectp instance0)	 
	 (let* ((instance (dereference instance0))
		(val (dereference val0))
		(explanation-to-delete0 (dereference explanation-to-delete))
		(target-situation (target-situation situation instance slot))
		(isv-explanations (get-explanation-data instance :situation target-situation :dereference t)))
	   (cond
	    ((and (neq explanation-to-delete 'all)
		  (not (member `(,instance ,slot ,val ,explanation-to-delete0) isv-explanations :test #'equal)))
	     (report-error 'user-error "Failed to delete explanation (doesn't seem to exist):~% ~a~%"
			   `(,instance ,slot ,val ,explanation-to-delete0)))
	    (t (let ((new-isv-explanations 
		      (cond ((neq explanation-to-delete 'all)
			     (remove `(,instance ,slot ,val ,explanation-to-delete0) isv-explanations :test #'equal))
			    (t (remove-if #'(lambda (isv-explanation)
					      (or (equal (first-n isv-explanation 3) `(,instance ,slot ,val))
						  (and (eq val '*)
						       (equal (first-n isv-explanation 2) `(,instance ,slot)))))
					  isv-explanations)))))
		 (cond ((eq explanation-to-delete 'all)
			(make-comment "Deleting all explanations supporting (~a ~a ~a)..." instance0 slot val0))
		       (t (make-comment "Deleting explanation ~a supporting (~a ~a ~a)..." 
					explanation-to-delete instance0 slot val0)))
		 (put-explanations instance slot new-isv-explanations :situation situation))))))))

(defun delete-all-supports-from-class (class)
  (mapc #'(lambda (instance) (delete-supports-from-class instance class)) (get-all-concepts))
  t)

;;; All explanations originating at a class are deleted
(defun delete-supports-from-class (instance0 class &key (situation 'all-situations))
  (let ((situations (cond ((eq situation 'all-situations) (all-situations))
			  (t (listify situation)))))
    (mapc #'(lambda (s) (delete-supports-from-class0 instance0 class :situation s)) situations)
    t))

(defun delete-supports-from-class0 (instance0 class &key (situation (curr-situation)))
  (let* ((instance (dereference instance0))
	 (isv-explanations (get-explanation-data instance :situation situation :dereference t)))
    (cond ((some #'(lambda (isv-explanation) 
		     (member class (originated-from-classes (explanation-in isv-explanation))))
		 isv-explanations)
	   (let ((new-isv-explanations 
		  (remove-if #'(lambda (isv-explanation)
				 (let ((origins (originated-from-classes (explanation-in isv-explanation))))
				   (cond ((member class origins)
					  (cond ((not (singletonp origins))
						 (report-error 'user-warning "delete-supports-from-class: Found an explanation with more than one originating class!?~%~a~%Continuing (will delete it anyway)...~%" isv-explanation)))
					  t))))
			     isv-explanations)))
	     (put-explanation-data instance new-isv-explanations :situation situation))))))


#|
Inverse to get-explanations:
	(get-explanations i s v) -> <structs>
	(delete-explanations i s v <structs>) 
|#
(defun delete-explanations (i s v structs)
  (mapc #'(lambda (explanation)
	    (delete-explanation i s v :explanation-to-delete explanation)
	    (delete-explanation v (invert-slot s) i :explanation-to-delete explanation))
	(apply #'append (mapcar #'fourth structs)))
  t)

;;; ======================================================================
;;;	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)))
(defun combine-explanations (explanations)
  (cond ((endp explanations) nil)
	(t (let* ( (explanation (first explanations))
		   (instance (first explanation))
		   (slot (second explanation))
		   (value (third explanation))
		   (exprs (fourth explanation)) 
		   (additional-explanations (remove-if-not #'(lambda (additional-explanation)
							      (and (eq (first additional-explanation) instance)
								   (eq (second additional-explanation) slot)
								   (eql (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
			   (ordered-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.
;;; NEW: modify (km-bind ...) to do it immediately before!
;;; This procedure is (only) called by (km-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.
(defun merge-explanations (i1 i2)
  (cond ((and (kb-objectp i1) (kb-objectp i2))
; ???
;	 (let* ( (dominant-i (dereference i1))		; i.e., find the result of (i1 & i2)
;		 (recessive-i (first (remove dominant-i (list i1 i2)))) )
; Let's to merge-explanations BEFORE the binding is actually done
	 (let* ((dominant-i (dereference i2))
		(recessive-i i1))
	 (cond ((null recessive-i)
		  (report-error 'user-warning "Null recessive-i encountered in merge-explanations!~%"))
		 (t (mapc #'(lambda (situation)
			      (let ( (recessive-explns (get-all-explanations recessive-i nil :situation situation)) )
				(cond (recessive-explns
				       (let* ( (dominant-explns (get-all-explanations dominant-i nil :situation situation)) 
					       (new-explns (ordered-set-difference recessive-explns dominant-explns :test #'equal)) )
					 (cond (new-explns (put-explanations dominant-i nil 
									     (remove-duplicates
									      (append dominant-explns new-explns)
									      :test #'equal
									      :from-end t)
									     :situation situation))))))))
			  (all-active-situations))))))))

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

(defun explain-all (&key (include-globalp t))
  (mapc #'(lambda (instance)
	    (mapc #'(lambda (situation)
		      (let* ( (explanations (get-all-explanations instance nil :situation situation))
			      (slots (remove-duplicates (mapcar #'second explanations))) )
			(mapc #'(lambda (slot)
				  (let* ( (slot-explanations (remove-if-not #'(lambda (x) (eq (second x) slot)) explanations))
					  (vals (remove-duplicates (mapcar #'third slot-explanations))) )
				    (mapc #'(lambda (val)
					      (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) 
											    (eql (third x) val))
											slot-explanations)))))
					  vals)))
			      slots)))
		  (cond (include-globalp (all-active-situations))
			(t (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 #'(lambda (situation)
				   (curr-situation-facet 'explanation situation))
			       (all-situations)))) )
    (mapc #'(lambda (frame)
	      (cond ((not (protoinstancep frame))		; [1]
		     (mapc #'(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 #'(lambda (situation)
					       (curr-situation-facet 'explanation situation))
					   (all-situations))) )
    (mapc #'(lambda (frame)
	      (mapc #'(lambda (explanation-facet)
			(let* ( (old-explanations (get frame explanation-facet)) 
			        (new-explanations nil) )		; NEW 12/29/07 
;				(new-explanations 
;				 (remove-if
;				  #'(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.
(defun clear-explanations (&key clear-globalp)
  (let ( (facets (mapcar #'(lambda (situation)
			      (curr-situation-facet 'explanation situation))
			  (cond (clear-globalp (all-situations-and-theories))
				(t (remove *global-situation* (all-situations-and-theories)))))) )
    (mapc #'(lambda (frame)
	      (mapc #'(lambda (facet)
			(remprop frame facet))
		    facets))
	  (get-all-concepts))
    t))

(defun explanations (&optional slots) 
  (cond ((and slots (listp slots)) (setq *record-explanations* slots))
	(t (setq *record-explanations* t))))
(defun no-explanations () (setq *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))
;(defun standard-explanation-expr (expr) 
;  (and (listp expr) (neq (first expr) '|every|) (not (sourcep (first expr)))))

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

;;; New function (not used):
;;; [1] For Shaken, *leave* explanations on the prototypes. They should stay. But clober everything else.
(defun clear-all-explanations ()
  (let ( (facets (cons 'explanation 
		       (mapcar #'(lambda (situation)
				   (curr-situation-facet 'explanation situation))
			       (all-situations-and-theories)))) )
    (mapc #'(lambda (frame)
	      (cond ((not (protoinstancep frame))		; [1]
		     (mapc #'(lambda (facet)
			       (remprop frame facet))
			   facets))))
	  (get-all-concepts))
    t))

;;; ======================================================================
;;;		OLD METHOD FOR CACHING EXPLANATIONS - remove this, ultimately
;;; ======================================================================

;;; Handle for clear-cached-explanations
;(defvar *instances-with-cached-explanations* nil)

;(defun cache-explanation-for (val expr0)
;  (declare (ignore val expr0))
;  nil)

(defun cache-explanation-for (val expr0)
  (cond ((and (kb-objectp val)
	      (existential-exprp expr0))		; Note: still works even if comment tags are in existential-exprp
	 (let ( (explanations (dereference (get val 'cached-explanations))) 		; TEMPORARY
		(expr (desource+decomment expr0)) )
;	   (cond ((not (member val *instances-with-cached-explanations*)) (push val *instances-with-cached-explanations*)))
	   (or (member expr explanations :test #'equal)
	       (km-setf val 'cached-explanations (cons expr explanations)))))))	; TEMPORARY TEST

;;; Disable for automatic system
; (defun clear-cached-explanations () '#$(t))
;  (mapc #'(lambda (instance) 
;	    (km-setf instance 'cached-explanations nil))
;	*instances-with-cached-explanations*)
;  (setq *instances-with-cached-explanations* nil))

;;; Rename to avoid collisions.
;;; NOTE: Not used by KM (it's indirectly flushed by km-remprops during (reset-kb)
;(defun clear-evaluation-cache ()
;  (mapc #'(lambda (instance) 
;	    (km-setf instance 'cached-explanations nil))
;	*instances-with-cached-explanations*)
;  (setq *instances-with-cached-explanations* nil)
;  '#$(t))

;;; Rewritten to avoid global variable. Only used now in test-suite/cache-problem.km
(defun clear-evaluation-cache ()
  (mapc #'(lambda (instance) 
	    (km-setf instance 'cached-explanations nil))
	(get-all-objects))
  '#$(t))


;;; RETURNED VALUE IS IRRELEVANT (just NIL / some value)
(defun explained-by (instance expr &optional target)
  (declare (ignore target))
  (member (desource+decomment expr) (cached-explanations-for instance) :test #'equal))

(defun cached-explanations-for (instance &optional (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
;;; NEW: Do before they are merged
(defun merge-cached-explanations (i1 i2)
  (cond ((and (kb-objectp i1) (kb-objectp i2))
	 (let ((merged-i (dereference i2))
	       (merged-cached-explanations 
		 (remove-duplicates (append (dereference (get i1 'cached-explanations)) 
					    (dereference (get i2 'cached-explanations))) 
				    :test #'equal)) )
	   (km-setf merged-i 'cached-explanations merged-cached-explanations)))))

;;; ======================================================================
;;;		ANNOTATE WITH SOURCES
;;; ======================================================================
#|
GIVEN 
(annotate-every-expr '#$
    (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]))))

NOTE: must-be-a constraints get special processing, by wrapping the slot in a (<slot> must-be-a) structure:

	(every Car has 
	    (parts ((must-be-a Engine (@ Self Car (parts must-be-a))))))

	(every Car has 
	    (parts ((must-be-a Engine with 
			(parts ((must-be-a Cylinder (@ Self Car (parts must-be-a) Engine (parts must-be-a))))) 
			(@ Self Car (parts must-be-a))))))

This is because to evaluate the constraint, enforce-val-constraint replaces the (must-be-a Engine ...) 
with (a Engine ...), thus losing the information that the class came from a constraint rather than 
existential expression. By wrapping the must-be-a in the source info, we preserve this knowledge
for explanation purposes. 

Note, the explanations affected are for (_Engine1 instance-of Engine), not (_Car1 parts _Engine1) triples.
|#

;;; [1] These slots are candidates for access via low-level get-vals, which doesn't filter out the
;;; source tags.
(defun annotate-slotsvals (slotsvals source)
  (cond 
   ((endp slotsvals) nil)
   ((null *record-sources*) slotsvals)
   (t (let ( (slotvals (first slotsvals)) )
	(cond ((or (comment-tagp slotvals)
		   (member (slot-in slotvals) *built-in-atomic-vals-only-slots*))
;		   (combine-values-by-appending-slotp (slot-in slotvals)))	; NEW [1]
	       (cons slotvals (annotate-slotsvals (rest slotsvals) source)))
	      (t (let ( (slot (slot-in slotvals))
			(vals (vals-in slotvals)) )
		   `((,slot ,(annotate-vals vals (add-to-source source slot))) ,@(annotate-slotsvals (rest slotsvals) source)))))))))

(defun annotate-vals (vals source &key embedded-structurep)
  (mapcar #'(lambda (val) (annotate-val val source :embedded-structurep embedded-structurep)) vals))

#|
EXAMPLES:
[1] USER(14): (annotate-val '#$((a x) & (a y)) '(@))
((a x (@)) & (a y (@)))
[1] USER(15): (annotate-val '#$((a x) & (a y) & (a z)) '(@))
((a x (@)) & (a y (@)) & (a z (@)))
[1] USER(16): (annotate-val '#$(((a x)) && ((a y))) '(@))
(((a x (@))) && ((a y (@))))
[1] USER(17): (annotate-val '#$(((a x)) && ((a y)) && ((a z))) '(@))
(((a x (@))) && ((a y) (@)) && ((a z (@))))
[1] USER(18): (annotate-val '#$(a Car with (parts ((a Engine)))) '(@))
(a Car with (parts ((a Engine (@ Car parts)))) (@))


(annotate-val '#$(_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)))))
;;; :embedded-structurep t => We are NOT annotating a top-level val, but some embedded substructure. In this case,
;;; we do NOT annotate atoms (e.g., DON'T do *black -> (*black (@ _Car1 Car color))) as atoms *may* be keywords.
(defun annotate-val (val source &key embedded-structurep)
 (prog1
  (cond ((or
	   ; (not (listp val))  - No, we *do* want to annotate single values like *down. Numbers too? Let's just do
	   ;			  KB objects so far
	     (and (not (listp val))
		  (or embedded-structurep
		      (and (not (kb-objectp val)) ; e.g., number, string. But *do* annotate constants, e.g., *cat, say
			   (not (numberp val))    ; New: *DO* annotate numbers and strings
			   (not (stringp val))   
			   )))
	     (comment-tagp val)
	     (km-varp val)
	     (descriptionp val)			; otherwise (quote foo) becomes (quote foo (@ Source)) which isn't a quotep any more!
	     (quoted-expressionp val)
; #|NEW|#    (and (km-structured-list-valp val) (not (km-triplep val)))
;;; 9/15/08 - No, we DO want structured list vals annotated.
;;; e.g., (every Car has (age ((:pair (a Number) *year)))) records a source for (:pair _Number23 *year) and
;;; (_Number23 instance-of Number). See the test at the end of test-suite/explanations.km

	     (and (constraint-exprp val)  ; now DON'T source-comment constraints, or else we get duplicates [3]. Hmmm. 
		  (or (eq val '#$:incomplete)
		      (and (listp val)
;			   (not (eq (first val) '#$must-be-a)))))	; EXCEPT let's annotate must-be-a now
			   (not (member (first val) *annotated-constraints*))))) ; EXCEPT lets annotate must-be-a etc
	     )
	 val)
;	((and (singletonp val) 
;	      (listp (first val))
;	      (report-error 'user-warning "Bad syntax: Unnecessary use of double parentheses around an expression ~a~%Could just be ~a instead (?)"
;			    val (first val))
;	      nil))			; just warning
	((and (or (kb-objectp val)
		  (numberp val)
		  (stringp val)
		  )
	      (not embedded-structurep))
	 (attach-source-to-expr val source))
	((and (listp (desource+decomment-top-level val))
	      (member (first (desource+decomment-top-level val)) '#$(a every must-be-a)))
	 (let* ((class-to-add (second (desource+decomment-top-level val)))
		(wrapper (cond ((eq (first (desource+decomment-top-level val)) '#$must-be-a) '#$must-be-a)))
;		(annotated-every-expr (annotate-every-expr val (add-to-source source 
;									      (cond (wrapper (list wrapper class-to-add))
;										    (t class-to-add)))))
		(source0 (cond (wrapper `(,@(butlast source) (,(last-el source) ,wrapper)))
			       (t source)))
		(annotated-every-expr (annotate-every-expr val (add-to-source source0 class-to-add)))
		(every-expr-with-source (attach-source-to-expr annotated-every-expr source0)))
;	   (km-format t "class-to-add = ~a~%" class-to-add)
;	   (km-format t "wrapper = ~a~%" wrapper)
;	   (km-format t "annotated-every-expr = ~a~%" annotated-every-expr)
;	   (km-format t "every-expr-with-source = ~a~%" every-expr-with-source)
	   every-expr-with-source))
	((and (listp val)
	      (member (second val) '(& &+)))
	 (cond ((member (fourth val) '(& &+))
		`(,(annotate-val (first val) source :embedded-structurep embedded-structurep)
		  ,(second val) 
		  ,@(annotate-val (rest (rest val)) source :embedded-structurep embedded-structurep))) ; [1a]
	       (t `(,(annotate-val (first val) source :embedded-structurep embedded-structurep) 
		    ,(second val) 
		    ,@(annotate-vals (rest (rest val)) source :embedded-structurep embedded-structurep))))) ; [1b]
	((and (listp val)
	      (eq (second val) '&&))
	 (cond ((eq (fourth val) '&&)
		`(,(annotate-vals (first val) source :embedded-structurep embedded-structurep) 
		  ,(second val) 
		  ,@(annotate-val (rest (rest val)) source :embedded-structurep embedded-structurep))) ; [2a]
	       ((not (= (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 :embedded-structurep embedded-structurep) 
		    ,(second val) 
		    ,(annotate-vals (third val) source :embedded-structurep embedded-structurep))))) ; [2b]
	((intersection val '(& && &+)) val) ; e.g. ([Car1] _Car1 & (a Car))	 - actually shouldn't be allowed

;;; Certain expressions, starting with a *decomment-top-level-only-headwords* should have their subexpresssions 
;;; also annotated.
	((and (listp val)
	      (member (first val) *decomment-top-level-only-headwords*))
	 (let* ((dotted-source (dot-source source)) ; (Car part) -> (Car part...)
		(annotated-expr (annotate-vals val dotted-source :embedded-structurep t))) ; atoms might be keywords
	   (attach-source-to-expr annotated-expr source)))
;	(t (attach-source-to-expr val source)))))
	(t (let* ((dotted-source (dot-source source))) ; (Car part) -> (Car part...)
	     (cond
; [1] DON'T annotate top-level if not done above, as it may be a keyword e.g. (LAMBDA () (KM0 (QUOTE ...)))
	      ((null val) nil)
	      (embedded-structurep (annotate-embedded-structures val dotted-source)) ; [1]
; [2] Otherwise, DO attach source to the top level constant or expression.	
; e.g. (every Foo has (parts ((:pair (a Car) Self)) 
;     val = (:pair (a Car) Self)  --annotated--> (:pair (a Car (@ Self Foo parts...)) Self (@ Self Foo parts))
; also    = (the1 of ...)
;	    (make-phase ...)
;           (?x == (...))    etc.
	      (t			; (km-format t "val = ~a~%" val)
	         (attach-source-to-expr 
		  (annotate-embedded-structures val dotted-source) source))))) ; [2] keep looking inside
	)))

;;; Forall embedded (a ...) expressions, annotate them and it's subexpressions. Leave everything else.
(defun annotate-embedded-structures (expr source)
  (cond ((listp expr)
	 (mapcar #'(lambda (elt) 
		     (cond ((and (listp elt) (eq (first elt) '#$a)) (annotate-val elt source))
			   (t (annotate-embedded-structures elt source))))
		 expr))
	(t expr)))

;;; (dot-source '(a b)) -> (a b...)
(defun dot-source (source)
  (cond ((and (listp source)
	      (kb-objectp (last-el source))
	      (not (ends-with (symbol-name (last-el source)) "...")))
	 (append (butlast source) (list (intern (concat (symbol-name (last-el source)) "...") *km-package*))))
	(t source)))

(defun dotted-slot (slot)
  (and (symbolp slot) (ends-with (symbol-name slot) "...")))

(defun attach-source-to-expr (expr source) 
  (cond ((and (listp expr) (not (some #'sourcep expr))) 	; not already commented
	 (append expr (list source)))
;	(t expr)
	(t ; (km-format t "DEBUG: Annotating non-list expr ~a (source ~a)~%" expr source)
	 (list expr source))))	; new, we DO annotate atomic values (for Halo)


;;; expr = '#$(a ...) or '#$(every ...)
;;; OR   ((a ...) [tag])
(defun annotate-every-expr (every-expr &optional source (search-for 'every))
  (cond ((and (pairp every-expr)
	     (comment-tagp (second every-expr)))
	 (list (annotate-every-expr (first every-expr) source search-for) (second every-expr)))
	(t (or (annotate-every-expr0 every-expr source search-for)
	       (report-error 'user-error "annotate-every-expr: Badly structured every/a expression ~a!~%" every-expr)))))

(defun annotate-every-expr0 (every-expr &optional source (search-for 'every))
 (let ( (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)
	 (member first-el '#$(a every must-be-a)))
    (cons first-el (annotate-every-expr0 (rest every-expr) source 'class)))
   ((eq search-for 'class)
    (let ( (source0 (or source (make-source first-el))) )
      (cons first-el (annotate-every-expr0 (rest every-expr) source0 'has))))
   ((and (eq search-for 'has)
	 (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)
	 (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 (goal-stack))))))))

;;; ======================================================================
;;;		JUSTIFICATIONS
;;; ======================================================================

;;; justify:
;;; GIVEN a triple
;;; PRINT the explanation to :stream, and return (t)
;;; 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)))
(defun justify (&optional triple-expr &key (situation (curr-situation)) (depth 0) (stream t))
  (mapc #'(lambda (string)
	    (format stream string)
            ;; RVA 21Aug2006 fix km rep loop input output problem
            ;; using format instead or terpri because format and terpri interpret the stream argument differently
            (format stream "~%"))
	(get-justification :triple triple-expr :situation situation :depth depth :format 'ascii))
  '#$(t))

;;; GIVEN a :triple
;;; RETURN: a list of strings, one per line, explaining :triple
;;; :format is either 'xml or 'ascii
(defun get-justification (&key triple (situation (curr-situation)) (depth 0) (format 'xml) (tab 0))
  (let ((last-question *last-question*)		; make a note of last-qa, as it might get reset during reasoning
	(last-answer *last-answer*))
    (prog1 
	(flatten (list
		  (cond ((eq format 'xml) (list (format nil "<explanation-structure>"))))
		  (get-justification0 :triple triple :situation situation :depth depth :format format :tab tab)
		  (cond ((eq format 'xml) (list (format nil "</explanation-structure>"))))))
      (setq *last-question* last-question)	; put it back to how it was
      (setq *last-answer* last-answer))))

;;; Same as above, except without the XML wrapper. Here the returned strings might be nested.
;;; Input (:triple f s v)
(defun get-justification0 (&key triple (situation (curr-situation)) (tab 0) done-triples (depth 0) (format 'xml))
  (cond 
   ((and triple (not (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 (let ((triples (compute-triples triple))) ; (:triple f x *) -> find *, and return list of (:triple f x v) forall v
	(mapcar #'(lambda (triple0)
		    (cond ((member triple0 done-triples :test #'equal) nil)
			  (t (get-justification1 triple0 :situation situation :tab tab 
						 :done-triples (append triples done-triples)
						 :depth depth :format format))))
		triples)))))

;;; Look for comments about triple in either direction, and then failing that resort to the explanation database
(defun get-justification1 (triple &key (situation (curr-situation)) (tab 0) done-triples (depth 0) (format 'xml))
  (let ((instance (arg1of triple))
	(slot (arg2of triple))
	(value (arg3of triple)))
    (or (get-justification2 instance slot value :situation situation :tab tab 
			    :done-triples done-triples :depth depth :format format)
	(get-justification2 value (invert-slot slot) instance :situation situation :tab tab 
			    :done-triples done-triples :depth depth :format format)	
	(justify-leaf triple :situation situation :tab tab :done-triples done-triples :depth depth :format format))))

(defvar *start-justifications-with-because* t)

(defun get-justification2 (instance slot value &key (situation (curr-situation)) (tab 0) done-triples (depth 0) 
						    (format 'xml))
  (let* ((isv-multi-explanations (get-explanations0 instance slot value situation)) ; returns (i s v explanations)
	 (explanations (explanations-in isv-multi-explanations))
	 (comment-tags (remove-duplicates (my-mapcan #'get-comment-tags-recursive explanations)
					  :test #'equal :from-end t)))
;	 (subslot-explanations (remove-if-not #'(lambda (explanation)
;						  (and (minimatch explanation '#$(the ?subslot of ?instance))
;						       (is-subslot-of (second explanation) slot)))
;					      explanations)))
    (cond ((or comment-tags #|subslot-explanations|#)
	   (list (cond (*start-justifications-with-because*
			(concat (spaces tab) (format nil "The ~a of ~a = ~a because:" slot
						     (make-phrase (expand-text instance))
						     (make-phrase (expand-text value))))))
		 (mapcar #'(lambda (comment-tag)
			     (get-comment-justification comment-tag `(#$:triple ,instance ,slot ,value) 
							:situation situation 
							:tab tab :done-triples done-triples :depth depth :format format))
			 comment-tags)
;		 (concat (spaces tab) (format nil "Therefore, the ~a of ~a = ~a." (arg2of atriple)
;					      (make-phrase (expand-text (arg1of atriple)))
;					      (make-phrase (expand-text (arg3of atriple)))))
;		 (mapcar #'(lambda (subslot-explanation)
;			     (get-comment-justification *subslot-comment-tag*
;							`(#$:triple ,instance ,slot ,value) 
;							:situation situation
;							:tab tab :done-triples done-triples :depth depth :format format
;							:subslot (second subslot-explanation)))	; special, for subslots
;			 subslot-explanations)
		 )))))

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

;;; INPUT: A comment tag and :triple
;;; RETURNS: A list of strings, expressing that comment in English
;;; NOTE: This function will recurse using subgoals in the comment tag, passed to get-justification0
(defun get-comment-justification (comment-tag triple &key (situation (curr-situation)) (tab 0) done-triples 
							  (depth 0) (format 'xml))
;  (km-format t "triple = ~a~%" triple)
  (let* ((frame (arg1of triple))
	 (slot (arg2of triple))
	 (value (arg3of triple))
	 (subslot (fourth comment-tag))	; special case to squirrel away the subslot 
	 (bindings `((#$Value1 . ,frame) (#$TheSlot . ,slot) (#$Value2 . ,value) (#$TheSubslot . ,subslot)))
	 (caller   (sublis bindings (get-comment2 comment-tag 'call)))
	 (exiter   (sublis bindings (get-comment2 comment-tag 'exit)))
	 (subgoals (sublis bindings (get-comment2 comment-tag 'subgoals))))
;	 (caller   (cond ((eq comment-tag *subslot-comment-tag*) nil)
;		         (t (sublis bindings (get-comment2 comment-tag 'call)))))
;	 (exiter   (cond ((eq comment-tag *subslot-comment-tag*) `#$(:seq "and" ,SUBSLOT "is a subslot of" ,SLOT))
;			 (t (sublis bindings (get-comment2 comment-tag 'exit)))))
;	 (subgoals (cond ((eq comment-tag *subslot-comment-tag*) `#$((:triple ,FRAME ,SUBSLOT ,VALUE)))
;			 (t (sublis bindings (get-comment2 comment-tag 'subgoals))))))
    (list
     (cond (*developer-mode*
	    (case format
	      (ascii (list 
		      (concat (spaces tab) 
			      (km-format nil "(Doing triple: ~a)~%Entry text for ~a:" triple (desource1 comment-tag))))))))
     (case format
       (ascii (cond (caller (concat (spaces tab) 
				    (make-phrase (km-int caller :fail-mode 'fail))))))
       (xml (cond (caller (concat (format nil "<explanation><call>")
				  (xmlify (make-phrase (km-int caller :fail-mode 'fail)))
				  "</call>")))))
					; recurse on subgoals
;     (km-format t "subgoals = ~a~%" subgoals)
;     (km-format t "sublis = ~a~%" `((#$Value1 . ,frame) (#$Value2 . ,value)))
     
     (mapcar #'(lambda (subgoal)					 
		 (get-justification0 :triple subgoal
				     :situation situation :tab (+ tab 2) 
				     :done-triples done-triples
				     :depth (1+ depth)
				     :format format))
	     (km-int subgoals))
     (cond (*developer-mode*
	    (case format
		  (ascii (list (concat (spaces tab) (km-format nil "(Doing triple: ~a)~%Exit text for ~a:" triple (desource1 comment-tag))))))))
     (case format
       (ascii (cond (exiter (concat (spaces tab) 
				    (cond ((eq comment-tag *subslot-comment-tag*) "  ")(t ""))
				    (km-format nil (make-phrase (km-int exiter)))) ; was (km ...)?
			    )))
       (xml (cond (exiter (concat (format nil "<exit>")
				  (xmlify (make-phrase (km-int exiter))) ; was (km ...)?
				  "</exit></explanation>"))))))))

;;; If this is t, then a justification for leaf facts of the form <x> = <y> will be generated.
(defvar *justify-leaves* nil)

#|
justify-leaf <triple>. Used when <triple> does NOT have a comment tag.
NOTE: By default, we don't bother explaining things without a comment-tag. However, if *justify-leaves* is t,
      then we *do*.
INPUT: a <triple>
RETURNS: A list of string(s) explaining <triple>

What is a good explanation for (:triple _Cell has-part _Nucleus)? Do we print out the rule(s) that were used,
  or just say (the has-part of Cell) = Nucleus?
I've chosen just to present the source class(es) for the triple, but NOT the whole rule(s).

The rules were pulled from the explanation database, and are of the usual 4 types:
	#$added-at, #$cloned-from, #$projected-from, or the first element of a KM expr.
In *addition*, for prototypes, we can trace the cloned-from links back to the source class(es).
     Tracing the cloned-from links, and looking at the recordings in the explanation database, are	
     essentially redundant. However, if we have *record-explanations-for-clones* set to NIL, which
     is a sensible setting, then we can still find where the clones came from.

Note that we look at sources for BOTH directions of the triple (f s v) and (v invs f).
|#
;;; [1] only show rule(s) in developer mode and for ascii output
(defun justify-leaf (triple &key (situation (curr-situation)) (tab 0) done-triples (depth 0) (format 'xml))
  (declare (ignore depth done-triples))
; (format t "*justify-leaves* = ~a~%" *justify-leaves*)
  (let* ((instance (arg1of triple))
	 (slot (arg2of triple))
	 (value (arg3of triple)))
    (cond (*developer-mode*		; [1]
	   (let ((rules (mapcar #'build-rule 
				(my-mapcan #'explanation-in (get-explanations instance slot value situation)))))
	    (case format
	     (ascii 
	      (cond (rules (concat-list 
			    `(,*newline-str* ,(spaces tab) ,(km-format nil "subgoal ~a: Computed from:~%" triple)
					     ,@(mapcan #'(lambda (rule)
							   (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)))))))))
	  ((and *justify-leaves*
		(neq slot '#$instance-of)) ; else "the instance-of of nucleus = nucleus" 
	   (let* ((forward-source-classes (source-classes-for-triple instance slot value situation))
		  (reverse-source-classes (source-classes-for-triple value (invert-slot slot) instance situation))
		  (source-classes (remove-duplicates (append forward-source-classes reverse-source-classes)))
		  (instance-classes (remove-subsumers (immediate-classes instance))) ; ug, AURA keeps subsumers sometimes
		  (value-classes (remove-subsumers (immediate-classes value)))
		  (instance-to-show 
		   (cond ((intersection instance-classes source-classes) instance)
			 ((intersection value-classes source-classes) value)
			 (t instance)))
		  (value-to-show
		   (cond ((intersection instance-classes source-classes) value)
			 ((intersection value-classes source-classes) instance)
			 (t value)))		   
		  (slot-to-show
		   (cond ((intersection instance-classes source-classes) slot)
			 ((intersection value-classes source-classes) (invert-slot slot))
			 (t slot)))		   
		  )
	     (case format
		(ascii (concat (spaces tab)
			       (format nil "The ~a of ~a = ~a." 
				       slot-to-show 
				       (make-phrase (expand-text instance-to-show)) 
				       (make-phrase (expand-text value-to-show)))
			       (cond (source-classes (format nil " (from ~a)" 
							     (concat-list (commaify source-classes))))
				     (t ""))))
		(xml (concat "<explanation><leaf>"
			     (xmlify (format nil "The ~a of ~a = ~a."
					     slot-to-show 
					     (make-phrase (expand-text instance-to-show)) 
					     (make-phrase (expand-text value-to-show))))
			     (cond (source-classes 
				    (format nil " (from ~a)" (concat-list (commaify source-classes))))
				   (t ""))
			     "</leaf></explanation>"))))))))

(defun source-classes-for-triple (instance slot value &optional (situation (curr-situation)))
  (let* ((explanations (get-explanations1 instance slot value situation))	; explanations1 - just get in the FORWARD
	 (rules (mapcar #'build-rule explanations))) ;    direction
    (remove-subsumers (my-mapcan #'originated-from-classes rules))))

#|
======================================================================
  TRACING SOURCE CLASSES VIA CLONED-FROM LINKS DOESN'T WORK
======================================================================
Q. Is the uracil complement of adenine?
A. Yes!
    For all Uracil:
       an adenine is the complement of an uracil.
Explanation
    The complement of uracil = adenine. (from Thymine, Uracil)

The problem here is Thymine is mentioned as a source. This is because
node-cloned-from traced the Uracil protoinstance as cloned from Thymine --
it appears that the user created Uracil by copy-and-edit of Thymine,
thus leaving a tracability pointer back to Thymine although Thymine is
no longer a valid superclass :-(

The bottom line is we can't rely on the cloned-from links for
tracing inference dependence.
======================================================================

Prototypes: Cell has-part Cytoplasm
	    Euk-Cell has-part Big-Cytoplasm
	    BigEuk-Cell has-part                 Ribosome
	    Human-Cell has-part Big-Cytoplasm
Triple: _Human-Cell1 has-part _Big-Cytoplasm1

(source-classes ...) returns the protoroot's class for ONLY protoroots supplying the most SPECIFIC information
source-classes-i = Human-Cell, Euk-Cell, BigEuk-Cell, Human-Cell
source-classes-v = Cell, Euk-Cell, Human-Cell


;;; RETURNS: A list of classes contributing to (i s v) in that direction only (e.g., classes of i),
;;; but NOT the reverse direction (v invs i)		    val

(defun source-classes-for-triple (instance slot value &optional (situation (curr-situation)))
  (let* ((explanations (get-explanations1 instance slot value situation))	; explanations1 - just get in the FORWARD
	 (rules (mapcar #'build-rule explanations)) ;    direction
	 (source-protoroots-i (cond ((anonymous-instancep instance) (source-protoroots-for-instance instance))))
	 (source-protoroots-v 	; only care about the ones supplying the most specific info on value
	  (cond ((anonymous-instancep value) (source-protoroots-for-most-specific-classes-of-instance value))))

	 (source-protoroots-iv		; THESE are the protoroots where the triple came from
	  (cond ((and (anonymous-instancep instance) (anonymous-instancep value))
		 (intersection source-protoroots-i source-protoroots-v))
		((anonymous-instancep instance) source-protoroots-i)
		((anonymous-instancep    value) source-protoroots-v)))

	 (source-classes-iv (my-mapcan #'(lambda (protoroot)
					   (remove-subsumers (immediate-classes protoroot)))
				       source-protoroots-iv))
	 (nonredundant-source-classes-iv (remove-subsumers source-classes-iv)) ; [1]
	 (source-classes 
	  (or nonredundant-source-classes-iv		; don't care about rules, if prototypes already supplied the data
	      (remove-duplicates (my-mapcan #'originated-from-classes rules))))) ; sources from explanations
    
    source-classes))

;;; ALL source protoroots
(defun source-protoroots-for-instance (instance)
  (remove-duplicates
   (my-mapcan #'(lambda (protoinstance) 
		  (get-vals protoinstance '#$prototype-participant-of))
	      (node-cloned-from* instance))))

;;; We're only interested in protoroots that supplied the most SPECIFIC information to instance
(defun source-protoroots-for-most-specific-classes-of-instance (instance)
  (let* ((classes (remove-subsumers (immediate-classes instance)))
	 (protoinstances (node-cloned-from* instance))
	 (protoinstances-of-interest (remove-if-not #'(lambda (protoinstance)	; [1]
							(intersection (immediate-classes protoinstance) classes))
						    protoinstances))
	 (protoroots-of-interest (my-mapcan #'(lambda (protoinstance) 
						(get-vals protoinstance '#$prototype-participant-of))
					    protoinstances-of-interest)))
    protoroots-of-interest))
|#

;;; ======================================================================

(defun compute-triples (&optional triple0)
  (cond 
   (triple0
    (let* ( (triple (km-unique-int triple0))
	    (instance (arg1of triple))
	    (slot (arg2of triple))
	    (value0 (arg3of triple)) 
	    (values (cond ((eq value0 '*) (km-int `#$(the ,SLOT of ,INSTANCE)))	; was (km ...)?
			  (t (val-to-vals value0)))) )
      (mapcar #'(lambda (value) (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 (let* ( (slot+frameadd (minimatch *last-question* '#$(the ?slot of ?frameadd))) 
	      (slot (first slot+frameadd))
	      (frameadd (second slot+frameadd)) )
	(cond 
	 ((not 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 (let ( (instances (km-int frameadd)) 	 	; if *last-answer*, then frames necc. not null
		   (values *last-answer*) )
	      (km-format t "I'll assume you're asking me to justify:~%   ~a = ~a...~%~%" *last-question* values)
	      (mapcan #'(lambda (instance) 
			  (mapcar #'(lambda (value)
				      (list '#$:triple instance slot value))
				  values))
		      instances))))))))

;;; Space-intensive version - see comments below on space-conscious version.
;;; [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 '(#\< #\> #\&))
	   (concat-list (mapcar #'(lambda (char) 
				    (case char
					  (#\< "&lt;")
					  (#\> "&gt;")
					  (#\& "&amp;")
					  (#\' "&apos;")
					  (#\" "&quot;")
					  (t (string char))))
				chars)))
	  (t string))))

#|
======================================================================
Feb 2008: Reini Urban reported that the space-conscious version below by Carl Shapiro does
not work under CLisp. (http://article.gmane.org/gmane.lisp.clisp.devel:17562).
Sam Steingold [sds@gnu.org] reports that his investigation shows that it creates 
circular code which does not work in clisp, sbcl and cmucl.
As a result, I'm restoring the old space-intensive version above.
======================================================================
;; 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.

(defun xml-length (string)
  (do ((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)))))

(defun xmlify-internal (string length new-string)
; (macrolet ((push-string (in-string out-string)
;               `(progn
;                  ,@(apply #'append
;                           (mapcar #'(lambda (char)
;;                                       `((setf (char ,out-string j) ,char)
;;                                         (incf j)))
;; Modified so that this will compile under Lispworks (by Francis Leboutte)
;				       (list `(setf (char ,out-string j) ,char)
;					     `(incf j)))
;                                   (coerce in-string 'list))))))

  (macrolet ((push-string (in-string out-string)
		`(progn ,@(mapcan #'(lambda (char)
				      (list `(setf (char ,out-string j) ,char)
					    `(incf j)))
				  (coerce in-string 'list)))))
	   
    (do ((i 0 (1+ i))
         (j 0))
        ((= i length) new-string)
      (let ((char (char string i)))
        (case char
          (#\<
           (push-string "&lt;"   new-string))
          (#\>
           (push-string "&gt;"   new-string))
          (#\&
           (push-string "&amp;"  new-string))
          (#\'
           (push-string "&apos;" new-string))
          (#\"
           (push-string "&quot;" new-string))
          (t
           (setf (char new-string j) char) (incf j)))))))

(defun xmlify (string)
  (let ((length (length string))
	(new-length (xml-length string)))
    (if (= length new-length)
	string
	(xmlify-internal string length (make-string new-length)))))
|#

;;; ======================================================================
;;; NOT part of KM's inference engine, but a utility for finding the supporting CLASSES for a triple
;;; ======================================================================

;;; [1] If the node leading to triple is deleted, remove its source class as a source of triple
;;; NOTE: triple-expanded-from removes non-existent instances
;;; Returns just the ORIGINAL supports
;(defun get-supports (triple)
;  (let ((f (first triple))
;	(s (second triple))
;	(v (third triple)))
;    (remove-duplicates 
;     (append (intersection (my-mapcan #'prototype-classes (triple-cloned-from-originally triple)) ; prototypes
;			   (my-mapcan #'all-classes (triple-expanded-from triple)))	; [1]
;      	     (my-mapcan #'originated-from-classes 
;			(remove-cloned-from-explns (get-explanations1 f s v))) ; traditional
;	     (my-mapcan #'originated-from-classes 
;			(remove-cloned-from-explns (get-explanations1 v (invert-slot s) f)))))))

#|
(defun get-supports (triple)
  (let ((f (first triple))
	(s (second triple))
	(v (third triple)))
    (remove-duplicates 
     (append (my-mapcan #'originated-from-classes (get-explanations1 f s v))
	     (my-mapcan #'originated-from-classes (get-explanations1 v (invert-slot s) f))))))
|#

;;; NEW: Enforce consistency with get-support-details
;;; RETURNS: A list of classes where support for triple originated.
;;;	Note: If prototype for C is cloned to SubC is cloned to SubSubC, then supports for triple
;;;	      in SubSubC will be just C, not the intermediate class SubC also.
(defun get-supports (triple &key ignore-constraintsp)
  (remove-duplicates
   (my-mapcan #'(lambda (support-detail)
		  (cond ((not (listp support-detail))
			 (report-error 'program-error 
				       "get-supports: (get-support-details ~a) returned a non-list element ~a~%" 
				       triple support-detail))
			((eq (first support-detail) '#$every) (list (second support-detail)))
			((eq (first support-detail) '|<location unknown>|) nil)
			((eq (first support-detail) '#$added-at) (list (second support-detail)))
			((triplep support-detail)
			 (let ((prototype-root (in-prototype support-detail)))
			   (cond (prototype-root (prototype-classes prototype-root))
				 (t (report-error 'program-error 
       "get-supports: support ~a for ~a returned by get-support-details doesn't seem to be part of a prototype!~%"
                                        support-detail triple)))))
			(t (report-error 'program-error 
			       "get-supports: Unrecognized structure ~a returned by (get-support-details ~a)~%" 
			       support-detail triple))))
	      (get-support-details triple :ignore-constraintsp ignore-constraintsp))))

#|
RETURNS: three types of explanation:
	(i) a triple (for prototypes) 
	(ii) a (every ...) expression (for original KM)
	     In principle, might also return (|<location unknown>| <expr>) if can't work out the originating class
	(iii) a (added-at <class> <comment) expression (for manually added links)
  eg: ((_Drive3 object _Car4) (every Control has (object ((a Device)))))
[1] Returns just the ORIGINAL supports: Suppose triple t1 is cloned to t2 is cloned to t3. Now we want to delete t1 and
     its deletable dependents. So when checking deletability, we need to see that t3 is supported by just t1 (rather 
     than t1 and t2) in order to confirm that t3 is indeed deletable.
[2] If all nodes leading to triple are deleted, remove it.
     Method: find all the (cloned-from PN N) supports for triple. If the originating triple is in PN, ensure N exists.
|#
(defun get-support-details (triple &key ignore-constraintsp) ; e.g., (_Drive1 object _Car2), from get-supports/get-supports.km example
  (let* ((f (first triple))
	 (s (second triple))
	 (v (third triple))
	 (explanations (append (get-explanations1 f s v) (get-explanations1 v (invert-slot s) f)))
; e.g., explanations = ((cloned-from _Drive3 _Drive1) (a Device (@ _Drive1 Control object)))
;	 (_ee (km-format t "explanations = ~a~%" explanations))
	 (originating-triples (triple-cloned-from-originally triple)) ; [1]  See kr/get-supports/test-get-supports3.lisp
;	 (originating-triples (triple-cloned-from triple)) ; [1]
	 (originating-triples+prototypes (mapcar #'(lambda (originating-triple)
						    (list originating-triple (in-prototype originating-triple)))
						 originating-triples))
; e.g., originating-triples+prototypes = (((_Drive3 object _Car4) _Drive3))	 
;	 (_dd (km-format t "originating-triples+prototypes = ~a~%" originating-triples+prototypes))
;	 (_ds (km-format t "explanations = ~a~%" explanations))
	 (still-valid-originating-triples ; [2]
	  (remove nil 
 	   (mapcar #'(lambda (originating-triple+prototype)
		       (let* 
			((originating-triple (first originating-triple+prototype)) ; (_Drive3 object _Car4)
			 (prototype (second originating-triple+prototype)) ; _Drive3
			 (expanded-from (remove nil
					 (mapcar #'(lambda (explanation) ; (cloned-from _Drive3 _Drive1) -> _Drive1
						    (cond ((and (eq (explanation-type explanation) '#$cloned-from)
								(eq (second explanation) prototype)) ; protoroot node
							   (third explanation))))	; corresponding node in clone
						explanations))))
			(cond ((some #'known-frame expanded-from) originating-triple)))) ; if _Drive1 deleted, drop
		   originating-triples+prototypes)))					 ;    (_Drive3 object _Car4)
;   (km-format t "still-valid-originating-triples = ~a~%" still-valid-originating-triples)

;;; Note: copied constraints in (every X has (slot ((a Y with ((must-be-a Z)))))) WILL be collected by the
;;; normal access to the explanation database, just like normal values.	 
;;; The below ADDITIONALLY captures non-copied constraints
	 (constraints-on-classes ; special case for constraints on "every" expressions: These are NOT copied, so look up
	  (cond ((constraint-exprp v)
		 (let* ((inherited-rule-sets (inherited-rule-sets f s :retain-commentsp t))
			(constraints (remove nil (mapcan #'find-constraints-in-exprs inherited-rule-sets))))
;		   (km-format t "constraints = ~a~%" constraints)
		   (remove nil
		    (mapcar #'(lambda (constraint)
			(cond ((equal v (desource+decomment constraint))
			       (build-rule constraint))))
			    constraints))))))
	 )
;    (km-format t "explanations = ~a~%" explanations)
    (remove-duplicates					 
     (append still-valid-originating-triples 				     ; prototype supports
	     (remove nil
	      (mapcar #'(lambda (expln)
			  (build-rule expln :ignore-constraintsp ignore-constraintsp))
		      (remove-cloned-from-explns explanations))) ; traditional (every X has ...) supports
	     constraints-on-classes)
     :test #'equal)))			; AND (added-at <class> <comment>) supports

(defun add-support (triple support &key (situation (curr-situation)))
  (let ((f (dereference (first triple)))
	(s (second triple))
	(v (dereference (third triple))))
    (cond 
     ((minimatch support '#$(added-at ?x ?y))
      (record-explanation-for `#$(the ,S of ,F) V support :situation situation)) ; which situation should we use?
     (t (report-error 'user-error
	      "add-support: Bad support structure ~a!~%Support structure must be of the form (added-at <class> <string>)~%"
	      support)))))

;;; Essentially a synonym for delete-explanation
(defun remove-support (triple support &key (situation (curr-situation)))
  (cond ((null support)
	 (report-error 'user-error "remove-support: Support to remove cannot be NIL!~%"))
	(t (let ((f (first triple))
		 (s (second triple))
		 (v (third triple)))
	     (delete-explanation f s v :explanation-to-delete support :situation situation)))))

(defun remove-supports (triple &key (situation (curr-situation)))
  (let ((f (first triple))
	(s (second triple))
	(v (third triple)))
    (delete-explanation f s v :explanation-to-delete 'all :situation situation))) ; keyword 'all means all explanations

(defun remove-cloned-from-explns (explanations)
  (remove-if #'(lambda (x) (and (listp x) (eq (explanation-type x) '#$cloned-from))) explanations))
     
;;; Copy explanations for (i s v) to a new triple (i' s v'), where renaming-alist
;;; provides bindings for renaming i, v, and all variables in the explanations.
(defun copy-explanations-for (triple &key (from-situation (curr-situation)) (to-situation *global-situation*)
					  renaming-alist)
  (let* ((instance (first triple))
	 (slot (second triple))
	 (val (third triple))
	 (invslot (invert-slot slot))
	 (r-instance (sublis renaming-alist instance))
	 (r-val (sublis renaming-alist val)))
    (mapc #'(lambda (r-explanation)
	      (record-explanation-for `#$(the ,SLOT of ,R-INSTANCE) r-val r-explanation :situation to-situation))
	  (sublis renaming-alist (get-explanations1 instance slot val from-situation)))
    (mapc #'(lambda (r-explanation)
	      (record-explanation-for `#$(the ,INVSLOT of ,R-VAL) r-instance r-explanation :situation to-situation))
	  (sublis renaming-alist (get-explanations1 val invslot instance from-situation)))
    t))

;;; ======================================================================

;;; Remove all explanations saying a triple was cloned from <protoroot>
(defun remove-cloned-from-explanations (isv-explanations protoroot)
  (remove-if #'(lambda (isv-explanation)
		 (let ((explanation (explanation-in isv-explanation)))
		   (and (eq (explanation-type explanation) '#$cloned-from)
			(eq (second explanation) protoroot))))
	     isv-explanations))
  

;;; FILE: kbutils.lisp

;;; File: kbutils.lisp
;;; Author: Peter Clark
;;; Date: Separated out Mar 1995
;;; Purpose: Basic utilities for KM

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

;;; ======================================================================
;;; 		RECOGNITION OF INSTANCES
;;; ======================================================================

(defun km-null (km-nil) 
  (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.
(defun simple-slotp (slot) 
  (and (symbolp slot) 
       (member slot (get-vals '#$Slot '#$instances :situation *global-situation*))))

(defun slotp (slot)
  (and (symbolp slot) 
       (intersection (cons '#$Slot (all-subclasses '#$Slot))
		     (get-vals slot '#$instance-of :situation *global-situation*))))

;;; Check is' a valid slot
(defun slot-objectp (slot) (and (symbolp slot) (not (null slot))))

;;; Rather crude approximation of a test...
(defun pathp (path) (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)
(defun is-km-term (concept)
  (or (atom concept)		; includes: 1 'a "12" nil
      (descriptionp concept)
      (quoted-expressionp concept)
      (km-structured-list-valp concept)
      (km-setp concept)
      (functionp concept)
      (constraint-exprp concept)))

(defun is-simple-km-term (concept)
  (or (and (atom concept)		; includes: 1 'a "12" nil
	   (not (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
(defun fully-evaluatedp (concept &key in-structured-exprp)
  (or (and (atom concept) (neq concept '*))		; includes: 1 'a "12" nil
      (and (quoted-expressionp concept)
	   (not (recursive-find 'unquote concept)))
      (the-class-exprp concept)				; (the-class ...)
      (and (km-setp concept)				; (:seq (:set 1 2)) is fully evaluated!
	   in-structured-exprp				; (:seq (:set (:set 1 2) 3)) is not!
	   (every #'(lambda (el) (fully-evaluatedp el :in-structured-exprp nil)) (val-to-vals concept)))
      (and (km-structured-list-valp concept)
	   (every #'(lambda (el) (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.
(defun classp (class)
  (or (member class *built-in-classes*)
      (and (kb-objectp class)
	   (or (get-vals class '#$superclasses)
	       (and (not (get-vals class '#$instance-of))
		    (or (get-vals class '#$instances)
			(get class 'member-properties)
			(get class 'member-definition)
			(get-vals class '#$subclasses)))))))


;;; Proves (just about) it's definitely an instance, though there may
;;; be other instances which fail this test.
(defun is-an-instance (instance)
  (or (anonymous-instancep instance)
      (numberp instance)
      (stringp instance)
      (functionp instance)
      (descriptionp instance)
      (km-structured-list-valp instance)
      (and ; (is-km-term instance) bug!
           (kb-objectp instance)
	   (or (get-vals instance '#$instance-of :facet 'own-properties)
	       (get-vals instance '#$instance-of :facet 'own-definition)))))
;; Time consuming!
;	   (not (classp instance)))))   ; just in case #$instance-of is a class-metaclass relation

;;; No taxonomic info declared, but IS some other info declared
(defun orphanp (concept)
  (and (kb-objectp concept)
       (not (get-vals concept '#$superclasses))
       (not (get-vals concept '#$subclasses))
       (not (get-vals concept '#$instances))
       (not (get-vals concept '#$instance-of))
; No, these won't put the thing in the taxonomy - the slots are for indexing purposes only       
;      (not (get-vals concept '#$instance-of :facet 'member-definition))
;      (not (get-vals concept '#$instance-of :facet 'own-definition))
       (not (built-in-concept concept))))

;;; _car12
(defun anonymous-instancep (instance0)
  (let ( (instance (dereference instance0)) )
    (and (symbolp instance)
	 (char= (first-char (symbol-name instance)) *var-marker-char*))))

;;; This function's really badly named, as it really means not an instance. Will phase this out.
;;; *pete, 32, "234", #'print
(defun named-instancep (instance) (not (anonymous-instancep instance)))

;;; Not used any more
(defun fluent-instancep (instance) (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.
(defun kb-objectp (instance) 
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))	; optimization from Francis Leboutte
  (and instance
       (symbolp instance) 
       (not (user-commentp instance))
;OLD   (not (member instance '#$(nil NIL :seq :bag :args :triple :pair :function)))))	; later: allow stuff on 't'!
       (case instance
	 (#$(nil :set :seq :bag :args :triple :pair :function :incomplete) nil) ; later: allow stuff on 't'!
	 (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!!
(defun km-structured-list-valp (val)
  (and (listp val) (member (first val) *structured-list-val-keywords*))) ; defined in interpreter.lisp

(defun km-functionp (val) (and (listp val) (eq (first val) '#$:function)))

(defun km-triplep (triple) 
  (and (listp triple) (eq (first triple) #$:triple) (= (length (desource+decomment triple)) 4)))

;;; recognize sequences eg. (:seq a b c)
(defun km-seqp (seq)  (and (listp seq) (eq (first seq) '#$:seq)))
(defun km-bagp (bag)  (and (listp bag) (eq (first bag) '#$:bag)))
(defun km-pairp (seq) (and (listp seq) (eq (first seq) '#$:pair)))

;;; '(:seq a b) -> (a b)
(defun bag-to-list (bag) (rest bag))
(defun seq-to-list (seq) (rest seq))
(defun set-to-list (set) (rest set))
(defun pair-to-list (pair) (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)
(defun flatten-sets (vals)
  (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.
(defun flatten-set (set)
  (cond ((km-setp set) (my-mapcan #'flatten-set (set-to-list set)))
	(t (list set))))

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

;;; (km-varp ?x) -> t
(defun km-varp (var)
  (and (symbolp var)
       (char= (first-char (symbol-name var)) #\?)))

;;; recognize a single expression as a set eg. (:set a b c)
(defun km-setp (set)
  (and (listp set) (eq (first set) '#$:set)))

;;; e.g. (a Cat called "fido")
(defun km-tagp (tag)
  (or (and (atom tag) (not (null tag)))
      (constraint-exprp tag)
      (and (km-setp tag) (every #'km-tagp (set-to-list tag)))))

;;; Optimized version from Francis Leboutte
;;; (defun km-argsp (args) (and (listp args) (eq (first args) '#$:args)))
(defun km-argsp (args)
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (and (listp args)
       (eq (first args) '#$:args)))

(defun km-defaultp (expr)
  (and (listp expr) (eq (first expr) '#$:default)))

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

(defun comparison-operator (slot)
  (or (member slot *inequality-relations*)
      (member slot *equality-relations*)
      (assoc slot *user-defined-infix-operators*)))

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

(defun &-exprp (expr) (and (listp expr) (member (second expr) '(& &! &+ ==))))	; but not &? &+?
(defun &&-exprp (expr) (and (listp expr) (member (second expr) '(&& &&! ===))))

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

;;; Accessing (:args ...) structures:
;(defun arg1of (arg-structure) (second arg-structure))		; (:args a b) -> a
(defun arg1of (arg-structure)	; optimized by Francis Leboutte
  (declare (type list arg-structure))
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (second arg-structure))

(defun arg2of (arg-structure) (third arg-structure))		; (:args a b) -> b
(defun arg3of (arg-structure) (fourth arg-structure))
(defun arg4of (arg-structure) (fifth arg-structure))	

;;; [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.
;;; 1/30/07: Need to modify to check dereference is actually applied, and if not copy the list.
;(defun remove-dup-instances (instances)
;  (delete-duplicates (dereference instances) :test #'km-equal :from-end t))
(defun remove-dup-instances (instances)
  (let ((copied-dereferenced-instances (cond ((needs-dereferencing instances) (dereference0 instances))
					     (t (copy-tree instances)))))
    (delete-duplicates copied-dereferenced-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 #'km-equal :from-end t))
|#
(defun remove-dup-atomic-instances (instances) (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
;; [3] we short-circuit the call to the compound structure tests.
;;     Thanks to Sunil Mishra for this!
(defun km-equal (i1 i2)
  (declare (optimize (safety 1) (speed 3)))
  (cond ;; Fast, atomic type comparisons are done first.
	((eq i1 i2))   				; [2]
	((null i1) (eq i2 '#$nil))
	((null i2) (eq i1 '#$nil))
;	((or (symbolp i1) (symbolp i2)) (eq i1 i2))	; [2]
	((or (symbolp i1) (symbolp i2)) nil) ; [3]
	((and (numberp i1) (numberp i2) *tolerance*)
	 (<= (abs (- i1 i2)) (min *tolerance*
				  (* (max (abs i1) (abs i2)) *tolerance*))))	; [1]
	((or (numberp i1) (numberp i2)) nil) ; [3]
	((and (equal i1 i2) 
	      (not (existential-exprp i1)) 
	      (not (km-structured-list-valp i1))))  ; (:pair (a Move) 1) (:pair (a Move) 1) are NOT equal
	((or (atom i1) (atom i2)) nil) ; [3]
	((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-argsp i1) (km-argsp i2)) (km-seq-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))
	((and (km-triplep i1) (km-triplep i2)) (km-seq-equal i1 i2))))


; OLD  VERSION
;(defun km-equal (i1 i2)
;  (cond ;; Fast, atomic type comparisons are done first.
;	((eq i1 i2))   				; [2]
;	((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*))))	; [1]
	;; The slow, aggregate type comparisons follow.
;	((and (equal i1 i2) (not (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))))

(defun km-set-equal (set1 set2) (not (set-exclusive-or set1 set2 :test #'km-equal)))

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

(defun km-bag-equal (bag1 bag2)
  (and (= (length bag1) (length bag2))
       (km-bag-equal0 bag1 bag2)))

(defun km-bag-equal0 (bag1 bag2)
  (cond ((equal bag1 bag2))				; equal is subset of km-equal
	((member (first bag1) bag2 :test #'km-equal)
	 (km-bag-equal0 (rest bag1) (remove (first bag1) bag2 :test #'km-equal :count 1)))))

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

(defun km-seq-equal (seq1 seq2)
  (and (= (length seq1) (length seq2))
       (km-seq-equal0 seq1 seq2)))

(defun km-seq-equal0 (seq1 seq2)
  (cond ((and (null seq1) (null seq2)))		; NOTE: (a Move) (a Move) are NOT equal
	((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.
(defun situation-invariant-exprp (expr)
  (and (listp expr) (eq (first expr) '#$a)))

(defun constraint-exprp (expr)
  (or (val-constraint-exprp expr)
      (set-constraint-exprp expr)))

(defun retain-exprp (expr) (and (listp expr) (eq (first expr) '#$retain-expr)))

(defun non-constraint-exprp (expr) (not (constraint-exprp expr)))

(defun val-constraint-exprp (expr)
  (and (listp expr) 
       (member (first expr) *val-constraint-keywords*)))

(defun set-constraint-exprp (expr)
  (or (eq expr '#$:incomplete)
      (and (listp expr) 
	   (member (first expr) *set-constraint-keywords*))))

(defun km-boolean-exprp (expr)
  (and (listp expr)
       (or (member (first expr) '#$(is-true all-true some-true theoneof theoneof2 exists has-value))
	   (member (second expr) '#$(&? &+? = /= > < >= <= and or not numberp is-subsumed-by subsumes 
					covers isa is includes is-superset-of))
	   (member (third expr) '#$(must))
	   (member (fifth expr) '#$(must)))))

;;; Experimental
(defun sometimes-exprp (expr)
  (and (listp expr) (eq (first expr) '#$sometimes)))

;;; Returns non-nil if expr contains (at least) one of symbols.
(defun contains-some-existential-exprs (exprs)
  (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.
(defun existential-exprp (expr) 
  (and (listp expr) 
       (or (member (first expr) '#$(a some))
	   (and (comment-tagp (first expr)) 		; allow ([Car1] a Big Engine)
		(existential-exprp (rest expr))))))

;;; (some <x>)
(defun fluent-instance-exprp (expr) 
  (and (listp expr) (eq (first expr) '#$some)))

;;; ======================================================================

(defun val-to-vals (val)
  (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))

(defun vals-to-val (vals)
  (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)) :single-valuedp t)  -> (a & b & c)
;;; single-valuedp = T:   (val-sets-to-expr '((a b) (c)) :single-valuedp t) -> ERROR! and (a & c)
;;; single-valuedp = NIL: (val-sets-to-expr '((a b) (b) (c d))) -> ((a b) && (b) && (c d))
;;; combine-values-by-appendingp = T: (val-sets-to-expr '((a b) (b) (c d))) -> (:set a b c d)
(defun val-sets-to-expr (exprs0 &key single-valuedp combine-values-by-appendingp 
				     (joiner (cond (single-valuedp '&) (t '&&))))
  (let* ((exprs1 (remove-duplicates (remove nil exprs0) :test #'equal :from-end t))
	 (exprs (cond ((some #'(lambda (x)
				 (cond ((not (listp x))
					(report-error 'user-error "val-sets-to-expr: Single value ~a found where list of values expected! Listifying it...~%" x) t)))
			     exprs1)
		       (mapcar #'listify exprs1))
		      (t exprs1))))
    (cond ((null exprs) nil)
	  ((singletonp exprs) (vals-to-val (first exprs)))
	  (combine-values-by-appendingp (vals-to-val (remove-dup-instances (apply #'append exprs))))
	  (t (val-sets-to-expr0 exprs :single-valuedp single-valuedp :joiner joiner)))))

(defun val-sets-to-expr0 (exprs &key single-valuedp (joiner (cond (single-valuedp '&) (t '&&))))
  (cond 
   ((endp exprs) nil)
   ((null (first exprs)) (val-sets-to-expr0 (rest exprs) :single-valuedp single-valuedp :joiner joiner))
; Now tested earlier in val-sets-to-expr
;   ((not (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)) :single-valuedp single-valuedp :joiner joiner))
   (t (let ( (first-item (cond (single-valuedp 
				(cond ((not (singletonp (first exprs)))		; error! (a b) found 
				       (km-trace 'comment
						 "Multiple values ~a found for single-valued slot!~%Assuming they should be unified...~%"
						 (first exprs))
				       (vals-to-&-expr (first exprs) :joiner joiner)) ; (a b) -> (a & b) (sing-val slot)
				      (t (first (first exprs))))) ; (a)   -> a		(single-valued slot)
			       (t (first exprs))))				; (a b c) -> (a b c)	(multivalued slot)
	     (linked-rest (val-sets-to-expr0 (rest exprs) :single-valuedp single-valuedp :joiner joiner)))
	(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)
(defun un-andify (vals)
  (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!
(defun &-expr-to-vals (expr)
  (cond ((null expr) nil)
	((&-exprp expr)
	 (cond (;(eq (fourth expr) '&)				; (x & y & ...)
		(val-unification-operator (fourth expr))
		(&-expr-to-vals `(,(first expr) ,(fourth expr) ,(rest (rest expr)))))
	       (t (cond ((not (= (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)
(defun vals-to-&-expr (vals &key (joiner '&) (first-time-through t))
  (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)
(defun valsets-to-&&-exprs (valsets)
  (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))))
(defun &&-exprs-to-valsets (exprs)
  (cond ((singletonp exprs)
	 (let ( (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
(defun find-constraints-in-exprs (exprs) 
; (find-constraints exprs 'plural))
; (desource+decomment 		; NEW: Remove desource+decomment, as we have comments on must-be-a
   (find-exprs exprs :expr-type 'constraint :plurality 'plural)) ; [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
;;; expr-type = constraint | non-constraint | default | any
(defun find-exprs (expr &key expr-type (plurality 'singular))	; ie. a single expr given
  (cond ((null expr) nil)
	((and (listp expr)
	      (unification-operator (second expr)))
	 (cond ((>= (length expr) 4)
		(cond ((not (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))    ; (a & b & c) -> (a & (b & c))
	       (t (let ( (next-plurality (cond (; (eq (second expr) '&) 'singular)   ; & takes a value as arg, && takes a list of values
						(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)		; & -> a single value/expr is given
	      (case expr-type
		    (constraint (constraint-exprp expr))
		    (non-constraint (not (constraint-exprp expr)))
		    (default (km-defaultp expr))
		    (any t)
;		    (override (overridep expr))
		    (t (report-error 'program-error "find-exprs: Unrecognized expr-type `~a'!~%" expr-type))))
	 (list expr))
	((and (eq plurality 'plural)		; special case - allowed to recurse if only one member
	      (singletonp expr))
	 (find-exprs (first expr) :expr-type expr-type :plurality 'singular))
	((and (eq plurality 'plural)			; && -> a list of values is given
	      (listp expr))
	 (mapcan #'(lambda (subexpr) (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)
(defun remove-constraints (vals)
  (cond ((not *are-some-constraints*) vals)
	((null vals) nil)
	((and (singletonp vals)
	      (listp (first vals)) 
;	      (eq (second (first vals)) '&))					; single-valued-slot format ((a & (must-be b)))
	      (val-unification-operator (second (first vals))))
	 (remove-if #'constraint-exprp (&-expr-to-vals (first vals))))
	(t (remove-if #'constraint-exprp vals))))

(defun extract-constraints (vals)
  (cond ((not *are-some-constraints*) nil)
	((null vals) nil)
	((and (singletonp vals)
	      (listp (first vals)) 
;	      (eq (second (first vals)) '&))					; single-valued-slot format ((a & (must-be b)))
	      (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
;;; ======================================================================

(defun quoted-expressionp (expr) (quotep expr))

(defun quoted-descriptionp (expr) 
  (and (quotep expr)
       (listp (unquote expr))
       (eq (first (unquote expr)) '#$every)))

;;; '(every ...) or (the-class ...)
(defun descriptionp (expr)
  (or (quoted-descriptionp expr)
      (the-class-exprp expr)))

(defun the-class-exprp (expr) (and (listp expr) (eq (first expr) '#$the-class)))

;;; '(a Cat) -> t	   
(defun instance-descriptionp (expr &key (fail-mode 'fail))
  (cond 
   ((and (quoted-expressionp expr)
	 (listp (unquote expr)))
    (cond 
     ((existential-exprp (unquote expr)))
     ((km-triplep (unquote expr)))		; <--- Bit of a fudge here: subsumes also handles triples as if they were descriptions
     ((eq fail-mode 'error)
      (cond 
       ((eq (first (unquote expr)) '#$every)	; '(every Cat) -> ERROR
	(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
(defun class-descriptionp (expr &key (fail-mode 'fail))
  (cond 
   ((quoted-descriptionp expr)
    (list (second (unquote expr)) (rest (rest (rest (unquote expr))))))
   ((the-class-exprp expr)		; (the-class X with Y)
    (let ( (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))	; '(every Cat) -> ERROR
    (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))))

;;; (classes-in-description '#$(the-class X with (instance-of (Y)) (instance-of (Z)))) -> (X Y Z)
(defun classes-in-description (expr)
  (let* ((class+slotsvals (class-description-to-class+slotsvals expr))
	 (class (first class+slotsvals))
	 (slotsvals (second class+slotsvals))
	 (other-classes (my-mapcan #'(lambda (slotvals) (cond ((eq (slot-in slotvals) '#$instance-of) (vals-in slotvals)))) slotsvals)))
    (cons class other-classes)))

(defun class-description-to-class+slotsvals (expr &key (fail-mode 'fail))
  (class-descriptionp expr :fail-mode fail-mode))

;;; Name: a symbol denoting a function -- allows km-lisp-exprs* and *downcase-km-lisp-exprs* to be 
;;; dynamically extended (thanks to Francis Leboutte)
(defun add-lisp&KM-function (name)
  (pushnew name *km-lisp-exprs* :test #'eq)
  (pushnew (intern (string-downcase name) *km-package*)
           *downcase-km-lisp-exprs*
           :test #'string=))


;;; ======================================================================

#|
The following KB has 4 axioms, one shown on each line:
(every Car has (parts ((a Engine with 			; Note 2 axioms: Engine, and
			  (parts ((a Fuel-Filter)))))) 	; parts of that Engins = Fuel-Filter
       (color (red)))
(Car has (superclasses (Vehicle)))

[1] Note that ground facts (Car has (superclasses (Vehicle))) will get counted twice, once in each direction,
    so let's divide this count by 2.
[2] Each separate axiom in a large KM expr is tagged internally with a "@" for explanation purposes
    Do (setq *developer-mode* t) then (showme <concept>) to see the @ visually
|#
(defun kb-size ()
  (let ((n 0))
    (mapc #'(lambda (concept)
	      (cond
	       ((not (anonymous-instancep concept)) ; avoid prototypes and run-time Skolems
		(mapc #'(lambda (facet)
			  (mapc #'(lambda (situation)
				    (mapc #'(lambda (slotvals)
					      (mapc #'(lambda (val)
							(cond ((kb-objectp val) (setq n (+ n 0.5))) ; [1]
							      (t (let ((n-embedded-rules
									(length (remove-if-not #'(lambda (x) 
												   (eq x '@)) ; [2]
											       (flatten val)))))
								   (setq n (+ n n-embedded-rules))))))
						    (vals-in slotvals)))
					  (get-slotsvals concept :facet facet :situation situation)))
				(all-situations-and-theories)))
		      *all-facets*))))
	  (get-all-concepts))
    (values (floor n))))		; return integer for neatness
;;; FILE: prototypes.lisp

;;; File: prototypes.lisp
;;; Author: Peter Clark
;;; Purpose: Knowledge Representation using Prototypes -- the answer to life!

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

#|
An explanation is recorded for cloned triples such as:

	(explanation (:triple <clone-node> <slot> <val>) ((cloned-from <prototype-root> <clone-root> <prototype-node>)))
	(explanation (:triple _Entity23 agent-of _Foo22) ((cloned-from _ProtoFoo7 _Foo22 _ProtoEntity10)))

where <prototype-root> was cloned onto <clone-root>, resulting in <prototype-node> cloning to <clone-node>.	

NOTES:
If B is cloned from ProtoA, then raised to a prototype ProtoB, then ProtoB cloned to C:
Normally (if *record-explanations-for-clones* is t), triples in C will have explanations 
		(cloned-from ProtoB) (cloned-from ProtoA)
But with *record-explanations-for-clones-selectively* set to t (and *record-explanations-for-clones* t),
		triples in C will just retain the ORIGINAL source explanation (cloned-from ProtoA).
		Note: If the triple in ProtoA had it's own explanation e.g., from (every SuperA has ....),
		then (cloned-from ProtoA) would not be recorded in C, rather (again) just the original source
		would be recorded.
|#
;(defparameter *record-explanations-for-clones-selectively* t) ; NO! Need nil for some fns, e.g., triple-expanded-from
;(defparameter *record-explanations-for-clones-selectively* nil) 

(defparameter *clone-built-from-slot* '#$clone-built-from)
(defparameter *add-cloned-from-links* t)
(defparameter *propogate-explanations-to-clones* t) ; see knowledge-revision/add-triple-asif-cloned/test-clones-of-clones.lisp for why is needed

;;; This always T, except for the special case of AURA when we can skip this. See [4] in (defun clone () ...) later
(defparameter *dereference-explanations-during-cloning* t)

;;; Used for cloning itself: Don't clone these slots' values when cloning the prototype graph.
;;; cloned-from and clone-built-from NOT in this list, to allow clones to be added into prototypes
;;; Make this a parameter (not constant), so user can change it
(defparameter *unclonable-slots* 
    '#$(prototype-participant-of prototype-participants 
	prototype-of prototypes
	prototype-scope
	has-clones 
	has-built-clones))

;;; The above parameter might change, but this one won't. This is used:
;;; - in save-prototype and trim-prototype to bypass the check that a slot's values are all participants
;;;	(and remove the non-participants). These special slots are allowed to have non-participant values.		
;;; - in build-clone, to take care of an obscure case: In obscure circumstances, a non-root might be 
;;;	cloned-from its own root. During cloning, we do NOT want these particular cloned-from values to
;;;	be copied to the clone.
(defparameter *slots-with-nonparticipant-skolems* 
    '#$(cloned-from
	clone-built-from
	has-clones 
	has-built-clones))

;;; We don't want to save the run-time clones in a prototype to disk (see writer.lisp), as the clones don't persist.
(defparameter *prototype-slots-not-to-save-to-file* '#$(has-clones has-built-clones))

;;; Purpose: save-prototype will output these, even though their values are not prototype-participants.
; (defparameter *prototype-bookkeeping-slots* '#$(has-clones has-built-clones cloned-from clone-built-from))
; (defparameter *prototype-bookkeeping-slots* '#$(has-clones has-built-clones))
; Now hard-wired into writer.lisp

;;; We can tell if it's cloned or not like this
(defun isa-clone (instance) 
  (and (kb-objectp instance) 
       (get-vals instance '#$cloned-from :situation *global-situation*)))

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

; (defvar *curr-prototype* nil)		; in header.lisp
(defun am-in-prototype-mode () *curr-prototype*)
(defun curr-prototype () *curr-prototype*)

(defun protoinstancep  (concept) 
  (and (kb-objectp concept) (get-vals concept '#$prototype-participant-of :situation *global-situation*)))
(defun prototypep (concept) 
  (and (kb-objectp concept) (get-vals concept '#$prototype-of :situation *global-situation*)))
;; Synonym
(defun protorootp (concept) (prototypep concept))

;;; Returns: The prototype root (an instance)
;;; Updated by Sunil Mishra: 
;;; Subject: [JIRA] Commented: (HLO-1755) triple-cloned-from doesn't work forcomplex values
;;; Triples claims the triple doesn't exist in the KB. Below is an updated version that I think does what you'd intended.
(defun in-prototype (triple)
  (let* ((f (dereference (first triple)))
	 (s (second triple))
	 (v (dereference (third triple))))
    (cond 
      ((not (member v (get-vals f s :situation *global-situation*) :test #'equal))
       (report-error 'user-error "~a does not exist as part of a prototype in the KB!" triple triple))
      (t (let* ((prototype-roots0
		 (cond ((anonymous-instancep v)
			(list (get-unique-val f '#$prototype-participant-of)
			      (get-unique-val v '#$prototype-participant-of)))
		       ((consp v)
			(cons (get-unique-val f '#$prototype-participant-of)
			      (mapcan (lambda (v-item)
					(when (anonymous-instancep v-item)
					  (list (get-unique-val v-item '#$prototype-participant-of))))
				      (flatten v))))
		       (t (list (get-unique-val f '#$prototype-participant-of)))))
		(prototype-roots (remove-duplicates (remove nil prototype-roots0))))
	   (cond ((null prototype-roots)
		  (report-error 'user-error "~a is not part of a prototype!" triple triple))
		 ((not (singletonp prototype-roots))
		  (report-error 'user-error 
				"~a appears to incoherently be part of multiple prototypes!"
				triple triple))
		 (t (first prototype-roots))))))))

					; 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?
;;; [ How it works: *recursive-prototypes* is NIL, and unify-in-prototypes is only called if *use-prototypes* is T ]
;;; [2] NOTE: unifying in applicable prototype1 may result in applicable prototype2 not being needed any
;;;	      more, because protoroot1 was clone-built-from* protoroot2 (thus after cloning in prototype1,
;;;	      instance will be clone-built-from* protoroot2 also, i.e., already include prototype2 within it).
(defun unify-in-prototypes (instance0 &optional slot)
;    (let* ((*are-some-prototypes* nil)		; [1] local scope change, prevents recursive prototype cloning
; (let* ((*are-some-prototypes* *recursive-prototypes*) ; [1] local scope change, prevents recursive prototype cloning 
  (let* ((*use-prototypes* *recursive-prototypes*) ; [1] local scope change, prevents recursive prototype cloning 
;	 (*unifying-in-prototype* t)		   ; Additional flag, for lazy-unify-vals - no, not needed
	 (instance (dereference instance0)) 		; NEW: Allow that prevention to be toggleable
	 (all-applicable-prototypes (all-applicable-prototypes instance slot)))
    (mapc #'(lambda (prototype) 
	      (cond ((not (member prototype (clone-built-from* instance)))	; [2]
		     (unify-in-prototype instance prototype slot))))
	  all-applicable-prototypes)
    all-applicable-prototypes))

#|
[3] NOTE: defined-prototypes includes ALL prototypes, i.e., is a superset of (<class> has (prototypes (<x>))) values.
    That is, if we simply have (_Car1 has (prototype-of (Car)) (prototype-scope (Car)))  then  (get '#$Car '#$defined-prototypes) *will* include _Car1
Note: the fact _Euk-cell14 below has a definition on it will be logged on Cell (property 'defined-prototypes):
(_Euk-cell14 has 
  (instance-of (Euk-cell))
  (prototype-of (Euk-cell))
  (prototype-scope (Euk-cell
                    (the-class Cell with (has-part ((a Nucleus))))))

(get '#$Cell 'defined-prototypes) -> (|_Euk-cell14|)
(get '#$Euk-Cell 'defined-prototypes) -> (|_Euk-cell14|)
|#
(defun all-applicable-prototypes (instance &optional slot)
  (remove-if-not #'(lambda (prototype) 				; NEW [2]
		     (suitable-for-cloning instance slot prototype))
		 (my-mapcan #'(lambda (class) 
;				(get-vals class '#$prototypes :situation *global-situation*) 
;				(km-format t "(get ~a 'defined-prototypes) = ~a~%" class (get class 'defined-prototypes))
				(get class 'defined-prototypes))   ; [3]
			    (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
(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.
|#    
(defun unify-in-prototype (instance prototype &optional slot)	; slot is purely for tracing purposes
  (cond (*trace-unify-in-prototype* 
	 (km-format t "UNIFYING IN PROTOTYPE ~a for ~a~%" prototype instance))) ; just for Shaken use
  (push-to-goal-stack `#$(unify-with-clone-of ,PROTOTYPE))			; [6]
  (let ((clone (km-unique-int `#$(clone ,PROTOTYPE))))		; [3] route through query interpreter for tracing

    (cond ((null slot) (make-comment "Cloned ~a~28T  -> ~a~%~43Tto find all info about ~a" prototype clone instance))
	  (t (make-comment "Cloned ~a~28T  -> ~a~%~43Tto find (the ~a of ~a)" prototype clone slot instance)))

;    In theory, this should be redundant as we already have (instance has (cloned-from (prototype))) created during
;    the cloning operation. Anyway, leave it here.    
; JUNE 2007 - No let's try removing it     
;   (add-val instance *clone-built-from-slot* prototype) ; restating default extra args unnecessary

#|
If the prototype SPECIALIZES the classes on instance, then record the explanation why.
This rarely fires, but occasionally is needed (see test-suite/prototypes.km) when there are class expressions on
the prototype-scope. The example is:
	(_ProtoPerson2 has (protoype-scope (Person (the-class Animal with (parts ((a Big-Brain)))))))
	(a Animal with (parts ((a Big-Brain)))) -> _Animal1
	(get-explanation-data '#$_Animal1) ->
	    (_Animal1 instance-of Person (_Animal1 isa (the-class Animal with (parts ((a Big-Brain))))))
|#
     (cond (*record-explanations* 
	    (let ((old-classes (immediate-classes instance))	; Animal
		  (new-classes (immediate-classes prototype)))	; Person (the-class Animal with (parts (a Big-Brain)))
	      (cond ((not (classes-subsume-classes new-classes old-classes)) ; so new-classes SPECIALIZE old-classes...
		     (let ((target `#$(the instance-of of ,INSTANCE))
			   (prototype-scopes (subst instance prototype 		; update Self after cloning
						    (get-vals prototype '#$prototype-scope))))
		       (mapc #'(lambda (new-class)
				 (mapc #'(lambda (prototype-scope)
					   (cond ((the-class-exprp prototype-scope)
						  (record-explanation-for target new-class `#$(,INSTANCE isa ,PROTOTYPE-SCOPE)))))
				       prototype-scopes))
			     new-classes)))))))

; [10] If instance is already cloned-from prototype (but is necessarily not clone-built-from prototype, else we 
;      wouldn't be unifying in the prototype in the first place), then instance's graph may already contain *part* 
;      of the prototype. This is the condition for considering &&! for combine-values-by-appending slots, to 
;      stop the values growing endlessly.
; [11] Suppose X cloned-from, but not clone-built-from, Y, i.e., X is partially clone from Y.
;      Now we have A, we unify in a clone of X  (-> A cloned-from X), now we consider unifying in a clone of Y.    
;      We need to register that Y is already partially included in A, hence we need to use cloned-from*, not cloned-from.
;    (cond ((member prototype (get-vals instance '#$cloned-from)) ; [11]
     (cond ((member prototype (cloned-from* instance))		  ; [10]
	    (let ((*partially-included-prototype* prototype))
	      (cond (*eagerly-unify-prototypes* (km-int `(,instance &! ,clone) :fail-mode 'error))
		    (t (km-int `(,instance & ,clone) :fail-mode 'error)))))
	   (t (cond (*eagerly-unify-prototypes* (km-int `(,instance &! ,clone) :fail-mode 'error))
		    (t (km-int `(,instance & ,clone) :fail-mode 'error)))))

     )
  (pop-from-goal-stack))


;;; 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]
;;; 1/19/10 - Appears to be no longer used for years, so comment out!
;(defun first-applicable-prototype (instance &optional slot) ; NEW [2]
;  (find-if #'(lambda (prototype) 				; NEW [2]
;	       (suitable-for-cloning instance slot prototype))
;	   (my-mapcan #'(lambda (class) 
;			  (get-vals class '#$prototypes :situation *global-situation*)) 
;		      (all-classes instance))))

; 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.
(defun suitable-for-cloning (instance slot prototype)
  (and (neq instance prototype)			; don't clone yourself!
       (prototypep prototype)		; 1. Is a prototype
       (or 					; Ignore constraint 2 -- it may provide other valuable info!!
	(null slot)
	(instance-has-something-to-say-about prototype slot))
       (neq prototype (curr-prototype))		; 4. don't clone curr prototype to help answer query during building curr prototype!

;       (not (member prototype (get-vals instance *clone-built-from-slot*)))
	; No, clone-built-from is transitive!!! So do the below for significant efficiency improvements!
       (not (member prototype (clone-built-from* instance)))
       
;      (not (looping-on `#$(unify-with-clone-of ,PROTOTYPE)))	; See note [6] in unify-in-prototype, and above
			        ; 5. do subsumption check, to make sure instance satisfies prototype's qualifications
       (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
;;; [1] NOTE: get-vals undesirably does a bind-self with the prototype instance, so need to undo it for scopes like:
;;; (prototype-scope ((the-class Rectangle with (length ((the width of Self))) (width ((the length of Self))))))
(defun satisfies-prototype-definition (instance prototype)
;  (km-int `(,(get-unique-val prototype '#$prototype-scope :situation *global-situation*) #$covers ,instance)))
  (some #'(lambda (prototype-scope)
	    (cond ((or *prototype-classification-enabled* 
		       (not (second (class-descriptionp prototype-scope)))); Cat, (the-class Cat) ok, but no "with" allowed
		   (km-int `(,instance #$isa ,prototype-scope)))))
	(subst '#$Self prototype (get-vals prototype '#$prototype-scope :situation *global-situation*))))  ; [1]

#|
 ======================================================================
			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.

:including-extra-slots has been added so that AURA can control when coordinate information is cloned or not.
This is done by: 
  (i) AURA modifying *unclonable-slots* to include the slots containing coordinate info (so for KM's reasoning,
		by default it's not cloned)
		(ii) adding those slots back in using this keyword, when cloning for knowledge editing.

:without-bookkeeping changes the cloning behavior to create an IDENTICAL COPY of the original. The 
   difference (cf normal cloning) is purely in which explanations are created and cloned:
   (1) KM does NOT record cloned-from links from the prototype nodes to the clones
   (2) KM copies the ENTIRE explanation database from the prototype verbatim (renaming Skolems, of course)
   	(cf. with normal cloning, added-at explanations *aren't* copied)
   Note that cloned-from links from the clone to the prototype ARE still asserted in the KB (HLO-1423), just not   
   explanations for them. Sunil then manually removes these cloned-from links when the clone is promoted up 
   to replace the original prototype (HLO-1802).

RETURNS: two values: the clone name, and also the mappings from proto-instances to the cloned instances

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

[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!.
[4] knowledge-revision/add-triple-asif-cloned/test-clones-of-clones.lisp fails otherwise, as 
	USER: (get-all-explanations |_Finger5| |parts-of| :situation |*Global| :ignore-clone-cycles nil)
	((|_Finger5| |instance-of| |Finger| (|cloned-from| |_Arm1| |_Arm3| |_Finger1|))
	 (|_Finger5| |parts-of| |_Hand4| (|cloned-from| |_Arm1| |_Arm3| |_Finger1|)))
    but _Arm3 has been bound earlier to _Arm2. We are counting on _Arm2 being returned so that the sublis at [5] succeeds:
	prototype = _Body1, prototype0 = _Body1
	participant = _Hand4, clone0 = _Hand10
	mapping-alist = ((_Finger5 . _Finger11) (_Hand4 . _Hand10) (_Arm2 . _Arm9) (_Body1 . _Body8))
	old-isv-explanations = ((_Hand10 parts _Finger11 (cloned-from _Body1 _Body8 _Hand4))
	                        (_Hand10 instance-of Hand (cloned-from _Body1 _Body8 _Hand4))
	                        (_Hand10 parts-of _Arm9 (cloned-from _Body1 _Body8 _Hand4)))
	isv-explanations = ((_Hand4 parts _Finger5 (cloned-from _Arm1 _Arm3 _Hand1)) 
			    (_Hand4 instance-of Hand (cloned-from _Arm1 _Arm3 _Hand1))
	                    (_Hand4 parts-of _Arm3 (cloned-from _Arm1 _Arm3 _Hand1)))
    We are counting on the sublis at [5] replacing _Arm2 with _Arm9, but as _Arm3 has not been dereferenced to _Arm2 this doesn't happen.	
|#
(defun clone-without-bookkeeping (prototype &key including-extra-slots)
  (clone prototype :including-extra-slots including-extra-slots :without-bookkeeping t))

(defun clone (prototype0 &key including-extra-slots without-bookkeeping)
;  (km-format t "Cloning ~a...~%" prototype0)
;  (break)
  (let (; (*classification-enabled* nil)	; New - disable classification, of course! 
	; NEW: Moved it later inside the mapc iteration
	; classification afterwards on the clone. (It's possible a clone instance might satisfy a new definition)
	(*trace* nil)
	(*dereferencing-on* nil)	; Inefficient and not necessary to do dereferencing 
	(*am-reasoning* t)		; In case (clone ...) called directly from the Lisp prompt
;	NOTE: ***is** needed (critical) for dereferencing the *explanations* later in this function in get-all-explanations [4]
	(prototype (dereference prototype0)))
  (cond 
   ((not (prototypep prototype))
    (report-error 'user-error "Attempt to clone a non-prototype ~a!~%" prototype))
   ((and (am-in-situations-mode)
	 (am-in-global-situation))
    (report-error 'user-error "Attempt to clone a prototype ~a in the global situation while using Situations -- not allowed!~%Only do cloning in local situations when using KM Situations.~%"
		  prototype))
   (t
;    (format t "build-clones...~%")
    (multiple-value-bind
     (clones mapping-alist)  ; clones = list of (<clone> <slotsvals>) pairs. mappings = alist (<orig-object>.<clone>) pairs
     (build-clones prototype :including-extra-slots including-extra-slots)	; compute what clones would look like
     (let ((clone-of-prototype (rest (assoc prototype mapping-alist)))) ; find the clone of the ROOT instance 
       (let ((*classification-enabled* nil)
	     (*prototype-classification-enabled* nil)      ; temporarily disable classification, as we need to do ALL
							   ; the assertions first before attempting classification!
;	     (*dereferencing-on* nil)			  ; Slightly inefficient and not necessary to do dereferencing 
	     )
;	 (format t "add-slotsvals...~%")

         (mapc #'(lambda (clone+slotsvals) ; expr = (<clone> <slotsvals>)		; NEW drop <situation>
		 (let* ((clone (first clone+slotsvals))
			(slotsvals (second clone+slotsvals)) 
			(cloned-from (first (rassoc clone mapping-alist))))
		   (add-slotsvals clone slotsvals) ; install-inversesp = t; eg. (I instance-of C), we *do* need

; Neah...
;		   (cache-explanation-for clone `#$(cloned-from ,PROTOTYPE (,CLONE-OF-PROTOTYPE)))

; Neah again...well (1/8/02) let's make it switchable...
		   (cond 
		    ((and (or *record-explanations* *record-explanations-for-clones*)
			  (not without-bookkeeping))
		     (mapc #'(lambda (slotvals)
			       (let* ((slot (slot-in slotvals))
				      (target `#$(the ,SLOT of ,CLONE)))
				 (cond
				  ((member slot '#$(cloned-from clone-built-from)) nil)

				  ((and (eq slot '#$instance-of) ; don't "explain" the root node class (HLO-1355)
					(eq cloned-from prototype)) nil) ; See knowledge-revision/instance-of-support/
				  (t (mapc #'(lambda (val)
					       (record-explanation-for target val ; [2]
						       `#$(cloned-from ,PROTOTYPE ,CLONE-OF-PROTOTYPE 
								       ,CLONED-FROM ; ,CLONE-OPERATION-ID
								       )))
					   (vals-in slotvals))))))				  
; This would be a better solution, rather than storing explanations in both directions.
;				  (t (mapc #'(lambda (val)
;					       (let* ((val-cloned-from 				       ; May be nil
;						       (listify (first (rassoc val mapping-alist))))   ; Listified for ,@
;						      (explanation `#$(cloned-from ,PROTOTYPE ,CLONE-OF-PROTOTYPE 
;										   ,CLONED-FROM ,@VAL-CLONED-FROM)))
;						 (cond
;						  ;; NB inverse may have already been recorded, in which case don't
;						  ;; redundantly record it in the other direction
;						  ((not (member explanation (get-explanations clone slot val) 
;								:test #'equal))
;						   (record-explanation-for target val explanation)))))
;					   (vals-in slotvals))))))
			   slotsvals)))

		   (cond ((am-in-prototype-mode) ; 1.4.5.17 - allow cloning *within* a prototype too
			  (add-val clone '#$prototype-participant-of (curr-prototype) t *global-situation*))))) ; install-inverses = t; Note in GLOBAL situation
	     clones))			; inverse (C instances I) installed

#|
New: 1/10/02 - copy *all* explanations over. **NOTE** These will be deposited in the *GLOBAL* situation, 
QUESTION: Why do we do this? 
For AURA, the only purpose of explanations is to note the source node(s).
Suppose		Arm1-parts->Hand1-parts->Finger2
		Body2-parts->Arm2-parts->Hand2-parts->Finger2
					 (cloned-from Arm1 Arm2)
	 Now    Person3-parts->Body3-parts->Arm3-parts->Hand3-parts->Finger3
							(cloned-from Body2 Body3)					 
The question is, do we also need to clone the expln:    (cloned-from Arm1 Arm3)		? [1]
Note we *do* clone cloned-from links, so we have:    Arm3 cloned-from (Arm2 Arm1)
						     Hand3 cloned-from (Hand2 Hand1)
	triple-expanded-from will say Body3, and Arm3 if [1] is done.
	get-supports will say Arm, Body, but the check to remove Body if Body3 is deleted will be lost.
	get-support-details will say Hand1-parts->Finger2 -- it only shows the ORIGINAL source, not the intermediate
	
because, cloning is necessarily done in the global situation ONLY (see (in-situation *Global ...) in unify-in-prototype 
earlier)
10/25/07 - 
However, if we *don't* record the cloned-from explanations, will KM re-apply the prototype Arm1 onto Arm3,
which will recreate them? e.g., that (Arm3 parts Hand3) is cloned-from Arm1? The answer is no (which is bad), 
because Arm3 is already noted as (clone-built-from Arm1) which blocks re-cloning. It's bad as we'll have lost 
additional information in the explanation database (that Arm1 was cloned onto Arm3), needed for 
triple-expanded-from.
Thus, we need to either copy the clone-built-from info AND the explanations (as we do now), OR not copy either. 
But we can't do one without the other.
Note we also need to record explanations attached to "traditional" structures, e.g., build with (a-prototype ...)
form. However, we can ignore these if they were inherited [4], as they will be reinherited when recomputed. LATER:
No, let's copy them all and not rely on recomputation.
[5] Note if we are doing without-bookkeeping, then the goal is the clone is an IDENTICAL COPY of the original, for
    the purposes of editing in AURA. As a result, in this special situation, we *do* need to copy the WHOLE
    explanation database over. In particular, we need to preserve the added-at links.
[6] 3/2/08: I appear to have decided NOT to propogate the added-at explanations to clones after all in KM 2.1.7
    back in October 2007. I guess the rationale is that if the SME does added-at (x y z), then (x y z) is  
    cloned to (a b c), (a b c) really should just be explained by (x y z) (it's not really true the SME added-at
    (a b c) directly). Of course, if we clone-without-bookkeeping (which DOES copy added-at) then save the
    new graph as a subclass of the original, then we will have kept some added-at links from the original.
    I guess that's ok. 
    HLO-2362 - actually it is ok, and we can always copy the added-at links. Just because a clone has an added-at
    explanation doesn't mean the link was added-at that clone; rather the source class is in the added-at structure.
[7] There's an issue of whether we copy the explanations in *Global or not during cloning. Here it looks like we *don't*;
    This is very strange, as participant has no explanations in the local situation (?).

|#
;      (km-format t "mapping-alist = ~a~%" mapping-alist)
    (cond 
     ((and (or *record-explanations* *record-explanations-for-clones*)
	   *propogate-explanations-to-clones*)
;      (format t "put-explanations...~%")      
      (let ((*dereferencing-on* *dereference-explanations-during-cloning*))		; [4]
       (mapc #'(lambda (participant-dot-clone)
		(let* ((participant (first participant-dot-clone)) 
		       (clone0 (rest participant-dot-clone))
		       (isv-explanations (get-all-explanations participant nil)) ; slot=nil   ; [7] - Combines both local and global explanations
		       (filtered-isv-explanations isv-explanations) ; NEW - HLO-2362 and HLO-1802 we need added-at copied
;		       (filtered-isv-explanations
;			(cond (without-bookkeeping isv-explanations) ; [5]
;			      (t (remove-if #'(lambda (isv-explanation) ; [6]
;						(eq (explanation-type (explanation-in isv-explanation)) '#$added-at))
;					    isv-explanations))))

		       (old-isv-explanations (get-all-explanations clone0 nil))) ; may be some from [2] - here we get from local...
;			 (km-format t "prototype = ~a, prototype0 = ~a~%" prototype prototype0)
;			 (km-format t "participant = ~a, clone0 = ~a~%" participant clone0)
;			 (km-format t "mapping-alist = ~a~%" mapping-alist)
;			 (km-format t "old-isv-explanations = ~a~%" old-isv-explanations)
;			 (km-format t "isv-explanations = ~a~%" isv-explanations)
;			 (km-format t "filtered-isv-explanations = ~a~%" filtered-isv-explanations)

		  (cond (filtered-isv-explanations 
			 (put-explanations clone0 nil 
			  (append old-isv-explanations 
		           (remove-clone-cycles (sublis mapping-alist filtered-isv-explanations))))))))  ; [5] ... and assert in local...
	    mapping-alist))))

;      (add-val clone-of-prototype '#$cloned-from prototype nil *global-situation*) ; install-inverses = nil [1]
	; NEW: add cloned-from links for *all* participants. Then we can get a constant handle on them.
;    (format t "add cloned-from links...~%")
       (cond
	(*add-cloned-from-links*
	 (mapc #'(lambda (protopart-dot-clone)
		   (let ( (protopart (first protopart-dot-clone))
			 (clone (rest protopart-dot-clone)) )
		     (add-val clone '#$cloned-from protopart t)))  ; cloned-from is global, so will go in global sitn
	       mapping-alist)))
       (add-val clone-of-prototype *clone-built-from-slot* prototype) ; restating default extra args unnecessary

       ;;; NOW classify the nodes 
;      (km-format t "*classification-enabled* = ~a~%" *prototype-classification-enabled*)
;      (km-format t "Now classifying the clones ~a...~%" (mapcar #'first clones))

;       (format t "classify...~%")
;;; This is a bit drastic, as it calls arbitrary classification reasoning on every prototype node after every
;;; cloning operation :-(. Maybe we can tone it down a bit (?):       
      (let ((*use-inheritance* nil)	; new - tone it down a bit
	    (*use-prototypes* nil))	; new - tone it down a bit
	 (mapc #'classify (mapcar #'first clones)))

;       (format t "Done!~%")
       (values clone-of-prototype mapping-alist))))))) ; 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> <slotsvals>) pairs
	- the clone-instance mapping, a list of (<protoname> . <clone>) acons's.
====================================================================== 

This was originally meant to allow prototypes to include some situation-specific components, but this generates errors 
when cloning!
[1] NO!!!!! You are *not* allowed to do any reasoning on PROTOTYPES! Bad!!!!
    In fact we get away with it because classification is disabled during cloning, but still let's change it!
     In particular it's still leaving an explanation for prototype-participants in the expln db (urgh)
|#
(defun build-clones (prototype &key including-extra-slots)
; [1] (let* ( (prototype-participants (km-int `#$(the prototype-participants of ,PROTOTYPE) :fail-mode 'error)) ; includes prototype	e.g. (_ProtoCar1 _ProtoWheel2)
   (let* ((prototype-participants (get-vals prototype '#$prototype-participants)) ;includes prototype eg (_PCar1 _PWheel2)
	  (clones (mapcar #'(lambda (prototype-participant)
				   (cond ((anonymous-instancep prototype-participant)
					  (create-instance-name (first (immediate-classes prototype-participant))))
					 (t prototype-participant)))
			       prototype-participants))
	  (mapping-alist (pairlis prototype-participants clones)) )		; (pairlis '(_ProtoCar1 _ProtoWheel2) '(_Car3 _Wheel4)) ->
     (cond ((null prototype-participants)
	    (report-error 'user-error "(clone ~a): No prototype-participants declared for this prototype!~%" prototype))
	   (t
	    (values (remove nil (mapcar #'(lambda (prototype-participant) ; ((_ProtoCar1 . _Car3) (_ProtoWheel2 . _Wheel4))
				    (build-clone prototype-participant mapping-alist ; nil: some prototype-participants need no assertions
						 :including-extra-slots including-extra-slots)) 
				prototype-participants))
		    mapping-alist)))))

#|
Patch for prototype reasoning
RETURNS: (<clone-root> <clone-slotsvals>)
:including-extra-slots allows user to override (hence clone) slots in *unclonable-slots*, e.g., coordinate info slots
[1] Normally cloned-from and clone-built-from point to other prototypes OUTSIDE the current prototype being cloned,
    and so these links are simply copied. However, it's possible they point WITHIN the prototype itself, e.g,

        [[Person]] -parent-> [Person]
	    <--cloned-from----/

For these links it's critical we *don't* copy the cloned-from link, as it results in an inverse has-clones link
on the (non-prototype) instance clone. The test [1] removes such pointers, but leaves the rest preserved.
|#	    
(defun build-clone (prototype mapping-alist &key including-extra-slots)
  (cond 
   ((anonymous-instancep prototype)    ;;; NEW: Important that slotvals on *named* instances are NOT cloned
    (let* ((clone (rest (assoc prototype mapping-alist)))  
	   (slotsvals (get-slotsvals prototype :situation *global-situation*)) ; now prototypes are *only* in Global
	   (new-slotsvals (remove nil
			   (mapcar #'(lambda (slotvals)
				       (let ((slot (slot-in slotvals)))
					 (cond ((and (member slot *unclonable-slots*)
						     (not (member slot including-extra-slots))) nil)
;					       ((member slot '#$(cloned-from clone-built-from))
					       ((member slot *slots-with-nonparticipant-skolems*)	; more general 1/7/11
						(let ((vals-outside-prototype 
						       (remove-if #'(lambda (val) 
								      (assoc val mapping-alist))  ; [1]
								  (vals-in slotvals))))
						  (cond (vals-outside-prototype 
							 (make-slotvals slot vals-outside-prototype)))))
					       (t slotvals))))
				   slotsvals))))
;     (km-format t "slotsvals = ~a~%" slotsvals)
      (cond (new-slotsvals
	     (list clone (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 ...).
(defun add-to-prototype-definition (prototype expr)
  (let ( (definition-so-far (get prototype 'definition)) )
    (km-setf prototype 'definition (append definition-so-far (list expr)))))

;;; ======================================================================
;;; NOT part of KM's inference engine, but a utility for tracing the has-clones links
;;; ======================================================================

(defun node-cloned-to (f) (remove-duplicates (get-vals f '#$has-clones))) ; NB get-vals may contain dups

;;; ======================================================================
;;;   NODES-CLONED-TO: Also see knowledge-revision/propogating-changes/README.txt
;;; ======================================================================
#|
If nodes is a pair, it returns a list of pairs of corresponding clones
e.g., (nodes-cloned-to '#$(_N1 _N2)) -> ((_n3 _n4) (_n6 _n7))	       
where _n1 _n2 are in prototype 1, _n3 _n4 are in prototype 2, and _n6 _n7 are in prototype 3.

Revised algorithm: 
   (i) find all the clones (_CNodes) of nodes (_PNodes)
   (ii) Find all the explanations for all the clones (i.e., <expn> for ALL triples (:triple _CNode ?any ?any) <expn>
  (iii) Find the signatures of all the different "cloning operations". If the explanation is 
	  (cloned-from _PRoot _CRoot _CNode) then the signature is (_PRoot _CRoot)
  (iv) Step through and see the mappings
I extended the explanation DB to include the necessary information to support this

Consider: Prototype _Foo1, containing (_Foo1 _Bar1), is cloned *twice* onto_Foo2 and _Foo3 respectively
USER: (nodes-cloned-to '(_Foo1 _Bar1))
isv-explanations = 
   (_Foo2 parts _Bar5 (cloned-from _Foo1 _Foo2 _Foo1))
   (_Foo3 parts _Bar7 (cloned-from _Foo1 _Foo3 _Foo1))
   (_Bar5 instance-of Bar (cloned-from _Foo1 _Foo2 _Bar1))
   (_Bar5 parts-of _Foo2 (cloned-from _Foo1 _Foo2 _Bar1))
   (_Bar7 instance-of Bar (cloned-from _Foo1 _Foo3 _Bar1))
   (_Bar7 parts-of _Foo3 (cloned-from _Foo1 _Foo3 _Bar1))
RETURNS:
'((_Foo2 _Bar5) (_Foo3 _Bar7))
|#

;;; ------------------------------ STANDARD CACHING WRAPPER 

(defvar *nodes-cloned-to-keys* nil)
(defvar *nodes-cloned-to-caching* nil)

(defun nodes-cloned-to (nodes0 &key clones-of-interest)
; (let ((start-time (get-internal-run-time)))
   (prog1
       (cond
	((or clones-of-interest		; cache only the full (unrestricted) answer
	     (not *nodes-cloned-to-caching*)) 
	 (nodes-cloned-to0 nodes0 :clones-of-interest clones-of-interest))
	(t (let* ((key (intern (format nil "~a" nodes0) *km-package*))
		  (cached-answer (get key 'nodes-cloned-to)))
	     (cond (cached-answer 
		    (cond ((neq cached-answer 'no) cached-answer)))
		   (t (let* ((answer (nodes-cloned-to0 nodes0)))
;			(km-format t "Retrieve from cache: (nodes-cloned-to0 ~a) -> ~a~%" nodes0 answer)
			(setf (get key 'nodes-cloned-to) (or answer 'no))
			(push key *nodes-cloned-to-keys*)
			answer))))))
;     (km-format t "[~,2f sec for (nodes-cloned-to ~a)~%" 
;		(/ (- (get-internal-run-time) start-time) internal-time-units-per-second)
;		nodes0))
   ))
  
(defun clear-nodes-cloned-to-cache ()
  (mapc #'(lambda (key) (setf (get key 'paraphrases) nil)) *nodes-cloned-to-keys*)
  (setq *nodes-cloned-to-keys* nil)
  t)

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

(defun nodes-cloned-to0 (nodes0 &key clones-of-interest)
 (let ((nodes (dereference nodes0)))
  (cond
   ((notevery #'protoinstancep nodes)
   (report-error 'user-error "ERROR! nodes-cloned-to: ~a is/are not instances in a prototype!~%"
		  (remove-if #'protoinstancep nodes)))
   ((not (= (length (remove-duplicates nodes)) (length nodes0)))
    (report-error 'user-error 
	  "nodes-cloned-to: ~a are not all distinct nodes (some are bound; they dereference to ~a)~%"
	  nodes0 nodes))
   (t (let* ((original-prototypes (gets-vals nodes '#$prototype-participant-of))
	     (original-prototype (first original-prototypes)) ; original-prototypes must be a singleton (checked below)
;	    (original-prototypes (km-int `#$(the prototype-participant-of of ,(VALS-TO-VAL NODES))))
	    )
	(cond 
	 ((not (singletonp original-prototypes))
	  (report-error 'user-error "nodes-cloned-to: ~a should belong to the same prototype, but belong to multiple ones ~a!~%" nodes original-prototypes))
	 (t (let* ((clones0 (gets-vals nodes '#$has-clones))
		   (clones (cond (clones-of-interest (intersection clones0 clones-of-interest)) (t clones0)))
		   (isv-explanations (dereference 
				      (remove-if-not #'(lambda (isv-explanation)
							 (let ((explanation (explanation-in isv-explanation)))
							   (and (eq (explanation-type explanation) '#$cloned-from)
								(or (member (fourth explanation) nodes) ; src protonode
								    (and (null (fourth explanation)) ; backwards compat.
									 (eq (second explanation) original-prototype))))))
						     (my-mapcan #'get-explanation-data clones))))
		   (clone-operation-ids 
		    (remove-duplicates
		     (remove nil
		      (mapcar #'(lambda (isv-explanation)
				  (let ((explanation (explanation-in isv-explanation))); (cloned-from _PRoot _CRoot _PNode)
				    (list (second explanation) (third explanation))))  ; (_PRoot _CRoot)
			      isv-explanations))
		     :test #'equal)))
;	      (km-format  t "isv-explanations = ~%~{   ~a~%~}" isv-explanations)
;	      (km-format  t "clone-operation-ids = ~a~%" clone-operation-ids)
;	      (km-format  t "~a clone-operation-ids~%" (length clone-operation-ids))
	      (remove-duplicates
	       (mapcan #'(lambda (clone-operation-id)
			   (collect-clonesets nodes isv-explanations clone-operation-id))
		       clone-operation-ids)
	       :test #'equal :from-end t)))))))))

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

;;; Returns a set of (Clone1...CloneN) matching (Node1...NodeN) created under CLONE-OPERATION-ID
(defun collect-clonesets (nodes isv-explanations clone-operation-id)
;  (km-format t ".")
  (let ((clonesets  	; a list of N elements (<Clones of Node1>...<Clones of NodeN>) under CLONE-OPERATION-ID 
	 (mapcar #'(lambda (node)
		     (remove-duplicates 
		      (remove nil (mapcar #'(lambda (isv-explanation)	    
					       (find-clone-of-node node isv-explanation clone-operation-id))
					  isv-explanations))))
		 nodes)))
;		 (km-format t "clone-operation-id = ~a, clonesets = ~a~%" clone-operation-id clonesets)
    (permute-clonesets clonesets)))

;;; Look in isv-explanation for a clone of node created under clone-operation-id. Can return NIL if not found
(defun find-clone-of-node (node isv-explanation clone-operation-id)
  (let ((cloned-from (first clone-operation-id))
	(expanded-from (second clone-operation-id)))
    (case (length (explanation-in isv-explanation)) ; returns the CLONE of NODE under CLONE-OPERATION-ID
; Awaiting implementation following modification to get-explanations 		 
;		         (5 (or (minimatch1 isv-explanation
;				     `(?clone ?any ?any (#$cloned-from ,cloned-from ,expanded-from ,node ?any)))
;				(minimatch1 isv-explanation
;				     `(?any ?any ?clone (#$cloned-from ,cloned-from ,expanded-from ?any ,node)))))
#|
; Inefficient (?) let's reimplement!
      (4 (or (minimatch1 isv-explanation ; backwards compatibility
			 `(?clone ?any ?any (#$cloned-from ,cloned-from ,expanded-from ,node)))
	     ; This case if only the inverse, but not forward, explanation is stored (shouldn't happen)
	     (let ((clone (minimatch1 isv-explanation ; backwards compatibility
				      `(?any ?any ?clone (#$cloned-from ,cloned-from ,expanded-from ?any)))))
	       (cond ((and clone (kb-objectp clone) (member node (get-vals clone '#$cloned-from))) clone)))))
      (3				; backwards compatibility
       (let ((clone (minimatch1 isv-explanation `(?clone ?any ?any (#$cloned-from ,cloned-from ,expanded-from)))))
	 (cond ((and clone (kb-objectp clone) (member node (get-vals clone '#$cloned-from))) clone))))
|#
; REIMPLEMENTED
      (4 (cond	; Backwards compatibility
		; (minimatch1 isv-explanation (?clone ?any ?any (#$cloned-from ,cloned-from ,expanded-from ,node)))
	       ((equal (fourth isv-explanation) `(#$cloned-from ,cloned-from ,expanded-from ,node))
		(first isv-explanation))
		; This case if only the inverse, but not forward, explanation is stored (shouldn't happen)
	       (t (let* (; (clone (minimatch1 isv-explanation ; backwards compatibility `(?any ?any ?clone (#$cloned-from ,cloned-from ,expanded-from ?any)))))
			 (explanation (explanation-in isv-explanation))
			 (clone (cond ((and (eq (first explanation) '#$cloned-from)
					    (eq (second explanation) cloned-from)
					    (eq (third explanation) expanded-from))
				       (third isv-explanation)))))
		    (cond ((and clone (kb-objectp clone) (member node (get-vals clone '#$cloned-from))) clone))))))
      (3				; backwards compatibility
;       (let ((clone (minimatch1 isv-explanation `(?clone ?any ?any (#$cloned-from ,cloned-from ,expanded-from)))))
        (let* ((explanation (explanation-in isv-explanation))
	       (clone (cond ((and (eq (first explanation) '#$cloned-from)
				  (eq (second explanation) cloned-from)
				  (eq (third explanation) expanded-from))
			     (first isv-explanation)))))
	  (cond ((and clone (kb-objectp clone) (member node (get-vals clone '#$cloned-from))) clone))))

   (t (report-error 'program-error "Invalid explanation length in nodes-cloned-to!~%")))))

;;; (permute-cloneset '((a) (c))) -> ((a c))
;;; (permute-cloneset '((a b) (c))) -> ((a c) (b c))
;;; (permute-cloneset '((a b) (c))) -> ((a c) (b c))
;;; (permute-cloneset '((a) nil)) -> ((a nil))
;;; (permute-cloneset '((a b) nil (c d))) -> ((a nil c) (a nil d) (b nil c) (b nil d))
(defun permute-clonesets (sets)
  (cond ((endp sets) (list nil))
	(t (let ((set (first sets)))
	     (mapcan #'(lambda (set-el)
			 (mapcar #'(lambda (rest-set) 
				     (cons set-el rest-set))
				 (permute-clonesets (rest sets))))
		     (or set '(nil)))))))

(defun node-cloned-from (f) (remove-duplicates (get-vals f '#$cloned-from)))
(defun node-cloned-from-originally (f) (remove-duplicates (remove-if #'node-cloned-from (get-vals f '#$cloned-from))))
;;; Transitive closure
(defun node-cloned-from* (f &key done) 
  (let ((sources (get-vals f '#$cloned-from)))
    (remove-duplicates 
     (append sources 
	     (my-mapcan #'(lambda (x) 
			    (cond ((member x done)
; Seems that loops can occur for obscure reasons				   
;			   (km-format t "ERROR! node-cloned-from*: Looping on cloned-from for ~a ~a; stopping...~%" 
;					      x (cons x done))
				   )
				  (t (node-cloned-from* x :done (cons x done)))))
			sources)))))

;;; Synonym for above
(defun cloned-from* (f &key done) (node-cloned-from* f :done done))

;;; Transitive closure of #$clone-built-from
(defun clone-built-from* (f &key done) 
  (let ((sources (get-vals f '#$clone-built-from)))
    (remove-duplicates 
     (append sources 
	     (my-mapcan #'(lambda (x) 
			    (cond ((member x done))
				  (t (clone-built-from* x :done (cons x done)))))
			sources)))))

;;; ======================================================================

;;; [1] If A clones to B clones to C (where A,B,C are triples), then (triple-cloned-from C) -> (A B)
;(defun triple-cloned-from (triple)
;  (let* ((f (dereference (first triple)))
;	 (s (second triple))
;	 (v (dereference (third triple)))
;	 (f-protos (node-cloned-from f))
;	 (v-protos (node-cloned-from v)))
;    (mapcan #'(lambda (f-proto)
;		(let ((vals (get-vals f-proto s :situation *global-situation*)))
;		  (mapcar #'(lambda (val) 
;			      (list f-proto s val)) 
;			  (intersection vals (cons v v-protos))))) ; allow for v to be named instances also
;	    f-protos)))

#|
Rewritten by Sunil Mishra 2/29/08:
triple-cloned-from fails on inputs such as (_Equation-Set90 equation-symbol (:pair 'x_1 _Speed-Value91)).
In fact, if the value is non-atomic, with error reporting turned on, triple-cloned-from will always given an error. 
The following code replaces the existing triple-cloned-from. For list values containing anonymous instances, 
triple-cloned-from-complex* carefully considers each possible filler for that value in a prototype, then filters 
out all non-existent triples. Other cases are handled through triple-cloned-from-simple*.
|#
;;; [1] If TripleA clones to TripleB clones to TripleC, then (triple-cloned-from TripleC) -> (TripleA TripleB)
(defun triple-cloned-from (triple)
  (let* ((f (dereference (first triple)))
	 (s (second triple))
	 (v (dereference (third triple))))
    (if (and (consp v) (some #'anonymous-instancep (flatten v)))
	(triple-cloned-from-complex* f s v)
	(triple-cloned-from-simple* f s v))))

(defun triple-cloned-from-simple* (f s v)
  (let* ((f-protos (node-cloned-from f))
	 (v-protos (if (anonymous-instancep v) ; allow for v to be non-anonymous instances
		       (node-cloned-from v)
		       (list v))))
    (select-real-triples f-protos s v-protos)))

(defun triple-cloned-from-complex* (f s v)
  (let* ((f-protos (node-cloned-from f))
	 (v-content (remove-if-not #'anonymous-instancep (flatten v)))
	 (v-content-substs (mapcar (lambda (v-node)
				     (mapcar (lambda (v-node-proto) (cons v-node v-node-proto))
					     (node-cloned-from v-node)))
				   v-content))
	 (v-content-permutations (permute v-content-substs))
	 (v-protos (mapcar (lambda (v-permutation)
			     (sublis v-permutation v))
			   v-content-permutations)))
    (select-real-triples f-protos s v-protos)))

;;; GIVEN a set of f, a slot, and a set of v
;;; RETURN ONLY the (f slot v) which actually exist in the KB (are "real")
(defun select-real-triples (fs s vs)
    (mapcan #'(lambda (f)
		(let ((vals (cond ((protoinstancep f) ; all prototype info necessarily in the global situation
				   (get-vals f s :situation *global-situation*))
				  (t (get-vals f s)))))
		  (mapcan #'(lambda (v)
			      (when (member v vals :test #'equal)
				(list (list f s v))))
			  vs)))
	    fs))

;;; ======================================================================

;;; Do similar thing for triple-cloned-to
;(defun triple-cloned-to (triple)
;  (let* ((f (dereference (first triple)))
;	 (s (second triple))
;	 (v (dereference (third triple)))
;	 (f-clones (node-cloned-to f))
;	 (v-clones (node-cloned-to v)))
;    (cond 
;     ((in-prototype triple)		; includes checks the triple exists and is part of a prototype
;      (mapcan #'(lambda (f-clone)
;	        (let ((vals (get-vals f-clone s)))		; is this ok? 
;		  (mapcar #'(lambda (val) 
;			      (list f-clone s val)) 
;			  (intersection vals (cons v v-clones)))))	; allow for v to be named instances also
;	      f-clones)))))

;;; [1] If A clones to B clones to C, then (triple-cloned-to C) -> (A B)
(defun triple-cloned-to (triple)
  (let* ((f (dereference (first triple)))
	 (s (second triple))
	 (v (dereference (third triple))))
    (if (and (consp v) (some #'anonymous-instancep (flatten v)))
	(triple-cloned-to-complex* f s v)
	(triple-cloned-to-simple* f s v))))

(defun triple-cloned-to-simple* (f s v)
  (let* ((f-clones (node-cloned-to f))
	 (v-clones (if (anonymous-instancep v) ; allow for v to be non-anonymous instances
		       (node-cloned-to v)
		       (list v))))
    (select-real-triples f-clones s v-clones)))

(defun triple-cloned-to-complex* (f s v)
  (let* ((f-clones (node-cloned-to f))
	 (v-content (remove-if-not #'anonymous-instancep (flatten v)))
	 (v-content-substs (mapcar (lambda (v-node)
				     (mapcar (lambda (v-node-clone) (cons v-node v-node-clone))
					     (node-cloned-to v-node)))
				   v-content))
	 (v-content-permutations (permute v-content-substs))
	 (v-clones (mapcar (lambda (v-permutation)
			     (sublis v-permutation v))
			   v-content-permutations)))
    (select-real-triples f-clones s v-clones)))

;; ======================================================================

#|
[1] If A clones to B clones to C, then (triple-cloned-from-originally C) -> (A), as B is an intermediate triple
SUPPOSE: (f s v) -clone-> (f1 s1 v1) -clone-> (f2 s2 v2)
THUS: (triple-cloned-from (f2 s2 v2)) -> (f s v) (f1 s1 v1)	
      (triple-cloned-from (f1 s1 v1)) -> (f s v)

[2] - This doesn't work if there's a cycle in the KB (as can easily arise - see 
	my notes in directory km/knowledge-revision/triple-expanded-from/). It also doesn't 
	take account of triples which may be clones of clones, but are also supported by a SME add action,
	or a unification, or from the base KB. For now let's ignore all these "intermediate supports".
[4]	8/25/08 - No, got bitten directly by this HLO-2362 - so fix it!!!
[5]    A (<triple> (added-at Foo "string")) explanation may be (i) about <triple> in Foo, or (ii) be about
       a CLONE in Bar of a <triple>' in Foo, with the explanation copied AND a separate (cloned-from <triple> <triple>')
       explanation stored. In this latter case, we don't want Bar to be labelled as an origination of <triple>,
       so we skip it and instead use the earlier ancestor (also collected in this function) in Foo.

[3]	If there's a cycle then include all the triples (except self). 
SUPPOSE: (a b c) -clone-> (a1 b1 c1) -clone-> (a2 b2 c2) -clone-> (a b c)
THUS: (triple-cloned-from (a2 b2 c2)) -> (a b c) (a1 b1 c1)	
      (triple-cloned-from (a1 b1 c1)) -> (a b c) (a2 b2 c2)
      (triple-cloned-from (a b c)) -> (a1 b1 c1) (a2 b2 c2)
RESOLUTION: Ignore source triples IF they're themselves cloned from something else AND they are not part of a cycle.
		(Thus for cycles, include all triples in the cycle as there's no notion of "most distant")
|#	
(defun triple-cloned-from-originally (triple)
  (let ((source-triples (triple-cloned-from triple))) ; [1]
    (cond ((member triple source-triples :test #'equal) (remove triple source-triples :test #'equal)) ; Cycle! [2,3]
; [4]	  (t (remove-if #'triple-cloned-from source-triples)))))
#|[4]|#	  (t (remove-if #'(lambda (source-triple)
			    (let* ((f (first source-triple))
				   (s (second source-triple))
				   (v (third source-triple))
				   
				   (explanations (append (get-explanations1 f s v) 
							 (get-explanations1 v (invert-slot s) f))))
			      (and (triple-cloned-from source-triple) ; NOT the originating triple IF: (a) cloned from something else, and
				   (notany #'(lambda (explanation)    ; (b) not explicitly (re-)added at this prototype
					       (and (eq (explanation-type explanation) '#$added-at)
						    (member (second explanation)	; avoid cloned added-at explns [5]
							    (prototype-classes source-triple))))
					   explanations))))
			source-triples)))))

;;; INPUT: a triple which is in a prototype, or the root node of the prototype
;;; RETURNS: A list of the class(es) which the prototype is in.
;;; Strictly we should look at prototype-scope rather than instance-of links, but instance-of is ok.
;;; In any case, they should be the same, except when the prototype-scope is a structured class, .e.g,
;;     (instance-of (Car)) (prototype-scope ((the-class Car with (speed (*fast)))))
(defun prototype-classes (node-or-triple0) 
  (let ((node-or-triple (dereference node-or-triple0)))
    (cond ((triplep node-or-triple) (prototype-classes (in-prototype node-or-triple))) ; includes error checking
	  ((not (prototypep node-or-triple))
	   (report-error 'user-error "(prototype-classes ~a): argument should be a prototype root node or a prototype triple but was not!~%" node-or-triple))
	  (t
	;  (get-vals node-or-triple '#$prototype-scope)
	;  (immediate-classes node-or-triple) 
	; NO: immediate-classes may contain redundant classes in AURA as *built-in-remove-subsumers-slots* = nil
	   (get-vals node-or-triple '#$prototype-of)))))
#|
;;; This version uses the explanation database. However, I think it's possible to instead
;;; do this using the cloned-from tags instead, thus simplifying the explanation database.
;;; In this case, we can set *record-explanations-from-clones* to nil and save some explanation space.
(defun triple-cloned-from (f s v)
  (let* ((explanations (my-mapcan #'fourth (get-explanations f s v *global-situation*)))
	 (source-prototypes (mapcar #'second (remove-cloned-from-explns explanations)))
;	 (f-protoinstances0 (km-int `#$(the cloned-from of ,F)))
;	 (v-protoinstances0 (km-int `#$(the cloned-from of ,V)))
	 (f-protoinstances0 (get-vals f '#$cloned-from))
	 (v-protoinstances0 (get-vals v '#$cloned-from))
	 (f-protoinstances (remove-if-not #'(lambda (f-protoinstance)
					      (intersection (get-vals f-protoinstance '#$prototype-participant-of)
							    source-prototypes))
					  f-protoinstances0))
	 (v-protoinstances (remove-if-not #'(lambda (v-protoinstance)
					      (intersection (get-vals v-protoinstance '#$prototype-participant-of)
							    source-prototypes))
					  v-protoinstances0)))
;    (km-format t "explanations = ~a~%" explanations)
;    (km-format t "source-prototypes = ~a~%" source-prototypes)
;    (km-format t "f-protoinstances0 = ~a~%" f-protoinstances0)
;    (km-format t "v-protoinstances0 = ~a~%" v-protoinstances0)
;    (km-format t "f-protoinstances = ~a~%" f-protoinstances)
;    (km-format t "v-protoinstances = ~a~%" v-protoinstances)
    (mapcan #'(lambda (f-protoinstance)
		(let ((vals (get-vals f-protoinstance s :situation *global-situation*)))
		  (mapcar #'(lambda (val) 
			      (list f-protoinstance s val)) 
			  (intersection vals (cons v v-protoinstances))))) ; allow for v to be named instances also
	    f-protoinstances)))
|#

#|
(save-prototype <protoroot>)
If :stream argument given, the caller must take responsibility for opening and closing the stream.
If :file argument given, the file is created and closed after writing.
If no keyword arguments are given, output is to standard-output.
If both :stream and :file are given, :stream takes precidence and :file is ignored.

RETURNS: TWO values:
  - The nodes in the prototype whose clone-built-from values changed, i.e., where recloning (reexpansion) is needed
    This may validly be NIL, if no clone-built-from values changed
  - If an error occurred, a string describing the error. To test for success, make sure this value in NIL

SIDE EFFECTS: None (the KB in memory is *not* changed - use trim-prototype to change the in-memory KB)

[1] The (cons ... (remove ...)) is to ensure that prototype is at the front of the list

NOTE: 
For "normal" slots: only slot values which are also prototype-participant instances are written out.
For *prototype-bookkeeping-slots*, only values which are ALSO prototype participants (of some prototype, not 
      necessarily this one) are written out (HLO-1690); Skolem instances (simple clones) are not.
(write-slotvals in writer.lisp implements the response to vals-to-show and *prototype-bookkeeping-slots*)

Example with essentials:
(save-prototype '#$_Car1 :essential-participants '#$(_Car1 _Engine1 _Cylinder1))
(save-prototype '#$_Cell161 :essential-participants 
	'#$(_Cell161 _Ribosome195 _Cytoplasm193 _Chromosome186 _Organism185 _Plasma-membrane184))

[2] Are there any non-essential individuals cloned-from a prototype?
    If so, drop the clone-built-from link for that prototype to allow re-cloning. Otherwise, keep the 
    clone-built-from link.
|#
(defvar *prototype-explanation-types-to-save* nil)

(defun save-prototype (prototype0 &key stream (file t) extra-assertions essential-participants)
  (let ((prototype (dereference prototype0)))
  (cond 
   ((not (prototypep prototype))
    (report-error 'user-error "(save-prototype ~a): ~a is not a prototype!~%" prototype prototype)
    (values nil (km-format nil "(save-prototype ~a): ~a is not a prototype!" prototype prototype)))
   ((and essential-participants (not (member prototype essential-participants)))
    (report-error 'user-error "(save-prototype ~a :essential-participants ...):~%   The root ~a must be a member of the essential-participants list, but wasn't!~%" prototype prototype)
    (values nil (km-format nil "(save-prototype ~a :essential-participants ...):~%   The root ~a must be a member of the essential-participants list, but wasn't!" prototype prototype)))
   (t (let* 
        ((stream0 (or stream (tell file)))
;	 (classes (km `#$(the classes of ,PROTOTYPE)))
;	 (scope (km `#$(the prototype-scope of ,PROTOTYPE)))
	 (scope (get-vals prototype '#$prototype-scope))
	 (participants0 (get-vals prototype '#$prototype-participants))
;	 (participants0 (km `#$(the prototype-participants of ,PROTOTYPE))))
;;; NEW: Add warning and error recovery if this procedure is passed some invalid essentials
	(essential-participants0 
	 (cond ((not (set-difference essential-participants participants0)) ; good! all essentials are participants
		essential-participants)
	       (t (report-error 'user-warning
			"(save-prototype ~a :essential-participants ~a):~%   ~a is/are not prototype-participant(s) of ~a, but should be!~%   Continuing, dropping those non-participants...~%"
			prototype0 essential-participants prototype
			(delistify (set-difference essential-participants participants0)) prototype) 
		  (intersection essential-participants participants0)))))
;;; end NEW (except for 3 essential-participants -> essential-participants0 later)
	(multiple-value-bind
	 (new-essentials error-message)	; nil, if essential participants not given
	    (cond (essential-participants0 (find-essentials essential-participants0 :protoroot prototype 
							   :participants participants0)))
	  (cond 
	   (error-message (values nil (concat "Doing save-prototype: " error-message)))
	   (t (let*
		  ((participants (get-vals prototype '#$prototype-participants))
;		   (partitipants (km `#$(the prototype-participants of ,PROTOTYPE))) ; redo incase find-essentials patched buggy file
		   (participants-to-write-out ; [1] put prototype root first
		    (cons prototype (remove prototype (or new-essentials participants)))) ; write out either essentials or all
		   (non-essentials (ordered-set-difference participants new-essentials))
		   (partially-cloned-from ; nil if no essential participants given. 
       ; partially-cloned-from = roots of prototypes cloned into prototype0 which are now only partially cloned in.
		    (cond (essential-participants0	
;			   (km `#$(the prototype-participant-of of (the cloned-from of ,(VALS-TO-VAL NON-ESSENTIALS))))))) ; [2]
			   (remove-duplicates ; -> protoroots
			    (my-mapcan #'(lambda (prototype-participant)
					   (get-vals prototype-participant '#$prototype-participant-of))
				       (my-mapcan #'(lambda (non-essential)  ; -> protoinstances
						      (get-vals non-essential '#$cloned-from))
						  non-essentials)))))) ; [2]
	   ; partial-clone-roots = nodes that need to be re-expanded (participants built from partially cloned prototypes)
		   (partial-clone-roots 
		    (remove-if-not #'(lambda (participant)
				       (intersection (get-vals participant '#$clone-built-from) partially-cloned-from))
				   new-essentials))
	   ; trimmed-expanded-from = additional essential nodes that need to be re-expanded (because some non-essential,
		; i.e., trimmed, node was derived from these essential nodes
		   ; NOTE: These were added per HLO-2608
		   (trimmed-expanded-from (remove-duplicates
					   (intersection (remove-duplicates (my-mapcan #'node-expanded-from non-essentials))
							 new-essentials)))		   
		   )			
;		(km-format t "non-essentials = ~a~%" non-essentials)
		(cond
		 (essential-participants0 ; the below messages are meaningless if no essentials are given (= all nodes are treated as essential)
		  (cond (partially-cloned-from
			 (km-format t "save-prototype: This save includes only partial clones of the following prototypes, 
   so the clone-built-from links to these prototypes will NOT be saved (to allow re-cloning):~%   ~a~%" 
				    partially-cloned-from))
			(t (km-format t "save-prototype: This trimmed prototype includes only full clones.~%")))
		  (cond (partial-clone-roots
			 (km-format t "save-prototype: These nodes need to be re-expanded (have the above prototypes re-cloned onto):~%   ~a~%" 
				    partial-clone-roots)))
		  (cond ((set-difference trimmed-expanded-from partial-clone-roots)
			 (km-format t "save-prototype: Also, these nodes need to be re-expanded (have BaseKb assertions re-applied to):~%   ~a~%" 
				    (set-difference trimmed-expanded-from partial-clone-roots))))
		  (cond ((and (null trimmed-expanded-from) (null partial-clone-roots))
			 (km-format t "save-prototype: No nodes need to be re-expanded.~%")))))
		
		(km-format stream0 "~%;;; ---------- Definition of prototype for ~a ----------~%~%" (delistify scope))
;    (mapc #'(lambda (class)
;	      (km-format stream0 "(~a has (superclasses ~a))~%~%" class (immediate-superclasses class)))
;	  (remove '#$Thing classes))
		(mapc #'(lambda (participant)
			  (save-frame participant :stream stream0 
				      :situations `(,*global-situation*) :save-prototypep t
				      :essentials participants-to-write-out :partially-cloned-from partially-cloned-from))
		      participants-to-write-out)
		(mapc #'(lambda (extra-assertion)
			  (km-format stream0 "~a~%" extra-assertion))
		      extra-assertions)
		(cond (extra-assertions (km-format stream0 "~%")))
		(mapc #'(lambda (participant)
			  (save-explanations participant :stream stream0 :explanation-types *prototype-explanation-types-to-save*
					     :essentials participants-to-write-out))
		      participants-to-write-out)
		(km-format stream0 "~%;;; ---------- end of prototype definition ----------~%~%")
		(cond ((and (not stream) ; i.e., file keyword given
			    (streamp stream0)) (close stream0)))
;    '#$(t)
		(cond ((set-difference partial-clone-roots trimmed-expanded-from)
		       (km-format t "WARNING: trimmed parts of prototypes cloned onto nodes ~a were missing explanations.~%" (set-difference partial-clone-roots trimmed-expanded-from))
		       (km-format t "WARNING: Not a problem but this shouldn't happen!~%")))
;		(km-format t "partial-clone-roots = ~a~%" partial-clone-roots)
;		(km-format t "trimmed-expanded-from = ~a~%" trimmed-expanded-from)
		(cond 
		 (essential-participants0   ; trimming only happens if essential participants was given
		  (cond ((null non-essentials) (km-format t "~a: Prototype size unchanged at ~a nodes.~%" prototype (length participants)))
			(t (km-format t "~a: Prototype size reduced from ~a to ~a nodes.~%" prototype (length participants) (length new-essentials)))))
		 (t (km-format t "Prototype ~a (~a nodes) saved.~%" prototype (length participants))))
		(remove-duplicates
		 (append partial-clone-roots ; may be NIL of course
			trimmed-expanded-from)) ; this should be a superset of partial-clone-roots, unless 
					; explanations are missing for some reason, hence do intersection
		)))))))))

;;; ======================================================================
;;;		TRIM PROTOTYPE
;;; ======================================================================

;;; Similar to save-prototype: trim prototype in-memory
;;; Some participants will be UNCHANGED, some will be MODIFIED, and some will be completely DELETED (the NON-ESSENTIALS)
;;; Trim prototype now returns the list of MODIFIED participants.
;;; RETURNS: TWO values
;;;   - The nodes in the prototype whose clone-built-from values changed, ie, where recloning (reexpansion) is needed
;;;   - If an error occurred, a string describing the error. To test for success, make sure this value in NIL
;;;
;;; The basic idea is that the essential participants are the visible ones, the others are inferred but never viewed
;;;    by the SME, so can be dropped
(defun trim-prototype (prototype0 &key essential-participants)
  (let* ((prototype (dereference prototype0))
	 (prototype-classes (remove-subsumers (get-vals prototype '#$prototype-of))))
  (cond 
   ((not (prototypep prototype))
    (report-error 'user-error "(trim-prototype ~a): ~a is not a prototype!~%" prototype prototype)
    (values nil (km-format nil "(trim-prototype ~a): ~a is not a prototype!" prototype prototype)))
   ((null essential-participants)
    (report-error 'user-error 
		  "(trim-prototype ~a :essential-participants nil): You must provide some essential participants!~%" 
		  prototype)
    (values nil (km-format nil 
		   "(trim-prototype ~a :essential-participants nil): You must provide some essential participants!" 
		  prototype)))
   ((not (member prototype essential-participants))
    (report-error 'user-error "(trim-prototype ~a :essential-participants ...):~%   The root ~a must be a member of the essential-participants list, but wasn't!~%" prototype prototype)
    (values nil (km-format nil "(trim-prototype ~a :essential-participants ...):~%   The root ~a must be a member of the essential-participants list, but wasn't!" prototype prototype)))
   (t (let* ((participants0 (get-vals prototype '#$prototype-participants))
;;; NEW: Add warning and error recovery if this procedure is passed some invalid essentials
	    (essential-participants0 
	     (cond ((not (set-difference essential-participants participants0)) ; good! all essentials are participants
		    essential-participants)
		   (t (report-error 'user-error
		        "(trim-prototype ~a :essential-participants ~a):~%   ~a is/are not prototype-participant(s) of ~a, but should be!~%   Continuing, dropping those non-participants...~%"
			prototype0 essential-participants prototype
			(delistify (set-difference essential-participants participants0)) prototype) 
		      (intersection essential-participants participants0)))))
;;; end NEW (except for 1 essential-participants -> essential-participants0 later)
	(multiple-value-bind
	    (new-essentials error-message)
	    (find-essentials essential-participants0 :protoroot prototype :participants participants0)
	  (cond
	   (error-message (values nil (concat "Doing trim-prototype: " error-message)))
	   (t (let*
	       ((participants (get-vals prototype '#$prototype-participants)) ; redo incase find-essentials patched buggy file
		(non-essentials (ordered-set-difference participants new-essentials))
; partially-cloned-from = roots of prototypes cloned into prototype0 which are now only partially cloned in.	 
		(partially-cloned-from
;		 (km `#$(the prototype-participant-of of (the cloned-from of ,(VALS-TO-VAL NON-ESSENTIALS))))) ; [2]
;		 This returns the ROOTS of prototypes cloned into the current one. If the root is non-essential,
;		 we better delete the clone-built-from tags later.
		           (remove-duplicates	; -> protoroots
			    (my-mapcan #'(lambda (prototype-participant)
					   (get-vals prototype-participant '#$prototype-participant-of))
				       (my-mapcan #'(lambda (non-essential)  ; -> protoinstances
						      (get-vals non-essential '#$cloned-from))			; these are the sources of the participants to be completely deleted
						  non-essentials)))) ; [2]
; partial-clone-roots = the nodes that the above partially-cloned prototypes were cloned onto
; Sunil wants these to change their expansion status (HLO-2250)	 
		(partial-clone-roots 
		 (remove-if-not #'(lambda (participant)
				    (intersection (get-vals participant '#$clone-built-from) partially-cloned-from))
				new-essentials))
	        (trimmed-expanded-from (remove-duplicates
					(intersection (remove-duplicates (my-mapcan #'node-expanded-from non-essentials))
						      new-essentials))))
	       
	       (cond (partially-cloned-from
		      (km-format t "trim-prototype: This trimmed prototype includes partial clones of the following prototypes,~% 
   so the clone-built-from links to these prototypes will be removed (to allow re-cloning):~%   ~a~%" 
				 partially-cloned-from))
		     (t (km-format t "trim-prototype: This trimmed prototype includes only full clones.~%")))

	       (cond (partial-clone-roots
		      (km-format t "trim-prototype: These nodes need to be re-expanded (have the above prototypes re-cloned onto):~%   ~a~%" 
				 partial-clone-roots)))
		(cond ((set-difference trimmed-expanded-from partial-clone-roots)
		       (km-format t "trim-prototype: Also, these nodes need to be re-expanded (have BaseKb assertions re-applied to):~%   ~a~%" 
				  (set-difference trimmed-expanded-from partial-clone-roots))))
		(cond ((and (null trimmed-expanded-from) (null partial-clone-roots))
		       (km-format t "trim-prototype: No nodes need to be re-expanded.~%")))
	       
	       (km-format t "Trimming ~a essential frames in memory..." (length new-essentials))
	       (let
		 ((modified-participants
  	          (remove-duplicates
		   (mapcan #'(lambda (participant) ; these are all the participants that will be LEFT after trimming
		    (mapcan #'(lambda (slotvals)
			    (let* ((slot (slot-in slotvals))
				   (vals0 (vals-in slotvals))
				   (vals (cond ((single-valued-slotp slot) (un-andify vals0))
					       (t vals0)))
				   (skolem-vals (remove-if-not #'anonymous-instancep (flatten vals)))) ; flatten is unnecessary for deletion, but is useful for checking all participants are declared
			      (cond
			       ((eq slot '#$clone-built-from) ; DROP clone-built-from flags for prototypes whose clones
				(let ((clone-built-from-to-drop		; are only being partially saved
				       (intersection vals partially-cloned-from)))
				  (mapc #'(lambda (val) 
					    (let ((*trace-prototype-assertions* nil)) ; ok to update prototypes
					      (delete-val participant '#$clone-built-from val :situation *global-situation*)))
					clone-built-from-to-drop))
				nil)
			       ((member slot *slots-with-nonparticipant-skolems*) nil) ; no action

; REVISED: Still may trim non-local constraints, even if all the vals are essential, hence we can't skip this step.
;			       ((not (set-difference skolem-vals new-essentials)) nil) ; all vals are essential, so keep them!
				
			       (vals (cond
				      ((set-difference skolem-vals participants)
				       (report-error 'user-warning "(the ~a of ~a) includes~%   ~a in prototype ~a,~%   but ~a isn't/aren't declared as prototype-participants)!~% I will drop these values on this slot."
						     slot participant 
						     (remove-if-not #'(lambda (val) 
									(set-difference
									 (remove-if-not #'anonymous-instancep (flatten val))
									 participants))
								    vals)
						     prototype 
						     (set-difference skolem-vals participants))))
				     
				     (let* ((deletions-p 
					     (mapcar #'(lambda (val)
							 (let* ((*trace-prototype-assertions* nil) ; ok to update prototypes
								(val-skolems (remove-if-not #'anonymous-instancep (flatten val)))) ; flatten is probably unnecssary
							   (cond ((constraint-exprp val)
								  (let* ((isv-explanations (get-explanations participant slot val *global-situation*))
									 (explanations (my-mapcan #'explanations-in isv-explanations)))
;								    (km-format t "explanations for ~a = ~a~%" val explanations)
								    (cond
								     ((every #'(lambda (explanation)	; No local support for constraint, so delete it
										 (or (eq (explanation-type explanation) '#$cloned-from)
										     (and (eq (explanation-type explanation) '#$added-at)
											  (not (member (second explanation) prototype-classes)))))	; added at superclass, not current class
									     explanations)
								      (mapc #'(lambda (explanation) ; (cloned-from _ProtoCar1 _Car2 _ProtoWheel1)  -> source was ProtoCar1, cloned onto _Car2
										(cond ((eq (explanation-type explanation) '#$cloned-from)
										       (let ((originating-protoroot (second explanation))
											     (cloned-onto (third explanation)))
;										  (km-format t "~a -> ~a~%" originating-protoroot cloned-onto)
											 (cond ((member originating-protoroot
													(get-vals cloned-onto '#$clone-built-from :situation *global-situation*))
												(delete-val cloned-onto '#$clone-built-from originating-protoroot :situation *global-situation*)))))))
									    explanations)
								      (km-format t "DEBUG: Trimming inherited constraint (~a has (~a (~a))) [not locally asserted]~%"
										 participant slot val)
								      (delete-val participant slot val :situation *global-situation*)
								      t))))
							         ((null (set-difference val-skolems new-essentials)) ; [1] no non-essential val-skolems, so keep it (includes constants)
								  nil)
								 (t (delete-val participant slot val :situation *global-situation*) t))))
						     vals)))
				       (cond ((member t deletions-p)
					      (list participant))))) ; return the id of the modified participant
			       )))
			    (get-slotsvals participant :situation *global-situation*)))
		       new-essentials))))
;		 (km-format t "DEBUG: modified-participants = ~a~%" modified-participants)
		 (km-format t "~a were modified, ~a remain unchanged...~%" (length modified-participants) 
			   (- (length new-essentials) (length modified-participants)))
		(km-format t "Deleting ~a non-essential frames from memory...~%" (length non-essentials))
		(let ((*trace-prototype-assertions* nil)) ; ok to update prototypes		
		  (mapc #'delete-frame non-essentials))
		
		(let ((n-deleted 
		       (apply #'+ (mapcar #'(lambda (essential)
					     (delete-nonessential-explanations essential :essentials new-essentials))
					 new-essentials))))
		  (km-format t "Deleted ~a explanations for essentials that involve non-essentials...~%" n-deleted))

		(cond ((set-difference partial-clone-roots trimmed-expanded-from)
		       (km-format t "WARNING: trimmed parts of prototypes cloned onto nodes ~a were missing explanations.~%" (set-difference partial-clone-roots trimmed-expanded-from))
		       (km-format t "WARNING: Not a problem but this shouldn't happen!~%")))

		(cond ((null non-essentials) (km-format t "~a: Prototype size unchanged at ~a nodes.~%" prototype (length participants)))
		      (t (km-format t "~a: Prototype size reduced from ~a to ~a nodes.~%" prototype (length participants) (length new-essentials))))
		(remove-duplicates
		 (append partial-clone-roots
			trimmed-expanded-from)) ; should be a superset of partial-clone-roots, but do a union
		 				; in case explanations are missing
		))))))))))

;;; ======================================================================

;;; Returns the number of deletions done
(defun delete-nonessential-explanations (concept &key essentials)
  (length (remove nil (mapcar #'(lambda (isv-explanation) 
				  (delete-nonessential-explanation isv-explanation :essentials essentials))
			      (get-all-explanations concept nil)))))

;;; [1] Note: all prototype explanations are in *Global
(defun delete-nonessential-explanation (isv-explanation &key essentials)
  (let ((nonessentials (nonessentials-in isv-explanation :essentials essentials)))
    (cond
     (nonessentials
;      (km-format t "DEBUG: Dropping explanation containing a non-essential ~a:~%  ~a~%"
;		 (delistify (remove-duplicates nonessentials)) isv-explanation)
      (let ((i (first isv-explanation))
	    (s (second isv-explanation))
	    (v (third isv-explanation))
	    (explanation (explanation-in isv-explanation)))
	(delete-explanation i s v :explanation-to-delete explanation :situation *global-situation*)	; [1]
	t)))))

;;; ======================================================================

(defparameter *expand-essentials* t)

#|
----------------------------------------
find-essentials: Given an initial list of essential participants, iteratively expand the list
so that each slot's values are either ALL essential or NONE are. Then (in save-prototype) just 
write out the slots where ALL the slot's values are essential. 

RETURNS: TWO values
 - The list of essential participants, or NIL if an error occurred
 - If an error occurred, a string reporting the error

ALGORITHM:
GATHER PROCESS:
foreach essential individual [a subset of participants]
  foreach slot+vals of essential individual
    IF none of the vals are essential individuals, skip the slot
    ELSE add any vals which AREN'T essential individuals to the essential individuals list
ITERATE until the list of essential participants is stable
----------------------------------------
|#
;;; Iterate until no more essentials found
;;; (find-essentials '#$(_Car1 _Engine1 _Cylinder1) :protoroot '#$_Car1)
(defun find-essentials (essentials &key protoroot (participants (get-vals protoroot '#$prototype-participants)) (n 1))
;  (km-format t "DEBUG: Iteration ~a: ~a essentials of ~a~%" n (length essentials) (length participants))
;  (km-format t "participants = ~a~%" participants)
  (cond
   ((not *expand-essentials*) essentials)		; conditionally disable this functionality
   ((> n 30)
    (report-error 'system-error "find-essentials for ~a seems stuck in a loop (iterated 30 times)!~%" protoroot)
    (values nil (km-format "find-essentials for ~a seems stuck in a loop (iterated 30 times)!" protoroot)))
   ((set-difference essentials participants)  ; bad! Some essentials aren't participants...
    (cond ((not (set-difference essentials ; ...but false alarm; participants doesn't reflect the (up to date) 
					   ; list of participants (they were augmented), so recompute and retry:
				(get-vals protoroot '#$prototype-participants)))
	   (find-essentials essentials :protoroot protoroot :n n))   ; no :participants -> will be recomputed (defun above)
;;; 1/16/10 Change this to a warning...
;	  (t (report-error 'user-error
;		  "(find-essentials ~a :protoroot ~a):~%   ~a is/are not prototype-participant(s) of ~a, but should be!~%"
;		  essentials protoroot (delistify (set-difference essentials participants)) protoroot)
;	     (values nil 
;	      (km-format nil 
;		"(find-essentials ~a :protoroot ~a):~%   ~a is/are not prototype-participant(s) of ~a, but should be!"
;		essentials protoroot (delistify (set-difference essentials participants)) protoroot)))))
	  (t (report-error 'user-warning
		  "(find-essentials ~a :protoroot ~a):~%   ~a is/are not prototype-participant(s) of ~a, but should be!~%   Continuing, dropping those non-participants...~%"			   
		  essentials protoroot (delistify (set-difference essentials participants)) protoroot)
	     (find-essentials (ordered-intersection essentials ; retry with just those essentials that are participants
						    (get-vals protoroot '#$prototype-participants))
			      :protoroot protoroot :n n))))
   (t (let ((new-essentials (find-essentials0 essentials :protoroot protoroot :participants participants)))
	(cond ((set-equal essentials new-essentials) 
	       (km-format t 
  "find-essentials: The following ~a of ~a participants are not essential to the prototype ~a:~%   ~a~%"
  		(length (set-difference participants essentials)) (length participants) protoroot 
		(set-difference participants essentials))
	       new-essentials)		; reached quiescence
	      (t (find-essentials new-essentials :protoroot protoroot :participants participants :n (1+ n))))))))

#|
(_Car1 parts (_Engine1 _Wheel1))
If _Car1 and _Engine1 are essential, _Wheel1 will be added as essential also

(_Car1 parts ((:pair _Engine1 *red)))
_Engine1 will be MADE essential because there are some non-anonymous elements in the structure
When writing, if there are ever non-anonymous elements, write them out.
|#
(defun find-essentials0 (essentials-to-check &key protoroot participants (essentials essentials-to-check))
  (cond
   ((endp essentials-to-check) essentials)
   (t (let* ((essential (first essentials-to-check))
	     (slotsvals (get-slotsvals essential :situation *global-situation*))
;	     (bad-instances-list nil) ; hacky way of catching bad-instances in procedure below
	     (extra-essentials
	      (remove-duplicates
	       (my-mapcan #'(lambda (slotvals)
			  (let ((slot (slot-in slotvals))
				(vals (vals-in slotvals)))
			    (cond
			     ((member slot *unclonable-slots*) nil)	; important! Skip these
			     ((member slot '#$(cloned-from clone-built-from)) nil)
			     (t (let* ((instances (remove-if-not #'anonymous-instancep (flatten vals)))
				       (good-instances (intersection instances participants))
;				       (bad-instances (set-difference instances (append bad-instances-list participants)))
				       )
; No: it would be better to *drop* the bad value (done later by trim-prototype and save-prototype)
;				  (cond
;				   (bad-instances
;				    (report-error 'user-warning
;		  "(the ~a of ~a) includes~%   ~a in prototype ~a,~%   but ~a isn't/aren't declared as prototype-participants)! I will patch the prototype and add them as participants...~%"
;		  slot essential (delistify bad-instances) protoroot (delistify bad-instances))
;				    (mapc #'(lambda (bad-instance)
;					      (push bad-instance bad-instances-list)
;					      (let ((*trace-prototype-assertions* nil))
;						(add-val bad-instance '#$prototype-participant-of protoroot)))
;					  bad-instances)))
				  (cond
				   ((or (intersection instances essentials) ; if ANY instance is essential...
					(notevery #'anonymous-instancep (flatten vals))) ; OR there's a non-Skolem...
;				    (ordered-set-difference instances ; ...then ALL instances are essential
;							    essentials))))))))
				    (ordered-set-difference good-instances ; ...then ALL (good) instances are essential
						    essentials))))))))			  
			  slotsvals))))
;	(km-format t "extra-essentials = ~a~%" extra-essentials)
	(find-essentials0 (append (rest essentials-to-check) extra-essentials)
			 :protoroot protoroot :participants participants ; (append bad-instances-list participants)
			 :essentials (append essentials extra-essentials))))))

;;; Force (re-)evaluation of all edges in the prototype
;(defun eval-prototype (protoinstance)
;  (let ((participants (km-int `#$(the prototype-participants of ,PROTOINSTANCE))))
;    (eval-instances participants :recursivep nil)))

;;; ======================================================================
;;; 		DELETE PROTOTYPE TRIPLE
;;; NOTE: This implementation is broken a little, as prototype supports are now (<f> <s> <v>) rather
;;; then (cloned-from <...>) structures ([1] needs modifying).
;;; 3/4/08: ALSO: For dependent triples that are NOT deleted [2] (as they are supported by other
;;;         things also), this function needs to at least UPDATE their supports to no longer include
;;;	    the prototype.
;;; ======================================================================
(defun delete-prototype-triple (triple)
  (cond 
   ((or (and (anonymous-instancep (first triple)) (not (protoinstancep (first triple))))
	(and (anonymous-instancep (third triple)) (not (protoinstancep (third triple))))
	(and (not (anonymous-instancep (first triple))) (not (anonymous-instancep (third triple)))))
    (report-error 'user-error "ERROR! ~a is not part of a prototype!~%" triple))
   (t (let* 
        ((classes (prototype-classes triple))
	 (prototype-root (in-prototype triple))
	 (supports (get-support-details triple))
	 (external-supports (remove-if-not #'(lambda (support)
					       (or (eq (first support) '#$every)
						   (and (eq (first support) '#$added-at)
							(not (member (second support) classes)))
						   (and (triplep support)
							(not (eq (first support) '#$added-at))
							(set-difference (prototype-classes support) classes))))
					   supports))
	 (internal-supports (ordered-set-difference supports external-supports :test #'equal)))
    (km-format t "(~a is part of the prototype for ~a)~%" triple (delistify classes))
    (cond (external-supports
	   (km-format t "Can't delete this triple! It is supported by:~%")
	   (mapc #'show-support external-supports) 
	   nil)
	  (t (cond (internal-supports
		    (km-format t "Can delete this triple. It only has local supports as follows:~%")
		    (mapc #'show-support internal-supports))
		   (t (km-format t "Can delete this triple~%")))
	     (let ((dependent-triples (triple-cloned-to triple)))
	       (cond (dependent-triples
		      (km-format t "Deleting dependent triples:~%")
		      (mapc #'(lambda (dependent-triple)
				(let* ((dependent-supports (get-support-details dependent-triple))
				       (new-dependent-supports0 (remove triple dependent-supports :test #'equal))
				       (new-dependent-supports (remove-if #'(lambda (triple)
									      (and (eq (first triple) '#$added-at)
										   (member (second triple) classes)))
									  new-dependent-supports0)))
				  (cond (new-dependent-supports ; [2]
					 (km-format t "   ~a: not deletable: still supported by ~a (not deleted).~%" 
						    dependent-triple new-dependent-supports)
					 (delete-support-by-prototypes dependent-triple (list prototype-root)))
					(t (km-format t "   ~a: deletable, so deleting it.~%" dependent-triple)
					   (delete-triple dependent-triple)))))
			    dependent-triples))
		     (t (km-format t "(No dependent triples to try and delete)~%"))))
	     (km-format t "Finally deleting main triple (done).~%")
	     (delete-triple triple)
	     t))))))

(defun delete-triple (triple)
  (let ((f (first triple))
	(s (second triple))
	(v (third triple)))
    (delete-val f s v)))

(defun show-support (support)		     
  (cond ((eq (first support) '#$every) (km-format t "   ~a~%" support))
	((eq (first support) '#$added-at) (km-format t "   A user-added assertion at ~a (~a)~%" 
						     (second support) (third support)))
	((triplep support) (km-format t "   ~a, stored at ~a~%" support (delistify (prototype-classes support))))))


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

(defun raise-prototype (prototype)
  (cond ((not (prototypep prototype))
	 (report-error 'user-error "ERROR! (raise-prototype ~a): ~a is not the root of a prototype!~%"
		       prototype prototype))
	(t ; (mapc #'raise-participant (km-int `#$(the prototype-participants of ,PROTOTYPE)))
	     (mapc #'raise-participant (get-vals prototype '#$prototype-participants))
	 t)))

(defun raise-participant (participant)
  ;;; Raise slot values
  (mapc #'(lambda (situation)
	    (add-slotsvals participant (get-slotsvals participant :situation situation)
			   :situation *global-situation* :combine-values-by 'appending))
	(remove *global-situation* (all-situations)))
  ;;; Raise explanations
  (put-explanation-data participant (remove-duplicates
				     (my-mapcan #'(lambda (situation)
						    (get-explanation-data participant :situation situation))
						(all-situations))
				     :test #'equal)
			:situation *global-situation*))

;;; ======================================================================

#|
triple-expanded-from returns the node(s) in the CMap which led to <triple> being concluded.
node-expanded-from does the same thing for a specific node. If <node> was part of a prototype whose root
  was cloned onto <root-clone>, then <root-clone> is returned.
  Or more specifically, like triple-expanded-from, TWO values are returned: 
	(i) a list of <root-clone> nodes
	(ii) a list of (<root-clone> <source> <source-class>), as documented for triple-expanded-from.

ALGORITHM:
The supports for <node> are the union of the supports for the triples in which <node> participates.

Question: We find the triples then look at their explanations via triple-expanded-from...  Why not simply
look at ALL explanations directly on node via get-explanation-data? I guess the only reason is that
triple-expanded-from looks at not just the forward links, but also the inverse direction: Suppose
N-r-X, and the explanation database says (X-invr-N (cloned-from ...)); then we want to get that inverse
explanation as part of the node-expanded-from data. However: I *think* KM records explanations in both
directions anyway so strictly such reversing may not be necessary. However, we'll leave it for now.
|#
(defun node-expanded-from (node0 &key ignore-prototypes)
  (let* ((node (dereference node0))
	 (incoming-triples 
	  (mapcan #'(lambda (slotvals)
		      (let ((slot (slot-in slotvals))
			    (vals (vals-in slotvals)))
			(mapcan #'(lambda (val)
				    (cond 
				     ((eq slot '#$cloned-from) nil)
				     ((or (&-exprp val) (&&-exprp val))		; (x & y) or ((x) && (y))
				      (mapcar #'(lambda (val0)
						  `(,node ,slot ,val0)) 	  ; (find-exprs '(x & y) -> (x y)
					      (find-exprs val :expr-type 'any)))  ; (find-exprs '((x) && (y))) -> (x y)
				     (t `((,node ,slot ,val)))))
				vals)))
		  (append (get-slotsvals node)
			  (cond ((am-in-local-situation) (get-slotsvals node :situation *global-situation*))))))
	 (node+rule-pairs (remove-duplicates
			   (mapcar #'(lambda (triple)
; Ug, why did I do :both-directions nil? It leads to errors (HLO-1617). Remove it!
;				       (multiple-value-list (triple-expanded-from triple :both-directions nil)))
; RETURNS: ((_Foo3) ((_Foo3 (cloned-from _ProtoFoo3) (Foo))))   for cloned nodes, NIL otherwise
				       (multiple-value-list (triple-expanded-from triple 
										  :ignore-prototypes ignore-prototypes))) 
				   incoming-triples)
			   :test #'equal))
	 (nodes+rules (transpose node+rule-pairs))
	 (nodes (remove-duplicates (apply #'append (first nodes+rules))))
	 (rules (remove-duplicates (apply #'append (second nodes+rules)) :test #'equal)))
;    (km-format t "nodes+rule-pairs = ~%~{   ~a~%~}" node+rule-pairs)
    (values nodes rules)))

#|
MAPCAN-SAFE
(triple-expanded-from <triple>)
(triple-expanded-from '#$(_Move5 agent _Person8))  
	-> (_Foo3)				
     AND   ((_Foo3 (cloned-from _ProtoFoo3) (Foo)))

This function takes a triple in a CMap, and returns TWO values, namely TWO
lists whose members are respectively:
 - the individual in the same CMap from which it was expanded
 - the (same) individual + source + classes 
   where source is EITHER:
   (cloned-from prototype-root), where prototype-root is the root of the 
         prototype which was cloned onto the individual to produce 
	 (among other things) <triple>.
   (every class has ...), an expression which when evaluated resulted in
         _Foo3.
   classes are either the class(es) of this prototype or the (listified)
   class on which the (every ...) expression resides.

   Each source contributing to <triple> will be denoted by a different
   element in this second list, even if they both were applied onto the same
   individual node in the CMap.

See aura-api.txt for further documentation
|#
(defun triple-expanded-from (triple &key ignore-prototypes)
  (cond
   ((not (triplep triple))
    (report-error 'user-error 
		  "expanded-from ~a: Need a triple as an argument, e.g., (expanded-from '#$(_Move5 agent _Person8))~%"
		  triple))
   (t (let* ((expln-struct1 (get-explanations0 (first triple) (second triple) (third triple)))
	     (expln-struct2 (get-explanations0 (third triple) (invert-slot (second triple)) (first triple)))
	     (expln-structs (remove nil (list expln-struct1 expln-struct2))))
	(item-expanded-from expln-structs :ignore-prototypes ignore-prototypes)))))

;;; MAPCAN-SAFE
(defun item-expanded-from (expln-structs &key ignore-prototypes)
  (let* ((explanations (my-mapcan #'fourth expln-structs))
	 (instance+root/rule+classes-list
	                  (remove-duplicates
			   (remove nil
			    (mapcar #'(lambda (explanation) ; [1] e.g., (cloned-from <protoroot> <clone-root>)
					(cond ((and (listp explanation)
						    (eq (first explanation) '#$cloned-from)
						    (known-frame (third explanation)) ; root of expansion
						    (not (member (second explanation) ignore-prototypes)))
					       (list (third explanation) 		; clone-root
						     `(#$cloned-from ,(second explanation)) ; prototype-root
						     (prototype-classes (second explanation)))) ; prototype-classes
					      ((and (listp explanation)
						    (let* ((source (first (sources explanation)))) ; should never be > 1
;						      (km-format t "source = ~a~%" source)
						      (cond (source
							     (let ((class (originated-from-class source))
								   (instance (inherited-to-instance source))
								   (rule (build-rule explanation)))
							       (list instance rule (list class))))))))))
				    explanations))
			   :test #'equal))
	 (instances (remove-duplicates (mapcar #'first instance+root/rule+classes-list))))
;    (km-format t "instance+root/rule+classes-list = ~a~%" instance+root/rule+classes-list)
;    (km-format t "triple-expanded-from: explanations = ~a~%" explanations)
    (values instances instance+root/rule+classes-list)))
	    
;;; ======================================================================

(defun add-triple (triple)
  (let* ((f (first triple))
	 (s (second triple))
	 (v (third triple)))
    (km `#$(,F also-has (,S (,V))))))

#|
(add-triple-asif-cloned <triple> <n> <source-triple> <source-root>)
(add-triple-asif-cloned 
     '#$(_Hand2 parts _Finger2) '#$_Arm2 '#$(_Hand1 parts _Finger1) '#$_Arm1)

Assert <triple>, but make it LOOK as if <triple> was cloned from 
<source-triple> in the prototype rooted at <source-root>. 

Imagine the prototype rooted at <source-root> was cloned onto the node <n>,
resulting in, among other things, <triple> being asserted as a clone 
of <source-triple>. add-triple-asif-cloned makes it *look* as if this
is what happened, although in practice it asserts <triple> explicitly.

For example, given:

  Prototype of Arm: [Arm1]-parts->[Hand1]

  Prototype of Body: [Body2]-parts->[Arm2]-parts->[Hand2]	
        where [Arm2]-parts->[Hand2] was cloned from [Arm1]-parts->[Hand1]	

Suppose we now extend Arm's prototype to be:

  Prototype of Arm: [Arm1]-parts->[Hand1]-parts->[Finger1]

If we want to add the equivalent triple to the Body prototype AS IF IT 
WAS CLONED from Arm, do:

  ;;; Create a finger
  (km '#$(a Finger)) -> [Finger2]

  ;;; Now do:
  (add-triple-asif-cloned 
        '(Hand2 parts Finger2) 'Arm2 '(Hand1 parts Finger1) 'Arm1)

This also works for adding onto a CLONE of a prototype (e.g., of Body)
as well as to a prototype itself (as above).
  
Footnotes below:
[1] Normally this will be a redundant call if Arm is already cloned into Body.
[2] To tolerate (add-triple-asif-cloned '(_Vic1 subevent (must-be-a OtherEvent)) '_Vic1 
					'(_Vic168 subevent (must-be-a OtherEvent)) '_Vic168)
|#
(defun add-triple-asif-cloned (triple n source-triple source-root)
  (let* ((f (first triple))
	 (s (second triple))
	 (v (third triple))
	 (source-f (first source-triple))
	 (source-v (third source-triple)))
  (km `#$(,F also-has (,S (,V))))
  (cond ((kb-objectp f) (km `#$(,F also-has (cloned-from (,SOURCE-F))))))
  (cond ((kb-objectp v) (km `#$(,V also-has (cloned-from (,SOURCE-V)))))) ; [2]
  (cond ((kb-objectp f) (km `#$(explanation (:triple ,F ,S ,V) ((cloned-from ,SOURCE-ROOT ,N ,SOURCE-F))))))
;;; Soon hopefully we can drop this, when the explanation API is extended
  (cond ((kb-objectp v) (km `#$(explanation (:triple ,V ,(INVERT-SLOT S) ,F) ((cloned-from ,SOURCE-ROOT ,N ,SOURCE-V))))))
  (km `#$(,N also-has (clone-built-from (,SOURCE-ROOT)))))) ; [1]

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

;;; Could probably make this more efficient with a lookahead but doesn't matter I think
(defun remove-clone-cycles (explanation-structs)
;  (break)
  (cond ((endp explanation-structs) nil)
	(t (let* ((explanation-struct (first explanation-structs)) ; (f s v explns)
		  (explanation (fourth explanation-struct)))
	     (cond ((clone-cycle explanation) 
;		    (km-format t "CLONE CYCLE DETECTED! Removing explanation...~%  ~a~%" explanation-struct)
		    (remove-clone-cycles (rest explanation-structs)))
		   (t (cons explanation-struct (remove-clone-cycles (rest explanation-structs)))))))))

#|
HLO-1770: [1] check for clone-cycle not general enough: When doing (clone P) to CP, the cloned explanations might
not only have (N (cloned-from CP CP), but also (N (cloned-from CP N2)) where N2 is a different node in the clone.
In prototype _Cell161, participant _Polymer10255 has:
    (explanation (:triple _Polymer10255 has-part _Amino-Acid10256) ((cloned-from _Cell161 _Dividing-cell10269)))
(where of course _Dividing-cell10269 is also a participant of _Cell161).

Strictly to spot this, we only need to look for (cloned-from CP *). However, to be safe we could check for
(cloned-from CX *) where CX is clone of ANY node in the original prototype. Or, to do the same thing,
simply test that CX is a prototype, i.e., hasn't been sublis'ed from a prototype to a non-prototype
through mapping-alist. In principle, the only case I can see where CX might be a non-prototype is when
CX is the clone of CP, but we may as well just check in general.

One can see how this issue can arise, if we have:

	[[Cell]] -similar-to-> [Dividing-Cell]
	     \-has-part-> [Amino-Acid]

which then becomes

	[[Cell]] -similar-to-> [Dividing-Cell] -similar-to-> [Dividing-Cell']
	     \-has-part-> [Amino-Acid]        \-has-part-> [Amino-Acid']

here we'll have 
    (explanation (:triple Dividing-Cell has-part Amino-Acid' ((cloned-from [Cell] [Dividing-Cell]))))
|#
;;; (cloned-from _Car1 _Car1)
;;; (cloned-from _Car1 _Car2)
;;; I think really we just need to make sure that _Car1 isn't the clone of the prototype root, but for safety
;;; let's check it isn't a clone of *anything* in the original prototype
(defun clone-cycle (explanation)
  (and (listp explanation)
       (eq (first explanation) '#$cloned-from)
;      (eq (second explanation) (third explanation))	 [1]
       (not (prototypep (second explanation))) ; No! Due to load order, may not YET be asserted a prototype (HLO-1859)
       ))				       ; We'll handle this by suppressing the check during file loading

;;; (cloned-from _Foo1 _Foo2 _Bar1 2) ->  (cloned-from _Foo1 _Foo2)
(defun simplify-cloned-from (explanation) (first-n explanation 3))

;;; FILE: stack.lisp

;;; File: stack.lisp
;;; Author: Peter Clark
;;; Date: 1994
;;; Purpose: Maintenance of the stack

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

(defvar *obj-stack* ())	; all objects created/touched during reasoning
(defvar *goal-stack* ())		; goal stack
(defvar *silent-spypoints-stack* ())    ; spying certain KM expressions (Jason Chaw)

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

(defun clear-silent-spypoints-stack () (setq *silent-spypoints-stack* nil))
(defun silent-spypoints-stack () *silent-spypoints-stack*)

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

;;; synonym
(defun new-context () 
;  (km-setq '*all-active-situations* nil)		; New!
  (clear-obj-stack))

(defun clear-goal-stack () (setq *goal-stack* nil))
(defun goal-stack () *goal-stack*)
(defun top-level-goal () (first (last-el *goal-stack*)))

;;; [1] Tiny bit slower, but allows spotting looping earlier (net loss timewise, gain inference wise)
;;; ALSO: See looping-on later
(defun push-to-goal-stack (expr &key target)
  (setq *goal-stack* (cons (item-to-stack (desource+decomment expr) :target target) *goal-stack*)))	; [1]

(defun pop-from-goal-stack ()
  (prog1
      (first *goal-stack*)
    (setq *goal-stack* (rest *goal-stack*))))

;;; ======================================================================
;;; 		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'.

#$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 push-to-goal-stack, earlier
(defun looping-on (expr) (on-goal-stackp (desource+decomment expr))) ; [1] 

#|
(pending-equality x y) - Returns t if x and y WILL be unified, so that deeper in the
stack we can assume they are equal, even though the equality has not yet been asserted.

KM: (show-goal-stack)
 CURRENT GOAL STACK IS AS FOLLOWS:
 -> (the has-part* of (a DNA))                      [called in _Situation10940]
   ;;;
       -> (unify-with-clone-of _Nucleic-Acid82) [called in _Situation10940]
        -> (_DNA-strand15400 &! _Nucleic-Acid15425) [called in |all situations|]

KM: (pending-equality '#$_DNA-strand15400 '#$_Nucleic-Acid15425)
t
|#
(defun pending-equality (x0 y0)
  (let ((x (dereference x0))
	(y (dereference y0)))
    (some #'(lambda (item)
	      (let ((original-expr (third item)))
		(and (listp original-expr)
		     (= (length original-expr) 3)
		     (or (and (equality-assertion-operator (second original-expr))
			      (or (and (eq x (dereference (first original-expr))) (eq y (dereference (third original-expr))))
				  (and (eq y (dereference (first original-expr))) (eq x (dereference (third original-expr))))))
; No, this is too strong.
;			 (and (member (second original-expr) '(&& &&!))
;			      (singletonp (first original-expr)) 		; i.e., (<list> && <list>)
;			      (singletonp (third original-expr)) 
;			      (or (and (eq x (dereference (first (first original-expr)))) (eq y (dereference (first (third original-expr)))))
;				  (and (eq y (dereference (first (first original-expr)))) (eq x (dereference (first (third original-expr)))))))
			      )
		     t)))
	  (goal-stack))))

(defun on-goal-stackp (expr)
; (km-format t "on-goal-stackp: expr = ~a. Stack =~%~{   ~a~%~}" expr *goal-stack*)
  (member (item-to-stack expr) *goal-stack* :test #'stack-equal))		; more efficient

;;; Note: non-canonicalized expressions (element 3 of itemN) are NOT compared
;;; NEW: ***NOT** symmetrical now: item1 is a NEW item, item2 is an item on the existing goal stack.
(defun stack-equal (item1 item2)
  (let ((canonical1 (dereference (first item1)))
	(canonical2 (dereference (first item2))))
  (and (or (equal canonical1 canonical2)		; match canonicalized expressions
;	   (equal (first item1) (first item2))		; [1]
	   (and (listp canonical1)
		(listp canonical2)
		(eq (second canonical1) '#$set-unified-with) ; Doing ((x) &&! (y)) for (x &! y)
		(eq (second canonical2) '#$unified-with)		
		(or (and (equal (first canonical1) (list (first canonical2)))  ; (x) equals (list x)
			 (equal (third canonical1) (list (third canonical2)))) ; (y) equals (list y)
		    (and (equal (first canonical1) (list (third canonical2)))  ; Reverse: Doing ((y) &&! (x)) for (x &! y)
			 (equal (third canonical1) (list (first canonical2)))) ; 
		)))
       (eql (second item1) (second item2))))) ; match situation

;(defun stack-equal (item1 item2)
;  (and (equal (first item1) (first item2))		; match canonicalized expressions
;       (eql (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)
|#
(defun item-to-stack (expr &key target)
;  (declare (ignore target))		; neah, not that helpful
  `(,(canonicalize expr) 
    ,(cond ((and (listp expr) (unification-operator (second expr))) '|all situations|)  ; better - trace is confusing otherwise!
	   (t (curr-situation)))
    ,expr
    ,(inference-number)
    ,target
    ))

;;; The three parts of an item on the stack
(defun stacked-canonical-expr (stacked-item) (first stacked-item))
(defun stacked-situation (stacked-item) (second stacked-item))
(defun stacked-expr (stacked-item) (third stacked-item))
(defun stacked-inference-number (stacked-item) (fourth stacked-item))
(defun stacked-target (stacked-item) (fifth 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.
(defun canonicalize (expr)
  (cond ((and (pairp expr)
	      (not (member (first expr) *reserved-keywords*)))
	 `#$(the ,(SECOND EXPR) of ,(FIRST EXPR)))
	((and (triplep expr)
	      (set-unification-operator (second expr)))			; fold &&, &&?, &&! into a single canonical form
	 `(,(first expr) #$set-unified-with ,(third expr)))		; [1] must distinguish set-unified and unified,
;	 `(,(first expr) #$unified-with ,(third expr)))			; see test-suite/unification.km for bug if they're
									; the same.
	 ((and (triplep expr)		; fold &, &?, &! into a single canonical form
	       (val-unification-operator (second expr))
	       (neq (second expr) '&+!)	; This isn't really a primitive unification operator -- it is decomposed in 
					; interpreter.lisp to &+? plus &!. Thus we don't canonicalize it, as we don't
	       				; want the subsequent &+? or &! to be taken as looping
;	       (neq (second expr) '&+)	; EXCEPT: These *is* a valid subgoal of &&, etc.
;	       (member (second expr) '(&! &+?))	; EXCEPT: These *are* valid subgoals of &+!
;	       (member (second expr) '(&+ &+!))	; Allow &? as a valid subgoal of these
	       )
	  (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)))))
;		`((,(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]

|#

(defun show-goal-stack (&optional (stream t))
  (let ( (show-situationsp (some #'(lambda (item) (neq (second item) *global-situation*)) (goal-stack))) )
    (format stream "--------------------~%~%")
    (format stream " CURRENT GOAL STACK IS AS FOLLOWS:~%")
    (show-goal-stack2 (reverse (goal-stack)) 1 show-situationsp stream)
    (format stream "~%--------------------~%")))

;;; Can turn this on for nicer formatting
(defvar *show-inference-numbers* nil)

(defun show-goal-stack2 (stack depth show-situationsp &optional (stream t))
  (cond 
   ((endp stack) nil)
   (t (let* ((item (first stack)) 
	     (expr (stacked-expr item))
	     (situation (stacked-situation item))
	     (inference-number (stacked-inference-number item))
	     (target (stacked-target item))
	     )
	(cond (*show-inference-numbers* 
	       (km-format stream "~a~vT-> ~a" inference-number (+ depth 7) (desource expr)))
	      (t (km-format stream "~vT-> ~a" depth (desource expr))))
; truncated version
;		 (format t (truncate-string (apply #'km-format `(nil "~vT -> ~a" ,depth ,(desource expr))) 80))
	(cond ((and target show-situationsp) (km-format stream "~%~vT[for ~a, in ~a]~%" (+ depth 3) target situation))
	      (show-situationsp (km-format stream "~vT[called in ~a]~%" 55 situation))
	      (target (km-format stream "~%~vT[for ~a]~%" (+ depth 3) target))	      
	      (t (format stream "~%")))
	(show-goal-stack2 (rest stack) (1+ depth) show-situationsp stream)))))

;;; ======================================================================
;;;		THE OBJECT STACK
;;; ======================================================================

(defun clear-obj-stack () (km-setq '*obj-stack* nil))

;;; Note we filter out duplicates and classes at access time (obj-stack), rather than 
;;; build-time (here), for efficiency.
(defun push-to-obj-stack (instance)
  (cond ((and (not (member instance *obj-stack*))
	      (stackable instance))
;	  (make-transaction `(setq *obj-stack* ,(cons instance *obj-stack*))))))
;	  (setq *obj-stack* (cons instance *obj-stack*)))))		; don't need to unwind this
	  (km-push instance '*obj-stack*))))
	  
(defparameter *unstackable-kb-instances* '#$(t))

(defun stackable (instance)
  (and (kb-objectp instance)
       (not (classp instance))
       (not (slotp instance))
       (not (member instance *unstackable-kb-instances*))))

;;; Only called by delete-frame, which is NOT part of the normal KM. 
;;; Note that this removal is *NOT* unwound by undo commands, to save memory.
;;; [1] Call to (obj-stack) is WAY too slow!
(defun remove-from-stack (instance)
; (make-transaction `(setq *obj-stack* ,(remove instance (obj-stack)))))
  (setq *obj-stack* (remove instance (obj-stack)))) ; don't need to unwind this [1]. remove removes ALL entries

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

;;; Find the first instance on *obj-stack* in class
(defun search-stack (class) 
   (find-if #'(lambda (instance) (isa instance class)) *obj-stack*))

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

(defun show-obj-stack ()
   (mapcar #'(lambda (instance) (km-format t "   ~a~%" instance)) (obj-stack))
   t)

;;; Obsolete now
(defun show-context () (show-obj-stack))

;;; Not used
;(defun showme-context () (showme (vals-to-val (reverse (obj-stack)))) t)

(defun unfiltered-obj-stack () *obj-stack*)

;(defun obj-stack () 
;  (let ( (clean-stack (remove-dup-atomic-instances *obj-stack*)) )
;    (cond ((not (equal clean-stack *obj-stack*)) 
;	   (setq *obj-stack* clean-stack)))
;    clean-stack))

; (defun obj-stack () (remove-dup-atomic-instances *obj-stack*)) ; new - too slow!!!

(defun obj-stack () 
  (let ((clean-stack			; (remove-dup-atomic-instances *obj-stack*)) ) 
	 (dereference *obj-stack*)))	; better
    (cond ((not (equal clean-stack *obj-stack*)) 
	   (setq *obj-stack* clean-stack)))
    clean-stack))

(defun showme-strings (km-expr &optional (situations (all-situations))
                       (theories (all-theories))
                       ;; RVA 21Aug2006 fix km rep loop input output problem
                       ;; stream defaulting to nil (*standard-input*) instead of t (*terminal-io*)
                       (stream nil))
  (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
(defun showme (km-expr &optional (situations (all-situations))
                       (theories (all-theories))
                       ;; RVA 21Aug2006 fix km rep loop input output problem
                       ;; stream defaulting to nil (*standard-input*) instead of t (*terminal-io*)
                       (stream nil) return-strings-p)
  (let* (;;(frames (km-int km-expr :fail-mode 'error))
         (frames (km km-expr))	; NEW: Might be called from within KM or as top-level call; need to account for both.
	 			; (OLD: when was km-int, won't catch any throws that occur and won't reset trace depth)
;        (frames (km-int km-expr))	 
         (frame (first frames))
         ;; FLE 04Aug2005
         (result nil))
    (cond ((and (singletonp frames)
		(neq km-expr frame)
		(kb-objectp km-expr)	; ie. _Car23
		(is-km-term frame))	; eg. _Car23, or "MyCar"
	   (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)
           (setf result
                 (showme-frame frame situations theories stream)))
	  (t (mapc #'(lambda (frame)
                       (push 
                        (showme-frame frame situations theories stream)
                        result)
		       (princ ";;; ----------" stream)
		       (terpri stream) 
		       (terpri stream))
		   frames)))
    (cond (return-strings-p result)
	  (t frames))))

(defun showme-frame (frame &optional (situations (all-situations)) (theories (all-theories))
                           ;; RVA 21Aug2006 fix km rep loop input output problem
                           ;; stream defaulting to nil (*standard-input*) instead of t (*terminal-io*)
                           (stream nil))
  (cond ((not (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!
(defun showme-all (km-expr &optional (situations (all-situations)))
  (let* ( (frames (km-int km-expr :fail-mode 'error))
	  (frame (first frames)) )
    (cond ((and (singletonp frames)
		(neq km-expr frame)
		(kb-objectp km-expr)	; ie. _Car23
		(is-km-term frame))	; eg. _Car23, or "MyCar"
	   (km-format t ";;; (~a is bound to ~a)~%~%" km-expr frame)))
    (cond ((singletonp frames) (showme-all-frame frame situations))
	  (t (mapc #'(lambda (frame) 
		       (showme-all-frame frame situations)
		       (princ ";;; ----------")
		       (terpri)
		       (terpri))
		   frames)))
    frames))

(defun showme-all-frame (instance &optional (situations (all-situations)))
  (cond ((not (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)
		     (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:
(defun showme-own-slots-in-situation (instance situation)
  (let* ( (own-slots-to-show1 (mapcar #'used-slot-in (get-slotsvals instance :facet 'own-properties :situation situation)))		; [1]
	  (own-slots-to-show2 (mapcar #'used-slot-in (get-slotsvals instance :facet 'own-definition :situation situation)))		; [1]
	  (inherited-slots-to-show (my-mapcan #'(lambda (class)
						  (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 (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)
	      (let* ( (inherited-rule-sets (inherited-rule-sets2 slot (all-classes instance) (list situation)))
		      (own-rule-sets (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 (remove-duplicates (append own-rule-sets inherited-rule-sets) :test #'equal :from-end t) instance)))
		      (joiner (cond ((single-valued-slotp slot) '&) 
				    (t '&&))) )
;		(cond ((singletonp all-rule-sets) (km-format t "~%  (~a ~a)" slot (first all-rule-sets)))
		(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))))
(defun showme-member-slots-in-situation (class situation)
  (let* ( (all-classes (cons class (all-superclasses class)))
	  (slots-to-show (remove-duplicates
			  (my-mapcan #'(lambda (class)
					 (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)
	      (let* ( (all-rule-sets (desource
				      (inherited-rule-sets2 slot all-classes (list situation))))	; find all rule sets in all classes in 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
(defun used-slot-in (slotvals)
  (cond ((not (null (vals-in slotvals))) (slot-in slotvals))))

(defun print-slot-exprs (slot all-rule-sets joiner &key (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 (+ 6 (length (symbol-name slot)))))
	   (km-format t "~a " joiner)))
  (cond ((single-valued-slotp slot)	; (km-format t "~a" (vals-to-&-expr (first all-rule-sets))))
	 (format t (expr2string (vals-to-&-expr (first all-rule-sets)))))
	(t ; (km-format t "~a" (first all-rule-sets))))
	 (format t (expr2string (first all-rule-sets))))) ; e.g. convert (UNQUOTE fred) to #,fred
  (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!
(defun evaluate-all (km-expr &optional (situations (all-situations)))
  (let* ( (frames (km-int km-expr :fail-mode 'error))
	  (frame (first frames)) )
    (cond ((and (singletonp frames)
		(neq km-expr frame)
		(kb-objectp km-expr)	; ie. _Car23
		(is-km-term frame))	; eg. _Car23, or "MyCar"
	   (km-format t ";;; (~a is bound to ~a)~%~%" km-expr frame)))
    (cond ((singletonp frames) (evaluate-all-frame frame situations))
	  (t (mapc #'(lambda (frame) 
		       (evaluate-all-frame frame situations)
		       (princ ";;; ----------")
		       (terpri)
		       (terpri))
		   frames)))
    frames))

(defun evaluate-all-frame (instance &optional (situations (all-situations)))
  (cond ((not (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)
		     (evaluate-all-frame-in-situation instance situation))
		 situations)
	   t)))

(defun evaluate-all-frame-in-situation (instance situation)
  (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)
	    (let ( (domain (or (km-unique-int `#$(the domain of ,SLOT)) '#$Thing)) )
	      (cond ((instance-of instance domain)
		     (let ( (vals (km-int `#$(the ,SLOT of ,INSTANCE))) )
		       (cond ((null vals) (km-format t "  (~a ())~%" slot))
			     (t (km-format t "  (~a ~a)~%" slot vals))))))))
	(sort (copy-list (all-instances '#$Slot)) #'string< :key #'symbol-name))		; copy list just to be safe, as sort is destructive
  (cond ((eq situation *global-situation*) (km-format t ")~%~%"))
	(t (km-format t "))~%~%"))))




;;; FILE: stats.lisp

;;; File: stats.lisp
;;; Author: Peter Clark
;;; Date: August 1994
;;; Purpose: Keep track and report various inference statistics

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

(defvar *reset-statistics-enabled* t)

(defun reset-statistics ()
  (cond (*reset-statistics-enabled*
          (setq *statistics-classification-inferences* 0)
          (setq *statistics-query-directed-inferences* 0)
          (setq *statistics-kb-access* 0)
          (setq *statistics-cpu-time* (get-internal-run-time))
          (setq *statistics-max-depth* 0)
          (setq *statistics-unifications* 0)
          (setq *statistics-skolems* 0)
          (setq *statistics-classifications-attempted* 0)
          (setq *statistics-classifications-succeeded* 0))))

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

(defun report-statistics ()
  (let ( (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))  ; itups = a system constant
       (cond ((not (= cpu-time 0))
	      (format nil " [~a lips, ~a kaps])"		; debugging only (history length ~a)"
		      (floor (/ (* internal-time-units-per-second  statistics-inferences) cpu-time))
		      (floor (/ (* internal-time-units-per-second  *statistics-kb-access*) cpu-time)))))
       (format nil ")~%"))))

(defun report-statistics-long ()
  (let ( (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))  ; itups = a system constant
       (cond ((not (= cpu-time 0))
	      (format nil " (~a inferences per second, ~a KB accesses per second).~%"		; debugging only (history length ~a)"
		      (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
;;; ======================================================================

(defparameter *inference-report-frequency* nil)
(defvar *spot-runtime* 0)

(defun increment-inference-statistics ()
  (cond (*am-classifying* (setq *statistics-classification-inferences* (1+ *statistics-classification-inferences*)))
	(t (setq *statistics-query-directed-inferences* (1+ *statistics-query-directed-inferences*))))
  (cond ((and *inference-report-frequency*
	      (numberp *inference-report-frequency*)
	      (> *inference-report-frequency* 0))
	 (let ( (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*))))
		   (setq *spot-runtime* (get-internal-run-time)))))))))

(defun inference-number () (+ *statistics-classification-inferences* *statistics-query-directed-inferences* 1))

;;; ======================================================================
;;;			PROFILING
;;; ======================================================================

(defvar *km-profile-start-cpu* (make-hash-table :test #'equal))
(defvar *km-profile-total-cpu* (make-hash-table :test #'equal))
(defvar *km-profile-total-entries* (make-hash-table :test #'equal))

(defun profile-call (kmexpr)
  (setf (gethash kmexpr *km-profile-start-cpu*) (get-internal-run-time)))

(defun profile-exit (kmexpr)
  (let* ((start-time (gethash kmexpr *km-profile-start-cpu*)))
    (cond ((not start-time) (report-error 'program-error
					  "Profiler: missing start-time when exiting call to ~a!~%" kmexpr))
	  (t (let ((cpu-time (- (get-internal-run-time) start-time))
		   (old-total-cpu-time (or (gethash kmexpr *km-profile-total-cpu*) 0))
		   (old-total-entries (or (gethash kmexpr *km-profile-total-entries*) 0)))
	       (setf (gethash kmexpr *km-profile-total-cpu*) (+ old-total-cpu-time cpu-time))
	       (setf (gethash kmexpr *km-profile-total-entries*) (1+ old-total-entries)))))))

(defun profile-reset ()
  (clrhash *km-profile-start-cpu*)
  (clrhash *km-profile-total-cpu*)
  (clrhash *km-profile-total-entries*))

(defun profile-report (&optional (n 100))
;  (km-format t "(hash-table-count *km-profile-start-cpu*) = ~a~%" (hash-table-count *km-profile-start-cpu*))
;  (km-format t "(hash-table-count *km-profile-total-cpu*) = ~a~%" (hash-table-count *km-profile-total-cpu*))
;  (km-format t "(hash-table-count *km-profile-total-entries*) = ~a~%" (hash-table-count *km-profile-total-entries*))
  (let ((exprs+cpus nil))
    (maphash #'(lambda (kmexpr cpu)
		 (push (list kmexpr cpu) exprs+cpus))
	     *km-profile-total-cpu*)
    (let ((exprs+cpus-srt (sort exprs+cpus #'> :key #'second)))
      (km-format t "CPU-TIME ~10t# CALLS~%")
      (mapc #'(lambda (expr+cpu)
		(let* ((expr (first expr+cpu))
		       (cpu (second expr+cpu))
		       (count (gethash expr *km-profile-total-entries*)))
		  (km-format t "~,2F ~10t~a ~20t~a~%"
			     (/ cpu internal-time-units-per-second) count expr)))
	    (first-n exprs+cpus-srt n))))
  t)

;;; 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.

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

(defun do-plan (event-instance)
  (let* ( (first-subevent (km-unique-int `#$(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)))))

(defun follow-event-chain (event)
    (make-comment "Executing event ~a...~%" event)
    (km-int `#$(do-and-next ,EVENT) :fail-mode 'error)
    (let ( (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)))))

(defun next-event (event)
  (let ( (next-events (km-int `#$(the next-event of ,EVENT)))
	 (next-event-test (km-unique-int `#$(the next-event-test of ,EVENT))) )
    (cond 
     ((and (not 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 (not 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))
     ((not next-event-test) (first next-events))
     (t 		; next-event-test necc. present
      (let* ( (test-result (km-unique-int `#$(evaluate ,NEXT-EVENT-TEST))) 
	      (actual-next-events
	       (mapcar #'arg2of (remove-if-not #'(lambda (next-event)
						   (equal (arg1of next-event) test-result))
					       next-events))) )
;	(km-format t "next-events = ~a~%" next-events)
;	(km-format t "actual-next-events = ~a~%" actual-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: 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)
;(defun flatten (list)
;  (cond ((null list) nil)
;	((atom list) (list list))
;	((aconsp list) (list (first list) (rest list)))	; won't handle '(a b . c)
;	(t (my-mapcan #'flatten list))))

;;; optimized version from Francis Leboutte
(defun flatten (l)
  (cond ((atomic-aconsp l)
         (list (car l) (cdr l)))
        (t (flatten-aux l))))

;;; avoid consing
(defun flatten-aux (l &optional (acc nil))
  (cond ((null l) acc)
        ((atom l) (cons l acc))
        ((atomic-aconsp l)                         
         (cons (car l)
               (cons (cdr l)
                     acc)))
        (t (flatten-aux (first l)
                        (flatten-aux (rest l) acc)))))
                        
;;; No :from-end keyword on (member ...), so create this!
;;; (last-member 'a '(a b a c a d)) -> (A D)
(defun last-member (item list &key (test #'eq))
  (cond ((endp list) nil)
	(t (let ((rest-list (member item list :test test)))
	     (or (last-member item (rest rest-list) :test test)
		 rest-list)))))

;;; see km function aconsp
;;; T if a cons and both elements of cons are atomic
;;; error if a cons and first element is a list
(defun atomic-aconsp (x)
  (cond ((aconsp x)
         ;; should remove this test?
         (when (listp (car x))
           (error "flatten: not a KM atomic cons: ~s"  x))
         t)
        (t nil)))                        

;;; ----------
;;; (aconsp '(a . b)) -> t
(defun aconsp (obj) (and (listp obj) (not (listp (rest obj)))))

;;; ======================================================================

(defun listify (atom)
   (cond ((listp atom) atom)
	 (t (list atom))))

;;; (append-list '((1 2) (3 4))) => (1 2 3 4)
(defun append-list (list) (apply #'append list))

(defun listify-if-there (x) (cond (x (list x))))

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

#|
;;; (my-split-if '(1 2 3 4) #'evenp) => ((2 4) (1 3))
;;; (mapcar #'append-list (transpose (mapcar #'(lambda (seq) (my-split-if seq #'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) ...)) #'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))
(defun partition (sequence function)
  (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)))
(defun assoc-equal (item alist)
  (cond ((endp alist) nil)
	((equal item (first (first alist))) (first alist))
	(t (assoc-equal item (rest alist)))))

(defun member-equal (item list)
  (cond ((endp list) nil)
	((equal item (first list)) list)
	(t (member-equal item (rest list)))))

;;; ======================================================================
;;;		MAPPING FUNCTIONS
;;; ======================================================================

;;; my-mapcan: non-destructive version of mapcan
;;; [1] (apply #'append ...) fails in some Lisp implementations if you exceed
;;; the maximum number of arguments allowed a Lisp function (here #'append)
#+allegro
(defun my-mapcan (function args)
  (apply #'append (mapcar function args)))

#-allegro
(defun my-mapcan (function args)
  (mapcan #'copy-list (mapcar function args)))

;; eg. (map-recursive #'string-upcase '("as" ("asd" ("df" "df") "ff")))
;;     ("AS" ("ASD" ("DF" "DF") "FF"))
(defun map-recursive (function tree)
  (cond ((null tree) nil)
	((not (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)))
(defun recursive-find (item tree)
  (cond ((eql item tree))
	((null tree) nil)
	((listp tree) 
	 (some #'(lambda (subtree) (recursive-find item subtree)) tree))))

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

#|
KM> (defun demo (x) (cond ((> x 0) (values x (* x x)))))
KM> (some #'demo '(-1 3 2))
3
KM> (multiple-value-some #'demo '(-1 3 2))
3
9
|#
;;; This just written for two-valued arguments
(defun multiple-value-some (fn arg-list)
  (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
;;; ======================================================================

(defvar *tell-stream* t)
(defvar *see-stream* t)
(defvar *append-stream* t)

(defun file-exists (file) (open file :direction :probe))

;;; Check you don't close the stream "t"
(defun close-stream (stream) (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.
(defun tell (file) 
  (cond ((null file) nil) 
	((eq file t) (format t "(Sending output to standard output)~%") t)
	(t (setq *tell-stream* (open file
			    :direction :output
			    :if-exists :supersede
			    :if-does-not-exist :create)))))

(defun told () (close-stream *tell-stream*) (setq *tell-stream* t))

(defun see (file) 
  (cond ((eq file t) t)		; read from standard input
	(t (setq *see-stream* (open file :direction :input)))))

(defun seen () (close-stream *see-stream*) (setq *see-stream* t))

(defun tell-append (file) 
  (cond ((null file) nil) 
	((eq file t) (format t "(Sending output to standard output)~%") t)
	(t (setq *append-stream* (open file
				    :direction :output
				    :if-exists :append
				    :if-does-not-exist :create)))))

(defun told-append () (close-stream *append-stream*) (setq *append-stream* t))

;;; Useful for finding mis-matching parentheses
(defun read-and-print (file)
  (let ( (stream (see file)) )
    (read-and-print2 stream)
    (close stream)))

(defun read-and-print2 (stream)
  (let ( (sexpr (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).
(defun my-parse-integer (string)
  (multiple-value-bind
   (integer n-chars)
   (parse-integer string :junk-allowed t)
   (cond ((= (length (princ-to-string integer)) n-chars) integer))))

;;; ======================================================================
;;;		BLOWFISH ENCRYPTION (Allegro utility only)
;;; ======================================================================

#+allegro
(defun encrypt-to-file (file string &key key)
  (write-file-array file (user::blowfish-encrypt string :key key) :element-type '(unsigned-byte 8)))

#+allegro
(defun decrypt-from-file (file &key key)
  (user::blowfish-decrypt (read-file-array file :element-type '(unsigned-byte 8)) :key key :string t))

;;; ======================================================================
;;;	Reading and writing arrays, strings, bytes, and chars to/from files
;;; ======================================================================

;;; byte-file -> array
(defun read-file-array (file &key element-type)
  (let ((data (read-file-bytes file :element-type element-type)))
    (make-array (length data) :element-type element-type :initial-contents data)))

;;; array -> byte-file
(defun write-file-array (file array &key element-type)
  (let ((stream (open file :element-type element-type :direction :output 
		      :if-does-not-exist :create :if-exists :supersede)))
    (loop for i from 0 to (1- (length array)) do 
	  (write-byte (aref array i) stream))
    (cond ((streamp stream) (close stream)))))

;;; read byte-file
(defun read-file-bytes (file &key element-type)
  (let ((stream (open file :element-type element-type :direction :input)))
    (prog1
	(loop for item = (read-byte stream nil 'eof-marker) until (eql item 'eof-marker) collect item)
      (cond ((streamp stream) (close stream))))))

;;; read txt file as a single gigantic string
(defun read-file-string (file) (implode (read-file-chars file)))

(defun read-file-chars (file)  
  (let ((stream (open file :direction :input)))
    (prog1
	(loop for item = (read-char stream nil 'eof-marker) until (eql item 'eof-marker) collect item)
      (cond ((streamp stream) (close stream))))))

;;; ----------------------------------------
;;; 	READ AN ENTIRE FILE INTO A LIST:
;;; ----------------------------------------
;;; Returns a list of strings
(defun read-file-lines (file) (read-file file))
(defun read-file-exprs (file) (read-file file 'sexpr))
(defun case-sensitive-read-file-exprs (file) (read-file file 'case-sensitive-sexpr))

(defun read-file (file &optional (type 'string)) 
  (cond 
   ((not (member type '(string sexpr case-sensitive-sexpr)))
    (format t "ERROR! Unrecognized unit-type ~s in read-file!~%" type))
   (t (let ((stream (see file)))
	(prog1
	    (loop for item = (case type
			       (string (read-line stream nil 'eof-marker))
			       (sexpr  (read      stream nil 'eof-marker))
			       (case-sensitive-sexpr (case-sensitive-read stream nil 'eof-marker))) ; defined in case.lisp
		until (eq item 'eof-marker) collect item)
	  (cond ((streamp stream) (close stream))))))))

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

(defun write-file (file lines)
  (let ( (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 #'(lambda (line)
		       (format stream "~a~%" line))
		   lines))
|#

(defun write-lines (structure &optional (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 apply-recursive (function structure)
  (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))))

;;; ======================================================================

(defun print-list (list) (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.
#-MCL
(defun neq (a b) (not (eq a b)))

;;; (nlist 3) --> (1 2 3)
(defun nlist (nmax &optional (n 1))
  (cond ((<= nmax 0) nil)
	((>= n nmax) (list n))
	(t (cons n (nlist nmax (1+ n))))))

;;; (duplicate 'hi 2) ==> (hi hi)
(defun duplicate (item length)
  (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).
(defun spaces (n)
  (make-sequence 'string n :initial-element #\ ))
;
; (defun tab (n &optional (stream t))
;    (cond ((<= n 0) t)
;          ( t (format stream " ") (tab (- n 1) stream))))

;;; ======================================================================

(defun transpose (list)
  (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)
(defun atranspose (list)
  (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).
(defun singletonp (list) (and (proper-listp list) (= (length list) 1)))
; (defun    pairp (list) (and (proper-listp list) (= (length list) 2))) ; ; See below for more efficient implementation
(defun    triplep (list) (and (proper-listp list) (= (length list) 3)))
(defun quadruplep (list) (and (proper-listp list) (= (length list) 4)))

;;; true for all lists except simple apairs '(a . b)
(defun proper-listp (list)
  (and (listp list) (listp (rest list))))

;;; (apairp '(a . b)) -> t
;;; NOTE: (apairp '(a . (b))) -> NIL, because (a . (b)) = (a b). Thus there's some undefinedness as
;;; to whether '(a . (b)) is an apair or not.
(defun apairp (list)
  (and (listp list) list (not (listp (rest list)))))

; -----Original Message-----
;  From: Francis Leboutte [mailto:f.leboutte@algo.be] 
; Sent: Thursday, June 26, 2008 8:41 AM
; Here is a version of the optimized pairp function that should work for any Lisp (I also get a bug with LispWorks 5.1):
; - the declaration is now correct.
; - the function works exactly like the original one.
;;; thing: should be anything but a dotted list 
;;; return T if thing is 2 elements proper list (defun pairp (thing)
(defun pairp (thing)
  (declare (optimize (speed 3) (safety 0)))
  (and (consp thing)     
       (let ((thing-cdr (cdr thing)))  
         (and (consp thing-cdr)
	 (null (cdr thing-cdr))))))

#|
#+SBCL 	; Also see below for more efficient implementation of pairp
(defun pairp (list)(and (listp list) (= (length list) 2))) ; <- buggy, generates error for dotted pairs
;;; More efficient implementation from Sunil
;;; Tim Menzies: Causes problems under SBCL, so retain simpler version also above
#-SBCL
(defun pairp (list)
  (declare (optimize (speed 3) (safety 0))
	   (type list list))
  (and (listp list)
       list
       (let ((list (cdr list)))
	 (declare (type list list))
	 (and (listp list)
	      list
	      (null (cdr list))))))
|#
;;; ======================================================================

;;; (a) -> a
(defun delistify (list)
   (cond ((singletonp list)(car list))
	 (t list)))

(defun last-el (list) (car (last list)))

(defun last-but-one-el (list) (car (last (butlast list))))

;;; ======================================================================

;;; (quotep ''hi) --> t
(defun quotep (expr)
  (cond ((and (listp expr) (= (length expr) 2) (eq (car expr) 'quote)))))

;;; ======================================================================

;;; Preserve order of list
;;; (The basic Lisp function is set-difference)
(defun ordered-set-difference (list set &key (test #'eq))
  (cond ((null set) list)
	((not (intersection list set :test test)) list)
	(t (remove-if #'(lambda (el) (member el set :test test)) list))))

;(defun ordered-set-difference (list set &key (test #'eq))
;  (remove-if #'(lambda (el) (member el set :test test)) list))

;;; Preserve order of first list
(defun ordered-intersection (list set &key (test #'eq))
  (remove-if-not #'(lambda (el) (member el set :test test)) list))

;;; Returns the first elememt of set1 which is in set2, or nil otherwise.
(defun intersects (set1 set2)
  (first (some #'(lambda (el) (member el set2)) set1)))

;;; (nreplace '(a b c d e) 2 'new)  -> (a b new d e)
(defun nreplace (list n new)
  (cond ((endp list) nil)
	((= n 0) (cons new (rest list)))
	(t (cons (first list) (nreplace (rest list) (1- n) new)))))

;;; ======================================================================
;;;		DICTIONARY FUNCTIONS
;;; ======================================================================

;;; Inefficient but non-destructive! Updated definition to preserve ordering as best possible
;;; KM> (gather-by-key '((a 1) (b 2) (a 3) (b 4))) -> ((a (1 3) (b (2 4))))
;;; KM> (gather-by-key '((a 1) (b 2) (a 3) (b 4) (c) (b))) -> ((a (1 3) (b (2 4))))
(defun gather-by-key (pairs &optional dict)
  (cond ((endp pairs) dict)
	(t (let* ((pair (first pairs))
		  (key (first pair))
		  (val (second pair))
		  (new-dict (cond (val (update-dict dict key val))
				  (t dict))))
	     (gather-by-key (rest pairs) new-dict)))))

;;; Modified from KM's library: (gather-by-key '((a) (b))) -> NIL, (gather-by-key-inc-nils '((a) (b))) -> ((A) (B))
(defun gather-by-key-inc-nils (pairs &optional dict)
  (cond ((endp pairs) dict)
	(t (let* ((pair (first pairs))
		  (key (first pair))
		  (val (second pair))
		  (new-dict (cond (val (update-dict dict key val))
				  ((assoc key dict :test #'equalp) dict)
				  (t `((,key) ,@dict)))))
	     (gather-by-key-inc-nils (rest pairs) new-dict)))))

(defun update-dict (dict key val)
  (cond ((endp dict) `((,key (,val))))
	((equalp (first (first dict)) key)
	 `((,key (,@(second (first dict)) ,val)) ,@(rest dict)))
	(t (cons (first dict) (update-dict (rest dict) key val)))))

;;; Inefficient but non-destructive!
;;; KM> (gather-by-akey '((a . 1) (b . 2) (a . 3) (b . 4)))
;;; ((b . (4 2)) (a . (3 1)))
(defun gather-by-akey (pairs &optional dict)
  (cond ((endp pairs) dict)
	(t (let* ((pair (first pairs))
		  (key (first pair))
		  (val (rest pair)))
	     (cond (val
		    (let ((vals (rest (assoc key dict :test #'equalp)))
			  (restdict (remove-if #'(lambda (pair) (equalp (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))))
(defun gathers-by-key (tuples &key dict (test #'equalp))
  (cond ((endp tuples) dict)
	(t (let* ((tuple (first tuples))
		  (key (first tuple))
		  (val (rest tuple))
		  (vals (first (rest (assoc key dict :test test))))
		  (restdict (remove-if #'(lambda (tuple) (equalp (first tuple) key)) dict)))
	     (cond (val (gathers-by-key (rest tuples)
					:dict (cons (list key (cons val vals)) restdict)
					:test test))
		   (t (gathers-by-key (rest tuples)
				      :dict (cons (list key vals) restdict)
				      :test test)))))))

;;; (ordered-gather-by-key '((a 1) (a 2) (a 2) (b 4) (b 5))) -> ((A (1 2 2)) (B (4 5)))
;;; (ordered-gather-by-key '((a 1) (a 2) (a 2) (b 4) (b 5)) :remove-duplicates t) -> ((A (1 2)) (B (4 5)))
;;; NOTE Assumes ordered keys. If unordered, behavior is:
;;; (ordered-gather-by-key '((a 1) (a 2) (a 2) (b 4) (b 5) (a 1))) -> ((A (1 2 2)) (B (4 5)) (A (1)))
(defun ordered-gather-by-key (pairs &key remove-duplicates)
  (cond ((endp pairs) nil)
	(t (let ( (pair (first pairs)) )
	     (cond ((equalp (first pair) (first (second pairs)))	  ; (a 1) (a 2) (a 3) (b 1) ...
		    (let* ((gathered-rest (ordered-gather-by-key (rest pairs) 	; ((a (2 3)) (b ...) ...)
								  :remove-duplicates remove-duplicates))
			   (next-gathered-pair (first gathered-rest)) ) ; (a (2 3))
		      (cond ((and remove-duplicates (member (second pair) (second next-gathered-pair) :test #'equalp))
			     gathered-rest)
			    (t (cons (list (first next-gathered-pair) ; a
					   (cons (second pair) (second next-gathered-pair))) ; (cons 1 (2 3))
				     (rest gathered-rest)))))) ; ((b ...) ...)
		   (t (cons (list (first pair) (rest pair))		; (a b) -> (a (b))
			    (ordered-gather-by-key (rest pairs) :remove-duplicates remove-duplicates))))))))

(defun ordered-count (list)
  (count-elements list))

#|
;;; Use count-elements for more efficient implementation
;;; Takes an *ordered* list of items, and counts occurences of each one.
;;; (ordered-count '("a" "a" "b" "c")) -> (("a" 2) ("b" 1) ("c" 1))
(defun ordered-count (list)
  (cond ((null list) nil)
	(t (ordered-count0 list :target (first list) :n 1))))

(defun ordered-count0 (list &key target n)
  (cond ((endp list) `((,target ,n)))
	((equal (first list) target)
	 (ordered-count0 (rest list) :target target :n (1+ n)))
	(t `((,target ,n) ,@(ordered-count0 (rest list) :target (first list) :n 1)))))
|#
; Old version: Horribly space-inefficient!
;(defun ordered-count (list &optional counts-so-far)
;  (cond ((endp list) (reverse counts-so-far))
;	((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)))))

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

(defun count-elements (list)
  (let ((hash-table (make-hash-table :test #'equal)))
    (mapc #'(lambda (entry)
	      (let ((old-entry (or (gethash entry hash-table) 0)))
		(setf (gethash entry hash-table) (1+ old-entry))))
	  list)
    (let ((results nil))
      (maphash #'(lambda (entry count)
		   (push (list entry count) results))
	       hash-table)
      results)))

#|
;;; Still horribly space inefficient
;;; (count-elements '(a b c b a)) -> ((C 1) (B 2) (A 2))
;;; [1] keep old counts in list to avoid updating the list, then remove out-of-date counts [2] later
(defun count-elements (list &optional counts)
  (cond ((endp list) (gather-counts counts))	 ; [2]
	(t (let* ((item (first list))
		  (count (or (second (assoc item counts :test #'equal)) 0)))
	     (count-elements (rest list) `((,item ,(1+ count)) ,@counts))))))	; [1]

;;; (GATHER-COUNTS ((A 2) (B 2) (C 1) (B 1) (A 1))) -> ((C 1) (B 2) (A 2))
(defun gather-counts (counts &optional done)
  (cond ((endp counts) done)
	((assoc (first (first counts)) done :test #'equal)
	 (gather-counts (rest counts) done))
	(t (gather-counts (rest counts) (cons (first counts) done)))))
|#

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

;;; merge att-val lists, padding with null-values if no entry
;;; (combine-attvals '((a 1) (b 3)) '((a 2) (c 4))) -> ((A 2 1) (B 0 3) (C 4 0))
;;; (combine-attvals '((a 4) (b 3) (e 3)) '((A 2 1) (B 0 3) (C 4 0))) -> ((A 2 1 4) (B 0 3 3) (E 0 0 3) (C 4 0 0))
(defun combine-attvals (list dict &key (n-entries (1- (length (first dict)))) (null-entry '0))
  (cond ((endp list)
	 (mapcar #'(lambda (dictentry) (append dictentry `(,null-entry))) dict))
	(t (let* ((entry (first list))
		  (key (first entry))
		  (val (second entry))
		  (dictentry (assoc key dict)))
	     (cond (dictentry `((,@dictentry ,val)
				,@(combine-attvals (rest list) 
						   (remove dictentry dict :test #'equal) 
						   :n-entries n-entries :null-entry null-entry)))
		   (t `((,key ,@(duplicate null-entry n-entries) ,val) 
			,@(combine-attvals (rest list) dict :n-entries n-entries :null-entry null-entry))))))))

;;; ----------
				  
(defun number-eq (n1 n2)
  (and (numberp n1) 
       (numberp n2) 
       (< (abs (- n1 n2)) 1e-24)))

;;; handle rounding errors
;;; NOTE: Now should use zerop, with a numberp check first!
(defun zero (n)
  (and (numberp n)
       (<= n  0.0000001)
       (>= n -0.0000001)))

(defun list-intersection (list)
  (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")
(defun rank-sort (list function) 
  (mapcar #'second (assoc-sort (transpose (list (mapcar function list) list)))))

(defun assoc-sort (list) (sort list #'pair-less-than))

(defun pair-less-than (pair1 pair2) (< (first pair1) (first pair2)))

(defun symbol-less-than (pair1 pair2) (string< (symbol-name pair1) (symbol-name pair2)))

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

(defvar *tmp-counter* 0)

(defun reset-trace-at-iteration () (setq *tmp-counter* 0))

(defun trace-at-iteration (n) 
  (setq *tmp-counter* (1+ *tmp-counter*))
  (cond ((= (mod *tmp-counter* n) 0) 
	 (format t "~a..." *tmp-counter*))))

(defun curr-iteration () *tmp-counter*)

;;; ======================================================================
;;;		       PROPERTY LISTS
;;; ======================================================================

;;; Remove *all* properties on the property list
(defun remprops (symbol)
  (mapc #'(lambda (indicator) 
	    (remprop symbol indicator)) 
	(odd-elements (symbol-plist symbol))))

;;; (odd-elements '(1 2 3 4 5)) -> (1 3 5)
(defun odd-elements (list)
  (cond ((endp list) nil)
	(t (cons (first list) (odd-elements (rest (rest list)))))))

;;; (even-elements '(1 2 3 4 5)) -> (2 4)
(defun even-elements (list) (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
(defun set-equal (set1 set2) (not (set-exclusive-or set1 set2 :test #'equal)))

(defun multiple-value-mapcar (function list)
  (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)))))))

(defun unquote (expr)
  (cond ((quotep expr) (second expr))
	(t (format t "Warning! Unquote received an already unquoted expression!~%") expr)))

(defun quotify (item) (list 'quote item))

(defun bag-equal (bag1 bag2)
  (and (= (length bag1) (length bag2))
       (bag-equal0 bag1 bag2)))

(defun bag-equal0 (bag1 bag2)
  (cond ((equal bag1 bag2))
	((member (first bag1) bag2 :test #'equal)
	 (bag-equal0 (rest bag1) (remove (first bag1) bag2 :test #'equal :count 1)))))

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

(defun update-assoc-list (assoc-list new-pair)
  (cond ((endp assoc-list) (list new-pair))
;	((string= (first (first assoc-list)) (first new-pair))
	((equal (first (first assoc-list)) (first new-pair))	; revised 12.16.99
	 (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)
(defun inv-assoc (key assoc-list &key (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. 
(defun remove-assoc-entry (key assoc-list)
  (remove-if #'(lambda (entry) (eql (first entry) key)) assoc-list))

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

;;; (insert-delimeter '(a b c) 'cat) -> (a cat b cat c)
(defun insert-delimeter (list delimeter)
  (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
(defun contains-some (expr symbols)
  (or (member expr symbols)
      (and (listp expr) 
	   (some #'(lambda (el) (contains-some el symbols)) expr))))

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

#|
xor clashes with CLISP
NOTE:: These have different side-effects to Lisp's or macro: Here ALL the arguments are evaluated THEN the results tested.
  - (nor (setq *w* t) (setq *z* t)) and (not (or (setq *w* t) (setq *z* t))) both return NIL, 
    BUT the nor will setq *z* t, while (not (or...)) will not.
|#
(defun x-or (a b) (and (or a b) (not (and a b))))
(defun nor (a b) (not (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
(defun subbagp (subbag bag &key (test #'eq))
  (cond 
   ((null subbag))
   ((member (first subbag) bag :test test)
    (subbagp (rest subbag) (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)
(defun remove-shared-elements (list1 list2 &key (test #'eq))
  (cond ((null list1) (values nil list2 nil))
	((member (first list1) list2 :test test)
	 (multiple-value-bind
	  (shorterlist1 shorterlist2 shared)
	  (remove-shared-elements (rest list1) (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) 1) -> (A C)
(defun remove-element-n (list n)
  (cond ((or (null list) (< n 0)) list)
	((= 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
(defun port-to-package (tree &key 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))
(defun permute (list-of-lists)
  (cond 
   ((endp list-of-lists) (list nil))
   (t (let ( (permutes (permute (rest list-of-lists))) )
	(mapcan #'(lambda (e)
		    (mapcar #'(lambda (permute)
				(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))
(defun all-pairs (list)
  (cond ((endp list) nil)
	(t (append
	    (mapcar #'(lambda (e)
			(list (first list) e))
		    (rest list))
	    (all-pairs (rest list))))))

;;; (all-adjacent-pairs '(a b c d e f)) -> ((a b) (b c) (c d) (d e) (e f))
(defun all-adjacent-pairs (list)
  (cond ((endp list) nil)
	((singletonp list) nil)
	(t `((,(first list) ,(second list)) ,@(all-adjacent-pairs (rest list))))))

;;; (first-n '(a b c) 2) -> (a b)
(defun first-n (list n) (cond ((> (length list) n) (subseq list 0 n)) (t list)))

;;; (is-subset-of '(a b) '(a b c)) -> t
(defun is-subset-of (list1 list2 &key (test #'eq)) 
  (not (set-difference list1 list2 :test test)))

;; (replace-element 2 '(a b c) 'x) -> (A X C)
(defun replace-element (n list el)
  (cond ((endp list) nil)
	((= n 1) (cons el (rest list)))
	(t (cons (first list) (replace-element (1- n) (rest list) el)))))

(defun numeric-char-p (char) (member char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :test #'char=))

;;; (permutations '(a b c)) -> ((A B C) (A C B) (B A C) (B C A) (C A B) (C B A))
;;; (permutations '(a b a)) -> ((B A) (A B))
(defun permutations (list)
  (permutations0 (remove-duplicates list :test #'equal)))
  
(defun permutations0 (list)
  (cond ((endp list) nil)
	((singletonp list) (list list))
	(t (mapcan #'(lambda (element)
		       (mapcar #'(lambda (permutation)
				   (cons element permutation))
			       (permutations0 (remove element list :test #'equal))))
		   list))))

;;; ======================================================================

;;; Utilities for handling binding alists
;;; Really these should be defconstants, but for some reason defconstant causes an error under 
;;; SBCL (Tim Menzies, March 2008), so replace with defvar.
(defvar *null-binding* '(t . t))	; note, not NIL, so we can distinguish no bindings from failure
(defvar *null-bindings* '((t . t)))

(defun combine-bindings (bindings1 bindings2)
   (or (remove *null-binding* (remove-duplicates (append bindings1 bindings2) :test #'equal :from-end t) :test #'equal)
       *null-bindings*))		; if bindings1 AND bindings2 are all *null-bindings*)

(defun add-binding (x y bindings) 
  (cond ((eql x y) bindings)
	((member `(,x . ,y) bindings :test #'equal) bindings)
	(t (combine-bindings bindings (list (bind x y))))))

(defun val-of (var bindings) (rest (assoc var bindings)))

(defun bind (x y) `(,x . ,y))

(defun var-boundp (var bindings) (assoc var bindings))

;;; (remove-singletons '(a b c b a b b)) -> (a b)
(defun remove-singletons (list) (remove-if #'(lambda (x) (uniquep x list)) (remove-duplicates list)))

(defun uniquep (x list) (not (member x (remove x list :count 1))))

; (areverse '(a . b)) -> (b . a)
(defun areverse (a-dot-b) `(,(rest a-dot-b) . ,(first a-dot-b)))

;;; (counts-to 3) -> (1 2 3)
;;; Note: keyword is :start-at, not :start, as symbol start conflicts with net.aserve :-(
(defun counts-to (nmax &key (start-at 1)) (counts-to0 start-at nmax))
(defun counts-to0 (n nmax)
  (cond ((> n nmax) nil)
	(t (cons n (counts-to0 (1+ n) nmax)))))

;;; (break-list <list> :test <test>) 
;;; Break <list> into sublists, breaking at (and removing) each element that passes <test>
;;; RETURNS: A list of sublists. 
;;; NOTE: If the first element passes <test>, then the first sublist will be NIL
;;; (break-list '("http" "a" "b" "http" "c" "d") 
;;;			:test #'(lambda (line) (starts-with (trim-whitespace line) "http"))))))
;;;  -> '(nil ("a" "b") ("c" "d"))
(defun break-list (list &key test)
  (let ((element (first list)))
    (cond ((endp list) nil)
	  ((apply test (list element)) 
	   (cons nil (break-list (rest list) :test test)))	; nil becomes the terminator of the prev para
	  (t (let ((sublists (break-list (rest list) :test test)))
	       `((,element ,@(first sublists)) ,@(rest sublists)))))))

;;; 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

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

;;; frame can be *any* valid KM term, including strings, numbers, sets, sequences, functions, and normal frames.
;;; RETURNS: A string containing the printed form of the frame.
(defun write-frame (frame &key (situations (all-situations)) (theories (all-theories)) htmlify nulls-okayp
			       essentials partially-cloned-from slots-to-show save-prototypep)
  (cond 
   ((and (kb-objectp frame) (bound frame)) (km-format nil ";;; (~a is bound to ~a)~%~%" frame (dereference frame)))
   (t (let ( (frame-string (write-frame0 frame situations theories htmlify essentials 
					 partially-cloned-from slots-to-show save-prototypep)) )
	(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 slots-to-show)
		    (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))
	      ((and (null slots-to-show)
		    (null (all-theories)))
	       (km-format nil ";;; (Concept ~a is not declared in the situations ~a)~%~%" frame situations))
	      ((null slots-to-show)
	       (km-format nil ";;; (Concept ~a is not declared in the situations ~a nor the theories ~a)~%~%" frame situations theories))
	      (t ""))))))

(defun write-frame0 (frame &optional (situations (all-situations)) 
		     (theories (all-theories)) htmlify essentials partially-cloned-from slots-to-show save-prototypep)
  (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)		; do *Global first
		       (write-frame-in-situation frame *global-situation* :htmlify htmlify :essentials essentials
						 :partially-cloned-from partially-cloned-from :slots-to-show slots-to-show
						 :save-prototypep save-prototypep))
		      (t ""))
		(append 
		 (let ( (prototypes (get-vals frame '#$prototypes :situation *global-situation*)) )
		   (cond ((and prototypes (null slots-to-show))
			  (append (list (km-format nil "#|"))
				  (mapcan #'(lambda (prototype)
					      (cons (km-format nil "~%;;; Prototype ~a defined by:~%" prototype)
						    (mapcar #'(lambda (expr)
;								(km-format nil "~a~%" 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 :essentials essentials
						       :partially-cloned-from partially-cloned-from 
						       :slots-to-show slots-to-show :save-prototypep save-prototypep))
			 theories)
		 (append
		  (flatten (write-situation-specific-assertions frame :htmlify htmlify))
		  (mapcar #'(lambda (situation) 
			      (write-frame-in-situation frame situation :htmlify htmlify :essentials essentials
							:partially-cloned-from partially-cloned-from 
							:slots-to-show slots-to-show :save-prototypep save-prototypep))
			  (remove *global-situation* situations)))))))
	(t (report-error 'user-error "~a is not a KB object!~%" frame))))

(defun write-situation-specific-assertions (situation-class &key htmlify)
  (cond 
   ((is-subclass-of situation-class '#$Situation)
    (let ( (assertions (second (assoc '#$assertions 
				      (desource-for-printing (get-slotsvals situation-class :facet 'member-properties :situation *global-situation*))))) )
      (cond (assertions
	     (mapcar #'(lambda (assertion)
			 (cond ((not (quotep assertion))
				(report-error 'user-error "Unquoted assertion ~a in situation-class ~a! Ignoring it...~%" 
					      assertion situation-class) "")
			       (t (let ( (modified-assertion (sublis '#$((SubSelf . Self) (#,Self . TheSituation)) (second assertion) 
								     :test #'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 ""
(defun write-frame-in-situation (frame situation 
				 &key htmlify theoryp essentials partially-cloned-from slots-to-show save-prototypep)
  (let ( (own-props (desource-for-printing (get-slotsvals frame :facet 'own-properties    :situation situation)))
	 (mbr-props (desource-for-printing (get-slotsvals frame :facet 'member-properties :situation situation)))
	 (own-defn  (desource-for-printing (get-slotsvals frame :facet 'own-definition    :situation situation)))
	 (mbr-defn  (desource-for-printing (get-slotsvals frame :facet 'member-definition :situation situation))) )
    (concat
     (cond (own-defn  
	    (concat-list 
	     (flatten 
	      (write-frame2 frame situation own-defn  nil '#$has-definition :htmlify htmlify :theoryp theoryp 
			    :essentials essentials :partially-cloned-from partially-cloned-from 
			    :slots-to-show slots-to-show :save-prototypep save-prototypep)))))
     (cond ((and own-props 
		 (not (and (singletonp own-props) (eq (first (first own-props)) '#$assertions)))) ; filter out these!
	    (concat-list (flatten (write-frame2 frame situation own-props nil '#$has :htmlify htmlify :theoryp theoryp 
						:essentials essentials :partially-cloned-from partially-cloned-from 
						:slots-to-show slots-to-show :save-prototypep save-prototypep)))))
     (cond (mbr-defn  (concat-list (flatten (write-frame2 frame situation mbr-defn  '#$every '#$has-definition 
					  :htmlify htmlify :theoryp theoryp :essentials essentials 
					  :partially-cloned-from partially-cloned-from 
					  :slots-to-show slots-to-show :save-prototypep save-prototypep)))))
     (cond ((and mbr-props 
		 (not (and (singletonp mbr-props) (eq (first (first mbr-props)) '#$assertions)))) ; filter out these!
	    (concat-list (flatten (write-frame2 frame situation mbr-props '#$every '#$has :htmlify htmlify 
					:theoryp theoryp :essentials essentials 
					:partially-cloned-from partially-cloned-from 
					:slots-to-show slots-to-show :save-prototypep save-prototypep))))))))

;;; theoryp = 'ignore suppresses the (in-theory ... ) wrapper, but we ignore that for now
(defun write-frame2 (frame situation slotsvals0 quantifier joiner 
		     &key htmlify theoryp essentials partially-cloned-from slots-to-show save-prototypep (tab 0))
  (let ( (slotsvals (dereference slotsvals0))
	 (tab2 (cond ((eq situation *global-situation*) tab)
		    (t (+ 2 tab)))) )
    (cond
     ((or (null slots-to-show)
	  (intersection slots-to-show (mapcar #'slot-in slotsvals)))
      (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 (= tab2 0)) (format nil "~vT" tab2)))    ; (format nil "~vT" 0) prints one space (Lisp bug?)
	  (cond (quantifier (km-format nil "(~a " quantifier))  	; "(every "
		(t "("))
	  (objwrite frame htmlify)
	  (km-format nil " ~a " joiner)				; "has" or "has-definition"
	  (write-slotsvals slotsvals (+ tab2 2) htmlify essentials partially-cloned-from slots-to-show save-prototypep)
	  ")"
	  (cond ((and (neq situation *global-situation*)
		      (neq theoryp 'ignore)) ")"))
	  (format nil "~%~%")))
     (t ""))))

(defun write-slotsvals (slotsvals &optional (tab 2) htmlify essentials partially-cloned-from slots-to-show save-prototypep)
  (mapcar #'(lambda (slotvals)
	      (cond ((or (null slots-to-show)
			 (member (slot-in slotvals) slots-to-show))
		     (write-slotvals slotvals tab htmlify essentials partially-cloned-from save-prototypep))))
	  slotsvals))

;;; essentials is the special flag from AURA to only PARTIALLY save the prototypes (just the essential elements)
(defun write-slotvals (slotvals &optional (tab 2) htmlify essentials partially-cloned-from save-prototypep)
  (cond ((null slotvals) (format nil " ()"))
	((eq (slot-in slotvals) '#$assertions) "")
	((and save-prototypep ; DROP cloned instances for modularity. Will be reinstalled as inverses when clones reloaded.
;	      (member (slot-in slotvals) '#$(has-clones has-built-clones))
	      (member (slot-in slotvals) *prototype-slots-not-to-save-to-file*))
	 "")
	(essentials
	 (let* ((slot (slot-in slotvals))
		(vals (vals-in slotvals))
		(skolem-vals (remove-if-not #'anonymous-instancep (flatten vals)))
		(vals2 ; vals2 are the values to *ACTUALLY* write out
		       (cond ((eq slot '#$clone-built-from) ; DROP clone-built-from flags for prototypes whose clones
			      (ordered-set-difference vals partially-cloned-from)) ; are only being partially saved
			     ((eq slot '#$prototype-participants)
			      (cond ((set-difference essentials vals)
				     (report-error 
              "ERROR! saving prototype: some essential instances are not prototype-participants of the prototype!~%   ~a~%"
	       (set-difference essentials vals)))
;				    (t essentials)	; (NB essentials is a subset of vals)
				    (t (ordered-intersection vals essentials))   ; preserve ordering in vals, for safety
				    ))
;			     ((member slot (cons '#$cloned-from *unclonable-slots*)) vals) ; write ALL these out
			     ((member slot *slots-with-nonparticipant-skolems*) vals) ; write ALL these out
			     ((not (set-difference skolem-vals essentials)) ; all vals are essential or constants, so write them all out!
			      vals)
			     ; [1] If val-skolems includes a non-essential, then drop it
			     (t (remove nil
				 (mapcar #'(lambda (val)
					    (let* ((*trace-prototype-assertions* nil) ; ok to update prototypes
						   (val-skolems (remove-if-not #'anonymous-instancep (flatten val))))
					      (cond ((null (set-difference val-skolems essentials)) ; [1]
						     val))))
					vals)))
			     )))
;	   (format t "slot = ~a, vals2 = ~a~%" slot vals2) (pause)
	   (cond (vals2 (write-slotvals (make-slotvals (slot-in slotvals) vals2))))))
	(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)))
		 ")"))))


(defun write-vals (vals &optional (tab 2) htmlify)
  (cond ((null vals) "()")
	(t (list "("
		 (objwrite (first vals) htmlify)
		 (mapcar #'(lambda (val)
			     (list (format nil "~%~vT" tab) (objwrite val htmlify)))
			 (rest vals))
		 ")"))))

(defun write-kmexpr (kmexpr _tab htmlify) (declare (ignore _tab)) (objwrite kmexpr htmlify))

;;; (expr2string '#$(the '(age of #,person))) -> "(the '(age of #,person))"
(defun expr2string (expr &optional htmlify) (concat-list (remove nil (flatten (objwrite expr htmlify)))))

;;; convert to strings to remove package info:
;;; [1c] USER(143): (first '`(the ,car))
;;; excl::backquote
(defun objwrite (expr &optional htmlify)
  (cond ((atom expr) (objwrite2 expr htmlify))
	((and (pairp expr) 
	      (symbolp (first expr))
	      (assoc (first expr) *special-symbol-alist*))
	 (let ( (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
(defparameter *html-action* '"frame")
; (defparameter *html-window* '"target=right")
(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|".
(defun objwrite2 (expr htmlify &key (action *html-action*) (window *html-window*))
  (cond ((and htmlify (kb-objectp expr) (known-frame expr)) 		; with KM only, htmlify is always nil 
	 (htextify expr (km-format nil "~a" expr) :action action :window window)) ; [1]
	((eq expr nil) "()")
	(t (km-format nil "~a" expr))))

;;; ======================================================================
;;		SHOW DEFINITIONS IN THE KB
;;; ======================================================================

(defun list-definitions (&optional (top-class '#$Thing))
 (let ((*print-right-margin* 9999))
  (mapc #'(lambda (depth+string)
	    (format t (second depth+string)))
	(sort (mapcan #'(lambda (class) (list-defined-subclasses class)) (cons top-class (all-subclasses top-class))) #'< :key #'first))
  t))

(defun list-defined-subclasses (class)
  (let ((defined-subclasses (get class 'defined-subclasses))
	(defined-prototypes (get class 'defined-prototypes)))
    (append 
     (mapcan #'(lambda (subclass) (list-definitions-for-class subclass class)) defined-subclasses)
     (mapcan #'(lambda (prototype) (list-definitions-for-prototype prototype class)) defined-prototypes)
    )))

(defun list-definitions-for-class (class superclass)
  (let ((depth (depth-to-thing superclass))
	(slotsvals (get-slotsvals class :facet 'member-definition :situation *global-situation*)))
    (cond (slotsvals
	   (list (list depth (concat (km-format nil "~2d ~a -> ~a [class] IF:~%" depth superclass class)
				     (concat-list (flatten (write-frame2 superclass *global-situation* (desource slotsvals) '#$a '#$has :tab 8))))))))))

;;; [1] (get Plant-cell 'defined-prototypes) -> (|_Plant-Cell-Inside-Hypotonic-Solution22322| |_Plant-cell5965|)
;;;	Note it includes Plant-cell itself, as Plant-cell has a definition on it (the-class Eukaryotic-cell with ...)
;;;     Given a new Plant-cell instance, (classify ...) automatically ignores these as the Plant-cell instance is already necessarily 
;;;		an instance of a Plant-cell. However, we don't want to list it here.
(defun list-definitions-for-prototype (prototype superclass)
  (let ((depth (depth-to-thing superclass))
	(prototype-scopes (get-vals prototype '#$prototype-scope :situation *global-situation*)))
    (remove nil
     (mapcar #'(lambda (prototype-scope)
		 (let* ((class (get-unique-val prototype '#$prototype-of))
			(superclass2+slotsvals (class-descriptionp prototype-scope))
			(superclass2 (first superclass2+slotsvals))
			(slotsvals (second superclass2+slotsvals)))
;			(classes (classes-in-description prototype-scope)))
		   (cond ((and slotsvals 
			       (eq superclass superclass2))
			  (list depth
				(concat
				 (km-format nil "~2d ~a -> ~a [prototype] IF:~%" depth superclass2 class)
				 (concat-list (flatten (write-frame2 superclass2 *global-situation* slotsvals '#$a '#$has :tab 8)))))
			  ))))
	     prototype-scopes))))

;; (depth-to-thing '#$Cell) -> 6  as Cell -> Living-Entity -> Physical-Object -> Tangible-Entity -> Spatial-Entity -> Entity -> Thing
(defun depth-to-thing (class) (depth-to-thing1 (list class) 0))

(defun depth-to-thing1 (classes depth-so-far)
  (cond 
   ((member '#$Thing classes) depth-so-far)
   (t (depth-to-thing1 (my-mapcan #'immediate-superclasses classes) (1+ depth-so-far)))))


;;; FILE: taxonomy.lisp

;;; File: taxonomy.lisp
;;; Author: Peter Clark
;;; Date: April 96
;;; Purpose: Print out the frame hierarchy
;;; Warning: Frighteningly inefficient.

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

(defconstant *indent-increment* 3)
(defconstant *prune-points* nil)
(defconstant *ignore-items* nil)
(defconstant *maxdepth* 9999)

(defun taxonomy (&optional (current-node '#$Thing) (relation-to-descend '#$subclasses) htmlify)
  (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)
(defun make-tax (&optional (current-node '#$Thing) (relation-to-descend '#$subclasses) htmlify)
  (cond ((eq relation-to-descend '#$subclasses) 
	 (clean-taxonomy)))
  (cond ((and (eq current-node '#$Thing)
	      (eq relation-to-descend '#$subclasses))
	 (let* ( (all-objects (dereference (get-all-concepts)))
		 (top-classes (immediate-subclasses '#$Thing)) )
	   (multiple-value-bind
	    (strings all-nodes-done)
	    (make-taxes (sort (remove '#$Thing top-classes) #'string< :key #'symbol-name) 
			relation-to-descend htmlify nil *indent-increment*)
	    (let ( (unplaceds (remove-if-not #'named-instancep 
					     (set-difference all-objects (cons '#$Thing all-nodes-done)))) )
	      (append (cons "Thing" strings)
		      (mapcar #'(lambda (unplaced)
				  (tax-obj-write unplaced *indent-increment* htmlify :instancep '?))
			      (sort unplaceds #'string< :key #'symbol-name)))))))
	(t (make-tax0 current-node relation-to-descend htmlify))))

(defun make-tax0 (current-node relation-to-descend &optional htmlify nodes-done (tab 0))
  (let ( (item-text (tax-obj-write current-node tab htmlify)) )
    (cond ((member current-node *ignore-items*)
	   (values (list item-text
			 (format nil "~vTignoring children..." 
				 (+ tab *indent-increment*)))
		   nodes-done))
	  (t (let* ( (all-instances  (km-int `#$(the instances of ,CURRENT-NODE)))
		     (named-instances (remove-if-not #'named-instancep all-instances))
		     (instances-text (mapcar #'(lambda (instance)
						 (tax-obj-write instance (+ tab *indent-increment*) htmlify :instancep t)) 
					     (sort named-instances #'string< :key #'symbol-name)))
		     (specs (sort (km-int `#$(the ,RELATION-TO-DESCEND #$of ,CURRENT-NODE))
				  #'string<
				  :key #'symbol-name)) )			; alphabetical order
	       (cond ((and specs (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)))))))))

(defun make-taxes (current-nodes relation-to-descend &optional htmlify nodes-done (tab 0))
  (cond ((not (listp current-nodes)) (values nil nodes-done))	; in case of a syntax error in the KB
	((endp current-nodes) (values nil nodes-done))
	((> (/ tab *indent-increment*) *maxdepth*)
	 (values (list (format nil "~vT...more..." 
			       (+ tab *indent-increment*)))
		 nodes-done))
	((not (atom (first current-nodes)))   			; in case of a syntax error in the KB
	 (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))		; don't show anonymous instances
		  (not (kb-objectp (first current-nodes)))))		; or numbers or strings
	 (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))))))
     
(defun tax-obj-write (concept tab htmlify &key instancep)
  (concat 
   (cond ((= tab 0) "")
	 ((eq instancep '?) (format nil "?~a" (spaces (1- tab))))  ; Unfortunately, (format nil "~vT" 0) = " " not ""
	 ((eq instancep t) (format nil "I~a" (spaces (1- tab))))  ; Unfortunately, (format nil "~vT" 0) = " " not ""
	 (t (format nil "~vT" tab)))  ; Unfortunately, (format nil "~vT" 0) = " " not ""
   (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.

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

#|
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-on-object-stack '(a Car with (color (Red)))) -> list of instances
(defun find-subsumees-on-object-stack (existential-expr)
  (let ((candidates (find-candidates existential-expr)))
    (remove-if-not #'(lambda (candidate-instance) 
		       (is0 candidate-instance existential-expr))
		   candidates)))

;;; > (find-subsumees+bindings '(a Car with (color (Red)))) -> list of instances + bindings
(defun find-subsumees+bindings (existential-expr candidates &key bindings)
  (remove nil 
	  (mapcar #'(lambda (candidate-instance) 
		      (let ((new-bindings (is0 candidate-instance existential-expr :bindings bindings)))
			(cond (new-bindings (list candidate-instance new-bindings)))))
		  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:
|#
(defun find-candidates (existential-expr)
  (let* 
    ( (class+slotsvals (breakup-existential-expr existential-expr :fail-mode 'error))  ; [1]
      (class (first class+slotsvals))
      (slotsvals (second class+slotsvals)) )
    (mapc #'(lambda (slotvals)         	      	  ; this will force some evaluation
	      (find-candidates2 class slotvals))  ; of relevant frames
	  slotsvals)
;;; (all-instances class)))
;;; NEW: Only instances on obj-stack are possible candidates, so obj-stack defines the context
    (remove-if-not #'(lambda (instance) (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
(defun find-candidates2 (class slotvals)
  (let* ( (slot (first slotvals))
 	  (invslot (invert-slot slot))
	  (vexprs (second slotvals)) )
     (mapc #'(lambda (vexpr)
	       (cond ((existential-exprp vexpr)
		      (mapc #'(lambda (val) 
				(cond ((kb-objectp val)
				       (km-int `(#$the ,class ,invslot #$of ,val)))))	 ; [1]
			    (find-subsumees-on-object-stack vexpr)))
		     (t (let ( (kb-vals (remove-if-not #'kb-objectp (km-int vexpr))) )	; [1]
			  (cond (kb-vals (km-int `(#$the ,class ,invslot #$of ,(vals-to-val kb-vals)))))))))  ; [2]
	   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).
|#

(defun subsumes (xs ys)
  (let ( (x-desc (vals-to-class-description xs))
	 (y-desc (vals-to-class-description ys)) )
    (cond ((and x-desc y-desc) 				        ; ('(every X) subsumes '(every Y)) == ('(a Y) is '(a X))
	   (is (every-to-a y-desc) (every-to-a x-desc)))
	  (x-desc 						; ('(every X) subsumes {I1,..,In}) == (allof {I1,..,In} 
	   (km-int `#$(allof ,(VALS-TO-VAL YS) must (,X-DESC covers It))))    ;           must ('(every X) covers It))
	  (y-desc						; ({I1,..,In} subsumes '(every Y)) == ERROR
	   (report-error 'user-error "Doing (~a subsumes ~a)~%Can't test if a set subsumes an expression!~%" xs ys))
	  (t 							; ({I1,..,In} subsumes {J1,..,Jn}) == ({I1,..,In} is-superset-of {J1,..,Jn})
	   (km-int `#$(,(VALS-TO-VAL XS) is-superset-of ,(VALS-TO-VAL YS)))))))

(defun covers (xs y)
  (let ( (x-desc (vals-to-class-description xs))
	 (y-desc (cond ((and (quoted-expressionp y) (listp (unquote y)) (instance-descriptionp y :fail-mode 'error)) y))) )		; instance-descriptionp will report error if necc.
    (cond ((and x-desc y-desc)					; ('(every X) covers '(a Y))    ==    ('(a Y) is '(a X))
	   (km-int `#$(,Y-DESC is ,(EVERY-TO-A X-DESC))))
	  (x-desc						; ('(every X) covers    I  )    ==    (I is '(a X))
	   (km-int `#$(,Y is ,(EVERY-TO-A X-DESC))))
	  (y-desc						; ({I1,..,In} covers '(a Y))    ==    (has-value (oneof {I1,..,In} 
	   (km-int `#$(has-value (oneof ,(VALS-TO-VAL XS) where (It is ,Y-DESC)))))   ;  where (It is '(a Y)))
	  (t 			       				; ({I1,..,In} covers    I  )    ==    ({I1,..,In} includes I)
	   (km-int `#$(,(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??
(defun is (x y)
  (cond 
   ((equal y ''#$(a Class))				; SPECIAL CASE - for metaclasses:  '(every Dog) is '(a Class)
    (cond ((or (class-descriptionp x) (symbolp x)))	; succeed
	  (t (report-error 'user-error "Doing (~a is ~a)~%~a doesn't appear to be a class or class description.~%" x y x))))
   (t (let ( (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)					; ('(a X) is '(a Y))	 ==     gensym a XI, (XI is '(a Y)), delete XI
	       (description-subsumes-description x-desc y-desc))
	      (x-desc						; ('(a X) is   I   )	 ==     ERROR
	       (report-error 'user-error "Doing (~a is ~a)~%Can't test if an expression is `subsumed' by an instance!~%" x y))
	      (y-desc						; (  I    is '(a Y))	 == 	*****BASE IMPLEMENTATION*****
	       (is0 x (unquote y-desc)))
	      (t (km-int `#$(,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!
|#

(defparameter *remove-temporary-via-backtracking* t)

(defun description-subsumes-description (x-desc y-desc)
  (cond 
   (*remove-temporary-via-backtracking*
    (let ( (old-internal-logging *internal-logging*)
	   (checkpoint-id (gensym)) )
      (setq *internal-logging* t)
      (set-checkpoint checkpoint-id)
      (prog1
	  (let ( (tmp-i (km-unique-int (unquote x-desc) :fail-mode 'error)) )
	    (km-int `#$(,TMP-I is ,Y-DESC)))
	(undo checkpoint-id)		; undo, whatever
	(setq *internal-logging* old-internal-logging))))	; [1]
   (t (let ( (tmp-i (km-unique-int (unquote x-desc) :fail-mode 'error)) )
	(prog1
	    (km-int `#$(,TMP-I is ,Y-DESC)) ; [1a]
	  (delete-frame tmp-i))))))			; VERY inefficient with a large KB

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

; [1] Causes problems with metaclasses!	   
(defun vals-to-class-description (classes)
  (cond ((and (singletonp classes)
	      (kb-objectp (first classes)))
; [1]	      (not (is-an-instance (first classes))))
	 `'(#$every ,(first classes)))					; (Dog) -> '(every Dog)
	((and (singletonp classes)
	      (descriptionp (first classes)))
	 (cond ((class-descriptionp (first classes))
		(let* ( (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))))
(defun every-to-a (expr) 
  (let* ( (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
;;; ======================================================================

#|
NEW: RETURNS: binding list 
[1] bind-self done for queries like:
CL-USER> (is0 '#$_rectangle0
	      '#$(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
|#
(defun is0 (instance expr &key (bindings *null-bindings*))
  (cond ((and (km-structured-list-valp instance)
	      (km-structured-list-valp expr)
	      (= (length (desource instance)) (length (desource expr)))
	      (eql (first instance) (first expr)))
	 (let ( (d-instance (desource instance))
		(d-expr (desource expr)) )
	   (cond ((km-triplep d-instance)
		  (let* ((bindings2 (is0  (second d-instance) (second d-expr) :bindings bindings))
			 (bindings3 (cond 
				     (bindings2 
				      (is0 (third d-instance) (third d-expr) :bindings bindings2))))
			 (bindings4 (cond
				     (bindings3
				      (some #'(lambda (val) ; See [3] above
						(is0 val (fourth d-expr) :bindings bindings3))
					    (val-to-vals (fourth d-instance)))))))
		    bindings4))
		 (t (is0s (rest (transpose (list d-instance d-expr)))  ; ((:seq :seq) (i1 e1) (i2 e2) ... )
			  :bindings bindings)))))

; Below [1], bind-self *may* appear redundant. However, expr
; *may* contain Self, if it came from a top-level query eg.
; 	KM> ((a Person with (owns (Self))) is (a Person with (owns (Self))))
;     (cond 
;      ((not (contains-self-keyword expr))
;	(km-format t "ERROR! Don't know how what `Self' refers to in the expression~%")
;	(km-format t "ERROR! ~a~%" expr))

	 (t (let ( (class+slotsvals (bind-self (breakup-existential-expr expr) instance)) )   ; [1]
	      (cond (class+slotsvals				;;; 1. An INDEFINITE expression
		     (let ((class (first class+slotsvals))		;;;    (so do subsumption)
			   (slotsvals (second class+slotsvals)) )
		       (and (isa instance class)
			    (are-slotsvals slotsvals) ; syntax check
			    (slotsvals-subsume slotsvals instance :bindings bindings))))
		    ((constraint-exprp expr)
		     (cond ((satisfies-constraints (list instance) (list expr) nil) ; nil = dummy slot name. This only 
			    bindings)))                      ; occurs for things like (is0 (:seq 1 2) (:seq (<> 1) 2))
;;;		    (t (let ( (definite-val (km-unique-int expr :fail-mode 'error)) )  ;;; 2. a DEFINITE expression
;;; Why 'error above?? 
		    (t (let ( (definite-val (km-unique-int expr)) )  ;;; 2. a DEFINITE expression
			 (cond ((null definite-val) nil)	; [2]		    ;;;    (so do equality)
			       ((equal definite-val instance) bindings)))))))))

;;; Perhaps rather slow?
;;; Returns 't' in the keyword 'Self' occurs in expr, nil otherwise.
(defun contains-self-keyword (expr)
  (cond ((null expr) nil)
	((eq expr '#$Self))
	((and (listp expr) 
	      (not (sourcep expr)))		; NEW: May contain Self, but that's ok
	 (some #'contains-self-keyword expr))))

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

(defun is0s (pairs &key (bindings *null-bindings*))
  (cond ((null pairs) bindings)
	(t (let* ((pair (first pairs))
		  (bindings2 (is0 (first pair) (second pair) :bindings bindings)))
	     (cond (bindings2 (is0s (rest pairs) :bindings bindings2)))))))

(defun slotsvals-subsume (slotsvals instance &key (bindings *null-bindings*)) 		    
  (cond ((endp slotsvals) bindings)
	(t (let* ((slotvals (first slotsvals))
		  (bindings2 (slotvals-subsume slotvals instance :bindings bindings)))
	     (cond (bindings2 (slotsvals-subsume (rest slotsvals) instance :bindings bindings2)))))))

#|
(slotvals-subsume <subsumer> <subsumee>
[1] is a quick, common lookahead, for calls like:
	(slotvals-subsume '#$(connects ((the Engine parts of _Car23))) '#$_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. 
    3/17/09: CHANGED to simple removal of constraints: remove-constraints is valid only for fully evaluated
	expressions (see that function), but here we do NOT have fully evaluated expressions.	
	Specifically: (remove-constraints '#$((?x == (a Point)))) -> (?x (a Point)), has length 2, so 
           will thus (undesirably) fail to match (_Point23). Note that the error here is in the use of
	   remove-constraints with this expression, as it is NOT fully evaluated.
	
[4a] Do a find-vals rather than a (km-int ...) 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.
|#
(defun slotvals-subsume (slotvals instance &key (bindings *null-bindings*))
  (let* ( (slot (first slotvals)) 
          (ser-exprs (second slotvals)) )
    (cond 
     ((some #'(lambda (situation)							; [1]
		(equal ser-exprs (get-vals instance slot :situation situation)))
	    (cons (curr-situation) (append (all-supersituations (curr-situation)) (visible-theories))))
      bindings)
;     ((not (situation-specificp slot))							; otherwise fail it out
; [5]
     (t (let ((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 (km-int `#$(the ,SLOT of ,INSTANCE))))) )		; [4b]
;	    (cond ((<= (length (remove-if-not #'existential-exprp ser-exprs)) (length see-vals)); quick look-ahead [2]
;	    (cond ((<= (length (remove-constraints ser-exprs)) (length see-vals))	; quick look-ahead check [2]
	    (cond ((<= (length (remove-if #'constraint-exprp ser-exprs)) (length see-vals)) ; quick look-ahead check [2]
		   (cond ((eq slot '#$instance-of) ; special case
			  (cond ((classes-subsume-classes ser-exprs see-vals) bindings))) ; assume no evaln needed
			 (t (let ((constraints (find-constraints-in-exprs ser-exprs)) 
				  (incompletep (or (member '#$:incomplete (get-vals instance slot))
						   (member '#$:incomplete (get-vals instance slot :situation *global-situation*)))))
			      (and (satisfies-constraints see-vals constraints slot :incompletep incompletep) ; [3]
				   (vals-subsume (cond ((single-valued-slotp slot) 
							(&-expr-to-vals (first ser-exprs)))  ; eg. ((a Car) & (must-be-a Dog))
						       (t ser-exprs))
						 see-vals
						 :bindings bindings))))))))))))

#|
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.
NOTE: (vals-subsume '(?x) '(_X1)), ?x unbound: -> bind ?x to _X1
      (vals-subsume '(?x) '(_X1)), ?x   bound: -> check ?x = _X1
      (vals-subsume '((?x == (a Car))) '(_X1)), ?x   bound: -> check ?x = _X1 AND _X1 is (a Car)
|#
(defun vals-subsume (ser-exprs see-vals &key (bindings *null-bindings*) current-var)
  (cond 
   ((endp ser-exprs) bindings)			; success!!
   ((equal ser-exprs see-vals) bindings)		; quick success - don't need to recurse
   (t (let ( (ser-expr (first ser-exprs)) )
	(cond ((or (existential-exprp ser-expr)
		   (km-structured-list-valp ser-expr))	; DON'T evaluate structured vals, preserve existentials in them
	       (let* ((see-val+new-bindings (first (find-subsumees+bindings ser-expr see-vals :bindings bindings))) ; [1]
		      (see-val (first see-val+new-bindings))
		      (new-bindings (second see-val+new-bindings)))
		 (cond (see-val 
			(vals-subsume (rest ser-exprs) 
				      (remove see-val see-vals :test #'equal)
				      :bindings (cond (current-var (add-binding current-var see-val new-bindings))
						      (t new-bindings)))))))
	      ((km-varp ser-expr)
	       (let ((binding (val-of ser-expr bindings)))
		 (cond (binding 
			(cond ((member binding see-vals :test #'equal)
			       (vals-subsume (rest ser-exprs) (remove binding see-vals) :bindings bindings))))
		       (see-vals 
			(vals-subsume (rest ser-exprs) (rest see-vals)  ; bind FIRST var only - no search :-(
				      :bindings (add-binding ser-expr (first see-vals) bindings))))))
	      ((and (listp ser-expr)
		    (km-varp (first ser-expr)))
	       (cond ((minimatch ser-expr '(?var == ?expr))
		      (let* ((var (first ser-expr))
			     (expr (third ser-expr))
			     (var-binding (val-of var bindings)))
			(cond (var-binding
			       (and (member var-binding see-vals)
				    (vals-subsume (list expr) (list var-binding))
				    (vals-subsume (rest ser-exprs) (remove var-binding see-vals) :bindings bindings)))
			      (t (vals-subsume (cons expr (rest ser-exprs)) see-vals 
					       :bindings bindings :current-var var)))))
		     (t (report-error 'user-error
			  "Bad use of a variable in subsumption expression ~a~%Expression must be of the form <var> or (<var> == <expr>)" ser-expr))))
	      (t (let ( (ser-vals (km-int ser-expr)) )
		   (cond ((subsetp ser-vals see-vals :test #'equal)
			  (let ((new-bindings
				 (cond 
				  (current-var 
				   (cond ((null ser-vals)
					  (report-error 'nodebugger-error
						       "~a == ~a == NIL in subsumption expression; ignoring ~a...~%"
						       current-var ser-expr current-var))
					 (t (cond ((>= (length ser-vals) 2)
						   (report-error 'nodebugger-error
						      "~a == ~a == ~a (multiple values!) in subsumption expression~%Just setting ~a == ~a (the first value)...~%"
						       current-var ser-expr ser-vals current-var (first ser-vals))))
					    (add-binding current-var (first ser-vals) bindings))))
				  (t bindings))))
			  (vals-subsume (rest ser-exprs) see-vals :bindings new-bindings))))))))))) ; [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))))
(defun breakup-existential-expr (expr0 &key (fail-mode 'fail))
 (let ( (expr (desource+decomment-top-level expr0)) )
  (cond ((and (listp expr)
	      (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) (= (length expr) 4)) (list (second expr) `((#$called (,(FOURTH EXPR))))))
	       ((and (eq (third expr) '#$uniquely-called) (= (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
(defun class-in-existential-expr (existential-expr)
  (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))))))
|#
(defun path-to-existential-expr (path &optional (prep '#$a))
  (path-to-existential-expr2 (rest path) (first path) prep))

(defun path-to-existential-expr2 (path embedded-unit prep)
  (cond ((endp path) embedded-unit)
	(t  (let* ( (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 '#$((a Cat) (a Door))
				 '#$(_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 '#$((a Cat) (a Door) (a Elephant))
				 '#$(_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)
|#
(defun remove-subsuming-exprs (exprs instances &key allow-coercion target eagerlyp)
 (cond ((and (tracep) (not (tracesubsumesp)))
	(let ((*trace* nil))
	  (remove-subsuming-exprs0 exprs instances :allow-coercion allow-coercion :target target :eagerlyp eagerlyp)))	  
       (t (remove-subsuming-exprs0 exprs instances :allow-coercion allow-coercion :target target :eagerlyp eagerlyp))))

(defun remove-subsuming-exprs0 (exprs instances &key allow-coercion target eagerlyp)
  (cond 
   ((or (null exprs) (null instances)) (values exprs instances nil))
   (t (let* 
	  ( (subsumed-instance 
	     (cond ((or (existential-exprp (first exprs))
;			(km-triplep (first exprs)))
			(km-structured-list-valp (first exprs)))
		    (find-if #'(lambda (instance) 
				 (cond 
				  ((is-an-instance instance)		; NB includes (:args foo) and (:triple a b c)
				   (or 
;;; PC CAN I safely get rid of this expensive and 
;;; PC confusing test? -> ...turns out for big KBs, it's actually cheaper to do this test!
;				       (km-int `#$(,INSTANCE is ',(FIRST EXPRS)))
				       (and allow-coercion ; [4]
#| hmm...|#				    (or (existential-exprp (first exprs))
						(km-structured-list-valp (first exprs)))
					    (not (contains-self-keyword (first exprs)))	; [4b]
					    (km-int `(,instance ,(cond (eagerlyp '&+!) (t '&+)) ,(first exprs)) 
						    :target target)
					; NOTE: no record-explanation here [7a] 
					    )))

				  ((and (existential-exprp instance)
					(not (contains-self-keyword (first exprs))))		; [6]
;				   (km-format t "**HERE!!**~%")
				   (km-int `#$(',INSTANCE is ',(FIRST EXPRS)))))) ; Test - if passed, can drop instance
			     ; NOTE: no record-explanation here [7b] 
			     instances))))
	    (instances0 (cond (subsumed-instance (remove subsumed-instance instances :test #'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 :eagerlyp eagerlyp)
	 (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 '#$(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 #'(lambda (subclass)					; WAS my-mapcan - #'mapcan safe here!
	      (cond ((is0 (km-unique-int `#$(a ,SUBCLASS) :fail-mode 'error) existential-expr) (list subclass))
		    (t (mgs2 existential-expr subclass))))	
  (km-int `#$(the subclasses of ,CLASS))))
|#

;;; ======================================================================

(defun valset-subsumes-valset (valset1 valset2)
  (cond 
   ((endp valset1))
   ((null valset2) nil)			; some valset2 without correlates in valset1
   (t (let ( (val1 (first valset1)) )
	(cond ((member val1 valset2 :test #'equal)
	       (valset-subsumes-valset (rest valset1) (remove val1 valset2 :test #'equal :count 1)))
	      ((existential-exprp val1)
	       (let ( (val2 (find-if #'(lambda (val)
					 (cond ((is-an-instance val) (is0 val val1))		; takes an instance and an (unquoted) expr
					       ((existential-exprp val) (is `',val `',val1))))
				     valset2)) )
		 (cond (val2 (valset-subsumes-valset (rest valset1) (remove val2 valset2 :test #'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: anglify.lisp

;;; File: anglify.lisp
;;; Author: Peter Clark
;;; Date: Separated out Aug 1994
;;; Purpose: Concatenation and customisation of text-fragments

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

; If nil then 3 -> "3". If t then 3 -> "the value 3"
(defparameter *verbose-number-to-text* nil)	

(defparameter *default-km-behavior-for-expand-text* t)

;;; ======================================================================
;;;		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.
|#
(defun make-phrase (text &key htmlify)
  (make-sentence text :capitalize nil :terminator "" :htmlify htmlify))

(defun make-sentence (text &key (capitalize t) (terminator ".") htmlify)
  (let ( (new-string 
	            (trim-whitespace
		     (concat-list 
		      (spacify
		       (remove nil
			(mapcar #'(lambda (i)
				    (cond 
				     ((null i) nil)
				     ((stringp i) i)
				     ((numberp i) (princ-to-string i))
				     ((member i '#$(:seq :set :triple)) nil)
				     ((symbolp i) (string-downcase i))
				     (t (report-error 'user-error "make-sentence/phrase: Don't know how to convert ~a to a string!~%" i))))
				(flatten (listify (expand-text text :htmlify htmlify))))))))) )
    (cond ((string= new-string "") "")
	  (t (let ( (terminated-string (cond ((not (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 (km-name ...). It eventually bottoms out when (km-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 (km-name _Engine23) -> (:seq "a" Engine)
      (km-name _Purpose24) -> ("a" Propelling "whose object is" _Airplane24)
      (km-name _Airplane25) -> (:seq "a" Airplane)
|#
(defun expand-text (item &key htmlify (depth 0))
  (let ( (expanded (remove '#$:seq (flatten (expand-text0 item :htmlify htmlify :depth depth)))) )
    (cond ((null expanded) nil)
	  ((singletonp expanded) (first expanded))
	  (t (cons '#$:seq expanded)))))

(defun expand-text0 (item &key htmlify (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*)))
		       (let ((number
			      (format nil (concat "~," (princ-to-string (- *output-precision* (floor (log item 10)))) "f") 
				      item)))
			 (cond ((search "." number) (string-right-trim '(#\0) number))
			       (t number))))
		      (t (format nil (concat "~," (princ-to-string *output-precision*) "e") item))))
	       (t item)))
;	((null item) (list "??"))		; why did I put this in? Add developer-mode flag 
	((and (null item) *developer-mode*) (list "??"))

; Modified by Sririam:
	((listp item)
	 (cond
	  (*default-km-behavior-for-expand-text*
	   (mapcar #'(lambda (i) (expand-text0 i :htmlify htmlify :depth (1+ depth))) item))
	  ;;; If NIL, switch to Sririam's alternative
	  (t (mapcar #'(lambda (i) (if (and (symbolp i)  (not (member i '(:|seq| :|set| NIL))) (not (or (kb-objectp i) (km-triplep i))))
				       (expand-text0 (string i) :htmlify htmlify :depth (1+ depth))
				     (expand-text0 i :htmlify htmlify :depth (1+ depth)))) item))))
	((member item '#$(:seq :set :bag :pair)) item)
	;((member item '#$(:seq :set :bag :pair)) "")
	((or (kb-objectp item) 
	     (km-triplep item))
	 (let ( (name (km-name item)) )
	   (cond ((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 (km-int `#$(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)))))
|#

(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.
(defun spacify (words)
  (cond ((null words) nil)
	((singletonp words) words)
	((white-space-p (second words) :whitespace-chars '(#\Space #\Tab))	; (but not #\Newline)
	 (spacify (cons (first words) (rest (rest words)))))
	((string= (first words) ".")
	 (cond ((and (string= (second words) (string #\Newline))
		     (not (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))))))))
;	((char= (first-char (second words)) #\-)	;; Special character, which forces no space
;	 (cons (first words)
;	       (spacify (cons (butfirst-char (second words))
;				    (rest (rest words))))))
	((string= (first words) *nospace-string*)	; handle multiple "nospace"s in a line
	 (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"
(defun capitalize (string)
  (concat (string-upcase (first-char string)) (butfirst-char string)))

;;; Crude!
;;; (a-space "cat" "dog") -> " "
;;; (a-space "cat" " dog") -> ""
;;; (a-space "cat " "dog") -> ""
(defun a-space (word1 word2)
  (cond ((no-following-spaces  (last-char word1)) "")
	((no-preceeding-spaces (first-char word2)) "")
	(t " ")))

(defun no-following-spaces (char)
  (member char '( #\( #\  )))

(defun no-preceeding-spaces (char)
  (member char '( #\' #\) #\. #\, #\ )))

;;; ======================================================================
;;;			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.
|#

;(defun km-name (concept &key 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.
(defun km-name (concept &key htmlify)
  (let ((*trace* nil))
    (cond 
        ((stringp concept) concept)
	((numberp concept) (princ-to-string concept))
;[2]	((protoinstancep concept) (prototype-name concept :htmlify htmlify))			; <== new
	((km-triplep concept) (triple-name concept))
	((let ( (name (km-int `#$(the name of ,CONCEPT))) )
	   (cond 
	    ((singletonp name) (first name))
	    ((not (null name)) 
	     (make-comment "Warning! ~a has multiple name expressions ~a!~%     Continuing just using the first (~a)..."
				      concept name (first name))
	     (first name)))))
	((km-unique-int `#$(the name of ,CONCEPT)))
	((symbol-starts-with concept #\*)		; "*pete" -> "pete"
	 (butfirst-char (string-downcase concept)))
	((anonymous-instancep concept)
	 (cond (t ;(not (equal (immediate-classes concept) '#$(Thing)))	; else return NIL [1]
		(anonymous-instance-name concept :htmlify htmlify))))
;	((atom concept) (string-downcase concept))
	((atom concept)
	 (if (not *default-km-behavior-for-expand-text*)
	     (string concept)
	   (string-downcase concept)))
	(t concept))))

(defun anonymous-instance-name (concept &key htmlify)
  (declare (ignore htmlify))
;  (concat "the " (km-name (first (immediate-classes concept)))))
  `(#$:seq "the" ,(km-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-unique-int `#$(the name of ,CONCEPT))
	     (let ( (parent (first (immediate-classes concept))) )
	       `(#$:seq "a" ,(km-name parent)))))
	(t `(#$:seq "the" ,(km-name (first (immediate-classes concept))) 
		  "of" ,(prototype-name (km-unique-int `#$(the prototype-participant-of of ,CONCEPT) :fail-mode 'error))))))
|#

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

#|
CL-USER> (triple-name '#$(:triple *pete owns (:set *money *goods *food)))
(:|seq| "pete" |owns| (:|seq| "money" ", " "goods" ", and " "food"))
CL-USER> (triple-name '#$(:triple *pete believes (:triple *joe owns *goods)))
(:|seq| "pete" |believes| (:|seq| "joe" |owns| "goods"))
|#
(defun triple-name (triple &key htmlify)
  (let ( (vals (val-to-vals (fourth triple))) )
    (list '#$:seq
	  (km-name (second triple) :htmlify htmlify) ; ("pete")
	  (km-name (third triple) :htmlify htmlify)  ; ("owns")
	  (cond ((null vals) nil)
		((singletonp vals) (km-name (first vals) :htmlify htmlify))
		(t (cons '#$:seq
			 (andify (mapcar #'(lambda (v) (km-name v :htmlify htmlify)) vals))))))))




;;; FILE: loadkb.lisp

;;; File: loadkb.lisp
;;; Author: Peter Clark
;;; Date: 21st Oct 1994

(eval-when (:execute :load-toplevel :compile-toplevel)
  (setq *readtable* *km-readtable*))	; So that the dispatch macro #$ is recognized

(defvar *creations* nil)
(defvar *logging-creations* nil)
(defconstant *checkpoint* 'checkpoint)

(defvar *current-renaming-alist* nil)
(defvar *stats* nil)			; internal back door for keeping records
(defvar *filename-extensions*
  (car `(#+(and Symbolics Lispm)              ("lisp" . "bin")
         #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
         #+(and dec common vax ultrix)        ("lsp"  . "fas")
 	 #+ACLPC                              ("lsp"  . "fsl")
 	 #+CLISP                              ("lisp" . "fas")
         #+KCL                                ("lsp"  . "o")
         #+ECL                                ("lsp"  . "so")
         #+IBCL                               ("lsp"  . "o")
         #+Xerox                              ("lisp" . "dfasl")
	 ;; Lucid on Silicon Graphics
	 #+(and Lucid MIPS)                   ("lisp" . "mbin")
	 ;; the entry for (and lucid hp300) must precede
	 ;; that of (and lucid mc68000) for hp9000/300's running lucid,
	 ;; since *features* on hp9000/300's also include the :mc68000
	 ;; feature.
	 #+(and lucid hp300)                  ("lisp" . "6bin")
         #+(and Lucid MC68000)                ("lisp" . "lbin")
         #+(and Lucid Vax)                    ("lisp" . "vbin")
         #+(and Lucid Prime)                  ("lisp" . "pbin")
         #+(and Lucid SUNRise)                ("lisp" . "sbin")
         #+(and Lucid SPARC)                  ("lisp" . "sbin")
         #+(and Lucid :IBM-RT-PC)             ("lisp" . "bbin")
	 ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
	 #+(and Lucid PA)		      ("lisp" . "hbin")
         #+excl ("cl"   . ,(pathname-type (compile-file-pathname "foo.cl")))
         #+(or :cmu :scl)  ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
;	 #+(and :CMU (not (or :sgi :sparc)))  ("lisp" . "fasl")
;        #+(and :CMU :sgi)                    ("lisp" . "sgif")
;        #+(and :CMU :sparc)                  ("lisp" . "sparcf")
	 #+PRIME                              ("lisp" . "pbin")
         #+HP                                 ("l"    . "b")
         #+TI ("lisp" . #.(string (si::local-binary-file-type)))
         #+:gclisp                            ("LSP"  . "F2S")
         #+pyramid                            ("clisp" . "o")

	 ;; Harlequin LispWorks
	 #+:lispworks 	      ("lisp" . ,COMPILER:*FASL-EXTENSION-STRING*)
;        #+(and :sun4 :lispworks)             ("lisp" . "wfasl")
;        #+(and :mips :lispworks)             ("lisp" . "mfasl")
         #+:mcl                               ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))
         #+:coral                             ("lisp" . "fasl")

         ;; Otherwise,
         ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
  "Filename extensions for Common Lisp.
A cons of the form (Source-Extension . Binary-Extension). If the
system is unknown (as in *features* not known), defaults to what compile-file-pathname
produces.")

;;; ======================================================================
;;;			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.
|#

(defun load-kb (file &key verbose with-morphism eval-instances load-patterns print-statistics silentp)
  (cond ((not silentp) (format t "Loading ~a...~%" file)))
  (reset-inference-engine)
  (let ((*logging* nil)			; switch off logging
	(*logging-creations* nil))
    (unwind-protect				; protect logging status in case syntax error in KB
	(progn 
	  (let ((renaming-alist (cond (with-morphism (setq *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) 
	      (cond (*am-reasoning* (report-error 'user-error (km-format nil "No such file ~a!~%" file)))
		    (t #|load-kb called from USER: prompt|# (km-format t "No such file ~a!~%" file)
		       (values nil (km-format nil "No such file ~a!~%" file)))))
	     (t (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)		; remove all `already computed' flags
		  (cond (with-morphism (setq *current-renaming-alist* nil)))
		  (cond ((and error	  ;;; NOTE: Error will already have been caught AND reported by load-exprs
			 		  ;;; error is an error WITHIN the file being loaded.
			      (not (member (on-error) '(continue continue-silently ignore))))
			 (cond (*am-reasoning* (report-error 'user-error (format nil "Loading of ~a aborted!~%" file)))
			       (t (format t "Loading of ~a aborted!~%" file)
				  (values nil (format nil "Loading of ~a aborted!~%" file)))))
			(t (cond ((not silentp) (format t "~a loaded!~%" file)))
			   (cond (print-statistics (princ (report-statistics)) (terpri)))
			   (values result)))))))))))

;;; 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
(defun load-exprs (expr stream &optional verbose renaming-alist eval-instances load-patterns)
  (multiple-value-bind (result error)
      (load-expr expr stream verbose renaming-alist eval-instances load-patterns)
    (cond (result
           (loop
            (let ((expr (case-sensitive-read-km stream nil nil)))
              (multiple-value-bind (result error)
                  (load-expr expr stream verbose renaming-alist eval-instances load-patterns)
                (unless result
                  (return (values result error)))))))
          (t (values result error)))))

;;; Returns t if load successful
;;; NIL of expr = nil (signifies EOF; needs updating)
;;; (values nil error) if error occurred and on-error /= continue
(defun load-expr (expr stream &optional verbose renaming-alist eval-instances load-patterns)
  (let ((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)				; only do these
                       (minimatch renamed-expr pattern))
                   load-patterns))
      t)
     (verbose (print-km-prompt)
              (km-format t " ~a~%" renamed-expr)		   
	      (let ((*am-reasoning* nil))    ; was (reset-inference-engine), but *am-resoning* nil will trigger (r-i-e)
              (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 ((and error (not (member (on-error) '(continue continue-silently ignore))))
		       (values nil error))
                      (t t)))))
     (t ; (reset-inference-engine) - no, let's keep the counter running for the whole KB
      (setq *catch-explanations* nil)		; but DO need this bit
      (cond (*catch-next-explanations*
             (setq *explanations* nil)
             (setq *catch-explanations* t)
             (setq *catch-next-explanations* nil)))
      (let ((*am-reasoning* nil))	; so (km '#$(load-kb ...)) will still make load-kb a top-level call
	(multiple-value-bind 
	    (results error)
;           (km-eval renamed-expr :fail-mode *top-level-fail-mode*)
	    (km renamed-expr :reset-statistics nil)
	  (cond ((minimatch renamed-expr '#$(the ?slot of ?expr)) (setq *last-answer* results)))
	  (cond ((or eval-instances (am-in-prototype-mode)) (eval-instances results)))
	  (cond ((and error (not (member (on-error) '(continue continue-silently ignore))))
		 (values nil error))
		(t t))))))))

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

(defun rename-symbols (expr renaming-alist) (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.
(defun triples-to-alist (triples) 
  (cond ((quotep triples) (triples-to-alist (unquote triples)))
	((or (not (listp triples))
	     (not (every #'(lambda (x) (and (triplep x)
					    (symbolp (first x))
					    (eq (second x) '->)))
;					    (symbolp (third 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) 
	      (cond ((not (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.
(defun reload-kb (file &key verbose with-morphism eval-instances load-patterns)
  (reset-kb)
  (load-kb file :verbose verbose 
	     :with-morphism with-morphism 
	     :eval-instances eval-instances :load-patterns load-patterns))

;;; Same, callable from within KM
;(defun reload-kb0 (file &key 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
(defvar *kb-objects* (make-hash-table :test #'eq))

(defun getobj (name0 facet)
 (let ((name (dereference name0)))
  (cond ((and (not (member facet *all-facets*))
	      (not (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)   
	 (setq *statistics-kb-access* (1+ *statistics-kb-access*))
	 (get name facet))	; new - add dereference
	((is-km-term name) nil)		; Valid get, but no attributes. This includes 1 'a "12" (:seq a b c) #'+ (:set a b c)
	((equal name name0)
	 (report-error 'program-error "Accessing frame ~a - the frame name `~a' should be an atom!~%" name name))
	(t (report-error 'program-error 
			 "Accessing frame ~a (dereferences to ~a) - the frame name `~a' should be an atom!~%" 
			 name0 name name)))))

;;; To DELETE an object, now use delete-frame (above).
;;; (putobj nil won't remove object from *kb-objects*)
(defun putobj (fname slotsvals facet)
  (cond ((and (not (member facet *all-facets*)) 
	      (not (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 ; (setf (get fname facet) slotsvals)        ;put it on the p-list
;		   (make-transaction `(setf ,fname ,facet ,slotsvals))        ;put it on the p-list
	           (km-setf fname facet slotsvals)
		   (cond ((not (gethash fname *kb-objects*))
			  ; (setf (gethash fname *kb-objects*) t)
			  ; (make-transaction `(add-to-kb ,fname))
			  (km-add-to-kb-object-list fname)
			  )))
	(t (km-remprop fname facet))))

;;; ======================================================================
;;;		ROLLBACK MECHANISMS
;;; ======================================================================

(defun reset-creations () (setq *creations* nil))

(defun start-creations-logging (&key (with-comment t))
  (cond (*logging-creations* (cond (with-comment (format t "(Logging of concept creations is already switched on)~%"))))
	(t (cond (with-comment (format t "(Started logging of concept creations)~%")))
	   (setq *logging-creations* t)))
  t)

(defun stop-creations-logging (&key (with-comment t))
  (cond ((not *logging-creations*) (cond (with-comment (format t "(Logging of concept creations is already switched off)~%"))))
	(t (cond (with-comment (format t "(Stopping logging of concept creations)~%")))
	   (setq *logging-creations* nil) (setq *creations* nil)))
  t)

(defun set-creations-checkpoint (&key (checkpoint-id *checkpoint*) (with-comment t) multiple-checkpoints)
  (cond ((not *logging-creations*)
	 (format t "WARNING! Trying to set-creations-checkpoint, but you should first call (start-creations-logging)!~%")
	 (format t "WARNING! I'll start creation's logging now for you.~%")
	 (start-creations-logging)))
  (cond ((not multiple-checkpoints) (reset-creations)))
  (push `(km-gensym-counter ,*km-gensym-counter*) *creations*)
  (push checkpoint-id *creations*) 
  (cond (with-comment (format t "Creations checkpoint is set~%")))
  t)


;;; [1] can happen as description-subsumes-description does an (undo) hence can be added twice to the stack
;;; [2] Is bound to another item, so its body should have already been deleted by km-bind. Thus we just need to delete it directly,
;;;     but better do this *after* deleting everything for real, or else we might lose data. A -> B -> C, delete B, so now A dereferences to NIL
;;; [3] Need delete-frame rather than delete-frame-structure, as we want to delete inverse links too
(defun undo-creations (&key (checkpoint-id *checkpoint*) (with-comment t) remove-checkpoint)
  (cond 
   ((not *logging-creations*)
    (format t "Unable to undo concept creations - concept creations not switched on! Do (start-creations-logging) first.~%"))
   (*logging*
    (format t "You're not allowed to undo concept creations while logging is on! Do (stop-logging) first.~%"))
   (t (let ((cpu-start-time (get-internal-run-time))
	    (n-to-undo (position checkpoint-id *creations*)))
	(cond (with-comment (format t "Undo creations: starting~%")))
	(cond ((not n-to-undo)
	       (format t "Unable to undo concept creations - can't find checkpoint ~a to undo back to.~%" checkpoint-id)
	       (format t "Do (set-creations-checkpoint) to create a checkpoint.~%"))
	      (t (let ((creations-to-delete (make-hash-table)))		; create a quickly accessible list of creations to delete
		    (loop 
			for i = (pop *creations*)			; will pop the checkpoint off *creations*, so put it back later [4]
			until (or (eq i checkpoint-id) (null i))
			do (setf (gethash i creations-to-delete) t))
		    (let ((undesirable-deletions 
			   (my-mapcan #'(lambda (retained-i) 
					  (cond ((and ; (anonymous-instancep retained-i) - no, we can delete named instances too
						      (not (gethash retained-i creations-to-delete)) ; not going to delete it
						      (gethash (get-binding retained-i) creations-to-delete)) ; but it's bound to something to delete :-(
						 (remove-if-not #'(lambda (x) (gethash x creations-to-delete)) (dereference-chain retained-i)))))
				      (get-all-objects)))
			  (*show-comments* nil))
		      (cond (undesirable-deletions 
			     (mapc #'(lambda (x)
				       (km-format t "   ~a created since checkpoint, but won't delete it (pre-checkpoint instance is unified with it)~%" x)
				       (remhash x creations-to-delete)) 
				   (remove-duplicates undesirable-deletions))))
		      (maphash (lambda (i v)
				 (declare (ignore v))
				 (cond ((not (anonymous-instancep i)) nil)
				       ((not (known-frame i))  nil) ; [1] 
				       ((bound i) nil) 		    ; [2]
				       (t (delete-frame i)))) 	    ; [3]
			       creations-to-delete)
		      (maphash (lambda (i v)
				 (declare (ignore v))
				 (cond ((bound i) (delete-frame-structure i)))) ; [2]
			       creations-to-delete)
		      (let ((km-gensym-counter (first *creations*)))
			(cond ((and (pairp km-gensym-counter) 
				    (eq (first km-gensym-counter) 'km-gensym-counter)
				    (integerp (second km-gensym-counter)))
			       (setq *km-gensym-counter* (second km-gensym-counter))
			       (cond (remove-checkpoint (pop *creations*))
				     (t (push checkpoint-id *creations*))))		; [4]
			      (t (format t "ERROR! Failed to find number to reset *km-gensym-counter* to (Leaving it unchanged)~%"))))))
		 (clear-obj-stack)
		 (cond (with-comment (format t "Undo creations: ~a concepts deleted in ~,2f sec~%" n-to-undo
					     (/ (- (get-internal-run-time) cpu-start-time) internal-time-units-per-second))))
		 t))))))
   
;;; DOESN'T include i   
(defun dereference-chain (i)
  (let ((i2 (get-binding i)))
    (cond (i2 (cons i2 (dereference-chain i2))))))
  
;;; ======================================================================  

#|
KM> (every man has (parts ((a Head))))
KM> (Pete has (instance-of (Man)))
KM> (undo)
Undone (Pete has (instance-of (Man)))...
KM> 
|#

(defvar *history* nil)
; (defvar *logging* nil) - in header.lisp

(defun reset-history () (setq *history* nil))

(defun checkpoint-p (x) (and (pairp x) (equal (first x) *checkpoint*)))
(defun checkpoint-id (x) (second x))

(defun set-checkpoint (&optional (checkpoint-id 't))
  (cond ((or *logging* *internal-logging*) (push (list *checkpoint* checkpoint-id) *history*) t)))

;;; From Ken Murray
(defun next-checkpoint ()
  (second (first (member *checkpoint* *history* :key #'first))))

(defun undo-possible (&optional checkpoint-id)
  (cond (checkpoint-id (member (list *checkpoint* checkpoint-id) *history* :test #'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.
(defun undo (&optional checkpoint-id)
  (cond ((undo-possible checkpoint-id)
	 (cond ((not *internal-logging*) (reset-done)))		; [1] NB do BEFORE objects are forgotten! Also [2]
	 (undo0 *history* checkpoint-id))))
  
(defun undo0 (history checkpoint-id)
  (cond ((null history) 		; should never be encountered
	 (setq *history* nil)
	 (km-format t "Nothing more to undo!~%"))
	((and (checkpoint-p (first history))
	      (or (null checkpoint-id)
		  (equal checkpoint-id (checkpoint-id (first history)))))
	 (prog1
	     (checkpoint-id (first history))		; return the checkpoint-id associated with the checkpoint
	   (setq *history* (rest history))))
	(t (cond ((not (checkpoint-p (first history))) (undo1 (first history))))
	   (undo0 (rest history) checkpoint-id))))

(defun undo1 (command)
;  (km-format t "Undoing ~a...~%" command)
  (eval command))

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

;;; This is how setf works: (setf (get symbol property) new-values)
(defun log-undo-command (command)
  (cond ((or *logging* *internal-logging*) (push command *history*))))

(defun start-logging (&key (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)~%")))
	   (setq *logging* t)))
  t)

(defun stop-logging (&key (with-comment t))
  (cond ((not *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)~%")))
	   (setq *logging* nil) (setq *history* nil)))
  t)

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

#|
Macro: Evaluate with no side-effects (Thanks to Francis Leboutte)
e.g., (keeping-kb
		(km '#$(a Car with (color (*red))))
		(km '#$(the color of (thelast Car))))
will remove the created Car after returning a result.		
|#
(defmacro keeping-kb (&body body)
   `(let ((*logging* t))
      (set-checkpoint '%keeping-kb-cpid%)
      (multiple-value-prog1
          (progn ,@body)
        (undo '%keeping-kb-cpid%))))

;;; Make accessible from KM prompt
(add-lisp&KM-function 'keeping-kb)

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

;;; Could optimize this if eval is too slow
(defun km-setq (variable value)
  (let ( (old-value (eval variable)) )
    (cond 
     ((equal old-value value))
     (t (log-undo-command `(setq ,variable ',old-value)) 
	(eval `(setq ,variable ',value))))))		; need to unquote the variable

;;; (km-push 'a '*x*)
(defun km-push (value variable)
  (log-undo-command `(pop ,variable))
  (eval `(push ',value ,variable)))

;;; (km-pop '*x*)
(defun km-pop (variable)
  (let ((popped (first (eval variable))))
    (log-undo-command `(push ',popped ,variable))
    (eval `(pop ,variable))))

(defun km-setf (symbol property value)
  (let ( (old-value (get symbol property)) )
    (cond 
     ((equal old-value value))
     (t (cond (old-value (log-undo-command `(setf (get ',symbol ',property) ',old-value)))
	      (t (log-undo-command `(remprop ',symbol ',property))))
	(cond ((null value) (remprop symbol property))
	      (t (setf (get symbol property) value)))))))

(defun km-remprop (symbol property)
  (let ( (old-value (get symbol property)) )
    (cond 
     ((null old-value))
     (t (log-undo-command `(setf (get ',symbol ',property) ',old-value))
	(remprop symbol property)))))

(defun km-add-to-kb-object-list (fname)
  (cond ((not (gethash fname *kb-objects*))
	 (log-undo-command `(remhash ',fname *kb-objects*))
					;	 (km-format t "pushing ~a onto *creations*...~%" fname)
	 (cond (*logging-creations* (push fname *creations*)))
	 (setf (gethash fname *kb-objects*) t))))

(defun km-remove-from-kb-object-list (fname)
  (cond ((gethash fname *kb-objects*)
	 (log-undo-command `(setf (gethash ',fname *kb-objects*) t))
	 (remhash fname *kb-objects*))))

;;; Inverse For undo only
;(defun km-remhash-kb-objects (fname) (remhash fname *kb-objects*))
;(defun km-addhash-kb-objects (fname) (setf (gethash fname *kb-objects*) t))

;;; ======================================================================
;;;	get-all-objects -- update thanks to Francis Leboutte
;;; ======================================================================

#|
get-all-objects and get-all-concepts rewritten using do-objects macro
and using delete functions instead of remove
|#

;;; macro to loop in all the objects in *kb-objects*
;;; example: (do-objects object (print object))
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmacro do-objects (var &body body)
    `(maphash (lambda (,var v)
                (declare (ignore v))
                ,@body)
              *kb-objects*)))

;;; NOTE: We *don't* do dereferencing here, because we want to delete the old concepts with a (reset-kb)
;;; This list includes instances bound (pointing) to other instances AND deleted instances.
(defun get-all-objects ()
  (let ((results nil))
    (do-objects object
      (push object results))
    results))

;;; should be faster
;;; EXCLUDES comment tags. Here we *do* do a dereference, hence must remove non-kb-objects in the list (from unifications)
(defun get-all-concepts ()
  (let ((results nil))
    (do-objects object
      (let ((frame (dereference object)))
        (when (kb-objectp frame)			; NOTE: exclude user comments 
          (push frame results))))
    (remove-duplicates results)))	; dereference may cause duplicates

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

;;; If t, we simply obliterate the frame's entire property list. The Lisp Manual advises that this is a relatively
;;; dangerous operation, as it may destroy important information that the implementation may happen to
;;; store in property lists.
;;; If NIL, we only delete the KM-specific properties, e.g., if the symbol is also used for other purposes.
(defparameter *fast-delete-frame-structure* nil)

;;; Note, is reversible (if *logging* is t)
(defun delete-frame-structure (fname &key (remove-from-kb-object-list t))
  (cond
   ((and *fast-delete-frame-structure* (not *logging*)) (setf (symbol-plist fname) nil))
   (t (km-remprops fname)
;  (km-format t "~a: ~a~%" fname (symbol-plist fname))
;  (remhash fname *kb-objects*)
      (cond (remove-from-kb-object-list (km-remove-from-kb-object-list fname))) ; reversible
      fname)))

;;; Remove *all* properties on the property list
(defun km-remprops (symbol)
  (mapc #'(lambda (property) 
	    (cond ((km-propertyp property) (km-remprop symbol property))))
	(odd-elements (symbol-plist symbol))))

(defun km-propertyp (property)
  (or (member property *all-facets*)
      (member property '(done cached-explanations ununify-data binding comment definition defined-instances defined-subclasses defined-prototypes explanation))
      (starts-with (symbol-name property) "OWN-")
      (starts-with (symbol-name property) "MEMBER-")
      (starts-with (symbol-name property) "EXPLANATION")))

;;; Rename this from "exists"; it really means fname is a known frame (Is an error to try this check for numbers and 
;;; strings).
(defun known-frame (fname)
  (cond ((kb-objectp fname)
	 (or (gethash fname *kb-objects*)
	     (built-in-concept fname)))
	(t (report-error 'program-error "Attempt to check if a non kb-object ~a is a frame!~%" fname))))

(defun unusable-frame-name (fname) (known-frame fname))
;  (cond ((kb-objectp fname)
;	 (or (gethash fname *kb-objects*)
;	     (get-binding frame)			; [1]
;	     (built-in-concept fname)))
;	(t (report-error 'program-error "Attempt to check if a non kb-object ~a is a frame!~%" fname))))

;;; return the list of KM properties of symbol (KM properties only)
(defun km-symbol-plist (symbol)
  (loop for l on (symbol-plist symbol) by #'cddr
        as prop = (first l)
        when (km-propertyp prop)
        collect prop
        and
        collect (second l)))

;;; to put a list of properties on symbol
(defun put-list (symbol list)
  (declare (optimize (speed 3) (safety 1) (debug 0)))
  (loop for l on list by #'cddr
        do
        (setf (get symbol (first l))
              (second l))))

;;; to put a list of properties on symbol - this is UNDOABLE
(defun km-put-list (symbol list)	
  (declare (optimize (speed 3) (safety 1) (debug 0)))
  (loop for l on list by #'cddr
        do
        (km-setf symbol (first l) (second l))))

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

(defun reset-kb ()
  (let ((*logging* nil)
	(*logging-creations* nil))
    (global-situation)
    (instance-of-is-nonfluent)		; set it back
    (make-comment "Resetting KM...")
    (mapc #'(lambda (frame) 
	      (delete-frame-structure frame))	; includes clearing explanations and cached-explanations
	  (get-all-objects))  	
    (clrhash *kb-objects*)
    (clear-obj-stack)
;   (clear-km-errors)
    (setq *curr-prototype* nil)
;   (setq *instances-with-cached-explanations* nil)	; not used any more
    (setq *classes-using-assertions-slot* nil) ; optimization flag
    (setq *are-some-subslots* nil)	; optimization flag
    (setq *are-some-prototypes* nil)	; optimization flag
    (setq *are-some-definitions* nil)	; optimization flag
    (setq *are-some-prototype-definitions* nil)	; optimization flag    
    (setq *are-some-constraints* nil)	; optimization flag
    (setq *are-some-tags* nil)		; optimization flag
    (setq *are-some-defaults* nil)		; optimization flag
    (setq *am-in-situations-mode* nil)
; NO! Allow any change to persist.    
;   (setq *built-in-remove-subsumers-slots* '#$(instance-of classes superclasses member-type)) ; in case user changes this
    (setq *visible-theories* nil)
    (setq *default-fluent-status* *default-default-fluent-status*)
    (setq *km-gensym-counter* 0)
;    (setq *clone-operation-id-counter* 0)
;    (setq *pid-counter* 0)
    (setq *max-padding-instances* 0)
    (setq *internal-logging* nil)
					; (reset-inference-engine)		; no, want to keep inference counter going!
    (enable-classification)
    (reset-history)
    (reset-creations)
    (clear-goal-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.
(defun reset-inference-engine ()
  (setq *postponed-classifications* nil)
; (setq *am-classifying* nil) - no longer used as a global so don't need to reset. Rather is always within lexical scoping
  (setq *catch-explanations* nil)
  (setq *internal-logging* nil)
  (cond (*catch-next-explanations*
	 (setq *explanations* nil)
	 (setq *catch-explanations* t)
	 (setq *catch-next-explanations* nil)))
  (cond (*profiling* (profile-reset)))
  (clear-goal-stack)
  (reset-statistics)
  (reset-trace)
  (reset-trace-depth)
  (enable-installing-inverses))		; [1]

(defun clear-situations ()
  (let ((*logging* nil)
	(*logging-creations* nil))
    (reset-history)
    (reset-creations)    
    (global-situation)
    (let ( (facets (my-mapcan #'(lambda (situation)
				  (mapcar #'(lambda (facet)
					      (curr-situation-facet facet situation))
					  (cons 'explanation *all-facets*)))
			      (remove *global-situation* (all-situations)))) )
      (mapc #'(lambda (frame) 
		(cond ((isa frame '#$Situation)
		       (delete-frame frame))
		      ((intersection (symbol-plist frame) facets) ; i.e., has situation-specific info...
		       (mapc #'(lambda (facet) (remprop frame facet)) facets))))
	    (get-all-concepts))
      (setq *am-in-situations-mode* nil)
      t)))

;;; ======================================================================
;;;			SAVING A KB
;;; ======================================================================

(defun save-kb (file &key (reset-kb t) (include-explanationsp t))
  (let ( (stream (tell file)) )
    (write-kb :stream stream :reset-kb reset-kb :include-explanationsp include-explanationsp)
    (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.
;;; [2] Without this got the error: Error: During case-sensitive-read:
;;;			The symbol "*RECURSIVE-CLASSIFICATION*" is not external in the KM package. [file position = 93565677]
;;;     As the file contained KM:*RECURSIVE-CLASSIFICATION*", just ":" as *recursive-classification* was external during the save, but not during the load.
(defun write-kb (&key (stream *standard-output*) (objects (get-all-objects)) 
		      situations0 (reset-kb t) (include-explanationsp t))
  (cond 
   ((and (not (streamp stream))
	 (not (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 (let ((situations (or situations0 (all-situations))) 
	    (*package* *km-package*))	; NOTE: Must be in KM package to remove the KM:: and KM: prefixes in the saved KB. [2]
	(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 (cond ((and reset-kb (neq reset-kb '#$nil)) (format stream "~%(reset-kb)~%")))
		  (km-format stream "~%(disable-slot-checking)       ; (Temporarily disable while rebuilding KB state)~%")
		  (km-format stream "                              ; (Will be restored to original value by final SETQ statements)~%")
;;; NOTE: Below need to disable this even if *are-some-definitions* is nil at save-time, because it may be t at load-time
		  (km-format stream "~%(disable-classification)      ; (Temporarily disable while rebuilding KB state)~%")
		  (km-format stream "                              ; (Will be restored to original value by final SETQ statements)~%")
		  (km-format stream "~%(disable-installing-inverses) ; (Temporarily disable while rebuilding KB state)~%")	; [1]
		  (km-format stream "                              ; (Will be switched back on by (enable-installing-inverses) at the end)~%")
;;; Strictly redundant, as final SETQ statements will set this
;		  (cond ((member '#$instance-of *built-in-inertial-fluent-slots*)
;			 (km-format stream "~%(instance-of-is-fluent)~%")))
;		  (format stream "~%;;; ----------~%~%")
		  ))
; Note: need to write out taxonomy first because some ordering things, e.g., most-specific-first in frame-io.lisp
; when indexing definitions, need it.
; It gets redundantly written out a 2nd time in CONTENTS, but that's ok.
	 (km-format stream "~%;;; ---------- TAXONOMY ----------~%~%")	 
	 (mapc #'(lambda (concept)
		   (cond ((not (bound concept))
			  (save-frame concept :situations situations 
				      :nulls-okayp nil  ; Don't write out "(_Car has...)" if no values
				      :stream stream
				      :slots-to-show '#$(superclasses))
;			  (princ ";;; ----------" stream) 
;			  (terpri stream) 
;			  (terpri stream)
			  )))
	       concepts)
	 (km-format stream "~%;;; ---------- CONTENTS ----------~%~%")	 
	 (mapc #'(lambda (concept)
		   (cond ((not (bound concept))
			  (save-frame concept :situations situations :nulls-okayp t :stream stream)
			  (princ ";;; ----------" stream) 
			  (terpri stream) 
			  (terpri stream))))
	       concepts)
	 (cond (include-explanationsp
		(km-format stream "~%;;; ---------- EXPLANATIONS ----------~%~%")
		(mapc #'(lambda (concept)
			  (cond ((not (bound concept))
				 (save-explanations concept :stream stream))))
		      concepts)
; Maybe not needed after all
;		(km-format stream "~%;;; ---------- DERIVATION CACHE ----------~%~%")
;		(mapc #'(lambda (concept)
;			  (cond ((not (bound concept))
;				 (save-explanations2 concept :stream stream))))
;		      concepts)
		))
	 (cond (comment-tags
		(km-format stream "~%;;; ---------- COMMENTS ----------~%~%")	 
		(mapc #'(lambda (comment-tag)
			  (km-format stream "~a~%~%" `(#$comment ,comment-tag ,@(get comment-tag 'comment)))
			  (princ ";;; ----------" stream) 
			  (terpri stream) 
			  (terpri stream))
		      comment-tags)))
; NO: Restore it with the SETQ statements at the end. It may that classification should stay off, if it was before.
;	 (cond (*are-some-definitions*  
;	        (km-format stream "~%(enable-classification)     ;;; (Re-enable it after restoring KB state)~%")))
	 (km-format stream "~%;;; ----------------------------------------~%")	 
	 (km-format stream "~%(enable-installing-inverses)  ; (Re-enable it after restoring KB state)~%")
	 (write-behavior-variables stream)
	 (write-state-variables stream)
	 (format stream ";;; --- end (~a frames written) ---~%~%"  (length (remove-if #'bound objects))))))))

;;; Output to file;
;;; [1] WARNING! (format stream <string>) doesn't work if string contains a "~". So must do (format stream "~a" <string>)
;;; vals-to-show: any anonymous instance NOT in vals-to-show will NOT be written out
;;; save-prototypep: t if called by save-prototype in prototypes.lisp
(defun save-frame (concept &key (stream t) (situations (all-situations)) save-prototypep 
		essentials partially-cloned-from slots-to-show (theories (all-theories)) nulls-okayp include-explanationsp)
  (cond ((not (is-km-term concept))
	 (report-error 'nodebugger-error "Doing (save-frame ~a) - the frame name `~a' should be a KB term!~%" 
		       concept concept))
	(t (format stream "~a" (write-frame concept :situations situations :essentials essentials 
					    :slots-to-show slots-to-show :partially-cloned-from partially-cloned-from 
				    :save-prototypep save-prototypep :theories theories :nulls-okayp nulls-okayp)) ; [1]
	   (cond (include-explanationsp 
		  (save-explanations concept :stream stream)
;		  (save-explanations2 concept :stream stream)
		  ))
	   t)))

;;; Specify explanation-types to restrict which ones to save (types are #$a, #$cloned-from, #$added-at, or 
;;; #$projected-from). NIL = save all types.
(defun save-explanations (concept &key (stream t) essentials explanation-types)
  (mapc #'(lambda (isv-explanation) 
	    (cond ((or (null explanation-types)
		       (member (explanation-type (fourth isv-explanation)) explanation-types))
		   (save-explanation isv-explanation :stream stream :essentials essentials))))
	(get-all-explanations concept nil)))

; isv-explanation = (<participant> <slot> <val> <expln>)
(defun save-explanation (isv-explanation &key (stream t) essentials)
  (cond
   ((or (null essentials)
	(null (nonessentials-in isv-explanation :essentials essentials)))
    (km-format stream "(explanation (:triple ~a ~a ~a)~%  (~a))~%" 
	       (first isv-explanation) (second isv-explanation) (third isv-explanation) (fourth isv-explanation)))
;   (t (km-format t "DEBUG: Dropping explanation containing a non-essential ~a:~%  ~a~%" 
;		 (delistify (remove-duplicates (nonessentials-in isv-explanation :essentials essentials)))
;		 isv-explanation))
   ))

#|
Note: This function is ONLY called in the context of saving prototype explanations (detected
	by :essentials being non-nil), so we ASSUME we are in that context always.
Note: For efficiency we don't collect all the nonessentials, just the first we find (as we only care about their presence)
[1] A cloned-from explanation is a special case where we *do* allow a non-participant in the explanation:
	(cloned-from _ProtoDrive1 _Drive1 _ProtoCar1)   ; cloned from _ProtoCar1 in _ProtoDrive1 to _Drive1
    Here, the 2nd and 4th elements are the source protoinstance and protoroot respectively from which _Drive1 was built.
    So we only need to check _Drive1 is indeed a essential.	
    For old explanation DBs, the third (and fourth) elements may be missing, hence the existence check (third explanation)
|#
(defun nonessentials-in (isv-explanation &key essentials)
  (let* ((triple (triple-in isv-explanation))
	 (i (first triple))
	 (v (third triple))
	 (explanation (explanation-in isv-explanation)))
    (cond ((not (member i essentials))
	   (report-error 'user-error
			 "(save-explanations ~a :essentials ~a): ~a should be in the list of essentials!~%"
			 i essentials)))
    (or (nonessentials-in-expr v :essentials essentials)		; v must be essential
	(case (explanation-type explanation)
	  (#$cloned-from (cond ((and (third explanation) ; [1]
				     (not (member (third explanation) essentials)))
				(list (third explanation)))))
	  (t (nonessentials-in-expr explanation :essentials essentials))))))

(defun nonessentials-in-expr (expr &key essentials)
  (cond ((member expr essentials) nil)		; Purely for efficiency (if expr is essential, then no nonessentials!)
	(t (set-difference (remove-if-not #'anonymous-instancep (flatten expr)) essentials))))

;;; This saves the 2nd type of explanations, namely cached expressions that an instance was derived from to prevent
;;; rederiving it a 2nd time. I *don't* think we need this though - it's purely an efficiency thing.
;(defun save-explanations2 (concept &key (stream t))
;  (mapc #'(lambda (cached-explanation)
;	    (km-format stream "(explained-by ~a ~a)~%" concept cached-explanation))
;	(cached-explanations-for concept)))

;;; Various variables about the current state, to write back so we can pick up 
;;; where we left off if we reload...
(defun write-behavior-variables (&optional (stream t))
  (km-format stream "
;;; ----------------------------------------
;;;	KM'S INTERNAL BEHAVIOR PARAMETER VALUES
;;; ----------------------------------------

")
  (mapc #'(lambda (km-parameter)
	    (km-format stream "(SETQ ~s '~s)~%" km-parameter (eval km-parameter)))
	*km-behavior-parameters*)
  (km-format stream "~%"))

(defun write-state-variables (&optional (stream t))
  (km-format stream "
;;; ----------------------------------------
;;;	KM'S INTERNAL STATE PARAMETER VALUES
;;; ----------------------------------------

")
  (mapc #'(lambda (km-parameter)
	    (km-format stream "(SETQ ~s '~s)~%" km-parameter (eval km-parameter)))
	*km-state-parameters*)
  (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.
(defun sort-objects-for-writing (objects0)
  (let* ( ; (prototypes (km-int '#$(the prototypes of (the all-subclasses of Thing))))
	  (comment-tags (remove-if-not #'user-commentp objects0))
	  (objects (remove-if #'user-commentp objects0))
	  (slot-classes (intersection (cons '#$Slot (all-subclasses '#$Slot)) objects))
	  (prototypes (remove-if-not #'prototypep objects))		; Doesn't involve the tracer (which is confusing to the user)
	  (situation-classes (cond ((member '#$Situation objects) (cons '#$Situation (all-subclasses '#$Situation)))))
	  (situation-instances (remove-if-not #'(lambda (situation)		; [2]
						  (isa situation '#$Situation))
					      objects))
	  (theory-classes (cond ((member '#$Theory objects) 
				 (intersection (cons '#$Theory (all-subclasses '#$Theory)) objects))))
	  (theory-instances (remove-if-not #'(lambda (theory)		; [2]
						  (isa theory '#$Theory))
					      objects))
	  (rest-objects (ordered-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)	
;;; ======================================================================

(defvar *stored-kb* nil)
(defun store-kb ()
  (let ( (now (now)) )
    (setq *stored-kb* (list now (get-kb)))
    (make-comment "State of KB stored (~a)~%" now)
    '#$(t)))

(defun restore-kb (&key unintern-symbols)
  (cond ((null *stored-kb*)
	 (format t "No stored KB state to restore!~%"))
	(t (put-kb (second *stored-kb*) :unintern-symbols unintern-symbols)
	   (make-comment "State of KB restored to that stored at ~a.~%" (first *stored-kb*))
	   '#$(t))))

;;; Return the KB as a massive data structure (!)
;;; More efficient implementation than before
(defun get-kb ()
 (let ((cpu-start-time (get-internal-run-time)))
  (prog1
    (append
     '((reset-kb))
     (copy-tree
      (mapcan #'(lambda (concept)
		  `((setf (symbol-plist ',concept) ',(symbol-plist concept))
		    (km-add-to-kb-object-list ',concept)))
	      (sort (get-all-objects) #'string<)))
     (mapcar #'(lambda (km-parameter)
		 `(setq ,km-parameter ',(eval km-parameter)))
	     (append *km-behavior-parameters* *km-state-parameters*)))
    (let* ((cpu-end-time (get-internal-run-time))
	   (cpu-time (/ (- cpu-end-time cpu-start-time) internal-time-units-per-second)))
      (make-comment "KB state gathered using get-kb (~a objects) in ~,2f secs" (length (get-all-objects)) cpu-time)))))

;;; [1] Note, copy-tree IS necessary. Jason Chaw found a case where doing (put-kb *x*), then a (reset-kb) via
;;; a second (put-kb *x*) would change *x* itself. Apparently *x* contained (setf (symbol-plist '|Move|) <struct>)
;;; resulting in the symbol plist being |Move| <struct>, or literally |Move| <pointer to <struct> in *x*>.
;;; Then (reset-kb) changed it to |Move| (done nil) which had the side-effect of ALSO replacing <struct> in *x* with 
;;; (done nil).
;;; NOTE: Current KB is deleted by a call to (reset-kb), included at the first element of the exprs in kb
(defun put-kb (kb &key unintern-symbols)
  (make-comment "Restoring KB from stored state...")
  (let ((old-concepts (cond (unintern-symbols (get-all-concepts)))))
    (mapc #'eval (copy-tree kb))	; Note, includes (reset-kb) which clears the history list [1]
    (cond (unintern-symbols (mapc #'km-unintern (set-difference old-concepts (get-all-concepts)))))
    t))
  
(defun km-unintern (concept) 
  (cond ((and (anonymous-instancep concept) ; steer clear of other possibly shared symbols
	      (null (symbol-plist concept))) ; not used by other s/w
;			      (km-format t "DEBUG: Uninterning ~a~%" concept)
	 (unintern concept *km-package*))))

;;; Thanks to Francis Leboutte for this.
;;; This new version:
;;; - uses km-symbol-plist to make fastsave-kb portable (see comment below)
;;; - produces a more compact file
;;; - has a compile argument: to compile the fkm file.
;;;  Loading the compiled file should be faster. On LispWorks 4.4, fastloading a compiled file
;;;  instead of a fkm file is about 20% faster.
(defun fastsave-kb (file &key (reset-kb t) (compile nil))
  (let ((stream (tell file)))
    (when *using-km-package*
      (print '(in-package :km) stream))
    (let ((*package* (if *using-km-package* (find-package :km) *package*)))
      (when reset-kb
        (print '(reset-kb) stream))
;     (do-objects concept	- No, need the dereferenced list
      (mapc #'(lambda (concept)
        ;; setting the symbol-plist was not safe because a symbol's property list is a global
        ;; resource that can contain information established by unrelated programs - for example
        ;; by the LW compiler (and probably other Lisp compilers).
        ;; (print `(setf (symbol-plist ',concept) ',(symbol-plist concept)) stream)
		(print `(put-list ',concept ',(dereference (km-symbol-plist concept))) stream)
		(print `(km-add-to-kb-object-list ',concept) stream))
;	    (get-all-concepts))
      	    (get-all-objects))
      (mapc #'(lambda (km-parameter)
                (print `(setq ,km-parameter ',(eval km-parameter)) stream))
            (append *km-behavior-parameters* *km-state-parameters*))
      (close stream)
      (format t "~a saved!~%NOTE: Load this file using (fastload-kb ~s), not (load-kb ~s)~%"
              file file file)      
      (when compile
        (compile-file file))
      t)))

;;; This is for Francis, so the default compile option is "t"
(defun faslsave-kb (file &key (reset-kb t) (compile t))
  (fastsave-kb file :reset-kb reset-kb :compile compile))

;;; (fastload-kb "tmp") - this will have KM try extensions .fasl, .fkm, and .km in that order for the most recent
;;; Load fkm-file compiled if it exists and is not out-of-date,
;;; else load fkm-file (source).
;;; force-fkm: t, to load fkm-file (source) anyway.
(defun fastload-kb (fkm-file &key (force-fkm t))		; was nil
  (format t "Fast-loading ~a...~%" (pathname-name fkm-file))
  (let* ((file (if force-fkm
                   (progn (load fkm-file) fkm-file)
                 (load-b fkm-file))))	; load compiled version only if up to date
    (format t "~a loaded!~%" file)))

;;;; Older version
;(defun fastload-kb (file) 
;  (format t "Fast-loading ~a...~%" file)
;  (load file)
;  (format t "~a loaded!~%" file))

;;; Load the compiled file if it exists and is not out-of-date,
;;; else load the (fkm - or lisp) file.
;;; File: a fkm or lisp file.
(defun load-b (file)
  (let ((compiled-file (make-pathname :defaults file
                                      :type (cdr *filename-extensions*))))
    (if (and (probe-file compiled-file)
             (>=  (file-write-date compiled-file)(file-write-date file)))
        (progn 
	  (format t "Lisp-compiled version of this file is more recent, so loading that instead...~%")
	  (load compiled-file) compiled-file)
      (progn (load file) file))))

;;; ======================================================================
;;;	   LOAD NEWEST FUNCTIONS (Thanks to Francis Leboutte)
;;; ======================================================================

;;; load the most recent file among the km, fkm and compiled fkm files.
;;; File: a file name or pathname (with or without the file type - file type doesn't have
;;;  to be specified).
(defun load-newest-kb (file &key
                    (reset-kb nil)
                    verbose with-morphism eval-instances load-patterns)
  (flet ((date (file)
           (if (probe-file file)
               (file-write-date file)
             0)))
    (when reset-kb
      (reset-kb))
    (let* ((km-file (make-pathname :defaults file :type "km"))
           (fkm-file (make-pathname :defaults file :type "fkm"))
           (fasl-file (make-pathname :defaults file :type (cdr *filename-extensions*)))
           (km-file-date (date km-file))
           (fkm-file-date (date fkm-file))
           (fasl-file-date (date fasl-file))
;	   (dummy (km-format t "fasl-file = ~a~%" fasl-file))
           (loaded-file
            (cond ((and (>= fasl-file-date fkm-file-date)
                        (>= fasl-file-date km-file-date))
                   (load fasl-file)
		   (format t "~a loaded!~%" fasl-file))
                  ((>= fkm-file-date km-file-date)
                   (load fkm-file)
		   (format t "~a loaded!~%" fkm-file))		   
                  (t (load-kb km-file
                              :verbose verbose
                              :with-morphism with-morphism
                              :eval-instances eval-instances
                              :load-patterns load-patterns)))))
      (declare (ignore loaded-file))
;      (format t "~a loaded!~%" loaded-file)  - earlier load statements already do a print 
      '#$(t)
      )))

; Done manually now earlier
; (add-lisp&KM-function 'load-newest-kb)

 ;;; ======================================================================
;;;	QUICK LOADING OF FILES WITH ONLY SIMPLE KM STRUCTURES IN
;;; ======================================================================

#|
These simple-loading functions directly access the KB database, rather than through
calls to KM. This simple-loading is limited:
  (i) detecting of redundant assertions by checking for duplicates, rather than subsumees.
 (ii) all slots asssumed multivalued
simpleload-kb will install inverses.
|#

(defun simpleload-kb (km-file &key (install-inversesp t))
  (format t "Simple-loading ~a...~%" km-file)
  (let ( (stream (see km-file)) )
    (loop while (simpleload-expr (case-sensitive-read-km stream nil nil) :install-inversesp install-inversesp))
    (close stream))
  (format t "~a read!~%" km-file))

(defun simpleload-expr (item &key (install-inversesp t))
  (cond ((null item) nil)
	((not (eq (second item) '#$has)) 
	 (report-error 'user-warning "simpleload-kb doesn't know how to process expression ~a! Ignoring it...~%" item) 
	 t)    ; t to continue to next item
	(t (simple-add-slotsvals (first item) (rest (rest item)) :install-inversesp install-inversesp))))

;;; Faster version of frame-io.lisp routine
(defun simple-add-slotsvals (instance add-slotsvals &key (install-inversesp t))
  (let* ( (old-slotsvals (get instance 'own-properties))
	  (new-slotsvals (simple-compute-new-slotsvals instance old-slotsvals add-slotsvals :install-inversesp install-inversesp)) )
    (cond ((and (equal old-slotsvals new-slotsvals)      ; no changes needed
		(not (null add-slotsvals))))
	  (t (cond (new-slotsvals (setf (get instance 'own-properties) new-slotsvals)))))
    (cond ((not (gethash instance *kb-objects*))
	   (setf (gethash instance *kb-objects*) t))))
  instance)

(defun simple-compute-new-slotsvals (instance old-slotsvals add-slotsvals &key (install-inversesp t))
  (cond 
   ((null old-slotsvals) 
    (cond (install-inversesp (mapc #'(lambda (slotvals)
				       (cond ((not (non-inverse-recording-slot (slot-in slotvals)))
					      (simple-add-inverses instance (slot-in slotvals) (vals-in slotvals)))))
				   add-slotsvals)))
    add-slotsvals)
   (t (let* ( (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   (ordered-set-difference add-vals old-vals :test #'equal))
	      (new-vals 	 (append old-vals extra-vals)) )	; simpleer than subsumption checks in frame-io.lisp
	(cond ((and extra-vals install-inversesp (not (non-inverse-recording-slot slot)))
	       (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
(defun simple-add-inverses (instance slot extra-vals)
  (let ( (inv-slot (invert-slot slot)) )	
    (mapc #'(lambda (extra-val)
	      (cond ((and (kb-objectp extra-val)
			  (not (non-inverse-recording-concept extra-val)))
		     (let ( (old-invvals (get-vals extra-val inv-slot)) )
		       (cond ((not (member instance old-invvals))
			      (let ( (old-invslotsvals (get extra-val 'own-properties)) )
;				(km-format t "Doing (setf ~a ~a ~a)~%" extra-val 'own-properties
;					   (update-assoc-list old-invslotsvals 
;							      (make-slotvals inv-slot (cons instance old-invvals))))
				(cond ((not (gethash extra-val *kb-objects*))
				       (setf (gethash extra-val *kb-objects*) t)))
				(setf (get extra-val 'own-properties)
				      (update-assoc-list old-invslotsvals 
							 (make-slotvals inv-slot (cons instance old-invvals)))))))))))
	  extra-vals)))

;;; ======================================================================
;;;		KM VERSION NUMBER CONTROL
;;; ======================================================================

(defun requires-km-version (version-number-str)
  (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
(defun km-version-greater-than (v1 v2)
  (cond 
   ((not (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))
   ((not (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 (let ( (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)
	       (km-format t 
		  "(requires-km-version: Can't check because KM version declaration is not a list of integers)~%")
	       (km-format t "(requires-km-version: Skipping requires-km-version check)~%"))
	      (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
(defun km-version-bits-greater-than (v1-bits v2-bits)
  (cond ((equal v1-bits v2-bits) nil)			; mustn't be the same
        ((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")
(defun load-triples (file)
  (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)

(defun load-triples0 (triples)
  (let ((non-triple (find-if #'(lambda (triple) (not (triplep triple))) triples)))
    (cond 
     (non-triple (report-error 'nodebugger-error "load-triples: Non-triple ~a encountered in file!~%" non-triple))
     (t (let ((instances (remove-duplicates (mapcar #'first triples))))
	  (mapc #'(lambda (instance)
		    (let* ((itriples (remove-if-not #'(lambda (triple) (eq (first triple) instance)) triples))
			   (slots (remove-duplicates (mapcar #'second itriples))))
		      (mapc #'(lambda (slot)
				(let* ((istriples (remove-if-not #'(lambda (triple) (eq (second triple) slot)) itriples))
				       (values (remove-duplicates (mapcar #'third istriples))))
				  (cond ((kb-objectp instance) (km-unique `#$(,INSTANCE has (,SLOT ,VALUES)))) ; [1]
					(t (mapcar #'(lambda (value)
						       (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
(defun minimatch1 (item pattern) (first (minimatch item pattern)))

;;; (find-pattern1 '((a r b) (a r c)) '(a r ?x)) -> b
;;; (find-pattern '((a r b) (a r c)) '(?x r ?y)) -> (a b)
(defun find-pattern1 (list pattern) (first (find-pattern list 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)))

(defun mv-minimatch (item pattern)
  (values-list (minimatch item pattern)))

(defun anonymous-minimatch-varp (var) (member var '(|?ANY| |?any| |?*|)))
(defun wildcard-varp (var) (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)
(defun minimatch (item pattern)
   (cond 
      ((anonymous-minimatch-varp pattern) 't)
      ((var-p pattern) (list item))
      ((and (singletonp pattern) (restvar-p (first pattern))) (list item))
      ((atom pattern)
       (cond ((equal item pattern) 't)))
      ((listp item)
       (cond ((wildcard-varp (first pattern))		; '(1 2 3) '(?* 3)
	      (or (minimatch item (rest pattern))			; ?* = no elements
		  (and item (minimatch (rest item) (rest pattern)))	; ?* = 1 element
		  (and item (minimatch (rest item) pattern))))		; ?* = 2 or more elements
	     (item
	      (let ( (carmatch (minimatch (car item) (car pattern))) )
		(cond (carmatch
		       (join-binds carmatch
				   (minimatch (cdr item) (cdr pattern)))))))))))

(defun join-binds (binds1 binds2)
   (cond ((null binds1) nil)
	 ((null binds2) nil)
         ((equal binds1 't) binds2)
	 ((equal binds2 't) binds1)
	 (t (append binds1 binds2))))

;;; Modified faster version thanks to Adam Farquhar!
;;; Renamed from varp to avoid name clash with Novak's code
;;; Synonymous with km-varp
(defun var-p (var)
  (and (symbolp var)
       (symbol-starts-with var #\?)))

(defun restvar-p (x) 
; (and (symbolp x) (starts-with (string-downcase x) "&rest")) - less efficient
  (member x '(&rest &rest1 &rest2 &rest3 &rest4 &rest5 |&rest| |&rest1| |&rest2| |&rest3| |&rest4| |&rest5|)))

(defun find-pattern (list pattern)
  (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*) =>
    (#'(lambda (slot path) (getval slot path)) 
     (house john)
     (the ?slot of ?expr))
|#
(defun find-handler (expr handler-alist &key (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 (let* ( (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)))
(defun apply-handler (handler) 
  (apply (first handler) (second handler)))

(defun find-and-apply-handler (expr handler-alist &key (fail-mode 'fail))
  (let ( (handler (find-handler expr handler-alist :fail-mode fail-mode)) )
    (cond (handler (apply-handler handler)))))
  
;;; ======================================================================
;;;		SAME, EXCEPT FOR STRINGS
;;; ======================================================================

;;; If :case-sensitivep = nil, then string matches are case-insensitive
(defun string-match1 (item pattern &key case-sensitivep) 
  (first (string-match item pattern :case-sensitivep case-sensitivep)))

(defun mv-string-match (string pattern &key case-sensitivep)
  (values-list (string-match string pattern :case-sensitivep case-sensitivep)))

;;; (string-match "the cat sat" '("the" ?cat "sat")) --> (" cat ")
;;; (string-match "the cat sat" '(?var "the" ?cat "sat")) --> ("" " cat ")
;;; Expand to allow ?any as a variable
;;; (string-match "the cat sat" '(?any " " ?word " " ?any)) --> ("cat")
(defun string-match (string pattern &key case-sensitivep)
  (let ( (pattern-el (first pattern)) )
    (cond ((null pattern) 
	   (cond ((string= string "") t)))
;	  ((member pattern '((&rest) (|&rest|)) :test #'equal) (list string))
	  ((and (singletonp pattern) (restvar-p (first pattern))) (list string))
	  ((stringp pattern-el)
	   (cond 
	    ((and (>= (length string) (length pattern-el))
		  (or (string= string pattern-el :end1 (length pattern-el))
		      (and (not case-sensitivep) 
			   (string= (string-downcase string) (string-downcase pattern-el) :end1 (length pattern-el)))))
	     (string-match (subseq string (length pattern-el))
			   (cdr pattern)
			   :case-sensitivep case-sensitivep))))
	  ((and (anonymous-minimatch-varp pattern-el)
		(singletonp pattern)) t)
	  ((and (var-p pattern-el)
		(singletonp pattern)) (list string))
	  ((and (var-p pattern-el)
		(stringp (second pattern)))
	   (let ((end-string-posn (cond (case-sensitivep (search (second pattern) string))
					(t (search (string-downcase (second pattern)) (string-downcase string))))))
	     (cond (end-string-posn
		    (let ((rest-matches (string-match (subseq string
							      (+ end-string-posn
								 (length (second pattern))))
						      (cddr pattern)
						      :case-sensitivep case-sensitivep)))
		      (cond ((anonymous-minimatch-varp pattern-el) rest-matches)
			    (t (cons-binding (subseq string 0 end-string-posn) rest-matches))))))))
	  (t (format t "ERROR! (string-match ~s ~s) bad syntax!~%"
		     string pattern) nil))))

;;; binding or bindings = nil imply match-failure
(defun cons-binding (binding bindings)
  (cond ((null bindings) nil)
	((null binding) nil)
	((equal bindings 't) (list binding))
	(t (cons binding bindings))))

;;; ======================================================================

;;; (full-match '(a b (c)) '(?a ?b ?c)) -> ((?a . a) (?b . b) (?c . (c)))
;;; (full-match '(a b c d) '(?any ?b &rest)) -> ((?b . b) (&rest . (c d)))
;;; (full-match '(a b (c)) '(?any ?b &rest)) -> ((?b . b) (&rest . ((c))))
;;; (full-match 1 1) -> ((t . t))
;;; (val-of '?b '((?b . b))) -> b
(defun full-match (item pattern &key (bindings *null-bindings*))
   (cond 
      ((anonymous-minimatch-varp pattern) bindings)
      ((var-p pattern) (add-binding pattern item bindings))
;     ((member pattern '((&rest) (|&rest|)) :test #'equal) bindings)
      ((and (singletonp pattern) (restvar-p (first pattern))) (add-binding (first pattern) item bindings))
      ((atom pattern)
       (cond ((equal item pattern) bindings)))
      ((listp item)
       (cond ;((wildcard-varp (first pattern))		; '(1 2 3) '(?* 3)
	     ; (or (full-match item (rest pattern))			; ?* = no elements
	     ;	  (and item (full-match (rest item) (rest pattern)))	; ?* = 1 element
	     ;	  (and item (full-match (rest item) pattern))))		; ?* = 2 or more elements
	     (item
	      (let ((new-bindings (full-match (car item) (car pattern) :bindings bindings)) )
		(cond (new-bindings (full-match (cdr item) (cdr pattern) :bindings new-bindings)))))))))

;;; FILE: strings.lisp

;;; File: strings.lisp
;;; Author: Peter Clark
;;; Date: August 1994
;;; Purpose: String manipulation with Lisp

#|
;;; Also this works nicely!
(let ((stream (see <file>)))
  (prog1
      (loop for item = (read stream nil 'eof-marker) until (eql item 'eof-marker) collect item)
    (cond ((streamp stream) (close stream)))))

OR
      (loop for item = (read stream nil 'eof-marker) until (eql item 'eof-marker) do (print item))

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 'eof-marker)) )
	(cond 
	 ((eql data 'eof-marker) nil)
	 (t (<process-fn> data)
	    t))))))
    (cond ((streamp stream) (close stream)))
    t))

REVISED: Simply do: (apply-to-file-exprs #'process-line "myfile.km")
|#

;;; Read file as lines of strings
(defun apply-to-file-lines (function file)
  (let ( (stream (see file)) )
    (loop until 
	  (not (progn
		 (let* ( (data (read-line stream nil nil)) )
		   (cond 
		    ((null data) nil)
		    (t (apply function (list data))
		       t))))))
    (cond ((streamp stream) (close stream)))
    t))

;;; Read file as sxeprs
(defun apply-to-file-exprs (function file)
  (let ( (stream (see file)) )
    (loop until 
	  (not (progn
		 (let* ( (data (read stream nil 'eof-marker)) )
		   (cond 
		    ((eql data 'eof-marker) nil)
		    (t (apply function (list data))
		       t))))))
    (cond ((streamp stream) (close stream)))
    t))

(defparameter *whitespace-chars* '(#\Space #\Tab #\Newline #\Return #\Linefeed #\Page))
(defparameter *end-of-sentence-chars* '(#\. #\? #\!))
(defparameter *newline-string* (make-string 1 :initial-element '#\Newline))

;;; (a b) -> "(a b)"		       
(defun truncate-string (string &optional (maxlen 60))
  (cond ((not (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"
(defun strip-endchars (string) (subseq string 1 (- (length string) 1)))

;;; t for "A", "B", "C", etc.
(defun uppercase-letterp (word)
  (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
(defun split-at (string substring &key from-end)
  (let ( (start0 (search substring string :from-end from-end)) )
    (cond (start0 (values (subseq string 0 start0)
			  (subseq string (+ start0 (length substring))))))))

;;; Returns a single value = list of two elements, or NIL if no split is possible
(defun split-at1 (string substring &key from-end)
  (let ( (start0 (search substring string :from-end from-end)))
    (cond (start0 (list (subseq string 0 start0)
			(subseq string (+ start0 (length substring))))))))

;;; (splits-at "a + b + c" " + ") -> ("a" "b" "c")
(defun splits-at (string substring)
  (let ( (start0 (search substring string)) )
    (cond (start0 (cons (subseq string 0 start0)
			(splits-at (subseq string (+ start0 (length substring))) substring)))
	  (t (list string)))))

(defun contains (string substring)
  (search substring string))

;;; (right-of "the big cat" "big") -> " cat"
;;; (right-of "foo.xml" "foo") -> ".xml"
(defun right-of (string substring &key from-end)
  (multiple-value-bind 
   (left right)
   (split-at string substring :from-end from-end)
   (declare (ignore left))
   right))

;;; (left-of "the big cat" "big") -> "the "
;;; (left-of "foo.xml" ".xml") -> "foo"
(defun left-of (string substring &key from-end)
  (split-at string substring :from-end from-end))		; just ignore second return value

;;; ASSUMES string has no trailing whitespace
;(defun rightmost-word (string) 
;  (last-el (string-to-list string)))

;;; Revised
(defun rightmost-word (string) (last-word string))

;;; ======================================================================

;;; shorthand
(defun concat (&rest list) (my-concat list))
(defun concat-list  (list) (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"
(defun my-concat (strings)
   (if (< (length strings) call-arguments-limit)
       (apply #'concatenate 'string strings)
     (let ((result (make-string (reduce #'+ (mapcar #'length strings))))
           (start-at 0))
       (dolist (string strings result)
         (replace result string :start1 start-at)
         (incf start-at (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
(defun white-space-p (string &key (whitespace-chars *whitespace-chars*))
  (white-space2-p string 0 (length string) whitespace-chars))

(defun white-space2-p (string n nmax whitespace-chars)
  (cond ((= n nmax))
	((member (char string n) whitespace-chars :test #'char=)
	 (white-space2-p string (+ n 1) nmax whitespace-chars))))
  
;;; ======================================================================
;;; Simpler version of scan-to (below)
;;; ======================================================================

;;; (break-up-at "c:dd>eee:f>" :delimeter-chars '(#\: #\>)) -> ("c" ":" "dd" ">" "eee" ":" "f" ">")
(defun break-up-at (string &key delimeter-chars)
  (break-up-at0 delimeter-chars string 0 0 (length string) 'positive))
    
(defun break-up-at0 (delimeter-chars string m n nmax polarity)
  (cond ((= n nmax) (list (subseq string m n)))		; reached the end.
	(t (let ( (curr-char (char string n)) )
	     (cond ((or (and (eql polarity 'positive) (member curr-char delimeter-chars :test #'char=))
			(and (eql polarity 'negative) (not (member curr-char delimeter-chars :test #'char=))))
		    (cons (subseq string m n)
			  (break-up-at0 delimeter-chars string n n nmax 
					(cond ((eql polarity 'positive) 'negative) (t 'positive)))))
		   (t (break-up-at0 delimeter-chars string m (1+ n) nmax polarity)))))))

;;; ======================================================================
;;;		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 man\" on the mat" :allow-quoted-phrases) -> ("the" "\"cat man\"" "on" "the" "mat")
;;; (string-to-words "the cat_n1 is big" :wordchars '(not whitespace)) -> ("the" "cat_n1" "is" "big")
(defun string-to-words (string &key (wordchars 'alphanum) allow-quoted-phrases)
  (remove-delimeters (string-to-list string :wordchars wordchars :allow-quoted-phrases allow-quoted-phrases)))

;;; 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.
(defun string-to-list (string &key (wordchars 'alphanum) allow-quoted-phrases)
  (scan-to wordchars string 0 0 (length string) :allow-quoted-phrases allow-quoted-phrases))

#| 
Original behavior: Break string up into alternating non-alphanum and alphanum blocks:
   "The cat d34" -> ("" "The" " " "cat" " " "d34")
Revised behavior: Numbers are separated from strings
   "d4mph" -> ("" "d" "" "4" "" "mph")   
   "a1b 34m/h" -> ("" "a" "" "1" "" "b" " " "34" "" "m" "/" "h") 
m = the start of the current chunk
n = the (growing) end of the current chunk
|#
(defun scan-to (delimeter string m n nmax &key allow-quoted-phrases) ; delimeter = when you hit it, end the current chunk
							; (The thing your currently collecting is the NON-delimeter)
  (cond 
   ((= n nmax) (list (subseq string m n))) ; reached the end.
   (t (let ((curr-char (char string n)) ; e.g. "3"
	    (next-char (cond ((< (1+ n) nmax) (char string (1+ n)))))) ; e.g., "."
	(cond 
	      ((and (eq delimeter 'doublequote)
		    allow-quoted-phrases)
	       (cond ((and (char= curr-char #\")
			   (or (null next-char) (is-type next-char 'not-alphanum)))
		      (cond (next-char
			     (cons (subseq string m (1+ n))
				   (scan-to 'alphanum string (1+ n) (+ n 2) nmax 
					    :allow-quoted-phrases allow-quoted-phrases)))
			    (t (list (subseq string m (1+ n))))))
		     (t (scan-to delimeter string m (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases))))
	       ((and (eq delimeter 'alphanum) ; currently scanning whitespace, hit a number
		    (or (digit-char-p curr-char)
; No! "cat" -> "cat" "."     (and (char= curr-char #\.) (or (null next-char) (digit-char-p next-char))))) ; ".3"
			(and (char= curr-char #\.) (not (null next-char)) (digit-char-p next-char)))) ; ".3"
	       (cons (subseq string m n)
		     (scan-to 'not-number string n (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases)))
	      ((and (eq delimeter 'alphanum) ; currently scanning whitepace, hit a letter
		    (alpha-char-p curr-char))
	       (cons (subseq string m n)
		     (scan-to 'not-alpha string n (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases)))
	      ((and (eq delimeter 'alphanum) ; currently scanning whitepace, hit a doublequote
		    allow-quoted-phrases
		    (char= curr-char #\"))
	       (cons (subseq string m n)
		     (scan-to 'doublequote string n (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases)))
	      ((and (eq delimeter 'not-number) ; currently scanning numbers, and immediately hit a letter (no spaces)
		    (alpha-char-p curr-char))
	       (cons (subseq string m n)
		     (cons "" (scan-to 'not-alpha string n (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases))))
	      ((and (eq delimeter 'not-alpha) ; currently scanning letters, and immediately hit a number (no spaces)
		    (or (digit-char-p curr-char)		; e.g., "cat1.2" -> "cat" "1.2"
;			     (and (char= curr-char #\.) (or (null next-char) (digit-char-p next-char))))) ; ".3"
			(and (char= curr-char #\.) (not (null next-char)) (digit-char-p next-char)))) ; ".3"
	       (cons (subseq string m n)
		     (cons "" (scan-to 'not-number string n (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases))))
	      ((and (neq delimeter 'doublequote)
		    (is-type curr-char delimeter)) ; You're at the END of the current text chunk, so stop and change
	       (cons (subseq string m n)
		     (scan-to (invert-type delimeter) string n (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases)))
	      (t (scan-to delimeter string m (1+ n) nmax :allow-quoted-phrases allow-quoted-phrases))))))) ; ELSE continue with the current text chunk

;;; x -> (not x); (not x) -> x
(defun invert-type (type)
  (case type
    (alphanum 'not-alphanum)
    (not-alphanum 'alphanum)
    (not-number 'alphanum)
    (not-alpha 'alphanum)
    (t (format t "ERROR! invert-type: Unrecognized delimeter type ~a!~%" type))))

(defun is-type (char type)
  (case type
    (not-number   (not (is-type char 'number)))
    (not-alpha    (not (is-type char 'alpha)))
    (not-alphanum (not (is-type char 'alphanum)))
    (number   (or (digit-char-p char) (char= char #\.)))
    (alpha    (alpha-char-p char))
    (doublequote  (char= char #\"))
    (alphanum (alphanumericp char))
    (t (format t "ERROR! is-type: Unrecognized delimeter type ~a!~%" type))))

;;; Remove the delimeter components:
(defun remove-delimeters (list)
  (cond ((eql (cdr list) nil) nil)		;;; length 0 or 1
	(t (cons (cadr list) (remove-delimeters (cddr list))))))

;;; ======================================================================
;;; A bit more generic

;;; (new-scan-to "c:dd>eee:f>" :delimeter-chars '(#\: #\>)) -> ("c" ":" "dd" ">" "eee" ":" "f" ">")
(defun new-scan-to (string &key delimeter-chars)
  (new-scan-to0 delimeter-chars string 0 0 (length string) 'positive))
    
(defun new-scan-to0 (delimeter-chars string m n nmax polarity)
  (cond ((= n nmax) (list (subseq string m n)))		; reached the end.
	(t (let ( (curr-char (char string n)) )
	     (cond ((or (and (eql polarity 'positive) (member curr-char delimeter-chars :test #'char=))
			(and (eql polarity 'negative) (not (member curr-char delimeter-chars :test #'char=))))
		    (cons (subseq string m n)
			  (new-scan-to0 delimeter-chars string n n nmax 
					(cond ((eql polarity 'positive) 'negative) (t 'positive)))))
		   (t (new-scan-to0 delimeter-chars string m (1+ n) nmax polarity)))))))

;;; ======================================================================

#|
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.")
|#
(defun list-to-lines (strings &optional reverse-line-bits-so-far)
  (cond ((endp strings) 
	 (cond (reverse-line-bits-so-far (list (concat-list (reverse reverse-line-bits-so-far))))))	; otherwise nil
	(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 "
;; "  " -> ""
(defun remove-leading-whitespace (string) 
  (string-left-trim *whitespace-chars* string))

(defun remove-trailing-whitespace (string) 
  (string-right-trim *whitespace-chars* string))

;;; " a " -> "a"
(defun trim-whitespace (string)
  (string-trim *whitespace-chars* string))

;;; " a " -> t
(defun contains-whitespace (string)
  (some #'(lambda (char) (find char string)) *whitespace-chars*))

(defun whitespace-char (char) (member char *whitespace-chars* :test #'char=))
  
;;; (remove-from-end "A cat..." '(#\. #\? #\! #\; #\ )) -> "A cat"
(defun remove-from-end (string chars)
  (cond ((string= string "") "")
	((member (last-char string) chars :test #'char=)
	 (remove-from-end (trim-from-end string 1) chars))
	(t string)))

;;; ======================================================================

;;; 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.

(defun mapchar (function string) (mapcar function (explode string)))

(defun explode (string)
  (loop for i from 0 to (1- (length string))
	collect (char string i)))

(defun implode (charlist) (coerce charlist 'string))

;;; Range is 32 to 126. So to add N, we do   32 + (C - 32) + N

(defun crypt (string &key (shift 50)) (implode (mapcar #'(lambda (c) (shift-char c :shift shift)) (explode string))))

(defun shift-char (c &key (shift 50)) 
  (let ((new-code (+ (char-code c) shift)))
    (cond ((> new-code 126) (code-char (- new-code 95))) ; 127 -> 32
	  (t (code-char new-code)))))

;;; ======================================================================

;;; copied from Denys, and modified...

(defun break-string-at (string break-char)
  (loop
    for start0 = 0 then end
    and end = 0
    while (setq start0 (position-if-not
		       #'(lambda (char) (char= char break-char))
		       string :start start0))
    do    (setq end (position-if
		     #'(lambda (char) (char= char break-char))
		     string :start start0))
    collecting (subseq string start0 end)
    while end))

;;; ======================================================================

;;; (commaed-list '("a" "b" "c")) -> ("a" ", " "b" ", " "c")
(defun commaed-list (list &optional (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")
(defun spaced-string (list) (concat-list (spaced-list list)))

(defun spaced-list (list)
  (cond ((endp list) nil)
	((singletonp list) list)
	(t (cons (first list) (cons " " (spaced-list (rest list)))))))
  
;;; ----------

(defun  last-char (string) (cond ((string/= string "") (char string (- (length string) 1)))))

; Optimization from Francis Leboutte
;(defun first-char (string) (cond ((string/= string "") (char string 0))))
(defun first-char (string)
  (declare (type simple-string string))
  (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
  (if (string= "" string)
    nil
    (schar string 0)))

;;; (last-but-n-char "cat" 1) -> #\a
(defun last-but-n-char (string n) (cond ((> (length string) n) (char string (- (length string) (+ 1 n))))))

;;; (butlast-char "cats") -> "cat"
(defun butlast-char (string)
  (cond ((string/= string "") (subseq string 0 (1- (length string))))))

(defun butfirst-char (string)
  (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))
(defun ends-with (string substr)
  (and (>= (length string) (length substr))
       (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))
(defun starts-with (string substr)
  (and (>= (length string) (length substr))
       (equal (subseq string 0 (length substr))
		substr)))

;;; Trim n characters from the end of string
(defun trim-from-end (string n)
  (subseq string 0 (- (length string) n)))

(defun trim-from-start (string n)
  (subseq string n (length string)))

(defun symbol-starts-with (symbol char)
  (char= char (char (symbol-name symbol) 0)))

;;; (remove-doublequotes "\"cat\"") -> "cat"
(defun remove-doublequotes (string &key nil-if-missing) (remove-wrapper string "\"" "\"" :nil-if-missing nil-if-missing))

;;; USER(2): (remove-wrapper "(the cat)" "(" ")") -> "the cat"
(defun remove-wrapper (string start0 end &key nil-if-missing)
  (cond ((and (starts-with string start0)
	      (ends-with string end)
	      (>= (length string) (+ (length start0) (length end))))
	 (subseq string (length start0) (- (length string) (length end))))
	((not nil-if-missing) string)))

;;; ----------------------------------------
;;; (double-quotify-list '("cat" "the big cat")) -> '("cat" "\"the big cat\"")
(defun double-quotify-list (words &optional (delim-chars '(#\ )))
  (cond ((stringp words) (double-quotify words delim-chars))
	(t (mapcar #'(lambda (word)
		       (double-quotify word delim-chars))
		   words))))

(defun double-quotify (word &optional (delim-chars '(#\ )))
  (cond ((some #'(lambda (char)
		   (member char delim-chars :test #'char=))
	       (explode word))
	 (add-doublequotes word))
	(t word)))

(defun add-doublequotes (string) (concat "\"" string "\""))

;;; ======================================================================
;;;	Break up a string into pieces, preserving quoted adjacencies
;;; 	and trimming leading/ending white-space.
;;; ======================================================================

#| (break-up (string '|    aadsf a  " " "" "the cat" 1/2 a"b"c  de"f|))
("aadsf" 
 "a" 
 " " 
 "the cat" 
 "1/2" 
 "a" 
 "b" 
 "c" 
 "de" 
 "f")
|#
;;; NOTE: delim-chars MUSTN'T be a '"'
(defun break-up (string &optional (delim-chars '(#\ )))
  (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.
(defun break-up2 (string m n nmax quotep &optional (delim-chars '(#\ )))
  (cond ((and (= n nmax) (= m n)) nil)			  ; ignore trailing white-space
	((= n nmax) (list (subseq string m n)))		  ; reached the end.
	(t (let ( (curr-char (char string n)) )
	     (cond ((and (not quotep)				  ; delimiter following start or a delimeter, so skip
			 (member curr-char delim-chars :test #'char=)
			 (= m n))
		    (break-up2 string (1+ n) (1+ n) nmax quotep delim-chars)) ; ... so ignore it
		   ((and (not quotep)				  ; found a delimiter
			 (member curr-char delim-chars :test #'char=))
		    (cond ((= m n)				  ; nothing between delimeters...
			   (break-up2 string (1+ n) (1+ n) nmax quotep delim-chars))    ; ... so ignore it
			  (t (cons (subseq string m n)
				   (break-up2 string (1+ n) (1+ n) nmax quotep delim-chars)))))
		   ((char= curr-char #\") 			  			; found a '"', so toggle quotep 
		    (break-up2 string m (1+ n) nmax (not 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)
(defun andify (vals)
  (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)))))))

(defun orify (vals)
  (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")
(defun commaify (vals)
  (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\""
(defun add-escapes (string specials)
  (cond ((not (stringp string))
	 (format t "ERROR! add-escapes: argument ~s isn't a string!~%" string))
	(t (concat-list (mapcar #'(lambda (char)
				    (cond ((member char specials) (concat "\\" (string char)))
					  (t (string char))))
				(explode string))))))

;;; (now) -> "22/4/1999 11:49.24"
(defun now ()  
  (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)))

;;; (date) -> "22/4/1999"
(defun date ()  
  (multiple-value-bind 
      (s m h d mo y)
      (get-decoded-time)
    (declare (ignore s m h))
    (format nil "~s/~s/~s" mo d y)))

;;; (common-startstring '("emergency" "emergencies")) -> "emergenc"
(defun common-startstring (strings)
  (cond ((singletonp strings) (first strings))
	(t (subseq (first strings) 0 (loop 
				       for i from 0 to (1- (apply #'min (mapcar #'length strings)))
				       until (some #'(lambda (string) 
						       (char/= (char string i) 
							       (char (first strings) i)))
						   (rest strings))
				       finally (return i))))))

(defun first-word (string)
  (subseq string 0 (or (search " " string) (length string))))

;;; "a b c" -> "c", "a" -> "a" 
(defun last-word (string)
  (subseq string (1+ (or (search " " string :from-end t) -1))))

;;; "cat" -> ""; "big fat cat" -> "big fat"
(defun butlast-word (string)
  (subseq string 0 (or (search " " string :from-end t) 0)))

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

;;; ("cat" "dog") -> ("cat" " " "dog")
(defun insert-spaces (words) 
  (insert-delimeter words " "))				; in utils.lisp

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

(defun ynread (&optional (question-str ""))
  (format t question-str)
  (let ( (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)))))

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

(defun number-stringp (string)  (string-to-number string))

;;; [1] Avoid (string-to-number "9:00") -> Error: Package "9" not found. [file position = 2]
(defun string-to-number (string &key (fail-mode 'fail))
  (cond ((not (stringp string))
	 (format t "; ERROR! (string-to-number ~s) should be given an ascii string as an argument!~%" string))
	((string= string "") nil)
	((let ((string0 (remove #\, string :test #'char=))) ; "3,000" -> "3000"
	   (handler-case
	     (multiple-value-bind
		 (number unread-char-no)
		 (read-from-string string0)
	       (cond ((and (numberp number)
			   (= unread-char-no (length string0)))
		      number)))
	   (error (error)			; [1]
	     (declare (ignore error))))))
	((eql fail-mode 'error)
	 (format t "; ERROR! (string-to-number ~s) should be given an ascii string representation of a number!~%" 
		 string))))

(defun clear-screen () (format t ""))

(defun pause ()
  (format t "Press <RETURN> to continue...")
  (read-line))

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

;;; USER(105): (remove-string "cat" "the cat on")
;;; -> "the  on"
(defun remove-string (bit string)
  (multiple-value-bind
   (left right)
   (split-at string bit)
   (cond (left (concat left (remove-string bit right)))
	 (t string))))

;;; (replace-string "a" "AA" "catat") -> "cAAtAAt"
(defun replace-string (old new string)
  (multiple-value-bind
   (left right)
      (split-at string old)
    (cond (left (concat left new (replace-string old new right)))
	  (t string))))

;;; ======================================================================

#|
SAPIR(133): (read-to "the cat; the mat" '(#\;))
"the cat"
" the mat"
#\;
SAPIR(134): (read-to "the cat; the mat" '(#\@))
"the cat; the mat"
""
nil
SAPIR(136): (read-to "the cat the mat;" '(#\;))
"the cat the mat"
""
#\;
|#
(defun read-to (string chars)
  (let ( (break-point (loop for i from 0 to (1- (length string))
			    until (member (elt string i) chars :test #'char=) 
			    finally (return 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))))))

;;; ----------
;;; Like read-to, except INCLUDE the delimeter char in the 2nd string returned
;;; (read-to2 "cat" '(#\a)) -> THREE values: "c" "at" #\a
;;; (read-to2 "cat" '(#\t)) -> THREE values: "cat" "" #\t
;;; (read-to2 "cat" '(#\x)) -> THREE values: "cat" "" NIL
(defun read-to2 (string chars)
  (let ( (break-point (loop for i from 0 to (1- (length string))
			    until (member (elt string i) chars :test #'char=) 
			    finally (return i))) )
    (cond ((= break-point (length string)) (values string "" nil))
	  (t (values (subseq string 0 break-point)
		     (subseq string break-point (length string))
		     (elt string break-point))))))

;;; ======================================================================

#|
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
|#
(defun list-to-lines-with-size-limit (strings &key (max-document-size 1000))
  (let* ( (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)))

(defun list-to-lines-with-size-limit0 (strings &key (max-document-size 1000) (length-so-far 0) reverse-line-bits-so-far)
  (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))))))	; otherwise nil
	(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" -> TWO values: "_Car" 23
;;; "_Car" -> TWO values: "_Car" NIL
(defun trim-numbers (string &key number-chars (with-warnings t))
  (cond 
   ((string= string "") 
    (cond (with-warnings (format t "; WARNING! Null string passed to trim-numbers!~%")))
    "")
   ((digit-char-p (last-char string))
    (trim-numbers (butlast-char string) 
		  :number-chars (cons (last-char string) number-chars) :with-warnings with-warnings))
   (t (values string (cond (number-chars (string-to-number (implode number-chars))))))))

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

;;; directory can be a directory or include a pattern, e.g., 
;;; (files-in-directory (concat *test-suite-directory* "*.lisp"))
;;; file-directory-p is Allegro-specific, I believe
#+allegro
(defun files-in-directory (directory) 
  (mapcar #'file-namestring (remove-if #'excl::file-directory-p (directory directory))))

#+allegro
(defun subdirectories-in-directory (directory) 
  (mapcar #'file-namestring (remove-if-not #'excl::file-directory-p (directory directory))))

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

;;; Allegro specific
(defun is-user-interrupt (error) (search "Keyboard interrupt" (format nil "~a" error)))

;;; Note: Message must include "Keyboard interrupt" string so the is-user-interrupt text is passed
(defun throw-ctrl-c-error () (error "(Keyboard interrupt from the user)"))

(defun handle-ctrl-c-error (error) (cond ((is-user-interrupt error) (throw-ctrl-c-error))))

;;; ======================================================================

;;; Multiple applications. 
;;; (substitute-strings "aaaaaaa" '(("aa" . "a")) :recursivep t) -> "a"
;;; (substitute-strings "aaaaaaa" '(("aa" . "a")) :recursivep nil) -> "aaaa"
(defun substitute-strings (string alist &key recursivep)
  (cond ((endp alist) string)
	(t (let* ((old-dot-new (first alist))
		  (old (first old-dot-new))
		  (new (rest old-dot-new)))
	     (substitute-strings (substitute-string old new string :recursivep recursivep) (rest alist) :recursivep recursivep)))))

;;; (substitute-string "a" "AA" "a cat is ra") -> "AA cAAt is rAA"
;;; (substitute-string "aa" "a" "aaaaaaa") -> "aaaa"
;;; (substitute-string "aa" "a" "aaaaaaa" :recursivep t) -> "a"
(defun substitute-string (old new string &key recursivep) (concat-list (substitute-string0 old new string :recursivep recursivep)))

(defun substitute-string0 (old new string &key recursivep)
  (let ((pos (search old string)))
    (cond (pos 
	   (cond (recursivep `(,(subseq string 0 pos) 
			       ,@(substitute-string0 old new (concat new (subseq string (+ pos (length old)) (length string))) :recursivep recursivep)))
		 (t `(,(subseq string 0 pos) 
		      ,new 
		      ,@(substitute-string0 old new (subseq string (+ pos (length old)) (length string)))))))
	  (t (list string)))))

;;; ======================================================================  

#|
(fold <string> <n>): Break a long string up after approximately <n> characters,
preferring to break at a space if possible.

(fold "the cat is on the mat in the park in the rainrainrainrainrainrainrain" 10)
"the cat
is on the
mat in
the park
in the
rainrainra
inrainrain
rainrain"
|#  
(defun fold (string0 n)
  (let ((string (trim-whitespace string0)))
    (cond 
     ((<= (length string) n) string)  
     (t (concat-list (insert-delimeter (fold0 string n) *newline-str*))))))
  
(defun fold0 (string n)
  (cond 
   ((<= (length string) n) (list string))
   (t (let ((space-posn (or (position #\  string :end n :from-end t) n)))
	(cons (subseq string 0 space-posn) 
	      (fold0 (remove-leading-whitespace (subseq string space-posn (length string))) n))))))

;;; 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!!

(defun reuse-cons (a b ab)
  (if (and (eql a (car ab))
	   (eql b (cdr ab)))
      ab
      (cons a b)))

(defun variables-in (x)
  (let ((vars nil))
    (labels ((vars-in (x)
	       (cond
		 ((consp x)
		  (vars-in (first x))
		  (vars-in (rest x)))
		 ((var-p x)
		  (pushnew x vars))
		 ((eql x '&rest)
		  (pushnew 'rest vars)))))
      (vars-in x)
      (nreverse vars))))
	       

(defun args-to-symbol (&rest args)
  (intern (string-upcase (format nil "~{~a~}" args)) *km-package*))

(defun add-quote-if-needed (x)
  "Quote X if necessary."
  (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.

(defstruct delay (value nil)(function nil))
(defmacro delay (&rest body)
  `(make-delay :function #'(lambda () . ,body)))
(defun force (x)
  (if (not (delay-p x))
      x
      (progn
	(when (delay-function x)
	  (setf (delay-value x)
		(funcall (delay-function x)))
	  (setf (delay-function x) nil)
	  (delay-value x)))))

;;; Rule Compiler
;;;

(defvar *bindings* nil
  "Alist (pattern-var . binding), used for rule compilation.")


(defun compile-rule (pattern consequent var)
  (let ((*bindings* nil))
    `(lambda (,var)
      ,(compile-expr var pattern consequent))))

(defun compile-rules (rules var)
  "A rules is of the form (pat code) where code may reference vars in pat."
  (reduce
   #'merge-code
   (loop for (pattern consequent) in rules
	 collect (compile-rule pattern consequent var))))

(defun compile-expr (var pattern consequent)
  (cond
    ((assoc pattern *bindings* :test #'eq)
     `(when (equal ,var ,(cdr (assoc pattern *bindings*)))
       ,(force consequent)))
    ((var-p pattern)
     (push (cons pattern var) *bindings*)
     ;; `(let ((,pattern ,var)) ,(force consequent))
     ;; do nothing, the consequent needs to get the bindings and use
     ;; it!
     (force consequent)
     )
    ((atom pattern)
     `(when (eql ,var ,(add-quote-if-needed pattern))
       ,(force consequent)))
    (t
     (compile-list var pattern consequent)
     )))

(defun compile-list (var pattern consequent)
  (let ((L (args-to-symbol var 'l))
	(r (args-to-symbol var 'r)))
    (if (consp pattern)
	(if (equal pattern '(&rest))
	    (progn
	      ;;(push (cons 'rest `(list ,var)) *bindings*)
	      (push (cons 'rest var) *bindings*)
	      (force consequent))
	    `(when (consp ,var)
	      (let ((,L (first ,var))
		    (,R (rest  ,var)))
		,(compile-expr
		  L (first pattern)
		  (delay (compile-expr R (rest pattern) consequent))))))
      `(when (null (cdr ,var))
	     (let ((,L (first ,var)))
	       ,(compile-expr
		 L (first pattern) consequent))))))

(defun mergeable (a b)
  ;; (f x y) (f x z) => (f x (merge y z))
  ;; also handles our when, let (only one element in body)
  (and (listp a) (listp b)
       (= (length a) (length b) 3)
       (equal (first a) (first b))
       (equal (second a) (second b))))

(defun merge-code (a b)
  ;; A and B are pieces of code generated by the pattern
  ;; compiler. Merge them (disjunctively) together.
  (cond
     ((mergeable a b)
      ;; (f x y) (f x z) => (f x (merge y z))
      ;; also handles our when, let (only one element in body)
       (list (first a)
	     (second a)
	     (merge-code (third a) (third b))))

     ((and (consp a) (eql 'or (first a)))
      ;; want to try to merge in with some interesting disjunct if
      ;; possible
      (let ((pos (position-if #'(lambda (x) (mergeable b x)) a)))
	(cond
	  ((null pos)
	   ;; just add b as a disjunct
	   (if (and (consp b) (eql 'or (first b)))
	       `(or ,@(rest a) ,@(rest b))
	       `(or ,@(rest a) ,b)))
	  (t
	   ;; merge b with one of a's disjuncts
	   `(,@(subseq a 0 pos)
	     ,(merge-code (nth pos a) b)
	     ,@(subseq a (1+ pos)))))))
     (t
      `(or ,a ,b))))

;;;
;;; 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 #'dereference x)
      (dereference x)))
|#

; (defparameter *km-handler-function* nil) - now in header.lisp
; no more (defparameter *custom-km-handler-function* nil)

(defun reset-handler-functions ()
  (format t "Compiling KM dispatch mechanism...")
  (setq *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*)))

(defparameter *trace-rules* nil)

(defun trace-rule (rule-pattern fact bindings)
  (format *trace-output*
   "Rule ~s is being applied to ~s with bindings ~s."
    rule-pattern fact bindings))

(defun compile-handlers (handlers &key code-only)
  "Compile the handler-alist Handlers.  If code-only is T, then just
return the code without invoking the compiler on it."
  (if (null handlers)
      (if code-only
          nil
          #'(lambda (fmode target X) (declare (ignore fmode target X)) nil))
      (let ((code
             (reduce
              #'merge-code
              (loop
               for (pattern closure)
               in handlers
               collect
               `(lambda (f-mode target x)
		 (block km-handler .
			,(cddr
			  (compile-rule
			   pattern
			   (delay

; OLD			    `(let ()
;			       (when *trace-rules*
;				(trace-rule ',pattern X (list ,@(bindings-for pattern))))
;			      (return-from km-handler
;				(funcall
;				 ',closure f-mode
;				 ,@(bindings-for pattern)))))

#|NEW|#			   `(return-from km-handler
			       (values
				(funcall
				 #',closure f-mode target
;				 #',closure f-mode
				 ,@(bindings-for pattern))
				',pattern)))

			   'x))))))))
        (if code-only
            code (compile nil code)))))

(defun bindings-for (pattern)
   (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 var-p (var)
  (and (symbolp var)
       (char=
       #\?
       (char (the string (symbol-name (the symbol var))) 0))))
|#

(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.
(defun write-compiled-handlers ()
  (let* ( (anonymous-function (compile-handlers *km-handler-alist* :code-only t))
          (named-function `(defun compiled-km-handler-function (f-mode target x) 
;;; Need to add this manually to compiled-handlers (it gets stripped off here)
;;;                 #+harlequin-pc-lisp (declare (optimize (debug 0)))     ; patch for Lispworks from Francis Leboutte [1]
                             . 
			     ,(rest (rest anonymous-function))))		   ; strip off "(lambda (f-mode x) ..."
	  (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 Francis 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 Francis Leboutte [1]
;;;  (block km-handler
;;;	...
;;;
;;; ==================== START OF MACHINE-GENERATED FILE ====================

(setq *compile-handlers* t)

(defun compiled-km-handler-function (f-mode target x)
   #+harlequin-pc-lisp (declare (optimize (debug 0)))     ; patch for Lispworks from Francis Leboutte [1]  
  (block km-handler
    (or (when (consp x)
          (let ((xl (first x)) (xr (rest x)))
            (or (when (eql xl '|the|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (or (when (eql xrrl '|of|)
                                    (when (consp xrrr)
                                      (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                        (when (eql xrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (fmode0 _target slot frameadd)
                                                                 (declare (ignore _target))
                                                                 (cond ((structured-slotp slot)
                                                                        (follow-multidepth-path (km-int frameadd :fail-mode fmode0) slot '*
                                                                          :fail-mode fmode0))
                                                                       ((pathp slot)
                                                                        (let ((eval-slot (km-unique-int slot :fail-mode 'error)))
                                                                          (km-int `(|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
                                                                                       (km-int frameadd
                                                                                         :fail-mode fmode
                                                                                         :check-for-looping nil)))))
                                                                          (cond ((= *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
                                                                                                (km-int
                                                                                                   `(|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))))))))
                                                             f-mode target xrl xrrrl)
                                                    '(|the| ?slot |of| ?frameadd)))))))
                                  (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (when (eql xrrrl '|of|)
                                        (when (consp xrrrr)
                                          (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                            (when (eql xrrrrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (fmode0 target class slot frameadd)
                                                                     (cond ((structured-slotp slot)
                                                                            (follow-multidepth-path
                                                                               (km-int frameadd
                                                                                 :fail-mode fmode0
                                                                                 :target target
                                                                                 :rewritep t)
                                                                               slot class
                                                                              :fail-mode fmode0))
                                                                           ((pathp slot)
                                                                            (let ((eval-slot (km-unique-int slot :fail-mode 'error)))
                                                                              (km-int `(|the| ,class ,eval-slot |of| ,frameadd)
                                                                                :fail-mode fmode0
                                                                                :target target
                                                                                :rewritep t)))
                                                                           (t
                                                                            (let* ((fmode
                                                                                    (cond ((built-in-aggregation-slot slot) 'fail)
                                                                                          (t fmode0))))
                                                                              (vals-in-class (km-int `(|the| ,slot |of| ,frameadd)
                                                                                               :fail-mode fmode
                                                                                               :target target
                                                                                               :rewritep t)
                                                                                             class)))))
                                                                 f-mode target xrl xrrl xrrrrl)
                                                        '(|the| ?class ?slot |of| ?frameadd)))))))))
                                  (when (eql xrrl '|with|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (fmode target frame slotsvals)
                                                           (declare (ignore fmode target))
                                                           (let ((answer (km-int `(|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))))
                                                       f-mode target xrl xrrr)
                                              '(|the| ?frame |with| &rest)))))))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target frame)
                                                   (declare (ignore fmode target))
                                                   (let ((answer (km-int `(|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))))
                                               f-mode target xrl)
                                      '(|the| ?frame))))))))
                (when (eql xl '|a|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode target class)
                                                   (declare (ignore _fmode))
                                                   (list (create-instance class nil :target target)))
                                               f-mode target xrl)
                                      '(|a| ?class))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (or (when (eql xrrl '|called|)
                                    (when (consp xrrr)
                                      (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                        (or (when (eql xrrrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (_fmode target class tag)
                                                                     (declare (ignore _fmode))
                                                                     (km-setq '*are-some-tags* t)
                                                                     (cond ((km-tagp tag)
                                                                            (list (create-instance class `((|called| ,(val-to-vals tag)))
                                                                                    :target target)))
                                                                           (t
                                                                            (report-error 'user-error
                                                                                          "~a~%    - The tag `~a' must be an atom or a constraint!"
                                                                                          `(|a| ,class |called| ,tag) tag))))
                                                                 f-mode target xrl xrrrl)
                                                        '(|a| ?class |called| ?tag))))
                                            (when (consp xrrrr)
                                              (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                                (when (eql xrrrrl '|with|)
                                                  (return-from km-handler
                                                    (values (funcall #'(lambda (_fmode target 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))
                                                                                         :target target)))
                                                                                  (cond ((am-in-prototype-mode)
                                                                                         (km-int '(|evaluate-paths|))))
                                                                                  (list instance)))))
                                                                     f-mode target xrl xrrrl xrrrrr)
                                                            '(|a| ?class |called| ?tag |with| &rest))))))))))
                                  (when (eql xrrl '|uniquely-called|)
                                    (when (consp xrrr)
                                      (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                        (or (when (eql xrrrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (_fmode target 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)))
                                                                                    :target target)))
                                                                           (t
                                                                            (report-error 'user-error
                                                                                          "~a~%    - The tag `~a' must be an atom or a constraint!"
                                                                                          `(|a| ,class |uniquely-called| ,tag) tag))))
                                                                 f-mode target xrl xrrrl)
                                                        '(|a| ?class |uniquely-called| ?tag))))
                                            (when (consp xrrrr)
                                              (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                                (when (eql xrrrrl '|with|)
                                                  (return-from km-handler
                                                    (values (funcall #'(lambda (_fmode target 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))
                                                                                         :target target)))
                                                                                  (cond ((am-in-prototype-mode)
                                                                                         (km-int '(|evaluate-paths|))))
                                                                                  (list instance)))))
                                                                     f-mode target xrl xrrrl xrrrrr)
                                                            '(|a| ?class |uniquely-called| ?tag |with| &rest))))))))))
                                  (when (eql xrrl '|with|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode target class slotsvals)
                                                           (declare (ignore _fmode))
                                                           (cond ((are-slotsvals slotsvals)
                                                                  (let ((instance
                                                                         (create-instance class
                                                                                          (convert-comments-to-internal-form slotsvals)
                                                                           :target target)))
                                                                    (cond ((am-in-prototype-mode) (km-int '(|evaluate-paths|))))
                                                                    (list instance)))))
                                                       f-mode target xrl xrrr)
                                              '(|a| ?class |with| &rest)))))))))))
                (when (eql xl '|a-prototype|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target class)
                                                   (km-int `(|a-prototype| ,class |with|) :fail-mode fmode :target target :rewritep t))
                                               f-mode target xrl)
                                      '(|a-prototype| ?class))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrl '|with|)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target class slotsvals)
                                                       (declare (ignore _fmode _target))
                                                       (cond ((am-in-local-situation)
                                                              (report-error 'user-error
                                                                            "Can't enter prototype mode when in a Situation!~%"))
                                                             ((am-in-local-theory)
                                                              (report-error 'user-error "Can't enter prototype mode when in a Theory!~%"))
                                                             ((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)
                                                                         :prefix-string *proto-marker-string*
                                                                         :bind-selfp 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*))))
                                                   f-mode target xrl xrrr)
                                          '(|a-prototype| ?class |with| &rest))))))))))
                (when (eql xl '|end-prototype|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target)
                                           (declare (ignore _fmode _target))
                                           (km-setq '*curr-prototype* nil)
                                           (global-situation)
                                           (new-context)
                                           '(|t|))
                                       f-mode target)
                              '(|end-prototype|)))))
                (when (eql xl '|clone|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target expr)
                                               (declare (ignore _fmode _target))
                                               (let ((source (km-unique-int expr :fail-mode 'error)))
                                                 (cond (source (list (clone source))))))
                                           f-mode target xrl)
                                  '(|clone| ?expr)))))))
                (when (eql xl '|evaluate-paths|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (eval-instances) '(|t|)) f-mode target)
                              '(|evaluate-paths|)))))
                (when (eql xl '|default-fluent-status|)
                  (return-from km-handler
                    (values (funcall #'(lambda (_fmode _target rest)
                                         (declare (ignore _fmode _target))
                                         (default-fluent-status (first rest)))
                                     f-mode target xr)
                            '(|default-fluent-status| &rest))))
                (when (eql xl '|must-be-a|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target _class)
                                                   (declare (ignore _fmode _target _class))
                                                   (note-are-constraints)
                                                   nil)
                                               f-mode target xrl)
                                      '(|must-be-a| ?class))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrl '|with|)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target _class slotsvals)
                                                       (declare (ignore _fmode _target _class))
                                                       (are-slotsvals slotsvals)
                                                       (note-are-constraints)
                                                       nil)
                                                   f-mode target xrl xrrr)
                                          '(|must-be-a| ?class |with| &rest))))))))))
                (when (eql xl '|possible-values|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target _values)
                                               (declare (ignore _fmode _target _values))
                                               (note-are-constraints)
                                               nil)
                                           f-mode target xrl)
                                  '(|possible-values| ?values)))))))
                (when (eql xl '|excluded-values|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target _values)
                                               (declare (ignore _fmode _target _values))
                                               (note-are-constraints)
                                               nil)
                                           f-mode target xrl)
                                  '(|excluded-values| ?values)))))))
                (when (eql xl '|mustnt-be-a|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target _class)
                                                   (declare (ignore _fmode _target _class))
                                                   (note-are-constraints)
                                                   nil)
                                               f-mode target xrl)
                                      '(|mustnt-be-a| ?class))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrl '|with|)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target _class slotsvals)
                                                       (declare (ignore _fmode _target _class))
                                                       (are-slotsvals slotsvals)
                                                       (note-are-constraints)
                                                       nil)
                                                   f-mode target xrl xrrr)
                                          '(|mustnt-be-a| ?class |with| &rest))))))))))
                (when (eql xl '<>)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target _val)
                                               (declare (ignore _fmode _target _val))
                                               (note-are-constraints)
                                               nil)
                                           f-mode target xrl)
                                  '(<> ?val)))))))
                (when (eql xl '|no-inheritance|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target))) f-mode target) '(|no-inheritance|)))))
                (when (eql xl '|constraint|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target _expr)
                                               (declare (ignore _fmode _target _expr))
                                               (note-are-constraints)
                                               nil)
                                           f-mode target xrl)
                                  '(|constraint| ?expr)))))))
                (when (eql xl '|set-constraint|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target _expr)
                                               (declare (ignore _fmode _target _expr))
                                               (note-are-constraints)
                                               nil)
                                           f-mode target xrl)
                                  '(|set-constraint| ?expr)))))))
                (when (eql xl '|set-filter|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target _expr)
                                               (declare (ignore _fmode _target _expr))
                                               (note-are-constraints)
                                               nil)
                                           f-mode target xrl)
                                  '(|set-filter| ?expr)))))))
                (when (eql xl '|at-least|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target _n _class)
                                                   (declare (ignore _fmode _target _n _class))
                                                   (note-are-constraints)
                                                   nil)
                                               f-mode target xrl xrrl)
                                      '(|at-least| ?n ?class)))))))))
                (when (eql xl '|at-most|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target _n _class)
                                                   (declare (ignore _fmode _target _n _class))
                                                   (note-are-constraints)
                                                   nil)
                                               f-mode target xrl xrrl)
                                      '(|at-most| ?n ?class)))))))))
                (when (eql xl '|exactly|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target _n _class)
                                                   (declare (ignore _fmode _target _n _class))
                                                   (note-are-constraints)
                                                   nil)
                                               f-mode target xrl xrrl)
                                      '(|exactly| ?n ?class)))))))))
                (when (eql xl '|sanity-check|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (cond (*sanity-checks* (km-int expr :fail-mode fmode :target target)) (t '(|t|))))
                                           f-mode target xrl)
                                  '(|sanity-check| ?expr)))))))
                (when (eql xl '|retain-expr|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (let ((instance (fourth target)) (slot (second target)))
                                                 (cond ((or (null target)
                                                            (notany #'(lambda (isv-explanation)
                                                                        (let ((explanation (explanation-in isv-explanation)))
                                                                          (equal explanation `(|retain-expr| ,expr))))
                                                                    (get-all-explanations instance slot)))
                                                        (km-int expr :fail-mode fmode :target target)))))
                                           f-mode target xrl)
                                  '(|retain-expr| ?expr)))))))
                (when (eql xl '|every|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (or (when (eql xrrl '|has|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target cexpr slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (let ((class (km-unique-int 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)))))
                                                       f-mode target xrl xrrr)
                                              '(|every| ?cexpr |has| &rest))))
                                  (when (eql xrrl '|also-has|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target cexpr slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (let ((class (km-unique-int 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)))))
                                                       f-mode target xrl xrrr)
                                              '(|every| ?cexpr |also-has| &rest))))
                                  (when (eql xrrl '|now-has|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target cexpr slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (let ((class (km-unique-int 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)))))
                                                       f-mode target xrl xrrr)
                                              '(|every| ?cexpr |now-has| &rest))))
                                  (when (eql xrrl '|also-hasnt|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target instance-expr slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (report-error 'user-error
                                                                         "~a:~%Can't use also-hasnt with an \"every\" expression (can only use it with instances, not classes)~%"
                                                                         `(|every| ,instance-expr |also-hasnt| ,@slotsvals)))
                                                       f-mode target xrl xrrr)
                                              '(|every| ?instance-expr |also-hasnt| &rest))))
                                  (when (eql xrrl '|with|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target frame slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (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-on-object-stack existential-expr)))))
                                                       f-mode target xrl xrrr)
                                              '(|every| ?frame |with| &rest))))
                                  (when (eql xrrl '|has-definition|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target cexpr slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (let ((class (km-unique-int 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
                                                                            (desource+decomment (vals-in (assoc '|instance-of| slotsvals0))
                                                                              :delistifyp nil)))
                                                                      (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))))))))
                                                       f-mode target xrl xrrr)
                                              '(|every| ?cexpr |has-definition| &rest))))
                                  (when (eql xrrl '|now-has-definition|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target cexpr slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (let ((class (km-unique-int 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-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
                                                                            (desource+decomment (vals-in (assoc '|instance-of| slotsvals0))
                                                                              :delistifyp nil)))
                                                                      (cond ((not (every #'kb-objectp parents-of-defined-concept))
                                                                             (report-error 'user-error
                                                                                           "~a~%The `instance-of' slot-filler(s) in a now-has-definition must be atomic class name(s) only.~%"
                                                                                           `(|every| ,cexpr |now-has-definition|
                                                                                             ,@slotsvals0)))
                                                                            ((and (null parents-of-defined-concept) slotsvals0)
                                                                             (report-error 'user-error
                                                                                           "~a~%You must specify an `instance-of' slot value for a now-has-definition, pointing to the parent class(es)!~%"
                                                                                           `(|every| ,cexpr |now-has-definition|
                                                                                             ,@slotsvals0)))
                                                                            (t
                                                                             (let ((member-definition-parents
                                                                                    (get-vals class '|instance-of|
                                                                                      :facet 'member-definition)))
                                                                               (cond (member-definition-parents
                                                                                      (unpoint-parents-to-defined-concept class
                                                                                        member-definition-parents 'member-definition))))
                                                                             (mapc #'(lambda (situation)
                                                                                       (mapc #'(lambda (slotvals)
                                                                                                 (let ((slot (slot-in slotvals)))
                                                                                                   (put-vals
                                                                                                    class
                                                                                                    slot
                                                                                                    nil
                                                                                                    :facet
                                                                                                    'member-definition
                                                                                                    :situation
                                                                                                    situation)))
                                                                                             (get-slotsvals class
                                                                                               :situation situation
                                                                                               :facet 'member-definition)))
                                                                                   (all-situations-and-theories))
                                                                             (cond (parents-of-defined-concept
                                                                                    (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))))))))
                                                       f-mode target xrl xrrr)
                                              '(|every| ?cexpr |now-has-definition| &rest)))))))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target frame)
                                                   (km-int `(|every| ,frame |with|) :fail-mode fmode :target target :rewritep t))
                                               f-mode target xrl)
                                      '(|every| ?frame))))))))
                (when (consp xr)
                  (let ((xrl (first xr)) (xrr (rest xr)))
                    (or (when (eql xrl '|has|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target instance-expr slotsvals)
                                                 (declare (ignore _fmode _target))
                                                 (let ((instance (km-unique-int 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) (km-int '(|evaluate-paths|))))
                                                          (list instance)))))
                                             f-mode target xl xrr)
                                    '(?instance-expr |has| &rest))))
                        (when (eql xrl '|also-has|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target instance-expr slotsvals)
                                                 (declare (ignore _fmode _target))
                                                 (let ((instance (km-unique-int 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) (km-int '(|evaluate-paths|))))
                                                          (list instance)))))
                                             f-mode target xl xrr)
                                    '(?instance-expr |also-has| &rest))))
                        (when (eql xrl '|also-hasnt|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target instance-expr slotsvals)
                                                 (declare (ignore _fmode _target))
                                                 (let ((instance (km-unique-int 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)
                                                          (mapc #'(lambda (slotvals)
                                                                    (let ((slot (slot-in slotvals)) (vals (vals-in slotvals)))
                                                                      (mapc #'(lambda (val) (delete-val instance slot val)) vals)))
                                                                slotsvals)
                                                          (un-done instance)
                                                          (list instance)))))
                                             f-mode target xl xrr)
                                    '(?instance-expr |also-hasnt| &rest))))
                        (when (eql xrl '|now-has|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target instance-expr slotsvals)
                                                 (declare (ignore _fmode _target))
                                                 (let ((instance (km-unique-int 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)
                                                          (un-done instance)
                                                          (classify instance)
                                                          (list instance)))))
                                             f-mode target xl xrr)
                                    '(?instance-expr |now-has| &rest))))
                        (when (eql xrl '&&)
                          (return-from km-handler
                            (values (funcall #'(lambda (fmode target xs rest)
                                                 (declare (ignore fmode))
                                                 (lazy-unify-&-expr `(,xs && ,@rest) :fail-mode 'error :joiner '&& :target target))
                                             f-mode target xl xrr)
                                    '(?xs && &rest))))
                        (when (eql xrl '&)
                          (return-from km-handler
                            (values (funcall #'(lambda (fmode target x rest)
                                                 (declare (ignore fmode))
                                                 (lazy-unify-&-expr `(,x & ,@rest) :fail-mode 'error :joiner '& :target target))
                                             f-mode target xl xrr)
                                    '(?x & &rest))))
                        (when (eql xrl '===)
                          (return-from km-handler
                            (values (funcall #'(lambda (fmode target xs rest)
                                                 (declare (ignore fmode))
                                                 (lazy-unify-&-expr `(,xs === ,@rest) :fail-mode 'error :joiner '=== :target target))
                                             f-mode target xl xrr)
                                    '(?xs === &rest))))
                        (when (eql xrl '==)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target x y)
                                                       (declare (ignore fmode))
                                                       (lazy-unify-&-expr `(,x == ,y) :fail-mode 'error :joiner '== :target target))
                                                   f-mode target xl xrrl)
                                          '(?x == ?y)))))))
                        (when (eql xrl '/==)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target x y)
                                                       (declare (ignore fmode target))
                                                       (let ((xv (km-unique-int x :fail-mode 'error))
                                                             (yv (km-unique-int 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) (km-int `(,xv |has| (/== (,yv))) :fail-mode 'error))
                                                               ((kb-objectp yv) (km-int `(,yv |has| (/== (,xv))) :fail-mode 'error))
                                                               ('(|t|)))))
                                                   f-mode target xl xrrl)
                                          '(?x /== ?y)))))))
                        (when (eql xrl '&&!)
                          (return-from km-handler
                            (values (funcall #'(lambda (fmode target xs rest)
                                                 (declare (ignore fmode))
                                                 (lazy-unify-&-expr `(,xs &&! ,@rest) :fail-mode 'error :joiner '&&! :target target))
                                             f-mode target xl xrr)
                                    '(?xs &&! &rest))))
                        (when (eql xrl '&!)
                          (return-from km-handler
                            (values (funcall #'(lambda (fmode target x rest)
                                                 (declare (ignore fmode))
                                                 (lazy-unify-&-expr `(,x &! ,@rest) :fail-mode 'error :joiner '&! :target target))
                                             f-mode target xl xrr)
                                    '(?x &! &rest))))
                        (when (eql xrl '&?)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode target x y)
                                                       (declare (ignore _fmode target))
                                                       (cond ((null x) '(|t|))
                                                             ((null y) '(|t|))
                                                             ((existential-exprp y)
                                                              (let ((xf (km-unique-int x)))
                                                                (cond ((null xf) '(|t|)) ((unifiable-with-existential-expr xf y) '(|t|)))))
                                                             ((existential-exprp x)
                                                              (let ((yf (km-unique-int y)))
                                                                (cond ((null yf) '(|t|)) ((unifiable-with-existential-expr yf x) '(|t|)))))
                                                             (t
                                                              (let ((xv (km-unique-int x)))
                                                                (cond ((null xv) '(|t|))
                                                                      (t
                                                                       (let ((yv (km-unique-int y)))
                                                                         (cond ((null yv) '(|t|)) ((try-lazy-unify xv yv) '(|t|))))))))))
                                                   f-mode target xl xrrl)
                                          '(?x &? ?y)))))))
                        (when (eql xrl '&+?)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode target x y)
                                                       (declare (ignore _fmode target))
                                                       (cond ((existential-exprp y)
                                                              (let ((xf (km-unique-int x)))
                                                                (cond ((null xf) '(|t|))
                                                                      ((unifiable-with-existential-expr xf y :classes-subsumep t)
                                                                       '(|t|)))))
                                                             ((existential-exprp x)
                                                              (let ((yf (km-unique-int y)))
                                                                (cond ((null yf) '(|t|))
                                                                      ((unifiable-with-existential-expr yf x :classes-subsumep t)
                                                                       '(|t|)))))
                                                             (t
                                                              (let ((xv (km-unique-int x)))
                                                                (cond ((null xv) '(|t|))
                                                                      (t
                                                                       (let ((yv (km-unique-int y)))
                                                                         (cond ((null yv) '(|t|))
                                                                               ((try-lazy-unify xv yv :classes-subsumep t) '(|t|))))))))))
                                                   f-mode target xl xrrl)
                                          '(?x &+? ?y)))))))
                        (when (eql xrl '&+)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(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)))))
                                                   f-mode target xl xrrl)
                                          '(?x &+ ?y)))))))
                        (when (eql xrl '&+!)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target x y)
                                                       (cond ((km-int `(,x &+? ,y) :target target :fail-mode fmode)
                                                              (km-int `(,x &! ,y) :target target :fail-mode 'error))
                                                             ((eq fmode 'error)
                                                              (report-error 'user-error "Unification (~a &+! ~a) failed!~%" x y))))
                                                   f-mode target xl xrrl)
                                          '(?x &+! ?y)))))))
                        (when (eql xrl '=)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (or (when (eql xrrr 'nil)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (fmode target x y)
                                                           (declare (ignore target))
                                                           (let ((xv (km-int x :fail-mode fmode)) (yv (km-int y :fail-mode fmode)))
                                                             (cond ((km-set-equal (dereference xv) yv) '(|t|)))))
                                                       f-mode target xl xrrl)
                                              '(?x = ?y))))
                                  (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (when (eql xrrrl '+/-)
                                        (when (consp xrrrr)
                                          (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                            (or (when (eql xrrrrr 'nil)
                                                  (return-from km-handler
                                                    (values (funcall #'(lambda (_fmode _target x y z)
                                                                         (declare (ignore _fmode _target))
                                                                         (let ((xval (km-unique-int x :fail-mode 'error))
                                                                               (yval (km-unique-int y :fail-mode 'error))
                                                                               (zval (km-unique-int z :fail-mode 'error)))
                                                                           (cond ((and (numberp xval) (numberp yval) (numberp zval))
                                                                                  (cond ((<= (abs (- xval yval)) (abs zval)) '(|t|)))))))
                                                                     f-mode target xl xrrl xrrrrl)
                                                            '(?x = ?y +/- ?z))))
                                                (when (consp xrrrrr)
                                                  (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                    (when (eql xrrrrrl '%)
                                                      (when (eql xrrrrrr 'nil)
                                                        (return-from km-handler
                                                          (values (funcall #'(lambda (_fmode _target x y z)
                                                                               (declare (ignore _fmode _target))
                                                                               (let ((xval (km-unique-int x :fail-mode 'error))
                                                                                     (yval (km-unique-int y :fail-mode 'error))
                                                                                     (zval (km-unique-int 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|)))))))
                                                                           f-mode target xl xrrl xrrrrl)
                                                                  '(?x = ?y +/- ?z %)))))))))))))))))
                        (when (eql xrl '/=)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target x y)
                                                       (declare (ignore target))
                                                       (let ((xv (km-int x :fail-mode fmode)) (yv (km-int y :fail-mode fmode)))
                                                         (cond ((not (km-set-equal (dereference xv) yv)) '(|t|)))))
                                                   f-mode target xl xrrl)
                                          '(?x /= ?y)))))))
                        (when (eql xrl '|has-definition|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target instance-expr slotsvals)
                                                 (declare (ignore _fmode _target))
                                                 (let ((instance (km-unique-int 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 (desource+decomment slotsvals))
                                                                 (parents-of-defined-concept (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))))))))
                                             f-mode target xl xrr)
                                    '(?instance-expr |has-definition| &rest))))
                        (when (eql xrl '|now-has-definition|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target instance-expr slotsvals)
                                                 (declare (ignore _fmode _target))
                                                 (let ((instance (km-unique-int 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 |now-has-definition| ,@slotsvals)
                                                                        instance-expr))
                                                         ((are-slotsvals slotsvals)
                                                          (let* ((slotsvals0 (desource+decomment slotsvals))
                                                                 (parents-of-defined-concept (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 now-has-definition must be atomic class name(s) only.~%"
                                                                                 `(,instance-expr |now-has-definition| ,@slotsvals0)))
                                                                  ((and (null parents-of-defined-concept) slotsvals0)
                                                                   (report-error 'user-error
                                                                                 "~a~%You must specify an `instance-of' slot value for a now-has-definition, pointing to the parent class(es)!~%"
                                                                                 `(,instance-expr |now-has-definition| ,@slotsvals0)))
                                                                  (t
                                                                   (let ((own-definition-parents
                                                                          (get-vals instance '|instance-of| :facet 'own-definition)))
                                                                     (cond (own-definition-parents
                                                                            (unpoint-parents-to-defined-concept instance
                                                                              own-definition-parents 'own-definition))))
                                                                   (mapc #'(lambda (situation)
                                                                             (mapc #'(lambda (slotvals)
                                                                                       (let ((slot (slot-in slotvals))
                                                                                             (vals (vals-in slotvals)))
                                                                                         (uninstall-inverses instance slot vals situation)
                                                                                         (put-vals instance slot nil
                                                                                           :facet 'own-definition
                                                                                           :situation situation)))
                                                                                   (get-slotsvals instance
                                                                                     :situation situation
                                                                                     :facet 'own-definition)))
                                                                         (all-situations-and-theories))
                                                                   (cond (parents-of-defined-concept
                                                                          (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))))))))
                                             f-mode target xl xrr)
                                    '(?instance-expr |now-has-definition| &rest))))
                        (when (eql xrl '>)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target x y)
                                                       (declare (ignore _fmode _target))
                                                       (let ((xval (km-unique-int x :fail-mode 'error))
                                                             (yval (km-unique-int y :fail-mode 'error)))
                                                         (cond ((and (numberp xval) (numberp yval)) (cond ((> xval yval) '(|t|)))))))
                                                   f-mode target xl xrrl)
                                          '(?x > ?y)))))))
                        (when (eql xrl '<)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target x y)
                                                       (declare (ignore _fmode _target))
                                                       (let ((xval (km-unique-int x :fail-mode 'error))
                                                             (yval (km-unique-int y :fail-mode 'error)))
                                                         (cond ((and (numberp xval) (numberp yval)) (cond ((< xval yval) '(|t|)))))))
                                                   f-mode target xl xrrl)
                                          '(?x < ?y)))))))
                        (when (eql xrl '>=)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target x y)
                                                       (declare (ignore _fmode _target))
                                                       (let ((xval (km-unique-int x :fail-mode 'error))
                                                             (yval (km-unique-int y :fail-mode 'error)))
                                                         (cond ((and (numberp xval) (numberp yval)) (cond ((>= xval yval) '(|t|)))))))
                                                   f-mode target xl xrrl)
                                          '(?x >= ?y)))))))
                        (when (eql xrl '<=)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target x y)
                                                       (declare (ignore _fmode _target))
                                                       (let ((xval (km-unique-int x :fail-mode 'error))
                                                             (yval (km-unique-int y :fail-mode 'error)))
                                                         (cond ((and (numberp xval) (numberp yval)) (cond ((<= xval yval) '(|t|)))))))
                                                   f-mode target xl xrrl)
                                          '(?x <= ?y)))))))
                        (when (eql xrl '|and|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target x rest)
                                                 (declare (ignore _fmode _target))
                                                 (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)) (km-int (subst xx yy rest)))
                                                                ((km-varp xx) (km-int (subst (vals-to-val (km-int yy)) xx rest)))
                                                                ((km-varp yy) (km-int (subst (vals-to-val (km-int xx)) yy rest)))
                                                                ((and (lazy-unify-&-expr `(,xx == yy) :fail-mode 'error :joiner '==)
                                                                      (km-int rest))))))
                                                       (t (and (km-int x) (km-int rest)))))
                                             f-mode target xl xrr)
                                    '(?x |and| &rest))))
                        (when (eql xrl '|or|)
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target x y)
                                                 (declare (ignore _fmode _target))
                                                 (or (and (not (on-goal-stackp x)) (km-int x)) (km-int y)))
                                             f-mode target xl xrr)
                                    '(?x |or| &rest))))
                        (when (eql xrl '|is-subsumed-by|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target x y)
                                                       (km-int `(,y |subsumes| ,x) :fail-mode fmode :target target :rewritep t))
                                                   f-mode target xl xrrl)
                                          '(?x |is-subsumed-by| ?y)))))))
                        (when (eql xrl '|subsumes|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target x y)
                                                       (declare (ignore _fmode _target))
                                                       (let ((yv (km-int y)))
                                                         (cond ((null yv) '(|t|))
                                                               (t
                                                                (let ((xv (km-int x)))
                                                                  (cond ((and (not (null xv)) (subsumes xv yv)) '(|t|))))))))
                                                   f-mode target xl xrrl)
                                          '(?x |subsumes| ?y)))))))
                        (when (eql xrl '|is-covered-by|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target x y)
                                                       (km-int `(,y |covers| ,x) :fail-mode fmode :target target :rewritep t))
                                                   f-mode target xl xrrl)
                                          '(?x |is-covered-by| ?y)))))))
                        (when (eql xrl '|covers|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target x y)
                                                       (km-int `(,y |isa| ,x) :fail-mode fmode :target target :rewritep t))
                                                   f-mode target xl xrrl)
                                          '(?x |covers| ?y)))))))
                        (when (eql xrl '|isa|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target y x)
                                                       (declare (ignore _fmode _target))
                                                       (let* ((yvals (km-int 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 (km-int 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|))))))))
                                                   f-mode target xl xrrl)
                                          '(?y |isa| ?x)))))))
                        (when (eql xrl '|is|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target x y)
                                                       (declare (ignore _fmode _target))
                                                       (let ((xv (km-unique-int x)))
                                                         (cond ((null xv) nil)
                                                               (t
                                                                (let ((yv (km-unique-int y)))
                                                                  (cond ((and (not (null yv)) (is xv yv)) '(|t|))))))))
                                                   f-mode target xl xrrl)
                                          '(?x |is| ?y)))))))
                        (when (eql xrl '|includes|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target xs y)
                                                       (declare (ignore _fmode _target))
                                                       (let ((xs-vals (km-int xs)) (y-val (km-unique-int y)))
                                                         (cond ((member y-val (dereference xs-vals) :test #'equal) '(|t|)))))
                                                   f-mode target xl xrrl)
                                          '(?xs |includes| ?y)))))))
                        (when (eql xrl '|is-superset-of|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target xs ys)
                                                       (declare (ignore _fmode _target))
                                                       (let ((xs-vals (km-int xs)) (ys-vals (km-int ys)))
                                                         (cond ((subsetp ys-vals (dereference xs-vals) :test #'equal) '(|t|)))))
                                                   f-mode target xl xrrl)
                                          '(?xs |is-superset-of| ?ys)))))))
                        (when (eql xrl '|append|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target seq-expr1 seq-expr2)
                                                       (declare (ignore _fmode _target))
                                                       (let* ((seq1 (km-unique-int seq-expr1))
                                                              (seq2 (km-unique-int 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)))))
                                                   f-mode target xl xrrl)
                                          '(?seq-expr1 |append| ?seq-expr2)))))))
                        (when (eql xrl '|called|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode _target expr tag)
                                                       (declare (ignore _target))
                                                       (let* ((vals (km-int 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 (km-int `(|the| |called| |of| ,val))
                                                                                                (km-int
                                                                                                   `(|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)))))
                                                   f-mode target xl xrrl)
                                          '(?expr |called| ?tag)))))))
                        (when (eql xrl '|uniquely-called|)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target expr tag)
                                                       (km-int `(,expr |called| ,tag) :fail-mode fmode :target target :rewritep t))
                                                   f-mode target xl xrrl)
                                          '(?expr |uniquely-called| ?tag)))))))
                        (when (eql xrl '^)
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (or (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (or (when (eql xrrrl '^)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x ^ ,y) ^ ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x ^ ?y ^ &rest))))
                                          (when (eql xrrrl '+)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x ^ ,y) + ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x ^ ?y + &rest))))
                                          (when (eql xrrrl '-)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x ^ ,y) - ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x ^ ?y - &rest))))
                                          (when (eql xrrrl '/)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x ^ ,y) / ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x ^ ?y / &rest))))
                                          (when (eql xrrrl '*)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x ^ ,y) * ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x ^ ?y * &rest)))))))
                                  (when (eql xrrr 'nil)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (fmode target expr1 expr2)
                                                           (let ((x (km-unique-int expr1 :fail-mode fmode :target target :rewritep t))
                                                                 (y (km-unique-int expr2 :fail-mode fmode :target target :rewritep t)))
                                                             (cond ((and (numberp x) (numberp y)) (list (expt x y))))))
                                                       f-mode target xl xrrl)
                                              '(?expr1 ^ ?expr2))))))))
                        (when (eql xrl '/)
                          (or (when (consp xrr)
                                (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                  (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (or (when (eql xrrrl '+)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x / ,y) + ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x / ?y + &rest))))
                                          (when (eql xrrrl '-)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x / ,y) - ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x / ?y - &rest))))
                                          (when (eql xrrrl '/)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x / ,y) / ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x / ?y / &rest))))
                                          (when (eql xrrrl '*)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x / ,y) * ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x / ?y * &rest)))))))))
                              (return-from km-handler
                                (values (funcall #'(lambda (fmode target expr rest)
                                                     (let ((x (km-unique-int expr :fail-mode fmode :target target :rewritep t))
                                                           (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)))
                                                       (cond ((and (numberp x) (numberp y))
                                                              (cond ((and (zerop x) (zerop y) (list 1)))
                                                                    ((zerop x) (list 0))
                                                                    ((zerop y) (list *infinity*))
                                                                    ((and (numberp x) (numberp y)) (list (/ x y))))))))
                                                 f-mode target xl xrr)
                                        '(?expr / &rest)))))
                        (when (eql xrl '*)
                          (or (when (consp xrr)
                                (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                  (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (or (when (eql xrrrl '+)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x * ,y) + ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x * ?y + &rest))))
                                          (when (eql xrrrl '-)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x * ,y) - ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x * ?y - &rest))))
                                          (when (eql xrrrl '/)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x * ,y) / ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x * ?y / &rest)))))))))
                              (return-from km-handler
                                (values (funcall #'(lambda (fmode target expr rest)
                                                     (let ((x (km-unique-int expr :fail-mode fmode :target target :rewritep t))
                                                           (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)))
                                                       (cond ((and (numberp x) (numberp y)) (list (* x y))))))
                                                 f-mode target xl xrr)
                                        '(?expr * &rest)))))
                        (when (eql xrl '-)
                          (or (when (consp xrr)
                                (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                  (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (or (when (eql xrrrl '-)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x - ,y) - ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x - ?y - &rest))))
                                          (when (eql xrrrl '+)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fm tg x y rest)
                                                                   (declare (ignore tg))
                                                                   (km-int `((,x - ,y) + ,@rest) :fail-mode fm))
                                                               f-mode target xl xrrl xrrrr)
                                                      '(?x - ?y + &rest)))))))))
                              (return-from km-handler
                                (values (funcall #'(lambda (fmode target expr rest)
                                                     (let ((x (km-unique-int expr :fail-mode fmode :target target :rewritep t))
                                                           (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)))
                                                       (cond ((and (numberp x) (numberp y)) (list (- x y))))))
                                                 f-mode target xl xrr)
                                        '(?expr - &rest)))))
                        (when (eql xrl '+)
                          (or (when (consp xrr)
                                (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                  (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (when (eql xrrrl '-)
                                        (return-from km-handler
                                          (values (funcall #'(lambda (fm tg x y rest)
                                                               (declare (ignore tg))
                                                               (km-int `((,x + ,y) - ,@rest) :fail-mode fm))
                                                           f-mode target xl xrrl xrrrr)
                                                  '(?x + ?y - &rest))))))))
                              (return-from km-handler
                                (values (funcall #'(lambda (fmode target expr rest)
                                                     (let ((x (km-unique-int expr :fail-mode fmode :target target :rewritep t))
                                                           (y (km-unique-int rest :fail-mode fmode :target target :rewritep t)))
                                                       (cond ((and (numberp x) (numberp y)) (list (+ x y))))))
                                                 f-mode target xl xrr)
                                        '(?expr + &rest))))))))
                (when (eql xl '|in-theory|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target theory-expr)
                                                   (declare (ignore _fmode _target))
                                                   (in-theory theory-expr))
                                               f-mode target xrl)
                                      '(|in-theory| ?theory-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target theory-expr km-expr)
                                                       (declare (ignore _fmode _target))
                                                       (in-theory theory-expr km-expr))
                                                   f-mode target xrl xrrl)
                                          '(|in-theory| ?theory-expr ?km-expr))))))))))
                (when (eql xl '|hide-theory|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target theory-expr)
                                               (declare (ignore _fmode _target))
                                               (mapc #'hide-theory (km-int theory-expr))
                                               (cond ((visible-theories)) (t '(|t|))))
                                           f-mode target xrl)
                                  '(|hide-theory| ?theory-expr)))))))
                (when (eql xl '|see-theory|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target theory-expr)
                                               (declare (ignore _fmode _target))
                                               (mapc #'see-theory (km-int theory-expr))
                                               (visible-theories))
                                           f-mode target xrl)
                                  '(|see-theory| ?theory-expr)))))))
                (when (eql xl '|end-theory|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (in-situation *global-situation*))
                                       f-mode target)
                              '(|end-theory|)))))
                (when (eql xl '|visible-theories|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (visible-theories)) f-mode target)
                              '(|visible-theories|)))))
                (when (eql xl '|in-situation|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target situation-expr)
                                                   (declare (ignore _fmode _target))
                                                   (in-situation situation-expr))
                                               f-mode target xrl)
                                      '(|in-situation| ?situation-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (or (when (consp xrrl)
                                    (let ((xrrll (first xrrl)) (xrrlr (rest xrrl)))
                                      (when (eql xrrll '|the|)
                                        (when (consp xrrlr)
                                          (let ((xrrlrl (first xrrlr)) (xrrlrr (rest xrrlr)))
                                            (when (consp xrrlrr)
                                              (let ((xrrlrrl (first xrrlrr)) (xrrlrrr (rest xrrlrr)))
                                                (when (eql xrrlrrl '|of|)
                                                  (when (consp xrrlrrr)
                                                    (let ((xrrlrrrl (first xrrlrrr)) (xrrlrrrr (rest xrrlrrr)))
                                                      (when (eql xrrlrrrr 'nil)
                                                        (when (eql xrrr 'nil)
                                                          (return-from km-handler
                                                            (values (funcall #'(lambda (_fmode _target situation slot frame)
                                                                                 (declare (ignore _fmode _target))
                                                                                 (cond ((and (kb-objectp situation)
                                                                                             (isa situation '|Situation|)
                                                                                             (already-done frame slot))
                                                                                        (remove-constraints (get-vals
                                                                                                             frame
                                                                                                             slot
                                                                                                             :situation
                                                                                                             (target-situation
                                                                                                              situation
                                                                                                              frame
                                                                                                              slot))))
                                                                                       (t
                                                                                        (in-situation situation
                                                                                                      `(|the| ,slot |of| ,frame)))))
                                                                             f-mode target xrl xrrlrl xrrlrrrl)
                                                                    '(|in-situation| ?situation (|the| ?slot |of| ?frame))))))))))))))))
                                  (when (eql xrrr 'nil)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target situation-expr km-expr)
                                                           (declare (ignore _fmode _target))
                                                           (in-situation situation-expr km-expr))
                                                       f-mode target xrl xrrl)
                                              '(|in-situation| ?situation-expr ?km-expr)))))))))))
                (when (eql xl '|end-situation|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (in-situation *global-situation*))
                                       f-mode target)
                              '(|end-situation|)))))
                (when (eql xl '|global-situation|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (in-situation *global-situation*))
                                       f-mode target)
                              '(|global-situation|)))))
                (when (eql xl '|new-situation|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (new-situation)) f-mode target)
                              '(|new-situation|)))))
                (when (eql xl '|do|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target action-expr)
                                                   (declare (ignore _fmode _target))
                                                   (list (do-action action-expr)))
                                               f-mode target xrl)
                                      '(|do| ?action-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target action-expr next-situation)
                                                       (declare (ignore _fmode _target))
                                                       (cond ((not (instance-of next-situation '|Situation|))
                                                              (report-error 'user-error
                                                                            "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%"
                                                                            action-expr next-situation next-situation))
                                                             (t (list (do-action action-expr :next-situation next-situation)))))
                                                   f-mode target xrl xrrl)
                                          '(|do| ?action-expr ?next-situation))))))))))
                (when (eql xl '|do-and-next|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target action-expr)
                                                   (declare (ignore _fmode _target))
                                                   (list (do-action action-expr :change-to-next-situation t)))
                                               f-mode target xrl)
                                      '(|do-and-next| ?action-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target action-expr next-situation)
                                                       (declare (ignore _fmode _target))
                                                       (cond ((not (instance-of next-situation '|Situation|))
                                                              (report-error 'user-error
                                                                            "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%"
                                                                            action-expr next-situation next-situation))
                                                             (t
                                                              (list (do-action action-expr
                                                                      :next-situation next-situation
                                                                      :change-to-next-situation t)))))
                                                   f-mode target xrl xrrl)
                                          '(|do-and-next| ?action-expr ?next-situation))))))))))
                (when (eql xl '|try-do|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target action-expr)
                                                   (declare (ignore _fmode _target))
                                                   (list (do-action action-expr :test-or-assert-pcs 'test)))
                                               f-mode target xrl)
                                      '(|try-do| ?action-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target action-expr next-situation)
                                                       (declare (ignore _fmode _target))
                                                       (cond ((not (instance-of next-situation '|Situation|))
                                                              (report-error 'user-error
                                                                            "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%"
                                                                            action-expr next-situation next-situation))
                                                             (t
                                                              (list (do-action action-expr
                                                                      :next-situation next-situation
                                                                      :test-or-assert-pcs 'test)))))
                                                   f-mode target xrl xrrl)
                                          '(|try-do| ?action-expr ?next-situation))))))))))
                (when (eql xl '|try-do-and-next|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target action-expr)
                                                   (declare (ignore _fmode _target))
                                                   (list (do-action action-expr :change-to-next-situation t :test-or-assert-pcs 'test)))
                                               f-mode target xrl)
                                      '(|try-do-and-next| ?action-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target action-expr next-situation)
                                                       (declare (ignore _fmode _target))
                                                       (cond ((not (instance-of next-situation '|Situation|))
                                                              (report-error 'user-error
                                                                            "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%"
                                                                            action-expr next-situation next-situation))
                                                             (t
                                                              (list (do-action action-expr
                                                                      :next-situation next-situation
                                                                      :change-to-next-situation t
                                                                      :test-or-assert-pcs 'test)))))
                                                   f-mode target xrl xrrl)
                                          '(|try-do-and-next| ?action-expr ?next-situation))))))))))
                (when (eql xl '|do-concurrently|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target action-expr)
                                                   (declare (ignore _fmode _target))
                                                   (let* ((actions (km-int action-expr))
                                                          (next-situation (km-unique-int `(|do| ,(first actions)))))
                                                     (mapc #'(lambda (action) (km-int `(|do| ,action ,next-situation))) (rest actions))
                                                     (list next-situation)))
                                               f-mode target xrl)
                                      '(|do-concurrently| ?action-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target action-expr next-situation)
                                                       (declare (ignore _fmode _target))
                                                       (cond ((not (instance-of next-situation '|Situation|))
                                                              (report-error 'user-error
                                                                            "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%"
                                                                            action-expr next-situation next-situation))
                                                             (t
                                                              (let ((actions (km-int action-expr)))
                                                                (mapc #'(lambda (action) (km-int `(|do| ,action ,next-situation))) actions)
                                                                (list next-situation)))))
                                                   f-mode target xrl xrrl)
                                          '(|do-concurrently| ?action-expr ?next-situation))))))))))
                (when (eql xl '|do-concurrently-and-next|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target action-expr)
                                                   (declare (ignore _fmode _target))
                                                   (let* ((actions (km-int action-expr))
                                                          (next-situation (km-unique-int `(|do| ,(first actions)))))
                                                     (mapc #'(lambda (action) (km-int `(|do| ,action ,next-situation))) (rest actions))
                                                     (in-situation next-situation)
                                                     (list next-situation)))
                                               f-mode target xrl)
                                      '(|do-concurrently-and-next| ?action-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target action-expr next-situation)
                                                       (declare (ignore _fmode _target))
                                                       (cond ((not (instance-of next-situation '|Situation|))
                                                              (report-error 'user-error
                                                                            "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%"
                                                                            action-expr next-situation next-situation))
                                                             (t
                                                              (let ((actions (km-int action-expr)))
                                                                (mapc #'(lambda (action) (km-int `(|do| ,action ,next-situation))) actions)
                                                                (in-situation next-situation)
                                                                (list next-situation)))))
                                                   f-mode target xrl xrrl)
                                          '(|do-concurrently-and-next| ?action-expr ?next-situation))))))))))
                (when (eql xl '|do-script|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target script)
                                               (km-int `(|forall| (|the| |actions| |of| ,script) (|do-and-next| |It|))
                                                 :fail-mode fmode
                                                 :target target
                                                 :rewritep t))
                                           f-mode target xrl)
                                  '(|do-script| ?script)))))))
                (when (eql xl '|do-plan|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target plan-instance-expr)
                                               (declare (ignore _fmode _target))
                                               (let ((plan-instance (km-unique plan-instance-expr))) (do-plan plan-instance)))
                                           f-mode target xrl)
                                  '(|do-plan| ?plan-instance-expr)))))))
                (when (eql xl '|assert|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target triple-expr)
                                               (declare (ignore _fmode _target))
                                               (let ((triple (km-unique-int 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
                                                        (km-int `(,(arg1of triple) |has| (,(arg2of triple) ,(val-to-vals (arg3of triple))))
                                                          :fail-mode 'error)))))
                                           f-mode target xrl)
                                  '(|assert| ?triple-expr)))))))
                (when (eql xl '|is-true|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target triple-expr)
                                               (declare (ignore _fmode _target))
                                               (let* ((triple (km-unique-int 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))
                                                        (km-int `(,(second triple) ,(third triple) ,(fourth triple))))
                                                       (t
                                                        (let ((frame (km-unique-int (second triple) :fail-mode 'error))
                                                              (slot (km-unique-int (third triple) :fail-mode 'error))
                                                              (value (fourth triple)))
                                                          (cond ((null value) '(|t|))
                                                                ((km-int `(,frame |is| '(|a| |Thing| |with| (,slot (,value))))))))))))
                                           f-mode target xrl)
                                  '(|is-true| ?triple-expr)))))))
                (when (eql xl '|all-true|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target triples-expr)
                                               (declare (ignore _fmode _target))
                                               (let ((triples (km-int triples-expr)))
                                                 (cond ((every #'(lambda (triple) (km-int `(|is-true| ,triple))) triples) '(|t|)))))
                                           f-mode target xrl)
                                  '(|all-true| ?triples-expr)))))))
                (when (eql xl '|some-true|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target triples-expr)
                                               (declare (ignore _fmode _target))
                                               (let ((triples (km-int triples-expr)))
                                                 (cond ((some #'(lambda (triple) (km-int `(|is-true| ,triple))) triples) '(|t|)))))
                                           f-mode target xrl)
                                  '(|some-true| ?triples-expr)))))))
                (when (eql xl '|next-situation|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target)
                                           (declare (ignore _fmode _target))
                                           (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!~%"))))
                                       f-mode target)
                              '(|next-situation|)))))
                (when (eql xl '|curr-situation|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (list (curr-situation))) f-mode target)
                              '(|curr-situation|)))))
                (when (eql xl '|ignore-result|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr) (declare (ignore fmode target)) (km-int expr) nil) f-mode target
                                           xrl)
                                  '(|ignore-result| ?expr)))))))
                (when (eql xl '|ignore|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr) (declare (ignore fmode target expr)) nil) f-mode target xrl)
                                  '(|ignore| ?expr)))))))
                (when (eql xl '|in-every-situation|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target 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)))
                                                            (km-int
                                                               `(|in-situation| ,*global-situation*
                                                                 (|every| ,situation-class |has| (|assertions| (',modified-expr))))
                                                              :fail-mode fmode
                                                              :target target
                                                              :rewritep t)))))
                                               f-mode target xrl xrrl)
                                      '(|in-every-situation| ?situation-class ?expr)))))))))
                (when (eql xl '|new-context|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) (clear-obj-stack) '(|t|)) f-mode
                                       target)
                              '(|new-context|)))))
                (when (eql xl '|thelast|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target frame)
                                               (declare (ignore _fmode _target))
                                               (let ((last-instance (search-stack frame))) (cond (last-instance (list last-instance)))))
                                           f-mode target xrl)
                                  '(|thelast| ?frame)))))))
                (when (eql xl '|the+|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (or (when (eql xrrl '|of|)
                                    (when (consp xrrr)
                                      (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                        (when (eql xrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (_fmode target slot frameadd)
                                                                 (declare (ignore _fmode))
                                                                 (km-int `(|the+| |Thing| |with| (,(invert-slot slot) (,frameadd)))
                                                                   :fail-mode 'error
                                                                   :target target
                                                                   :rewritep t))
                                                             f-mode target xrl xrrrl)
                                                    '(|the+| ?slot |of| ?frameadd)))))))
                                  (when (consp xrrr)
                                    (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                      (when (eql xrrrl '|of|)
                                        (when (consp xrrrr)
                                          (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                            (when (eql xrrrrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (_fmode target class slot frameadd)
                                                                     (declare (ignore _fmode))
                                                                     (km-int `(|the+| ,class |with| (,(invert-slot slot) (,frameadd)))
                                                                       :fail-mode 'error
                                                                       :target target
                                                                       :rewritep t))
                                                                 f-mode target xrl xrrl xrrrrl)
                                                        '(|the+| ?class ?slot |of| ?frameadd)))))))))
                                  (when (eql xrrl '|with|)
                                    (return-from km-handler
                                      (values (funcall #'(lambda (_fmode _target frame slotsvals)
                                                           (declare (ignore _fmode _target))
                                                           (let ((val (km-unique-int `(|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
                                                                              (km-int existential-expr :fail-mode 'error)))))))
                                                       f-mode target xrl xrrr)
                                              '(|the+| ?frame |with| &rest)))))))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target frame)
                                                   (km-int `(|the+| ,frame |with|) :fail-mode fmode :target target :rewritep t))
                                               f-mode target xrl)
                                      '(|the+| ?frame))))))))
                (when (eql xl '|a+|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target rest) (km-int `(|the+| ,@rest) :fail-mode fmode :target target :rewritep t))
                                     f-mode target xr)
                            '(|a+| &rest))))
                (when (eql xl '|if|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrl '|then|)
                            (when (consp xrrr)
                              (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                (or (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target condition action)
                                                             (km-int `(|if| ,condition |then| ,action |else| nil)
                                                               :fail-mode fmode
                                                               :target target
                                                               :rewritep t))
                                                         f-mode target xrl xrrrl)
                                                '(|if| ?condition |then| ?action))))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrl '|else|)
                                          (when (consp xrrrrr)
                                            (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                              (when (eql xrrrrrr 'nil)
                                                (return-from km-handler
                                                  (values (funcall #'(lambda (fmode target condition action altaction)
                                                                       (declare (ignore target))
                                                                       (let ((test-result (km-int condition)))
                                                                         (cond ((not (member test-result '(nil |f| f)))
                                                                                (km-int action :fail-mode fmode))
                                                                               (t (km-int altaction :fail-mode fmode)))))
                                                                   f-mode target xrl xrrrl xrrrrrl)
                                                          '(|if| ?condition |then| ?action |else| ?altaction))))))))))))))))))
                (when (eql xl '|not|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target x) (declare (ignore _fmode _target)) (cond ((not (km-int x)) '(|t|))))
                                           f-mode target xrl)
                                  '(|not| ?x)))))))
                (when (eql xl '|numberp|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target x)
                                               (declare (ignore _fmode _target))
                                               (cond ((numberp (km-unique-int x)) '(|t|))))
                                           f-mode target xrl)
                                  '(|numberp| ?x)))))))
                (when (eql xl '|allof|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (or (when (eql xrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (fmode target set test)
                                                                 (km-int `(|forall| ,set |where| ,test |It|)
                                                                   :fail-mode fmode
                                                                   :target target
                                                                   :rewritep t))
                                                             f-mode target xrl xrrrl)
                                                    '(|allof| ?set |where| ?test))))
                                        (when (consp xrrrr)
                                          (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                            (when (eql xrrrrl '|must|)
                                              (when (consp xrrrrr)
                                                (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                  (when (eql xrrrrrr 'nil)
                                                    (return-from km-handler
                                                      (values (funcall #'(lambda (fmode target set test2 test)
                                                                           (declare (ignore fmode target))
                                                                           (cond ((every #'(lambda (instance)
                                                                                             (km-int (subst instance '|It| test)))
                                                                                         (km-int `(|allof| ,set |where| ,test2)))
                                                                                  '(|t|))))
                                                                       f-mode target xrl xrrrl xrrrrrl)
                                                              '(|allof| ?set |where| ?test2 |must| ?test)))))))))))))
                              (when (eql xrrl '|must|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target set test)
                                                             (declare (ignore fmode target))
                                                             (cond ((every #'(lambda (instance) (km-int (subst instance '|It| test)))
                                                                           (km-int set))
                                                                    '(|t|))))
                                                         f-mode target xrl xrrrl)
                                                '(|allof| ?set |must| ?test)))))))
                              (when (eql xrrl '|in|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (or (when (eql xrrrrl '|where|)
                                              (when (consp xrrrrr)
                                                (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                  (or (when (eql xrrrrrr 'nil)
                                                        (return-from km-handler
                                                          (values (funcall #'(lambda (fmode target 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
                                                                                      (km-int `(|forall| ,var |in| ,set |where| ,test ,var)
                                                                                        :fail-mode fmode
                                                                                        :target target
                                                                                        :rewritep t))))
                                                                           f-mode target xrl xrrrl xrrrrrl)
                                                                  '(|allof| ?var |in| ?set |where| ?test))))
                                                      (when (consp xrrrrrr)
                                                        (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr)))
                                                          (when (eql xrrrrrrl '|must|)
                                                            (when (consp xrrrrrrr)
                                                              (let ((xrrrrrrrl (first xrrrrrrr)) (xrrrrrrrr (rest xrrrrrrr)))
                                                                (when (eql xrrrrrrrr 'nil)
                                                                  (return-from km-handler
                                                                    (values (funcall #'(lambda (fmode target var set test2 test)
                                                                                         (declare (ignore fmode target))
                                                                                         (allof-where-must var set test2 test))
                                                                                     f-mode target xrl xrrrl xrrrrrl xrrrrrrrl)
                                                                            '(|allof| ?var |in| ?set |where| ?test2 |must|
                                                                              ?test)))))))))))))
                                            (when (eql xrrrrl '|must|)
                                              (when (consp xrrrrr)
                                                (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                  (when (eql xrrrrrr 'nil)
                                                    (return-from km-handler
                                                      (values (funcall #'(lambda (fmode target var set test)
                                                                           (declare (ignore fmode target))
                                                                           (allof-must var set test))
                                                                       f-mode target xrl xrrrl xrrrrrl)
                                                              '(|allof| ?var |in| ?set |must| ?test)))))))))))))))))))
                (when (eql xl '|oneof|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target set test)
                                                             (declare (ignore fmode target))
                                                             (let ((answer
                                                                    (find-if #'(lambda (member) (km-int (subst member '|It| test)))
                                                                             (km-int set))))
                                                               (cond (answer (list answer)))))
                                                         f-mode target xrl xrrrl)
                                                '(|oneof| ?set |where| ?test)))))))
                              (when (eql xrrl '|in|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrl '|where|)
                                          (when (consp xrrrrr)
                                            (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                              (when (eql xrrrrrr 'nil)
                                                (return-from km-handler
                                                  (values (funcall #'(lambda (fmode target var set test)
                                                                       (declare (ignore fmode target))
                                                                       (oneof-where var set test))
                                                                   f-mode target xrl xrrrl xrrrrrl)
                                                          '(|oneof| ?var |in| ?set |where| ?test))))))))))))))))))
                (when (eql xl '|theoneof|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target set test)
                                                             (let ((val
                                                                    (km-unique-int `(|forall| ,set |where| ,test |It|)
                                                                      :fail-mode fmode
                                                                      :target target
                                                                      :rewritep t)))
                                                               (cond (val (list val)))))
                                                         f-mode target xrl xrrrl)
                                                '(|theoneof| ?set |where| ?test)))))))
                              (when (eql xrrl '|in|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrl '|where|)
                                          (when (consp xrrrrr)
                                            (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                              (when (eql xrrrrrr 'nil)
                                                (return-from km-handler
                                                  (values (funcall #'(lambda (fmode target 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-unique-int
                                                                                        `(|forall| ,var |in| ,set |where| ,test ,var)
                                                                                       :fail-mode fmode
                                                                                       :target target
                                                                                       :rewritep t)))
                                                                                (cond (val (list val)))))))
                                                                   f-mode target xrl xrrrl xrrrrrl)
                                                          '(|theoneof| ?var |in| ?set |where| ?test))))))))))))))))))
                (when (eql xl '|forall|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target set value)
                                                       (km-int `(|forall| ,set |where| t ,value)
                                                         :fail-mode fmode
                                                         :target target
                                                         :rewritep t))
                                                   f-mode target xrl xrrl)
                                          '(|forall| ?set ?value))))
                              (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (_fmode _target set constraint value)
                                                                 (declare (ignore _fmode _target))
                                                                 (remove nil
                                                                         (my-mapcan #'(lambda (member)
                                                                                        (cond ((km-int (subst member '|It| constraint))
                                                                                               (km-int (subst member '|It| value)))))
                                                                                    (km-int set))))
                                                             f-mode target xrl xrrrl xrrrrl)
                                                    '(|forall| ?set |where| ?constraint ?value)))))))))
                              (when (eql xrrl '|in|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (or (when (eql xrrrrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (fmode target 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
                                                                            (km-int `(|forall| ,var |in| ,set |where| t ,value)
                                                                              :fail-mode fmode
                                                                              :target target
                                                                              :rewritep t))))
                                                                 f-mode target xrl xrrrl xrrrrl)
                                                        '(|forall| ?var |in| ?set ?value))))
                                            (when (eql xrrrrl '|where|)
                                              (when (consp xrrrrr)
                                                (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                  (when (consp xrrrrrr)
                                                    (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr)))
                                                      (when (eql xrrrrrrr 'nil)
                                                        (return-from km-handler
                                                          (values (funcall #'(lambda (_fmode _target var set constraint value)
                                                                               (declare (ignore _fmode _target))
                                                                               (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
                                                                                                             ((km-int
                                                                                                               (subst
                                                                                                                member
                                                                                                                var
                                                                                                                constraint))
                                                                                                              (km-int
                                                                                                               (subst member var value)))))
                                                                                                         (km-int set))))))
                                                                           f-mode target xrl xrrrl xrrrrrl xrrrrrrl)
                                                                  '(|forall| ?var |in| ?set |where| ?constraint ?value)))))))))))))))))))))
                (when (eql xl '|forall-seq|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target seq value)
                                                       (km-int `(|forall-seq| ,seq |where| t ,value)
                                                         :fail-mode fmode
                                                         :target target
                                                         :rewritep t))
                                                   f-mode target xrl xrrl)
                                          '(|forall-seq| ?seq ?value))))
                              (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (_fmode _target seq constraint value)
                                                                 (declare (ignore _fmode _target))
                                                                 (let ((sequences (km-int seq)))
                                                                   (cond ((null sequences) nil)
                                                                         ((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
                                                                                                          ((km-int
                                                                                                            (subst
                                                                                                             member
                                                                                                             '|It|
                                                                                                             constraint))
                                                                                                           (vals-to-val
                                                                                                            (km-int
                                                                                                             (subst member '|It| value))))
                                                                                                          (t 'to-remove)))
                                                                                                      (rest (first sequences))))))))))
                                                             f-mode target xrl xrrrl xrrrrl)
                                                    '(|forall-seq| ?seq |where| ?constraint ?value)))))))))
                              (when (eql xrrl '|in|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (or (when (eql xrrrrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (fmode target 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
                                                                            (km-int `(|forall-seq| ,var |in| ,seq |where| t ,value)
                                                                              :fail-mode fmode
                                                                              :target target
                                                                              :rewritep t))))
                                                                 f-mode target xrl xrrrl xrrrrl)
                                                        '(|forall-seq| ?var |in| ?seq ?value))))
                                            (when (eql xrrrrl '|where|)
                                              (when (consp xrrrrr)
                                                (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                  (when (consp xrrrrrr)
                                                    (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr)))
                                                      (when (eql xrrrrrrr 'nil)
                                                        (return-from km-handler
                                                          (values (funcall #'(lambda (_fmode _target var seq constraint value)
                                                                               (declare (ignore _fmode _target))
                                                                               (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 (km-int 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
                                                                                                            ((km-int
                                                                                                              (subst
                                                                                                               member
                                                                                                               var
                                                                                                               constraint))
                                                                                                             (vals-to-val
                                                                                                              (km-int
                                                                                                               (subst member var value))))
                                                                                                            (t 'to-remove)))
                                                                                                        (rest (first sequences))))))))))))
                                                                           f-mode target xrl xrrrl xrrrrrl xrrrrrrl)
                                                                  '(|forall-seq| ?var |in| ?seq |where| ?constraint
                                                                    ?value)))))))))))))))))))))
                (when (eql xl '|forall-bag|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target bag value)
                                                       (km-int `(|forall-bag| ,bag |where| t ,value)
                                                         :fail-mode fmode
                                                         :target target
                                                         :rewritep t))
                                                   f-mode target xrl xrrl)
                                          '(|forall-bag| ?bag ?value))))
                              (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (_fmode _target bag constraint value)
                                                                 (declare (ignore _fmode _target))
                                                                 (let ((bags (km-int bag)))
                                                                   (cond ((null bags) nil)
                                                                         ((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
                                                                                                          ((km-int
                                                                                                            (subst
                                                                                                             member
                                                                                                             '|It|
                                                                                                             constraint))
                                                                                                           (vals-to-val
                                                                                                            (km-int
                                                                                                             (subst
                                                                                                              member
                                                                                                              '|It|
                                                                                                              value))))))
                                                                                                      (rest (first bags))))))))))
                                                             f-mode target xrl xrrrl xrrrrl)
                                                    '(|forall-bag| ?bag |where| ?constraint ?value)))))))))
                              (when (eql xrrl '|in|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (or (when (eql xrrrrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (fmode target 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
                                                                            (km-int `(|forall-bag| ,var |in| ,bag |where| t ,value)
                                                                              :fail-mode fmode
                                                                              :target target
                                                                              :rewritep t))))
                                                                 f-mode target xrl xrrrl xrrrrl)
                                                        '(|forall-bag| ?var |in| ?bag ?value))))
                                            (when (eql xrrrrl '|where|)
                                              (when (consp xrrrrr)
                                                (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                  (when (consp xrrrrrr)
                                                    (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr)))
                                                      (when (eql xrrrrrrr 'nil)
                                                        (return-from km-handler
                                                          (values (funcall #'(lambda (_fmode _target var bag constraint value)
                                                                               (declare (ignore _fmode _target))
                                                                               (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 (km-int 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
                                                                                                            ((km-int
                                                                                                              (subst
                                                                                                               member
                                                                                                               var
                                                                                                               constraint))
                                                                                                             (vals-to-val
                                                                                                              (km-int
                                                                                                               (subst
                                                                                                                member
                                                                                                                var
                                                                                                                value))))))
                                                                                                        (rest (first bags))))))))))))
                                                                           f-mode target xrl xrrrl xrrrrrl xrrrrrrl)
                                                                  '(|forall-bag| ?var |in| ?bag |where| ?constraint
                                                                    ?value)))))))))))))))))))))
                (when (eql xl '|forall-seq2|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (_fmode _target seq constraint value)
                                                                 (declare (ignore _fmode _target))
                                                                 (let ((sequences (km-int seq)))
                                                                   (cond ((null sequences) nil)
                                                                         ((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
                                                                                                          ((km-int
                                                                                                            (subst
                                                                                                             member
                                                                                                             '|It2|
                                                                                                             constraint))
                                                                                                           (vals-to-val
                                                                                                            (km-int
                                                                                                             (subst member '|It2| value))))
                                                                                                          (t 'to-remove)))
                                                                                                      (rest (first sequences))))))))))
                                                             f-mode target xrl xrrrl xrrrrl)
                                                    '(|forall-seq2| ?seq |where| ?constraint ?value)))))))))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target seq value)
                                                       (km-int `(|forall-seq2| ,seq |where| t ,value)
                                                         :fail-mode fmode
                                                         :target target
                                                         :rewritep t))
                                                   f-mode target xrl xrrl)
                                          '(|forall-seq2| ?seq ?value))))))))))
                (when (eql xl '|forall-bag2|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (_fmode _target bag constraint value)
                                                                 (declare (ignore _fmode _target))
                                                                 (let ((bags (km-int bag)))
                                                                   (cond ((null bags) nil)
                                                                         ((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
                                                                                                          ((km-int
                                                                                                            (subst
                                                                                                             member
                                                                                                             '|It2|
                                                                                                             constraint))
                                                                                                           (vals-to-val
                                                                                                            (km-int
                                                                                                             (subst
                                                                                                              member
                                                                                                              '|It2|
                                                                                                              value))))))
                                                                                                      (rest (first bags))))))))))
                                                             f-mode target xrl xrrrl xrrrrl)
                                                    '(|forall-bag2| ?bag |where| ?constraint ?value)))))))))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target bag value)
                                                       (km-int `(|forall-bag2| ,bag |where| t ,value)
                                                         :fail-mode fmode
                                                         :target target
                                                         :rewritep t))
                                                   f-mode target xrl xrrl)
                                          '(|forall-bag2| ?bag ?value))))))))))
                (when (eql xl '|allof2|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (or (when (eql xrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (fmode target set test)
                                                                 (km-int `(|forall2| ,set |where| ,test |It2|)
                                                                   :fail-mode fmode
                                                                   :target target
                                                                   :rewritep t))
                                                             f-mode target xrl xrrrl)
                                                    '(|allof2| ?set |where| ?test))))
                                        (when (consp xrrrr)
                                          (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                            (when (eql xrrrrl '|must|)
                                              (when (consp xrrrrr)
                                                (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr)))
                                                  (when (eql xrrrrrr 'nil)
                                                    (return-from km-handler
                                                      (values (funcall #'(lambda (fmode target set test2 test)
                                                                           (declare (ignore fmode target))
                                                                           (cond ((every #'(lambda (instance)
                                                                                             (km-int (subst instance '|It2| test)))
                                                                                         (km-int `(|allof2| ,set |where| ,test2)))
                                                                                  '(|t|))))
                                                                       f-mode target xrl xrrrl xrrrrrl)
                                                              '(|allof2| ?set |where| ?test2 |must| ?test)))))))))))))
                              (when (eql xrrl '|must|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target set test)
                                                             (declare (ignore fmode target))
                                                             (cond ((every #'(lambda (instance) (km-int (subst instance '|It2| test)))
                                                                           (km-int set))
                                                                    '(|t|))))
                                                         f-mode target xrl xrrrl)
                                                '(|allof2| ?set |must| ?test)))))))))))))
                (when (eql xl '|oneof2|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrl '|where|)
                            (when (consp xrrr)
                              (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                (when (eql xrrrr 'nil)
                                  (return-from km-handler
                                    (values (funcall #'(lambda (fmode target set test)
                                                         (declare (ignore fmode target))
                                                         (let ((answer
                                                                (find-if #'(lambda (member) (km-int (subst member '|It2| test)))
                                                                         (km-int set))))
                                                           (cond (answer (list answer)))))
                                                     f-mode target xrl xrrrl)
                                            '(|oneof2| ?set |where| ?test))))))))))))
                (when (eql xl '|forall2|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (or (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target set value)
                                                       (km-int `(|forall2| ,set |where| t ,value)
                                                         :fail-mode fmode
                                                         :target target
                                                         :rewritep t))
                                                   f-mode target xrl xrrl)
                                          '(|forall2| ?set ?value))))
                              (when (eql xrrl '|where|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (consp xrrrr)
                                      (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                        (when (eql xrrrrr 'nil)
                                          (return-from km-handler
                                            (values (funcall #'(lambda (_fmode _target set constraint value)
                                                                 (declare (ignore _fmode _target))
                                                                 (remove 'nil
                                                                         (my-mapcan #'(lambda (member)
                                                                                        (cond ((km-int (subst member '|It2| constraint))
                                                                                               (km-int (subst member '|It2| value)))))
                                                                                    (km-int set))))
                                                             f-mode target xrl xrrrl xrrrrl)
                                                    '(|forall2| ?set |where| ?constraint ?value)))))))))))))))
                (when (eql xl '|theoneof2|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrl '|where|)
                            (when (consp xrrr)
                              (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                (when (eql xrrrr 'nil)
                                  (return-from km-handler
                                    (values (funcall #'(lambda (fmode target set test)
                                                         (let ((val
                                                                (km-unique-int `(|forall2| ,set |where| ,test |It2|)
                                                                  :fail-mode fmode
                                                                  :target target
                                                                  :rewritep t)))
                                                           (cond (val (list val)))))
                                                     f-mode target xrl xrrrl)
                                            '(|theoneof2| ?set |where| ?test))))))))))))
                (when (eql xl 'function)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target lispcode)
                                               (declare (ignore _fmode _target))
                                               (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)))))
                                           f-mode target xrl)
                                  '#'?lispcode))))))
                (when (eql xl '|the1|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrl '|of|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target slot frameadd)
                                                             (km-int `(|the1| |of| (|the| ,slot |of| ,frameadd))
                                                               :fail-mode fmode
                                                               :target target
                                                               :rewritep t))
                                                         f-mode target xrl xrrrl)
                                                '(|the1| ?slot |of| ?frameadd)))))))))
                          (when (eql xrl '|of|)
                            (when (consp xrr)
                              (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                (when (eql xrrr 'nil)
                                  (return-from km-handler
                                    (values (funcall #'(lambda (fmode target frameadd)
                                                         (let ((multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)))
                                                           (km-int
                                                              (vals-to-val (mapcar #'(lambda (multiarg)
                                                                                       (cond ((km-structured-list-valp multiarg)
                                                                                              (arg1of multiarg))
                                                                                             (t multiarg)))
                                                                                   multiargs)))))
                                                     f-mode target xrrl)
                                            '(|the1| |of| ?frameadd)))))))))))
                (when (eql xl '|the2|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrl '|of|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target slot frameadd)
                                                             (km-int `(|the2| |of| (|the| ,slot |of| ,frameadd))
                                                               :fail-mode fmode
                                                               :target target
                                                               :rewritep t))
                                                         f-mode target xrl xrrrl)
                                                '(|the2| ?slot |of| ?frameadd)))))))))
                          (when (eql xrl '|of|)
                            (when (consp xrr)
                              (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                (when (eql xrrr 'nil)
                                  (return-from km-handler
                                    (values (funcall #'(lambda (fmode target frameadd)
                                                         (let ((multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)))
                                                           (km-int
                                                              (vals-to-val (mapcar #'(lambda (multiarg)
                                                                                       (cond ((km-structured-list-valp multiarg)
                                                                                              (arg2of multiarg))))
                                                                                   multiargs)))))
                                                     f-mode target xrrl)
                                            '(|the2| |of| ?frameadd)))))))))))
                (when (eql xl '|the3|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrl '|of|)
                                (when (consp xrrr)
                                  (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                    (when (eql xrrrr 'nil)
                                      (return-from km-handler
                                        (values (funcall #'(lambda (fmode target slot frameadd)
                                                             (km-int `(|the3| |of| (|the| ,slot |of| ,frameadd))
                                                               :fail-mode fmode
                                                               :target target
                                                               :rewritep t))
                                                         f-mode target xrl xrrrl)
                                                '(|the3| ?slot |of| ?frameadd)))))))))
                          (when (eql xrl '|of|)
                            (when (consp xrr)
                              (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                (when (eql xrrr 'nil)
                                  (return-from km-handler
                                    (values (funcall #'(lambda (fmode target frameadd)
                                                         (let ((multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)))
                                                           (km-int
                                                              (vals-to-val (mapcar #'(lambda (multiarg)
                                                                                       (cond ((km-structured-list-valp multiarg)
                                                                                              (arg3of multiarg))))
                                                                                   multiargs)))))
                                                     f-mode target xrrl)
                                            '(|the3| |of| ?frameadd)))))))))))
                (when (eql xl '|theN|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrl '|of|)
                            (when (consp xrrr)
                              (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                (when (eql xrrrr 'nil)
                                  (return-from km-handler
                                    (values (funcall #'(lambda (fmode target nexpr frameadd)
                                                         (let ((n (km-unique-int nexpr :fail-mode 'error))
                                                               (multiargs (km-int frameadd :fail-mode fmode :target target :rewritep t)))
                                                           (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
                                                                  (km-int
                                                                     (vals-to-val (mapcar #'(lambda (multiarg)
                                                                                              (cond ((and
                                                                                                      (km-structured-list-valp multiarg)
                                                                                                      (< n (length multiarg)))
                                                                                                     (elt multiarg n))
                                                                                                    ((= n 1) multiarg)))
                                                                                          multiargs)))))))
                                                     f-mode target xrl xrrrl)
                                            '(|theN| ?nexpr |of| ?frameadd))))))))))))
                (when (eql xl '|theNth|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrl '|of|)
                            (when (consp xrrr)
                              (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                (when (eql xrrrr 'nil)
                                  (return-from km-handler
                                    (values (funcall #'(lambda (fmode target nexpr frameadd)
                                                         (let ((n (km-unique-int nexpr :fail-mode 'error))
                                                               (vals (km-int frameadd :fail-mode fmode :target target :rewritep t)))
                                                           (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)))))))
                                                     f-mode target xrl xrrrl)
                                            '(|theNth| ?nexpr |of| ?frameadd))))))))))))
                (when (eql xl :|set|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target exprs)
                                         (declare (ignore fmode))
                                         (my-mapcan #'(lambda (expr) (km-int expr :target target)) exprs))
                                     f-mode target xr)
                            '(:|set| &rest))))
                (when (eql xl :|seq|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target exprs)
                                         (declare (ignore target fmode))
                                         (let ((sequence (mapcar #'(lambda (expr) (vals-to-val (km-int expr))) exprs)))
                                           (cond (sequence `((:|seq| ,@sequence))))))
                                     f-mode target xr)
                            '(:|seq| &rest))))
                (when (eql xl :|bag|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target exprs)
                                         (declare (ignore target fmode))
                                         (let ((bag (mapcar #'(lambda (expr) (vals-to-val (km-int expr))) exprs)))
                                           (cond (bag `((:|bag| ,@bag))))))
                                     f-mode target xr)
                            '(:|bag| &rest))))
                (when (eql xl :|function|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target exprs)
                                         (declare (ignore target fmode))
                                         (let ((sequence (mapcar #'(lambda (expr) (vals-to-val (km-int expr))) exprs)))
                                           (cond (sequence `((:|function| ,@sequence))))))
                                     f-mode target xr)
                            '(:|function| &rest))))
                (when (eql xl :|pair|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target exprs)
                                         (declare (ignore target 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 (km-int expr))) exprs)))
                                                  (cond (sequence `((:|pair| ,@sequence))))))))
                                     f-mode target xr)
                            '(:|pair| &rest))))
                (when (eql xl :|triple|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (consp xrrr)
                            (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                              (when (eql xrrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target frame-expr slot-expr val-expr)
                                                       (declare (ignore _fmode _target))
                                                       (let* ((slot
                                                               (cond ((comparison-operator slot-expr) slot-expr)
                                                                     (t (km-unique-int slot-expr :fail-mode 'error))))
                                                              (frame
                                                               (cond ((and (comparison-operator slot)
                                                                           (minimatch frame-expr '(|the| |?x| |of| |?y|)))
                                                                      frame-expr)
                                                                     (t (km-unique-int frame-expr :fail-mode 'error))))
                                                              (val-expr0 (desource+decomment val-expr))
                                                              (val
                                                               (cond ((or (constraint-exprp val-expr0) (existential-exprp val-expr0)
                                                                          (comparison-operator slot))
                                                                      val-expr0)
                                                                     (t (vals-to-val (km-int val-expr))))))
                                                         `((:|triple| ,frame ,slot ,val))))
                                                   f-mode target xrl xrrl xrrrl)
                                          '(:|triple| ?frame-expr ?slot-expr ?val-expr)))))))))))
                (when (eql xl :|args|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target exprs)
                                         (declare (ignore fmode target))
                                         (let ((sequence (mapcar #'(lambda (expr) (vals-to-val (km-int expr))) exprs)))
                                           (cond (sequence `((:|args| ,@sequence))))))
                                     f-mode target xr)
                            '(:|args| &rest))))
                (when (eql xl '|showme|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (_fmode _target km-expr) (declare (ignore _fmode _target)) (showme km-expr))
                                               f-mode target xrl)
                                      '(|showme| ?km-expr))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrr 'nil)
                                (return-from km-handler
                                  (values (funcall #'(lambda (_fmode _target km-expr file)
                                                       (declare (ignore _fmode _target))
                                                       (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))))))
                                                   f-mode target xrl xrrl)
                                          '(|showme| ?km-expr ?file))))))))))
                (when (eql xl '|showme-all|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target km-expr) (declare (ignore _fmode _target)) (showme-all km-expr))
                                           f-mode target xrl)
                                  '(|showme-all| ?km-expr)))))))
                (when (eql xl '|evaluate-all|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target km-expr) (declare (ignore _fmode _target)) (evaluate-all km-expr))
                                           f-mode target xrl)
                                  '(|evaluate-all| ?km-expr)))))))
                (when (eql xl '|showme-here|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target km-expr)
                                               (declare (ignore _fmode _target))
                                               (showme km-expr (list (curr-situation)) (visible-theories)))
                                           f-mode target xrl)
                                  '(|showme-here| ?km-expr)))))))
                (when (eql xl '|the-class|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (or (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target class)
                                                   (declare (ignore fmode target))
                                                   (process-unquotes `((|the-class| ,class))))
                                               f-mode target xrl)
                                      '(|the-class| ?class))))
                          (when (consp xrr)
                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                              (when (eql xrrl '|with|)
                                (return-from km-handler
                                  (values (funcall #'(lambda (fmode target class slotsvals)
                                                       (declare (ignore fmode target))
                                                       (cond ((are-slotsvals slotsvals)
                                                              (process-unquotes `((|the-class| ,class |with| ,@slotsvals))))))
                                                   f-mode target xrl xrrr)
                                          '(|the-class| ?class |with| &rest))))))))))
                (when (eql xl '|constraints-for|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrl)
                        (let ((xrll (first xrl)) (xrlr (rest xrl)))
                          (when (eql xrll '|the|)
                            (when (consp xrlr)
                              (let ((xrlrl (first xrlr)) (xrlrr (rest xrlr)))
                                (when (consp xrlrr)
                                  (let ((xrlrrl (first xrlrr)) (xrlrrr (rest xrlrr)))
                                    (when (eql xrlrrl '|of|)
                                      (when (consp xrlrrr)
                                        (let ((xrlrrrl (first xrlrrr)) (xrlrrrr (rest xrlrrr)))
                                          (when (eql xrlrrrr 'nil)
                                            (when (eql xrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (fmode0 target slot frameadd)
                                                                     (declare (ignore fmode0 target))
                                                                     (let ((frame (km-unique-int frameadd :fail-mode 'error)))
                                                                       (mapcar #'quotify (collect-constraints-on-instance frame slot))))
                                                                 f-mode target xrlrl xrlrrrl)
                                                        '(|constraints-for| (|the| ?slot |of| ?frameadd)))))))))))))))))))
                (when (eql xl '|rules-for|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrl)
                        (let ((xrll (first xrl)) (xrlr (rest xrl)))
                          (when (eql xrll '|the|)
                            (when (consp xrlr)
                              (let ((xrlrl (first xrlr)) (xrlrr (rest xrlr)))
                                (when (consp xrlrr)
                                  (let ((xrlrrl (first xrlrr)) (xrlrrr (rest xrlrr)))
                                    (when (eql xrlrrl '|of|)
                                      (when (consp xrlrrr)
                                        (let ((xrlrrrl (first xrlrrr)) (xrlrrrr (rest xrlrrr)))
                                          (when (eql xrlrrrr 'nil)
                                            (when (eql xrr 'nil)
                                              (return-from km-handler
                                                (values (funcall #'(lambda (fmode0 target slot frameadd)
                                                                     (declare (ignore fmode0 target))
                                                                     (let ((rules (rules-for slot frameadd)))
                                                                       (cond ((null rules) nil)
                                                                             ((km-setp rules) (mapcar #'quotify (set-to-list rules)))
                                                                             (t (list (quotify rules))))))
                                                                 f-mode target xrlrl xrlrrrl)
                                                        '(|rules-for| (|the| ?slot |of| ?frameadd)))))))))))))))))))
                (when (eql xl '|why|)
                  (or (when (eql xr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target) (declare (ignore fmode target)) (why)) f-mode target) '(|why|))))
                      (when (consp xr)
                        (let ((xrl (first xr)) (xrr (rest xr)))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target triple)
                                                   (declare (ignore fmode target))
                                                   (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))))
                                               f-mode target xrl)
                                      '(|why| ?triple))))))))
                (when (eql xl '|justify|)
                  (or (when (eql xr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target) (declare (ignore fmode target)) (justify)) f-mode target)
                                  '(|justify|))))
                      (when (consp xr)
                        (let ((xrl (first xr)) (xrr (rest xr)))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target triple) (declare (ignore fmode target)) (justify triple)) f-mode
                                               target xrl)
                                      '(|justify| ?triple))))))))
                (when (eql xl '|get-justification|)
                  (or (when (eql xr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target)
                                               (declare (ignore fmode target))
                                               (list (concat-list (insert-delimeter (get-justification :format 'ascii) *newline-str*))))
                                           f-mode target)
                                  '(|get-justification|))))
                      (when (consp xr)
                        (let ((xrl (first xr)) (xrr (rest xr)))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target triple)
                                                   (declare (ignore fmode target))
                                                   (list (concat-list (insert-delimeter (get-justification :triple triple :format 'ascii)
                                                                                        *newline-str*))))
                                               f-mode target xrl)
                                      '(|get-justification| ?triple))))))))
                (when (eql xl '|explanation|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrl)
                        (let ((xrll (first xrl)) (xrlr (rest xrl)))
                          (when (eql xrll :|triple|)
                            (when (consp xrlr)
                              (let ((xrlrl (first xrlr)) (xrlrr (rest xrlr)))
                                (when (consp xrlrr)
                                  (let ((xrlrrl (first xrlrr)) (xrlrrr (rest xrlrr)))
                                    (when (consp xrlrrr)
                                      (let ((xrlrrrl (first xrlrrr)) (xrlrrrr (rest xrlrrr)))
                                        (when (eql xrlrrrr 'nil)
                                          (when (consp xrr)
                                            (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                                              (when (eql xrrr 'nil)
                                                (return-from km-handler
                                                  (values (funcall #'(lambda (fmode target f0 s v0 explanations)
                                                                       (declare (ignore fmode target))
                                                                       (let ((f (dereference f0)) (v (dereference v0)))
                                                                         (mapc #'(lambda (explanation)
                                                                                   (record-explanation-for `(|the| ,s |of| ,f) v
                                                                                                           explanation
                                                                                     :situation *global-situation*
                                                                                     :ignore-clone-cycles t))
                                                                               (dereference explanations)))
                                                                       '(|t|))
                                                                   f-mode target xrlrl xrlrrl xrlrrrl xrrl)
                                                          '(|explanation| (:|triple| ?f0 ?s ?v0) ?explanations)))))))))))))))))))
                (when (eql xl '|explained-by|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (when (eql xrrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target instance expr)
                                                   (declare (ignore fmode target))
                                                   (explained-by instance expr))
                                               f-mode target xrl xrrl)
                                      '(|explained-by| ?instance ?expr)))))))))
                (when (eql xl '|comment|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (return-from km-handler
                        (values (funcall #'(lambda (fmode target comment-tag data)
                                             (declare (ignore fmode target))
                                             (comment comment-tag data))
                                         f-mode target xrl xrr)
                                '(|comment| ?comment-tag &rest))))))
                (when (eql xl '|show-comment|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target comment-tag) (declare (ignore fmode target)) (show-comment comment-tag))
                                           f-mode target xrl)
                                  '(|show-comment| ?comment-tag)))))))
                (when (eql xl 'quote)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (declare (ignore fmode target))
                                               (let ((processed-expr (process-unquotes expr)))
                                                 (cond (processed-expr (list (list 'quote processed-expr))))))
                                           f-mode target xrl)
                                  ''?expr))))))
                (when (eql xl 'unquote)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (declare (ignore fmode target))
                                               (report-error 'user-error
                                                             "Doing #,~a: You can't unquote something without it first being quoted!~%"
                                                             expr))
                                           f-mode target xrl)
                                  '(unquote ?expr)))))))
                (when (eql xl '|delete|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target km-expr)
                                               (mapc #'delete-frame (km-int km-expr :fail-mode fmode :target target :rewritep t))
                                               '(|t|))
                                           f-mode target xrl)
                                  '(|delete| ?km-expr)))))))
                (when (eql xl '|evaluate|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (let ((quoted-exprs (km-int expr :fail-mode fmode :target target :rewritep t)))
                                                 (remove nil
                                                         (my-mapcan #'(lambda (quoted-expr)
                                                                        (cond ((member quoted-expr '(|f| f)) nil)
                                                                              ((and (pairp quoted-expr) (eq (first quoted-expr) 'quote))
                                                                               (km-int (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))))
                                           f-mode target xrl)
                                  '(|evaluate| ?expr)))))))
                (when (eql xl '|exists|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target 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)
                                               (km-int `(|has-value| ,frame) :fail-mode fmode :target target :rewritep t))
                                           f-mode target xrl)
                                  '(|exists| ?frame)))))))
                (when (eql xl '|has-value|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target frame)
                                               (declare (ignore _fmode _target))
                                               (cond ((km-int frame) '(|t|))))
                                           f-mode target xrl)
                                  '(|has-value| ?frame)))))))
                (when (eql xl '|print|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target expr)
                                               (declare (ignore _fmode _target))
                                               (let ((vals (km-int expr))) (km-format t "~a~%" vals) vals))
                                           f-mode target xrl)
                                  '(|print| ?expr)))))))
                (when (eql xl '|format|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target flag string arguments)
                                                 (declare (ignore _fmode _target))
                                                 (cond ((eq flag '|t|)
                                                        (apply #'format `(t ,string ,@(mapcar #'(lambda (arg) (km-int arg)) arguments)))
                                                        '(|t|))
                                                       ((member flag '(|nil| nil))
                                                        (list (apply #'format
                                                                     `(nil ,string ,@(mapcar #'(lambda (arg) (km-int arg)) arguments)))))
                                                       (t
                                                        (report-error 'user-error "~a: Second argument must be `t' or `nil', not `~a'!~%"
                                                                      `(|format| ,flag ,string ,@arguments) flag))))
                                             f-mode target xrl xrrl xrrr)
                                    '(|format| ?flag ?string &rest))))))))
                (when (eql xl '|km-format|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (consp xrr)
                        (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                          (return-from km-handler
                            (values (funcall #'(lambda (_fmode _target flag string arguments)
                                                 (declare (ignore _fmode _target))
                                                 (cond ((eq flag '|t|)
                                                        (apply #'km-format `(t ,string ,@(mapcar #'(lambda (arg) (km-int arg)) arguments)))
                                                        '(|t|))
                                                       ((member flag '(|nil| nil))
                                                        (list (apply #'km-format
                                                                     `(nil ,string ,@(mapcar #'(lambda (arg) (km-int arg)) arguments)))))
                                                       (t
                                                        (report-error 'user-error "~a: Second argument must be `t' or `nil', not `~a'!~%"
                                                                      `(|km-format| ,flag ,string ,@arguments) flag))))
                                             f-mode target xrl xrrl xrrr)
                                    '(|km-format| ?flag ?string &rest))))))))
                (when (eql xl '|andify|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (list (cons ':|seq| (andify (km-int expr :fail-mode fmode :target target :rewritep t)))))
                                           f-mode target xrl)
                                  '(|andify| ?expr)))))))
                (when (eql xl '|make-sentence|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target expr)
                                               (declare (ignore _fmode _target))
                                               (let ((text (km-int expr)))
                                                 (make-comment "anglifying ~a" text)
                                                 (list (make-sentence text))))
                                           f-mode target xrl)
                                  '(|make-sentence| ?expr)))))))
                (when (eql xl '|make-phrase|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (_fmode _target expr)
                                               (declare (ignore _fmode _target))
                                               (let ((text (km-int expr))) (make-comment "anglifying ~a" text) (list (make-phrase text))))
                                           f-mode target xrl)
                                  '(|make-phrase| ?expr)))))))
                (when (eql xl '|pluralize|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (declare (ignore fmode target))
                                               (report-error 'user-error
                                                             "(pluralize ~a): pluralize is no longer defined in KM1.4 - use \"-s\" suffix instead!~%"
                                                             expr))
                                           f-mode target xrl)
                                  '(|pluralize| ?expr)))))))
                (when (eql xl '|spy|)
                  (or (when (consp xr)
                        (let ((xrl (first xr)) (xrr (rest xr)))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target expr) (declare (ignore fmode target)) (spy expr)) f-mode target xrl)
                                      '(|spy| ?expr))))))
                      (when (eql xr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target) (declare (ignore fmode target)) (spy)) f-mode target) '(|spy|))))))
                (when (eql xl '|unspy|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (fmode target) (declare (ignore fmode target)) (unspy)) f-mode target) '(|unspy|)))))
                (when (eql xl '|profile|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (declare (ignore fmode target))
                                               (let ((*profiling* t))
                                                 (profile-reset)
                                                 (let ((answer (km-int expr))) (km-format t "~a~%" answer) (profile-report) answer)))
                                           f-mode target xrl)
                                  '(|profile| ?expr)))))))
                (when (eql xl '|profile-report|)
                  (or (when (eql xr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target) (declare (ignore fmode target)) (profile-report) '(|t|)) f-mode target)
                                  '(|profile-report|))))
                      (when (consp xr)
                        (let ((xrl (first xr)) (xrr (rest xr)))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target n) (declare (ignore fmode target)) (profile-report n) '(|t|)) f-mode
                                               target xrl)
                                      '(|profile-report| ?n))))))))
                (when (eql xl '|taxonomy|)
                  (return-from km-handler
                    (values (funcall #'(lambda (fmode target args)
                                         (declare (ignore fmode target))
                                         (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>)~%"))))
                                     f-mode target xr)
                            '(|taxonomy| &rest))))
                (when (eql xl '|checkpoint|)
                  (or (when (eql xr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target) (declare (ignore fmode target)) (set-checkpoint) '(|t|)) f-mode target)
                                  '(|checkpoint|))))
                      (when (consp xr)
                        (let ((xrl (first xr)) (xrr (rest xr)))
                          (when (eql xrr 'nil)
                            (return-from km-handler
                              (values (funcall #'(lambda (fmode target checkpoint-id)
                                                   (declare (ignore fmode target))
                                                   (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|))))
                                               f-mode target xrl)
                                      '(|checkpoint| ?checkpoint-id))))))))
                (when (eql xl '|undo|)
                  (when (eql xr 'nil)
                    (return-from km-handler
                      (values (funcall #'(lambda (fmode target) (declare (ignore fmode target)) (cond ((undo) '(|t|)))) f-mode target)
                              '(|undo|)))))
                (when (eql xl '|an|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrl '|instance|)
                        (when (consp xrr)
                          (let ((xrrl (first xrr)) (xrrr (rest xrr)))
                            (when (eql xrrl '|of|)
                              (when (consp xrrr)
                                (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr)))
                                  (or (when (eql xrrrr 'nil)
                                        (return-from km-handler
                                          (values (funcall #'(lambda (fmode target expr)
                                                               (km-int `(|an| |instance| |of| ,expr |with|)
                                                                 :fail-mode fmode
                                                                 :target target
                                                                 :rewritep t))
                                                           f-mode target xrrrl)
                                                  '(|an| |instance| |of| ?expr))))
                                      (when (consp xrrrr)
                                        (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr)))
                                          (when (eql xrrrrl '|with|)
                                            (return-from km-handler
                                              (values (funcall #'(lambda (fmode target expr slotsvals)
                                                                   (declare (ignore fmode target))
                                                                   (cond ((are-slotsvals slotsvals)
                                                                          (let* ((classes (km-int expr))
                                                                                 (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))))
                                                                            (cond ((or classes classes-in-slotsvals)
                                                                                   (list (create-instance class new-slotsvals))))))))
                                                               f-mode target xrrrl xrrrrr)
                                                      '(|an| |instance| |of| ?expr |with| &rest))))))))))))))))
                (when (eql xl '|reverse|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target seq-expr)
                                               (let ((seq (km-unique-int seq-expr :fail-mode fmode :target target :rewritep t)))
                                                 (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)))))
                                           f-mode target xrl)
                                  '(|reverse| ?seq-expr)))))))
                (when (eql xl :|default|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (declare (ignore fmode target expr))
                                               (km-setq '*are-some-defaults* t)
                                               nil)
                                           f-mode target xrl)
                                  '(:|default| ?expr)))))))
                (when (eql xl '|sometimes|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr) (km-int expr :fail-mode fmode :target target :rewritep t)) f-mode
                                           target xrl)
                                  '(|sometimes| ?expr)))))))
                (when (eql xl '|anonymous-instancep|)
                  (when (consp xr)
                    (let ((xrl (first xr)) (xrr (rest xr)))
                      (when (eql xrr 'nil)
                        (return-from km-handler
                          (values (funcall #'(lambda (fmode target expr)
                                               (declare (ignore fmode target))
                                               (cond ((anonymous-instancep (km-unique-int expr :fail-mode 'error)) '(|t|))))
                                           f-mode target xrl)
                                  '(|anonymous-instancep| ?expr))))))))))
        (when (eql x '|nil|)
          (return-from km-handler
            (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) nil) f-mode target) '|nil|)))
        (when (eql x 'nil)
          (return-from km-handler (values (funcall #'(lambda (_fmode _target) (declare (ignore _fmode _target)) nil) f-mode target) 'nil)))
        (return-from km-handler
          (values (funcall #'(lambda (fmode0 target path)
                               (declare (ignore target))
                               (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) (km-int (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 (km-int (first path))))
                                                      (y (vals-to-val (km-int (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 (km-int (butlast (butlast path)) :fail-mode fmode0)
                                                                     (last-el (butlast path)) (last-el path)
                                               :fail-mode fmode0))
                                            (t (vals-in-class (km-int (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 (km-int frameadd :fail-mode fmode0) slot0 '* :fail-mode fmode0))
                                              (t
                                               (let* ((slot (cond ((pathp slot0) (km-unique-int slot0 :fail-mode 'error)) (t slot0)))
                                                      (fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0)))
                                                      (frames (km-int frameadd :fail-mode fmode)))
                                                 (cond ((not (equal frames (val-to-vals frameadd)))
                                                        (km-int `(,(vals-to-val frames) ,slot) :fail-mode fmode))
                                                       (t (km-multi-slotvals frames slot :fail-mode fmode))))))))))
                           f-mode target x)
                  '?path)))))

(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 ====================

;;; FILE: licence.lisp

;;; File: licence.lisp
;;; Author: Peter Clark
;;; Purpose: Recite Simplified BSD Licence to the user.

;;; English spelling!
(defun licence () (license))

(defun license ()
  (format t "
This software is released under the Simplified BSD Licence (below). If you would like a 
copy of this software issued under a different license please contact the authors.

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

Copyright (c) 1994-2011 Peter Clark and Bruce Porter. All rights reserved.

Redistribution and use in source and binary forms, with or without modification, are
permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice, this list of
      conditions and the following disclaimer.

   2. Redistributions in binary form must reproduce the above copyright notice, this list
      of conditions and the following disclaimer in the documentation and/or other materials
      provided with the distribution.

THIS SOFTWARE IS PROVIDED BY PETER CLARK AND BRUCE PORTER ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL PETER CLARK AND BRUCE PORTER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

The views and conclusions contained in the software and documentation are those of the
authors and should not be interpreted as representing official policies, either expressed
or implied, of Peter Clark and Bruce Porter.

Contact information:
Peter Clark (peterc@vulcan.com)
Bruce Porter (porter@cs.utexas.edu)
"))
;;; FILE: LICENCE
#|
This software is released under the Simplified BSD Licence (below). If you would like a 
copy of this software issued under a different license please contact the authors.

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

Copyright (c) 1994-2011 Peter Clark and Bruce Porter. All rights reserved.

Redistribution and use in source and binary forms, with or without modification, are
permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice, this list of
      conditions and the following disclaimer.

   2. Redistributions in binary form must reproduce the above copyright notice, this list
      of conditions and the following disclaimer in the documentation and/or other materials
      provided with the distribution.

THIS SOFTWARE IS PROVIDED BY PETER CLARK AND BRUCE PORTER ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL PETER CLARK AND BRUCE PORTER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

The views and conclusions contained in the software and documentation are those of the
authors and should not be interpreted as representing official policies, either expressed
or implied, of Peter Clark and Bruce Porter.

Contact information:
Peter Clark (peterc@vulcan.com)
Bruce Porter (porter@cs.utexas.edu)
|#
;;; FILE: initkb.lisp

;;; File: initkb.lisp
;;; Author: Peter Clark
;;; Purpose: Initialize the KB (directive). This file is loaded last.

(reset-kb)

(defun version () 
  (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)

(version)
(format t "Documentation at http://www.cs.utexas.edu/users/mfkb/km/~%")
(cond (*using-km-package*
       (format t "Type (in-package :km) then (km) for the KM interpreter prompt!~%"))
      (t (format t "Type (km) for the KM interpreter prompt!~%")))

; (hash-dollar)