;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10 -*- ;;;; --------------------------------------------------------------------------- ;;;; File name: case-library-dumper.lsp ;;;; System: FIRE v1 ;;;; Author: Ken Forbus ;;;; Created: February 2, 2004 12:34:32 ;;;; Purpose: Dumping and loading of case libraries ;;;; --------------------------------------------------------------------------- ;;;; Modified: Tuesday, February 3, 2004 at 09:24:39 by Ken Forbus ;;;; --------------------------------------------------------------------------- (in-package :fire) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Dumping and loading case libraries ;; ;; Because the content vector computation can be expensive, we provide the option of ;; of writing them out to disk as a persistent cache for the case library. ;; ;; The file name associated with a case library cache is computed once and stored ;; in the KB, so that subsequent images will be able to find it. We'll use facts ;; of the form (caseLibraryFileName ) ;; for this purpose. ;; ;; We will only keep one copy of the case library on-disk at a time. ;; This means cleaning up older copies. (defmethod dump-case-library-file ((library-term t) (parent knowledge-base) &key (verbose? t)) (let ((library (retrieve-case-library library-term parent))) ;; We will only dump libraries if they exist, to avoid ;; time-consuming user mistakes. (cond ((null library) (when verbose? (format t "~%No cached case library ~A in ~A." library-term (name parent))) nil) (t (remove-previous-case-library-caches library-term parent) (let ((cache-name (generate-case-library-file-cache-name)) (resource-path (kb-resource-path parent))) (setf (file-name library) cache-name) (ensure-directories-exist resource-path) (when verbose? (format t "Dumping cache of ~A in ~A..." library-term (name parent))) (bd-save library resource-path cache-name) (store (make-case-library-file-name-expr library-term cache-name) parent) (when verbose? (format t "Done.")) cache-name))))) (defmethod remove-previous-case-library-caches ((library-term t) (parent knowledge-base)) (let ((names (case-library-file-cache-names library-term parent)) (resource-path (kb-resource-path parent))) (dolist (name names) (forget (make-case-library-file-name-expr library-term name) :kb parent) (dolist (file (directory (concatenate 'string resource-path name ".*"))) (delete-file file))))) (defmethod case-library-file-cache-names ((library-term t) (parent knowledge-base)) ;; Should be only one, but let's program defensively. (retrieve (make-case-library-file-name-expr library-term '?name) :response '?name)) (defun generate-case-library-file-cache-name () ;; The odds of getting nailed when going across machines is tiny (format nil "case-library-~A" (get-universal-time))) (defun case-library-cached-in-file? (library-term kb) (let ((names (case-library-file-cache-names library-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))))) (defmethod load-case-library-file ((library-term t) (parent knowledge-base) &key (verbose? t)) (let ((names (case-library-file-cache-names library-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." library-term names parent)) (t (when verbose? (format t "~%Loading case library ~A for ~A." library-term (name parent))) (with-kb parent (trap-error (error (format t "~&WARNING: error -- ~A not loaded." library-term) nil) (let ((library (bd-load resource-path (car names)))) (when verbose? (format t "~%Finished loading ~A into ~A." library-term (name parent)) (cond ((case-library? library) (push (cons library-term library) (case-libraries parent)) library) (t (error "Load failure: Not a case library: ~A." library))))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Write/read routines, by datatype (defmethod bd-write ((thing case-library) sout &rest args &key (context nil) &allow-other-keys) "BDumper method for storing case libraries." (bd-write-token bdt-case-library sout) (bd-write (term thing) sout :context context) (bd-write (members thing) sout :context context) (bd-write (file-name thing) sout :context context) (bd-write (cvectors thing) sout :context context)) (defmethod bd-read (sin (token (eql bdt-case-library)) &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 ((library (make-instance 'case-library :parent *kb* :term (bd-read-object sin context)))) (setf (members library) (bd-read-object sin context)) (setf (file-name library) (bd-read-object sin context)) (setf (cvectors library) (bd-read-object sin context)) library)) ;;; Write/read for cvectors (defmethod bd-write ((thing content-vector) sout &rest args &key (context nil) &allow-other-keys) "BDumper method for storing content vectors." (bd-write-token bdt-cvector sout) (bd-write (case-term thing) sout :context context) (bd-write (fact-count thing) sout :context context) (bd-write (cv-magnitude thing) sout :context context) (write-cv-entries (cv-entries thing) sout context)) (defmethod bd-read (sin (token (eql bdt-cvector)) &rest args &key (context nil) &allow-other-keys) "BDumper method to loading a content vector." (let ((cvector (make-instance 'content-vector))) (setf (case-term cvector) (bd-read-object sin cvector)) (setf (fact-count cvector) (bd-read-object sin cvector)) (setf (cv-magnitude cvector) (bd-read-object sin cvector)) (setf (cv-entries cvector) (read-cv-entries sin context)) cvector)) ;;; The trick with entries is that we want the predicates to be those from the ;;; current KB. That is, it is an alist whose entries are ( . ) ;;; so we don't want to dump the entry, just save a pointer to it. ;;; Also, bdumper doesn't deal with cons cells (as distinct from lists) so we ;;; have to convert ( . ) to ( ) during dump and revert to ;;; the cons coming out. (defun write-cv-entries (entries sout context) ;; One could do something devious to avoid copying the whole list, but ;; it probably isn't worth it. (bd-write (mapcar #'(lambda (entry) (cons (sc-item (car entry)) (list (cdr entry)))) entries) sout :context context)) (defun read-cv-entries (sin context) (let ((sanitized-alist (bd-read-object sin context))) (mapcar #'(lambda (entry) (cons (find-sc-entry (car entry) *kb*) (cadr entry))) sanitized-alist))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Testing (defun test-case-library-dumping () ;; Assume 344 KB and reasoner created (let* ((term '(data::CaseLibraryInstancesOfFn data::Planet data::MinimalCaseFn)) (library (cache-case-library term *kb*))) (get-case-library-cvectors library) (dump-case-library-file term *kb* :verbose? t) (load-case-library-file term *kb* :verbose? t) (if (equal-case-libraries? (get-case-library term *kb*) library) 'data::Okay 'data::Bug))) (defmethod equal-case-libraries? ((cl1 t) (cl2 t)) (format t "One isn't case library.") nil) (defmethod equal-case-libraries? ((cl1 case-library) (cl2 case-library)) (and (equal (term cl1) (term cl2)) (equal (members cl1) (members cl2)) (equal (parent cl1) (parent cl2)) (every 'equal-content-vectors (cvectors cl1) (cvectors cl2)))) (defun equal-content-vectors (cv1 cv2) (and (equal (case-term cv1) (case-term cv2)) (= (cv-magnitude cv1) (cv-magnitude cv2)) (= (fact-count cv1) (fact-count cv2)) ;; Might need to do something more clever on floats. (equal (cv-entries cv1) (cv-entries cv2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; End of Code