;;; CIT Advisory Assistant Program (basic version)

;;; This non-monotonic TMS example program is written by 
;;; Neli P. Zlatareva, 2002. 

;;; Representation of rules and assertions is the following:

;;; Rule format:  (<rule-name> (<rule-conclusion>)
;;;                 (<monotonic-just>) (<non-monot-just>))

;;; Assertion format: (<statement> <justification>), where
;;; <justification> can be: (1) the rule name, whose conclusion
;;; is the statement, (2) premise, and (3) assumption.

;;; Assertions and rules are stored in streams *assertions* and 
;;; *rules*, respectively. The following functions define some 
;;; basic operations on streams. 

(defun stream-endp (stream) (eq stream 'empty-stream))

(defun stream-first (stream) (first stream))

(defun stream-rest (stream) (second stream))

(defun stream-cons (object stream) (list object stream))

(defun stream-append (stream1 stream2) 
	(if (stream-endp stream1)
             stream2
	    (stream-cons (stream-first stream1)
                         (stream-append (stream-rest stream1)
                                         stream2))))
 
(defun stream-member (object stream)
	(cond ((stream-endp stream) nil)
	      ((equal object (stream-first stream)) t)
	      (t (stream-member object (stream-rest stream)))))

;;; STREAM-REMEMBER is a macro that inserts new stream objects
;;; at the end a stream.

(defmacro stream-remember (object variable)
	`(unless (stream-member ,object ,variable)
		(setf ,variable
                      (stream-append ,variable
                           (stream-cons ,object 'empty-stream)))
          ,object))

;;; REMEMBER-RULE adds a new rule at the end of stream *rules*.

(defun remember-rule (rule)
	(stream-remember rule *rules*))

;;; The following functions access various parts of individual rules.

(defun rule-name (rule) 
     (first rule))

(defun rule-conclusion (rule) 
     (second rule))

(defun rule-monotonic (rule) 
     (third rule))

(defun rule-nonmonotonic (rule) 
     (fourth rule))

;;; REMEMBER-ASSERTION stores new assertions at the end of
;;; stream *assertions*. Its initial value is stored in
;;; the driver function, RUN-SCHEDULE.

(defun remember-assertion (assertion)
	(stream-remember assertion *assertions*))

;;; MATCH-ing functions check rule applicability.
;;; MATCH-PREMISE matches a rule premise against a list of
;;; assertions.

(defun match-premise (premise list)
    (cond ((eql list 'empty-stream) 'fail)
          ((eql (first (stream-first list)) premise) t)
          (t (match-premise premise (stream-rest list)))))

;;; MATCH-RULE-PREMISES-MON returns t if all monotinic premises 
;;; match.

(defun match-rule-premises-mon (list db)
    (cond ((endp list) t)
          ((eql 'fail (match-premise (first list) db)) 'fail)
          (t (match-rule-premises-mon (rest list) db))))

;;; MATCH-RULE-PREMISES-NONMON returns t if none of rule's 
;;; non-monotonic premises match
           
(defun match-rule-premises-nonmon (list db)
    (cond ((endp list) t)
          ((eql t (match-premise (first list) db)) 'fail)
          (t (match-rule-premises-nonmon (rest list) db))))

;;; TRY-RULE checks rule applicability. A rule is applicable if
;;; all of its nomotonic premises hold and none of its non-monotonic
;;; premises hold.

(defun try-rule (rule)
    (let ((rule-mon (rule-monotonic rule))
          (rule-nonmon (rule-nonmonotonic rule)))
       (if (and (not (eql 'fail (match-rule-premises-mon 
                                        rule-mon *assertions*)))
                (not (eql 'fail (match-rule-premises-nonmon 
                                        rule-nonmon *assertions*))))
           (rule-name rule))))

;;; APPLY-RULE calls TRY-RULE first and if the rule is applicable 
;;; applies it and updates *assertions* and *history*.
    
(defun apply-rule (rule)
   (setf *assertions* (stream-cons (rule-conclusion rule) *assertions*))
   (setf *history* (cons (rule-name rule) *history*)))

;;; RUN-RULE avoids multiple invocations of the same rule

(defun run-rule (rule)
   (if (and (not (member (rule-name rule) *history*))
            (not (null (try-rule rule))))
       (apply-rule rule)))

;;; RUN-RULES starts the rule engine.

(defun run-rules ()
   (do ((rule-stream *rules* (stream-rest rule-stream))
        (repeat-switch nil))
       ((stream-endp rule-stream) 
            (if repeat-switch
                (progn
                   (print *history*)
                   (format t "~%I am trying the rules again.")
                   (run-rules))
                (progn
                (format t "~%All done.")
                (format t "~%Final course sequence: ~a" 
                                    (print-sequence *history*)))))
      (when (run-rule (stream-first rule-stream))
            (setf repeat-switch t)
            (print repeat-switch))))

;;; PRINT-SEQUENCE and GET-COURSE-NAME facilitate the program
;;; output. PRINT-SEQUENCE returns a topological ordering of
;;; the courses.

(defun print-sequence (*history*)
    (if (endp *history*) 
        nil
        (cons (get-course-name (first *history*) *rules*)
                  (print-sequence (rest *history*))))) 

(defun get-course-name (rule-name *rules*)
    (cond ((eql 'empty-stream *rules*) nil)
          ((eql (first (stream-first *rules*)) rule-name) 
               (first (second (stream-first *rules*))))
          (t (get-course-name rule-name (stream-rest *rules*)))))

;;; START is a driver function, which (1) cleans up old values of
;;; *assertions* (the data base) and *history* (stores rules that have 
;;; fired in a given run; its initial value is (no-more), and (2) sets 
;;; initial data -- in this test case, is is assumed that the student
;;; has taken cs151, cs152 and math122 (they comprise the initial
;;; *assertions* stream). To try other test cases, modify the initial
;;; *assertions* stream accordingly.

(defun start ()
   (setf *history* '(no-more))
   (setf *assertions* 'empty-stream)
   (remember-assertion '(math122))
   (remember-assertion '(cs151))
   (remember-assertion '(cs152))
   (print *assertions*)
   (run-rules))
   
;;; The rule base follows. Note that problem solutions are 
;;; irrelevant of any rule order. 

(setf *rules* 'empty-stream)

(remember-rule '(rule1 (math122) () (math122)))

(remember-rule '(rule4 (cs501) (cs151 cs152) ()))

(remember-rule '(rule8 (cs501) (cs500) ()))

(remember-rule '(rule9 (cs502) (cs500) ()))

(remember-rule '(rule2 (math218) (math122 cs501) (math218)))

(remember-rule '(rule3 (cs500) (cs151) (cs152)))

(remember-rule '(rule5 (cs500) (math122 programming-experience) (cs151)))

(remember-rule '(rule6 (cs500) (programming-experience) (math122 cs151)))

(remember-rule '(rule7 (cs151) () (cs151 cs500)))

(remember-rule '(rule10 (tc500) () (tc500)))

(remember-rule '(rule11 (tc501) (tc500) (tc501)))

(remember-rule '(rule12 (mis501) () (mis501)))

(remember-rule '(rule13 (mis502) (mis501) (mis502)))

(remember-rule '(rule14 (cs-spec1) (cs501 cs502 math218) ()))

(remember-rule '(rule15 (cs-spec2) (cs501 cs502 math218 cs-spec1) ()))

(remember-rule '(rule16 (cs-spec3) (cs501 cs502 math218 cs-spec1 cs-spec2) ()))

(remember-rule '(rule17 (cs-spec4) (cs501 cs502 math218 cs-spec1 cs-spec2 cs-spec3) ()))

(remember-rule '(rule18 (core-fulfield) (cs501 cs502 tc500 tc501 mis501 mis502
                                         math218) ()))

(remember-rule '(rule19 (capstone) (core-fulfield cs-spec1 cs-spec2) ()))

(remember-rule '(rule20 (cs502) (cs151 cs152) ()))