;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: minimal-ascension.lsp
;;;;    System: 
;;;;    Author: Ken Forbus
;;;;   Created: July 5, 2003 15:06:54
;;;;   Purpose: Support for minimal ascension during analogical matching
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Saturday, July 5, 2003 at 16:52:56 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)


;;;; Minimal ascension is a strategy in tiered identicality, the first thing
;;;; that is tried when appropriate and strong identicality has failed.
;;;;
;;;; Subtlety: When the predicates are attributes, we want to use the genls
;;;; hierarchy.  When the predicates are relations, we want to use the genlPreds
;;;; hierarchy.  

(defmethod sme::minimal-ascension-satisfied? ((base-pred sme::predicate)
                                              (target-pred sme::predicate)
                                              (vocabulary analogy-source))
  (check-minimal-ascension-satisfaction
   (sme::name base-pred) (sme::name target-pred) (reasoner vocabulary)
   (max-minimal-ascension-depth vocabulary)))

(defun check-minimal-ascension-satisfaction (bpred tpred reasoner max-depth)
    (unless (integerp max-depth)
      ;; Not currently in use for this analogy source
      (return-from check-minimal-ascension-satisfaction (values nil nil)))
    (cond ((collection? bpred)
           (cond ((collection? tpred)
                  (check-minimal-ascension-for-attributes
                   bpred tpred reasoner max-depth))
                 (t (values nil nil))))
          ((and (relation? bpred)
                (relation? tpred))
           (check-minimal-ascension-for-relations
            bpred tpred reasoner max-depth))
          (t (values nil nil))))

(defun check-minimal-ascension-for-attributes (bpred tpred reasoner max-depth)
  (with-kb (kb reasoner)
    (find-a-minimal-superordinate bpred tpred max-depth 'immediate-genls)))

(defun check-minimal-ascension-for-relations (bpred tpred reasoner max-depth)
  (with-kb (kb reasoner)
    (find-a-minimal-superordinate bpred tpred max-depth 'genlPreds)))

(defun find-a-minimal-superordinate (bpred tpred max-depth parent-procedure)
  ;; We already know that bpred and tpred are different or we wouldn't have arrived here
  ;; However, it could be that one of them is a superordinate of the other, so we have
  ;; to march upwards carefully. 
  (do ((base-aboves (list (list :other bpred)))
       (target-aboves (list (list :other tpred)))
       (base-candidates nil nil)
       (target-candidates nil nil)
       (common nil)
       (current-depth 0))
      ((or common (> current-depth max-depth))
       (if common (values common current-depth)
         (values nil nil)))
    (incf current-depth)
    ;; Find next layer up
    (setq base-candidates (get-unique-predicate-layer-above
                           parent-procedure base-aboves))
    (setq target-candidates (get-unique-predicate-layer-above
                             parent-procedure target-aboves))
    ;; Now look for overlap between the current layers and the previous layers.
    ;; Arrange the search to look for the smallest first.
    (multiple-value-bind (found at-depth)
        (find-minimal-superordinate-between
         base-candidates target-aboves current-depth)
      (cond (found ;; Got it!
             (setq common found current-depth at-depth))
            (t (multiple-value-bind (found at-depth)
                   (find-minimal-superordinate-between
                    target-candidates base-aboves current-depth)
                 (cond (found ;Got it!
                        (setq common found current-depth at-depth))
                       (t (let ((found (intersection base-candidates target-candidates
                                                      :test 'equal)))
                            (cond (found 
                                   (setq common (car found))) ;; Arbitrary
                                  (t ;; Set things up for the next layer
                                   (setq base-aboves (nconc base-aboves
                                                            (list (cons current-depth
                                                                        base-candidates)))
                                       target-aboves (nconc target-aboves
                                                            (list (cons current-depth
                                                                        target-candidates)))))))))))))))

(defun get-unique-predicate-layer-above (parent-procedure lattice-so-far)
  ;; lattice-so-far = list of entries of form (<depth> . <elements>),
  ;;    in increasing order (so must expand from last)
  ;; parent-procedure = immediate-genls or genlPreds, gets next layer
  ;; Since it's a lattice, we need to filter out those elements
  ;; which appear at some earlier level, or multiple equivalent length
  ;; paths at this level
  (let ((new-layer nil))
    (dolist (start (cdr (car (last lattice-so-far))) new-layer)
      (dolist (candidate (funcall parent-procedure start))
        (cond ((member candidate new-layer :test 'equal))
              ((some #'(lambda (entry)
                         (member candidate (cdr entry) :test 'equal))
                     lattice-so-far))
              (t (push candidate new-layer)))))))

(defun find-minimal-superordinate-between (candidates ordered-lattice depth)
  ;; candidates = list of predicates/collections
  ;; ordered-lattice = ((<depth> . <candidates>) ...), in min order first.
  (dolist (lattice-layer ordered-lattice (values nil nil))
    (let ((winners (intersection candidates (cdr lattice-layer)
                                 :test 'equal)))
      (when winners
        (return-from find-minimal-superordinate-between
          (values (car winners) ;; Arbitrary, pick one
                  (cond ((integerp (car lattice-layer)) (car lattice-layer))
                        (t depth))))))))

(defun compute-predicate-lattice-above (seed parent-procedure depth)
  ;; For debugging only
  (let ((lattice (list (list 0 seed))))
    (dotimes (i depth lattice)
      (let ((stuff (get-unique-predicate-layer-above parent-procedure lattice)))
        (setq lattice (nconc lattice (list (cons (1+ i) stuff))))))))


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