(in-package "KPML-I")

;;; File: presentation-methods.lisp
;;; John Bateman. IPSI, updated Sep99 Bremen.

;;; ----------------------------------------------------------------------
;;; Collects all the presentation definitions and accompanying
;;; presentation methods together.
;;; KPML 0.9: completing has been added to typed in object names
;;;           TAB (2.1) => complete as far as possible
;;;           cntrl-?   => give list of possible completers
;;;           cntrl-/   => give list of superstring completers
;;; All accept methods have therefore been completely redone wrt their
;;; 0.8 and before equivalents.
;;;
;;; N.B. 2.1
;;;  John: Sept 99, Bremen.
;;;  was a bit flakey and did not then port to Lispworks, so corrected
;;;  a bit so that it is (hopefully) more in line with how things
;;;  work and also portable across Allegro and Harlequin (at least).
;;; ----------------------------------------------------------------------

;;; ----------------------------------------------------------------------
;;; Presentation types and gestures of the interface...
;;; ----------------------------------------------------------------------

(clim:define-presentation-type SYSTEM () )
(clim:define-presentation-type FEATURE () )
(clim:define-presentation-type CHOOSER ())
(clim:define-presentation-type INQUIRY () )
(clim:define-presentation-type INQUIRY-HISTORY () )
(clim:define-presentation-type SPL-TERM () )
(clim:define-presentation-type EXAMPLE-NAME () )
(clim:define-presentation-type LEX-ITEM () )
(clim:define-presentation-type REGION () )
(clim:define-presentation-type METAFUNCTION () ) ;; 2.1
(clim:define-presentation-type STRATUM () )

(clim:define-presentation-type MICROFUNCTION () ) ;; 3.0

(clim:define-presentation-type KR-INSTANCE ())
(clim:define-presentation-type KR-CONCEPT ())
(clim:define-presentation-type KR-RELATION ())

;;; ----------------------------------------------------------------------
;;; 0.9 completion put back in (based on Allegro CLIM manual p8-40)
;;;     and made properly general. Help is triggered by cntr-?,
;;;     super-help by cntr-/.
;;;
;;; General functions/macros are provided for setting these up
;;; making all the individual methods uniform.
;;;
;;; 2.1 portability update.
;;; ----------------------------------------------------------------------


;;;----------------------------------------------------------------------
;;;  Following function prints the possibility list in the main 
;;;  inspector frame instead of where the command is being printed.
;;;  (2.1 Lispworks, still gets the mousing box in the wrong place
;;;       often...)
;;; ----------------------------------------------------------------------

(defun DISPLAY-COMPLETIONS (completion type stream)
  (declare (ignore type stream))
  (let ((message-stream 
	 (clim:get-frame-pane *resource-inspector-frame* 'inspector)))
    (clim:with-output-recording-options (message-stream :record T)
      (format message-stream "~%    ")
      (clim:with-output-as-presentation
	  (message-stream (first completion) 'string) 
        (format message-stream "~A" (first completion)))
      (second completion))))

;;; ----------------------------------------------------------------------
;;; 2.1 these possibility generators appear to need reworking for Lispworks...
;;;     And why were they creating both upper
;;;     and lower case entries?? (John, Bremen, Sept 99).
;;; ----------------------------------------------------------------------

(defun GENERATE-POSSIBILITIES-FOR-HASH-TABLE (hash-table)
  (let ((possibilities nil))
    (maphash 
     #'(lambda (key value)
	 (declare (ignore value))
         (let ((suggestion 
                (cons (string-upcase (string key)) key)))
           (push suggestion  possibilities)))
     hash-table)
    (remove-duplicates possibilities :test #'equal)))

(defun GENERATE-POSSIBILITIES-FOR-LIST (list)
  (let ((possibilities nil))
    (mapcar
     #'(lambda (key)
         (let ((suggestion 
                (cons (string-upcase (string key)) key)))
           (push suggestion  possibilities)))
     list)
    (remove-duplicates possibilities :test #'equal)))

(defmacro ACCEPTING-FROM-POSSIBILITIES (hash-table start-pos target-type)
  `(let ((possibilities (generate-possibilities-for-hash-table ,hash-table)))
     (clim:with-input-context 
         ('string :override t) 
         (object type)
         (let ((object 
                (clim:completing-from-suggestions 
                    (stream
                     :possibility-printer #'display-completions)
                  (map nil
                       #'(lambda (x) (clim:suggest (car x)(cdr x))) possibilities))))
           object)
       (string
        (clim:replace-input stream object :buffer-start  
                            #+lispworks 0                    ;; 2.1
                            #-lispworks ,start-pos
                            )
        (loop for (display . possible-object) in possibilities
              when (string= display object)
              return
              (values possible-object ,target-type)))
       (t
        (error "Non-string presentation sent thru!")))))
  
(defmacro ACCEPTING-FROM-LIST-OF-POSSIBILITIES (list start-pos target-type)
  `(let ((possibilities (generate-possibilities-for-list ,list)))
     (clim:with-input-context 
         ('string :override t) (object type)
         (let ((object 
                (clim:completing-from-suggestions 
                    (stream
                     :possibility-printer #'display-completions)
                  (map nil
                       #'(lambda (x)(clim:suggest (car x)(cdr x))) possibilities))))
           object)
       (string
        (clim:replace-input stream object :buffer-start 
                            #+lispworks 0                    ;; 2.1
                            #-lispworks ,start-pos
                            )
        (loop for (display . possible-object) in possibilities
              when (string= display object)
              return
              (values possible-object ,target-type)))
       (t
        (error "Non-string presentation sent thru!")))))


;;;----------------------------------------------------------------------
;;;                      PRESENTATION METHODS...
;;;----------------------------------------------------------------------

(clim:define-presentation-method clim:accept
    ((type stratum) stream (view clim:textual-view) &key)
  (accepting-from-list-of-possibilities
   (kpml::fetch-output-features 'kpml::stratification)
   14 'stratum))

(clim:define-presentation-method clim:accept
    ((type region) stream (view clim:textual-view) &key)
  (accepting-from-list-of-possibilities (kpml::get-regions) 14 'region))

(clim:define-presentation-method clim:accept
    ((type system) stream (view clim:textual-view) &key)
  (accepting-from-possibilities kpml::system-table 14 'system))

(clim:define-presentation-method clim:accept
    ((type feature) stream (view clim:textual-view) &key)
  (accepting-from-possibilities kpml::all-output-features 15 'feature))

(clim:define-presentation-method clim:accept
    ((type chooser) stream (view clim:textual-view) &key)
  (accepting-from-possibilities kpml::choosers 15 'chooser))

(clim:define-presentation-method clim:accept
    ((type inquiry) stream (view clim:textual-view) &key)
  (accepting-from-list-of-possibilities kpml::inquiry-operators 15 'inquiry))

(clim:define-presentation-method clim:accept
    ((type spl-term) stream (view clim:textual-view) &key)
  (accepting-from-list-of-possibilities kpml::*plan-graphs* 16 'spl-term))

(clim:define-presentation-method clim:accept
    ((type lex-item) stream (view clim:textual-view) &key)
  (accepting-from-possibilities kpml::lexicon 20 'lex-item))

;;; ----------------------------------------------------------------------
;;; 1.0 additional presentation type for inquiry implementations.
;;; ----------------------------------------------------------------------

(clim:define-presentation-type inquiry-implementation ())

(clim:define-presentation-method clim:accept
    ((type inquiry-implementation) stream (view clim:textual-view) &key)
  (accepting-from-possibilities kpml::*inquiry-implementation-functions*
				20 'inquiry-implementation))



;;; ---------------------------------------------------------------------
;;; The Loom relations fall outside the above pattern. They should
;;; in any case be replaced by generic non-Loom specific kb-interface
;;; functions. For the present, ignore completion on these.
;;; ----------------------------------------------------------------------

(clim:define-presentation-method clim:accept
    ((type kr-concept) stream
     (view clim:textual-view) &key)
  (let* ((token (clim:read-token stream))
	 (concept-object 
	  #+Loom
	  (loom::find-concept token :ignore-package-p t :no-warning-p t)
	  #-Loom
	  (let ((c (typecase token
		     (string 
		      (intern (string-upcase token) (kpml::kb-package)))
		     (null nil)
		     (symbol token))))
	    (kpml::kb-getnamedconcept c))))
    (when (kpml::kb-concept-p concept-object)
      (return-from clim:accept concept-object))
    (clim:input-not-of-required-type token type)))

(clim:define-presentation-method clim:accept
    ((type kr-relation) stream
     (view clim:textual-view) &key)
  (let* ((token (clim:read-token stream))
	 (rel-object 
	  #+loom(loom::find-relation token :ignore-package-p t
				     :no-warning-p t)
	  #-loom
	  (let ((c (typecase token
		     (string 
		      (intern (string-upcase token) (kpml::kb-package)))
		     (null nil)
		     (symbol token))))
	    (kpml::kb-getnamedconcept c))))
    (when (kpml::kb-concept-p rel-object)
      (return-from clim:accept rel-object))
    (clim:input-not-of-required-type token type)))

(clim:define-presentation-method clim:accept
    ((type kr-instance) stream
     (view clim:textual-view) &key)
  (let* ((token (clim:read-token stream))
	 (inst-object 
	  #+loom(loom::find-instance token :ignore-package-p t
				     :no-warning-p t)
	  #-loom '*some-instance*))
    (when inst-object
      (return-from clim:accept inst-object))
    (clim:input-not-of-required-type token type)))
      
