;;; Derives from a Common Lisp implementation by Patrick Winston.  
;;; Some of the code is borrowed from "Paradigms of AI Programming: Case Studies
;;; in Common Lisp", by Peter Norvig, published by Morgan Kaufmann, 1992.
;;; The complete code from that book is available for ftp at mkp.com in
;;; the directory "pub/Norvig".

;;; Converted to Scheme and extensively modified by Tomas Lozano-Perez (MIT).

;;; BASIC RULE OPERATIONS

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

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

;;; Adds a new rule to *rules* or updates an existing rule of the same name.
(define (remember-rule rule)
  (if (eq? (rule-name rule) 'if)	; catch common mistake
      (display* "Ignoring this rule, which is missing its name:" rule)
      (let* ((name (rule-name rule))
	     (prev-rule (assoc name *rules*)))
	(if prev-rule
	    ;; existing rule, update it.
	    (update-rule prev-rule rule)
	    ;; Adds a single (new) rule to (end of) *rules*
	    (if (member rule *rules*)
		*rules*
		(set! *rules* (append *rules* (list rule)))
		)))
      )
)

;;; replaces old rule with new - assuming same name
(define (update-rule old new)
  (if (equal? (rule-name old) (rule-name new))
      ;; relies on the fact that name is car of list and body is the rest.
      (set-cdr! old (rest new))
      (error "Can only update rules of the same name" old new)
      ))

;;; Hide implementation
(define (get-rules) *rules*)

;;;; 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 (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))
	'())))

;;; 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.
(define (extract-expressions rule)
  (cond ((null? rule) '())
	((list? (first rule))
	 (cons (first rule) (extract-expressions (rest rule))))
	(else '())))

;;; Accessors for rule components - most of these only for forward-chaining.
(define (rule-name rule) (first rule))
(define (rule-body rule) (rest 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-ifs rule) (extract-from-rule 'and-if rule))
(define (rule-evals rule) (extract-from-rule 'evaluating rule))
(define (rule-sayings rule) (extract-from-rule 'saying 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-rules 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))

;;; Like remember-rules but given an explicit list argument.
(define (remember-rules-list rules)
  ;; Adds a list of rules to *rules*
  (for-each remember-rule rules))

;;; BASIC ASSERTION OPERATIONS

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

;;; Removes all current assertions.
(define (clear-assertions) 
  (set! *assertions* '()))
 
;;; Adds a single assertions to (end of) *assertions*, if it is distinct.
;;; This is done by a side-effect to the *assertions* list.
(define (remember-assertion assertion)
  ;; loop is only called when l has at least one entry.
  (define (loop l)
    (or (equal? assertion (first l))	; already there, stop.
	(if (null? (rest l))
	    ;; last assertion, modify last cell to point to the new assertion.
	    (set-cdr! l (list assertion))
	    (loop (rest l)))))
  (if (null? (variables-in assertion))
      (if (null? *assertions*)
	  (set! *assertions* (list assertion))
	  (loop *assertions*))
      (error "Assertion has variables in it, 
probably produced by a rule with a variable in the consequent 
that is not present in the antecedent!" assertion)))

;;; Analogous to remember-rules. 
(define (remember-assertions . assertions)
  ;; Adds a list of assertions to *assertions*, maintains the order in input.
  (for-each remember-assertion assertions))

;;; Like remember-assertions but given an explicit list argument.
(define (remember-assertions-list assertions)
  ;; Adds a list of assertions to *assertions*, maintains the order in input.
  (for-each remember-assertion assertions))

;;; Print the assertions, all those in *assertions* when no arguemt.
(define (display-assertions . arg)
  (for-each (lambda (assertion) (display* assertion))
	    (if (null? arg)
		(get-assertions)
		(first arg))))

;;; Hide the implementation
(define (get-assertions) *assertions*)

;;;; BINDINGS ABSTRACTION

;;; Indicates unification/match failure"
(define *fail* #f)

;;; Indicates unification/match success, with no variables.
(define *no-bindings* '(( #f )))

;;; Replace any ? within exp with a variable of the form ?123.
(define (replace-?-vars exp)
  (cond ((eq? exp '?) (new-variable '?))
	((pair? exp)
	 (reuse-cons (replace-?-vars (first exp))
		     (replace-?-vars (rest exp))
		     exp))
	(else exp)))

;;; Is x a variable (a symbol beginning with `?')?"
(define (variable? x)
  (and (symbol? x) (equal? (string-ref (symbol->string x) 0) #\?)))

;;; Find a (variable . value) pair in a binding list."
(define (get-binding var bindings)
  (assoc var bindings))

;;; Get the variable part of a single binding."
(define (binding-var binding)
  (and binding (car binding)))

;;; Get the value part of a single binding."
(define (binding-val binding)
  (and binding (cdr binding)))

(define make-binding cons)

;;; Get the value part (for var) from a binding list."
(define (lookup var bindings)
  (binding-val (get-binding var bindings)))

;;; Add a (var . value) pair to a binding list."
(define (extend-bindings var val bindings)
  (cons (make-binding var val)
        ;; Once we add a "real" binding,
        ;; we can get rid of the dummy *no-bindings*
        (if (eq? bindings *no-bindings*)
            '()
            bindings)))

;;; Combine lists of bindings
(define (merge-bindings bindings1 bindings2)
  (cond ((or (eq? bindings1 *fail*) (eq? bindings2 *fail*))
	 *fail*)
	((eq? bindings1 *no-bindings*) bindings2)
	((eq? bindings2 *no-bindings*) bindings1)
	(else
	 (append bindings1 bindings2))))

(define (make-bindings-list . l)
  (define (loop lst bindings)
    ;;(print lst)
    (if (null? lst) bindings
	(loop (cddr lst) (extend-bindings (car lst) (cadr lst) bindings))))
  (if (even? (length l))
      (loop l *null-bindings*)
      (error "Length of bindings must be even.")))

;;; Substitute the value of variables in bindings into x,
;;;  taking recursively bound variables into account.
(define (subst-bindings bindings x)
  (cond ((eq? bindings *fail*) *fail*)
        ((eq? bindings *no-bindings*) x)
        ((and (variable? x) (get-binding x bindings))
         (subst-bindings bindings (lookup x bindings)))
        ((not (pair? x)) x)
        (else (reuse-cons (subst-bindings bindings (car x))
			  (subst-bindings bindings (cdr x))
			  x))))

;;; Return (cons x y), or reuse x-y if it is equal? to (cons x y)
(define (reuse-cons x y x-y)
  (if (and (eqv? x (car x-y)) (eqv? y (cdr x-y)))
      x-y
      (cons x y)))

;;; Return a list of all the variables in EXP.
(define (variables-in exp)
  (unique-find-anywhere-if variable? exp))

;;; Return a list of leaves of tree satisfying predicate,
;;;  with duplicates removed.

(define (unique-find-anywhere-if predicate tree)
  (define (loop tree found-so-far)
    (if (pair? tree)
	(loop
	 (first tree)
	 (loop (rest tree) found-so-far))
	(if (predicate tree)
	    (adjoin tree found-so-far)
	    found-so-far)))
  (loop tree '()))

;;; Does predicate apply to any atom in the tree?
(define (find-anywhere-if predicate tree)
  (if (pair? tree)
      (or (find-anywhere-if predicate (first tree))
          (find-anywhere-if predicate (rest tree)))
      (predicate tree)
      ))

;;; Replace all variables in x with new ones."

(define (rename-variables x . new-prefix)
  (let ((renaming
	 (map (lambda (var) 
		(make-binding var (apply new-variable var new-prefix)))
	      (variables-in x))))
    (if (null? renaming) x (subst-bindings renaming x))))

(define *new-variable-counter* 0)
(define *variable-prefix* "?@")

;;; "Create a new variable.  Assumes user never types variables of form ?X_9"
(define (new-variable var . new-prefix)
  (set! *new-variable-counter* (+ 1 *new-variable-counter*))
  (string->symbol
   (string-append (if (variable? var) "" "?")
                  (if (and (not (null? new-prefix)) (first new-prefix))
		      *variable-prefix* 
		      ;; The variable may already be subscripted
		      (root-string (symbol->string var)))
		  "_"
		  (number->string *new-variable-counter*))))

;;; Remove last suffix starting with underscore, foo_1 -> foo and foo_1_2 -> foo_1
(define (root-string str)
  (define (loop i)
    (if (< i 0)
	#f
	(if (eqv? (string-ref str i) #\_)
	    i
	    (loop (- i 1)))))
  (let ((i (loop (- (string-length str) 1))))
    (if i (substring str 0 i) str)))

;;; KNOWLEDGE FILES
;;; Read in an initialize rules, assertions and test functions.
;;; A typical file would look like:
;;; assertions
;;; (parent ...)
;;; (parent ...)
;;; rules
;;; (r1 if ... then ...)
;;; code
;;; (define (test-parent) ...)

(define (read-k-file filename)
  (with-input-from-file filename
    (lambda ()
      (let ((rules '())
	    (assertions '())
	    (mode #f))
	(do ((input (read) (read)))
	    ((eof-object? input)
	     (clear-rules)
	     (apply remember-rules (reverse rules))
	     (clear-assertions)
	     (apply remember-assertions (reverse assertions)))
	  (display input) (newline)
	  (cond ((memq input '(rules assertions code))
		 (set! mode input))
		((eq? mode 'rules)
		 (set! rules (cons input rules)))
		((eq? mode 'assertions)
		 (set! assertions (cons input assertions)))
		((eq? mode 'code)
		 (scheme-eval input))
		(else
		 (error "Unknown mode: " mode)))
	  )))))