;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: sme-translation.lsp
;;;;    System: FIRE
;;;;    Author: Ken Forbus
;;;;   Created: October 25, 2002 15:54:33
;;;;   Purpose: Handles expression translations between FIRE and SME
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Wednesday, December 10, 2003 at 16:57:20 by hinrichs
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;;; This subsystem handles translations between SME and FIRE.
;;;; For example, attributes in SME are handled as unary predicates.
;;;; The distinction between attributes and relations is fundamental psychologically.
;;;; But in FIRE, we use the Cyc ISA convention, for efficient reasoning.
;;;;  [One never wants to write patterns like (?attribute ?x)!]
;;;; This would make attribute statements look like relations, which is not correct
;;;; psychologically.  
;;;; Similarly, the Cyc notion of attribute, which uses various relationships to make
;;;; different types of attributions, needs to be translated into unary predicate form
;;;; as well.
;;;; There could also be other translations.
;;;; To handle this in an extensible fashion, we provide the following procedures:
;;;;
;;;; fire->sme-expression and sme->fire-expression translate between the two expression forms.
;;;;
;;;; All of the internals are methods because we want to be able to extend the translations
;;;; without rewriting source code.  Won't always be possible, for instance the
;;;; attribute translations.  But the point is to isolate these translations here, 
;;;; in one place, so they can be used everywhere.
;;;;
;;;; Since statements can be highly nested, we must tree-walk though the entire expression.  
;;;;
;;;; Regarding NAT's: In general, the arguments to a NAT aren't themselves interestingly complex
;;;; expressions.  One exception is KAPPA, which is handled as a special case.

(declaim (special *analogy-source*))

(defun fire->sme-expression (exp &key (source (analogy-source-of fire::*reasoner*)))
  (with-analogy-source source
    (catch 'expression-not-for-sme
           (fire->sme-expression-internal exp))))

(defun fire->sme-expression-internal (exp)
  (cond ((null exp) nil)
        ((not (listp exp)) exp)
        ((not-for-analogy-exp? exp *analogy-source*)
         ;; Punt if NotForAnalogyPredicate appears anywhere in the expression
         (throw 'expression-not-for-sme nil))
        ((and (listp (car exp)) (eq (caar exp) 'data::Kappa))
         (cons (append (list (caar exp) (cadar exp)) ;; Kappa + args
                       (mapcar 'fire->sme-expression-internal (cddar exp)))
               (mapcar 'fire->sme-expression (cdr exp))))
        ((non-atomic-term? (car exp))
         (cons (fire->sme-expression-internal (car exp))
               (mapcar 'fire->sme-expression-internal (cdr exp))))
        (t (if (fire->sme-translation-needed? exp) (setq exp (fire->sme (car exp) (cdr exp))))
           (cons (car exp) ;; Recurse through the arguments
                 (mapcar 'fire->sme-expression-internal (cdr exp))))))

(defun sme->fire-expression (exp)
  (cond ((null exp) nil)
        ((not (listp exp)) exp)
        ((and (listp (car exp)) (eq (caar exp) 'data::Kappa))
         (cons (append (list (caar exp) (cadar exp))
                       (mapcar 'sme->fire-expression (cddar exp)))
               (mapcar 'sme->fire-expression (cdr exp))))
;;;        ((non-atomic-term? (car exp))
;;;         (cons (car exp) (mapcar 'sme->fire-expression (cdr exp))))
        (t (if (sme->fire-translation-needed? exp)
             (setq exp (sme->fire (car exp) (cdr exp))))
           (cons (car exp)
                 (mapcar 'sme->fire-expression (cdr exp))))))

(defmethod sme->fire-translation-needed? ((statement list))
  (let ((pred (car statement)))
    (cond ((eq :attribute (fire:predicate-type pred)) t)  ;; Catch isas
          ((sme->fire-translation-NAT-needed? pred) t)
          (t nil))))

(defmethod fire->sme-translation-needed? ((statement list))
  (cond ((isa-statement? statement) t)
        ((fire->sme-translation-NAT-needed? (car statement)) t)
        (t nil)))

(defmethod sme->fire-translation-needed? ((statement t)) nil)
(defmethod fire->sme-translation-needed? ((statement t)) nil)

;;; Not used yet, but suspect that they will be.
(defmethod sme->fire-translation-NAT-needed? ((predicate t)) nil) ;; Default

(defmethod fire->sme-translation-NAT-needed? ((predicate t)) nil) ;; Default

(defmethod fire->sme ((predicate symbol) (arguments list)) 
  (cons predicate arguments))

(defmethod fire->sme ((predicate list) (arguments list))
  (fire->sme-nat (car predicate) (cdr predicate) arguments))

;;;;;; The other direction, from SME internal expressions to FIRE

(defmethod sme->fire ((predicate symbol) (arguments list))
  (cond ((fire::collection? predicate) 
         (cond ((null (cdr arguments))
                (fire:make-isa (car arguments) predicate))
               (t (error "Unexpected collection in predicate position: ~A, ~A"
                    predicate arguments))))
        (t (cons predicate arguments))))

(defmethod sme->fire ((predicate list) (arguments list))
  (cond ((fire::collection? predicate)
         (cond ((null (cdr arguments))
                (fire::make-isa (car arguments) predicate))
               (t (error "Unexpected collection in predicate position: ~A, ~A"
                    predicate arguments))))
        (t (sme->fire-nat (car predicate) (cdr predicate) arguments))))

;; Handling nats in translation -- the defaults are pass-through

(defmethod fire->sme-nat ((predicate symbol) (nat-arguments list)
                          (arguments list))
  (cons (cons predicate nat-arguments) arguments))

(defmethod sme->fire-nat ((predicate symbol) (nat-arguments list)
                          (arguments list))
  (cons (cons predicate nat-arguments) arguments))

;; What about nested NAT's?  Well, here's our default answer:

(defmethod fire->sme-nat ((predicate list) (nat-arguments list)
                          (arguments list))
  (cons (fire->sme-nat (car predicate) (cdr predicate) nat-arguments)
        arguments))

(defmethod sme->fire-nat ((predicate list) (nat-arguments list)
                          (arguments list))
  (cons (sme->fire-nat (car predicate) (cdr predicate)
                       nat-arguments)
        arguments))

;;; Handling ISA's

(defmethod fire->sme-translation-needed? ((predicate (eql 'data::isa))) t)

(defmethod fire->sme ((predicate (eql 'data::isa)) (arguments list))
  (list (second arguments) (first arguments)))

;;;;;;;; A bit of debugging
;; ******* Move to a utilities file later 

(defun count-atoms-if (tree &key (test #'(lambda (x) 
                                           (declare (ignore x))
                                           t)))
  (cond ((null tree) 0)
        ((not (consp tree))
         (if (funcall test tree) 1 0))
        (t (+ (count-atoms-if (car tree) :test test)
              (count-atoms-if (cdr tree) :test test)))))


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