; --------------------------------------  FORWARDS-REASONS -------------------------------------- 

#| This defines a generic structure whose slots are those used in common by both
backwards and forwards reasons.  If use-basis is nil, when a support-link is constructed, 
the basis is nil.  This is used by def-prob-rule. |#

(defstruct (reason (:print-function print-reason) (:conc-name nil))
    (reason-name nil)
    (reason-function nil)
    (reason-conclusions nil)
    (conclusions-function nil)
    (forwards-premises nil)
    (backwards-premises nil)
    (reason-variables nil)
    (defeasible-rule nil) 
    (reason-strength 1.0)
    (discount-factor 1.0)
    (reason-description nil)
    (reason-instantiated-premise nil)
    (backwards-premises-function nil)
    (temporal? nil)
    (undercutting-defeaters nil)
    (reason-defeatees)
    )

(defun print-reason (x stream depth)
    (declare (ignore depth)) (princ (reason-name x) stream))

;(defunction reason-strength+ (reason)
;    (if (stringp reason) 1.0 (reason-strength reason)))

(defunction reason (name)
    (let ((R (find-if #'(lambda (x) (equal (reason-name x) name)) *forwards-reasons*)))
       (when (null R)
            (setf R (find-if #'(lambda (x) (equal (reason-name x) name)) *backwards-reasons*)))
       R))

(defstruct (forwards-premise (:print-function print-f-premise) (:conc-name fp-))
    (formula nil)
    (kind :inference)
    (condition nil)
    (binding-function nil)
    (variables nil)
    (instantiator nil)
    (clue? nil)
    (node-specifier nil)  ;; bound to the node instantiating the premise in a link
    )

#| Condition1 is a predicate that an existing interest must satisfy to be used in
backwards reasoning as the left terminus of a link encoding this reason, and condition2
is a function which is applied to a new interest constructed for that purpose.
The application of this condition will normally be such as to set the values of slots
so that the resulting interest satisffies condition1. |#
(defstruct (backwards-premise (:print-function print-b-premise) (:conc-name bp-))
    (formula nil)
    (condition1 nil)
    (condition2 nil)
    (instantiator nil)
    (clue? nil)
    (text-condition nil)  ;; text specification of the discharge condition
    (node-specifier nil)  ;; bound to the node instantiating the premise in a link
    )

(defunction premise-node-specifier (premise)
    (cond ((backwards-premise-p premise) (bp-node-specifier premise))
              ((forwards-premise-p premise) (fp-node-specifier premise))))

(defunction print-f-premise (premise stream depth)
    (declare (ignore depth))
    (princ "#<premise: " stream)
    (prinp (fp-formula premise) stream)
    (princ ">" stream))

(defunction print-b-premise (premise stream depth)
    (declare (ignore depth))
    (princ "#<premise: " stream)
    (prinp (bp-formula premise) stream)
    (princ ">" stream))

(defunction clue? (premise)
    (cond ((forwards-premise-p premise) (fp-clue? premise))
              ((backwards-premise-p premise) (bp-clue? premise))))

(defunction construct-forwards-premise (P C V &optional B)
    (make-forwards-premise
      :formula P
      :condition C
      :binding-function B
      :variables V
      :instantiator (reason-instantiator P V)))

(defmacro cfp (P V &optional B) `(construct-forwards-premise ,P nil ,V ,B))

(defunction construct-backwards-premise (P C1 C2 V)
    (let ((V* (subset #'(lambda (x) (occur* x P)) V)))
      (make-backwards-premise
        :formula P
        :condition1 C1
        :condition2 C2
        :instantiator (reason-instantiator P V*))))

(defmacro cbp (P C1 C2 V) `(construct-backwards-premise ,P ,C1 ,C2 ,V))

(defstruct (forwards-reason (:include reason) (:print-function print-reason)
                                                       (:conc-name nil)))

(defun is-inference (c &rest r) (declare (ignore r)) (eq (node-kind c) :inference))

(defun is-desire (c &rest r) (declare (ignore r)) (eq (node-kind c) :desire))

(defun is-percept (c &rest r) (declare (ignore r)) (eq (node-kind c) :percept))

(setf is-inference #'is-inference)

(setf is-desire #'is-desire)

(setf is-percept #'is-percept)

#| This produces a match equivalent to applying m1 first and then m2. |#
(defunction merge-matches* (m1 m2)
    (cond ((null m1) m2)
                ((null m2) m1)
                ((eq m1 t) m2)
                ((eq m2 t) m1)
                (t
                  (let* ((m1* (mapcar #'(lambda (x) (cons (car x) (match-sublis m2 (cdr x)))) m1))
                            (domain (domain m1*))
                            (m2* (subset #'(lambda (x) (not (member (car x) domain))) m2)))
                     (append m1* m2*)))))