(in-package "KPML-I")
;;;
;;; File: inspection.lisp
;;; Author: John Bateman
;;; Created: 14 Oct 95
;;; Last Major Update: Oct 98, user levels added.
;;; Minor corrections/extensions for KPML4, October 2003
;;;   for compatibility with Loom4.
;;;
;;; Contains all the definitions for the windows and commands associated
;;; with the resource inspection functionality of the new KPML interface.
;;;

;;; ----------------------------------------------------------------------
;;; Application frame definition and layout

(clim:define-application-frame 
 KPML-RESOURCE-INSPECTOR ()
 ()
 (:menu-bar nil)
 (:top-level (clim:default-frame-top-level :prompt kpml-prompt-function))
 (:panes (menu        :command-menu
		      :foreground menu-fg
		      :background menu-bg
		      :text-style *menu-font*)
	 (interactor  :interactor
		      :foreground interactor-fg
		      :background interactor-bg
		      :text-style *fix--roman--12*)
	 (inspector   :application
		      :scroll-bars :vertical
		      :foreground inspector-fg
		      :background inspector-bg 
		      :text-style *main-info-font*)
	 (mouse-doc   :pointer-documentation
		      :foreground  mouse-doc-fg
		      :background  mouse-doc-bg)
	 )
 (:layouts (first (clim:vertically
		   ()
		   #-lispworks (100 menu) #+lispworks menu
		   (1/6 interactor)
		   (:fill inspector)
		   #-lispworks (2/32 mouse-doc)))))


;;; ======================================================================
;;; Frame startups...

;;; Make sure that some of the special variables are set up appropriately.

(defun STARTUP-RESOURCE-INSPECTOR-FRAME (&optional (reset nil))
  (when (and reset *resource-inspector-frame*)
    (close-a-window *resource-inspector-frame*)
    (setf *resource-inspector-frame* nil))
  (unless *resource-inspector-frame*
	  (let* ((frame (setf *resource-inspector-frame*
			      (clim:make-application-frame
			       'kpml-resource-inspector
			       :pretty-name 
			       "Inspector (KPML)"
			       :left 110 :top 30
			       :width 500 :height 400)))
		 (process
		  (process-run-function "KPML-IN" 
					   #'run-packaged-frame 
					   frame
					   *package*)))
	    (push (cons frame process) *frame-process-alist*)))
  T)





;;; ----------------------------------------------------------------------
;;; Commands...

;; 4.0
;;
#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-SHOW-DISABLED-SYSTEMS :name t :menu t)	      
  ()
  (if kpml::*disabled-systems*
      (loop for (sysname language) in kpml::*disabled-systems*
	    do 
	    (kpml::describe-system sysname))
    ))

;;; ----------------------------------------------------------------------
;;; Resource inspector...
;;; 2.0 updated for new display methods...

(define-kpml-resource-inspector-command 
  (com-WHO-CAN-... :name t :menu T)
  ()
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 
				      'interactor))
	 (operation 
	  (menu-choose 
	   '(
	     #+(and :kpml-level>= :kpml-l2) |... ask|
	     |... insert|
	     |... classify|
	     |... conflate|
	     #+(and :kpml-level>= :kpml-l2) |... identify|
	     |... inflectify|
	     |... lexify|
	     |... out classify|
	     |... order|
	     |... partition|
	     #+(and :kpml-level>= :kpml-l2) |... pose identifying inquiry|
	     |... preselect|
	     |... realize|
	     )
	   :associated-window 
	   (clim:frame-top-level-sheet clim:*application-frame*)
	   :label "Who can ...")))
    (case operation
      (|... realize|
       (pen-pprint-for-clim 
	(kpml::who-can-realize (clim:accept 'symbol :stream stream))
	nil))
      (|... ask|
       (pen-pprint-for-clim 
	(kpml::who-can-ask (clim:accept 'inquiry :stream stream))
	nil))
      (|... pose identifying inquiry|
       (pen-pprint-for-clim 
	(kpml::who-can-pose-identifying-inquiry
	 (clim:accept 'inquiry :stream stream))
	nil))
      (|... identify|
       (pen-pprint-for-clim 
	(kpml::who-can-identify (clim:accept 'symbol :stream stream))
	nil))
      (|... insert|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-insert))
      (|... conflate|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-conflate))
      (|... order|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-order))
      (|... partition|
       (display-partitions (clim:accept 'symbol :stream stream)))
      (|... preselect|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-preselect))
      (|... classify|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-classify))
      (|... out classify|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-out-classify))
      (|... lexify|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-lexify))
      (|... inflectify|
       (display-realization-operation (clim:accept 'symbol :stream stream)
				      #'kpml::kpml-who-can-inflectify)))))


(define-kpml-resource-inspector-command (com-eval-lisp-expr2 :name ",")
  ((expression '((clim:expression) :auto-activate NIL)))
  (eval-lisp-expression expression))
  
(defun DISPLAY-REALIZATION-OPERATION (fn access-fn)
  (let ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    (loop for r in (funcall access-fn (first (kpml::extract-fundle-names fn)))
	do  (display-realization-information r stream))))

(defun DISPLAY-REALIZATION-INFORMATION (r stream)
  (let ((system (first r))
	(feats  (cdr r)))
    (kpml-i-terpri stream)
    (clim:with-text-style (stream *sans-serif--bold--10*)
      (clim:with-output-as-presentation (stream system 'system)
	(format stream "~%~A" system)))
    (loop for f in feats
	do
	  (kpml-i-terpri stream)
	  (format stream "~4T")
	  (clim:with-text-style (stream *sans-serif--roman--10*)
	    (clim:with-output-as-presentation 
		(stream (car f) 'feature)
	      (format stream ": ~A; " (car f)))
	    (clim:with-text-style (stream *sans-serif--italic--8*)
	      (loop for x in (cdr f) 
		  do (format stream "~A " x)))))))

(defun DISPLAY-PARTITIONS (fn)
  (let ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    (multiple-value-bind (gr def)
	(kpml::kpml-who-can-partition fn)
      (if gr
	  (loop for r in gr
	      do (display-realization-information r stream))
	(clim:with-text-style (stream *sans-serif--roman--10*)
	  (format stream "~%No partitions in grammar.")))
      (when def
	(clim:with-text-style (stream *sans-serif--roman--10*)
	  (format stream "~%Default partition defined as follows:"))
	(clim:with-text-style (stream *sans-serif--italic--8*)
	  (loop for r in def
	      do (kpml-i-terpri stream)
		 (kpml-tick stream)
		 (format stream "      ")
		 (loop for p in (cdr r)
		     when (eq p fn)
		     do (clim:with-drawing-options 
			    (stream :ink clim:+red+)
			  (format stream "~A  " p))
		     else do (format stream "~A  " p))))))))



;;; ----------------------------------------------------------------------
;;; inquiry implementations...

#+(and :acl3.0 :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-PRINT-INQUIRY-IMPLEMENTATION-DIRECT 
     :name "Print implementation"  :menu nil)
    ((inq-name 'inquiry-implementation :gesture :select))
    (let ((def nil)
	  (stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
      (if def
	  (progn
	    (format stream "~%Implementation named ~A is:" inq-name)
	    (pprint def stream))
	(format stream "~%Implementation not available."))))

#+(and (not acl3.0) :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-PRINT-INQUIRY-IMPLEMENTATION-DIRECT 
     :name "Print implementation"  :menu nil)
    ((inq-name 'inquiry-implementation :gesture :select))
    (let ((def (if (fboundp inq-name)
			   (function-lambda-expression 
			    (symbol-function inq-name))
			 nil))
	  (stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
      (if def
	  (progn
	    (format stream "~%Implementation named ~A is:" inq-name)
	    (pprint def stream))
	(format stream "~%Implementation not available."))))


;;; ----------------------------------------------------------------------
;;;
;;; Displaying linguistic object commands...
;;;

(define-kpml-resource-inspector-command (com-PRINT-SYSTEM :name "Show the system" :menu t)
    ((system 'system :gesture :select))
  (kpml::describe-system system))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-CHOOSER :name t :menu t)
  ((chooser 'chooser :gesture :select))
  (kpml::describe-chooser chooser))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-SHOW-INQUIRIES-OF-CHOOSER :name t :menu nil)
    ((chooser 'chooser :gesture :menu))
  (let* ((ch (find-symbol (string chooser) "PENMAN"))
	 (q-inquiries 
	  (mapcar #'first (kpml::fetch-chooser-db-elt 'kpml::asks ch)))
	 (id-inquiries 
	  (mapcar #'caadr 
		  (kpml::fetch-chooser-db-elt 'kpml::identifies ch))))
    (pen-pprint-for-clim 
     (remove-duplicates (append q-inquiries id-inquiries))
     nil)))

;;; Note 0.9: following now only trace the inquiries when they are
;;;   used in the chooser traced, not elsewhere. For general tracing
;;;   of an inquiry, use trace-inquiry.

(defvar kpml::*traced-chooser-inquiries*)

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-TRACE-INQUIRIES-OF-CHOOSER :name t :menu nil)
    ((chooser 'chooser :gesture :menu))
  (let ((ch (find-symbol (string chooser) "PENMAN")))
    (loop for inq in (kpml::inquiries-of-chooser ch)
	do (push (cons ch inq) kpml::*traced-chooser-inquiries*))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-UNTRACE-INQUIRIES-OF-CHOOSER :name t :menu nil)
    ((chooser 'chooser :gesture :menu))
  (let ((ch (find-symbol (string chooser) "PENMAN")))
    (setf kpml::*traced-chooser-inquiries*
      (remove ch kpml::*traced-chooser-inquiries*
	      :key #'car))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-INQUIRY :name t :menu t)
  ((inquiry 'inquiry :gesture :select))
  (kpml::describe-inquiry inquiry))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-IMPLEMENTATION 
					 :name t :menu t)
  ((inquiry 'inquiry :gesture :select))
  (let* ((inq-name (kpml::fetch-inquiry-info inquiry 'kpml::operatorcode))
	 (def (if (fboundp inq-name)
		  (function-lambda-expression 
		   (symbol-function inq-name))
		nil))
	(stream (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    (if def
	(progn
	  (format stream "~%Implementation named ~A is:" inq-name)
	  (pprint def stream))
      (format stream "~%Implementation not available."))))

(define-kpml-resource-inspector-command (com-PRINT-LEXICAL-ITEM 
					 :name t :menu t)
  ((lex-item 'lex-item :gesture :select))
  (kpml::describe-lex-item lex-item))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-SENTENCE-PLAN 
					 :name t :menu t)
  ()
  (print-sentence-plan-function))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-EXPANDED-PLAN 
					 :name t :menu t)
  ()
  (print-extended-spl-function))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-SPL-TERM
					 :name t :menu t)
    ((term 'spl-term :gesture :select))
  (kpml::describe-spl-term term))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-CONCEPT :name t :menu t)
  ((concept 'kr-concept :gesture :select))
  (kpml::describe-concept-or-relation concept 'concept))

;;; ----------------------------------------------------------------------
;;; 4.0 each of the following graphing commands should make
;;;     sure that they only pass the *name* of a concept/relation
;;;     on to the graphing routines. The graphing function
;;;     expects that its starting positions will be given
;;;     by concept names.

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-GRAPH-SEMANTIC-CONCEPT :name t)
  ((concept 'kr-concept :gesture :select))
  (kpml-i::create-a-semantic-resource-graph 
   (if (symbolp concept)
       concept
     (kpml::kb-getconceptname concept))))


#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-GRAPH-SEMANTIC-RELATION :name t)
  ((concept 'kr-relation :gesture :select))
  (kpml-i::create-a-semantic-resource-graph
   (if (symbolp concept)
       concept
     (kpml::kb-getconceptname concept))))

;;; ----------------------------------------------------------------------

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-PRINT-RELATION :name t :menu t)
  ((relation 'kr-relation :gesture :select))
  (kpml::describe-concept-or-relation relation 'relation))

(define-kpml-resource-inspector-command (com-PRINT-FEATURE :name t :menu t)
  ((feature 'feature :gesture :select))
  (kpml::describe-feature feature))

;;; ----------------------------------------------------------------------
;;; who-cans and who-has's... In KPML 0.9 the who-has's removed from 
;;; main menu since the same info can be got from Print Feature.

;;; 1.0.6: was using wrong function.
;;;
#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-WHO-CAN-ASK :name t)
  ((inquiry 'inquiry :gesture :select))
   (pen-pprint-for-clim 
    (kpml::who-can-ask (find-symbol (string inquiry) "KPML")) ;; 1.0.6
   nil))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-WHO-CAN-POSE-IDENTIFYING-INQUIRY :name t)
    ((inquiry 'inquiry :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-pose-identifying-inquiry
    (find-symbol (string inquiry) "KPML"))                     ;; 1.0.6
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-CLASSIFY :name t)
  ((argument 'symbol :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-classify argument)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-INFLECTIFY :name t)
  ((argument 'symbol :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-inflectify argument)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-INSERT :name t)
  ((argument 'symbol :gesture :select))
  (kpml-i::display-inserts argument))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-LEXIFY :name t)
  ((argument 'symbol :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-lexify argument)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-PRESELECT :name t)
  ((argument 'symbol :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-preselect argument)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-ORDER :name t)
  ((argument 'symbol :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-order argument)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-PARTITION :name t)
  ((argument 'symbol :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-partition argument)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-CAN-REALIZE :name t)
  ((argument 'symbol :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-can-realize argument)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-HAS-AS-INPUT :name t)
  ((feature 'feature :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-has-as-input feature)
   nil))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-WHO-HAS-AS-OUTPUT :name t)
  ((feature 'feature :gesture :select))
  (pen-pprint-for-clim 
   (kpml::who-has-as-output feature)
   nil))




;;;
;;; Additional operations on linguistic objects...
;;;

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-SHOW-PATH-TO :name t)
  ((feature 'feature :gesture :select))
  (let ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	(path (kpml::augment-preselections (list feature))))
    (kpml-i-terpri stream)
    (pen-pprint-for-clim 
     (format nil "Path to feature: ~A is~%" feature)
     ':string stream)
    (pen-pprint-for-clim 
     path
     nil stream)))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-GRAPH-PATH-TO :name t)
  ((feature 'feature :gesture :select))
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
         (path (kpml::augment-preselections (list feature)))
         (ordered 
          (sort 
           (mapcar #'(lambda (f) (cons (length (kpml::augment-preselections (list f))) f))
                   path)
           #'<
           :key #'car))
         (starts 
          (loop for (l . f) in ordered
                while (= l 1)
                collect f)))
    (declare
     (special kpml::*region-external-links-visible?* 
              kpml::*resource-graphing-region-restricted?*))
    (unless starts
      (clim:notify-user stream "No path recoverable."))
    (setf kpml::*resource-graphing-region-restricted?* nil
          kpml::*region-external-links-visible?* nil)
    (setf *graph-stop-points* 
          (remove feature (set-difference (kpml::list-grammatical-features) path)))
    (create-a-resource-graph-from-features starts)))


#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-SHOW-CHOOSER-OF-FEATURE :name t)
  ((feature 'feature :gesture :select))
  (when (gethash feature kpml::all-output-features)
    (if (loop for s in (kpml::who-has-as-output feature)
	      thereis (kpml::fetch-system-chooser s))
        (loop for s in (kpml::who-has-as-output feature)
	      when (kpml::fetch-system-chooser s)
	      do (kpml::describe-chooser (kpml::fetch-system-chooser s)))
      (clim:notify-user clim:*application-frame*
		        (format nil
			        "Feature ~A is not associated with a chooser."
			        feature)))))

;;; 4.0
#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-GRAPH-REGION-OVERVIEW-FROM :name t)
  ((feature 'feature :gesture :select))
  (startup-region-overview-from-feature-frame feature nil kpml::curlan))


#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-SAY-EXAMPLE-2 :name "Say example" :menu nil)
  ((example-name 'example-name :gesture :select))
  (setf *say-process*
    (cpc:make-process #'(lambda () (run-say-top-level example-name))
		      :name "say")))


;;; 2.0 modifed to use proper multilingual access functions for examples.
(define-kpml-resource-inspector-command 
    (com-GRAPH-EXAMPLE-2 :name "Graph example structure" :menu nil)
    ((example-name 'example-name :gesture :select))
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (struct    (kpml::fetch-example-info example-name 'kpml::structure)))
    (if struct
	(loop for s in (if (consp struct) struct
			 (list struct))
	    do (graph-example-structure s))
      (format stream "~%No stored structure for example: ~A" example-name))))

(define-kpml-resource-inspector-command 
    (com-DISPLAY-STRING-OF-EXAMPLE-2 
     :name "Display generated string" :menu nil)
    ((example-name 'example-name :gesture :select))
    (display-string-of-example example-name))

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command 
    (com-EXAMPLES-USING-FEATURES :name t :menu T)
  ()
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (features (if kpml::*collected-features*
		       kpml::*collected-features*
		     (list (clim:accept 'feature
					:stream (clim:get-frame-pane 
						 *resource-inspector-frame* 
						 'interactor)))))
	 (examples (kpml::get-examples-with-features features)))
    (kpml-i-terpri stream)
    (if examples
	(progn 
	  (pen-pprint-for-clim 
	   (format nil "Examples using features: ~A are~%" features)
	   ':string stream)
	  (dolist (ex examples)
		  (clim:with-output-as-presentation
		   (stream ex 'example-name)
		   (format stream "~A " ex))))
      (format stream "No examples use: ~A ~%" kpml::*collected-features*))))


;; KPML 4.0
(define-kpml-resource-inspector-command 
    (com-EXAMPLES-WITH-SUBSTRING :name t :menu T)
  ()
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (string (clim:accept 'string :stream stream))
	 (examples (kpml::get-examples-with-substring string)))
    (kpml-i-terpri stream)
    (if examples
	(progn 
	  (pen-pprint-for-clim 
	   (format nil "Examples with substring: ~S  are~%" string)
	   ':string stream)
	  (dolist (ex examples)
		  (clim:with-output-as-presentation
		   (stream ex 'example-name)
		   (format stream "~A " ex))))
      (format stream "No examples use the string: ~A ~%" string))))


;; KPML 4.0
(define-kpml-resource-inspector-command 
    (com-MARK-EXAMPLES-WITH-SUBSTRING :name t :menu T)
  ()
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (string (clim:accept 'string :stream stream))
	 (examples (kpml::get-examples-with-substring string)))
    (kpml-i-terpri stream)
    (pen-pprint-for-clim 
     (format nil "~A examples marked" (length examples))
     ':string stream)
    (if examples
	(dolist (ex examples)
	  (pushnew ex *currently-marked*)
	  (when *ex-op-frame*
	    (setf (slot-value *ex-op-frame* 'marked-set) *currently-marked*))))))


;;; ----------------------------------------------------------------------
;;; Additional functions...

;;; Note, following does not appear to be wholely reliable with
;;; multilingual resources loaded... Needs checking over.

(define-kpml-resource-inspector-command (com-GRAMMAR-CONSISTENCY-TESTS
					   :name t :menu nil)
  ()
  (kpml::perform-static-consistency-checks
   :to-file "TESTING-CONSISTENCY-CHECKS"
   :lg-restricted t))


;;; ----------------------------------------------------------------------
;;; Commands available from inspection window command interactor...

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-DISABLE-SYSTEM :name t)	      
  ((system 'system :gesture :select))
  (kpml::disable-system system))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-ENABLE-SYSTEM :name t)	      
  ((system 'system :gesture :select))
  (kpml::enable-system system))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-TRACE-SYSTEM :name t)	      
  ((system 'system :gesture :select))
  (pushnew system kpml::*traced-systems*))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-UNTRACE-SYSTEM :name t)	      
  ((system 'system :gesture :select))
  (setf kpml::*traced-systems* (remove system kpml::*traced-systems*)))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-TRACE-INQUIRY :name t)
    ((inquiry 'inquiry :gesture :select))
  (push (find-symbol (string inquiry) "PENMAN") kpml::*traced-inquiries*))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-UNTRACE-INQUIRY :name t)
    ((inquiry 'inquiry :gesture :select))
  (setf kpml::*traced-inquiries*
    (remove (find-symbol (string inquiry) "PENMAN") 
	    kpml::*traced-inquiries*)))

;;; ------------------------------------------------------------
;;; 0.9 some more for features...

(define-kpml-resource-inspector-command 
    (com-GRAPH-FROM-FEATURE :name t :menu nil)
    ((feature 'feature :gesture :select))
  (create-a-resource-graph feature))
 
 ;; 4.0 added...
 ;;
(define-kpml-resource-inspector-command 
  (com-LIST-EXAMPLES-WITH-FEATURE :name t)
  ((feature 'feature :gesture :select))
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (examples (kpml::get-examples-with-features (list feature))))
    (cond ((gethash feature kpml::all-output-features)
	   (kpml-i-terpri stream)
	   (if examples
	       (progn 
		 (pen-pprint-for-clim 
		  (format nil "Examples using feature: ~A are~%" feature)
		  ':string stream)
		 (dolist (ex examples)
			 (clim:with-output-as-presentation
			  (stream ex 'example-name)
			  (format stream "~A " ex))))
	     (format stream "No loaded examples use: ~A ~%" feature)))
	  (t
	   (kpml::warning feature " not a feature!")))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-COLLECT-FEATURE-2 :name "Collect feature" :menu nil)
    ((feature 'feature :gesture :select))
  (pushnew feature kpml::*collected-features*))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-UNCOLLECT-FEATURE-2 :name "Uncollect feature" :menu nil)
    ((feature 'feature :gesture :select))
  (setf kpml::*collected-features*
    (remove feature kpml::*collected-features*)))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-CLEAR-COLLECTED-FEATURES-2 :name "Clear collected features" :menu nil)
    ((feature 'feature :gesture :select))
  (declare (ignore feature))
  (setf kpml::*collected-features* nil))

;;; ----------------------------------------------------------------------
;;; 0.9 additional commands for navigating between objects of various
;;; kinds that were not covered previously... It should be possible
;;; to click our way around all possible information chains, without
;;; arriving at dead ends where something must be typed in.

;;; systems -> choosers.

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-CHOOSER-OF-SYSTEM :name t)	      
  ((system 'system :gesture :select))
  (kpml::describe-chooser (kpml::fetch-system-chooser system)))

;;; choosers -> systems.

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-SYSTEMS-OF-CHOOSER :name t :menu nil)
  ((chooser 'chooser :gesture :select))
  (let ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	(systems (loop for system in (kpml::list-systems)
		     when (eq (kpml::fetch-system-chooser system) chooser)
		     collect system)))
    (kpml-i-terpri stream)
    (pen-pprint-for-clim 
     (format nil "Systems using chooser: ~A are~%" chooser)
     ':string stream)
    (dolist (system systems)
      (clim:with-output-as-presentation
	  (stream system 'system)
	(format stream "~A " system)))))


;;; 1.1 missed this one...
(define-kpml-resource-inspector-command (com-SHOW-SYSTEM-OF-FEATURE :name t)
  ((feature 'feature :gesture :select))
  (when (gethash feature kpml::all-output-features)
    (loop for s in (kpml::who-has-as-output feature)
	do (kpml::describe-system s))))


;;; ----------------------------------------------------------------------

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
	(com-PAUSE-ON-INQUIRY-INSPECTOR :name "Pause on inquiry")
  ((inquiry 'inquiry :gesture :select))	
  (pushnew inquiry kpml::*inquiries-to-pause-upon*))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-GET-INQUIRY-TO-PAUSE :name t :menu nil)
  ()
  (let ((inquiry-name nil)
    	(stream NIL))
    (restart-case
     (clim:accepting-values 
      (stream
       :own-window T
       :label "Inquiry to pause upon: "
       :exit-boxes '((:exit "Accept")(:abort "Abort")))
      (setf inquiry-name 
	    (clim:accept 'kpml-i::inquiry :stream stream
			 :prompt "Inquiry name"))
      (kpml-i-terpri stream))
     (abort () 
	    (let ((message-frame 
		   (clim:get-frame-pane 
		    kpml-i::*resource-development-frame* 
		    'kpml-i::inspector)))
	      (format message-frame "~%Command aborted."))))
    (com-pause-on-inquiry-inspector inquiry-name)))


#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-STOP-PAUSING-ON-INQUIRY-INSPECTOR :name "Stop pausing on inquiry")
    ((inquiry 'inquiry :gesture :select))
  (setf kpml::*inquiries-to-pause-upon*
    (remove inquiry kpml::*inquiries-to-pause-upon*)))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-RENAME-EXAMPLE-2 :name "Rename example" :menu nil)
  ((example-name 'example-name :gesture :select))
  (example-renamer example-name))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-DELETE-EXAMPLE :name "Delete example" :menu nil)
  ((example-name 'example-name :gesture :select))
  (kpml::delete-example example-name))

;;; ----------------------------------------------------------------------
;;; 0.9.56 Addition of generate SPL term action on SPL terms.
;;;        Uses the same hack for getting an SPL from a term-graph
;;;        as the Edit SPL term command. Can be simplified when
;;;        the old graph-to-term function is fixed. (N.B. CURRENTLY
;;;        WORKING WITH GRAPH-TO-TERM TO CHECK POSSIBLE BUGS: this
;;;        has not been done with the Edit SPL term command since
;;;        there we also require the result to be pretty printed;
;;;        there is a logical form pretty printer under the example
;;;        generic display function which could be used sometime.)

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command (com-GENERATE-FROM-SPL-TERM
				  :name t			      
				  :menu nil)
    ((term 'spl-term :gesture :select))
  (spawn-an-spl-generation term))

(define-kpml-resource-inspector-command (com-GENERATE-EXAMPLE
				  :name t      
				  :menu nil)
    ()
  (com-generate-sentence))

(define-kpml-resource-inspector-command (com-GENERATE-AGAIN-2
				  :name t      
				  :menu nil)
    ()
  (com-generate-again))

;;; Starts a generation process that either takes the specified logical
;;; form as starting point or, if this is not present, takes the 
;;; logical form formed by the value of the SPL term specified.
(defun SPAWN-AN-SPL-GENERATION (term &optional (lf nil))
  (setf *say-process*
    (cpc:make-process #'(lambda ()
			  (run-generate-from-spl-top-level term lf))
		      :name "say-spl-term")))

;;; Does the work of spawning an SPL generation, reporting, setting
;;; abort cases, making an example record, etc.
;;;
;;; 4.0 following was sending a non-string to intern, naughty and
;;;     not correct. Changed.
(defun RUN-GENERATE-FROM-SPL-TOP-LEVEL (spl-term lf)
  (let* ((dev-frame (clim:get-frame-pane 
		     *resource-development-frame* 'inspector))
	 (spl (if lf lf
		(if (and (boundp spl-term)
			 (symbol-value spl-term)
			 (kpml::term-graph-p (symbol-value spl-term)))
		    (kpml::graph-to-term (symbol-value spl-term))
		  nil)))
	 (example-wrap
	  (let ((name (intern (string (kpml::gentemp "SPL")) "PENMAN")))
	    ;; 0.9 make sure that current language prevails
	    (kpml::clear-region-and-language-defaults)
	    (kpml::example-1 
	     `(:name ,name 
		     :logicalform ,spl
		     :targetform ""))
	    name)))
    ;; 2.1
    (when *reset-generation-history-each-generation* (kpml::reset-generation-history))
    (cond (spl
	   (format dev-frame "~%<GENERATING SPL term: ")
	   (clim:with-output-as-presentation
	       (dev-frame spl-term 'spl-term)
	     (format dev-frame "~A" spl-term))
	   (format dev-frame ")>")
	   (restart-case 
	       (say-and-display-results example-wrap dev-frame)
	     (ABORT () (format dev-frame "~2%Generation process aborted.~%")))
	   (kpml-i-terpri dev-frame))
	  (t
	   (format dev-frame "~%Null SPL given as generation source.")))))

;;; ----------------------------------------------------------------------
;;; 1.0.4
;;; was no way to clear the cumulative history without bringing up the
;;; cumulative display window... 

#+(and :kpml-level>= :kpml-l2)
(kpml-i::define-kpml-resource-inspector-command 
    (kpml-i::com-CLEAR-CH-FROM-INSPECTOR
     :name "Clear cumulative history"			      
     :menu nil)
    ()
  (kpml::reset-generation-history))

;;; ----------------------------------------------------------------------
;;; 1.0.38 add show examples with feature to feature options everywhere...
;;; 4.0    updated

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command 
    (com-SHOW-EXAMPLES-WITH-FEATURE-GEN 
     :name "Show examples with feature")
  ((feature 'feature :gesture :select))
  (let* ((stream (clim:get-frame-pane *selexpression-frame* 'selexpr))
	 (stream2 (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (examples (kpml::get-examples-with-features (list feature))))
    ;; (setf *f* feature)
    (cond ((gethash feature kpml::all-output-features)
	   (when *display-examples*
	     (bring-up-a-list-of-examples (list feature)))
	   (kpml-i-terpri stream)
	   (if (and examples stream2)
	       (progn 
		 (pen-pprint-for-clim 
		  (format nil "Examples using feature: ~A are~%" feature)
		  ':string stream2)
		 (dolist (ex examples)
		   (clim:with-output-as-presentation
		       (stream2 ex 'example-name)
		     (format stream2 "~A " ex))))
	     (format stream2 "No examples use: ~A ~%" feature)))
	  (t
	   (when (and *display-examples* 
		      (kpml::fetch-output-features feature))
	     (bring-up-a-list-of-examples 
	      (kpml::fetch-output-features feature)))
	   (kpml::warning feature " not a feature!")))))

;;; was 
#+ignore
(define-kpml-resource-inspector-command 
    (com-SHOW-EXAMPLES-WITH-FEATURE-GEN :name t)
  ((feature 'feature :gesture :select))
  (let* ((stream (clim:get-frame-pane *resource-inspector-frame* 'inspector))
	 (examples (kpml::get-examples-with-features (list feature))))
    (cond ((gethash feature kpml::all-output-features)
	   (kpml-i-terpri stream)
	   (if examples
	       (progn 
		 (pen-pprint-for-clim 
		  (format nil "Examples using feature: ~A are~%" feature)
		  ':string stream)
		 (dolist (ex examples)
			 (clim:with-output-as-presentation
			  (stream ex 'example-name)
			  (format stream "~A " ex))))
	     (format stream "No loaded examples use: ~A ~%" feature)))
	  (t
	   (kpml::warning feature " not a feature!")))))

;;; ----------------------------------------------------------------------
(defun DISPLAY-INSERTS (fn)
  (let ((stream (clim:get-frame-pane *resource-inspector-frame* 
				     'inspector)))
    (loop for r in (kpml::kpml-who-can-insert fn)
	do 
	  (let ((system (first r))
		(feats  (cdr r)))
	    (kpml-i-terpri stream)
	    (clim:with-text-style (stream *sans-serif--bold--10*)
	      (clim:with-output-as-presentation (stream system 'system)
		(format stream "~%~A" system)))
	    (loop for f in feats
		do
		  (kpml-i-terpri stream)
		  (format stream "~4T")
		  (clim:with-text-style (stream *sans-serif--roman--10*)
		    (clim:with-output-as-presentation 
			(stream (car f) 'feature)
		      (format stream ": ~A; " (car f)))
		    (clim:with-text-style (stream *sans-serif--italic--8*)
		      (loop for x in (cdr f) 
			  do (format stream "~A " x)))))))))


;;; ----------------------------------------------------------------------
;;; And the solo (i.e., nonparameterized) versions of the inspection commands
;;; for use from the menubar...

(define-kpml-resource-inspector-command 
  (com-print-system-solo :name "Print system" :menu nil)
  ()
  (com-print-system 
   (clim:accept 'system :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-print-chooser-solo :name "Print chooser" :menu nil)
  ()
  (com-print-chooser
   (clim:accept 'chooser :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-print-inquiry-solo :name "Print inquiry" :menu nil)
  ()
  (com-print-inquiry
   (clim:accept 'inquiry :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

(define-kpml-resource-inspector-command 
    (com-PRINT-LEXICAL-ITEM-SOLO :name "Print lexeme" :menu nil)
    ()
  (com-print-lexical-item
   (clim:accept 'lex-item :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
    (com-print-implementation-solo 
     :name "Print inquiry implementation" :menu nil)
    ()
  (com-print-implementation
   (clim:accept 'inquiry :stream (clim:get-frame-pane 
				  *resource-inspector-frame* 
				  'interactor))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-print-spl-term-solo :name "Print SPL term" :menu nil)
  ()
  (com-print-spl-term
   (clim:accept 'spl-term :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-print-concept-solo :name "Print KR concept" :menu nil)
  ()
  (com-print-concept
   (clim:accept 'kr-concept :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

(define-kpml-resource-inspector-command 
  (com-print-feature-solo :name "Print feature" :menu nil)
  ()
  (com-print-feature
   (clim:accept 'feature :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

(define-kpml-resource-inspector-command 
  (com-graph-grammar-solo :name "Graph grammar" :menu nil)
  ()
  (com-graph-grammar
   (clim:accept 'system :stream (clim:get-frame-pane 
				 *resource-inspector-frame* 
				 'interactor))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-graph-collection :name t :menu nil)
  ()
  (com-graph-from-collecteds))

(define-kpml-resource-inspector-command 
  (com-REGION-OVERVIEW :name t :menu nil)
    ()
  (let ((selected-region (select-a-region-menu)))
    (when selected-region
      (display-region-overview selected-region))))

;; 2.1

(define-kpml-resource-inspector-command 
    (com-ACTIVATE-SELEXPR-TOOL :name t :menu nil)
    ()
  (setf *selection-expression-tool* T)
  (setf *reset-selection-tool* T)
  (startup-selexpression-tool-internal "unknown" nil nil nil nil T))

;;; ----------------------------------------------------------------------

#+(and :kpml-level>= :kpml-l1)
(define-kpml-resource-inspector-command (com-TOGGLE-SINGLE-STEP
					 :name t			      
					 :menu nil)
    ()
  (com-toggle-single-step-2))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-CLEARING-OPTIONS :name "Clear tracing options" :menu nil)
    ()
  (com-development-bs-options))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-RESET-GENERATION-MODES-2 :name "Reset generation modes" :menu nil)
    ()
  (com-reset-generation-modes))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command 
  (com-GENERATION-DISPLAY-MODES-2 :name "Set generation modes" :menu nil)
    ()
  (com-generation-display-modes))

;;; ----------------------------------------------------------------------
;;; Some extras for KPML-internal editing of systems, etc.

;;; 2.0
;;; Following from inspection.lisp extended so that one does
;;; have a choice as to whether to use the KPML-internal
;;; editing form or not. Previously, they *always* used the
;;; KPML-internal form of creation...., that is, the kpml/emacs
;;; choice only affected existing linguistic objects, not the
;;; creation of new ones. We introduce a further flag here to
;;; split that behaviour: when *kpml-internal-new-object-creation*
;;; is set, then we always use the KPML-internal editing form;
;;; if it is not set, then we take our behaviour from the kpml/emacs
;;; editing method list.

(defvar *kpml-internal-new-object-creation* nil)

(define-kpml-resource-inspector-command
    (com-MAKE-NEW-SYSTEM :name t :menu nil)
    ()
  (if (or *kpml-internal-new-object-creation*
          (eq (cdr (assoc :system *kpml-editing-method*)) :kpml))
      (create-a-new-system-editing-graph nil nil *default-region-name*)
    (progn
      (kpml::system
       :name KPML::NEW-SYSTEM
       :inputs kpml::input-features
       :outputs ((1.0 kpml::output-features))
       :region kpml::region)
      (edit-object 'kpml::new-system :system)
      (kpml::delete-system 'kpml::new-system))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command
    (com-MAKE-NEW-CHOOSER :name t :menu nil)
    ()
  (if (or *kpml-internal-new-object-creation*
          (eq (cdr (assoc :chooser *kpml-editing-method*)) :kpml))
      (make-a-chooser-editor nil)
    (progn
      (kpml::chooser
       :name KPML::NEW-CHOOSER
       :definition ((kpml::defaultchoose kpml::feature)))
      (edit-object 'kpml::new-chooser :chooser)
      (kpml::delete-chooser 'kpml::new-chooser))))

#+(and :kpml-level>= :kpml-l2)
(define-kpml-resource-inspector-command
    (com-MAKE-NEW-INQUIRY :name t :menu nil)
    ()
  (if (or *kpml-internal-new-object-creation*
          (eq (cdr (assoc :inquiry *kpml-editing-method*)) :kpml))
      (startup-an-inquiry-editor-frame nil)
    (progn
      (kpml::askoperator
       :name KPML::NEW-INQUIRY
       :answerset (kpml::response)
       :parameters (kpml::parameter)
       :parameterassociationtypes (kpml::concept)
       :trivialdefault (kpml::response))
      (edit-object 'kpml::new-inquiry :inquiry)
      (kpml::delete-inquiry 'kpml::new-inquiry))))

;;; ----------------------------------------------------------------------
;;; 2.0
;;; The following also was relying on the existence of some mysterious
;;; lexical item called new-lexical-item. This was just defined at top
;;; level and can easily get lost, if for example, resources
;;; are cleared, etc. So we have to make anew each time this command is
;;; called. It is possible to set up defaults for the new lexical item
;;; template by setting the following globals to appropriate values.
;;;
;;; 3.2.39 updated so that it allows the user to edit the newly defined
;;;        lexeme more appropriately.

(defvar kpml-i::*new-lexical-item-features* nil)
(defvar kpml-i::*new-lexical-item-properties* nil)


(define-kpml-resource-inspector-command
    (com-MAKE-NEW-LEXEME :name t :menu nil)
    ()
  (progn
    (kpml::load-ml-lexicon
     `(:name KPML::NEW-LEXICAL-ITEM
       :spelling "the spelling"
       :features ,(if kpml-i::*new-lexical-item-features*
                      kpml-i::*new-lexical-item-features*
                    '(kpml::lexical-features))
       :properties ,(if kpml-i::*new-lexical-item-properties*
                        kpml-i::*new-lexical-item-properties*
                      '((property "value")))))
    ;; 3.2.39
    (edit-object 'kpml::new-lexical-item :lexeme)
    (kpml::delete-lexeme 'kpml::new-lexical-item)))
