;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: gfr.lsp
;;;;    System: 
;;;;    Author: Ken Forbus
;;;;   Created: January 4, 2004 17:47:44
;;;;   Purpose: The Grim Fact Reaper
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Tuesday, March 16, 2004 at 22:27:51 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)

(defun grim-fact-reaper (&key (deadly? nil)
                              (log? nil)
                              (verbose? t)
                              (frequency 1000)
                              (log-file (qrg::make-qrg-file-name
                                         fire::*fire-path*
                                         "gfr-log.lsp"))
                              (kb fire::*kb*))
  (if log?
    (start-gfr-log-file log-file kb))
  (let ((n-facts 0)
        (n-losers 0)
        (line-feed (* frequency 20)))
    (map-over-kb #'(lambda (fact)
                     (incf n-facts)
                     (when verbose?
                       (if (= (rem n-facts line-feed) 0)
                         (format t "~%"))
                       (if (= (rem n-facts frequency) 0)
                         (format t ".")))   
                     (cond ((legal-expression? fact))
                           (t (incf n-losers)
                              (if verbose?
                                (format t "~%~A" fact))
                              (if log?
                                (append-form-to-file fact
                                                     log-file))
                              (if deadly?
                                (kb-forget fact :kb kb)))))
                 kb)
    (list n-facts n-losers)))

(defun start-gfr-log-file (file kb)
  (with-open-file (fout file
                        :direction :output
                        :if-exists :supersede)
    (format fout ";;;; Grim Fact Reaper log for ~A." (name kb))))

(defun append-form-to-file (form file)
  (with-open-file (fout file
                        :direction :output
                        :if-exists :append)
    (format fout "~%~S" form)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Old start

(defvar *issues* nil)

(defun find-arity-issues (&key (kb *kb*))
  (setq *issues* nil)
  (map-over-sc-entries #'(lambda (e)
                           (when (sc-predicate? e)
                             (let ((issue (check-arity-data-for (sc-item e)
                                                                :kb kb)))
                               (when issue 
                                 (pprint issue)
                                 (push issue *issues*)))))
                       (structural-cache kb))
  *issues*)

(defun check-arity-data-for (predicate &key (kb *kb*))
  (let* ((from-declarations (arity-evidence-from-declarations predicate :kb kb))
         (from-collections (arity-evidence-from-collections predicate :kb kb))
         (from-arg-isas (arity-evidence-from-arg-isas predicate :kb kb))
         (candidates (union from-declarations from-collections)))
    (if (and from-arg-isas 
             (every #'(lambda (candidate) (> from-arg-isas candidate))
                    candidates))
             (pushnew from-arg-isas candidates))
    (cond ((> (length candidates) 1) ;; Ambiguity
           (let ((usage (arity-evidence-from-usage predicate candidates :kb kb)))
             (cond ((integerp usage)
                    `(:ambiguous ,predicate :data (,from-declarations ,from-collections
                                                                      ,from-arg-isas
                                                                      ,usage)
                                 :suggest ,usage))
                   ((null usage)
                    `(:ambiguous-floating
                      ,predicate :data (,from-declarations ,from-collections
                                                           ,from-arg-isas
                                                           ,usage)))
                   (t `(:ambiguous-inconsistent
                        ,predicate :data (,from-declarations ,from-collections
                                                           ,from-arg-isas
                                                             ,usage))))))
          ((= (length candidates) 1) nil)
          (t nil))))

(defun arity-evidence-from-declarations (predicate &key (kb *kb*))
  (let ((arity-facts (retrieve `(data::arity ,predicate ?arity)
                               :kb kb :response '?arity)))
    (delete nil
            (mapcar #'(lambda (arity)
                        (cond ((and (integerp arity) (> arity -1)) arity)
                              (t ;; Bogus fact
                               (let ((bogus `(data::arity ,predicate ,arity)))
                                 (write-to-sc-log `(:inconsistent-arity-fact
                                                    ,bogus :deleted))
                                 (fire::forget bogus)))))
              arity-facts))))

(defun arity-evidence-from-collections (predicate &key (kb *kb*))
  (let ((arity-by-type nil))
    (dolist (implied '((1 UnaryRelation)
                       (2 BinaryRelation)
                       (3 TernaryRelation)
                       (4 QuaternaryRelation)
                       (5 QuintaryRelation))
                     arity-by-type)
      (when (instance-of? predicate (cadr implied) kb)
        (push (car implied) arity-by-type)))))

(defvar *argisa-relns* '((1 . data::arg1Isa)
                         (2 . data::arg2Isa)
                         (3 . data::arg3Isa)
                         (4 . data::arg4Isa)
                         (5 . data::arg5Isa)
                         (6 . data::arg6Isa)
                         (7 . data::arg7Isa)))
 

(defun arity-evidence-from-arg-isas (predicate &key (kb *kb*))
  (let ((candidate -1))
    (dolist (implied *argisa-relns*)
      (when (retrieve `(,(cdr implied) ,predicate ?col)
                      :kb kb)
        (if (> (car implied) candidate)
          (setq candidate (car implied)))))
    (dolist (other (retrieve `(argIsa ,predicate ?n ?col)
                             :kb kb :response '?n))
      (if (> other candidate) (setq candidate other)))
    (if (> candidate -1) candidate nil)))
                      
(defun arity-evidence-from-usage (predicate candidates &key (kb *kb*))
  (let ((facts-retrieved
         (mapcar #'(lambda (arity) (cons arity
                                         (retrieve (cons predicate
                                                         (make-n-long-var-list arity))
                                                   :kb kb)))
           candidates)))
    (setq facts-retrieved (delete-if #'(lambda (entry) (null (cdr entry)))
                                     facts-retrieved))
    (cond ((= (length facts-retrieved) 1) ;; Got it
           (caar facts-retrieved))
          ((null facts-retrieved) nil)
          (t (mapcar 'car facts-retrieved)))))

(defun make-n-long-var-list (n)
  (let ((vars nil))
    (dotimes (i n (nreverse vars))
      (push (intern (format nil "?~D" i)) vars))))

(defun nuke-arity-arg-isas-for (predicate arity &key (kb *kb*))
  (dolist (fact (retrieve `(data::argIsa ,predicate ,arity ?col)
                          :kb kb))
    (write-to-sc-log `(:delete ,fact :arity-ambiguity ,predicate))
    (forget fact :kb kb))
  (let ((rel (assoc arity *argisa-relns* :test '=)))
    (when rel
      (dolist (fact (retrieve `(,(cdr rel) ,predicate ?col)
                              :kb kb))
        (write-to-sc-log `(:delete ,fact :arity-ambiguity ,predicate))
        (forget fact :kb kb)))))
           
           
           
           
           

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