;;;; -*- mode:Scheme -*- ;;;;

(load-option 'format)

;;;; RULE AND ASSERTION PROCEDURES

;;; The top-level list of rules.
(define *rules* '())

(define *my-hash* (make-eq-hash-table))

(define (clear-rules)
  ;; Removes all current rules.
  (set! *rules* '()))

(define (remember-rule rule)
  ;; Adds a single rules to (end of) *rules*
  (if (member rule *rules*)
      *rules*
      (set! *rules* (append *rules* (list rule)))
      ))

;;; Scheme note: the use of . in the argument list allows a function
;;; to be called with a variable number of arguments.  A list of any
;;; remaining arguments "left over" after binding required arguments
;;; are bound to the variable after the dot.  So, remember-rule can be
;;; called with any number of rules (see examples, e.g. zoo.scm).
(define (remember-rules . rules)
  ;; Adds a list of rules to *rules*
  (for-each remember-rule rules))

;;; The top-level list of assertions.
(define *assertions* '())

(define (clear-assertions) 
  ;; Removes all current assertions.
  (set! *assertions* '()))
 
(define (remember-assertion assertion)
  ;; Adds a single assertions to (front of) *assertions*
  (if (member assertion *assertions*)
      *assertions*
      (set! *assertions* (cons assertion *assertions*))))

(define (remember-assertions . assertions)
  ;; Adds a list of assertions to *assertions*, maintain the order.
  (begin
    (for-each remember-assertion assertions)
    (set! *assertions* (reverse *assertions*))))

(define (delete-assertion assertion)
  ;; Deletes assertions that match specified assertion.
  (set! *assertions*
	(append-map (lambda (assert)
		      (if (eq? (match assertion assert) 'fail)
			  (list assert)
			  '()))
		    *assertions*)
	))

(define (count-assertions pattern)
  ;; Counts assertions that match specified pattern.
  (let ((count 0))
    (for-each 
     (lambda (x)
       (let ((m (match pattern x)))
	 (if (not (eq? m 'fail))
	     (set! count (+ count 1)))))
     *assertions*)
    count))

(define (display-assertions assertions)
  ;; Print the assertions.
  (if (not (null? assertions))
      (begin (format #t "~%~a" (car assertions))
	     (display-assertions (cdr assertions)))
      ))

;;;; ACCESS FUNCTIONS FOR RULE ELEMENTS

;;; A rule is stored as a list.  Its first element is an arbitrary
;;; name, the rest are for the form (... Marker a b c Marker...)
;;; where the markers are IF, THEN, etc.  These functions return a
;;; list of all the entries after a specified marker.

(define (rule-name rule) (first rule))
(define (rule-ifs rule) (extract-from-rule 'if rule))
(define (rule-thens rule) (extract-from-rule 'then rule))
(define (rule-then rule) (first (rule-thens rule)))
(define (rule-adds rule) (extract-from-rule 'add rule))
(define (rule-deletes rule) (extract-from-rule 'delete rule))
(define (rule-and-if rule) (extract-from-rule 'and-if rule))
(define (rule-evaluating rule) (extract-from-rule 'evaluating rule))
(define (rule-saying rule) (extract-from-rule 'saying rule))

(define (extract-from-rule marker rule)
  ;; Construct a list of elements in the rule following the specified marker.
  (let ((fragment (member marker rule)))
    ;; (member x l) returns a sublist of l starting with x or #f.
    (if fragment
	(extract-expressions (rest fragment))
	'())))

(define (extract-expressions rule)
  ;; This returns a list of the elements following a marker (such as IF, THEN ...)
  ;; It relies on the fact that markers will fail the list? test.
  (cond ((null? rule) '())
	((list? (first rule))
	 (cons (first rule) (extract-expressions (rest rule))))
	(else '())))

;;;; FORWARD CHAINING

;; Top-level chainer that uses try-first-rule to generate list of triggered
;; rule instances.
(define (chain) (chain-internal try-first-rule 1))

(define (chain-internal rule-instance-select-fn step)
  ;; Initiate forward chaining.
  (let* ((triggered (rule-instance-select-fn))
	 (rule-to-fire (choose-rule-instance triggered)))
    (format #t "~%Step ~s: Triggered rules: ~s" step (map first triggered))
    (if rule-to-fire
	;; The triggered rule is already "instantiated" by try-rule,
	;; that is, any variables have been replaced by what they
	;; matched to in the assertion database.  The relevant
	;; components of the rule are in a list in the following
	;; (arbitrary) order.
	(let* ((name (list-ref rule-to-fire 0))
	       (thens (list-ref rule-to-fire 1))
	       (deletes (list-ref rule-to-fire 2))
	       (evaluatings (list-ref rule-to-fire 3))
	       (sayings (list-ref rule-to-fire 4)))
	  ;; Do the actions specified by the rule.
	  (for-each (lambda (x)
		      (format #t "~%Rule ~a adds ~a" name x)
		      (remember-assertion x))
		    thens)
	  (for-each (lambda (x)
		      (format #t "~%Rule ~a deletes ~a" name x)
		      (delete-assertion x))
		    deletes)
	  (for-each (lambda (x) (eval x (the-environment))) evaluatings)
	  (for-each (lambda (x) (format #t "~%") (apply format #t x))
		    sayings)
	  ;; Keep chaining
	  (hash-table/put! *my-hash* name step)
	  (if (not (member '(STOP) *assertions*))
	      (chain-internal rule-instance-select-fn (+ 1 step))
	      (format #t "~%STOP.")
	      ))
	;; No more rules...
	(format #t "~%No rule can assert anything new"))))

(define (choose-rule-instance rules)
  ;; Conflict resolution. Select first triggered rule instance.
  (if (pair? rules)
      (first rules)
      #f))

(define (my-rule-sorter rule1 rule2)
  (< (hash-table/get *my-hash*
			 (list-ref rule1 0)
			 0)
	 (hash-table/get *my-hash*
			 (list-ref rule2 0)
			 0)))

(define (try-first-rule)
  ;; Check each rules and find the first that triggers.  This is less
  ;; general than try-all-rules, but much faster...
  (let ((sorted-rules (sort *rules* my-rule-sorter)))
    (or (there-exists? sorted-rules (lambda (rule) (try-rule rule)))
	'())))

(define (try-rule rule)
  ;; Determines if a rule is triggered.
  ;; Handles IF, THEN, ADD, DELETE, AND-IF, EVALUATING,
  ;; and SAYING.  The SAYING marker arranges for printing
  ;; helpful notes for the user.
  (let ((bindings-list (apply-filters (rule-ifs rule) (list '()))))
    ;; If bindings-list is non-empty, these are the variable bindings
    ;; determined from the various assertions that match the IF part
    ;; of the rule (antecedent).
    (append-map
     (lambda (bindings)
       ;; Pull out the different components of the rule and
       ;; instantiate them. that is replace variables with the
       ;; matching entry in bindings.
       (let ((deletes (instantiate-variables (rule-deletes rule) bindings))
	     (adds (instantiate-variables (rule-adds rule) bindings))
	     (thens (instantiate-variables (rule-thens rule) bindings))
	     (and-if (instantiate-variables (rule-and-if rule) bindings))
	     (saying (instantiate-variables (rule-saying rule) bindings))
	     (evaluating
	      (instantiate-variables (rule-evaluating rule) bindings))
	     )
	 ;; Check the additional conditions for firing (beyond matching the
	 ;; antecedent to the assertions).  That is,
	 ;; (a) The rule adds a new assertion (via THEN or ADD) or
	 ;; (b) The rule deletes some asertion (via DELETE)
	 ;; and any AND-IF conditions evaluate to true.
	 (if (and (or (not (for-all? thens
			     (lambda (x) (member x *assertions*))))
		      (not (for-all? adds
			     (lambda (x) (member x *assertions*))))
		      (there-exists? deletes
			(lambda (x) 
			  (or (member x *assertions*)
			      ;; Delete may include variable.
			      (there-exists? *assertions*
				(lambda (y) 
				  (not (eq? 'fail (match x y)))))))))
		  (for-all? and-if (lambda (x) (eval x (the-environment)))))
	     ;; Passed the test, return a list with instantiated rule.
	     ;; The outer list is here because the output will be appended.
	     (list (list (rule-name rule)
			 (or thens adds)
			 deletes
			 evaluating
			 saying))
	     ;; Failed.
	     '())))
     bindings-list)))

(define (apply-filters patterns bindings-list)
  ;; Tries to match all patterns to all assertions using
  ;; all binding lists.
  (if (null? patterns)
      bindings-list
      (apply-filters (rest patterns)
		     (filter-bindings-list (first patterns)
					   bindings-list))))

(define (filter-bindings-list pattern bindings-list)
  ;; Tries to match one pattern to all assertions using
  ;; all binding lists.
  (append-map
   (lambda (bindings)
     (match-pattern-to-assertions pattern bindings))
   bindings-list))

(define (match-pattern-to-assertions pattern bindings)
  ;; Tries to match one pattern to all assertions using
  ;; one binding list.
  (append-map
   (lambda (assertion) (try-assertion pattern assertion bindings))
   *assertions*))

(define (try-assertion pattern assertion bindings)
  ;; Tries to match one pattern to one assertion.
  (let ((result (do-match pattern assertion bindings)))
    (if (eq? result 'fail)
        '()
        (list result))))

(define (instantiate-variables pattern bindings-list)
  ;; Replaces variables by their bindings
  (cond ((not (list? pattern)) pattern)
	((null? pattern) '())
	((eq? '? (first pattern))
	 (if (eq? '_ (second pattern))
	     pattern
	     (let ((binding (assoc (second pattern) bindings-list)))
	       (if binding
		   (second binding)
		   (error "Unbound variable in rule:" pattern)))))
	(else (cons (instantiate-variables (first pattern) bindings-list)
		    (instantiate-variables (rest pattern) bindings-list)))))

;;; UTILITIES

(define (append-map fn list)
  ;; Append the reult of the map of FN over list.
  (apply append (map fn list)))