;; -*- Mode: Lisp; -*-

;;;; This file is jrules.lisp
;;;; Last edited 1/29/93, by KDF

;;; Copyright (c) 1989 --- 1992 Kenneth D. Forbus, Northwestern University,
;;; Johan de Kleer and Xerox Corporation.
;;; All rights reserved.

;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty.  The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.

(in-package :cl-user)

(defvar *bound-vars* nil)
(defvar *rule-procedures* nil)

(defstruct (rule (:print-function jtre-rule-printer))
  "JTRE rule definition."
  id           ; Unique ID for easy lookup
  jtre         ; The JTRE it is part of
  dbclass      ; Dbclass of associated pattern
  matcher      ; Procedure that performs the match.
  body)        ; Procedure that does the work.

(defun jtre-rule-printer (r st ignore)
  (declare (ignore ignore))
  (format st "<Rule ~D>" (rule-id r)))

(defvar *file-counter* 0 "ID counter for newly created rules.")
(defvar *file-prefix* "" "Prefix for naming newly created rules.")

(defmacro Rule-File (prefix)
  "For use at beginning of rule file.  Set rulename prefix and zeros counter."
  `(eval-when (compile load eval)
     (setq *file-counter* 0)
     (setq *file-prefix* ,prefix)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Building and installing rules

(defmacro rule (triggers &rest body) 
   "Top-level macro for rule creation."
   (do-rule triggers body))

(defun do-rule (triggers body)
  "Create and return an expanded rule form with the given triggers and body."
  (let ((*rule-procedures* nil)
        (*bound-vars* nil)
        (index-form nil))
    (setq index-form
          (build-rule (car triggers)
                      (subst 'internal-rule
                             'rule
                             (make-nested-rule
                              (cdr triggers) body))))
  `(progn ,@ *rule-procedures* ,index-form)))

(defmacro internal-rule (triggers &rest body)
  `(add-internal-rule ,(car triggers)
     ,(make-nested-rule (cdr triggers) body)))

(defun make-nested-rule (triggers body)
  (cond ((null triggers) body)
        (t `((add-internal-rule ,(car triggers)
               ,(make-nested-rule (cdr triggers) body))))))

(defmacro add-internal-rule (trigger body)
  (build-rule trigger body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Details of rule-building

(defun build-rule (trigger body &aux match-procedure body-procedure)
  "construct form for single rule insertion."
  (multiple-value-bind (pattern condition var test)
                       (parse-rule-trigger trigger)
   (setq match-procedure
         (generate-match-procedure pattern var test condition))   
   (setq body-procedure
         (generate-body-procedure pattern condition var body))
   (push match-procedure *rule-procedures*)
   (push body-procedure *rule-procedures*)
   `(insert-rule
     (get-dbclass ,(get-trigger-dbclass pattern))
     ;return form to index rule
     (function ;the match function for rule
       ,(if *bound-vars*
            `(lambda (p)
               (,(cadr match-procedure) p ,@ *bound-vars*))
          (cadr match-procedure)))
     (function ;;the body function for rule
       ,(if (or *bound-vars*
                (not (eq condition :intern)))
            (let ((tv (nreverse
                        (pattern-free-variables trigger))))
              (unless (eq condition :intern)
                      (push 'trigger-node tv))
              `(lambda ,tv
                 (,(cadr body-procedure) ,@ tv
                  ;(fn-name parameters)
                  ,@ (scratchout tv *bound-vars*))))
              (cadr body-procedure))))))

(defun parse-rule-trigger (trigger)
  (values (cadr trigger)
          (cond ((member (car trigger) '(:intern :in :out))
                 (car trigger))
                (t (error
                    "~% Unknown belief condition ~A in trigger ~A."
                          (car trigger) trigger)))
          (cadr (member :var (cddr trigger)))
          (cadr (member :test (cddr trigger)))))

(defun get-trigger-dbclass (trigger)
  (cond ((variable? trigger)
         (if (member trigger *bound-vars*)  trigger
             (error "~%Trigger dbclass is unbound -- ~A."
                    trigger)))
        ((atom trigger)  (list 'quote trigger))
        (t (get-trigger-dbclass (car trigger)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Generating the body function

(defmacro with-pushed-variable-bindings (new-bindings &rest body)
  `(let ((*bound-vars* (append ,new-bindings
                               (scratchout ,new-bindings
                                           *bound-vars*))))
     ,@ body))

(defun generate-body-procedure (pattern condition var body
                                 &aux newly-bound env fname)
  (setq newly-bound (pattern-free-variables pattern))
  (if var (push var newly-bound))
  (setq body (with-pushed-variable-bindings
               newly-bound (fully-expand-body body)))
  (setq env (append newly-bound
                    (scratchout newly-bound *bound-vars*)))
  (unless (eq condition :intern) (push 'trigger-node env))
  (setq fname (generate-rule-procedure-name pattern))
  `(defun ,fname ,env
     ,@ (cond ((eq condition :intern) body) ;; Just do it
              (t ;; Must check and see if the node's belief state
                 ;; matches the rule's requirements
               `((cond ((,(case condition
                                (:in 'in-node?)(:out 'out-node?)
                                (t (error "~A bad condition -- GBF"
                                                 condition)))
                         trigger-node) ,@ body)
                       (t (push (list ',fname ,@ env)
                                ,(ecase condition
                                       (:in `(tms-node-in-rules trigger-node))
                                       (:out `(tms-node-out-rules trigger-node)
                            ))))))))))

(defun generate-match-procedure (pattern var test condition)
  (multiple-value-bind (tests binding-specs)
   (generate-match-body
    pattern (pattern-free-variables pattern) test)
   `(defun ,(generate-rule-procedure-name pattern)
      (p ,@ *bound-vars*)
       ;;first arg, p, is the pattern
       (if (and ,@ tests)
           (values t (list ,@ (if var '(p))
                           ,@ (reverse binding-specs))
                   ,(unless (eq condition :intern) t))))))

(defun scratchout (l1 l2)  ;non-destructive and order-preserving
  (dolist (el1 l1 l2) (setq l2 (remove el1 l2))))

(defun generate-rule-procedure-name (pattern)
  (intern (format nil "~A-~A-~A" *file-prefix* pattern (incf *file-counter*))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Recursive macroexpansion

(defvar *macros-to-expand*
  '(rule rlet rassert! rretract!
    internal-rule add-internal-rule with-pushed-variable-bindings
    without-contradiction-check with-contradiction-check
    with-contradiction-handler with-JTRE)
  "Macros in this list are automatically expanded by FULLY-EXPAND-BODY.")

(defun fully-expand-body (body)
  "Create complete macroexpansion of <body> form, making
   sure that members of *macros-to-expand* are always expanded."
  (cond ((null body) nil)
        ((not (listp body)) body)
        ((symbolp (car body))
         (cond ((member (car body) *macros-to-expand*)
                (fully-expand-body (macroexpand body)))
               (t (cons (car body)
                        (fully-expand-body (cdr body))))))
        (t (cons (fully-expand-body (car body))
                 (fully-expand-body (cdr body))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Running rules

(defun insert-rule (dbclass matcher body &aux rule)
  "Insert single rule into a dbclass, and run on existing facts."
  (let ((*jtre* (dbclass-jtre dbclass)))
    (setq rule (make-rule :matcher matcher
                          :body body
        		  :dbclass dbclass
                          :id (incf (jtre-rule-counter *jtre*))))
    (push rule (dbclass-rules dbclass))
    (dolist (candidate (dbclass-facts dbclass))
            (try-rule-on rule candidate))))

(defun try-rules (datum)
  (dolist (rule (dbclass-rules (datum-dbclass datum)))
    (try-rule-on rule datum)))

(defun try-rule-on (rule datum)
  (let ((*jtre* (dbclass-jtre (datum-dbclass datum))))
    (multiple-value-bind (okay? bindings node?)
     (funcall (rule-matcher rule)
              (datum-lisp-form datum))
     (when okay?
           (when node?
                 (push (datum-tms-node datum) bindings))
           (enqueue (cons (rule-body rule) bindings) *jtre*)))))

(defun run-rules (&optional (*jtre* *jtre*))
  "run all queued rules."
  (do ((form (dequeue *jtre*) (dequeue *jtre*))
       (counter 0 (1+ counter)))
      ((null form)
       (debugging-jtre "~%    ~A rules run."  counter)
       (incf (jtre-rules-run *jtre*) counter))
    (apply (car form) (cdr form))))

(defun rules-waiting? (jtre) (jtre-queue jtre))

(defun enqueue (new j) (push new (jtre-queue j)))

(defun dequeue (jtre) (pop (jtre-queue jtre)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Display routines

(defun show-rules (&optional (*jtre* *jtre*) (stream *standard-output*))
  "Show the set of all rules in the JTRE."
  (format t "~%There are ~D rules in ~A:" 
          (jtre-rule-counter *jtre*) (jtre-title *jtre*))
  (format stream "~% ~a queued." (if (null (jtre-queue *jtre*)) "none"
                                   (length (jtre-queue *jtre*))))
  (map-dbclass #'(lambda (dbclass)
                 (dolist (rule (dbclass-rules dbclass))
                         (print-rule rule stream)))))

(defun print-rule (rule &optional (stream *standard-output*))
  (format stream "~% ~A: ~A, ~A" rule
          (rule-matcher rule) (rule-body rule)))

(defun test-rule-expansion ()
 "Test rule expansion on a prototypical example."
 (pprint (macroexpand
          '(rule ((:in (implies ?p ?q) :var ?f1)
                  (:in ?p)) (rassert! ?q (:CE ?f1 ?p))))))

(defun get-rule (num &optional (*jtre* *jtre*))
  "Return a rule given its ID number."
  (map-dbclass #'(lambda (dbclass)
                 (dolist (rule (dbclass-rules dbclass))
                         (when (= (rule-id rule) num)
                               (return-from get-rule rule))))))