;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: loader.lsp
;;;;    System: FIRE
;;;;   Version: 1.0
;;;;    Author: Ken Forbus
;;;;   Created: January 12, 2001 15:42:18
;;;;   Purpose: Loading KB's from flat files
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Sunday, January 4, 2004 at 19:34:55 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;; This file contains loaders for flat files of knowledge, especially
;;; imported from other sources.
;;; 
;;; A loader that handles legacy QRG materials from DTE is implemented
;;; in the companion file dt-loader.lsp
;;; 
;;; As of 2001, we are converting to mixed-case KB's from our previous
;;; hyphenated convention.  This is facilitated by switching to
;;; case-sensitive mode in Common Lisp.  It will make it much easier to share
;;; knowledge with Cycorp and with other RKF participants.
;;; 
;;; Interface procedures:
;;; 
;;; (meld-file->kb <file> &optional (kb *kb*)) adds the contents of <file>,
;;; which is presumed to be in MELD format, to kb.

;;; (km-pred-file->kb <file> &optional (kb *kb*)) adds the contenst of <file>,
;;; which is presumed to be in predicate logic form from KM

;;; Cycish reader macro
;;; Since we're using case-sensitive common lisp, this becomes trivial.
;;; This version is due to John Everett

(defun cyc-style-readmacro-absorber (stream char1 char2)
  "Absorbs #$, so that the symbol following it will be returned"
  (declare (ignore stream char1 char2))
  (values))

(set-dispatch-macro-character #\# #\$ #'cyc-style-readmacro-absorber)

(defun meld-file->kb (file 
                      &key (kb *kb*) (context 'data::BaseKB) callback-fn (check-for-mt-type nil))
  (declare (ignore context))  ;; *** for now
  (with-kb kb
    (with-open-file (fin file :direction :input)
      (let ((eof-pointer (cons file file))
            (first-form? t)
            (case nil))
        (do ((form (read fin nil eof-pointer)
                   (read fin nil eof-pointer)))
            ((eq form eof-pointer))
          (when callback-fn
            (funcall callback-fn form fin))
          
          (cond (first-form?
                 (setf first-form? nil)
                 (if check-for-mt-type
                   (when (or (eq (car form) 'data::case)
                             (eq (car form) 'data::Case))
                     (setf case (cadr form))
                     (store (make-isa case 'data::Case) kb))
                   (store form kb)))
                ;;Mts that should be cases must have first form as (case #$CIAWorldFactBook1995)
                ;;Other mts must have first line (microtheory #$BaseKB)
                ;;This check and corrections are done only if check-for-mt-type is true
                                  
                ((not (listp form))) ;; Ignore if not list
                ((contains-dotted-pair? form)) ;; Can't handle these yet
                ((ist-statement? form) ;; Store it and context
                 (store (third form) kb)
                 ;; Workaround for dbex bug: Can't make subexpression a toplevel expression.
;;;                  (store form kb)
                 ;; Workaround: Since we're still figuring out how we want
                 ;; to handle context, we're going to make all of these
                 ;; statements top-level available, storing the IST statement
                 ;; as well to provide context/microtheory information.
                 ;; As we figure out our model, we'll change the way this works,
                 ;; mostly likely using some special-purpose features added to
                 ;; dbex.
                 )
               
                (t (if case (store (make-case-fact case form) kb)
                     (store form kb))
                   ;; Workaround for dbex bug: Can't make subexpression a toplevel expression.
;;                    (store (make-ist-statement context form) kb)
                   )))))))

(defun contains-dotted-pair? (thing)
  (cond ((null thing) nil)
        ((not (consp thing)) nil)
        ((not (or (consp (cdr thing))
                  (null (cdr thing)))) t)
        (t (or (contains-dotted-pair? (car thing))
               (contains-dotted-pair? (cdr thing))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; KM Predicate Logic file import

(defun km-pred-file->kb (file &key (kb *kb*))
  (with-kb kb
    (with-open-file (fin file :direction :input)
      (let ((eof-pointer (cons file file)))
        (do ((expform (read fin nil eof-pointer)
                      (read fin nil eof-pointer)))
            ((eq expform eof-pointer))
          ;; The structure of the form in this file format is:
          ;;  (<class> <base-class> (<ground-binary-prop1> <ground-binary-prop2>...))
          ;; Iterate over each of the ground binary propositions storing them in the 
          ;; kb.  
          ;; The propositions have the form:
          ;;  (<object1> <predicate> <object2>)
          ;; Needs to be restructured to
          ;;  (<predicate> <object1> <object2>)
          ;; and then wrapped in ist-information (ie make-case-fact)
          (if (listp expform) ;; Ignore if not list
            (let ((casename (second expform))
                  (proposition-list (third expform)))
              (dispatch-expr-to-kb (make-isa casename 'data::Case) :kb kb)
              (dolist (prop proposition-list)
                (let ((form (make-case-fact casename 
                                            (list (if (eq (second prop) 'data::instance-of)
                                                    'data::isa
                                                    (second prop))
                                                  (first prop) (third prop)))))
                  (dispatch-expr-to-kb form :kb kb))))))))))


(defun dispatch-expr-to-kb (form &key (kb *kb*))
  (cond ((not (listp form))) ;; Ignore if not list
        ((contains-dotted-pair? form)) ;; Can't handle these yet
        ((ist-statement? form) ;; Store it and context
         (store (third form) kb)
         ;; Workaround for dbex bug: Can't make subexpression a toplevel expression.
         ;;;                  (store form kb)
         ;; Workaround: Since we're still figuring out how we want
         ;; to handle context, we're going to make all of these
         ;; statements top-level available, storing the IST statement
         ;; as well to provide context/microtheory information.
         ;; As we figure out our model, we'll change the way this works,
         ;; mostly likely using some special-purpose features added to
         ;; dbex.
         )
        (t (store form kb)
           ;; Workaround for dbex bug: Can't make subexpression a toplevel expression.
           ;;;                    (store (make-ist-statement context form) kb)
           )))


        
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Hooks for testing/debugging

;; N.B. Changed default to not make a new KB but just open it instead.

(defparameter *ikb-kb-path* (make-qrg-path "fire" "kbs" "ikb"))
(defparameter *ikb-kb-name* "ikb")
(defparameter *ikb-flat-file-path* 
  (make-qrg-path "fire" "flat-files" "cyc"))
(defparameter *ikb-file-name* "ikb-13-H.cyc")
(defparameter *rkf-kb-path* (make-qrg-path "fire" "kbs" "qrg-rkf"))
(defparameter *rkf-kb-name* "QRG-KB")
(defparameter *darpa-kb-path* (make-qrg-path "fire" "kbs" "qrg-darpa"))
(defparameter *darpa-kb-name* "QRG-DARPA")

(defun create-ikb ()
  (make-cyc-style-kb *ikb-kb-path* *ikb-kb-name* :new? t)
  (meld-file->kb (concatenate 'string *ikb-flat-file-path* *ikb-file-name*)))

(defun create-rkf-kb ()
  (make-cyc-style-kb *rkf-kb-path* *rkf-kb-name* :new? t)
  (meld-file->kb (concatenate 'string *ikb-flat-file-path* *ikb-file-name*))
  (meld-file->kb (concatenate 'string *ikb-flat-file-path* "cyc-rkf-extras.meld"))
  (meld-file->kb (concatenate 'string *ikb-flat-file-path* "molecular-biology-cycorp.meld"))
  (meld-file->kb (concatenate 'string *ikb-flat-file-path* "prettyNames.cyc"))
  (meld-file->kb (concatenate 'string *ikb-flat-file-path* "prettyNames-nonplural.cyc"))
  (close-kb))
                 
(defun make-cyc-style-kb (path name &key (new? nil))
  (make-kb path name :new? new?
           :predicate-style :mixed-case))

(defun make-ikb (&key (new? nil))
  (make-cyc-style-kb *ikb-kb-path* *ikb-kb-name* :new? new?))

(defun make-cyc-rkf-kb ()
  ;; We got this from Cycorp, so we cannot reconstruct it
  (make-cyc-style-kb (make-qrg-path "fire" "kbs" "Cyc-RKF")
                     "cyc" :new? nil))

(defun make-qrg-rkf-kb ()
  (make-kb *rkf-kb-path* *rkf-kb-name*
           :new? nil :predicate-style :mixed-case))

(defun make-qrg-darpa-kb ()
  (make-kb *darpa-kb-path* *darpa-kb-name*
           :new? nil :predicate-style :mixed-case))











;;;; ---------------------------------------------------------------------------
;;; END OF CODE