;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: analogy-tests.lsp
;;;;    System: Fire
;;;;    Author: Ken Forbus
;;;;   Created: July 5, 2003 15:01:52
;;;;   Purpose: Testing analogy facilities
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Monday, May 31, 2004 at 20:30:13 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :common-lisp-user)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Unit testing for analogy subsystem

(eval-when (:compile-toplevel :load-toplevel :evaluate)
  (proclaim '(special a r))) ;; debugging hooks

(defun test-analogy-reasoner (&key (reasoner fire::*reasoner*))
  (fire::with-kb (fire::kb reasoner)
    ;; Assumes reasoner and KB are already around 
    (setq a (fire::analogy-source-of reasoner)
        r reasoner) ; set debugging hooks
    (fire::tell-all saturn-snapshot-2-5-04 reasoner :shakedown :every)
    (fire::tell-all mars-snapshot-2-5-04 reasoner :shakedown :every)
    (let ((matcher 
           (car (fire::ask-it '(matchBetween (WMCaseFn (ExplicitCaseFn SaturnSnapshot-2-5-04))
                                             (WMCaseFn (ExplicitCaseFn MarsSnapshot-2-5-04))
                                             (TheSet) ?matcher) :response '?matcher)))
          (okay? t))
      ;; Spot checks of reification
      (let ((n (car (fire::ask-it `(numberOfCorrespondences ,matcher ?n) :response '?n))))
        (unless (and (numberp n) (= n 58))
          (setq okay? nil)
          (warn "Number of correspondences in ~A should be 58, was ~A." matcher n)))
      (let ((n (car (fire::ask-it `(numberOfMappings ,matcher ?n) :response '?n))))
        (unless (and (numberp n) (= n 1))
          (setq okay? nil)
          (warn "Wrong number of mappings: ~A instead of 1.")))
      (let ((mapping (car (fire::ask-it `(bestMapping ,matcher ?m) :response '?m))))
        ;; Exactly which mapping it is will depend on SME internals that might change.
        ;; But if the overall properties of the best are different, that's worth noting.
        (cond ((not (sme::mapping? (fire::sme-referent mapping reasoner)))
               (setq okay? nil)
               (warn "Failure to retrieve mapping ~A from matcher ~A." mapping matcher))
              (t ;; If not a mapping, none of these will work
               (let ((n (car (fire::ask-it `(numberOfCorrespondences ,mapping ?n) :response '?n))))
                 (unless (and (numberp n) (= n 41))
                   (setq okay? nil)
                   (warn "Number of correspondences in ~A should be 41, was ~A." mapping n))
                 (setq n (car (fire::ask-it `(numberOfCandidateInferences ,mapping ?n) :response '?n)))
                 (unless (= n 2)
                   (setq okay? nil)
                   (warn "Number of candidate inferences in ~A should be 2, was ~A." mapping n))))))
      okay?)))
              
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Test cases for matching
;;;
;;; This is a fairly random "found" example.  
;;; It would be nice to replace it with an updated classic.

(defparameter saturn-snapshot-2-5-04
      '((ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (conceptuallyRelated Titan-MoonOfSaturn PlanetSaturn))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (orbits Titan-MoonOfSaturn PlanetSaturn))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (spacecraftDestination Cassini-Probe PlanetSaturn))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (groupMembers SolarSystem PlanetSaturn))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (definingMt PlanetSaturn SimpleAstronomyDataVocabularyMt))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (isa PlanetSaturn CelestialObject))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (inRegion PlanetSaturn Ecliptic))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (isa PlanetSaturn Entity))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (isa PlanetSaturn Individual))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (massOfObject PlanetSaturn (MetricTon 5.68e+23)))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (isa PlanetSaturn GasGiant))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (isa PlanetSaturn Planet))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (nameString PlanetSaturn "Saturn"))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (orbits PlanetSaturn Sun))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (distanceBetween Sun PlanetSaturn ((Mega Mile) 900)))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (largerThan PlanetJupiter PlanetSaturn massOfObject))
        (ist-Information (ExplicitCaseFn SaturnSnapshot-2-5-04)
                         (largerThan PlanetSaturn PlanetNeptune massOfObject))))
  
(defparameter mars-snapshot-2-5-04
  '((ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (orbits Deimos-MoonOfMars PlanetMars))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (conceptuallyRelated Deimos-MoonOfMars PlanetMars))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (conceptuallyRelated Phobos-MoonOfMars PlanetMars))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (orbits Phobos-MoonOfMars PlanetMars))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (groupMembers SolarSystem PlanetMars))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (definingMt PlanetMars SimpleAstronomyVocabularyMt))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (inRegion PlanetMars Ecliptic))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (isa PlanetMars TerrestrialPlanet))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (orbits PlanetMars Sun))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (nameString PlanetMars "Mars"))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (massOfObject PlanetMars (MetricTon 6.42e+20)))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (isa PlanetMars CelestialObject))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (isa PlanetMars Individual))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (isa PlanetMars Entity))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (isa PlanetMars Planet))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (distanceBetween Sun PlanetMars ((Mega Mile) 141)))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (largerThan PlanetVenus PlanetMars massOfObject))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (largerThan PlanetMars PlanetMercury massOfObject))
    (ist-Information (ExplicitCaseFn MarsSnapshot-2-5-04)
                     (between PlanetMars PlanetJupiter AsteroidBelt))))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Shakedown via exhaustive testing of explicit cases
;;;
;;; This is a good thing to do when debugging or gathering performance data.

(defun list-all-cases ()
  (remove-duplicates (fire::ask (fire::make-case-fact '?case '?fact) fire::*reasoner*
                          :any :all '?case :lookup-only)
                     :test 'equal))


(defun with-timed-matches (case-pairs procedure)
  ;; N.B. This version just runs SME directly, so that reification doesn't
  ;; occur.  This is for generating runtime data for the SME paper.
  ;; We'll use the other version for optimizing the SME/FIRE interface.
  ;; case-pairs are dotted pairs of case terms suitable for match-between
  ;; Procedure takes two arguments, the SME and the time the match took.
  (let ((source (fire::analogy-source-of fire::*reasoner*)))
    (dolist (case-pair case-pairs)
      (let* ((base (fire::get-dgroup (car case-pair) source))
             (target (fire::get-dgroup (cdr case-pair) source))
             (end-time nil)
             (sme (sme::define-sme base target))
             (start-time (get-internal-real-time)))
        (sme:match-with-appropriate-filters sme nil)
        (setq end-time (get-internal-real-time))
        (funcall procedure sme::*sme* (/ (- end-time start-time)
                                         (float internal-time-units-per-second)))))))

;;;(defun with-timed-matches (case-pairs procedure)
;;;  ;; case-pairs are dotted pairs of case terms suitable for match-between
;;;  ;; Procedure takes two arguments, the SME and the time the match took.
;;;  (dolist (case-pair case-pairs)
;;;    (let* ((base (car case-pair))
;;;           (target (cdr case-pair))
;;;           (end-time nil)
;;;           (start-time (get-internal-real-time)))
;;;      (ask (make-match-query base target nil '?match) *reasoner*
;;;           :any :all '?match :all)
;;;      (setq end-time (get-internal-real-time))
;;;      (funcall procedure sme::*sme* (/ (- end-time start-time)
;;;                                        (float internal-time-units-per-second))))))

(defun exhaustive-explicit-case-pairs ()
  (let ((all-cases (list-all-cases)))
    (mapcan #'(lambda (case1)
                (mapcar #'(lambda (case2)
                            (cons (fire::make-explicit-case-fn case1)
                                  (fire::make-explicit-case-fn case2))) all-cases))
      all-cases)))

(defun exhaustive-pairwise-explicit-cases-test (&key (stream *standard-output*))
  (let ((min-time 1.0e16)
        (max-time -1.0e-12)
        (total-time 0.0)
        (n-comps 0)
        (fastest-pair nil)
        (slowest-pair nil))
    (with-timed-matches (exhaustive-explicit-case-pairs)
      #'(lambda (sme current-time)
          (let ((pair (format nil "SME(~A,~A)" (sme::name (sme::base sme))
                        (sme::name (sme::target sme)))))
            (when (> current-time max-time)
              (setq max-time current-time slowest-pair pair))
            (when (< current-time max-time)
              (setq min-time current-time fastest-pair pair))
            (incf n-comps)
            (incf total-time current-time)
            (format stream "~%~A: ~G seconds." pair current-time))
          ))
    (format stream "~%~D comparisons." n-comps)
    (format stream "~% Fastest pair: ~A, ~G seconds." fastest-pair min-time)
    (format stream "~% Slowest pair: ~A, ~G seconds." slowest-pair max-time)
    (format stream "~% Average: ~G seconds." (/ total-time (float n-comps)))
    (list n-comps total-time min-time fastest-pair max-time slowest-pair)))

(defun test-all-explicit-dgroups (&optional (reasoner fire::*reasoner*))
  (let ((analogy-source (fire::analogy-source-of reasoner)))
    (when (fire::analogy-source? analogy-source)
      (dolist (case (list-all-cases))
        (format t "~% Trying ~A." case)
        (let* ((end-time 0.0)
               (start-time (get-internal-real-time)))
          (fire::get-dgroup (fire::make-explicit-case-fn case) analogy-source)
          (setq end-time (get-internal-real-time))
          (format t "...~G seconds." (/ (- end-time start-time)
                                        (float internal-time-units-per-second))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun quick-macfac-test ()
  ;; Assumes 344 KB and reasoner are in place
  (let ((result (fire::ask-it '(reminding (MinimalCaseFn PlanetJupiter)
                                    (CaseLibraryInstancesOfFn Planet MinimalCaseFn)
                                          ?reminding ?match)))
        (okay? t))
    (cond ((not (equal (fourth (car result)) '(MinimalCaseFn PlanetJupiter)))
           (setq okay? nil)
           (warn "Jupiter didn't self-retrieve."))
          (t (setq result 
                   (fire::ask-it '(reminding (MinimalCaseFn PlanetJupiter)
                                       (CaseLibrarySansFn
                                        (CaseLibraryInstancesOfFn Planet MinimalCaseFn)
                                        (MinimalCaseFn PlanetJupiter))
                                       ?reminding ?match)))
             (cond ((equal (fourth (car result)) '(MinimalCaseFn PlanetMars)))
                   (t (setq okay? nil)
                      (warn "Jupiter didn't retrieve Mars in sans-self case library.")))))
    okay?))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities for generating test case data
;;;
;;; Since KB contents can change, it is useful to be able to store the contents of a particular
;;; existing dgroup as a set of facts, so that it can be used again.  

(defun dgroup->case-facts (dgroup case-name)
  (let ((case-id `(ExplicitCaseFn ,case-name)))
    (mapcar #'(lambda (exp) (fire::make-case-fact case-id (fire::sme->fire-expression exp)))
      (cdr (sme::lisp-form dgroup)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Old test

;;; Classic test, but the classic SME vocabulary file doesn't pass the
;;; structural cache consistency tests.  Need to fix that, but it's
;;; quite low priority.
;;;(defun test-analogy-reasoner (&optional (title "Test"))
;;;  (unless (typep fire::*kb* 'fire::knowledge-base)
;;;    (fire::make-kb fire::*test-kb-path* fire::*test-kb-name* 
;;;             :new? nil
;;;             :predicate-style :hyphen))
;;;  (unless (eq (fire::state fire::*kb*) :open) (fire::open-kb))
;;;  (setq r (fire::make-reasoner title))
;;;  (fire::add-analogy-source r)
;;;  (setq a (car (fire::sources r)))
;;;  (let ((queries (if (fire::mixed-case?)
;;;                   '((matchBetween (ExplicitCaseFn SolarSystem)
;;;                                         (ExplicitCaseFn RutherfordAtom)
;;;                                         nil 
;;;                                         ?match)
;;;                     (matchBetween (ExplicitCaseFn SwaterFlow)
;;;                                         (ExplicitCaseFn SheatFlow)
;;;                                         nil 
;;;                                         ?match)
;;;                     (matchBetween (ExplicitCaseFn SwaterFlow)
;;;                                         (ExplicitCaseFn SheatFlow)
;;;                                         (TheList (requiredCorrespondence water coffee))
;;;                                         ?match))
;;;                   '((match-between (explicit-case-fn solar-system)
;;;                                          (explicit-case-fn rutherford-atom)
;;;                                          nil 
;;;                                          ?match)
;;;                     (match-between (explicit-case-fn swater-flow)
;;;                                          (explicit-case-fn sheat-flow) 
;;;                                          nil 
;;;                                          ?match)
;;;                     (match-between (explicit-case-fn swater-flow)
;;;                                          (explicit-case-fn sheat-flow)
;;;                                          (the-list (required-correspondence
;;;                                                           water coffee))
;;;                                          ?match)))))
;;;    (dolist (query queries)
;;;      (fire::ask query r ;; reasoner
;;;           :any          ;; context
;;;           :all          ;; number
;;;           :pattern      ;; response
;;;           :all)         ;; effort
;;;      (show-vital-stats sme::*sme*))))
;;;
;;;(defparameter *test-cases* '((explicit-case-fn solar-system)
;;;                             (explicit-case-fn rutherford-atom)
;;;                             (explicit-case-fn swater-flow)
;;;                             (explicit-case-fn sheat-flow)))
;;;
;;;
;;;(defun store-test-case-cvs (&optional (analogy-source a))
;;;  (dolist (case *test-cases*)
;;;    (fire::store-case-cv case analogy-source)))
;;;
;;;(defun test-skolem-case (&optional (reasoner r))
;;;  (fire::tell (if (fire::mixed-case?)
;;;          '(ist-Information HeatFlowSituation (isa coffee Inanimate))
;;;          '(ist--information heat-flow-situation
;;;                                 (isa coffee inanimate)))
;;;        reasoner :test :all)
;;;  (fire::tell (if (fire::mixed-case?)
;;;          '(ist-Information HeatFlowSituation (isa silverBar Inanimate))
;;;          '(ist--information heat-flow-situation
;;;                                 (isa silver-bar inanimate)))
;;;        reasoner :test :all)
;;;  (fire::tell (if (fire::mixed-case?)
;;;          '(ist-Information HeatFlowSituation (isa iceCube Inanimate))
;;;          '(ist--information heat-flow-situation
;;;                                 (isa ice-cube inanimate)))
;;;        reasoner :test :all)
;;;  (fire::ask (if (fire::mixed-case?)
;;;         '(seekingMatchBetween (ExplicitCaseFn SwaterFlow) (ExplicitCaseFn HeatFlowSituation)
;;;                                     (TheList (requiredCorrespondence beaker coffee)
;;;                                                    (requiredCorrespondence vial iceCube)
;;;                                                    (requiredCorrespondence pipe silverBar))
;;;                                     ?match)
;;;         '(seeking-match-between 
;;;           (explicit-case-fn swater-flow) (explicit-case-fn heat-flow-situation)
;;;           (the-list
;;;            (required-correspondence beaker coffee)
;;;            (required-correspondence vial ice-cube)
;;;            (required-correspondence pipe silver-bar))
;;;           ?match))
;;;       reasoner :all :all '?match :any))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Shakedown for minimal ascension

;;;(defun minimal-ascension-shakedown (&optional (reasoner fire::*reasoner*))
;;;  ;; Assumes Cyc-compatible KB and reasoner are already set up
;;;  (fire::with-reasoner reasoner
;;;    (let ((analogy-source (fire::analogy-source-of reasoner))
;;;          (results nil))
;;;      (when (fire:analogy-source? analogy-source)
;;;        (let ((old-depth (fire::max-minimal-ascension-depth analogy-source)))
;;;          (declare (ignore old-depth))
;;;          (setf (fire::max-minimal-ascension-depth analogy-source) 3)
;;;          (fire::tell-all '((ist-Information Cat-Case
;;;                                             (implies (isa Nero Cat) (foodSourceFor Nero Mouse))))
;;;                          reasoner :test :every)
;;;          (fire::tell-all '((ist-Information Dog-Case
;;;                                             (implies (isa Biggles Dog) (foodSourceFor Biggles Squirrel))))
;;;                          reasoner :test :every)
;;;          (let* ((result 
;;;                  (fire::ask-it  `(and (matchBetween (ExplicitCaseFn Cat-Case) (ExplicitCaseFn Dog-Case)
;;;                                                     (TheList) ?mapping)
;;;                                       (bestMapping ?mapping (MappingFn ?mapping-ID ?SME-ID)))
;;;                                :response '(?mapping-ID ?SME-ID)))
;;;                 (mapping (fire::lookup-mapping (caar result) (cadar result) analogy-source)))
;;;            (cond ((sme::mapping? mapping)
;;;                   (push (sme::minimal-abstraction mapping) results)
;;;                   (if (equal '((implies (CarnivoreOrder ?Nero) (foodSourceFor ?Nero ?Mouse)))
;;;                              (car results))
;;;                     (format t "~% Minimal ascension working correctly with attributes.")
;;;                     (format t "~% Minimal ascension with attributes failed!")))
;;;                  (t (format t "~% Minimal ascension with attributes failed grossly!"))))
;;;          (fire::tell-all `((ist-Information death-case 
;;;                                             (implies (beneficiary ReceivedInheritance18 Joe)
;;;                                                      (financialState Joe Wealthy))))
;;;                          reasoner :test :every)
;;;          (fire::tell-all `((ist-Information winning-case
;;;                                             (implies (objectActedOn GivingAwayPrizeMoney Jim)
;;;                                                      (financialState Jim Wealthy))))
;;;                          reasoner :test :every)
;;;          (let* ((result 
;;;                 (fire::ask-it `(and (matchBetween (ExplicitCaseFn death-case) (ExplicitCaseFn winning-case)
;;;                                                   (TheList) ?mapping)
;;;                                     (bestMapping ?mapping (MappingFn ?mapping-ID ?SME-ID)))
;;;                               :response '(?mapping-ID ?SME-ID)))
;;;                (mapping (fire::lookup-mapping (caar result) (cadar result) analogy-source)))
;;;            (cond ((sme::mapping? mapping)
;;;                   (push (sme::minimal-abstraction mapping) results)
;;;                   (if (equal '((implies (objectiveOfTask ?ReceivedInheritance18 ?Joe)
;;;                                         (financialState ?Joe ?Wealthy)))
;;;                              (car results))
;;;                     (format t "~% Minimal ascension working correctly with relations.")
;;;                     (format t "~% Minimal ascension with relations failed!")))
;;;                  (t (format t "~% Minimal ascension with relations failed grossly!"))))
;;;          (nreverse results))))))       

 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; End of Code