;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: case-load-popup.lsp
;;;;    System: 
;;;;    Author: Shawn Nicholson
;;;;   Created: July 10, 2002 17:28:45
;;;;   Purpose: 
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Wednesday, March 17, 2004 at 22:04:39 by usher
;;;; ---------------------------------------------------------------------------

(in-package :fire-case-viewer)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *user-changed* t)

(defclass case-load-popup (cg:dialog)
  ())


(defun load-case-popup (&optional (owner (cg:screen cg:*system*)))
  (cg:pop-up-modal-dialog 
      (cg:find-or-make-pop-up-window :load-case-popup 'make-load-case-popup owner)))


(defun make-load-case-popup (&optional (owner (cg:screen cg:*system*)))
  (cg:make-window  :load-case-popup
    :owner owner
    :background-color (cg:background-color owner)
    :class 'case-load-popup
    :height 346
    :width 272
    :pop-up t
    :left (+ 25 (if (eq owner (cg:screen cg:*system*)) 0 (cg:left owner)))
    :top (+ 25 (if (eq owner (cg:screen cg:*system*)) 0 (cg:top owner)))
    :border :palette
    :title "Load Case from KB"
    :dialog-items (make-load-case-dialog-items)
    ))


(defmacro with-system-edit (&rest body)
  `(let ((*user-changed* nil))
     ,@body))

(defun make-load-case-dialog-items ()
  (list (make-instance 'cg:static-text
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :name :case-kb-load-name-label
          :value "Case Name"
          :left 11
          :top 9
          :width 62
          :height 16)
        (make-instance 'cg:editable-text
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :name :case-kb-load-casename
          :delayed nil
          :up-down-control nil
          :value ""
          :left 11
          :top 27
          :width 172
          :height 25
          :on-change #'case-name-completion
          :right-attachment :right)
        (make-instance 'cg:button
          :name :case-kb-load-complete-casename
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :title "Complete"
          :left 187
          :top 31
          :height 19
          :width 61
          :on-change #'case-kb-load-complete-casename
          :right-attachment :right
          :left-attachment :right
          :top-attachment :top
          :bottom-attachment :top)
        
        
        (make-instance 'cg:static-text
          :name :case-kb-load-construction-label
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :value "Case Construction Style"
          :left 11
          :top 62
          :width 123
          :height 16)
        (make-instance 'cg:combo-box
          :name :case-kb-load-case-construction-style
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :range (case-construction-styles)
          :value 'd::ExplicitCaseFn
          :on-print #'user-namestring
          :available t
          :left 11
          :top 78
          :width 236
          :right-attachment :right)
        
        (make-instance 'cg:static-text
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :name :case-kb-load-completions-label
          :value "Current Cases/Completions"
          :left 11
          :top 108
          :width 145
          :height 16)
        (make-instance 'cg:single-item-list
          :name :case-name-completion-list
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :available t
          :left 11
          :top 123
          :height 136
          :width 239
          :on-change 'set-selected-casename
;;          :on-double-click 'complete-casename-selected          
          :right-attachment :right
          :bottom-attachment :bottom)
        
        (make-instance 'cg:button
          :name :case-kb-load-list-cases
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :title "List all in KB"
          :left 50
          :top 263
          :height 18
          :width 80
          :on-change 'case-kb-load-list-cases
          :right-attachment :right
          :left-attachment :right
          :top-attachment :bottom
          :bottom-attachment :bottom)
        #+rbrowse
        (make-instance 'cg:button
          :name :case-kb-load-kb-browse-button
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :title "Browse KB"
          :left 142
          :top 263
          :height 18
          :width 80
          :on-change #'case-kb-load-browse-kb
          :right-attachment :right
          :left-attachment :right
          :top-attachment :bottom
          :bottom-attachment :bottom)
          
        (make-instance 'cg:button
          :name :case-kb-load-help-button
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :title "Help"
          :left 6
          :top 296
          :height 19
          :width 80
          :on-change #'case-kb-load-load
          :right-attachment :right
          :left-attachment :right
          :top-attachment :bottom
          :bottom-attachment :bottom)
        (make-instance 'cg:button
          :name :case-kb-load-load-button
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :title "Load"
          :left 91
          :top 296
          :height 19
          :width 80
          :on-change 'case-kb-load-load
          :right-attachment :right
          :left-attachment :right
          :top-attachment :bottom
          :bottom-attachment :bottom)
        (make-instance 'cg:cancel-button
          :name :case-kb-load-cancel-button
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :left 178
          :top 296
          :height 19
          :width 80
          :on-change #'case-kb-load-cancel
          :right-attachment :right
          :left-attachment :right
          :top-attachment :bottom
          :bottom-attachment :bottom)
        
        (make-instance 'cg:lisp-group-box
          :name :case-kb-load-group-box
          :font (cg:make-font-ex nil "Tahoma" 11 nil)
          :left 5
          :top 4
          :height 286
          :width 252
          :right-attachment :right
          :bottom-attachment :bottom)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EVENT Handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun clear-selected-case-completion-list (case-load-dialog)
  (let ((case-completion-list (cg:find-component :case-name-completion-list case-load-dialog)))
    (with-system-edit
        (setf (cg:value case-completion-list) nil))))
    
(defun set-selected-casename (cases-completion-list new old)
  (declare (ignore new old))
  (when *user-changed*
    (with-system-edit 
        (complete-casename-selected (cg:parent cases-completion-list) cases-completion-list)))
  t)
  
  
  
(defun complete-casename-selected (case-load-dialog cases-completion-list)
  (let ((casename-text-window (cg:find-component :case-kb-load-casename 
                                                 case-load-dialog)))
    (setf (cg:value casename-text-window) 
      (format nil "~A" (cg:value cases-completion-list)))))



(defun get-filter-function (construction-style)
  #'(lambda (casename)
      (include-in-casename-completion? construction-style casename)))



(defun complete-casename (case-load-dialog)
  (let ((sub-casename (cg:value (cg:find-component 
                                 :case-kb-load-casename case-load-dialog))))
    ;; sub-casename has to be at least 1 letter long...
    (when (>= (length sub-casename) 1)
      (let* ((construction-style (cg:value (cg:find-component 
                                            :case-kb-load-case-construction-style 
                                            case-load-dialog)))
             (filter-func (get-filter-function construction-style))
             (completions (remove-duplicates 
                           (fire::complete-from-KB sub-casename 
                                                   :filter filter-func) 
                           :test 'equal))
             (completion-list-widget (cg:find-component 
                                      :case-name-completion-list 
                                      case-load-dialog)))
        (setf (cg:range completion-list-widget) completions)))))


(defun case-kb-load-complete-casename (complete-button new old)
  (declare (ignore new old))
  (let ((case-load-dialog (cg:parent complete-button)))
    (cg:with-hourglass (complete-casename case-load-dialog))))

;; For speedup do caching at some point...
(defun case-name-completion (casename-text-window new old)
  (declare (ignore old))
  (when (and *user-changed* (> (length new) 3))
    (clear-selected-case-completion-list (cg:parent casename-text-window))
    (complete-casename (cg:parent casename-text-window)))
  t)


(defun case-kb-load-cancel (cancel-button new old)
  (declare (ignore new old))
  (close (cg:parent cancel-button)))

;; When you click the load button to actually load your case this gets called.
(defun case-kb-load-load (load-button new old)
  (declare (ignore new old))
  (let* ((case-load-dialog (cg:parent load-button))
         (casename (cg:read-from-string-safely 
                    (cg:value (cg:find-component :case-kb-load-casename 
                                                 case-load-dialog))))
         (construction-style (cg:value (cg:find-component 
                                        :case-kb-load-case-construction-style 
                                        case-load-dialog)))
         (filter-func (get-filter-function construction-style))
         (valid-case? (member casename (fire::complete-from-KB 
                                        casename 
                                        :filter filter-func))))
    (if valid-case? 
      (cg:flag-modal-completion 
       case-load-dialog (make-full-casename construction-style casename))
      (cg:pop-up-message-dialog 
       case-load-dialog "No such case" 
       "No case exists with this name in the Knowledge Base" 
       nil "OK"))))


(defun case-kb-load-browse-kb (browse-kb-button new old)
  (declare (ignore browse-kb-button new old))
  #+rbrowse (when (fire:open-kb? fire:*kb*) 
              (rbrowse:browse-kb :kb fire:*kb*))
  nil)

(defun retrieve-fire-cases (&key (kb fire:*kb*))
  (sort (fire:retrieve '(d::isa ?case-name d::Case) 
                       :kb kb
                       :number :all
                       :response '?case-name)
        #'exp<))

(defun ensure-unwrapped (case-name)
  (cond ((null case-name) nil)
        ((listp case-name) (second case-name))
        (t case-name)))

;; When you click on list all cases in the KB - this displays them all
(defun case-kb-load-list-cases (list-cases-button new old)
  (declare (ignore new old))
  (cg:with-hourglass
    (let* ((case-load-dialog (cg:parent list-cases-button))
           (case-list-widget (cg:find-component :case-name-completion-list 
                                                case-load-dialog))
           (fire-cases (mapcar #'ensure-unwrapped (retrieve-fire-cases))))
      (setf (cg:range case-list-widget) fire-cases))
    nil))
           

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