home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / clips_2 / CLIPS / Examples / Wine < prev    next >
Encoding:
Text File  |  1993-06-02  |  13.0 KB  |  393 lines
  1.  
  2. ;;;======================================================
  3. ;;;   Wine Expert Sample Problem
  4. ;;;
  5. ;;;     WINEX: The WINe EXpert system.
  6. ;;;     This example selects an appropriate wine
  7. ;;;     to drink with a meal.
  8. ;;;
  9. ;;;     CLIPS Version 6.0 Example
  10. ;;;
  11. ;;;     To execute, merely load, reset and run.
  12. ;;;======================================================
  13.  
  14. (defmodule MAIN (export ?ALL))
  15.  
  16. ;;****************
  17. ;;* DEFFUNCTIONS *
  18. ;;****************
  19.  
  20. (deffunction MAIN::ask-question (?question ?allowed-values)
  21.    (printout t ?question)
  22.    (bind ?answer (read))
  23.    (if (lexemep ?answer) then (bind ?answer (lowcase ?answer)))
  24.    (while (not (member ?answer ?allowed-values)) do
  25.       (printout t ?question)
  26.       (bind ?answer (read))
  27.       (if (lexemep ?answer) then (bind ?answer (lowcase ?answer))))
  28.    ?answer)
  29.  
  30. ;;*****************
  31. ;;* INITIAL STATE *
  32. ;;*****************
  33.  
  34. (deftemplate MAIN::attribute
  35.    (slot name)
  36.    (slot value)
  37.    (slot certainty (default 100.0)))
  38.  
  39. (defrule MAIN::start
  40.   (declare (salience 10000))
  41.   =>
  42.   (set-fact-duplication TRUE)
  43.   (focus QUESTIONS CHOOSE-QUALITIES WINES PRINT-RESULTS))
  44.  
  45. (defrule MAIN::combine-certainties ""
  46.   (declare (salience 100)
  47.            (auto-focus TRUE))
  48.   ?rem1 <- (attribute (name ?rel) (value ?val) (certainty ?per1))
  49.   ?rem2 <- (attribute (name ?rel) (value ?val) (certainty ?per2))
  50.   (test (neq ?rem1 ?rem2))
  51.   =>
  52.   (retract ?rem1)
  53.   (modify ?rem2 (certainty (/ (- (* 100 (+ ?per1 ?per2)) (* ?per1 ?per2)) 100))))
  54.   
  55. ;;******************
  56. ;;* QUESTION RULES *
  57. ;;******************
  58.  
  59. (defmodule QUESTIONS (import MAIN ?ALL) (export ?ALL))
  60.  
  61. (deftemplate QUESTIONS::question
  62.    (slot attribute (default ?NONE))
  63.    (slot the-question (default ?NONE))
  64.    (multislot valid-answers (default ?NONE))
  65.    (slot already-asked (default FALSE))
  66.    (multislot precursors (default ?DERIVE)))
  67.    
  68. (defrule QUESTIONS::ask-a-question
  69.    ?f <- (question (already-asked FALSE)
  70.                    (precursors)
  71.                    (the-question ?the-question)
  72.                    (attribute ?the-attribute)
  73.                    (valid-answers $?valid-answers))
  74.    =>
  75.    (modify ?f (already-asked TRUE))
  76.    (assert (attribute (name ?the-attribute)
  77.                       (value (ask-question ?the-question ?valid-answers)))))
  78.  
  79. (defrule QUESTIONS::precursor-is-satisfied
  80.    ?f <- (question (already-asked FALSE)
  81.                    (precursors ?name is ?value $?rest))
  82.          (attribute (name ?name) (value ?value))
  83.    =>
  84.    (if (eq (nth 1 ?rest) and) 
  85.     then (modify ?f (precursors (rest$ ?rest)))
  86.     else (modify ?f (precursors ?rest))))
  87.  
  88. (defrule QUESTIONS::precursor-is-not-satisfied
  89.    ?f <- (question (already-asked FALSE)
  90.                    (precursors ?name is-not ?value $?rest))
  91.          (attribute (name ?name) (value ~?value))
  92.    =>
  93.    (if (eq (nth 1 ?rest) and) 
  94.     then (modify ?f (precursors (rest$ ?rest)))
  95.     else (modify ?f (precursors ?rest))))
  96.  
  97. ;;*******************
  98. ;;* WINEX QUESTIONS *
  99. ;;*******************
  100.  
  101. (defmodule WINE-QUESTIONS (import QUESTIONS ?ALL))
  102.  
  103. (deffacts WINE-QUESTIONS::question-attributes
  104.   (question (attribute main-component)
  105.             (the-question "Is the main component of the meal meat, fish, or poultry? ")
  106.             (valid-answers meat fish poultry unknown))
  107.   (question (attribute has-turkey)
  108.             (precursors main-component is turkey)
  109.             (the-question "Does the meal have turkey in it? ")
  110.             (valid-answers yes no unknown))
  111.   (question (attribute has-sauce)
  112.             (the-question "Does the meal have a sauce on it? ")
  113.             (valid-answers yes no unknown))
  114.   (question (attribute sauce)
  115.             (precursors has-sauce is yes)
  116.             (the-question "Is the sauce for the meal spicy, sweet, cream, or tomato? ")
  117.             (valid-answers sauce spicy sweet cream tomato unknown))
  118.   (question (attribute tastiness)
  119.             (the-question "Is the flavor of the meal delicate, average, or strong? ")
  120.             (valid-answers delicate average strong unknown))
  121.   (question (attribute preferred-body)
  122.             (the-question "Do you generally prefer light, medium, or full bodied wines? ")
  123.             (valid-answers light medium full unknown))
  124.   (question (attribute preferred-color)
  125.             (the-question "Do you generally prefer red or white wines? ")
  126.             (valid-answers red white unknown))
  127.   (question (attribute preferred-sweetness)
  128.             (the-question "Do you generally prefer dry, medium, or sweet wines? ")
  129.             (valid-answers dry medium sweet unknown))) 
  130.  
  131. ;;******************
  132. ;; The RULES module
  133. ;;******************
  134.  
  135. (defmodule RULES (import MAIN ?ALL) (export ?ALL))
  136.  
  137. (deftemplate RULES::rule
  138.   (slot certainty (default 100.0))
  139.   (multislot if)
  140.   (multislot then))
  141.  
  142. (defrule RULES::throw-away-ands-in-antecedent
  143.   ?f <- (rule (if and $?rest))
  144.   =>
  145.   (modify ?f (if ?rest)))
  146.  
  147. (defrule RULES::throw-away-ands-in-consequent
  148.   ?f <- (rule (then and $?rest))
  149.   =>
  150.   (modify ?f (then ?rest)))
  151.  
  152. (defrule RULES::remove-is-condition-when-satisfied
  153.   ?f <- (rule (certainty ?c1) 
  154.               (if ?attribute is ?value $?rest))
  155.   (attribute (name ?attribute) 
  156.              (value ?value) 
  157.              (certainty ?c2))
  158.   =>
  159.   (modify ?f (certainty (min ?c1 ?c2)) (if ?rest)))
  160.  
  161. (defrule RULES::remove-is-not-condition-when-satisfied
  162.   ?f <- (rule (certainty ?c1) 
  163.               (if ?attribute is-not ?value $?rest))
  164.   (attribute (name ?attribute) (value ~?value) (certainty ?c2))
  165.   =>
  166.   (modify ?f (certainty (min ?c1 ?c2)) (if ?rest)))
  167.  
  168. (defrule RULES::perform-rule-consequent-with-certainty
  169.   ?f <- (rule (certainty ?c1) 
  170.               (if) 
  171.               (then ?attribute is ?value with certainty ?c2 $?rest))
  172.   =>
  173.   (modify ?f (then ?rest))
  174.   (assert (attribute (name ?attribute) 
  175.                      (value ?value)
  176.                      (certainty (/ (* ?c1 ?c2) 100)))))
  177.  
  178. (defrule RULES::perform-rule-consequent-without-certainty
  179.   ?f <- (rule (certainty ?c1)
  180.               (if)
  181.               (then ?attribute is ?value $?rest))
  182.   (test (or (eq (length$ ?rest) 0)
  183.             (neq (nth 1 ?rest) with)))
  184.   =>
  185.   (modify ?f (then ?rest))
  186.   (assert (attribute (name ?attribute) (value ?value) (certainty ?c1))))
  187.  
  188. ;;*******************************
  189. ;;* CHOOSE WINE QUALITIES RULES *
  190. ;;*******************************
  191.  
  192. (defmodule CHOOSE-QUALITIES (import RULES ?ALL)
  193.                             (import QUESTIONS ?ALL)
  194.                             (import MAIN ?ALL))
  195.  
  196. (defrule CHOOSE-QUALITIES::startit => (focus RULES))
  197.  
  198. (deffacts the-wine-rules
  199.  
  200.   ; Rules for picking the best body
  201.  
  202.   (rule (if has-sauce is yes and 
  203.             sauce is spicy)
  204.         (then best-body is full))
  205.  
  206.   (rule (if tastiness is delicate)
  207.         (then best-body is light))
  208.  
  209.   (rule (if tastiness is average)
  210.         (then best-body is light with certainty 30 and
  211.               best-body is medium with certainty 60 and
  212.               best-body is full with certainty 30))
  213.  
  214.   (rule (if tastiness is strong)
  215.         (then best-body is medium with certainty 40 and
  216.               best-body is full with certainty 80))
  217.  
  218.   (rule (if has-sauce is yes and
  219.             sauce is cream)
  220.         (then best-body is medium with certainty 40 and
  221.               best-body is full with certainty 60))
  222.  
  223.   (rule (if preferred-body is full)
  224.         (then best-body is full with certainty 40))
  225.  
  226.   (rule (if preferred-body is medium)
  227.         (then best-body is medium with certainty 40))
  228.  
  229.   (rule (if preferred-body is light) 
  230.         (then best-body is light with certainty 40))
  231.  
  232.   (rule (if preferred-body is light and
  233.             best-body is full)
  234.         (then best-body is medium))
  235.  
  236.   (rule (if preferred-body is full and
  237.             best-body is light)
  238.         (then best-body is medium))
  239.  
  240.   (rule (if preferred-body is unknown) 
  241.         (then best-body is light with certainty 20 and
  242.               best-body is medium with certainty 20 and
  243.               best-body is full with certainty 20))
  244.  
  245.   ; Rules for picking the best color
  246.  
  247.   (rule (if main-component is meat)
  248.         (then best-color is red with certainty 90))
  249.  
  250.   (rule (if main-component is poultry and
  251.             has-turkey is no)
  252.         (then best-color is white with certainty 90 and
  253.               best-color is red with certainty 30))
  254.  
  255.   (rule (if main-component is poultry and
  256.             has-turkey is yes)
  257.         (then best-color is red with certainty 80 and
  258.               best-color is white with certainty 50))
  259.  
  260.   (rule (if main-component is fish)
  261.         (then best-color is white))
  262.  
  263.   (rule (if main-component is-not fish and
  264.             has-sauce is yes and
  265.             sauce is tomato)
  266.         (then best-color is red))
  267.  
  268.   (rule (if has-sauce is yes and
  269.             sauce is cream)
  270.         (then best-color is white with certainty 40))
  271.                    
  272.   (rule (if preferred-color is red)
  273.         (then best-color is red with certainty 40))
  274.  
  275.   (rule (if preferred-color is white)
  276.         (then best-color is white with certainty 40))
  277.  
  278.   (rule (if preferred-color is unknown)
  279.         (then best-color is red with certainty 20 and
  280.               best-color is white with certainty 20))
  281.   
  282.   ; Rules for picking the best sweetness
  283.  
  284.   (rule (if has-sauce is yes and
  285.             sauce is sweet)
  286.         (then best-sweetness is sweet with certainty 90 and
  287.               best-sweetness is medium with certainty 40))
  288.  
  289.   (rule (if preferred-sweetness is dry)
  290.         (then best-sweetness is dry with certainty 40))
  291.  
  292.   (rule (if preferred-sweetness is medium)
  293.         (then best-sweetness is medium with certainty 40))
  294.  
  295.   (rule (if preferred-sweetness is sweet)
  296.         (then best-sweetness is sweet with certainty 40))
  297.  
  298.   (rule (if best-sweetness is sweet and
  299.             preferred-sweetness is dry)
  300.         (then best-sweetness is medium))
  301.  
  302.   (rule (if best-sweetness is dry and
  303.             preferred-sweetness is sweet) 
  304.         (then best-sweetness is medium))
  305.  
  306.   (rule (if preferred-sweetness is unknown)
  307.         (then best-sweetness is dry with certainty 20 and
  308.               best-sweetness is medium with certainty 20 and
  309.               best-sweetness is sweet with certainty 20))
  310.  
  311. )
  312.  
  313. ;;************************
  314. ;;* WINE SELECTION RULES *
  315. ;;************************
  316.  
  317. (defmodule WINES (import MAIN ?ALL))
  318.  
  319. (deffacts any-attributes
  320.   (attribute (name best-color) (value any))
  321.   (attribute (name best-body) (value any))
  322.   (attribute (name best-sweetness) (value any)))
  323.  
  324. (deftemplate WINES::wine
  325.   (slot name (default ?NONE))
  326.   (multislot color (default any))
  327.   (multislot body (default any))
  328.   (multislot sweetness (default any)))
  329.  
  330. (deffacts WINES::the-wine-list 
  331.   (wine (name Gamay) (color red) (body medium) (sweetness medium sweet))
  332.   (wine (name Chablis) (color white) (body light) (sweetness dry))
  333.   (wine (name Sauvignon-Blanc) (color white) (body medium) (sweetness dry))
  334.   (wine (name Chardonnay) (color white) (body medium full) (sweetness medium dry))
  335.   (wine (name Soave) (color white) (body light) (sweetness medium dry))
  336.   (wine (name Riesling) (color white) (body light medium) (sweetness medium sweet))
  337.   (wine (name Geverztraminer) (color white) (body full))
  338.   (wine (name Chenin-Blanc) (color white) (body light) (sweetness medium sweet))
  339.   (wine (name Valpolicella) (color red) (body light))
  340.   (wine (name Cabernet-Sauvignon) (color red) (sweetness dry medium))
  341.   (wine (name Zinfandel) (color red) (sweetness dry medium))
  342.   (wine (name Pinot-Noir) (color red) (body medium) (sweetness medium))
  343.   (wine (name Burgundy) (color red) (body full))
  344.   (wine (name Zinfandel) (color red) (sweetness dry medium)))
  345.   
  346. (defrule WINES::generate-wines
  347.   (wine (name ?name)
  348.         (color $? ?c $?)
  349.         (body $? ?b $?)
  350.         (sweetness $? ?s $?))
  351.   (attribute (name best-color) (value ?c) (certainty ?certainty-1))
  352.   (attribute (name best-body) (value ?b) (certainty ?certainty-2))
  353.   (attribute (name best-sweetness) (value ?s) (certainty ?certainty-3))
  354.   =>
  355.   (assert (attribute (name wine) (value ?name)
  356.                      (certainty (min ?certainty-1 ?certainty-2 ?certainty-3)))))
  357.  
  358. ;;*****************************
  359. ;;* PRINT SELECTED WINE RULES *
  360. ;;*****************************
  361.  
  362. (defmodule PRINT-RESULTS (import MAIN ?ALL))
  363.  
  364. (defrule PRINT-RESULTS::header ""
  365.    (declare (salience 10))
  366.    =>
  367.    (printout t t)
  368.    (printout t "        SELECTED WINES" t t)
  369.    (printout t " WINE                  CERTAINTY" t)
  370.    (printout t " -------------------------------" t)
  371.    (assert (phase print-wines)))
  372.  
  373. (defrule PRINT-RESULTS::print-wine ""
  374.   ?rem <- (attribute (name wine) (value ?name) (certainty ?per))          
  375.   (not (attribute (name wine) (certainty ?per1&:(> ?per1 ?per))))
  376.   =>
  377.   (retract ?rem)
  378.   (format t " %-24s %2d%%%n" ?name ?per))
  379.  
  380. (defrule PRINT-RESULTS::remove-poor-wine-choices ""
  381.   ?rem <- (attribute (name wine) (certainty ?per&:(< ?per 20)))
  382.   =>
  383.   (retract ?rem))
  384.  
  385. (defrule PRINT-RESULTS::end-spaces ""
  386.    (not (attribute (name wine)))
  387.    =>
  388.    (printout t t))
  389.  
  390.  
  391.  
  392.  
  393.