;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                        -*-
;;;; -------------------------------------------------------------------------
;;;; File name: knowledge-entry-api.lsp
;;;;    System: FIRE
;;;;   Version: 1.0
;;;;    Author: Tom Hinrichs
;;;;   Created: July 9, 2003
;;;;   Purpose: KB Metadata accessors
;;;;  Modified: Monday, January 5, 2004 at 11:32:39 by hinrichs
;;;; -------------------------------------------------------------------------

;;; This knowledge entry api is intended to support automatic meta-data 
;;; capture.  It forms a layer of accessors above the fire kb-api
;;; to handle user and timestamping of assertions, cases and case libraries.
;;; It also provides a flat-file case-dumper to support checkpointing and
;;; review.
;;; 10/23/03 We have decided not to use the specialized bdl table for 
;;; metadata, in order to permit querying for assertions based on metadata.

(in-package :fire)

;;; Users
;;; In order to have a knowledge engineering process, we must have 
;;; representations of users/knowledge engineers.  Here are some routines
;;; to support that.
;;; Note: login is for metadata capture, not security.

(defvar *fire-user* nil "The currently logged in knowledge-enterer")

(defun login (username &key (reasoner *reasoner*))
  (cond ((is-human-cyclist-p username :reasoner reasoner)
         (setf *fire-user* username))
        (t (warn "Not a valid user: ~A" username))))

(defun logout ()
  (setf *fire-user* nil))

(defun is-human-cyclist-p (username &key (reasoner *reasoner*))
  (ask (make-isa username 'data::HumanCyclist) reasoner :all 1 :pattern :all))

;;; define-user <name> to create an instance of HumanCyclist
(defun define-user (username &key (reasoner *reasoner*))
  (cond ((is-human-cyclist-p username :reasoner reasoner)
         (warn "User already exists")
         username)
        ((ask (make-isa username '?x) reasoner :all :all '?x :all)
         (warn "Term already exists - pick another username")
         nil)
        (t (store (make-isa username 'data::HumanCyclist) (kb reasoner))
           username)))

#+common-graphics
(defun require-login (&key (reasoner *reasoner*))
  "A more user-friendly front end to requiring login"
  (unless *fire-user*
    (multiple-value-bind (s1 s2 button-label acceptedp)
        (cg:ask-user-for-string "Please login:" nil "~OK" nil)
      (declare (ignore s2 button-label))
      (when (and acceptedp (not (string-equal s1 "")))
        (let ((sym (intern s1 :data)))
          (cond ((is-human-cyclist-p sym :reasoner reasoner)
                 (setf *fire-user* sym))
                ((ask (make-isa sym '?x) reasoner :all :all '?x :all)
                 (cg:pop-up-message-dialog (cg:screen cg:*system*) "Invalid login" 
                                           (format nil "~A cannot be a username" sym) 
                                           cg:error-icon "~Cancel")
                 nil)
                ((maybe-make-user sym :reasoner reasoner)
                 (setf *fire-user* sym))
                (t nil)))))))

#+common-graphics
(defun maybe-make-user (username &key (reasoner *reasoner*))
  (let* ((prompt (format nil "~A doesn't exist.  Would you like to create a new user?" username))
         (answer (cg:ask-user-for-choice prompt "~Yes" "~No")))
    (when (string-equal answer "~Yes")
      (define-user username :reasoner reasoner))))


#-common-graphics
(defun require-login (&key (reasoner *reasoner*))
  "A more user-friendly front end to requiring login"
  (unless *fire-user*
    (format t "~%Please login: ")
      (let ((s1 (read-line)))
        (unless (string-equal s1 "")
          (let ((sym (intern s1 :data)))
            (cond ((null sym) nil)
                  ((is-human-cyclist-p sym :reasoner reasoner)
                   (setf *fire-user* sym))
                  ((ask (make-isa sym '?x) reasoner :all :all '?x :all)
                   (warn "~A cannot be a username" sym)
                   nil)
                  ((maybe-make-user sym :reasoner reasoner)
                   (setf *fire-user* sym))
                  (t nil)))))))

#-common-graphics
(defun maybe-make-user (username &key (reasoner *reasoner*))
  (when (y-or-n-p "~A doesn't exist.  Would you like to create a new user?" username)
    (define-user username :reasoner reasoner)))


(defun makeCreator (expr)
  (and *fire-user*
       (list (if (mixed-case?) 'data::myCreator 'data::my-creator) expr *fire-user*)))

   
;;; Libraries and cases
;;; Promote concepts of cases and libraries to provide minimal partitioning
;;; and quarantine of axioms (as well as support retrieval and analogy)
;;; These routines make it easier to create explicit cases and libraries and
;;; maintain metadata for them.

(defvar *current-library* nil 
  "Holds the atomic term representing the name of the explicit case library")

(defvar *current-case* nil 
  "Holds the atomic term representing the name of the explicit case")

(defun set-current-case (casename)
  (setf *current-case* casename))

(defun set-current-library (libname)
  (setf *current-library* libname))

;;; Kind of syntactic sugar, but it's worth it:
(defun create-case-library (libname &key (reasoner *reasoner*))
  "Add a new case library to the kb & set up the appropriate fire datastructures"
  (let* ((lib (if (mixed-case?) 'data::CaseLibrary 'data::case-library))
         (isa-stmt (make-isa libname lib)))
    (unless (ask isa-stmt reasoner :all 1 :pattern :all)
      (store-concept-w-metadata isa-stmt :reasoner reasoner))
    (when (analogy-source-of reasoner)
      (get-case-library (make-case-library libname) (analogy-source-of reasoner)))
    (set-current-library libname)))


(defun create-case (casename &key (reasoner *reasoner*))
  "Creates a case if it doesn't exist already and adds it to *current-library* if bound"
  (unless (ask `(data::isa ,casename data::Case) reasoner :all 1 :pattern :all)
    (store-concept-w-metadata (make-isa casename 'data::Case) :reasoner reasoner)
    (setf *current-case* casename)
    (when *current-library*
      (add-to-caseLib *current-case* *current-library* :reasoner reasoner))))


(defun add-to-caseLib (case lib &key (reasoner *reasoner*))
  "Takes a name corresponding to an explicit case, and stores an elementOf statement"
  (let* ((case-term (make-explicit-case-fn case))
         (lib-term (make-case-library lib))
         (stmt (make-element-statement case-term lib-term)))
    (unless (ask stmt reasoner :all 1 :pattern :all)
      (store-axiom-w-metadata stmt :reasoner reasoner)
      t)))


(defun library-members (lib &key (reasoner *reasoner*))
  "Return a list of names of cases that belong to the explicit case library lib"
  (let* ((case-term (make-explicit-case-fn '?case))
         (lib-term (make-case-library lib))
         (stmt (make-element-statement case-term lib-term)))
    (ask stmt reasoner :all :all '?case :all)))
   

(defun store-in-case (expr &key (*current-case* *current-case*) (reasoner *reasoner*))
  "Store expression in current case, with metadata"
  (if (null *current-case*)
    (warn "No current case")
    (store-axiom-w-metadata (make-case-fact *current-case* expr) :reasoner reasoner)))

(defun store-concept-w-metadata (expr &key (reasoner *reasoner*))
  (require-login :reasoner reasoner)
  (let ((metadata (list (makeCreator expr)
                        (makeCreationTime expr)
                        (makeCreationSecond expr))))
    (store-with-metadata expr metadata :reasoner reasoner)))


(defun store-axiom-w-metadata (expr &key (reasoner *reasoner*))
  (require-login :reasoner reasoner)
  (let ((metadata (list (makeCreator expr)
                        (makeAssertionTime expr))))
    (store-with-metadata expr metadata :reasoner reasoner)))


(defun store-with-metadata (expr metadata &key (reasoner *reasoner*))
  "Store an expression along with metadata (passed in as an association list)"
  (store expr (kb reasoner))
  (dolist (m metadata) 
    (when m
      (store m (kb reasoner)))))

;;;
;;; Case Dumping
;;;

(defun pprint-case-fn (term &optional casePred (stream *standard-output*))
  "Pretty-print case to stream in a format amenable to re-loading" 
  (let* ((caseFn (if (and casePred (not (eql casePred 'cl-user::ExplicitCaseFn)))
                  (list casePred term)
                   term))
         (assertions (fire::retrieve
                      (list 'cl-user::ist-Information caseFn 'cl-user::?x)
                      :response 'cl-user::?x)))
    (dolist (assertion assertions)
      (pprint assertion stream))))

(defun dump-case-to-file (term file-name &optional casePred)
  "Dump case to a flat file to in a format amenable to re-loading"
  (with-open-file (fout file-name 
                        :direction :output
                        :if-exists :rename 
                        :if-does-not-exist :create)
    (princ (make-isa term 'Case) fout)
    (terpri fout)
    (pprint-case-fn term casePred fout)
    (terpri fout)
    (finish-output fout)))

#+common-graphics
(defun dump-case (term &optional casePred)
  (let ((path (cg:ask-user-for-new-pathname
               "Save As"
               :initial-name (concatenate 'string (symbol-name term) ".meld")
               :warn-if-exists-p nil
               :allowed-types '(("Meld files" . "*.meld")
                                ("All files" . "*.*")))))
    (when path
      (dump-case-to-file term path casePred))))

;;;
;;; Time
;;;

(defun makeCreationTime (expr)
  (list 'data::myCreationTime expr (universal-time->cyc-time)))

(defun makeCreationSecond (expr)
  (list 'data::myCreationSecond expr (universal-time->cyc-seconds)))

(defun makeAssertionTime (expr)
  (list 'data::myAssertionTime expr (universal-time->cyc-time)))

(defun universal-time->cyc-seconds ()
  (multiple-value-bind 
        (seconds minutes hour day month year 
                 day-of-week daylight-saving-time-p time-zone)
      (get-decoded-time)
    (declare (ignore day month year day-of-week daylight-saving-time-p time-zone))
    (+ seconds (* 100 minutes) (* 10000 hour))))

(defun universal-time->cyc-time ()
  (multiple-value-bind 
        (seconds minutes hour day month year 
                 day-of-week daylight-saving-time-p time-zone)
      (get-decoded-time)
    (declare (ignore seconds minutes hour day-of-week daylight-saving-time-p time-zone))
    (+ day (* 100 month) (* 10000 year))))

;;;
;;; Accessors
;;;

(defun bookkeeping-data (expr &key (kb *kb*))
  "Return an association list of metadata about expression expr"
  (flet ((retrieve-metadata (pred)
           (let* ((query (list pred expr '?X))
                  (result (retrieve query :kb kb :coverage :ground :number 1 :response '?X)))
             (when (consp result)
               (list (list pred (car result)))))))
  (mapcan #'retrieve-metadata
    'data::(comment
            myCreator 
            myCreationDate     ;; Why don't we just store this as universal-time?
            myCreationTime     ;; format =  yyyymmdd
            myCreationSecond   ;; format =  hhmmss
            myAssertionTime    ;; format =  yyyymmdd
            myCreationPurpose
            myReviewer
            constantCopiedFrom
            sourceOfTerm))))


(defun set-bookkeeping-data (expr data-alist &key (kb *kb*))
  "Sets the bookkeeping data for expression to the specified association list"
  (flet ((set-metadata (pred-val-pair)
           (let ((assertion (list (car pred-val-pair) expr (cdr pred-val-pair))))
             (store assertion kb))))
    (mapc #'set-metadata data-alist)))

;;;
;;; API functions as listed in Fire documentation:
;;;

;;; Ok this one's kind of ridiculous.  If we don't use the bdl table,
;;; then we don't need to force all metadata into alists, so this 
;;; should probably be streamlined.
(defun set-comment (expr comment &key (kb *kb*))
  (set-bookkeeping-data expr (cons 'data::comment comment) :kb kb))


;;; This should probably return things like backchainForbidden, etc
(defun control-info (expr &key (kb *kb*))
  "Return an association list of control information about expr."
  (declare (ignore expr kb))
   )

(defun clauses-for (goal &key constraints (kb *kb*))
  "Return clause-indexes for specified goal"
  (declare (ignore goal constraints kb))
   )

;;; End of Code