;;; FILE: README.txt ;;; KM - The Knowledge Machine - Build Date: Thu Oct 9 14:16:29 PDT 2008 #| ====================================================================== KM - THE KNOWLEDGE MACHINE - INFERENCE ENGINE 2.2.22 ====================================================================== Copyright (C) 1994-2007 Peter Clark and Bruce Porter This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Contact information: Peter Clark, m/s 7L-66, Mathematics and Computing Technology, The Boeing Company, PO Box 3707, Seattle, WA 98124, USA. (peter.e.clark@boeing.com) Bruce Porter, m/s C0500, Dept Computer Science, Univ Texas at Austin, Austin, TX 78712, USA. (porter@cs.utexas.edu) If you would like a copy of this software issued under a different license (e.g., with different redistribution conditions) please contact the authors. A copy of the GNU Lesser General Public Licence can be found at the end of this file (or in the file LICENCE if disassembled into its constitutent files), or by typing (license) at the Lisp or KM prompts when running KM. ====================================================================== The source code, manuals, and a test suite of examples for the most recent version of KM are available at http://www.cs.utexas.edu/users/mfkb/km/ Check this site for RELEASE NOTES and the CURRENT VERSION of KM. ====================================================================== USING THIS FILE: ====================================================================== Save this file as (say) km.lisp, then load it into your favorite Lisp environment: % lisp > (load "km") For greatly increased efficiency, make a compiled version of this file: % lisp > (compile-file "km") > (load "km") will load the faster, compiled version in future. [Note: you no longer need to pre-load km.lisp before compiling, as described in the manual] To start the query interpreter running, type (km): > (km) KM> See the User Manual and Reference Manual for instructions on using KM, and building knowledge bases. The manuals are available at: http://www.cs.utexas.edu/users/mfkb/km/ ====================================================================== READING/EDITING THE SOURCE: ====================================================================== The following file is a machine-built concatenation of the various files in the KM inference system. It can be loaded or compiled directly into Lisp, deconcatenation is not necessary for running KM. Although you can read/edit the below code all in this one file, it is very large and unweildy; you may prefer to break it up into the (approx 20) constituent files which it comprises. You can break it up either manually, looking for the ";;; FILE: " headers below which denote the start of different files in this concatenation, OR use the Perl unpacker below which automatically cut this big file into its consistutent files. Peter Clark peter.e.clark@boeing.com ====================================================================== DISASSEMBLING THIS CONCATENATION INTO ITS CONSTITUENT FILES: ====================================================================== Note you don't have to disassemble km.lisp to use KM. However, if you want to read/edit the code, you might find it helpful to break it up into individual files. If you do disassmble the files, then the single file loadme.lisp contains (commented out) load commands to load all the other constituent files, for your convenience. (Don't forget to uncomment the load commands in this file). If you don't disassemble the files and just work with km.lisp, then you can ignore all of this. Option 1. (For Emacs users) [Thanks to Joe Corneli for this piece of code!] [(1) Ignore end-of-line whitespace - thanks to Nate Blaylock] (save-excursion (let ((case-fold-search nil)) (goto-char (point-min)) ; (while (re-search-forward "^;;; FILE: +\\(.*\\)" nil t) [see (1) above] (while (re-search-forward "^;;; FILE: +\\([a-zA-Z-\\._]+\\)" nil t) (let* ((matched (match-string 1)) (beg (match-beginning 0)) (end (or (save-excursion (when (search-forward-regexp "^;;; FILE: +.*" nil t) (match-beginning 0))) (point-max))) (str (buffer-substring beg end))) (with-temp-file matched (save-excursion (insert str)) (next-line 1) ; uncomment the below lines if you want KM files to have KM package declaration (insert (concat "(unless (find-package :km) (make-package :km :use '(:common-lisp)))\n" "(in-package :km)\n")) ))))) ^ position cursor behind the emacs lisp expression above and run M-x eval-last-sexp Option 2. (For non-Emacs users) 1. cut and paste the short Perl script below to a file, eg called "disassemble" 2. Make sure the first line is #!/usr/local/bin/perl and edit this path /usr/local/bin/perl as needed to point to the local version of Perl. 3. Make the file executable: % chmod a+x disassemble 4. Now disassemble km.lisp: % disassemble km.lisp This will populate the current directory with the approx. 20 Lisp files constituting the KM system. ------------------------------ cut here ------------------------------ #!/usr/local/bin/perl # Splits file with internal file markers of the form: # ;;; FILE: # 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"; # uncomment the below line if you want KM files to have KM package declaration print (OUTFILE "\n(unless (find-package :km) (make-package :km :use '(:common-lisp)))\n"); } else { print (OUTFILE $_); } } close(PACKED); close(OUTFILE); print "Completed without errors. Processed $lineno lines of input from $fn.\n"; ------------------------------ cut here ------------------------------ |# ;;; FILE: loadme.lisp ;;; File: loadme.lisp ;;; Purpose: load all the KM files, if you've disassembled the full KM ;;; into its constituent files. ;;; Usage: Uncomment and load this file to compile and load the individual KM ;;; files (assumed within the local directory) ;;; ****NOTE**** You DON'T need to uncomment this part of the code ;;; if you are simply working with the single file km.lisp. #| ;;; compile-and-load function (defun cload (file) (load (user::compile-file-if-needed file :print nil))) (cload "header") (cload "htextify") (cload "case") (cload "interpreter") (cload "get-slotvals") (cload "frame-io") (cload "trace") (cload "lazy-unify") (cload "constraints") (cload "explain") (cload "kbutils") (cload "stack") (cload "stats") (cload "sadl") (cload "anglify") (cload "writer") (cload "taxonomy") (cload "subsumes") (cload "prototypes") (cload "loadkb") (cload "minimatch") (cload "utils") (cload "strings") (cload "compiler") (cload "compiled-handlers") (cload "licence") (cload "initkb") |# ;;; FILE: header.lisp ;;; File: header.lisp ;;; Purpose: Set some compilation flags etc. ;;; Suggestion from Francis Leboutte for improving KM's speed ;;; NOTE: This is left commented, as some users have requested to not ;;; have this optimization (with subsequent tradeoffs) imposed on them. ;;; Uncomment this for a tiny bit more speed, but at loss of some tracing ;;; info etc. ;;; (eval-when (:compile-toplevel) ;;; (proclaim '(optimize (speed 3) (safety 1) (space 0) (debug 0)))) #| ====================================================================== THE KM PACKAGE ====================================================================== KM is released with two versions (i) without an explicit package definition ([1] below commented out). KM will be in which ever package it is loaded into. (ii) with an explicit package definition ([1] below uncommented). KM will always be in this package. The variable *km-package* is set to the KM package name that KM is in. |# ;;; From Tim Menzies: Suppress style warnings under SBCL (Mac and Linux) #+SBCL (DECLAIM (SB-EXT:MUFFLE-CONDITIONS CL:STYLE-WARNING)) ;;; COMMENT THIS OUT FOR THE PACKAGED VERSION OF KM ; (defvar *using-km-package* nil) ;;; [1] UNCOMMENT THIS FOR PACKAGED VERSION OF KM (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package :km) (make-package :km :use '(:common-lisp)))) (in-package :km) (defvar *using-km-package* nil) (setq *using-km-package* t) ; flag used by fastsave-kb ;;; KM defines neq (in utils.lisp), except for Mac CommonLisp where it's ;;; a built-in. However, in MCL it's in the ccl not cl package, and so with ;;; KM's packaged version we need to explicitly import it to KM, in addition ;;; to the normal importing via :use '(:common-lisp) above #+MCL (eval-when (:compile-toplevel :load-toplevel :execute) (import 'ccl:neq)) ;;; KM package is now the current package (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant *km-package* *package*)) ;;; ====================================================================== ;;; Personal preference ;(setq *print-case* :downcase) ;;; Dispatch mechanism not "compiled" be default, unless ;;; compiled-handlers.lisp is included. (defparameter *compile-handlers* nil) ;;; ====================================================================== ;;; DECLARATION OF CONSTANTS ;;; ====================================================================== ;;; This is really a constant, but I *really* don't want to put the definition ;;; here! It's setq'ed in interpreter.lisp. (defparameter *km-handler-alist1* nil) (defparameter *km-handler-alist2* nil) (defparameter *km-handler-alist* nil) (defconstant *var-marker-char* #\_) (defparameter *var-marker-string* "_") (defparameter *proto-marker-string* (concatenate 'string *var-marker-string* "Proto")) ; ie. "_Proto" (defparameter *fluent-instance-marker-string* (concatenate 'string *var-marker-string* "Some")) ; ie. "_Some" (defparameter *km-version-str* "2.2.22") (defparameter *year* "2008") (defparameter *newline-str* (make-string 1 :initial-element '#\Newline)) (defparameter *km-handler-function* nil) ; used in compiler.lisp ; (defconstant *global-situation* '|*Global|) ; Correction to allow compilation in CLisp (Thanks to Francis Leboutte). (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant *global-situation* '|*Global|)) ;;; ------------------------------ ; from prototypes.lisp (defparameter *slots-not-to-clone-for* ; Intent is defconstant, but SBCL doesn't like defconstants on lists '(|prototype-participant-of| |prototype-participants| |prototypes| |prototype-of| |instance-of| |cloned-from| |has-clones| |clone-built-from| |has-built-clones|)) ;;; -------------------- ;;; Optimization flags: note which bits of machinery are in use. ;;; -------------------- (defparameter *classes-using-assertions-slot* nil) (defparameter *are-some-definitions* nil) (defparameter *are-some-prototypes* nil) (defparameter *are-some-subslots* nil) (defparameter *are-some-constraints* nil) (defparameter *are-some-tags* nil) (defparameter *are-some-defaults* nil) (defparameter *deleted-frames* nil) ;;; ====================================================================== ;;; KM'S PARAMETERS ;;; ====================================================================== ;;; The following are user-tunable, controlling KM's behavior ;;; Most of these should never need to be changed by the user. The commented ones would ;;; never be changed by the user, and are really internal. (defparameter *km-behavior-parameters* '(*recursive-classification* ; default t *indirect-classification* ; default t *recursive-prototypes* ; default nil *eagerly-unify-prototypes* ; default t *sanity-checks* ; default t *slot-checking-enabled* ; default nil *logging* ; default nil *max-padding-instances* ; default 0 *tolerance* ; default 0.001 *output-precision* ; default 2 *instance-of-is-fluent* ; default nil *km-depth-limit* ; default nil *linear-paths* ; default nil *project-cached-values-only* ; default nil *record-explanations-for-clones* ; default nil *coerce-undeclared-slots* ; default nil *record-explanations* ; default t *record-sources* ; default t *add-comments-to-names* ; t - print _Car3 as: _Car3 #|"a Car&Dog"|# *check-kb* ; default nil *classify-slotless-instances* ; default t *built-in-remove-subsumers-slots* ; #$(instance-of classes superclasses member-type) (is changed in AURA appn) *built-in-remove-subsumees-slots* ; #$(subclasses prototype-of domain range) (is changed in AURA appn) *default-fluent-status* ; #$*Fluent *active-obj-stack* ; nil *on-error* ; default = debug *classification-enabled* *prototype-classification-enabled* *use-inheritance* *use-prototypes* *developer-mode* )) (defparameter *recursive-classification* t) (defparameter *indirect-classification* t) (defparameter *recursive-prototypes* nil) (defparameter *eagerly-unify-prototypes* t) (defparameter *sanity-checks* nil) ; see constraints.lisp to toggle these on and off (defparameter *slot-checking-enabled* nil) (defparameter *logging* nil) (defparameter *max-padding-instances* 0) ; [1] (defparameter *tolerance* 0.0001) ; within this means the two numbers are the same (defparameter *output-precision* 2) ; for make-sentence (defparameter *instance-of-is-fluent* nil) (defparameter *km-depth-limit* nil) ; nil = no limit (defparameter *linear-paths* nil) ; DON'T recognize linear paths any more (defparameter *project-cached-values-only* nil) (defparameter *record-explanations-for-clones* t) ; change (defparameter *coerce-undeclared-slots* nil) ; if t and slot isn't declared, assert it as (instance-of (Slot)) (defvar *record-explanations* t) ; Allow users to turn this off (to save memory) (defparameter *record-sources* t) ; Allow users to turn this off (to save memory) (defparameter *add-comments-to-names* t) ; print _Car3 as: _Car3 #|"a Car&Dog"|# (defvar *check-kb* nil) ; (defvar *classify-slotless-instances* t) - in frame-io.lisp ; (defparameter *built-in-remove-subsumers-slots* '#$(instance-of classes superclasses member-type)) - in frame-io.lisp ; (defparameter *built-in-remove-subsumees-slots* '#$(subclasses prototype-of domain range)) - in frame-io.lisp ; In frame-io.lisp ;(defconstant *default-default-fluent-status* '#$*Fluent) ; neah, don't change this! ;(defparameter *default-fluent-status* *default-default-fluent-status*) ; user can change this (defparameter *active-obj-stack* nil) ;;; ---------------------------------------------------------------------- ;;; [1] above: For (at-least n Class) and (exactly n Class) constraints. KM will generate missing ;;; instances of Class if there are less than n on a slot, unless n > *max-padding-instances*. ;;; Setting *max-padding-instances* to 0 thus disables this feature. (defconstant *classify-in-local-situations* t) ; should never need to change ;;; ---------------------------------------- ;;; The following are run-time state variables, computed automatically by KM ;;; during KB load and KB execution, which the user doesn't need to set. ;;; These are the variables that need to be preserved to restore the KM state. (defparameter *km-state-parameters* '(*km-gensym-counter* ; *clone-operation-id-counter* *visible-theories* ; *obj-stack* neah, this doesn't need to be saved. *curr-prototype* *curr-situation* *classes-using-assertions-slot* *are-some-definitions* *are-some-prototypes* *are-some-subslots* *are-some-constraints* *are-some-tags* *are-some-defaults* *am-in-situations-mode* ; *abort-on-error-report* ; *error-report-silent* ; *user-defined-infix-operators* - these don't write out properly so ignore these )) ;;; These are internal during system development and are now fixed. They are parameters created ;;; during system development to allow easy switching off of new features if they break something. (defparameter *km-fixed-parameters* '(*add-cloned-from-links* ; t *propogate-explanations-to-clones* ; t *unclonable-slots* ; *prototype-bookkeeping-slots* *installing-inverses-enabled* *less-aggressive-constraint-checking* *overriding-in-prototypes* ; *clones-are-global* *force-with-cloned-from* ; take cloned-from as a tagging slot *classify-in-local-situations* )) ;;; Additional query-specific parameters (defparameter *km-runtime-variables* '(*trace* *depth* *internal-logging* *am-classifying* *looping* *spypoints* *profiling* *print-explanations* *show-comments* *deleted-frames* )) ;;; -------------------- (defvar *curr-prototype* nil) ; For prototype mode (defparameter *show-comments* t) ; for tracing (defparameter *use-inheritance* t) ; Applied in get-slotvals.lisp (defparameter *use-prototypes* t) ; Applied in get-slotvals.lisp (defparameter *use-no-inheritance-flag* nil) ; for Shaken (defvar *trace* nil) ; Tracer is on/off (defvar *depth* 0) ; Tracing depth (defvar *internal-logging* nil) ; for internal backtracking (defvar *am-classifying* nil) ; Don't classify while classifying ; (defvar *backtrack-after-testing-unification* nil) ; Obsolete parameter (always nil), but I'll leave the code there ;;; New mechanism (defvar *visible-theories* nil) ;(defvar *clone-operation-id-counter* 0) (defparameter *special-symbol-alist* '( (quote "'") (function "#'") (unquote "#,") (unquote-splice "#@") (#+allegro excl::backquote #-allegro backquote "`") (#+allegro excl::bq-comma #-allegro bq-comma ",") ; I'm not sure of the non-Allegro implementation (#+allegro excl::bq-comma-atsign #-allegro bq-comma-atsign ",@") )) ;;; when t, exposes the source info on frame data structures (for debugging purposes) (defparameter *developer-mode* nil) ;;; ---------------------------------------- ;;; encapsulate checking flag ; (defvar *check-kb* nil) - put earlier (defun checkkbon () (km-setq '*check-kb* t)) (defun checkkboff () (km-setq '*check-kb* nil)) (defun checkkbp () *check-kb*) ;;; ====================================================================== ;;; STATISTICS COUNTERS ;;; ====================================================================== (defvar *statistics-classification-inferences* 0) (defvar *statistics-query-directed-inferences* 0) (defvar *statistics-kb-access* 0) (defvar *statistics-cpu-time* (get-internal-run-time)) (defvar *statistics-skolems* 0) (defvar *statistics-max-depth* 0) (defvar *statistics-unifications* 0) (defvar *statistics-classifications-attempted* 0) (defvar *statistics-classifications-succeeded* 0) (defparameter *user-defined-infix-operators* nil) ;;; Experiment with making them local - doesn't work so well though ; (defparameter *clones-are-global* t) ; 7/24/08: NEW: No equate *clones-are-global* with *am-in-situations-mode* ;;; FILE: htextify.lisp ;;; File: htextify.lisp ;;; Author: Peter Clark ;;; Purpose: Dummy function, to suppress compiler warning. ;;; This function is referenced but inaccessible in stand-alone KM. (defun htextify (concept &optional concept-phrase &key action window) (declare (ignore concept concept-phrase action window))) ;;; FILE: case.lisp ;;; File: case.lisp ;;; Author: Peter Clark ;;; Purpose: Case-sensitive handling for KM ;;; ====================================================================== ;;; READING ;;; ====================================================================== ;;; Thanks to Brian Mastenbrook for info on the usage of eval-when, which ;;; avoids pre-loading km.lisp before compiling! ;;; New version, thanks to Sunil Mishra (SRI) ;;; This version uses unwind-protect to ensure that the readtable-case gets reset, ;;; and cerror to allow resuming km from the entered debugger with a :cont. ;;; New version, extended to add a #t construct - thanks to Francis Leboutte ;;; The #t construct (dispatch macro-character) ;;; Francis Leboutte, 20Jul2005 #| Reader macro documentation: Example: (km '#$(every Car has (wheel-count (4)) (parts ((a Engine) (a Chassis))))) (km '#$(a Car)) To get the parts of a Car instance, below the various ways to write the call to km. Notice: in this example, the current package is the "USER" package and the km symbol accessible in the "USER" package 1. without using the #$ construct: (let* ((car-instance (first (km '(km::|the| km::|all-instances| km::|of| km::|Car|))))) (km `((km::|the| km::|parts| km::|of| ,USER::CAR-INSTANCE)))) 2. with the #$ construct: (let ((car-instance (first (km '#$(the all-instances of Car))))) (km `(#$the #$parts #$of ,car-instance))) 3. with the #$ construct, other way Notice in the second call to km, car-instance must be package qualified and in majuscules: (let ((car-instance (first (km '#$(the all-instances of Car))))) (km `#$(the parts of ,USER::CAR-INSTANCE))) 4. with the #$ and #t constructs. Just write the km requests as they would be written at the KM prompt and prefix any lisp variables with #t. The case of letters of these variables is unimportant: (let ((car-instance (first (km '#$(the all-instances of Car))))) (km `#$(the parts of ,#tcar-instance))) For another example of how to use the #t construct, see the property-mult-property and property-div-property functions. |# (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *t-readtable* (copy-readtable *readtable*)) ;; standard CL mode: ; (setf (readtable-case *t-readtable*) :upcase) (defvar *t-package* nil)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun hash-t-reader (stream subchar arg) (declare (ignore subchar arg)) (let (;; bind *package* to the package that was in effect outside the ;; form prefixed by #$ (*package* *t-package*) (*readtable* *t-readtable*)) (read stream t nil t)))) ;;; (get-dispatch-macro-character #\# #\t) (eval-when (:compile-toplevel :load-toplevel :execute) (set-dispatch-macro-character #\# #\t #'hash-t-reader)) ;;; UPDATED DEFINITIONS ;;; ******************* (eval-when (:compile-toplevel :load-toplevel :execute) (defun case-sensitive-read-km (&optional stream (eof-err-p t) eof-val rec-p) ;; FLE 29Jul2005 ;; bind *t-package* to the current package, to be used in the #t construct ;; It doesn't hurt if *package* is already bound to *km-package* ;; (which is :km or a "current" package, usually :user). ;; BTW, I think KM should always be packaged (:km package) (let ((*t-package* *package*) (*package* *km-package*)) (case-sensitive-read stream eof-err-p eof-val rec-p)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun case-sensitive-read (&optional stream (eof-err-p t) eof-val rec-p) (let ((old-readtable-case (readtable-case *readtable*))) (loop (handler-case (unwind-protect (progn (setf (readtable-case *readtable*) :preserve) (return (read stream eof-err-p eof-val rec-p))) (setf (readtable-case *readtable*) old-readtable-case)) (error (error) ;; FLE 25Jul2005: more understandable error message (typep and ~a) (cerror "Ignore error and return." (if (typep error 'end-of-file) "During case-sensitive-read, certainly a premature end-of-file:~%~a" "During case-sensitive-read:~%~a") error))))))) ;;; ====================================================================== (eval-when (:compile-toplevel :load-toplevel :execute) (defun hash-dollar-reader (stream subchar arg) (declare (ignore subchar arg)) (case-sensitive-read-km stream t nil t))) (eval-when (:compile-toplevel :load-toplevel :execute) (set-dispatch-macro-character #\# #\$ #'hash-dollar-reader)) ;;; ====================================================================== ;;; WRITING ;;; ====================================================================== #| This version of format *doesn't* put || around symbols, but *does* put "" around strings. This is impossible to do with the normal format, as || and "" can only be suppressed in unison (via the *print-escape* variable). There's no other way round that I can see besides the below. > ([km-]format t "~a" (case-sensitive-read)) (The BIG big "car" 2) produces: *case-sensitivity* *print-case* format ~a km-format ~a format ~s km-format ~s t :upcase (The BIG big car 2) (The BIG big "car" 2) (|The| BIG |big| "car" 2) (|The| BIG |big| "\"car\"" 2) t :downcase (the big big car 2) (The BIG big "car" 2) [ nil :upcase (THE BIG BIG car 2) (THE BIG BIG "car" 2)] [ nil :downcase (the big big car 2) (the big big "car" 2)] (defun test (x) (setq *print-case* :upcase) (km-format t "km-format: ~a~%" x) (format t "format: ~a~%" x) (setq *print-case* :downcase) (km-format t "km-format: ~a~%" x) (format t "format: ~a~%" x)) |# (defun km-format (stream string &rest args) (let ( (old-print-case *print-case*) ) (prog2 (setq *print-case* :upcase) ; :upcase really means "case-sensitively" (apply #'format (cons stream (cons string (mapcar #'add-quotes args)))) (setq *print-case* old-print-case)))) ;;; For prettiness, we normally remove || when printing. But, this has the side-effect of also ;;; removing quotes, so we must add those back in -- and also add back in || if the symbol ;;; contains special characters "() ,;:". ;;; (the "cat") -> (the "\"cat\"") (defun add-quotes (obj) (cond ((null obj) nil) ((aconsp obj) (cons (add-quotes (first obj)) (add-quotes (rest obj)))) ((listp obj) (mapcar #'add-quotes obj)) ((stringp obj) (format nil "~s" obj)) ; (concat "\"" obj "\"") <- Insufficient for "a\"b" ((and (symbolp obj) (let ( (chars (explode (symbol-name obj))) ) (or (intersection chars '(#\( #\) #\ #\, #\; #\: #\' #\")) (not (set-difference chars '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))))) ; e.g. |1943|, the symbol (concat "|" (symbol-name obj) "|")) ((keywordp obj) (concat ":" (symbol-name obj))) ; better! (t obj))) ;;; ====================================================================== ;;; BETTER FORMATTING ;;; ====================================================================== ;;; (write-km-vals '#$(:seq _Car2 |the Dog| (baz . bar) #,(the #'dog))) ;;; -> (:seq _Car2 #|"mike" "joe"|# |the Dog| (baz . bar) #,(the #'dog)) ;;; (write-km-vals '#$(:seq _Car2 #|"mike" "joe"|# |the Dog| (foo baz . bar))) will give an error though ;;; [(length '(a b . c)) generates an error - ignore this case for now]. (defun write-km-vals (vals &optional (stream t)) (let ( (old-print-case *print-case*) ) (prog2 (setq *print-case* :upcase) ; :upcase really means "case-sensitively" (write-km-vals2 vals stream) (setq *print-case* old-print-case)))) (defun write-km-vals2 (vals &optional (stream t)) (cond ((null vals) (format stream "~a" nil)) ((and (pairp vals) (symbolp (first vals)) (assoc (first vals) *special-symbol-alist*)) (let ( (special-symbol-str (second (assoc (first vals) *special-symbol-alist*))) ) (format stream "~a" special-symbol-str) (write-km-vals2 (second vals) stream))) ((listp vals) (write-km-list vals stream)) ((stringp vals) (format stream "~s" vals)) ((keywordp vals) (format stream ":~a" vals)) ((and (symbolp vals) (intersection (explode (symbol-name vals)) '(#\( #\) #\ #\, #\; #\:))) (format stream "|~a|" vals)) ((anonymous-instancep vals) (format stream "~a" vals) (let ( (tags (remove-constraints (append (get-vals vals '|called| :situation *global-situation*) (get-vals vals '|uniquely-called| :situation *global-situation*)))) ) (cond (tags (tag-write tags)) (t (let* ( (classes (immediate-classes vals)) (skolem-root (skolem-root (symbol-name vals))) (name-class-str (cond ((starts-with skolem-root "_Proto") (subseq skolem-root 6 (length skolem-root))) ((starts-with skolem-root "_Some") (subseq skolem-root 5 (length skolem-root))) (t (butfirst-char skolem-root)))) (name-class (intern name-class-str *km-package*)) ) (cond ((or (>= (length classes) 2) (neq name-class (first classes))) (let ( (new-tag (concat-list (cons "a " (commaed-list (mapcar #'symbol-name classes) "&")))) ) (tag-write (list new-tag) stream))))))))) (t (format stream "~a" vals)))) (defun write-km-list (list &optional (stream t) (first-time-through t)) (cond ((null list) (format stream ")")) (t (cond (first-time-through (format stream "(")) (t (format stream " "))) (cond ((aconsp list) (write-km-vals2 (first list) stream) (format stream " . ") (write-km-vals2 (rest list) stream) (format stream ")")) (t (write-km-vals2 (first list) stream) (write-km-list (rest list) stream nil)))))) ; i.e. first-time-through = nil (defun tag-write (tags &optional (stream t) (first-time-through t)) (cond ((null tags) (format stream "|#")) (t (cond (first-time-through (format stream " #|")) (t (format stream " "))) (format stream "~s" (first tags)) (tag-write (rest tags) stream nil)))) ; i.e. first-time-through = nil ;;; "_Car23" -> "_Car" (defun skolem-root (string) (cond ((string= string "")) ((member (last-char string) '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :test #'char=) (skolem-root (butlast-char string))) (t string))) ;;; ====================================================================== ;;; "Tool" -> |Tool| (case-sensitivity on); [|TOOL| (case-sensitivity off)] (defun string-to-frame (string) (cond ((string= string "") nil) (t (intern string *km-package*)))) ;;; Inverse suffix must obey case-sensitive restrictions (defparameter *inverse-suffix* "-of") (defparameter *length-of-inverse-suffix* (length *inverse-suffix*)) #| ====================================================================== UNQUOTING: KM's own mechanism ============================= This isn't very elegant, I'd rather use the traditional `, Lisp syntax, but this will have to do**. Note the complication that #, always returns a LIST of instances, so we have to be careful to splice them in appropriately. Added #@ to do splicing. (a #@b) = (a . #,b) However, we need to make it a reader macro so that KM will respond to embedded #, which would otherwise be unprocessed, eg. a handler for "," won't even reach the embedded unit in: KM> (Pete has (owns (`(a Car with (age ,(the Number)))))) but a macro character will: KM> (Pete has (owns ('(a Car with (age #,(the Number)))))) ** The mechanism needs to be vendor-independent, but the handling of `, is vendor-specific. Allegro names these two symbols as excl:backquote and excl:bq-comma; Harlequin preprocesses the expressions in the reader, so that `(a b ,c) is pre-converted to (list 'a 'b c). ====================================================================== This *doesn't* require pairing with backquote `. Usage: KM> (:set (a Car) (a Car)) (_Car13 _Car14) KM> '(:set (a Car) (a Car)) ('(:set (a Car) (a Car))) KM> '(:set (a Car) #,(a Car)) ('(:set (a Car) (_Car16))) <= note undesirable () around _Car16 KM> '(:set (a Car) . #,(a Car)) <= use . #, to slice item at end of list ('(:set (a Car) _Car17)) |# ;;; Thanks to Brian Mastenbrook for info on the usage of eval-when, which ;;; avoids pre-loading km.lisp before compiling! (eval-when (:compile-toplevel :load-toplevel :execute) (defun hash-comma-reader (stream subchar arg) (declare (ignore subchar arg)) (list 'unquote (case-sensitive-read-km stream t nil t)))) (eval-when (:compile-toplevel :load-toplevel :execute) (set-dispatch-macro-character #\# #\, #'hash-comma-reader)) ;;; FILE: interpreter.lisp ;;; File: interpreter.lisp ;;; Author: Peter Clark ;;; Date: July 1994 ;;; Purpose: KM Query Language interpreter (defvar *looping* nil) (defvar *warnings* nil) (defvar *errors* nil) (defvar *error-structures* nil) (defparameter *multidepth-path-default-searchdepth* 5) ;;; *additional-keywords* ARE allowed as slot names (defparameter *additional-keywords* '#$(TheValue TheValues * called uniquely-called Self QUOTE UNQUOTE == /== > <)) ; used for (scan-kb) in frame-io.lisp. (defparameter *infinity* 999999) (defparameter *structured-list-val-keywords* '#$(:seq :bag :args :triple :pair :function)) (defparameter *reserved-keywords* ; NOT allowed as class or slot names '#$(a some must-be-a mustnt-be-a print format km-format an instance @ retain-expr ; sometimes possible-values excluded-values spy unspy anonymous-instancep sanity-check every the the1 the2 the3 theN theNth of forall forall2 with where theoneof theoneof2 forall-seq forall-seq2 forall-bag forall-bag2 the-class constraints-for rules-for the+ a+ evaluate-paths clone a-prototype oneof oneof2 It It2 if then else allof allof2 and or not is & && &? &+ #|&&?|# &! &&! = === /= + - / ^ >= <= isa #|expand-text add-clones-to in-which|# append are includes thelast :set :seq :bag :args :triple :pair :function :default showme-here showme showme-all evaluate-all quote delete evaluate has-value andify make-sentence make-phrase #|pluralize|# every has now-has also-has also-hasnt must is-superset-of covers subsumes has-definition numberp bag seq #|override|# no-inheritance comm trace untrace fluent-instancep at-least at-most exactly constraint <> reverse is-subsumed-by is-covered-by set-constraint set-filter in-situation in-every-situation end-situation do do-and-next in-theory end-theory see-theory hide-theory visible-theories curr-situation ignore-result do-script new-context do-plan)) (defparameter *km-lisp-exprs* ;; KM functions which should function both at the KM> and Lisp prompt. ;; Note these ALL RETURN (t), hence new-situation and global-situation are not here. '(save-kb reset-kb write-kb fastsave-kb fastload-kb faslsave-kb load-newest-kb load-triples orphans show-context checkkbon checkkboff show-bindings version dereference-kb show-obj-stack clear-obj-stack reset-done clear-evaluation-cache install-all-subclasses clean-taxonomy scan-kb disable-classification enable-classification explain-all clear-explanations disable-installing-inverses enable-installing-inverses start-logging stop-logging no-explanations explanations clear-situations sanity-checks no-sanity-checks store-kb restore-kb fail-quietly fail-noisily requires-km-version catch-explanations show-explanations show-explanations-xml instance-of-is-fluent instance-of-is-nonfluent eval setq tracekm untracekm license enable-slot-checking disable-slot-checking comments nocomments trace-to-file-on trace-to-file-off t2f-on t2f-off ;;; From Raphael Van Dyck, for switching tracing on to a file )) (defparameter *downcase-km-lisp-exprs* (mapcar #'(lambda (expr) (intern (string-downcase expr) *km-package*)) *km-lisp-exprs*)) ;;; Directs KM to use process-load-expression for these commands used at the KM prompt (defparameter *loadsave-commands-with-keywords* '(load-kb #$load-kb reload-kb #$reload-kb save-kb #$save-kb fastsave-kb #$fastsave-kb fastload-kb #$fastload-kb faslsave-kb #$faslsave-kb write-kb #$write-kb load-newest-kb #$load-newest-kb)) ;;; Don't strip out (@ ...) structures for lists beginning with these items. (defparameter *no-decomment-headwords* '#$(comment show-comment explanation)) ;;; 10/28/02: These are calls where all the subcalls are direct calls to km-int, so we can defer decommenting down ;;; to there for the elements. i.e., we DON'T decomment the embedded structures when passing to km-int ;;; (defparameter *decomment-top-level-only-headwords* '#$(:set if)) (defparameter *decomment-top-level-only-headwords* '#$(:set if forall allof oneof theoneof forall-seq forall-bag forall2 allof2 oneof2 theoneof2 forall-seq2 forall-bag2 :seq :bag :args :triple :pair :function )) ; from frame-io.lisp, as we want to reference it here (defparameter *built-in-classes-with-nonfluent-instances-relation* '#$(Situation Slot Partition Theory)) ; No longer used... ;;; For annotation in explain.lisp ;;; Format ( ). Note a var will only be annotated providing it's a list. ;(defvar *patterns-to-annotate* ; '#$(((the ?x of ?y) (?y)) ; ((the ?x ?y of ?z) (?z)))) ;;; -------------------- ;;; Change to 'error for test-suite (defparameter *top-level-fail-mode* 'fail) (defun fail-noisily () (km-setq '*top-level-fail-mode* 'error) t) (defun fail-quietly () (km-setq '*top-level-fail-mode* 'fail) t) (defconstant *default-fail-mode* 'fail) (defvar *am-reasoning* nil) ;;; -------------------- ;;; Backwards-compatibility: (km0 ...) now synonymous with (km ...) (defun km0 (&optional (kmexpr 'ask-user) &key (fail-mode (cond (*am-reasoning* *default-fail-mode*) (t *top-level-fail-mode*)))) (km kmexpr :fail-mode fail-mode)) ;;; The top level call, either by person or machine ;;; RETURNS 3 values: ;;; - result of evaluating ;;; - if an error occurred, a string describing it ;;; - if an error occurred, a structure describing it ;;; NOTE: If *am-reasoning*, then km is equivalent to km-int (defun km (&optional (kmexpr 'ask-user) &key (fail-mode (cond (*am-reasoning* *default-fail-mode*) (t *top-level-fail-mode*))) (reset-statistics t)) (cond ((eq kmexpr 'ask-user) (km-read-eval-print)) (*am-reasoning* (km-int kmexpr :fail-mode fail-mode)) ; km -> km-int if *am-reasoning* already (t (let ((*am-reasoning* t) ; so must be top-level KM call (*warnings* nil) (*errors* nil) (*error-structures* nil)) (reset-for-top-level-call kmexpr :reset-statistics reset-statistics) (let* ((answer0 (catch 'km-abort (desource (km-int kmexpr :fail-mode fail-mode)))) (answer (cond ((and (listp answer0) (eq (first answer0) 'km-abort)) (km-format t "(Execution aborted)~%") nil) ; user or KM abort (t answer0)))) (cond ((and (null *errors*) (null *error-structures*) (null *warnings*)) answer) (t (values answer (reverse *errors*) (reverse *error-structures*) (reverse *warnings*))))))))) ;;; [1] See cache-problem.km in test-suite. (reset-done) might be rather inefficiently implemented (?). ;;; [2] For load-kb, load-kb does a (reset-inference-engine) right at the start, and then for specific KM calls ;;; within load-kb we keep statistics counters going (skip redoing (reset-inference-engine) for each KM call) (defun reset-for-top-level-call (km-expr &key (reset-statistics t)) ; (km-format t "Resetting for top level call...~%") (cond (reset-statistics (reset-inference-engine))) ; [2] (cond (*looping* ; better: Only need to reset the cache if you were looping. (reset-done) (setq *looping* nil))) (cond ((and km-expr (am-in-prototype-mode)) ; cosmetic: Store prototype build commands and print out if you do a save-kb (add-to-prototype-definition *curr-prototype* km-expr))) (cond ((and km-expr (km-assertion-expr km-expr)) (reset-done) (clear-cached-explanations)))) ; [1] ;;; ---------- (defvar *last-question* nil) ; so we can simply ask "why" rather than "why" with a whole list of arguments (defvar *last-answer* nil) ; so we can simply ask "why" rather than "why" with a whole list of arguments #| 21Aug2006 Thanks to Raphael Van Dyck for these improvements! The KM read-eval-print loop doesn't work well in Lispworks, especially when km enters the debugger. The problem arises because a T stream argument is often used in km functions and a T stream hasn't the same meaning in all the IO CL functions: - For the CL function format, a stream agument of t means writing to the standard output. - For the CL functions write, prin1, print, pprint and princ, a stream argument of t means writing to the terminal. - For the CL function read, a stream argument of t means reading from the terminal. The km read-eval-print loop should probably always write to the standard output and read from the standard input. Consequently this patch passes a stream argument of nil instead of t to the functions write, prin1, print, pprint, princ and read. This patch also adds a fresh-line after the case-sensitive-read-km in the rep loop. This is because in Lispworks the read function returns as soon as the expression is complete, causing the value of the expression to be printed on the same line as the expression. Note Maybe some other KM functions will need to be fixed in the same way. [1] We set-checkpoint here, rather than in km-eval-print, as (load-kb ... :verbose t) also calls km-eval-print, and we DON'T (?) want checkpointing used there too. |# (defun km-read-eval-print () (loop (reset-inference-engine) (print-km-prompt) (finish-output) ; flush output if stream is buffered (let ( (query (case-sensitive-read-km)) ) ;; RVA 21Aug2006 ;; added fresh-line because in lispworks the read function returns the expression as soon as it is complete, ;; before the user has pressed the return key (fresh-line) (cond ((minimatch query '#$(the ?slot of ?expr)) (setq *last-question* query))) (cond ((eq query '#$q) (return)) (t (cond ((not (skip-checkpoint query)) (set-checkpoint query))) ; [1] (multiple-value-bind (answer error) (km-eval-print query) (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) ;;; moved to km-eval, below. Calls to km-eval and km-eval-print MUST have same behavior! (multiple-value-bind (answer error error-str) ; (km-eval query :fail-mode fail-mode) (km query :fail-mode fail-mode) ; phase out km-eval (declare (ignore error-str)) (cond (*add-comments-to-names* (write-km-vals answer)) (t (km-format t "~a" answer))) (cond (error (format t " ; (WARNING: Errors occurred during reasoning)~%")) (t (terpri))) (princ (report-statistics)) ;;; (cond (*frame-accessp* (report-frame-access-count))) (terpri) (values answer error))))) #| Call to km-int: answer = EITHER the answer OR a list of three things: (km-abort ) RETURNS 3 values: - result of evaluating - if an error occurred, a string describing it - if an error occurred, a structure describing it reset-inference-engine done up in (km), or NOT, if called by load-kb (don't want to keep resetting counters) also no checkpointing done [1] New - see cache-problem.km in test-suite. (reset-done) might be rather inefficiently implemented (?). I wonder if it's too slow. |# #| (defun km-eval (km-expr &key (fail-mode *top-level-fail-mode*)) ; (reset-done) ; see test-suite/cache-problem3.km ; Move these now up to KM (cond (*looping* ; better: Only need to reset the cache if you were looping. (reset-done) (setq *looping* nil))) (cond ((am-in-prototype-mode) ; purely cosmetic: Store prototype build commands and print them out if you do a save-kb (add-to-prototype-definition *curr-prototype* km-expr))) (cond ((km-assertion-expr km-expr) (reset-done) (clear-cached-explanations))) ; [1] (let ((answer (catch 'km-abort (desource (km-int km-expr :fail-mode fail-mode))))) (cond ((and (listp answer) (eq (first answer) 'km-abort)) ; error encountered (values nil (second answer) (third answer))) (t answer)))) |# ;;; NEW: Make km-eval synonymous with km. Phase out km-eval in the code at a later time ; (defun km-eval (km-expr &key (fail-mode *top-level-fail-mode*)) (km km-expr :fail-mode fail-mode)) ;;; ---------- (defun print-km-prompt (&optional (stream t)) (cond ((and (am-in-local-situation) (am-in-prototype-mode)) (report-error 'user-error "You are in both prototype-mode and in a Situation, which isn't allowed!~%")) ((and (am-in-local-theory) (am-in-prototype-mode)) (report-error 'user-error "You are in both prototype-mode and in a Theory, which isn't allowed!~%")) ; (cond ((and (am-in-prototype-mode) (am-in-local-situation)) (km-format stream "[prototype-mode, ~a] KM> " (curr-situation))) ((am-in-prototype-mode) (km-format stream "[prototype-mode] KM> ")) ((am-in-local-situation) (km-format stream "[~a] KM> " (curr-situation))) ((am-in-local-theory) (km-format stream "{~a} KM> " (curr-situation))) (t (km-format stream "KM> ")))) ;;; ====================================================================== ;;; KM HANDLER METHODS ;;; (km-int ) is the recursive to KM *internal* to the KM Engine ;;; ====================================================================== ;;; (km-int ) 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 *profiling* nil) ;;; For Jason Chaw. Accessors in trace.lisp (defvar *silent-spypoints* nil) (defvar *silent-spypoints-log* nil) (push '*silent-spypoints* *km-runtime-variables*) (push '*silent-spypoints-log* *km-runtime-variables*) #| Called by lazy-unify, where we want to look like trace-expr has gone through km-int, with kmexpr as the subgoal, even though this isn't literally true. In other words, this splices an extra step in the trace output which doesn't really exist in KM. Rather than displaying: -> (_Car1 &? _Car2) -> ((a Engine) (a Chassis)) <- (_Engine1 _Chassis3) -> ((a Engine) (a Chassis)) <- (_Engine4 _Chassis5) It displays: -> (_Car1 &? _Car2) -> (the parts of _Car1) -> ((a Engine) (a Chassis)) <- (_Engine1 _Chassis3) -> (the parts of _Car2) -> ((a Engine) (a Chassis)) <- (_Engine4 _Chassis5) Note the "virtual" extra steps inserted. The (the parts of _Car1) are in fact done by a direct get-vals in lazy-unify, rather than by a recursive call to KM, but we still want to show this to the user. |# (defun km-int-with-trace (trace-expr kmexpr &key (fail-mode *default-fail-mode*) (check-for-looping t) target) (prog2 (push-to-goal-stack trace-expr) (let* ( (users-goal (km-trace 'call "-> ~a" trace-expr)) (answer (cond ((eq users-goal 'fail) nil) (t (km-int kmexpr :fail-mode fail-mode :check-for-looping check-for-looping :target target)))) (users-response (cond (answer (km-trace 'exit "<- ~a~30T\"~a\"" answer trace-expr)) (t (km-trace 'fail "<- FAIL!~30T\"~a\"" trace-expr)))) ) (cond ((eq users-response 'redo) (reset-done) (km-int-with-trace trace-expr kmexpr :fail-mode fail-mode :check-for-looping check-for-looping :target target)) ((eq users-response 'fail) nil) (t answer))) (pop-from-goal-stack))) ;;; -------------------- ;;; Wrapper, to maintain a stack and check for looping #| kmexpr-with-comments is the expression passed to km-int. It may include comments. kmexpr is the ACTUAL expression to evaluate by km. This requires remove all comments, EXCEPT for assertion statements (has, a, some) in which only the TOP LEVEL comments are stripped (so that the sub-level comments get asserted in the KB) |# (defun km-int (kmexpr-with-comments &key (fail-mode (cond (*am-reasoning* *default-fail-mode*) (t *top-level-fail-mode*))) (check-for-looping t) target rewritep) (cond ((null *am-reasoning*) (km kmexpr-with-comments :fail-mode fail-mode)) ; eg. top-level (in-situation ) calls km-int ;;; FAILED similification (t (let ((kmexpr (cond ((km-assertion-expr kmexpr-with-comments) ; (every Car has (parts ((a Engine [Car1]))) (desource+decomment-top-level kmexpr-with-comments)) ; NB leave embedded comments in here ((and (listp kmexpr-with-comments) ; (comment [Cat1] "a cat" "people like cats") (or (member (first kmexpr-with-comments) *no-decomment-headwords*) (and (eq (first kmexpr-with-comments) '#$in-situation) (listp (third kmexpr-with-comments)) (member (first (third kmexpr-with-comments)) *no-decomment-headwords*)))) kmexpr-with-comments) ;;; NEW: Decomment *everything* ONLY at the top level (t (desource-top-level (decomment kmexpr-with-comments)))) #| (cond ((or (km-assertion-expr kmexpr-with-comments) ; (every Car has (parts ((a Engine [Car1]))) (and target ; target=(the pets of Pete) (record-explanation-later kmexpr-with-comments)) ; ((a Cat [Cat1]) & (a Pet [Pet1])) (and (listp kmexpr-with-comments) (member (first kmexpr-with-comments) *decomment-top-level-only-headwords*)) ; (let ((kmexpr0 (desource+decomment-top-level kmexpr-with-comments))) ; (some #'(lambda (pattern+vars) ; patterns by definition don't have top-level annotated ; (minimatch kmexpr0 (first pattern+vars))) ; *patterns-to-annotate*)) ) (desource+decomment-top-level kmexpr-with-comments)) ((and (listp kmexpr-with-comments) ; (comment [Cat1] "a cat" "people like cats") (or (member (first kmexpr-with-comments) *no-decomment-headwords*) (and (eq (first kmexpr-with-comments) '#$in-situation) (listp (third kmexpr-with-comments)) (member (first (third kmexpr-with-comments)) *no-decomment-headwords*)))) kmexpr-with-comments) (t (desource+decomment kmexpr-with-comments))) |# )) ; (km-format t "~%kmexpr-with-comments:~% ~a~%" kmexpr-with-comments) ; (km-format t "kmexpr-without-assignment:~% ~a~%" kmexpr-without-assignment) ; (km-format t "kmexpr (to actually process):~% ~a~%" kmexpr) (cond ((and *spypoints* (some #'(lambda (spypoint) (minimatch kmexpr spypoint)) *spypoints*)) (km-format t "(Spypoint reached!)~%") (tracekm))) (cond ((and *silent-spypoints* (some #'(lambda (spypoint) (minimatch kmexpr spypoint)) *silent-spypoints*)) (push kmexpr *silent-spypoints-log*))) (cond ((and (not *are-some-constraints*) (constraint-exprp kmexpr)) (note-are-constraints))) (cond ((member kmexpr '#$((tracekm) (TRACEKM) (trace) (TRACE)) :test #'equal) (reset-trace-depth) (tracekm) '#$(t)) ((member kmexpr '#$((untracekm) (UNTRACEKM) (untrace) (UNTRACE)) :test #'equal) (reset-trace-depth) (untracekm) '#$(t)) ((and (listp kmexpr) ; handle case-sensitivity for keywords in load-kb (member (first kmexpr) *loadsave-commands-with-keywords*)) (process-load-expression kmexpr)) ((and (listp kmexpr) (member (first kmexpr) *km-lisp-exprs*)) ; (eval kmexpr) '#$(t) ; old (listify (eval kmexpr))) ; new ((and (listp kmexpr) (member (first kmexpr) *downcase-km-lisp-exprs*)) ; (eval (cons (intern (string-upcase (first kmexpr)) *km-package*) (rest kmexpr))) '#$(t) ; old (listify (eval (cons (intern (string-upcase (first kmexpr)) *km-package*) (rest kmexpr))))) ; new ((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 (and (constraint-exprp kmexpr) (not (retain-exprp kmexpr)))) (cond ((eq fail-mode 'error) (report-error 'user-error "No values found for ~a!~%" kmexpr))) nil) ((and (atom kmexpr) (not (no-reserved-keywords (list kmexpr)))) ; User error! Contains keywords, so fail out nil) ((km-varp kmexpr) (report-error 'user-error "Unbound variable ~a encountered!~%" kmexpr)) ((and (fully-evaluatedp kmexpr) ; fast handling, & don't clutter up the program trace with reflexive calls (eql (dereference kmexpr) kmexpr)) ; Is this the reflexive case? see (cond ((km-setp kmexpr) (set-to-list kmexpr)) ((and (listp kmexpr) (eq (first kmexpr) '#$:triple) (not (= (length (rest kmexpr)) 3)) (report-error 'user-error "~a: A triple should have exactly three elements!~%" kmexpr))) ((and (listp kmexpr) (eq (first kmexpr) '#$:pair) (not (= (length (rest kmexpr)) 2)) (report-error 'user-error "~a: A pair should have exactly two elements!~%" kmexpr))) (t (list kmexpr)))) ((internal-commentp kmexpr-with-comments) (let ( (comment-tag (second kmexpr-with-comments)) ) (report-error 'user-error "Comment tag ~a was encountered as a free-standing slot-value in the KB - not allowed! It should be embedded within a KM expression.~%" comment-tag))) ((and check-for-looping (looping-on kmexpr-with-comments)) ; LOOPING! Defined in stack.lisp (km-trace 'comment "Looping on ~a!" kmexpr) ; (break) (handle-looping kmexpr)) ((and *km-depth-limit* (> *depth* *km-depth-limit*)) (km-trace 'comment "Maximum depth limit reached, doing ~a!" kmexpr) (handle-looping kmexpr :reason 'depth-limit-reached)) (t (prog2 (push-to-goal-stack kmexpr-with-comments) (km1 kmexpr kmexpr-with-comments :fail-mode fail-mode :target target :rewritep rewritep) (pop-from-goal-stack)))))))) ;;; ---------------------------------------- ;;; Handling of loops - allow inductive completion of proofs ;;; ---------------------------------------- ;;; reason = loop-detected OR depth-limit-reached ;;; [2] Not having the correct target-situation specified seems like an error to me. (defun handle-looping (kmexpr &key (reason 'loop-detected)) (setq *looping* t) (let ( (cexpr (canonicalize kmexpr)) ) (cond ((and (minimatch cexpr '#$(the ?slot of ?instance)) ; SPECIAL CASE: (the 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 ((kmexpr2 (vals-to-val vals))) ; vals may be an expression! ? see test-suite/looping.km (cond ((not (looping-on kmexpr2)) ; very important!!!! (let ((new-vals (km-int kmexpr2))) ; (let ((new-vals (prog2 ; No don't stack - will ALWAYS seem like looping! ; (push-to-goal-stack kmexpr2) ; NOTE: must stack to spot looping during looping ; (km-int kmexpr2) ; recovery ; (pop-from-goal-stack)))) (cond ((not (dont-cache-values-slotp slot)) ; (put-vals instance slot new-vals :install-inversesp nil))) ; constraints will be added + note-done when loop is unwound ;;; No: The "nil" causes a bug - see inverses-bug.km in test-suite (put-vals instance slot new-vals))) ; constraints will be added + note-done when loop is unwound new-vals)))))))) ; to upper calling level ((and (listp kmexpr) ; &-exprp too specific; want to include &? and &+? also (val-unification-operator (second kmexpr))) ; (a &/&?/&! b): Inductive proof: Can assume (X &? Y) when proving (X &? Y) (cond ((member (second kmexpr) '(&? &+?)) (case reason (loop-detected (km-trace 'comment "Assuming ~a to prove ~a (ie. Inductive proof)" kmexpr kmexpr) '#$(t)) (depth-limit-reached (km-trace 'comment "Assuming success...") '#$(t)))) ; Very questionable assumption! (t (let ( (val (find-if #'kb-objectp (&-expr-to-vals kmexpr))) ) ; find first fully evaluated val (cond (val (case reason (loop-detected (km-trace 'comment "Assuming ~a to prove ~a (ie. Inductive proof)" kmexpr kmexpr)) (depth-limit-reached (km-trace 'comment "Just using value found so far, = ~a..." val))) (list val))))))) ((&&-exprp kmexpr) (let ( (answer (find-if #'(lambda (set) (every #'kb-objectp set)) (&&-exprs-to-valsets (list kmexpr)))) ) (cond (answer (case reason (looping-detected (km-trace 'comment "Assuming ~a to prove ~a (ie. Inductive proof)" kmexpr kmexpr)) (depth-limit-reached (km-trace 'comment "Just using value found so far, = ~a..." answer))) answer)))) (t (km-trace 'comment "Giving up...)" kmexpr) nil)))) ;;; ---------------------------------------- ;;; Extensions for Jihie: ;(defvar *trace-log* nil) ; **** NEW LINE ;(defvar *trace-log-on* nil) ; **** another NEW LINE (defvar *print-explanations* nil) (defvar *catch-explanations* nil) (defvar *catch-next-explanations* nil) (defvar *explanations* nil) ;;; (km1 ...) ;;; [1] Note we can't do a remove duplicates, as we often need duplicate ;;; entries in. Eg. ("remove" _car1 "and put" _car1 "into the furnace") ;;; target = the target slot and frame for the result, in the form '#$(the of ). NIL if none known eg. top-level query (defun km1 (kmexpr kmexpr-with-comments &key (fail-mode *default-fail-mode*) target rewritep) (increment-inference-statistics) (cond (*profiling* (profile-call (desource kmexpr)))) ; (if (and *trace-log-on* (not *am-classifying*)) ; **** another NEW LINE ; (setq *trace-log* (cons `(,(1+ *depth*) call ,kmexpr-with-comments) *trace-log*))) ; **** NEW LINE (let* ( (users-goal (cond (target (km-trace 'call "-> ~a~40T [for ~a]" ; "-> (a Car) [for (the parts of _Car3)]" kmexpr-with-comments target)) (t (km-trace 'call "-> ~a" kmexpr-with-comments)))) (dummy (cond ((or *catch-explanations* *print-explanations*) (catch-explanation kmexpr-with-comments 'call))))) (declare (ignore dummy)) (multiple-value-bind (answer0 handler-pattern) ; handler-pattern now used (cond ((eq users-goal 'fail) nil) ((atom kmexpr) (list kmexpr)) ; [2]: Checks for keywords and add-to-obj-stack in km [1] above (*compile-handlers* (funcall *km-handler-function* fail-mode target kmexpr)) ; COMPILED DISPATCH MECHANISM (t (let* ( (handler (find-handler kmexpr *km-handler-alist*)) ; INTERPRETED DISPATCH MECHANISM (answer00 (apply (first handler) `(,fail-mode ,target ,@(second handler)))) (pattern (third handler)) ) (values answer00 pattern)))) (let ( (answer (remove-dup-instances (remove nil answer0)))) ; NOTE includes dereferencing (cond ((and (null answer) (eq fail-mode 'error)) (report-error 'user-error "No values found for ~a!~%" kmexpr-with-comments))) (process-km1-result answer kmexpr kmexpr-with-comments :fail-mode fail-mode :target target :handler-pattern handler-pattern :rewritep rewritep))))) ;;; This allows handling of redo and fail options when tracing. (defun process-km1-result (answer kmexpr kmexpr-with-comments &key (fail-mode *default-fail-mode*) target handler-pattern rewritep) (mapc #'(lambda (val) (cache-explanation-for val kmexpr)) answer) ; NOW: store the *decommented* version. NB kmexpr isn't (cond ((and target ; fully decommented for (a ... with ...) exprs (not rewritep) ; don't record all the rewrites *record-explanations* (not (record-explanation-later kmexpr-with-comments)) ) (mapc #'(lambda (val) (record-explanation-for target val kmexpr-with-comments)) answer))) (cond ((and (not rewritep) *record-explanations* (existential-exprp kmexpr)) (cond ((not (singletonp answer)) (report-error 'program-error "Multiple values from an existential expr ~a!~%" kmexpr)) (t (let ((class (second kmexpr))) ; (a Car [with ...]) (record-explanation-for `#$(the instance-of of ,(FIRST ANSWER)) class kmexpr-with-comments)))))) ; (if (and *trace-log-on* (not *am-classifying*)) ; **** another NEW LINE ; (setq *trace-log* (cons `(,*depth* exit ,kmexpr-with-comments ,answer) *trace-log*))) ; **** NEW LINE (cond ((or *catch-explanations* *print-explanations*) (catch-explanation kmexpr-with-comments (cond (answer 'exit) (t 'fail))))) (cond (*profiling* (profile-exit (desource kmexpr)))) (let ( (users-response (cond (answer (cond (target (km-trace 'exit "<- ~a~40T [~a, for ~a]" answer kmexpr-with-comments target)) (t (km-trace 'exit "<- ~a~40T [~a]" answer kmexpr-with-comments)))) (t (cond (target (km-trace 'fail "<- FAIL!~40T [~a, for ~a]" kmexpr-with-comments target)) (t (km-trace 'fail "<- FAIL!~40T [~a]" kmexpr-with-comments)))))) ) (cond ((eq users-response 'redo) (reset-done) (km1 kmexpr kmexpr-with-comments :fail-mode fail-mode :target target :rewritep rewritep)) ((eq users-response 'fail) ; resets answer to be NIL [doesn't destroy cached non-nil answers though!] (increment-trace-depth) ; put *depth* back to where it was (process-km1-result nil kmexpr kmexpr-with-comments :fail-mode fail-mode :target target :handler-pattern handler-pattern)) (t answer)))) ;;; ---------------------------------------- ;;; km-unique: Expected to return EXACTLY *one* value, otherwise a warning is generated. ;;; ---------------------------------------- ;;; Backwards-compatibility: (km-unique0 ...) now synonymous with (km-unique ...) (defun km-unique0 (kmexpr &key (fail-mode (cond (*am-reasoning* *default-fail-mode*) (t *top-level-fail-mode*)))) (km-unique kmexpr :fail-mode fail-mode)) ;;; EXTERNAL, from some other application - rewritten 1/19/08 to be identical in structure to (defun km ...) (defun km-unique (kmexpr &key (fail-mode (cond (*am-reasoning* *default-fail-mode*) (t *top-level-fail-mode*)))) (cond (*am-reasoning* (km-unique-int kmexpr :fail-mode fail-mode)) ; km-unique -> km-unique-int if *am-reasoning* already (t (let ((*am-reasoning* t) ; so must be top-level KM call (*warnings* nil)) (reset-for-top-level-call kmexpr) (let ((answer (catch 'km-abort (desource (km-unique-int kmexpr :fail-mode fail-mode))))) (cond ((and (listp answer) (eq (first answer) 'km-abort)) ; error encountered (values nil (second answer) (third answer) (reverse *warnings*))) (*warnings* (values answer nil nil (reverse *warnings*))) (t answer))))))) #| ;;; EXTERNAL, from some other application (defun km-unique (kmexpr &key (fail-mode *top-level-fail-mode*)) (reset-inference-engine) (let ( (answer (catch 'km-abort (km-unique-int kmexpr :fail-mode fail-mode))) ) (cond ((and (pairp answer) (eq (first answer) 'km-abort)) ; error encountered (values nil (second answer))) (t answer)))) |# ;;; ---------- ;;; INTERNAL, from within KM itself. (defun km-unique-int (kmexpr &key (fail-mode (cond (*am-reasoning* *default-fail-mode*) (t *top-level-fail-mode*))) target rewritep) (cond ((null *am-reasoning*) (km-unique kmexpr :fail-mode fail-mode)) ; if called from top-level call (in-situation ...) say (t (let ( (vals (km-int kmexpr :fail-mode fail-mode :target target :rewritep rewritep)) ) (cond ((singletonp vals) (first vals)) (vals (report-error 'user-error "Expression ~a was expected to return a single value, but it returned multiple values ~a! Just taking the first...(~a) ~%" kmexpr vals (first vals)) (first vals)) ((eq fail-mode 'error) (report-error 'user-error "Expression ~a didn't return a value!~%" kmexpr))))))) ;;; ====================================================================== ;;; Handle case-sensitivity and quoted morphism table in load-kb expression ;;; (load-kb "foo.km" :verbose t :with-morphism '((a -> 1) (b -> 2))) (defun process-load-expression (load-expr0) (let* ((load-expr1 (sublis '((#$:verbose . :verbose) ; :verbose -> :VERBOSE etc. (#$:eval-instances . :eval-instances) (#$:with-morphism . :with-morphism) (#$:load-patterns . :load-patterns) (#$:reset-kb . :reset-kb) (#$:force-fkm . :force-fkm) (#$:compile . :compile) (#$t . t)) load-expr0)) (load-expr (cons (intern (string-upcase (first load-expr1)) *km-package*) ; (|load-kb| ...) -> (LOAD-KB ...) (rest load-expr1)))) ; (km-format t "load-expr = ~a~%" load-expr) (multiple-value-bind (result error) (eval load-expr) (declare (ignore result)) (cond (error (princ error) (throw 'km-abort (list 'km-abort error))) ; (format t "~/home") gives format error! (t '#$(t)))))) ;;; ====================================================================== ;;; The association list is a set of pairs of form (pattern function). ;;; Function gets applied to the values of variables in pattern, the ;;; values stored in a list in the order they were encountered ;;; when (depth-first) traversing the km expression. ;;; Below: two alternative ways of embedding Lisp code ;;; `,#'(lambda () ....) <- marginally faster, but can't be manipulated ;;; '(lambda (...)) ;;; 4.15.99 Changed `(a ,frame with . ,slotsvals) to `(a ,frame with ,@slotsvals), as Lucid problem ;;; for writing out the flattened-out code: ;;; (write '`(a ,frame with . ,slotsvals)) -> `(A ,FRAME WITH EXCL::BQ-COMMA SLOTSVALS) = Lucid-specific!! ;;; (write '`(a ,frame with ,@slotsvals)) -> `(A ,FRAME WITH ,@SLOTSVALS) = readable by other Lisps ;;; v1.4.0 - order in terms of utility for speed! ;; split this list initialization into 2, since ABCL can't handle such a long structure def (setf *km-handler-alist1* '( ;;; [1] NEW: Here make another top level call, so ;;; (i) the trace is easier to follow during debugging ;;; (ii) the looping checker jumps in at the right moment ;;; [2] This is a bit of a hack; with looping, e.g. another query higher in the stack for (((a Cat)) && (the cats of Sue)), ;;; KM may possibly return structured answers e.g. ((a Cat) (the cats of Sue)). Need to remove the non-evaluated ones (urgh). ;;; See test-suite/restaurant.km for the source of this patch. ;;; [3] New! Remove the transitivity incompleteness described in the user manual ( (#$the ?slot #$of ?frameadd) (lambda (fmode0 _target slot frameadd) (declare (ignore _target)) ; (cond ((neq slot '#$instances) (check-situations-mode))) ; allow query for instances to slip through, for internal (all-instances) queries (cond ((structured-slotp slot) (follow-multidepth-path (km-int frameadd :fail-mode fmode0) ; start-values slot '* :fail-mode fmode0)) ; target-class = * ((pathp slot) (let ( (eval-slot (km-unique-int slot :fail-mode 'error)) ) (km-int `#$(the ,EVAL-SLOT of ,FRAMEADD) :fail-mode fmode0))) (t ; (km-format t "frameadd = ~a~%" frameadd) (let* ( (fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0))) ; OLD (frames (km-int frameadd :fail-mode fmode)) ) ; Now we at least see the looping and collect cached values (frames (cond ((every #'is-simple-km-term (val-to-vals frameadd)) ; [4] ; (km-format t "Infinite recursion avoided for ~a!~%" `#$(the ,SLOT of ,FRAMEADD)) (remove-dup-instances (val-to-vals frameadd))) ; includes dereferencing (t (km-int frameadd :fail-mode fmode :check-for-looping nil)))) ) ; [3] (cond ((= *depth* 1) (setq *last-question* `(#$the ,slot #$of ,(vals-to-val frames))))) ; for explanation (cond ((not (equal frames (val-to-vals frameadd))) (remove-if-not #'is-km-term (km-int `#$(the ,SLOT of ,(VALS-TO-VAL FRAMES)) :fail-mode fmode))) ; [1], [2] (t (remove-if-not #'is-km-term (km-multi-slotvals frames slot :fail-mode fmode)))))))) ) ; [2] ; No, filter needs to be on ALL retrieved values, not just (the of ) expressions ; (let ((vals (cond ((not (equal frames (val-to-vals frameadd))) ; (remove-if-not #'is-km-term ; (km-int `#$(the ,SLOT of ,(VALS-TO-VAL FRAMES)) :fail-mode fmode))) ; [1], [2] ; (t (remove-if-not #'is-km-term ; (km-multi-slotvals frames slot :fail-mode fmode)))))) ; [2] ; (case slot ; (#$nowexists vals) ; (t (remove-if-not #'nowexists vals)))))))) ) ( (#$a ?class) (lambda (_fmode target class) (declare (ignore _fmode)) (list (create-instance class nil :target target))) ) ( (#$a ?class #$called ?tag) (lambda (_fmode target class tag) (declare (ignore _fmode)) (km-setq '*are-some-tags* t) (cond ((km-tagp tag) (list (create-instance class `((#$called ,(VAL-TO-VALS TAG))) :target target))) (t (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS called ,TAG) tag))))) ( (#$a ?class #$uniquely-called ?tag) (lambda (_fmode target class tag) (declare (ignore _fmode)) (km-setq '*are-some-constraints* t) (km-setq '*are-some-tags* t) (cond ((km-tagp tag) (list (create-instance class `((#$uniquely-called ,(VAL-TO-VALS TAG))) :target target))) (t (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS uniquely-called ,TAG) tag))))) ( (#$a ?class #$with &rest) (lambda (_fmode target class slotsvals) (declare (ignore _fmode)) (cond ((are-slotsvals slotsvals) (let ( (instance (create-instance class (convert-comments-to-internal-form slotsvals) :target target)) ) (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) ( (#$a ?class #$uniquely-called ?tag #$with &rest) (lambda (_fmode target class tag slotsvals) (declare (ignore _fmode)) (km-setq '*are-some-constraints* t) (km-setq '*are-some-tags* t) (cond ((not (km-tagp tag)) (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS uniquely-called ,TAG with ,@SLOTSVALS) tag)) ((are-slotsvals slotsvals) (let ( (instance (create-instance class (cons `(#$uniquely-called ,(VAL-TO-VALS TAG)) (convert-comments-to-internal-form slotsvals)) :target target)) ) (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) ( (#$a ?class #$called ?tag #$with &rest) (lambda (_fmode target class tag slotsvals) (declare (ignore _fmode)) (km-setq '*are-some-tags* t) (cond ((not (km-tagp tag)) (report-error 'user-error "~a~% - The tag `~a' must be an atom or a constraint!" `#$(a ,CLASS called ,TAG with ,@SLOTSVALS) tag)) ((are-slotsvals slotsvals) (let ( (instance (create-instance class (cons `(#$called ,(VAL-TO-VALS TAG)) (convert-comments-to-internal-form slotsvals)) :target target)) ) (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) ;;; ====================================================================== ;;; PROTOTYPES ;;; ====================================================================== ( (#$a-prototype ?class) (lambda (fmode target class) (km-int `#$(a-prototype ,CLASS with) :fail-mode fmode :target target :rewritep t)) ) ; rewrite, errors caught below ( (#$a-prototype ?class #$with &rest) (lambda (_fmode _target class slotsvals) (declare (ignore _fmode _target)) (cond ((am-in-local-situation) (report-error 'user-error "Can't enter prototype mode when in a Situation!~%")) ((am-in-prototype-mode) (report-error 'user-error "~a~%Attempt to enter prototype mode while already in prototype mode (not allowed)!~%Perhaps you are missing an (end-prototype)?" `#$(a-prototype ,CLASS with ,@SLOTSVALS))) ((are-slotsvals slotsvals) (new-context) (km-setq '*curr-prototype* (create-instance class `#$((prototype-of (,CLASS)) ; ,(COND (SLOTSVALS `(prototype-scope ('(a ,CLASS with ,@SLOTSVALS)))) ,(COND (SLOTSVALS `(prototype-scope ((the-class ,CLASS with ,@SLOTSVALS)))) (T `(prototype-scope (,CLASS)))) ,@SLOTSVALS) :prefix-string *proto-marker-string* ; ie. "_Proto" :bind-selfp nil)) ; bind-selfp = nil - PRESERVE "Self" in prototype-scope (add-val *curr-prototype* '#$prototype-participants *curr-prototype*) ; consistency (km-setq '*are-some-prototypes* t) ; optimization flag (cond ((null slotsvals) (add-to-prototype-definition *curr-prototype* `(#$a-prototoype ,class))) (t (add-to-prototype-definition *curr-prototype* `(#$a-prototype ,class #$with ,@slotsvals)))) (list *curr-prototype*)))) ) ( (#$end-prototype) (lambda (_fmode _target) (declare (ignore _fmode _target)) (km-setq '*curr-prototype* nil) (global-situation) (new-context) '#$(t)) ) ( (#$clone ?expr) (lambda (_fmode _target expr) (declare (ignore _fmode _target)) (let ( (source (km-unique-int expr :fail-mode 'error)) ) (cond (source (list (clone source)))))) ) ( (#$evaluate-paths) (lambda (_fmode _target) (declare (ignore _fmode _target)) (eval-instances) '#$(t)) ) ( (#$default-fluent-status &rest) (lambda (_fmode _target rest) (declare (ignore _fmode _target)) (default-fluent-status (first rest))) ) ;;; ---------------------------------------------------------------------- ;;; Type constraints don't get evaluated. ( (#$must-be-a ?class) (lambda (_fmode _target _class) (declare (ignore _fmode _target _class)) (note-are-constraints) nil)) ( (#$possible-values ?values) (lambda (_fmode _target _values) (declare (ignore _fmode _target _values)) (note-are-constraints) nil)) ( (#$excluded-values ?values) (lambda (_fmode _target _values) (declare (ignore _fmode _target _values)) (note-are-constraints) nil)) ( (#$must-be-a ?class #$with &rest) (lambda (_fmode _target _class slotsvals) (declare (ignore _fmode _target _class)) (are-slotsvals slotsvals) ; Syntax check (note-are-constraints) nil)) ( (#$mustnt-be-a ?class) (lambda (_fmode _target _class) (declare (ignore _fmode _target _class)) (note-are-constraints) nil) ) ( (#$mustnt-be-a ?class #$with &rest) (lambda (_fmode _target _class slotsvals) (declare (ignore _fmode _target _class)) (are-slotsvals slotsvals) ; Syntax check (note-are-constraints) nil)) ;;; New 1.4.0-beta10: ( (<> ?val) ; ie. means isn't val (lambda (_fmode _target _val) (declare (ignore _fmode _target _val)) (note-are-constraints) nil)) ( (#$no-inheritance) (lambda (_fmode _target) (declare (ignore _fmode _target))) nil ) ( (#$constraint ?expr) ; constraints tested elsewhere (lambda (_fmode _target _expr) (declare (ignore _fmode _target _expr)) (note-are-constraints) nil) ) ( (#$set-constraint ?expr) ; constraints tested elsewhere (lambda (_fmode _target _expr) (declare (ignore _fmode _target _expr)) (note-are-constraints) nil) ) ( (#$set-filter ?expr) ; constraints tested elsewhere (lambda (_fmode _target _expr) (declare (ignore _fmode _target _expr)) (note-are-constraints) nil) ) ( (#$at-least ?n ?class) (lambda (_fmode _target _n _class) (declare (ignore _fmode _target _n _class)) (note-are-constraints) nil) ) ( (#$at-most ?n ?class) (lambda (_fmode _target _n _class) (declare (ignore _fmode _target _n _class)) (note-are-constraints) nil) ) ( (#$exactly ?n ?class) (lambda (_fmode _target _n _class) (declare (ignore _fmode _target _n _class)) (note-are-constraints) nil) ) ( (#$sanity-check ?expr) ; toggleable wrapper around constraints (lambda (fmode target expr) (cond (*sanity-checks* (km-int expr :fail-mode fmode :target target)) (t '#$(t)))) ) ((#$retain-expr ?expr) (lambda (fmode target expr) (let ((instance (fourth target)) (slot (second target))) (cond ((or (null target) (notany #'(lambda (isv-explanation) (let ((explanation (explanation-in isv-explanation))) (equal explanation `(#$retain-expr ,expr)))) (get-all-explanations instance slot))) (km-int expr :fail-mode fmode :target target))))) ) ; ---------------------------------------- ; ============================ ; AUGMENTING MEMBER PROPERTIES ; ============================ ( (#$every ?cexpr #$has &rest) (lambda (_fmode _target cexpr slotsvals) (declare (ignore _fmode _target)) (let ( (class (km-unique-int cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$has ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) ; check (let* ( (slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00)) ) (add-slotsvals class slotsvals0 :facet 'member-properties :install-inversesp nil)) (cond ((and (assoc '#$assertions slotsvals) (not (member class *classes-using-assertions-slot*))) (km-setq '*classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) (mapc #'un-done (all-instances class)) (list class)))))) ( (#$every ?cexpr #$also-has &rest) (lambda (_fmode _target cexpr slotsvals) (declare (ignore _fmode _target)) (let ( (class (km-unique-int cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$also-has ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) ; check (let* ( (slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00)) ) (add-slotsvals class slotsvals0 :facet 'member-properties :install-inversesp nil :combine-values-by 'appending)) (cond ((and (assoc '#$assertions slotsvals) (not (member class *classes-using-assertions-slot*))) ; (setq *classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) ; (make-transaction `(setq *classes-using-assertions-slot* ,(cons class *classes-using-assertions-slot*))))) (km-setq '*classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) (mapc #'un-done (all-instances class)) (list class)))))) ( (#$every ?cexpr #$now-has &rest) (lambda (_fmode _target cexpr slotsvals) (declare (ignore _fmode _target)) (let ( (class (km-unique-int cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$now-has ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) ; check (let* ( (slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00)) ) (add-slotsvals class slotsvals0 :facet 'member-properties :install-inversesp nil :combine-values-by 'overwriting)) (cond ((and (assoc '#$assertions slotsvals) (not (member class *classes-using-assertions-slot*))) ; (setq *classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) ; (make-transaction `(setq *classes-using-assertions-slot* ,(cons class *classes-using-assertions-slot*))))) (km-setq '*classes-using-assertions-slot* (cons class *classes-using-assertions-slot*)))) (mapc #'un-done (all-instances class)) (list class))))) ) ; ========================= ; AUGMENTING OWN PROPERTIES ; ========================= ( (?instance-expr #$has &rest) (lambda (_fmode _target instance-expr slotsvals) (declare (ignore _fmode _target)) (let ( (instance (km-unique-int instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr #$has ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (add-slotsvals instance (convert-comments-to-internal-form slotsvals)) (make-assertions instance slotsvals) (un-done instance) ; In case redefinition - now in put-slotsvals; Later: No!! (classify instance :slots-that-changed (mapcar #'slot-in slotsvals)) ; Because it's an instance (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) )) ;; end part 1 of list init (setf *km-handler-alist2* ;; part 2 of the list '( ( (?instance-expr #$also-has &rest) (lambda (_fmode _target instance-expr slotsvals) (declare (ignore _fmode _target)) (let ( (instance (km-unique-int instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr #$also-has ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (add-slotsvals instance (convert-comments-to-internal-form slotsvals) :combine-values-by 'appending) (un-done instance) ; In case redefinition - now in put-slotsvals; Later: No!! (classify instance :slots-that-changed (mapcar #'slot-in slotsvals)) ; Because it's an instance (cond ((am-in-prototype-mode) (km-int '#$(evaluate-paths)))) ; route through interpreter for tracing + loop detection (list instance))))) ) ((#$every ?instance-expr #$also-hasnt &rest) (lambda (_fmode _target instance-expr slotsvals) (declare (ignore _fmode _target)) (report-error 'user-error "~a:~%Can't use also-hasnt with an \"every\" expression (can only use it with instances, not classes)~%" `(#$every ,instance-expr #$also-hasnt ,@slotsvals)))) ;;; USE WITH EXTREME CAUTION ( (?instance-expr #$also-hasnt &rest) (lambda (_fmode _target instance-expr slotsvals) (declare (ignore _fmode _target)) (let ( (instance (km-unique-int instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr #$also-has ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (mapc #'(lambda (slotvals) (let ((slot (slot-in slotvals)) (vals (vals-in slotvals))) (mapc #'(lambda (val) (delete-val instance slot val)) vals))) slotsvals) (un-done instance) ; In case redefinition - now in put-slotsvals; Later: No!! (list instance))))) ) ;;; New, explicitly for Shaken. The new slotsvals OVERWRITE the old slotsvals, so must be used with extreme caution! ;;; Old inverses will also uninstalled providing they are fully-evaluated KB objects. ( (?instance-expr #$now-has &rest) (lambda (_fmode _target instance-expr slotsvals) (declare (ignore _fmode _target)) (let ( (instance (km-unique-int instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(,instance-expr #$now-has ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (add-slotsvals instance (convert-comments-to-internal-form slotsvals) :combine-values-by 'overwriting) ; Neah, let's assume these things better not change!! (un-done instance) ; In case redefinition - now in put-slotsvals; Later: No!! (classify instance) ; Because it's an instance ;#|new|# (cond ((am-in-prototype-mode) ; ; (eval-instances) ; (km-int '#$(evaluate-paths) :fail-mode 'error))) ; new: route through query interpreter for tracing and also loop detection (list instance))))) ) ;;; ---------------------------------------------------------------------- ;;; UNIFICIATION - now off-load to special procedure in lazy-unify.lisp ;;; ---------------------------------------------------------------------- ( (?xs && &rest) (lambda (fmode target xs rest) (declare (ignore fmode)) ; (km-format t "xs = ~a~%rest = ~a~%" xs rest) (lazy-unify-&-expr `(,xs && ,@rest) :fail-mode 'error :joiner '&& :target target)) ) ( (?x & &rest) (lambda (fmode target x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x & ,@rest) :fail-mode 'error :joiner '& :target target)) ) ( (?xs === &rest) (lambda (fmode target xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs === ,@rest) :fail-mode 'error :joiner '=== :target target)) ) ( (?x == ?y) (lambda (fmode target x y) (declare (ignore fmode)) (lazy-unify-&-expr `(,x == ,y) :fail-mode 'error :joiner '== :target target)) ) ( (?x /== ?y) (lambda (fmode target x y) (declare (ignore fmode target)) (let ( (xv (km-unique-int x :fail-mode 'error)) (yv (km-unique-int y :fail-mode 'error)) ) (cond ((equal xv yv) (report-error 'user-error "(~a /== ~a): ~a and ~a are the same object!~%" x y x y)) ((kb-objectp xv) (km-int `#$(,XV has (/== (,YV))) :fail-mode 'error)) ((kb-objectp yv) (km-int `#$(,YV has (/== (,XV))) :fail-mode 'error)) ('#$(t))))) ) ; two distinct, non-KB objects eg. ("cat" /== "dog") ;;; These variants do eager unification ( (?xs &&! &rest) (lambda (fmode target xs rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,xs &&! ,@rest) :fail-mode 'error :joiner '&&! :target target)) ) ( (?x &! &rest) (lambda (fmode target x rest) (declare (ignore fmode)) (lazy-unify-&-expr `(,x &! ,@rest) :fail-mode 'error :joiner '&! :target target)) ) ;;; NEW VERSION: Avoids creating then deleting the temporary frame ( (?x &? ?y) ; *tests* unification. No side effects. Returns a better unification expression if successful. (lambda (_fmode target x y) (declare (ignore _fmode target)) (cond ((null x) '#$(t)) ((null y) '#$(t)) ((existential-exprp y) (let ( (xf (km-unique-int x)) ) (cond ((null xf) '#$(t)) ((unifiable-with-existential-expr xf y) '#$(t))))) ((existential-exprp x) (let ( (yf (km-unique-int y)) ) (cond ((null yf) '#$(t)) ((unifiable-with-existential-expr yf x) '#$(t))))) (t (let ( (xv (km-unique-int x)) ) (cond ((null xv) '#$(t)) (t (let ( (yv (km-unique-int y)) ) (cond ((null yv) '#$(t)) ((try-lazy-unify xv yv) '#$(t))))))))))) ; return "t" if successful ;;; SAME, but insist on classes-subsume constraint turned ON... ( (?x &+? ?y) ; *tests* unification. No side effects. Returns a better unification expression if successful. (lambda (_fmode target x y) (declare (ignore _fmode target)) (cond ((existential-exprp y) (let ( (xf (km-unique-int x)) ) (cond ((null xf) '#$(t)) ((unifiable-with-existential-expr xf y :classes-subsumep t) '#$(t))))) ((existential-exprp x) (let ( (yf (km-unique-int y)) ) (cond ((null yf) '#$(t)) ((unifiable-with-existential-expr yf x :classes-subsumep t) '#$(t))))) (t (let ( (xv (km-unique-int x)) ) (cond ((null xv) '#$(t)) (t (let ( (yv (km-unique-int y)) ) (cond ((null yv) '#$(t)) ((try-lazy-unify xv yv :classes-subsumep t) '#$(t))))))))))) ; return "t" if successful ;;; ---------- Unification, but with classes-subsumep constraint turned ON ;;;; Unification, but with classes-subsumep constraint turned ON ;;; If unification fails, it returns NIL but no error is printed out. ;;; &+ is more restricted than & (at least for now), it won't nicely break up nested ;;; expressions. ( (?x &+ ?y) (lambda (fmode target x y) (let ( (unification (lazy-unify-exprs x y :classes-subsumep t :fail-mode fmode :target target)) ) (cond (unification (list unification)) ((eq fmode 'error) (report-error 'user-error "Unification (~a &+ ~a) failed!~%" x y))))) ) ;;; ---------------------------------------- ;;; This is a special case where we do allow delistification. ;;; "(the x of y) = z" is okay [strictly should be (the x of y) = (:set z)] ;;; [1] In computing yv, the binding of xv may have changed! ( (?x = ?y) (lambda (fmode target x y) (declare (ignore target)) (let ( (xv (km-int x :fail-mode fmode)) (yv (km-int y :fail-mode fmode)) ) (cond ((km-set-equal (dereference xv) yv) '(#$t))))) ) ; [1] ( (?x /= ?y) (lambda (fmode target x y) (declare (ignore target)) (let ( (xv (km-int x :fail-mode fmode)) (yv (km-int y :fail-mode fmode)) ) (cond ((not (km-set-equal (dereference xv) yv)) '(#$t))))) ) ; [1] ( (#$the ?class ?slot #$of ?frameadd) (lambda (fmode0 target class slot frameadd) ; (cond ((neq slot '#$instances) (check-situations-mode))) ; allow query for instances to slip through, for internal (all-instances) queries (cond ((structured-slotp slot) (follow-multidepth-path (km-int frameadd :fail-mode fmode0 :target target :rewritep t) ; start-values slot class :fail-mode fmode0)) ((pathp slot) (let ( (eval-slot (km-unique-int slot :fail-mode 'error)) ) (km-int `#$(the ,CLASS ,EVAL-SLOT of ,FRAMEADD) :fail-mode fmode0 :target target :rewritep t))) (t (let* ( (fmode (cond ((built-in-aggregation-slot slot) 'fail) (t fmode0))) ) (vals-in-class (km-int `#$(the ,SLOT of ,FRAMEADD) :fail-mode fmode :target target :rewritep t) class))))) ) ;;; ====================================================================== ;;; THEORIES - NEW ;;; ====================================================================== ( (#$in-theory ?theory-expr) (lambda (_fmode _target theory-expr) (declare (ignore _fmode _target)) (in-theory theory-expr)) ) ( (#$in-theory ?theory-expr ?km-expr) (lambda (_fmode _target theory-expr km-expr) (declare (ignore _fmode _target)) (in-theory theory-expr km-expr)) ) ( (#$hide-theory ?theory-expr) (lambda (_fmode _target theory-expr) (declare (ignore _fmode _target)) (mapc #'hide-theory (km-int theory-expr)) (cond ((visible-theories)) (t '#$(t))))) ( (#$see-theory ?theory-expr) (lambda (_fmode _target theory-expr) (declare (ignore _fmode _target)) (mapc #'see-theory (km-int theory-expr)) (visible-theories)) ) ( (#$end-theory) (lambda (_fmode _target) (declare (ignore _fmode _target)) (in-situation *global-situation*)) ) ( (#$visible-theories) (lambda (_fmode _target) (declare (ignore _fmode _target)) (visible-theories)) ) ;;; ====================================================================== ;;; SITUATIONS: Pass these KM commands straight to Lisp ;;; Note if these are issued directly from Lisp, then the KM exprs have to be quoted. ;;; ====================================================================== ( (#$in-situation ?situation-expr) (lambda (_fmode _target situation-expr) (declare (ignore _fmode _target)) (in-situation situation-expr)) ) ( (#$in-situation ?situation (#$the ?slot #$of ?frame)) ; special fast handling of this: If (lambda (_fmode _target situation slot frame) ; the slot-vals are already computed ([1]) (declare (ignore _fmode _target)) ; then just do a lookup ([2]) (cond ((and (kb-objectp situation) (isa situation '#$Situation) ; APR30 (already-done frame slot situation)) ; [1] (already-done frame slot)) ; [1] #|OLD|# (remove-constraints (get-vals frame slot :situation (target-situation situation frame slot)))) ; [2] ;#|NEW|# (get-vals-in-cache frame slot :situation situation)) (t (in-situation situation `#$(the ,SLOT of ,FRAME))))) ) ( (#$in-situation ?situation-expr ?km-expr) (lambda (_fmode _target situation-expr km-expr) (declare (ignore _fmode _target)) (in-situation situation-expr km-expr)) ) ( (#$end-situation) (lambda (_fmode _target) (declare (ignore _fmode _target)) (in-situation *global-situation*)) ) ( (#$global-situation) (lambda (_fmode _target) (declare (ignore _fmode _target)) (in-situation *global-situation*)) ) ( (#$new-situation) (lambda (_fmode _target) (declare (ignore _fmode _target)) (new-situation)) ) ; NB returns a singleton list containing the new situation ;;; ---------------------------------------- ( (#$do ?action-expr) (lambda (_fmode _target action-expr) (declare (ignore _fmode _target)) (list (do-action action-expr))) ) ; NB do-action returns a SINGLE value (a situation), not a list. ( (#$do ?action-expr ?next-situation) (lambda (_fmode _target action-expr next-situation) (declare (ignore _fmode _target)) (cond ((not (instance-of next-situation '#$Situation)) (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" action-expr next-situation next-situation)) (t (list (do-action action-expr :next-situation next-situation))))) ) ( (#$do-and-next ?action-expr) (lambda (_fmode _target action-expr) (declare (ignore _fmode _target)) (list (do-action action-expr :change-to-next-situation t))) ) ( (#$do-and-next ?action-expr ?next-situation) (lambda (_fmode _target action-expr next-situation) (declare (ignore _fmode _target)) (cond ((not (instance-of next-situation '#$Situation)) (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" action-expr next-situation next-situation)) (t (list (do-action action-expr :next-situation next-situation :change-to-next-situation t))))) ) ;;; New ( (#$try-do ?action-expr) (lambda (_fmode _target action-expr) (declare (ignore _fmode _target)) (list (do-action action-expr :test-or-assert-pcs 'test))) ) ; NB do-action returns a SINGLE value (a situation), not a list. ( (#$try-do ?action-expr ?next-situation) (lambda (_fmode _target action-expr next-situation) (declare (ignore _fmode _target)) (cond ((not (instance-of next-situation '#$Situation)) (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" action-expr next-situation next-situation)) (t (list (do-action action-expr :next-situation next-situation :test-or-assert-pcs 'test))))) ) ( (#$try-do-and-next ?action-expr) (lambda (_fmode _target action-expr) (declare (ignore _fmode _target)) (list (do-action action-expr :change-to-next-situation t :test-or-assert-pcs 'test))) ) ( (#$try-do-and-next ?action-expr ?next-situation) (lambda (_fmode _target action-expr next-situation) (declare (ignore _fmode _target)) (cond ((not (instance-of next-situation '#$Situation)) (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" action-expr next-situation next-situation)) (t (list (do-action action-expr :next-situation next-situation :change-to-next-situation t :test-or-assert-pcs 'test))))) ) ( (#$do-concurrently ?action-expr) (lambda (_fmode _target action-expr) (declare (ignore _fmode _target)) (let* ((actions (km-int action-expr)) (next-situation (km-unique-int `#$(do ,(FIRST ACTIONS))))) (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) (rest actions)) (list next-situation))) ) ( (#$do-concurrently ?action-expr ?next-situation) (lambda (_fmode _target action-expr next-situation) (declare (ignore _fmode _target)) (cond ((not (instance-of next-situation '#$Situation)) (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" action-expr next-situation next-situation)) (t (let ((actions (km-int action-expr))) (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) actions) (list next-situation))))) ) ( (#$do-concurrently-and-next ?action-expr) (lambda (_fmode _target action-expr) (declare (ignore _fmode _target)) (let* ((actions (km-int action-expr)) (next-situation (km-unique-int `#$(do ,(FIRST ACTIONS))))) (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) (rest actions)) (in-situation next-situation) (list next-situation))) ) ( (#$do-concurrently-and-next ?action-expr ?next-situation) (lambda (_fmode _target action-expr next-situation) (declare (ignore _fmode _target)) (cond ((not (instance-of next-situation '#$Situation)) (report-error 'user-error "(do ~a ~a): ~a should be an instance of Situation, but isn't!~%" action-expr next-situation next-situation)) (t (let ((actions (km-int action-expr))) (mapc #'(lambda (action) (km-int `#$(do ,ACTION ,NEXT-SITUATION))) actions) (in-situation next-situation) (list next-situation))))) ) ;;; Now returns the list of successful actions ( (#$do-script ?script) (lambda (fmode target script) (km-int `#$(forall (the actions of ,SCRIPT) (do-and-next It)) :fail-mode fmode :target target :rewritep t)) ) ( (#$do-plan ?plan-instance-expr) (lambda (_fmode _target plan-instance-expr) (declare (ignore _fmode _target)) (let ( (plan-instance (km-unique plan-instance-expr)) ) (do-plan plan-instance))) ) ; defined in sadl.lisp ;;; ---------------------------------------- ;;; Should even work for constraints ( (#$assert ?triple-expr) (lambda (_fmode _target triple-expr) (declare (ignore _fmode _target)) (let ( (triple (km-unique-int triple-expr)) ) (cond ((not (km-triplep triple)) (report-error 'user-error "(assert ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" triple-expr triple)) (t (km-int `#$(,(ARG1OF TRIPLE) has (,(ARG2OF TRIPLE) ,(VAL-TO-VALS (ARG3OF TRIPLE)))) :fail-mode 'error))))) ) ( (#$is-true ?triple-expr) (lambda (_fmode _target triple-expr) (declare (ignore _fmode _target)) (let* ( (triple (km-unique-int triple-expr)) ) (cond ((not (km-triplep triple)) (report-error 'user-error "(is-true ~a): ~a should evaluate to a triple! (evaluated to ~a instead)!~%" triple-expr triple)) ((comparison-operator (arg2of triple)) (km-int `#$(,(SECOND TRIPLE) ,(THIRD TRIPLE) ,(FOURTH TRIPLE)))) (t (let ( (frame (km-unique-int (second triple) :fail-mode 'error)) (slot (km-unique-int (third triple) :fail-mode 'error)) (value (fourth triple)) ) ; don't evaluate this! (cond ((null value) '#$(t)) ((km-int `#$(,FRAME is '(a Thing with (,SLOT (,VALUE)))))))))))) ) ; ((constraint-exprp value) ; (km-int `#$(,FRAME &? (a Thing with (,SLOT (,VALUE)))))) ; (t (km-int `#$((the ,SLOT of ,FRAME) includes ,VALUE))))))))) ) ( (#$all-true ?triples-expr) (lambda (_fmode _target triples-expr) (declare (ignore _fmode _target)) (let ( (triples (km-int triples-expr)) ) (cond ((every #'(lambda (triple) (km-int `#$(is-true ,TRIPLE))) triples) '#$(t)))))) ( (#$some-true ?triples-expr) (lambda (_fmode _target triples-expr) (declare (ignore _fmode _target)) (let ( (triples (km-int triples-expr)) ) (cond ((some #'(lambda (triple) (km-int `#$(is-true ,TRIPLE))) triples) '#$(t)))))) ;;; ---------------------------------------- ( #$(next-situation) (lambda (_fmode _target) (declare (ignore _fmode _target)) (cond ((am-in-local-situation) (list (do-action nil :change-to-next-situation t))) (t (report-error 'user-error "Can only do (next-situation) from within a situation!~%"))))) ( #$(curr-situation) (lambda (_fmode _target) (declare (ignore _fmode _target)) (list (curr-situation))) ) ( (#$ignore-result ?expr) ; return t always (lambda (fmode target expr) (declare (ignore fmode target)) (km-int expr) nil)) ( (#$ignore ?expr) ; return t always (lambda (fmode target expr) (declare (ignore fmode target expr)) nil)) ; Important v1.3.8 addition! ; expr should be an assertional expression ( (#$in-every-situation ?situation-class ?expr) (lambda (fmode target situation-class km-expr) (cond ((not (is-subclass-of situation-class '#$Situation)) (report-error 'user-error "~a:~% Can't do this! (~a is not a subclass of Situation!)~%" `#$(in-every-situation ,SITUATION-CLASS ,KM-EXPR) situation-class)) (t (let ( (modified-expr (sublis '#$((TheSituation . #,Self) (Self . SubSelf)) km-expr)) ) (km-int `#$(in-situation ,*GLOBAL-SITUATION* (every ,SITUATION-CLASS has (assertions (',MODIFIED-EXPR)))) :fail-mode fmode :target target :rewritep t))))) ) ;;; ====================================================================== ;;; CONTEXTS - Very experimental!! ;;; These are distinct from situations. A situation is a version of the KB. ;;; A context is where just the participant instances are visible. ;;; ====================================================================== ( #$(new-context) (lambda (_fmode _target) (declare (ignore _fmode _target)) (clear-obj-stack) ; NEW. Let obj-stack be the context '#$(t)) ) ;;; ====================================================================== ;;; the ordering of the remaining handers is arbitrary ;;; ====================================================================== ;;; ======================================== ;;; QUICK SEARCH OF THE STACK (previously was "the" rather than "that") ;;; ======================================== ;;; Now merged into the single framework of subsumption checking. ( (#$thelast ?frame) (lambda (_fmode _target frame) (declare (ignore _fmode _target)) (let ( (last-instance (search-stack frame)) ) (cond (last-instance (list last-instance))))) ) ;;; ======================================== ;;; FIND OBJECTS BY SUBSUMPTION CHECKING ;;; ======================================== ( (#$every ?frame) (lambda (fmode target frame) (km-int `(#$every ,frame #$with) :fail-mode fmode :target target :rewritep t)) ) ( (#$every ?frame #$with &rest) (lambda (_fmode _target frame slotsvals) (declare (ignore _fmode _target)) (cond ((are-slotsvals slotsvals) (let ( (existential-expr (cond ((and (null slotsvals) (pathp frame)) ; eg. (the (porter owns car)) (path-to-existential-expr frame)) (t `(#$a ,frame #$with ,@slotsvals)))) ) (find-subsumees-on-object-stack existential-expr))))) ) ;;; (the ...) -- expects a unique answer ;;; REDEFINITIONS: ;;; (the ...) -> (find-the ...) ;;; (forc (the ...)) -> (the ...) ;;; 2.29.00 - the below is more verbose, to give better error messages during debugging. ;;; (The earlier version just send (the X) -> (the X with ...) -> (km-unique-int (every X with ...)), but then error messages were unintuitive) ( (#$the ?frame) (lambda (fmode target frame) (declare (ignore fmode target)) (let ( (answer (km-int `(#$every ,frame))) ) (cond ((null answer) (report-error 'user-error "No values found for expression ~a!~%" `#$(the ,FRAME))) ((not (singletonp answer)) (report-error 'user-error "Expected a single value for expression ~a, but found multiple values ~a!~%" `#$(the ,FRAME) answer)) (t answer))))) ( (#$the ?frame #$with &rest) (lambda (fmode target frame slotsvals) (declare (ignore fmode target)) (let ( (answer (km-int `(#$every ,frame #$with ,@slotsvals))) ) (cond ((null answer) (report-error 'user-error "No values found for expression ~a!~%" `#$(the ,FRAME with ,@SLOTSVALS))) ((not (singletonp answer)) (report-error 'user-error "Expected a single value for expression ~a, but found multiple values ~a!~%" `#$(the ,FRAME with ,@SLOTSVALS) answer)) (t answer))))) ;;; Find-or-create Three forms for forc: ;;; (forc (the (porter owns car))) ; (forc (the ...)) and (forc (a ...)) are synonymous ;;; (forc (the car with (owns-by (porter)))) ;;; (forc (porter owns car) ;;; Rewrites, to allow path notation to be used... ( (#$the+ ?slot #$of ?frameadd) (lambda (_fmode target slot frameadd) (declare (ignore _fmode)) (km-int `#$(the+ Thing with (,(INVERT-SLOT SLOT) (,FRAMEADD))) :fail-mode 'error :target target :rewritep t))) ( (#$the+ ?class ?slot #$of ?frameadd) (lambda (_fmode target class slot frameadd) (declare (ignore _fmode)) (km-int `#$(the+ ,CLASS with (,(INVERT-SLOT SLOT) (,FRAMEADD))) :fail-mode 'error :target target :rewritep t))) ( (#$the+ ?frame) (lambda (fmode target frame) (km-int `(#$the+ ,frame #$with) :fail-mode fmode :target target :rewritep t)) ) ( (#$the+ ?frame #$with &rest) (lambda (_fmode _target frame slotsvals) (declare (ignore _fmode _target)) ; (cond ; ((km-int `(#$the ,frame #$with ,@slotsvals))) ; OLD: (the ... with ...) *always* generates error on failure, so bypass this. (let ( (val (km-unique-int `(#$every ,frame #$with ,@slotsvals))) ) ; NEW ; PS don't surpress error for (the ...)! (cond (val (list val)) ((are-slotsvals slotsvals) (let ( (existential-expr (cond ((and (null slotsvals) (pathp frame)) ; eg. (a (porter owns car)) (path-to-existential-expr frame)) (t `(#$a ,frame #$with ,@slotsvals)))) ) (mapcar #'eval-instance (km-int existential-expr :fail-mode 'error))))))) ) ; [1] ( (#$a+ &rest) ; a+ is synonym for the+ (lambda (fmode target rest) (km-int `(#$the+ ,@rest) :fail-mode fmode :target target :rewritep t)) ) ;;; [1] above: Do an eval-instance forces inverses in! For example, doing ;;; (the+ Leg with (part-of ((the Dog with (owned-by (Bruce)))))) ;;; should not just return _Leg2, but also add (Bruce owns _Dog3), and (_Dog3 parts _Leg2) ; ---------------------------------------- ; ========================== ; DEFINING MEMBER PROPERTIES ; ========================== ( (#$every ?cexpr #$has-definition &rest) (lambda (_fmode _target cexpr slotsvals) (declare (ignore _fmode _target)) (let ( (class (km-unique-int cexpr :fail-mode 'error)) ) (cond ((not (kb-objectp class)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a class name.~%" `(#$every ,cexpr #$has-definition ,@slotsvals) cexpr)) ((are-slotsvals slotsvals) (let* ((slotsvals00 (cond (*record-sources* (annotate-slotsvals slotsvals (make-source class))) (t slotsvals))) (slotsvals0 (convert-comments-to-internal-form slotsvals00)) (parents-of-defined-concept (desource+decomment (vals-in (assoc '#$instance-of slotsvals0)) :delistifyp nil)) ) (cond ((not (every #'kb-objectp parents-of-defined-concept)) (report-error 'user-error "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%" `(#$every ,cexpr #$has-definition ,@slotsvals0))) ((null parents-of-defined-concept) (report-error 'user-error "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%" `(#$every ,cexpr #$has-definition ,@slotsvals0))) (t (add-slotsvals class slotsvals0 :facet 'member-definition :install-inversesp nil) (point-parents-to-defined-concept class parents-of-defined-concept 'member-definition) (km-setq '*are-some-definitions* t) (mapc #'un-done (all-instances class)) (list class)))))))) ) ; ======================= ; DEFINING OWN PROPERTIES ; ======================= ( (?instance-expr #$has-definition &rest) (lambda (_fmode _target instance-expr slotsvals) (declare (ignore _fmode _target)) (let ( (instance (km-unique-int instance-expr :fail-mode 'error)) ) (cond ((not (kb-objectp instance)) (report-error 'user-error "~a~%~a isn't/doesn't evaluate to a KB object name.~%" `(#$every ,instance-expr #$has-definition ,@slotsvals) instance-expr)) ((are-slotsvals slotsvals) ; check (let* ((slotsvals0 (desource+decomment slotsvals)) ; Can't handle comments on instances yet, so strip ; them off and throw them out, unlike for (every ... has-def...) (parents-of-defined-concept (vals-in (assoc '#$instance-of slotsvals0)))) (cond ((not (every #'kb-objectp parents-of-defined-concept)) (report-error 'user-error "~a~%The `instance-of' slot-filler(s) in a has-definition must be atomic class name(s) only.~%" `(,instance-expr #$has-definition ,@slotsvals0))) ((null parents-of-defined-concept) (report-error 'user-error "~a~%You must specify an `instance-of' slot value for a has-definition, pointing to the parent class(es)!~%" `(,instance-expr #$has-definition ,@slotsvals0))) (t (add-slotsvals instance slotsvals0 :facet 'own-definition) (point-parents-to-defined-concept instance parents-of-defined-concept 'own-definition) (km-setq '*are-some-definitions* t) (un-done instance) ; In case redefinition - now in put-slotsvals; Later: no!!! (classify instance :slots-that-changed (mapcar #'slot-in slotsvals)) ; Because it's an instance (list instance)))))))) ) ; ---------------------------------------- ( (#$if ?condition #$then ?action) (lambda (fmode target condition action) (km-int `(#$if ,condition #$then ,action #$else nil) :fail-mode fmode :target target :rewritep t)) ) ( (#$if ?condition #$then ?action #$else ?altaction) (lambda (fmode target condition action altaction) (declare (ignore target)) (let ( (test-result (km-int condition)) ) (cond ((not (member test-result '#$(NIL f F))) (km-int action :fail-mode fmode)) (t (km-int altaction :fail-mode fmode)))))) ( (?x > ?y) (lambda (_fmode _target x y) (declare (ignore _fmode _target)) (let ( (xval (km-unique-int x :fail-mode 'error)) (yval (km-unique-int y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((> xval yval) '#$(t)))))))) ( (?x < ?y) (lambda (_fmode _target x y) (declare (ignore _fmode _target)) (let ( (xval (km-unique-int x :fail-mode 'error)) (yval (km-unique-int y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((< xval yval) '#$(t)))))))) ( (?x >= ?y) (lambda (_fmode _target x y) (declare (ignore _fmode _target)) (let ( (xval (km-unique-int x :fail-mode 'error)) (yval (km-unique-int y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((>= xval yval) '#$(t)))))))) ( (?x <= ?y) (lambda (_fmode _target x y) (declare (ignore _fmode _target)) (let ( (xval (km-unique-int x :fail-mode 'error)) (yval (km-unique-int y :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval)) (cond ((<= xval yval) '#$(t)))))))) ( (?x = ?y +/- ?z) (lambda (_fmode _target x y z) (declare (ignore _fmode _target)) (let ( (xval (km-unique-int x :fail-mode 'error)) (yval (km-unique-int y :fail-mode 'error)) (zval (km-unique-int z :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval) (numberp zval)) (cond ((<= (abs (- xval yval)) (abs zval)) '#$(t))))))) ) ( (?x = ?y +/- ?z %) (lambda (_fmode _target x y z) (declare (ignore _fmode _target)) (let ( (xval (km-unique-int x :fail-mode 'error)) (yval (km-unique-int y :fail-mode 'error)) (zval (km-unique-int z :fail-mode 'error)) ) (cond ((and (numberp xval) (numberp yval) (numberp zval)) (cond ((<= (abs (- xval yval)) (* (max (abs xval) (abs yval)) (abs zval) 0.01)) '#$(t))))))) ) ; ---------------------------------------- ( (?x #$and &rest) (lambda (_fmode _target x rest) (declare (ignore _fmode _target)) (cond ((and (listp x) (= (length x) 3) (eq (second x) '==)) ; special handling for ((?x == ) and ...) (let* ( (xx (first x)) (yy (third x)) ) (cond ((and (km-varp xx) (km-varp yy)) (km-int (subst xx yy rest))) ; or perhaps should be an error ((km-varp xx) (km-int (subst (vals-to-val (km-int yy)) xx rest))) ((km-varp yy) (km-int (subst (vals-to-val (km-int xx)) yy rest))) ((and (lazy-unify-&-expr `(,xx == yy) :fail-mode 'error :joiner '==) (km-int rest)))))) (t (and (km-int x) (km-int rest))))) ) ( (?x #$or &rest) (lambda (_fmode _target x y) (declare (ignore _fmode _target)) (or (and (not (on-goal-stackp x)) (km-int x)) (km-int y))) ) ( (#$not ?x) (lambda (_fmode _target x) (declare (ignore _fmode _target)) (cond ((not (km-int x)) '#$(t)))) ) ( (#$numberp ?x) (lambda (_fmode _target x) (declare (ignore _fmode _target)) (cond ((numberp (km-unique-int x)) '#$(t)))) ) ;;; ====================================================================== ;;; SUBSUMPTION TESTING ;;; ====================================================================== ( (?x #$is-subsumed-by ?y) (lambda (fmode target x y) (km-int `(,y #$subsumes ,x) :fail-mode fmode :target target :rewritep t)) ) ( (?x #$subsumes ?y) (lambda (_fmode _target x y) (declare (ignore _fmode _target)) (let ( (yv (km-int y)) ) (cond ((null yv) '#$(t)) (t (let ( (xv (km-int x)) ) (cond ((and (not (null xv)) (subsumes xv yv)) '#$(t))))))))) ( (?x #$is-covered-by ?y) (lambda (fmode target x y) (km-int `(,y #$covers ,x) :fail-mode fmode :target target :rewritep t)) ) ; replace with generalized isa ; ( (?x #$covers ?y) ; (lambda (_fmode x y) ; (declare (ignore _fmode)) ; (let ( (yv (km-unique-int y)) ) ; (cond ((null yv) '#$(t)) ; (t (let ( (xv (km-int x)) ) ; (cond ((and (not (null xv)) ; (covers xv yv)) ; '#$(t))))))))) ;;; Obsolete, but keep for backward compatibility ( (?x #$covers ?y) (lambda (fmode target x y) (km-int `(,y #$isa ,x) :fail-mode fmode :target target :rewritep t)) ) ( (?y #$isa ?x) (lambda (_fmode _target y x) (declare (ignore _fmode _target)) (let* ( (yvals (km-int y)) (yv (first yvals)) ) (cond ((null yvals) (report-error 'user-error "Doing ~a:~% ~a evaluates to nil (should evaluate to an instance!)" `(,y #$isa ,x) y)) ((not (singletonp yvals)) (report-error 'user-error "Doing ~a:~% ~a evaluates to multiple values ~a (should evaluate to a single instance!)" `(,y #$isa ,x) y yvals)) (t (let* ((xvals (km-int x)) (xv (first xvals))) (cond ((null xvals) (report-error 'user-error "Doing ~a:~% ~a evaluates to nil (should evaluate to something!)" `(,y #$isa ,x) x)) ((not (singletonp xvals)) (report-error 'user-error "Doing ~a:~% ~a evaluates to multiple values ~a (should evaluate to a single object!)" `(,y #$isa ,x) x xvals)) ((kb-objectp xv) (cond ((isa yv xv) '#$(t)))) ; quick test ((covers (list xv) yv) '#$(t)))))))) ) ; more complex test for expressions ( (?x #$is ?y) (lambda (_fmode _target x y) (declare (ignore _fmode _target)) (let ( (xv (km-unique-int x)) ) (cond ((null xv) nil) (t (let ( (yv (km-unique-int y)) ) (cond ((and (not (null yv)) (is xv yv)) '#$(t))))))))) ;;; ====================================================================== ( (?xs #$includes ?y) (lambda (_fmode _target xs y) (declare (ignore _fmode _target)) (let ( (xs-vals (km-int xs)) (y-val (km-unique-int y :fail-mode 'error)) ) (cond ((member y-val (dereference xs-vals) :test #'equal) '#$(t)))))) ( (?xs #$is-superset-of ?ys) (lambda (_fmode _target xs ys) (declare (ignore _fmode _target)) (let ( (xs-vals (km-int xs)) (ys-vals (km-int ys)) ) (cond ((subsetp ys-vals (dereference xs-vals) :test #'equal) '#$(t))))) ) ;;; ====================================================================== ;;; SEQUENCE MANIPULATION ;;; ====================================================================== ( (?seq-expr1 #$append ?seq-expr2) (lambda (_fmode _target seq-expr1 seq-expr2) (declare (ignore _fmode _target)) (let* ( (seq1 (km-unique-int seq-expr1)) (seq2 (km-unique-int seq-expr2)) (elts1 (cond ((or (km-seqp seq1) (km-bagp seq1)) (seq-to-list seq1)) ((null seq1) nil) ((is-km-term seq1) (list seq1)) (t (report-error 'user-error "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" seq-expr1 seq-expr2 seq-expr1)))) (elts2 (cond ((or (km-seqp seq2) (km-bagp seq2)) (seq-to-list seq2)) ((null seq2) nil) ((is-km-term seq2) (list seq2)) (t (report-error 'user-error "(~a append ~a): ~a doesn't evaluate to an instance, sequence, or bag!" seq-expr1 seq-expr2 seq-expr2)))) (result-type (cond ((or (and (km-seqp seq1) (km-bagp seq2)) (and (km-seqp seq2) (km-bagp seq1))) (report-error 'user-error "(~a append ~a): Elements should be both sequences or both bags!" seq-expr1 seq-expr2) '#$:seq) ; result on failure ((or (km-bagp seq1) (km-bagp seq2)) '#$:bag) (t '#$:seq))) ) ; default `((,result-type ,@(append elts1 elts2))))) ) ;;; ====================================================================== ;;; ALLOF/ONEOF etc. ;;; ====================================================================== ;;; New. NOTE: fails quietly if it can't find any values. That's fine. ( (?expr #$called ?tag) (lambda (fmode _target expr tag) (declare (ignore _target)) (let* ( (vals (km-int expr)) ) (cond (vals (km-trace 'comment "Now find just those value(s) whose tag = ~a..." tag))) (let* ( (tags (val-to-vals tag)) (target-vals (remove-if #'(lambda (val) (set-difference tags (append (km-int `#$(the called of ,VAL)) (km-int `#$(the uniquely-called of ,VAL))) :test #'equal)) vals)) ) (cond ((null target-vals) (cond ((eq fmode 'error) (report-error 'user-error "(~a called/uniquely-called ~a): No values of ~a (evaluates to ~a) is called/uniquely-called ~a!" expr tag expr vals (val-to-vals tag))) ; (t (make-comment "Warning: Can't find any (~a called/uniquely-called ~a)" expr tag)) )) (t target-vals))))) ) ; synonym ( (?expr #$uniquely-called ?tag) (lambda (fmode target expr tag) (km-int `(,expr #$called ,tag) :fail-mode fmode :target target :rewritep t)) ) ;;; > (a man with (parts ((a arm) (a leg) (a arm)))) ;;; _man1187 ;;; > (allof ((_man1187 parts)) where (it isa arm)) ;;; (_arm1188 _arm1190) ( (#$allof ?set #$where ?test) (lambda (fmode target set test) (km-int `(#$forall ,set #$where ,test #$It) :fail-mode fmode :target target :rewritep t))) ; equivalent ;;; New for KM1.4.0 beta-12 ( (#$allof ?set #$must ?test) (lambda (fmode target set test) (declare (ignore fmode target)) (cond ((every #'(lambda (instance) (km-int (subst Instance '#$It test))) (km-int set)) '#$(t))))) ;;; New for KM1.4.0 beta-18 ( (#$allof ?set #$where ?test2 #$must ?test) (lambda (fmode target set test2 test) (declare (ignore fmode target)) (cond ((every #'(lambda (instance) (km-int (subst Instance '#$It test))) (km-int `#$(allof ,SET where ,TEST2))) '#$(t))))) ( (#$oneof ?set #$where ?test) (lambda (fmode target set test) (declare (ignore fmode target)) (let ( (answer (find-if #'(lambda (member) (km-int (subst member '#$It test))) (km-int set))) ) (cond (answer (list answer))))) ) ;;; New 1.4 - check to ensure there's a single value ( (#$theoneof ?set #$where ?test) (lambda (fmode target set test) (let ( (val (km-unique-int `(#$forall ,set #$where ,test #$It) :fail-mode fmode :target target :rewritep t)) ) ; equivalent (cond (val (list val))))) ) ( (#$forall ?set ?value) (lambda (fmode target set value) (km-int `(#$forall ,set #$where t ,value) :fail-mode fmode :target target :rewritep t))) ; equivalent ;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results. ( (#$forall-seq ?seq ?value) (lambda (fmode target seq value) (km-int `(#$forall-seq ,seq #$where t ,value) :fail-mode fmode :target target :rewritep t))) ; equivalent ( (#$forall-bag ?bag ?value) (lambda (fmode target bag value) (km-int `(#$forall-bag ,bag #$where t ,value) :fail-mode fmode :target target :rewritep t))) ; equivalent ( (#$forall ?set #$where ?constraint ?value) (lambda (_fmode _target set constraint value) (declare (ignore _fmode _target)) (remove nil (my-mapcan #'(lambda (member) (cond ((km-int (subst member '#$It constraint)) (km-int (subst member '#$It value))))) (km-int set)))) ) ;;; ---------- ;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results. ( (#$forall-seq ?seq #$where ?constraint ?value) (lambda (_fmode _target seq constraint value) (declare (ignore _fmode _target)) (let ( (sequences (km-int seq)) ) (cond ((null sequences) nil) ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `#$(forall-seq ,SEQ where ,CONSTRAINT ,VALUE) seq)) (t (list (cons '#$:seq (remove 'to-remove (mapcar #'(lambda (member) (cond ((km-int (subst member '#$It constraint)) (vals-to-val (km-int (subst member '#$It value)))) (t 'to-remove))) (rest (first sequences)))))))))) ) ; ((:seq a b)) -> map over (a b) ( (#$forall-seq2 ?seq #$where ?constraint ?value) (lambda (_fmode _target seq constraint value) (declare (ignore _fmode _target)) (let ( (sequences (km-int seq)) ) (cond ((null sequences) nil) ((or (not (singletonp sequences)) (not (km-seqp (first sequences)))) (report-error 'user-error "~a: ~a should evaluate to a single sequence (:seq ... ...)!~%" `#$(forall-seq2 ,SEQ where ,CONSTRAINT ,VALUE) seq)) (t (list (cons '#$:seq (remove 'to-remove (mapcar #'(lambda (member) (cond ((km-int (subst member '#$It2 constraint)) (vals-to-val (km-int (subst member '#$It2 value)))) (t 'to-remove))) (rest (first sequences)))))))))) ) ; ((:seq a b)) -> map over (a b) ;;; ---------- ;;; This iterates through a SINGLE SEQUENCE, returning a SEQUENCE of results. ( (#$forall-bag ?bag #$where ?constraint ?value) (lambda (_fmode _target bag constraint value) (declare (ignore _fmode _target)) (let ( (bags (km-int bag)) ) (cond ((null bags) nil) ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `#$(forall-bag ,BAG where ,CONSTRAINT ,VALUE) bag)) (t (list (cons '#$:bag (remove nil (mapcar #'(lambda (member) (cond ((km-int (subst member '#$It constraint)) (vals-to-val (km-int (subst member '#$It value)))))) (rest (first bags)))))))))) ) ; ((:bag a b)) -> map over (a b) ( (#$forall-bag2 ?bag #$where ?constraint ?value) (lambda (_fmode _target bag constraint value) (declare (ignore _fmode _target)) (let ( (bags (km-int bag)) ) (cond ((null bags) nil) ((or (not (singletonp bags)) (not (km-bagp (first bags)))) (report-error 'user-error "~a: ~a should evaluate to a single bag (:bag ... ...)!~%" `#$(forall-bag2 ,BAG where ,CONSTRAINT ,VALUE) bag)) (t (list (cons '#$:bag (remove nil (mapcar #'(lambda (member) (cond ((km-int (subst member '#$It2 constraint)) (vals-to-val (km-int (subst member '#$It2 value)))))) (rest (first bags)))))))))) ) ; ((:bag a b)) -> map over (a b) ;;; ---------- ;;; To allow nesting, we also have forall2, whose referents are "it2" ( (#$allof2 ?set #$where ?test) (lambda (fmode target set test) (km-int `(#$forall2 ,set #$where ,test #$It2) :fail-mode fmode :target target :rewritep t))) ; equivalent ;;; New for KM1.4.0 beta-12 ( (#$allof2 ?set #$must ?test) (lambda (fmode target set test) (declare (ignore fmode target)) (cond ((every #'(lambda (instance) (km-int (subst Instance '#$It2 test))) (km-int set)) '#$(t))))) ;;; New for KM1.4.0 beta-18