;;;
;;; FILE: hw2-prod.ss
;;;
;;; kyle wagner
;;; february 10, 1997
;;;
;;; This file contains all of the code needed to run a forward-chaining
;;; production system.  Also included are rule lists for the production
;;; system to use, along with an initial working memory.
;;;
;;; Programs contained herein:
;;;
;;;   substitute
;;;   unify
;;;   unify-var
;;;   match-antecedent
;;;   execute
;;;   match-rule
;;;   match-rules
;;;   run-ps
;;;
;;; To test each function:
;;;
;;;   test-match-antec
;;;   test-execute
;;;   test-match-rule
;;;   test-match-rule9
;;;   match-rules-test
;;;   run-ps-test   (this will actually run run-ps on the working memory
;;;                  specified in the homework assignment)
;;;
;;;
;;; A few, brief descriptions:
;;;
;;; states: lists with two items in them.  The first item is a list of
;;;      antecedents, the second is a list of substitutions:
;;;      ( <list of antecedents>  <list of substitutions>).  The first
;;;      antecedent in the list of antecedents is the one we will be interested
;;;      in when expanding states for the depth-first-search executed by
;;;      match-rule.
;;; working memory: list of lists: each list is an assertion either given at
;;;      startup or generated by firing rules.  This list has no ordering
;;;      to speak of.  "Working" here refers to the fact that we work with
;;;      the memory, not to the fact that it could be broken; it isn't.
;;;
;;; Variables look like:
;;;   ?x
;;;
;;; A substitution list looks like:
;;;   ((?x . john) (?y . cough) (?z . flu))
;;;
;;;
;;;



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;; Here's the code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;
;;; substitute
;;;
;;; INPUT
;;;   subs, a substitution list of the form: ((?x john) (?y mary) ...)
;;;   pattern, a list with symbols and vars.  Vars will be replaced according
;;;     to subs.
;;;
;;; OUTPUT
;;;   returns new pattern, with substitutions made
;;;
;;; OPERATION
;;;   For each item in the pattern list, check to see if it is a variable.
;;;   If so, replace it with its value in subs (if none, leave it alone).
;;;   If the item is a sublist, call substitute on that sublist.
;;;   If the item is a non-variable atom, just keep it and move on to
;;;     the next item in pattern.
;;;
(define substitute
  (lambda (subs pattern)
    (cond 
     [(null? pattern) '()]
     [else
      (let ([item (car pattern)]
	    [rest (cdr pattern)])
	(cond
	 
	 ;;
	 ;; Is the item a variable?  Find its value, replace.
	 ;;
	 [(var? item)
	  (let ([sub (assoc item subs)])
	    (cond 
	     
	     ;; Nothing found - keep the item
	     [(eq? sub #f)
	      (cons item
		    (substitute subs rest))]

	     ;; Continue replacing vars until no longer possible
	     [(and (var? (cdr sub))
		   (not (equal? (cdr sub) item)))
	      (substitute subs
			  (cons (cdr sub) rest))]

	     ;; Found something, replace and go on to rest
	     [else
	      (cons (cdr sub)
		    (substitute subs rest))]))]
	 
	 ;;
	 ;; Is item a list?  Call substitute on it...
	 ;;
	 [(list? item)
	  (cons (substitute subs item)
		(substitute subs rest))]
	 
	 ;;
	 ;; Item is not a var or a list -  keep it and move on to next item
	 ;;
	 [else
	  (cons item
		(substitute subs rest))]))])))



;;;
;;; var?
;;; 
;;; Test if arg is a variable.  
;;; From Mike Gasser.
;;;
(define var?
  (lambda (obj)
    (and (symbol? obj)
	 (char=? (string-ref (symbol->string obj) 0) #\?))))



;;;
;;; unify
;;;
;;; INPUT
;;;   pat1, pat2: 2 patterns
;;;   subs, a substitution list to be used in unifying pat1 & pat2
;;;
;;; OUTPUT
;;;   updated subs list, '(), or #f (if no unify can occur)
;;;
;;; OPERATION
;;;   If pat1 == pat2, return subs
;;;   if either are vars, call unify-var
;;;   if pat1 or pat2 is atom, return #f (we know they're not ==)
;;;   if pat1 and pat2 both lists:
;;;     unify corresponding parts of lists
;;;       if get #f, return #f for all
;;;       else, replace subs with new subs and continue
;;;
(define unify
  (lambda (pat1 pat2 subs)
    (cond
     
     ;; pat1 and pat2 are the same
     [(equal? pat1 pat2) subs]

     ;; Either pat1, pat2 or both are vars
     [(var? pat1) (unify-var pat1 pat2 subs)]
     [(var? pat2) (unify-var pat2 pat1 subs)]
     
     ;; If either are atoms, return #f (we know they aren't == by now)
     [(or (atom? pat1)
	  (atom? pat2))
      #f]

     ;; Both are lists, so unify them, then do rest of lists
     [else
      (let* ([pat1-item (car pat1)]
	     [pat2-item (car pat2)]
	     [pat1-rest (cdr pat1)]
	     [pat2-rest (cdr pat2)]
	     [new-subs (unify pat1-item pat2-item subs)])
	(if new-subs
	    (unify pat1-rest pat2-rest new-subs)
	    #f))])))



;;;
;;; unify-var
;;;
;;; INPUT
;;;   var, a variable
;;;   pat, a pattern
;;;   subs, a substitution list
;;; 
;;; OUTPUT
;;;   new subs, or #f
;;;
;;; OPERATION
;;;   if subs has value for var, call unify with that and pat
;;;   if var == pat, return subs (i.e., they're the same variable)
;;;   [  if var in pat, return #f ("occurs-check") IGNORED FOR NOW]
;;;   else, add (var . pat) to subs, return this
;;;
(define unify-var
  (lambda (var pat subs)
    (let ([sub (assoc var subs)])
      (cond

       ;; subs already has value for var - check to see if it's congruent
       [sub
	(unify (cdr sub) pat subs)]

       ;; If var and pat are same var, just return subs
       [(eq? var pat) subs]

       ;; Add (var . pat) to subs
       [else
	(cons (cons var pat) subs)]))))



;;;
;;; match-antecedent
;;;
;;; INPUT:     state, a list of two things: a list of antecedents left to match
;;;                 and a list of substitutions
;;;            wm, the working memory
;;; OUTPUT:    list of all new states (of the above kind) that can arise from
;;;            matching (unifying) the first antecedent with items in the
;;;            working memory, wm.
;;; OPERATION: Use a helper function, match-mem (in a letrec), to look at each
;;;            item in wm.  It calls unify on each of these items with the
;;;            first antecedent on the antec. list.  If a non-#f substitution
;;;            is returned, then a new state is added onto a growing list of
;;;            new states.  This new state is composed of the cdr of the
;;;            antecedent list (since we used the first item to get the subst.)
;;;            and the new subst list.
;;;
(define match-antecedent
  (lambda (state wm)
    (let* ([antecs (state->antecs state)]
	   [subs (state->subs state)]
	   [1st-antec (car antecs)]
	   [antecs-left (cdr antecs)])
      (letrec ([match-mem
		(lambda (new-states wm-left)
		  (cond
		   [(null? wm-left) new-states]
		   [else
		    (let* ([new-subs (unify 1st-antec (car wm-left) subs)])

		      ;;Did unify succeed?  If so, new-subs will be some list
		      (if new-subs

			  ;;Unify succeeded! Now, we can
			  ;;  add the new subs made by unify to the end of a
			  ;;  list of the remaining antecedents, thus forming
			  ;;  a new state.  Add this state to list of new ones,
			  ;;  then recur to look at the next thing in wm.
			  (match-mem (cons (make-state antecs-left new-subs)
					   new-states)
				     (cdr wm-left))

			  ;;Unify failed, so don't add a new state, look at
			  ;;  the next thing in wm
			  (match-mem new-states (cdr wm-left))))]))])

	(match-mem '() wm)))))



;;;
;;; States - Helper routines
;;;
;;; States look like:
;;;   (antecs subs)
;;;
;;;   antecs is a list of antecedents from a rule,
;;;   subs is a list of substitutions
;;;
;;;
;;; make-state
;;; state->antecs
;;; state->subs
;;;
(define make-state
  (lambda (antecs subs)
    (list antecs subs)))
(define state->antecs
  (lambda (state)
    (car state)))
(define state->subs
  (lambda (state)
    (cadr state)))



;;;
;;; execute
;;;
;;; INPUT:     subs, a substitution list
;;;            conseq-list, a list of consequents from some rule
;;;            wm, the working memory
;;; OUTPUT:    List of new patterns which should later be added to wm
;;; OPERATION: Use a helper routine to go through each consequent in the list,
;;;            conseq-list, and call substitute on it to get an instantiation
;;;            of the consequent.  See if this instantiation is already in wm
;;;            by using member.  If so, then the inst already exists, so don't 
;;;            add it and go on to the next consequent.
;;;
(define execute
  (lambda (subs conseq-list wm)
    (letrec ([helper
	      ;; conseq-left is the list of conseq's for which we still
	      ;;   must substitute
	      ;; conseq-inst is the list of instantiations of the consequents
	      (lambda (conseq-left conseq-inst)
		(cond
		 [(null? conseq-left) conseq-inst]
		 [else
		  (let ([new-inst (substitute subs (car conseq-left))])
		    
		    ;;Look thru wm to see if out new instatiation already
		    ;;  exists in wm.
		    (if (member new-inst wm)
			
			;;If so, new-inst is a duplicate, so don't add it
			(helper (cdr conseq-left) conseq-inst)
			
			;;Else, add new-inst to conseq-inst
			(helper (cdr conseq-left)
				(cons new-inst conseq-inst))))]))])
      (helper conseq-list '()))))



;;;
;;; match-rule
;;;
;;; INPUT:     antec-list, a list of antecedents
;;;            conseq-list, a list of consequents
;;;            wm, the working memory
;;; OUTPUT:    List of new patterns to be added to wm as a result of matching
;;;            ("firing") this rule.
;;; OPERATION: The two lists, antec-list and conseq-list, are the lhs and rhs
;;;            of some rule.  Here, we use a depth-first-search to find all
;;;            ways to satisfy the rule using patterns in the wm.
;;;            To expand a state, a routine, match-antecedent, will be used.
;;;
(define match-rule
  (lambda (antec-list conseq-list wm)
    (letrec (
	     ;;
	     ;; goal? - If the antecedent list for this state is empty,
	     ;;    then return #t, otherwise return #f
	     ;;
	     [goal?
	      (lambda (state)
		(let ([antecs (state->antecs state)])
		  (if (null? antecs)
		      #t
		      #f)))]

	     ;;
	     ;; dfs - Exhaustive depth-first search
	     ;;
	     [dfs
	      (lambda (Q new-pat)
		(cond

		 ;; Done
		 [(null? Q) new-pat]

		 ;; The state has had all of its antecs matched, so add 
		 ;; the consequents (after subs is applied to them) to
		 ;; current list of patterns, new-pat.  Keep going - this
		 ;; is exhaustive search.
		 [(goal? (car Q))
		  (let* ([state (car Q)]
			 [subs (state->subs state)])
		    (dfs (cdr Q)
			 (append (execute subs conseq-list wm)
				 new-pat)))]

		 ;; No goal, so expand the state and keep going.
		 [else      (dfs (append (match-antecedent (car Q) wm)
					 (cdr Q))
				 new-pat)]))])

      (dfs (list (list antec-list '())) '()))))



;;;
;;; match-rules
;;;
;;; INPUT:     rule-list, a list of rules to be used in the production system
;;;            wm, the working memory
;;; OUTPUT:    list of all new patterns resulting from matching the rules
;;; OPERATION: Calls match-rule for each rule in the rule-list.  Uses a helper
;;;            function to do this recursively
;;;            Adds all of the new facts to a list, new-facts.  This list
;;;            will eventually be appended to wm (by run-ps).
;;;
(define match-rules
  (lambda (rule-list wm)
    (letrec ([check-each-rule
	      (lambda (rules-left new-facts)

		(if (null? rules-left)

		    ;; No more rules left
		    (begin
		      (if (null? new-facts)
			  (printf "< Added no facts >:~%")
			  (begin
			    (printf "In total, added the following facts:~%")
			    (pretty-print new-facts)))
		      new-facts)

		    ;; Still some rules left to match
		    (let* ([cur-rule (car rules-left)]
			   [rule-name (car cur-rule)]
			   [antec-list (cadr cur-rule)]
			   [conseq-list (caddr cur-rule)]
			   [rule-facts (match-rule antec-list conseq-list wm)])
		      (printf (format "Looking at rule ~s:" rule-name))
		      (if (null? rule-facts)
			  (printf (format "     <nothing added>~%"))
			  (begin
			    (printf "~%     Adding the following facts:~%")
			    (pretty-print rule-facts)))
		      (check-each-rule (cdr rules-left)
				       (append rule-facts new-facts)))))])
      (check-each-rule rule-list '()))))



;;;
;;; run-ps
;;;
;;; INPUT:     rule-list, a list of rules for the production system
;;;            wm, a working memory
;;; OUTPUT:    the updated wm, after all possible rule firings have occurred
;;; OPERATION: calls match-rules repeatedly, appending its results to wm until
;;;            no more changes to wm are made (i.e., when match-rules returns
;;;            an empty list).
;;;
(define run-ps
  (lambda (rule-list wm)
    (letrec ([expand-wm
	      (lambda (wm-new)
		(let ([new-facts (match-rules rule-list wm-new)])
		  (if (null? new-facts)

		      ;; nothing new was added this time, so we're done -
		      ;;   return wm-new
		      (begin
			(printf "~%~%*************************************~%")
			(printf "FINISHED - NO CHANGES TO WM THIS TIME~%")
			(printf "*************************************")
			(printf "~%~%Final Contents of Working Memory:~%~%")
			
			;; Return result
			wm-new)

		      ;; more things get added to wm this time, so keep
		      ;;   calling match-rules
		      ;;   (Print out the contents of wm before we add to it.)
		      (begin
			(printf "~%***********************************~%")
			(printf "Current Contents of Working Memory:~%")
			(pretty-print (append new-facts wm-new))
			(printf "***********************************~%")

			;; Accumulate new facts
			(expand-wm (append new-facts wm-new))))))])
      (printf "~%***********************************~%")
      (printf "Intial Contents of Working Memory:~%")
      (pretty-print wm)
      (printf "***********************************~%")

      ;; Start the process
      (expand-wm wm))))
					      



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                               ;;;
;;; RULES FOR THE FORWARD CHAINER ;;;
;;;                               ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define r1 '(r1 [(symptom ?p (fever high))
		 (symptom ?p congestion)]
		[(condition ?p flu)]))

(define r2 '(r2 [(doctor ?d)
		 (says ?d (condition ?p ?yuk))]
		[(condition ?p ?yuk)]))

(define r3 '(r3 [(says ?loser (condition ?p ?yuk))
		 (not (condition ?p ?yuk))]
		[(not (doctor ?loser))]))

(define r4 '(r4 [(symptom ?p rash)
		 (not (symptom ?p (fever high)))]
		[(condition ?p poison-ivy)]))

(define r5 '(r5 [(symptom ?p cough)
		 (symptom ?p (fever very-high))]
		[(condition ?p whooping-cough)]))

(define r6 '(r6 [(condition ?p whooping-cough)]
		[(symptom ?p cough)]))

(define r7 '(r7 [(condition ?p poison-ivy)]
		[(symptom ?p rash)]))

(define r8 '(r8 [(symptom ?p (fever very-high))]
		[(symptom ?p (fever high))]))

(define r9 '(r9 [(not (symptom ?p (fever high)))
		 (not (symptom ?p cough))
		 (not (symptom ?p rash))]
		[(condition ?p healthy)]))

(define r10 '(r10 [(condition ?p ?yuk)
		   (contagious ?yuk)
		   (contacts ?p ?poor-slob)]
		  [(condition ?poor-slob ?yuk)]))

(define rule-list (list r1
			r2
			r3
			r4
			r5
			r6
			r7
			r8
			r9
			r10))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                        ;;;
;;; WORKING MEMORY FOR THE FORWARD CHAINER ;;;
;;;                                        ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define wm '(
	     [symptom ed (fever very-high)]
	     [symptom ed cough]
	     [not (condition alice poison-ivy)]
	     [says max (condition alice poison-ivy)]
	     [says grace (condition don healthy)]
	     [doctor grace]
	     [contagious whooping-cough]
	     [contacts ed alice]
	    ))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                              ;;;
;;; VARIOUS OBJECTS USED IN TESTING EACH ROUTINE ;;;
;;;                                              ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(define wm-test1 '(
		   [condition galadriel elven]
		   [symptom gollum (fever high)]
		   [symptom frodo (fever high)]
		   [symptom sauron cough]
		   [doctor parking]
		   ))

;;;
;;; state-test
;;; helps test match-antecedent
;;;
(define state-test
  '( ([symptom ?p ?yuk]
      [symptom ?p (fever high)]
      [doctor ?d])
     ([x . unknown])))

(define test-match-antec
  (lambda ()
    (display "RUNNING match-antecedent:")
    (newline)
    (display "STATE=")
    (newline)
    (pretty-print state-test)
    (display "WORKING-MEMORY=")
    (newline)
    (pretty-print wm-test1)
    (display "RESULT=")
    (newline)
    (match-antecedent state-test wm-test1)))



;;;
;;; subs-test
;;; starting substitution list for testers
;;;
(define subs-test '((?p . gollum)
		    (?yuk . poison-ivy)
		    (?q . frodo)
		    (?yuk2 . (fever high))))

;;;
;;; rhs-test
;;; right-hand-side of a "rule" with two consequents: tests execute
;;;
(define rhs-test (list '(condition ?p flu)
		       '(condition ?p whooping-cough)
		       '(condition ?p healthy)
		       '(symptom ?p ?yuk2)
		       '(symptom ?q ?yuk)))

(define wm-test '(
		  [condition frodo healthy]
		  [condition gollum flu]
		  [symptom gollum cough]
		  [symptom gollum rash]
		  [symptom gollum (fever high)]
		  [symptom gollum congestion]
		  [not (doctor gollum)]
		  )
);ENDDEFINE

(define test-execute
  (lambda ()
    (display "RUNNING execute:")
    (newline)
    (display "SUBS=")
    (newline)
    (pretty-print subs-test)
    (display "RHS OF RULE=")
    (newline)
    (pretty-print rhs-test)
    (display "WORKING-MEMORY=")
    (newline)
    (pretty-print wm-test)
    (display "RESULT=")
    (newline)
    (execute subs-test rhs-test wm-test)
  )
)



(define wm-test2 '(
		   [symptom merlin (fever high)]
		   [symptom merlin congestion]
		   [symptom merlin cough]
		  )
);ENDDEFINE

(define test-match-rule
  (lambda ()
    (display "RUNNING match-rule:")
    (newline)
    (display "LHS OF RULE=")
    (newline)
    (pretty-print (cadr r1))
    (display "RHS OF RULE=")
    (newline)
    (pretty-print (caddr r1))
    (display "WORKING-MEMORY=")
    (newline)
    (pretty-print wm-test2)
    (display "RESULT=")
    (newline)
    (match-rule (cadr r1) (caddr r1) wm-test2)
  )
)

(define wm-test9 '(
		   [not (symptom merlin (fever high))]
		   [not (symptom merlin cough)]
		   [not (symptom merlin rash)]
		  )
);ENDDEFINE

(define test-match-rule9
  (lambda ()
    (display "RUNNING match-rule:")
    (newline)
    (display "LHS OF RULE=")
    (newline)
    (pretty-print (cadr r9))
    (display "RHS OF RULE=")
    (newline)
    (pretty-print (caddr r9))
    (display "WORKING-MEMORY=")
    (newline)
    (pretty-print wm-test9)
    (display "RESULT=")
    (newline)
    (match-rule (cadr r9) (caddr r9) wm-test9)
  )
)



(define rules-test (list r1
			 r5
			 r6
			 r8)
)

(define wm-match-test '(
		        [symptom gollum (fever very-high)]
			[symptom gollum congestion]
			[symptom gollum cough]
		       )
)

(define match-rules-test
  (lambda ()
    (display "RUNNING match-rules:")
    (newline)
    (display "LIST OF RULES=")
    (newline)
    (pretty-print rules-test)
    (display "WORKING-MEMORY=")
    (newline)
    (pretty-print wm-match-test)
    (display "RESULT=")
    (newline)
    (match-rules rules-test wm-match-test)
  )
)


(define run-ps-test
  (lambda ()
    (display "RUNNING run-ps ON THE REAL DATA:")
    (newline)
    (display "LIST OF RULES=")
    (newline)
    (pretty-print rule-list)
    (display "WORKING-MEMORY=")
    (newline)
    (pretty-print wm)
    (display "RESULT=")
    (newline)
    (run-ps rule-list wm)
  )
)