;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10 -*- ;;;; --------------------------------------------------------------------------- ;;;; File name: kb-api-structural.lsp ;;;; System: FIRE v1 ;;;; Author: Ken Forbus ;;;; Created: January 3, 2004 14:52:39 ;;;; Purpose: ;;;; --------------------------------------------------------------------------- ;;;; Modified: Wednesday, April 14, 2004 at 18:26:18 by forbus ;;;; --------------------------------------------------------------------------- (in-package :fire) ;;; This file contains the subset of the KB API for making structural queries. ;;; These are for FIRE-level developers -- most development of reasoners should ;;; use ASK or QUERY or SOLVE as appropriate, since one wants to be using the contents ;;; of the working memory as well as the KB. These procedures are only for KB access. ;;; ;;; The intended interface procedures are: ;;; ;;; OPERATIONS CONCERNING COLLECTIONS ;;; ;;; (collection? &key (kb *kb*)) returns non-nil if is a collection. ;;; ;;; (collections-of &key (kb *kb*)) returns the list of collections that ;;; is directly a member of. ;;; ;;; (all-collections-of &key (kb *kb*)) returns the list of all collections that ;;; is a member of. ;;; ;;; (instance-of? kb) returns non-nil if is in . ;;; ;;; (instance-of-any? &key (kb *kb*)) returns non-nil if is in ;;; one of the collections in . ;;; ;;; (instances-of &key (kb *kb*)) returns a list of all instances of . ;;; ;;; (map-collections &key (kb *kb*)) applies to every ;;; collection in the KB. Return value is unspecified. ;;; ;;; RELATIONSHIPS BETWEEN COLLECTIONS ;;; ;;; (immediate-genls &key (kb *kb*)) returns the set of collections that is ;;; a direct spec of. ;;; ;;; (immediate-specs &key (kb *kb*)) similar. ;;; ;;; (all-genls &key (kb *kb*)) returns the complete set of collections that ;;; is a spec of. ;;; ;;; (all-specs &key (kb *kb*)) similar. ;;; ;;; (spec-of? &key (kb *kb*)) is non-nil iff has as a genl. ;;; ;;; (map-over-genls &key (kb *kb*)) executes on each genl of . ;;; Return value is unspecified. ;;; ;;; (map-over-specs &key (kb *kb*)) similar. ;;; ;;; PROPERTIES OF PREDICATES ;;; ;;; (predicate-type &key (kb *kb*)) returns a keyword indicating the SME type ;;; of the predicate. That is, :function, :relation, :logical have their usual meanings. ;;; collections return :attribute. ;;; ;;; (function? &key (kb *kb*)) returns non-nil iff is a function ;;; (relation? &key (kb *kb*)) similar. ;;; (logical-connective? &key (kb *kb*)) similar. ;;; (evaluatable-function? &key (kb *kb*)) similar. ;;; (evaluatable-relation? &key (kb *kb*)) similar. ;;; (nart-predicate? &key (kb *kb*)) similar. ;;; (produces-evaluatable-function? &key (kb *kb*)) similar. ;;; (commutative? &key (kb *kb*)) similar. ;;; ;;; (arity &key (kb *kb*)) returns the arity of predicate, either an integer ;;; or the keyword :n-ary. ;;; ;;; (n-ary? &key (kb *kb*)) returns non-nil if is n-ary, nil o.w. ;;; (n-ary-expression? &key (kb *kb*)) similar, but starts with an expression. ;;; ;;; (arg-isa &key (kb *kb*)) returns argument type information for ;;; if is an integer, it returns the type information for the nth argument. ;;; if is :all, it returns a list of types for all arguments, in order ;;; ;;; (result-isa-type &key (kb *kb*)) returns the collection(s) that any ;;; result of the function must be. ;;; ;;; (produces-evaluatable-function? &key (kb *kb*)) returns non-nil if the result of ;;; the function is an EvaluatableFunction. ;;; ;;; RELATIONSHIPS BETWEEN PREDICATES ;;; ;;; (immediate-genlpreds &key (kb *kb*)) returns the list of predicates that are ;;; directly above in the genlPred lattice. ;;; ;;; (immediate-specpreds &key (kb *kb*)) similar, but directly below. ;;; ;;; (all-genlpreds &key (kb *kb*)) returns all predicates that are above ;;; in the genlPred lattice. ;;; ;;; (all-specpreds &key (kb *kb*)) returns all predicates that are below ;;; in the genlPred lattice. ;;; ;;; (specpred-of? &key (kb *kb*)) returns non-nil if is a specPred ;;; of in the genlPred lattice. ;;; ;;; DEBUGGING AND STATISTICS ;;; ;;; (kb-statistics &key (kb *kb*) (stream *standard-output*)) produces a concise summary ;;; of KB information. ;;; ;;; (list-all-collections &key (kb *kb*) (include-nats? nil)) returns a list of all collections ;;; in the KB. (Expensive, use with caution) ;;; (list-all-predicates &key (kb *kb*)) similar. ;;; (list-all-functions &key (kb *kb*)) similar. ;;; (list-all-relations &key (kb *kb*)) similar. ;;; (list-all-connectives &key (kb *kb*)) similar. ;;; (list-all-constants &key (kb *kb*)) similar. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; OPERATIONS CONCERNING COLLECTIONS (defun collection? (thing &key (kb *kb*)) (let ((entry (find-sc-entry thing kb))) (and entry (sc-collection? entry)))) (defun collections-of (thing &key (kb *kb*)) (let ((entry (find-sc-entry thing kb))) (when entry (mapcar #'sc-item (sc-isas entry))))) (defun all-collections-of (thing &key (kb *kb*)) ;; Not the most efficient, but simple (remove-duplicates (apply 'append (mapcar 'all-genls (collections-of thing :kb kb))) :test 'equal)) (defgeneric instance-of? (entity col kb-or-reasoner) (:documentation "Returns non-nil iff entity is an instance of the specified collection. If a knowledge-base is passed in as the third argument, only the KB will be checked; if a reasoner is passed in, both the KB and the reasoner's working memory will be checked.")) (defmethod instance-of? (entity col kb-or-reasoner) (declare (ignore entity col kb-or-reasoner)) nil) (defmethod instance-of? (entity col (kb knowledge-base)) (instance-of-any? entity (list col) :kb kb)) (defun instance-of-any? (entity clist &key (kb *kb*)) ;; **** we're assuming that non-nil is accurate, but ;; **** nil could be unknown. We need to juice this up with ;; **** reasoning about disjointness at some point soon. (let ((targets (delete nil (mapcar #'(lambda (col) (let ((entry (find-sc-entry col kb))) (when (sc-collection? entry) entry))) clist))) (start (find-sc-entry entity kb))) (cond ((null start) nil) ;; entity not in KB ((some #'(lambda (col) (member col targets)) (sc-isas start)) t) ;; Known explicitly (t ;; Have to search (search-for-sc-targets (sc-isas start) targets 'sc-genls))))) (defun instances-of (col &key (kb *kb*)) (let ((instances nil)) (map-over-instances #'(lambda (e) (push (sc-item e) instances)) (list col) :kb kb) instances)) (defun instances-of-sc (col &key (kb *kb*)) (let ((instances nil)) (map-over-instances #'(lambda (e) (push e instances)) (list col) :kb kb) instances)) (defun map-collections (procedure &key (kb *kb*)) (maphash #'(lambda (key entry) (declare (ignore key)) (when (sc-collection? entry) (funcall procedure (sc-item entry)))) (table (structural-cache kb)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Listing subsets of KB content (defun list-all-collections (&key (kb *kb*) (include-nats? nil)) (let ((cols nil)) (maphash #'(lambda (key entry) (declare (ignore key)) (when (sc-collection? entry) (unless (and (not include-nats?) (not (symbolp (sc-item entry)))) (push (sc-item entry) cols)))) (table (structural-cache kb))) cols)) (defun list-sc-entries-satisfying (test &key (kb *kb*)) (let ((results nil)) (map-over-sc-entries #'(lambda (e) (when (funcall test e) (push (sc-item e) results))) (structural-cache kb)) results)) (defun list-all-predicates (&key (kb *kb*)) (list-sc-entries-satisfying #'sc-predicate? :kb kb)) (defun list-all-functions (&key (kb *kb*)) (list-sc-entries-satisfying #'sc-function? :kb kb)) (defun list-all-relations (&key (kb *kb*)) (list-sc-entries-satisfying #'sc-relation? :kb kb)) (defun list-all-connectives (&key (kb *kb*)) (list-sc-entries-satisfying #'sc-logical? :kb kb)) (defun list-all-constants (&key (kb *kb*)) (list-sc-entries-satisfying #'(lambda (e) (eq (sc-type e) :constant)) :kb kb)) (defun list-all-microtheories (&key (kb *kb*)) (list-sc-entries-satisfying #'(lambda (e) (eq (sc-type e) :microtheory)) :kb kb)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; RELATIONSHIPS BETWEEN COLLECTIONS (defun immediate-genls (col &key (kb *kb*)) (let ((entry (find-sc-entry col kb))) (cond ((or (null entry) (not (sc-collection? entry))) nil) (t (mapcar 'sc-item (sc-genls (sc-details entry))))))) (defun immediate-specs (col &key (kb *kb*)) (let ((entry (find-sc-entry col kb))) (cond ((or (null entry) (not (sc-collection? entry))) nil) (t (mapcar 'sc-item (sc-specs (sc-details entry))))))) (defun all-genls (col &key (kb *kb*) (recompute? nil)) (let ((entry (find-sc-entry col kb))) (cond ((or (null entry) (not (sc-collection? entry))) nil) ((and (sc-all-genls (sc-details entry)) (not recompute?)) (mapcar 'sc-item (sc-all-genls (sc-details entry)))) (t (let ((genls nil)) (map-over-sc-field #'(lambda (e) (push e genls)) entry 'sc-genls) (setf (sc-all-genls (sc-details entry)) genls) (mapcar 'sc-item genls)))))) (defun all-specs (col &key (kb *kb*) (recompute? nil)) (let ((entry (find-sc-entry col kb))) (cond ((or (null entry) (not (sc-collection? entry))) nil) ((and (sc-all-specs (sc-details entry)) (not recompute?)) (mapcar 'sc-item (sc-all-specs (sc-details entry)))) (t (let ((specs nil)) (map-over-sc-field #'(lambda (e) (push e specs)) entry 'sc-specs) (setf (sc-all-specs (sc-details entry)) specs) (mapcar 'sc-item specs)))))) (defun spec-of? (sub super &key (kb *kb*)) (let ((sube (find-sc-entry sub kb)) (supe (find-sc-entry super kb))) (sc-spec-of? sube supe))) (defun sc-spec-of? (sube supe) (cond ((or (null sube) (null supe) (not (sc-collection? sube)) (not (sc-collection? supe))) nil) ((some #'(lambda (s) (eq s supe)) (sc-genls (sc-details sube))) t) (t (search-for-sc-targets (sc-genls (sc-details sube)) (list supe) 'sc-genls)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; PROPERTIES OF PREDICATES (defun predicate-type (pred &key (kb *kb*)) (let ((entry (find-sc-entry pred kb))) (cond ((sc-entry? entry) (cond ((sc-collection? entry) :attribute) ((sc-relation? entry) :relation) ((sc-function? entry) :function) ((sc-logical? entry) :logical) ((sc-predicate? entry) :relation) ;; Default (t nil))) ((listp pred) ;; It has to be a function ;; And we look at its result type for the answer (setq entry (find-sc-entry (car pred) kb)) (cond ((sc-function? entry) (let ((result-isas (sc-result-isa (sc-details entry)))) (cond ((some 'sc-function-type? result-isas) :function) ((some 'sc-collection-type? result-isas) :attribute) ((some 'sc-relation-type? result-isas) :relation) ((some 'sc-logical-type? result-isas) :logical) ((some 'sc-predicate-type? result-isas) :relation) (t nil)))) (t ;; Could be kappa or lambda but not supported yet. nil))) (t nil)))) (defun sc-function-type? (sc-entry) (let ((super-entry (find-sc-entry 'data::Function-Denotational *kb*))) (or (eq super-entry sc-entry) (sc-spec-of? sc-entry super-entry)))) (defun sc-collection-type? (sc-entry) (let ((super-entry (find-sc-entry 'data::Collection *kb*))) (or (eq super-entry sc-entry) (sc-spec-of? sc-entry super-entry)))) (defun sc-relation-type? (sc-entry) (let ((super-entry (find-sc-entry 'data::Predicate *kb*))) (or (eq super-entry sc-entry) (sc-spec-of? sc-entry super-entry)))) (defun sc-logical-type? (sc-entry) (let ((s1 (find-sc-entry 'data::LogicalConnective *kb*)) (s2 (find-sc-entry 'data::Quantifier *kb*))) (or (eq s1 sc-entry) (eq s2 sc-entry) (sc-spec-of? sc-entry s1) (sc-spec-of? sc-entry s2)))) (defun sc-predicate-type? (sc-entry) (let ((super-entry (find-sc-entry 'data::Relation *kb*))) (or (eq super-entry sc-entry) (sc-spec-of? sc-entry super-entry)))) (defun function? (pred &key (kb *kb*)) (let ((entry (find-sc-entry pred kb))) (and entry (sc-function? entry)))) (defun relation? (pred &key (kb *kb*)) (let ((entry (find-sc-entry pred kb))) (and entry (sc-relation? entry)))) (defun logical-connective? (pred &key (kb *kb*)) (let ((entry (find-sc-entry pred kb))) (and entry (sc-logical? entry)))) (defun predicate? (pred &key (kb *kb*)) (member (predicate-type pred :kb kb) '(:relation :function :logical))) (defun found-sc-instance-of? (thing collection kb) (let ((entry (find-sc-entry thing kb)) (target (find-sc-entry collection kb))) (and entry (sc-function? entry) target (sc-collection? target) (search-for-sc-targets (sc-isas entry) (list target) 'sc-genls)))) (defun evaluatable-function? (pred &key (kb *kb*)) (found-sc-instance-of? pred (if (mixed-case?) 'data::EvaluatableFunction 'data::evaluatable-function) kb)) (defun evaluatable-relation? (pred &key (kb *kb*)) (found-sc-instance-of? pred (if (mixed-case?) 'data::EvaluatableRelation 'data::evaluatable-relation) kb)) (defun produces-evaluatable-function? (pred &key (kb *kb*)) (let ((pe (find-sc-entry pred kb)) (target (if (mixed-case?) 'data::EvaluatableFunction 'data::evaluatable-function))) (cond ((not (sc-function? pe)) nil) (t (some #'(lambda (col) (spec-of? (sc-item col) target)) (sc-result-isa (sc-details pe))))))) (defun nart-predicate? (pred &key (kb *kb*)) (found-sc-instance-of? pred (if (mixed-case?) 'data::ReifiableFunction 'data::reifiable-function) kb)) (defun careful-sc-field-extraction (thing kb type-test extractor) (let ((entry (find-sc-entry thing kb))) (and entry (funcall type-test entry) (funcall extractor entry)))) (defun arity (pred &key (kb *kb*)) (careful-sc-field-extraction pred kb 'sc-predicate? #'(lambda (e) (sc-arity (sc-details e))))) (defun n-ary? (pred &key (kb *kb*)) (careful-sc-field-extraction pred kb 'sc-predicate? #'(lambda (e) (sc-n-ary? (sc-details e))))) (defun n-ary-expression? (exp &key (kb *kb*)) (and (listp exp) (n-ary? (car exp) :kb kb))) (defun arg-isa (predicate args &key (kb *kb*)) "Returns argument type information for . If is an integer, it returns the type information for the nth argument. If is :all, it returns a list of types for all arguments, in order." (let ((arity (arity predicate :kb kb))) (cond ((eq arity :n-ary) (retrieve-argn-isa predicate :n-ary kb)) ((integerp arity) (cond ((integerp args) (if (or (> args arity) (< args 1)) (error "Out of range argument for arg-isa: ~ ~A out of ~A in ~A" args arity predicate) (retrieve-argn-isa predicate args kb))) ((eq args :all) (let ((result nil)) (dotimes (arg arity (nreverse result)) (push (retrieve-argn-isa predicate (1+ arg) kb) result)))) (t (error "Unknown arg request: ~A for ~A in fire:arg-isa." args predicate)))) (t (error "Unknown arity type: ~A in ~A." arity predicate))))) (defun retrieve-argn-isa (pred n kb) ;; for internal use only (let* ((entry (find-sc-entry pred kb)) (details (and (sc-predicate? entry) (sc-details entry)))) (cond ((null details) :unknown) ((sc-really-n-ary? details) (let ((type-entry (or (assoc ':n-ary? (sc-arg-isas details)) (assoc 0 (sc-arg-isas details))))) (when type-entry (sc-item (second type-entry))))) ((integerp n) (let ((type-entry (assoc n (sc-arg-isas details)))) (when type-entry (sc-item (second type-entry))))) (t :unknown)))) ;;; (result-isa-type &key (kb *kb*)) returns the collection(s) that any ;;; result of the function must be. ;;; ;;; (produces-evaluatable-function? &key (kb *kb*)) returns non-nil if the result of ;;; the function is an EvaluatableFunction. (defun commutative? (pred &key (kb *kb*)) "Returns non-nil iff pred refers to a commutative relation." (let ((entry (find-sc-entry pred kb))) (and entry (sc-predicate? entry) (sc-commutative? (sc-details entry))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; RELATIONSHIPS BETWEEN PREDICATES (defun immediate-genlpreds (rel &key (kb *kb*)) (let ((entry (find-sc-entry rel kb))) (cond ((or (null entry) (not (sc-predicate? entry))) nil) (t (mapcar 'sc-item (sc-genlpreds (sc-details entry))))))) (defun immediate-specpreds (rel &key (kb *kb*)) (let ((entry (find-sc-entry rel kb))) (cond ((or (null entry) (not (sc-predicate? entry))) nil) (t (mapcar 'sc-item (sc-specpreds (sc-details entry))))))) (defun all-genlpreds (rel &key (kb *kb*)) (let ((entry (find-sc-entry rel kb))) (cond ((or (null entry) (not (sc-predicate? entry))) nil) (t (let ((above nil)) (map-over-sc-field #'(lambda (entry) (pushnew (sc-item entry) above :test 'equal)) entry 'sc-genlpreds) above))))) (defun all-specpreds (rel &key (kb *kb*)) (let ((entry (find-sc-entry rel kb))) (cond ((or (null entry) (not (sc-predicate? entry))) nil) (t (let ((below nil)) (map-over-sc-field #'(lambda (entry) (pushnew (sc-item entry) below :test 'equal)) entry 'sc-specpreds) below))))) (defun specpred-of? (sub super &key (kb *kb*)) (let ((sube (find-sc-entry sub kb)) (supe (find-sc-entry super kb))) (cond ((or (null sube) (null supe) (not (sc-predicate? sube)) (not (sc-predicate? supe))) nil) ((some #'(lambda (s) (eq s supe)) (sc-genlpreds (sc-details sube))) t) (t (search-for-sc-targets (sc-genlpreds (sc-details sube)) (list supe) 'sc-genlpreds))))) (defun search-for-sc-targets (seeds targets extractor) "Returns t if any of the targets can be reached from the seeds via extractor" (do ((queue (copy-list seeds) (nconc (cdr queue) new)) (found? nil) (new nil nil) (visited nil)) ((or (null queue) found?) found?) (let ((current (car queue))) (cond ((member current targets) ;; Bingo (setq found? t)) (t (push current visited) (dolist (candidate (funcall extractor (sc-details current))) (unless (or (member candidate visited) (member candidate queue)) (push candidate new)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Mapping utilities ;;; FIRE developer level: map-over-genls, map-over-specs (defun map-over-genls (procedure col &key (kb *kb*)) (let ((entry (find-sc-entry col kb))) (when (or (null entry) (not (sc-collection? entry))) (return-from map-over-genls nil)) (with-kb kb (map-over-sc-field #'(lambda (sc-col) (funcall procedure (sc-item sc-col))) entry 'sc-genls)))) (defun map-over-specs (procedure col &key (kb *kb*)) (let ((entry (find-sc-entry col kb))) (when (or (null entry) (not (sc-collection? entry))) (return-from map-over-specs nil)) (with-kb kb (map-over-sc-field #'(lambda (sc-col) (funcall procedure (sc-item sc-col))) entry 'sc-specs)))) (defun map-over-sc-field (procedure seed extractor) (do ((queue (copy-list (funcall extractor (sc-details seed))) (nconc (cdr queue) new)) (new nil nil) (visited nil)) ((null queue)) (let ((current (car queue))) (funcall procedure current) (push current visited) (dolist (candidate (funcall extractor (sc-details current))) (unless (or (member candidate visited) (member candidate queue)) (push candidate new)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; End of Code