;;; FILE: README ;;; KM - The Knowledge Machine - Build Date: Fri Jan 21 14:56:20 PST 2005 #| ====================================================================== KM - THE KNOWLEDGE MACHINE - INFERENCE ENGINE 2.0.11 ====================================================================== Copyright (C) 1994-2005 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 7L66, Boeing, PO Box 3707, Seattle, WA 98124-2207, 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 > (load "km.lisp") ;;; <== You *must* do this before compiling! > (compile-file "km") ;;; see [1] below. Now > (load "km") will load the faster, compiled version in future. [1] *Note* you will need to load km.lisp first before compiling, so that the reader macro #$ is recognized by compile-file. 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: " headers below which denote the start of different files in this concatenation, OR use the Perl unpacker below which automatically cut this big file into its consistutent files. Warning: The code is largely undocumented! Peter Clark 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: Option 1. (For Emacs users) (save-excursion (let ((case-fold-search nil)) (goto-char (point-min)) (while (re-search-forward "^;;; FILE: +\\(.*\\)" nil t) (let ((matched (match-string 1)) (beg (match-beginning 0)) (end (or (save-excursion (when (search-forward-regexp "^;;; FILE: +.*" nil t) (match-beginning 0))) (point-max)))) (write-region beg end matched))))) ^ 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: # 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 "; $_ = ; $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 () { $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"; } else { print (OUTFILE $_); } } close(PACKED); close(OUTFILE); print "Completed without errors. Processed $lineno lines of input from $fn.\n"; ------------------------------ cut here ------------------------------ |# ;;; FILE: header.lisp ;;; File: header.lisp ;;; Purpose: Set some compilation flags etc. #| ====================================================================== 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. |# #| ;;; [1] UNCOMMENT THIS FOR PACKAGED VERSION OF KM (unless (find-package :km) (make-package :km)) (in-package :km) |# ;;; KM package is now the current package (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-alist* nil) (defconstant *var-marker-char* #\_) (defconstant *var-marker-string* "_") (defconstant *proto-marker-string* (concatenate 'string *var-marker-string* "Proto")) ; ie. "_Proto" (defconstant *fluent-instance-marker-string* (concatenate 'string *var-marker-string* "Some")) ; ie. "_Some" (defconstant *km-version-str* "2.0.11") (defconstant *year* "2005") (defparameter *km-handler-function* nil) ; used in compiler.lisp ; (defconstant *global-situation* '#$*Global) ; Put in case.lisp, AFTER #$ is defined. Note, need #$ ; (defconstant *tag-slot* '#$:tag) ; to allow case-sensitivity to be switched off. ;;; ------------------------------ ; from prototypes.lisp - move this to AFTER #$ declaration in case.lisp ;(defconstant *slots-not-to-clone-for* ; '#$(prototype-participant-of prototype-participants prototypes prototype-of #|source|# instance-of cloned-from)) ;;; -------------------- ;;; Optimization flags: note which bits of machinery are in use. ;;; -------------------- (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) ;;; ====================================================================== ;;; 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. (defconstant *km-behavior-parameters* '(*recursive-classification* ; default t *indirect-classification* ; 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 )) (defparameter *recursive-classification* t) (defparameter *indirect-classification* 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 ;;; [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. (defconstant *km-state-parameters* '(*km-gensym-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*)) ;;; -------------------- (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 *depth* 0) ; Tracing depth (defvar *internal-logging* nil) ; for internal backtracking ;;; New mechanism (defvar *visible-theories* nil) (defconstant *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 ",@") )) ;;; print _Car3 as: _Car3 #|"a Car&Dog"|# (defparameter *add-comments-to-names* t) ;;; Allow users to turn this off (to save memory) (defvar *record-explanations* t) (defparameter *record-sources* t) ;;; when t, exposes the source info on frame data structures (for debugging purposes) (defparameter *developer-mode* nil) ;;; ---------------------------------------- ;;; encapsulate checking flag (defvar *check-kb* nil) (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) ;;; 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 ;;; ====================================================================== ;;; 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. (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) (cerror "Ignore error and return." "during case-sensitive-read (premature end-of-file?)~% ~s" error)))))) ;;; This reads input into the KM package, rather than current package (defun case-sensitive-read-km (&optional stream (eof-err-p t) eof-val rec-p) (cond ((not (eq *package* *km-package*)) (let ( (*package* *km-package*) ) (case-sensitive-read stream eof-err-p eof-val rec-p))) (t (case-sensitive-read stream eof-err-p eof-val rec-p)))) ;;; JFT's update (defun hash-dollar-reader (stream subchar arg) (declare (ignore subchar arg)) (case-sensitive-read-km stream t nil t)) (set-dispatch-macro-character #\# #\$ #'hash-dollar-reader) (defconstant *global-situation* '|*Global|) (defconstant *slots-not-to-clone-for* '(|prototype-participant-of| |prototype-participants| |prototypes| |prototype-of| |instance-of| |cloned-from|)) ;;; ====================================================================== ;;; WRITING ;;; ====================================================================== #| This version of format *doesn't* put || 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 (defconstant *inverse-suffix* "-of") (defconstant *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)) |# (defun hash-comma-reader (stream subchar arg) (declare (ignore subchar arg)) (list 'unquote (case-sensitive-read-km stream t nil t))) (set-dispatch-macro-character #\# #\, #'hash-comma-reader) ;;; FILE: interpreter.lisp ;;; File: interpreter.lisp ;;; Author: Peter Clark ;;; Date: July 1994 ;;; Purpose: KM Query Language interpreter (defparameter *exhaustive-forward-chaining* nil) (defconstant *multidepth-path-default-searchdepth* 5) ;;; *additional-keywords* ARE allowed as slot names (defconstant *additional-keywords* '#$(TheValue TheValues * called uniquely-called Self QUOTE UNQUOTE == /== > <)) ; used for (scan-kb) in frame-io.lisp. (defconstant *infinity* 999999) (defconstant *reserved-keywords* ; NOT allowed as class or slot names '#$(a some must-be-a mustnt-be-a print format km-format an instance @ ; 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 showme-here showme showme-all evaluate-all quote delete evaluate has-value andify make-sentence make-phrase #|pluralize|# every has also-has must is-superset-of covers subsumes has-definition numberp bag seq #|override|# no-inheritance comm trace untrace fluent-instancep at-least at-most exactly constraint <> reverse is-subsumed-by is-covered-by set-constraint set-filter in-situation in-every-situation end-situation do do-and-next in-theory end-theory see-theory hide-theory visible-theories curr-situation ignore-result do-script new-context do-plan)) (defconstant *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 show-context checkkbon checkkboff show-bindings version show-obj-stack clear-obj-stack reset-done clear-evaluation-cache install-all-subclasses scan-kb disable-classification enable-classification explain-all clear-explanations disable-installing-inverses enable-installing-inverses start-logging stop-logging no-explanations explanations clear-situations sanity-checks no-sanity-checks store-kb restore-kb fail-quietly fail-noisily requires-km-version catch-explanations show-explanations show-explanations-xml instance-of-is-fluent instance-of-is-nonfluent no-search-control eval setq tracekm untracekm license enable-slot-checking disable-slot-checking comments nocomments)) (defconstant *downcase-km-lisp-exprs* (mapcar #'(lambda (expr) (intern (string-downcase expr) *km-package*)) *km-lisp-exprs*)) ;;; Don't add cloned prototype name to the stack!! ; (defconstant *commands-not-to-stack-result-for* '#$(clone)) ;;; Don't strip out (@ ...) structures for lists beginning with these items. (defconstant *no-decomment-headwords* '#$(comment show-comment explanation)) ;;; 10/28/02: These are calls where all the subcalls are direct calls to km0, so we can defer decommenting down to there for the elements (defconstant *decomment-top-level-only-headwords* '#$(:set if)) ; from frame-io.lisp, as we want to reference it here (defconstant *built-in-classes-with-nonfluent-instances-relation* '#$(Situation Slot Partition Theory)) ;;; -------------------- ;;; 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) ;;; -------------------- ;;; The top level call, either by person or machine (defun km (&optional (kmexpr 'ask-user) &key (fail-mode *top-level-fail-mode*)) (reset-inference-engine) (cond ((eq kmexpr 'ask-user) (km-read-eval-print)) (t (km-eval kmexpr :fail-mode fail-mode)))) ;;; ---------- (defun km-with-explanations (expr &key (fail-mode *top-level-fail-mode*)) (catch-explanations) (let ( (old-backtrack *backtrack-after-testing-unification*) ) (prog1 (km expr :fail-mode fail-mode) (setq *backtrack-after-testing-unification* old-backtrack)))) ;;; ---------- (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 ;;; [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)) ) (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) (cond ((minimatch query '#$(the ?slot of ?expr)) (setq *last-answer* answer))) (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) ; (reset-inference-engine) moved earlier (multiple-value-bind (answer error) (km-eval query :fail-mode fail-mode) (cond (error (format t "(Execution aborted)~%NIL~%")) (*add-comments-to-names* (write-km-vals answer) (terpri)) (t (km-format t "~a~%" answer))) (princ (report-statistics)) ;;; (cond (*frame-accessp* (report-frame-access-count))) (terpri) (values answer error))))) ;;; reset-inference-engine done up in (km), or NOT, if called by load-kb (don't want to keep resetting counters) ;;; also no checkpointing done ;;; [1] New Feb 2004 - 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*)) (cond ((am-in-prototype-mode) (add-to-prototype-definition *curr-prototype* km-expr))) (cond ((km-assertion-expr km-expr) (reset-done) (clear-cached-explanations))) ; [1] (remove-temporary-disablement-of-classification) ; in case KM previously bombed in the middle of temporary disablement (let ( (answer (catch 'km-abort (prog1 (desource (km0 km-expr :fail-mode fail-mode)) (cond (*exhaustive-forward-chaining* (exhaustively-forward-chain)))))) ) (cond ((and (pairp answer) (eq (first answer) 'km-abort)) ; error encountered (values nil (second answer))) (t answer)))) ;;; ---------- (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 ;;; (km0 ) is the recursive to KM *internal* to the KM Engine ;;; ====================================================================== ;;; (km0 ) will evaluate ;;; ;;; km evaluates the expression (a path) which is given to it, and returns a ;;; list of instances which the path points to. ;;; 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 *search-control-points* nil) #| Called by lazy-unify, where we want to look like trace-expr has gone through km0, with kmexpr as the subgoal, even though this isn't literally true. In other words, this splices an extra step in the trace output which doesn't really exist in KM. Rather than displaying: -> (_Car1 &? _Car2) -> ((a Engine) (a Chassis)) <- (_Engine1 _Chassis3) -> ((a Engine) (a Chassis)) <- (_Engine4 _Chassis5) It displays: -> (_Car1 &? _Car2) -> (the parts of _Car1) -> ((a Engine) (a Chassis)) <- (_Engine1 _Chassis3) -> (the parts of _Car2) -> ((a Engine) (a Chassis)) <- (_Engine4 _Chassis5) Note the "virtual" extra steps inserted. The (the parts of _Car1) are in fact done by a direct get-vals in lazy-unify, rather than by a recursive call to KM, but we still want to show this to the user. |# (defun km0-with-trace (trace-expr kmexpr &key (fail-mode *default-fail-mode*) (check-for-looping t) target) (prog2 (km-push trace-expr) (let* ( (users-goal (km-trace 'call "-> ~a" trace-expr)) (answer (cond ((eq users-goal 'fail) nil) (t (km0 kmexpr :fail-mode fail-mode :check-for-looping check-for-looping :target target)))) (users-response (cond (answer (km-trace 'exit "<- ~a~30T\"~a\"" answer trace-expr)) (t (km-trace 'fail "<- FAIL!~30T\"~a\"" trace-expr)))) ) (cond ((eq users-response 'redo) (reset-done) (km0-with-trace trace-expr kmexpr :fail-mode fail-mode :check-for-looping check-for-looping :target target)) ((eq users-response 'fail) nil) (t answer))) (km-pop))) ;;; -------------------- ;;; Wrapper, to maintain a stack and check for looping #| kmexpr-with-comments is the expression passed to km0. It may include comments, and may be an assignment :== statement. kmexpr is the ACTUAL expression to evaluate by km. This requires remove all comments, EXCEPT for assertion statements (has, a, some) in which only the TOP LEVEL comments are stripped (so that the sub-level comments get asserted in the KB) |# (defun km0 (kmexpr-with-comments &key (fail-mode *default-fail-mode*) (check-for-looping t) target) (let ( (kmexpr (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*))) (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 (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 *search-control-points* (let* ( (search-control-point (find-if #'(lambda (search-control-point) (minimatch kmexpr (first search-control-point))) *search-control-points*)) (min-depth (third search-control-point)) (max-depth (fourth search-control-point)) ) ; (format t "search-control-point = ~a~%" search-control-point) ; (format t "*depth* = ~a, min-depth = ~a, max-depth = ~a~%" *depth* min-depth max-depth) (and search-control-point (or (not (numberp min-depth)) (>= (1+ *depth*) min-depth)) (or (not (numberp max-depth)) (<= (1+ *depth*) max-depth))))) (search-control kmexpr)) ((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) '(load-kb #$load-kb reload-kb #$reload-kb))) (process-load-expression kmexpr)) ((and (listp kmexpr) (member (first kmexpr) *km-lisp-exprs*)) (eval kmexpr) '#$(t)) ((and (listp kmexpr) (member (first kmexpr) *downcase-km-lisp-exprs*)) (eval (cons (intern (string-upcase (first kmexpr)) *km-package*) (rest kmexpr))) '#$(t)) ((and (am-in-local-situation) (am-in-prototype-mode)) (report-error 'user-error "You are in both prototype-mode and in a Situation, which isn't allowed!~%")) ((or (null kmexpr) ; fast handling of these special cases, copied from *km-handler-function* (eq kmexpr '#$nil) ; This IS allowed to fail quietly (constraint-exprp kmexpr)) (cond ((eq fail-mode 'error) (report-error 'user-error "No values found for ~a!~%" kmexpr))) (cond ((constraint-exprp kmexpr) (note-are-constraints))) nil) ((and (atom kmexpr) (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 (eq (dereference kmexpr) kmexpr)) ; Is this the reflexive case? see (cond ((km-setp kmexpr) (set-to-list kmexpr)) ((and (listp kmexpr) (eq (first kmexpr) '#$:triple) (neq (length (rest kmexpr)) 3) (report-error 'user-error "~a: A triple should have exactly three elements!~%" kmexpr))) ((and (listp kmexpr) (eq (first kmexpr) '#$:pair) (neq (length (rest kmexpr)) 2) (report-error 'user-error "~a: A pair should have exactly two elements!~%" kmexpr))) (t (list kmexpr)))) ((internal-commentp kmexpr-with-comments) (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) (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 (let ( (pid (new-proof-node-id)) ) (prog2 (km-push kmexpr-with-comments pid) (km1 kmexpr kmexpr-with-comments :fail-mode fail-mode :target target :pid pid) (km-pop))))))) ;;; ---------------------------------------- ;;; Handling of loops - allow inductive completion of proofs ;;; ---------------------------------------- ;;; reason = loop-detected OR depth-limit-reached ;;; [2] Not having the correct target-situation specified seems like an error to me. (defun handle-looping (kmexpr &key (reason 'loop-detected)) (let ( (cexpr (canonicalize kmexpr)) ) (cond ((and (minimatch cexpr '#$(the ?slot of ?instance)) ; SPECIAL CASE: (the of ) (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 ( (new-vals (km0 (vals-to-val vals))) ) ; vals may be an expression! ? see test-suite/looping.km for discussion (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 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 of ). NIL if none known eg. top-level query (defun km1 (kmexpr kmexpr-with-comments &key (fail-mode *default-fail-mode*) target pid) (increment-inference-statistics) (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)))) (kmexpr-to-call (cond ((and target (record-explanation-later kmexpr)) `(,target :== ,kmexpr)) ; little trick to pass target into the dispatch mechanism (t kmexpr)))) (declare (ignore dummy)) (multiple-value-bind (answer0 handler-pattern) ; handler-pattern now used (cond ((eq users-goal 'fail) nil) ((atom kmexpr-to-call) (list kmexpr-to-call)) ; [2]: Checks for keywords and add-to-stack in km [1] above (*compile-handlers* (funcall *km-handler-function* fail-mode kmexpr-to-call)) ; COMPILED DISPATCH MECHANISM (t (let* ( (handler (find-handler kmexpr-to-call *km-handler-alist*)) ; INTERPRETED DISPATCH MECHANISM (answer00 (apply (first handler) (cons fail-mode (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 :pid pid))))) (defvar *process-proof-node* nil) ;;; 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 pid) (let ( (parent-pid (stacked-id (second (km-stack)))) ) (cond (*process-proof-node* (process-proof-node pid parent-pid *depth* (desource kmexpr) answer handler-pattern)))) (mapc #'(lambda (val) (cache-explanation-for val kmexpr)) answer) ; NOW: store the *decommented* version. NB kmexpr isn't (cond ((and target ; fully decommented for (a ... with ...) exprs *record-explanations* (not (record-explanation-later kmexpr-with-comments)) ) (mapc #'(lambda (val) (record-explanation-for target val kmexpr-with-comments)) answer))) (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))))) (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 :pid pid)) ((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 :pid pid)) (t answer)))) ;;; Temp function (defun process-proof-node (pid parent-pid depth kmexpr answer handler-pattern) (km-format t "PID~a: [parent PID~a]~25T ~a~vT~a = ~a ~100T [using rule for: ~a]~%" pid parent-pid depth (+ depth 30) kmexpr answer handler-pattern)) ;;; ---------------------------------------- ;;; km-unique: Expected to return EXACTLY *one* value, otherwise a warning is generated. ;;; ---------------------------------------- ;;; EXTERNAL, from some other application (defun km-unique (kmexpr &key (fail-mode *top-level-fail-mode*)) (reset-inference-engine) (let ( (answer (catch 'km-abort (km-unique0 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-unique0 (kmexpr &key (fail-mode *default-fail-mode*) target) (let ( (vals (km0 kmexpr :fail-mode fail-mode :target target)) ) (cond ((singletonp vals) (first vals)) (vals (report-error 'user-error "Expression ~a was expected to return a single value, but it returned multiple values ~a! Just taking the first...(~a) ~%" kmexpr vals (first vals)) (first vals)) ((eq fail-mode 'error) (report-error 'user-error "Expression ~a didn't return a value!~%" kmexpr))))) ;;; ====================================================================== ;;; Handle case-sensitivity and quoted morphism table in load-kb expression ;;; (load-kb "foo.km" :verbose t :with-morphism '((a -> 1) (b -> 2))) (defun process-load-expression (load-expr0) (let ( (load-expr (sublis '((#$:verbose . :verbose) ; :verbose -> :VERBOSE etc. (#$:eval-instances . :eval-instances) (#$:with-morphism . :with-morphism) (#$:load-patterns . :load-patterns)) load-expr0)) ) (case (first load-expr) ((load-kb #$load-kb) (multiple-value-bind (result error) (apply #'load-kb0 (rest load-expr)) (declare (ignore result)) (cond (error (princ error) (throw 'km-abort (list 'km-abort error))) ; (format t "~/home") gives format error! (t '#$(t))))) ((reload-kb #$reload-kb) (multiple-value-bind (result error) (apply #'reload-kb0 (rest load-expr)) (declare (ignore result)) (cond (error (princ error) (throw 'km-abort (list 'km-abort error))) (t '#$(t)))))))) ;;; ====================================================================== ;;; The association list is a set of pairs of form (pattern function). ;;; Function gets applied to the values of variables in pattern, the ;;; values stored in a list in the order they were encountered ;;; when (depth-first) traversing the km expression. ;;; Below: two alternative ways of embedding Lisp code ;;; `,#'(lambda () ....) <- marginally faster, but can't be manipulated ;;; '(lambda (...)) ;;; 4.15.99 Changed `(a ,frame with . ,slotsvals) to `(a ,frame with ,@slotsvals), as Lucid problem ;;; for writing out the flattened-out code: ;;; (write '`(a ,frame with . ,slotsvals)) -> `(A ,FRAME WITH EXCL::BQ-COMMA SLOTSVALS) = Lucid-specific!! ;;; (write '`(a ,frame with ,@slotsvals)) -> `(A ,FRAME WITH ,@SLOTSVALS) = readable by other Lisps ;;; v1.4.0 - order in terms of utility for speed! (setq *km-handler-alist* '( ;;; [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 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 (km0 frameadd :fail-mode fmode0) ; start-values slot '* :fail-mode fmode0)) ; target-class = * ((pathp slot) (let ( (eval-slot (km-unique0 slot :fail-mode 'error)) ) (km0 `#$(the ,EVAL-SLOT of ,FRAMEADD) :fail-mode fmode0))) (t (let* ( (fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0))) ; OLD (frames (km0 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 (km0 frameadd :fail-mode fmode :check-for-looping nil)))) ) ; [3] (cond ((eq *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 (km0 `#$(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] ( (#$a ?class) (lambda (_fmode class) (declare (ignore _fmode)) (list (create-instance class))) ) ( (#$a ?class #$called ?tag) (lambda (_fmode class tag) (declare (ignore _fmode)) (km-setq '*are-some-tags* t) (cond ((km-tagp tag) (list (create-instance class `((#$called ,(VAL-TO-VALS TAG)))))) (t (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS called ,TAG) tag))))) ( (#$a ?class #$uniquely-called ?tag) (lambda (_fmode class tag) (declare (ignore _fmode)) (km-setq '*are-some-constraints* t) (km-setq '*are-some-tags* t) (cond ((km-tagp tag) (list (create-instance class `((#$uniquely-called ,(VAL-TO-VALS TAG)))))) (t (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS uniquely-called ,TAG) tag))))) ( (#$a ?class #$with &rest) (lambda (_fmode class slotsvals) (declare (ignore _fmode)) (cond ((are-slotsvals slotsvals) (let ( (instance (create-instance class slotsvals)) ) (cond ((am-in-prototype-mode) (km0 '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) ( (#$a ?class #$uniquely-called ?tag #$with &rest) (lambda (_fmode class tag slotsvals) (declare (ignore _fmode)) (km-setq '*are-some-constraints* t) (km-setq '*are-some-tags* t) (cond ((not (km-tagp tag)) (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS uniquely-called ,TAG with ,@SLOTSVALS) tag)) ((are-slotsvals slotsvals) (let ( (instance (create-instance class (cons `(#$uniquely-called ,(VAL-TO-VALS TAG)) slotsvals))) ) (cond ((am-in-prototype-mode) (km0 '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) ( (#$a ?class #$called ?tag #$with &rest) (lambda (_fmode class tag slotsvals) (declare (ignore _fmode)) (km-setq '*are-some-tags* t) (cond ((not (km-tagp tag)) (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS called ,TAG with ,@SLOTSVALS) tag)) ((are-slotsvals slotsvals) (let ( (instance (create-instance class (cons `(#$called ,(VAL-TO-VALS TAG)) slotsvals))) ) (cond ((am-in-prototype-mode) (km0 '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) ;;; Internal -- for RKF prototype synthesis ; ( (#$a-protoinstance ?class) ; (lambda (_fmode class) (declare (ignore _fmode)) (list (create-instance class nil *proto-marker-string*))) ) ; ; ( (#$a-protoinstance ?class #$with &rest) ; (lambda (_fmode class slotsvals) ; (declare (ignore _fmode)) ; (cond ((are-slotsvals slotsvals) ; (list (create-instance class slotsvals *proto-marker-string*))))) ) #| Remove this now - require user to explicitly use "assertions" slot ;;; Special rewrite for situations: ;;; (a Situation in-which '(Fred has (leg (*Broken))) '(Joe has (feeling (*Sad)))) ;;; -> (a Situation with (assertions ('(Fred has (leg (*Broken))) '(Joe has (feeling (*Sad)))))) ( (#$a ?situation-class #$in-which &rest) (lambda (fmode situation-class assertions) ; (print assertions) (cond ((not (is-subclass-of situation-class '#$Situation)) (report-error 'user-error "~a:~% Can't do this! (~a is not a subclass of Situation!)~%" `#$(a ,SITUATION-CLASS in-which ,@ASSERTIONS) situation-class)) ((some #'(lambda (assertion) (not (quoted-expressionp assertion))) assertions) (report-error 'user-error "~a:~% `in-which' must be followed by a list of quoted assertions! e.g. (a Situation in-which '(Fred has (leg (*Broken))) '(Joe has (feeling (*Sad))))~%" `#$(a ,SITUATION-CLASS in-which ,@ASSERTIONS) situation-class)) (t (km0 `#$(a ,SITUATION-CLASS with (assertions ,ASSERTIONS)) :fail-mode fmode))))) |# ;;; Define fluent-instances: ( (#$some ?class) (lambda (_fmode class) (declare (ignore _fmode)) (list (create-instance class nil *fluent-instance-marker-string*))) ) ; svs = nil, fluent-instance string = "Some" ( (#$some ?class #$with &rest) (lambda (_fmode class slotsvals) (declare (ignore _fmode)) (cond ((are-slotsvals slotsvals) (list (create-instance class slotsvals *fluent-instance-marker-string*))))) ) ; fluent-instance string = "Some" ;;; ====================================================================== ;;; PROTOTYPES - Experimental! ;;; ====================================================================== ( (#$a-prototype ?class) (lambda (fmode class) (km0 `#$(a-prototype ,CLASS with) :fail-mode fmode)) ) ; rewrite, errors caught below ( (#$a-prototype ?class #$with &rest) (lambda (_fmode class slotsvals) (declare (ignore _fmode)) (cond ((am-in-local-situation) (report-error 'user-error "Can't enter prototype mode when in a Situation!~%")) ((am-in-prototype-mode) (report-error 'user-error "~a~%Attempt to enter prototype mode while already in prototype mode (not allowed)!~%Perhaps you are missing an (end-prototype)?" `#$(a-prototype ,CLASS with ,@SLOTSVALS))) ((are-slotsvals slotsvals) (new-context) (km-setq '*curr-prototype* (create-instance class `#$((prototype-of (,CLASS)) ; ,(COND (SLOTSVALS `(prototype-scope ('(a ,CLASS with ,@SLOTSVALS)))) ,(COND (SLOTSVALS `(prototype-scope ((the-class ,CLASS with ,@SLOTSVALS)))) (T `(prototype-scope (,CLASS)))) ,@SLOTSVALS) *proto-marker-string* ; ie. "_Proto" 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) (declare (ignore _fmode)) ; (eval-instances) ; (eval-instances) ; (setq *curr-prototype* nil) (km-setq '*curr-prototype* nil) (global-situation) (new-context) '#$(t)) ) ( (#$clone ?expr) (lambda (fmode expr) (declare (ignore fmode)) (let ( (source (km-unique0 expr :fail-mode 'error)) ) (cond (source (list (clone source)))))) ) #| Appears to be obsolete ( (#$add-clones-to ?expr) (lambda (fmode expr) (let ( (source (km-unique0 expr :fail-mode 'error)) ) (cond (source (unify-in-prototypes source) (list source))))) ) |# ( (#$evaluate-paths) (lambda (_fmode) (declare (ignore _fmode)) (eval-instances) '#$(t)) ) ;;; ====================================================================== ;;; This for internal use only ( (#$fluent-instancep ?expr) ; largely for debugging (lambda (fmode expr) (cond ((fluent-instancep (km-unique0 expr :fail-mode fmode)) '#$(t)))) ) ( (#$default-fluent-status &rest) (lambda (fmode rest) (declare (ignore fmode)) (default-fluent-status (first rest))) ) ;;; ---------------------------------------------------------------------- ;;; Type constraints don't get evaluated. ( (#$must-be-a ?class) (lambda (_fmode _class) (declare (ignore _fmode _class)) (note-are-constraints) nil)) ( (#$possible-values ?values) (lambda (_fmode _values) (declare (ignore _fmode _values)) (note-are-constraints) nil)) ( (#$excluded-values ?values) (lambda (_fmode _values) (declare (ignore _fmode _values)) (note-are-constraints) nil)) ( (#$must-be-a ?class #$with &rest) (lambda (_fmode _class slotsvals) (declare (ignore _fmode _class)) (are-slotsvals slotsvals) ; Syntax check (note-are-constraints) nil)) ( (#$mustnt-be-a ?class) (lambda (_fmode _class) (declare (ignore _fmode _class)) (note-are-constraints) nil) ) ( (#$mustnt-be-a ?class #$with &rest) (lambda (_fmode _class slotsvals) (declare (ignore _fmode _class)) (are-slotsvals slotsvals) ; Syntax check (note-are-constraints) nil)) ;;; New 1.4.0-beta10: ( (<> ?val) (lambda (_fmode _val) (declare (ignore _fmode _val)) (note-are-constraints) nil)) ; ie. means isn't val ; obsolete now ; ( (#$override ?expr) (lambda (_fmode _expr) (declare (ignore _fmode _expr))) nil ) ( (#$no-inheritance) (lambda (_fmode) (declare (ignore _fmode))) nil ) ( (#$constraint ?expr) ; constraints tested elsewhere (lambda (_fmode _expr) (declare (ignore _fmode _expr)) (note-are-constraints) nil) ) ( (#$set-constraint ?expr) ; constraints tested elsewhere (lambda (_fmode _expr) (declare (ignore _fmode _expr)) (note-are-constraints) nil) ) ( (#$set-filter ?expr) ; constraints tested elsewhere (lambda (_fmode _expr) (declare (ignore _fmode _expr)) (note-are-constraints) nil) ) ( (#$at-least ?n ?class) (lambda (_fmode _n _class) (declare (ignore _fmode _n _class)) (note-are-constraints) nil) ) ( (#$at-most ?n ?class) (lambda (_fmode _n _class) (declare (ignore _fmode _n _class)) (note-are-constraints) nil) ) ( (#$exactly ?n ?class) (lambda (_fmode _n _class) (declare (ignore _fmode _n _class)) (note-are-constraints) nil) ) ( (#$sanity-check ?expr) ; toggleable wrapper around constraints (lambda (fmode expr) (cond (*sanity-checks* (km0 expr :fail-mode fmode)) (t '#$(t)))) ) ; ---------------------------------------- ; ============================ ; AUGMENTING MEMBER PROPERTIES ; ============================ ( (#$every ?cexpr #$has &rest) (lambda (_fmode cexpr slotsvals) (declare (ignore _fmode)) (let ( (class (km-unique0 cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$has ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) ; 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 cexpr slotsvals) (declare (ignore _fmode)) (let ( (class (km-unique0 cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$also-has ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) ; 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 cexpr slotsvals) (declare (ignore _fmode)) (let ( (class (km-unique0 cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$now-has ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) ; 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 ; ========================= ;;; [1] not used (yet). The goal was to distinguish primary ("notable") links which the prototype asserted, ;;; from secondary links which the prototype had to build to reach objects for the primary links. For example, ;;; want to highlight that (for a prototype flying plane) the engine is status on, but not that the plane ;;; has an engine, even though both assertions are part of the prototype graph. ( (?instance-expr #$has &rest) (lambda (_fmode instance-expr slotsvals) (declare (ignore _fmode)) (let ( (instance (km-unique0 instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr #$has ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (add-slotsvals 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) (km0 '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) #| [1] (cond ((am-in-prototype-mode) (let ( (evaluated-slotsvals (mapcar #'(lambda (slotvals) (cond ((some #'(lambda (val) (not (is-simple-km-term val))) (vals-in slotvals)) (list (slot-in slotvals) (km0 `#$(the ,(SLOT-IN SLOTVALS) of ,INSTANCE) :fail-mode 'error))) (t slotvals))) slotsvals)) ) (add-slotsvals instance evaluated-slotsvals 'notable-properties)))) (list instance)))))) |# ( (?instance-expr #$also-has &rest) (lambda (_fmode instance-expr slotsvals) (declare (ignore _fmode)) (let ( (instance (km-unique0 instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr #$also-has ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (add-slotsvals instance 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) (km0 '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (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 instance-expr slotsvals) (declare (ignore _fmode)) (let ( (instance (km-unique0 instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr #$now-has ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (add-slotsvals instance 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) ; (km0 '#$(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 ;;; ---------------------------------------------------------------------- ( (?target :== (?xs && &rest)) (lambda (fmode target xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs && ,@rest) :fail-mode 'error :joiner '&& :target target)) ) ( (?xs && &rest) (lambda (fmode xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs && ,@rest) :fail-mode 'error :joiner '&&)) ) ( (?target :== (?x & &rest)) (lambda (fmode target x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x & ,@rest) :fail-mode 'error :joiner '& :target target)) ) ( (?x & &rest) (lambda (fmode x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x & ,@rest) :fail-mode 'error :joiner '&)) ) ( (?xs === &rest) (lambda (fmode xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs === ,@rest) :fail-mode 'error :joiner '===)) ) ( (?x == ?y) (lambda (fmode x y) (declare (ignore fmode)) (lazy-unify-&-expr `(,x == ,y) :fail-mode 'error :joiner '==)) ) ( (?x /== ?y) (lambda (fmode x y) (declare (ignore fmode)) (let ( (xv (km-unique0 x :fail-mode 'error)) (yv (km-unique0 y :fail-mode 'error)) ) (cond ((equal xv yv) (report-error 'user-error "(~a /== ~a): ~a and ~a are the same object!~%" x y x y)) ((kb-objectp xv) (km0 `#$(,XV has (/== (,YV))) :fail-mode 'error)) ((kb-objectp yv) (km0 `#$(,YV has (/== (,XV))) :fail-mode 'error)) ('#$(t))))) ) ; two distinct, non-KB objects eg. ("cat" /== "dog") ;;; These variants do eager unification ( (?xs &&! &rest) (lambda (fmode xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs &&! ,@rest) :fail-mode 'error :joiner '&&!)) ) ( (?x &! &rest) (lambda (fmode x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x &! ,@rest) :fail-mode 'error :joiner '&!)) ) ;;; 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 x y) (declare (ignore _fmode)) (cond ((null x) '#$(t)) ((null y) '#$(t)) ((existential-exprp y) (let ( (xf (km-unique0 x)) ) (cond ((null xf) '#$(t)) ((unifiable-with-existential-expr xf y) '#$(t))))) ((existential-exprp x) (let ( (yf (km-unique0 y)) ) (cond ((null yf) '#$(t)) ((unifiable-with-existential-expr yf x) '#$(t))))) (t (let ( (xv (km-unique0 x)) ) (cond ((null xv) '#$(t)) (t (let ( (yv (km-unique0 y)) ) (cond ((null yv) '#$(t)) ((try-lazy-unify xv yv) '#$(t))))))))))) ; 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 x y) (declare (ignore _fmode)) (cond ((existential-exprp y) (let ( (xf (km-unique0 x)) ) (cond ((null xf) '#$(t)) ((unifiable-with-existential-expr xf y :classes-subsumep t) '#$(t))))) ((existential-exprp x) (let ( (yf (km-unique0 y)) ) (cond ((null yf) '#$(t)) ((unifiable-with-existential-expr yf x :classes-subsumep t) '#$(t))))) (t (let ( (xv (km-unique0 x)) ) (cond ((null xv) '#$(t)) (t (let ( (yv (km-unique0 y)) ) (cond ((null yv) '#$(t)) ((try-lazy-unify xv yv :classes-subsumep t) '#$(t))))))))))) ; 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. ;;; For INTERNAL KM USE ONLY ( (?target :== (?x &+ ?y)) (lambda (fmode target x y) (let ( (unification (lazy-unify-exprs x y :classes-subsumep t :fail-mode fmode :target target)) ) (cond (unification (list unification)) ((eq fmode 'error) (report-error 'user-error "Unification (~a &+ ~a) failed!~%" x y))))) ) ( (?x &+ ?y) (lambda (fmode x y) (let ( (unification (lazy-unify-exprs x y :classes-subsumep t :fail-mode fmode)) ) (cond (unification (list unification)) ((eq fmode 'error) (report-error 'user-error "Unification (~a &+ ~a) failed!~%" x y))))) ) ;;; ---------------------------------------- ;;; 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 x y) (let ( (xv (km0 x :fail-mode fmode)) (yv (km0 y :fail-mode fmode)) ) (cond ((km-set-equal (dereference xv) yv) '(#$t))))) ) ; [1] ( (?x /= ?y) (lambda (fmode x y) (let ( (xv (km0 x :fail-mode fmode)) (yv (km0 y :fail-mode fmode)) ) (cond ((not (km-set-equal (dereference xv) yv)) '(#$t))))) ) ; [1] ( (#$the ?class ?slot #$of ?frameadd) (lambda (fmode0 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 (km0 frameadd :fail-mode fmode0) ; start-values slot class :fail-mode fmode0)) ((pathp slot) (let ( (eval-slot (km-unique0 slot :fail-mode 'error)) ) (km0 `#$(the ,CLASS ,EVAL-SLOT of ,FRAMEADD) :fail-mode fmode0))) (t (let* ( (fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0))) ) (vals-in-class (km0 `#$(the ,SLOT of ,FRAMEADD) :fail-mode fmode) class))))) ) ;;; ====================================================================== ;;; THEORIES - NEW (Dec 2000) ;;; ====================================================================== ( (#$in-theory ?theory-expr) (lambda (_fmode theory-expr) (declare (ignore _fmode)) (in-theory theory-expr)) ) ( (#$in-theory ?theory-expr ?km-expr) (lambda (_fmode theory-expr km-expr) (declare (ignore _fmode)) (in-theory theory-expr km-expr)) ) ( (#$hide-theory ?theory-expr) (lambda (_fmode theory-expr) (declare (ignore _fmode)) (mapc #'hide-theory (km0 theory-expr)) (cond ((visible-theories)) (t '#$(t))))) ( (#$see-theory ?theory-expr) (lambda (_fmode theory-expr) (declare (ignore _fmode)) (mapc #'see-theory (km0 theory-expr)) (visible-theories)) ) ( (#$end-theory) (lambda (_fmode) (declare (ignore _fmode)) (in-situation *global-situation*)) ) ( (#$visible-theories) (lambda (_fmode) (declare (ignore _fmode)) (visible-theories)) ) ;;; ====================================================================== ;;; 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 situation-expr) (declare (ignore _fmode)) (in-situation situation-expr)) ) ( (#$in-situation ?situation (#$the ?slot #$of ?frame)) ; special fast handling of this: If (lambda (_fmode situation slot frame) ; the slot-vals are already computed ([1]) (declare (ignore _fmode)) ; then just do a lookup ([2]) (cond ((and (kb-objectp situation) (isa situation '#$Situation) (already-done frame slot situation)) ; [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 situation-expr km-expr) (declare (ignore _fmode)) (in-situation situation-expr km-expr)) ) ( (#$end-situation) (lambda (_fmode) (declare (ignore _fmode)) (in-situation *global-situation*)) ) ( (#$global-situation) (lambda (_fmode) (declare (ignore _fmode)) (in-situation *global-situation*)) ) ( (#$new-situation) (lambda (_fmode) (declare (ignore _fmode)) (new-situation)) ) ; NB returns a singleton list containing the new situation ;;; ---------------------------------------- ( (#$do ?action-expr) (lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr))) ) ; NB do-action returns a SINGLE value (a situation), not a list. ( (#$do-and-next ?action-expr) (lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr :change-to-next-situation t))) ) ;;; New ( (#$try-do ?action-expr) (lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr :test-or-assert-pcs 'test))) ) ; NB do-action returns a SINGLE value (a situation), not a list. ( (#$try-do-and-next ?action-expr) (lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr :change-to-next-situation t :test-or-assert-pcs 'test))) ) ;;; Now returns the list of successful actions ( (#$do-script ?script) (lambda (fmode script) (km0 `#$(forall (the actions of ,SCRIPT) (do-and-next It)) :fail-mode fmode)) ) ( (#$do-plan ?plan-instance-expr) (lambda (_fmode plan-instance-expr) (declare (ignore _fmode)) (let ( (plan-instance (km-unique plan-instance-expr)) ) (do-plan plan-instance))) ) ; defined in sadl.lisp ;;; ---------------------------------------- ;;; Should even work for constraints ( (#$assert ?triple-expr) (lambda (_fmode triple-expr) (declare (ignore _fmode)) (let ( (triple (km-unique0 triple-expr)) ) (cond ((not (km-triplep triple)) (report-error 'user-error "(assert ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" triple-expr triple)) (t (km0 `#$(,(ARG1OF TRIPLE) has (,(ARG2OF TRIPLE) ,(VAL-TO-VALS (ARG3OF TRIPLE)))) :fail-mode 'error))))) ) ( (#$is-true ?triple-expr) (lambda (_fmode triple-expr) (declare (ignore _fmode)) (let* ( (triple (km-unique0 triple-expr)) ) (cond ((not (km-triplep triple)) (report-error 'user-error "(is-true ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" triple-expr triple)) ((comparison-operator (arg2of triple)) (km0 `#$(,(SECOND TRIPLE) ,(THIRD TRIPLE) ,(FOURTH TRIPLE)))) (t (let ( (frame (km-unique0 (second triple) :fail-mode 'error)) (slot (km-unique0 (third triple) :fail-mode 'error)) (value (fourth triple)) ) ; don't evaluate this! (cond ((null value) '#$(t)) ((km0 `#$(,FRAME is '(a Thing with (,SLOT (,VALUE)))))))))))) ) ; ((constraint-exprp value) ; (km0 `#$(,FRAME &? (a Thing with (,SLOT (,VALUE)))))) ; (t (km0 `#$((the ,SLOT of ,FRAME) includes ,VALUE))))))))) ) ( (#$all-true ?triples-expr) (lambda (_fmode triples-expr) (declare (ignore _fmode)) (let ( (triples (km0 triples-expr)) ) (cond ((every #'(lambda (triple) (km0 `#$(is-true ,TRIPLE))) triples) '#$(t)))))) ( (#$some-true ?triples-expr) (lambda (_fmode triples-expr) (declare (ignore _fmode)) (let ( (triples (km0 triples-expr)) ) (cond ((some #'(lambda (triple) (km0 `#$(is-true ,TRIPLE))) triples) '#$(t)))))) ;;; ---------------------------------------- ( #$(next-situation) (lambda (_fmode) (declare (ignore _fmode)) (cond ((am-in-local-situation) (list (do-action nil :change-to-next-situation t))) (t (report-error 'user-error "Can only do (next-situation) from within a situation!~%"))))) ( #$(curr-situation) (lambda (_fmode) (declare (ignore _fmode)) (list (curr-situation))) ) ( (#$ignore-result ?expr) ; return t always (lambda (fmode expr) (declare (ignore fmode)) (km0 expr) nil)) ( (#$ignore ?expr) ; return t always (lambda (fmode expr) (declare (ignore fmode expr)) nil)) ; Important v1.3.8 addition! ; expr should be an assertional expression ( (#$in-every-situation ?situation-class ?expr) (lambda (fmode situation-class km-expr) (cond ((not (is-subclass-of situation-class '#$Situation)) (report-error 'user-error "~a:~% Can't do this! (~a is not a subclass of Situation!)~%" `#$(in-every-situation ,SITUATION-CLASS ,KM-EXPR) situation-class)) (t (let ( (modified-expr (sublis '#$((TheSituation . #,Self) (Self . SubSelf)) km-expr)) ) (km0 `#$(in-situation ,*GLOBAL-SITUATION* (every ,SITUATION-CLASS has (assertions (',MODIFIED-EXPR)))) :fail-mode fmode))))) ) ;;; ====================================================================== ;;; 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) (declare (ignore _fmode)) (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 frame) (declare (ignore _fmode)) (let ( (last-instance (search-stack frame)) ) (cond (last-instance (list last-instance))))) ) ;;; ======================================== ;;; FIND OBJECTS BY SUBSUMPTION CHECKING ;;; ======================================== ( (#$every ?frame) (lambda (fmode frame) (km0 `(#$every ,frame #$with) :fail-mode fmode)) ) ( (#$every ?frame #$with &rest) (lambda (_fmode frame slotsvals) (declare (ignore _fmode)) (cond ((are-slotsvals slotsvals) (let ( (existential-expr (cond ((and (null slotsvals) (pathp frame)) ; eg. (the (porter owns car)) (path-to-existential-expr frame)) (t `(#$a ,frame #$with ,@slotsvals)))) ) (find-subsumees existential-expr))))) ) ; NB Don't search the whole *obj-stack*; v1.3.8 yes do! ;;; (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-unique0 (every X with ...)), but then error messages were unintuitive) ( (#$the ?frame) (lambda (fmode frame) (declare (ignore fmode)) (let ( (answer (km0 `(#$every ,frame))) ) (cond ((null answer) (report-error 'user-error "No values found for expression ~a!~%" `#$(the ,FRAME))) ((not (singletonp answer)) (report-error 'user-error "Expected a single value for expression ~a, but found multiple values ~a!~%" `#$(the ,FRAME) answer)) (t answer))))) ( (#$the ?frame #$with &rest) (lambda (fmode frame slotsvals) (declare (ignore fmode)) (let ( (answer (km0 `(#$every ,frame #$with ,@slotsvals))) ) (cond ((null answer) (report-error 'user-error "No values found for expression ~a!~%" `#$(the ,FRAME with ,@SLOTSVALS))) ((not (singletonp answer)) (report-error 'user-error "Expected a single value for expression ~a, but found multiple values ~a!~%" `#$(the ,FRAME with ,@SLOTSVALS) answer)) (t answer))))) ;;; 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 slot frameadd) (declare (ignore _fmode)) (km0 `#$(the+ Thing with (,(INVERT-SLOT SLOT) (,FRAMEADD))) :fail-mode 'error))) ( (#$the+ ?class ?slot #$of ?frameadd) (lambda (_fmode class slot frameadd) (declare (ignore _fmode)) (km0 `#$(the+ ,CLASS with (,(INVERT-SLOT SLOT) (,FRAMEADD))) :fail-mode 'error))) ( (#$the+ ?frame) (lambda (fmode frame) (km0 `(#$the+ ,frame #$with) :fail-mode fmode)) ) ( (#$the+ ?frame #$with &rest) (lambda (_fmode frame slotsvals) (declare (ignore _fmode)) ; (cond ; ((km0 `(#$the ,frame #$with ,@slotsvals))) ; OLD: (the ... with ...) *always* generates error on failure, so bypass this. (let ( (val (km-unique0 `(#$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 (km0 existential-expr :fail-mode 'error))))))) ) ; [1] ( (#$a+ &rest) ; a+ is synonym for the+ (lambda (fmode rest) (km0 `(#$the+ ,@rest) :fail-mode fmode)) ) ;;; [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 cexpr slotsvals) (declare (ignore _fmode)) (let ( (class (km-unique0 cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$has-definition ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) (let* ( (slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00)) (parents-of-defined-concept (decomment (vals-in (assoc '#$instance-of slotsvals0)))) ) (cond ((not (every #'kb-objectp parents-of-defined-concept)) (report-error 'user-error "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%" `(#$every ,cexpr #$has-definition ,@slotsvals0))) ((null parents-of-defined-concept) (report-error 'user-error "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%" `(#$every ,cexpr #$has-definition ,@slotsvals0))) (t (add-slotsvals class slotsvals0 :facet 'member-definition :install-inversesp nil) (point-parents-to-defined-concept class parents-of-defined-concept 'member-definition) (km-setq '*are-some-definitions* t) (mapc #'un-done (all-instances class)) (list class)))))))) ) ; ======================= ; DEFINING OWN PROPERTIES ; ======================= ( (?instance-expr #$has-definition &rest) (lambda (_fmode instance-expr slotsvals) (declare (ignore _fmode)) (let ( (instance (km-unique0 instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(#$every ,instance-expr #$has-definition ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (let* ( (slotsvals0 (decomment slotsvals)) ; Can't handle comments on instances yet (parents-of-defined-concept (decomment (vals-in (assoc '#$instance-of slotsvals0)))) ) (cond ((not (every #'kb-objectp parents-of-defined-concept)) (report-error 'user-error "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%" `(,instance-expr #$has-definition ,@slotsvals0))) ((null parents-of-defined-concept) (report-error 'user-error "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%" `(,instance-expr #$has-definition ,@slotsvals0))) (t (add-slotsvals instance slotsvals0 :facet 'own-definition) (point-parents-to-defined-concept instance parents-of-defined-concept 'own-definition) (km-setq '*are-some-definitions* t) (un-done instance) ; 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 condition action) (km0 `(#$if ,condition #$then ,action #$else nil) :fail-mode fmode)) ) ( (#$if ?condition #$then ?action #$else ?altaction) (lambda (fmode condition action altaction) (let ( (test-result (km0 condition)) ) (cond ((not (member test-result '#$(NIL f F))) (km0 action :fail-mode fmode)) (t (km0 altaction :fail-mode fmode)))))) ( (?x > ?y) (lambda (_fmode x y) (declare (ignore _fmode)) (let ( (xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((> xval yval) '#$(t)))))))) ( (?x < ?y) (lambda (_fmode x y) (declare (ignore _fmode)) (let ( (xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((< xval yval) '#$(t)))))))) ( (?x >= ?y) (lambda (_fmode x y) (declare (ignore _fmode)) (let ( (xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((>= xval yval) '#$(t)))))))) ( (?x <= ?y) (lambda (_fmode x y) (declare (ignore _fmode)) (let ( (xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((<= xval yval) '#$(t)))))))) ( (?x = ?y +/- ?z) (lambda (_fmode x y z) (declare (ignore _fmode)) (let ( (xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) (zval (km-unique0 z :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval) (numberp zval)) (cond ((<= (abs (- xval yval)) (abs zval)) '#$(t))))))) ) ( (?x = ?y +/- ?z %) (lambda (_fmode x y z) (declare (ignore _fmode)) (let ( (xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) (zval (km-unique0 z :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval) (numberp zval)) (cond ((<= (abs (- xval yval)) (* (max (abs xval) (abs yval)) (abs zval) 0.01)) '#$(t))))))) ) ; ---------------------------------------- #| ( (?x #$isa ?y) (lambda (fmode x y) (let ( (xvals (km0 x)) ) ; trap error later (below) (cond ((null xvals) (report-error 'user-error "Doing ~a:~% ~a evaluates to nil (should evaluate to an instance!)" `(,x #$isa ,y) x)) ((not (singletonp xvals)) (report-error 'user-error "Doing ~a:~% ~a evaluates to multiple values ~a (should evaluate to a single instance!)" `(,x #$isa ,y) x xvals)) ((atom y) (cond ((isa (first xvals) y) '#$(t)))) ; Quick try first ((isa (first xvals) (km-unique0 y :fail-mode fmode)) '#$(t))))) ) |# ; ---------------------------------------- ( (?x #$and &rest) (lambda (_fmode x rest) (declare (ignore _fmode)) (cond ((and (listp x) (= (length x) 3) (eq (second x) '==)) ; special handling for ((?x == ) and ...) (let* ( (xx (first x)) (yy (third x)) ) (cond ((and (km-varp xx) (km-varp yy)) (km0 (subst xx yy rest))) ; or perhaps should be an error ((km-varp xx) (km0 (subst (vals-to-val (km0 yy)) xx rest))) ((km-varp yy) (km0 (subst (vals-to-val (km0 xx)) yy rest))) ((and (lazy-unify-&-expr `(,xx == yy) :fail-mode 'error :joiner '==) (km0 rest)))))) (t (and (km0 x) (km0 rest))))) ) ( (?x #$or &rest) (lambda (_fmode x y) (declare (ignore _fmode)) (or (and (not (on-km-stackp x)) (km0 x)) (km0 y))) ) ( (#$not ?x) (lambda (_fmode x) (declare (ignore _fmode)) (cond ((not (km0 x)) '#$(t)))) ) ( (#$numberp ?x) (lambda (_fmode x) (declare (ignore _fmode)) (cond ((numberp (km-unique0 x)) '#$(t)))) ) ;;; ====================================================================== ;;; SUBSUMPTION TESTING ;;; ====================================================================== ( (?x #$is-subsumed-by ?y) (lambda (fmode x y) (km0 `(,y #$subsumes ,x) :fail-mode fmode)) ) ( (?x #$subsumes ?y) (lambda (_fmode x y) (declare (ignore _fmode)) (let ( (yv (km0 y)) ) (cond ((null yv) '#$(t)) (t (let ( (xv (km0 x)) ) (cond ((and (not (null xv)) (subsumes xv yv)) '#$(t))))))))) ( (?x #$is-covered-by ?y) (lambda (fmode x y) (km0 `(,y #$covers ,x) :fail-mode fmode)) ) ; replace with generalized isa ; ( (?x #$covers ?y) ; (lambda (_fmode x y) ; (declare (ignore _fmode)) ; (let ( (yv (km-unique0 y)) ) ; (cond ((null yv) '#$(t)) ; (t (let ( (xv (km0 x)) ) ; (cond ((and (not (null xv)) ; (covers xv yv)) ; '#$(t))))))))) ;;; Obsolete, but keep for backward compatibility ( (?x #$covers ?y) (lambda (fmode x y) (km0 `(,y #$isa ,x) :fail-mode fmode)) ) ( (?y #$isa ?x) (lambda (_fmode y x) (declare (ignore _fmode)) (let ( (yv (km-unique0 y)) ) (cond ((null yv) '#$(t)) (t (let ( (xv (km-unique0 x)) ) (cond ((null xv) nil) ((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 x y) (declare (ignore _fmode)) (let ( (xv (km-unique0 x)) ) (cond ((null xv) nil) (t (let ( (yv (km-unique0 y)) ) (cond ((and (not (null yv)) (is xv yv)) '#$(t))))))))) ;;; ====================================================================== ( (?xs #$includes ?y) (lambda (_fmode xs y) (declare (ignore _fmode)) (let ( (xs-vals (km0 xs)) (y-val (km-unique0 y :fail-mode 'error)) ) (cond ((member y-val (dereference xs-vals) :test #'equal) '#$(t)))))) ( (?xs #$is-superset-of ?ys) (lambda (_fmode xs ys) (declare (ignore _fmode)) (let ( (xs-vals (km0 xs)) (ys-vals (km0 ys)) ) (cond ((subsetp ys-vals (dereference xs-vals) :test #'equal) '#$(t))))) ) ;;; ====================================================================== ;;; SEQUENCE MANIPULATION ;;; ====================================================================== ( (?seq-expr1 #$append ?seq-expr2) (lambda (_fmode seq-expr1 seq-expr2) (declare (ignore _fmode)) (let* ( (seq1 (km-unique0 seq-expr1)) (seq2 (km-unique0 seq-expr2)) (elts1 (cond ((or (km-seqp seq1) (km-bagp seq1)) (seq-to-list seq1)) ((null seq1) nil) ((is-km-term seq1) (list seq1)) (t (report-error 'user-error "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" seq-expr1 seq-expr2 seq-expr1)))) (elts2 (cond ((or (km-seqp seq2) (km-bagp seq2)) (seq-to-list seq2)) ((null seq2) nil) ((is-km-term seq2) (list seq2)) (t (report-error 'user-error "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" seq-expr1 seq-expr2 seq-expr2)))) (result-type (cond ((or (and (km-seqp seq1) (km-bagp seq2)) (and (km-seqp seq2) (km-bagp seq1))) (report-error 'user-error "(~a append ~a): Elements should be both sequences or both bags!" seq-expr1 seq-expr2) '#$:seq) ; 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 expr tag) (let* ( (vals (km0 expr)) ) (cond (vals (km-trace 'comment "Now find just those value(s) whose tag = ~a..." tag))) (let* ( (tags (val-to-vals tag)) (target-vals (remove-if #'(lambda (val) (set-difference tags (append (km0 `#$(the called of ,VAL)) (km0 `#$(the uniquely-called of ,VAL))) :test #'equal)) vals)) ) (cond ((null target-vals) (cond ((eq fmode 'error) (report-error 'user-error "(~a called/uniquely-called ~a): No values of ~a (evaluates to ~a) is called/uniquely-called ~a!" expr tag expr vals (val-to-vals tag))) ; (t (make-comment "Warning: Can't find any (~a called/uniquely-called ~a)" expr tag)) )) (t target-vals))))) ) ; synonym ( (?expr #$uniquely-called ?tag) (lambda (fmode expr tag) (km0 `(,expr #$called ,tag) :fail-mode fmode)) ) ;;; > (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 set test) (km0 `(#$forall ,set #$where ,test #$It) :fail-mode fmode))) ; equivalent ;;; New for KM1.4.0 beta-12 ( (#$allof ?set #$must ?test) (lambda (fmode set test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst Instance '#$It test))) (km0 set)) '#$(t))))) ;;; New for KM1.4.0 beta-18 ( (#$allof ?set #$where ?test2 #$must ?test) (lambda (fmode set test2 test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst Instance '#$It test))) (km0 `#$(allof ,SET where ,TEST2))) '#$(t))))) ( (#$oneof ?set #$where ?test) (lambda (fmode set test) (declare (ignore fmode)) (let ( (answer (find-if #'(lambda (member) (km0 (subst member '#$It test))) (km0 set))) ) (cond (answer (list answer))))) ) ;;; New 1.4 - check to ensure there's a single value ( (#$theoneof ?set #$where ?test) (lambda (fmode set test) (let ( (val (km-unique0 `(#$forall ,set #$where ,test #$It) :fail-mode fmode)) ) ; equivalent (cond (val (list val))))) ) ( (#$forall ?set ?value) (lambda (fmode set value) (km0 `(#$forall ,set #$where t ,value) :fail-mode fmode))) ; equivalent ;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results. ( (#$forall-seq ?seq ?value) (lambda (fmode seq value) (km0 `(#$forall-seq ,seq #$where t ,value) :fail-mode fmode))) ; equivalent ( (#$forall-bag ?bag ?value) (lambda (fmode bag value) (km0 `(#$forall-bag ,bag #$where t ,value) :fail-mode fmode))) ; equivalent ; not used any more ; ( (#$forone ?set ?value) ; (lambda (fmode set value) ; (km0 `(#$forone ,set #$where t ,value) :fail-mode fmode))) ; equivalent ( (#$forall ?set #$where ?constraint ?value) (lambda (_fmode set constraint value) (declare (ignore _fmode)) (remove nil (my-mapcan #'(lambda (member) (cond ((km0 (subst member '#$It constraint)) (km0 (subst member '#$It value))))) (km0 set)))) ) ;;; ---------- ;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results. ( (#$forall-seq ?seq #$where ?constraint ?value) (lambda (_fmode seq constraint value) (declare (ignore _fmode)) (let ( (sequences (km0 seq)) ) (cond ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `#$(forall-seq ,SEQ where ,CONSTRAINT ,VALUE) seq)) (t (list (cons '#$:seq (remove 'to-remove (mapcar #'(lambda (member) (cond ((km0 (subst member '#$It constraint)) (vals-to-val (km0 (subst member '#$It value)))) (t 'to-remove))) (rest (first sequences)))))))))) ) ; ((:seq a b)) -> map over (a b) ( (#$forall-seq2 ?seq #$where ?constraint ?value) (lambda (_fmode seq constraint value) (declare (ignore _fmode)) (let ( (sequences (km0 seq)) ) (cond ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `#$(forall-seq2 ,SEQ where ,CONSTRAINT ,VALUE) seq)) (t (list (cons '#$:seq (remove 'to-remove (mapcar #'(lambda (member) (cond ((km0 (subst member '#$It2 constraint)) (vals-to-val (km0 (subst member '#$It2 value)))) (t 'to-remove))) (rest (first sequences)))))))))) ) ; ((: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 bag constraint value) (declare (ignore _fmode)) (let ( (bags (km0 bag)) ) (cond ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `#$(forall-bag ,BAG where ,CONSTRAINT ,VALUE) bag)) (t (list (cons '#$:bag (remove nil (mapcar #'(lambda (member) (cond ((km0 (subst member '#$It constraint)) (vals-to-val (km0 (subst member '#$It value)))))) (rest (first bags)))))))))) ) ; ((:bag a b)) -> map over (a b) ( (#$forall-bag2 ?bag #$where ?constraint ?value) (lambda (_fmode bag constraint value) (declare (ignore _fmode)) (let ( (bags (km0 bag)) ) (cond ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `#$(forall-bag2 ,BAG where ,CONSTRAINT ,VALUE) bag)) (t (list (cons '#$:bag (remove nil (mapcar #'(lambda (member) (cond ((km0 (subst member '#$It2 constraint)) (vals-to-val (km0 (subst member '#$It2 value)))))) (rest (first bags)))))))))) ) ; ((:bag a b)) -> map over (a b) ;;; ---------- ;;; To allow nesting, we also have forall2, whose referents are "it2" ( (#$allof2 ?set #$where ?test) (lambda (fmode set test) (km0 `(#$forall2 ,set #$where ,test #$It2) :fail-mode fmode))) ; equivalent ;;; New for KM1.4.0 beta-12 ( (#$allof2 ?set #$must ?test) (lambda (fmode set test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst Instance '#$It2 test))) (km0 set)) '#$(t))))) ;;; New for KM1.4.0 beta-18 ( (#$allof2 ?set #$where ?test2 #$must ?test) (lambda (fmode set test2 test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst Instance '#$It2 test))) (km0 `#$(allof2 ,SET where ,TEST2))) '#$(t))))) ( (#$oneof2 ?set #$where ?test) (lambda (fmode set test) (declare (ignore fmode)) (let ( (answer (find-if #'(lambda (member) (km0 (subst member '#$It2 test))) (km0 set))) ) (cond (answer (list answer))))) ) ( (#$forall2 ?set ?value) (lambda (fmode set value) (km0 `(#$forall2 ,set #$where t ,value) :fail-mode fmode))) ; equivalent ( (#$forall-seq2 ?seq ?value) (lambda (fmode seq value) (km0 `(#$forall-seq2 ,seq #$where t ,value) :fail-mode fmode))) ; equivalent ( (#$forall-bag2 ?bag ?value) (lambda (fmode bag value) (km0 `(#$forall-bag2 ,bag #$where t ,value) :fail-mode fmode))) ; equivalent ; ( (#$forone2 ?set ?value) ; (lambda (fmode set value) ; (km0 `(#$forone2 ,set #$where t ,value) :fail-mode fmode))) ; equivalent ( (#$theoneof2 ?set #$where ?test) (lambda (fmode set test) (let ( (val (km-unique0 `(#$forall2 ,set #$where ,test #$It2) :fail-mode fmode)) ) ; equivalent (cond (val (list val))))) ) ( (#$forall2 ?set #$where ?constraint ?value) (lambda (_fmode set constraint value) (declare (ignore _fmode)) (remove 'nil (my-mapcan #'(lambda (member) (cond ((km0 (subst member '#$It2 constraint)) (km0 (subst member '#$It2 value))))) (km0 set)))) ) ; ( (#$forone2 ?set #$where ?constraint ?value) ; (lambda (_fmode set constraint value) ; (declare (ignore _fmode)) ; (some #'(lambda (member) ; (cond ((km0 (subst member '#$It2 constraint)) ; (km0 (subst member '#$It2 value))))) ; (km0 set)))) ;;; ====================================================================== ;;; NEW: VARIABLES!!! ;;; ====================================================================== ( (#$allof ?var #$in ?set #$where ?test) (lambda (fmode var set test) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$allof ,var #$in ,set #$where ,test))) (t (km0 `(#$forall ,var #$in ,set #$where ,test ,var) :fail-mode fmode)))) ) ; equivalent ( (#$allof ?var #$in ?set #$must ?test) (lambda (fmode var set test) (declare (ignore fmode)) (allof-must var set test)) ) ( (#$allof ?var #$in ?set #$where ?test2 #$must ?test) (lambda (fmode var set test2 test) (declare (ignore fmode)) (allof-where-must var set test2 test)) ) ( (#$oneof ?var #$in ?set #$where ?test) (lambda (fmode var set test) (declare (ignore fmode)) (oneof-where var set test)) ) ( (#$theoneof ?var #$in ?set #$where ?test) (lambda (fmode var set test) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$theoneof ,var #$in ,set #$where ,test))) (t (let ( (val (km-unique0 `(#$forall ,var #$in ,set #$where ,test ,var) :fail-mode fmode)) ) ; equivalent (cond (val (list val))))))) ) ( (#$forall ?var #$in ?set ?value) (lambda (fmode var set value) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$forall ,var #$in ,set ,value))) (t (km0 `(#$forall ,var #$in ,set #$where t ,value) :fail-mode fmode)))) ) ; equivalent ( (#$forall-seq ?var #$in ?seq ?value) (lambda (fmode var seq value) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$forall-seq ,var #$in ,seq ,value))) (t (km0 `(#$forall-seq ,var #$in ,seq #$where t ,value) :fail-mode fmode)))) ) ; equivalent ( (#$forall-bag ?var #$in ?bag ?value) (lambda (fmode var bag value) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$forall-bag ,var #$in ,bag ,value))) (t (km0 `(#$forall-bag ,var #$in ,bag #$where t ,value) :fail-mode fmode)))) ) ; equivalent ( (#$forall ?var #$in ?set #$where ?constraint ?value) (lambda (_fmode var set constraint value) (declare (ignore _fmode)) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$forall ,var #$in ,set #$where ,constraint ,value))) (t (remove nil (my-mapcan #'(lambda (member) (cond ((km0 (subst member var constraint)) (km0 (subst member var value))))) (km0 set)))))) ) ( (#$forall-bag ?var #$in ?bag #$where ?constraint ?value) (lambda (_fmode var bag constraint value) (declare (ignore _fmode)) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$forall-bag ,var #$in ,bag #$where ,constraint ,value))) (t (let ( (bags (km0 bag)) ) (cond ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `#$(forall-bag ,VAR in ,BAG where ,CONSTRAINT ,VALUE) bag)) (t (list (cons '#$:bag (remove nil (mapcar #'(lambda (member) (cond ((km0 (subst member var constraint)) (vals-to-val (km0 (subst member var value)))))) (rest (first bags)))))))))))) ) ; ((:bag a b)) -> map over (a b) ( (#$forall-seq ?var #$in ?seq #$where ?constraint ?value) (lambda (_fmode var seq constraint value) (declare (ignore _fmode)) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(#$forall-seq ,var #$in ,seq #$where ,constraint ,value))) (t (let ( (sequences (km0 seq)) ) (cond ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `#$(forall-seq ,VAR in ,SEQ where ,CONSTRAINT ,VALUE) seq)) (t (list (cons '#$:seq (remove 'to-remove (mapcar #'(lambda (member) (cond ((km0 (subst member var constraint)) (vals-to-val (km0 (subst member var value)))) (t 'to-remove))) (rest (first sequences)))))))))))) ) ; ((: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 lispcode) (declare (ignore _fmode)) (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))))) ) ( (#$search-control ?pattern ?vars ?mindepth ?maxdepth ?result) (lambda (_fmode pattern vars mindepth maxdepth result) (declare (ignore _fmode)) (let ( (pattern0 (subst '&rest '#$&rest pattern)) ) (cond ((not (member pattern0 *search-control-points* :test #'equal)) (setq *search-control-points* (cons (list pattern0 vars mindepth maxdepth result) *search-control-points*)))) (km-format t "Search will be controlled at the following points:~%~{ ~a~%~}" (mapcar #'(lambda (s) (list (first s) '-> (fifth s))) *search-control-points*)) ; friendly formatting '#$(t))) ) ;;; ====================================================================== ;;; MULTIARGUMENT PREDICATES ;;; ====================================================================== ;;; Shorthands ( (#$the1 ?slot #$of ?frameadd) (lambda (fmode slot frameadd) (km0 `#$(the1 of (the ,SLOT of ,FRAMEADD)) :fail-mode fmode)) ) ( (#$the2 ?slot #$of ?frameadd) (lambda (fmode slot frameadd) (km0 `#$(the2 of (the ,SLOT of ,FRAMEADD)) :fail-mode fmode)) ) ( (#$the3 ?slot #$of ?frameadd) (lambda (fmode slot frameadd) (km0 `#$(the3 of (the ,SLOT of ,FRAMEADD)) :fail-mode fmode)) ) ;;; ---------- ;;; [1] New: tolerate (the1 of x), where x isn't structured ( (#$the1 #$of ?frameadd) (lambda (fmode frameadd) (let ( (multiargs (km0 frameadd :fail-mode fmode)) ) (km0 (vals-to-val (mapcar #'(lambda (multiarg) (cond ((km-structured-list-valp multiarg) (arg1of multiarg)) (t multiarg))) ; [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 frameadd) (let ( (multiargs (km0 frameadd :fail-mode fmode)) ) (km0 (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 frameadd) (let ( (multiargs (km0 frameadd :fail-mode fmode)) ) (km0 (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 nexpr frameadd) (let ( (n (km-unique0 nexpr :fail-mode 'error)) (multiargs (km0 frameadd :fail-mode fmode)) ) (cond ((or (not (integerp n)) (< n 1)) (report-error 'user-error "Doing ~a. ~a should evaluate to a non-negative integer!~%" `#$(the ,NEXPR of ,FRAMEADD) nexpr)) (t (km0 (vals-to-val (mapcar #'(lambda (multiarg) (cond ((and (km-structured-list-valp multiarg) (< n (length multiarg))) ; elt returns error if n out of range under Mac CommonLisp (elt multiarg n)) ((eq 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 nexpr frameadd) (let ( (n (km-unique0 nexpr :fail-mode 'error)) (vals (km0 frameadd :fail-mode fmode)) ) (cond ((or (not (integerp n)) (< n 1)) (report-error 'user-error "Doing ~a. ~a should evaluate to a non-negative integer!~%" `#$(the ,NEXPR of ,FRAMEADD) nexpr)) ((and (<= n (length vals)) ; elt 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 x y rest) (km0 `((,x ^ ,y) ^ ,@rest) :fail-mode fm)) ) ( (?x ^ ?y + &rest) (lambda (fm x y rest) (km0 `((,x ^ ,y) + ,@rest) :fail-mode fm)) ) ( (?x ^ ?y - &rest) (lambda (fm x y rest) (km0 `((,x ^ ,y) - ,@rest) :fail-mode fm)) ) ( (?x ^ ?y / &rest) (lambda (fm x y rest) (km0 `((,x ^ ,y) / ,@rest) :fail-mode fm)) ) ( (?x ^ ?y * &rest) (lambda (fm x y rest) (km0 `((,x ^ ,y) * ,@rest) :fail-mode fm)) ) ( (?x / ?y + &rest) (lambda (fm x y rest) (km0 `((,x / ,y) + ,@rest) :fail-mode fm)) ) ( (?x / ?y - &rest) (lambda (fm x y rest) (km0 `((,x / ,y) - ,@rest) :fail-mode fm)) ) ( (?x / ?y / &rest) (lambda (fm x y rest) (km0 `((,x / ,y) / ,@rest) :fail-mode fm)) ) ( (?x / ?y * &rest) (lambda (fm x y rest) (km0 `((,x / ,y) * ,@rest) :fail-mode fm)) ) ( (?x * ?y + &rest) (lambda (fm x y rest) (km0 `((,x * ,y) + ,@rest) :fail-mode fm)) ) ( (?x * ?y - &rest) (lambda (fm x y rest) (km0 `((,x * ,y) - ,@rest) :fail-mode fm)) ) ( (?x * ?y / &rest) (lambda (fm x y rest) (km0 `((,x * ,y) / ,@rest) :fail-mode fm)) ) ( (?x - ?y - &rest) (lambda (fm x y rest) (km0 `((,x - ,y) - ,@rest) :fail-mode fm)) ) ( (?x - ?y + &rest) (lambda (fm x y rest) (km0 `((,x - ,y) + ,@rest) :fail-mode fm)) ) ( (?x + ?y - &rest) (lambda (fm x y rest) (km0 `((,x + ,y) - ,@rest) :fail-mode fm)) ) ;;; ---------------------------------------- ( (?expr + &rest) (lambda (fmode expr rest) (let ( (x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode)) ) (cond ((and (numberp x) (numberp y)) (list (+ x y))))))) ( (?expr - &rest) (lambda (fmode expr rest) (let ( (x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode)) ) (cond ((and (numberp x) (numberp y)) (list (- x y))))))) ( (?expr * &rest) (lambda (fmode expr rest) (let ( (x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode)) ) (cond ((and (numberp x) (numberp y)) (list (* x y))))))) ( (?expr / &rest) (lambda (fmode expr rest) (let ( (x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode)) ) (cond ((and (numberp x) (numberp y)) #|new|# (cond ((and (zerop x) (zerop y) (list 1))) #|new|# ((zerop x) (list 0)) #|new|# ((zerop y) (list *infinity*)) ((and (numberp x) (numberp y)) (list (/ x y)))))))) ) ( (?expr1 ^ ?expr2) (lambda (fmode expr1 expr2) (let ( (x (km-unique0 expr1 :fail-mode fmode)) (y (km-unique0 expr2 :fail-mode fmode)) ) (cond ((and (numberp x) (numberp y)) (list (expt x y))))))) ; 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) (declare (ignore _fmode)) nil) ) ( nil ; ie. NIL (lambda (_fmode) (declare (ignore _fmode)) nil) ) ( (?target :== (#$: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) (km0 expr :target target)) exprs)) ) ( (#$:set &rest) ; for :set, just remove :set tag to return a list (lambda (fmode exprs) ; km will do the dereferencing and remove the duplicates later (declare (ignore fmode)) (my-mapcan #'(lambda (expr) (km0 expr)) exprs)) ) ( (#$:seq &rest) ; for :seq, build a one-element long structure (lambda (fmode exprs) (declare (ignore fmode)) (let ( (sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs)) ) (cond (sequence `#$((:seq ,@SEQUENCE)))))) ) ( (#$:bag &rest) ; for :bag, build a one-element long structure (lambda (fmode exprs) (declare (ignore fmode)) (let ( (bag (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs)) ) (cond (bag `#$((:bag ,@BAG)))))) ) ( (#$:function &rest) ; Identical code for functions... (lambda (fmode exprs) (declare (ignore fmode)) (let ( (sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs)) ) (cond (sequence `#$((:function ,@SEQUENCE)))))) ) ( (#$:pair &rest) ; for :seq, build a one-element long structure (lambda (fmode exprs) (declare (ignore fmode)) (cond ((not (pairp exprs)) (report-error 'user-error "~a: A pair should have exactly two elements!~%" `#$(:pair ,@EXPRS))) (t (let ( (sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs)) ) (cond (sequence `#$((:pair ,@SEQUENCE)))))))) ) ;;; 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 frame-expr slot-expr val-expr) (declare (ignore _fmode)) (let* ((slot (cond ((comparison-operator slot-expr) slot-expr) ; can't pass >= etc. to km-unique0 (it's a keyword) (t (km-unique0 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-unique0 frame-expr :fail-mode 'error)))) (val (cond ((or (constraint-exprp val-expr) (existential-exprp val-expr) (comparison-operator slot)) 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 (km0 val-expr))))) ) `#$((:triple ,FRAME ,SLOT ,VAL)))) ) ( (#$:args &rest) ; for :seq, build a one-element long structure (lambda (fmode exprs) (declare (ignore fmode)) (let ( (sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs)) ) (cond (sequence `#$((:args ,@SEQUENCE)))))) ) ; Neah, not this: ; (let ( (sequence (my-mapcan #'(lambda (expr) (km0 expr)) exprs)) ) ; (cond (sequence `#$((:args ,@SEQUENCE)))))) ) ( (#$showme ?km-expr) (lambda (_fmode km-expr) (declare (ignore _fmode)) (showme km-expr)) ) ( (#$showme ?km-expr ?file) (lambda (_fmode km-expr file) (declare (ignore _fmode)) (cond ((not (stringp file)) (report-error 'user-error "(showme ): should be a string!~%")) (t (let ( (stream (tell file)) ) (prog1 (showme km-expr (all-situations) (visible-theories) stream) (cond ((streamp stream) (close stream))) (km-format t "(Output sent to file ~a)~%" file)))))) ) ( (#$showme-all ?km-expr) (lambda (_fmode km-expr) (declare (ignore _fmode)) (showme-all km-expr)) ) ( (#$evaluate-all ?km-expr) (lambda (_fmode km-expr) (declare (ignore _fmode)) (evaluate-all km-expr)) ) ( (#$showme-here ?km-expr) (lambda (_fmode km-expr) (declare (ignore _fmode)) (showme km-expr (list (curr-situation)) (visible-theories))) ) ;;; ---------- ( (#$the-class ?class) (lambda (fmode class) (declare (ignore fmode)) ; (km0 class :fail-mode fmode)) ) ; `((#$the-class ,class))) ) #|NEW|# (process-unquotes `((#$the-class ,class)))) ) ; `('(#$every ,class))) ) ( (#$the-class ?class #$with &rest) (lambda (fmode class slotsvals) (declare (ignore fmode)) (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 slot frameadd) (declare (ignore fmode0)) (let ( (frame (km-unique0 frameadd :fail-mode 'error)) ) (mapcar #'quotify (collect-constraints-on-instance frame slot)))) ) ( (#$rules-for (#$the ?slot #$of ?frameadd)) (lambda (fmode0 slot frameadd) (declare (ignore fmode0)) (let ( (rules (rules-for slot frameadd)) ) (cond ((null rules) nil) ((km-setp rules) (mapcar #'quotify (set-to-list rules))) (t (list (quotify rules)))))) ) ; otherwise ( (#$why) (lambda (fmode) (declare (ignore fmode)) (why)) ) ( (#$why ?triple) (lambda (fmode triple) (declare (ignore fmode)) (cond ((not (km-triplep triple)) (report-error 'user-error "Bad argument to (why ...)! Should be of form (why (:triple ))!")) (t (why triple)))) ) ( (#$justify) (lambda (fmode) (declare (ignore fmode)) (justify))) ( (#$justify ?triple) (lambda (fmode triple) (declare (ignore fmode)) (justify triple))) ( (#$get-justification) (lambda (fmode) (declare (ignore fmode)) (list (concat-list (cons (format nil "--------------------~%") (append (insert-delimeter (get-justification :format 'ascii) *newline-string*) (list (format nil "~%-------------------~%"))))))) ) ( (#$get-justification ?triple) (lambda (fmode triple) (declare (ignore fmode)) (list (concat-list (cons (format nil "--------------------~%") (append (insert-delimeter (get-justification :triple triple :format 'ascii) *newline-string*) (list (format nil "~%-------------------~%"))))))) ) ;;; NEW: allow explanations to be re-read in from a .km file. Useful for explanations for prototype pieces. ( (#$explanation (#$:triple ?f ?s ?v) ?explanations) (lambda (fmode f s v explanations) (declare (ignore fmode)) (mapc #'(lambda (explanation) (record-explanation-for `#$(the ,S of ,F) v explanation :situation *global-situation*)) explanations) '#$(t)) ) ( (#$comment ?comment-tag &rest) (lambda (fmode comment-tag data) (declare (ignore fmode)) (comment comment-tag data)) ) ( (#$show-comment ?comment-tag) (lambda (fmode comment-tag) (declare (ignore fmode)) (show-comment comment-tag)) ) ;;; For test-suite only ; ( (#$delete-triple ?frame ?slot ?value) ; (lambda (fmode frame slot value) ; (declare (ignore fmode)) ; (delete-triple (dereference frame) slot (dereference value))) ) ( (quote ?expr) (lambda (fmode expr) (declare (ignore fmode)) (let ( (processed-expr (process-unquotes expr)) ) (cond (processed-expr (list (list 'quote processed-expr)))))) ) ( (unquote ?expr) (lambda (fmode expr) (declare (ignore fmode)) (report-error 'user-error "Doing #,~a: You can't unquote something without it first being quoted!~%" expr)) ) ;;; For Adam Farquhar - 12/9/98 now it *does* delete inverses ( (#$delete ?km-expr) (lambda (fmode km-expr) (mapcar #'delete-frame (km0 km-expr :fail-mode fmode))) ) ( (#$evaluate ?expr) ; Can't use eval, as that's a Lisp call! (lambda (fmode expr) (let ( (quoted-exprs (km0 expr :fail-mode fmode)) ) (remove nil (my-mapcan #'(lambda (quoted-expr) (cond ((member quoted-expr '#$(f F)) nil) ((and (pairp quoted-expr) (eq (first quoted-expr) 'quote)) (km0 (second quoted-expr) :fail-mode fmode)) ; Neah, don't do this. ; ((km-triplep quoted-expr) ; NEW ; (let ( (frame (km-unique0 (second quoted-expr) :fail-mode 'error)) ; (slot (km-unique0 (third quoted-expr) :fail-mode 'error)) ; (val (cond ((constraint-exprp (fourth quoted-expr)) (fourth quoted-expr)) ; NEW: constraints *preserved* ; (t (vals-to-val (km0 (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 frame) (report-error 'user-warning "(exists ~a): (exists ) has been renamed (has-value ) in KM 1.4.~% Please update your KB! Continuing...~%" frame) (km0 `#$(has-value ,FRAME) :fail-mode fmode)) ) ( (#$has-value ?frame) (lambda (_fmode frame) (declare (ignore _fmode)) (cond ((km0 frame) '#$(t)))) ) ( (#$print ?expr) (lambda (_fmode expr) (declare (ignore _fmode)) (let ( (vals (km0 expr)) ) (km-format t "~a~%" vals) vals ))) ( (#$format ?flag ?string &rest) (lambda (_fmode flag string arguments) (declare (ignore _fmode)) (cond ((eq flag '#$t) (apply #'format `(t ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))) '#$(t)) ((member flag '#$(nil NIL)) (list (apply #'format `(nil ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))))) (t (report-error 'user-error "~a: Second argument must be `t' or `nil', not `~a'!~%" `(#$format ,flag ,string ,@arguments) flag)))) ) ( (#$km-format ?flag ?string &rest) (lambda (_fmode flag string arguments) (declare (ignore _fmode)) (cond ((eq flag '#$t) (apply #'km-format `(t ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))) '#$(t)) ((member flag '#$(nil NIL)) (list (apply #'km-format `(nil ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))))) (t (report-error 'user-error "~a: Second argument must be `t' or `nil', not `~a'!~%" `(#$km-format ,flag ,string ,@arguments) flag)))) ) ; ( (tell (quote (?frame ?slot ?val))) ; (lambda (_fmode frame slot val) ; (declare (ignore _fmode)) ; (set-val frame slot val) ; t) ) ;;; (_car1) -> (_car1) ;;; (_car1 _car2) -> (_car1 "and" _car2) ;;; (_car1 _car2 _car3) -> (_car1 "," _car2 ", and" _car3) ( (#$andify ?expr) (lambda (fmode expr) (list (cons '#$:seq (andify (km0 expr :fail-mode fmode))))) ) ; to avoid removing duplicate ", "s ; not used any more... ; ( (#$expand-text ?expr) ; (lambda (fmode expr) ; (let ( (expanded (expand-text (km0 expr :fail-mode fmode))) ) ; (cond (expanded (list expanded))))) ) ;;; [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 expr) (declare (ignore _fmode)) #|[1]|# (let ( (text (km0 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 expr) (declare (ignore _fmode)) (let ( (text (km0 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 expr) (declare (ignore fmode)) (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 expr) (declare (ignore fmode)) (spy expr)) ) ( (#$spy) (lambda (fmode) (declare (ignore fmode)) (spy)) ) ( (#$unspy) (lambda (fmode) (declare (ignore fmode)) (unspy)) ) ;;; ====================================================================== ;;; TAXONOMY ;;; ====================================================================== ( (#$taxonomy &rest) (lambda (fmode args) (declare (ignore fmode)) (cond ((null args) (taxonomy)) ((singletonp args) (taxonomy (km-unique (first args)))) ((pairp args) (taxonomy (km-unique (first args)) (km-unique (second args)))) (t (report-error 'user-error "Too many arguments to the taxonomy function! Format is (taxonomy )~%")))) ) ;;; ====================================================================== ;;; ROLLBACK MECHANISM ;;; ====================================================================== ( (#$checkpoint) (lambda (fmode) (declare (ignore fmode)) (set-checkpoint) '#$(t)) ) ( (#$checkpoint ?checkpoint-id) (lambda (fmode checkpoint-id) (declare (ignore fmode)) (cond ((null checkpoint-id) (report-error 'user-error "(checkpoint ~a): Argument to checkpoint can't be NIL!~%" checkpoint-id)) (t (set-checkpoint checkpoint-id) '#$(t))))) ( (#$undo) ; called only from within a program (km ...), NOT from the KM prompt (lambda (fmode) (declare (ignore fmode)) (cond ((undo) '#$(t)))) ) ;;; This is rather an ugly macro...oh well, let's leave it here ( (#$an #$instance #$of ?expr) (lambda (fmode expr) (km0 `(#$an #$instance #$of ,expr #$with) :fail-mode fmode)) ) ( (#$an #$instance #$of ?expr #$with &rest) (lambda (fmode expr slotsvals) (declare (ignore fmode)) (cond ((are-slotsvals slotsvals) (let* ( (classes (km0 expr :fail-mode 'error)) (class (first classes)) (classes-in-slotsvals (vals-in (assoc '#$instance-of slotsvals))) (new-slotsvals (cond ((>= (length classes) 2) (update-assoc-list slotsvals `(#$instance-of ,(remove-duplicates (append (rest classes) classes-in-slotsvals))))) (t slotsvals))) ) (list (create-instance class new-slotsvals)))))) ) ( (#$reverse ?seq-expr) (lambda (fmode seq-expr) (let ( (seq (km-unique0 seq-expr :fail-mode fmode)) ) (cond ((null seq) nil) ((km-seqp seq) (list (cons '#$:seq (reverse (rest seq))))) (t (report-error 'user-error "Attempting to reverse a non-sequence ~a!~%[Sequences should be of the form (:seq ... )]~%" seq-expr)))))) ( (#$:default ?expr) ; strip off and ignore :default flag (lambda (fmode expr) ;;; (km0 expr :fail-mode fmode)) ) (declare (ignore fmode expr)) ; no - now ignore them (km-setq '*are-some-defaults* t) nil )) ;;; New and inert... ( (#$sometimes ?expr) (lambda (fmode expr) (km0 expr :fail-mode fmode)) ) ( (#$anonymous-instancep ?expr) (lambda (fmode expr) (declare (ignore fmode)) (cond ((anonymous-instancep (km-unique0 expr :fail-mode 'error)) '#$(t)))) ) ;;; [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 path) (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) (km0 (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 (km0 (first path)))) (y (vals-to-val (km0 (third path)))) (answer0 (apply infix-implementation-fn (list x y))) (answer (listify answer0)) ) (cond ((every #'fully-evaluatedp answer) answer) (t (report-error 'user-error "In call to external Lisp procedure (~a ~a ~a) Lisp procedure should return one/a list of fully evaluated KM objects (e.g., instances, or :seq/:bag/:pair of instances), but instead returned: ~a~%" infix-implementation-fn x y answer0)))))))) ((not *linear-paths*) (report-error 'user-error "KM Syntax error: ~a is not a valid KM expression~%" path)) ((not (no-reserved-keywords path)) nil) ; 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 (km0 (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 (km0 (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 (km0 frameadd :fail-mode fmode0) slot0 '* :fail-mode fmode0)) ; target-class = * (t (let* ( (slot (cond ((pathp slot0) (km-unique0 slot0 :fail-mode 'error)) (t slot0))) (fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0))) (frames (km0 frameadd :fail-mode fmode)) ) (cond ((not (equal frames (val-to-vals frameadd))) (km0 `#$(,(VALS-TO-VAL FRAMES) ,SLOT) :fail-mode fmode)) ; [1] (t (km-multi-slotvals frames slot :fail-mode fmode)))))))))) ) ) ) ;;; ====================================================================== ;;; QUOTED PATHS eg. (Delta owns Plane (part *) Wing) ;;; ;;; a quoted path is of form: ;;; (...... ) ;;; where is of the form ;;; ( *) ;;; or ( * ) ;;; ====================================================================== ;;; 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)) (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 (km0 (vals-to-val (multidepth-path-expr (vals-to-val values) slot target-class depth-limit)) :fail-mode fail-mode))))) (defun multidepth-path-expr (path slot target-class depth-limit) (cond ((<= depth-limit 0) nil) ((neq target-class '*) (cons `#$(the ,TARGET-CLASS ,SLOT of ,PATH) (multidepth-path-expr `#$(the ,SLOT of ,PATH) slot target-class (1- depth-limit)))) (t (cons `#$(the ,SLOT of ,PATH) (multidepth-path-expr `#$(the ,SLOT of ,PATH) slot target-class (1- depth-limit)))))) ;;; ====================================================================== ;;; ACCESS TO THE KNOWLEDGE-BASE ;;; These functions make the bridge between km expressions (see ;;; *km-handler-alist* below) and the KB access function get-global. ;;; ====================================================================== ;;; --------------------------------------- ;;; 1. The basic routine for getting slot values is km-multi-slotvals. ;;; It is given a *list* of frames, and gets their values. ;;; ---------------------------------------- ;;; (km-multi-slotvals frames slot): ;;; frames will always be a list. ;;; Find and concatenate the vals of slot for frames. ;;; MUST return a *list* of values. <- ?? Oct 97: No! ;;; Some special handling for slots like "sum" etc. which instead of ;;; looking up values of frames they *sum* the frames (which of ;;; course must thus be numbers) (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 (km0 (val-sets-to-expr (mapcar #'list frames) t))) ; t = single-valuedp (#$set-unification (km0 (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))) (#$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): value 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-unique0 `#$(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|# (km0 `#$(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 #'+))) (km0 '#$(a Number) :fail-mode 'error)) ; just for #'+, allow zero arguments. ((every #'numberp vals) (list (apply function vals))) (t (km0 '#$(a Number) :fail-mode 'error)))) ;;; --------------------------------------- ;;; 2. The auxiliary routine for getting the value of a slot is km-slotvals, ;;; which gets the slot values on a single frame. This is only used by ;;; kulti-slotvals. ;;; ---------------------------------------- ;;; (km-slotvals frame slot) ;;; - slot is atomic. Frame may be a kb-instance (including (:set ...) (:triple ...)) or a string or number ;;; - return the evaluated *list* of values for the slot of frame. ;;; NOTE: frame is already assumed to be dereferenced (using dereference) ;;; before this procedure is called. ;;; This procedure first filters special cases, then calls km-slotvals-from-kb ;;; for handling standard queries. (defun km-slotvals (frame slot &key (fail-mode 'fail)) (cond ((null frame) nil) ((km-triplep frame) ; special handling for triples, eg. (case slot ; (the name of (:triple *john wants *cash)) (#$name (list (name frame))) ; returns "john wants cash" ; (#$frame (list (second frame))) ; (the frame of ) ; (#$slot (list (third frame))) ; (the slot of ) ; (#$value (val-to-vals (fourth frame))) (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.5 (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 (km0 '#$(a Number) :fail-mode 'error)))) (#$min (aggregate-vals #'min frames)) (#$max (aggregate-vals #'max frames)) (#$product (aggregate-vals #'* frames)) (#$quotient (aggregate-vals #'/ frames)) (#$difference (aggregate-vals #'- frames))))) (t (report-error 'user-error "(the ~a of ~a): ~a should be given a bag (:bag ...) as an argument!~% [(the bag of ) will convert sets to bags]" slot frame slot)))) ((km-argsp frame) ; (the age of (:args Pete Clark)) -> (the age of Pete) (km0 `#$(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) (km0 `#$(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) (immediate-classes frame :enforce-constraints t)) ; synonyms (#$instances (immediate-instances frame)) (#$superclasses (immediate-superclasses 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 (domains-of frame)) (#$range (ranges-of frame)) (#$inverse (list (invert-slot frame))) (#$called (km0 (vals-to-val (append (get-vals frame '#$called :situation *global-situation*) (get-vals frame '#$uniquely-called :situation *global-situation*))) )) ; e.g. ((:set a b (<> c))) -> (a b) (#$uniquely-called (km0 (get-vals frame '#$uniquely-called :situation *global-situation*))) (#$cardinality (listify (cardinality-of frame))) (#$fluent-status (listify (fluent-status frame))))) (t (km-slotvals2 frame slot :fail-mode fail-mode)))) (defun km-slotvals2 (frame slot &key (fail-mode 'fail)) (cond ((not (kb-objectp frame)) (cond ((eq slot '#$name) (list (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) ((km-slotvals-from-kb frame slot :fail-mode fail-mode)) ((eq slot '#$name) ; failed to compute it so generate it (let ( (name (name frame)) ) (cond (name (put-vals frame slot (list name) :install-inversesp nil) (list name))))))) ;;; ====================================================================== ;;; GENERAL UTILITIES ;;; ====================================================================== ;;; (vals-in-class vals class): Return only those vals which are in class. (defun vals-in-class (vals class) (cond ((eq class '*) vals) (t (remove-if-not #'(lambda (val) (isa val class)) vals)))) ;;; 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 (km0 (second expr) :fail-mode fail-mode))))) (t (cons (process-unquotes (first expr)) (process-unquotes (rest expr)))))) ;;; (append-seqs '#$(:seq (:seq 1 2) (:seq 3 4))) -> #$(:|seq| 1 2 3 4) (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-unique0 frameadd :fail-mode 'error)) ) (val-sets-to-expr (append (own-rule-sets frame slot :retain-commentsp retain-commentsp) (inherited-rule-sets frame slot :retain-commentsp retain-commentsp)) (single-valued-slotp slot)))) ;;; ====================================================================== ;;; QUANTIFICATION: I get bus errors if I include these verbatim in the handler-alist itself, and use KM in compiled mode. ;;; This is an Allegro bug. So I need to separate out the bodies here. It seems to be the #'every and #'find-if calls which cause the problem. ;;; ====================================================================== (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) (km0 (subst instance var test))) (km0 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) (km0 (subst instance var test))) (km0 `#$(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)) ) (km0 test0))) (km0 set))) ) (cond (answer (list answer))))))) ;;; ====================================================================== ;;; SEARCH CONTROL ;;; *search-control-points* is a LIST of elements: ;;; (pattern vars mindepth maxdepth result) ;;; ====================================================================== (defun no-search-control () (setq *search-control-points* nil) (format t "All search control points removed.~%") '#$(t)) (defun search-control (kmexpr) (let ( (search-control-point (find-if #'(lambda (search-control-point) (minimatch kmexpr (first search-control-point))) *search-control-points*)) ) (cond (search-control-point (let* ((pattern (first search-control-point)) (vars (second search-control-point)) (result (fifth search-control-point)) (match (minimatch kmexpr pattern)) (bindings (mapcar #'(lambda (pair) (cons (first pair) (second pair))) ; convert ((?x 1) (?y 2)) to ((?x . 1) (?y . 2)) (transpose (list vars match)))) (depth (1+ *depth*)) ) ; effective depth (cond (*trace* (format t "~a" depth) (format t (spaces (- (1+ depth) (length (princ-to-string depth))))) (km-format t "-> ~a~%" kmexpr))) (make-comment "Search control: Expression ~a~% caught by pattern ~a,~% and evaluated as ~a (i.e., ~a)..." kmexpr pattern result (sublis bindings result)) (let ( (answer (km0 (sublis bindings result))) ) (cond (*trace* (format t "~a" depth) (format t (spaces (- (1+ depth) (length (princ-to-string depth))))) (km-format t "<- ~a~%" answer))) answer)))))) ;;; FILE: get-slotvals.lisp ;;; File: get-slotvals.lisp ;;; Author: Peter Clark ;;; Date: Separated out April 1999 ;;; 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 then (the Copy subevent of Self) else ...))))))) ;;; Here's the problem we want to avoid... [_Situation1] KM> (the subevent of (a Transcribe)) (_Copy2) [_Situation1] KM> (next-situation) [_Situation2] KM> (the next-event of _Copy2) NIL Similarly, projecting from prev situation doesn't work, as we want to re-evaluate the next-event rule. Hence we reify _Copy2 in the *Global situation. But we can only do this if subevent is a non-fluent ([2]) ?? - Do I really need this constraint? I'm restricting the generality of my reification "solution" here. I need a good model of destruction for this to be okay. Consider: (every Water has (parts ((a Hydrogen with (bound-to ((the Oxygen parts of Self)))) (a Oxygen with (bound-to ((the Hydrogen parts of Self))))))) If the Hydrogen and Oxygen can be removed as parts of the Water, then we must also be allowed to break their bindings. Hmm...But we shouldn't be able to break the "parts" relation, though? I suppose we could "switch" one Hydrogen for another, without violating the axiom, and then the bound-to relationship no longer needs to hold for the old Hydrogen part. But that is rather strange. [2] came up as Ken Barker wanted to be able to say things like: (every Person has (owns ((a Car)))) but not insist that it's the *same* car uniformly throughout their life. So we make owns a fluent. Now: (every Person has (owns ((a Car with (parts ((a Engine))))))) Suppose Fred owns _Car1 with _Engine1 in _Situation1. Now, in Situation2, there's no guarantee that Fred still owns _Car1, and hence no guarantee that the constraint _Car1 parts _Engine1 still needs to be enforced (?). |# (instance (dereference instance0)) (target `(#$the ,slot #$of ,instance)) (own-rule-sets0 (own-rule-sets instance slot :retain-commentsp t)) (own-constraints (mapcan #'find-constraints-in-exprs own-rule-sets0)) ; from instance in curr-situation AND its supersituations (inherited-rule-sets ; [1] (cond ((use-inheritance) (cond ((and (not own-rule-sets0) ; 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-constraints (mapcan #'find-constraints-in-exprs inherited-rule-sets)) ; 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)))) (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))) (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))) ) (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))) ; No! Sibling vals shouldn't unify! ; (km0 (val-sets-to-expr ; (mapcar #'(lambda (subslot) `#$((the ,SUBSLOT of ,INSTANCE0))) subslots) ; single-valuedp) #|Correct|# (km0 (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-sets0))) (cond ((tracep) (setq n (1+ n)) (km-trace 'comment "(~a) Look in supersituation(s)" n))) ; not used any more (remove-fluent-instances (km0 (val-sets-to-expr (mapcar #'(lambda (sitn) `#$((in-situation ,SITN (the ,SLOT of ,INSTANCE0)))) supersituations) single-valuedp) )))) |# (supersituation-vals nil) ; disabled now ;;; ---------- 4. LOCAL VALUES ---------- #| June 2001 Now redundant - we move prototype unification in earlier, and then can compute own-rule-sets immediately afterwards using the function specifically for this purpose, in frame-io.lisp. This correction here is no longer needed. ;;; 11.15.00 MOVE THIS EARLIER -- BEFORE the supersituation access clobbers the rules on instances!! ;;; 11.16.00 No! Must come *AFTER* prototypes are folded in, in order to pick up their contributions ;;; to the slot values! (own-rules (let ( (local-situation (target-situation (curr-situation) instance slot)) ) (bind-self (or (get-vals instance slot :facet 'own-properties :situation local-situation) ; This disjunct should be in get-vals- (get-vals instance slot :facet 'own-definition :situation local-situation)) ; in-situation, not here,+ should be conj! instance))) ;;; Same as own-rules, except here we must remove the fluent instances! NB *leave* the fluent ;;; instances in own-rules. (supersituation-own-rule-sets (supersituation-own-rule-sets instance slot :retain-commentsp t)) ;;; May 2001 - own-rule-sets SUPERCEDES own-rule-sets0. It may contain extra data as a result of the prototypes being unified in. (own-rule-sets (remove nil (cons own-rules supersituation-own-rule-sets))) ; (_dum (km-format t "own-rules = ~a, own-rule-sets = ~a~%" own-rules own-rule-sets)) |# (own-rule-sets own-rule-sets0) ; new ; PEC: No, better evaluate the defaults AFTER we get the inherited info, not before! ; (own-rule-sets (cond (*are-some-defaults* ; (mapcar #'(lambda (expr-set) (evaluate-and-filter-defaults expr-set constraints slot nil)) ; vals = nil, as we don't know any! ; own-rule-sets0)) ; (t own-rule-sets0))) (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)))) (cond ((and (singletonp own-rule-sets) ; (a) no evaluation necessary (singletonp (first own-rule-sets)) (atom (first (first own-rule-sets))) (eq (dereference (first (first own-rule-sets))) (first (first own-rule-sets)))) (first own-rule-sets)) (t ; (b) some evaluation necesary (eg. path in local slot) ; (km0 (val-sets-to-expr own-rule-sets single-valuedp))))))) (km0 (val-sets-to-expr own-rule-sets 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 ) 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 (member (first constraint) '#$(at-most exactly)) (eq (second constraint) 1))) constraints)) ) (cond ((singletonp val-sets) ; ONE val set found (cond ((not (dont-cache-values-slotp slot)) (let ( (vals0 (enforce-set-constraints (first val-sets) singletonp-constraints instance)) ) (put-vals instance slot vals0) vals0)) (t (first val-sets)))) (t (cond ((neq n-first-source n-sources) (km-trace 'comment "(~a-~a) Combine ~a-~a together" n-first-source n-sources n-first-source n-sources))) (let ( (vals0 (enforce-set-constraints (km0 (val-sets-to-expr val-sets single-valuedp) :target target) singletonp-constraints instance)) ) (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 ;;; PEC: Hmm...well, it treats defaults on *own*-rule-sets as "inherited" information, which can then be ;;; subsequently ignored if inherit-with-overrides is set to t. (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)) #|NEW|# (append own-rule-sets inherited-rule-sets))) (t inherited-rule-sets))) (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) ((and vals (inherit-with-overrides-slotp slot)) (km-trace 'comment "(Ignore rules, as there are local values and the slot is an inherit-with-overrides slot)") vals) (t ; (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))) (t (km-trace 'comment "(~a) From inheritance: ~a" n (val-sets-to-expr inherited-rule-sets00 single-valuedp)))))) (cond (vals (km-trace 'comment "(~a-~a) Combine ~a-~a together" n-first-source n n-first-source n))) (km0 (val-sets-to-expr (cons vals inherited-rule-sets00) single-valuedp) :target target)))) (t vals))) ;;; 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) (km0 (val-sets-to-expr (cons all-vals00 inherited-rule-sets00) 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)))) (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 (all-vals2 (cond (constraints ; note all-vals1 can be nil; we might coerce new vals to appear! (cond ((and (tracep) (not (traceconstraintsp))) (prog2 (suspend-trace) (enforce-constraints all-vals1 constraints instance slot) (unsuspend-trace))) (t (km-trace 'comment "(~ab) Test values against constraints ~a" n constraints) (enforce-constraints all-vals1 constraints instance slot)))) (t all-vals1))) (all-vals (cond ((remove-subsumers-slotp slot) (remove-subsumers all-vals2)) ((remove-subsumees-slotp slot) (remove-subsumees all-vals2)) (t all-vals2))) (all-vals-and-constraints (cond (local-constraints (cond (single-valuedp (list (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] ; Why was classify removed in earlier versions? ; (classify instance) ; June 2001: 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 ;;; 2/8/02 if in local, all global explanations necc. apply too so copy them in (cond ((and (am-in-local-situation) *record-explanations*) (mapc #'(lambda (aval0) (mapc #'(lambda (global-explanation) (let ( (i (first global-explanation)) (s (second global-explanation)) (v (third global-explanation)) (es (fourth global-explanation)) ) ; (km-format t "DEBUG: Copying ~a from *Global to ~a~%" global-explanation (curr-situation)) (mapc #'(lambda (e) (record-explanation-for `#$(the ,S of ,I) v e)) ; re-assert in (curr-situation) es))) (get-explanations instance slot aval0 *global-situation*))) ; -> ((i s v es) (v invs i es')) all-vals))) all-vals)) #| Special case: If looping, then all-vals-and-constraints might be a STRUCTURE, rather than kb-objects. In this case, we must filter off the structures, as get-vals is required to return only kb-objects. We also must defer noting this slot as done -- a future retry might enable these structures to evaluate. This patch was later moved elsewhere into the interpreter.lisp code, see (remove-if-not #'is-km-term ...) test in (#$the ?slot of #$expr). See the example in test-suite/restaurant.km for the explanation of this patch. (cond ((every #'is-km-term all-vals) (check-slot instance slot all-vals) ; optional error-checking (note-done instance slot) ; flag instance.slot done all-vals) (t (remove-if-not #'is-km-term all-vals))))) |# ;;; (recursive-ruleset '#$_Car23 '#$parts '#$(_Engine3 (the parts of (the parts of _Car23)))) ;;; -> t ;;; This is using cheap tricks to check for recursive rules! If it accidentally makes a ;;; mistake it's not an error, just an inefficiency. (defun recursive-ruleset (instance slot ruleset) (search `#$(,SLOT of ,INSTANCE) (flatten ruleset))) #| (defun recursive-ruleset (instance slot ruleset) (some #'(lambda (rule) (recursive-rule instance slot rule)) ruleset)) (defun recursive-rule (instance slot rule) (cond ((equal rule `#$(the ,SLOT of ,INSTANCE))) ((and (listp rule) (some #'(lambda (rule-part) (recursive-rule instance slot rule-part)) rule))))) |# ;;; ====================================================================== ;;; TEMPORAL PROJECTION CODE ;;; ====================================================================== #| Look up the slotvals from the previous situation (if any). Assume test "(and (am-in-local-situation) (projectable slot instance))" has already been passed. [1] 9/8/00 - We must ensure that EVENTS have non-inertial slot values, even if the user's failed to specify that these slots are non-inertial fluents. To ensure this, BOTH (Event slot Instance) and (Instance invslot Event) triples CANNOT be projected. [2] in projectable() removes the former, and [1] below removes the latter. |# (defun km-slotvals-via-projection (instance slot) ; (km-format t "Calling km-slotvals-via-projection...~%") (let ( (prev-situation (prev-situation (curr-situation))) ) (cond (prev-situation ; (remove-if #'(lambda (val) (isa val '#$Event)) ; [1] - Neah, let's not do this ; (remove-fluent-instances (km0 `#$(in-situation ,PREV-SITUATION (the ,SLOT of ,INSTANCE)))))) ; (km-format t "About to do remove-fluent-instances...~%") ; not used any more (remove-fluent-instances (km0 `#$(in-situation ,PREV-SITUATION (the ,SLOT of ,INSTANCE))))) (km0 `#$(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))) (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-unique0 `#$(in-situation *Global ,EXPR) :fail-mode 'error)) (t expr))) ;;; FILE: frame-io.lisp ;;; File: frame-io.lisp ;;; Author: Peter Clark ;;; Date: August 1994 ;;; Purpose: Low-level interface to the KM data structures ;;; Don't classify while classifying (defvar *am-classifying* nil) ;;; ====================================================================== ;;; 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) (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 prefix-string bind-selfp]) scan all supersituations and classes for rules: (own-rule-sets instance slot [start-situation retain-commentsp]) (supersituation-own-rule-sets instance slot [start-situation retain-commentsp]) [- not used] (inherited-rule-sets instance slot [start-situation retain-commentsp]) (inherited-rule-sets-on-classes classes slot [start-situation retain-commentsp]) (collect-constraints-on-instance instance slot [start-situation retain-commentsp]) (local-constraints instance slot [situation retain-commentsp]) other: ; (exists frame [start-situation]) ; look in local + accessible situations (known-frame frame) ; Replace "exists", to be more explicit about what exists means (has-situation-specific-info frame situation) ; look in local situation only (instance-of instance class) (is-subclass-of subclass class) (immediate-classes instance) (immediate-superclasses class) (immediate-subclasses class) (immediate-supersituations situation) (immediate-subslots slot) (all-instances class) (all-prototypes class) (all-classes instance) (all-superclasses class) (all-subclasses class) (all-supersituations situation) (all-subslots slot) ====================================================================== |# (defconstant *all-facets* '(own-properties member-properties own-definition member-definition)) (defconstant *valid-cardinalities* '#$(1-to-N 1-to-1 N-to-1 N-to-N)) (defconstant *default-cardinality* '#$N-to-N) (defconstant *inequality-relations* '(< > <= >= /=)) ; for km-assert etc. (defconstant *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 ;;; ====================================================================== (defconstant *built-in-bag-aggregation-slots* '#$(min max sum average difference product quotient)) ; maps (:bag ...) -> value (defconstant *built-in-seq-aggregation-slots* nil) ; maps (:seq ...) -> value (defconstant *built-in-set-aggregation-slots* ; maps (:set ...) -> value '#$(first second third fourth fifth last unification set-unification append number)) (defconstant *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 (defconstant *slots-slots* '#$(domain range cardinality inverse inverse2 inverse3 inverse12 fluent-status inherit-with-overrides aggregation-function)) (defconstant *built-in-single-valued-slots* (append '#$(#|domain range|# cardinality aggregation-function #|complete|# ignore-inverses inverse inverse2 inverse3 remove-subsumers remove-subsumees inherit-with-overrides fluent-status seq-length bag-length prev-situation ; 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 abs log exp sqrt floor aggregation-function) *built-in-aggregation-slots*)) (defconstant *built-in-multivalued-slots* '#$(domain range #|M-new|# element-type superclasses subclasses instances instance-of add-list del-list pcs-list ncs-list supersituations subsituations subslots superslots slots-to-opportunistically-evaluate ; as views useful-views ; for view mechanism 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 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 constraints < > )) ; NEW 11/6/00 for numeric inequality constraints (defconstant *built-in-slots* (append *built-in-single-valued-slots* *built-in-multivalued-slots*)) ;;; ====================================================================== #| (defconstant *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* nil) ; let's try this for now... (defparameter *default-built-in-inertial-fluent-slots* (cond ((not *clones-are-global*) '#$(cloned-from)))) (defparameter *built-in-inertial-fluent-slots* *default-built-in-inertial-fluent-slots*) ;;; This can be over-ridden... ;;; cloned-from = new! (defconstant *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 ;(defconstant *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. (defconstant *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 superclasses subclasses instances instance-of supersituations members member-of cloned-from domain-of range-of remove-subsumers remove-subsumees subsituations subslots superslots id combine-values-by-appending dont-cache-values ignore-inverses fluent-status called uniquely-called block-projection-for prototypes prototypes-of prototype-participants prototype-participants-of assertions)) ;;; (every f has (s (v))), (every f has (s (v'))) -> (every f has (s (v v'))) NOT (every f has (s ((v) && (v')))) ;;; Also - all INVERSE assertions are automatically by appending; sigh and urgh! (defconstant *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). (defconstant *built-in-remove-subsumers-slots* '#$(instance-of superclasses member-type domain range)) ;;; 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). (defconstant *built-in-remove-subsumees-slots* '#$(subclasses prototype-of)) ; latter new (8/14/02) ;;; These better be complete! ;(defconstant *built-in-complete-slots* '#$(prev-situation next-situation) ;(defconstant *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 (defconstant *built-in-slots-with-constraints* '#$(instance-of == < > called uniquely-called)) (defconstant *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 Event)) ; Event is new! ;;; 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. (defconstant *built-in-superclass-links* '#$((Integer Number) (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. (defconstant *built-in-classes-with-no-built-in-superclasses* '#$(Aggregate)) (defconstant *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*) (defconstant *valid-fluent-statuses* '#$(*Fluent *Inertial-Fluent *Non-Fluent)) (defconstant *built-in-instances* (append *valid-cardinalities* *valid-fluent-statuses* `#$(t f ,*GLOBAL-SITUATION*))) (defconstant *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. (defconstant *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 #|duplicate-valued|# called uniquely-called arity block-projection-for remove-subsumers remove-subsumees combine-values-by-appending dont-cache-values ignore-inverses name == #|text print-name terms|#)) ;;; no! inverse2 inverse3 ;;; eg. DON'T record inverses for boolean T/F, eg. (T has (open-of (Box1)) (defconstant *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))) ;;; ====================================================================== (defconstant *val-constraint-keywords* '#$(must-be-a mustnt-be-a <> possible-values excluded-values constraint no-inheritance)) (defconstant *set-constraint-keywords* '#$(at-least at-most exactly set-constraint sometimes set-filter)) (defconstant *constraint-keywords* (append *val-constraint-keywords* *set-constraint-keywords*)) (defconstant *constraint-slots* '(== /== < >)) ;;; ====================================================================== ;;; Situations (defvar *curr-situation* *global-situation*) ;;; ====================================================================== (defvar *classification-enabled* t) (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)) (defun disable-classification () (km-setq '*classification-enabled* nil)) (defun 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)))) (defun disable-installing-inverses() (setq *installing-inverses-enabled* nil)) ;;; ====================================================================== ; (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 (( ) ( ) .... ) (defconstant *built-in-subslots* nil) ; if change this, the EDIT immediate-subslots, immediate-superslots too! (defconstant *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) ; (views as) ; (as views) (/== /==))) ; new 10/3/00 (defconstant *built-in-inverse2s* '#$( (next-situation after-situation) ; -> (after-situation next-situation) (prev-situation before-situation) ; -> (before-situation prev-situation))) ;;; ====================================================================== ;;; COREFERENTIALITY ;;; ====================================================================== #| Some frames are, in fact, typed variables. They are denoted by having a name which begins with "_", eg _person34 is a "variable frame" of type person. Variable frames can be bound to other frames. The unifier (km/lazy-unify.lisp) is the thing which does the unifying. |# ;;; bind: RESULT is irrelevant, only the side-effect is important. ;;; [1] Feb 2000 - check to prevent circular bindings (defun bind (frame1 frame2) (cond ((neq (dereference frame1) (dereference frame2)) ; [1] ; (setf (get frame1 'binding) frame2)))) ; (make-transaction `(bind ,frame1 ,frame2)) (km-setf frame1 'binding frame2) (merge-cached-explanations frame1 frame2) (merge-explanations frame1 frame2)))) (defun get-binding (frame) (get frame 'binding)) (defun bound (frame1) (get frame1 'binding)) ;;; ---------- #| (defun dereference (frame) (cond ((symbolp frame) (let ( (binding (get-binding frame)) ) (cond (binding (dereference binding)) (t frame)))) ((listp frame) ; [1] (mapcar #'dereference frame)) (t frame))) |# ;;; June 2001 - 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) (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-concepts)) (terpri) t) (defun unbind () (mapcar #'(lambda (frame) (bind frame nil)) (get-all-concepts)) 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))))))) ;;; ====================================================================== ;;; 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)) (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 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 list of slot-values!~%Slot+values ~a should be a of the form (slot (v1 ... vn))~%" slotsvals slotvals)) ((not (symbolp (slot-in slotvals))) (report-error 'user-error "Bad structure ~a for list of slot-values!~%Slot `~a' should be a symbol!~%" slotsvals (slot-in slotvals))) ((not (listp (second slotvals))) (report-error 'user-error "Bad structure ~a for list of slot-values!~%Values ~a for slot ~a should be a list!~%" slotsvals (second slotvals) (slot-in slotvals))) ((member (slot-in slotvals) *reserved-keywords*) (report-error 'user-error "Bad structure ~a for list of slot-values!~%The slot `~a' is a reserved KM keyword, and cannot be used as a slot name!~%" slotsvals (slot-in slotvals))) ((no-reserved-keywords (vals-in slotvals)) ; 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 'kb ). ;;; ====================================================================== #| 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 - install-all-subclasses 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 (install-all-subclasses) ;;; 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 (list (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) ; (cond ((eq slot '#$instance-of) (install-views instance (list val)))) ))) ((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. Jan 2001 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 (defun put-vals (instance slot vals &key (facet 'own-properties) (install-inversesp t) (situation (curr-situation))) ; (cond ((and (eq instance '#$*My-Box) ; (eq slot '#$contents)) ; (break))) (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)) ((eq slot '#$complete) ; temp error message for a while (report-error 'user-error "KM 1.4.0-beta36 and later: The `complete' slot has been renamed - you should change your KB as follows:~% `( has (complete (t)))' should be replaced with `( has (fluent-status (*Fluent)))'!")) (t (cond ((not (isa slot '#$Slot)) ; Do this *after* checking instance-of above! (add-val slot '#$instance-of '#$Slot t *global-situation*) ; install-inversesp = t (cond ((starts-with (symbol-name slot) "some-associated-") (add-val slot '#$fluent-status '#$*Non-Fluent t *global-situation*))))) ; RKF-specific addition (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))) ) (cond ((equal vals old-vals) vals) (t (let ( (putobj-facet (curr-situation-facet facet target-situation)) ) (cond ((not (known-frame instance)) (add-to-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 ((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)) ; (cond ((assoc '#$instance-of slotsvals) ; new - view mechanism ; (install-views frame (vals-in (assoc '#$instance-of 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)))) ;;; -------------------- (defun delete-slot (instance slot &optional (facet 'own-properties) (situation (curr-situation))) (put-vals instance slot nil :install-inversesp nil :facet facet :situation situation)) ;;; Not used by KM, but used by auxiliary s/w (defun delete-val (instance slot val &optional (uninstall-inversesp t) (situation (curr-situation))) (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)) (km-format t "Warning! Trying to delete non-existent value ~a on (the ~a of ~a)!~%" val slot instance)) ((single-valued-slotp slot) (put-vals instance slot (vals-to-&-expr (remove val oldvals)) :install-inversesp nil :situation situation) ; uninstall-inversesp would be ineffective here, as we've a STRUCTURE (cond (uninstall-inversesp (uninstall-inverses instance slot (list val) situation))) ; NOW do it manually for the new val (un-done instance :situation situation)) ; 1.4.0-beta8: Don't forget this! Important!! (t (put-vals instance slot (remove val oldvals) :install-inversesp nil :situation situation) (cond (uninstall-inversesp (uninstall-inverses instance slot (list val) situation))))))) ; NOW do it manually for new val ;;; ---------------------------------------------------------------------- ;;; 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) ((universalp slot) *global-situation*) ; NB fluent -> non-universal, by definition ((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 symbol!~%" slot frame slot)) (t (report-error 'user-error "Doing (the ~a of ~a) - the frame name `~a' should be a symbol!~%" slot frame frame)))) ;;; ---------- ; (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: ( ...) ; exprs to evaluate in situation ( ...) ; 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)) (let* ( (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 ((inherit-with-overrides-slotp slot) (decomment (bind-self (inherited-rule-sets-with-overrides slot (immediate-classes instance) (append all-situations visible-theories)) instance) :retain-commentsp retain-commentsp)) (t (decomment (bind-self (inherited-rule-sets2 slot (all-classes instance) (append all-situations visible-theories)) instance) :retain-commentsp retain-commentsp))))) ;;; ---------- STOP after you've found something ;;; Slots are declared to use this by setting their "inherit-with-overrides" property to t ;;; REVISED 8.16.00: ;;; With multiple inheritance, climb up all the branches stopping at the point(s) where you hit a rule. ;;; REVISED 12.11.00: ;;; Don't bother also ascending situation hierarchy, instead use all situations immediately ;;; RETURNS: A list of rule sets (defun inherited-rule-sets-with-overrides (slot classes all-situations) (remove-duplicates (remove nil (mapcan #'(lambda (class) (inherited-rule-sets-with-overrides2 slot class all-situations)) classes)) :test #'equal)) ;;; RETURNS: A list of rule sets. Is MAPCAN-SAFE (defun inherited-rule-sets-with-overrides2 (slot class all-situations) (cond ((inherited-rule-sets2 slot (list class) all-situations)) ; found something! So stop along this (upward) branch. ((neq class '#$Thing) (inherited-rule-sets-with-overrides slot (immediate-superclasses class) all-situations)))) ;;; ---------- ;;; Find all the rule sets on all the classes in all the situations ;;; Is MAPCAN SAFE ;;; RETURNS: A list of rule-sets (defun inherited-rule-sets2 (slot classes situations) (remove-duplicates (remove nil ; tidy up answer... (mapcan #'(lambda (situation) (mapcan #'(lambda (class) (get-rule-sets-in-situation class slot situation)) classes)) situations)) ; (includes situation) :test #'equal :from-end t)) #| (Essentially a synonym for get-vals) IS MAPCAN-SAFE [due to &&-exprs-to-valsets, and &-expr-to-vals] [1] Jan 2001 - 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] (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] (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)) ) (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. ;;; 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, as of May 2001, find-constraints-in-exprs ALWAYS does a decomment anyway! (defun collect-constraints-on-instance (instance slot &key (situation (curr-situation)) retain-commentsp) (cond ((and *are-some-constraints* ; optimization flag (or (member slot *built-in-slots-with-constraints*) (not (member slot *built-in-slots*)))) (let* ( (inherited-sets (inherited-rule-sets instance slot :situation situation :retain-commentsp t)) ; 2D search up classes and sitns [1] (inherited-constraints (mapcan #'find-constraints-in-exprs inherited-sets)) ; from classes. NB *WILL* remove comments (own-constraints (mapcan #'find-constraints-in-exprs ; from instance in curr-situation + its supersituations (own-rule-sets instance slot :situation situation))) ) (decomment (remove-duplicates (append inherited-constraints own-constraints) :test #'equal) :retain-commentsp retain-commentsp))))) ;;; 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) (let* ( (all-situations (cond ((and (neq situation *global-situation*) (fluentp slot)) (cons situation (all-supersituations situation))) (t (list *global-situation*)))) (all-classes (my-mapcan #'all-superclasses0 classes)) ; [1] (visible-theories (visible-theories)) ) (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 (cond ((eq facet 'own-definition) 'defined-instances) (t 'defined-subclasses))) ) (cond ((null parents) (report-error 'user-error "~a: Definition for ~a must include an `instance-of' slot, declaring the most general superclass of ~a. Continuing, but ignoring definition...~%" frame frame frame)) (t (mapcar #'(lambda (parent) (let ( (children (get parent defined-children-facet)) ) (cond ((eq facet 'member-definition) ; Prologue: add the implied taxonomic link (km0 `(,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 (cons frame children)) )))) parents))))) ;;; ====================================================================== ;;; Adding (not replacing) new values to the originals... ;;; ====================================================================== ;;; [1] Factor out 'Self' at load-time for own properties. ;;; [2] Now compute-new-vals might return (old && new), we need to do install-inverses explicitly on new. ;;; RETURNS: irrelevant. ;;; [3] Extra condition: (greater-than has (instance-of (Relation)) (inverse (less-than))) ;;; *don't* install (less-than has (instance-of (Slot))), which will happen otherwise ;;; [4] Would use (not (non-inverse-recording-slot )), 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 (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)) (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) (list (vals-to-&-expr add-vals))) (t add-vals))) ((eq combine-values-by 'overwriting) (cond ((eq facet 'own-properties) (uninstall-inverses instance slot (set-difference old-vals add-vals) situation0))) (cond ((single-valued-slotp slot) (list (vals-to-&-expr add-vals))) (t add-vals))) (t (compute-new-vals slot old-vals add-vals :combine-values-by combine-values-by)))) ) (cond ((or new-vals (eq combine-values-by 'overwriting)) ; 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 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))) (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 ...) (add-vals (invert-slot instance) '#$instance-of (or (vals-in (assoc '#$instance-of add-slotsvals)) '#$(Slot)) ; I don't think this is justified! :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) (list (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 (list (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 &optional slotsvals0 (prefix-string (cond ((am-in-prototype-mode) *proto-marker-string*) (t *var-marker-string*))) (bind-selfp t)) (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)) ;;; 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))) (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! (defun create-named-instance (newframe parent &optional slotsvals0 (bind-selfp t)) (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] (slotsvals1 (update-assoc-list slotsvals0 (list '#$instance-of (remove-subsumers (cons parent extra-classes))))) (slotsvals (cond (bind-selfp (bind-self slotsvals1 newframe)) (t slotsvals1))) ) ; (cond ((is-subclass-of parent '#$Situation) ; all situation assertions are done in Global context [3] ; (add-slotsvals newframe slotsvals &key needed here now...'own-properties t *global-situation*)) ; [3] ; (t (add-slotsvals newframe slotsvals))) ; [2] ;; Neah, what about (*Temporal-Theory has (instance-of (Theory))) - how make this default visible? ; (cond ((is-subclass-of parent '#$Theory) ; by default, theories are all visible ; (setq *visible-theories* (cons newframe *visible-theories*)))) ; No, this is dumb!!! 9/8/00 ; (cond ((and (neq (curr-situation) *global-situation*) ; (some #'(lambda (class) (is-subclass-of class '#$Event)) ; (cons parent extra-classes))) ; (add-slotsvals newframe slotsvals &key needed here now... 'own-properties t *global-situation*)) ; (t (add-slotsvals newframe slotsvals))) ; [2] (add-slotsvals newframe slotsvals :bind-selfp bind-selfp) ; allow Self to preserved in exceptional circumstances (prototype-scope) ; (install-views newframe) ; check for inherited views also (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 (slots-that-changed (classify newframe :slots-that-changed slots-that-changed)))) ; neah, want (a Texan) to be classified (classify newframe :slots-that-changed slots-that-changed)) ; with *indirect-classification* on. [1] below (mapc #'(lambda (slot) (km-trace 'comment "New instance ~a: evaluating slot ~a opportunistically..." newframe slot) (km0 `#$(the ,SLOT of ,NEWFRAME))) (slots-to-opportunistically-evaluate newframe)) newframe)))) ;;; [1] above: NOTE If *indirect-classification* is NIL, and there's a plain instance (a ), then slots-that-changed will be NIL, and ;;; hence classification won't happen anyway. ;;; ====================================================================== ;;; NEW - keep a local copy of the gensym counter, rather than use the Lisp internal counter, ;;; to allow us to reset it (eg. after an "undo" operation) (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 (km0 `#$(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) (km0 situated-assertion :fail-mode 'error))))) assertions))))) ;;; ====================================================================== ;;; THE DONE LIST ;;; The purpose of this list is to prevent recomputation of cached values. ;;; Here KM records which slot-values have been computed. If KM subsequently ;;; need those slot-values, it just does a lookup rather than a recomputation. ;;; note-done and reset-done are called by interpreter.lisp. ;;; Aug 98: We have to note "done in a situation", note just "done". Just ;;; because KM knows X's age in Sitn1, doesn't mean it knows it in Sitn2! ;;; ====================================================================== (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 (Apr 2003) 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 (curr-situation))) ; (km-format t "note-done: situation = ~a, curr-situation = ~a~%" situation (curr-situation)) (cond ((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 (curr-situation))) (and (kb-objectp frame) (member (list slot situation) (get frame 'done) :test #'equal))) ;;; ---------- #| There's a subtle special case here. Fluent instances are NOT projected, so if we have (*MyCar owner _SomePerson3) in S0, then ask for (*MyCar owner) in S1, we get NIL, and then (*MyCar owner) is flagged as DONE in S1. Fine so far. But suppose later _SomePerson3 becomes a non-fluent instance, by doing (_SomePerson3 & *Pete) - now it SHOULD be projected to S1, which would require removing the DONE flag on (*MyCar owner) in S1. But of course this unification will not remove the DONE flag on all the things which are in some relationship to _SomePerson3. We can probably make it do that though with a (very) special purpose line of code in lazy-unify.lisp! |# (defun un-done (frame &key slot situation) ; (cond ((eq frame '#$_Default-Combat-Power-Value1721) ; (cond ((eq frame '#$*Victor) ; (km-format t "~%(un-done ~a ~a ~a)~%~%" frame 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)))))) #| Global un-done (defun un-done (frame &key slot situation) (declare (ignore situation)) (cond (slot (let ( (done-so-far (get frame 'done)) ) (setf (get frame 'done) (remove-if #'(lambda (pair) (eq (first pair) slot)) done-so-far)))) (t (remprop frame 'done)))) |# ;;; ---------- ;;; (defun reset-done () (mapc #'un-done *done*) (setq *done* nil) t) ;(defun reset-done () (mapc #'un-done (get-all-concepts)) t) ; More efficient (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) *are-some-definitions* (or (am-in-global-situation) *classify-in-local-situations*) (or *recursive-classification* (not *am-classifying*))) (let ( (was-classifying *am-classifying*) ) (setq *am-classifying* t) (cond ((and (tracep) (not (traceclassifyp))) (suspend-trace) (classify0 instance :slots-that-changed slots-that-changed :slot-of-interest slot-of-interest) (unsuspend-trace)) (t (classify0 instance :slots-that-changed slots-that-changed :slot-of-interest slot-of-interest))) (setq *am-classifying* was-classifying))))) (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))))))) ;;; ---------------------------------------------------------------------- ;;; (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. (defun classify-as-member (instance parent &key slots-that-changed slot-of-interest) (some #'(lambda (possible-new-parent) (cond ((and (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) (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))) ;;; 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 ((km0 `#$(,INSTANCE &? (a Thing with . ,(FIND-SLOTSVALS POSSIBLE-NEW-PARENT 'MEMBER-PROPERTIES)))) ; new test [1] (cond ((km0 `#$(,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) ;;; Dec 2002: 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? ;;; Dec 2002: Returns *two* values (i) a satisfied flag (ii) the definition that was satisfied (for explanatory purposes) (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)) (satisfiedp (km0 `#$(,INSTANCE is ,DESCRIPTION))) ) (cond (*developer-mode* (km-format t "#"))) (cond (satisfiedp (km-trace 'comment "CLASSIFY: ~a *is* a ~a!" instance class)) (t (km-trace 'comment "CLASSIFY: ~a is not a ~a." instance class))) (values satisfiedp `#$(every ,CLASS has-definition ,@DEFINITIONAL-SLOTSVALS))))))) ;;; ---------------------------------------------------------------------- ;;; (II) CLASSIFY INSTANCE AS BEING COREFERENTIAL WITH ANOTHER INSTANCE ;;; ---------------------------------------------------------------------- #| This is for equating coreferential instances, eg. bright-color IS red (Red has (definition (((Self isa Color) and ((Self is) = Bright))))) (a Color with (is (Bright))) -> _Color32 unifies with Red -> Red BUT: Suppose an instance satisfies *two* different instances' definitions? In fact, KM will prevent you doing this. The first classification will cause _Color34 to be unified to Red. The second will classify Red as Another-red, but the unification of these two isn't permitted. |# (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 (eq 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 ((km0 `(,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 (km0 `#$(,INSTANCE is ,DESCRIPTION))) ) (cond (*developer-mode* (km-format t "#"))) (cond (satisfiedp (km-trace 'comment "CLASSIFY: ~a = ~a!" instance poss-coref-instance)) (t (km-trace 'comment "CLASSIFY: ~a \= ~a." instance poss-coref-instance))) satisfiedp))))) ;;; ====================================================================== ;;; TAXONOMIC OPERATIONS ;;; ====================================================================== ;;; check frame isa genframe. Returns frame. ;;; (isa x x) returns nil (defun isa (instance class &optional (situation (curr-situation))) (instance-of instance class situation)) ; synonym (defun instance-of (instance target-class &optional (situation (curr-situation))) (let ( (its-classes (immediate-classes instance :situation situation)) ) (cond ((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)))) (defun is-subclass-of (class target-class) (cond ((eq class target-class) class) ((eq class '#$Thing) nil) ((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)) 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 (ignore enforce-constraints)) (cond ((integerp instance) '(#$Integer)) ((numberp instance) '(#$Number)) ((assoc instance *built-in-instance-of-links*) ; e.g. t -> Boolean (list (second (assoc instance *built-in-instance-of-links*)))) ; ((eq instance '#$*Global) '(#$Situation)) ((member instance *built-in-set-aggregation-slots*) '#$(Set-Aggregation-Slot)) ((member instance *built-in-seq-aggregation-slots*) '#$(Seq-Aggregation-Slot)) ((member instance *built-in-bag-aggregation-slots*) '#$(Bag-Aggregation-Slot)) ((member instance *built-in-slots*) '#$(Slot)) ((class-descriptionp instance) '#$(Class)) ((quoted-expressionp instance) '#$(Quoted-Expression)) ((stringp instance) '(#$String)) ((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 (km0 (vals-to-val vals0)))) ) (put-vals instance '#$instance-of (append vals1 constraints)) (note-done instance '#$instance-of) vals1)))) ) (cond ; (nil ; NEW!!!!!! May 2001 - 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))) )) ((already-done instance '#$instance-of situation) (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) (note-done instance '#$instance-of situation))))) ;;; 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)) ) (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))) ((class-descriptionp class) (list (first (class-descriptionp class)))) ; (the-class Remove with ...) -> (Remove) ((let ( (superclasses (get-vals class '#$superclasses :situation *global-situation*)) ) (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)))) ;;; ---------- (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 :situation *global-situation*) ; [1] (get-vals concept '#$superclasses :situation *global-situation*) ; [1] ; too slow!!!!! (some #'(lambda (situation) ; (get-vals concept '#$instances :situation situation)) ; [2] ; all-situations-and-theories) (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-unique0, as may be a path there (unlikely!, did in previous test suites though) ;;; [3] Don't consider it an error to be missing a :args structure, so we can say (Y1999 has (next-situation (Y2000))) for short. (defun prev-situation (situation) ; (let ( (prev-situation-args-structure ; (get-vals situation '#$prev-situation :situation *global-situation*)) ) ; eg ((:args _Sit23 _Action23)) [1] (let ( (prev-situation-args-structure (km-unique0 (get-unique-val situation '#$prev-situation :situation *global-situation* ) ; eg ((:args _Sit23 _Action23)) [2] )) ) ; [3] (cond ((km-argsp prev-situation-args-structure) (arg1of prev-situation-args-structure)) (t prev-situation-args-structure)))) |# ;;; [1] Misses inheritance! Probably not important, but better cover that case -> [2] ;;; [2] km-unique0, as may be a path there (unlikely!, did in previous test suites though) ;;; [3] Don't consider it an error to be missing a :args structure, so we can say (Y1999 has (next-situation (Y2000))) for short. ;;; RETURNS: NIL if no prev situation, the atomic prev situation otherwise (defun prev-situation (situation) (let ( (prev-situation-args-structures (get-vals situation '#$prev-situation :situation *global-situation*)) ) ; eg ((:args _Sit23 _Action23)) [1] ; (let ( (prev-situation-args-structure ; (km-unique0 (find-unique-val situation '#$prev-situation :situation *global-situation*) ; eg ((:args _Sit23 _Action23)) [2] ; )) ) ; [3] (cond ((null prev-situation-args-structures) nil) ((singletonp prev-situation-args-structures) (let ( (prev-situation-args-structure (km-unique0 (first prev-situation-args-structures))) ) (cond ((not (equal prev-situation-args-structure (first prev-situation-args-structures))) (put-vals situation '#$prev-situation (list prev-situation-args-structure) :situation *global-situation*) (note-done situation '#$prev-situation *global-situation*))) (cond ((km-argsp prev-situation-args-structure) ; (km-format t "prev-situation-args-structures = ~a~%" prev-situation-args-structures) (arg1of prev-situation-args-structure)) (t prev-situation-args-structure)))) (t (report-error 'user-error "Situation ~a has multiple previous situations, but that isn't allowed!~% (~a has (prev-situation ~a))~%" situation situation prev-situation-args-structures))))) ;; NB plural ;;; Result is MAPCAN-SAFE (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))) ;;; INCLUDES situation (defun all-next-situations (situation) (cond ((null situation) nil) (t (cons situation (mapcan #'all-next-situations (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-unique0 (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-unique0 (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*) (note-done event '#$before-situation *global-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 ) -- 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) (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) (is-subclass-of class other-class))) classes)) classes) :from-end t)) ;;; (classes-subsume-classes '(vehicle expensive-thing) '(car very-expensive-thing)) ;;; AND ;;; (classes-subsume-classes '(vehicle expensive-thing) '(car very-expensive-thing wheeled-thing)) ;;; case [1] should never be necessary, but just in case... ;(defun classes-subsume-classes (classes1 classes2) ; (let ( (trimmed-classes2 (remove-subsumers classes2)) ) ; [1] eg. (car thing) -> (car) ; (subsetp trimmed-classes2 (remove-subsumers (append classes1 trimmed-classes2))))) ;;; Or more efficiently...every class1 has some class2 which is a subclass of it. (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) (cond ((eq class '#$Thing) nil) ; for efficiency. #$Thing is added by all-superclasses above (t (cons class (my-mapcan #'all-superclasses0 (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) (cons class (mapcan #'all-subclasses0 (immediate-subclasses class)))) |# (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 (dereference (my-mapcan #'immediate-instances (cons class (all-subclasses class)))))) ;;; [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) (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 (km0 `#$(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*)))) ; old ; (t (or (get-vals situation '#$supersituations :situation *global-situation*) ; (get-vals situation '#$supersituations :situation (curr-situation)) ; (list *global-situation*))))) ;;; ====================================================================== ;;; SLOTS: Cardinalities ;;; ====================================================================== ;(defconstant *default-default-fluent-status* '#$*Inertial-Fluent) ; this is the reset value after a (reset-kb) (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) (get-vals slot '#$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 operation: (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))) ) (put-vals val invslot new-vals :install-inversesp nil :situation situation)))))) ; install-inversesp = nil 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)) (n 0)) (cond ((null instances) nil) ((>= n 100) (report-error 'user-error "eval-instances in frame-io.lisp!~%Recursion is causing an infinite graph to be generated! Giving up...~%")) (t (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) (1+ n)))))) ; process newly created instances ; (t (let ( (expansion-done? (remove nil (mapcar #'simple-eval-instance instances))) ) ; (cond (expansion-done? (eval-instances (obj-stack) (1+ n)))))))) (defun eval-constraints (instance) (mapc #'(lambda (slotvals) (let ( (new-vals (mapcar #'(lambda (val) (cond ((and (pairp val) (eq (first val) '<>)) (list '<> (km-unique0 (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] (km0 `#$(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 (install-all-subclasses) 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 "Removing all old subclasses...~%") (mapc #'remove-subclasses (cons '#$Thing (get-all-concepts))) ; [1] ; (format t "Removing redundancies in superclass links...~%") (mapc #'remove-redundant-superclasses (get-all-concepts)) ; [2] ; (format t "Recomputing and adding subclasses...~%") ; (mapc #'install-subclasses (get-all-concepts)) t) (mapc #'(lambda (val) (add-val '#$Thing '#$subclasses val)) (subclasses-of-thing)) ; [3] t) (defun remove-subclasses (class) (cond ((not (anonymous-instancep class)) ; ignore anonymous things (delete-slot class '#$subclasses)))) #| ;;; [1] IF something is an instance-of something, AND it has no superclasses, THEN we ignore it (defun install-subclasses (class) (cond ((kb-objectp class) (let* ( (superclasses (immediate-superclasses class)) (actual-superclasses (cond ((and (equal superclasses '#$(Thing)) (find-vals class '#$instance-of)) nil) ; [1] (t superclasses))) ) (mapc #'(lambda (genclass) (add-val genclass '#$subclasses class nil)) ; NEW: install-inversesp = nil for efficiency actual-superclasses))))) |# ;;; Remove redundant superclasses -- and add subclass links in for all classes except Thing: ;;; [1] don't install subclass links here, as we do that in the next stage anyway! ;;; We could do the subclass links here instead, if we could force put-vals to *always* set the ;;; vals (Currently, it only sets vals if the new vals /= old vals). (defun remove-redundant-superclasses (class) (let* ( (superclasses (get-vals class '#$superclasses :situation *global-situation* :dereferencep nil)) (minimal-superclasses (or (remove-subsumers superclasses) (rest (assoc class *built-in-superclass-links*)))) ) ; eg. Integer -> (Number) (cond ((not (equal superclasses minimal-superclasses)) (put-vals class '#$superclasses minimal-superclasses :install-inversesp nil))) ; [1] (mapc #'(lambda (superclass) (add-val superclass '#$subclasses class nil *global-situation*)) ; install-inversesp = nil minimal-superclasses))) ;;; ====================================================================== ;;; 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))) (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-unique0 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 (km0 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 (km0 km-expr) (change-to-situation curr-situation) (km-trace 'comment "Exiting ~a ~a, and returning to ~a." situation-class situation curr-situation) (km-trace 'comment ""))))))) (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)) ;;; next-situation will create a new situation which is at the next-situation relation ;;; to the situation given. ;;; NOTE: if the future-pointing-slot is single-valued, then next-situation will ;;; first try and FIND the next-situation rather than create a new one (which will ;;; necessarily need to be unified in). ;;; action is an INSTANCE (it better be!) ;;; RETURNS: The next situation (defun next-situation (action) ; &optional (future-pointing-slot '#$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 (make-new-situation)) ) (cond ((null action) (km-unique0 `#$(,NEW-SITUATION has (instance-of (Situation)) (prev-situation ((:args ,CURR-SITUATION ,ACTION)))) :fail-mode 'error)) ; inverse auto-installed (t (km-unique0 `#$(,NEW-SITUATION 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-unique0 `#$(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 (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! ;;; Jan 2001: No, we must evaluate del-list AFTER the pcs-list have been asserted! Suppose the del-list says (forall (:triple ...)) ;;; and the pcs-list asserts the existence of an , we better make sure the pcs-list are evaluated first! ;;; [4] Mar 2001: ;;; 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 change-to-next-situation (test-or-assert-pcs 'assert)) (temporarily-disable-classification) ; [5] (prog1 (do-action0 action-expr :change-to-next-situation change-to-next-situation :test-or-assert-pcs test-or-assert-pcs) (remove-temporary-disablement-of-classification))) (defun do-action0 (action-expr &key change-to-next-situation (test-or-assert-pcs 'assert)) (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-unique0 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)) (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 ), , are evaluated, and ; is evaluated UNLESS = 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) (km0 frame)) (t (km0 `#$(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 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-situation (next-situation action)) #|Now it's okay to have them here, see [4]|# #|tmp|# (add-list (find-propositions action '#$add-list)) #|tmp|# (del-list (find-propositions action '#$del-list)) #|tmp|# #|[3]|# (evaluated-add-list (mapcar #'evaluate-triple add-list)) #|tmp|# (evaluated-del-list (mapcar #'evaluate-triple del-list)) (add-blk-list (block-list evaluated-add-list)) ) (cond ((or del-list add-blk-list add-list) (km-trace 'comment "Now asserting effects of ~a in the new situation (~a)..." action next-situation))) (in-situation next-situation) (mapc #'(lambda (del-item) (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 , in the ;;; two special cases when = 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-unique0 (arg1of triple) :fail-mode 'error) ,(km-unique0 (arg2of triple) :fail-mode 'error) ,(vals-to-val (km0 (arg3of triple))))) (t triple))) ;;; ---------------------------------------- #| [1] KM1.4.0-beta17: If slot is single-valued, and (F S OldV) in prev-situation, and (F S V) in new situation, then we must also add (OldV InvS (<> F)) otherwise (OldV InvS F) will be projected. ADD LIST: (F S OldV) = (*TrojanHorse location _Place125) [later Place125 to be unified with *outside] (F S V) = (*TrojanHorse location *inside) location is single-valued. So need to add: (_Place125 location-of (<> *TrojanHorse)) in the NEW situation. Fine. But why do this for PCS also?????? |# (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 (km0 `#$(the ,SLOT of ,FRAME)))))))))) add-list))) ;;; -------------------- ;;; PCS-LIST and NCS-LIST are assumed SEMI-EVALUATED, ie. and 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 inconsistent-pcs))) (cond (inconsistent-ncs (km-format t "(do ~a): Can't do this action as it would be inconsistent to assert negated precondition(s):~%~{ ~a~%~}" action inconsistent-ncs))) (and (null inconsistent-pcs) (null inconsistent-ncs)))) ; condition for success (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-unique0 (second x+y) :fail-mode 'error)) ) (km0 `#$(,Y &? (a Thing with (,X ((constraint (not (TheValue ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION)))))))) ))) (t (km0 `#$(not (,FRAME ,(INVERT-INEQUALITY-RELATION SLOT) ,(FOURTH PROPOSITION))) )))) ; just test it. (t (km0 `#$(,FRAME &? (a Thing with (,SLOT ,VALUES))))))) ; inverses installed automatically. (#$(ncs-list del-list) (every #'(lambda (value) (and ; (neq value '*) (km0 `#$(,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))) (km0 `#$(,VALUE &? (a Thing with (,INV-SLOT ((<> ,FRAME))))))) (t)))) (km0 (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) (km0 `#$(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) (km0 (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). MAY 2001: 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-unique0 (second x+y) :fail-mode 'error)) ) (km0 `#$(,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 (km0 `#$(,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) (km0 `#$(,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))) (km0 `#$(,VALUE also-has (,INV-SLOT ((<> ,FRAME)))) :fail-mode 'error)))) values)) ; (km0 (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 ), , are evaluated, and ;;; is evaluated UNLESS = 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))) (km0 `#$(the ,SLOT of ,ACTION))))) #| (defun convert-to-triple (triple) (cond ((km-triplep triple) triple) ((isa triple '#$Triple) (list '#$:triple (km-unique0 `#$(the frame of ,TRIPLE) :fail-mode 'error) (km-unique0 `#$(the slot of ,TRIPLE) :fail-mode 'error) (vals-to-val (km0 `#$(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 (New, Dec 2000) ;;; ====================================================================== ;;; 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 (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 (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! (defun delete-frame (frame) (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)) (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) (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) ;;; FILE: trace.lisp ;;; File: trace.lisp ;;; Author: Peter Clark ;;; Date: Separated out Apr 1999 ;;; Purpose: Debugging facilities for KM ;;; ====================================================================== ;;; FOR TRACING EXECUTION ;;; ====================================================================== (defvar *trace* nil) (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) ;(defvar *depth* 0) ; move earlier, to header.lisp (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) (defun km-trace (mode string &rest args) ; (km-format t "Current situation = ~a~%" (curr-situation)) ; BELOW: Don't allow this unless we also twin it with a km-pop elsewhere! ; (cond ((eq mode 'comment) ; (km-push-comment `(comment ,string ,@args)))) ; extra info for debugging (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-km-stack) nil) (*trace* (km-trace2 mode string args))) (cond ((or (eq mode 'exit)(eq mode 'fail)) (decrement-trace-depth))))) (defun km-trace2 (mode string args) ; (format t "~vT" *depth*) ; Bug in Harlequin lisp causes this not to tab properly! (format t "~a" *depth*) (format t (spaces (- (1+ *depth*) (length (princ-to-string *depth*))))) (cond ((eq mode 'comment) (format t " "))) ; extra space tabulation for comments (case mode ((call redo comment) (apply #'km-format `(t ,string . ,(desource0 args)))) ; ie. (km-format t string arg1 ... argn) ((exit fail) (format t (truncate-string (apply #'km-format `(nil ,string . ,(desource0 args))) 80))) ; TRUNCATE these particular strings, and add "" (t (report-error 'program-error "km-trace2: Unknown trace mode ~a!~%" mode))) (cond ((and *interactive-trace* (neq mode 'comment)) (finish-output) ; flush output if stream is buffered (let ( (debug-option (read-line t 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)) ((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)) (t 'redo))) ((string= debug-option "n") (setq *trace* nil) (setq *suspended-trace* nil)) ((string= debug-option "f") 'fail) ((string= debug-option "g") (show-km-stack) (km-trace2 mode string args)) ((string= debug-option "w") (let* ( (last-expr (stacked-expr (first *km-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~%~}" (desource0 expr) paths)) (t (km-format t "~%(I don't know where expression ~a originated from)~%" expr))))) exprs)) (terpri) (km-trace2 mode string args)) ((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)) ((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)) ((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)) ; 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)) ((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)) ((string= debug-option "+U") (format t "(Will now show a more detailed trace during unification)~%") (setq *trace-unify* t) (km-trace2 mode string args)) ((string= debug-option "-U") (format t "(Will no longer show a detailed trace during unification)~%") (setq *trace-unify* nil) (km-trace2 mode string args)) ((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)) ((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)) ((string= debug-option "+X") (format t "(Will now show more detailed trace during classification)~%") (setq *trace-classify* t) (km-trace2 mode string args)) ((string= debug-option "-X") (format t "(Will no longer show a detailed trace during classification)~%") (setq *trace-classify* nil) (km-trace2 mode string args)) ((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)) ((and (string/= debug-option "") (string/= debug-option "c")) (print-trace-options) (km-trace2 mode string args))))) (t (format t "~%")))) (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: 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: ,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 display - display (showme) frame 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: ,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) (unsuspend-trace))) (t )) This is not! (prog2 (suspend-trace) (unsuspend-trace)) because the (unsuspend-trace) will restart the trace, even if the trace was already off ie. (suspend-trace) had no effect. NOTE!! 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 ")~%") ,@(desource0 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 ;;; ====================================================================== #| Behaviors on error: *error-report-silent* - ignore the error and continue. Overrides abort-on-error-report *abort-on-error-report* - report error and abort (NEW: now throwing the error message back too) otherwise - report error and switch on debugger at next opportunity |# ;;; For Jihie - to surpress error reporting (defvar *error-report-silent* nil) ; **** another NEW LINE (defvar *abort-on-error-report* nil) ; (throw 'km-abort ...) ;;; RETURNS NIL, like format (defun report-error (error-type string &rest args) (unless *error-report-silent* ; **** another NEW LINE (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)))) (error-str (concat error-str-prefix (apply #'km-format `(nil ,string ,@(desource0 args))))) ) (format t error-str) (cond ((member error-type '(user-warning nodebugger-error)) nil) ; no action ((or *abort-on-error-report* (eq error-type 'abort-error)) (km-format t "Throwing error...~a~%" error-str) (throw 'km-abort (list 'km-abort error-str))) ((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 (*developer-mode* (break))) 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) (make-sentence (km0 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 (eq (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 "~%"))) (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 "~%"))) t) (defun show-explanation (explanation depth mode comment-tags &key format (stream t)) (declare (ignore comment-tags)) (let ( (sentence (make-sentence (km explanation))) (nl (cond (stream *newline-string*) (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 "~a" nl) depth (string-downcase mode) sentence)) (html (case mode (call (format stream (concat "
  • ~a" nl) sentence)) (exit (format stream (concat "
  • ~a
" 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 "")))) (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 "")))))) ;;; 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 *backtrack-after-testing-unification* nil) #| MAIN ENTRY POINTS ================= LAZY-UNIFY-&-EXPR -> lazy-unify-exprs -> lazy-unify: Use for &, && TRY-LAZY-UNIFY: Use for &? Note there is no &&? operator any more. Also note lazy-unify is *NOT* a main entry point. LAZY-UNIFY always takes ATOMIC atoms, not (:triple ...) etc. TRY-LAZY-UNIFY2: Is a susidiary of TRY-LAZY-UNIFY and LAZY-UNIFY. Returns binding information, which is discarded by try-lazy-unify but used by lazy-unify. (lazy-unify '_Person1 '_Professor1) Returns NIL if they won't unify. Does a quick check on slot-val compatibility, so that IF there's a single-valued slot AND there's a value on each instance AND those values are atomic AND they are unifiable THEN the unification fails. In addition, we add a classes-subsumep mode: If it's T (used for &&) then the classes of one instance must *subsume* the classes of another. Thus cat & dog won't unify. If it's NIL (used for &) then the classes are assumed mergable, eg. pet & fish will unify to (superclasses (pet fish)). eagerlyp: if true, then do eager rather than lazy unification, ie. don't leave any & or && residues on frames, just atomic values. |# (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) (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) (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)) (null (get-slotsvals unified-name)) (subsetp (second sitn+svs) (get-slotsvals unified-name :situation (prev-situation (curr-situation))) :test #'equal)))) (t ; (km-format t "unified-name = ~a~%" unified-name) ; (km-format t "(second sitn+svs) = ~a~%" (second sitn+svs)) ; (km-format t "(get-slotvals ~a) = ~a~%" unified-name (get-slotsvals unified-name)) ; (km-format t "(get-slotvals ~a 'own-properties ~a) = ~a~%" unified-name ; (get-slotsvals unified-name :situation (prev-situation (curr-situation))) ; (prev-situation (curr-situation))) (setq change-made t))) ; (cond ((and (not change-made) ; (not (equal (second sitn+svs) (get-slotsvals unified-name)))) ; (km-format t "unified-name = ~a~%" unified-name) ; (km-format t "(second sitn+svs) = ~a~%" (second sitn+svs)) ; (km-format t "(get-slotvals ~a) = ~a~%" unified-name (get-slotsvals unified-name)) ; (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-active-situations)) ; (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 ((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-active-situations)) 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) (t (cons sitn-svs-pair sitn-svs-pairs)))))))))) ;;; [1] This is critical, as lazy-unify-slotsvals drags in constraints from whatever the current situation is! ;;; [2] change-to-situation doesn't make-comments. ;;; [3] There must be *some* data on both objects. Note, we still check slot values if only ONE instance has values providing the OTHER ;;; instance has at least some slot-values somewhere (including other slots). (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 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)))) (t (list situation (or slotsvals1 slotsvals2)))) )) ;;; ---------------------------------------- ;;; Returns (i) unified value (ii) extra binding list elements ;;; In the case of two anonymous instances A and B, then B points to A, ie. get B->A, ;;; not A->B. Three items of code depend on this ordering: ;;; 1. (load-kb ...), so that a statement like (_X2 == _X1) binds _X1 ;;; to point to _X2, and not vice-versa. (The writer prints the master ;;; object first, then the bound synonym second). ;;; Apr 01: Redundant now, the writer does dereferencing and no "==" writing. ;;; 2. [overall-expr-for-slot, global-expr-for-slot, and local-expr-for-slot] now called ;;; inherited-rule-sets, local-rule-sets, ;;; in frame-io.lisp assumes this binding order (see that ;;; file for notes), putting *Global instances before situation-specific ;;; ones. ;;; 3. get-unified-all puts local instances before inherited expressions, ;;; so that the local instance names persist. ;;; [1] I don't know why, but I enforced the classes-subsumep constraint *always* for ;;; non-kb-objects. This means (100 & (a Coordinate)) fails, which I don't think it should. ;;; Apr 03: Relax this. The anonymous instance must either be blank, or have only an acceptable class definition (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 (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) (not (set-equal immediate-classes1 immediate-classes2)))))) ;;; Check /== constraints ;;; [1] :test #'equal, to allow for "cat" and _Animal-Name1 where (_Animal-Name1 (/== ("cat"))) ;;; [2] IF there is some equality constraints, AND the check-slotvals-constraints FAILS for them, ;;; THEN the instances are incompatible ;;; [3] I guess I'm assuming people will assert inequalities via KM> (x /== y), rather than such ;;; statements being put on frames themselves. But really, we should do (km0 `#$(the /== of ,INSTANCE1)) to ;;; be safe (/== is also assumed to be an atomic values only slot). ;;; Let's leave it as a direct get-vals, for efficiency for now! (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 (km0 ...)? [3] (km0 `#$(the /== of ,INSTANCE1))))) (instance2-neq (cond ((and (kb-objectp instance2) #|quick lookahead|# (get-vals instance2 '/== :situation *global-situation*)) (km0 `#$(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))) (km0 `#$(the > of ,INSTANCE2))) (some #'(lambda (n) (and (numberp n) (>= instance1 n))) (km0 `#$(the < of ,INSTANCE2))))) (and (numberp instance2) (kb-objectp instance1) (or (some #'(lambda (n) (and (numberp n) (<= instance2 n))) (km0 `#$(the > of ,INSTANCE1))) (some #'(lambda (n) (and (numberp n) (>= instance2 n))) (km0 `#$(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) (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] May 2000: 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. |# (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-constraints0 (slot i1 i2 exprs1 exprs2 &key cs1 cs2 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-inheritancep (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)))) (cs1-expr-sets (cond (cs1 (remove-if #'contains-self-keyword ; [6] (cons exprs1 (cond ((and (use-inheritance) (not no-inheritancep)) (inherited-rule-sets-on-classes cs1 slot :retain-commentsp t)))))) ; (t (list exprs1)))) ; in case eagerlyp, we just do val-sets-to-expr #|NEW|# (t (cons exprs1 (append (supersituation-own-rule-sets i1 slot :retain-commentsp t) (cond ((and (use-inheritance) (not no-inheritancep)) (inherited-rule-sets i1 slot :retain-commentsp t)))))))) ; NB dereferencing has already been done (cs2-expr-sets (cond (cs2 (remove-if #'contains-self-keyword (cons exprs2 (cond ((and (use-inheritance) (not no-inheritancep)) (inherited-rule-sets-on-classes cs2 slot :retain-commentsp t)))))) ; (t (list exprs2)))) #|NEW|# (t (cons exprs2 (append (supersituation-own-rule-sets i2 slot :retain-commentsp t) (cond ((and (use-inheritance) (not no-inheritancep)) (inherited-rule-sets i2 slot :retain-commentsp t)))))))) #| OLD (constraints (remove-duplicates (append (cond (i1 (collect-constraints-on-instance i1 slot)) ; [3], [7] (cs1 (mapcan #'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)) (constraints2 (mapcan #'find-constraints-in-exprs cs2-expr-sets)) ;;; 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 "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) ; 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 (km0 ...) on the val-sets, but *NOT* a call to (km0 `(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)))) (t (km0-with-trace `#$(the ,SLOT of ,I1) (val-sets-to-expr cs1-expr-sets))))) ; [11] (*less-aggressive-constraint-checking* (remove-if-not #'fully-evaluatedp exprs1)) (t (km0-with-trace `#$(the ,SLOT of (a ,(VALS-TO-VAL CS1) with (,SLOT ,EXPRS1))) (val-sets-to-expr (remove-if #'contains-some-existential-exprs cs1-expr-sets)) ; [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)))) (t (km0-with-trace `#$(the ,SLOT of ,I2) (val-sets-to-expr cs2-expr-sets))))) ; [11] (*less-aggressive-constraint-checking* (remove-if-not #'fully-evaluatedp exprs2)) (t (km0-with-trace `#$(the ,SLOT of (a ,(VALS-TO-VAL CS2) with (,SLOT ,EXPRS2))) (val-sets-to-expr (remove-if #'contains-some-existential-exprs cs2-expr-sets)) )))) ; (_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))) ; (km0 (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))) ; (km0 (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 (km0 `#$(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) (list (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) (list (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) (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] June 2001: 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 ((combine-values-by-appending-slotp slot) (values (remove-dup-instances (append vs1 vs2)) t)) ; optimized access methods assume atomic values only. ((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 (km0 `(,(first vs1) &+? ,(first vs2)))) ; [2], [6] (t (km0 `(,(first vs1) &? ,(first vs2))))) ; [2], [6] (cond (eagerlyp (let ( (new-vals (km0 (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 (list (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)) ; (t (append (and-append vs1-vals '&&! vs2-vals) vs1-constraints vs2-constraints))))) ; (t (km0 (vals-to-val (and-append vs1 '&&! vs2))))))) ; eagerly -> do it! [1] (t (values (append (km0 (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) (list (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 ((km0 `#$((the ,SLOT of ,I1) &? (the ,SLOT of ,I2))) ; returns a shorter unification expression (or fails). (and-append (list (first vs1)) '& (list (first vs2)))))) ; OLD (t (km0 `(,vs1 &&? ,vs2))))) ; NEW: v1s the slot of i1 v2s the slot of i2 THEN do && ((km0 `#$((the ,SLOT of ,I1) &&? (the ,SLOT of ,I2))) (and-append vs1 '&& vs2)))) |# ; OLD (let ( (v1 (first vs1)) ; OLD (v2 (first vs2)) ) ;#|NEW|# (km-trace 'comment "Seeing if values for single-valued slot `~a' are unifiable..." slot) ;#|NEW|# (km-trace 'comment "(Values are: ~a and ~a)" (first vs1) (first vs2)) ;#|NEW|# (let ( (v1 (km-unique0 (first vs1))) ;#|NEW|# (v2 (km-unique0 (first vs2))) ) ; (cond ((and (atom v1) (atom v2)) ; Check for inconsistency ; (let ( (vv1 (dereference v1)) ; just in this special case ; DEREF NOT NECESSARY WITH NEW ; (vv2 (dereference v2)) ) ; of two named single values. ; (cond ((and (named-instancep vv1) ; (named-instancep vv2)) ; (cond ((equal vv1 vv2) (list vv1)))) ; else FAIL (nil) ; OLD (t ;#|NEW|# ((km0 `(,vv1 &? ,vv2)) ; test feasibility of unification ; (and-append (list vv1) '& (list vv2)))))) ; (t (and-append (list v1) '& (list v2)))))))) ;;; ====================================================================== ;;; LAZY-UNIFY-EXPRS ;;; Does a subsumption check first ;;; ====================================================================== ;;; Must be an & expr, ie. either (a & b), or ((a b) && (c d)) ;;; The arguments to &/&& may themselves be &/&& expressions, ;;; eg. ((a & b) & c), ;;; ( (((a b) && (c d))) && (e f) ) ;;; [ Note ( ((a b) && (c d)) && (e f) ) is illegal, as the args to && must be a *list* of expressions ] ;;; ALWAYS returns a list of values (necessarily singleton, for '&) ;;; Feb 2002: **NOTE** No point in doing any classification *DURING* unification (?). Better to wait until finished, and THEN do ;;; unification. But...might be incomplete? Better leave it in. ;;; [1] (disable-classification) will be permanent if KM bombs during the evaluation, while (temporarily-disable-classification) ;;; will be reset at the next KM call. ;;; [2] Note (remove-temporary-disablement-of-classification) doesn't necc. imply (classification-enabled) - it's only enabled ;;; if the user hasn't called (disable-classification) #| (defun lazy-unify-&-expr (expr &key (joiner '&) (fail-mode 'fail) target) (temporarily-disable-classification) ; [1] (let* ( ; (constraints (find-constraints expr)) OLD (constraints nil) ; DISABLE now! - move to get-slotvals.lisp (unified0 (lazy-unify-&-expr0 expr :joiner joiner :fail-mode fail-mode :target target)) (unified (cond ((val-unification-operator joiner) (list unified0)) ; must listify for & (t unified0))) (result0 (cond (constraints (enforce-constraints unified constraints nil nil)) ; instance, slot = nil, as there's no known slot here (t unified))) (result (remove nil result0)) ) (remove-temporary-disablement-of-classification) (cond ((classification-enabled) (mapc #'(lambda (x) (cond ((kb-objectp x) (classify x)))) result))) ; [2] result))) |# (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 nil nil)) ; instance, slot = nil, as there's no known slot here (t unified))) ) (remove nil checked))) (defun lazy-unify-&-expr0 (expr &key (joiner '&) (fail-mode 'fail) target) (cond ((and (tracep) (not (traceunifyp))) (prog2 (suspend-trace) (lazy-unify-&-expr1 expr :joiner joiner :fail-mode fail-mode :target target) (unsuspend-trace))) (t (lazy-unify-&-expr1 expr :joiner joiner :fail-mode fail-mode :target target)))) ;;; Input: A & or && expression. Output: a value (&) or value set (&&) (defun lazy-unify-&-expr1 (expr &key (joiner '&) (fail-mode 'fail) target) (cond ((null expr) nil) ((and (listp expr) (eq (second expr) joiner)) ; either (a & b) or (a & b & c) (cond ((>= (length expr) 4) (cond ((neq (fourth expr) joiner) (report-error 'user-error "Badly formed unification expression ~a encountered during unification!~%" expr))) (let ( (revised-expr (cond ; (a & b & c) -> ((a & b) & c), (as && bs && cc) -> (((as && bs)) & c) [NB extra () for &&] ((val-unification-operator joiner) `( (,(first expr) ,joiner ,(third expr)) ,joiner ,@(rest (rest (rest (rest expr)))))) ((set-unification-operator joiner) `(((,(first expr) ,joiner ,(third expr))) ,joiner ,@(rest (rest (rest (rest expr)))))))) ) (lazy-unify-&-expr1 revised-expr :joiner joiner :fail-mode fail-mode :target target))) ((val-unification-operator joiner) (lazy-unify-exprs (lazy-unify-&-expr1 (first expr) :joiner joiner :fail-mode fail-mode :target target) (lazy-unify-&-expr1 (third expr) :joiner joiner :fail-mode fail-mode :target target) :eagerlyp (eq joiner '&!) :fail-mode fail-mode :target target)) ; [1] ((set-unification-operator joiner) (lazy-unify-expr-sets (lazy-unify-&-expr1 (first expr) :joiner joiner :fail-mode fail-mode :target target) (lazy-unify-&-expr1 (third expr) :joiner joiner :fail-mode fail-mode :target target) :eagerlyp (eq joiner '&&!) :fail-mode fail-mode :target target)))) ((and (singletonp expr) ; special case: (((a b) && (c d))) [NB double parentheses] -> (a b c d) (listp (first expr)) ; This comes if I do (((set1 && set2)) && set3) (set-unification-operator joiner) ; Note: ((set1 && set2) && set3) is badly formed! (&& takes a *set* of expressions) (eq (second (first expr)) joiner)) (lazy-unify-&-expr1 (first expr) :joiner joiner :fail-mode fail-mode :target target)) (t expr))) ;;; ====================================================================== ;;; UNIFICATION OF TWO EXPRESSIONS ;;; Returns an ATOM, or more strictly something which passes an is-km-term() test, eg. a triple. ;;; This *DOESN'T* enforce type constraints ;;; ====================================================================== ;;; [1] Classify does a &, then does (undone X), which rechecks the classification a second time. ;;; Thus classify needs to know if & fails, or else it will loop repeatedly rechecking the classification. ;;; Thus we make lazy-unify-exprs return NIL rather than have a recovery attempt if there's a problem. ;;; [2] fail-mode = fail, not error here, as we want to report the error at the lazy-unify-exprs ;;; level, not here. ;;; RETURNS a SINGLE ATOMIC VALUE ;;; [3] Presumably we took this out to make sure that expressions in the position didn't get evaluated, e.g. ;;; (:triple *Sue mood (a Mood)) (defun lazy-unify-exprs (x y &key eagerlyp classes-subsumep (fail-mode 'fail) target) (cond ((and (null x) (null y)) nil) ((null x) (km-unique0 y :target target)) ; [2] ((null y) (km-unique0 x :target target)) ;#|bug|#((equal x y) x) ((km-equal x y) (km-unique0 x :target target)) ((and (km-triplep x) (km-triplep y)) ; [3] nil) ((or (km-structured-list-valp x) (km-structured-list-valp y)) (let ( (dx (desource x)) (dy (desource y)) ) #| (cond ((not (km-structured-list-valp dx)) (lazy-unify-exprs (list (first dy) dx) dy ; dx & (:args dx dy) :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode :target target)) ((not (km-structured-list-valp dy)) (lazy-unify-exprs dx (list (first dx) dy) ; (:args dx dy) & dx :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode :target target)) |# (cond ((and (km-structured-list-valp dy) (not (km-structured-list-valp dx))) (let ( (edx (km-unique0 dx)) ) (cond ((not (km-structured-list-valp edx)) (cond ((null edx) (km-unique0 dy)) ; dy is the structured item, edx is the evaluated ((and (anonymous-instancep edx) (no-properties edx)) ; special case (lazy-unify edx (km-unique0 dy))) ((km-argsp dy) (lazy-unify-exprs (list (first dy) edx) dy)) ; dx & (:args dx dy) ((eq fail-mode 'error) (report-error 'user-error "Unification (~a ~a ~a) failed!~%" x (cond (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y) nil))) (t (lazy-unify-exprs edx dy))))) ((and (km-structured-list-valp dx) (not (km-structured-list-valp dy))) (let ( (edy (km-unique0 dy)) ) (cond ((not (km-structured-list-valp edy)) (cond ((null edy) (km-unique0 dx)) ((and (anonymous-instancep edy) (no-properties edy)) ; special case (lazy-unify (km-unique0 dx) edy)) ((km-argsp dx) (lazy-unify-exprs dx (list (first dx) edy))) ; dx & (:args dx dy) ((eq fail-mode 'error) (report-error 'user-error "Unification (~a ~a ~a) failed!~%" x (cond (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y) nil))) (t (lazy-unify-exprs dx edy))))) ((and (listp dx) (listp dy) (eq (first dx) (first dy)) (neq (first dx) '#$:triple) ; [3] (unify-structured-list-vals dx dy :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode))) ((eq fail-mode 'error) (report-error 'user-error "Unification (~a ~a ~a) failed!~%" x (cond (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y) nil)))) ((existential-exprp y) (let ( (xf (km-unique0 x :target target)) ) (cond ((null xf) (km-unique0 y :target target)) (t (unify-with-existential-expr xf y :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode :target target))))) ((existential-exprp x) (let ( (yf (km-unique0 y :target target)) ) (cond ((null yf) (km-unique0 x :target target)) (t (unify-with-existential-expr yf x :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode :target target))))) ((and (kb-objectp x) (explained-by x y target)) (km-trace 'comment "[ ~a was originally derived from ~a, so must unify with it! ]" x y) x) ; NEW (t (let ( (xf (km-unique0 x :target target)) (yf (km-unique0 y :target target)) ) (cond ((null xf) yf) ((null yf) xf) ((or (km-structured-list-valp xf) (km-structured-list-valp yf)) (lazy-unify-exprs xf yf :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode :target target)) ((and (is-km-term xf) (is-km-term yf)) (cond ((lazy-unify xf yf :eagerlyp eagerlyp :classes-subsumep classes-subsumep)) ((eq fail-mode 'error) (report-error 'user-error "Unification (~a ~a ~a) failed!~%" xf (cond (eagerlyp '&!) (classes-subsumep '&+) (t '&)) yf) #| NEW - give up [1] |# nil))) ((eq fail-mode 'error) (report-error 'user-error "Arguments in a unification expression should be unique KM objects!~%Doing (~a ~a ~a) [ie. (~a ~a ~a)]~%" x (cond (eagerlyp '&!) (classes-subsumep '&+) (t '&)) y xf (cond (eagerlyp '&!) (classes-subsumep '&+) (t '&)) yf))))))) ;;; ====================================================================== ;;; Called by lazy-unify-exprs ;;; Break up structured instances, and feed back fragments to lazy-unify-exprs ;;; [1] 3/13/01 - Bug! Need to check *all* unifications succeed before effecting them, not just one at a time! ;;; Correction is to add this up-front test. This is slightly redundant (KM will work out the unifications twice, once in the test ;;; and once when actually doing it), but that's ok. ;;; It's possible KM will *think* a unification's possible but then fail to actually do it. Yikes! In this case, KM will be stuck ;;; with a partly unified sequence. We'll live with that for now. ;;; [2] Must pass through km0, as the elements may be expressions (not guaranteed to be atomic!) ;;; [3] & of structured vals are only decommented at the top level by km0, so we need to do another decommenting here so that remaining ;;; comments aren't taken as actual values themselves! (defun unify-structured-list-vals (instance10 instance20 &key classes-subsumep eagerlyp fail-mode) (let ( (instance1 (decomment-top-level instance10)) ; [3] (instance2 (decomment-top-level instance20)) ) (cond ((and (listp instance1) (listp instance2) (eq (first instance1) (first instance2)) ; (try-lazy-unify instance1 instance2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp)) ; [1] (every #'(lambda (pair) ; [2] (or (km-setp (first pair)) ; ((:set a) &? _X), also ((:set a b) &? NIL) should succeed (km-setp (second pair)) (km0 `(,(first pair) &? ,(second pair))))) (transpose (list (rest instance1) (rest instance2))))) (let ( (unification (unify-structured-list-vals2 (rest instance1) (rest instance2) :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode)) ) (cond ((eq unification 'fail) (report-error 'nodebugger-error "Yikes! I partly unified two sequences ~a and ~a but then found they couldn't be unified!~%I'll continue and hope for the best (sorry!)...~%" instance1 instance2)) (t (cons (first instance1) unification)))))))) (defun unify-structured-list-vals2 (elements1 elements2 &key classes-subsumep eagerlyp fail-mode) (cond ((null elements1) elements2) ((null elements2) elements1) ((or (km-setp (first elements1)) (km-setp (first elements2))) (let* ( (set-element1 (cond ((km-setp (first elements1)) (set-to-list (first elements1))) (t (list (first elements1))))) (set-element2 (cond ((km-setp (first elements2)) (set-to-list (first elements2))) (t (list (first elements2))))) (unification (lazy-unify-expr-sets set-element1 set-element2 #|:classes-subsumep classes-subsumep|# :eagerlyp eagerlyp )) ) (cond (unification (let ( (unifications (unify-structured-list-vals2 (rest elements1) (rest elements2) :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode)) ) (cond ((neq unifications 'fail) (cons (vals-to-val unification) unifications)) (t 'fail)))) (t 'fail)))) (t (let* ( ; (e1 (km-unique0 (first elements1))) ; - not necc to evaluate! ; (e2 (km-unique0 (first elements2))) (e1 (first elements1)) (e2 (first elements2)) (unification (lazy-unify-exprs e1 e2 :classes-subsumep classes-subsumep :eagerlyp eagerlyp)) ) (cond ((or unification (km-null e1) ; if e1 or e2 is NIL, or evaluates to NIL, then the (km-null e2) ; unification necessarily MUST succeed (inc. nil & nil -> nil) (and (not (existential-exprp e1)) (null (km-unique0 e1))) ; efficiency: existentials can never be nil (and (not (existential-exprp e2)) (null (km-unique0 e2)))) (let ( (unifications (unify-structured-list-vals2 (rest elements1) (rest elements2) :classes-subsumep classes-subsumep :eagerlyp eagerlyp :fail-mode fail-mode)) ) (cond ((neq unifications 'fail) (cons unification unifications)) (t 'fail)))) (t 'fail)))))) ;;; ====================================================================== ;;; LAZY-UNIFY-EXPR-SETS ;;; Handling of expressions: Here KM limits the evaluation of the second expression list, ;;; so as to avoid creating unnecessary instances and simplify the proof trace. ;;; HOWEVER: This is extremely cryptic to watch in the normal execution of KM, ;;; so hide it from the user!! ;;; ====================================================================== ;;; Allows us to switch off KM's heuristic unification mechanism (defparameter *no-heuristic-unification* nil) #| ((_Door178 _Door179 _Cat23 _Bumper176) && ((a Cat) (MyCar has-door) (a Door) (a Door)) [1] evaluate any non-existential exprs ((_Door178 _Door179 _Cat23 _Bumper176) && ((a Cat) _Door178 (a Door) (a Door))) [2] remove duplicates (_Door178) APPEND ((_Door179 _Cat23 _Bumper176) && ((a Cat) (a Door) (a Door)) [3] remove subsuming elements (_Door178 _Door179 _Cat23) APPEND ((_Bumper176) && ((a Door))) [4] evaluate the remaining exprs (_Door178 _Door179 _Cat23) APPEND ((_Bumper176) && (_Door180)) [5] unify the result (_Door178 _Door179 _Cat23 _Bumper176 _Door180) [6] NOTE this is guaranteed to succeed, as there are no constraints here (constraints are on expressions in situ on slots) [7] Eager set unification: previous error: (_Move3 _Enter4) &&! (_Enter5) With :eagerlyp passed to lazy-unify-sets, thus to lazy-unify-vals, I *force* _Enter5 and _Move3 to unify, even if there's a constraint violation. Urgh! Really I need a two-pass implementation: (i) Do a && (ii) Evaluate the subexpression unifications & / && (((_Car1 with (color (_Red1 _Green1))) _Toy1) &&! ((_Car2 with (color (_Green2))))) -> ((_Car12 with (color (((_Red1 _Green1) &&! _Green2)))) _Toy1) -> need to map through all the slot-values of the unifications, looking for &&! and executing them. Will this catch them all? I *think* so. Note &! CAN be executed within lazy-unify-slotvals, as this IS unambiguous, and thus we don't need this two-pass approach. I haven't accounted for multiple situations, though. QUESTION: GIVEN: ((the parts of _Engine13)) && ((the parts of _Engine13) _Distributor14) AND (the parts of _Engine13) include _Distributor12, then should _Distributor12 and _Distributor14 unify? Answer: no I think. Any evaluation of a shared expression should *augment*, not *unify with* other values present. |# (defun lazy-unify-expr-sets (exprs1 exprs2 &key eagerlyp (fail-mode 'fail) target) (declare (ignore fail-mode)) ; [6] (cond ((or (not (listp exprs1)) (not (listp exprs2))) (report-error 'user-error "(~a && ~a): Arguments should be *sets* of values, but just found a single value!~%" exprs1 exprs2)) ((subbagp exprs2 exprs1 :test #'equal) (km0 (vals-to-val exprs1) :target target)) (t (let ( (set1 (km0 (vals-to-val exprs1) :target target)) ) (cond ((null set1) (km0 (vals-to-val exprs2) :target target)) ; i.e. evaluated exprs1 is a subbag of exprs2 (t (multiple-value-bind (unexplained-set1 unexplaining-exprs2) (remove-explained-vals set1 (dereference exprs2) :target target) (let* ( (set2 (my-mapcan #'(lambda (expr) ; [1] evaluate definite exprs in set2 (cond ((or (and (not (existential-exprp expr)) (not (km-structured-list-valp expr))) *no-heuristic-unification*) (km0 expr :target target)) (t (list expr)))) unexplaining-exprs2)) ) ; (_dummy (km-format t "set1 = ~a, exprs2 = ~a, explained-set1 = ~a, unexplained-set1 = ~a, unexplaining-exprs2 = ~a~%" ; set1 exprs2 explained-set1 unexplained-set1 unexplaining-exprs2)) ; (shared-elements (ordered-intersection unexplained-set1 set2 :test #'equal)) ; [2] ; (reduced-set1 (ordered-set-difference unexplained-set1 shared-elements :test #'equal)) ; (reduced-set2 (ordered-set-difference set2 shared-elements :test #'equal)) ) (multiple-value-bind (reduced-set1 reduced-set2) ; don't need shared elements: added back in at [9] below (remove-shared-elements unexplained-set1 set2 :test #'equal) (multiple-value-bind (more-reduced-set1 more-reduced-set2) ; don't need shared elements: added back in at [9] below (do-forced-unifications reduced-set1 reduced-set2 :eagerlyp eagerlyp :target target) (multiple-value-bind (remainder-set2 remainder-set1 subsumed-set1) ; [3] ; PC (remove-subsuming-exprs more-reduced-set2 more-reduced-set1) ; (expects exprs first, instances next) ; PC - Can I get away with :allow-coeercion t?? What will the effect be? #|PC|# (remove-subsuming-exprs more-reduced-set2 more-reduced-set1 :allow-coercion t :target target) ; more-reduced-set1 is already eval'd #|[9]|# (declare (ignore subsumed-set1)) (let* ( (new-set2 (my-mapcan #'(lambda (expr) ; [4] now evaluate (remaining) existential exprs in set2 (cond ((or (existential-exprp expr) ; i.e., opposite of [1] (km-structured-list-valp expr)) (km0 expr :target target)) (t (list expr)))) remainder-set2)) #| NEW |# (unified (lazy-unify-sets remainder-set1 new-set2 :eagerlyp eagerlyp)) ; [9] Jan 2001 - preserve ordering as best as possible: (final-result (remove-dup-instances (append (dereference set1) (ordered-set-difference (dereference unified) (dereference set1))))) ) (cond (eagerlyp (mapc #'eagerly-evaluate-exprs final-result))) final-result)))))))))))) #| RETURNS two values - vals which are unexplained by any of exprs - exprs which don't explain any vals ALGORITHM: (i) find all the explanations of vals (ii) For each val, - if val is explained by (path1) (path2) (a C) (a C2) in exprs then: - remove val from list of unexplained vals - remove *all* explaining paths, i.e., path1, path2 - remove *one* existential, e.g., (a C). ***Actually** in the current implementation of explanations-for, explanations are *necessarily* existential-exprs, but we allow for the case when they're also not below, even though it never currently can happen. June 2001 - neah, drop this [1] NOTE: cache-explanations now LEAVES comments in, because if we have two rules: (a Wing with (has-logo (t)) (@ Airplane parts))) (a Wing with (has-logo (t)) (@ Jumbo parts))) Then these should *BOTH* be recorded as explanations for _Wing1. If we discard rule 2 as "already used" as _Wing1 is explained by rule 1, then we'll lose rule 2 as an explanation for _Wing1. HOWEVER: We really want some clever matching which will "realize" that these two rules match, i.e. a value explained by rule 1 is also covered by rule 2...and hence rule 2 can be removed, but ALSO noted as an explanation for that value. We can do this at a later time. |# ;;; [2] Now *includes* source info ;;; [3] cached-explanations may include (a Engine), existing recorded explanations may record (a Engine (@ Car parts)), ;;; all-explanations may include explanation (a Engine (@ Vehicle parts)), so need to record this explanation too if we ;;; are going to drop the expr! ;;; [4a] The existential explanation is removed on the way down; [4b] The path explanations are removed on the way back ;(defun remove-explained-vals (vals exprs &key target) ; (declare (ignore target)) ; (values vals exprs)) #| Problem before: (_Car1 _Car2) ((a Car with (color (Red))) (a Car)) and suppose _Car1 is explained by (a Car) This causes the ordering to be violated: _Car1 matches (a Car) _Car2 matches (a Car with (color (Red))) and this is bad for the Shaken system! This reduced version insists the matching is sequential and exits otherwise [5]. Hmm... but doesn't seem to speed things up much, particularly because there are paths in the exprs (which aren't in the cache). |# (defun remove-explained-vals (vals exprs &key target) (cond ((null vals) (values nil exprs)) (t (let* ( (val (first vals)) (expr (first exprs)) (cached-explanations (cached-explanations-for val)) ) (cond ((member (desource expr) cached-explanations :test #'equal) ; first val explained by first expr... (cond (target (record-explanation-for target val expr))) ; [3] (cond ((existential-exprp expr) (remove-explained-vals (rest vals) (rest exprs) :target target)) ; [4a] (t (multiple-value-bind ; expr is a path (unexplained-vals unexplaining-exprs) (remove-explained-vals (rest vals) exprs :target target) ; [4a] (values unexplained-vals (remove expr unexplaining-exprs :test #'equal)))))) ; [4b] (t (values vals exprs))))))) ; [5] #| (defun remove-explained-vals (vals exprs &key target) (cond ((endp vals) (values nil exprs)) (t (let* ( (val (first vals)) ; correct! (explanations (intersection (cached-explanations-for val) exprs :test #'equal)) ; [1] ; Temp - need to remove these for backward library compatibility... ; (cached-explanations (desource (cached-explanations-for val))) ; desource to be removed shortly... (cached-explanations (cached-explanations-for val)) (explanations (remove-if-not #'(lambda (expr) (member (desource expr) cached-explanations :test #'equal)) exprs)) ; [2] (path-explanations (remove-if #'existential-exprp explanations)) (existential-explanation (find-if #'existential-exprp explanations)) ; find just first... (all-explanations (cond (existential-explanation (cons existential-explanation path-explanations)) (t path-explanations))) ) (cond (all-explanations ; (km-format t "~a removed as existing explanations for ~a = ~a!~%" all-explanations target val) (km-trace 'comment "[ ~a is already known to be computed from ~a ]" val all-explanations) (cond (target (mapc #'(lambda (explanation) (record-explanation-for target val explanation)) ; [3] all-explanations))) (multiple-value-bind (unexplained-vals unexplaining-exprs) (remove-explained-vals (rest vals) (remove existential-explanation exprs :test #'equal :count 1) :target target) ; [4a] (values unexplained-vals (ordered-set-difference unexplaining-exprs path-explanations :test #'equal)))) ; [4b] (t (multiple-value-bind (unexplained-vals unexplaining-exprs) (remove-explained-vals (rest vals) exprs :target target) (values (cons val unexplained-vals) unexplaining-exprs)))))))) |# ;;; ---------- ;;; This implements the eager evaluation of sub-unified expressions. (defun eagerly-evaluate-exprs (instance &optional (situation (curr-situation))) (mapc #'(lambda (slotvals) (cond ((minimatch (vals-in slotvals) '((?x &&! ?y) &rest)) (km0 `#$(the ,(SLOT-IN SLOTVALS) of ,INSTANCE))))) (get-slotsvals instance :situation situation))) #| INPUT: set1 set2 RETURNS: three values: - shorter set1 - shorter set2 - list of items which unified via forcing (through the :tag slot) |# ;;; Dormant for a year, reinstated Dec 2000 (defun do-forced-unifications (set1 exprs2 &key eagerlyp target) (cond ((not *are-some-tags*) (values set1 exprs2 nil)) ; optimization ((endp set1) (values nil exprs2 nil)) (t (let* ( (val1 (first set1)) (val1-tags (cond ((kb-objectp val1) (append (get-vals val1 '#$called :situation *global-situation*) (get-vals val1 '#$uniquely-called :situation *global-situation*))))) (matches (remove-if-not #'(lambda (expr) (intersection (tags-in-expr expr) val1-tags :test #'equal)) exprs2)) (val2 (first matches)) (val2-tags (cond (val2 (tags-in-expr val2)))) ) (cond ((null matches) (multiple-value-bind (reduced-set1 reduced-exprs2 unifications) (do-forced-unifications (rest set1) exprs2) (values (cons val1 reduced-set1) reduced-exprs2 unifications))) ((>= (length matches) 2) (report-error 'user-error "Tagging error! ~a's tags ~a imply it should unify with multiple, distinct values:~% ~a!~%" val1 val1-tags matches)) ((not (is-consistent (append val1-tags val2-tags))) (report-error 'user-error "Tag inconsistency! ~a and ~a have tags both forcing and disallowing unification!~% Tag sets were: ~a and ~a~%" val1 val2 val1-tags val2-tags)) (t ; (cond ((existential-exprp val2) ; UNIFY! Result = val1 ;;; No, the is0 test is too expensive! ; (cond ((is0 val1 val2) ; val2 subsumes val1, so no unification needed.... ; (cond ((set-difference val2-tags val1-tags :test #'equal) ; ...except for tranferring the tags. ; (cond (target (record-explanation-for target val1 val2))) ; (km0 `(,val1 #$has (,'#$called ,val2-tags)) :fail-mode 'error)))) ; (t (lazy-unify val1 (km-unique0 val2 :fail-mode 'error :target target) :eagerlyp eagerlyp)))) ; otherwise we do unify them ; try 2 (lazy-unify val1 (km-unique0 val2 :fail-mode 'error :target target) ; :eagerlyp eagerlyp :check-constraintsp nil)) ; otherwise we do unify them (let ( (unification (cond ((existential-exprp val2) ; UNIFY! Result = val1 (unify-with-existential-expr val1 val2 :eagerlyp eagerlyp :check-constraintsp nil :target target)) ; allow :fail-mode 'fail so error is caught below ; otherwise we do unify them (t (lazy-unify val1 val2 :eagerlyp eagerlyp :check-constraintsp nil)))) ) (cond ((not unification) (report-error 'user-error "Tagging error! tags ~a (on ~a) and ~a (on ~a) imply (~a & ~a) must be unified, but this unification fails!" val1-tags val1 val2-tags val2 val1 val2)))) (multiple-value-bind (reduced-set1 reduced-exprs2 unifications) (do-forced-unifications (rest set1) (remove val2 exprs2 :test #'equal)) (values reduced-set1 reduced-exprs2 (cons val1 unifications))))))))) ;;; ---------- ;;; expr is necessarily an *instance* or an *existential expr* (defun tags-in-expr (expr) (cond ((kb-objectp expr) (append (get-vals expr '#$called :situation *global-situation*) (get-vals expr '#$uniquely-called :situation *global-situation*))) (t (let ( (class+slotsvals (breakup-existential-expr expr)) ) (cond (class+slotsvals (append (vals-in (assoc '#$called (second class+slotsvals))) (vals-in (assoc '#$uniquely-called (second class+slotsvals)))))))))) ;;; ====================================================================== ;;; LAZY-UNIFY-SETS ;;; Here KM makes a plausible guess as to which members of the sets should ;;; be coreferential. ;;; Is an ***auxiliary function*** to lazy-unify-expr-sets, not called from ;;; anywhere else in KM. ;;; ====================================================================== #| (lazy-unify-sets set1 set2) For the members which *will* unify, actually do the unification. Below does not allow *different* set1s to unify with the *same* set2. INPUT: Both sets must be lists of instances. They will already have been dereferenced before this point. RETURNS: A list of instances. [1] need :count 1, so that ((Open) && (Open Open)) = (Open Open), not just (Open) [2] Need to first remove duplicate, named instances, so that ((*MyCar) && (_Car2 *MyCar)) = (_Car2 *MyCar), not (*MyCar) MAR99: Why just named? ((_Car3) && (_Car2 _Car3)) = (_Car2 _Car3), not (_Car3) INPUT: The members of the sets must be FULLY EVALUATED - it's an error otherwise. |# (defun lazy-unify-sets (set1 set2 &key eagerlyp) (cond (*no-heuristic-unification* (remove-dup-atomic-instances (append set1 set2))) (t (let ( (shared-elements (ordered-intersection set1 set2)) ) (cond (shared-elements ; [2] (append shared-elements (lazy-unify-sets2 (ordered-set-difference set1 shared-elements) (ordered-set-difference set2 shared-elements) :eagerlyp eagerlyp))) (t (lazy-unify-sets2 set1 set2 :eagerlyp eagerlyp))))))) (defun lazy-unify-sets2 (set1 set2 &key eagerlyp) (cond ((endp set1) set2) ((endp set2) set1) ; NEW: Experimental interactive version: - spot ambiguities ; (t (let* ( (unifees (remove-if-not #'(lambda (set2el) ; (try-lazy-unify (first set1) set2el :classes-subsumep t :eagerlyp eagerlyp)) ; set2)) ; (unifee (cond ((>= (length unifees) 2) ; (let ( (target (menu-ask (km-format nil "Ambiguous unification! What should ~a equal?" (first set1)) ; (append unifees '("None of the above")))) ) ; (cond ((string/= target "None of the above") target)))) ; (t (first unifees)))) ; (unifier (cond (unifee (km-unique0 `(,(first set1) & ,unifee) :fail-mode 'error)))) ) ; OLD (t (let ( (unifier (find-if #'(lambda (set2el) (lazy-unify (first set1) set2el :classes-subsumep t :eagerlyp eagerlyp)) set2)) ) ; back to original code... (cond (unifier (cons unifier (lazy-unify-sets (rest set1) (remove unifier set2 :count 1) :eagerlyp eagerlyp))) ; [1] (t (cons (first set1) (lazy-unify-sets (rest set1) set2 :eagerlyp eagerlyp)))))))) ;;; ====================================================================== ;;; MACHINERY FOR REMOVING DUPLICATES WHEN &'ing TOGETHER STUFF ;;; ====================================================================== #| and-append: - Takes two *sets* of values. For &, those sets will necessarily be singletons. - Returns a *set* containing a *single* value, = the unification of those two sets (either using & or && as specified in the call). This simple task ends up being surprisingly tricky to implement correctly... ;;; without duplicates (and-append '(a) '& '(b)) ;-> ((a & b)) (and-append '(a) '& '((b & c))) ;-> ((a & b & c)) (and-append '((a & b)) '& '((c & d))) ;-> ((a & b & c & d)) ;;; with duplicates (and-append '(a) '& '((b & a))) ;-> ((b & a)) (and-append '((b & a)) '& '(a)) ;-> ((b & a)) (and-append '((a & b)) '& '((c & a))) ;-> (( b & c & a)) The critical property is that repeated and'ing doesn't make the list grow indefinitely: (and-append '(a) '& '(b)) ;-> ((a & b)) (and-append '((a & b)) '& '(b)) ;-> ((a & b)) (and-append '(a b) '&& '(c d)) ;-> (((a b) && (c d))) (and-append '(((a b) && (c d))) '&& '(c d)) ;-> (((a b) && (c d))) Inputs get converted to call and-append2 as follows: (((a b) && (c d))) (((a b) && (e f))) [1a] -> ((a b) && (c d)) ((a b) && (e f)) ((a & b)) ((a & c)) [1b] -> (a & b) (a & c) (((a b) && (c d))) (a b) [2a] -> ((a b) && (c d)) ((a b)) ((a & b)) (a) [2b] -> (a & b) (a) (a b) (c d) [3a] -> returns ((a b) && (c d)) (a) (c) [3b] -> returns (a & b) |# (defun and-append (xs0 and-symbol ys0) (let ( (xs (remove-dup-atomic-instances xs0)) (ys (remove-dup-atomic-instances ys0)) ) (cond ((equal xs ys) xs) ((and (singletonp xs) ; (((a b) && (c d))) (((a b) && (e f))) [1a] (and-listp (first xs) and-symbol) ; ((a & b)) ((a & c)) [1b] (singletonp ys) (and-listp (first ys) and-symbol)) (list (and-append2 (first xs) and-symbol (first ys)))) ((and (singletonp xs) ; (((a b) && (c d))) (a b) [2a] (and-listp (first xs) and-symbol)) ; ((a & b)) (a) [2b] (list (and-append2 (first xs) and-symbol (do-setify ys and-symbol)))) ((and (singletonp ys) ; (a b) (((a b) && (c d))) [2a] (and-listp (first ys) and-symbol)) ; (a) ((a & b)) [2b] (list (and-append2 (do-setify xs and-symbol) and-symbol (first ys)))) ((set-unification-operator and-symbol) ; (a b) (c d) [3a] (list (list xs and-symbol ys))) ((val-unification-operator and-symbol) ; (a) (c) [3b] (list (list (first xs) and-symbol (first ys)))) (t (report-error 'user-error "Unknown case for (ands-append ~a ~a ~a)~%!" xs and-symbol ys))))) (defun do-setify (set and-symbol) (cond ((set-unification-operator and-symbol) (list set)) (t set))) ;;; Here x and y are lists of conjoined values. Note how non-and-lists have been ()'ed ;;; (and-append2 '(a) '& '(a & b)) ;;; (and-append2 '((a)) '&& '((a) && (b))) ;;; eg. (and-(a & b), or (a) but not a (defun and-append2 (x and-symbol y) (cond ((null x) y) ; termination ((and (not (singletonp x)) (not (and (> (length x) 2) (eq (second x) and-symbol)))) (report-error 'program-error "and-append2 given a badly formed list (not an and-list!)~%Doing (and-append2 ~a ~a ~a)~%" x and-symbol y)) ((and-member (first x) y and-symbol) (and-append2 (rest (rest x)) and-symbol y)) (t (cons (first x) (cons and-symbol (and-append2 (rest (rest x)) and-symbol y)))))) ; (and-listp '(a & b) '&) --> t ; (and-listp '((a) && (b)) '&&) --> t (defun and-listp (list and-symbol) (and (listp list) (> (length list) 2) (eq (second list) and-symbol))) (defun and-member (el list and-symbol) (cond ((equal el (first list))) ((singletonp list) nil) ((and (> (length list) 2) (eq (second list) and-symbol)) (and-member el (rest (rest list)) and-symbol)) (t (report-error 'program-error "and-member given a badly formed list (not an and-list!)~%Doing (and-member ~a ~a ~a)~%" el list and-symbol)))) ;;; ====================================================================== ;;; UNIFYING SITUATIONS ;;; ====================================================================== #| An extra step is required besides unifying the frames themselves, namely unifying their situational contents. |# ;;; source and target are instances (defun copy-situation-contents (source-sitn target-sitn) (cond ((eq source-sitn target-sitn)) ((not (isa source-sitn '#$Situation))) ((not (kb-objectp target-sitn)) (report-error 'user-error "Can't copy ~a's contents to target situation ~a, as ~a isn't a KB object!~%" source-sitn target-sitn target-sitn)) (t (let ( (curr-situation (curr-situation)) (objects-to-copy (remove-if-not #'(lambda (instance) (has-situation-specific-info instance source-sitn)) (get-all-concepts))) ) ; (km-format t "Changing to the target-sitn = ~a...~%" target-sitn) (in-situation target-sitn) ; Change to target... (mapc #'(lambda (instance) (merge-slotsvals instance source-sitn target-sitn :facet 'own-properties) (merge-slotsvals instance source-sitn target-sitn :facet 'member-properties)) objects-to-copy) (mapc #'un-done objects-to-copy) ; - now in put-slotsvals via merge-slotsvals; Later: No! (mapc #'classify objects-to-copy) ; (km-format t "Changing back the curr-sitn = ~a...~%" curr-situation) (in-situation curr-situation))))) ; Change back... ;;; ---------- ;;; (No result passed back) ;;; [1] The inverses will be installed anyway when the other frames in the situation are merged. ;;; [2] here we just merge the *structures*, which is why i1 and i2 are nil (defun merge-slotsvals (instance source-sitn target-sitn &key classes-subsumep (facet 'own-properties)) (let ( (source-svs (get-slotsvals instance :facet facet :situation source-sitn)) (target-svs (get-slotsvals instance :facet facet :situation target-sitn)) ) (cond (source-svs (multiple-value-bind (successp unified-svs) ; (lazy-unify-slotsvals instance instance source-svs target-svs :classes-subsumep classes-subsumep) (lazy-unify-slotsvals nil nil source-svs target-svs ; [2] :cs1 (immediate-classes instance :situation source-sitn) :cs2 (immediate-classes instance :situation target-sitn) :classes-subsumep classes-subsumep :check-constraintsp nil) (cond (successp (cond ((not (equal unified-svs target-svs)) (put-slotsvals instance unified-svs :facet facet :situation target-sitn :install-inversesp nil)))) ; install-inversesp = nil [1] (t (report-error 'user-error "Failed to unify ~a's slot-values of ~a in ~a~%with its slot-values ~a in ~a!~%Dropping these values...~%" instance source-svs source-sitn target-svs target-sitn)))))))) ;;; ====================================================================== ;;; UNIFIABLE-WITH-EXPR ;;; ====================================================================== ;;; 5.3.00 remove this, replace with &? as it ignores constraints attached to class. #| unifiable-with-existential-expr: This is like the &? operator, except its second argument is an expression rather than an instance. It uses the same comparison machinery (lazy-unify-slotsvals) as &?, except enters it a bit lower down (lazy-unify-slotsvals, rather than try-lazy-unify), and without actually creating a temporary Skolem instance denoting expr. Unifiable - eventually should merge with subsumes. EXPR = necessarily '(a Class with slotsvals)), for now [1] Technically, we unify in *every* situation, but of course the existential-expr is invisible in other situations*** so we'd just be unifying instance with nil for all other situations = redundant. 9/8/00 *** - no! It's also visible in all subsituations of the current situation and so should check them too! [2] Merging an instance with a structure, so i2 = NIL [3] for multiple classes in expr, e.g., (a Car with (instance-of (Expensive-Thing)) (...)): classes -> (Car Expensive-Thing) slotsvals -> ((instance-of (Car Expensive-Thing)) ... , for constraint-checking by lazy-unify-slotsvals [4] Optimization: (_Agent3 & (a Agent)) shouldn't test all the constraints on _Agent3's slots! [5] Let's *try* and allow people to put expressions on instance-of slots |# (defun unifiable-with-existential-expr (instance expr &key classes-subsumep) (cond (*backtrack-after-testing-unification* (setq *internal-logging* t) (let ( (checkpoint-id (gensym)) ) (set-checkpoint checkpoint-id) (prog1 (unifiable-with-existential-expr0 instance expr :classes-subsumep classes-subsumep) (undo checkpoint-id) ; undo, whatever (setq *internal-logging* nil)))) (t (unifiable-with-existential-expr0 instance expr :classes-subsumep classes-subsumep)))) (defun unifiable-with-existential-expr0 (instance expr &key classes-subsumep) (cond ((explained-by instance expr) (km-trace 'comment "[ ~a was originally derived from ~a, so must unify with it! ]" instance expr) instance) (t (let ( (class+slotsvals (bind-self (breakup-existential-expr expr) instance)) ) ; [1] (cond (class+slotsvals ;;; 1. An INDEFINITE expression (let* ( (class (first class+slotsvals)) ;;; (so do subsumption) (slotsvals0 (second class+slotsvals)) (classes (remove-duplicates (cons class (vals-in (assoc '#$instance-of slotsvals0))))) ; [3] (slotsvals (update-assoc-list slotsvals0 `(#$instance-of ,classes))) ) ; [3] (are-slotsvals slotsvals) ; inc. look for constraints in slots (cond ((and (null slotsvals) (isa instance class)) instance) ; [4] ((and ;(can-be-a instance class) (compatible-classes :instance1 instance :classes2 (remove-constraints classes) ; incomplete [no constraint checking] lookahead :classes-subsumep classes-subsumep) (cond ((am-in-local-situation) (let ( ; (local (remove-if-not #'(lambda (slotvals) ; (fluentp (slot-in slotvals))) slotsvals)) (global (remove-if #'(lambda (slotvals) (fluentp (slot-in slotvals))) slotsvals)) (curr-situation (curr-situation)) ) (and (lazy-unify-slotsvals instance nil (get-slotsvals instance) slotsvals ; was "local", not "slotsvals" [1]*** ; :cs2 (remove-constraints classes) :cs2 (remove-if-not #'kb-objectp classes) ; [5] :classes-subsumep classes-subsumep) (prog2 (change-to-situation *global-situation*) (lazy-unify-slotsvals instance nil (get-slotsvals instance) global ; :cs2 (remove-constraints classes) :cs2 (remove-if-not #'kb-objectp classes) ; [5] :classes-subsumep classes-subsumep) (change-to-situation curr-situation))))) (t (lazy-unify-slotsvals instance nil (get-slotsvals instance) slotsvals ; :cs2 (remove-constraints classes) :cs2 (remove-if-not #'kb-objectp classes) ; [5] :classes-subsumep classes-subsumep)))))))) ; only unify in curr sitn [1], [2] (t (report-error 'program-error "unifiable-with-existential-expr() in lazy-unify.lisp wasn't given an existential expr!~% (was ~a instead)~%" expr))))))) ;;; This unifies instance with an existential expr *without* creating then subsequently deleting a Skolem ;;; constant for that existential expr. It's rather a lot of code just to save extra instance creation, ;;; but useful for must-be-a constraints. ;;; IF successful returns INSTANCE, if not returns NIL. ;;; [1] creation routine is largely copied from create-named-instance in frame-io.lisp ;;; [2] this subsumption test is new, from remove-subsuming-exprs. It avoids creating ;;; unnecessary structures e.g. if (Pete has (owns (_Car0))) then: ;;; (unify-with-existential-expr Pete '#$(a Person with (owns ((a Car))))) ;;; would otherwise have resulted in (Pete has (owns (((_Car0) && ((a Car)))))). ;;; [2b] PC - beta48 - so why is that a problem? You just defer resolving the && until later! ;;; [3] Merging an instance with a structure, so i2 = NIL ;;; NOTE: This unification is *only* done in the local situation. ;;; [4] Optimization: (_Agent3 & (a Agent)) shouldn't test all the constraints on _Agent3's slots! ;;; [5] Let's *try* and allow people to put expressions on instance-of slots (defun unify-with-existential-expr (instance expr &key eagerlyp classes-subsumep (fail-mode 'fail) target (check-constraintsp t)) (cond ((explained-by instance expr target) (km-trace 'comment "[ ~a was originally derived from ~a, so must unify with it! ]" instance expr) instance) ((and (fluent-instancep instance) ; special case: (_SomePerson23 & (a Person)) -> _Person35, a definite object (neq (first expr) '#$some)) (let ( (val (km-unique0 expr :target target)) ) (cond (eagerlyp (km-unique0 `(,instance &! ,val) :fail-mode fail-mode)) (t (km-unique0 `(,instance & ,val) :fail-mode fail-mode))))) ; ((km0 `#$(,INSTANCE is ',EXPR)) instance)) ; [2], [2b] (t (let ( (class+slotsvals (bind-self (breakup-existential-expr expr) instance)) ) ; [1] (cond (class+slotsvals ;;; 1. An INDEFINITE expression (let* ( (class (first class+slotsvals)) ;;; (so do subsumption) (slotsvals0 (second class+slotsvals)) (_dummy (are-slotsvals slotsvals0)) ; inc. look for constraints in slots (unification (cond ((and (null slotsvals0) (isa instance class)) instance) ; [4] ((compatible-classes :instance1 instance :classes2 (list class) ; incomplete [no constraint checking], quick lookahead :classes-subsumep classes-subsumep) (cond ((not (kb-objectp instance)) instance) ; e.g. (1 & (a Coordinate)) (t (let ( (extra-classes (vals-in (assoc '#$instance-of slotsvals0))) ) ; [1] (or (unify-with-slotsvals2 instance (cons class extra-classes) slotsvals0 :classes-subsumep classes-subsumep :eagerlyp eagerlyp :check-constraintsp check-constraintsp) (cond ((eq fail-mode 'error) (report-error 'user-error "Unification (~a & ~a) failed!~%" instance expr) nil))))))))) ) (declare (ignore _dummy)) (cond (unification (cond (target (record-explanation-for target instance expr))) (cache-explanation-for instance expr) ; new - missed this first time round (setq *statistics-unifications* (1+ *statistics-unifications*)) unification) ((eq fail-mode 'error) (cond (classes-subsumep (report-error 'user-error "Unification (~a &+ ~a) failed! (Classes of one do not subsume classes of the other)~%" instance expr)) (t (report-error 'user-error "Unification (~a & ~a) failed! (Classes are incompatible)~%" instance expr))))))) (t (report-error 'program-error "unify-with-existential-expr() in lazy-unify.lisp wasn't given an existential expr!~% (was ~a instead)~%" expr))))))) (defun unify-with-slotsvals2 (instance classes slotsvals &key classes-subsumep eagerlyp (check-constraintsp t)) (cond ((am-in-local-situation) (let* ( (local0 (remove-if-not #'(lambda (slotvals) (fluentp (slot-in slotvals))) slotsvals)) (global0 (remove-if #'(lambda (slotvals) (fluentp (slot-in slotvals))) slotsvals)) (local (cond ((fluentp '#$instance-of) (update-assoc-list local0 `#$(instance-of ,CLASSES))) (t local0))) (global (cond ((not (fluentp '#$instance-of)) (update-assoc-list global0 `#$(instance-of ,CLASSES))) (t global0))) (curr-situation (curr-situation)) ) (multiple-value-bind (successp1 unified-svs1) (lazy-unify-slotsvals instance nil (get-slotsvals instance) local ; :cs2 (remove-constraints classes) :cs2 (remove-if-not #'kb-objectp classes) ; [5] :classes-subsumep classes-subsumep ; [3] :eagerlyp eagerlyp :check-constraintsp check-constraintsp) (cond (successp1 (change-to-situation *global-situation*) (multiple-value-bind (successp2 unified-svs2) (lazy-unify-slotsvals instance nil (get-slotsvals instance) global ; :cs2 (remove-constraints classes) :cs2 (remove-if-not #'kb-objectp classes) ; [5] :classes-subsumep classes-subsumep ; [3] :eagerlyp eagerlyp :check-constraintsp check-constraintsp) (cond ((and successp1 successp2) (let ( (local-change-made nil) (global-change-made nil) ) (cond ((not (equal unified-svs2 (get-slotsvals instance))) ; GLOBAL SITUATION (cond ((not global-change-made) ; (km-format t "unified-svs2 = ~a~%" unified-svs2) ; (km-format t "(get-slotsvals ~a) = ~a~%" instance (get-slotsvals instance)) (setq global-change-made t))) ; (km-format t "tracepoint 1: ~a~%" unified-svs2) (mapc #'(lambda (slotvals) (put-vals instance (slot-in slotvals) (vals-in slotvals))) unified-svs2) ; [1] (cond ((some #'(lambda (class) (is-subclass-of class '#$Situation)) classes) (make-assertions instance unified-svs2))))) (change-to-situation curr-situation) (cond ((not (equal unified-svs1 (get-slotsvals instance))) ; LOCAL SITUATION (cond ((not local-change-made) ; (km-format t "unified-svs1 = ~a~%" unified-svs1) ; (km-format t "(get-slotsvals ~a) = ~a~%" instance (get-slotsvals instance)) (setq local-change-made t))) ; (km-format t "tracepoint 2: ~a~%" unified-svs1) (mapc #'(lambda (slotvals) (put-vals instance (slot-in slotvals) (vals-in slotvals))) unified-svs1) ; [1] (cond ((some #'(lambda (class) (is-subclass-of class '#$Situation)) classes) (make-assertions instance unified-svs1))))) ; (un-done instance) ; It looks like slotsvals are adequate, but no: ; i1 & (a Move with (object (...))) may, as a side effect, include OTHER changes on OTHER slots on i1 too, ; inherited from Move or its superclasses. So we better undo all of these! ; (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in slotsvals)) (cond (local-change-made (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in unified-svs1)))) (cond (global-change-made (mapc #'(lambda (slot) (un-done instance :slot slot :situation *global-situation*)) (mapcar #'slot-in unified-svs2)))) (cond ((or local-change-made global-change-made) (classify instance)))) ; OLD VERSION ; (cond (change-made ; (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in unified-svs1)) ; (classify instance)))) instance) (t (change-to-situation curr-situation) nil)))))))) ; oops! Must change back again even after failure! (t (multiple-value-bind (successp unified-svs) (lazy-unify-slotsvals instance nil (get-slotsvals instance) (update-assoc-list slotsvals `#$(instance-of ,CLASSES)) ; :cs2 (remove-constraints classes) :cs2 (remove-if-not #'kb-objectp classes) ; [5] :classes-subsumep classes-subsumep ; [3] :eagerlyp eagerlyp :check-constraintsp check-constraintsp) (cond (successp (let ( (change-made nil) ) (cond ((not (equal unified-svs (get-slotsvals instance))) (mapc #'(lambda (slotvals) (cond ((not change-made) ; (km-format t "unified-svs = ~a~%" unified-svs) ; (km-format t "(get-slotsvals ~a) = ~a~%" instance (get-slotsvals instance)) (setq change-made t))) ; (km-format t "tracepoint 3: ~a~%" slotvals) (put-vals instance (slot-in slotvals) (vals-in slotvals))) unified-svs) ; [1] (cond ((some #'(lambda (class) (is-subclass-of class '#$Situation)) classes) (make-assertions instance unified-svs))) ; (un-done instance) ; It looks like slotsvals are adequate, but no: ; i1 & (a Move with (object (...))) may, as a side effect, include OTHER changes on OTHER slots on i1 too, ; inherited from Move or its superclasses. So we better undo all of these! (cond (change-made (mapc #'(lambda (slot) (un-done instance :slot slot :situation (curr-situation))) (mapcar #'slot-in unified-svs)) (classify instance))) ))) instance)))))) ;;; Compatible: Classes mustn't be disjoint, and may have a subsumption requirement also. ;;; IN ADDITION: As we also allow negated class values, we must also check consistency here, ;;; e.g. (instance-of (Car)) and (instance-of ((<> Car))) are incompatible. ;;; Also, because instance-of is a *built-in-remove-subsumers-slots*, (instance-of (Car)) and (instance-of ((<> Vehicle))) are incompatible, ;;; although (instance-of (Vehicle)) and (instance-of ((<> Car))) are not. ;;; [This handling of types as values needs better facilities in KM] ;;; HOWEVER: We **DEFER** this checking instead to check-slotvals-constraints instead, as this kind of check is already performed for other slots. ;;; class constraints are simply ignored here as if they weren't there. ;;; Note: The subsumption requirement isn't that the instance is subsumed by a class, ;;; but that one set of classes is subsumed by another. ;;; [2] This may miss some constraints if instance-of-is-fluent is true. ;;; [3] New: classes-subsumep = 'exact-match, 't or nil. exact-match checks for identity. (defun compatible-classes (&key instance1 instance2 classes1 classes2 classes-subsumep) (let ( (immediate-classes1 (or classes1 (and instance1 (immediate-classes instance1)) (report-error 'program-error "compatible-classes: missing instance/classes for instance1!~%"))) (immediate-classes2 (or classes2 (and instance2 (immediate-classes instance2)) (report-error 'program-error "compatible-classes: missing instance/classes for instance2!~%"))) ) (cond ((eq classes-subsumep 'exact-match) ; [3] (set-equal immediate-classes1 immediate-classes2)) (classes-subsumep (or (classes-subsume-classes immediate-classes1 immediate-classes2) (classes-subsume-classes immediate-classes2 immediate-classes1))) (t (not (disjoint-class-sets immediate-classes1 immediate-classes2 :instance1 instance1 :instance2 instance2)))))) ;;; ====================================================================== ;;; HANDLING OF PARTITIONS - only used by the above function compatible-classes ;;; ====================================================================== ;;; [1] all-superclasses0 is like all-superclasses, except it INCLUDES class, and MAY NOT ;;; include Thing unless Thing is explicitly declared as a superclass. This is exactly ;;; what we want here! ;;; Returns NIL if the class sets are NOT disjoint (i.e. can be combined) (defun disjoint-class-sets (immediate-classes1 immediate-classes2 &key instance1 instance2) (disjoint-class-sets0 (remove-duplicates (my-mapcan #'all-superclasses0 (remove '#$Thing immediate-classes1))) ; [1] (remove-duplicates (my-mapcan #'all-superclasses0 (remove '#$Thing immediate-classes2))) ; [1] :instance1 (or instance1 `#$(a ,(VALS-TO-VAL IMMEDIATE-CLASSES1))) ; purely for tracing output :instance2 (or instance2 `#$(a ,(VALS-TO-VAL IMMEDIATE-CLASSES2))))) ; purely for tracing output ;;; ---------- ;;; classes1 = (C1 SuperC1 SuperSuperC1), classes2 = (C2 SuperC2 SuperSuperC2) ;;; or could also have multiple C's, e.g. classes1 = (C11 SuperC11 SuperSuperC11 C12 SuperC12 SuperSuperC12) ;;; If partition is exhaustive and mutually exclusive, then exactly ONE of classes1 should = a partition member (defun disjoint-class-sets0 (classes1 classes2 &key instance1 instance2) (declare (ignore instance2)) (and (not (equal classes1 classes2)) (not (subsetp classes1 classes2)) (not (subsetp classes2 classes1)) (some #'(lambda (partition) (let* ( (partition-members (get-vals partition '#$members :situation *global-situation*)) (classes1-in-partition (intersection classes1 partition-members)) ) #| EXHAUSTIVE PARTITIONS -- needs some more work: They are only applicable if the instance is a member of the partition's PARENT, an as-yet undefined slot. e.g. (a Exhaustive-Partition with (parent (Tangible)) (members (Solid Liquid Gas))) So it's OK if a Dream isn't in any of this partition's members, but not for _Dog23. But it IS okay if _Tangible23 isn't in any members (ie. we haven't decided on which member it is in). But then, which instances DO we check for compulsory class membership for?? ;;; Exhaustive partition check... (cond ((isa partition '#$Exhaustive-Partition) (cond ((null classes1-in-partition) (report-error 'user-error "Instance ~a must be in exactly one class in the below exhaustive partition!~% (~a has (members ~a))~% [~a is currently in classes ~a]~%" instance1 partition partition-members instance1 classes1)) ((null (intersection classes2 partition-members)) (report-error 'user-error "Instance ~a must be in exactly one class in the below exhaustive partition!~% (~a has (members ~a))~% [~a is currently in classes ~a]~%" instance2 partition partition-members instance2 classes2))))) |# ;;; Disjoint classes check (cond ((null classes1-in-partition) nil) ; Non-mutually exhaustive partition - null is ok ((not (singletonp classes1-in-partition)) (report-error 'user-error "An object ~a was encountered which was in mutually exclusive classes ~a!~% [Partition was: (~a has (members ~a))]~%" instance1 classes1-in-partition partition partition-members)) ;;; We could also check partition2 like this, but don't bother (t (intersection classes2 (remove (first classes1-in-partition) partition-members)))))) ; = classes1 & classes2 are (all-instances '#$Partition)))) ; disjoint ;;; FILE: constraints.lisp ;;; File: constraints.lisp ;;; Author: Peter Clark ;;; Date: 1999 ;;; Purpose: Constraint checking/enforcement mechanism for KM #| ====================================================================== CONSTRAINT CHECKING / ENFORCEMENT ====================================================================== filter-using-constraints: remove vals which fail a constraint. Violations aren't an error. Used solely to remove inconsistent projected vals in km-slotvals-from-kb. (are-consistent-with-constraints vals constraints slot) - lazy-unify (satisfies-constraints vals constraints slot) - subsumes returns t/nil if vals [can] satisfy constraints or not. Failure is not an error. Used by lazy-unify and subsumes, to check for consistency/satisfaction. No side effects. enforce-constraints: Apply the constraints. Failure IS an error and will be reported. Used to process the values collected in km-slotvals-from-kb. |# ;;; ====================================================================== (defun note-are-constraints () (or *are-some-constraints* (km-setq '*are-some-constraints* t))) ;;; This will *REMOVE VIOLATORS* (but not necessarily fail) if a constraint is violated. ;;; It should be used as a filter, not as a test. For a test, use ;;; instead. It *DOESN'T* report violations. ;;; This has no side-effects. Returns a reduced list of values. ;;; It's solely used for filtering out projected values which conflict with current constraints. ;;; THIS ASSUME VALS IS A LIST OF ATOMS, IE. ANY KM EVALUATION HAS ALREADY BEEN PERFORMED. (defun filter-using-constraints (vals constraints &optional slot) (cond ((null constraints) vals) ((and (tracep) (not (traceconstraintsp))) (prog2 (suspend-trace) (filter-using-constraints0 vals constraints slot) (unsuspend-trace))) (t (km-trace 'comment "Testing constraints ~a" constraints) (filter-using-constraints0 vals constraints slot)))) (defun filter-using-constraints0 (vals constraints slot) (remove-if-not #'(lambda (val) (test-val-constraints val (dereference constraints) (special-slot-type slot) :mode 'consistent)) vals)) ;;; ====================================================================== ;;; ARE-CONSISTENT-WITH-CONSTRAINTS ;;; ====================================================================== #| This will *FAIL* if a constraint is violated. Returns T/NIL. 8/16/00 - Extended to to handle special constraint handling for slots whose values are classes. (are-consistent-with-constraints '#$(Car) '#$((<> Vehicle)) '#$instance-of) should FAIL, as #$instance-of is a remove-subsumers-slotp, but (are-consistent-with-constraints '#$(Vehicle) '#$((<> Car)) '#$instance-of) should SUCCEED. Similarly, (are-consistent-with-constraints '#$(Vehicle) '#$((<> Car)) '#$subclasses should FAIL, as #$subclasses is a remove-subsumees-slotp, but (are-consistent-with-constraints '#$(Car) '#$((<> Vehicle)) '#$subclasses) should SUCCEED. |# (defun are-consistent-with-constraints (vals0 constraints0 slot) (test-constraints vals0 constraints0 slot :mode 'consistent)) (defun satisfies-constraints (vals0 constraints0 slot) (test-constraints vals0 constraints0 slot :mode 'satisfies)) ;;; ---------------------------------------- (defun test-constraints (vals0 constraints0 slot &key mode) ; (cond ((or (null constraints0) (null vals0)) t) ; No: null vals0 may VIOLATE the constraint! VULCAN (cond ((null constraints0) t) (t (let ( (vals (remove-dup-instances vals0)) ; does dereferencing etc. (constraints (dereference constraints0)) (special-slot-type (special-slot-type slot)) ) (and (every #'(lambda (constraint) (or (not (set-constraint-exprp constraint)) (test-set-constraint vals constraint :mode mode))) constraints) (every #'(lambda (val) (test-val-constraints val constraints special-slot-type :mode mode)) vals)))))) (defun special-slot-type (slot) (cond ((null slot) nil) ((remove-subsumers-slotp slot) 'remove-subsumers-slot) ((remove-subsumees-slotp slot) 'remove-subsumees-slot))) (defun test-val-constraints (val constraints special-slot-type &key mode) (and val (every #'(lambda (constraint) (or (not (val-constraint-exprp constraint)) (test-val-constraint val constraint special-slot-type :mode mode))) constraints))) ;;; [1] ignore for now - could look for mutually inconsistent constraints later ;;; [2] Note we ASSUME for special-slot-types that the constraints are NECESSARILY of the form (<> ATOMIC-CLASS) ;;; [3] Technically, this is a failure -- if there's no possible values. HOWEVER, KM may fail to find possible values if the ;;; system is looping, and so aborts the computation. See enforce-val-constraint also, for identical issue (defun test-val-constraint (val constraint special-slot-type &key mode) (cond ((constraint-exprp val)) ; [1] (t (case (first constraint) ; (#$must-be-a (unifiable-with-expr val `#$(a ,@(REST CONSTRAINT)))) ; not complete enough, and may loop!! (#$must-be-a (cond ((instance-of val '#$Aggregate) (let ( (element-type (km0 `#$(the element-type of ,VAL))) ) (or (null element-type) (compatible-classes :classes1 element-type :classes2 (list (second constraint)))))) ; ignore any "with ..." part, as ; disjoint-class-sets can't handle it. ; (every #'(lambda (element-type) ; (km0 `#$(,ELEMENT-TYPE is-subsumed-by (the-class ,@(REST CONSTRAINT))))) ; (km0 `#$(the element-type of ,VAL)))) ((equal constraint '#$(must-be-a Thing))) ; t (t (case mode (consistent (km0 `#$(,VAL &? (a ,@(REST CONSTRAINT))))) (satisfies (km0 `#$(,VAL is '(a ,@(REST CONSTRAINT))))))))) (#$mustnt-be-a (km0 `#$(not (,VAL is '(a ,@(REST CONSTRAINT)))))) (<> (cond ((is-km-term (second constraint)) (case special-slot-type (remove-subsumers-slot (not (is-subclass-of val (second constraint)))) (remove-subsumees-slot (not (is-subclass-of (second constraint) val))) (t (not (equal val (second constraint)))))) (t (km0 `#$(,VAL /= ,(SECOND CONSTRAINT)))))) ; [2] (#$excluded-values (let ( (excluded-values (km0 (vals-to-val (rest constraint)))) ) (cond ((null excluded-values)) ((eq special-slot-type 'remove-subsumers-slot) ; #$instance-of ; val = Animal, excluded-values = (Tiger) OK (not (intersection (all-superclasses0 val) excluded-values))) ; val = Tiger, excluded-values = (Animal) NOT OK ((eq special-slot-type 'remove-subsumees-slot) ; #$subclasses ; val = Animal, excluded-values = (Tiger) NOT OK [4] (not (intersection (all-subclasses0 val) excluded-values))) ; val = Tiger, excluded-values = (Animal) OK (t (not (member val excluded-values)))))) ; test it (#$possible-values (let ( (possible-values (km0 (vals-to-val (rest constraint)))) ) ; [3] ; (km-format t "possible-values = ~a~%" possible-values) (cond (possible-values (case special-slot-type (remove-subsumers-slot (not (disjoint-class-sets (list val) possible-values))) (remove-subsumees-slot (not (disjoint-class-sets (list val) possible-values))) (t (case mode (consistent (some #'(lambda (possible-value) (km0 `(,val &? ,possible-value))) possible-values)) (satisfies (member val possible-values :test #'equal)))))) (t)))) ; [3] fail, not succeed -- may be no vals due to looping, not really values (#$constraint (km0 (subst val '#$TheValue (second constraint)))) ; (#$override t) (#$no-inheritance t) (t (report-error 'user-error "Unrecognized form of constraint ~a~%" constraint)))))) ;;; [1] this computation is seemingly (but insignificantly) inefficient here, and could be moved earlier. ;;; But: it is a place-holder, where we might later want to check for mutually inconsistent constraints later. ;;; [2] Efficiency - only do the length test if needed later (defun test-set-constraint (vals0 constraint &key mode) (let* ( (vals (remove-constraints vals0)) ; [1] (n (second constraint)) (class (third constraint)) (nvals (cond ((or (and (eq (first constraint) '#$at-least) (eq mode 'satisfies)) ; [2] (member (first constraint) '#$(exactly at-most))) (length (remove-if-not #'(lambda (val) (isa val class)) vals))))) ) (case (first constraint) (#$at-least (case mode (consistent t) ; can always add values (satisfies (>= nvals n)))) (#$exactly (case mode (consistent (<= nvals n)) (satisfies (= nvals n)))) (#$at-most (<= nvals n)) (#$set-constraint (km0 (subst (vals-to-val vals) '#$TheValues (second constraint)))) ; (#$set-constraint (cond ((km0 (subst (vals-to-val vals) '#$TheValues (second constraint)))) ; No!! Should fail quietly... ; (t (report-error 'user-error ; "set-constraint violation!~%~a failed test ~a. Continuing anyway...~%" ; vals (second constraint)) ; t))) (#$sometimes t) (#$set-filter t) (t (report-error 'user-error "Unrecognized form of set constraint ~a~%" constraint) vals0)))) ;;; ====================================================================== ;;; IS-CONSISTENT ;;; ====================================================================== ;;; Returns T/NIL. Here, we have vals and constraints mixed, and in principle could check ;;; constraints are mutually consistent also. (defun is-consistent (vals+constraints0) (cond ((null vals+constraints0) t) (t (let ( (vals+constraints (remove-dup-instances vals+constraints0)) ) (and (every #'(lambda (constraint) (or (not (set-constraint-exprp constraint)) ; (is-consistent-with-set-constraint vals+constraints constraint))) (test-set-constraint vals+constraints constraint :mode 'consistent))) vals+constraints) (every #'(lambda (val) (test-val-constraints val vals+constraints nil :mode 'consistent)) vals+constraints)))))) ; (every #'(lambda (val) (is-consistent-with-val-constraints val vals+constraints)) vals+constraints)))))) ;;; ====================================================================== ;;; ENFORCE-CONSTRAINTS ;;; ====================================================================== ;;; Returns revised vals, after constraints have been enforced ;;; This one will do coersion, as well as testing. ;;; This assume vals is a list of atoms, ie. any km evaluation has already been performed. ;;; It also ASSUMES vals and constraints are ALREADY dereferenced (defun enforce-constraints (vals constraints instance slot) (cond ((and (tracep) (not (traceconstraintsp))) (prog2 (suspend-trace) (enforce-constraints0 vals constraints instance slot) (unsuspend-trace))) (t (km-trace 'comment "Enforcing constraints ~a" constraints) (enforce-constraints0 vals constraints instance slot)))) ;;; ******* NOTE!! ********** ;;; 9/7/99: Disable the set-valued constraints! It's causing too many problems! See constraints.README ;;; We now reduce it to are-consistent-with-constraints for set-valued constraints. ;;; 9/17/99: Put it back again, then hurriedly take it out again (see enforcement-problem.km) ;;; [1] 9/19/00: Should do set constraint checks first, as they may enforce coercion enabling later val checks to succeed. ;;; ASSUME: Dereferencing has already been done (defun enforce-constraints0 (vals constraints instance slot) ; ENFORCEMENT VERSION ; (enforce-set-constraints ; (remove-if-not #'(lambda (val) (enforce-val-constraints val constraints slot)) vals) ; revised vals ; constraints)) (let ( (special-slot-type (cond ((remove-subsumers-slotp slot) 'remove-subsumers-slot) ((remove-subsumees-slotp slot) 'remove-subsumees-slot))) ) (remove-if-not #'(lambda (val) ; [1] (enforce-val-constraints val constraints instance special-slot-type)) (enforce-set-constraints vals constraints instance special-slot-type)))) ; TESTING ONLY VERSION ; (let ( (newvals (remove-if-not #'(lambda (val) (enforce-val-constraints val constraints)) vals)) ) ; (mapc #'(lambda (constraint) ; test but don't enforce set constraints, for now ; (cond ((not (set-constraint-exprp constraint))) ; ((is-consistent-with-set-constraint newvals constraint)) ; (t (report-error 'user-error "Constraint violation! Values ~a conflict with constraint ~a!~%" ; newvals constraint)))) ; constraints) ; newvals)) (defun enforce-val-constraints (val constraints instance special-slot-type) (and val (every #'(lambda (constraint) (or (not (val-constraint-exprp constraint)) (enforce-val-constraint val constraint instance special-slot-type) (report-error 'user-error "Constraint violation! Discarding value ~a (conflicts with ~a)~%" val constraint))) constraints))) ;;; 5.3.00 add to report error later ;;; [1] This is actually a check, rather than an enforcement. It's the best we can do for now. ;;; [2] This could be more efficient - I only care if there's a unique solution or not ;;; [3] Technically, this is a failure -- if there's no possible values. HOWEVER, KM may fail to find possible values if the ;;; system is looping, and so aborts the computation. See is-consistent-with-val-constraint also, for identical issue ;;; [4] I'm not sure about this - leave it in for completeness for now. (defun enforce-val-constraint (val constraint instance special-slot-type) (case (first constraint) (#$must-be-a (cond ((instance-of val '#$Aggregate) ; NB constraints on the aggregates elements should be implemented at KB, not KM, level (let ( (element-type (km0 `#$(the element-type of ,VAL))) ) (or (null element-type) (compatible-classes :classes1 element-type :classes2 (list (second constraint)))))) ; ignore any "with ..." part, as ; disjoint-class-sets can't handle it. ((equal constraint '#$(must-be-a Thing)) val) (t (km0 `#$(,VAL & (a ,@(REST CONSTRAINT))))))) (#$mustnt-be-a (km0 `#$(not (,VAL is '(a ,@(REST CONSTRAINT)))))) ; (<> (cond ((is-km-term (second constraint)) ; (cond ((not (equal val (second constraint))) ; check constraint ; (t (km0 `#$(,VAL /= ,(SECOND CONSTRAINT)))))) (<> (km0 `#$(,VAL /== ,(SECOND CONSTRAINT)))) (#$excluded-values (let ( (excluded-values (km0 (vals-to-val (rest constraint)))) ) ; [1] (cond ((null excluded-values)) ((eq special-slot-type 'remove-subsumers-slot) ; #$instance-of ; val = Animal, excluded-values = (Tiger) OK (not (intersection (all-superclasses0 val) excluded-values))) ; val = Tiger, excluded-values = (Animal) NOT OK ((eq special-slot-type 'remove-subsumees-slot) ; #$subclasses ; val = Animal, excluded-values = (Tiger) NOT OK [4] (not (intersection (all-subclasses0 val) excluded-values))) ; val = Tiger, excluded-values = (Animal) OK ((member val excluded-values) nil) ; test it (t (mapcar #'(lambda (excluded-value) ; assert it (add-val val '/== excluded-value)) excluded-values))))) (#$possible-values (let ( (possible-values (km0 (vals-to-val (rest constraint)))) ) ; [3] (cond ((null possible-values)) ; [3] - Not necc. failure -- could fail due to looping! ((and (eq special-slot-type 'remove-subsumers-slot) instance) ; instance /= nil (cond ((member val possible-values)) ((singletonp possible-values) (km-trace 'comment "~a: Only one possible value so enforcing ~a isa ~a!~%" `#$(possible-values ,@(REST CONSTRAINT)) instance (first possible-values)) (km0 `(,instance == (#$a ,(first possible-values))))) (t (let ( (unifiable-values (first-N-unifiable-values2 possible-values instance 2)) ) (cond ((singletonp unifiable-values) (km-trace 'comment "~a: Only one consistent, possible value so enforcing ~a isa ~a!~%" `#$(possible-values ,@(REST CONSTRAINT)) instance (first unifiable-values)) (km0 `(,instance == (#$a ,(first unifiable-values))))) (unifiable-values t)))))) ; if some unifiable values, constraint is satisfied ((member special-slot-type '(remove-subsumers-slot remove-subsumees-slot)) ; '#$instance-of (not (disjoint-class-sets (list val) possible-values))) ((member val possible-values)) ((singletonp possible-values) (km-trace 'comment "~a: Only one possible value so enforcing ~a == ~a!~%" `#$(possible-values ,@(REST CONSTRAINT)) val (first possible-values)) (km0 `(,val == ,(first possible-values)))) (t (let ( (new-constraint `#$(possible-values ,@POSSIBLE-VALUES)) (unifiable-values (first-N-unifiable-values possible-values val 2)) ) ; (km-format t "unifiable-values = ~a~%" unifiable-values) (cond ((singletonp unifiable-values) (km-trace 'comment "~a: Only one consistent, possible value so enforcing ~a == ~a!~%" `#$(possible-values ,@(REST CONSTRAINT)) val (first unifiable-values)) (km0 `(,val == ,(first unifiable-values)))) ((not (null unifiable-values)) (or (member new-constraint (get-vals val '== :situation *global-situation*) :test #'equal) (km0 `#$(,VAL has (== (,NEW-CONSTRAINT))) :fail-mode 'error))))))))) ; assert it (#$constraint (km0 (subst val '#$TheValue (second constraint)))) ; (#$override t) (#$no-inheritance t) (t (report-error 'user-error "Unrecognized form of constraint ~a~%" constraint)))) ;;; Returns the first N possible-values which are unifiable with val. ;;; This stops after the first N are found, and thus is a bit more efficient than doing: ;;; (remove-if-not #'(lambda (possible-value) (km0 `(,val &? ,possible-value))) possible-values) (defun first-N-unifiable-values (possible-values val n) (cond ((endp possible-values) nil) ((<= n 0) nil) ((km0 `(,val &? ,(first possible-values))) (cons (first possible-values) (first-N-unifiable-values (rest possible-values) val (1- n)))) (t (first-N-unifiable-values (rest possible-values) val n)))) (defun first-N-unifiable-values2 (possible-values instance n) (cond ((endp possible-values) nil) ((<= n 0) nil) ((km0 `(,instance &? (#$a ,(first possible-values)))) (cons (first possible-values) (first-N-unifiable-values2 (rest possible-values) instance (1- n)))) (t (first-N-unifiable-values2 (rest possible-values) instance (1- n))))) ;;; ---------------------------------------- (defun enforce-set-constraints (vals constraints instance &optional special-slot-type) ; special-slot-type not used (cond ((endp constraints) vals) ((val-constraint-exprp (first constraints)) ; skip these (enforce-set-constraints vals (rest constraints) instance special-slot-type)) (t (enforce-set-constraints (enforce-set-constraint vals (first constraints) instance special-slot-type) (rest constraints) instance special-slot-type)))) ;;; Just do this reduced version (defun enforce-set-constraint (vals constraint instance special-slot-type) (declare (ignore instance special-slot-type)) (let* ( (forced-class (first (or (minimatch constraint '#$(at-most 1 ?class)) (minimatch constraint '#$(exactly 1 ?class))))) (vals-in-class (cond (forced-class (remove-if-not #'(lambda (val) (isa val forced-class)) vals)))) ) (cond ((> (length vals-in-class) 1) ; necc. 0 if no forced class (make-comment "Unifying values ~a (forced by constraint (at-most 1 ~a)" vals-in-class forced-class) (cons (km-unique0 (vals-to-&-expr vals-in-class) :fail-mode 'error) (set-difference vals vals-in-class))) (t (enforce-set-constraint2 vals constraint))))) ;;; PROBLEMS! see test-suite/outstanding/enforcement-problem.km ;;; Simplified to just do the test and report on the problems (defun enforce-set-constraint2 (vals constraint) (let* ( (n (second constraint)) (class (third constraint)) (count (length (remove-if-not #'(lambda (val) (isa val class)) vals))) ) (case (first constraint) ;old (#$at-least vals) ; no testing on this constraint #|new|# (#$at-least (cond ((or (> n *max-padding-instances*) #|new|# (>= count n)) vals) ; avoid (at-least 3455 Gene) #|new|# (t (append vals (loop repeat (- n count) collect (km-unique0 `#$(a ,CLASS) :fail-mode 'error)))))) ; classes missing so create them!! (#$exactly (cond ;old ((<= count n) vals) #|new|# ((= count n) vals) ((> count n) (report-error 'user-error "set-constraint violation! Found ~a ~a(s), but should be~%exactly ~a! Values were: ~a. Ignoring extras...~%" count class n vals) ; (remove-if #'(lambda (val) (isa val class)) vals :from-end t :count (- count n)) ) #|new|# ((> n *max-padding-instances*) vals) ; avoid (at-least 3455 Gene) - (< count n) is necc. true #|new|# (t (append vals (loop repeat (- n count) collect (km-unique0 `#$(a ,CLASS) :fail-mode 'error)))) ; classes missing so create them!! )) (#$at-most (cond ((<= count n) vals) (t (report-error 'user-error "set-constraint violation! Found ~a ~a(s), but should be~%at-most ~a! Values were: ~a. Ignoring extras...~%" count class n vals) ; (remove-if #'(lambda (val) (isa val class)) vals :from-end t :count (- count n)) ))) (#$set-constraint (cond ((km0 (subst (vals-to-val vals) '#$TheValues (second constraint))) vals) (t (report-error 'user-error "set-constraint violation!~%~a failed test ~a. Continuing anyway...~%" vals (second constraint)) vals))) (#$sometimes t) (#$set-filter (let ( (filter (second constraint)) ) (apply filter (list vals)))) ; return modified list of vals (t (report-error 'user-error "Unrecognized form of set constraint ~a~%" constraint) vals)))) ;;; ====================================================================== ;;; TEST-SET-CONSTRAINTS ;;; This is a rather complicated bit of code, to avoid reifying all existential expressions ;;; ====================================================================== #| This is a special case of constraint checking, used by lazy-unify.lisp Checks that the number of (potentially) unified objects are below the specified maximum. Takes as arguments: exprs1 exprs2 expr-sets1 expr-sets2, where exprs1 exprs2 are each a set of instances, expr-sets1 is list of expression sets (expr-set1 expr-set2 ...), and similarly for expr-sets2. We want to estimate what (exprs1 && exprs2 && expr-set11 && expr-set12 && ... && expr-set21 && expr-set22 && ...) will produce. The system creates "unifications" which is a single list of unified elements from each sets. The result will be, say: unifications = ((v11 & expr111) (v12) (v13 & expr112 & expr211 & expr221) (v21 & expr121) ....) But we drop the "&" sign from these lists for convenience, as we never actually compute the unification. (We only care how many objects are in the final unification). USER(109): (test-set-constraints '#$(_Car1 _Car2) '(_Car2) '#$( ((a Car)) ((a House) (a Dog)) ) nil '#$((at-most 1 Thing))) -> NIL USER(110): (test-set-constraints '#$(_Car1 _Car2) '(_Car2) '#$( ((a Car)) ((a House) (a Dog)) ) nil '#$((at-most 2 Car))) -> T USER(111): (test-set-constraints '#$(_Car1 _Car2) '(_Car2) '#$( ((a Car)) ((a House) (a Dog)) ) nil '#$((at-most 1 House))) -> T USER(112): (test-set-constraints '#$(_Car1 _Car2) '(_Car2) '#$( ((a Car)) ((a House) (a Dog)) ) nil '#$((at-most 3 Thing))) -> T |# #| (test-set-constraints '#$(_Car1 _Car2) '(_Car2) '#$( ((a Car)) ((a House) (a Dog)) ) nil '#$((at-most 1 Thing))) unification = ((_Car1 _Car2 (a Car)) ((a House)) ((a Dog))) [1a] 3/16/01 - Can get confused: (_Car1 _Engine1) & (_Engine2) makes KM estimate that _Engine2 unifies with _Car1, which means there are now two engines resulting in an (incorrect) violation of a (exactly 1 Engine) constraint. Let's drop the vs for now. See outstanding/set-constraints.km [1b] 5/23/01 - but no! (test-set-constraints '(_Tangible-Entity10 _Car11 _Tangible-Entity19) '(_Tangible-Entity26) nil nil '((exactly 1 Entity))) Should *succeed*, as (exactly 1 Entity) will force the three vs1 to be unified together, = ok! |# (defun test-set-constraints (vs1 vs2 expr-sets1 expr-sets2 constraints) ; (km-format t "(test-set-constraints ~a ~a ~a ~a ~a)~%" vs1 vs2 expr-sets1 expr-sets2 constraints) (cond ((and (not (assoc '#$exactly constraints)) ; quick look-ahead - no constraints (not (assoc '#$at-most constraints))) ; quick look-ahead - no constraints t) (t (let* ( (expr-sets (append (mapcar #'list (remove-duplicates (append vs1 vs2))) ; [1a] ; [1b] (cond (vs1 (list vs1))) ; (cond (vs2 (list vs2))) (mapcar #'(lambda (exprs) (remove-if-not #'existential-exprp exprs)) expr-sets1) ; [2] (mapcar #'(lambda (exprs) (remove-if-not #'existential-exprp exprs)) expr-sets2))) (unifications (estimate-unifications expr-sets)) ) ; (km-format t "unifications = ~a~%" unifications) (every #'(lambda (constraint) (test-set-constraint0 unifications constraint)) constraints))))) (defun test-set-constraint0 (unifications constraint) (case (first constraint) (#$(exactly at-most) (test-set-constraint1 unifications (second constraint) (third constraint))) ; More verbose version, for debugging ; (km-format t "Testing set constraint ~a for ~a..." constraint unifications) ; (let ( (ans (test-set-constraint1 unifications (second constraint) (third constraint))) ) ; (cond (ans (km-format t "passed!~%")) ; (t (km-format t "failed!~%"))) ; ans)) (t t))) ;;; (test-set-constraint1 '(1 2 3) '(1 2) 2 '#$Thing) -> NIL (defun test-set-constraint1 (unifications n class) (let ( (unifications-in-class (cond ((eq class '#$Thing) unifications) (t (remove-if-not #'(lambda (unification) (unification-in-class unification class)) unifications)))) ) (<= (length unifications-in-class) n))) #| ====================================================================== ESTIMATING UNIFICATIONS ====================================================================== 1. Given expr-sets, combine them into unification 2. Explore which members of unification are in a class |# ; not used ;(defun number-in-class (unifications class) ; (cond ((eq class '#$Thing) (length unifications)) ; (t (length (remove-if-not #'(lambda (unification) ; (unifications-in-class unification class)) ; unifications))))) (defun unification-in-class (unification class) (some #'(lambda (item) (cond ((existential-exprp item) (is-subclass-of (class-in-existential-expr item) class)) (t (isa item class)))) unification)) ;;; for testing purposes #| (estimate-unifications '#$((_Car13 _Dog14) ((a Car) (a Dog)) ((a House)) ((a Big-House) (a Book)) (_House17) (_Car13 _Car16) ((a Undefined-Class)))) => 5 unified items ((_Car13 (a Car) (a Undefined-Class)) ((a House) (a Big-House) _House17) (_Dog14 (a Dog)) ((a Book)) (_Car16)) |# ;;; (defun estimate-unifications (expr-sets &optional tally-so-far) (cond ((endp expr-sets) tally-so-far) (t (let ( (new-tally (combine-in-exprs tally-so-far (first expr-sets))) ) ; (km-format t "Fold in ~a...~%Tally (length ~a) = ~a~%~%" (first expr-sets) (length new-tally) new-tally) (estimate-unifications (rest expr-sets) new-tally))))) #| Given: VALUE SETS 1: (_Car13 _Dog14) ((a Car) (a Dog)) ((a House)) VALUE SETS 2: ((a Big-House) (a Book)) (_House17) (_Car13 _Car16) SET-CONSTRAINTS: (at-most 3 Thing) (at-most 2 Car) Are the set constraints satisfied? Urgh! Need to combine these iteratively, and non-destructively, as: (_Car2) (_Dog2) (_Car2 (a Car)) (_Dog2 (a Dog)) ((a House)) (_Car2 (a Car)) (_Dog2 (a Dog)) ((a House) (a Big-House)) (_Car2 (a Car)) (_Dog2 (a Dog)) ((a House) (a Big-House)) (a Book) (_Car2 (a Car)) (_Dog2 (a Dog)) ((a House) (a Big-House) _House6) (a Book) (_Car2 (a Car)) (_Dog2 (a Dog)) ((a House) (a Big-House) _House6) (a Book) (_Car3) Let's call this iteratively growing set a TALLY USER(66): USER(66): USER(66): (test-tally) Fold in (_Car13 _Dog14)... Tally (length 2) = ((_Car13) (_Dog14)) Fold in ((a Car) (a Dog))... Tally (length 2) = ((_Car13 (a Car)) (_Dog14 (a Dog))) Fold in ((a House))... Tally (length 3) = ((_Car13 (a Car)) (_Dog14 (a Dog)) ((a House))) Fold in ((a Big-House) (a Book))... Tally (length 4) = (((a House) (a Big-House)) (_Car13 (a Car)) (_Dog14 (a Dog)) ((a Book))) Fold in (_House17)... Tally (length 4) = (((a House) (a Big-House) _House17) (_Car13 (a Car)) (_Dog14 (a Dog)) ((a Book))) Fold in (_Car13 _Car16)... Tally (length 5) = ((_Car13 (a Car)) ((a House) (a Big-House) _House17) (_Dog14 (a Dog)) ((a Book)) (_Car16)) Fold in ((a Undefined-Class))... Tally (length 5) = ((_Car13 (a Car) (a Undefined-Class)) ((a House) (a Big-House) _House17) (_Dog14 (a Dog)) ((a Book)) (_Car16)) |# (defun combine-in-exprs (tally exprs) (multiple-value-bind (tally1 unused-tally1 unmatched-exprs1) (combine-in-exprs0 tally exprs :classes-subsumep 'exact-match) (multiple-value-bind (tally2 unused-tally2 unmatched-exprs2) (combine-in-exprs0 unused-tally1 unmatched-exprs1 :classes-subsumep t) (multiple-value-bind (tally3 unused-tally3 unmatched-exprs3) (combine-in-exprs0 unused-tally2 unmatched-exprs2 :classes-subsumep nil) (append tally1 tally2 tally3 unused-tally3 (mapcar #'list unmatched-exprs3)))))) ;;; Returns: used-tally unused-tally unmatched-exprs (defun combine-in-exprs0 (tally exprs &key classes-subsumep) (cond ((null exprs) (values nil tally nil)) (t (let* ( (expr (first exprs)) (matching-tally-item (find-if #'(lambda (tally-item) (tally-item-matches tally-item expr :classes-subsumep classes-subsumep)) tally)) ) (cond (matching-tally-item (multiple-value-bind (rest-tally unused-tally unmatched-exprs) (combine-in-exprs0 (remove matching-tally-item tally :test #'equal) (rest exprs) :classes-subsumep classes-subsumep) (cond ((member expr matching-tally-item :test #'equal) (values (cons matching-tally-item rest-tally) unused-tally unmatched-exprs)) (t (values (cons (append matching-tally-item (list expr)) rest-tally) unused-tally unmatched-exprs))))) (t (multiple-value-bind (rest-tally unused-tally unmatched-exprs) (combine-in-exprs0 tally (rest exprs) :classes-subsumep classes-subsumep) (values rest-tally unused-tally (cons expr unmatched-exprs))))))))) #| (defun combine-in-exprs (tally exprs) (cond ((null exprs) tally) ((let* ( (expr (first exprs)) (matching-tally-item (or (find-if #'(lambda (tally-item) (tally-item-matches tally-item expr :classes-subsumep 'exact-match)) tally) (find-if #'(lambda (tally-item) (tally-item-matches tally-item expr :classes-subsumep t)) tally) (find-if #'(lambda (tally-item) (tally-item-matches tally-item expr :classes-subsumep nil)) tally))) ) (cond (matching-tally-item (cond ((member expr matching-tally-item :test #'equal) (cons matching-tally-item (combine-in-exprs (remove matching-tally-item tally :test #'equal) (rest exprs)))) (t (cons (append matching-tally-item (list expr)) (combine-in-exprs (remove matching-tally-item tally :test #'equal) (rest exprs)))))) (t (cons (list expr) (combine-in-exprs tally (rest exprs))))))))) |# #| ; Note Cat and Dog are a Partition. USER(41): (tally-item-matches '#$((a Dog)) '#$_Dog8) -> t USER(42): (tally-item-matches '#$((a Dog)) '#$_Cat9) -> NIL USER(43): (tally-item-matches '#$((a Dog)) '#$(a Dog)) -> t USER(44): (tally-item-matches '#$((a Dog)) '#$(a Cat)) -> NIL USER(45): (tally-item-matches '#$((a Dog) _Dog7) '#$(a Cat)) -> NIL USER(47): (tally-item-matches '#$((a Dog) _Dog12) '#$_Dog8) -> t USER(48): (tally-item-matches '#$((a Dog) _Cat9) '#$_Dog8) -> NIL |# (defun tally-item-matches (tally-exprs expr &key classes-subsumep) (every #'(lambda (tally-expr) (exprs-match tally-expr expr :classes-subsumep classes-subsumep)) tally-exprs)) #| subsumesp = t implies STRICTER compatibility testing. This is a slight work-around to PREVENT this misjudgement: (estimate-unifications '((_Airfoil-Body545 _Airfoil-Leading-Edge550 _Airfoil-Trailing-Edge551) (_Airfoil-Leading-Edge547 _Airfoil-Trailing-Edge548 _Airfoil-Body553))) -> ((_Airfoil-Body545 _Airfoil-Leading-Edge547) (_Airfoil-Trailing-Edge551 _Airfoil-Trailing-Edge548) (_Airfoil-Leading-Edge550 _Airfoil-Body553)) |# (defun exprs-match (expr1 expr2 &key classes-subsumep) (let ( (is-existentialp1 (existential-exprp expr2)) (is-existentialp2 (existential-exprp expr1)) ) (cond ((equal expr1 expr2)) ((null expr1)) ((null expr2)) ((km-structured-list-valp expr1) (cond ((km-structured-list-valp expr2) (every #'(lambda (pair) (exprs-match (first pair) (second pair) :classes-subsumep classes-subsumep)) (transpose (list (rest expr1) (rest expr2))))) (t (exprs-match (second expr1) expr2) :classes-subsumep classes-subsumep))) ((km-structured-list-valp expr2) ; e.g. '(:args S1 _Going3) 'S1 (exprs-match expr1 (second expr2) :classes-subsumep classes-subsumep)) ((and is-existentialp1 is-existentialp2) (compatible-classes :classes1 (list (class-in-existential-expr expr2)) :classes2 (list (class-in-existential-expr expr1)) :classes-subsumep classes-subsumep)) ((and is-existentialp1 (not is-existentialp2)) (compatible-classes :classes1 (list (class-in-existential-expr expr2)) :instance2 expr1 :classes-subsumep classes-subsumep)) ((and (not is-existentialp1) is-existentialp2) (compatible-classes :instance1 expr2 :classes2 (list (class-in-existential-expr expr1)) :classes-subsumep classes-subsumep)) ((and (not is-existentialp1) (not is-existentialp2)) (and (compatible-classes :instance1 expr1 :instance2 expr2 :classes-subsumep classes-subsumep) (not (incompatible-instances expr2 expr1))))))) ; e.g. *Cat *Dog ;;; --- end --- ;;; ====================================================================== #| (defun evaluate-and-filter-defaults (expr-set constraints) (cond ((some #'km-defaultp expr-set) (mapcan #'(lambda (expr) (cond ((km-defaultp expr) (let* ( (vals (km0 (second expr))) (new-vals (filter-using-constraints vals constraints)) ) (cond ((and (tracep) (not (equal vals new-vals))) (km-trace 'comment "Discarding ~a (conflicts with constraint(s) ~a)" expr constraints))) new-vals)) (t (list expr)))) expr-set)) (t expr-set))) |# (defun evaluate-and-filter-defaults (expr-set constraints curr-vals slot &key single-valuedp) (cond ((some #'km-defaultp expr-set) (mapcan #'(lambda (expr) (cond ((km-defaultp expr) (let* ( (vals (km0 (second expr))) (new-vals (cond ((and single-valuedp curr-vals vals (not (km0 `(,(first curr-vals) &? ,(first vals))))) nil) (t (remove-if-not #'(lambda (val) (are-consistent-with-constraints (append curr-vals (list val)) (dereference constraints) slot)) vals)))) ) (cond ((and (tracep) (not (equal vals new-vals))) (km-trace 'comment "Discarding ~a (conflicts with constraint(s) ~a)" expr constraints))) new-vals)) (t (list expr)))) expr-set)) (t expr-set))) ;;; ====================================================================== ;;; TOGGLING THE CONSTRAINTS ;;; ====================================================================== (defun sanity-checks () (cond (*sanity-checks* (format t "(Checking of `sanity-check' constraints is already switched on)~%")) (t (format t "(Checking of `sanity-check' constraints switched on)~%") (km-setq '*sanity-checks* t))) '#$(t)) (defun no-sanity-checks () (cond ((not *sanity-checks*) (format t "(Checking of `sanity-check' constraints is already switched off)~%")) (t (format t "(Checking of `sanity-check' constraints switched off)~%") (km-setq '*sanity-checks* nil))) '#$(t)) ;;; -------------------- for Shaken ;;; (pair-filter '#$((:pair 1 *foot) (:pair 2 *foot) (:pair 1 *yard) (:pair 2 *yard))) ;;; -> ((:|pair| 1 |*foot|) (:|pair| 1 |*yard|)) ;;; Retain just first item (defun pair-filter (vals &optional selected-so-far) (cond ((endp vals) nil) (t (let* ( (pair (first vals)) (units (arg2of pair)) ) (cond ((or (not (km-pairp pair)) (notany #'(lambda (selected-pair) ; not selected a pair in this unit yet (eq (arg2of selected-pair) units)) selected-so-far)) (cons pair (pair-filter (rest vals) (cons pair selected-so-far)))) (t (pair-filter (rest vals) selected-so-far))))))) ;;; FILE: explain.lisp ;;; File: explain.lisp ;;; Author: Peter Clark ;;; Date: May 2001 ;;; Purpose: Have KM explain its reasoning #| RECORDING EXPLANATIONS (record-explanation-for target val expr &key situation) target = (the of ) - The explaining expr may include a "source" annotation about the origin of the expression e.g. (a Engine (@ Car parts)) - situation is the situation in which the computation was done, *not* necessarily *Global for non-fluent slots. [This might mean there's duplicate explanations in the KB, one in each situation, for non-fluent slots]. WITH THE EXCEPTION of automatic classification, where instance-of explanations are stored globally. [SpecialCase] handles this below. RETRIEVING EXPLANATIONS - (why [instance slot val situation]) NEW: (why [triple situation]) will print out an explanation for this triple, using the functions below. - (get-explanations instance slot val [situation]) returns a list of EXPLANATIONS for this triple. An explanation has one of these two structures: (instance slot val (*)) (val invslot instance (*)) where each is one of the KM expressions deriving the triple. - (get-comments ) GIVEN an EXPR, we can find the full KM rule and any comments about it as follows: (multiple-value-bind (descriptions justifications rule path body) (get-comments )) where: - descriptions is a list of English translations of the rule - justifications is a list of English justifications of the rule - body is the expression which was evaluated, justifying the triple. - path is the location of that body, in the form of (class1 slot1 class2 slot2 ...) - rule is a simple syntactic combination of the path + body, looking like this: (every class1 has (slot1 ((a class2 with (slot2 (body)))))) - (explain-all) List the *entire* explanation database (could be lots!!) |# ;;; ====================================================================== ;;; SOURCES: ;;; A source denotes the source of an expression. ;;; It's format is: (@ ... ) ;;; ====================================================================== #| SOURCES *NOT* allowed on - &, &&, &+ structures - structured list vals (:triple ...) otherwise a (desource-top-level ...) doesn't prune them all ALSO: I aggressively decomment and desource constraints in ;(defun find-constraints-in-exprs (exprs) ; (decomment (find-constraints exprs 'plural))) In an ideal world, it'd be better to pass these comments back with the constraints for tracking down where they came from, but the constraint engine won't handle that for now! |# (defun sourcep (tag) (and (listp tag) (eq (first tag) '@))) ;;; (source-path '(@ Car parts Engine)) -> (Car parts Engine) ;;; GIVEN: a source data structure ;;; RETURN: the actual path the source denotes ;;; ASSUME sourcep test has already been passed (defun source-path (source) (rest source)) ;;; Find the class of origin (defun originated-from-class (source) (second source)) ;;; Cat -> [@Cat] (defun make-source (class) (list '@ class)) (defun add-to-source (source item) (append source (list item))) ;;; Neah, parenthesizing and deparenthesizing causes too many problems. ;;; Just refuse to parenthesize stuff in the first place. ;;; [1] we want to ALLOW SME to assert things like: (#$explanation (#$:triple ?f ?s ?v) ?explanations), which include the @. ;;; So in this special case, let the sources (@) go through. (defun desource (expr) (cond ((and (listp expr) (or *record-explanations* *record-sources*)) (remove-if #'sourcep (mapcar #'desource expr))) (t expr))) ; in header.lisp ; (defparameter *developer-mode* nil) ;;; ---------- ;;; For my own debugging (defun desource0 (expr) (cond (*developer-mode* expr) (t (desource1 expr)))) (defun desource1 (expr) (cond ((listp expr) (cond ((and (eq (length expr) 3) ; (comm [cat] _Cat3) -> [cat] (eq (first expr) '#$comm)) (second expr)) (t (remove-if #'sourcep (mapcar #'desource1 expr))))) (t expr))) ;;; ---------- (defun sources (expr) (cond ((listp expr) (remove-if-not #'sourcep expr)))) ;;; ====================================================================== ;;; MANIPULATING COMMENTS ;;; ====================================================================== (defconstant *comment-marker-char* #\[) (defun comment-tagp (tag) (or (internal-commentp tag) (user-commentp tag))) (defun comment-or-sourcep (tag) (or (internal-commentp tag) (sourcep tag) (user-commentp tag))) (defun internal-commentp (tag) (and (listp tag) (eq (first tag) '#$comm))) (defun user-commentp (tag) (and (symbolp tag) (char= (first-char (symbol-name tag)) *comment-marker-char*))) ;;; ---------- ;;; Only applied to slotsvals at load time, not to anything else (defun convert-comments-to-internal-form (expr) (cond ((user-commentp expr) (convert-comment-to-internal-form expr)) ((listp expr) (mapcar #'convert-comments-to-internal-form expr)) (t expr))) ;;; [Car1] -> (comm [Car1] Self) (defun convert-comment-to-internal-form (user-comment) `#$(comm ,USER-COMMENT Self)) ;;; ---------- ;;; USER(3): (decomment '(cat [1] (dog [3] ([4] [45] man)))) ;;; (cat (dog (man))) (defun decomment (expr &key retain-commentsp) (cond ((and (listp expr) (not retain-commentsp)) (remove-if #'comment-or-sourcep (mapcar #'decomment expr))) (t expr))) (defun decomment-top-level (expr) (cond (; (and (listp expr) (not (overridep expr))) (listp expr) (remove-if #'comment-or-sourcep expr)) (t expr))) ;;; ---------- (defun get-comment-tags (expr) (cond ((listp expr) (remove-if-not #'comment-tagp expr)))) (defun get-comment-tags-recursive (expr) (cond ((comment-tagp expr) (list expr)) ((listp expr) (my-mapcan #'get-comment-tags-recursive expr)))) ;;; Returns five values ;;; - list of English explanations ;;; - list of English justifications ;;; - the KM rule ;;; - the location part of the KM rule ;;; - the expression part of the KM rule (defun get-comments (expr) (cond ((listp expr) (let* ( (sources (sources expr)) (expr0 (desource expr)) (source-path (source-path (first sources))) (rule (build-rule expr)) (explanations+justifications (transpose (mapcar #'get-comment (get-comment-tags expr)))) ) (cond ((>= (length sources) 2) (report-error 'nodebugger-error "get-comments: More than one source path ~a (?). Just using first...~%" sources))) (values (remove nil (first explanations+justifications)) (remove nil (second explanations+justifications)) rule source-path expr0))))) ;;; ---------- ;;; USER(22): (print (build-rule '#$(a Distributor (@ Car parts Engine parts)))) ;;; (every Car has (parts ((a Engine with (parts ((a Distributor))))))) ;;; ;;; [1] New: 1/10/01 - allow rules to be explicitly stored too (for Shaken) - result is then reflexive: ;;; USER(22): (print (build-rule '#$(every Car has (parts ((a Engine with (parts ((a Distributor))))))))) ;;; (every Car has (parts ((a Engine with (parts ((a Distributor))))))) (defun build-rule (expr0) (cond ((eq (first expr0) '#$every) expr0) ; [1] (t (let* ( (source (first (sources expr0))) ; should never be multiple sources, but just in case! (expr (desource expr0)) (source-path (source-path source)) ) (cond ((or (null source-path) (oddp (length source-path))) (cond ((oddp (length source-path)) (report-error 'nodebugger-error "build-rule: Odd path length for path ~a! Don't know how to build a rule...~%" source-path))) (list '|| expr)) (t `(#$every ,(first source-path) #$has (,(second source-path) (,(build-embedded-val (rest (rest source-path)) expr)))))))))) ;;; Returns an (a ... with ...) structure (defun build-embedded-val (path expr) (cond ((null path) expr) (t `(#$a ,(first path) #$with (,(second path) (,(build-embedded-val (rest (rest path)) expr))))))) ;;; ------------------------------ (defun comment (comment-tag data) (cond ((not (comment-tagp comment-tag)) (report-error 'user-error "~a~% Comment tag ~a should be a symbol in square brackets, e.g. [Car1]!" `(#$comment ,comment-tag ,data) comment-tag)) (t (km-add-to-kb-object-list comment-tag) (setf (get comment-tag 'comment) data)))) (defun show-comment (comment-tag) (cond ((not (comment-tagp comment-tag)) (report-error 'user-error "~a~% Comment tag ~a should be a symbol in square brackets, e.g. [Car1]!" `(#$show-comment ,comment-tag) comment-tag)) (t (get comment-tag 'comment)))) (defun get-comment (comment-tag) (cond ((user-commentp comment-tag) (get comment-tag 'comment)) ((internal-commentp comment-tag) (let ( (comment (get (second comment-tag) 'comment)) (self (third comment-tag)) ) (bind-self comment self))))) (defun get-comment2 (comment-tag mode) (cond ((user-commentp comment-tag) (get comment-tag 'comment)) ((internal-commentp comment-tag) (let* ( (self (third comment-tag)) (comments (bind-self (get (second comment-tag) 'comment) self)) ) (case mode (call (second comments)) ((exit fail) (first comments)) (subgoals (third comments))))))) ;;; ====================================================================== ;;; RECOGNIZING SPECIAL TYPES OF COMMENTS ;;; ====================================================================== ;;; (x has ...) ;;; (every x has ...) ;;; (in-situation (x has ...)) (defun km-assertion-expr (expr) (and (listp expr) (or (intersection expr '#$(a an some has has-definition now-has)) ; new: add now-has (missed in 1.4.5.83) (and (eq (first expr) '#$in-situation) (km-assertion-expr (third expr)))))) ;;; In interpreter.lisp, we strip the assignment data off expressions EXCEPT for ;;; certain special forms, where the data is stripped off lower down in the processing. ;;; [PS Better make sure there are special handlers to deal with these cases!!] ;;; These special forms are: ;;; 1. (:set a b c) ;;; NEW: No, we're going to remove handling of sets, so we consider "record it later" here, but then don't bother later. ;;; Hmm... (defun record-explanation-later (expr) (and *record-explanations* (or (and (km-setp expr) (notevery #'atom (rest expr))) ; if all atoms, then don't pass it further down (and (listp expr) (member (second expr) '(&& & &+)))))) ;;; ====================================================================== ;;; MAINTAINING THE EXPLANATION DATABASE ITSELF ;;; ====================================================================== #| explanations are triples target = (the of ) - we ASSUME this is GUARANTEED by this point. Or this? (defun record-explanation-for (target val expr &key (situation (cond ((existential-exprp expr) *global-situation*) (t (curr-situation))))) [1] If call (km0 '#$_Expose2), km0 *will* call km1 if '#$_Expose2 dereferences to something else e.g. _Expose3. BUT we don't want to record _Expose3 as an explanation for _Expose2, hence the listp test. [2] was getting combinatorial: a b c ((:set m1) (:set m1 m2) (:set m1 m2 m3) ... (:set m1 m2 m3 c)) No! We *do* need :set! (every Amino-Acid-Sequence has (has-region ((a Carboxyl-Terminus (@ Amino-Acid-Sequence has-region)) (a Amino-Terminus (@ Amino-Acid-Sequence has-region))))) [_Situation21] KM> (the has-region of _Enzyme36) 1 -> (the has-region of _Enzyme36) 1 (2) From inheritance: (:set (a Carboxyl-Terminus) (a Amino-Terminus)) ... 0: (record-explanation-for (|the| |has-region| |of| |_Enzyme39|) |_Carboxyl-Terminus40| (:|set| (|a| |Carboxyl-Terminus| (@ |Amino-Acid-Sequence| |has-region|)) (|a| |Amino-Terminus| (@ |Amino-Acid-Sequence| |has-region|)))) We can't pair the right set member with the evaluated result, as this information is lost in the interpreter. [3] Hmm...we remove the :sets if a more specific explanation is available, presumably from the :set being broken up. new-explanation: (:set a b) old-explanation (:set a b c) -> store (:set a b), discard (:set a b c) new-explanation: a old-explanation (:set a b c) -> store a |# (defun record-explanation-for (target val expr0 &key (situation (curr-situation))) (cond (*record-explanations* (let ( (expr (modify-set-explanation expr0)) ) (cond ((and (listp expr) ; [1] val (or (not (km-setp expr)) (notevery #'(lambda (val) (is-km-term (desource val))) (set-to-list expr))) ; :set must have at least one path in it... (or (not (km-triplep val)) (not (null (arg3of val))))) ; ignore (:triple x y NIL) computations (let* ( (slot (second target)) (instance (fourth target)) (explanation (list instance slot val expr)) (old-explanations (get-all-explanations instance :situation situation)) ) (note-expr-is-used expr instance slot val situation) ; NEW OLD RESULT (cond ((member explanation old-explanations :test #'equal)) ; a a -> a (t (put-explanations instance (update-explanations old-explanations explanation) :situation situation)))))))))) ;;; ---------- ;;; Slightly complex, to minimise storage of :sets (defun update-explanations (old-explanations explanation) (cond ((endp old-explanations) (list explanation)) (t (let ( (old-explanation (first old-explanations)) ) (cond ((not (equal (subseq old-explanation 0 3) (subseq explanation 0 3))) (cons old-explanation (update-explanations (rest old-explanations) explanation))) (t (let ( (expr (fourth explanation)) (old-expr (fourth old-explanation)) ) (cond ; ((equal expr old-expr) old-explanations) ; (tested for earlier) ((km-setp expr) ; EXPR OLD-EPXR (cond ((not (km-setp old-expr)) ; (:set a b) a -> a (cond ((member (desource old-expr) expr :test #'equal) old-explanations) ; DROP explanation (t (cons old-explanation (update-explanations (rest old-explanations) explanation))))) ((subsetp expr old-expr :test #'equal) ; (:set a b) (:set a b c) -> (:set a b) (update-explanations (rest old-explanations) explanation)) ; DROP old-explanation (t (cons old-explanation (update-explanations (rest old-explanations) explanation))))) ((and (km-setp old-expr) ; a (:set a b) -> a (member (desource expr) old-expr :test #'equal)) (update-explanations (rest old-explanations) explanation)) ; DROP old-explanation (t (cons old-explanation (update-explanations (rest old-explanations) explanation))))))))))) ;;; (:set (a Cat (@ Person pet)) (a Dog (@ Person pet))) -> (:set (a Cat) (A Dog) (@ Person pet)) (defun modify-set-explanation (expr) (cond ((km-setp expr) (let* ( (vals (set-to-list expr)) (sources (remove-duplicates (my-mapcan #'sources vals) :test #'equal)) ) (vals-to-val (append (desource vals) sources)))) (t expr))) (defun why (&optional triple (situation (curr-situation))) (cond ((and (null triple) (null *last-answer*)) (km-format t "There are no answers to explain!~%")) ((null triple) (let* ( (slot+frameadd (minimatch *last-question* '#$(the ?slot of ?frameadd))) (slot (first slot+frameadd)) (frameadd (second slot+frameadd)) ) (cond ((not slot+frameadd) (km-format t "Which conclusion are you asking about? (Here, I can't guess). Enter in the form (why (:triple )) e.g. KM> (why (:triple _Car1 parts _Engine1))~%")) (t (let ( (values *last-answer*) (instances (km0 frameadd)) ) ; if *last-answer*, then frames necc. not null (km-format t "I'll assume you're asking me:~%Why ~a = ~a...~%~%" *last-question* values) (mapc #'(lambda (instance) (mapc #'(lambda (value) (why0 `(#$:triple ,instance ,slot ,value) situation)) values)) instances) '#$(t)))))) (t (why0 triple situation)))) #| For example: KM> (why (:triple *MyCar parts _Engine1)) (:triple *MyCar parts _Engine1 [in *Global]) because: ENGLISH: "All cars have engines" JUSTIFICATION: "Engines are required for propulsion" RULE: ([Fpp] a Engine with (parts ((a Spark-Plug [Vehicle2])))) ENGLISH: "A Car" JUSTIFICATION: "I said so" RULE: (a Engine [Car1]) |# (defun why0 (triple &optional (situation (curr-situation))) (let* ( (instance0 (arg1of triple)) (slot (arg2of triple)) (val0 (arg3of triple)) (instance (dereference instance0)) (val (dereference val0)) (isv-explanations (get-explanations instance slot val situation)) ) ; returns two, forward and back (cond ((not (equal instance instance0)) (km-format t "(~a is bound to ~a)~%" instance0 instance))) (cond ((not (equal val val0)) (km-format t "(~a is bound to ~a)~%" val0 val))) (cond ((null isv-explanations) (km-format t "(:triple ~a ~a ~a [in ~a]) because:~% (no explanation available)~%" instance slot val situation)) (t (mapc #'(lambda (isv-explanation) (let ( (i (first isv-explanation)) (s (second isv-explanation)) (v (third isv-explanation)) (explanations (fourth isv-explanation)) ) (km-format t "(:triple ~a ~a ~a [in ~a]) because:~%" i s v situation) (mapc #'(lambda (explanation) (multiple-value-bind (english justification rule path body) (get-comments explanation) (declare (ignore path body)) ; is always included in rule anyway (cond (justification (km-format t " ENTRY TEXT: ~a~%" justification))) (cond (english (km-format t " EXIT TEXT: ~a~%" english))) (km-format t " RULE: ~a~%" (desource0 rule)))) explanations) (terpri))) isv-explanations))) '#$(t))) ;;; Purely for debugging (defun count-explanations (instance &optional slot) (length (remove-if #'(lambda (x) (neq (second x) slot)) (get-all-explanations (dereference instance))))) ;;; ====================================================================== ;;; GETTING THE EXPLANATIONS FOR A TRIPLE ;;; ====================================================================== #| (get-explanations i s v) -> ( (i s v ( ... )) (v invs i ( ... )) ) |# ;;; Note: is **MAPCAN-SAFE** (defun get-explanations (instance slot val &optional (situation (curr-situation))) (remove nil (list (get-explanations0 instance slot val situation) (get-explanations0 val (invert-slot slot) instance situation)))) ;;; Returns structure ( ) where = (expr*) #| OLD (defun get-explanations0 (instance slot val &optional (situation (curr-situation))) (let ( (explanations (remove-duplicates (get-explanations1 instance slot val situation) :test #'equal)) ) (cond (explanations (list instance slot val explanations))))) |# ;;; NEW: instance-of explanations are a special case, retrieved globally. (defun get-explanations0 (instance slot val &optional (situation0 (curr-situation))) (let* ( (situation (case slot (#$instance-of *global-situation*) (t situation0))) (explanations (remove-duplicates (get-explanations1 instance slot val situation) :test #'equal)) ) (cond (explanations (list instance slot val explanations))))) (defun get-explanations1 (instance slot val &optional (situation (curr-situation))) (let* ( (explanations (mapcar #'fourth (remove-if-not #'(lambda (x) (and (eq (second x) slot) (equal (third x) val))) (get-all-explanations instance :situation situation :dereferencep t)))) (projected-from-situation (some #'(lambda (explanation) (cond ((and (listp explanation) (eq (first explanation) '#$projected-from)) (second explanation)))) ; i.e. return the source situation explanations)) ) (cond (projected-from-situation (append (remove-if #'(lambda (explanation) (and (listp explanation) (eq (first explanation) '#$projected-from))) explanations) (get-explanations1 instance slot val projected-from-situation))) (t explanations)))) ;;; ---------- ;;; low-level get/put: ;;; ---------- ;;; 1/11/02: NEW: This now looks *up* into the global situation too, to collect explanations attached to prototypes, ;;; which get deposited in the global situation even if we're in KM situation-mode. ;;; 2/8/02: No, this transfer from global to local is done in the interpreter, and only on a demand-driven basis #| (defun get-all-explanations (instance &key (situation (curr-situation)) dereferencep) (cond ((kb-objectp instance) (let* ( (global-explanations (get instance (curr-situation-facet 'explanation *global-situation*))) (all-explanations (cond ((eq situation *global-situation*) global-explanations) (t (append (get instance (curr-situation-facet 'explanation situation)) global-explanations)))) ) (cond (dereferencep (remove-duplicates (dereference all-explanations) :test #'equal)) (t (remove-duplicates all-explanations :test #'equal))))))) |# ; OLD VERSION (defun get-all-explanations (instance &key (situation (curr-situation)) dereferencep) (cond ((kb-objectp instance) (cond (dereferencep (dereference (get instance (curr-situation-facet 'explanation situation)))) (t (get instance (curr-situation-facet 'explanation situation))))))) (defun put-explanations (instance explanations &key (situation (curr-situation))) (cond ((not (kb-objectp instance)) (report-error 'program-error "Attempt to put an explanation associated with a non-kb-object ~a!~%" instance)) (t (setf (get instance (curr-situation-facet 'explanation situation)) explanations)))) (defun delete-explanations (instance slot val &key (situation (curr-situation))) (cond ((kb-objectp instance) (let* ( (explanations (get-all-explanations instance :situation situation :dereferencep t)) (new-explanations (remove-if #'(lambda (explanation) (and (eq (first explanation) instance) ; necc. true (eq (second explanation) slot) (eq (third explanation) val))) explanations)) ) (put-explanations instance new-explanations))))) ;;; ====================================================================== ;;; UTILTIES - combine independently collected explanation structures ;;; ====================================================================== ;;; Here we merge explanations for the SAME triple, but from DIFFERENT situations, into a single list. ;;; USER(11): (combine-explanations '( (i s v (e1 e2)) (i s2 v2 (e3)) (i s v (e4 e1)) (i s2 v3 (e5)) (i s2 v2 (e3 e4)))) ;;; ((i s v (e2 e4 e1)) (i s2 v2 (e4 e3)) (i s2 v3 (e5))) (defun combine-explanations (explanations) (cond ((endp explanations) nil) (t (let* ( (explanation (first explanations)) (instance (first explanation)) (slot (second explanation)) (value (third explanation)) (exprs (fourth explanation)) (additional-explanations (remove-if-not #'(lambda (additional-explanation) (and (eq (first additional-explanation) instance) (eq (second additional-explanation) slot) (eq (third additional-explanation) value))) (rest explanations))) ) (cond (additional-explanations (cons (list instance slot value (remove-duplicates (apply #'append (cons exprs (mapcar #'fourth additional-explanations))) :test #'equal)) (combine-explanations (set-difference (rest explanations) additional-explanations :test #'equal)))) (t (cons explanation (combine-explanations (rest explanations))))))))) ;;; ====================================================================== ;;; MERGING EXPLANATIONS (AFTER UNIFICATION) ;;; ====================================================================== #| When two instances get unified, we better unify their explanations too! |# ;;; Done when (in fact, immediately after) i1 and i2 are bound together. ;;; This procedure is (only) called by (bind i1 i2) in frame-io.lisp, binding i1 to point to i2. ;;; Urgh - need to scan the entire space of situations. Could make this more efficient by some lazy method, but it'll do for now. (defun merge-explanations (i1 i2) (cond ((and (kb-objectp i1) (kb-objectp i2)) (let* ( (dominant-i (dereference i1)) ; i.e., find the result of (i1 & i2) (recessive-i (first (remove dominant-i (list i1 i2)))) ) (cond ((null recessive-i) (report-error 'user-warning "Null recessive-i encountered in merge-explanations!~%")) (t (mapc #'(lambda (situation) (let ( (recessive-explns (get-all-explanations recessive-i :situation situation)) ) (cond (recessive-explns (let* ( (dominant-explns (get-all-explanations dominant-i :situation situation)) (new-explns (set-difference recessive-explns dominant-explns :test #'equal)) ) (cond (new-explns (put-explanations dominant-i (append dominant-explns new-explns) :situation situation)))))))) (all-active-situations)))))))) ;;; ---------- (defun explain-all (&key include-globalp) (mapc #'(lambda (instance) (mapc #'(lambda (situation) (let* ( (explanations (get-all-explanations instance :situation situation :dereferencep t)) (slots (remove-duplicates (mapcar #'second explanations))) ) (mapc #'(lambda (slot) (let* ( (slot-explanations (remove-if-not #'(lambda (x) (eq (second x) slot)) explanations)) (vals (remove-duplicates (mapcar #'third slot-explanations))) ) (mapc #'(lambda (val) (km-format t "~%(:triple ~a ~a ~a [in ~a]) because:~%~{ ~a~%~}" instance slot val situation #|NEW|# (mapcar #'build-rule (mapcar #'fourth (remove-if-not #'(lambda (x) (eq (third x) val)) slot-explanations))))) vals))) slots))) (cond (include-globalp (all-active-situations)) (t (remove *global-situation* (all-active-situations)))))) (get-all-concepts)) t) #| ;;; [1] For Shaken, *leave* explanations on the prototypes. They should stay. (defun clear-explanations () (let ( (facets (cons 'explanation (mapcar #'(lambda (situation) (curr-situation-facet 'explanation situation)) (all-situations)))) ) (mapc #'(lambda (frame) (cond ((not (protoinstancep frame)) ; [1] (mapc #'(lambda (facet) (remprop frame facet)) facets)))) (get-all-concepts)) t)) ;;; *Leave* the prototype-style explanations, and also for Shaken the ((@ SME entered)) ;;; explanation flag. Everything else can be removed. (defun clear-explanations () (let ( (explanation-facets (cons 'explanation (mapcar #'(lambda (situation) (curr-situation-facet 'explanation situation)) (all-situations))) ) (mapc #'(lambda (frame) (mapc #'(lambda (explanation-facet) (let* ( (old-explanations (get frame explanation-facet)) (new-explanations (remove-if #'(lambda (explanation) (standard-explanation-expr (fourth explanation))) old-explanations)) ) (cond ((not new-explanations) (remprop frame explanation-facet)) ((not (equal old-explanations new-explanations)) (setf (get frame explanation-facet) new-explanations))))) explanation-facets)) (get-all-concepts)) t)) |# ;;; REVISED (AGAIN): Just leave the *GLOBAL* explanations untouched (conditionally) ;;; [1] For Shaken, *leave* explanations on the prototypes. They should stay. (defun clear-explanations (&key clear-globalp) (let ( (facets (mapcar #'(lambda (situation) (curr-situation-facet 'explanation situation)) (cond (clear-globalp (all-situations)) (t (remove *global-situation* (all-situations)))))) ) (mapc #'(lambda (frame) (mapc #'(lambda (facet) (remprop frame facet)) facets)) (get-all-concepts)) t)) (defun explanations () (setq *record-explanations* t)) (defun no-explanations () (setq *record-explanations* nil)) ;;; (a Engine (@ Car parts)) is standard, i.e. from a standard KB frame ;;; (every Car has (parts ((a Engine)))) is not (comes from Shaken), neither is ((@ SME entered)) (defun standard-explanation-expr (expr) (and (listp expr) (neq (first expr) '|every|) (not (sourcep (first expr))))) ;;; ---------- ;;; New function (not used): ;;; [1] For Shaken, *leave* explanations on the prototypes. They should stay. But clober everything else. (defun clear-all-explanations () (let ( (facets (cons 'explanation (mapcar #'(lambda (situation) (curr-situation-facet 'explanation situation)) (all-situations)))) ) (mapc #'(lambda (frame) (cond ((not (protoinstancep frame)) ; [1] (mapc #'(lambda (facet) (remprop frame facet)) facets)))) (get-all-concepts)) t)) ;;; ====================================================================== ;;; OLD METHOD FOR CACHING EXPLANATIONS - remove this, ultimately ;;; ====================================================================== ;;; Handle for clear-cached-explanations (defvar *instances-with-cached-explanations* nil) ;(defun cache-explanation-for (val expr0) ; (declare (ignore val expr0)) ; nil) (defun cache-explanation-for (val expr0) (cond ((and (kb-objectp val) (existential-exprp expr0)) ; Note: still works even if comment tags are in existential-exprp (let ( (explanations (dereference (get val 'cached-explanations))) ; TEMPORARY (expr (decomment expr0)) ) (cond ((not (member val *instances-with-cached-explanations*)) (push val *instances-with-cached-explanations*))) (or (member expr explanations :test #'equal) (km-setf val 'cached-explanations (cons expr explanations))))))) ; TEMPORARY TEST ;;; Disable for automatic system (defun clear-cached-explanations () nil) ; (mapc #'(lambda (instance) ; (km-setf instance 'cached-explanations nil)) ; *instances-with-cached-explanations*) ; (setq *instances-with-cached-explanations* nil)) ;;; Rename to avoid collisions. (defun clear-evaluation-cache () (mapc #'(lambda (instance) (km-setf instance 'cached-explanations nil)) *instances-with-cached-explanations*) (setq *instances-with-cached-explanations* nil)) ;;; RETURNED VALUE IS IRRELEVANT (just NIL / some value) (defun explained-by (instance expr &optional target) (declare (ignore target)) (member (decomment expr) (cached-explanations-for instance) :test #'equal)) (defun cached-explanations-for (instance &optional (situation (curr-situation))) (declare (ignore situation)) (cond ((kb-objectp instance) (dereference (get instance 'cached-explanations))))) ; TEMPORARY ;;; Done when (in fact, immediately after) i1 and i2 are bound together (defun merge-cached-explanations (i1 i2) (cond ((and (kb-objectp i1) (kb-objectp i2)) (let ( (merged-i (dereference i1)) (merged-cached-explanations (remove-duplicates (append (dereference (get i1 'cached-explanations)) (dereference (get i2 'cached-explanations))) :test #'equal)) ) (km-setf merged-i 'cached-explanations merged-cached-explanations))))) ;;; ====================================================================== ;;; ANNOTATE WITH SOURCES ;;; ====================================================================== #| GIVEN (annotate-every-expr '#$ (every Car has (parts ((a Engine with (parts ((a Wheel))))) ((a Seat))) (engine ((the Engine parts of Self)))))) RETURN (every Car has (parts ((a Engine with (parts ((a Wheel [@Car]))) [@Car])) ((a Seat [@Car]))) (engine ((the Engine parts of Self [@Car])))) |# (defun annotate-slotsvals (slotsvals source) (cond ((endp slotsvals) nil) ((null *record-sources*) slotsvals) (t (let ( (slotvals (first slotsvals)) ) (cond ((comment-tagp slotvals) (cons slotvals (annotate-slotsvals (rest slotsvals) source))) (t (let ( (slot (slot-in slotvals)) (vals (vals-in slotvals)) ) `((,slot ,(annotate-vals vals (add-to-source source slot))) ,@(annotate-slotsvals (rest slotsvals) source))))))))) (defun annotate-vals (vals source) (mapcar #'(lambda (val) (annotate-val val source)) vals)) #| EXAMPLES: [1] USER(14): (annotate-val '#$((a x) & (a y)) '(@)) ((a x (@)) & (a y (@))) [1] USER(15): (annotate-val '#$((a x) & (a y) & (a z)) '(@)) ((a x (@)) & (a y (@)) & (a z (@))) [1] USER(16): (annotate-val '#$(((a x)) && ((a y))) '(@)) (((a x (@))) && ((a y (@)))) [1] USER(17): (annotate-val '#$(((a x)) && ((a y)) && ((a z))) '(@)) (((a x (@))) && ((a y) (@)) && ((a z (@)))) [1] USER(18): (annotate-val '#$(a Car with (parts ((a Engine)))) '(@)) (a Car with (parts ((a Engine (@ Car parts)))) (@)) (annotate-val '#$(_Break19 &+ (a Break with (next-event ((the some-associated-break-contact of _Car-Accident8))))) '(@)) |# ;;; Note: for &, &+, and && we DON'T record these expressions as justifications, rather their components. So we break them up here ;;; also during annotation. For other expressions, we DO record them as justifications so DON'T break them up here. ;;; [1a] (a & b & c) -> (annotate-val 'a) (annotate-val '(b & c)) ;;; [1b] (a & b) -> (annotate-val 'a) (annotate-vals '(b)) ;;; [2a] ((a) && (b) && (c)) -> (annotate-vals '(a)) (annotate-val '((b) && (c))) ;;; [2b] ((a) && (b)) -> (annotate-vals '(a)) (annotate-vals '((b))) ;;; [2c] ((a) && (b) [Car1]) -> not allowed!! ;;; [3] It might be safe to put this back at some point, if we want to track where the constraints came from. But for now let's leave it. (defvar *d* 0) ;;; [1] A few exotic forms still exist which are quoted but not class descriptions, e.g.,: ;;; (every Falling-Situation has ;;; (assertions ('(the agent of Self) has (feelings (*Scared))))) (defun annotate-val (val source) (setq *d* (1+ *d*)) (prog1 (cond ((or (not (listp val)) (comment-tagp val) (descriptionp val) ; otherwise (quote foo) becomes (quote foo (@ Source)) which isn't a quotep any more! (quoted-expressionp val) #|NEW|# (and (km-structured-list-valp val) (not (km-triplep val))) (constraint-exprp val)) ; now DON'T source-comment constraints, or else we get duplicates [3]. Hmmm. val) ((and (listp (decomment-top-level val)) (member (first (decomment-top-level val)) '#$(a every))) (let* ( (annotated-every-expr (annotate-every-expr val (add-to-source source (second (decomment-top-level val))))) (every-expr-with-source (attach-source-to-expr annotated-every-expr source)) ) (note-expr-is-in-kb every-expr-with-source) every-expr-with-source)) ((and (listp val) (member (second val) '(& &+))) (cond ((member (fourth val) '(& &+)) `(,(annotate-val (first val) source) ,(second val) ,@(annotate-val (rest (rest val)) source))) ; [1a] (t `(,(annotate-val (first val) source) ,(second val) ,@(annotate-vals (rest (rest val)) source))))) ; [1b] ((and (listp val) (eq (second val) '&&)) (cond ((eq (fourth val) '&&) `(,(annotate-vals (first val) source) ,(second val) ,@(annotate-val (rest (rest val)) source))) ; [2a] ((neq (length val) 3) (report-error 'user-error "Badly formed && expr - should be (exprs && exprs) [no comments allowed!]~% ~a~%" val) val) (t `(,(annotate-vals (first val) source) ,(second val) ,(annotate-vals (third val) source))))) ; [2b] ((intersection val '(& && &+)) val) ; e.g. ([Car1] _Car1 & (a Car)) - actually shouldn't be allowed (t (let ( (expr-with-source (attach-source-to-expr val source)) ) (note-expr-is-in-kb expr-with-source) expr-with-source))) (setq *d* (1- *d*)))) (defun attach-source-to-expr (expr source) (cond ((and (listp expr) (not (some #'sourcep expr))) ; not already commented (append expr (list source))) (t expr))) ;;; expr = '#$(a ...) or '#$(every ...) (defun annotate-every-expr (every-expr &optional source (search-for 'every)) (or (annotate-every-expr0 every-expr source search-for) (report-error 'user-error "annotate-every-expr: Badly structured every/a expression ~a!~%" every-expr))) (defun annotate-every-expr0 (every-expr &optional source (search-for 'every)) (let ( (first-el (first every-expr)) ) (cond ((null every-expr) nil) ((comment-tagp first-el) (cons first-el (annotate-every-expr0 (rest every-expr) source search-for))) ((and (eq search-for 'every) (member first-el '#$(a every))) (cons first-el (annotate-every-expr0 (rest every-expr) source 'class))) ((eq search-for 'class) (let ( (source0 (or source (make-source first-el))) ) (cons first-el (annotate-every-expr0 (rest every-expr) source0 'has)))) ((and (eq search-for 'has) (member first-el '#$(called uniquely-called))) (cons first-el (cons (second every-expr) (annotate-every-expr0 (rest (rest every-expr)) source 'has)))) ((and (eq search-for 'has) (member first-el '#$(has with))) (cons first-el (annotate-slotsvals (rest every-expr) source))) (t (report-error 'user-error "Syntax error! Encountered at ~a~% doing:~% ~a~%" (append '(|...|) every-expr '(|...|)) (stacked-expr (last-el (km-stack)))))))) ;;; ====================================================================== ;;; FOR METRIC COLLECTION ;;; ====================================================================== ;;; I'll leave note-expr-is-encountered here for backward compatibility for ;;; Sunil, until he starts using note-expr-is-in-kb instead. (defun note-expr-is-encountered (expr) (declare (ignore expr))) (defun note-expr-is-in-kb (expr) (note-expr-is-encountered expr)) ;(defun note-expr-is-in-kb (expr) ; (km-format t "Encountered: ~a~%" (build-rule expr))) (defun note-expr-is-used (expr instance slot val situation) (declare (ignore expr instance slot val situation))) ;(defun note-expr-is-used (expr instance slot val situation) ; (declare (ignore instance slot val situation)) ; (km-format t "Used: ~a~%" (build-rule expr))) ;;; ====================================================================== ;;; PLAN B FOR JUSTIFICATIONS ;;; ====================================================================== ;;; This wrapper simply makes sure that the *last-question* and *last-answer* variables ;;; don't get changed by the justification process itself! ;;; e.g., (justify (:triple _Value1 value (:pair 0.45 *molar))) (defun justify (&optional triple-expr &key (situation (curr-situation)) (depth 0) (stream t)) (mapc #'(lambda (string) (format stream string) (terpri stream)) (get-justification :triple triple-expr :situation situation :depth depth :format 'ascii)) '#$(t)) (defun get-justification (&key triple (situation (curr-situation)) (depth 0) (format 'xml)) (let ( (last-question *last-question*) (last-answer *last-answer*) ) (prog1 (flatten (list (cond ((eq format 'xml) (list (format nil "")))) (get-justification0 :triple triple :situation situation :depth depth :format format) (cond ((eq format 'xml) (list (format nil "")))))) (setq *last-question* last-question) (setq *last-answer* last-answer)))) (defun get-justification0 (&key triple (situation (curr-situation)) (tab 0) done-triples (depth 0) (format 'xml)) (cond ((and triple (not (km-triplep triple))) (report-error 'user-error "(justify ~a): Argument should be a triple (justify (:triple ))!" triple)) ((> depth 20) (km-format t "(depth limit for justification reached...no further details below this)~%")) (t (let* ( (triples (compute-triples triple)) (comment-tags ; ([com1] [com2] (triple ((every ..) (every ..))) [com3]) (remove-duplicates (mapcan #'(lambda (atriple) (cond ((member atriple done-triples :test #'equal) nil) (t (let* ( (instance (arg1of atriple)) (slot (arg2of atriple)) (value (arg3of atriple)) (isv-explanations (get-explanations0 instance slot value situation)) ; returns (i s v explanations) (explanations (fourth isv-explanations)) (comment-tags (my-mapcan #'get-comment-tags-recursive explanations)) ) (or comment-tags ; ([com1] [com2]) (list (list atriple (mapcar #'build-rule explanations)))))))) ; ( ( ((every ...) (every ..))) ) triples) :test #'equal)) ) ; (km-format t "DEBUG: Depth ~a: triples ~a justified by ~a~%" depth triples comment-tags) (mapcar #'(lambda (comment-tag) (cond ((comment-tagp comment-tag) (get-comment-justification comment-tag triples :situation situation :tab tab :done-triples (append triples done-triples) :depth depth :format format)) (t (let ( (triple (first comment-tag)) (rules (second comment-tag)) ) (get-rules-justification triple rules :situation situation :tab tab :done-triples (append triples done-triples) :depth depth :format format))))) comment-tags))))) ;;; -------------------- (defun get-comment-justification (comment-tag triples &key (situation (curr-situation)) (tab 0) done-triples (depth 0) (format 'xml)) (let ( (caller (get-comment2 comment-tag 'call)) (exiter (get-comment2 comment-tag 'exit)) (subgoals (get-comment2 comment-tag 'subgoals)) ) (list (cond (*developer-mode* (case format (ascii (list (concat (spaces tab) (km-format nil "(Doing triples: ~a)~%Entry text for ~a:" triples (desource1 comment-tag)))))))) (case format (ascii (concat (spaces tab) (cond (caller (make-sentence (km0 caller :fail-mode 'fail))) (t (km-format nil "(Missing entry text for comment tag ~a)" (desource1 comment-tag)))))) (xml (concat (format nil "") (cond (caller (xmlify (make-sentence (km0 caller :fail-mode 'fail)))) (t (xmlify (km-format nil "(Missing entry text for comment tag ~a)" (desource1 comment-tag))))) ""))) (mapcar #'(lambda (subgoal) (get-justification0 :triple subgoal :situation situation :tab (+ tab 2) :done-triples done-triples :depth (1+ depth) :format format)) (km0 subgoals)) ; was (km ...) ??? (cond (*developer-mode* (case format (ascii (list (concat (spaces tab) (km-format nil "(Doing triples: ~a)~%Exit text for ~a:" triples (desource1 comment-tag)))))))) (case format (ascii (concat (spaces tab) (cond (exiter (km-format nil (make-sentence (km0 exiter)))) ; was (km ...)? (t (km-format nil "(Missing exit text for comment tag ~a)" (desource1 comment-tag)))))) (xml (concat (format nil "") (cond (exiter (xmlify (make-sentence (km0 exiter)))) ; was (km ...)? (t (xmlify (km-format nil "(Missing exit text for comment tag ~a)" (desource1 comment-tag))))) "")))))) ;;; If this is t, then a justification for leaf facts of the form = will be generated. (defvar *justify-leaves* nil) ;;; [1] only show rule(s) in developer mode and for ascii output (defun get-rules-justification (triple rules &key (situation (curr-situation)) (tab 0) done-triples (depth 0) (format 'xml)) (declare (ignore depth done-triples situation)) (cond (*developer-mode* ; [1] (case format (ascii (cond (rules (concat-list `(,*newline-string* ,(spaces tab) ,(km-format nil "subgoal ~a: Computed from:~%" triple) ,@(mapcan #'(lambda (rule) (list (spaces (+ tab 2)) (km-format nil "~a~%" rule))) rules)))) (t (concat-list `(,*newline-string* ,(spaces tab) ,(km-format nil "subgoal ~a: Computed from: (unrecorded!)" triple)))))))) (*justify-leaves* (let ( (instance (arg1of triple)) (slot (arg2of triple)) (value (arg3of triple)) ) (case format (ascii (concat (spaces tab) (format nil "The ~a of ~a = ~a." slot (make-phrase (expand-text instance)) (make-phrase (expand-text value))))) (xml (concat "" (xmlify (format nil "The ~a of ~a = ~a." slot (make-phrase (expand-text instance)) (make-phrase (expand-text value)))) ""))))))) ;;; -------------------- (defun compute-triples (&optional triple0) (cond (triple0 (let* ( (triple (km-unique0 triple0)) (instance (arg1of triple)) (slot (arg2of triple)) (value0 (arg3of triple)) (values (cond ((eq value0 '*) (km0 `#$(the ,SLOT of ,INSTANCE))) ; was (km ...)? (t (val-to-vals value0)))) ) (mapcar #'(lambda (value) (list '#$:triple instance slot value)) values))) ((null *last-answer*) (km-format t "There's no recorded last answer, so I'm not sure what you're asking me to justify!~%")) (t (let* ( (slot+frameadd (minimatch *last-question* '#$(the ?slot of ?frameadd))) (slot (first slot+frameadd)) (frameadd (second slot+frameadd)) ) (cond ((not slot+frameadd) (km-format t "Which conclusion are you asking about? (Here, I can't guess). Enter in the form (justify (:triple ))~%")) (t (let ( (instances (km0 frameadd)) ; if *last-answer*, then frames necc. not null (values *last-answer*) ) (km-format t "I'll assume you're asking me to justify:~% ~a = ~a...~%~%" *last-question* values) (mapcan #'(lambda (instance) (mapcar #'(lambda (value) (list '#$:triple instance slot value)) values)) instances)))))))) ;;; -------------------- ;;; [ideally should be in html.lisp] ;;; INPUT: A string, OUTPUT a string ;;; BEHAVIOR: Change <>& to > < & ;;; (xmlify "") -> "<enter>" #| (defun xmlify (string) (let ( (chars (explode string)) ) (cond ((intersection chars '(#\< #\> #\&)) (concat-list (mapcar #'(lambda (char) (case char (#\< "<") (#\> ">") (#\& "&") (t (string char)))) chars))) (t string)))) |# ;; Rewrite by Carl Shapiro: ;; A space-conscious implementation of XMLIFY. This recasting of ;; XMLIFY should, in the worst case, have the same asymptotic ;; complexity as the previous definition. However, this version will ;; only allocate memory when it must introduce escape sequences into ;; the output string. The overwhelming majority of strings pass ;; through XMLIFY without quoting so this is worth special casing. (defun xml-length (string) (do ((i 0 (1+ i)) (<-count 0) (>-count 0) (&-count 0) (\'-count 0) (\"-count 0) (length (length string))) ((= i length) (+ length (* 3 <-count) (* 3 >-count) (* 4 &-count) (* 5 \'-count) (* 5 \"-count))) (case (char string i) (#\< (incf <-count)) (#\> (incf >-count)) (#\& (incf &-count)) (#\' (incf \'-count)) (#\" (incf \"-count))))) (defun xmlify-internal (string length new-string) (macrolet ((push-string (in-string out-string) `(progn ,@(mapcan #'(lambda (char) `((setf (char ,out-string j) ,char) (incf j))) (coerce in-string 'list))))) (do ((i 0 (1+ i)) (j 0)) ((= i length) new-string) (let ((char (char string i))) (case char (#\< (push-string "<" new-string)) (#\> (push-string ">" new-string)) (#\& (push-string "&" new-string)) (#\' (push-string "'" new-string)) (#\" (push-string """ new-string)) (t (setf (char new-string j) char) (incf j))))))) (defun xmlify (string) (let ((length (length string)) (new-length (xml-length string))) (if (= length new-length) string (xmlify-internal string length (make-string new-length))))) ;;; FILE: kbutils.lisp ;;; File: kbutils.lisp ;;; Author: Peter Clark ;;; Date: Separated out Mar 1995 ;;; Purpose: Basic utilities for KM ;;; ====================================================================== ;;; RECOGNITION OF INSTANCES ;;; ====================================================================== (defun km-null (km-nil) (or (null km-nil) (eq km-nil '#$nil))) ;;; Only recognizes slots whose immediate class is Slot. I don't use this, the ;;; second is better. (defun simple-slotp (slot) (and (symbolp slot) (member slot (get-vals '#$Slot '#$instances :situation *global-situation*)))) (defun slotp (slot) (and (symbolp slot) (intersection (cons '#$Slot (all-subclasses '#$Slot)) (get-vals slot '#$instance-of :situation *global-situation*)))) ;;; Check is' a valid slot (defun slot-objectp (slot) (and (symbolp slot) (not (null slot)))) ;;; Rather crude approximation of a test... (defun pathp (path) (listp path)) ;;; Anything which is considered to be fully evaluated in KM. ;;; EXCEPT it ALSO includes constraints. Argh! ;;; 345, "a", pete, #'print, '(every Dog), (:triple Sue loves John), (<> 23) (defun is-km-term (concept) (or (atom concept) ; includes: 1 'a "12" nil (descriptionp concept) (quoted-expressionp concept) (km-structured-list-valp concept) (km-setp concept) (functionp concept) (constraint-exprp concept))) (defun is-simple-km-term (concept) (or (and (atom concept) ; includes: 1 'a "12" nil (not (member concept *reserved-keywords*))) (descriptionp concept) (functionp concept))) ;;; Anything which is considered to be fully evaluated in KM. ;;; Eventually, should get rid of is-km-term above (defun fully-evaluatedp (concept &key in-structured-exprp) (or (and (atom concept) (neq concept '*)) ; includes: 1 'a "12" nil (and (quoted-expressionp concept) (not (recursive-find 'unquote concept))) (the-class-exprp concept) ; (the-class ...) (and (km-setp concept) ; (:seq (:set 1 2)) is fully evaluated! in-structured-exprp ; (:seq (:set (:set 1 2) 3)) is not! (every #'(lambda (el) (fully-evaluatedp el :in-structured-exprp nil)) (val-to-vals concept))) (and (km-structured-list-valp concept) (every #'(lambda (el) (fully-evaluatedp el :in-structured-exprp t)) (seq-to-list concept))))) ; No!!! if a function and/or constraint has been fully evaluated, then it will be NIL! ; (functionp concept) ; (constraint-exprp concept))) ;; Proves that it's *definitely* a class; however, some other objects may also ;; be classes too (eg. if they haven't been declared). ;;; [1] This is optional, and here purely for efficiency. If we do find instance-of link, then it isn't ;;; a class [ignoring metaclasses for now], so we don't need to bother doing the tests for classp. ;;; If we don't find one, or we miss one because instance-of is a fluent and we don't look for ;;; situation-specific instance-of links, then that's okay, we just proceed on anyway to do the class ;;; tests. Non-classes will fail these tests. (defun classp (class) (or (member class *built-in-classes*) (and (kb-objectp class) (or (get-vals class '#$superclasses :situation *global-situation*) (and (not (get-vals class '#$instance-of :situation *global-situation*)) ; [1] (or (get-vals class '#$instances :situation *global-situation*) (get class 'member-properties) (get class 'member-definition) (get-vals class '#$subclasses :situation *global-situation*))))))) ;;; Proves (just about) it's definitely an instance, though there may ;;; be other instances which fail this test. ;;; [1] Note: We'll miss situation-specific instance-of links, in the case instance-of is a fluent. ;;; I hope that doesn't matter!! (defun is-an-instance (instance) (or (anonymous-instancep instance) (numberp instance) (stringp instance) (functionp instance) (descriptionp instance) (km-structured-list-valp instance) (and ; (is-km-term instance) bug! (kb-objectp instance) (or (get-vals instance '#$instance-of :facet 'own-properties :situation *global-situation*) ; [1] (get-vals instance '#$instance-of :facet 'own-definition :situation *global-situation*))))) ;; Time consuming! ; (not (classp instance))))) ; just in case #$instance-of is a class-metaclass relation ;;; _car12 (defun anonymous-instancep (instance0) (let ( (instance (dereference instance0)) ) (and (symbolp instance) (char= (first-char (symbol-name instance)) *var-marker-char*)))) ;;; 345, "a", pete, #'print (defun named-instancep (instance) (not (anonymous-instancep instance))) ;;; Not used any more (defun fluent-instancep (instance) (declare (ignore instance)) nil) ;(defun fluent-instancep (instance) ; (and (symbolp instance) ; (starts-with (symbol-name instance) *fluent-instance-marker-string*))) ; Not used any more ;(defun remove-fluent-instances (instances) (remove-if #'fluent-instancep instances)) ;;; (recursive-remove-fluent-instances '#$((_SomePerson813) && ((some Person)))) ;;; -> ((nil) && ((|some| |Person|))) ;;; Dec00 Revised to be -> (() && ((|some| |Person|))) - yikes, but becomes (&& ((some Person)))! ;;; Patched Jan01 - we simply splice out these things. ;;; BUT still a bug: (_Some23 & (a Car)) -> (& (a Car)), but should be just (a Car). Need to be more sophisticated. ;;; Fixed Feb01 ;;; Apr02: Still bug: (:args nil _Car1) -> (:args _Car1) ;(defun recursive-remove-fluent-instances (instances) ; (cond ((&-exprp instances) ; (vals-to-&-expr (recursive-remove-fluent-instances (&-expr-to-vals instances)))) ; ((&&-exprp instances) ; (vals-to-val (valsets-to-&&-exprs (recursive-remove-fluent-instances (&&-exprs-to-valsets (val-to-vals instances)))))) ; ((listp instances) ; (remove nil (mapcar #'recursive-remove-fluent-instances instances))) ; ((fluent-instancep instances) nil) ; (t instances))) ;;; Objects which will have frames in the KB about them, e.g., *Pete, _Car12 ;; Rewrite by Carl Shapiro: ;; An optimized KB-OBJECTP definition. Profiling has shown that the ;; out-of-line call to MEMBER is a huge performance drain on this ;; frequently invoked predicate. Since the list of test subjects is ;; small, we can inline the comparisons by rewriting MEMBER in terms ;; of CASE. (defun kb-objectp (instance) (and instance (symbolp instance) (not (user-commentp instance)) ;OLD (not (member instance '#$(nil NIL :seq :bag :args :triple :pair :function))))) ; later: allow stuff on 't'! (case instance (#$(nil :seq :bag :args :triple :pair :function) nil) ; later: allow stuff on 't'! (t t)))) ;;; A *structured value* is a CONTAINER of values, collected together. It *doesn't* ;;; include quoted expressions. ;;; NOTE a SET isn't a structured value, it's a set of values!! (defun km-structured-list-valp (val) (and (listp val) (member (first val) '#$(:seq :bag :args :triple :pair :function)))) (defun km-functionp (val) (and (listp val) (eq (first val) '#$:function))) (defun km-triplep (triple) (and (listp triple) (eq (first triple) #$:triple) (= (length (decomment triple)) 4))) ;;; recognize sequences eg. (:seq a b c) (defun km-seqp (seq) (and (listp seq) (eq (first seq) '#$:seq))) (defun km-bagp (bag) (and (listp bag) (eq (first bag) '#$:bag))) (defun km-pairp (seq) (and (listp seq) (eq (first seq) '#$:pair))) ;;; '(:seq a b) -> (a b) (defun bag-to-list (bag) (rest bag)) (defun seq-to-list (seq) (rest seq)) (defun set-to-list (set) (rest set)) (defun pair-to-list (pair) (rest pair)) ;;; ---------- ;;; NOTE: doesn't remove dups ;;; Input: a LIST of values. Returns a LIST of values. ;;; NOTE: (flatten-sets '((:set a b))) is OK ;;; (flatten-sets '(a b)) is OK ;;; (flatten-sets '(:set a b)) is NOT OK ;;; (flatten-sets 'b) is NOT OK ;;; (flatten-sets '#$((:set a b (:set c (:set d e)) f (:set g h)))) -> (a b c d e f g h) (defun flatten-sets (vals) (my-mapcan #'flatten-set vals)) ;;; Given a SINGLE value, which might be a set, return either ;;; (1) a singleton list of that one value, if that value is NOT a set. ;;; (2) a list of the values in that set, if that value IS a set. (defun flatten-set (set) (cond ((km-setp set) (my-mapcan #'flatten-set (set-to-list set))) (t (list set)))) ;;; ---------- ;;; (km-varp ?x) -> t (defun km-varp (var) (and (symbolp var) (char= (first-char (symbol-name var)) #\?))) ;;; recognize a single expression as a set eg. (:set a b c) (defun km-setp (set) (and (listp set) (eq (first set) '#$:set))) ;;; e.g. (a Cat called "fido") (defun km-tagp (tag) (or (and (atom tag) (not (null tag))) (constraint-exprp tag) (and (km-setp tag) (every #'km-tagp (set-to-list tag))))) (defun km-argsp (args) (and (listp args) (eq (first args) '#$:args))) (defun km-defaultp (expr) (and (listp expr) (eq (first expr) '#$:default))) ;;; ---------------------------------------- (defun comparison-operator (slot) (or (member slot *inequality-relations*) (member slot *equality-relations*) (assoc slot *user-defined-infix-operators*))) ;;; ---------------------------------------- (defun &-exprp (expr) (and (listp expr) (member (second expr) '(& &! &+ ==)))) ; but not &? &+? (defun &&-exprp (expr) (and (listp expr) (member (second expr) '(&& &&! ===)))) ;;; ---------------------------------------- ;;; Accessing (:args ...) structures: (defun arg1of (arg-structure) (second arg-structure)) ; (:args a b) -> a (defun arg2of (arg-structure) (third arg-structure)) ; (:args a b) -> b (defun arg3of (arg-structure) (fourth arg-structure)) ; (:args a b) -> b ;;; [1] NOTE: avoids numeric and set testing ;;; 7/28/04: At some risk, replaced remove-duplicates with (destructive) delete-duplicates (which is 50% faster). ;;; This change relies on the fact that (dereference ...) will create a copy of instances, which is necessarily a list. (defun remove-dup-instances (instances) (delete-duplicates (dereference instances) :test #'km-equal :from-end t)) #| 7/28/04 - playing with fire!! Let's not do this. ;;; delete-duplicates is twice as fast as remove-duplicates. ;;; It relies on the fact that (dereference ...) will create a copy of instances, which is necessarily a list... dangerous!! (defun remove-dup-atomic-instances (instances) (delete-duplicates (dereference instances) :test #'km-equal :from-end t)) |# (defun remove-dup-atomic-instances (instances) (remove-dup-instances instances)) ;;; ====================================================================== ;;; DEFINITION OF EQUALITY ;;; ====================================================================== ;;; "equal" isn't quite what we want, as we *don't* remove duplicate numeric entries. Is this a bad idea?? ;;; March 2001 - yes, use a bag if you want duplicate numbers ;;; I suspect in other places in the code, duplicate numbers are removed as I've used equal not km-equal (eg. during lazy unify). ;;; This compares SINGLE VALUES. Note: We DON'T expect to be given the test (:set 1) = 1, (:set (:seq 1)) = (:seq 1) ;(defun km-equal (i1 i2) ; (and (equal i1 i2) (not (numberp i1)) (not (existential-exprp i1)))) ; (and (equal i1 i2) (not (existential-exprp i1)))) ;;; ---------------------------------------- #| [1] TOLERANCE: Desired behavior: 0.00001 /= 0.00002 4.99999 = 5.00000 499999 /= 500000 For large numbers, it is absolute, i.e., +/- 0.0001. For small numbers, it is fractional, i.e., +/- 0.01% Behavior: x = y if x = y +/- (0.0001 or 0.01% of max(x,y), whichever is smaller) |# ;; Rewrite by Carl Shapiro: ;; An optimized KM-EQUAL definition. The comparisons against atomic ;; types now occupy the beginning of the COND clause. This saves us ;; the out-of-line call to EQUAL and its expensive general equality ;; test. Profiling has shown that most comparisons are done against ;; variables of an atomic type (symbols, mostly). The added cost of ;; explicity codifying the EQ tests done interally by EQUAL should be ;; lost in the noise during aggregate (list) comparisons. ;; [2] 11/1/04 - moved [2] up, as (km-equal NIL NIL) was incorrectly failing (defun km-equal (i1 i2) (cond ;; Fast, atomic type comparisons are done first. ((eq i1 i2)) ; [2] ((null i1) (eq i2 '#$nil)) ((null i2) (eq i1 '#$nil)) ; ((or (symbolp i1) (symbolp i2)) (eq i1 i2)) ; [2] ((and (numberp i1) (numberp i2) *tolerance*) (<= (abs (- i1 i2)) (min *tolerance* (* (max (abs i1) (abs i2)) *tolerance*)))) ; [1] ;; The slow, aggregate type comparisons follow. ((and (equal i1 i2) (not (existential-exprp i1)))) ((and (km-setp i1) (km-setp i2)) (km-set-equal i1 i2)) ((and (km-bagp i1) (km-bagp i2)) (km-bag-equal i1 i2)) ((and (km-seqp i1) (km-seqp i2)) (km-seq-equal i1 i2)) ((and (km-pairp i1) (km-pairp i2)) (km-seq-equal i1 i2)))) (defun km-set-equal (set1 set2) (not (set-exclusive-or set1 set2 :test #'km-equal))) ;;; ---------- (defun km-bag-equal (bag1 bag2) (and (eq (length bag1) (length bag2)) (km-bag-equal0 bag1 bag2))) (defun km-bag-equal0 (bag1 bag2) (cond ((equal bag1 bag2)) ; equal is subset of km-equal ((member (first bag1) bag2 :test #'km-equal) (km-bag-equal0 (rest bag1) (remove (first bag1) bag2 :test #'km-equal :count 1))))) ;;; ---------- (defun km-seq-equal (seq1 seq2) (and (eq (length seq1) (length seq2)) (km-seq-equal0 seq1 seq2))) (defun km-seq-equal0 (seq1 seq2) (cond ((equal seq1 seq2)) ((and (km-equal (first seq1) (first seq2)) (km-seq-equal0 (rest seq1) (rest seq2)))))) ;;; ====================================================================== ; Old def -- definition?? ;(defun km-equal (i1 i2) ; (and (equal i1 i2) ; (or (symbolp i1) ; (kb-objectp i1) ERROR! should remove dups for non-kb-objects t f! ; (km-structured-list-valp i1)))) ;;; Only expressions of the form (a ... [with ...]) return a situation-invariant answer. ;;; This is used to block passing these *expressions* between situations, to avoid redundant computation ;;; of identities. The result of their evaluation *will* be passed between situations, still, of course. (defun situation-invariant-exprp (expr) (and (listp expr) (eq (first expr) '#$a))) (defun constraint-exprp (expr) (or (val-constraint-exprp expr) (set-constraint-exprp expr))) (defun val-constraint-exprp (expr) (and (listp expr) (member (first expr) *val-constraint-keywords*))) (defun set-constraint-exprp (expr) (and (listp expr) (member (first expr) *set-constraint-keywords*))) ;;; Experimental (defun sometimes-exprp (expr) (and (listp expr) (eq (first expr) '#$sometimes))) ;;; Returns non-nil if expr contains (at least) one of symbols. (defun contains-some-existential-exprs (exprs) (contains-some exprs '#$(a an some))) ;(defun existential-exprp (expr) ; (and (listp expr) (member (first expr) '#$(a some)))) ;;; NB "an" is NOT considered an existential structure, it needs preprocessing by the interpreter. (defun existential-exprp (expr) (and (listp expr) (or (member (first expr) '#$(a some)) (and (comment-tagp (first expr)) ; allow ([Car1] a Big Engine) (existential-exprp (rest expr)))))) ;;; (some ) (defun fluent-instance-exprp (expr) (and (listp expr) (eq (first expr) '#$some))) ;;; ====================================================================== (defun val-to-vals (val) (cond ((null val) nil) ((eq val '#$nil) nil) ((and (listp val) (eq (first val) '#$:set)) (rest val)) (t (list val)))) ; val must be an atom (eg. _Car23) or a single expression, eg. (a Car) ; so we simply wrap it in a list (_Car23), or ((a Car)) (defun vals-to-val (vals) (cond ((null vals) nil) ((singletonp vals) (first vals)) ((listp vals) (cons '#$:set vals)) (t (report-error 'user-error "Expecting a set of values, but just found a single value ~a!~%" vals)))) ;;; ====================================================================== ;;; val-sets-to-expr ;;; ====================================================================== ;;; GIVEN a LIST of SETS of VALS (ie. some val-sets) ;;; RETURNS a *SINGLE* expression which KM can evaluate, denoting the combination. ;;; single-valuedp = *: (val-sets-to-expr '((a)) ) -> a ;;; single-valuedp = *: (val-sets-to-expr '((a b)) ) -> (:set a b) ;;; single-valuedp = T: (val-sets-to-expr '((a) (b) (c)) 't) -> (a & b & c) ;;; single-valuedp = T: (val-sets-to-expr '((a b) (c)) 't) -> ERROR! and (a & c) ;;; single-valuedp = NIL: (val-sets-to-expr '((a b) (b) (c d))) -> ((a b) && (b) && (c d)) (defun val-sets-to-expr (exprs0 &optional single-valuedp) (let ( (exprs (remove-duplicates (remove nil exprs0) :test #'equal :from-end t)) ) (cond ((null exprs) nil) ((singletonp exprs) (vals-to-val (first exprs))) (t (val-sets-to-expr0 exprs single-valuedp))))) (defun val-sets-to-expr0 (exprs &optional single-valuedp) (cond ((endp exprs) nil) ((null (first exprs)) (val-sets-to-expr0 (rest exprs) single-valuedp)) ((not (listp (first exprs))) (report-error 'user-error "val-sets-to-expr0: Single value ~a found where list of values expected! Listifying it...~%" (first exprs)) (val-sets-to-expr0 (cons (list (first exprs)) (rest exprs)))) (t (let ( (first-item (cond (single-valuedp (cond ((not (singletonp (first exprs))) ; error! (a b) found (km-trace 'comment "Multiple values ~a found for single-valued slot!~%Assuming they should be unified...~%" (first exprs)) (vals-to-&-expr (first exprs))) ; (a b) -> (a & b) (single-valued slot) (t (first (first exprs))))) ; (a) -> a (single-valued slot) (t (first exprs)))) ; (a b c) -> (a b c) (multivalued slot) (linked-rest (val-sets-to-expr0 (rest exprs) single-valuedp)) (joiner (cond (single-valuedp '&) (t '&&))) ) (cond ((null linked-rest) (list first-item)) (t (cons first-item (cons joiner linked-rest)))))))) ;;; ====================================================================== ;;; FLATTENING '&' AND '&&' EXPRESSIONS ;;; ====================================================================== ;;; vals should be either nil, or a SINGLETON list of one KM expression eg. (a), ((a & b)). ;;; RETURNS the component values as a list, eg. (a), (a b) (defun un-andify (vals) (cond ((null vals) nil) ((singletonp vals) (&-expr-to-vals (first vals))) (t (km-trace 'comment "Multiple values ~a found for single-valued slot!~%Assuming they should be unified...~%" vals) (my-mapcan #'&-expr-to-vals vals)))) ;;; (&-expr-to-vals '(x & y & z)) -> (x y z) ;;; (&-expr-to-vals '((a Car) & (a Dog))) -> ((a Car) (a Dog))) ;;; (&-expr-to-vals '(a Car)) -> ((a Car)) <- NB listify ;;; (&-expr-to-vals 'x) -> (x) <- NB listify ;;; (&-expr-to-vals '((a & (b & d)) & (e & (f & g)))) -> (a b c d e f g) <- NB nested ;;; (&-expr-to-vals '(x & y z)) <- ERROR! (defun &-expr-to-vals (expr) (cond ((null expr) nil) ((&-exprp expr) (cond (;(eq (fourth expr) '&) ; (x & y & ...) (val-unification-operator (fourth expr)) (&-expr-to-vals `(,(first expr) ,(fourth expr) ,(rest (rest expr))))) (t (cond ((neq (length expr) 3) (report-error 'user-error "Illegally formed expression ~a encountered!~%Continuing with just ~a...~%" expr (subseq expr 0 3)))) (append (&-expr-to-vals (first expr)) (&-expr-to-vals (third expr)))))) (t (list expr)))) ;;; nil -> nil, (a) -> a, (a b c) -> (a & b & c) (defun vals-to-&-expr (vals &key (joiner '&) (first-time-through t)) (cond ((null vals) nil) ((singletonp vals) (cond (first-time-through (first vals)) (t vals))) (t `(,(first vals) ,joiner ,@(vals-to-&-expr (rest vals) :joiner joiner :first-time-through nil))))) ;;; (valsets-to-&&-exprs '((a b) (c d) (e f))) -> (((a b) && (c d) && (e f))) ;;; NOTE! (valsets-to-&&-exprs '((a b)) -> (a b) (defun valsets-to-&&-exprs (valsets) (cond ((null valsets) nil) ((singletonp valsets) (first valsets)) (t (list (vals-to-&-expr valsets :joiner '&&))))) ;;; (&&-exprs-to-valsets '(a b)) -> ((a b)) ;;; (&&-exprs-to-valsets '(((a b) && (c d)))) -> ((a b) (c d)) ;;; (&&-exprs-to-valsets '(((a b) && (c d) && (e f)))) -> ((a b) (c d) (e f)) ;;; (&&-exprs-to-valsets '(((a b) && (((c d) && (e f)))))) -> ((a b) (c d) (e f)) ;;; (&&-exprs-to-valsets '(((((a b) && (c d))) && (e f)))) -> ((a b) (c d) (e f)) ;;; (&&-exprs-to-valsets '(a ((a b) && (c d)))) -> ((a ((a b) && (c d)))) (defun &&-exprs-to-valsets (exprs) (cond ((singletonp exprs) (let ( (expr (first exprs)) ) (cond ((and (listp expr) (set-unification-operator (second expr))) (append (&&-exprs-to-valsets (first expr)) (cond ((triplep expr) (&&-exprs-to-valsets (third expr))) (t (&&-exprs-to-valsets (list (rest (rest expr)))))))) (t (list exprs))))) (t (list exprs)))) ;;; ---------------------------------------- ;;; Digging out the constraints... ;;; ---------------------------------------- #| Call with a SINGLE EXPRESSION. It will further call itself with either with (a) a single value, with :joiner = & or (b) a list of values, with :joiner = && RETURNS the constraints embedded in the expression. Shown below, where numbers denote things passing constraint-exprp test. A test procedure is in find-constraints.lisp, a multivalued version of the below. EXPRESSION ==> CONSTRAINTS (a & 1 & 2) (1 2) (a & 1 & 2 & (3 & d)) (1 2 3) (a & 1 & 2 & (3 & (d & 4))) (1 2 3 4) ((a 1) && (b 2)) (1 2) ((a 1 b) && (c 2 d)) (1 2) ((a 1 b) && (c 2 d) && (e f)) (1 2) ((a 1 b) && (((c 2 d) && (e f)))) (1 2) ((a 1 b) && (((c 2 d) && (e f 3)))) (1 2 3) ((a 1 b) && (((c 2 d) && (e f 3) && (4)))) (1 2 3 4) a nil ((((a 1) && (b 2)) d e) && (c 3)) (3) ((((a 1) && (b 2)) d 4) && (c 3)) (4 3) ((((a 1) && (b 2))) && (c 3)) (1 2 3) |# ;;; [1] May 2001 - aggressive decommenting of constraints (defun find-constraints-in-exprs (exprs) ; (find-constraints exprs 'plural)) (decomment (find-exprs exprs :expr-type 'constraint :plurality 'plural))) ; [1] ;;; *MAPCAN-SAFE* ;;; a, (a & b) (as && bs) plurality = singular. ;;; (a) plurality = plural (1 member). ;;; (a b) plurality = plural (2 members). ;;; ((a b)) plurality = plural (1 member). ;;; Note: (must-be-a Car) plurality = singular is a constraint, ;;; but (must-be-a Car) plurality = plural isn't a constraint, it's two values "must-be-a" and "Car". ;;; Result is newly created list, so it is safe to mapcan over it. ;;; [1] (find-constraints '#$(_Shut-Out16 (((<> _Be-Shut-Out5)) && ((<> _Be-Shut-Out15)))) 'plural) ;;; => ((<> |_Be-Shut-Out5|) (<> |_Be-Shut-Out15|)) ;;; May 2001 - GENERALIZE THIS to find expressions of any type (defun find-exprs (expr &key expr-type (plurality 'singular)) ; ie. a single expr given (cond ((null expr) nil) ((and (listp expr) (unification-operator (second expr))) (cond ((>= (length expr) 4) (cond ((not (unification-operator (fourth expr))) (report-error 'user-error "Badly formed unification expression ~a!~%" expr))) (find-exprs `(,(first expr) ,(second expr) ,(rest (rest expr))) :expr-type expr-type :plurality 'singular)) ; (a & b & c) -> (a & (b & c)) (t (let ( (next-plurality (cond (; (eq (second expr) '&) 'singular) ; & takes a value as arg, && takes a list of values (val-unification-operator (second expr)) 'singular) (t 'plural))) ) (append (find-exprs (first expr) :expr-type expr-type :plurality next-plurality) (find-exprs (third expr) :expr-type expr-type :plurality next-plurality)))))) ((and (eq plurality 'singular) ; & -> a single value/expr is given (case expr-type (constraint (constraint-exprp expr)) (non-constraint (not (constraint-exprp expr))) (any t) ; (override (overridep expr)) (t (report-error 'program-error "find-exprs: Unrecognized expr-type `~a'!~%" expr-type)))) (list expr)) ((and (eq plurality 'plural) ; special case - allowed to recurse if only one member (singletonp expr)) (find-exprs (first expr) :expr-type expr-type :plurality 'singular)) ((and (eq plurality 'plural) ; && -> a list of values is given (listp expr)) (mapcan #'(lambda (subexpr) (find-exprs subexpr :expr-type expr-type :plurality 'singular)) expr)))) ; [1] ;;; ---------- ;;; This is to remove constraints from a POST-EVALUATED expression ONLY. A post-evaluated expression is ;;; single-valued slots: either a single value, or a single value &'ed with constraints ;;; eg. (1) -> (1), ((a & (must-be x))) -> (a) ;;; multivalued slots: a list of values + constraints eg. (1 2 (must-be y)) -> (1 2) ;;; RETURNS: A list of values ;;; (remove-constraints '#$((a & (must-be-a c)))) -> '#$(a) ;;; (remove-constraints '#$(a b (must-be-a c))) -> '#$(a b) (defun remove-constraints (vals) (cond ((not *are-some-constraints*) vals) ((null vals) nil) ((and (singletonp vals) (listp (first vals)) ; (eq (second (first vals)) '&)) ; single-valued-slot format ((a & (must-be b))) (val-unification-operator (second (first vals)))) (remove-if #'constraint-exprp (&-expr-to-vals (first vals)))) (t (remove-if #'constraint-exprp vals)))) (defun extract-constraints (vals) (cond ((not *are-some-constraints*) nil) ((null vals) nil) ((and (singletonp vals) (listp (first vals)) ; (eq (second (first vals)) '&)) ; single-valued-slot format ((a & (must-be b))) (val-unification-operator (second (first vals)))) (remove-if-not #'constraint-exprp (&-expr-to-vals (first vals)))) (t (remove-if-not #'constraint-exprp vals)))) ;;; ====================================================================== ;;; RECOGNIZING DESCRIPTIONS ;;; ====================================================================== (defun quoted-expressionp (expr) (quotep expr)) (defun quoted-descriptionp (expr) (and (quotep expr) (listp (unquote expr)) (eq (first (unquote expr)) '#$every))) ;;; '(every ...) or (the-class ...) (defun descriptionp (expr) (or (quoted-descriptionp expr) (the-class-exprp expr))) (defun the-class-exprp (expr) (and (listp expr) (eq (first expr) '#$the-class))) ;;; '(a Cat) -> t (defun instance-descriptionp (expr &key (fail-mode 'fail)) (cond ((and (quoted-expressionp expr) (listp (unquote expr))) (cond ((existential-exprp (unquote expr))) ((km-triplep (unquote expr))) ; <--- Bit of a fudge here: subsumes also handles triples as if they were descriptions ((eq fail-mode 'error) (cond ((eq (first (unquote expr)) '#$every) ; '(every Cat) -> ERROR (report-error 'user-error "Expecting an instance description '(a ...), but found a class~%description ~a instead!~%" expr)) (t (report-error 'user-error "Expecting an instance description '(a ...), but found~%description ~a instead!~%" expr)))))) ((eq fail-mode 'error) (report-error 'user-error "Expecting a quoted instance description '(a ...), but found an unquoted~%expression ~a instead!~%" expr)))) ;;; Returns the class + slotsvals, if expr is indeed a class description (defun class-descriptionp (expr &key (fail-mode 'fail)) (cond ((quoted-descriptionp expr) (list (second (unquote expr)) (rest (rest (rest (unquote expr)))))) ((and (listp expr) (eq (first expr) '#$the-class)) (let ( (class (second expr)) (slotsvals (cond ((eq (third expr) '#$called) `((#$called ,(list (fourth expr))) ,@(rest (rest (rest (rest (rest expr))))))) (t (rest (rest (rest expr)))))) ) (list class slotsvals))) ((and (eq fail-mode 'error) (quotep expr) (eq (first (unquote expr)) '#$a)) ; '(every Cat) -> ERROR (report-error 'user-error "Expecting a class description '(every ...), but found an instance~%description ~a instead!~%" expr)) ((eq fail-mode 'error) (report-error 'user-error "Expecting a class description (the-class ...) or '(every ...), but found a different~%expression ~a instead!~%" expr)))) (defun class-description-to-class+slotsvals (expr &key (fail-mode 'fail)) (class-descriptionp expr :fail-mode fail-mode)) #| Note: slotp using isa causes recursion: edit ed edit the source for the current stack frame EOF either :pop or :exit error err print the last error message evalmode eval examine or set evaluation mode exit ex exit and return to the shell find fin find the stack frame calling the function `func' focus fo focus the top level on a process frame fr print info about current frame [type return for next page or an integer to set the page length] function fun print and set * to the function object of this frame help he print this text -- use `:help cmd-name' for more info hide hid hide functions or types of stack frames history his print the most recently typed user inputs inspect i inspect a lisp object kill ki kill a process ld load one or more files ldb Turn on/off low-level debugging local loc print the value of a local (interpreted or compiled) variable macroexpand ma call macroexpand on the argument, and pretty print it optimize opt interactively set compiler optimizations package pa go into a package pop pop up `n' (default 1) break levels popd cd into the previous entry on directory stack printer-variables pri Interactively set printer control variables processes pro List all processes prt pop-and-retry the last expression which caused an error pushd pu cd to a directory, pushing the directory on to the stack pwd pw print the process current working directory reset res return to the top-most break level restart rest restart the function in the current frame return ret return values from the current frame [type return for next page or an integer to set the page length] scont sc step `n' forms before stopping set-local set-l set the value of a local variable sover so eval the current step form, with stepping turned off step st turn on or off stepping top to Zoom at the newest frame on the stack. trace tr trace the function arguments unarrest unar revoke the debugging arrest reason on a process unhide unh unhide functions or types of stack frames untrace untr stop tracing some or all functions up move up `n' (default 1) stack frames who-binds who-b find bindings of a variable who-calls who-c find callers of a function who-references who-r find references to a variable who-sets who-s find setters of a variable who-uses who-u find references, bindings and settings of a variable zoom zo print the runtime stack [1c] USER(11): :zo 30 Error: &key list isn't even. [condition type: program-error] Restart actions (select using :continue): 0: continue computation 1: Return to Top Level (an "abort" restart) [2] USER(12): :pop Previous error: Stack overflow (signal 1000) If continued, continue computation [1c] USER(12): :zo :depth 30 Error: Illegal keyword given: :depth. [condition type: program-error] Restart actions (select using :continue): 0: continue computation 1: Return to Top Level (an "abort" restart) [2] USER(13): :pop Previous error: Stack overflow (signal 1000) If continued, continue computation [1c] USER(13): :zo :count 50 Evaluation stack: ... 10 more (possibly invisible) newer frames ... ((:internal immediate-classes0 0) |*Global|) (mapcar # (|*Global|)) (my-mapcan # (|*Global|)) (immediate-classes0 |Box| |_Situation1|) (immediate-classes |Box|) (instance-of |Box| |Slot|) (isa |Box| |Slot|) (slotp |Box|) (stackable |Box|) (add-to-stack |Box|) (put-vals |Box| |instance-of| ...) (immediate-classes0 |Box| |_Situation1|) (immediate-classes |Box|) (instance-of |Box| |Slot|) (isa |Box| |Slot|) (slotp |Box|) (stackable |Box|) (add-to-stack |Box|) (put-vals |Box| |instance-of| ...) (immediate-classes0 |Box| |_Situation1|) (immediate-classes |Box|) (instance-of |Box| |Slot|) (isa |Box| |Slot|) (slotp |Box|) (stackable |Box|) ->(add-to-stack |Box|) (put-vals |Box| |instance-of| ...) (immediate-classes0 |Box| |_Situation1|) (immediate-classes |Box|) (instance-of |Box| |Slot|) (isa |Box| |Slot|) (slotp |Box|) (stackable |Box|) |# ;;; FILE: stack.lisp ;;; File: stack.lisp ;;; Author: Peter Clark ;;; Date: 1994 ;;; Purpose: Maintenance of the stack (defvar *obj-stack* ()) (defvar *km-stack* ()) ;;; ---------- ;;; synonym (defun new-context () ; (km-setq '*all-active-situations* nil) ; New! (clear-obj-stack)) (defun clear-km-stack () (setq *km-stack* nil)) ;(defun clear-obj-stack () (make-transaction '(setq *obj-stack* nil))) (defun clear-obj-stack () (km-setq '*obj-stack* nil)) (defun km-stack () *km-stack*) (defun top-level-goal () (first (last-el *km-stack*))) ;;; [1] Tiny bit slower, but allows spotting looping earlier (net loss timewise, gain inference wise) ;;; ALSO: See looping-on later (defun km-push (expr &optional id) (setq *km-stack* (cons (item-to-stack (decomment expr) id) *km-stack*))) ; [1] ;;; e.g. (km-push-comment '(comment "Classifying ~a..." #$_Car23)) (defun km-push-comment (comment) (setq *km-stack* (cons comment *km-stack*))) (defun km-pop () (prog1 (first *km-stack*) (setq *km-stack* (rest *km-stack*)))) ;;; Can now add comments to the stack (defun stacked-commentp (item) (eq (first item) 'comment)) ;;; e.g. (print-stacked-comment '(comment "Classifying ~a..." #$_Car23)) (defun print-stacked-comment (comment &optional (stream t)) (apply #'km-format (cons stream (rest comment)))) ;;; ====================================================================== ;;; THE EXPRESSION STACK ;;; ====================================================================== #| Looping problem with disjuncts!!! I failed to fix this Suppose we ask X, and X <- Y or Z, and Y <- X. KM will give up on Y, even if Z can compute it. This is a problem, because then Y might be projected from the previous situation! The problem is that KM's triggers too easily. If, when calculating X, I hit a non-deterministic choice-point and take branch 1 of 2 (say), then hit a call to calculate X again, KM *should* continue, but this time take branch 2 of 2 at the same choice-point. Instead, KM just gives up. A fix would be to (i) identify non-deterministic choice-points (ii) mark them in the stack and (iii) steer as above. We can do this with a REVISED LOOPING CHECK: IF the current call C' matches an earlier call C THEN abort UNLESS there is an "or" clause between C and C'. #$or clauses: Select an option which ISN'T in the current stack (see interpreter.lisp). |# ;;; [1] Tiny bit slower, but allows spotting looping earlier (net loss timewise, gain inference wise) ;;; ALSO: See km-push, earlier (defun looping-on (expr) (on-km-stackp (decomment expr))) ; [1] (defun on-km-stackp (expr) (member (item-to-stack expr) *km-stack* :test #'stack-equal)) ; more efficient ;;; Note: non-canonicalized expressions (element 3 of itemN) are NOT compared (defun stack-equal (item1 item2) (and (equal (first item1) (first item2)) ; match canonicalized expressions (eq (second item1) (second item2)))) ; match situation #| Here we canonicalize the item for stacking. Must add a note of the current situation. [1] for &, the canonical form *isn't* situation-dependent as we unify in all situations, hence returns 2nd element = *global-situation* rather than (curr-situation) |# (defun item-to-stack (expr &optional id) `(,(canonicalize expr) ,(cond ((and (listp expr) (unification-operator (second expr))) '|all situations|) ; better - trace is confusing otherwise! (t (curr-situation))) ,expr ,@(cond (id (list id))))) ;;; The three parts of an item on the stack (defun stacked-canonical-expr (stacked-item) (first stacked-item)) (defun stacked-situation (stacked-item) (second stacked-item)) (defun stacked-expr (stacked-item) (third stacked-item)) (defun stacked-id (stacked-item) (fourth stacked-item)) ;;; [2] Must canonicalize the two forms of paths: ;;; (_Car23 parts) -> stack as (the parts of _Car23) ;;; [3] Make (a & b), (b & a) into a canonical form. Strictly we should also do this for non-symbols, ;;; but I don't want to do expensive structure1 @< structure2 tests to derive the canonical form. (defun canonicalize (expr) (cond ((and (pairp expr) (not (member (first expr) *reserved-keywords*))) `#$(the ,(SECOND EXPR) of ,(FIRST EXPR))) ((and (triplep expr) (set-unification-operator (second expr))) ; fold &&, &&?, &&! into a single canonical form `(,(first expr) unified-with ,(third expr))) ((and (triplep expr) ; fold &, &?, &! into a single canonical form (val-unification-operator (second expr)) (neq (second expr) '&+)) ; EXCEPT: This *is* a valid subgoal of && (cond ((and (symbolp (first expr)) (symbolp (third expr)) (string> (symbol-name (first expr)) (symbol-name (third expr)))) `((,(third expr)) unified-with (,(first expr)))) (t `((,(first expr)) unified-with (,(third expr)))))) (t expr))) ;;; (a && b) (a & b) ;;; ---------------------------------------- ;;; DISPLAY OF EXPRESSION STACK ;;; ---------------------------------------- #| <- (_Chassis70) "(the body-parts of *MyCar)" (3) Look in supersituation(s) -> (in-situation *Global (the parts of *MyCar))g ---------------------------------------- CURRENT GOAL STACK IS AS FOLLOWS: -> (the parts of *MyCar) [called in _Situation69] -> (in-situation *Global (the parts of *MyCar)) [called in _Situation69] |# (defun show-km-stack (&optional (stream t)) (let ( (show-situationsp (some #'(lambda (item) (neq (second item) *global-situation*)) (km-stack))) ) (format stream "--------------------~%~%") (format stream " CURRENT GOAL STACK IS AS FOLLOWS:~%") (show-km-stack2 (reverse (km-stack)) 1 show-situationsp stream) (format stream "~%--------------------~%"))) (defun show-km-stack2 (stack depth show-situationsp &optional (stream t)) (cond ((endp stack) nil) (t (let ( (item (first stack)) ) (cond ((stacked-commentp item) (km-format stream "~vT" depth) (print-stacked-comment item stream) (format stream "~%") (show-km-stack2 (rest stack) depth show-situationsp stream)) (t (let ( ; (expr (strip-assignment (third item))) (expr (stacked-expr item)) (situation (stacked-situation item)) ) (km-format stream "~vT-> ~a" depth (desource expr)) ; truncated version ; (format t (truncate-string (apply #'km-format `(nil "~vT -> ~a" ,depth ,(desource expr))) 80)) (cond (show-situationsp (km-format stream "~vT[called in ~a]~%" 55 situation)) (t (format stream "~%"))) (show-km-stack2 (rest stack) (1+ depth) show-situationsp stream)))))))) ;;; ====================================================================== ;;; THE OBJECT STACK ;;; ====================================================================== ;;; Note we filter out duplicates and classes at access time (obj-stack), rather than ;;; build-time (here), for efficiency. (defun add-to-stack (instance) (cond ((and (not (member instance *obj-stack*)) (stackable instance)) ; (make-transaction `(setq *obj-stack* ,(cons instance *obj-stack*)))))) (setq *obj-stack* (cons instance *obj-stack*))))) ; don't need to unwind this (defconstant *unstackable-kb-instances* '#$(t)) (defun stackable (instance) (and (kb-objectp instance) (not (classp instance)) (not (slotp instance)) (not (member instance *unstackable-kb-instances*)))) (defun remove-from-stack (instance) ; (make-transaction `(setq *obj-stack* ,(remove instance (obj-stack))))) (setq *obj-stack* (remove instance (obj-stack)))) ; don't need to unwind this ;;; ---------------------------------------- ;;; Find the first instance on *obj-stack* in class (defun search-stack (class) (find-if #'(lambda (instance) (isa instance class)) *obj-stack*)) ;;; ---------- ;;; (defun show-km-stack () ...) See debug.lisp (defun show-obj-stack () (mapcar #'(lambda (instance) (km-format t " ~a~%" instance)) (obj-stack)) t) ;;; Obsolete now (defun show-context () (show-obj-stack)) ;;; Not used ;(defun showme-context () (showme (vals-to-val (reverse (obj-stack)))) t) (defun unfiltered-obj-stack () *obj-stack*) (defun obj-stack () (let ( (clean-stack (remove-dup-atomic-instances *obj-stack*)) ) (cond ((not (equal clean-stack *obj-stack*)) ; (make-transaction `(setq *obj-stack* ,clean-stack)))) (setq *obj-stack* clean-stack))) clean-stack)) (defun showme (km-expr &optional (situations (all-situations)) (theories (all-theories)) (stream t)) (let* ( ;(frames (km0 km-expr :fail-mode 'error)) (frames (km0 km-expr)) (frame (first frames)) ) (cond ((and (singletonp frames) (neq km-expr frame) (kb-objectp km-expr) ; ie. _Car23 (is-km-term frame)) ; eg. _Car23, or "MyCar" (km-format stream ";;; (~a is bound to ~a)~%~%" km-expr frame))) (cond ((null frames) (km-format t ";;; (No frames to show: ~a evaluates to NIL)~%" km-expr)) ((singletonp frames) (showme-frame frame situations theories stream)) (t (mapc #'(lambda (frame) (showme-frame frame situations theories stream) (princ ";;; ----------" stream) (terpri stream) (terpri stream)) frames))) frames)) (defun showme-frame (frame &optional (situations (all-situations)) (theories (all-theories)) (stream t)) (cond ((not (is-km-term frame)) (report-error 'nodebugger-error "Doing (showme-frame ~a) - the frame name `~a' should be a KB term!~%" frame frame)) (t (princ (write-frame frame :situations situations :theories theories) stream)))) ;;; ====================================================================== ;;; This shows all valid slots! (defun showme-all (km-expr &optional (situations (all-situations))) (let* ( (frames (km0 km-expr :fail-mode 'error)) (frame (first frames)) ) (cond ((and (singletonp frames) (neq km-expr frame) (kb-objectp km-expr) ; ie. _Car23 (is-km-term frame)) ; eg. _Car23, or "MyCar" (km-format t ";;; (~a is bound to ~a)~%~%" km-expr frame))) (cond ((singletonp frames) (showme-all-frame frame situations)) (t (mapc #'(lambda (frame) (showme-all-frame frame situations) (princ ";;; ----------") (terpri) (terpri)) frames))) frames)) (defun showme-all-frame (instance &optional (situations (all-situations))) (cond ((not (is-km-term instance)) (report-error 'nodebugger-error "Doing (showme-all-frame ~a) - the instance name `~a' should be a KB term!~%" instance instance)) (t (mapc #'(lambda (situation) (showme-own-slots-in-situation instance situation) (showme-member-slots-in-situation instance situation)) situations) t))) ;;; e.g. (Car has (superclasses (Vehicle))), (*MyCar has (instance-of (Car))) ;;; [1] Bit inefficient, but simple: (defun showme-own-slots-in-situation (instance situation) (let* ( (own-slots-to-show1 (mapcar #'used-slot-in (get-slotsvals instance :facet 'own-properties :situation situation))) ; [1] (own-slots-to-show2 (mapcar #'used-slot-in (get-slotsvals instance :facet 'own-definition :situation situation))) ; [1] (inherited-slots-to-show (my-mapcan #'(lambda (class) (mapcar #'used-slot-in (append (get-slotsvals class :facet 'member-properties :situation situation) (get-slotsvals class :facet 'member-definition :situation situation)))) (all-classes instance))) (slots-to-show (remove-duplicates (append own-slots-to-show1 own-slots-to-show2 inherited-slots-to-show))) ) (cond (slots-to-show (cond ((eq situation *global-situation*) (km-format t "(~a has" instance)) (t (km-format t "(in-situation ~a~% (~a has" situation instance))) (mapc #'(lambda (slot) (let* ( (inherited-rule-sets (inherited-rule-sets2 slot (all-classes instance) (list situation))) (own-rule-sets (remove nil (list (get-vals instance slot :facet 'own-properties :situation situation) (get-vals instance slot :facet 'own-definition :situation situation)))) (all-rule-sets (desource (bind-self (remove-duplicates (append own-rule-sets inherited-rule-sets) :test #'equal :from-end t) instance))) (joiner (cond ((single-valued-slotp slot) '&) (t '&&))) ) ; (cond ((singletonp all-rule-sets) (km-format t "~% (~a ~a)" slot (first all-rule-sets))) (cond ((singletonp all-rule-sets) (km-format t "~% (~a " slot) (format t (expr2string (first all-rule-sets))) (format t ")")) (t (print-slot-exprs slot all-rule-sets joiner))))) (sort (copy-list slots-to-show) #'string< :key #'symbol-name)) (cond ((eq situation *global-situation*) (km-format t ")~%~%")) (t (km-format t "))~%~%"))))))) ;;; e.g. (every Car has (parts ((a Wheel)))) (defun showme-member-slots-in-situation (class situation) (let* ( (all-classes (cons class (all-superclasses class))) (slots-to-show (remove-duplicates (my-mapcan #'(lambda (class) (mapcar #'used-slot-in (append (get-slotsvals class :facet 'member-properties :situation situation) (get-slotsvals class :facet 'member-definition :situation situation)))) all-classes))) ) (cond (slots-to-show (cond ((eq situation *global-situation*) (km-format t "(every ~a has" class)) (t (km-format t "(in-situation ~a~% (every ~a has" situation class))) (mapc #'(lambda (slot) (let* ( (all-rule-sets (desource (inherited-rule-sets2 slot all-classes (list situation)))) ; find all rule sets in all classes in situation (joiner (cond ((single-valued-slotp slot) '&) (t '&&))) ) (cond ((singletonp all-rule-sets) (km-format t "~% (~a " slot) (format t (expr2string (first all-rule-sets))) (format t ")")) (t (print-slot-exprs slot all-rule-sets joiner))))) (sort (copy-list slots-to-show) #'string< :key #'symbol-name)) (cond ((eq situation *global-situation*) (km-format t ")~%~%")) (t (km-format t "))~%~%"))))))) ;;; (used-slot-in '(age (20))) -> age ;;; (used-slot-in '(age ())) -> nil (defun used-slot-in (slotvals) (cond ((not (null (vals-in slotvals))) (slot-in slotvals)))) (defun print-slot-exprs (slot all-rule-sets joiner &key (first-time-through t)) (cond (first-time-through (case joiner (& (km-format t "~% (~a ( " slot)) (&& (km-format t "~% (~a ( " slot)))) (t (km-format t (spaces (+ 5 (length (symbol-name slot))))) (km-format t "~a " joiner))) (cond ((single-valued-slotp slot) ; (km-format t "~a" (vals-to-&-expr (first all-rule-sets)))) (format t (expr2string (vals-to-&-expr (first all-rule-sets))))) (t ; (km-format t "~a" (first all-rule-sets)))) (format t (expr2string (first all-rule-sets))))) ; e.g. convert (UNQUOTE fred) to #,fred (cond ((null all-rule-sets) (report-error 'program-error "Null all-rule-sets in print-slot-exprs (stack.lisp!)~%")) ((singletonp all-rule-sets) (format t ")")) (t (format t "~%") (print-slot-exprs slot (rest all-rule-sets) joiner :first-time-through nil)))) ;;; ====================================================================== ;;; This shows all valid slots! (defun evaluate-all (km-expr &optional (situations (all-situations))) (let* ( (frames (km0 km-expr :fail-mode 'error)) (frame (first frames)) ) (cond ((and (singletonp frames) (neq km-expr frame) (kb-objectp km-expr) ; ie. _Car23 (is-km-term frame)) ; eg. _Car23, or "MyCar" (km-format t ";;; (~a is bound to ~a)~%~%" km-expr frame))) (cond ((singletonp frames) (evaluate-all-frame frame situations)) (t (mapc #'(lambda (frame) (evaluate-all-frame frame situations) (princ ";;; ----------") (terpri) (terpri)) frames))) frames)) (defun evaluate-all-frame (instance &optional (situations (all-situations))) (cond ((not (is-km-term instance)) (report-error 'nodebugger-error "Doing (evaluate-all-frame ~a) - the instance name `~a' should be a KB term!~%" instance instance)) (t (mapc #'(lambda (situation) (evaluate-all-frame-in-situation instance situation)) situations) t))) (defun evaluate-all-frame-in-situation (instance situation) (cond ((eq situation *global-situation*) (km-format t "(~a has~%" instance)) (t (km-format t "(in-situation ~a~% (~a has~%" situation instance))) (mapc #'(lambda (slot) (let ( (domain (or (km-unique0 `#$(the domain of ,SLOT)) '#$Thing)) ) (cond ((instance-of instance domain) (let ( (vals (km0 `#$(the ,SLOT of ,INSTANCE))) ) (cond ((null vals) (km-format t " (~a ())~%" slot)) (t (km-format t " (~a ~a)~%" slot vals)))))))) (sort (copy-list (all-instances '#$Slot)) #'string< :key #'symbol-name)) ; copy list just to be safe, as sort is destructive (cond ((eq situation *global-situation*) (km-format t ")~%~%")) (t (km-format t "))~%~%")))) ;;; ====================================================================== ;(defun new-proof-node-id () (gentemp "PID")) (defvar *pid-counter* 0) (defun new-proof-node-id () (setq *pid-counter* (1+ *pid-counter*))) ;;; FILE: stats.lisp ;;; File: stats.lisp ;;; Author: Peter Clark ;;; Date: August 1994 ;;; Purpose: Keep track and report various inference statistics (defvar *reset-statistics-enabled* t) (defun reset-statistics () (cond (*reset-statistics-enabled* (setq *statistics-classification-inferences* 0) (setq *statistics-query-directed-inferences* 0) (setq *statistics-kb-access* 0) (setq *statistics-cpu-time* (get-internal-run-time)) (setq *statistics-max-depth* 0) (setq *statistics-unifications* 0) (setq *statistics-skolems* 0) (setq *statistics-classifications-attempted* 0) (setq *statistics-classifications-succeeded* 0)))) ;;; ---------- (defun report-statistics () (let ( (cpu-time (- (get-internal-run-time) *statistics-cpu-time*)) (statistics-inferences (+ *statistics-classification-inferences* *statistics-query-directed-inferences*)) ) (concat (format nil "(~a inferences and ~a KB accesses in ~,1F sec" statistics-inferences *statistics-kb-access* (/ cpu-time internal-time-units-per-second)) ; itups = a system constant (cond ((not (eq cpu-time 0)) (format nil " [~a lips, ~a kaps])" ; debugging only (history length ~a)" (floor (/ (* internal-time-units-per-second statistics-inferences) cpu-time)) (floor (/ (* internal-time-units-per-second *statistics-kb-access*) cpu-time))))) (format nil ")~%")))) (defun report-statistics-long () (let ( (cpu-time (- (get-internal-run-time) *statistics-cpu-time*)) (statistics-inferences (+ *statistics-classification-inferences* *statistics-query-directed-inferences*)) ) (concat (format nil "~a inferences (~a query-directed, ~a classification) and ~a KB accesses in ~,1F sec~%" statistics-inferences *statistics-query-directed-inferences* *statistics-classification-inferences* *statistics-kb-access* (/ cpu-time internal-time-units-per-second)) ; itups = a system constant (cond ((not (eq cpu-time 0)) (format nil " (~a inferences per second, ~a KB accesses per second).~%" ; debugging only (history length ~a)" (floor (/ (* internal-time-units-per-second statistics-inferences) cpu-time)) (floor (/ (* internal-time-units-per-second *statistics-kb-access*) cpu-time))))) (format nil "~a classifications attempted, of these ~a succeeded.~%" *statistics-classifications-attempted* *statistics-classifications-succeeded*) (format nil "~a Skolem instances created, " *statistics-skolems*) (format nil "~a unifications, " *statistics-unifications*) (format nil "maximum depth of reasoning was depth ~a.~%" *statistics-max-depth*) ))) ;;; ====================================================================== ;;; REPORTING INFERENCE SPEED ;;; Set *inference-report-frequency* to a number to have KM report its spot run-time speed ;;; ====================================================================== (defparameter *inference-report-frequency* nil) (defvar *spot-runtime* 0) (defun increment-inference-statistics () (cond (*am-classifying* (setq *statistics-classification-inferences* (1+ *statistics-classification-inferences*))) (t (setq *statistics-query-directed-inferences* (1+ *statistics-query-directed-inferences*)))) (cond ((and *inference-report-frequency* (numberp *inference-report-frequency*) (> *inference-report-frequency* 0)) (let ( (inferences (+ *statistics-classification-inferences* *statistics-query-directed-inferences*)) ) (multiple-value-bind (number remainder) (floor (/ inferences *inference-report-frequency*)) (declare (ignore number)) (cond ((= remainder 0) (format t "~a logical inferences done (spot speed: ~a lips)~%" inferences (floor (/ (* *inference-report-frequency* internal-time-units-per-second) (- (get-internal-run-time) *spot-runtime*)))) (setq *spot-runtime* (get-internal-run-time))))))))) ;;; FILE: sadl.lisp ;;; File: sadl.lisp (version 1.1) ;;; Author: Peter Clark ;;; Date: 2/23/01 updated 11/9/01 for direct incorporation into KM ;;; Totally rewritten and simplified 4/2/02 to be in line with the new SADL spec. (defun do-plan (event-instance) (let* ( (first-subevent (km-unique0 `#$(the first-subevent of ,EVENT-INSTANCE))) ) (cond ((null first-subevent) (report-error 'user-error "do-plan: event ~a has no first-subevent, so I don't know where to start!" event-instance)) (t (follow-event-chain first-subevent))))) (defun follow-event-chain (event) (make-comment "Executing event ~a...~%" event) (km0 `#$(do-and-next ,EVENT) :fail-mode 'error) (let ( (next-event (next-event event)) ) (cond ((null next-event) (make-comment "No more next events: Finishing simulation.~%") (list (curr-situation))) (t (follow-event-chain next-event))))) (defun next-event (event) (let ( (next-events (km0 `#$(the next-event of ,EVENT))) (next-event-test (km-unique0 `#$(the next-event-test of ,EVENT))) ) (cond ((and (not next-event-test) (some #'km-argsp next-events)) (report-error 'user-error "Missing a next-event-test on ~a!~%(It is needed to select the appropriate next-event from options: ~a)~%" event next-events)) ((and next-event-test (notevery #'km-argsp next-events)) (report-error 'user-error "next-events for ~a should be a list of (:args ) structures, as ~a has a next-event-test!~%(Was ~a instead)~%" event event next-events)) ((and (not next-event-test) (>= (length next-events) 2)) (report-error 'user-error "Multiple next-events ~a specified for event ~a! (Don't know how to handle this)~%" event next-events)) ((not next-event-test) (first next-events)) (t ; next-event-test necc. present (let* ( (test-result (km-unique0 `#$(evaluate ,NEXT-EVENT-TEST))) (actual-next-events (mapcar #'arg2of (remove-if-not #'(lambda (next-event) (equal (arg1of next-event) test-result)) next-events))) ) ; (km-format t "next-events = ~a~%" next-events) ; (km-format t "actual-next-events = ~a~%" actual-next-events) (cond ((singletonp actual-next-events) (first actual-next-events)) ((>= (length actual-next-events) 2) (report-error 'user-error "~a has multiple next-events ~a specified for the result ~a (of test ~a)~%(Don't know how to handle this)~%" event actual-next-events test-result next-event-test)) (t (make-comment "(No next-event of ~a matches the result ~a (of test ~a)~%(next-events were ~a)~%Ending simulation...~%" event test-result next-event-test next-events)))))))) ;;; FILE: anglify.lisp ;;; File: anglify.lisp ;;; Author: Peter Clark ;;; Date: Separated out Aug 1994 ;;; Purpose: Concatenation and customisation of text-fragments ; If nil then 3 -> "3". If t then 3 -> "the value 3" (defparameter *verbose-number-to-text* nil) ;;; ====================================================================== ;;; CONCATENATING TEXT FRAGMENTS TOGETHER NICELY ;;; ====================================================================== #| make-phrase/make-sentence: INPUT: Can be either a single KM expression, or a :set / :seq of KM expressions -- make-sentence will flatten them out and doesn't care. :set and :seq flags are ignored, and sequence is preserved. RETURNS: A string built from these fragments, possibly capitalized and with a terminator added. If a KM instance is included in the input, then this function will recursively replace it by (the name of ) until (the name of ) just returns . This typically happens when is a class name: -> (the name of _Dog3) constructs (:seq "a" Dog), then calls itself again for instances in this expression -> (the name of Dog) -> Dog ; fixed point <- Dog <- (:seq "a" Dog) NOTE: :htmlify flag isn't used by KM, but might be by the user if (i) he/she makes a top-level call to make-phrase/make-sentence, and (ii) he/she redefines (make-name ...) to respond to a :htmlify t flag. |# (defun make-phrase (text &key htmlify) (make-sentence text :capitalize nil :terminator "" :htmlify htmlify)) (defun make-sentence (text &key (capitalize t) (terminator ".") htmlify) (let ( (new-string (concat-list (spacify (remove nil (mapcar #'(lambda (i) (cond ((null i) nil) ((stringp i) i) ((numberp i) (princ-to-string i)) ((member i '#$(:seq :set :triple)) nil) ((symbolp i) (string-downcase i)) (t (report-error 'user-error "make-sentence/phrase: Don't know how to convert ~a to a string!~%" i)))) (flatten (listify (expand-text text :htmlify htmlify)))))))) ) (cond ((null new-string) "") (t (let ( (terminated-string (cond ((not (ends-with new-string terminator)) (concat new-string terminator)) (t new-string))) ) (cond (capitalize (capitalize terminated-string)) (t terminated-string))))))) #| expand-text: This function takes a KM structure or atom, eg. a (:seq ...) structure, and recursively expands it to more primitive fragments using calls to (name ...). It eventually bottoms out when (name X) returns X. An example of the expansion might be: (:seq _Engine23 "has purpose" _Purpose24) -> (:seq (:seq "a" Engine) "has purpose" ("a" Propelling "whose object is" _Airplane25)) -> (:seq (:seq "a" Engine) "has purpose" ("a" Propelling "whose object is" (:seq "a" Airplane))) [<= final result] where (name _Engine23) -> (:seq "a" Engine) (name _Purpose24) -> ("a" Propelling "whose object is" _Airplane24) (name _Airplane25) -> (:seq "a" Airplane) |# (defun expand-text (item &key htmlify (depth 0)) (let ( (expanded (remove '#$:seq (flatten (expand-text0 item :htmlify htmlify :depth depth)))) ) (cond ((null expanded) nil) ((singletonp expanded) (first expanded)) (t (cons '#$:seq expanded))))) (defun expand-text0 (item &key htmlify (depth 0)) (cond ((> depth 100) (report-error 'user-error "make-sentence/phrase: Infinite recursion when generating name for ~a!~%" item)) ((stringp item) item) ((numberp item) (cond (*verbose-number-to-text* (list "the value" item)) ((integerp item) item) (*output-precision* (cond ((>= item 1.0) (format nil (concat "~," (princ-to-string *output-precision*) "f") item)) ((>= item (expt 10 (- *output-precision*))) (format nil (concat "~," (princ-to-string (- *output-precision* (floor (log item 10)))) "f") item)) (t (format nil (concat "~," (princ-to-string *output-precision*) "e") item)))) (t item))) ; ((null item) (list "??")) ; why did I put this in? Add developer-mode flag ((and (null item) *developer-mode*) (list "??")) ((listp item) (mapcar #'(lambda (i) (expand-text0 i :htmlify htmlify :depth (1+ depth))) item)) ((member item '#$(:seq :set :bag :pair)) item) ((or (kb-objectp item) (km-triplep item)) (let ( (name (name item)) ) (cond ((equal name item) item) (t (expand-text0 name :depth (1+ depth)))))) (t (report-error 'user-error "make-sentence/phrase: Bad element `~a' encountered!!~%" item)))) #| ;;; The htmlify flag is passed here in case the user wants to redefine make-name to actually do something with the flag! (defun make-name (item &key htmlify) (declare (ignore htmlify)) (let ( (names (km0 `#$(the name of ,ITEM))) ) (cond ((singletonp names) (cond ((stringp (first names)) (first names)) (t (report-error 'user-error "make-sentence/phrase: (the name of ~a) should return a string,~%but it returned ~a instead!~%" item (first names))))) ((null names) "???") (t (report-error 'user-error "make-sentence/phrase: (the name of ~a) should return a single string,~%but it returned ~a instead!~%" item names))))) |# (defconstant *nospace-string* "nospace") ;;; This could be written a million times better! ;;; words = A flattened list of strings. ;;; Periods must be a separate string (".") for capitalization to work ;;; properly. (defun spacify (words) (cond ((null words) nil) ((singletonp words) words) ((white-space-p (second words) :whitespace-chars '(#\Space #\Tab)) ; (but not #\Newline) (spacify (cons (first words) (rest (rest words))))) ((string= (first words) ".") (cond ((and (string= (second words) (string #\Newline)) (not (null (third words)))) (cons (first words) (cons (second words) (spacify (cons (capitalize (third words)) (rest (rest (rest words)))))))) (t (cons ". " (spacify (cons (capitalize (second words)) (rest (rest words)))))))) ; ((char= (first-char (second words)) #\-) ;; Special character, which forces no space ; (cons (first words) ; (spacify (cons (butfirst-char (second words)) ; (rest (rest words)))))) ((string= (first words) *nospace-string*) ; handle multiple "nospace"s in a line (spacify (rest words))) ((string= (second words) *nospace-string*) (cons (first words) (spacify (rest (rest words))))) (t (cons (first words) (cons (a-space (first words) (second words)) (spacify (rest words))))))) ;;; "dog" -> "Dog" (defun capitalize (string) (concat (string-upcase (first-char string)) (butfirst-char string))) ;;; Crude! ;;; (a-space "cat" "dog") -> " " ;;; (a-space "cat" " dog") -> "" ;;; (a-space "cat " "dog") -> "" (defun a-space (word1 word2) (cond ((no-following-spaces (last-char word1)) "") ((no-preceeding-spaces (first-char word2)) "") (t " "))) (defun no-following-spaces (char) (member char '( #\( #\ ))) (defun no-preceeding-spaces (char) (member char '( #\' #\) #\. #\, #\ ))) ;;; ====================================================================== ;;; NAMES OF FRAMES ;;; ====================================================================== #| Revised March 2000. Name returns a (possibly nested) list of fragments, which together produce a top-level name for an object. name *doesn't* call itself recursively. To recursively expand the name for objects, use make-phrase or make-sentence. These two functions recursively convert symbols to their name structures, and then flatten, stringify, and concatenate the result. |# (defun name (concept &key htmlify) (cond ((tracep) (prog2 (suspend-trace) (name0 concept :htmlify htmlify) (unsuspend-trace))) (t (name0 concept :htmlify htmlify)))) ;;; [1] to prevent situation-specific instances all inheriting name "the thing" from the global situation! ;;; 9/18/02 - this is no longer applicable, as KM no longer evaluates situation-specific stuff globally ;;; [2] Ken Barker doesn't want this. (defun name0 (concept &key htmlify) (cond ((stringp concept) concept) ((numberp concept) (princ-to-string concept)) ;[2] ((protoinstancep concept) (prototype-name concept :htmlify htmlify)) ; <== new ((km-triplep concept) (triple-name concept)) ((let ( (name (km0 `#$(the name of ,CONCEPT))) ) (cond ((singletonp name) (first name)) ((not (null name)) (make-comment "Warning! ~a has multiple name expressions ~a!~% Continuing just using the first (~a)..." concept name (first name)) (first name))))) ((km-unique0 `#$(the name of ,CONCEPT))) ((symbol-starts-with concept #\*) ; "*pete" -> "pete" (butfirst-char (string-downcase concept))) ((anonymous-instancep concept) (cond (t ;(not (equal (immediate-classes concept) '#$(Thing))) ; else return NIL [1] (anonymous-instance-name concept :htmlify htmlify)))) ((atom concept) (string-downcase concept)) (t concept))) (defun anonymous-instance-name (concept &key htmlify) (declare (ignore htmlify)) ; (concat "the " (name (first (immediate-classes concept))))) `(#$:seq "the" ,(name (first (immediate-classes concept))))) ;;; ---------- #| Not used any more (defun prototype-name (concept &key htmlify) (declare (ignore htmlify)) (cond ((not (protoinstancep concept)) (report-error 'user-error "Trying to generate prototype name of non-prototype ~a!~%" concept)) ((prototypep concept) (or (km-unique0 `#$(the name of ,CONCEPT)) (let ( (parent (first (immediate-classes concept))) ) `(#$:seq "a" ,(name parent))))) (t `(#$:seq "the" ,(name (first (immediate-classes concept))) "of" ,(prototype-name (km-unique0 `#$(the prototype-participant-of of ,CONCEPT) :fail-mode 'error)))))) |# ;;; ---------- #| CL-USER> (triple-name '#$(:triple *pete owns (:set *money *goods *food))) (:|seq| "pete" |owns| (:|seq| "money" ", " "goods" ", and " "food")) CL-USER> (triple-name '#$(:triple *pete believes (:triple *joe owns *goods))) (:|seq| "pete" |believes| (:|seq| "joe" |owns| "goods")) |# (defun triple-name (triple &key htmlify) (let ( (vals (val-to-vals (fourth triple))) ) (list '#$:seq (name (second triple) :htmlify htmlify) ; ("pete") (name (third triple) :htmlify htmlify) ; ("owns") (cond ((null vals) nil) ((singletonp vals) (name (first vals) :htmlify htmlify)) (t (cons '#$:seq (andify (mapcar #'(lambda (v) (name v :htmlify htmlify)) vals)))))))) ;;; FILE: writer.lisp ;;; File: writer.lisp ;;; Author: Peter Clark ;;; Date: Mar 1996 spliced out Feb 1997 ;;; Purpose: Copy of updated write-frame from server/frame-dev.lisp ;;; Move to header.lisp ;(defconstant *special-symbol-alist* ; '( (quote "'") ; (function "#'") ; (unquote "#,") ; (unquote-splice "#@") )) ; ("BACKQUOTE" "`") ; ("BQ-COMMA" ","))) ;;; frame can be *any* valid KM term, including strings, numbers, sets, sequences, functions, and normal frames. (defun write-frame (frame &key (situations (all-situations)) (theories (all-theories)) htmlify nulls-okayp) (cond ((and (kb-objectp frame) (bound frame)) (km-format nil ";;; (~a is bound to ~a)~%~%" frame (dereference frame))) (t (let ( (frame-string (write-frame0 frame situations theories htmlify)) ) (cond ((string/= frame-string "") frame-string) ((built-in-concept-type frame) (concat (km-format nil ";;; (Concept ~a is a built-in " frame) (built-in-concept-type frame) (format nil ")~%~%"))) (nulls-okayp (km-format nil "(~a has)~%~%" frame)) ((and (null (set-difference (all-situations) situations)) (null (set-difference (all-theories) theories))) (km-format nil ";;; (Concept ~a is not declared anywhere in the KB)~%~%" frame)) ((null (all-theories)) (km-format nil ";;; (Concept ~a is not declared in the situations ~a)~%~%" frame situations)) (t (km-format nil ";;; (Concept ~a is not declared in the situations ~a nor the theories ~a)~%~%" frame situations theories))))))) (defun write-frame0 (frame &optional (situations (all-situations)) (theories (all-theories)) htmlify) (cond ((stringp frame) (km-format nil ";;; (~a is a string)~%~%" frame)) ((numberp frame) (km-format nil ";;; (~a is a number)~%~%" frame)) ((descriptionp frame) (km-format nil ";;; (~a is a quoted expression)~%~%" frame)) ((km-seqp frame) (km-format nil ";;; (~a is a sequence)~%~%" frame)) ((km-setp frame) (km-format nil ";;; (~a is a set)~%~%" frame)) ((km-argsp frame) (km-format nil ";;; (~a is an argument list)~%~%" frame)) ((functionp frame) (km-format nil ";;; (~a is a Lisp function)~%~%" frame)) ((kb-objectp frame) (concat-list (cons (cond ((member *global-situation* situations) ; do *Global first (write-frame-in-situation frame *global-situation* :htmlify htmlify)) (t "")) (append (let ( (prototypes (get-vals frame '#$prototypes :situation *global-situation*)) ) (cond (prototypes (append (list (km-format nil "#|")) (mapcan #'(lambda (prototype) (cons (km-format nil "~%;;; Prototype ~a defined by:~%" prototype) (mapcar #'(lambda (expr) ; (km-format nil "~a~%" expr)) (concat (expr2string expr htmlify) (format nil "~%"))) (dereference (get prototype 'definition))))) prototypes) (list (km-format nil "|#~%~%")))))) (mapcar #'(lambda (theory) (write-frame-in-situation frame theory :htmlify htmlify :theoryp t)) theories) (append (flatten (write-situation-specific-assertions frame :htmlify htmlify)) (mapcar #'(lambda (situation) (write-frame-in-situation frame situation :htmlify htmlify)) (remove *global-situation* situations))))))) (t (report-error 'user-error "~a is not a KB object!~%" frame)))) (defun write-situation-specific-assertions (situation-class &key htmlify) (cond ((is-subclass-of situation-class '#$Situation) (let ( (assertions (second (assoc '#$assertions (desource0 (get-slotsvals situation-class :facet 'member-properties :situation *global-situation*))))) ) (cond (assertions (mapcar #'(lambda (assertion) (cond ((not (quotep assertion)) (report-error 'user-error "Unquoted assertion ~a in situation-class ~a! Ignoring it...~%" assertion situation-class) "") (t (let ( (modified-assertion (sublis '#$((SubSelf . Self) (#,Self . TheSituation)) (second assertion) :test #'equal)) ) (list (km-format nil "(in-every-situation ") (objwrite situation-class htmlify) (km-format nil "~% ") (objwrite modified-assertion htmlify) (km-format nil ")~%~%")))))) assertions))))))) ;;; If no data, then returns "" (defun write-frame-in-situation (frame situation &key htmlify theoryp) (let ( (own-props (desource0 (get-slotsvals frame :facet 'own-properties :situation situation))) (mbr-props (desource0 (get-slotsvals frame :facet 'member-properties :situation situation))) (own-defn (desource0 (get-slotsvals frame :facet 'own-definition :situation situation))) (mbr-defn (desource0 (get-slotsvals frame :facet 'member-definition :situation situation))) ) (concat (cond (own-defn (concat-list (flatten (write-frame2 frame situation own-defn nil '#$has-definition :htmlify htmlify :theoryp theoryp))))) (cond ((and own-props (not (and (singletonp own-props) (eq (first (first own-props)) '#$assertions)))) ; filter out these! (concat-list (flatten (write-frame2 frame situation own-props nil '#$has :htmlify htmlify :theoryp theoryp))))) (cond (mbr-defn (concat-list (flatten (write-frame2 frame situation mbr-defn '#$every '#$has-definition :htmlify htmlify :theoryp theoryp))))) (cond ((and mbr-props (not (and (singletonp mbr-props) (eq (first (first mbr-props)) '#$assertions)))) ; filter out these! (concat-list (flatten (write-frame2 frame situation mbr-props '#$every '#$has :htmlify htmlify :theoryp theoryp)))))))) ;;; theoryp = 'ignore suppresses the (in-theory ... ) wrapper, but we ignore that for now (defun write-frame2 (frame situation slotsvals0 quantifier joiner &key htmlify theoryp) (let ( (slotsvals (dereference slotsvals0)) (tab (cond ((eq situation *global-situation*) 0) (t 2))) ) (list (cond ((and (neq situation *global-situation*) (neq theoryp 'ignore)) (list (cond ((eq theoryp t) (km-format nil "(in-theory ")) (t (km-format nil "(in-situation "))) (objwrite situation htmlify) (km-format nil "~%")))) (cond ((not (eq tab 0)) (format nil "~vT" tab))) ; (format nil "~vT" 0) prints one space (Lisp bug?) (cond (quantifier (km-format nil "(~a " quantifier)) ; "(every " (t "(")) (objwrite frame htmlify) (km-format nil " ~a " joiner) ; "has" or "has-definition" (write-slotsvals slotsvals (+ tab 2) htmlify) ")" (cond ((and (neq situation *global-situation*) (neq theoryp 'ignore)) ")")) (format nil "~%~%")))) (defun write-slotsvals (slotsvals &optional (tab 2) htmlify) (mapcar #'(lambda (slotvals) (write-slotvals slotvals tab htmlify)) slotsvals)) (defun write-slotvals (slotvals &optional (tab 2) htmlify) (cond ((null slotvals) (format nil " ()")) ((eq (slot-in slotvals) '#$assertions) "") (t (list (format nil "~%~vT(" tab) (objwrite (slot-in slotvals) htmlify) " " (write-vals (remove-dup-instances (vals-in slotvals)) (+ tab 3 (length (km-format nil "~a" (slot-in slotvals)))) htmlify) (cond ((> (length slotvals) 2) (report-error 'user-error "Extra element(s) in slotvals list!~%~a. Ignoring them...~%" slotvals))) ")")))) (defun write-vals (vals &optional (tab 2) htmlify) (cond ((null vals) "()") (t (list "(" (objwrite (first vals) htmlify) (mapcar #'(lambda (val) (list (format nil "~%~vT" tab) (objwrite val htmlify))) (rest vals)) ")")))) (defun write-kmexpr (kmexpr _tab htmlify) (declare (ignore _tab)) (objwrite kmexpr htmlify)) ;;; (expr2string '#$(the '(age of #,person))) -> "(the '(age of #,person))" (defun expr2string (expr &optional htmlify) (concat-list (remove nil (flatten (objwrite expr htmlify))))) ;;; convert to strings to remove package info: ;;; [1c] USER(143): (first '`(the ,car)) ;;; excl::backquote (defun objwrite (expr &optional htmlify) (cond ((atom expr) (objwrite2 expr htmlify)) ((and (pairp expr) (symbolp (first expr)) (assoc (first expr) *special-symbol-alist*)) (let ( (special-symbol-str (second (assoc (first expr) *special-symbol-alist*))) ) (list special-symbol-str (objwrite (second expr) htmlify)))) ((listp expr) (list "(" (objwrite (first expr) htmlify) (mapcar #'(lambda (item) (list " " (objwrite item htmlify))) (rest expr)) ")")) (t (report-error 'user-error "Don't know how to (objwrite ~a)!~%" expr)))) ;;; Default server action, when interfaced with Web browser. Not used in KM stand-alone (defparameter *html-action* '"frame") ; (defparameter *html-window* '"target=right") (defparameter *html-window* '"") ;;; The primitive write operation ;;; [1] Include ||s: (symbol-name '|the dog|) -> "the dog", while (km-format nil "~a" '|the dog|) -> "|the dog|". (defun objwrite2 (expr htmlify &key (action *html-action*) (window *html-window*)) (cond ((and htmlify (kb-objectp expr) (known-frame expr)) ; with KM only, htmlify is always nil (htextify expr (km-format nil "~a" expr) :action action :window window)) ; [1] ((eq expr nil) "()") (t (km-format nil "~a" expr)))) ;;; FILE: taxonomy.lisp ;;; File: taxonomy.lisp ;;; Author: Peter Clark ;;; Date: April 96 ;;; Purpose: Print out the frame hierarchy ;;; Warning: Frighteningly inefficient. (defconstant *indent-increment* 3) (defconstant *prune-points* nil) (defconstant *ignore-items* nil) (defconstant *maxdepth* 9999) (defun taxonomy (&optional (current-node '#$Thing) (relation-to-descend '#$subclasses) htmlify) (write-lines (make-tax current-node relation-to-descend htmlify)) '#$(t)) ;;; Rather ugly -- returns two values ;;; (i) a list of strings, = the taxonomy ;;; (ii) a list of all the concepts processed (= all of them) (defun make-tax (&optional (current-node '#$Thing) (relation-to-descend '#$subclasses) htmlify) (cond ((eq relation-to-descend '#$subclasses) (install-all-subclasses))) (cond ((and (eq current-node '#$Thing) (eq relation-to-descend '#$subclasses)) (let* ( (all-objects (dereference (get-all-concepts))) (top-classes (immediate-subclasses '#$Thing)) ) (multiple-value-bind (strings all-nodes-done) (make-taxes (sort (remove '#$Thing top-classes) #'string< :key #'symbol-name) relation-to-descend htmlify nil *indent-increment*) (let ( (unplaceds (remove-if-not #'named-instancep (set-difference all-objects (cons '#$Thing all-nodes-done)))) ) (append (cons "Thing" strings) (mapcar #'(lambda (unplaced) (tax-obj-write unplaced *indent-increment* htmlify :instancep '?)) (sort unplaceds #'string< :key #'symbol-name))))))) (t (make-tax0 current-node relation-to-descend htmlify)))) (defun make-tax0 (current-node relation-to-descend &optional htmlify nodes-done (tab 0)) (let ( (item-text (tax-obj-write current-node tab htmlify)) ) (cond ((member current-node *ignore-items*) (values (list item-text (format nil "~vTignoring children..." (+ tab *indent-increment*))) nodes-done)) (t (let* ( (all-instances (km0 `#$(the instances of ,CURRENT-NODE))) (named-instances (remove-if-not #'named-instancep all-instances)) (instances-text (mapcar #'(lambda (instance) (tax-obj-write instance (+ tab *indent-increment*) htmlify :instancep t)) (sort named-instances #'string< :key #'symbol-name))) (specs (sort (km0 `#$(the ,RELATION-TO-DESCEND #$of ,CURRENT-NODE)) #'string< :key #'symbol-name)) ) ; alphabetical order (cond ((and specs (member current-node nodes-done)) (values (list item-text (format nil "~vT..." (+ tab *indent-increment*))) nodes-done)) (t (multiple-value-bind (string new-nodes-done) (make-taxes specs relation-to-descend htmlify (cons current-node (append all-instances nodes-done)) (+ tab *indent-increment*)) (values (cons item-text (cons instances-text string)) new-nodes-done))))))))) (defun make-taxes (current-nodes relation-to-descend &optional htmlify nodes-done (tab 0)) (cond ((not (listp current-nodes)) (values nil nodes-done)) ; in case of a syntax error in the KB ((endp current-nodes) (values nil nodes-done)) ((> (/ tab *indent-increment*) *maxdepth*) (values (list (format nil "~vT...more..." (+ tab *indent-increment*))) nodes-done)) ((not (atom (first current-nodes))) ; in case of a syntax error in the KB (make-taxes (rest current-nodes) relation-to-descend htmlify nodes-done tab)) ((and (eq relation-to-descend '#$instance-of) (or (anonymous-instancep (first current-nodes)) ; don't show anonymous instances (not (kb-objectp (first current-nodes))))) ; or numbers or strings (make-taxes (rest current-nodes) relation-to-descend htmlify nodes-done tab)) (t (multiple-value-bind (string mid-nodes-done) (make-tax0 (first current-nodes) relation-to-descend htmlify nodes-done tab) (multiple-value-bind (strings new-nodes-done) (make-taxes (rest current-nodes) relation-to-descend htmlify mid-nodes-done tab) (values (list string strings) new-nodes-done)))))) (defun tax-obj-write (concept tab htmlify &key instancep) (concat (cond ((eq tab 0) "") ((eq instancep '?) (format nil "?~a" (spaces (1- tab)))) ; Unfortunately, (format nil "~vT" 0) = " " not "" ((eq instancep t) (format nil "I~a" (spaces (1- tab)))) ; Unfortunately, (format nil "~vT" 0) = " " not "" (t (format nil "~vT" tab))) ; Unfortunately, (format nil "~vT" 0) = " " not "" (objwrite2 concept htmlify))) ; (cond (htmlify (htextify concept (symbol-name concept) :action '"frame")) ; htmlify always nil for KM only ; (t (km-format nil "~a" concept))))) ;;; FILE: subsumes.lisp ;;; File: subsumes.lisp ;;; Author: Peter Clark ;;; Purpose: Checking subsumption. This is slightly tricky to do properly. ;;; In this implementation, no unification is performed. #| Note we want to distinguish between a. "The car owned by a person." (the car with (owner ((a person)))) b. "The car owned by person23." (the car with (owner ( _person23))) We could evaluate (a person) to create a Skolem, and then do unification with a subsumption flag in, but this doesn't work -- case a. and b. are indistinguishable, but we'd want unification with _person24 (say) to succeed in case a. and fail in b. Handler for (the X with SVs) in interpreter.lisp: ------------------------------------------------- 1. call subsumes (a X with SVs) to return an answer. 2. If no answer returned, call (a X with SVs) to create it. The base algorithm: ------------------- ;;; where subsumer-expr is form '(a Class with SlotsVals) (defun is0 (subsumee-instance subsumer-expr) 1. find an object O of type Class (person) 2. for each slot S on person a. compute vals Vs of O.S for each expr in the value of person.S IF expr is of form "(a ?class)" or "(a ?class with &rest)" THEN foreach V in Vs call (subsumes expr V) until success (removing V from Vs?) ELSE i. evaluate expr to find OVs ii. check OVs is a subset of Vs (and if so remove OVs from Vs?) (Note we're *not* allowing unification to occur) 3. If success, then return Subsumee-Instance |# ;;; > (find-subsumees '(a Car with (color (Red)))) (defun find-subsumees (existential-expr &optional (candidates (find-candidates existential-expr))) (remove-if-not #'(lambda (candidate-instance) (is0 candidate-instance existential-expr)) candidates)) ;;; ------------------------------ #| Finding all candidate instances which the existential expression might be referring to. There are two ways of doing this: (a Car with (owned-by (Porter)) (color (Brown)) (age (10)) (parts ((a Steering-wheel with (color (Red)))))) 1. follow inverse links (Porter owns Car), (Brown color-of), (10 age-of) However, this is incomplete for two reasons: (i) the implicit (instance-of (Car)) relation isn't searched -- but we can add it in. (ii) it will miss some items starting with non-symbols, eg. (10 age-of). 2. The answer(s) must be in the intersection of the answers returned, subject to: - we better also add (all-instance-of Car) to the set - if no instances are returned by a particular inversing, then we'll ignore it (assuming either it was a non-symbolic frame, or the evaluator has somehow failed to cache the answer even though it's there). INCOMPLETENESS: Suppose (Brown color-of) *does* return some values, but not including this Car (eg. this Car is an embedded unit? We'll fail then. Depends on how complete/efficient we want this. Now we just do this simple version below: |# (defun find-candidates (existential-expr) (let* ( (class+slotsvals (breakup-existential-expr existential-expr :fail-mode 'error)) ; [1] (class (first class+slotsvals)) (slotsvals (second class+slotsvals)) ) (mapc #'(lambda (slotvals) ; this will force some evaluation (find-candidates2 class slotvals)) ; of relevant frames slotsvals) ;;; (all-instances class))) ;;; NEW: Only instances on obj-stack are possible candidates, so obj-stack defines the context (remove-if-not #'(lambda (instance) (isa instance class)) (obj-stack)))) ;;; STRIPPED VERSION: ;;; [1] kb-objectp test to avoid (the part-number-of of 1) ;;; PURPOSE: to force some evaluation of relevant frames ;;; RETURNS: Irrelevant and discarded (defun find-candidates2 (class slotvals) (let* ( (slot (first slotvals)) (invslot (invert-slot slot)) (vexprs (second slotvals)) ) (mapc #'(lambda (vexpr) (cond ((existential-exprp vexpr) (mapc #'(lambda (val) (cond ((kb-objectp val) (km0 `(#$the ,class ,invslot #$of ,val))))) ; [1] (find-subsumees vexpr))) (t (let ( (kb-vals (remove-if-not #'kb-objectp (km0 vexpr))) ) ; [1] (cond (kb-vals (km0 `(#$the ,class ,invslot #$of ,(vals-to-val kb-vals))))))))) ; [2] vexprs))) #| ====================================================================== SUBSUMPTION TESTING ====================================================================== This below table gives the rules for transforming different forms of the expression into the BASE IMPLEMENTATION for "is0": SUBSUMES: ('(every X) subsumes '(every Y)) == ('(a Y) is '(a X)) ('(every X) subsumes {I1,..,In}) == (allof {I1,..,In} must ('(every X) covers It)) ({I1,..,In} subsumes '(every Y)) == ERROR ({I1,..,In} subsumes {J1,..,Jn}) == ({I1,..,In} is-superset-of {J1,..,Jn}) COVERS: ('(every X) covers '(a Y)) == ('(a Y) is '(a X)) ('(every X) covers I ) == (I is '(a X)) ({I1,..,In} covers '(a Y)) == (has-value (oneof {I1,..,In} where (It is '(a Y)))) ({I1,..,In} covers I ) == ({I1,..,In} includes I) IS: ('(a Y) is '(a X)) == gensym a YI, (YI is '(a X)), delete YI ('(a Y) is I ) == ERROR ( I is '(a X)) == *****BASE IMPLEMENTATION***** : (is0 I '(a X)) ( I1 is I2 ) == (I1 = I2) We also have to be careful: With (Animal subsumes Dog), we must be sure that the set (Animal) is recognized as a class description, not a set of instances. To do this, we convert (say) Dog to '(every Dog). |# (defun subsumes (xs ys) (let ( (x-desc (vals-to-class-description xs)) (y-desc (vals-to-class-description ys)) ) (cond ((and x-desc y-desc) ; ('(every X) subsumes '(every Y)) == ('(a Y) is '(a X)) (is (every-to-a y-desc) (every-to-a x-desc))) (x-desc ; ('(every X) subsumes {I1,..,In}) == (allof {I1,..,In} (km0 `#$(allof ,(VALS-TO-VAL YS) must (,X-DESC covers It)))) ; must ('(every X) covers It)) (y-desc ; ({I1,..,In} subsumes '(every Y)) == ERROR (report-error 'user-error "Doing (~a subsumes ~a)~%Can't test if a set subsumes an expression!~%" xs ys)) (t ; ({I1,..,In} subsumes {J1,..,Jn}) == ({I1,..,In} is-superset-of {J1,..,Jn}) (km0 `#$(,(VALS-TO-VAL XS) is-superset-of ,(VALS-TO-VAL YS))))))) (defun covers (xs y) (let ( (x-desc (vals-to-class-description xs)) (y-desc (cond ((and (quoted-expressionp y) (listp (unquote y)) (instance-descriptionp y :fail-mode 'error)) y))) ) ; instance-descriptionp will report error if necc. (cond ((and x-desc y-desc) ; ('(every X) covers '(a Y)) == ('(a Y) is '(a X)) (km0 `#$(,Y-DESC is ,(EVERY-TO-A X-DESC)))) (x-desc ; ('(every X) covers I ) == (I is '(a X)) (km0 `#$(,Y is ,(EVERY-TO-A X-DESC)))) (y-desc ; ({I1,..,In} covers '(a Y)) == (has-value (oneof {I1,..,In} (km0 `#$(has-value (oneof ,(VALS-TO-VAL XS) where (It is ,Y-DESC))))) ; where (It is '(a Y))) (t ; ({I1,..,In} covers I ) == ({I1,..,In} includes I) (km0 `#$(,(VALS-TO-VAL XS) includes ,Y)))))) ;;; [1]: Hmmm....We can't always guarantee KM will clean up after itself, as the computation [1a] may create additional ;;; instances which *aren't* deleted by the tidy-up [1b]. Could use a subsituation?? (defun is (x y) (cond ((equal y ''#$(a Class)) ; SPECIAL CASE - for metaclasses: '(every Dog) is '(a Class) (cond ((or (class-descriptionp x) (symbolp x))) ; succeed (t (report-error 'user-error "Doing (~a is ~a)~%~a doesn't appear to be a class or class description.~%" x y x)))) (t (let ( (x-desc (cond ((and (quoted-expressionp x) (listp (unquote x)) (instance-descriptionp x :fail-mode 'error)) x))) (y-desc (cond ((and (quoted-expressionp y) (listp (unquote y)) (instance-descriptionp y :fail-mode 'error)) y))) ) (cond ((and x-desc y-desc) ; ('(a X) is '(a Y)) == gensym a XI, (XI is '(a Y)), delete XI (description-subsumes-description x-desc y-desc)) (x-desc ; ('(a X) is I ) == ERROR (report-error 'user-error "Doing (~a is ~a)~%Can't test if an expression is `subsumed' by an instance!~%" x y)) (y-desc ; ( I is '(a Y)) == *****BASE IMPLEMENTATION***** (is0 x (unquote y-desc))) (t (km0 `#$(,X = ,Y)))))))) ; ( I1 is I2 ) == (I1 = I2) ;;; ---------------------------------------- ;;; Rewrite this to me more efficient - delete-frame is horrible for a large KB ;;; ---------------------------------------- #| [1] NB Not set it to NIL, in case this is recursive, to avoid: logging on, checkpoint C1 logging on (already on), checkpoint C2 backtrack to C2, logging off (urgh!) backtrack to C1, but some logging has been missed! |# (defparameter *remove-temporary-via-backtracking* t) (defun description-subsumes-description (x-desc y-desc) (cond (*remove-temporary-via-backtracking* (let ( (old-internal-logging *internal-logging*) (checkpoint-id (gensym)) ) (setq *internal-logging* t) (set-checkpoint checkpoint-id) (prog1 (let ( (tmp-i (km-unique0 (unquote x-desc) :fail-mode 'error)) ) (km0 `#$(,TMP-I is ,Y-DESC))) (undo checkpoint-id) ; undo, whatever (setq *internal-logging* old-internal-logging)))) ; [1] (t (let ( (tmp-i (km-unique0 (unquote x-desc) :fail-mode 'error)) ) (prog1 (km0 `#$(,TMP-I is ,Y-DESC)) ; [1a] (delete-frame tmp-i)))))) ; VERY inefficient with a large KB ;;; ---------------------------------------- ; [1] Causes problems with metaclasses! (defun vals-to-class-description (classes) (cond ((and (singletonp classes) (kb-objectp (first classes))) ; [1] (not (is-an-instance (first classes)))) `'(#$every ,(first classes))) ; (Dog) -> '(every Dog) ((and (singletonp classes) (descriptionp (first classes))) (cond ((class-descriptionp (first classes)) (let* ( (class+slotsvals (class-description-to-class+slotsvals (first classes))) (class (first class+slotsvals)) (slotsvals (second class+slotsvals)) ) `'(#$every ,class #$with ,@slotsvals))) (t (report-error 'user-error "Subsumption with ~a:~%Don't know how to do subsumption with this kind of expression!~%" (first classes))))))) ;;; '(every Cat) -> '(a Cat) ;(defun every-to-a (expr) `'(#$a ,@(rest (unquote expr)))) (defun every-to-a (expr) (let* ( (class+slotsvals (class-description-to-class+slotsvals expr)) (class (first class+slotsvals)) (slotsvals (second class+slotsvals)) ) (cond (slotsvals `'(#$a ,class #$with ,@slotsvals)) (t `'(#$a ,class))))) ;;; ====================================================================== ;;; BASE IMPLEMENTATION FOR SUBSUMPTION TESTING: COMPARE AN INSTANCE WITH A DESCRIPTION ;;; ====================================================================== #| [1] bind-self done for queries like: CL-USER> (is0 '#$_rectangle0 '#$(a rectangle with (length ((Self width))) (width ((Self length))))) MARCH 1999: CORRECTION! bind-self must be done *before* calling is0, as expr may be an embedded expression (thus Self refers to the embedding frame). [2] NB if no value in subsumer, then it *doesn't* subsume everything!! NOTE: expr is UNQUOTED here, to allow easy recursive calling of is0 [3] del-list expr (:triple Self position (a Position)) (a Position) is a single value instance (:triple _Light1 position (the position of _Light1)) is going to return a *list* of values for the third argument |# (defun is0 (instance expr) (cond ((and (km-structured-list-valp instance) (km-structured-list-valp expr) (eq (length (desource instance)) (length (desource expr))) (eq (first instance) (first expr))) (let ( (d-instance (desource instance)) (d-expr (desource expr)) ) (cond ((km-triplep d-instance) (and (is0 (second d-instance) (second d-expr)) (is0 (third d-instance) (third d-expr)) (some #'(lambda (val) (is0 val (fourth d-expr))) ; See [3] above (val-to-vals (fourth d-instance))))) (t (every #'(lambda (pair) (is0 (first pair) (second pair))) (rest (transpose (list d-instance d-expr)))))))) ; ((:seq :seq) (i1 e1) (i2 e2) ... ) ; Below [1], bind-self *may* appear redundant. However, expr ; *may* contain Self, if it came from a top-level query eg. ; KM> ((a Person with (owns (Self))) is (a Person with (owns (Self)))) ; (cond ; ((not (contains-self-keyword expr)) ; (km-format t "ERROR! Don't know how what `Self' refers to in the expression~%") ; (km-format t "ERROR! ~a~%" expr)) (t (let ( (class+slotsvals (bind-self (breakup-existential-expr expr) instance)) ) ; [1] (cond (class+slotsvals ;;; 1. An INDEFINITE expression (cond ((and (fluent-instancep instance) ;;; NOTE a fluent-instance _SomePerson23 CAN'T be subsumed by (eq (first expr) '#$a)) nil) ;;; a non-fluent-instance (a ...) (t (let ( (class (first class+slotsvals)) ;;; (so do subsumption) (slotsvals (second class+slotsvals)) ) (and (isa instance class) (are-slotsvals slotsvals) ; syntax check (every #'(lambda (slotvals) (slotvals-subsume slotvals instance)) slotsvals)))))) ((constraint-exprp expr) (satisfies-constraints (list instance) (list expr) nil)) ; nil = dummy slot name. This only occurs for things like ; (is0 (:seq 1 2) (:seq (<> 1) 2)) ;;; (t (let ( (definite-val (km-unique0 expr :fail-mode 'error)) ) ;;; 2. a DEFINITE expression ;;; Why 'error above?? (t (let ( (definite-val (km-unique0 expr)) ) ;;; 2. a DEFINITE expression (cond ((null definite-val) nil) ; [2] ;;; (so do equality) (t (equal definite-val instance)))))))))) ;;; Perhaps rather slow? ;;; Returns 't' in the keyword 'Self' occurs in expr, nil otherwise. (defun contains-self-keyword (expr) (cond ((null expr) nil) ((eq expr '#$Self)) ((listp expr) (or (contains-self-keyword (first expr)) (contains-self-keyword (rest expr)))))) #| (slotvals-subsume [1] is a quick, common lookahead, for calls like: (slotvals-subsume '#$(connects ((the Engine parts of _Car23))) '#$_Car23) where the connects of _Car23 is exactly ((the Engine parts of _Car23)). [2] Don't count constraints! eg. Want (<> 20) to subsume () ! Thus, we abort if (the foo of Self) - NIL, on the assumption that (the foo of Self) will return at least one item (?). June 2001 - This assumption isn't valid! So simplify this to just count existentials. The only case this doesn't hold is for the special `tag' slot. And in any case, see-constraints have been already removed by the KM call at [4b]! But: Put it back. Reason is we want to stop this: KM> (_Car23 is '(a Car with (color ((the favorite-color of (the owner of Self)))))) KM> (every Nice-Car has-definition (instance-of (Car)) (color ((the favorite-color of (the owner of Self))))) KM> (a Car) CLASSIFY: _Car23 is a Nice-Car! This slightly violates the semantics of the KB (strictly null attribute values should be ignored), but we assume that the rule is there for a reason and must return at least one value. [4a] Do a find-vals rather than a (km0 ...) call, as we *do* want to preserve constraints here in the special case of tags. [5] Jan 2001: Why ignore situation-specific slots? I'm confused why I put this constraint in. Let's remove it. |# (defun slotvals-subsume (slotvals instance) (let* ( (slot (first slotvals)) (ser-exprs (second slotvals)) ) (cond ((some #'(lambda (situation) ; [1] (equal ser-exprs (get-vals instance slot :situation situation))) (cons (curr-situation) (append (all-supersituations (curr-situation)) (visible-theories))))) ; ((not (situation-specificp slot)) ; otherwise fail it out ; [5] (t (cond ; tag slots no longer used ; ((and (tag-slotp slot) *are-some-constraints*) ; (is-consistent (append ser-exprs (find-vals instance slot)))) ; [4a] (t (let ( (see-vals (cond ((ignore-slot-due-to-situations-mode slot) (km-trace 'comment "Subsumption test: Ignoring attempt to compute (the ~a of ~a) in the global~% situation, as slot `~a' is a fluent (so can only take on situation-specific values)." slot instance slot)) (t (km0 `#$(the ,SLOT of ,INSTANCE))))) ) ; [4b] (cond ((<= (length (remove-constraints ser-exprs)) (length see-vals)) ; quick look-ahead check [2] ; (cond ((<= (length (remove-if-not #'existential-exprp ser-exprs)) (length see-vals)) ; quick look-ahead check [2] (cond ((eq slot '#$instance-of) ; special case (classes-subsume-classes ser-exprs see-vals)) ; assume no evaln needed (t (let ( (constraints (find-constraints-in-exprs ser-exprs)) ) (and (satisfies-constraints see-vals constraints slot) ; [3] (vals-subsume (cond ((single-valued-slotp slot) (&-expr-to-vals (first ser-exprs))) ; eg. ((a Car) & (must-be-a Dog)) (t ser-exprs)) see-vals)))))))))))))) ;;; GIVEN: some expressions, and some values ;;; RETURN t if *every* expression subsumes some (different) value in values. ;;; Notes: ;;; [1]: if expr includes, say, (a car), then consider it to subsume the first ;;; instance of car in the subsumee. ;;; [2]: Don't remove ser-vals from see-vals, as subsumer may have several ;;; exprs which evaluate to the *same* instance: ;;; eg. in (expr1 expr2), expr1 evals to (x1 x2) and expr2 evaluates (x2 x3) ;;; But if we remove (x1 x2) from see-vals (x1 x2 x3 x4) we get (x3 x4), ;;; and now (subsetp '(x2 x3) '(x3 x4)) undesirably fails, even though x2 ;;; is known to be in the full set see-vals. (defun vals-subsume (ser-exprs see-vals) (cond ((endp ser-exprs)) ; success!! ((equal ser-exprs see-vals)) ; quick success - don't need to recurse (t (let ( (ser-expr (first ser-exprs)) ) (cond ((or (existential-exprp ser-expr) (km-structured-list-valp ser-expr)) ; DON'T evaluate structured vals, preserve existentials in them (let ( (see-val (first (find-subsumees ser-expr see-vals))) ) ; [1] (cond (see-val (vals-subsume (rest ser-exprs) (remove see-val see-vals :test #'equal)))))) (t (let ( (ser-vals (km0 ser-expr)) ) (cond ((subsetp ser-vals see-vals :test #'equal) (vals-subsume (rest ser-exprs) see-vals)))))))))) ; [2] ;;; ====================================================================== ;;; UTILS ;;; ====================================================================== ;;; If expr is an existential expr, this returns a list ( ) of ;;; the existential expr's structure. ;;; (breakup-existential-expr '(a car with (age (old)))) -> (car ((age (old)))) (defun breakup-existential-expr (expr0 &key (fail-mode 'fail)) (let ( (expr (decomment-top-level expr0)) ) (cond ((and (listp expr) (member (first expr) '#$(a some)) (>= (length expr) 2)) (cond ((pairp expr) (list (second expr) nil)) ((eq (third expr) '#$with) (list (second expr) (rest (rest (rest expr))))) ((and (eq (third expr) '#$called) (eq (length expr) 4)) (list (second expr) `((#$called (,(FOURTH EXPR)))))) ((and (eq (third expr) '#$uniquely-called) (eq (length expr) 4)) (list (second expr) `((#$uniquely-called (,(FOURTH EXPR)))))) ((and (eq (third expr) '#$called) (eq (fifth expr) '#$with)) (list (second expr) (cons `(#$called (,(FOURTH EXPR))) (rest (rest (rest (rest (rest expr)))))))) ((and (eq (third expr) '#$uniquely-called) (eq (fifth expr) '#$with)) (list (second expr) (cons `(#$uniquely-called (,(FOURTH EXPR))) (rest (rest (rest (rest (rest expr)))))))) ((eq fail-mode 'error) (report-error 'user-error "Bad expression in subsumption testing ~a~%(Should be one of (a ?class) or (a ?class with &rest)).~%" expr)))) ((eq fail-mode 'error) (report-error 'user-error "Bad expression in subsumption testing ~a~%(Should be one of (a ?class) or (a ?class with &rest)).~%" expr))))) ;;; No error checking here (defun class-in-existential-expr (existential-expr) (second existential-expr)) ;;; ====================================================================== ;;; Syntactic sugar: ;;; Can say (the (Self parts Wing parts Engine)) ; the engine of a wing ;;; as well as (and equivalently) ;;; (the Engine with (parts-of ((a Wing with (parts-of (Self)))))) ;;; ====================================================================== #| > (path-to-existential-expr '(airplane01 parts wing)) (a wing with (parts-of (airplane01))) > (path-to-existential-expr '(airplane01 parts wing parts edp)) (a edp with (parts-of ((a wing with (parts-of (airplane01)))))) > (path-to-existential-expr '(airplane01 parts wing parts)) (a thing with (parts-of ((a wing with (parts-of (airplane01)))))) |# (defun path-to-existential-expr (path &optional (prep '#$a)) (path-to-existential-expr2 (rest path) (first path) prep)) (defun path-to-existential-expr2 (path embedded-unit prep) (cond ((endp path) embedded-unit) (t (let* ( (slot (first path)) (class (cond ((eq (second path) '*) '#$Thing) ((second path)) (t '#$Thing))) (rest-rest-path (rest (rest path))) (preposition (cond (rest-rest-path '#$a) (t prep))) (new-embedded-unit `(,preposition ,class with (,(invert-slot slot) (,embedded-unit)))) ) (path-to-existential-expr2 (rest (rest path)) new-embedded-unit prep))))) ;;; ====================================================================== ;;; REMOVE SUBSUMING EXPRESSIONS ;;; This is called by (compute-new-slotsvals old-slotsvals old-slotsvals) in frame-io.lisp ;;; ====================================================================== #| remove-subsuming-exprs: GIVEN: "exprs" - a set of existential exprs (plus some other exprs) "instances" - a set of instances (plus some other exprs) Returns three values: - the existential exprs (plus other exprs) not subsuming any instances - the instances (plus other exprs) not subsumed by any existential expr - the instances which were subsumed CL-USER> (remove-subsuming-exprs '#$((a Cat) (a Door)) '#$(_Door178 (a Elephant) _Bumper176)) ((a Cat)) ((a Elephant) _Bumper176) (_Door178) [1] an instance can only be subsumed by *one* expr [2] route this query through the KM interpreter, so the user can trace it if necessary BUT: 9.8.99 is very confusing to the user! Hide it instead. NOTE!! This routine should have NO SIDE EFFECTS, beyond evaluating definite paths already present. Apr 99: What we'd also like is: CL-USER> (remove-subsuming-exprs '#$((a Cat) (a Door) (a Elephant)) '#$(_Door178 (a Elephant with (size (Big))) _Bumper176)) CURRENT IMPLEMENTATION DESIRED ((a Cat) (a Elephant)) ((a Cat)) ; non-subsumers ((a Elephant with size (Big)) _Bumper176) (_Bumper176) ; non-subsumed (_Door178) ((a Elephant with (size (Big))) _Door178) ; subsumed [3] is more aggressive, it will cause a "hidden" instance to be actually created for purposes of testing, then discarded [4] This extra check to ensure (a Big-Engine) "subsumes" (_Engine23). This is modifying "subsuming" to mean "subsumes including allowing coercion". Note that (_Engine23) and (_Engine24) still *shouldn't* result in any removals, ie. we're *not* doing unification. eg. consider (Red color-of _Engine23) then (Red color-of _Engine24) ; don't want to unify the Engines. [4b] NOTE We have to exclude subsumption checks which include reference to Self, because the answer to the subsumption check depends on the instance in question! - PC This can only come with instances entered from the user, not from lazy-unifiable-expr-sets (where bind-self has PC necessarily already been conducted). [5] Clean up the junk, so as not to pollute the object stack. [6] Incorrect behaviour: ('(a Car) is '(a Car with (age ((the foo of Self))))) -> NIL ; correct but (every Car has (age ((a Thing)))) ('(a Car) is '(a Car with (age ((the foo of Self))))) -> t ; incorrect! This is because KM treats this as equivalent to ((a Car) is '(a Car with (age ((the foo of Self))))) which is wrong!!! [7a] It looks like we should record explanation here, but we don't need to as &+ takes care of it. [7b] As far as I can tell this branch NEVER gets taken with &+, as Self will always be removed, allow-coercion is always t, and &+ is stronger than is. (So if &+ fails, `is' will too, necessarily) |# (defun remove-subsuming-exprs (exprs instances &key allow-coercion target) (cond ((and (tracep) (not (tracesubsumesp))) (suspend-trace) (multiple-value-bind (non-subsumers non-subsumed subsumed) (remove-subsuming-exprs0 exprs instances :allow-coercion allow-coercion :target target) (unsuspend-trace) (values non-subsumers non-subsumed subsumed))) (t (remove-subsuming-exprs0 exprs instances :allow-coercion allow-coercion :target target)))) (defun remove-subsuming-exprs0 (exprs instances &key allow-coercion target) (cond ((or (null exprs) (null instances)) (values exprs instances nil)) (t (let* ( (subsumed-instance (cond ((or (existential-exprp (first exprs)) ; (km-triplep (first exprs))) (km-structured-list-valp (first exprs))) (find-if #'(lambda (instance) (cond ((is-an-instance instance) ; NB includes (:args foo) and (:triple a b c) (or ;;; PC CAN I safely get rid of this expensive and ;;; PC confusing test? -> ...turns out for big KBs, it's actually cheaper to do this test! ; (km0 `#$(,INSTANCE is ',(FIRST EXPRS))) (and allow-coercion ; [4] #| hmm...|# (or (existential-exprp (first exprs)) (km-structured-list-valp (first exprs))) (not (contains-self-keyword (first exprs))) ; [4b] (km0 `(,instance &+ ,(first exprs)) :target target) ; NOTE: no record-explanation here [7a] ))) ((and (existential-exprp instance) (not (contains-self-keyword (first exprs)))) ; [6] ; (km-format t "**HERE!!**~%") (km0 `#$(',INSTANCE is ',(FIRST EXPRS)))))) ; NEW ; NOTE: no record-explanation here [7b] instances)))) (instances0 (cond (subsumed-instance (remove subsumed-instance instances :test #'equal :count 1)) (t instances))) ) (multiple-value-bind (unused-exprs unused-instances subsumed-instances) (remove-subsuming-exprs0 (rest exprs) instances0 :allow-coercion allow-coercion :target target) (cond (subsumed-instance (cond ((and target *record-explanations*) (record-explanation-for target subsumed-instance (first exprs)))) (values unused-exprs unused-instances (cons subsumed-instance subsumed-instances))) (t (values (cons (first exprs) unused-exprs) unused-instances subsumed-instances)))))))) ;;; Quick lookahead for _Engine23 (a Engine) : the immediate-classes of _Engine23 must subsume or be subsumed by Engine. ;;; If this test fails, then we needn't proceed further. ;;; expr is necessarily of the form (a ), or (a with ...) ;(defun classes-subsumep-test (instance expr) ; (let ( (i-classes (immediate-classes instance)) ; (e-classes (list (second expr))) ) ; (or (classes-subsume-classes e-classes i-classes) ; (classes-subsume-classes i-classes e-classes)))) ;(defun classes-subsumep-test (i-classes e-classes) ; (or (equal i-classes e-classes) ; for efficiency ; (classes-subsume-classes e-classes i-classes) ; (classes-subsume-classes i-classes e-classes))) ;;; ====================================================================== ;;; Compute most general specialization(s) of a concept description ;;; Used for KM> (the-class-of ...) expressions. ;;; Not used for now. ;;; ====================================================================== #| The class has to be input as an instance expression. mgs returns the most general class(es) subsumed by that expression. The algorithm searches down the taxonomy (general-to-specific) from the class provided, until it hits candidates. Instances are not searched. The algorithm is similar to finding subsumed instances, except the candidates are classes, and we instant-ify them. CL-USER> (mgs '#$(a Physobj with (produces (*Electricity)))) (Power-Supply) ;;; Return most general class(es) subsumed by existential-expr. (defun mgs (existential-expr) (let* ( (class+slotsvals (breakup-existential-expr existential-expr :fail-mode 'error)) (class (first class+slotsvals)) ) (cond (class (remove-duplicates (mgs2 existential-expr class)))))) ;;; Return most general subclass(es) of class subsumed by existential-expr. (defun mgs2 (existential-expr class) (mapcan #'(lambda (subclass) ; WAS my-mapcan - #'mapcan safe here! (cond ((is0 (km-unique0 `#$(a ,SUBCLASS) :fail-mode 'error) existential-expr) (list subclass)) (t (mgs2 existential-expr subclass)))) (km0 `#$(the subclasses of ,CLASS)))) |# ;;; ====================================================================== (defun valset-subsumes-valset (valset1 valset2) (cond ((endp valset1)) ((null valset2) nil) ; some valset2 without correlates in valset1 (t (let ( (val1 (first valset1)) ) (cond ((member val1 valset2 :test #'equal) (valset-subsumes-valset (rest valset1) (remove val1 valset2 :test #'equal :count 1))) ((existential-exprp val1) (let ( (val2 (find-if #'(lambda (val) (cond ((is-an-instance val) (is0 val val1)) ; takes an instance and an (unquoted) expr ((existential-exprp val) (is `',val `',val1)))) valset2)) ) (cond (val2 (valset-subsumes-valset (rest valset1) (remove val2 valset2 :test #'equal :count 1))))))))))) #| ;;; More efficient but less thorough, expecting ordering to be preserved. ;;; val2 is more specific than val1 (defun valset-subsumes-valset (valset1 valset2) (cond ((endp valset1)) ((null valset2) nil) ; some valset2 without correlates in valset1 (t (let ( (val1 (first valset1)) (val2 (first valset2)) ) (cond ((equal val1 val2) (valset-subsumes-valset (rest valset1) (rest valset2))) ((existential-exprp val1) (let ( (successp (cond ((is-an-instance val2) (is0 val2 val1)) ; takes an instance and an (unquoted) expr ((existential-exprp val2) (is `',val2 `',val1)))) ) (cond (successp (valset-subsumes-valset (rest valset1) (rest valset2))))))))))) |# ;;; FILE: prototypes.lisp ;;; File: prototypes.lisp ;;; Author: Peter Clark ;;; Date: May 1999 ;;; Purpose: Knowledge Representation using Prototypes -- the answer to life! ;;; Neah, don't do this for now, but leave it as an option (defvar *record-explanations-for-clones* nil) ;;; Used for cloning itself: Don't follow these slots when cloning the prototype graph. ;;; June 2001: cloned-from NOT in this list, to allow clones to be added into prototypes ;;; March 2004: Make this a parameter (not constant), so user can change it (defparameter *unclonable-slots* '#$(prototype-participant-of prototype-of prototype-participants prototypes prototype-scope)) ;;; Used by get-slotvals.lisp. DON'T use cloning as a method for finding vals for these slots. ;(defconstant *slots-not-to-clone-for* '#$(prototype-participant-of prototype-participants prototypes prototype-of #|source|# instance-of cloned-from)) ;;; We can tell if it's cloned or not like this (defun isa-clone (instance) (and (kb-objectp instance) (get-vals instance '#$cloned-from :situation *global-situation*))) ;;; ---------- ; (defvar *curr-prototype* nil) ; in header.lisp (defun am-in-prototype-mode () *curr-prototype*) (defun curr-prototype () *curr-prototype*) (defun protoinstancep (concept) (get-unique-val concept '#$prototype-participant-of :situation *global-situation*)) ;(defun prototypep (concept) (get-unique-val concept '#$prototype-of :situation *global-situation*)) (defun prototypep (concept) (get-vals concept '#$prototype-of :situation *global-situation*)) ; Not used any more. ;;; concept /= generic, but a special case of it. ;(defun qualified-prototypep (concept) ; (and (prototypep concept) ; (find-vals concept '#$activity-type))) ;;; ====================================================================== ;;; LAZY CLONING: ;;; We only clone prototypes which have a value for the slot of interest. ;;; ====================================================================== ;;; If slot is nil, then all prototypes are unified in. Returned result is irrelevant (nil). ;;; 9/22/03: New: return list of prototypes unified in (defun unify-in-prototypes (instance0 &optional slot) (let* ( (instance (dereference instance0)) ; identity may change with each iteration (prototype (first-applicable-prototype instance slot)) ) (cond (prototype (unify-in-prototype instance prototype slot) (cons prototype (unify-in-prototypes instance slot)))))) ;;; with eager unification, we can end up in an infinite loop with big KBs (e.g. aeronet.km) ;;; So make this toggleable (defvar *eagerly-unify-prototypes* nil) ;(defvar *eagerly-unify-prototypes* t) (defvar *trace-unify-in-prototype* nil) ;;; [4] KM 1.4.0-beta32, we substantially simplified prototypes so that a prototype will never draw any external information in ;;; when building a prototype, so the problem [3] never occurs. ;;; The implementation of (obj-stack), called by remove-from-stack, is terrifyingly inefficient!!!! ;;; sequential version no longer may get into these looping problems ;;; [5] Neah, with situations we need to clone and merge for each situation, unfortunately. ;;; In particular, we want any CONSTRAINTS to be passed down to instances in EVERY situation, and constraints aren't projected. ;;; RETURNS: Irrelevant ;;; [6] We cannibalize the stack to make sure we don't unify a prototype as part of unifying the same prototype. The stack is ;;; searched in applicable-prototypes to check on this. ;;; [7] If cloned-from is a non-fluent, so we only ever clone once, then we better unify in Global so any local values and ;;; constraints are universally applicable ;;; [8] June 2001: If cloned-from is a non-fluent, then we only ever clone once. So we better put all the clone results in *Global, so that ;;; any constraints are universally applicable. (defun unify-in-prototype (instance prototype &optional slot) ; slot is purely for tracing purposes (cond (*trace-unify-in-prototype* (km-format t "UNIFYING IN PROTOTYPE ~a for ~a~%" prototype instance))) ; just for Shaken use (km-push `#$(unify-with-clone-of ,PROTOTYPE)) ; [6] ; (let ( (clone (km-unique0 `#$(clone ,PROTOTYPE))) ) ; [3] route through query interpreter for tracing (let ( (clone (cond (*clones-are-global* (km-unique0 `#$(in-situation *Global (clone ,PROTOTYPE)))) ; [3] route through query interpreter for tracing [8] (t (km-unique0 `#$(clone ,PROTOTYPE))) )) ) ; [3] route through query interpreter for tracing ; [4] (remove-from-stack prototype) ; remove side-effect, to stop looping! [2] (cond ((null slot) (make-comment "Cloned ~a~28T -> ~a~%~43Tto find all info about ~a" prototype clone instance)) (t (make-comment "Cloned ~a~28T -> ~a~%~43Tto find (the ~a of ~a)" prototype clone slot instance))) (add-val instance '#$cloned-from prototype nil (target-situation (curr-situation) instance '#$cloned-from)) (cond (*eagerly-unify-prototypes* (km0 `(,instance &! ,clone) :fail-mode 'error)) ; route through query interpreter (t (km0 `(,instance & ,clone) :fail-mode 'error))) ; route through query interpreter ; [4] (remove-from-stack prototype) ) (km-pop)) ;;; We only clone prototype roots, not things which are *in* a prototype ;(defun find-and-clone-prototypes (instance slot) ; (mapcar #'clone (applicable-prototypes instance slot))) ;;; Returns a list of prototypes which can validly provide values of slot for instance ;;; NB We must do the "already-done" test *after* the suitable-for-cloning work, because suitable-for-cloning may ;;; itself create new prototypes when doing the subsumption check! ;;; [1] If P1 and P2 are prototypes to clone, but P2 is already cloned from P1, then don't reclone P1! ;;; I assume you can't get mutual dependencies, where P1 is cloned from P2, is cloned from P1. ;;; [2] March 2001 - return just the first one instead ;(defun applicable-prototypes (instance slot) ; OLD [2] ; (remove-if-not #'(lambda (prototype) ; OLD [2] (defun first-applicable-prototype (instance &optional slot) ; NEW [2] (find-if #'(lambda (prototype) ; NEW [2] (suitable-for-cloning instance slot prototype)) (my-mapcan #'(lambda (class) (get-vals class '#$prototypes :situation *global-situation*)) (all-classes instance)))) ; No longer used ;;; Returns a list of prototypes which can provide values of slot for instance, valid for a particular context only ;(defun qualified-prototypes (instance slot) ; (let* ( (all-classes (all-classes instance)) ; (all-prototypes (remove-if-not #'protoinstancep (my-mapcan #'(lambda (class) ; (find-vals class '#$instances)) ; all-classes))) ; (qualified-prototypes (remove-if-not #'(lambda (prototype) ; (find-vals prototype slot)) ; all-prototypes)) ) ; qualified-prototypes)) ;;; Should we clone prototype to find the slot of instance? ;;; [1] This is comparing just along one dimension of "context space" ;;; [2] It's not obvious, but we only ever need to clone a prototype *once* per instance, namely in the highest supersituation in which that ;;; instance is an instance-of the prototype class. In any next-situations, the values will then be projected. In any new-situations, ;;; the instance will have no known instance-of relationship, and thus the cloning wouldn't be valid anyway. ;;; [6] This catastrophic kind of looping should *never* occur, but we better test for it anyway! See test-suite/protolooping2.km for ;;; a case where it might be necessary. (defun suitable-for-cloning (instance slot prototype) (and (neq instance prototype) ; don't clone yourself! (prototypep prototype) ; 1. Is a prototype (or ; Ignore constraint 2 -- it may provide other valuable info!! (null slot) (instance-has-something-to-say-about prototype slot)) (neq prototype (curr-prototype)) ; 4. don't clone curr prototype to help answer query during building curr prototype! (cond (*clones-are-global* (not (member prototype (get-vals instance '#$cloned-from :situation (target-situation (curr-situation) instance '#$cloned-from))))) (t (not (member prototype (km0 `#$(the cloned-from of ,INSTANCE)))))) ; allow cloned-from to project, to avoid re-cloning in all sitns ; (not (looping-on `#$(unify-with-clone-of ,PROTOTYPE))) ; See note [6] in unify-in-prototype, and above ; 5. do subsumption check, to make sure instance satisfies prototype's qualifications (progn (km-trace 'comment "Seeing if prototype ~a is applicable to ~a..." prototype instance) (satisfies-prototype-definition instance prototype)))) ;;; 1/16/04 - allow multiple prototype-scope statements (defun satisfies-prototype-definition (instance prototype) ; (km0 `(,(get-unique-val prototype '#$prototype-scope :situation *global-situation*) #$covers ,instance))) (some #'(lambda (prototype-scope) (km0 `(,instance #$isa ,prototype-scope))) (get-vals prototype '#$prototype-scope :situation *global-situation*))) #| ====================================================================== CLONING A prototype is an anonymous prototype instance, connected to a network of other instances, which can be both: - anonymous prototype instances - named instances Cloning involves building a copy of this network, with prototype instances replaced with new anonymous instances. Note that cloning DOESN'T do any evaluation of expressions, they are just cloned as is. ====================================================================== |# ;(defvar *cloning* nil) ;;; clone returns the cloned instance, and (if you're interested) the mapping-alist from proto-instances to cloned-instances. (defun clone (prototype) (cond ((tracep) (suspend-trace) (multiple-value-bind (clone mapping-alist) (clone0 prototype) (unsuspend-trace) (values clone mapping-alist))) (t (clone0 prototype)))) #| [1] prevents trying to clone P to find info about a clone of P. Later: instead of flagging "nil" here, I added cloned-from as a non-inverse-recording slot, to prevent this problem in general. For example: I1 & Clone1, where Clone1 has cloned-from X, results in X being added to the object stack when the unified result is asserted into memory and the inverses are automatically installed. [2] This call to km causes redundant work: Suppose my clone is (:set (_ProtoCar1 has (parts (_ProtoEngine1))) ; (i) (_ProtoEngine1 has (parts-of (_ProtoCar1 _ProtoTransmission1))) ; (ii) ...) (i) will assert both _ProtoCar1 and the inverse link (_ProtoEngine1 parts-of _ProtoCar1) Then at (ii), because _ProtoEngine1 already has some slotsvals, KM will merge in rather than just assert the given slotsvals. And this merging can be computationally complex (?) [though I think my optimizations filters these out]? But worse: If we load a prototype while in prototype mode, ( has ) will be followed by an (evaluate-paths), which is killingly expensive and unnecessary! A put-slotsvals will work fine here, it will clober any old values (eg. any earlier-installed inverses), but that's fine as the new values should necessarily include those old values. [3] It's not clear that we really need to keep these prototype-participant links, (they could be recomputed by a search algorithm if really necessary). I'll leave them for now, as I went to all the trouble!. RETURNS: two values: the clone name, and also the mappings from proto-instances to the cloned instances |# (defun clone0 (prototype) ; (setq *cloning* t) (cond ; ((not (protoinstancep prototype)) ; bug? ((not (prototypep prototype)) (report-error 'user-error "Attempt to clone a non-prototype ~a!~%" prototype)) (t (multiple-value-bind (clones mapping-alist) ; clones = list of KM expressions to build them. mappings = list of ( . ) pairs (build-clones prototype) ; compute what clones would look like (let* ( (clone-of-prototype (rest (assoc prototype mapping-alist))) ); find the clone of the ROOT instance (not its embedded instances) ) (mapc #'(lambda (clonename+slotsvals) ; expr = ( ) ; NEW drop (let ( (clone-name (first clonename+slotsvals)) (slotsvals (second clonename+slotsvals)) ) (add-slotsvals clone-name slotsvals) ; install-inversesp = t; eg. (I instance-of C), we *do* need ; Neah... ; (cache-explanation-for clone-name `#$(cloned-from ,PROTOTYPE (,CLONE-OF-PROTOTYPE))) ; Neah again...well (1/8/02) let's make it switchable... (cond ((and *record-explanations* *record-explanations-for-clones*) (mapc #'(lambda (slotvals) (let* ( (slot (slot-in slotvals)) (target `#$(the ,SLOT of ,CLONE-NAME)) ) (mapc #'(lambda (val) (record-explanation-for target val `#$(cloned-from ,PROTOTYPE))) (vals-in slotvals)))) slotsvals))) (cond ((am-in-prototype-mode) ; 1.4.5.17 - allow cloning *within* a prototype too (add-val clone-name '#$prototype-participant-of (curr-prototype) t *global-situation*))))) ; install-inverses = t; Note in GLOBAL situation clones) ; inverse (C instances I) installed ;;; New: 1/10/02 - copy *all* explanations over. **NOTE** These will be deposited in the *GLOBAL* situation, ;;; because, cloning is necessarily done in the global situation ONLY (see (in-situation *Global ...) in unify-in-prototype earlier) ; (km-format t "mapping-alist = ~a~%" mapping-alist) (cond (*record-explanations* (mapc #'(lambda (participant-dot-clone) (let* ( (participant (first participant-dot-clone)) (clone (rest participant-dot-clone)) (explanations (get-all-explanations participant)) ) (cond (explanations (put-explanations clone (sublis mapping-alist explanations)))))) mapping-alist))) ; (add-val clone-of-prototype '#$cloned-from prototype nil *global-situation*) ; install-inverses = nil [1] ; NEW: add cloned-from links for *all* participants. Then we can get a constant handle on them. (mapc #'(lambda (protopart-dot-clone) (let ( (protopart (first protopart-dot-clone)) (clone (rest protopart-dot-clone)) ) (cond (*clones-are-global* (add-val clone '#$cloned-from protopart nil *global-situation*)) ; install-inverses = nil [1] (t (add-val clone '#$cloned-from protopart nil))))) ; install-inverses = nil [1] mapping-alist) (values clone-of-prototype mapping-alist)))))) ; return clone of prototype #| ====================================================================== build-clones: Redefined Mar 2000, rather than walking the clone graph, we know all the proto-instances already as they're stored on the prototype-participants slot of the clone root! Returns two values: - a list of ( ) triples - the clone-instance mapping, a list of ( . ) acons's. ====================================================================== |# ;;; This was originally meant to allow prototypes to include some situation-specific components, but this generates errors when cloning! (defun build-clones (prototype) (let* ( (prototype-participants (km0 `#$(the prototype-participants of ,PROTOTYPE) :fail-mode 'error)) ; includes prototype e.g. (_ProtoCar1 _ProtoWheel2) (clone-names (mapcar #'(lambda (prototype-participant) (cond ((anonymous-instancep prototype-participant) (create-instance-name (first (immediate-classes prototype-participant)))) (t prototype-participant))) prototype-participants)) (mapping-alist (pairlis prototype-participants clone-names)) ) ; (pairlis '(_ProtoCar1 _ProtoWheel2) '(_Car3 _Wheel4)) -> (values (remove nil (mapcar #'(lambda (prototype-participant) ; ((_ProtoCar1 . _Car3) (_ProtoWheel2 . _Wheel4)) (build-clone prototype-participant mapping-alist)) ; nil: some prototype-participants need no assertions prototype-participants)) mapping-alist))) (defun build-clone (prototype mapping-alist) (let* ( (clone-name (rest (assoc prototype mapping-alist))) (slotsvals (get-slotsvals prototype :situation *global-situation*)) ; now prototypes are *only* in the global situation (new-slotsvals (remove-if #'(lambda (svs) (member (slot-in svs) *unclonable-slots*)) slotsvals)) ) (cond (new-slotsvals (list clone-name (sublis mapping-alist (dereference new-slotsvals))))))) ;;; ====================================================================== ;;; NOTE: This records the KM commands which created the prototype, purely as comments ;;; for a showme command. These are *not* retained by (save-kb ...). (defun add-to-prototype-definition (prototype expr) (let ( (definition-so-far (get prototype 'definition)) ) (km-setf prototype 'definition (append definition-so-far (list expr))))) ;;; FILE: think.lisp ;;; File: think.lisp :-) ;;; Author: Peter Clark ;;; Date: Dec 1999 ;;; Purpose: Experimental, exhaustive forward-chaining on all instances in the object stack (defun build (km-expr) (new-context) (let ( (seed (km-unique0 km-expr :fail-mode 'error)) ) (cond ((or (protoinstancep seed) (not (anonymous-instancep seed))) (km-format t "ERROR! ~a should return an anonymous instance!~%" km-expr)) (t (exhaustively-forward-chain) (dereference seed))))) ;;; This avoids inefficient recomputing of obj-stack each time (defun exhaustively-forward-chain (&optional (todo (obj-stack)) done) (cond ((endp todo) ; (format t ".") (let ( (new-todo (set-difference (obj-stack) done)) ) (cond (new-todo (exhaustively-forward-chain new-todo done))))) (t (let* ( (next-instance0 (first todo)) (next-instance (dereference next-instance0)) ) (cond ((and (not (member next-instance done)) (anonymous-instancep next-instance) (not (protoinstancep next-instance))) (unify-in-prototypes next-instance))) (exhaustively-forward-chain (rest todo) (cons next-instance0 done)))))) ;;; FILE: loadkb.lisp ;;; File: loadkb.lisp ;;; Author: Peter Clark ;;; Date: 21st Oct 1994 (defvar *current-renaming-alist* nil) (defvar *stats* nil) ; internal back door for keeping records ;;; ====================================================================== ;;; LOADING A KB ;;; ====================================================================== #| load-kb Options: :verbose t - print out evaluation of expressions during load (useful for debugging a KB) :with-morphism - Experimental: table is a list of pairs. Occurences of old-symbol are syntactically changed to new-symbol before evaluation. See note [1] below. :eval-instances t - Force recursive evaluation of the slot-val expressions on the instances. As a result, this creates the instance graph eagerly rather than lazily. :in-global t - Evaluate expressions in the global situation, not the current situation. [1] SYMBOL RENAMING: This isn't quite right: a new symbol renaming table over-rides, rather than augments, any earlier symbol table. Also it's rather ugly with the global variable...update later... (load-kb "fred.km" :verbose t :with-morphism '((Node Elec-Device) (Arc Wire))) Symbol renaming is performed as a purely syntactic preprocessing step. |# ;;; This is a top-level call by the user, issued from the USER> rather than KM> ;;; prompt. As a result, we must mimic the initializations that the KM> prompt gives, ;;; and in particular CATCH any throws from the user aborting from the debugger. (defun load-kb (file &key verbose with-morphism eval-instances load-patterns) (reset-inference-engine) (let ( (was-logging *logging*) ) (unwind-protect ; protect logging status in case syntax error in KB (progn (stop-logging :with-comment nil) (multiple-value-bind (answer error) (load-kb0 file :verbose verbose :with-morphism with-morphism :eval-instances eval-instances :load-patterns load-patterns) (declare (ignore answer)) (cond (error (format t "(Execution aborted)~%NIL~%") (values nil error)) (t ; (km-format t "~a~%" answer) (princ (report-statistics)) (terpri) '#$(t))))) (cond (was-logging (start-logging :with-comment nil)))))) ;;; This is the version called from the KM> prompt or load-kb (above). ;;; in-global is permenantly t, for now (defun load-kb0 (file &key verbose with-morphism eval-instances (in-global t) load-patterns) (format t "Loading ~a...~%" file) (let ( (renaming-alist (cond (with-morphism (setq *current-renaming-alist* (triples-to-alist with-morphism)) *current-renaming-alist*) (t *current-renaming-alist*))) (stream (open file :direction :input :if-does-not-exist nil)) ) (cond ((null stream) (values nil (km-format nil "No such file ~a!~%" file))) (t (cond (in-global (global-situation))) ; change to the global situation (multiple-value-bind (result error) (load-exprs (case-sensitive-read-km stream nil nil) stream verbose renaming-alist eval-instances load-patterns) (close stream) (reset-done) ; remove all `already computed' flags (cond (with-morphism (setq *current-renaming-alist* nil))) (cond (error (format t "Loading of ~a aborted!~%" file)) (t (format t "~a loaded!~%" file))) (values result error)))))) ;;; 3/20/01 - rewritten to pass error back up to load-kb (defun load-exprs (expr stream &optional verbose renaming-alist eval-instances load-patterns) (let ( (renamed-expr (rename-symbols expr renaming-alist)) ) (cond ((null renamed-expr)) ((and (listp renamed-expr) (eq (first renamed-expr) '#$symbol-renaming-table)) (format t "(Symbol renaming table encountered and will be conformed to)~%") (load-exprs (case-sensitive-read-km stream nil nil) stream verbose (triples-to-alist (second renamed-expr)) eval-instances load-patterns)) ((and load-patterns (notany #'(lambda (pattern) ; only do these (minimatch renamed-expr pattern)) load-patterns)) (load-exprs (case-sensitive-read-km stream nil nil) stream verbose renaming-alist eval-instances load-patterns)) (verbose (print-km-prompt) (km-format t " ~a~%" renamed-expr) (reset-inference-engine) (multiple-value-bind (results error) (km-eval-print renamed-expr :fail-mode *top-level-fail-mode*) (cond ((or eval-instances (am-in-prototype-mode)) (eval-instances results))) (cond (error (values nil error)) (t (load-exprs (case-sensitive-read-km stream nil nil) stream verbose renaming-alist eval-instances load-patterns))))) (t ; (reset-inference-engine) - no, let's keep the counter running for the whole KB (setq *catch-explanations* nil) ; but DO need this bit (cond (*catch-next-explanations* (setq *explanations* nil) (setq *catch-explanations* t) (setq *catch-next-explanations* nil))) (multiple-value-bind (results error) (km-eval renamed-expr :fail-mode *top-level-fail-mode*) (cond ((or eval-instances (am-in-prototype-mode)) (eval-instances results))) (cond (error (values nil error)) (t (load-exprs (case-sensitive-read-km stream nil nil) stream verbose renaming-alist eval-instances load-patterns)))))))) ;;; ---------- (defun rename-symbols (expr renaming-alist) (sublis renaming-alist expr)) ;;; '((1 -> a) (2 -> b)) -> ((1 . a) (2 . b)) ;;; ^ ^ ;;; local global ;;; We do this conversion so that we can use built-in sublis to do the symbol renaming. (defun triples-to-alist (triples) (cond ((quotep triples) (triples-to-alist (unquote triples))) ((or (not (listp triples)) (not (every #'(lambda (x) (and (triplep x) (symbolp (first x)) (eq (second x) '->))) ; (symbolp (third x)))) triples))) (report-error 'nodebugger-error ":with-morphism: renaming table should be a list of triples of the form~% ((OldS1 -> NewS1) (OldS2 -> NewS2) ...)~%")) (t (mapcar #'(lambda (triple) (cond ((not (triplep triple)) (report-error 'nodebugger-error "Non-triple found in the symbol renaming table!~%Non-triple was: ~a. Ignoring it...~%" triple)) (t (cons (first triple) (third triple))))) triples)))) ;;; ---------------------------------------- ;; Useful macro, callable from top-level prompt. (defun reload-kb (file &key verbose with-morphism eval-instances load-patterns) (reset-kb) (load-kb file :verbose verbose :with-morphism with-morphism :eval-instances eval-instances :load-patterns load-patterns)) ;;; Same, callable from within KM (defun reload-kb0 (file &key verbose with-morphism eval-instances load-patterns) (reset-kb) (load-kb0 file :verbose verbose :with-morphism with-morphism :eval-instances eval-instances :load-patterns load-patterns)) ;;; ====================================================================== ;;; LOWEST-LEVEL ACCESS TO THE PROPERTY LISTS ;;; ====================================================================== ;;; Converted to using hash table for KB-objects thanks to Adam Farquhar (defvar *kb-objects* (make-hash-table :test #'eq)) (defun getobj (name facet) (cond ((and (not (member facet *all-facets*)) (not (isa-situation-facet facet))) (report-error 'program-error "(getobj ~a ~a) Don't recognize facet ~a!~%(Should be one of ~a)~%" name facet facet *all-facets*)) ((kb-objectp name) (setq *statistics-kb-access* (1+ *statistics-kb-access*)) (get name facet)) ((is-km-term name) nil) ; Valid get, but no attributes. This includes 1 'a "12" (:seq a b c) #'+ (:set a b c) (t (report-error 'program-error "Accessing frame ~a - the frame name `~a' should be an atom!~%" name name)))) ;;; To DELETE an object, now use delete-frame (above). ;;; (putobj nil won't remove object from *kb-objects*) (defun putobj (fname slotsvals facet) (cond ((and (not (member facet *all-facets*)) (not (isa-situation-facet facet))) (report-error 'program-error "(putobj ~a ~a) Don't recognize facet ~a!~%(Should be one of ~a)~%" fname facet facet *all-facets*)) (slotsvals ; (setf (get fname facet) slotsvals) ;put it on the p-list ; (make-transaction `(setf ,fname ,facet ,slotsvals)) ;put it on the p-list (km-setf fname facet slotsvals) (cond ((not (gethash fname *kb-objects*)) ; (setf (gethash fname *kb-objects*) t) ; (make-transaction `(add-to-kb ,fname)) (km-add-to-kb-object-list fname) ))) (t (remprop fname facet)))) ;;; ====================================================================== ;;; ROLLBACK MECHANISM ;;; ====================================================================== #| KM> (every man has (parts ((a Head)))) KM> (Pete has (instance-of (Man))) KM> (undo) Undone (Pete has (instance-of (Man)))... KM> |# (defvar *history* nil) ; (defvar *logging* nil) - in header.lisp (defun reset-history () (setq *history* nil)) (defconstant *checkpoint* 'checkpoint) (defun checkpoint-p (x) (and (pairp x) (equal (first x) *checkpoint*))) (defun checkpoint-id (x) (second x)) (defun set-checkpoint (&optional (checkpoint-id 't)) (cond ((or *logging* *internal-logging*) (push (list *checkpoint* checkpoint-id) *history*) t))) ;;; From Ken Murray (defun next-checkpoint () (second (first (member *checkpoint* *history* :key #'first)))) (defun undo-possible (&optional checkpoint-id) (cond (checkpoint-id (member (list *checkpoint* checkpoint-id) *history* :test #'equal)) (t (assoc *checkpoint* *history*)))) ;;; May 2001 - revise this: (undo ) will undo right back to (if it exists) ;;; Returns NIL if no undo possible, if so. ;;; If checkpoint-id = nil, then just undo to the last checkpoint. ;;; [1] When called from a program, need to do this. When called from KM> prompt, this is done automatically anyway ;;; by (reset-inference-engine) ;;; [2] With *internal-logging*, the done flags ARE on the history trace and so undo0 will undo them. This is better ;;; than undoing absolutely everything. (defun undo (&optional checkpoint-id) (cond ((undo-possible checkpoint-id) (cond ((not *internal-logging*) (reset-done))) ; [1] NB do BEFORE objects are forgotten! Also [2] (prog1 (undo0 *history* checkpoint-id))))) (defun undo0 (history checkpoint-id) (cond ((null history) ; should never be encountered (setq *history* nil) (km-format t "Nothing more to undo!~%")) ((and (checkpoint-p (first history)) (or (null checkpoint-id) (equal checkpoint-id (checkpoint-id (first history))))) (prog1 (checkpoint-id (first history)) ; return the checkpoint-id associated with the checkpoint (setq *history* (rest history)))) (t (cond ((not (checkpoint-p (first history))) (undo1 (first history)))) (undo0 (rest history) checkpoint-id)))) (defun undo1 (command) ; (km-format t "Undoing ~a...~%" command) (eval command)) ;;; ---------- ;;; This is how setf works: (setf (get symbol property) new-values) (defun log-undo-command (command) (cond ((or *logging* *internal-logging*) (push command *history*)))) (defun start-logging (&key (with-comment t)) (cond (*logging* (cond (with-comment (format t "(Logging of KM commands is already switched on)~%")))) (t (cond (with-comment (format t "(Started logging KM commands)~%"))) (setq *logging* t))) t) (defun stop-logging (&key (with-comment t)) (cond ((not *logging*) (cond (with-comment (format t "(Logging of KM commands is already switched off)~%")))) (t (cond (with-comment (format t "(Stopping logging of KM commands)~%"))) (setq *logging* nil) (setq *history* nil))) t) ;;; ---------- ;;; Could optimize this if eval is too slow (defun km-setq (variable value) (let ( (old-value (eval variable)) ) (cond ((equal old-value value)) (t (log-undo-command `(setq ,variable ',old-value)) (eval `(setq ,variable ',value)))))) ; need to unquote the variable (defun km-setf (symbol property value) (let ( (old-value (get symbol property)) ) (cond ((equal old-value value)) (t (log-undo-command `(setf (get ',symbol ',property) ',old-value)) (setf (get symbol property) value))))) (defun km-add-to-kb-object-list (fname) (let ( (old-value (gethash fname *kb-objects*)) ) (cond (old-value) (t (log-undo-command `(km-del-from-kb-object-list ',fname)) (setf (gethash fname *kb-objects*) t))))) ;;; For undo only (defun km-del-from-kb-object-list (fname) (remhash fname *kb-objects*)) ;;; ====================================================================== ;;; NEW (using hash table) (defun get-all-objects () (let ((results nil)) (maphash #'(lambda (k v) (declare (ignore v)) (push k results)) *kb-objects*) results)) ;;; EXCLUDES comment tags (defun get-all-concepts () (let ((results nil)) (maphash #'(lambda (k v) (declare (ignore v)) (cond ((not (user-commentp k)) (push k results)))) *kb-objects*) results)) (defun delete-frame-structure (fname) (remprops fname) (remhash fname *kb-objects*) fname) ;;; Rename this from "exists"; it really means fname is a known frame (Is an error to try this check for numbers and strings) (defun known-frame (fname) (cond ((kb-objectp fname) (or (gethash fname *kb-objects*) (built-in-concept fname))) (t (report-error 'program-error "known-frame: Attempt to check if a non kb-object ~a is a frame!~%" fname)))) ;;; e.g. _X is a concept with no properties (defun no-properties (frame) (not (symbol-plist frame))) ;; -------------------- (defun reset-kb () (global-situation) (instance-of-is-nonfluent) ; set it back (format t "Resetting KM...~%") (mapc #'(lambda (frame) (delete-frame-structure frame)) (get-all-objects)) (clear-obj-stack) (setq *curr-prototype* nil) (setq *classes-using-assertions-slot* nil) ; optimization flag (setq *are-some-subslots* nil) ; optimization flag (setq *are-some-prototypes* nil) ; optimization flag (setq *are-some-definitions* nil) ; optimization flag (setq *are-some-constraints* nil) ; optimization flag (setq *are-some-tags* nil) ; optimization flag (setq *am-in-situations-mode* nil) (setq *visible-theories* nil) (setq *default-fluent-status* *default-default-fluent-status*) (setq *km-gensym-counter* 0) (setq *pid-counter* 0) (setq *max-padding-instances* 0) (setq *internal-logging* nil) ; (reset-inference-engine) ; no, want to keep inference counter going! (enable-classification) (reset-history) (clear-km-stack) (reset-trace) (reset-trace-depth) (reset-done) t) ;;; [1] This should *always* be enabled EXCEPT during restoration of a saved-state. ;;; To be sure, we re-enable it with a (reset-inference-engine) call in case somehow ;;; there's an abort during a saved-state restoration, and we don't want to be left ;;; with installing-inverses disabled. (defun reset-inference-engine () (setq *am-classifying* nil) (setq *catch-explanations* nil) (setq *internal-logging* nil) (cond (*catch-next-explanations* (setq *explanations* nil) (setq *catch-explanations* t) (setq *catch-next-explanations* nil))) (clear-km-stack) (reset-statistics) (reset-trace) (reset-trace-depth) (enable-installing-inverses)) ; [1] (defun clear-situations () (global-situation) (let ( (facets (my-mapcan #'(lambda (situation) (mapcar #'(lambda (facet) (curr-situation-facet facet situation)) (cons 'explanation *all-facets*))) (remove *global-situation* (all-situations)))) ) (mapc #'(lambda (frame) (cond ((isa frame '#$Situation) (delete-frame frame)) ((intersection (symbol-plist frame) facets) ; i.e., has situation-specific info... (mapc #'(lambda (facet) (remprop frame facet)) facets)))) (get-all-concepts)) t)) ;;; ====================================================================== ;;; SAVING A KB ;;; ====================================================================== (defun save-kb (file) (let ( (stream (tell file)) ) (write-kb stream) (close stream) (format t "~a saved!~%" file) t)) ;;; [1] We disable installing inverses so that, when restoring the KB state, we guarantee that ;;; the ordering of slot-vals on inverse slots is preserved (otherwise the install inverses ;;; procedure may change the ordering, ;;; e.g. SAVED: fsv', f'sv', v'invs(f'f) would restore as fsv', f'sv', v'invs(ff') without this. (defun write-kb (&optional (stream *standard-output*) (objects (get-all-objects)) situations0) (cond ((and (not (streamp stream)) (not (eq stream t))) (report-error 'nodebugger-error "write-kb given a non-stream as an argument!~%(Use (save-kb \"myfile\") to save KB to the file called \"myfile\")~%")) (t (let ( (situations (or situations0 (all-situations))) ) (multiple-value-bind (concepts comment-tags) (sort-objects-for-writing objects) (format stream "~%;;; Current state of the KB (~a, KM ~a)~%" (now) *km-version-str*) (cond ((singletonp situations0) (km-format stream ";;; Showing data for situation ~a only.~%~%" (first situations0))) (situations0 (km-format stream "Showing data for situations ~a only.~%~%" situations0)) (t (format stream "~%(reset-kb)~%") (km-format stream "~%(disable-slot-checking) ;;; (Temporarily disable while rebuilding KB state)~%") (km-format stream "~%(disable-installing-inverses) ;;; (Temporarily disable while rebuilding KB state)~%") ; [1] (cond (*are-some-definitions* (km-format stream "~%(disable-classification) ;;; (Temporarily disable while rebuilding KB state)~%"))) (cond (*built-in-inertial-fluent-slots* (km-format stream "~%(instance-of-is-fluent)~%"))) (format stream "~%;;; ----------~%~%") )) (mapc #'(lambda (concept) (cond ((not (bound concept)) (princ (write-frame concept :situations situations :nulls-okayp t) stream) (princ ";;; ----------" stream) (terpri stream) (terpri stream)))) concepts) (mapc #'(lambda (comment-tag) (km-format stream "~a~%~%" `(#$comment ,comment-tag ,@(get comment-tag 'comment))) (princ ";;; ----------" stream) (terpri stream) (terpri stream)) comment-tags) (write-state-variables stream) (format stream ";;; --- end (~a frames written) ---~%~%" (length (remove-if #'bound objects)))))))) ;;; Various variables about the current state, to write back so we can pick up ;;; where we left off if we reload... (defun write-state-variables (&optional (stream t)) (km-format stream " ;;; ---------------------------------------- ;;; KM'S INTERNAL PARAMETER VALUES ;;; ---------------------------------------- ") (mapc #'(lambda (km-parameter) (km-format stream "(SETQ ~a '~a)~%" km-parameter (eval km-parameter))) (append *km-behavior-parameters* *km-state-parameters*)) (cond ((neq *default-fluent-status* *default-default-fluent-status*) (km-format stream "(default-fluent-status ~a)~%" *default-fluent-status*))) (cond (*instance-of-is-fluent* (km-format stream "~%((instance-of-is-fluent))~%"))) (cond (*are-some-definitions* (km-format stream "~%(enable-classification) ;;; (Re-enable it after restoring KB state)~%"))) (km-format stream "~%(enable-installing-inverses) ;; (Re-enable it after restoring KB state)~%") (cond ((neq *curr-situation* *global-situation*) (km-format stream "~%(in-situation ~a)~%" (curr-situation)))) (km-format stream "~%")) ;;; ------------------------------ ; [1] copy-seq as sort is destructive! ; [2] When reading (in-situation ...) KM will check S is a situation, we ; must ensure Situations are written out *first* so the check is passed at reload time. (defun sort-objects-for-writing (objects0) (let* ( ; (prototypes (km0 '#$(the prototypes of (the all-subclasses of Thing)))) (comment-tags (remove-if-not #'user-commentp objects0)) (objects (remove-if #'user-commentp objects0)) (slot-classes (intersection (cons '#$Slot (all-subclasses '#$Slot)) objects)) (prototypes (remove-if-not #'prototypep objects)) ; Doesn't involve the tracer (which is confusing to the user) (situation-classes (cond ((member '#$Situation objects) (cons '#$Situation (all-subclasses '#$Situation))))) (situation-instances (remove-if-not #'(lambda (situation) ; [2] (isa situation '#$Situation)) objects)) (theory-classes (cond ((member '#$Theory objects) (intersection (cons '#$Theory (all-subclasses '#$Theory)) objects)))) (theory-instances (remove-if-not #'(lambda (theory) ; [2] (isa theory '#$Theory)) objects)) (rest-objects (set-difference objects0 (append slot-classes prototypes situation-classes situation-instances theory-classes theory-instances comment-tags))) ) (values (append (sort (copy-seq slot-classes) #'string-lessp) (sort (copy-seq theory-classes) #'string-lessp) (sort (copy-seq theory-instances) #'string-lessp) (sort (copy-seq situation-classes) #'string-lessp) (sort (copy-seq situation-instances) #'string-lessp) (sort (copy-seq prototypes) #'string-lessp) (sort (copy-seq rest-objects) #'string-lessp)) (sort (copy-seq comment-tags) #'string-lessp)))) ;;; ====================================================================== ;;; SAVING THE KB TO MEMORY (RATHER THAN DISK) ;;; ====================================================================== (defvar *stored-kb* nil) (defun store-kb () (let ( (now (now)) ) (setq *stored-kb* (list now (get-kb))) (format t "State of KB stored (~a)~%" now) '#$(t))) (defun restore-kb () (cond ((null *stored-kb*) (format t "No stored KB state to restore!~%")) (t (put-kb (second *stored-kb*)) (format t "State of KB restored to that stored at ~a.~%" (first *stored-kb*)) '#$(t)))) ;;; Return the KB as a massive data structure (!) (defun get-kb () (append '((reset-kb)) (mapcan #'(lambda (concept) `((setf (symbol-plist ',concept) ',(copy-tree (symbol-plist concept))) (km-add-to-kb-object-list ',concept))) (sort (copy-tree (get-all-objects)) #'string<)) (mapcar #'(lambda (km-parameter) `(setq ,km-parameter ',(eval km-parameter))) (append *km-behavior-parameters* *km-state-parameters*)) (cond (*instance-of-is-fluent* '((instance-of-is-fluent)))) (cond (*are-some-definitions* '((enable-classification)))) (cond ((neq *curr-situation* *global-situation*) `((in-situation ',*curr-situation*)))))) (defun put-kb (kb) (format t "Restoring KB from stored state...~%") (mapc #'eval (copy-tree kb)) t) (defun fastsave-kb (file) (let ( (stream (tell file)) ) (print '(reset-kb) stream) (mapc #'(lambda (concept) (print `(setf (symbol-plist ',concept) ',(symbol-plist concept)) stream) (print `(km-add-to-kb-object-list ',concept) stream)) (sort (copy-tree (get-all-objects)) #'string<)) (mapc #'(lambda (km-parameter) (print `(setq ,km-parameter ',(eval km-parameter)) stream)) (append *km-behavior-parameters* *km-state-parameters*)) (cond (*instance-of-is-fluent* (print '(instance-of-is-fluent) stream))) (cond (*are-some-definitions* (print '(enable-classification) stream))) (cond ((neq *curr-situation* *global-situation*) (print `(in-situation ',*curr-situation*) stream))) (close stream) (format t "~a saved!~%NOTE: Load this file using (fastload-kb ~s), not (load-kb ~s)~%" file file file) t)) ;;; Fastload is simply using the Lisp loader (defun fastload-kb (file) (format t "Fast-loading ~a...~%" file) (load file) (format t "~a loaded!~%" file)) ;;; ====================================================================== ;;; FAST-LOADING OF FILES ;;; ====================================================================== #| These fast-loading functions directly access the KB database, rather than through calls to KM. This fast-loading is limited: (i) no inverses are installed. This includes subclass-superclass links!! (ii) detecting of redundant assertions by checking for duplicates, rather than subsumees. (iii) all slots asssumed multivalued |# (defun simpleload-kb (km-file &key (install-inversesp t)) (format t "Simple-loading ~a...~%" km-file) (let ( (stream (see km-file)) ) (loop while (simpleload-expr (case-sensitive-read-km stream nil nil) :install-inversesp install-inversesp)) (close stream)) (format t "~a read!~%" km-file)) (defun simpleload-expr (item &key (install-inversesp t)) (cond ((null item) nil) ((not (eq (second item) '#$has)) (report-error 'nodebugger-error "simpleload-kb doesn't know how to process expression ~a! Ignoring it...~%" item) t) ; t to continue to next item (t (simple-add-slotsvals (first item) (rest (rest item)) :install-inversesp install-inversesp)))) ;;; Faster version of frame-io.lisp routine (defun simple-add-slotsvals (instance add-slotsvals &key (install-inversesp t)) (let* ( (old-slotsvals (get instance 'own-properties)) (new-slotsvals (simple-compute-new-slotsvals instance old-slotsvals add-slotsvals :install-inversesp install-inversesp)) ) (cond ((and (equal old-slotsvals new-slotsvals) ; no changes needed (not (null add-slotsvals)))) (t (cond (new-slotsvals (setf (get instance 'own-properties) new-slotsvals))))) (cond ((not (gethash instance *kb-objects*)) (setf (gethash instance *kb-objects*) t)))) instance) (defun simple-compute-new-slotsvals (instance old-slotsvals add-slotsvals &key (install-inversesp t)) (cond ((null old-slotsvals) (cond (install-inversesp (mapc #'(lambda (slotvals) (simple-add-inverses instance (slot-in slotvals) (vals-in slotvals))) add-slotsvals))) add-slotsvals) (t (let* ( (old-slotvals (first old-slotsvals)) (slot (slot-in old-slotvals)) (old-vals (vals-in old-slotvals)) (add-vals (vals-in (assoc slot add-slotsvals))) (extra-vals (ordered-set-difference add-vals old-vals :test #'equal)) (new-vals (append old-vals extra-vals)) ) ; simpleer than subsumption checks in frame-io.lisp (cond ((and extra-vals install-inversesp) (simple-add-inverses instance slot extra-vals))) (cons (make-slotvals slot new-vals) (simple-compute-new-slotsvals instance (rest old-slotsvals) (remove-if #'(lambda (sv) (eq (car sv) slot)) add-slotsvals) :install-inversesp install-inversesp)))))) ;;; [1] New - install inverses too (defun simple-add-inverses (instance slot extra-vals) (let ( (inv-slot (invert-slot slot)) ) (mapc #'(lambda (extra-val) (cond ((kb-objectp extra-val) (let ( (old-invvals (get-vals extra-val inv-slot)) ) (cond ((not (member instance old-invvals)) (let ( (old-invslotsvals (get extra-val 'own-properties)) ) ; (km-format t "Doing (setf ~a ~a ~a)~%" extra-val 'own-properties ; (update-assoc-list old-invslotsvals ; (make-slotvals inv-slot (cons instance old-invvals)))) (setf (get extra-val 'own-properties) (update-assoc-list old-invslotsvals (make-slotvals inv-slot (cons instance old-invvals))))))))))) extra-vals))) ;;; ====================================================================== ;;; KM VERSION NUMBER CONTROL ;;; ====================================================================== (defun requires-km-version (version-number-str) (cond ((km-version-greater-than version-number-str *km-version-str*) (format t "~%Sorry! This KB requires KM version ~a or later.~%" version-number-str) (format t "Please download the latest KM from the KM Web page at:~%") (format t " http://www.cs.utexas.edu/users/mfkb/km/~%~%") (abort)) (t '(|t|)))) ;;; (km-version-greater-than "1.4.1.2" "1.4.1") -> t (defun km-version-greater-than (v1 v2) (cond ((not (stringp v1)) (report-error 'user-error "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" v1)) ((not (stringp v2)) (report-error 'user-error "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" v2)) (t (let ( (v1-bits (mapcar #'read-from-string (break-up v1 '(#\.)))) (v2-bits (mapcar #'read-from-string (break-up v2 '(#\.)))) ) (cond ((notevery #'integerp v1-bits) (report-error 'user-error "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" v1)) ((notevery #'integerp v2-bits) (report-error 'user-error "Bad KM version number ~a encountered (should be a dotted list of integers, e.g. \"1.4.3.1\")~%" v2)) (t (km-version-bits-greater-than v1-bits v2-bits))))))) ;;; (km-version-bits-greater-than '(1 3 1) '(1 2 1 2)) -> t ;;; (km-version-bits-greater-than '(1 3 1) '(1 3)) -> t ;;; (km-version-bits-greater-than '(1 3) '(1 3)) -> NIL ;;; (km-version-bits-greater-than '(1 3 1) '(1 4)) -> NIL (defun km-version-bits-greater-than (v1-bits v2-bits) (cond ((equal v1-bits v2-bits) nil) ; mustn't be the same ((null v2-bits)) ((and v1-bits (> (first v1-bits) (first v2-bits)))) ((and v1-bits (= (first v1-bits) (first v2-bits))) (km-version-bits-greater-than (rest v1-bits) (rest v2-bits))))) ;;; FILE: minimatch.lisp ;;; File: minimatch.lisp ;;; Author: Peter Clark ;;; Date: August 1994 ;;; Purpose: Simplistic pattern-matching (see examples below) ;;; The system matches items with variables, returning a list of the ;;; matched items. All variables are anonymous. ;;; Here where we know there's just ONE item (defun minimatch1 (item pattern) (first (minimatch item pattern))) ;;; Mini-matching -- doesn't keep an explicit binding list, but just the ;;; values which matched with variables, in order. ;;; (minimatch 'x 'y) => nil ;;; (minimatch '(a b c) '(a ?x ?y)) => (b c) ;;; (minimatch '(a b c) '(a ?x ?x)) => (b c) ;;; (minimatch '(a b) '(a b)) => t ;;; (minimatch '(a b c (d e)) '(a b ?x (?y ?z))) => (c d e) ;;; (minimatch '(a b c (d e)) '(a b ?x ?y)) => (c (d e)) ;;; (minimatch '(a b c (d e)) '(a b &rest) => ((c (d e))) (defun mv-minimatch (item pattern) (values-list (minimatch item pattern))) (defun anonymous-minimatch-varp (var) (member var '(|?ANY| |?any| |?*|))) (defun wildcard-varp (var) (eq var '?*)) ;;; Must distinguish failure (nil) and no bindings (t) ;;; Mar'04 - use of wildcard variable ?* ;;; CL-USER(28): (minimatch '(1 2 3 4 5 6 7 8) '(?* 3 ?x ?* 6 ?y ?z ?*)) ;;; (4 7 8) (defun minimatch (item pattern) (cond ((anonymous-minimatch-varp pattern) 't) ((varp pattern) (list item)) ((member pattern '((&rest) (|&rest|)) :test #'equal) (list item)) ((atom pattern) (cond ((equal item pattern) 't))) ((listp item) (cond ((wildcard-varp (first pattern)) ; '(1 2 3) '(?* 3) (or (minimatch item (rest pattern)) ; ?* = no elements (and item (minimatch (rest item) (rest pattern))) ; ?* = 1 element (and item (minimatch (rest item) pattern)))) ; ?* = 2 or more elements (item (let ( (carmatch (minimatch (car item) (car pattern))) ) (cond (carmatch (join-binds carmatch (minimatch (cdr item) (cdr pattern))))))))))) (defun join-binds (binds1 binds2) (cond ((null binds1) nil) ((null binds2) nil) ((equal binds1 't) binds2) ((equal binds2 't) binds1) (t (append binds1 binds2)))) #| ;;; Cache the common variable names in km/interpreter.lisp for efficiency... (defconstant *cached-variable-names* '(?frame ?frameadd ?expr ?exprs ?slot ?class ?f ?s ?v ?name ?condition ?action ?x ?y ?set ?constraint ?value ?test ?lispcode ?command ?path ?lispcode ?future-pointing-slot ?action-expr ?situation-expr ?val-expr ?slot-expr ?frame-expr ?ys ?constraint ?value ?test ?set ?altaction ?action ?condition ?y ?frameadd ?slot ?cexpr ?a ?class ?km-expr ?expr1 ?expr ?xs ?x ?frame ?path ?instance-expr)) SLOW - obsolete now (defun varp (var) (and (symbolp var) (or (member var *cached-variable-names*) (char= (first-char (string var)) #\?))) ;;; Adam Farquhar's faster version, with type-checking (defun varp (var) (and (symbolp var) (char= #\? (char (the string (symbol-name (the symbol var))) 0)))) |# ;;; Modified faster version thanks to Adam Farquhar! (defun varp (var) (and (symbolp var) (symbol-starts-with var #\?))) (defun find-pattern (list pattern) (cond ((endp list) nil) ((minimatch (first list) pattern)) (t (find-pattern (rest list) pattern)))) ;;; ====================================================================== ;;; USE OF THE MINIMATCHER TO SELECT A LAMBDA EXPRESSION ;;; ====================================================================== #| find-handler -- finds a (pattern function) pair where pattern matches the input expr, and returns a LIST of THREE things: - function - a list of values in expr which matched the variables in pattern - the entire pattern which the input expr matched e.g., (find-handler '(the house of john) *km-handler-alist*) => (#'(lambda (slot path) (getval slot path)) (house john) (the ?slot of ?expr)) |# (defun find-handler (expr handler-alist &key (fail-mode 'fail)) (cond ((endp handler-alist) (cond ((eq fail-mode 'error) (format t "ERROR! Can't find handler for expression ~a!~%" expr) nil))) (t (let* ( (pattern+handler (first handler-alist)) (pattern (first pattern+handler)) (handler (second pattern+handler)) (bindings (minimatch expr pattern)) ) (cond ((eq bindings 't) (list handler nil pattern)) (bindings (list handler bindings pattern)) (t (find-handler expr (rest handler-alist) :fail-mode fail-mode))))))) ;;; Default method of applying ;;; Or could apply with extra args, eg. ;;; (apply (first handler) (cons depth (second handler))) (defun apply-handler (handler) (apply (first handler) (second handler))) (defun find-and-apply-handler (expr handler-alist &key (fail-mode 'fail)) (let ( (handler (find-handler expr handler-alist :fail-mode fail-mode)) ) (cond (handler (apply-handler handler))))) ;;; ====================================================================== ;;; SAME, EXCEPT FOR STRINGS ;;; ====================================================================== (defun mv-string-match (string pattern) (values-list (string-match string pattern))) ;;; (string-match "the cat sat" '("the" ?cat "sat")) --> (" cat ") ;;; (string-match "the cat sat" '(?var "the" ?cat "sat")) --> ("" " cat ") (defun string-match (string pattern) (let ( (pattern-el (first pattern)) ) (cond ((and (null pattern) (string= string "")) 't) ((member pattern '((&rest) (|&rest|)) :test #'equal) (list string)) ((stringp pattern-el) (cond ((string= string pattern-el :end1 (length pattern-el)) (string-match (subseq string (length pattern-el)) (cdr pattern))))) ((and (varp pattern-el) (singletonp pattern)) (list string)) ((and (varp pattern-el) (stringp (second pattern))) (let ( (end-string-posn (search (second pattern) string)) ) (cond (end-string-posn (cons-binding (subseq string 0 end-string-posn) (string-match (subseq string (+ end-string-posn (length (second pattern)))) (cddr pattern))))))) (t (format t "ERROR! (string-match ~s ~s) bad syntax!~%" string pattern) nil)))) ;;; binding or bindings = nil imply match-failure (defun cons-binding (binding bindings) (cond ((null bindings) nil) ((null binding) nil) ((equal bindings 't) (list binding)) (t (cons binding bindings)))) ;;; FILE: utils.lisp ;;; File: utils.lisp ;;; Author: Peter Clark ;;; Date: 1994 ;;; Purpose: General Lisp utilities ;;; (flatten '((a b) (c (d e)))) -> (a b c d e) ;;; (flatten 'a) -> (a) (defun flatten (list) (cond ((null list) nil) ((atom list) (list list)) ((aconsp list) (list (first list) (rest list))) ; won't handle '(a b . c) (t (my-mapcan #'flatten list)))) ;;; ---------- (defun listify (atom) (cond ((listp atom) atom) (t (list atom)))) ;;; (append-list '((1 2) (3 4))) => (1 2 3 4) (defun append-list (list) (apply #'append list)) ;;; ---------------------------------------- #| ;;; (my-split-if '(1 2 3 4) #'evenp) => ((2 4) (1 3)) ;;; (mapcar #'append-list (transpose (mapcar #'(lambda (seq) (my-split-if seq #'evenp)) '((1 2 3 4) (5 6 7 8) ...)))) ;;; [PEC: ?? but why not just do (my-split-if (append '((1 2 3 4) (5 6 7 8) ...)) #'evenp) ? ;;; ((2 4 6 8) (1 3 5 7)) (defun my-split-if (sequence function) (cond ((endp sequence) nil) (t (let ( (pass+fail (my-split-if (rest sequence) function)) ) (cond ((funcall function (first sequence)) (list (cons (first sequence) (first pass+fail)) (second pass+fail))) (t (list (first pass+fail) (cons (first sequence) (second pass+fail))))))))) |# ;;; Rewrite and rename. This time, returns multiple values (i) those passing the text (ii) those failing ;;; (partition '(1 2 3 4) #'evenp) => (2 4) (1 3) ;;; ((2 4 6 8) (1 3 5 7)) (defun partition (sequence function) (cond ((endp sequence) nil) (t (multiple-value-bind (pass fail) (partition (rest sequence) function) (cond ((funcall function (first sequence)) (values (cons (first sequence) pass) fail)) (t (values pass (cons (first sequence) fail)))))))) ;;; ====================================================================== ;;; SOME *-EQUAL FUNCTIONS ;;; ====================================================================== ;;; unlike assoc, item can be a structure ;;; > (assoc-equal '(a b) '(((a b) c) (d e))) (defun assoc-equal (item alist) (cond ((endp alist) nil) ((equal item (first (first alist))) (first alist)) (t (assoc-equal item (rest alist))))) (defun member-equal (item list) (cond ((endp list) nil) ((equal item (first list)) list) (t (member-equal item (rest list))))) ;;; ====================================================================== ;;; MAPPING FUNCTIONS ;;; ====================================================================== ;;; my-mapcan: non-destructive version of mapcan (defun my-mapcan (function args) (apply #'append (mapcar function args))) ;; eg. (map-recursive #'string-upcase '("as" ("asd" ("df" "df") "ff"))) ;; ("AS" ("ASD" ("DF" "DF") "FF")) (defun map-recursive (function tree) (cond ((null tree) nil) ((not (listp tree)) (funcall function tree)) (t (cons (map-recursive function (car tree)) (map-recursive function (cdr tree)))))) ;;; (recursive-find 'a '(1 2 (c 3) (a))) (defun recursive-find (item tree) (cond ((eq item tree)) ((null tree) nil) ((listp tree) (some #'(lambda (subtree) (recursive-find item subtree)) tree)))) ;;; ---------------------------------------- #| KM> (defun demo (x) (cond ((> x 0) (values x (* x x))))) KM> (some #'demo '(-1 3 2)) 3 KM> (multiple-value-some #'demo '(-1 3 2)) 3 9 |# ;;; This just written for two-valued arguments (defun multiple-value-some (fn arg-list) (cond ((endp arg-list) nil) (t (multiple-value-bind (x y) (apply fn (list (first arg-list))) (cond (x (values x y)) (t (multiple-value-some fn (rest arg-list)))))))) ;;; ====================================================================== ;;; GENERAL UTILITIES ;;; ====================================================================== (defvar *tell-stream* t) (defvar *see-stream* t) (defvar *append-stream* t) (defun file-exists (file) (open file :direction :probe)) ;;; Check you don't close the stream "t" (defun close-stream (stream) (cond ((streamp stream) (close stream)))) ;;; (see) and (tell) open files with my standard default modes. ;;; They also cache the stream, just in case an error occurs during ;;; interpretation (otherwise you've lost the handle on the stream). ;;; t will send to std output, nil will output to nothing. (defun tell (file) (cond ((null file) nil) ((eq file t) (format t "(Sending output to standard output)~%") t) (t (setq *tell-stream* (open file :direction :output :if-exists :supersede :if-does-not-exist :create))))) (defun told () (close-stream *tell-stream*) (setq *tell-stream* t)) (defun see (file) (cond ((eq file t) t) ; read from standard input (t (setq *see-stream* (open file :direction :input))))) (defun seen () (close-stream *see-stream*) (setq *see-stream* t)) (defun tell-append (file) (cond ((null file) nil) ((eq file t) (format t "(Sending output to standard output)~%") t) (t (setq *append-stream* (open file :direction :output :if-exists :append :if-does-not-exist :create))))) (defun told-append () (close-stream *append-stream*) (setq *append-stream* t)) ;;; Useful for finding mis-matching parentheses (defun read-and-print (file) (let ( (stream (see file)) ) (read-and-print2 stream) (close stream))) (defun read-and-print2 (stream) (let ( (sexpr (read stream nil nil)) ) (cond (sexpr (print sexpr) (read-and-print2 stream))))) ;;; Bug(?) in CL: (read-string nil nil) should return nil if is an incomplete s-expr (e.g. "\""cat") ;;; but in practice generates an eof error regardless. (What I wanted to do was a read-string followed by integerp test). (defun my-parse-integer (string) (multiple-value-bind (integer n-chars) (parse-integer string :junk-allowed t) (cond ((eq (length (princ-to-string integer)) n-chars) integer)))) ;;; ---------------------------------------- ;;; READ AN ENTIRE FILE INTO A LIST: ;;; ---------------------------------------- ;;; Returns a list of strings (defun read-file (file &optional (type 'string)) (cond ((not (member type '(string sexpr case-sensitive-sexpr))) (format t "ERROR! Unrecognized unit-type ~s in read-file!~%" type)) (t (read-stream (see file) type)))) (defun read-stream (stream &optional (type 'string)) (prog1 (read-lines (read-unit stream type) stream type) (cond ((streamp stream) (close stream))))) (defun read-lines (line &optional (stream t) (type 'string)) (cond ((null line) nil) (t (cons line (read-lines (read-unit stream type) stream type))))) (defun read-unit (&optional (stream t) (type 'string)) (case type (string (read-line stream nil nil)) (sexpr (read stream nil nil)) (case-sensitive-sexpr (case-sensitive-read stream nil nil)))) ; defined in case.lisp ;;; ------------------------------ (defun write-file (file lines) (let ( (stream (tell file)) ) (write-lines lines stream) (close-stream stream))) #| ;;; Works, but apply-recursive can be *very* slow as it's interpreted (defun write-lines (lines &optional (stream t)) (apply-recursive #'(lambda (line) (format stream "~a~%" line)) lines)) |# (defun write-lines (structure &optional (stream t)) (cond ((null structure) nil) ((atom structure) (format stream "~a~%" structure)) ((and (listp structure) (null (first structure))) (write-lines (rest structure) stream)) ((listp structure) (cons (write-lines (first structure) stream) (write-lines (rest structure) stream))) (t (format t "ERROR! Don't know how to do write-lines on structure:~%") (format t "ERROR! ~s~%" structure)))) ;(defun write-lines (lines &optional (stream t)) ; (cond ; ((null lines)) ; ((atom lines) (format stream "~a~%" lines)) ; ((listp lines) ; (write-lines (car lines) stream) ; (write-lines (cdr lines) stream)) ; (t (format t "ERROR! Don't know how to do write-lines on structure:~%") ; (format t "ERROR! ~s~%" lines)))) ; ---------- (defun apply-recursive (function structure) (cond ((null structure) nil) ((atom structure) (funcall function structure)) ((listp structure) (cons (apply-recursive function (first structure)) (apply-recursive function (rest structure)))) (t (format t "ERROR! Don't know how to apply-recursive on structure:~%") (format t "ERROR! ~s~%" structure)))) ;;; ====================================================================== (defun print-list (list) (mapcar #'print list) t) ;;; Below command means DON'T define neq in Mac CommonLisp (as it's a built-in) ;;; but it is NOT defined in openmcl #-(and MCL (not openmcl)) (defun neq (a b) (not (eq a b))) ;;; (nlist 3) --> (1 2 3) (defun nlist (nmax &optional (n 1)) (cond ((<= nmax 0) nil) ((>= n nmax) (list n)) (t (cons n (nlist nmax (1+ n)))))) ;;; (duplicate 'hi 2) ==> (hi hi) (defun duplicate (item length) (make-sequence 'list length :initial-element item)) ; Better: use ~vT directive in format ; BUT!! Bug under Harlequin - column counter doesn't get reset by a from ; user (as a result of a read-line or read). (defun spaces (n) (make-sequence 'string n :initial-element #\ )) ; ; (defun tab (n &optional (stream t)) ; (cond ((<= n 0) t) ; ( t (format stream " ") (tab (- n 1) stream)))) ;;; ====================================================================== (defun transpose (list) (cond ((every #'null list) nil) (t (cons (mapcar #'first list) (transpose (mapcar #'rest list)))))) ;;; (atranspose '((a b c) (c d e))) ;;; ((A . C) (B . D) (C . E)) ;;; NOTE: must have at most two input lists (extra lists are ignored) (defun atranspose (list) (cond ((every #'null list) nil) (t (cons (cons (first (first list)) (first (second list))) (atranspose (mapcar #'rest list)))))) ;;; ====================================================================== ;;; 22nd Aug: had to rewrite this. Checking the cadr is non-null doesn't ;;; reliably test there's a second element (eg. if the 2nd el is nil). (defun singletonp (list) (and (listp list) (eq (length list) 1))) (defun pairp (list) (and (listp list) (eq (length list) 2))) ; triple has different repn in KM, namely with a :triple prefix (defun triplep (list) (and (listp list) (eq (length list) 3))) ;;; ====================================================================== ;;; (a) -> a (defun delistify (list) (cond ((singletonp list)(car list)) (t list))) (defun last-el (list) (car (last list))) (defun last-but-one-el (list) (car (last (butlast list)))) ;;; (aconsp '(a . b)) -> t (defun aconsp (obj) (and (listp obj) (not (listp (rest obj))))) ;;; ====================================================================== ;;; (quotep ''hi) --> t (defun quotep (expr) (cond ((and (listp expr) (eq (length expr) 2) (eq (car expr) 'quote))))) ;;; ====================================================================== ;;; Preserve order of list ;;; (The basic Lisp function is set-difference) (defun ordered-set-difference (list set &key (test #'eq)) (remove-if #'(lambda (el) (member el set :test test)) list)) ;;; Preserve order of first list (defun ordered-intersection (list set &key (test #'eq)) (remove-if-not #'(lambda (el) (member el set :test test)) list)) ;;; Returns the first elememt of set1 which is in set2, or nil otherwise. (defun intersects (set1 set2) (first (some #'(lambda (el) (member el set2)) set1))) ;;; (nreplace '(a b c d e) 2 'new) -> (a b new d e) (defun nreplace (list n new) (cond ((endp list) nil) ((eq n 0) (cons new (rest list))) (t (cons (first list) (nreplace (rest list) (1- n) new))))) ;;; ====================================================================== ;;; DICTIONARY FUNCTIONS ;;; ====================================================================== ;;; Inefficient but non-destructive! ;;; KM> (gather-by-key '((a 1) (b 2) (a 3) (b 4))) ;;; ((b (4 2)) (a (3 1))) ;;; KM> (gather-by-key '((a 1) (b 2) (a 3) (b 4) (c) (b))) ;;; ((b (4 2)) (a (3 1)) (defun gather-by-key (pairs &optional dict) (cond ((endp pairs) dict) (t (let* ((pair (first pairs)) (key (first pair)) (val (second pair))) (cond (val (let ( (vals (first (rest (assoc key dict :test #'equal)))) (restdict (remove-if #'(lambda (pair) (equal (first pair) key)) dict)) ) (gather-by-key (rest pairs) (cons (list key (cons val vals)) restdict)))) (t (gather-by-key (rest pairs) dict))))))) ;;; ---------- ;;; Inefficient but non-destructive! ;;; [1c] USER(31): (gathers-by-key '((a 1 2) (b 3 4) (a 5 6))) ;;; ((a ((5 6) (1 2))) (b ((3 4)))) (defun gathers-by-key (tuples &optional dict) (cond ((endp tuples) dict) (t (let* ((tuple (first tuples)) (key (first tuple)) (val (rest tuple)) (vals (first (rest (assoc key dict :test #'equal)))) (restdict (remove-if #'(lambda (tuple) (equal (first tuple) key)) dict))) (cond (val (gathers-by-key (rest tuples) (cons (list key (cons val vals)) restdict))) (t (gathers-by-key (rest tuples) (cons (list key vals) restdict)))))))) ;;; (ordered-gather-by-key '((a 1) (a 2) (b 3) (b 4) (c 5) (a 6) (a 7) (d 8))) ;;; -> ((a (1 2)) (b (3 4)) (c (5)) (a (6 7)) (d (8))) ;;; NOTE duplicate (a ...) entries, if (a ...) entries aren't consecutive (defun ordered-gather-by-key (pairs) (cond ((endp pairs) nil) (t (let ( (pair (first pairs)) ) (cond ((equal (first pair) (first (second pairs))) (let* ( (gathered-rest (ordered-gather-by-key (rest pairs))) (next-gathered-pair (first gathered-rest)) ) (cons (list (first next-gathered-pair) ; pair = (a x), next-gathered-pair (a (d e)) -> (c (x d e)) (cons (second pair) (second next-gathered-pair))) (rest gathered-rest)))) (t (cons (list (first pair) (rest pair)) ; (a b) -> (a (b)) (ordered-gather-by-key (rest pairs))))))))) ;;; Takes an *ordered* list of items, and counts occurences of each one. ;;; (ordered-count '("a" "a" "b" "c")) -> (("a" 2) ("b" 1) ("c" 1)) (defun ordered-count (list &optional counts-so-far) (cond ((endp list) (reverse counts-so-far)) ((equal (first list) (first (first counts-so-far))) (ordered-count (rest list) (cons (list (first list) (1+ (second (first counts-so-far)))) (rest counts-so-far)))) (t (ordered-count (rest list) (cons (list (first list) 1) counts-so-far))))) ;;; ---------- (defun number-eq (n1 n2) (and (numberp n1) (numberp n2) (< (abs (- n1 n2)) 1e-24))) ;;; handle rounding errors ;;; NOTE: Now should use zerop, with a numberp check first! (defun zero (n) (and (numberp n) (<= n 0.0000001) (>= n -0.0000001))) (defun list-intersection (list) (cond ((null list) nil) ((singletonp list) (first list)) (t (list-intersection (cons (intersection (first list) (second list)) (rest (rest list))))))) ;;; ---------- ;;; (rank-sort list rank-function) ;;; rank-function generates a rank (a number) for each element in list, and then list is returned sorted, ;;; lowest rank first. This constrasts with Lisp's sort, where function is a *two* argument ;;; predicate for comparing two elements in list. ;;; rank-sort is non-destructive on list. ;;; CL-USER> (rank-sort '("cat" "the" "elephant" "a") #'length) ;;; ("a" "cat" "the" "elephant") (defun rank-sort (list function) (mapcar #'second (assoc-sort (transpose (list (mapcar function list) list))))) (defun assoc-sort (list) (sort list #'pair-less-than)) (defun pair-less-than (pair1 pair2) (< (first pair1) (first pair2))) (defun symbol-less-than (pair1 pair2) (string< (symbol-name pair1) (symbol-name pair2))) ;;; ---------- (defvar *tmp-counter* 0) (defun reset-trace-at-iteration () (setq *tmp-counter* 0)) (defun trace-at-iteration (n) (setq *tmp-counter* (1+ *tmp-counter*)) (cond ((eq (mod *tmp-counter* n) 0) (format t "~a..." *tmp-counter*)))) (defun curr-iteration () *tmp-counter*) ;;; ====================================================================== ;;; PROPERTY LISTS ;;; ====================================================================== ;;; Remove *all* properties on the property list (defun remprops (symbol) (mapc #'(lambda (indicator) (remprop symbol indicator)) (odd-elements (symbol-plist symbol)))) ;;; (odd-elements '(1 2 3 4 5)) -> (1 3 5) (defun odd-elements (list) (cond ((endp list) nil) (t (cons (first list) (odd-elements (rest (rest list))))))) ;;; (even-elements '(1 2 3 4 5)) -> (2 4) (defun even-elements (list) (odd-elements (rest list))) ;;; ====================================================================== ;;; (Could also define set-eq if I need it) ;;; CL-USER> (set-equal '("a" b) '(b "a")) -> t ;;; CL-USER> (set-equal '(a b) '(b a b)) -> nil ;(defun set-equal (set1 set2) ; (cond ((and (endp set1) (endp set2)) t) ; ((member (first set1) set2 :test #'equal) ; (set-equal (rest set1) (remove (first set1) set2 :test #'equal :count 1))))) ;;; (set-equal '(a b) '(b a)) -> t ;;; (set-equal '("a" "b") '("b" "a")) -> t ;;; (set-equal '("a" "b") '("b" "a" "a")) -> t (defun set-equal (set1 set2) (not (set-exclusive-or set1 set2 :test #'equal))) (defun multiple-value-mapcar (function list) (cond ((endp list) nil) (t (multiple-value-bind (x y) (funcall function (first list)) (multiple-value-bind (xs ys) (multiple-value-mapcar function (rest list)) (values (cons x xs) (cons y ys))))))) (defun unquote (expr) (cond ((quotep expr) (second expr)) (t (format t "Warning! Unquote received an already unquoted expression!~%") expr))) (defun quotify (item) (list 'quote item)) (defun bag-equal (bag1 bag2) (and (eq (length bag1) (length bag2)) (bag-equal0 bag1 bag2))) (defun bag-equal0 (bag1 bag2) (cond ((equal bag1 bag2)) ((member (first bag1) bag2 :test #'equal) (bag-equal0 (rest bag1) (remove (first bag1) bag2 :test #'equal :count 1))))) ;;; ---------- (defun update-assoc-list (assoc-list new-pair) (cond ((endp assoc-list) (list new-pair)) ; ((string= (first (first assoc-list)) (first new-pair)) ((equal (first (first assoc-list)) (first new-pair)) ; revised 12.16.99 (cons new-pair (rest assoc-list))) (t (cons (first assoc-list) (update-assoc-list (rest assoc-list) new-pair))))) ;;; Same, but matches with *second* argument ;;; (assoc 'a '((a b) (c e))) -> (a b) ;;; (inv-assoc 'b '((a b) (c e))) -> (a b) ;;; NOTE!! Common Lisp rassoc might be a better choice, doing the same thing but with dotted pairs ;;; (rassoc 'b '((a . b) (c . e))) -> (a . b) (defun inv-assoc (key assoc-list &key (test #'eq)) (cond ((endp assoc-list) nil) ((apply test (list (second (first assoc-list)) key)) (first assoc-list)) (t (inv-assoc key (rest assoc-list) :test test)))) ;;; ---------- ;;; removes ALL the assoc-list entries with key. (defun remove-assoc-entry (key assoc-list) (remove-if #'(lambda (entry) (eq (first entry) key)) assoc-list)) ;;; ---------- ;;; (insert-delimeter '(a b c) 'cat) -> (a cat b cat c) (defun insert-delimeter (list delimeter) (cond ((endp list) list) ((singletonp list) list) ((cons (first list) (cons delimeter (insert-delimeter (rest list) delimeter)))))) ;;; ---------- ;;; Returns non-nil if expr contains (at least) one of symbols. ;;; (contains-some '(a b (c d)) '(d e)) -> true (defun contains-some (expr symbols) (or (member expr symbols) (and (listp expr) (some #'(lambda (el) (contains-some el symbols)) expr)))) ;;; ---------- ;;; xor clashes with CLISP (defun x-or (a b) (and (or a b) (not (and a b)))) (defun nor (a b) (not (or a b))) ; = (and (not a) (not b)) ;;; ---------- ;;; USER(60): (subbagp '(1 2 2) '(1 2 2 3)) -> t ;;; USER(61): (subbagp '(1 2 2 2) '(1 2 2 3)) -> NIL (defun subbagp (subbag bag &key (test #'eq)) (cond ((null subbag)) ((member (first subbag) bag :test test) (subbagp (rest subbag) (remove (first subbag) bag :test test :count 1))))) ;;; ---------- ;;; RETURNS THREE VALUES: shorterlist1 shorterlist2 shared ;;; USER(63): (remove-shared-elements '(1 2 1 2 3) '(1 2 3 4 5)) ;;; (1 2) ;;; (4 5) ;;; (1 2 3) ;;; USER(64): (remove-shared-elements '(1 2 1 2 1 3) '(1 2 3 1 4 5)) ;;; (2 1) ;;; (4 5) ;;; (1 2 1 3) (defun remove-shared-elements (list1 list2 &key (test #'eq)) (cond ((null list1) (values nil list2 nil)) ((member (first list1) list2 :test test) (multiple-value-bind (shorterlist1 shorterlist2 shared) (remove-shared-elements (rest list1) (remove (first list1) list2 :test test :count 1)) (values shorterlist1 shorterlist2 (cons (first list1) shared)))) (t (multiple-value-bind (shorterlist1 shorterlist2 shared) (remove-shared-elements (rest list1) list2) (values (cons (first list1) shorterlist1) shorterlist2 shared))))) ;;; Remove element number n (first position = 0) ;;; USER(58): (remove-element-n '(a b c) 2) -> (A C) (defun remove-element-n (list n) (cond ((or (null list) (< n 0)) list) ((eq n 0) (rest list)) (t (cons (first list) (remove-element-n (rest list) (1- n)))))) ;;; ---------------------------------------------------------------------- ;;; Move symbols from one package to another. Fairly crude implementation! ;;; e.g. (port-to-package ... :old-package :sapir :new-package :user) ;;; REVISED: Dec 2003 - don't care what the old package was (defun port-to-package (tree &key package) (cond ((null tree) nil) ((listp tree) (cons (port-to-package (first tree) :package package) (port-to-package (rest tree) :package package))) ((symbolp tree) (intern (symbol-name tree) package)) (t tree))) ;;; ====================================================================== ;;; CL-USER(30): (permute '((a b) (1 2) (X Y))) ;;; ((A 1 X) (A 1 Y) (A 2 X) (A 2 Y) (B 1 X) (B 1 Y) (B 2 X) (B 2 Y)) (defun permute (list-of-lists) (cond ((endp list-of-lists) (list nil)) (t (let ( (permutes (permute (rest list-of-lists))) ) (mapcan #'(lambda (e) (mapcar #'(lambda (permute) (cons e permute)) permutes)) (first list-of-lists)))))) ;;; (all-pairs '(a b c d)) ;;; ((A B) (A C) (A D) (B C) (B D) (C D)) (defun all-pairs (list) (cond ((endp list) nil) (t (append (mapcar #'(lambda (e) (list (first list) e)) (rest list)) (all-pairs (rest list)))))) ;;; FILE: strings.lisp ;;; File: strings.lisp ;;; Author: Peter Clark ;;; Date: August 1994 ;;; Purpose: String manipulation with Lisp #| Template for a file reader. Or just use (read-file 'sexpr) (defun (&optional (file )) (let ( (stream (see file)) ) (loop until (not (progn (let* ( (data (read stream nil nil)) ) (cond ((null data) nil) (t ( data) t)))))) (cond ((streamp stream) (close stream))) t)) REVISED: Simply do: (apply-to-file-lines #'process-line "myfile.km") |# (defun apply-to-file-lines (function file) (let ( (stream (see file)) ) (loop until (not (progn (let* ( (data (read stream nil nil)) ) (cond ((null data) nil) (t (apply function (list data)) t)))))) (cond ((streamp stream) (close stream))) t)) ;;; words that shouldn't be pluralized or singularized (defconstant *mass-nouns* '("air" "water" "these" "asbestos" "always")) (defconstant *plural-with-s-words* '("antennas")) ; special cases: exceptions to exceptions where "s" should be stripped (defconstant *tmp-shell-file* "/tmp/tmp-clarkp") ; (defconstant *max-concat-length* 500) ; Lisp implementation constraint - Lucid (defconstant *max-concat-length* 255) ; Lisp implementation constraint - Harlequin! (defconstant *whitespace-chars* '(#\Space #\Tab #\Newline #\Return #\Linefeed #\Page)) (defconstant *newline-string* (make-string 1 :initial-element '#\Newline)) (defconstant *irregular-plurals* '(("person" "people") ("woman" "women") ("man" "men") ("wife" "wives") ("child" "children"))) ;;; (a b) -> "(a b)" (defun truncate-string (string &optional (maxlen 60)) (cond ((not (stringp string)) (format t "ERROR! Non-string given to truncate-string in utils.lisp!~%") string) ((< (length string) maxlen) string) (t (concat (subseq string 0 maxlen) "...")))) ;;; ====================================================================== ;;; (split-at "abcde" "bc") ---> "a" and "de" ;;; (split-at "abcde" "xx") ---> nil (defun split-at (string substring) (let ( (start0 (search substring string)) ) (cond (start0 (values (subseq string 0 start0) (subseq string (+ start0 (length substring)))))))) (defun contains (string substring) (search substring string)) (defun right-of (string substring) (multiple-value-bind (left right) (split-at string substring) (declare (ignore left)) right)) (defun left-of (string substring) (split-at string substring)) ; just ignore second return value ;;; ASSUMES string has no trailing whitespace (defun rightmost-word (string) (last-el (string-to-list string))) ;;; ====================================================================== ;;; shorthand (defun concat (&rest list) (my-concat list (length list))) (defun concat-list (list) (my-concat list (length list))) ; > (my-concat '("a" "b" "c" "d" "e" "f" "g" "h") 8) ; "abcdefgh" (defun my-concat (list len) (cond ((<= len *max-concat-length*) (apply #'concatenate (cons 'string list))) (t (concatenate 'string (apply #'concatenate (cons 'string (subseq list 0 *max-concat-length*))) (my-concat (subseq list *max-concat-length*) (- len *max-concat-length*)))))) ; -------------------- ;;; contains only whitespace (defun white-space-p (string &key (whitespace-chars *whitespace-chars*)) (white-space2-p string 0 (length string) whitespace-chars)) (defun white-space2-p (string n nmax whitespace-chars) (cond ((eq n nmax)) ((member (char string n) whitespace-chars :test #'char=) (white-space2-p string (+ n 1) nmax whitespace-chars)))) ;;; ====================================================================== ;;; STRING-TO-LIST ;;; This nifty little utility breaks a string up into its word ;;; and delimeter components. Always starts with delimeter: ;;; (string-to-list '"the cat, sat on t-he m/at ") ;;; ==> ("" "the" " " "cat" ", " "sat" " " "on" " " "t-he" " " "m/at" " ") ;;; ====================================================================== ;;; (string-to-words "the cat on the mat") -> ("the" "cat" "on" "the" "mat") ;;; (string-to-words "the cat_n1 is big" :wordchars '(not whitespace)) -> ("the" "cat_n1" "is" "big") (defun string-to-words (string &key (wordchars 'alphanum)) (remove-delimeters (string-to-list string :wordchars wordchars))) ;;; USER(3): (string-to-list "the cat sat") ;;; ("" "the" " " "cat" " " "sat") ;;; [1] This is a special-purpose bit of code which makes sure "." within ;;; a string (eg. "Section 2.2.1") is *not* categorized as a delimeter. (defun string-to-list (string &key (wordchars 'alphanum)) (scan-to wordchars string 0 0 (length string))) (defun scan-to (delimeter string m n nmax) (cond ((eq n nmax) (list (subseq string m n))) ; reached the end. (t (let ( (curr-char (char string n)) (next-char (cond ((< (1+ n) nmax) (char string (1+ n))) (t #\ ))) ) (cond ((and (is-type curr-char delimeter) (not (and (char= curr-char #\.) ; [1] (alphanumericp next-char)))) (cons (subseq string m n) (scan-to (invert-type delimeter) string n n nmax))) (t (scan-to delimeter string m (1+ n) nmax))))))) ;;; x -> (not x); (not x) -> x (defun invert-type (type) (cond ((and (listp type) (eq (first type) 'not)) (second type)) (t `(not ,type)))) ;(defun embedded-delimeter (curr-char next-char type) ; (declare (ignore type)) ; (and (char= curr-char #\.) ; (alphanumericp next-char))) (defun is-type (char type) (cond ((and (listp type) (eq (first type) 'not)) (not (is-type char (second type)))) ((eq type 'alphanum) (not (delimeter char))) ((eq type 'whitespace) (member char *whitespace-chars* :test #'char=)) (t (format t "ERROR! is-type: Unrecognized delimeter type ~a!~%" type)))) ;;; 5/7/99: *Do* want to break up software/hardware into two words. ;;; (defun delimeter (char) ;;; (and (not (alphanumericp char)) ;;; (not (char= char #\-)) ;;; (not (char= char #\/)))) (defun delimeter (char) (not (alphanumericp char))) ;;; Remove the delimeter components: (defun remove-delimeters (list) (cond ((eq (cdr list) nil) nil) ;;; length 0 or 1 (t (cons (cadr list) (remove-delimeters (cddr list)))))) ;;; ---------- #| Break list of string fragments into lines USER: (list-to-lines '("" "the" " " "cat" " " "sat" " " "on" " " "th" " " "emat" " " "I" " " "think" ".")) -> ("the cat sat" " on th emat" "I think.") |# (defun list-to-lines (strings &optional reverse-line-bits-so-far) (cond ((endp strings) (cond (reverse-line-bits-so-far (list (concat-list (reverse reverse-line-bits-so-far)))))) ; otherwise nil (t (multiple-value-bind (left right) (split-at (first strings) *newline-string*) (cond (left (cons (concat-list (reverse (cons left reverse-line-bits-so-far))) (list-to-lines (cons right (rest strings))))) (t (list-to-lines (rest strings) (cons (first strings) reverse-line-bits-so-far)))))))) ;;; ====================================================================== ;; " a " -> "a " ;; " " -> "" (defun remove-leading-whitespace (string) (string-left-trim *whitespace-chars* string)) (defun remove-trailing-whitespace (string) (string-right-trim *whitespace-chars* string)) ;;; " a " -> "a" (defun trim-whitespace (string) (string-trim *whitespace-chars* string)) ;;; " a " -> t (defun contains-whitespace (string) (some #'(lambda (char) (find char string)) *whitespace-chars*)) (defun whitespace-char (char) (member char *whitespace-chars* :test #'char=)) ;;; ====================================================================== ;;; mapchar; like mapcar, except it maps a function onto every ;;; character of a string rather than every element in a list. ;;; This should probably be a macro rather than a function. (defun mapchar (function string) (mapcar function (explode string))) (defun explode (string) (loop for i from 0 to (1- (length string)) collect (char string i))) (defun implode (charlist) (concat-list (mapcar #'string charlist))) ;;; ====================================================================== ;;; copied from Denys, and modified... (defun break-string-at (string break-char) (loop for start0 = 0 then end and end = 0 while (setq start0 (position-if-not #'(lambda (char) (char= char break-char)) string :start start0)) do (setq end (position-if #'(lambda (char) (char= char break-char)) string :start start0)) collecting (subseq string start0 end) while end)) ;;; ====================================================================== ;;; (commaed-list '("a" "b" "c")) -> ("a" ", " "b" ", " "c") (defun commaed-list (list &optional (delimeter ", ")) (cond ((endp list) nil) ((singletonp list) list) (t (cons (car list) (cons delimeter (commaed-list (cdr list) delimeter)))))) ;;; Previously called spaced-list ;;; (spaced-string '("a" "b" "c")) -> ("a b c") (defun spaced-string (list) (concat-list (spaced-list list))) (defun spaced-list (list) (cond ((endp list) nil) ((singletonp list) list) (t (cons (first list) (cons " " (spaced-list (rest list))))))) ;;; ---------- (defun first-char (string) (cond ((string/= string "") (char string 0)))) (defun last-char (string) (cond ((string/= string "") (char string (- (length string) 1))))) ;;; (last-but-n-char "cat" 1) -> #\a (defun last-but-n-char (string n) (cond ((> (length string) n) (char string (- (length string) (+ 1 n)))))) ;;; (butlast-char "cats") -> "cat" (defun butlast-char (string) (cond ((string/= string "") (subseq string 0 (1- (length string)))))) (defun butfirst-char (string) (cond ((string/= string "") (subseq string 1 (length string))))) ;;; (ends-with "abcde" "de") -> t ;;; Modified June 1999, to work with lists too (ends-with '(a b c d) '(c d)) (defun ends-with (string substr) (and (>= (length string) (length substr)) (equal (subseq string (- (length string) (length substr))) substr))) ;;; (starts-with "step 10" "step") -> t ;;; Modified June 1999, to work with lists too (starts-with '(a b c d) '(a b)) (defun starts-with (string substr) (and (>= (length string) (length substr)) (equal (subseq string 0 (length substr)) substr))) ;;; Trim n characters from the end of string (defun trim-from-end (string n) (subseq string 0 (- (length string) n))) (defun trim-from-start (string n) (subseq string n (length string))) (defun symbol-starts-with (symbol char) (char= char (char (symbol-name symbol) 0))) ;;; USER(2): (remove-wrapper "(the cat)" "(" ")") -> "the cat" (defun remove-wrapper (string start0 end) (cond ((and (starts-with string start0) (ends-with string end) (>= (length string) (+ (length start0) (length end)))) (subseq string (length start0) (- (length string) (length end)))) (t string))) ;;; ---------- (defun variants (word) (cond ((and (ends-with word "ing") (>= (length word) 7)) ; avoid trimming "wing", "sting", "string" (list (trim-from-end word 3))) ; ((and (ends-with word "ion") ; (>= (length word) 5)) ; (list (trim-from-end word 3))) ; avoid trimming "lion" (but will trim, "mission", "action") ; ((ends-with word "able") (list (trim-from-end word 4))) ; ((ends-with word "yse") (list (trim-from-end word 1))) ; ((ends-with word "ysis") (list (trim-from-end word 2))) (t (remove-duplicates (list word (singular word) (plural word) (gerund (singular word))) :test #'string=)))) (defun root-form (word) (cond ((ends-with word "ing") (trim-from-end word 3)) (t (singular word)))) ;;; Input: plural of a word. ;;; Very heuristic... We miss a few plural words whose singular form ends in a;i;o;u eg. ;;; "macros", "silos", "emus", and singular a few singluar words ending with "es" eg. ;;; "Les" (I can't think of a better example). Also things like "avionics" get the "s" ;;; mistakenly (?) trimmed. ;;; NOTE capitalized words are *not* trimmed - we'll assume they are acronyms. (defun singular (word &key external-mass-nounp) (declare (ignore external-mass-nounp)) (cond ((member word *mass-nouns* :test #'string=) word) ; ((and external-mass-nounp (apply #'mass-noun (list word))) word) ; **SLOW** if use Phil's one! ((inv-assoc word *irregular-plurals* :test #'string=) (first (inv-assoc word *irregular-plurals* :test #'string=))) ((member (rightmost-word word) *plural-with-s-words* :test #'string=) (trim-from-end word 1)) ; exceptions to exceptions, e.g "antennas" ((ends-with word "sses") (trim-from-end word 2)) ; "masses" -> "mass" ((ends-with word "ss") word) ; "mass" -> "mass" ((ends-with word "as") word) ; "atlas" -> "atlas" ((ends-with word "is") word) ; "prognisis" -> "prognosis" ; ((ends-with word "os") word) ; "asbestos" -> "asbestos" but "gyros" -> "gyro" ! ((ends-with word "us") word) ; "apparatus" -> "apparatus" ((and (ends-with word "ies") (>= (length word) 6)) ; avoid "dies" -> "d" (concat (trim-from-end word 3) "y")) ; "bodies" -> "body" ((ends-with word "s") (trim-from-end word 1)) ; "moments" -> "moment" (t word))) ;;; ---------- (defconstant *irregular-passives* '(("make" "made") ("do" "done") ("have" "had") ("give" "given") ("sell" "sold") ("be" "be'ed") ("see" "seen") ("buy" "bought") ("bring" "brought") ("take" "taken") ("lose" "lost"))) (defun passive (word) (cond ((second (assoc word *irregular-passives* :test #'string=))) ((char= (last-char word) #\e) (concat word "d")) ((char= (last-char word) #\y) (concat (trim-from-end word 1) "ied")) (t (concat word "ed")))) ;;; ---------- (defun plural (word &key (use-mass-nounp t)) ; slow if using SAPIR (declare (ignore use-mass-nounp)) (let ( (downcase-word (string-downcase word)) ) (cond ; ((and use-mass-nounp (mass-noun downcase-word)) word) ((let ( (ireg-plural (second (assoc downcase-word *irregular-plurals* :test #'string=))) ) (cond (ireg-plural (cond ((string= word (string-capitalize word)) (string-capitalize ireg-plural)) (t ireg-plural)))))) ((ends-with downcase-word "ss") (concat word "es")) ; "mass" -> "masses" ((and (ends-with downcase-word "y") (> (length downcase-word) 2) (not (member (last-but-n-char downcase-word 1) '(#\a #\e #\i #\o #\u) :test #'char=))) (concat (trim-from-end word 1) "ies")) ; "body" -> "bodies", but "display" -> "displays" ((ends-with downcase-word "s") word) ; "moments" -> "moments" ((member downcase-word *irregular-plurals* :test #'(lambda (x y) (string= x (second y)))) word) (t (concat word "s"))))) ;;; expects singular of a word in. (defun gerund (word) (cond ((and (ends-with word "e") (>= (length word) 4)) ; avoid "die" -> "diing" (concat (trim-from-end word 1) "ing")) ; "warehouse" -> "warehousing" (t (concat word "ing")))) ;;; If all capitals, then preserve case (eg. for acronyms). Otherwise, downcase it. (defun normalize-case (word) (cond ((string= word "A") "a") ; special case, for "A car" ((string= word (string-upcase word)) word) ((and (char= (last-char word) #\s) ; "RATs" -> RATs (string= (butlast-char word) (string-upcase (butlast-char word))) (string/= word "As") (string/= word "Is")) word) (t (string-downcase word)))) (defun is-acronym (word) (let ( (singular-word (singular word)) ) (string= singular-word (string-upcase singular-word)))) ;;; ---------------------------------------- ;;; (double-quotify-list '("cat" "the big cat")) -> '("cat" "\"the big cat\"") (defun double-quotify-list (words &optional (delim-chars '(#\ ))) (cond ((stringp words) (double-quotify words delim-chars)) (t (mapcar #'(lambda (word) (double-quotify word delim-chars)) words)))) (defun double-quotify (word &optional (delim-chars '(#\ ))) (cond ((some #'(lambda (char) (member char delim-chars :test #'char=)) (explode word)) (add-doublequotes word)) (t word))) (defun add-doublequotes (string) (concat "\"" string "\"")) ;;; ====================================================================== ;;; Break up a string into pieces, preserving quoted adjacencies ;;; and trimming leading/ending white-space. ;;; ====================================================================== #| (break-up (string '| aadsf a " " "" "the cat" 1/2 a"b"c de"f|)) ("aadsf" "a" " " "the cat" "1/2" "a" "b" "c" "de" "f") |# ;;; NOTE: delim-chars MUSTN'T be a '"' (defun break-up (string &optional (delim-chars '(#\ ))) (break-up2 string 0 0 (length string) nil delim-chars)) ; nil means "not in quotes" (defun break-up2 (string m n nmax quotep &optional (delim-chars '(#\ ))) (cond ((and (eq n nmax) (eq m n)) nil) ; ignore trailing white-space ((eq n nmax) (list (subseq string m n))) ; reached the end. (t (let ( (curr-char (char string n)) ) (cond ((and (not quotep) ; is an unquoted leading white-space... (member curr-char delim-chars :test #'char=) (eq m n)) (break-up2 string (1+ n) (1+ n) nmax quotep delim-chars)) ; ... so ignore it ((and (char= curr-char #\") ; A start-quote or end-quote (eq m n)) ; without a current word (break-up2 string (1+ n) (1+ n) nmax (cond ((char= curr-char #\") (not quotep)) (t quotep)) delim-chars)) ((or (and (not quotep) (member curr-char delim-chars :test #'char=)) ; Ending delimeter = an unquoted space... (char= curr-char #\")) ; or an open-quote or a close-quote (cons (subseq string m n) (break-up2 string (1+ n) (1+ n) nmax (cond ((char= curr-char #\") (not quotep)) (t quotep)) delim-chars))) (t (break-up2 string m (1+ n) nmax quotep delim-chars))))))) ;;; ---------- ;;; (_car1) -> (_car1) ;;; (_car1 _car2) -> (_car1 "and" _car2) ;;; (_car1 _car2 _car3) -> (_car1 "," _car2 ", and" _car3) (defun andify (vals) (case (length vals) (0 nil) (1 vals) (2 (list (first vals) " and " (second vals))) (3 (list (first vals) ", " (second vals) ", and " (third vals))) (t (cons (first vals) (cons ", " (andify (rest vals))))))) (defun orify (vals) (case (length vals) (0 nil) (1 vals) (2 (list (first vals) " or " (second vals))) (3 (list (first vals) ", " (second vals) ", or " (third vals))) (t (cons (first vals) (cons ", " (orify (rest vals))))))) ;;; (commaify '(a b c d)) -> ("A, " "B, " "C, " "D") (defun commaify (vals) (cond ((endp vals) nil) ((singletonp vals) (list (string (first vals)))) (t (cons (concat (string (first vals)) ", ") (commaify (rest vals)))))) ;;; ---------- ;;; (add-escapes "a+b"" '(#\+ #\") -> "a\+b\"" (defun add-escapes (string specials) (cond ((not (stringp string)) (format t "ERROR! add-escapes: argument ~s isn't a string!~%" string)) (t (concat-list (mapcar #'(lambda (char) (cond ((member char specials) (concat "\\" (string char))) (t (string char)))) (explode string)))))) ;;; (now) -> "22/4/1999 11:49.24" (defun now () (multiple-value-bind (s m h d mo y) (get-decoded-time) (format nil "~s/~s/~s ~s:~s.~s" mo d y h m s))) ;;; (common-startstring '("emergency" "emergencies")) -> "emergenc" (defun common-startstring (strings) (cond ((singletonp strings) (first strings)) (t (subseq (first strings) 0 (loop for i from 0 to (1- (apply #'min (mapcar #'length strings))) until (some #'(lambda (string) (char/= (char string i) (char (first strings) i))) (rest strings)) finally (return i)))))) ;;; "a b c" -> "c", "a" -> "a" (defun last-word (string) (subseq string (1+ (or (search " " string :from-end t) -1)))) ;;; ---------- ;;; ("cat" "dog") -> ("cat" " " "dog") (defun insert-spaces (words) (insert-delimeter words " ")) ; in utils.lisp #| (defun insert-spaces (words) (cond ((endp words) nil) ((singletonp words) words) (t (cons (first words) (cons " " (insert-spaces (rest words))))))) |# ;;; ---------- (defun ynread (&optional (question-str "")) (format t question-str) (let ( (answer-str (read-line)) ) (cond ((string= answer-str "y") 'y) ((string= answer-str "n") 'n) (t (format t "Please enter `y' or `n'!~%") (ynread question-str))))) ;;; ---------------------------------------- (defun number-stringp (string) (string-to-number string)) (defun string-to-number (string &key (fail-mode 'fail)) (cond ((not (stringp string)) (format t "ERROR! (string-to-number ~s) should be given an ascii string as an argument!~%" string)) ((string= string "") nil) (t (let ( (number (read-from-string string)) ) (cond ((not (numberp number)) (cond ((eq fail-mode 'error) (format t "ERROR! (string-to-number ~s) should be given an ascii string representation of a number!~%" string)))) (t number)))))) (defun clear-screen () (format t " ")) (defun pause () (format t "Press to continue...") (read-line)) ;;; ---------------------------------------- ;;; USER(105): (remove-string "cat" "the cat on") ;;; -> "the on" (defun remove-string (bit string) (multiple-value-bind (left right) (split-at string bit) (cond (left (concat left (remove-string bit right))) (t string)))) ;;; ====================================================================== #| SAPIR(133): (read-to "the cat; the mat" '(#\;)) "the cat" " the mat" #\; SAPIR(134): (read-to "the cat; the mat" '(#\@)) "the cat; the mat" "" nil SAPIR(136): (read-to "the cat the mat;" '(#\;)) "the cat the mat" "" #\; |# (defun read-to (string chars) (let ( (break-point (loop for i from 0 to (1- (length string)) until (member (elt string i) chars :test #'char=) finally (return i))) ) (cond ((= break-point (length string)) (values string "" nil)) (t (values (subseq string 0 break-point) (subseq string (1+ break-point) (length string)) (elt string break-point)))))) ;;; ====================================================================== #| No! Already defined in minimatch.lisp! ;;; NOTE: This simply ignores the variables, and INSISTS that the pattern order is: (var string var string var ... var) ;;; (string-match "The hello there" '(?x "" ?y "" ?z)) -> ("The " "hello" " there") ;;; pattern *must* be odd length. Variables are just dummy fillers, and are ignored. (defun string-match (string pattern) (cond ((singletonp pattern) ; tail variable. (list string)) (t (multiple-value-bind (start0 rest-string) (split-at string (second pattern)) ; (first pattern) should be a variable (assumed!) (cond (start0 (cons start0 (string-match rest-string (rest (rest pattern)))))))))) |# ;;; ====================================================================== ;;; Returns (i) the string without parenthetical comments, and (ii) a list of the parenthesized strings ;;; USER(71): (remove-parentheticals "a (b) c (d) e") ;;; "a c e" ;;; ("b" "d") (defun remove-parentheticals (string &optional (parenthesis "(")) (multiple-value-bind (pre-parenthesis post-parenthesis) (split-at string parenthesis) (cond ((and pre-parenthesis (string= parenthesis "(")) (multiple-value-bind (rest-string parentheticals) (remove-parentheticals post-parenthesis ")") (cond ((and (char= (last-char pre-parenthesis) #\ ) ; "x (y) z" -> "x z", (char= (first-char rest-string) #\ )) ; not "x z". (values (concat pre-parenthesis (butfirst-char rest-string)) parentheticals)) (t (values (concat pre-parenthesis rest-string) parentheticals))))) ((and pre-parenthesis (string= parenthesis ")")) (multiple-value-bind (rest-string parentheticals) (remove-parentheticals post-parenthesis "(") (values rest-string (cons pre-parenthesis parentheticals)))) (t string)))) ;;; ====================================================================== #| GIVEN a list of strings broken at arbitrary points THEN concatenate and rebreak the strings at points only AND truncate when max-document-size characters have been reached [1c] USER(9): (list-to-lines-with-size-limit '("the big" "cat sat " "on the" "mat I think today") :max-document-size 20) returns TWO values ("the bigcat sat on" "the") t ; max document size was reached |# (defun list-to-lines-with-size-limit (strings &key (max-document-size 1000)) (let* ( (rebroken-strings (list-to-lines-with-size-limit0 strings :max-document-size max-document-size)) (max-document-size-reached (>= (apply #'+ (mapcar #'length rebroken-strings)) max-document-size)) ) (values rebroken-strings max-document-size-reached))) (defun list-to-lines-with-size-limit0 (strings &key (max-document-size 1000) (length-so-far 0) reverse-line-bits-so-far) (cond ((or (endp strings) (>= length-so-far max-document-size)) (cond (reverse-line-bits-so-far (list (concat-list (reverse reverse-line-bits-so-far)))))) ; otherwise nil (t (multiple-value-bind (left right) (split-at (first strings) *newline-string*) (cond (left (cons (concat-list (reverse (cons left reverse-line-bits-so-far))) (list-to-lines-with-size-limit0 (cons right (rest strings)) :max-document-size max-document-size :length-so-far (+ length-so-far (length left))))) (t (list-to-lines-with-size-limit0 (rest strings) :max-document-size max-document-size :length-so-far (+ length-so-far (length (first strings))) :reverse-line-bits-so-far (cons (first strings) reverse-line-bits-so-far)))))))) ;;; "_Car23" -> "_Car" (defun trim-numbers (string) (cond ((string= string "") (format t "WARNING! Null string passed to trim-numbers!~%") "") ((digit-char-p (last-char string)) (trim-numbers (butlast-char string))) (t string))) ;;; FILE: compiler.lisp ;;; File: compiler.lisp ;;; Author: Adam Farquhar (afarquhar@slb.com) ;;; Date: 1998 ;;; Purpose: Partially flatten the code for the KM dispatch mechanism, which ;;; in limited tests gives a 10%-30% speed-up in execution speed. ;;; Many thanks to Adam Farquhar for this neat bit of coding!! (defun reuse-cons (a b ab) (if (and (eql a (car ab)) (eql b (cdr ab))) ab (cons a b))) (defun variables-in (x) (let ((vars nil)) (labels ((vars-in (x) (cond ((consp x) (vars-in (first x)) (vars-in (rest x))) ((varp x) (pushnew x vars)) ((eql x '&rest) (pushnew 'rest vars))))) (vars-in x) (nreverse vars)))) (defun args-to-symbol (&rest args) (intern (string-upcase (format nil "~{~a~}" args)) *km-package*)) (defun add-quote-if-needed (x) "Quote X if necessary." (if (or (numberp x) (stringp x) (and (consp x) (eql (first x) 'quote)) (keywordp x)) x (list 'quote x))) ;; See Norvig pg. 180ff for description of Delay, Force. (defstruct delay (value nil)(function nil)) (defmacro delay (&rest body) `(make-delay :function #'(lambda () . ,body))) (defun force (x) (if (not (delay-p x)) x (progn (when (delay-function x) (setf (delay-value x) (funcall (delay-function x))) (setf (delay-function x) nil) (delay-value x))))) ;;; Rule Compiler ;;; (defvar *bindings* nil "Alist (pattern-var . binding), used for rule compilation.") (defun compile-rule (pattern consequent var) (let ((*bindings* nil)) `(lambda (,var) ,(compile-expr var pattern consequent)))) (defun compile-rules (rules var) "A rules is of the form (pat code) where code may reference vars in pat." (reduce #'merge-code (loop for (pattern consequent) in rules collect (compile-rule pattern consequent var)))) (defun compile-expr (var pattern consequent) (cond ((assoc pattern *bindings* :test #'eq) `(when (equal ,var ,(cdr (assoc pattern *bindings*))) ,(force consequent))) ((varp pattern) (push (cons pattern var) *bindings*) ;; `(let ((,pattern ,var)) ,(force consequent)) ;; do nothing, the consequent needs to get the bindings and use ;; it! (force consequent) ) ((atom pattern) `(when (eql ,var ,(add-quote-if-needed pattern)) ,(force consequent))) (t (compile-list var pattern consequent) ))) (defun compile-list (var pattern consequent) (let ((L (args-to-symbol var 'l)) (r (args-to-symbol var 'r))) (if (consp pattern) (if (equal pattern '(&rest)) (progn ;;(push (cons 'rest `(list ,var)) *bindings*) (push (cons 'rest var) *bindings*) (force consequent)) `(when (consp ,var) (let ((,L (first ,var)) (,R (rest ,var))) ,(compile-expr L (first pattern) (delay (compile-expr R (rest pattern) consequent)))))) `(when (null (cdr ,var)) (let ((,L (first ,var))) ,(compile-expr L (first pattern) consequent)))))) (defun mergeable (a b) ;; (f x y) (f x z) => (f x (merge y z)) ;; also handles our when, let (only one element in body) (and (listp a) (listp b) (= (length a) (length b) 3) (equal (first a) (first b)) (equal (second a) (second b)))) (defun merge-code (a b) ;; A and B are pieces of code generated by the pattern ;; compiler. Merge them (disjunctively) together. (cond ((mergeable a b) ;; (f x y) (f x z) => (f x (merge y z)) ;; also handles our when, let (only one element in body) (list (first a) (second a) (merge-code (third a) (third b)))) ((and (consp a) (eql 'or (first a))) ;; want to try to merge in with some interesting disjunct if ;; possible (let ((pos (position-if #'(lambda (x) (mergeable b x)) a))) (cond ((null pos) ;; just add b as a disjunct (if (and (consp b) (eql 'or (first b))) `(or ,@(rest a) ,@(rest b)) `(or ,@(rest a) ,b))) (t ;; merge b with one of a's disjuncts `(,@(subseq a 0 pos) ,(merge-code (nth pos a) b) ,@(subseq a (1+ pos))))))) (t `(or ,a ,b)))) ;;; ;;; KM Handler compilation ;;; #| #+ignore(defun dereference-expr (x) ;; note depending on the compiler, this can be slow. (if (consp x) (reuse-cons (dereference-expr (first x)) (dereference-expr (rest x)) x) (dereference x))) |# #| ;;; Move to interpreter lisp (defun dereference-expr (x) ;; This is fundamentally WRONG, but is the existing 1.2 behavior. (if (consp x) (mapcar #'dereference x) (dereference x))) |# ; (defparameter *km-handler-function* nil) - now in header.lisp ; no more (defparameter *custom-km-handler-function* nil) (defun reset-handler-functions () (format t "Compiling KM dispatch mechanism...") (setq *km-handler-function* (compile-handlers *km-handler-alist*)) (format t "done!~%")) ; no more (setq *custom-km-handler-function* ; no more (compile-handlers *custom-km-handlers*))) (defparameter *trace-rules* nil) (defun trace-rule (rule-pattern fact bindings) (format *trace-output* "Rule ~s is being applied to ~s with bindings ~s." rule-pattern fact bindings)) (defun compile-handlers (handlers &key code-only) "Compile the handler-alist Handlers. If code-only is T, then just return the code without invoking the compiler on it." (if (null handlers) (if code-only nil #'(lambda (fmode X) (declare (ignore X fmode)) nil)) (let ((code (reduce #'merge-code (loop for (pattern closure) in handlers collect `(lambda (f-mode x) (block km-handler . ,(cddr (compile-rule pattern (delay ; OLD `(let () ; (when *trace-rules* ; (trace-rule ',pattern X (list ,@(bindings-for pattern)))) ; (return-from km-handler ; (funcall ; ',closure f-mode ; ,@(bindings-for pattern))))) #|NEW|# `(return-from km-handler (values (funcall #',closure f-mode ; #',closure f-mode ,@(bindings-for pattern)) ',pattern))) 'x)))))))) (if code-only code (compile nil code))))) (defun bindings-for (pattern) (loop for var in (variables-in pattern) collect (cdr (assoc var *bindings*)))) #| ;;; AUX FUNCTIONS FROM KM SOURCE ;;; This is defined in km.lisp already. Need this for stand-alone compiler. (defun varp (var) (and (symbolp var) (char= #\? (char (the string (symbol-name (the symbol var))) 0)))) |# (defun faster () (format t "(Redundant command - the dispatch mechanism is now automatically compiled in KM1.4)~%")) ;;; for development mode, when the compiled code isn't there. (defun faster-dev () (cond (*compile-handlers* (format t "(The dispatch mechanism is already compiled)~%") t) (t (reset-handler-functions) (setq *compile-handlers* t)))) (defconstant *compiled-handlers-file* "compiled-handlers.lisp") (defun write-compiled-handlers () (let* ( (anonymous-function (compile-handlers *km-handler-alist* :code-only t)) (named-function `(defun compiled-km-handler-function (f-mode x) . ,(rest (rest anonymous-function)))) ; strip off "(lambda (f-mode x) ..." (stream (tell *compiled-handlers-file*)) ) (format stream " ;;; File: compiled-handlers.lisp ;;; Author: MACHINE GENERATED FILE, generated by compiler.lisp (author Adam Farquahar) ;;; This file was generated by (write-compiled-handlers) in compiler.lisp. ;;; This partially flattens the code assigned to *km-handler-list*, which results in ;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, ;;; KM will be slower if it's not loaded. For the legible, unflattened source of this ;;; flattened code, see the file interpreter.lisp. ;;; ;;; ==================== START OF MACHINE-GENERATED FILE ==================== (setq *compile-handlers* t) ") (write named-function :stream stream) (format stream " (setq *km-handler-function* #'compiled-km-handler-function) ;;; This file was generated by (write-compiled-handlers) in compiler.lisp. ;;; This partially flattens the code assigned to *km-handler-list*, which results in ;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, ;;; KM will be slower if it's not loaded. For the legible, unflattened source of this ;;; flattened code, see the file interpreter.lisp. ;;; ==================== END OF MACHINE-GENERATED FILE ==================== ") (close stream) (format t "Compiled handlers written to the file ~a~%" *compiled-handlers-file*))) ;;; FILE: compiled-handlers.lisp ;;; File: compiled-handlers.lisp ;;; Author: MACHINE GENERATED FILE, generated by compiler.lisp (author Adam Farquahar) ;;; This file was generated by (write-compiled-handlers) in compiler.lisp. ;;; This partially flattens the code assigned to *km-handler-list*, which results in ;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, ;;; KM will be slower if it's not loaded. For the legible, unflattened source of this ;;; flattened code, see the file interpreter.lisp. ;;; ;;; ==================== START OF MACHINE-GENERATED FILE ==================== (setq *compile-handlers* t) (defun compiled-km-handler-function (f-mode x) (block km-handler (or (when (consp x) (let ((xl (first x)) (xr (rest x))) (or (when (eql xl '|the|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode0 slot frameadd) (cond ((structured-slotp slot) (follow-multidepth-path (km0 frameadd :fail-mode fmode0) slot '* :fail-mode fmode0)) ((pathp slot) (let ((eval-slot (km-unique0 slot :fail-mode 'error))) (km0 `(|the| ,eval-slot |of| ,frameadd) :fail-mode fmode0))) (t (let* ((fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0))) (frames (cond ((every #'is-simple-km-term (val-to-vals frameadd)) (remove-dup-instances (val-to-vals frameadd))) (t (km0 frameadd :fail-mode fmode :check-for-looping nil))))) (cond ((eq *depth* 1) (setq *last-question* `(|the| ,slot |of| ,(vals-to-val frames))))) (cond ((not (equal frames (val-to-vals frameadd))) (remove-if-not #'is-km-term (km0 `(|the| ,slot |of| ,(vals-to-val frames)) :fail-mode fmode))) (t (remove-if-not #'is-km-term (km-multi-slotvals frames slot :fail-mode fmode)))))))) f-mode xrl xrrrl) '(|the| ?slot |of| ?frameadd))))))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrl '|of|) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode0 class slot frameadd) (cond ((structured-slotp slot) (follow-multidepth-path (km0 frameadd :fail-mode fmode0) slot class :fail-mode fmode0)) ((pathp slot) (let ((eval-slot (km-unique0 slot :fail-mode 'error))) (km0 `(|the| ,class ,eval-slot |of| ,frameadd) :fail-mode fmode0))) (t (let* ((fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0)))) (vals-in-class (km0 `(|the| ,slot |of| ,frameadd) :fail-mode fmode) class))))) f-mode xrl xrrl xrrrrl) '(|the| ?class ?slot |of| ?frameadd))))))))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (fmode frame slotsvals) (declare (ignore fmode)) (let ((answer (km0 `(|every| ,frame |with| ,@slotsvals)))) (cond ((null answer) (report-error 'user-error "No values found for expression ~a!~%" `(|the| ,frame |with| ,@slotsvals))) ((not (singletonp answer)) (report-error 'user-error "Expected a single value for expression ~a, but found multiple values ~a!~%" `(|the| ,frame |with| ,@slotsvals) answer)) (t answer)))) f-mode xrl xrrr) '(|the| ?frame |with| &rest))))))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode frame) (declare (ignore fmode)) (let ((answer (km0 `(|every| ,frame)))) (cond ((null answer) (report-error 'user-error "No values found for expression ~a!~%" `(|the| ,frame))) ((not (singletonp answer)) (report-error 'user-error "Expected a single value for expression ~a, but found multiple values ~a!~%" `(|the| ,frame) answer)) (t answer)))) f-mode xrl) '(|the| ?frame)))))))) (when (eql xl '|a|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode class) (declare (ignore _fmode)) (list (create-instance class))) f-mode xrl) '(|a| ?class)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|called|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode class tag) (declare (ignore _fmode)) (km-setq '*are-some-tags* t) (cond ((km-tagp tag) (list (create-instance class `((|called| ,(val-to-vals tag)))))) (t (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `(|a| ,class |called| ,tag) tag)))) f-mode xrl xrrrl) '(|a| ?class |called| ?tag)))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode 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)) slotsvals)))) (cond ((am-in-prototype-mode) (km0 '(|evaluate-paths|)))) (list instance))))) f-mode xrl xrrrl xrrrrr) '(|a| ?class |called| ?tag |with| &rest)))))))))) (when (eql xrrl '|uniquely-called|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode class tag) (declare (ignore _fmode)) (km-setq '*are-some-constraints* t) (km-setq '*are-some-tags* t) (cond ((km-tagp tag) (list (create-instance class `((|uniquely-called| ,(val-to-vals tag)))))) (t (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `(|a| ,class |uniquely-called| ,tag) tag)))) f-mode xrl xrrrl) '(|a| ?class |uniquely-called| ?tag)))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode 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)) slotsvals)))) (cond ((am-in-prototype-mode) (km0 '(|evaluate-paths|)))) (list instance))))) f-mode xrl xrrrl xrrrrr) '(|a| ?class |uniquely-called| ?tag |with| &rest)))))))))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode class slotsvals) (declare (ignore _fmode)) (cond ((are-slotsvals slotsvals) (let ((instance (create-instance class slotsvals))) (cond ((am-in-prototype-mode) (km0 '(|evaluate-paths|)))) (list instance))))) f-mode xrl xrrr) '(|a| ?class |with| &rest))))))))))) (when (eql xl '|some|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode class) (declare (ignore _fmode)) (list (create-instance class nil *fluent-instance-marker-string*))) f-mode xrl) '(|some| ?class)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode class slotsvals) (declare (ignore _fmode)) (cond ((are-slotsvals slotsvals) (list (create-instance class slotsvals *fluent-instance-marker-string*))))) f-mode xrl xrrr) '(|some| ?class |with| &rest)))))))))) (when (eql xl '|a-prototype|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode class) (km0 `(|a-prototype| ,class |with|) :fail-mode fmode)) f-mode xrl) '(|a-prototype| ?class)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode class slotsvals) (declare (ignore _fmode)) (cond ((am-in-local-situation) (report-error 'user-error "Can't enter prototype mode when in a Situation!~%")) ((am-in-prototype-mode) (report-error 'user-error "~a~%Attempt to enter prototype mode while already in prototype mode (not allowed)!~%Perhaps you are missing an (end-prototype)?" `(|a-prototype| ,class |with| ,@slotsvals))) ((are-slotsvals slotsvals) (new-context) (km-setq '*curr-prototype* (create-instance class `((|prototype-of| (,class)) ,(cond (slotsvals `(|prototype-scope| ((|the-class| ,class |with| ,@slotsvals)))) (t `(|prototype-scope| (,class)))) ,@slotsvals) *proto-marker-string* nil)) (add-val *curr-prototype* '|prototype-participants| *curr-prototype*) (km-setq '*are-some-prototypes* t) (cond ((null slotsvals) (add-to-prototype-definition *curr-prototype* `(|a-prototoype| ,class))) (t (add-to-prototype-definition *curr-prototype* `(|a-prototype| ,class |with| ,@slotsvals)))) (list *curr-prototype*)))) f-mode xrl xrrr) '(|a-prototype| ?class |with| &rest)))))))))) (when (eql xl '|end-prototype|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (km-setq '*curr-prototype* nil) (global-situation) (new-context) '(|t|)) f-mode) '(|end-prototype|))))) (when (eql xl '|clone|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode)) (let ((source (km-unique0 expr :fail-mode 'error))) (cond (source (list (clone source)))))) f-mode xrl) '(|clone| ?expr))))))) (when (eql xl '|evaluate-paths|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (eval-instances) '(|t|)) f-mode) '(|evaluate-paths|))))) (when (eql xl '|fluent-instancep|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (cond ((fluent-instancep (km-unique0 expr :fail-mode fmode)) '(|t|)))) f-mode xrl) '(|fluent-instancep| ?expr))))))) (when (eql xl '|default-fluent-status|) (return-from km-handler (values (funcall #'(lambda (fmode rest) (declare (ignore fmode)) (default-fluent-status (first rest))) f-mode xr) '(|default-fluent-status| &rest)))) (when (eql xl '|must-be-a|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _class) (declare (ignore _fmode _class)) (note-are-constraints) nil) f-mode xrl) '(|must-be-a| ?class)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode _class slotsvals) (declare (ignore _fmode _class)) (are-slotsvals slotsvals) (note-are-constraints) nil) f-mode xrl xrrr) '(|must-be-a| ?class |with| &rest)))))))))) (when (eql xl '|possible-values|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _values) (declare (ignore _fmode _values)) (note-are-constraints) nil) f-mode xrl) '(|possible-values| ?values))))))) (when (eql xl '|excluded-values|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _values) (declare (ignore _fmode _values)) (note-are-constraints) nil) f-mode xrl) '(|excluded-values| ?values))))))) (when (eql xl '|mustnt-be-a|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _class) (declare (ignore _fmode _class)) (note-are-constraints) nil) f-mode xrl) '(|mustnt-be-a| ?class)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode _class slotsvals) (declare (ignore _fmode _class)) (are-slotsvals slotsvals) (note-are-constraints) nil) f-mode xrl xrrr) '(|mustnt-be-a| ?class |with| &rest)))))))))) (when (eql xl '<>) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _val) (declare (ignore _fmode _val)) (note-are-constraints) nil) f-mode xrl) '(<> ?val))))))) (when (eql xl '|no-inheritance|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode))) f-mode) '(|no-inheritance|))))) (when (eql xl '|constraint|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _expr) (declare (ignore _fmode _expr)) (note-are-constraints) nil) f-mode xrl) '(|constraint| ?expr))))))) (when (eql xl '|set-constraint|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _expr) (declare (ignore _fmode _expr)) (note-are-constraints) nil) f-mode xrl) '(|set-constraint| ?expr))))))) (when (eql xl '|set-filter|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _expr) (declare (ignore _fmode _expr)) (note-are-constraints) nil) f-mode xrl) '(|set-filter| ?expr))))))) (when (eql xl '|at-least|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _n _class) (declare (ignore _fmode _n _class)) (note-are-constraints) nil) f-mode xrl xrrl) '(|at-least| ?n ?class))))))))) (when (eql xl '|at-most|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _n _class) (declare (ignore _fmode _n _class)) (note-are-constraints) nil) f-mode xrl xrrl) '(|at-most| ?n ?class))))))))) (when (eql xl '|exactly|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode _n _class) (declare (ignore _fmode _n _class)) (note-are-constraints) nil) f-mode xrl xrrl) '(|exactly| ?n ?class))))))))) (when (eql xl '|sanity-check|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (cond (*sanity-checks* (km0 expr :fail-mode fmode)) (t '(|t|)))) f-mode xrl) '(|sanity-check| ?expr))))))) (when (eql xl '|every|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|has|) (return-from km-handler (values (funcall #'(lambda (_fmode cexpr slotsvals) (declare (ignore _fmode)) (let ((class (km-unique0 cexpr :fail-mode 'error))) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,cexpr |has| ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) (let* ((slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00))) (add-slotsvals class slotsvals0 :facet 'member-properties :install-inversesp nil)) (cond ((and (assoc '|assertions| slotsvals) (not (member class *classes-using-assertions-slot*))) (km-setq '*classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) (mapc #'un-done (all-instances class)) (list class))))) f-mode xrl xrrr) '(|every| ?cexpr |has| &rest)))) (when (eql xrrl '|also-has|) (return-from km-handler (values (funcall #'(lambda (_fmode cexpr slotsvals) (declare (ignore _fmode)) (let ((class (km-unique0 cexpr :fail-mode 'error))) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,cexpr |also-has| ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) (let* ((slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00))) (add-slotsvals class slotsvals0 :facet 'member-properties :install-inversesp nil :combine-values-by 'appending)) (cond ((and (assoc '|assertions| slotsvals) (not (member class *classes-using-assertions-slot*))) (km-setq '*classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) (mapc #'un-done (all-instances class)) (list class))))) f-mode xrl xrrr) '(|every| ?cexpr |also-has| &rest)))) (when (eql xrrl '|now-has|) (return-from km-handler (values (funcall #'(lambda (_fmode cexpr slotsvals) (declare (ignore _fmode)) (let ((class (km-unique0 cexpr :fail-mode 'error))) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,cexpr |now-has| ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) (let* ((slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00))) (add-slotsvals class slotsvals0 :facet 'member-properties :install-inversesp nil :combine-values-by 'overwriting)) (cond ((and (assoc '|assertions| slotsvals) (not (member class *classes-using-assertions-slot*))) (km-setq '*classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) (mapc #'un-done (all-instances class)) (list class))))) f-mode xrl xrrr) '(|every| ?cexpr |now-has| &rest)))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode frame slotsvals) (declare (ignore _fmode)) (cond ((are-slotsvals slotsvals) (let ((existential-expr (cond ((and (null slotsvals) (pathp frame)) (path-to-existential-expr frame)) (t `(|a| ,frame |with| ,@slotsvals))))) (find-subsumees existential-expr))))) f-mode xrl xrrr) '(|every| ?frame |with| &rest)))) (when (eql xrrl '|has-definition|) (return-from km-handler (values (funcall #'(lambda (_fmode cexpr slotsvals) (declare (ignore _fmode)) (let ((class (km-unique0 cexpr :fail-mode 'error))) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(|every| ,cexpr |has-definition| ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) (let* ((slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00)) (parents-of-defined-concept (decomment (vals-in (assoc '|instance-of| slotsvals0))))) (cond ((not (every #'kb-objectp parents-of-defined-concept)) (report-error 'user-error "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%" `(|every| ,cexpr |has-definition| ,@slotsvals0))) ((null parents-of-defined-concept) (report-error 'user-error "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%" `(|every| ,cexpr |has-definition| ,@slotsvals0))) (t (add-slotsvals class slotsvals0 :facet 'member-definition :install-inversesp nil) (point-parents-to-defined-concept class parents-of-defined-concept 'member-definition) (km-setq '*are-some-definitions* t) (mapc #'un-done (all-instances class)) (list class)))))))) f-mode xrl xrrr) '(|every| ?cexpr |has-definition| &rest))))))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode frame) (km0 `(|every| ,frame |with|) :fail-mode fmode)) f-mode xrl) '(|every| ?frame)))))))) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrl '|has|) (return-from km-handler (values (funcall #'(lambda (_fmode instance-expr slotsvals) (declare (ignore _fmode)) (let ((instance (km-unique0 instance-expr :fail-mode 'error))) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr |has| ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) (add-slotsvals instance slotsvals) (un-done instance) (classify instance :slots-that-changed (mapcar #'slot-in slotsvals)) (cond ((am-in-prototype-mode) (km0 '(|evaluate-paths|)))) (list instance))))) f-mode xl xrr) '(?instance-expr |has| &rest)))) (when (eql xrl '|also-has|) (return-from km-handler (values (funcall #'(lambda (_fmode instance-expr slotsvals) (declare (ignore _fmode)) (let ((instance (km-unique0 instance-expr :fail-mode 'error))) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr |also-has| ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) (add-slotsvals instance slotsvals :combine-values-by 'appending) (un-done instance) (classify instance :slots-that-changed (mapcar #'slot-in slotsvals)) (cond ((am-in-prototype-mode) (km0 '(|evaluate-paths|)))) (list instance))))) f-mode xl xrr) '(?instance-expr |also-has| &rest)))) (when (eql xrl '|now-has|) (return-from km-handler (values (funcall #'(lambda (_fmode instance-expr slotsvals) (declare (ignore _fmode)) (let ((instance (km-unique0 instance-expr :fail-mode 'error))) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr |now-has| ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) (add-slotsvals instance slotsvals :combine-values-by 'overwriting) (list instance))))) f-mode xl xrr) '(?instance-expr |now-has| &rest)))) (when (eql xrl :==) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (consp xrrl) (let ((xrrll (first xrrl)) (xrrlr (rest xrrl))) (or (when (consp xrrlr) (let ((xrrlrl (first xrrlr)) (xrrlrr (rest xrrlr))) (or (when (eql xrrlrl '&&) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode target xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs && ,@rest) :fail-mode 'error :joiner '&& :target target)) f-mode xl xrrll xrrlrr) '(?target :== (?xs && &rest)))))) (when (eql xrrlrl '&) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode target x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x & ,@rest) :fail-mode 'error :joiner '& :target target)) f-mode xl xrrll xrrlrr) '(?target :== (?x & &rest)))))) (when (eql xrrlrl '&+) (when (consp xrrlrr) (let ((xrrlrrl (first xrrlrr)) (xrrlrrr (rest xrrlrr))) (when (eql xrrlrrr 'nil) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode target x y) (let ((unification (lazy-unify-exprs x y :classes-subsumep t :fail-mode fmode :target target))) (cond (unification (list unification)) ((eq fmode 'error) (report-error 'user-error "Unification (~a &+ ~a) failed!~%" x y))))) f-mode xl xrrll xrrlrrl) '(?target :== (?x &+ ?y)))))))))))) (when (eql xrrll :|set|) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode target exprs) (declare (ignore fmode)) (my-mapcan #'(lambda (expr) (km0 expr :target target)) exprs)) f-mode xl xrrlr) '(?target :== (:|set| &rest)))))))))))) (when (eql xrl '&&) (return-from km-handler (values (funcall #'(lambda (fmode xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs && ,@rest) :fail-mode 'error :joiner '&&)) f-mode xl xrr) '(?xs && &rest)))) (when (eql xrl '&) (return-from km-handler (values (funcall #'(lambda (fmode x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x & ,@rest) :fail-mode 'error :joiner '&)) f-mode xl xrr) '(?x & &rest)))) (when (eql xrl '===) (return-from km-handler (values (funcall #'(lambda (fmode xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs === ,@rest) :fail-mode 'error :joiner '===)) f-mode xl xrr) '(?xs === &rest)))) (when (eql xrl '==) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (declare (ignore fmode)) (lazy-unify-&-expr `(,x == ,y) :fail-mode 'error :joiner '==)) f-mode xl xrrl) '(?x == ?y))))))) (when (eql xrl '/==) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (declare (ignore fmode)) (let ((xv (km-unique0 x :fail-mode 'error)) (yv (km-unique0 y :fail-mode 'error))) (cond ((equal xv yv) (report-error 'user-error "(~a /== ~a): ~a and ~a are the same object!~%" x y x y)) ((kb-objectp xv) (km0 `(,xv |has| (/== (,yv))) :fail-mode 'error)) ((kb-objectp yv) (km0 `(,yv |has| (/== (,xv))) :fail-mode 'error)) ('(|t|))))) f-mode xl xrrl) '(?x /== ?y))))))) (when (eql xrl '&&!) (return-from km-handler (values (funcall #'(lambda (fmode xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs &&! ,@rest) :fail-mode 'error :joiner '&&!)) f-mode xl xrr) '(?xs &&! &rest)))) (when (eql xrl '&!) (return-from km-handler (values (funcall #'(lambda (fmode x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x &! ,@rest) :fail-mode 'error :joiner '&!)) f-mode xl xrr) '(?x &! &rest)))) (when (eql xrl '&?) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (cond ((null x) '(|t|)) ((null y) '(|t|)) ((existential-exprp y) (let ((xf (km-unique0 x))) (cond ((null xf) '(|t|)) ((unifiable-with-existential-expr xf y) '(|t|))))) ((existential-exprp x) (let ((yf (km-unique0 y))) (cond ((null yf) '(|t|)) ((unifiable-with-existential-expr yf x) '(|t|))))) (t (let ((xv (km-unique0 x))) (cond ((null xv) '(|t|)) (t (let ((yv (km-unique0 y))) (cond ((null yv) '(|t|)) ((try-lazy-unify xv yv) '(|t|)))))))))) f-mode xl xrrl) '(?x &? ?y))))))) (when (eql xrl '&+?) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (cond ((existential-exprp y) (let ((xf (km-unique0 x))) (cond ((null xf) '(|t|)) ((unifiable-with-existential-expr xf y :classes-subsumep t) '(|t|))))) ((existential-exprp x) (let ((yf (km-unique0 y))) (cond ((null yf) '(|t|)) ((unifiable-with-existential-expr yf x :classes-subsumep t) '(|t|))))) (t (let ((xv (km-unique0 x))) (cond ((null xv) '(|t|)) (t (let ((yv (km-unique0 y))) (cond ((null yv) '(|t|)) ((try-lazy-unify xv yv :classes-subsumep t) '(|t|)))))))))) f-mode xl xrrl) '(?x &+? ?y))))))) (when (eql xrl '&+) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (let ((unification (lazy-unify-exprs x y :classes-subsumep t :fail-mode fmode))) (cond (unification (list unification)) ((eq fmode 'error) (report-error 'user-error "Unification (~a &+ ~a) failed!~%" x y))))) f-mode xl xrrl) '(?x &+ ?y))))))) (when (eql xrl '=) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (let ((xv (km0 x :fail-mode fmode)) (yv (km0 y :fail-mode fmode))) (cond ((km-set-equal (dereference xv) yv) '(|t|))))) f-mode xl xrrl) '(?x = ?y)))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrl '+/-) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (or (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y z) (declare (ignore _fmode)) (let ((xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) (zval (km-unique0 z :fail-mode 'error))) (cond ((and (numberp xval) (numberp yval) (numberp zval)) (cond ((<= (abs (- xval yval)) (abs zval)) '(|t|))))))) f-mode xl xrrl xrrrrl) '(?x = ?y +/- ?z)))) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrl '%) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y z) (declare (ignore _fmode)) (let ((xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error)) (zval (km-unique0 z :fail-mode 'error))) (cond ((and (numberp xval) (numberp yval) (numberp zval)) (cond ((<= (abs (- xval yval)) (* (max (abs xval) (abs yval)) (abs zval) 0.01)) '(|t|))))))) f-mode xl xrrl xrrrrl) '(?x = ?y +/- ?z %))))))))))))))))) (when (eql xrl '/=) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (let ((xv (km0 x :fail-mode fmode)) (yv (km0 y :fail-mode fmode))) (cond ((not (km-set-equal (dereference xv) yv)) '(|t|))))) f-mode xl xrrl) '(?x /= ?y))))))) (when (eql xrl '|has-definition|) (return-from km-handler (values (funcall #'(lambda (_fmode instance-expr slotsvals) (declare (ignore _fmode)) (let ((instance (km-unique0 instance-expr :fail-mode 'error))) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(|every| ,instance-expr |has-definition| ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) (let* ((slotsvals0 (decomment slotsvals)) (parents-of-defined-concept (decomment (vals-in (assoc '|instance-of| slotsvals0))))) (cond ((not (every #'kb-objectp parents-of-defined-concept)) (report-error 'user-error "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%" `(,instance-expr |has-definition| ,@slotsvals0))) ((null parents-of-defined-concept) (report-error 'user-error "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%" `(,instance-expr |has-definition| ,@slotsvals0))) (t (add-slotsvals instance slotsvals0 :facet 'own-definition) (point-parents-to-defined-concept instance parents-of-defined-concept 'own-definition) (km-setq '*are-some-definitions* t) (un-done instance) (classify instance :slots-that-changed (mapcar #'slot-in slotsvals)) (list instance)))))))) f-mode xl xrr) '(?instance-expr |has-definition| &rest)))) (when (eql xrl '>) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (let ((xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error))) (cond ((and (numberp xval) (numberp yval)) (cond ((> xval yval) '(|t|))))))) f-mode xl xrrl) '(?x > ?y))))))) (when (eql xrl '<) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (let ((xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error))) (cond ((and (numberp xval) (numberp yval)) (cond ((< xval yval) '(|t|))))))) f-mode xl xrrl) '(?x < ?y))))))) (when (eql xrl '>=) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (let ((xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error))) (cond ((and (numberp xval) (numberp yval)) (cond ((>= xval yval) '(|t|))))))) f-mode xl xrrl) '(?x >= ?y))))))) (when (eql xrl '<=) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (let ((xval (km-unique0 x :fail-mode 'error)) (yval (km-unique0 y :fail-mode 'error))) (cond ((and (numberp xval) (numberp yval)) (cond ((<= xval yval) '(|t|))))))) f-mode xl xrrl) '(?x <= ?y))))))) (when (eql xrl '|and|) (return-from km-handler (values (funcall #'(lambda (_fmode x rest) (declare (ignore _fmode)) (cond ((and (listp x) (= (length x) 3) (eq (second x) '==)) (let* ((xx (first x)) (yy (third x))) (cond ((and (km-varp xx) (km-varp yy)) (km0 (subst xx yy rest))) ((km-varp xx) (km0 (subst (vals-to-val (km0 yy)) xx rest))) ((km-varp yy) (km0 (subst (vals-to-val (km0 xx)) yy rest))) ((and (lazy-unify-&-expr `(,xx == yy) :fail-mode 'error :joiner '==) (km0 rest)))))) (t (and (km0 x) (km0 rest))))) f-mode xl xrr) '(?x |and| &rest)))) (when (eql xrl '|or|) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (or (and (not (on-km-stackp x)) (km0 x)) (km0 y))) f-mode xl xrr) '(?x |or| &rest)))) (when (eql xrl '|is-subsumed-by|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (km0 `(,y |subsumes| ,x) :fail-mode fmode)) f-mode xl xrrl) '(?x |is-subsumed-by| ?y))))))) (when (eql xrl '|subsumes|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (let ((yv (km0 y))) (cond ((null yv) '(|t|)) (t (let ((xv (km0 x))) (cond ((and (not (null xv)) (subsumes xv yv)) '(|t|)))))))) f-mode xl xrrl) '(?x |subsumes| ?y))))))) (when (eql xrl '|is-covered-by|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (km0 `(,y |covers| ,x) :fail-mode fmode)) f-mode xl xrrl) '(?x |is-covered-by| ?y))))))) (when (eql xrl '|covers|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode x y) (km0 `(,y |isa| ,x) :fail-mode fmode)) f-mode xl xrrl) '(?x |covers| ?y))))))) (when (eql xrl '|isa|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode y x) (declare (ignore _fmode)) (let ((yv (km-unique0 y))) (cond ((null yv) '(|t|)) (t (let ((xv (km-unique0 x))) (cond ((null xv) nil) ((kb-objectp xv) (cond ((isa yv xv) '(|t|)))) ((covers (list xv) yv) '(|t|)))))))) f-mode xl xrrl) '(?y |isa| ?x))))))) (when (eql xrl '|is|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x y) (declare (ignore _fmode)) (let ((xv (km-unique0 x))) (cond ((null xv) nil) (t (let ((yv (km-unique0 y))) (cond ((and (not (null yv)) (is xv yv)) '(|t|)))))))) f-mode xl xrrl) '(?x |is| ?y))))))) (when (eql xrl '|includes|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode xs y) (declare (ignore _fmode)) (let ((xs-vals (km0 xs)) (y-val (km-unique0 y :fail-mode 'error))) (cond ((member y-val (dereference xs-vals) :test #'equal) '(|t|))))) f-mode xl xrrl) '(?xs |includes| ?y))))))) (when (eql xrl '|is-superset-of|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode xs ys) (declare (ignore _fmode)) (let ((xs-vals (km0 xs)) (ys-vals (km0 ys))) (cond ((subsetp ys-vals (dereference xs-vals) :test #'equal) '(|t|))))) f-mode xl xrrl) '(?xs |is-superset-of| ?ys))))))) (when (eql xrl '|append|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode seq-expr1 seq-expr2) (declare (ignore _fmode)) (let* ((seq1 (km-unique0 seq-expr1)) (seq2 (km-unique0 seq-expr2)) (elts1 (cond ((or (km-seqp seq1) (km-bagp seq1)) (seq-to-list seq1)) ((null seq1) nil) ((is-km-term seq1) (list seq1)) (t (report-error 'user-error "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" seq-expr1 seq-expr2 seq-expr1)))) (elts2 (cond ((or (km-seqp seq2) (km-bagp seq2)) (seq-to-list seq2)) ((null seq2) nil) ((is-km-term seq2) (list seq2)) (t (report-error 'user-error "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" seq-expr1 seq-expr2 seq-expr2)))) (result-type (cond ((or (and (km-seqp seq1) (km-bagp seq2)) (and (km-seqp seq2) (km-bagp seq1))) (report-error 'user-error "(~a append ~a): Elements should be both sequences or both bags!" seq-expr1 seq-expr2) ':|seq|) ((or (km-bagp seq1) (km-bagp seq2)) ':|bag|) (t ':|seq|)))) `((,result-type ,@(append elts1 elts2))))) f-mode xl xrrl) '(?seq-expr1 |append| ?seq-expr2))))))) (when (eql xrl '|called|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr tag) (let* ((vals (km0 expr))) (cond (vals (km-trace 'comment "Now find just those value(s) whose tag = ~a..." tag))) (let* ((tags (val-to-vals tag)) (target-vals (remove-if #'(lambda (val) (set-difference tags (append (km0 `(|the| |called| |of| ,val)) (km0 `(|the| |uniquely-called| |of| ,val))) :test #'equal)) vals))) (cond ((null target-vals) (cond ((eq fmode 'error) (report-error 'user-error "(~a called/uniquely-called ~a): No values of ~a (evaluates to ~a) is called/uniquely-called ~a!" expr tag expr vals (val-to-vals tag))))) (t target-vals))))) f-mode xl xrrl) '(?expr |called| ?tag))))))) (when (eql xrl '|uniquely-called|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr tag) (km0 `(,expr |called| ,tag) :fail-mode fmode)) f-mode xl xrrl) '(?expr |uniquely-called| ?tag))))))) (when (eql xrl '^) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrl '^) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x ^ ,y) ^ ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x ^ ?y ^ &rest)))) (when (eql xrrrl '+) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x ^ ,y) + ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x ^ ?y + &rest)))) (when (eql xrrrl '-) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x ^ ,y) - ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x ^ ?y - &rest)))) (when (eql xrrrl '/) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x ^ ,y) / ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x ^ ?y / &rest)))) (when (eql xrrrl '*) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x ^ ,y) * ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x ^ ?y * &rest))))))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr1 expr2) (let ((x (km-unique0 expr1 :fail-mode fmode)) (y (km-unique0 expr2 :fail-mode fmode))) (cond ((and (numberp x) (numberp y)) (list (expt x y)))))) f-mode xl xrrl) '(?expr1 ^ ?expr2)))))))) (when (eql xrl '/) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrl '+) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x / ,y) + ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x / ?y + &rest)))) (when (eql xrrrl '-) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x / ,y) - ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x / ?y - &rest)))) (when (eql xrrrl '/) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x / ,y) / ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x / ?y / &rest)))) (when (eql xrrrl '*) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x / ,y) * ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x / ?y * &rest))))))))) (return-from km-handler (values (funcall #'(lambda (fmode expr rest) (let ((x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode))) (cond ((and (numberp x) (numberp y)) (cond ((and (zerop x) (zerop y) (list 1))) ((zerop x) (list 0)) ((zerop y) (list *infinity*)) ((and (numberp x) (numberp y)) (list (/ x y)))))))) f-mode xl xrr) '(?expr / &rest))))) (when (eql xrl '*) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrl '+) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x * ,y) + ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x * ?y + &rest)))) (when (eql xrrrl '-) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x * ,y) - ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x * ?y - &rest)))) (when (eql xrrrl '/) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x * ,y) / ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x * ?y / &rest))))))))) (return-from km-handler (values (funcall #'(lambda (fmode expr rest) (let ((x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode))) (cond ((and (numberp x) (numberp y)) (list (* x y)))))) f-mode xl xrr) '(?expr * &rest))))) (when (eql xrl '-) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrl '-) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x - ,y) - ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x - ?y - &rest)))) (when (eql xrrrl '+) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x - ,y) + ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x - ?y + &rest))))))))) (return-from km-handler (values (funcall #'(lambda (fmode expr rest) (let ((x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode))) (cond ((and (numberp x) (numberp y)) (list (- x y)))))) f-mode xl xrr) '(?expr - &rest))))) (when (eql xrl '+) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrl '-) (return-from km-handler (values (funcall #'(lambda (fm x y rest) (km0 `((,x + ,y) - ,@rest) :fail-mode fm)) f-mode xl xrrl xrrrr) '(?x + ?y - &rest)))))))) (return-from km-handler (values (funcall #'(lambda (fmode expr rest) (let ((x (km-unique0 expr :fail-mode fmode)) (y (km-unique0 rest :fail-mode fmode))) (cond ((and (numberp x) (numberp y)) (list (+ x y)))))) f-mode xl xrr) '(?expr + &rest)))))))) (when (eql xl '|in-theory|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode theory-expr) (declare (ignore _fmode)) (in-theory theory-expr)) f-mode xrl) '(|in-theory| ?theory-expr)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode theory-expr km-expr) (declare (ignore _fmode)) (in-theory theory-expr km-expr)) f-mode xrl xrrl) '(|in-theory| ?theory-expr ?km-expr)))))))))) (when (eql xl '|hide-theory|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode theory-expr) (declare (ignore _fmode)) (mapc #'hide-theory (km0 theory-expr)) (cond ((visible-theories)) (t '(|t|)))) f-mode xrl) '(|hide-theory| ?theory-expr))))))) (when (eql xl '|see-theory|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode theory-expr) (declare (ignore _fmode)) (mapc #'see-theory (km0 theory-expr)) (visible-theories)) f-mode xrl) '(|see-theory| ?theory-expr))))))) (when (eql xl '|end-theory|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (in-situation *global-situation*)) f-mode) '(|end-theory|))))) (when (eql xl '|visible-theories|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (visible-theories)) f-mode) '(|visible-theories|))))) (when (eql xl '|in-situation|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode situation-expr) (declare (ignore _fmode)) (in-situation situation-expr)) f-mode xrl) '(|in-situation| ?situation-expr)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (consp xrrl) (let ((xrrll (first xrrl)) (xrrlr (rest xrrl))) (when (eql xrrll '|the|) (when (consp xrrlr) (let ((xrrlrl (first xrrlr)) (xrrlrr (rest xrrlr))) (when (consp xrrlrr) (let ((xrrlrrl (first xrrlrr)) (xrrlrrr (rest xrrlrr))) (when (eql xrrlrrl '|of|) (when (consp xrrlrrr) (let ((xrrlrrrl (first xrrlrrr)) (xrrlrrrr (rest xrrlrrr))) (when (eql xrrlrrrr 'nil) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode situation slot frame) (declare (ignore _fmode)) (cond ((and (kb-objectp situation) (isa situation '|Situation|) (already-done frame slot situation)) (remove-constraints (get-vals frame slot :situation (target-situation situation frame slot)))) (t (in-situation situation `(|the| ,slot |of| ,frame))))) f-mode xrl xrrlrl xrrlrrrl) '(|in-situation| ?situation (|the| ?slot |of| ?frame)))))))))))))))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode situation-expr km-expr) (declare (ignore _fmode)) (in-situation situation-expr km-expr)) f-mode xrl xrrl) '(|in-situation| ?situation-expr ?km-expr))))))))))) (when (eql xl '|end-situation|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (in-situation *global-situation*)) f-mode) '(|end-situation|))))) (when (eql xl '|global-situation|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (in-situation *global-situation*)) f-mode) '(|global-situation|))))) (when (eql xl '|new-situation|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (new-situation)) f-mode) '(|new-situation|))))) (when (eql xl '|do|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr))) f-mode xrl) '(|do| ?action-expr))))))) (when (eql xl '|do-and-next|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr :change-to-next-situation t))) f-mode xrl) '(|do-and-next| ?action-expr))))))) (when (eql xl '|try-do|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr :test-or-assert-pcs 'test))) f-mode xrl) '(|try-do| ?action-expr))))))) (when (eql xl '|try-do-and-next|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode action-expr) (declare (ignore _fmode)) (list (do-action action-expr :change-to-next-situation t :test-or-assert-pcs 'test))) f-mode xrl) '(|try-do-and-next| ?action-expr))))))) (when (eql xl '|do-script|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode script) (km0 `(|forall| (|the| |actions| |of| ,script) (|do-and-next| |It|)) :fail-mode fmode)) f-mode xrl) '(|do-script| ?script))))))) (when (eql xl '|do-plan|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode plan-instance-expr) (declare (ignore _fmode)) (let ((plan-instance (km-unique plan-instance-expr))) (do-plan plan-instance))) f-mode xrl) '(|do-plan| ?plan-instance-expr))))))) (when (eql xl '|assert|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode triple-expr) (declare (ignore _fmode)) (let ((triple (km-unique0 triple-expr))) (cond ((not (km-triplep triple)) (report-error 'user-error "(assert ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" triple-expr triple)) (t (km0 `(,(arg1of triple) |has| (,(arg2of triple) ,(val-to-vals (arg3of triple)))) :fail-mode 'error))))) f-mode xrl) '(|assert| ?triple-expr))))))) (when (eql xl '|is-true|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode triple-expr) (declare (ignore _fmode)) (let* ((triple (km-unique0 triple-expr))) (cond ((not (km-triplep triple)) (report-error 'user-error "(is-true ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" triple-expr triple)) ((comparison-operator (arg2of triple)) (km0 `(,(second triple) ,(third triple) ,(fourth triple)))) (t (let ((frame (km-unique0 (second triple) :fail-mode 'error)) (slot (km-unique0 (third triple) :fail-mode 'error)) (value (fourth triple))) (cond ((null value) '(|t|)) ((km0 `(,frame |is| '(|a| |Thing| |with| (,slot (,value)))))))))))) f-mode xrl) '(|is-true| ?triple-expr))))))) (when (eql xl '|all-true|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode triples-expr) (declare (ignore _fmode)) (let ((triples (km0 triples-expr))) (cond ((every #'(lambda (triple) (km0 `(|is-true| ,triple))) triples) '(|t|))))) f-mode xrl) '(|all-true| ?triples-expr))))))) (when (eql xl '|some-true|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode triples-expr) (declare (ignore _fmode)) (let ((triples (km0 triples-expr))) (cond ((some #'(lambda (triple) (km0 `(|is-true| ,triple))) triples) '(|t|))))) f-mode xrl) '(|some-true| ?triples-expr))))))) (when (eql xl '|next-situation|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (cond ((am-in-local-situation) (list (do-action nil :change-to-next-situation t))) (t (report-error 'user-error "Can only do (next-situation) from within a situation!~%")))) f-mode) '(|next-situation|))))) (when (eql xl '|curr-situation|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (list (curr-situation))) f-mode) '(|curr-situation|))))) (when (eql xl '|ignore-result|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode)) (km0 expr) nil) f-mode xrl) '(|ignore-result| ?expr))))))) (when (eql xl '|ignore|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode expr)) nil) f-mode xrl) '(|ignore| ?expr))))))) (when (eql xl '|in-every-situation|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode situation-class km-expr) (cond ((not (is-subclass-of situation-class '|Situation|)) (report-error 'user-error "~a:~% Can't do this! (~a is not a subclass of Situation!)~%" `(|in-every-situation| ,situation-class ,km-expr) situation-class)) (t (let ((modified-expr (sublis '((|TheSituation| unquote |Self|) (|Self| . |SubSelf|)) km-expr))) (km0 `(|in-situation| ,*global-situation* (|every| ,situation-class |has| (|assertions| (',modified-expr)))) :fail-mode fmode))))) f-mode xrl xrrl) '(|in-every-situation| ?situation-class ?expr))))))))) (when (eql xl '|new-context|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) (clear-obj-stack) '(|t|)) f-mode) '(|new-context|))))) (when (eql xl '|thelast|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode frame) (declare (ignore _fmode)) (let ((last-instance (search-stack frame))) (cond (last-instance (list last-instance))))) f-mode xrl) '(|thelast| ?frame))))))) (when (eql xl '|the+|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode slot frameadd) (declare (ignore _fmode)) (km0 `(|the+| |Thing| |with| (,(invert-slot slot) (,frameadd))) :fail-mode 'error)) f-mode xrl xrrrl) '(|the+| ?slot |of| ?frameadd))))))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrl '|of|) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode class slot frameadd) (declare (ignore _fmode)) (km0 `(|the+| ,class |with| (,(invert-slot slot) (,frameadd))) :fail-mode 'error)) f-mode xrl xrrl xrrrrl) '(|the+| ?class ?slot |of| ?frameadd))))))))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (_fmode frame slotsvals) (declare (ignore _fmode)) (let ((val (km-unique0 `(|every| ,frame |with| ,@slotsvals)))) (cond (val (list val)) ((are-slotsvals slotsvals) (let ((existential-expr (cond ((and (null slotsvals) (pathp frame)) (path-to-existential-expr frame)) (t `(|a| ,frame |with| ,@slotsvals))))) (mapcar #'eval-instance (km0 existential-expr :fail-mode 'error))))))) f-mode xrl xrrr) '(|the+| ?frame |with| &rest))))))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode frame) (km0 `(|the+| ,frame |with|) :fail-mode fmode)) f-mode xrl) '(|the+| ?frame)))))))) (when (eql xl '|a+|) (return-from km-handler (values (funcall #'(lambda (fmode rest) (km0 `(|the+| ,@rest) :fail-mode fmode)) f-mode xr) '(|a+| &rest)))) (when (eql xl '|if|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|then|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode condition action) (km0 `(|if| ,condition |then| ,action |else| nil) :fail-mode fmode)) f-mode xrl xrrrl) '(|if| ?condition |then| ?action)))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|else|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode condition action altaction) (let ((test-result (km0 condition))) (cond ((not (member test-result '(nil |f| f))) (km0 action :fail-mode fmode)) (t (km0 altaction :fail-mode fmode))))) f-mode xrl xrrrl xrrrrrl) '(|if| ?condition |then| ?action |else| ?altaction)))))))))))))))))) (when (eql xl '|not|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x) (declare (ignore _fmode)) (cond ((not (km0 x)) '(|t|)))) f-mode xrl) '(|not| ?x))))))) (when (eql xl '|numberp|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode x) (declare (ignore _fmode)) (cond ((numberp (km-unique0 x)) '(|t|)))) f-mode xrl) '(|numberp| ?x))))))) (when (eql xl '|allof|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (km0 `(|forall| ,set |where| ,test |It|) :fail-mode fmode)) f-mode xrl xrrrl) '(|allof| ?set |where| ?test)))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|must|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test2 test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst instance '|It| test))) (km0 `(|allof| ,set |where| ,test2))) '(|t|)))) f-mode xrl xrrrl xrrrrrl) '(|allof| ?set |where| ?test2 |must| ?test))))))))))))) (when (eql xrrl '|must|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst instance '|It| test))) (km0 set)) '(|t|)))) f-mode xrl xrrrl) '(|allof| ?set |must| ?test))))))) (when (eql xrrl '|in|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (or (when (eql xrrrrl '|where|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (or (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var set test) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|allof| ,var |in| ,set |where| ,test))) (t (km0 `(|forall| ,var |in| ,set |where| ,test ,var) :fail-mode fmode)))) f-mode xrl xrrrl xrrrrrl) '(|allof| ?var |in| ?set |where| ?test)))) (when (consp xrrrrrr) (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr))) (when (eql xrrrrrrl '|must|) (when (consp xrrrrrrr) (let ((xrrrrrrrl (first xrrrrrrr)) (xrrrrrrrr (rest xrrrrrrr))) (when (eql xrrrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var set test2 test) (declare (ignore fmode)) (allof-where-must var set test2 test)) f-mode xrl xrrrl xrrrrrl xrrrrrrrl) '(|allof| ?var |in| ?set |where| ?test2 |must| ?test))))))))))))) (when (eql xrrrrl '|must|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var set test) (declare (ignore fmode)) (allof-must var set test)) f-mode xrl xrrrl xrrrrrl) '(|allof| ?var |in| ?set |must| ?test))))))))))))))))))) (when (eql xl '|oneof|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (declare (ignore fmode)) (let ((answer (find-if #'(lambda (member) (km0 (subst member '|It| test))) (km0 set)))) (cond (answer (list answer))))) f-mode xrl xrrrl) '(|oneof| ?set |where| ?test))))))) (when (eql xrrl '|in|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|where|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var set test) (declare (ignore fmode)) (oneof-where var set test)) f-mode xrl xrrrl xrrrrrl) '(|oneof| ?var |in| ?set |where| ?test)))))))))))))))))) (when (eql xl '|theoneof|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (let ((val (km-unique0 `(|forall| ,set |where| ,test |It|) :fail-mode fmode))) (cond (val (list val))))) f-mode xrl xrrrl) '(|theoneof| ?set |where| ?test))))))) (when (eql xrrl '|in|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|where|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var set test) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|theoneof| ,var |in| ,set |where| ,test))) (t (let ((val (km-unique0 `(|forall| ,var |in| ,set |where| ,test ,var) :fail-mode fmode))) (cond (val (list val))))))) f-mode xrl xrrrl xrrrrrl) '(|theoneof| ?var |in| ?set |where| ?test)))))))))))))))))) (when (eql xl '|forall|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set value) (km0 `(|forall| ,set |where| t ,value) :fail-mode fmode)) f-mode xrl xrrl) '(|forall| ?set ?value)))) (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode set constraint value) (declare (ignore _fmode)) (remove nil (my-mapcan #'(lambda (member) (cond ((km0 (subst member '|It| constraint)) (km0 (subst member '|It| value))))) (km0 set)))) f-mode xrl xrrrl xrrrrl) '(|forall| ?set |where| ?constraint ?value))))))))) (when (eql xrrl '|in|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (or (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var set value) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall| ,var |in| ,set ,value))) (t (km0 `(|forall| ,var |in| ,set |where| t ,value) :fail-mode fmode)))) f-mode xrl xrrrl xrrrrl) '(|forall| ?var |in| ?set ?value)))) (when (eql xrrrrl '|where|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (consp xrrrrrr) (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr))) (when (eql xrrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode var set constraint value) (declare (ignore _fmode)) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall| ,var |in| ,set |where| ,constraint ,value))) (t (remove nil (my-mapcan #'(lambda (member) (cond ((km0 (subst member var constraint)) (km0 (subst member var value))))) (km0 set)))))) f-mode xrl xrrrl xrrrrrl xrrrrrrl) '(|forall| ?var |in| ?set |where| ?constraint ?value))))))))))))))))))))) (when (eql xl '|forall-seq|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode seq value) (km0 `(|forall-seq| ,seq |where| t ,value) :fail-mode fmode)) f-mode xrl xrrl) '(|forall-seq| ?seq ?value)))) (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode seq constraint value) (declare (ignore _fmode)) (let ((sequences (km0 seq))) (cond ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `(|forall-seq| ,seq |where| ,constraint ,value) seq)) (t (list (cons ':|seq| (remove 'to-remove (mapcar #'(lambda (member) (cond ((km0 (subst member '|It| constraint)) (vals-to-val (km0 (subst member '|It| value)))) (t 'to-remove))) (rest (first sequences)))))))))) f-mode xrl xrrrl xrrrrl) '(|forall-seq| ?seq |where| ?constraint ?value))))))))) (when (eql xrrl '|in|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (or (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var seq value) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-seq| ,var |in| ,seq ,value))) (t (km0 `(|forall-seq| ,var |in| ,seq |where| t ,value) :fail-mode fmode)))) f-mode xrl xrrrl xrrrrl) '(|forall-seq| ?var |in| ?seq ?value)))) (when (eql xrrrrl '|where|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (consp xrrrrrr) (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr))) (when (eql xrrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode var seq constraint value) (declare (ignore _fmode)) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-seq| ,var |in| ,seq |where| ,constraint ,value))) (t (let ((sequences (km0 seq))) (cond ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `(|forall-seq| ,var |in| ,seq |where| ,constraint ,value) seq)) (t (list (cons ':|seq| (remove 'to-remove (mapcar #'(lambda (member) (cond ((km0 (subst member var constraint)) (vals-to-val (km0 (subst member var value)))) (t 'to-remove))) (rest (first sequences)))))))))))) f-mode xrl xrrrl xrrrrrl xrrrrrrl) '(|forall-seq| ?var |in| ?seq |where| ?constraint ?value))))))))))))))))))))) (when (eql xl '|forall-bag|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode bag value) (km0 `(|forall-bag| ,bag |where| t ,value) :fail-mode fmode)) f-mode xrl xrrl) '(|forall-bag| ?bag ?value)))) (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode bag constraint value) (declare (ignore _fmode)) (let ((bags (km0 bag))) (cond ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `(|forall-bag| ,bag |where| ,constraint ,value) bag)) (t (list (cons ':|bag| (remove nil (mapcar #'(lambda (member) (cond ((km0 (subst member '|It| constraint)) (vals-to-val (km0 (subst member '|It| value)))))) (rest (first bags)))))))))) f-mode xrl xrrrl xrrrrl) '(|forall-bag| ?bag |where| ?constraint ?value))))))))) (when (eql xrrl '|in|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (or (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode var bag value) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-bag| ,var |in| ,bag ,value))) (t (km0 `(|forall-bag| ,var |in| ,bag |where| t ,value) :fail-mode fmode)))) f-mode xrl xrrrl xrrrrl) '(|forall-bag| ?var |in| ?bag ?value)))) (when (eql xrrrrl '|where|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (consp xrrrrrr) (let ((xrrrrrrl (first xrrrrrr)) (xrrrrrrr (rest xrrrrrr))) (when (eql xrrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode var bag constraint value) (declare (ignore _fmode)) (cond ((not (km-varp var)) (report-error 'user-error "~a: Second argument should be a variable (e.g., ?x)!~%" `(|forall-bag| ,var |in| ,bag |where| ,constraint ,value))) (t (let ((bags (km0 bag))) (cond ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `(|forall-bag| ,var |in| ,bag |where| ,constraint ,value) bag)) (t (list (cons ':|bag| (remove nil (mapcar #'(lambda (member) (cond ((km0 (subst member var constraint)) (vals-to-val (km0 (subst member var value)))))) (rest (first bags)))))))))))) f-mode xrl xrrrl xrrrrrl xrrrrrrl) '(|forall-bag| ?var |in| ?bag |where| ?constraint ?value))))))))))))))))))))) (when (eql xl '|forall-seq2|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode seq constraint value) (declare (ignore _fmode)) (let ((sequences (km0 seq))) (cond ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `(|forall-seq2| ,seq |where| ,constraint ,value) seq)) (t (list (cons ':|seq| (remove 'to-remove (mapcar #'(lambda (member) (cond ((km0 (subst member '|It2| constraint)) (vals-to-val (km0 (subst member '|It2| value)))) (t 'to-remove))) (rest (first sequences)))))))))) f-mode xrl xrrrl xrrrrl) '(|forall-seq2| ?seq |where| ?constraint ?value))))))))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode seq value) (km0 `(|forall-seq2| ,seq |where| t ,value) :fail-mode fmode)) f-mode xrl xrrl) '(|forall-seq2| ?seq ?value)))))))))) (when (eql xl '|forall-bag2|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode bag constraint value) (declare (ignore _fmode)) (let ((bags (km0 bag))) (cond ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `(|forall-bag2| ,bag |where| ,constraint ,value) bag)) (t (list (cons ':|bag| (remove nil (mapcar #'(lambda (member) (cond ((km0 (subst member '|It2| constraint)) (vals-to-val (km0 (subst member '|It2| value)))))) (rest (first bags)))))))))) f-mode xrl xrrrl xrrrrl) '(|forall-bag2| ?bag |where| ?constraint ?value))))))))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode bag value) (km0 `(|forall-bag2| ,bag |where| t ,value) :fail-mode fmode)) f-mode xrl xrrl) '(|forall-bag2| ?bag ?value)))))))))) (when (eql xl '|allof2|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (km0 `(|forall2| ,set |where| ,test |It2|) :fail-mode fmode)) f-mode xrl xrrrl) '(|allof2| ?set |where| ?test)))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|must|) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test2 test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst instance '|It2| test))) (km0 `(|allof2| ,set |where| ,test2))) '(|t|)))) f-mode xrl xrrrl xrrrrrl) '(|allof2| ?set |where| ?test2 |must| ?test))))))))))))) (when (eql xrrl '|must|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (declare (ignore fmode)) (cond ((every #'(lambda (instance) (km0 (subst instance '|It2| test))) (km0 set)) '(|t|)))) f-mode xrl xrrrl) '(|allof2| ?set |must| ?test))))))))))))) (when (eql xl '|oneof2|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (declare (ignore fmode)) (let ((answer (find-if #'(lambda (member) (km0 (subst member '|It2| test))) (km0 set)))) (cond (answer (list answer))))) f-mode xrl xrrrl) '(|oneof2| ?set |where| ?test)))))))))))) (when (eql xl '|forall2|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (or (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set value) (km0 `(|forall2| ,set |where| t ,value) :fail-mode fmode)) f-mode xrl xrrl) '(|forall2| ?set ?value)))) (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode set constraint value) (declare (ignore _fmode)) (remove 'nil (my-mapcan #'(lambda (member) (cond ((km0 (subst member '|It2| constraint)) (km0 (subst member '|It2| value))))) (km0 set)))) f-mode xrl xrrrl xrrrrl) '(|forall2| ?set |where| ?constraint ?value))))))))))))))) (when (eql xl '|theoneof2|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|where|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode set test) (let ((val (km-unique0 `(|forall2| ,set |where| ,test |It2|) :fail-mode fmode))) (cond (val (list val))))) f-mode xrl xrrrl) '(|theoneof2| ?set |where| ?test)))))))))))) (when (eql xl 'function) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode lispcode) (declare (ignore _fmode)) (let* ((answer0 (funcall (eval (list 'function lispcode)))) (answer (listify answer0))) (cond ((every #'fully-evaluatedp answer) answer) (t (report-error 'user-error "In call to external Lisp procedure ~a Lisp procedure should return a list of fully evaluated KM objects (e.g., instances, or :seq/:bag/:pair of instances), but instead returned: ~a~%" lispcode answer0))))) f-mode xrl) '#'?lispcode)))))) (when (eql xl '|search-control|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (consp xrrrrr) (let ((xrrrrrl (first xrrrrr)) (xrrrrrr (rest xrrrrr))) (when (eql xrrrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode pattern vars mindepth maxdepth result) (declare (ignore _fmode)) (let ((pattern0 (subst '&rest '|&rest| pattern))) (cond ((not (member pattern0 *search-control-points* :test #'equal)) (setq *search-control-points* (cons (list pattern0 vars mindepth maxdepth result) *search-control-points*)))) (km-format t "Search will be controlled at the following points:~%~{ ~a~%~}" (mapcar #'(lambda (s) (list (first s) '-> (fifth s))) *search-control-points*)) '(|t|))) f-mode xrl xrrl xrrrl xrrrrl xrrrrrl) '(|search-control| ?pattern ?vars ?mindepth ?maxdepth ?result))))))))))))))) (when (eql xl '|the1|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode slot frameadd) (km0 `(|the1| |of| (|the| ,slot |of| ,frameadd)) :fail-mode fmode)) f-mode xrl xrrrl) '(|the1| ?slot |of| ?frameadd))))))))) (when (eql xrl '|of|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode frameadd) (let ((multiargs (km0 frameadd :fail-mode fmode))) (km0 (vals-to-val (mapcar #'(lambda (multiarg) (cond ((km-structured-list-valp multiarg) (arg1of multiarg)) (t multiarg))) multiargs))))) f-mode xrrl) '(|the1| |of| ?frameadd))))))))))) (when (eql xl '|the2|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode slot frameadd) (km0 `(|the2| |of| (|the| ,slot |of| ,frameadd)) :fail-mode fmode)) f-mode xrl xrrrl) '(|the2| ?slot |of| ?frameadd))))))))) (when (eql xrl '|of|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode frameadd) (let ((multiargs (km0 frameadd :fail-mode fmode))) (km0 (vals-to-val (mapcar #'(lambda (multiarg) (cond ((km-structured-list-valp multiarg) (arg2of multiarg)))) multiargs))))) f-mode xrrl) '(|the2| |of| ?frameadd))))))))))) (when (eql xl '|the3|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode slot frameadd) (km0 `(|the3| |of| (|the| ,slot |of| ,frameadd)) :fail-mode fmode)) f-mode xrl xrrrl) '(|the3| ?slot |of| ?frameadd))))))))) (when (eql xrl '|of|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode frameadd) (let ((multiargs (km0 frameadd :fail-mode fmode))) (km0 (vals-to-val (mapcar #'(lambda (multiarg) (cond ((km-structured-list-valp multiarg) (arg3of multiarg)))) multiargs))))) f-mode xrrl) '(|the3| |of| ?frameadd))))))))))) (when (eql xl '|theN|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode nexpr frameadd) (let ((n (km-unique0 nexpr :fail-mode 'error)) (multiargs (km0 frameadd :fail-mode fmode))) (cond ((or (not (integerp n)) (< n 1)) (report-error 'user-error "Doing ~a. ~a should evaluate to a non-negative integer!~%" `(|the| ,nexpr |of| ,frameadd) nexpr)) (t (km0 (vals-to-val (mapcar #'(lambda (multiarg) (cond ((and (km-structured-list-valp multiarg) (< n (length multiarg))) (elt multiarg n)) ((eq n 1) multiarg))) multiargs))))))) f-mode xrl xrrrl) '(|theN| ?nexpr |of| ?frameadd)))))))))))) (when (eql xl '|theNth|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode nexpr frameadd) (let ((n (km-unique0 nexpr :fail-mode 'error)) (vals (km0 frameadd :fail-mode fmode))) (cond ((or (not (integerp n)) (< n 1)) (report-error 'user-error "Doing ~a. ~a should evaluate to a non-negative integer!~%" `(|the| ,nexpr |of| ,frameadd) nexpr)) ((and (<= n (length vals)) (elt vals (1- n))) (list (elt vals (1- n))))))) f-mode xrl xrrrl) '(|theNth| ?nexpr |of| ?frameadd)))))))))))) (when (eql xl :|set|) (return-from km-handler (values (funcall #'(lambda (fmode exprs) (declare (ignore fmode)) (my-mapcan #'(lambda (expr) (km0 expr)) exprs)) f-mode xr) '(:|set| &rest)))) (when (eql xl :|seq|) (return-from km-handler (values (funcall #'(lambda (fmode exprs) (declare (ignore fmode)) (let ((sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs))) (cond (sequence `((:|seq| ,@sequence)))))) f-mode xr) '(:|seq| &rest)))) (when (eql xl :|bag|) (return-from km-handler (values (funcall #'(lambda (fmode exprs) (declare (ignore fmode)) (let ((bag (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs))) (cond (bag `((:|bag| ,@bag)))))) f-mode xr) '(:|bag| &rest)))) (when (eql xl :|function|) (return-from km-handler (values (funcall #'(lambda (fmode exprs) (declare (ignore fmode)) (let ((sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs))) (cond (sequence `((:|function| ,@sequence)))))) f-mode xr) '(:|function| &rest)))) (when (eql xl :|pair|) (return-from km-handler (values (funcall #'(lambda (fmode exprs) (declare (ignore fmode)) (cond ((not (pairp exprs)) (report-error 'user-error "~a: A pair should have exactly two elements!~%" `(:|pair| ,@exprs))) (t (let ((sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs))) (cond (sequence `((:|pair| ,@sequence)))))))) f-mode xr) '(:|pair| &rest)))) (when (eql xl :|triple|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode frame-expr slot-expr val-expr) (declare (ignore _fmode)) (let* ((slot (cond ((comparison-operator slot-expr) slot-expr) (t (km-unique0 slot-expr :fail-mode 'error)))) (frame (cond ((and (comparison-operator slot) (minimatch frame-expr '(|the| |?x| |of| |?y|))) frame-expr) (t (km-unique0 frame-expr :fail-mode 'error)))) (val (cond ((or (constraint-exprp val-expr) (existential-exprp val-expr) (comparison-operator slot)) val-expr) (t (vals-to-val (km0 val-expr)))))) `((:|triple| ,frame ,slot ,val)))) f-mode xrl xrrl xrrrl) '(:|triple| ?frame-expr ?slot-expr ?val-expr))))))))))) (when (eql xl :|args|) (return-from km-handler (values (funcall #'(lambda (fmode exprs) (declare (ignore fmode)) (let ((sequence (mapcar #'(lambda (expr) (vals-to-val (km0 expr))) exprs))) (cond (sequence `((:|args| ,@sequence)))))) f-mode xr) '(:|args| &rest)))) (when (eql xl '|showme|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode km-expr) (declare (ignore _fmode)) (showme km-expr)) f-mode xrl) '(|showme| ?km-expr)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode km-expr file) (declare (ignore _fmode)) (cond ((not (stringp file)) (report-error 'user-error "(showme ): should be a string!~%")) (t (let ((stream (tell file))) (prog1 (showme km-expr (all-situations) (visible-theories) stream) (cond ((streamp stream) (close stream))) (km-format t "(Output sent to file ~a)~%" file)))))) f-mode xrl xrrl) '(|showme| ?km-expr ?file)))))))))) (when (eql xl '|showme-all|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode km-expr) (declare (ignore _fmode)) (showme-all km-expr)) f-mode xrl) '(|showme-all| ?km-expr))))))) (when (eql xl '|evaluate-all|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode km-expr) (declare (ignore _fmode)) (evaluate-all km-expr)) f-mode xrl) '(|evaluate-all| ?km-expr))))))) (when (eql xl '|showme-here|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode km-expr) (declare (ignore _fmode)) (showme km-expr (list (curr-situation)) (visible-theories))) f-mode xrl) '(|showme-here| ?km-expr))))))) (when (eql xl '|the-class|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (or (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode class) (declare (ignore fmode)) (process-unquotes `((|the-class| ,class)))) f-mode xrl) '(|the-class| ?class)))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|with|) (return-from km-handler (values (funcall #'(lambda (fmode class slotsvals) (declare (ignore fmode)) (cond ((are-slotsvals slotsvals) (process-unquotes `((|the-class| ,class |with| ,@slotsvals)))))) f-mode xrl xrrr) '(|the-class| ?class |with| &rest)))))))))) (when (eql xl '|constraints-for|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrl) (let ((xrll (first xrl)) (xrlr (rest xrl))) (when (eql xrll '|the|) (when (consp xrlr) (let ((xrlrl (first xrlr)) (xrlrr (rest xrlr))) (when (consp xrlrr) (let ((xrlrrl (first xrlrr)) (xrlrrr (rest xrlrr))) (when (eql xrlrrl '|of|) (when (consp xrlrrr) (let ((xrlrrrl (first xrlrrr)) (xrlrrrr (rest xrlrrr))) (when (eql xrlrrrr 'nil) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode0 slot frameadd) (declare (ignore fmode0)) (let ((frame (km-unique0 frameadd :fail-mode 'error))) (mapcar #'quotify (collect-constraints-on-instance frame slot)))) f-mode xrlrl xrlrrrl) '(|constraints-for| (|the| ?slot |of| ?frameadd))))))))))))))))))) (when (eql xl '|rules-for|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrl) (let ((xrll (first xrl)) (xrlr (rest xrl))) (when (eql xrll '|the|) (when (consp xrlr) (let ((xrlrl (first xrlr)) (xrlrr (rest xrlr))) (when (consp xrlrr) (let ((xrlrrl (first xrlrr)) (xrlrrr (rest xrlrr))) (when (eql xrlrrl '|of|) (when (consp xrlrrr) (let ((xrlrrrl (first xrlrrr)) (xrlrrrr (rest xrlrrr))) (when (eql xrlrrrr 'nil) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode0 slot frameadd) (declare (ignore fmode0)) (let ((rules (rules-for slot frameadd))) (cond ((null rules) nil) ((km-setp rules) (mapcar #'quotify (set-to-list rules))) (t (list (quotify rules)))))) f-mode xrlrl xrlrrrl) '(|rules-for| (|the| ?slot |of| ?frameadd))))))))))))))))))) (when (eql xl '|why|) (or (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode) (declare (ignore fmode)) (why)) f-mode) '(|why|)))) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode triple) (declare (ignore fmode)) (cond ((not (km-triplep triple)) (report-error 'user-error "Bad argument to (why ...)! Should be of form (why (:triple ))!")) (t (why triple)))) f-mode xrl) '(|why| ?triple)))))))) (when (eql xl '|justify|) (or (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode) (declare (ignore fmode)) (justify)) f-mode) '(|justify|)))) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode triple) (declare (ignore fmode)) (justify triple)) f-mode xrl) '(|justify| ?triple)))))))) (when (eql xl '|get-justification|) (or (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode) (declare (ignore fmode)) (list (concat-list (cons (format nil "--------------------~%") (append (insert-delimeter (get-justification :format 'ascii) *newline-string*) (list (format nil "~%-------------------~%"))))))) f-mode) '(|get-justification|)))) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode triple) (declare (ignore fmode)) (list (concat-list (cons (format nil "--------------------~%") (append (insert-delimeter (get-justification :triple triple :format 'ascii) *newline-string*) (list (format nil "~%-------------------~%"))))))) f-mode xrl) '(|get-justification| ?triple)))))))) (when (eql xl '|explanation|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrl) (let ((xrll (first xrl)) (xrlr (rest xrl))) (when (eql xrll :|triple|) (when (consp xrlr) (let ((xrlrl (first xrlr)) (xrlrr (rest xrlr))) (when (consp xrlrr) (let ((xrlrrl (first xrlrr)) (xrlrrr (rest xrlrr))) (when (consp xrlrrr) (let ((xrlrrrl (first xrlrrr)) (xrlrrrr (rest xrlrrr))) (when (eql xrlrrrr 'nil) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode f s v explanations) (declare (ignore fmode)) (mapc #'(lambda (explanation) (record-explanation-for `(|the| ,s |of| ,f) v explanation :situation *global-situation*)) explanations) '(|t|)) f-mode xrlrl xrlrrl xrlrrrl xrrl) '(|explanation| (:|triple| ?f ?s ?v) ?explanations))))))))))))))))))) (when (eql xl '|comment|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (return-from km-handler (values (funcall #'(lambda (fmode comment-tag data) (declare (ignore fmode)) (comment comment-tag data)) f-mode xrl xrr) '(|comment| ?comment-tag &rest)))))) (when (eql xl '|show-comment|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode comment-tag) (declare (ignore fmode)) (show-comment comment-tag)) f-mode xrl) '(|show-comment| ?comment-tag))))))) (when (eql xl 'quote) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode)) (let ((processed-expr (process-unquotes expr))) (cond (processed-expr (list (list 'quote processed-expr)))))) f-mode xrl) ''?expr)))))) (when (eql xl 'unquote) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode)) (report-error 'user-error "Doing #,~a: You can't unquote something without it first being quoted!~%" expr)) f-mode xrl) '(unquote ?expr))))))) (when (eql xl '|delete|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode km-expr) (mapcar #'delete-frame (km0 km-expr :fail-mode fmode))) f-mode xrl) '(|delete| ?km-expr))))))) (when (eql xl '|evaluate|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (let ((quoted-exprs (km0 expr :fail-mode fmode))) (remove nil (my-mapcan #'(lambda (quoted-expr) (cond ((member quoted-expr '(|f| f)) nil) ((and (pairp quoted-expr) (eq (first quoted-expr) 'quote)) (km0 (second quoted-expr) :fail-mode fmode)) (t (report-error 'user-error "(evaluate ~a)~%evaluate should be given a quoted expression to evaluate!~%" quoted-expr)))) quoted-exprs)))) f-mode xrl) '(|evaluate| ?expr))))))) (when (eql xl '|exists|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode frame) (report-error 'user-warning "(exists ~a): (exists ) has been renamed (has-value ) in KM 1.4.~% Please update your KB! Continuing...~%" frame) (km0 `(|has-value| ,frame) :fail-mode fmode)) f-mode xrl) '(|exists| ?frame))))))) (when (eql xl '|has-value|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode frame) (declare (ignore _fmode)) (cond ((km0 frame) '(|t|)))) f-mode xrl) '(|has-value| ?frame))))))) (when (eql xl '|print|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode expr) (declare (ignore _fmode)) (let ((vals (km0 expr))) (km-format t "~a~%" vals) vals)) f-mode xrl) '(|print| ?expr))))))) (when (eql xl '|format|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (return-from km-handler (values (funcall #'(lambda (_fmode flag string arguments) (declare (ignore _fmode)) (cond ((eq flag '|t|) (apply #'format `(t ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))) '(|t|)) ((member flag '(|nil| nil)) (list (apply #'format `(nil ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))))) (t (report-error 'user-error "~a: Second argument must be `t' or `nil', not `~a'!~%" `(|format| ,flag ,string ,@arguments) flag)))) f-mode xrl xrrl xrrr) '(|format| ?flag ?string &rest)))))))) (when (eql xl '|km-format|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (return-from km-handler (values (funcall #'(lambda (_fmode flag string arguments) (declare (ignore _fmode)) (cond ((eq flag '|t|) (apply #'km-format `(t ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))) '(|t|)) ((member flag '(|nil| nil)) (list (apply #'km-format `(nil ,string ,@(mapcar #'(lambda (arg) (km0 arg)) arguments))))) (t (report-error 'user-error "~a: Second argument must be `t' or `nil', not `~a'!~%" `(|km-format| ,flag ,string ,@arguments) flag)))) f-mode xrl xrrl xrrr) '(|km-format| ?flag ?string &rest)))))))) (when (eql xl '|andify|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (list (cons ':|seq| (andify (km0 expr :fail-mode fmode))))) f-mode xrl) '(|andify| ?expr))))))) (when (eql xl '|make-sentence|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode expr) (declare (ignore _fmode)) (let ((text (km0 expr))) (make-comment "anglifying ~a" text) (list (make-sentence text)))) f-mode xrl) '(|make-sentence| ?expr))))))) (when (eql xl '|make-phrase|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode expr) (declare (ignore _fmode)) (let ((text (km0 expr))) (make-comment "anglifying ~a" text) (list (make-phrase text)))) f-mode xrl) '(|make-phrase| ?expr))))))) (when (eql xl '|pluralize|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode)) (report-error 'user-error "(pluralize ~a): pluralize is no longer defined in KM1.4 - use \"-s\" suffix instead!~%" expr)) f-mode xrl) '(|pluralize| ?expr))))))) (when (eql xl '|spy|) (or (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode)) (spy expr)) f-mode xrl) '(|spy| ?expr)))))) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode) (declare (ignore fmode)) (spy)) f-mode) '(|spy|)))))) (when (eql xl '|unspy|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode) (declare (ignore fmode)) (unspy)) f-mode) '(|unspy|))))) (when (eql xl '|taxonomy|) (return-from km-handler (values (funcall #'(lambda (fmode args) (declare (ignore fmode)) (cond ((null args) (taxonomy)) ((singletonp args) (taxonomy (km-unique (first args)))) ((pairp args) (taxonomy (km-unique (first args)) (km-unique (second args)))) (t (report-error 'user-error "Too many arguments to the taxonomy function! Format is (taxonomy )~%")))) f-mode xr) '(|taxonomy| &rest)))) (when (eql xl '|checkpoint|) (or (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode) (declare (ignore fmode)) (set-checkpoint) '(|t|)) f-mode) '(|checkpoint|)))) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode checkpoint-id) (declare (ignore fmode)) (cond ((null checkpoint-id) (report-error 'user-error "(checkpoint ~a): Argument to checkpoint can't be NIL!~%" checkpoint-id)) (t (set-checkpoint checkpoint-id) '(|t|)))) f-mode xrl) '(|checkpoint| ?checkpoint-id)))))))) (when (eql xl '|undo|) (when (eql xr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode) (declare (ignore fmode)) (cond ((undo) '(|t|)))) f-mode) '(|undo|))))) (when (eql xl '|an|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrl '|instance|) (when (consp xrr) (let ((xrrl (first xrr)) (xrrr (rest xrr))) (when (eql xrrl '|of|) (when (consp xrrr) (let ((xrrrl (first xrrr)) (xrrrr (rest xrrr))) (or (when (eql xrrrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (km0 `(|an| |instance| |of| ,expr |with|) :fail-mode fmode)) f-mode xrrrl) '(|an| |instance| |of| ?expr)))) (when (consp xrrrr) (let ((xrrrrl (first xrrrr)) (xrrrrr (rest xrrrr))) (when (eql xrrrrl '|with|) (return-from km-handler (values (funcall #'(lambda (fmode expr slotsvals) (declare (ignore fmode)) (cond ((are-slotsvals slotsvals) (let* ((classes (km0 expr :fail-mode 'error)) (class (first classes)) (classes-in-slotsvals (vals-in (assoc '|instance-of| slotsvals))) (new-slotsvals (cond ((>= (length classes) 2) (update-assoc-list slotsvals `(|instance-of| ,(remove-duplicates (append (rest classes) classes-in-slotsvals))))) (t slotsvals)))) (list (create-instance class new-slotsvals)))))) f-mode xrrrl xrrrrr) '(|an| |instance| |of| ?expr |with| &rest)))))))))))))))) (when (eql xl '|reverse|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode seq-expr) (let ((seq (km-unique0 seq-expr :fail-mode fmode))) (cond ((null seq) nil) ((km-seqp seq) (list (cons ':|seq| (reverse (rest seq))))) (t (report-error 'user-error "Attempting to reverse a non-sequence ~a!~%[Sequences should be of the form (:seq ... )]~%" seq-expr))))) f-mode xrl) '(|reverse| ?seq-expr))))))) (when (eql xl :|default|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode expr)) (km-setq '*are-some-defaults* t) nil) f-mode xrl) '(:|default| ?expr))))))) (when (eql xl '|sometimes|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (km0 expr :fail-mode fmode)) f-mode xrl) '(|sometimes| ?expr))))))) (when (eql xl '|anonymous-instancep|) (when (consp xr) (let ((xrl (first xr)) (xrr (rest xr))) (when (eql xrr 'nil) (return-from km-handler (values (funcall #'(lambda (fmode expr) (declare (ignore fmode)) (cond ((anonymous-instancep (km-unique0 expr :fail-mode 'error)) '(|t|)))) f-mode xrl) '(|anonymous-instancep| ?expr)))))))))) (when (eql x '|nil|) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) nil) f-mode) '|nil|))) (when (eql x 'nil) (return-from km-handler (values (funcall #'(lambda (_fmode) (declare (ignore _fmode)) nil) f-mode) 'nil))) (return-from km-handler (values (funcall #'(lambda (fmode0 path) (cond ((atom path) (cond ((no-reserved-keywords (list path)) (list path)))) ((not (listp path)) (report-error 'program-error "Failed to find km handler for ~a!~%" path)) ((singletonp path) (km0 (first path) :fail-mode fmode0)) ((and (triplep path) (assoc (second path) *user-defined-infix-operators*)) (let ((infix-implementation-fn (second (assoc (second path) *user-defined-infix-operators*)))) (cond ((not (functionp infix-implementation-fn)) (report-error 'user-error " The specified implementation of infix operator ~a is not a Lisp function! (missing \"#'\" prefix?) The specified implementation was: ~a~%" (second path) infix-implementation-fn)) (t (let* ((x (vals-to-val (km0 (first path)))) (y (vals-to-val (km0 (third path)))) (answer0 (apply infix-implementation-fn (list x y))) (answer (listify answer0))) (cond ((every #'fully-evaluatedp answer) answer) (t (report-error 'user-error "In call to external Lisp procedure (~a ~a ~a) Lisp procedure should return one/a list of fully evaluated KM objects (e.g., instances, or :seq/:bag/:pair of instances), but instead returned: ~a~%" infix-implementation-fn x y answer0)))))))) ((not *linear-paths*) (report-error 'user-error "KM Syntax error: ~a is not a valid KM expression~%" path)) ((not (no-reserved-keywords path)) nil) ((oddp (length path)) (cond ((structured-slotp (last-el (butlast path))) (follow-multidepth-path (km0 (butlast (butlast path)) :fail-mode fmode0) (last-el (butlast path)) (last-el path) :fail-mode fmode0)) (t (vals-in-class (km0 (butlast path) :fail-mode fmode0) (last-el path))))) ((evenp (length path)) (let* ((frameadd (cond ((pairp path) (first path)) (t (butlast path)))) (slot0 (last-el path))) (cond ((structured-slotp slot0) (follow-multidepth-path (km0 frameadd :fail-mode fmode0) slot0 '* :fail-mode fmode0)) (t (let* ((slot (cond ((pathp slot0) (km-unique0 slot0 :fail-mode 'error)) (t slot0))) (fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0))) (frames (km0 frameadd :fail-mode fmode))) (cond ((not (equal frames (val-to-vals frameadd))) (km0 `(,(vals-to-val frames) ,slot) :fail-mode fmode)) (t (km-multi-slotvals frames slot :fail-mode fmode)))))))))) f-mode x) '?path))))) (setq *km-handler-function* #'compiled-km-handler-function) ;;; This file was generated by (write-compiled-handlers) in compiler.lisp. ;;; This partially flattens the code assigned to *km-handler-list*, which results in ;;; 10%-30% faster execution (10%-30%) at run-time. Loading of this file is optional, ;;; KM will be slower if it's not loaded. For the legible, unflattened source of this ;;; flattened code, see the file interpreter.lisp. ;;; ==================== END OF MACHINE-GENERATED FILE ==================== ;;; FILE: licence.lisp ;;; File: licence.lisp ;;; Author: Peter Clark ;;; Date: 2000 ;;; Purpose: Recite GPL to the user. ;;; English spelling! (defun licence () (license)) (defun license () (format t " GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the \"Lesser\" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a \"work based on the library\" and a \"work that uses the library\". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called \"this License\"). Each licensee is addressed as \"you\". A \"library\" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The \"Library\", below, refers to any such software library or work which has been distributed under these terms. A \"work based on the Library\" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term \"modification\".) \"Source code\" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a \"work that uses the Library\". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a \"work that uses the Library\" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a \"work that uses the library\". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a \"work that uses the Library\" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a \"work that uses the Library\" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable \"work that uses the Library\", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the \"work that uses the Library\" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and \"any later version\", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ")) ;;; FILE: LICENCE #| GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS |# ;;; FILE: initkb.lisp ;;; File: initkb.lisp ;;; Author: Peter Clark ;;; Purpose: Initialize the KB (directive). This file is loaded last. (reset-kb) (defun version () (format t " ====================================================~%") (format t " KM - THE KNOWLEDGE MACHINE - INFERENCE ENGINE v~a~%" *km-version-str*) (format t " ====================================================~%") (format t "Copyright (C) 1994-~a Peter Clark and Bruce Porter. KM comes with ABSOLUTELY~%" *year*) (format t "NO WARRANTY. This is free software, and you are welcome to redistribute it~%") (format t "under certain conditions. Type (license) for details.~%~%") t) (version) (format t "Documentation at http://www.cs.utexas.edu/users/mfkb/km/~%") (format t "Type (km) for the KM interpreter prompt!~%")