;;; -*- Mode: LISP; Syntax: Ansi-common-lisp; Base: 10; Vsp: 1; Package: RPRS -*-

;;;; user.lisp
(in-package rprs)
;;; User (lisp) interface to RPRS. All functions in this file are exported unless
;;; otherwise noted.

;;;;;
;;;;; Copyright (C) 1993, 1991, 1989 by the University of Rochester. All rights reserved.
;;;;; See your Rhet license agreement and file RPRS:rprs;copyright.text for more details.
;;;;;
;; 3.2 12May92 by Miller - fix reset to have reset-tempos first, since that clears rhet structures.
;; 3.3 13May92 by miller - per spackman@dfki.uni-sb.de, allow timelogic/tempos args to reset-rprs.

;;;; Note: references to "thesis" are to 
;;;
;;;@string{URCS = "University of Rochester, Computer Science Department"}
;;;
;;;@phdthesis{Kautz,
;;;		Author = "Kautz, Henry A.",
;;;		Title = "A Formal Theory of Plan Recognition",
;;;		School = URCS,
;;;		Year = 1987,
;;;		Month = may,
;;;		Note = "Also published as TR215"}
;;;

(DEFUN RESET-RPRS (&rest timelogic-args &key &allow-other-keys)
  "Reset the RPRS system to the just-loaded and initialized condition."
  (apply #'TEMPOS::RESET-TEMPOS :TT-AXIOMS-P T #||:TRACE :ON||# :AUTO-REFERENCE :ON :allow-other-keys t timelogic-args )
  (DEFINE-REP-RELATION :STEPS :INHERIT-TYPE :MERGE
		       :FN-DEFINITION-HOOK 'STEP-RELATION-DEFINITION-HOOK)
  (SET-CONTRADICTION-MODE :THROW 'RPRS-CONTRADICTION-FOUND)
  (SETQ RHET-TERMS:*INHIBIT-MAXTYPE-WARNINGS* T)	;yeah, yeah.
  (TSUBTYPE 'T-U 'T-AGENT-OBJECT)			;give it REP name later, but need to maxtype F-AGENT first.
  (DEFINE-SUBTYPE 'T-ANIMATE 'T-U)
  (DECLARE-FN-TYPE 'F-AGENT '(T-AGENT-OBJECT T-ANIMATE))	; set maxtype correctly
  (DEFINE-SUBTYPE 'T-AGENT-OBJECT 'T-U
    :ROLES '((R-AGENT T-ANIMATE)))
  (TDISJOINT 'T-ANIMATE 'T-AGENT-OBJECT 'T-TIME)
  (DEFINE-SUBTYPE 'T-PLAN 'T-AGENT-OBJECT	; plans must be a subtype of this. Necessary slots common to all
						; plans defined here.
    :INITIALIZATIONS (LIST (CONS-RHET-FORM 'RLLIB::ASSERT-RELATIONS	; force them to provide their own accessors, this is a bit
					   (RHET-TERMS:CREATE-RVARIABLE "?SELF")	; more general, and besides, we need to do 
					   :STEPS			; declare-fn-type.
					   :T)))
  ;; actions (steps in a plan) must be a subtype of this. Necessary slots common to all
  (DEFINE-SUBTYPE 'T-ACTION 'T-AGENT-OBJECT)	  ; actions defined here.
  (TDISJOINT 'T-ACTION 'T-PLAN)			  ; plans are not actions, and vice-versa
  (DEFINE-SUBTYPE 'T-RPLAN 'T-PLAN)	; plans that can be construed as a complete plan are subtypes of this. See thesis for
					; information about "END" plan types. (Henry makes END an abstraction for certain kinds of
					; plans, RPRS makes it a subtype relationship only. This also prevents going thru each
					; abstraction separately.)
  (DEFINE-SUBTYPE 'T-CPLAN 'T-PLAN)	; for non-end (recognizable) plans, they inherit from this.
  (TXSUBTYPE 'T-PLAN 'T-CPLAN 'T-RPLAN)	; note that these types partition the plan type, either you are a recognizable plan, or you
					; are not.
  #+logical-pathnames (LOAD "rprs:code;rhet-code.lisp")
  #-logical-pathnames (load "/s5/rprs/code/rhet-code.lisp")
  (VALUES))

#+CLIM
(RWIN:DEFINE-RHET-COMMAND (COM-RESET-RPRS :MENU T) () (RESET-RPRS))

#+CLIM
(RWIN:DEFINE-RHET-COMMAND (COM-EXPLAIN-OBSERVATIONS :MENU T) 
    ((EVENT-LIST '((CLIM:EXPRESSION)) :DOCUMENTATION "List of events to explain"))
   (EXPLAIN-OBSERVATIONS EVENT-LIST))

#+CLIM
(DEFMETHOD RWIN::REDISPLAY-TITLE :AFTER ((SELF RWIN::RHET) OUTPUT-STREAM)
  (format OUTPUT-STREAM "{RPRS, TEMPOS Loaded}"))
		
(DEFUN EXPLAIN-OBSERVATIONS (&REST EVENT-LIST)
  "Return a list of lists whose cars are a possible Plan that describe all of EVENT-LIST, and whose cdr is the context
this instance is instantiated in. Each EVENT object is an instance of a subtype of T-Action.

Note that one can make following calls to Explain-Observations passing one of these returned contexts; this would constrain
the world to be consistent with the previous discovered plan."
  ;; try to find entries

  ;; this step will depend on the particular algorithm. Now, assume they must be related

  (LET* ((UCONTEXT (EXTRACT-KEYWORD :UCONTEXT EVENT-LIST "T"))
	 (EVENT-LIST (TRUNCATE-KEYWORDS EVENT-LIST))
	 (PLAN-LIST (RHET-TERMS:CREATE-RVARIABLE "?plan-list" RHET-TERMS:*T-LIST-ITYPE-STRUCT*))
	 CANDIDATES	  ; each value is [has-step-recursive event-type plan-type (plan-type step)]
	 RETURN-VALUE)
    (PROVE (CONS-RHET-FORM 'COVER-OBSERVATIONS EVENT-LIST PLAN-LIST) :MODE :SIMPLE)	  ;side effect changes plan-list
    (SETQ CANDIDATES (E-UNIFY:CRUNCH-VARS (E-UNIFY:GET-VAR-REFERENCE PLAN-LIST)))

    ;; now we must instantiate each possibility so Rhet will calculate constraints. Set up handlers for certain kinds of errors
    ;; Rhet may generate. 'rprs-contradiction-found is thrown by rhet thanks to the set-contradiction-mode in reset-rprs.
    ;;
    ;; Catch them here and then we know that particular plan is impossible.
    ;; Where oh where is the common-lisp error system when you really need it?
    (FORMAT T "Candidates for matching: ~S" CANDIDATES)
    (DOLIST (CURRENT-PROOF-ENTRY (UNLESS (RHET-TERMS:RVARIABLE-P CANDIDATES)
				   CANDIDATES))
      ;; generate a new context to make the attempt in. This should be a child of the provided Ucontext.
      (LET ((TEST-CONTEXT (PROG1 (STRING (GENSYM "RPRS-Test-Context")))))
	(CREATE-UCONTEXT TEST-CONTEXT UCONTEXT)
	(LET* ((*DEFAULT-CONTEXT* (UCONTEXT TEST-CONTEXT))      ; so adds and proof done in this new context.
	       (RHET-TERMS:*CURRENT-CONTEXT* *DEFAULT-CONTEXT*)
	       RPLAN-INSTANCE
	       (ABORT T))
	  (DECLARE (SPECIAL *DEFAULT-CONTEXT* RHET-TERMS:*CURRENT-CONTEXT*))
	
	  ;; for this CURRENT-PLAN instantiate it.
	  (CATCH 'RPRS-CONTRADICTION-FOUND
	    ;; add equalities for the EVENTs and if we actually finish, we have succeeded in showing by construction
	    ;; a consistent plan which "explains" all the observed events.
	    (LABELS ((CREATE-PLAN (PLAN-TYPE STEP-ENTRIES)
		       (LET ((INSTANCE (DEFINE-INSTANCE (CONS-RHET-FORM (GENSYM "CUR-PLAN")) PLAN-TYPE)))
			 (DOLIST (STEP-ENTRY STEP-ENTRIES)
			   (ADD-EQ (IF (CONSP (SECOND STEP-ENTRY))
				       (CREATE-PLAN (CAR (SECOND STEP-ENTRY)) (CDR (SECOND STEP-ENTRY)))
				       (SECOND STEP-ENTRY))
				   (CONS-RHET-FORM (FIRST STEP-ENTRY) INSTANCE)
				   :HANDLE-ERRORS T))
			 INSTANCE)))

	      (SETQ RPLAN-INSTANCE (CREATE-PLAN (CAR CURRENT-PROOF-ENTRY) (CDR CURRENT-PROOF-ENTRY))))
	    (SETQ ABORT NIL))
	  (IF ABORT
	      (DESTROY-UCONTEXT TEST-CONTEXT)	    ; error
	      (PUSH (LIST RPLAN-INSTANCE TEST-CONTEXT) RETURN-VALUE)))))
    RETURN-VALUE))

;;
;;
(DEFUN DEFINE-ACTION-TYPE (TYPE &REST ARGS &KEY (PARENT 'T-ACTION) &ALLOW-OTHER-KEYS)
  "Defines a RPRS compatible Action type, which may appear as a constructor function in a step.
Warning: be sure to define these BEFORE use, otherwise types won't get updated properly.
\(and RPRS will not find any applicable plans with steps.)"

  (APPLY #'DEFINE-FUNCTIONAL-SUBTYPE (LIST* TYPE PARENT ARGS)))

;;
;;
(DEFUN DEFINE-RPLAN-TYPE (TYPE &REST ARGS &KEY (PARENT 'T-RPLAN) STEPS &ALLOW-OTHER-KEYS )
  "Defines a RPRS compatible Plan type, which may be returned by the recognizer as a 'complete' or Recognized PLAN"
  (DEFINE-PLAN-TYPE-COMMON TYPE PARENT :RPLAN STEPS ARGS))

(DEFUN DEFINE-CPLAN-TYPE (TYPE &REST ARGS &KEY (PARENT 'T-CPLAN) STEPS &ALLOW-OTHER-KEYS)
  "Defines a RPRS compatible Plan type, which may NOT be returned by the recognizer as a 'complete' plan, rather it is
a Constituent PLAN"

  (DEFINE-PLAN-TYPE-COMMON TYPE PARENT :CPLAN STEPS ARGS T))

(DEFUN DEFINE-PLAN-TYPE-COMMON (TYPE PARENT-TYPE CODE STEPS ARGS &OPTIONAL FUNCTIONAL)
    (COND
      (STEPS
       ;; define-subtype would do the tsubtype call, but we want to define appropriate fn types for our steps first.
       (LET ((RHET-TERMS:*HDEBUG* T))     ;so tsubtype will do tsubtype instead of define-subtype
	 (TSUBTYPE PARENT-TYPE TYPE))
       (APPLY (IF FUNCTIONAL #'DEFINE-FUNCTIONAL-SUBTYPE #'DEFINE-SUBTYPE)
	      TYPE PARENT-TYPE :RELATIONS `((:STEPS ,@STEPS) ,@(EXTRACT-KEYWORD :RELATIONS ARGS)) ARGS)
       ;; invert the steps (we could handle, but don't, having step relations inside of ARGS)
       (LET ((NUMBER 0))
	 (DOLIST (STEP (RHET-TERMS:GET-RELATIONS :STEPS TYPE))    ; this picks up inherited steps so they get properly inverted.
	   (INCF NUMBER)
	   (LET ((STEP-TYPE (GET-TYPE-OBJECT (IF (CONSP STEP)    ;playing the accessor game
						  (CDR STEP)
						  STEP)))
		 (CURRENT-ACCESSOR (IF (CONSP STEP)		 ; note: don't currently handle accessor string for
								 ; assert-relations, only :t or default.
					(CAR STEP)		 ; accessor which assert-relations will use.
					(INTERN			 ; default for assert-relations.
					  (FORMAT NIL "STEPS-%d" NUMBER) *KEYWORD-PACKAGE*))))
		     (LET ((AXIOM (CONS-RHET-AXIOM
				    (CONS-RHET-FORM :HAS-STEP CODE
						    (INTERN (STRING TYPE) *KEYWORD-PACKAGE* )
						    (INTERN (STRING #| (RELN-TYPE STEP-TYPES) |# STEP-TYPE) *KEYWORD-PACKAGE*)
						    CURRENT-ACCESSOR))))
		       (SETF (RAX:RINDEX AXIOM) "INDEX-<RPRS-ASSERTION")
		       (Rassert AXIOM))))))
      (T
       (APPLY (IF FUNCTIONAL #'DEFINE-FUNCTIONAL-SUBTYPE #'DEFINE-SUBTYPE) TYPE PARENT-TYPE ARGS))))

;; for now, a quick and dirty function to pretty print out and explanation returned by explain-observations.
(DEFUN SHOW-EXPLANATION (X)
  (LET ((RHET-TERMS:*CURRENT-CONTEXT* (UCONTEXT (CADR X))))
    (DECLARE (SPECIAL RHET-TERMS:*CURRENT-CONTEXT*))
    (FORMAT T "~&~%In context: ~A we found plan ~S of type~%~{~S~%~} with steps~%~{~S~%~}"
	    (CADR X) (CAR X) (MULTIPLE-VALUE-LIST (RETRIEVE-DEF (CAR X) :RCONTEXT (UCONTEXT (CADR X))))
	    (LET (STEPLIST)
	      (DOTIMES (N 5)					;handle 5 steps
		(LET*-NON-NULL ((STEP (E-UNIFY:SIMPLIFY-FORM
					(CONS-RHET-FORM
					  (INTERN (FORMAT NIL "S-~D" (+ N 1)) (FIND-PACKAGE 'rhet-user))
					  (CAR X)))))
		  (PUSH
		    (FLET ((CVT-TO-FN-TERM (CAN)
			     (E-UNIFY:CONVERT-TO-FN-TERM (OR (RHET-TERMS:PRIMARY CAN)
							(IF (RHET-TERMS:CONSTRUCTOR-SET CAN)
							    (CAR (RHET-TERMS:CONSTRUCTOR-SET CAN)))
							(CAR (RHET-TERMS:CSET CAN))))))
		      (TYPECASE STEP
			(RFORM
			  STEP)
			(CANONICAL
			  (CVT-TO-FN-TERM STEP))
			(FN-TERM
			  (LET ((CNAME (RHET-TERMS:GET-CANONICAL STEP RHET-TERMS:*CURRENT-CONTEXT*)))
			    (IF CNAME
				(CVT-TO-FN-TERM CNAME)
				STEP)))
			(T
			  STEP)))
		    STEPLIST)))
	      STEPLIST))
    (LET ((RHET-TERMS:*PRINT-FN-TERM-PRETTY* NIL))
      (FORMAT T " and equivclass~%~{~S~%~}"
	      (EQUIVCLASS (CAR X) :RCONTEXT RHET-TERMS:*CURRENT-CONTEXT*))))
  X)

(DEFUN STEP-RELATION-DEFINITION-HOOK (TYPE STEPS)
  "Called when define-(functional-)subtype is about to reparse constraints/relations/initializations. This lets step
accessors be properly declared first."
  (MAPC #'(LAMBDA (STEP)
	    (UNLESS (LOOK-UP-FN-TYPE (CAR STEP))
	      ;; never before defined; this will set an appropriate maxtype.
	      (DECLARE-FN-TYPE (CAR STEP) (LIST 'T-PLAN 'T-AGENT-OBJECT)))
	    (ADD-FN-TYPE (CAR STEP) (LIST TYPE (LET ((RHET-TERMS::*BE-PERMISSIVE* T))
						 (DECLARE (SPECIAL RHET-TERMS::*BE-PERMISSIVE*))
						 (GET-TYPE-OBJECT (CDR STEP))))))
	STEPS))
