;; fps6
#|

An enhanced version of Mark Watson's fps forward-chaining production system.

This program contains software written by Mark Watson. (from COMMON LISP
MODULES, Springer-Verlag 1991)

Enhancements by Lee Spector (LSPECTOR@hamp.hampshire.edu), 1993-4.


Enhancements:
- various stylistic improvements (IMHO)
- MESSAGE, *FPS-MESSAGES* -- message recording system
- new MAKE-FACT -- non-destructive, leading to many changes elsewhere
- extended then-clause functionality -- then-clause syntax:
  (add <fact>)      | (delete <fact>)      | (eval <lisp form>) | 
  (add-rule <rule>) | (delete-rule <rule>) | (halt)
- variable substitution decends into tree structures, but
  fact matching is still top-level-only. 
- FIRE-RULE? split into FIRE-RULE? and DO-THEN-CLAUSES.
- better pattern matcher with segment variables (adapted from Norvig's ELIZA)
- evals nested within other RHS then clauses (partially implemented -- initial
  leading evals only).

Possible future enhancements:
- negated IF clauses
- unification pattern matcher
- rule-base matching in IF clauses
- tree-structured fact matching
- DELETE-RULE that doesn't care about variable names matching

|#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; message recording system

(defvar *fps-messages* ""
  "A string of messages about rule firings, fact additions, etc.
during the current forward-chaining session.")

(defun erase-messages ()
  "Erase all of the messages."
  (setq *fps-messages* ""))

(defun message (format-string &rest args)
  "Add the message, with args handled by FORMAT, to *fps-messages*"
  (setq *fps-messages*
        (concatenate 'string
                     *fps-messages*
                     (apply #'format (cons nil (cons format-string args))))))

(defun print-messages ()
  "Prints all of the saved messages to standard output."
  (format t "~a" *fps-messages*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; globals


(defvar *rules* nil "The current rules for the FPS production system.")
(defvar *facts* nil "The knowledge base for the FPS production system.")
(defvar *explicit-halt* nil "True if a rule has triggered an explicit halt.")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; top-level function

(defun forward ()
  "Invokes the forward-chaining process with the current *rules* and
*facts*. Returns only when one cycle through the rules produces no
firings -- then it returns 'NO-MORE-RULES-FIRE. Use (print-messages)
to see a trace of rule-firings, etc."
  (erase-messages)
  (setq *explicit-halt* nil)
  (let ((keep-going t))
    (loop
      (when *explicit-halt*
        (return 'EXPLICIT-HALT))      ;; an explicit halt was triggered
      (when (not keep-going)
        (return 'NO-MORE-RULES-FIRE)) ;; nothing fired last time
      (setq keep-going nil)
      (dolist (rule *rules*)          ;; try to fire all rules
        (when (fire-rule? rule)
          (message "From rule: ~a~%" rule)
          (setq keep-going t))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; knowledge base functions

(defun not-fact (test-fact)
  "Returns t if test-fact is not a current fact."
  (not (member test-fact *facts* :test #'equal)))

(defun make-fact (fact)
  "Adds the given fact to the knowledge base."
  (when fact
    (push fact *facts*)
    (message "New fact: ~a~%" fact)))

(defun delete-fact (fact)
  "Deletes the given fact from the knowledge base."
  (when fact
    (setq *facts* (remove fact *facts* :test #'equal))
    (message "Deleted fact: ~a~%" fact)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; rule-base functions

(defun add-rule (rule)
  "Adds the given rule to the rule-base."
  (push rule *rules*)
  (message "New rule: ~a~%" rule))

(defun delete-rule (rule)
  "Deletes the given rule from the rule-base."
  (setq *rules* (remove rule *rules* :test #'equal))
  (message "Deleted rule: ~a~%" rule))

(defun not-rule (test-rule)
  "Returns t if test-rule is not a current rule."
  (not (member test-rule *rules* :test #'equal)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; variable handling and pattern matching
;; from the version of ELIZA  written by Peter Norvig and modified by
;; Lee Spector

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; variable/binding handling functions
;; (Norvig used association lists and sublis)

(defconstant fail nil
  "Indicates pat-match failure")

(defconstant no-bindings '((t t))
  "Indicates pat-match success, with no variables.")

(defun subvv (varval-list list)
  "Returns list with substitutions made as indicated in in varval-list."
  (dolist (varval-pair varval-list)
    (setq list (subst (second varval-pair) (first varval-pair) list)))
  list)

(defun subvv-quoted (varval-list list)
  "Returns list with substitutions made as indicated in in varval-list.
Variables are replaced at all levels of the list, and they are
replaced with quoted instances of their values. For example, if ?x is bound
to FOO, (bar ?x (baz ?x)) will produce (bar 'foo (baz 'foo))."
  (dolist (varval-pair varval-list)
    (setq list (subst (list 'quote (second varval-pair))
                      (first varval-pair)
                      list)))
  list)

(defun variable-p (x)
  "Is x a variable (a symbol beginning with `?')?"
  (and (symbolp x)
       (equal (char (symbol-name x) 0)
              #\?)))

(defun segment-pattern-p (pat)
  "Is this a segment-matching pattern: (?*var ...)"
  (and (listp pat)
       (>= (length (symbol-name (car pat))) 2)
       (equal (char (symbol-name (car pat)) 0) #\?)
       (equal (char (symbol-name (car pat)) 1) #\*)))

(defun get-binding (var bindings)
  "Find a (variable value) pair in a binding list."
  (cond ((null bindings) nil)
        ((eq var (caar bindings))
         (car bindings))
        (t (get-binding var (cdr bindings))))) 

(defun binding-val (binding)
  "Get the value part of a single binding."
  (cadr binding))

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

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


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pattern matching

(defun match-variable (var input bindings)
  "Does VAR match input?  Uses (or updates) and returns bindings."
  (let ((binding (get-binding var bindings)))
    (cond ((not binding)
           (extend-bindings var input bindings))
          ((equal input (binding-val binding))
           bindings)
          (t fail))))

(defun pat-match (pattern input &optional (bindings no-bindings))
  "Match pattern against input in the context of the bindings"
  (cond ((eq bindings fail) fail)
        ((variable-p pattern)
         (match-variable pattern input bindings))
        ((equalp pattern input) bindings)
        ((segment-pattern-p pattern)            ; ***
         (segment-match pattern input bindings)); ***
        ((and (listp pattern) (listp input)) 
         (pat-match (rest pattern)
                    (rest input)
                    (pat-match (first pattern)
                               (first input) 
                               bindings)))
        (t fail)))

;; our segment match is not as robust as Norvig's
(defun segment-match (pattern input bindings)
  "Match the segment pattern (?*var remainder) against input."
  (let ((var (first pattern))
        (remainder (rest pattern)))
    (if (null remainder)
      (match-variable var input bindings)
      (if (member (first remainder) input)
        (pat-match remainder
                   (member (first remainder) input)
                   (match-variable var
                                   (upto (first remainder) input)
                                   bindings))
        fail))))


(defun match-to-some-fact (list bindings)
  "Returns the variable bindings required to match list to some fact
in the knowledge base in the context of the given pre-established
bindings."
  (let ((new-bindings bindings))
    (dolist (fact *facts*)
      (setq new-bindings (pat-match list fact bindings))
      (when new-bindings (return new-bindings)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utilities

(defun upto (item list)
  "returns the list up to, but not including the first element that is
equalp to the given item."
  (cond ((null list) nil)
        ((equalp item (car list)) nil)
        (t (cons (car list) (upto item (cdr list))))))

(defun flatten (the-list)
  "Append together elements (or lists) in the list."
  (apply #'append
         (mapcar #'(lambda (thing)
                     (if (listp thing)
                       thing
                       (list thing)))
                 the-list)))

(defun random-elt (choices)
  "Choose an element from a list at random."
  (nth (random (length choices)) choices))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; rule firing

(defun fire-rule? (rule)
  "Attempts to fire the given rule. Returns non-nil if it fires and results in
action being taken (kb modification or lisp code evaluated)."
  (if (not (equal (car rule) 'if))   ;; minimal rule syntax check
    (message "Illegal rule: ~a~%" rule)
    (let ((rule-fired t) (bindings no-bindings))
      ;; try to match IF clauses
      (setq rule (cdr rule))         ;; skip the IF
      (dolist (clause rule)
        (when (equal clause 'then) (return))   ;; when we find THEN we're done
        (setq bindings (match-to-some-fact clause bindings))
        (unless bindings  ;; if we get empty bindings we've failed to match
          (setq rule-fired nil)
          (return)))
      ;; do then-clauses if the rule fires
      (when rule-fired
        (do-then-clauses (cdr (member 'then rule)) bindings)))))


(defun do-then-clauses (clauses bindings)
  "Performs the actions specified by the given set of then-clauses, using
the given variable bindings. Returns non-nil if an action is taken."
  (let ((action-taken nil) (fact nil) (rule nil))
    (dolist (then-clause clauses) ;; for each clause
      (let ((action-arg (do-embedded-evals (second then-clause) bindings)))
        (case (first then-clause)   ;; do the right thing depending on the keyword
          (add (setq fact (subvv bindings action-arg))
               (when (not-fact fact)
                 (make-fact fact)
                 (setq action-taken t)))
          (delete (setq fact (subvv bindings action-arg))
                  (unless (not-fact fact)
                    (delete-fact fact)
                    (setq action-taken t)))
          (eval (eval (subvv-quoted bindings action-arg))
                (setq action-taken t))
          (add-rule (setq rule (subvv bindings action-arg))
                    (when (not-rule rule)
                      (add-rule rule)
                      (setq action-taken t)))
          (delete-rule (setq rule (subvv bindings action-arg))
                       (unless (not-rule rule)
                         (delete-rule rule)
                         (setq action-taken t)))
          (halt (setq *explicit-halt* t))
          (otherwise (message "Illegal then-clause: ~a~%" then-clause)))))
    action-taken)) ;; return non-nil if something happened

(defun do-embedded-evals (list bindings)
  "Returns list with all internal instances of (eval <form>) replaced
with <val-of-evaling-list-with-bindings>. CURRENT VERSION ONLY WORKS FOR A SINGLE,
INITIAL EVAL."
  (if (eq (first list) 'eval)
    (eval (subvv-quoted bindings (second list)))
    list))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; examples
#|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; watson's example -- modified for the extended syntax

(setq *rules*
      '((if (in jeep) (has ?object) then (add (drive jeep)))
        (if (has ?x) then (add (drop ?x)))
        (if (drive jeep) then (add (be-at store)))
        (if (in jeep) then (add (leave jeep)))
        (if (leave jeep) then (add (walk)))))

(setq *facts* '((in jeep) (has keys)))

(forward)
(print-messages)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; enhanced watson's example -- uses delete and eval

(setq *rules*
      '((if (in jeep) (has ?object) then (add (drive jeep)))
        (if (has ?x) (angry)
            then
            (add (drop ?x))
            (eval (format t "Ouch! I dropped ~a!~%" ?x))
            (delete (angry)))
        (if (drive jeep) then (add (be-at store)))
        (if (in jeep) then (add (leave jeep)))
        (if (leave jeep) (fidgety)
            then
            (add (walk))
            (eval (ed-beep))
            (delete (fidgety)))))

(setq *facts* '((in jeep) (has keys) (angry) (fidgety)))

(forward)
(print-messages)
          
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; examples using rule mods

(setq *rules*
      '((if (curious ?x) then (add-rule (if (rumor ?x) then (add (ask ?x)))))
        (if (ask ?x) then (add (know ?x)) (delete (curious ?x)))))
      
(setq *facts* '((curious trees) (curious fish) (rumor trees)))

(forward)
(print-messages)


;; this one shows a rule deletion
(setq *rules*
      '((if (dumb) then (delete-rule (if (rumor ?x) then (add (ask ?x)))))
        (if (rumor ?x) then (add (ask ?x)))))
      
(setq *facts* '((dumb)))

(forward)
(print-messages)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; an explicit halt example

(setq *rules*
      '((if (love ?x)
          then
          (delete (love ?x))
          (add (leave ?x))
          (halt))))

(setq *facts* '((love fish) (love chips) (love pretzels)))

(forward)
(print-messages)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a segment matching example

(setq *rules*
      '((if (ate ?*x) (hungry)
          then
          (delete (hungry))
          (eval (print (append '(I just ate) ?*x))))))

(setq *facts* '((hungry) (ate fish chips sugar lips)))

(forward)
(print-messages)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; an internal eval rule

(setq *rules*
      '((if (really hungry for ?food)
          then
          (add (eval (list 'eat ?food ?food 'and 'more ?food))))))

(setq *facts* '((really hungry for burgers)))

(forward)
(print-messages)

            
|#