;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: chainer-dumper.lsp
;;;;    System: FIRE v1
;;;;    Author: Ken Forbus
;;;;   Created: February 23, 2004 23:36:12
;;;;   Purpose: Dumps chainers
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Monday, May 31, 2004 at 17:45:56 by Kenneth Forbus
;;;; ---------------------------------------------------------------------------

(in-package :fire)

;;; Adapted from case-library-dumper
;;; Q: Why is/was a string used as the name of a chainer?  Wouldn't a 
;;; symbol be better for indexing?
;;;
;;; Methods added or modified elsewhere:
;;; added file-name slot to chainer class (defs.lsp)
;;; retrieve-chainer  (chainer.lsp)
;;; make-chainer-file-name-expr (make-expr.lsp)
;;; and modifications to bdumper to support dotted lists

(defmethod dump-chainer-file ((chainer-term t) (parent knowledge-base)
                                   &key (verbose? t))
  (let ((chainer (retrieve-chainer chainer-term parent)))
    ;; We will only dump chainers if they exist, to avoid
    ;; time-consuming user mistakes.
    (cond ((null chainer) 
           (when verbose? (format t "~%No cached chainer ~A in ~A."
                            chainer-term (name parent)))           
           nil)
          (t (remove-previous-chainer-caches chainer-term parent)
             (let ((cache-name (generate-chainer-file-cache-name))
                   (resource-path (kb-resource-path parent)))
               (setf (file-name chainer) cache-name)
               (ensure-directories-exist resource-path)
               (when verbose? (format t "Dumping cache of ~A in ~A..." 
                                chainer-term (name parent)))
               (bd-save chainer resource-path cache-name)
               (store (make-chainer-file-name-expr chainer-term cache-name)
                      parent)
               (when verbose? (format t "Done."))
               (update-chainer-dumped-timestamp chainer-term)
               cache-name)))))

(defmethod remove-previous-chainer-caches ((chainer-term t) (parent knowledge-base))
  (let ((names (chainer-file-cache-names chainer-term parent))
        (resource-path (kb-resource-path parent)))
    (dolist (name names)
      (forget (make-chainer-file-name-expr chainer-term name) :kb parent)
      (dolist (file (directory (concatenate 'string resource-path name ".*")))
        (delete-file file)))))

(defmethod chainer-file-cache-names ((chainer-term t) (parent knowledge-base))
  ;; Should be only one, but let's program defensively.
  (retrieve (make-chainer-file-name-expr chainer-term '?name)
            :response '?name))

(defun generate-chainer-file-cache-name ()
  ;; The odds of getting nailed when going across machines is tiny
  (format nil "chainer-~A" (get-universal-time)))

(defun chainer-cached-in-file? (chainer-term kb)
  (let ((names (chainer-file-cache-names chainer-term kb))
        (resource-path (kb-resource-path kb))
        (winners nil))
    (dolist (name names winners)
      (when (and (probe-file (concatenate 'string resource-path name ".bin"))
                 (probe-file (concatenate 'string resource-path name ".pac"))
                 (probe-file (concatenate 'string resource-path name ".sym")))
        (push name winners)))))

;;; ISSUE: chainers are supposed to be stored with reasoners as well as kbs
(defmethod load-chainer-file ((chainer-term t) (parent knowledge-base) &key (verbose? t))
  (let ((names (chainer-file-cache-names chainer-term parent))
        (resource-path (kb-resource-path parent)))
    (cond ((null names) nil) ;; Nothing
          ((cdr names)
           ;; Might want to take the newest and nuke the rest,
           ;; but let's decide on that later.
           (error "Multiple stored caches for ~A: ~A in ~A." 
             chainer-term names parent))
          (t (when verbose?
               (format t "~%Loading chainer ~A for ~A." chainer-term
                 (name parent)))
             (with-kb parent
               (trap-error (error
                               (format t "~&WARNING: error -- ~A not loaded."
                                 chainer-term)
                  nil)
                 (let ((chainer (bd-load resource-path (car names))))
                   (when verbose?
                     (format t "~%Finished loading ~A into ~A." 
                       chainer-term (name parent))
                     (cond ((chainer? chainer)
                            (push chainer (chainers parent))
                            chainer)
                           (t (error "Load failure: Not a chainer: ~A."
                                chainer)))))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Write/read routines, by datatype
;;;
;;; Here's where we must decide if we keep the title string or convert to a term.
;;; Also, how is context used?

(defmethod bd-write ((thing chainer) sout &rest args
                     &key (context nil) &allow-other-keys)
  "BDumper method for storing chainers."
  (bd-write-token bdt-chainer sout)
  (bd-write (title thing) sout :context context)          ; string
  (bd-write (term thing) sout :context context)           ; s-expr
  (bd-write (table thing) sout :context context)          ; hashtable
  (bd-write (clauses thing) sout :context thing)          ; hashtable
  (bd-write (clause-counter thing) sout :context context) ; integer
  (bd-write (file-name thing) sout :context context))     ; string

(defmethod bd-read (sin (token (eql bdt-chainer))
                        &rest args
                        &key (context nil) &allow-other-keys)
  "BDumper method to loading a structural cache."
  ;; Next line will need changing if case libraries in sources are ever dumped
  (let ((chainer (make-instance 'chainer :kb *kb*
                   :title (bd-read-object sin context))))
    (setf (slot-value chainer 'term) (bd-read-object sin context))
    (setf (slot-value chainer 'table) (bd-read-object sin chainer))  ; no accessor defined  
    (setf (slot-value chainer 'clauses) (bd-read-object sin chainer)); no accessor defined
    (setf (clause-counter chainer) (bd-read-object sin context))
    (setf (file-name chainer) (bd-read-object sin context))
    chainer))

;;; Write/read for clauses

(defmethod bd-write ((thing clause) sout &rest args
                     &key (context nil) &allow-other-keys)
  "BDumper method for storing clauses."
  (bd-write-token bdt-clause sout)
  (bd-write (id thing) sout :context context)
  (bd-write (variables thing) sout :context context)
  (bd-write (terms thing) sout :context context)
  (bd-write (axiom thing) sout :context context))

(defmethod bd-read (sin (token (eql bdt-clause))
                        &rest args
                        &key (context nil) &allow-other-keys)
  "BDumper method to loading a clause."
  (let ((clause (make-instance 'clause)))
    (setf (slot-value clause 'chainer) context)
    (setf (slot-value clause 'id) (bd-read-object sin context))
    (setf (slot-value clause 'variables) (bd-read-object sin context))
    (setf (slot-value clause 'terms) (bd-read-object sin context))  ; a flat list of terms.  Handle separately
    (setf (slot-value clause 'axiom) (bd-read-object sin context))
    clause)) 


;;; Write/read for quantified terms

(defmethod bd-write ((thing quantified-term) sout &rest args
                     &key (context nil) &allow-other-keys)
  "BDumper method for storing clauses."
  (bd-write-token bdt-qterm sout)
  (bd-write (form thing) sout :context context)
  (bd-write (expansion thing) sout :context context)
  (bd-write (var thing) sout :context context))

(defmethod bd-read (sin (token (eql bdt-qterm))
                        &rest args
                        &key (context nil) &allow-other-keys)
  "BDumper method to loading a clause."
  (let ((qterm (make-instance 'quantified-term)))
    (setf (slot-value qterm 'form) (bd-read-object sin context))
    (setf (slot-value qterm 'expansion) (bd-read-object sin context))
    (setf (slot-value qterm 'var) (bd-read-object sin context))
    qterm)) 
    
    


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