;;; FILE: README.txt
;;; KM - The Knowledge Machine - Build Date:  Mon Nov 2 11:32:42 PST 2009 
#|
======================================================================
	 KM - THE KNOWLEDGE MACHINE - INFERENCE ENGINE 2.2.33
======================================================================
Copyright (C) 1994-2009 Peter Clark and Bruce Porter

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

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

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

Contact information:
Peter Clark, m/s 7L-66, Mathematics and Computing Technology, 
      The Boeing Company, PO Box 3707, Seattle, WA 98124, USA.
      (peter.e.clark@boeing.com)
Bruce Porter, m/s C0500, Dept Computer Science, 
      Univ Texas at Austin, Austin, TX 78712, USA. (porter@cs.utexas.edu)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Peter Clark
peter.e.clark@boeing.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]

(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)
      (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");
	}
	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*))

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

;;; 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.2.33")
(defparameter *year* "2009")
(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-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 2
    *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
    *classification-enabled* 
    *prototype-classification-enabled* 
    *use-inheritance*
    *use-prototypes*
    *developer-mode*
    ))

(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* 2)	; 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)

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

;;; [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-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
      *unclonable-slots*
;      *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
(defparameter *km-runtime-variables* 
    '(*trace*
      *depth*
      *internal-logging*
      *am-classifying*
      *looping*
      *spypoints*
      *profiling*
      *print-explanations*
      *show-comments*
      *deleted-frames*
      ))

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

(defvar *curr-prototype* nil)		; For prototype mode
(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 *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*

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

;;; ======================================================================
;;;			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))))

;;; (get-dispatch-macro-character #\# #\t)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (set-dispatch-macro-character #\# #\t #'hash-t-reader))


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

(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)
    (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 hash-dollar-reader (stream subchar arg)
   (declare (ignore subchar arg))
   (case-sensitive-read-km stream t nil t)))

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

;;; ======================================================================
;;;			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 (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))))

(eval-when
 (:compile-toplevel :load-toplevel :execute)
 (set-dispatch-macro-character #\# #\, #'hash-comma-reader))
;;; FILE: interpreter.lisp
 
;;; File: interpreter.lisp
;;; Author: Peter Clark
;;; Date: July 1994
;;; Purpose: KM Query Language interpreter

(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 
	must is-superset-of covers subsumes has-definition numberp bag seq #|override|#
	no-inheritance comm
	trace untrace fluent-instancep at-least at-most exactly constraint <> reverse
	is-subsumed-by is-covered-by set-constraint set-filter
	in-situation in-every-situation end-situation do do-and-next in-theory end-theory see-theory hide-theory visible-theories
	curr-situation ignore-result do-script new-context do-plan))

(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 
    clear-evaluation-cache install-all-subclasses clean-taxonomy scan-kb
    disable-classification enable-classification explain-all clear-explanations
    disable-installing-inverses enable-installing-inverses
    start-logging stop-logging no-explanations explanations clear-situations
    sanity-checks no-sanity-checks store-kb restore-kb
    fail-quietly fail-noisily requires-km-version catch-explanations show-explanations show-explanations-xml
    instance-of-is-fluent instance-of-is-nonfluent 
    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* 
  '#$(:set if forall allof oneof theoneof forall-seq forall-bag
	   forall2 allof2 oneof2 theoneof2 forall-seq2 forall-bag2
	   :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))

; 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
(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 kmexpr :fail-mode fail-mode))))
	       (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.
|#
#|
(defun km-eval (km-expr &key (fail-mode *top-level-fail-mode*))
; (reset-done)	; see test-suite/cache-problem3.km

; Move these now up to KM
  (cond (*looping*			; better: Only need to reset the cache if you were looping.
	 (reset-done) (setq *looping* nil)))
  (cond ((am-in-prototype-mode) ; purely cosmetic: Store prototype build commands and print them out if you do a save-kb
	 (add-to-prototype-definition *curr-prototype* km-expr))) 
  (cond ((km-assertion-expr km-expr) (reset-done) (clear-cached-explanations))) ; [1]

  (let ((answer (catch 'km-abort (desource (km-int km-expr :fail-mode fail-mode)))))
    (cond ((and (listp answer)
		(eq (first answer) 'km-abort)) ; error encountered
	   (values nil (second answer) (third answer)))
	  (t answer))))
|#

;;; 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)
      (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 (answer (km-trace 'exit "<- ~a~30T\"~a\"" answer trace-expr))
				    (t (km-trace 'fail "<- FAIL!~30T\"~a\"" trace-expr)))) )
	(cond ((eq users-response 'redo)
	       (reset-done)
	       (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 *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)
;;; NEW: Decomment *everything* ONLY at the top level		   
		   (t (desource-top-level (decomment kmexpr-with-comments))))

	#|
             (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)
	  (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 (answer (cond (target (km-trace 'exit "<- ~a~40T [~a, for ~a]" answer kmexpr-with-comments target))
			      (t (km-trace 'exit "<- ~a~40T [~a]" answer kmexpr-with-comments))))
		(t  (cond (target (km-trace 'fail "<- FAIL!~40T [~a, for ~a]" kmexpr-with-comments target))
			  (t (km-trace 'fail "<- FAIL!~40T [~a]" kmexpr-with-comments)))))) )
    (cond ((eq users-response 'redo)
	   (reset-done)
	   (km1 kmexpr kmexpr-with-comments :fail-mode fail-mode :target target :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 ...)
(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 kmexpr :fail-mode fail-mode)))))
	  (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))))) )

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


    ; =======================
    ; 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)))))))) )

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

    ( (#$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)) )
	     (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 (cond ((or (constraint-exprp (desource val-expr))
			       (existential-exprp (desource val-expr))
			       (comparison-operator slot)) (desource val-expr)) ; 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)) )
      
    ( (#$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)))
	(#$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))
	       (#$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)))))
	(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)
;OLD	((km-slotvals-from-kb frame slot :fail-mode fail-mode))
#|NEW|#	((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

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

;;; 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))
	  (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 				; [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-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)) 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)
					   :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 :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) Combine ~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 :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) Combine ~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 _inherited-rule-sets-dummy _project1-dummy _project2-dummy _all-vals-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, local-constraints = ~a~%" target 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

;;; ======================================================================
;;; 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 aggregation-function)
   *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
      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

;;; May be recomputed if built-in-inertial-fluent-slots changes (see instance-of-is-fluent)
(defparameter *built-in-non-fluent-slots*
  (set-difference *built-in-slots* (append *built-in-inertial-fluent-slots* *built-in-non-inertial-fluent-slots*)))

;;; Let's allow the user to toggle these...
(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*
	(set-difference *built-in-slots* (append *built-in-inertial-fluent-slots* *built-in-non-inertial-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*
	(set-difference *built-in-slots* (append *built-in-inertial-fluent-slots* *built-in-non-inertial-fluent-slots*))))

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

;;; For instances of these classes, KM *assumes* that the instances/instance-of relation will *not*
;;; vary between situations, and thus will only read and write to the global situation.
; NOTE: put in interpreter.lisp, so it can be loaded before use
;(defparameter *built-in-classes-with-nonfluent-instances-relation* '#$(Situation Slot Theory Partition))

;;; the rest are all non-fluents

;;; EXPRESSIONLESS SLOTS:
;;; The following slots can't have KM expressions as values, only
;;; atomic values. This is because they are accessed by optimized access methods
;;; (get-vals) which assume atomic values and make no attempt to 
;;; evaluate any expressions found there. Also, their values are not unified together,
;;; they are set unioned, which means that find-vals will encounter a list of values,
;;; not a to-be-unifed value expression.
;;; NOTE: KM doesn't actually make the test of built-in-atomic-vals-only -- rather the assumptions of expressionlessness
;;; 	  are hard-wired into the code itself.
(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 supersituations members member-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
		   prototypes prototypes-of prototype-participants prototype-participant-of assertions))

;;; (every f has (s (v))), (every f has (s (v'))) -> (every f has (s (v v'))) NOT (every f has (s ((v) && (v'))))
;;; Also - all INVERSE assertions are automatically by appending; sigh and urgh!
(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) 
  (member 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
(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)
	 (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)))
	((known-frame 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 ((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))
  (if (null list)
      nil
      (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)))		; dereferenced list
  (mapc #'(lambda (concept)
	    (cond ((not (eql concept (dereference concept))) 	; i.e., is bound, so will have been dereferenced away
		   (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)))
  (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)))
  (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. Doesn't remove inverse links or
scan through situations. NOTE: vals can validly be NIL, in the case where (i) lazy-unify may put a *path* 
on an instance's slot, then (ii) it later is evaluated to NIL. So in that case, a put-vals with NIL will 
remove that cached path.
This DOESN'T require that the right situation has been identified, here the determination of target-situation is done WITHIN this procedure
[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.
|#
(defun put-vals (instance slot vals0 &key (facet 'own-properties) (install-inversesp t) (situation (curr-situation)))
  (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
	     (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)
			      (let ((parent-classes 
				     (mapcar #'(lambda (val)
						 (cond ((kb-objectp val) val)
						       ((first (class-description-to-class+slotsvals val)))))
					     vals)))
				(point-parents-to-defined-concept instance parent-classes 'prototype-definition))))
		       (cond ((and (member facet '(own-definition own-properties))
				   install-inversesp)
			      (install-inverses instance slot (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) (situation (curr-situation)) (install-inversesp t))
    (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)))
  (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
	       (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)) 
					       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)) 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 (situation (curr-situation)) retain-commentsp)
 (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 (situation (curr-situation)) retain-commentsp)
 (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 (situation (curr-situation)) retain-commentsp)
  (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 (situation (curr-situation)) retain-commentsp ignore-prototypes)
  (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)) 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 (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)))
  (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
;;; ======================================================================

(defun point-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))))
    (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)))
			   (make-comment "Noting definition for ~a..." frame)
			   (cond ((member frame children))	  ; already got this definition
				 (t ;(setf (get parent defined-children-facet) (cons frame children))
;				    (make-transaction `(setf ,parent ,defined-children-facet ,(cons frame children)))
				  (km-setf parent defined-children-facet (most-specific-first (cons frame children)))
				  ;;; NEW: Must try most specific classifications first! HLO bug
				    ))))
		   parents)))))

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



;;; 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 (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 ((known-frame 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)
	 (kb-objectp frame)
	 (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 (curr-situation)))
  (frame-has-something-to-say-about instance slot 'member-properties situation))

;;; We could be even more thorough here by also checking whether its classes have something to say about slot
(defun instance-has-something-to-say-about (instance slot &optional (situation (curr-situation)))
  (frame-has-something-to-say-about instance slot 'own-properties situation))

(defun frame-has-something-to-say-about (frame slot facet &optional (situation (curr-situation)))
  (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.
;;; 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
(defun classify (instance &key (slots-that-changed 'unspecified) slot-of-interest)	; [3]
  (cond ((and (classification-enabled)
	      (or *classify-slotless-instances*
		  slots-that-changed)		; may be NIL, as opposed to unspecified
	      *are-some-definitions*
	      (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)))))))

(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)))
		     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)
  (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")))
;;; [1] or  = ((instance-of (Chemical)) (has-basic-structural-unit ((a Zn (@ Zn-Substance has-basic-structural-unit)))))
(defun might-be-member (instance parent)
;  (km-format t "(might-be-member ~a ~a)? " instance parent)
  (let* ((slotsvals (append (get-slotsvals parent :facet 'member-definition :situation *global-situation*)
			    (cond ((am-in-local-situation)
				   (get-slotsvals parent :facet 'member-definition)))))
	 (missing-required-info
	  (some #'(lambda (slotvals)
		    (let* ((slot (slot-in slotvals))
			   (dvals (vals-in slotvals))
			   (ivals (get-vals instance slot)))
;		      (km-format t "slot = ~a, dvals = ~a, ivals = ~a, already-done = ~a~%" slot dvals ivals
;				 (already-done instance slot))
		      (and (already-done instance slot)
			   (not (remove-subsumers-slotp slot))	; can have different, named vals and still subsume
			   (not (remove-subsumees-slotp slot))
			   (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))))))
		slotsvals)))
;    (cond (missing-required-info (km-format t "nope.~%"))
;	  (t (km-format t "maybe....~%")))
;    (km-format t "slotsvals = ~a~%" slotsvals)
    (and (not missing-required-info)
	 (let* ((rest+slot+class (minimatch slotsvals '#$((instance-of &rest) (?slot ((a ?class &rest))) &rest)))  ; [1]
		(slot (second rest+slot+class))
		(class (third rest+slot+class))
		(vals (cond (slot (get-vals instance slot)))))
;	   (km-format t "slot = ~a, class = ~a, vals = ~a..." slot class vals)
	   (cond ((and rest+slot+class			; IF just need a class
		       (already-done instance slot)
		       (singletonp vals) ; and already got an instance
		       (kb-objectp (first vals)))	; not a constraint e.g., slot = instance-of, vals = ((<> *ShinerBock))
		  (isa (first vals) class)) ; check class membership		  
;		  (km-format t "try the test (isa ~a ~a)..." (first vals) class)
;		  (let ((v (isa (first vals) class))) ; check class membership
;		    (cond (v (format t "yes, continue to classify!~%") t)
;			  (t (format t "no, abort classify~%")))))
;		 (t (km-format t "(skip the test, continue to classify)~%") t))))))
		 (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 (instance new-immediate-parent explanation)
 (let* ( (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)
(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)
  (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)))))

;;; ======================================================================
;;;			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))))))

;;; Shadow of KM. Find immediate generalizations of a frame.
;;; The top generalization is #$Thing
;;; [1] instance-of is treated as a *Non-Fluent for Slots and Situations, and so we must also check the global
;;;     situation here. For cases where it's a fluent, it's value will be cached in the local situation.
;;; [2] :enforce-constraints - if we always enforce constraints, the system will easily fall into infinite
;;;	recursion. So we restrict how much this is allowed. Here we just allow it when the user explicitly
;;;     requests it.
;;; [3] enforce-constraints may change the parent classes, so we then must recheck what the parent
;;;     classes are (this recursive call WITHOUT constraint checking this time, to prevent looping)
(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)
	  ((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)
  (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 other-class class)))	 
			classes))
	      classes)
   :from-end t))

;;; Returns the most general class(es) in a list
;;; (remove-subsumees '(car vehicle car tree)) -> (vehicle tree)
;;; NOTE preserves order, so if there are no subsumees, then (remove-subsumees x) = x.
(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!!
|#
(defun all-instances (class)
  (remove-duplicates
   (my-mapcan #'immediate-instances (cons class (all-subclasses class)))))	; dereferencing done in immediate-instances

;;; [1] This is probably redundant, as instances should never be declared a fluent. However, it used to be allowed as an option
;;; a long time ago, so let's leave it there.
;;; NOTE: We *won't* consider *Global to be an instance of Situation, as really Situation is meant to mean situation-specific situation
(defun 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 immediate-protoinstances (class) 
  (remove-if-not #'protoinstancep (km-int `#$(the instances of ,CLASS))))

(defun all-prototypes (class)
  (remove-dup-instances
   (append (get-vals class '#$prototypes :situation *global-situation*)
	   (mapcan #'all-prototypes (immediate-subclasses class)))))

(defun all-protoinstances (class)
  (remove-if-not #'protoinstancep (all-instances class)))

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

;;; Return a list of all situations used in the current session.
;;; It includes doing dereferencing (in all-instances)
;;; [1] Strictly, should be remove-dup-instances; however all-instances has already done this (including dereferencing), so we just need to make sure 
;;;	we don't have *global-situation* in twice.
(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)
   ((member slot *built-in-non-fluent-slots*) '#$*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 (curr-situation)))
  (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 (curr-situation)))
  (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 (curr-situation)))
  (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 (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 ()
  (format t "Removing redundant superclasses...~%")
  (mapc #'remove-redundant-superclasses (get-all-concepts)) ; [2]
  (format t "Removing redundant subclasses...~%")
  (mapc #'remove-redundant-subclasses (get-all-concepts)) ; [2]
  (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 (first slotvals))
						    (vals (second 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
		(mapc #'(lambda (vals0)
			  (let ((vals (cond ((single-valued-slotp slot) (un-andify vals0))
					    (t vals0))))
			    (uninstall-inverses frame slot vals situation)))	; includes explanations
		      (get-vals frame slot :situation situation))))
	 (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)))))

#|
(defun delete-slot (frame slot &key (delete-inversesp t))
  (cond ((known-frame frame)
	 (cond (delete-inversesp
		(mapc #'(lambda (situation)
			  (mapc #'(lambda (slotvals)
				    (let ( (slot (first slotvals))
					  (vals (second slotvals)) )
				      (uninstall-inverses frame slot vals situation)))
				(get-slotsvals frame :situation situation)))
		      (all-situations-and-theories))))
	 (remove-from-stack frame)
	 (delete-frame-structure frame)
	 t)
	(t (report-error 'user-error "(delete-frame ~a): ~a is not a known frame.~%" frame frame))))

;;; Rewritten 4/2/08
(defun delete-slot (instance slot &optional (facet 'own-properties) 
					    (situation (target-situation (curr-situation) instance slot)))
  (let ((vals (get-vals instance slot :situation situation)))
    
  
   (put-vals instance slot nil :install-inversesp nil :facet facet :situation situation))
|#

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

(defun scan-kb ()
  (let* ( (declared-symbols (get-all-concepts))
	  (all-objects (flatten (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)
						(comment-tagp symbol)
						(km-varp symbol)
						(member (invert-slot symbol) declared-symbols)))
					 user-symbols)) )
    (cond (undeclared-symbols
	   (km-format t "A cursory check of the KB shows (at least) these symbols were undeclared:~%" (length undeclared-symbols))
	   (mapc #'(lambda (symbol) (km-format t "   ~a~%" symbol)) 
		 (sort undeclared-symbols #'string< :key #'symbol-name))
	   (format t "----- end -----~%")))
; Remove this confusing message
;	  (t (km-format t "(No All the symbols in the KB have frames declared for them)~%")))
    '#$(t)))


;;; ======================================================================
;;;		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
(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

;;; ======================================================================
;;;		    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*
(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))))

(defun show-explanations-xml (&key (stream t)) (show-explanations :format 'xml :stream stream))
(defun show-explanations-html (&key (stream t)) (show-explanations :format 'html :stream stream))

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

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

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

(defun val-unification-operator (x) (member x '(& &? &! &+ &+? ==)))
(defun set-unification-operator (x) (member x '(&& #|&&?|# &&! ===)))
(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

#|
MAIN ENTRY POINTS
=================
LAZY-UNIFY-&-EXPR -> lazy-unify-exprs -> lazy-unify: Use for &, &&
TRY-LAZY-UNIFY: Use for &?

WARNING! try-lazy-unify MAY have side-effects if called with :eagerlyp t (see HLO-2200) later.
   This is bad; really try-lazy-unify should not even have the :eagerlyp option in the first place.

Note there is no &&? operator any more. 

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

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

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

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

eagerlyp: if true, then do eager rather than lazy unification, ie. don't leave any & or && residues on frames, 
 just atomic values.
|#
(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))
 (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)) )
    (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 (classes-subsumep '&&) (eagerlyp '&!) (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)))
    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))
; (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)))))

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

#|
[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))
  (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)	; (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.
|#
(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))

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

#|
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))
  (multiple-value-bind
      (unified-name bindings)
      (unify-names instance1 instance2 classes-subsumep)
    (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)) )
;	     (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))
  (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)) )
	     (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)) )
			(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))
  (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)
	    (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 classes-subsumep)
  (cond 
   ((eq  instance1 instance2) (values instance1 nil)) 			; (*car2 & *car2)
   ((incompatible-instances instance1 instance2) 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
;;; [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 ((and (named-instancep instance1) 
	      (named-instancep instance2)	; (*f & *g) FAILS
	      (neq instance1 instance2)))
	((classp instance1) (not (isa instance2 '#$Class)))	; if instance1 is a class, then so must instance2 be (e.g. (Car & _Class3)
	((classp instance2) (not (isa instance1 '#$Class)))	; if instance1 is a class, then so must instance2 be (e.g. (Car & _Class3)
	(*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)))))
		    )
	   (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)

|#
(defun lazy-unify-slotsvals (i1 i2 svs1 svs2 &key cs1 cs2 classes-subsumep eagerlyp (check-constraintsp t))
  (cond
   ((and (endp svs1)
	 (endp svs2)))	; ie. return (values t nil)
   (t (let* ( (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))
	      ((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 :eagerlyp eagerlyp))

	       (multiple-value-bind
		   (unified-vals successp1)
		   (lazy-unify-vals slot i1 i2 exprs1 exprs2 
				    :cs1 cs1 :cs2 cs2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp)
		 (cond (successp1			;; 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)
			 (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 eagerlyp)
  (check-slotvals-constraints0 slot i1 i2 exprs1 exprs2 :cs1 cs1 :cs2 cs2 :eagerlyp eagerlyp))

(defun check-slotvals-constraints0 (slot i1 i2 exprs1 exprs2 &key cs1 cs2 eagerlyp)
  (declare (ignore eagerlyp))
 (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)) )
|#
#|NEW|# (constraints1 (mapcan #'find-constraints-in-exprs cs1-expr-sets-all))
	(constraints2 (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 
			    (cons '#$(exactly 1 Thing) 			; in test-suite/constraints.km for a case where we need this work.
				  (append constraints1 constraints2)))
			   (t (append constraints1 constraints2)))) )

;    (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))
				(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]
				      ))))
		     (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))
				      ))))
;		     (_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 "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 
					    (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]
					    constraints)))
		(t (cond ((and i1 i2) (km-trace 'comment "Instances ~a and ~a won't unify [constraint violation on slot `~a':" i1 i2 slot))
			 (i1 (km-trace 'comment "Instance ~a won't unify with (a ~a with (~a ~a) ...)" i1 (delistify cs2) slot exprs2))
			 (i2 (km-trace 'comment "Instance ~a won't unify with (a ~a with (~a ~a) ...)" i2 (delistify cs1) slot exprs1))
			 (t (km-trace 'comment "(a ~a with (~a ~a) ...) and (a ~a with (~a ~a) ...) won't unify~%     [constraint violation on slot `~a':" 
				      (delistify cs1) slot exprs1 (delistify cs2) slot exprs2 slot)))
		   (km-trace 'comment "  constraints ~a violated by value(s) ~a on slot ~a.]" constraints (append vs1 vs2) slot)))))))))

;;; ======================================================================
;;;		LAZY-UNIFY-VALS
;;; ======================================================================

#|
lazy-unify-vals: One of the vs1 or vs2 may be nil, **but not both**
RETURNS TWO values
  (i) The unified structure (NB may be NIL with eagerlyp option), denoting the unified vals
  (ii) A t/nil flag depending on whether the unification was successful or not
11/17/00: This *doesn't* catch single-valued slot constraints, when v1 is local and given, but v2 is
	  to be inherited and clashes with v1.
 	  SOLUTION: Move the single-valued-slotp test to check-slotvals-constraints.
		(age has  (instance-of (Slot)) (cardinality (N-to-1)))
		(_Person1 has (age (23))))
		(new-situation)
		(_Person2 has (age (24)))
		(_Person1 &? _Person2)		will incorrectly succeed in KM 1.4.1.6 and earlier

(_v1) (_v2) -> ((_v1 & _v2))
((a cat)) ((a hat)) -> (((a cat) & ((a hat)))
[1]: and-append returns a (singleton) LIST of expressions, but we just want to pass a SINGLE expression to KM.
[2] If this unification fails, it doesn't mean a KB error, it just means that the two parent instances can't be unified.
    The failure is passed up to lazy-unify-slotsvals above, and the unification aborted. lazy-unify-slotsvals returns successp NIL.
[3]: KM necessarily returns either NIL or a singleton list here.
[4]: In the special case of ((<> foo) &! (<> bar)), an answer of NIL from evaluating the expression *doesn't* constitute failure of the
	unification.
[5]: Not an error, but would like to tidy this up: ((<> foo) &&! (<> bar)) should be reduced to ((<> foo) (<> bar))
[6]: If classes-subsumep is TRUE, then we are doing SET unification.
     Thus, we should FAIL if we are forced to coerce vs1 and vs2 to unify, ie. if
	- slot is a single-valued
	- vs1 and vs2 do not satisfy the classes-subsumep test
[7]  USER(49): (lazy-unify-vals '#$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!
|#
(defun lazy-unify-vals (slot i1 i2 vs1 vs2 &key cs1 cs2 classes-subsumep eagerlyp) 
  (declare (ignore i1 i2 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)
;;; 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/hlo2366.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
		  ))
	 (values (remove-dup-instances (append vs1 vs2)) 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...

         (cond ((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-int `(,(first vs1) &+? ,(first vs2))))		    ; [2], [6]
		      (t (km-int `(,(first vs1) &? ,(first vs2)))))		    	    ; [2], [6]
		(cond (eagerlyp 
		       (let ((new-vals (km-int (vals-to-val (and-append (list (first vs1)) '&! (list (first vs2))))    ; eagerly -> do it!  [1],[3]
					   )) )						    ; [4]
			 (cond ((not *are-some-constraints*) (values new-vals t))
			       ((or new-vals
				    (and (null (remove-constraints vs1))					    ; [4]
					 (null (remove-constraints vs2))))
				(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 (let ( (vs1-vals (remove-constraints vs1))				; see note [7] under lazy-unify-expr-sets
			 (vs2-vals (remove-constraints vs2))
			 (vs1-constraints (find-constraints-in-exprs vs1))
			 (vs2-constraints (find-constraints-in-exprs vs2)) )
		    (cond ((null vs1-vals) (values (append vs2-vals vs1-constraints vs2-constraints) t))
			  ((null vs2-vals) (values (append vs1-vals vs1-constraints vs2-constraints) t))
			  ((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
					     vs1-constraints vs2-constraints)
				     t))
			  (t (values (append (km-int (vals-to-val (and-append vs1 '&&! vs2)))
					     vs1-constraints vs2-constraints)
				     t)))))
;       (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))))

;;; ---------
#|
;;; This function re-inserts the local constraints into the unified expressions
;;; [1] multi-valued slot, [2] single-valued slot
;;; [1] (reinstate-constraints '#$foo '(x y) '#$((<> z) (<> p)) '#$((must-be-a C)))  -> #$(x y (<> z) (<> p) (must-be-a c))
;;; [2] (reinstate-constraints '#$foo '((x & y)) '#$((<> z) (<> p)) '#$((must-be-a C))) -> ((x & y & (<> z) & (<> p) & (must-be-a c)))
(defun reinstate-constraints (slot unified-vals exprs1 exprs2)
  (let ( (local-constraints (append (find-constraints-in-exprs exprs1) (find-constraints-in-exprs exprs2))) )
    (cond ((not local-constraints) unified-vals)
	  ((single-valued-slotp slot) 
	   (val-to-vals (vals-to-&-expr (remove-duplicates (append (un-andify unified-vals) local-constraints) :test #'equal))))
	  (t (remove-duplicates (append unified-vals local-constraints) :test #'equal)))))
|#


#|
; NEW:
	 (cond ((km-int `#$((the ,SLOT of ,I1) &?  (the ,SLOT of ,I2)))	; returns a shorter unification expression (or fails).
		(and-append (list (first vs1)) '& (list (first vs2))))))
; OLD	(t (km-int `(,vs1 &&? ,vs2)))))
; NEW:
	v1s the slot of i1
	v2s the slot of i2
	THEN do &&


	((km-int `#$((the ,SLOT of ,I1) &&? (the ,SLOT of ,I2)))
	 (and-append vs1 '&& vs2))))
|#

; OLD	   (let ( (v1 (first vs1))
; OLD		  (v2 (first vs2)) )
;#|NEW|#	   (km-trace 'comment "Seeing if values for single-valued slot `~a' are unifiable..." slot)
;#|NEW|#	   (km-trace 'comment "(Values are: ~a and ~a)" (first vs1) (first vs2))
;#|NEW|#	   (let ( (v1 (km-unique-int (first vs1)))
;#|NEW|#		  (v2 (km-unique-int (first vs2))) )
;	     (cond ((and (atom v1) (atom v2))		    ; Check for inconsistency
;		    (let ( (vv1 (dereference v1))    ; just in this special case	; DEREF NOT NECESSARY WITH NEW
;			   (vv2 (dereference v2)) )  ; of two named single values.
;		      (cond ((and (named-instancep vv1)
;				  (named-instancep vv2))
;			     (cond ((equal vv1 vv2) (list vv1))))   ; else FAIL (nil)
; OLD			    (t 
;#|NEW|#			    ((km-int `(,vv1 &? ,vv2))	; test feasibility of unification
;			     (and-append (list vv1) '& (list vv2))))))
;		   (t (and-append (list v1) '& (list v2))))))))

;;; ======================================================================
;;; 		LAZY-UNIFY-EXPRS
;;; Does a subsumption check first
;;; ======================================================================

;;; Must be an & expr, ie. either (a & b), or ((a b) && (c d))
;;; The arguments to &/&& may themselves be &/&& expressions, 
;;; 	eg. ((a & b) & c),  
;;;	    ( (((a b) && (c d))) && (e f) )
;;; [ Note  (  ((a b) && (c d))  && (e f) ) is illegal, as the args to && must be a *list* of expressions ]
;;; ALWAYS returns a list of values (necessarily singleton, for '&)
;;; **NOTE** No point in doing any classification *DURING* unification (?). Better to wait until finished, and THEN do 
;;; unification. But...might be incomplete? Better leave it in.
(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