识别云种类的专家系统

cloud.clp

;;;======================================================
;;;   Cloud Identification Expert System
;;;
;;;     A simple expert system which attempts to identify
;;;     an cloud based on its characteristics.
;;;     The knowledge base in this example is a 
;;;     collection of facts which represent backward
;;;     chaining rules. CLIPS forward chaining rules are
;;;     then used to simulate a backward chaining inference
;;;     engine.
;;; 
;;;     To execute, merely load, reset, and run.
;;;     Answer questions yes or no.
;;;======================================================

;;;***************************
;;;* DEFTEMPLATE DEFINITIONS *
;;;***************************

(deftemplate rule 
   (multislot if)
   (multislot then))

;;;**************************
;;;* INFERENCE ENGINE RULES *
;;;**************************

(defrule propagate-goal ""
   (goal is ?goal)
   (rule (if ?variable $?)
         (then ?goal ? ?value))
   =>
   (assert (goal is ?variable)))

(defrule goal-satified ""
   (declare (salience 30))
   ?f <- (goal is ?goal)
   (variable ?goal ?value)
   (answer ? ?text ?goal)
   =>
   (retract ?f)
   (format t "%s%s%n" ?text ?value))

(defrule remove-rule-no-match ""
   (declare (salience 20))
   (variable ?variable ?value)
   ?f <- (rule (if ?variable ? ~?value $?))
   =>
   (retract ?f))

(defrule modify-rule-match ""
   (declare (salience 20))
   (variable ?variable ?value)
   ?f <- (rule (if ?variable ? ?value and $?rest))
   =>
   (modify ?f (if ?rest)))

(defrule rule-satisfied ""
   (declare (salience 20))
   (variable ?variable ?value)
   ?f <- (rule (if ?variable ? ?value)
               (then ?goal ? ?goal-value))
   =>
   (retract ?f)
   (assert (variable ?goal ?goal-value)))

(defrule ask-question-no-legalvalues ""
   (declare (salience 10))
   (not (legalanswers $?))
   ?f1 <- (goal is ?variable)
   ?f2 <- (question ?variable ? ?text)
   =>
   (retract ?f1 ?f2)
   (format t "%s " ?text)
   (assert (variable ?variable (read))))


;;;***************************
;;;* DEFFACTS KNOWLEDGE BASE *
;;;***************************

(deffacts knowledge-base 
   (goal is type.cloud)

   (rule (if altitude.cloud is vertical)
         (then altitude is vertical))
   (rule (if altitude.cloud is high)
         (then altitude is high))
   (rule (if altitude.cloud is medium)
         (then altitude is medium))
   (rule (if altitude.cloud is low)
         (then altitude is low))
   (question altitude.cloud is "Firstly, what is the altitude of this cloud (low, medium, high or vertical)?")
   (rule (if color.gray is yes) 
         (then color is gray))
   (rule (if color.gray is no) 
         (then color is white))
   (question color.gray is "Is the color dark gray (yes or no)?")

   (rule (if altitude is vertical and
          color is gray) 
         (then type.cloud is Cb))
   (rule (if altitude is vertical and
          color is white) 
         (then type.cloud is Cu))

   (rule (if class.cloud is hair)
         (then class is hair))
   (rule (if class.cloud is taper)
         (then class is taper))
   (rule (if class.cloud is paper)
         (then class is paper))
   (question class.cloud is "What's the cloud like, hair, taper or paper?")

   (rule (if altitude is high and
          class is hair) 
         (then type.cloud is Ci))
   (rule (if altitude is high and
          class is paper) 
         (then type.cloud is Cc))
   (rule (if altitude is high and
          class is taper) 
         (then type.cloud is Cs))
   (rule (if altitude is medium and
          color is gray) 
         (then type.cloud is Ni))
   (rule (if altitude is medium and
          color is white and
          class is taper ) 
         (then type.cloud is Cu))
   (rule (if altitude is medium and
          color is white and
          class is paper ) 
         (then type.cloud is Ac))
   (rule (if altitude is low and
          class is paper) 
         (then type.cloud is Sc))
   (rule (if altitude is low and
          class is taper) 
         (then type.cloud is St))
   (answer is "I think this cloud is a " type.cloud))