;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: kb-loader.lsp
;;;;    System: FIRE
;;;;    Author: Jeff Usher
;;;;   Created: May 20, 2001 17:39:54
;;;;   Purpose: Wraps user-feedback around the KB flat-file loader routines.
;;;;            Note that this file is not loaded automatically when you load
;;;;            FIRE.  If you wish to use this code, call fire:load-kb-tools.
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Monday, January 19, 2004 at 18:05:05 by usher
;;;; ---------------------------------------------------------------------------

(in-package :cl-user)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Exports

(eval-when (:compile-toplevel :load-toplevel :execute)
  (export '(build-kb
            load-flat-files
            load-flat-file-w-gui
            list-kb-flat-files)
          :cl-user))
          

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Globals

(defparameter *KB-flat-files* (fire::make-queue))


(defparameter *kb-progress-win-interior* nil
  "Last known position of the KB progress window.")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Class Definitions

(defclass kb-progress-win (cg:dialog)
  ((progress-bar
    :documentation "Pointer to the window's progress bar."
    :accessor progress-bar :initform nil)
   (percent-readout
    :documentation "Text widget displaying the current percent complete."
    :accessor percent-readout :initform nil)
   (file-size
    :documentation "Size of the file in bytes, as given by 
                    (file-length <stream>)."
    :accessor file-size :initform nil))
  (:documentation "Class of window used to display a busy message."))



(defclass kb-progress-bar (cg:progress-indicator)
  ()
  (:documentation "Special class of progress bars."))

(defclass kb-progress-pane (cg::progress-indicator-pane)
  ()
  (:documentation "Pane to use with a kb-progress-bar"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File Def Functions

(defun def-kbff (rel-path filename language)
  ;; rel-path should be relative to qrg; filename should include the extenstion;
  ;; and language should be one of :meld or :kif
  (let ((new-entry (cons
                    (concatenate 'string (qrg:get-qrg-path) rel-path filename)
                    language)))
    (fire::enqueue *KB-flat-files* new-entry)
    new-entry))

(defun list-kb-flat-files ()
  (fire::list-data *KB-flat-files*))

(defun reset-kb-flat-files ()
  (fire::reset-queue *KB-flat-files*))



(defun kbff-filepath (file-def)
  (car file-def))

(defun kbff-language (file-def)
  (cdr file-def))

(defun kbff-context (file-def)
  (declare (ignore file-def))
  'data::BaseKB) ;; for now


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Basic Loader Functions

(defun load-flat-file (file-def kb &key (callback-fn 'default-loader-callback) (check-for-mt-type nil))
  "Loads the specified flat-file.  Language should be one of :kif or :meld.
   File-def should be a flat-file definition made with def-kbff.
   If specified, callback-fn is called everytime a form is read from the
   flat-file; it should take two arguments: the form read and the stream
   that the form is being read from (the stream to the flat-file)."
  (let ((filepath (kbff-filepath file-def))
        (language (kbff-language file-def))
        (context  (kbff-context  file-def)))
    (format t "~%Loading ~A ..." filepath)
    (cg:process-pending-events)
    (case language
      (:kif
       (fire:flat-file->kb filepath
                           :kb kb
                           :verbose? t
                           :legacy? nil
                           :dt context
                           :check-for-mt-type check-for-mt-type
                           :callback-fn callback-fn))
      (:meld
       (fire:meld-file->kb filepath
                           :kb kb
                           :context context
                           :check-for-mt-type check-for-mt-type
                           :callback-fn callback-fn))
      (otherwise
       (warn "unrecognized language for load-flat-file: ~
              filepath = ~S; language = ~S" filepath language)
       nil))))

(defun default-loader-callback (form input-file)
  (declare (ignore form input-file))
  (cg:process-single-event :no-wait))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions for handling progress bar

(defmethod cg:widget-device ((widget kb-progress-bar) win)
  (declare (ignore win))
  'kb-progress-pane)



(defmethod cg::device-open ((widget-pane kb-progress-pane) options)
  ;; note that some of the code in this method uses functions that are not
  ;; exported from Allegro's Common Graphics package and therefore might not
  ;; be portable to new versions of ACL.
  (cg::ensure-common-controls-are-initialized)
  (let* ((widget (cg:dialog-item widget-pane))
         (value (getf options :value)))
    (apply #'cg::open-widget-window widget-pane
           :control-class (cg::control-name widget)
           :id nil 
           :has-title t 
           :style fire::PBS_SMOOTH
           :init-range-p t
           options)
    (when value
      (cg:widget-set-value widget-pane widget value 0 nil))
    widget-pane))


(defun set-progress-bar (progress-win percent-complete)
  (let ((pbar (progress-bar progress-win)))
    (when pbar
      (setf (cg:value pbar) (round (* 1000 percent-complete)))
      percent-complete)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Progress Display Window

(defun make-kb-progress-win (file-def &key (parent (cg:screen cg:*system*)))
  (let ((win
         (cg:make-window :kb-progress-window
           :parent parent
           :device 'kb-progress-win
           :title "Loading KB Flat-File ..."
           :interior (or *kb-progress-win-interior*
                         (cg:center-box-on-window parent 400 110))
           :border :dialog-box
           :state :shrunk
           :close-button t
           :minimize-button nil
           :maximize-button nil
           :resizable t
           :scrollbars nil
           :title-bar t
           :toolbar nil
           :pop-up nil
           :help-string nil
           :widgets nil)))
    (add-kb-progress-widgets win file-def)
    (setf (progress-bar win) (cg:find-component :progress-bar win))
    (cg:select-window win)
    win))

(defun add-kb-progress-widgets (win file-def)
  (let ((win-width  (cg:interior-width win))
        (win-height (cg:interior-height win))
        (filepath (kbff-filepath file-def))
        (language (kbff-language file-def))
        (context  (kbff-context  file-def)))

    (cg:add-component
     (make-instance 'cg:static-text
       :name :flat-file-name
       :title "flat-file-name"
       :available t
       :value (format nil "Filepath = ~A" filepath)
       :left 4  :width (- win-width 8)
       :top 4   :height 16
       :tabstop nil
       :border :none
       :font (cg:make-font-ex :swiss :|ms sans serif| 11 nil)
       :top-attachment :top
       :bottom-attachment :top
       :left-attachment :left
       :right-attachment :right) win)
    (cg:add-component
     (make-instance 'cg:static-text
       :name :flat-file-language
       :title "flat-file-language"
       :available t
       :value (format nil "Language = ~:@(~A~)" language)
       :left 4  :width (- (round (/ win-width 2)) 8)
       :top 24  :height 16
       :tabstop nil
       :border :none
       :font (cg:make-font-ex :swiss :|ms sans serif| 11 nil)
       :top-attachment :top
       :bottom-attachment :top
       :left-attachment :left
       :right-attachment :right) win)
    (cg:add-component
     (make-instance 'cg:static-text
       :name :file-size
       :title "file-size"
       :available t
       :value (concatenate 'string "File Size: "
                (print-numbytes (get-file-length filepath)))
       :left (+ (round (/ win-width 2)) 4)  
       :width (- (round (/ win-width 2)) 8)
       :top 24  :height 16
       :tabstop nil
       :border :none
       :font (cg:make-font-ex :swiss :|ms sans serif| 11 nil)
       :top-attachment :top
       :bottom-attachment :top
       :left-attachment :left
       :right-attachment :right) win)
    (cg:add-component
     (make-instance 'cg:static-text
       :name :flat-file-context
       :title "flat-file-context"
       :available t
       :value (format nil "Context = ~A" context)
       :left 4  :width (- win-width 8)
       :top 44  :height 16
       :tabstop nil
       :border :none
       :font (cg:make-font-ex :swiss :|ms sans serif| 11 nil)
       :top-attachment :top
       :bottom-attachment :top
       :left-attachment :left
       :right-attachment :right) win)
    (cg:add-component
     (make-instance 'kb-progress-bar
       :name :progress-bar
       :title "progress-bar"
       :left 2                   :width (- win-width 50 6)
       :top (- win-height 22 4)  :height 22
       :value 0
       :range '(0 1000)
       :available t
       :border :static
       :tabstop nil
       :foreground-color #.(cg:make-rgb :red 18 :green 40 :blue 60)
       :top-attachment :bottom
       :bottom-attachment :bottom
       :left-attachment :left
       :right-attachment :right) win)
    (setf (percent-readout win)
      (make-instance 'cg:static-text
        :name :percent-complete
        :title "percent-complete"
        :available t
        :value ""
        :left (- win-width 50 2)  :width 50
        :top (- win-height 19 4)  :height 16
        :tabstop nil
        :border :none
        :font (cg:make-font-ex :swiss :|ms sans serif| 11 nil)
        :justification :center
        :top-attachment :top
        :bottom-attachment :top
        :left-attachment :left
        :right-attachment :right))
    (cg:add-component (percent-readout win) win)
    win))

(defun get-file-length (filepath)
  "Returns the length of the file specified by filepath; returns nil if the
   file does not exist." 
  (ignore-errors 
   (with-open-file (str filepath :direction :input
                        :element-type 'unsigned-byte)
     (file-length str))))

(defun print-numbytes (num &optional (width 6) (prefix ""))
  "Given a number of bytes, returns a string representation that is given in 
   units appropriate for an easy to read display."
  (unless (numberp num)
    (setq num 0))
  (let ((control (format nil "~~A ~~~A,2F ~~A" width))
        (abs-num (if (plusp num) num (+ #.(expt 2 32) num))))
    (cond ((> abs-num #.(expt 10 12))
           (format nil control prefix (/ abs-num #.(expt 2 40)) "TB"))
          ((> abs-num #.(expt 10 9))
           (format nil control prefix (/ abs-num #.(expt 2 30)) "GB"))
          ((> abs-num #.(expt 10 6))
           (format nil control prefix (/ abs-num #.(expt 2 20)) "MB"))
          ((> abs-num #.(expt 10 3))
             (format nil control prefix (/ abs-num #.(expt 2 10)) "KB"))
          (t
           (format nil control prefix abs-num "bytes")))))



(defun update-kb-progress-win (progress-win flatfile-stream)
  (ignore-errors
   (let* ((file-length (or (file-size progress-win)
                           (setf (file-size progress-win)
                             (file-length flatfile-stream))))
          (file-pos (file-position flatfile-stream))
          (percent-complete (/ file-pos file-length)))
     (set-progress-bar progress-win percent-complete)
     (setf (cg:value (percent-readout progress-win))
       (format nil "~,1F%" (* percent-complete 100)))
     (cg:process-pending-events)
     progress-win)))



#+acl5
(defmethod device-close :before ((win kb-progress-win) abort)
  (declare (ignore abort))
  (setq *kb-progress-win-interior* (cg:copy-box (cg:interior win))))

#+acl6
(defmethod close :before ((win kb-progress-win) &key abort)
  (declare (ignore abort))
  (setq *kb-progress-win-interior* (cg:copy-box (cg:interior win))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Main KB Building Functions

(defun build-kb (kb-path kb-name 
                         &key dbex-logging? check-for-mt-type post-load-fn)
  (when (make-sure-all-files-exist (list-kb-flat-files))
    (let ((kb (fire:make-kb kb-path kb-name
                            :new? t
                            :predicate-style :mixed-case))
          (old-log-val dbex::*log?*))
      (setf dbex::*log?* dbex-logging?)
      (fire:open-kb kb)
      (unwind-protect 
          (progn
            (load-flat-files (list-kb-flat-files) kb 
                             :check-for-mt-type check-for-mt-type)
            (when post-load-fn
              (funcall post-load-fn kb)))
        (format t "~%Resetting the structure cache ...")
        (fire::recompute-structural-cache :kb kb)
        (fire::dump-structural-cache :kb kb)
        (fire:close-kb kb)
        (format t "~%Running KB-Tools on the new KB ...")
        (fire::check-kb 
         kb-path kb-name 
         :logfile (qrg:make-full-file-spec kb-path "KB-Tools-log" ".txt"))
        (setf dbex::*log?* old-log-val))
      :done)))



(defun load-flat-files (file-def-list kb &key (check-for-mt-type nil))
  (dolist (file-def file-def-list)
    (load-flat-file-w-gui file-def kb :check-for-mt-type check-for-mt-type))
  file-def-list)

(defun load-flat-file-w-gui (file-def kb &key (check-for-mt-type nil))
  (let ((win (make-kb-progress-win file-def)))
    (unwind-protect
        (load-flat-file 
         file-def kb
         :check-for-mt-type check-for-mt-type
         :callback-fn #'(lambda (form flatfile-stream)
                          (declare (ignore form))
                          (update-kb-progress-win win flatfile-stream)))
      (close win))
    (kbff-filepath file-def)))


(defun make-sure-all-files-exist (file-defs)
  (dolist (file-def file-defs)
    (unless (probe-file (kbff-filepath file-def))
      (error "The KB flat-file ~A does not exist." (kbff-filepath file-def))))
  :ok)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Test KB

(defun debug-kb-loader ()
  (reset-kb-flat-files)
  (def-kbff "fire\\flat-files\\" "analogy-dt-mc.lsp"           :kif)
  (def-kbff "fire\\flat-files\\cyc\\" "molecular-biology.meld" :meld)
  (def-kbff "fire\\flat-files\\cyc\\" "prettyNames.cyc"        :kif)
  (build-kb "c:\\test-kb\\" "test-kb"))
  

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