home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / clips / wine.clp < prev   
Encoding:
Text File  |  1988-05-03  |  14.5 KB  |  546 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. ;;;     To execute, merely load, reset and run.
  10. ;;;======================================================
  11.  
  12. (deffacts valid-combinations ""
  13.   (combine best-body)
  14.   (combine best-color)
  15.   (combine best-sweetness)
  16.   (combine recommended-body)
  17.   (combine recommended-color)
  18.   (combine recommended-sweetness)
  19.   (combine wine))
  20.  
  21. (deffacts question-info ""
  22.   (values-for main-component meat fish poultry unknown)
  23.   (values-for has-turkey yes no unknown)
  24.   (values-for has-veal yes no unknown)
  25.   (values-for has-sauce yes no unknown)
  26.   (values-for sauce spicy sweet cream tomato unknown)
  27.   (values-for tastiness delicate average strong unknown)
  28.   (values-for preferred-body light medium full unknown)
  29.   (values-for preferred-sweetness dry medium sweet unknown)
  30.   (values-for preferred-color red white unknown)
  31.   (values-for preferred-body light medium full unknown))
  32.   
  33. ;;*******************************
  34. ;;* CHOOSE WINE QUALITIES RULES *
  35. ;;*******************************
  36.  
  37. (defrule choose-body-for-spicy-sauce ""
  38.   (choose-qualities)
  39.   (has-sauce yes)
  40.   (sauce spicy)
  41.   =>
  42.   (assert (best-body full 100 =(gensym))))
  43.  
  44. (defrule choose-body-for-delicate-taste "" 
  45.   (choose-qualities)
  46.   (tastiness delicate)
  47.   =>
  48.   (assert (best-body light 100 =(gensym))))
  49.  
  50. (defrule choose-body-for-average-taste ""
  51.   (choose-qualities)
  52.   (tastiness average)
  53.   =>
  54.   (assert (best-body light 30 =(gensym)))
  55.   (assert (best-body medium 60 =(gensym)))
  56.   (assert (best-body full 30 =(gensym))))
  57.  
  58. (defrule choose-body-for-strong-taste ""
  59.   (choose-qualities)
  60.   (tastiness strong)
  61.   =>
  62.   (assert (best-body medium 40 =(gensym)))
  63.   (assert (best-body full 80 =(gensym))))
  64.  
  65. (defrule choose-body-for-cream-sauce ""
  66.   (choose-qualities)
  67.   (has-sauce yes)
  68.   (sauce cream)
  69.   =>
  70.   (assert (best-body medium 40 =(gensym)))
  71.   (assert (best-body full 60 =(gensym))))
  72.  
  73. (defrule choose-color-for-meat ""
  74.   (choose-qualities)
  75.   (main-component meat)
  76.   (has-veal no)
  77.   =>
  78.   (assert (best-color red 90 =(gensym))))
  79.  
  80. (defrule choose-color-for-poultry ""
  81.   (choose-qualities)
  82.   (main-component poultry)
  83.   (has-turkey no)
  84.   =>
  85.   (assert (best-color white 90 =(gensym)))
  86.   (assert (best-color red 30 =(gensym))))
  87.  
  88. (defrule choose-color-for-fish ""
  89.   (choose-qualities)
  90.   (main-component fish)
  91.   =>
  92.   (assert (best-color white 100 =(gensym))))
  93.  
  94. (defrule choose-color-for-tomato-sauce ""
  95.   (choose-qualities)
  96.   (not (main-component fish))
  97.   (has-sauce yes)
  98.   (sauce tomato)
  99.   =>
  100.   (assert (best-color red 100 =(gensym))))
  101.  
  102. (defrule choose-color-for-turkey ""
  103.   (choose-qualities)
  104.   (main-component poultry)
  105.   (has-turkey yes)
  106.   =>
  107.   (assert (best-color red 80 =(gensym)))
  108.   (assert (best-color white 50 =(gensym))))
  109.  
  110. (defrule choose-color-for-cream-sauce ""
  111.   (choose-qualities)
  112.   (main-component unknown)
  113.   (has-sauce yes)
  114.   (sauce cream)
  115.   =>
  116.   (assert (best-color white 40 =(gensym))))
  117.  
  118. (defrule choose-color-for-sweet-sauce ""
  119.   (choose-qualities)
  120.   (has-sauce yes)
  121.   (sauce sweet)
  122.   =>
  123.   (assert (best-sweetness sweet 90 =(gensym)))
  124.   (assert (best-sweetness medium 40 =(gensym))))
  125.  
  126. (defrule spicy-sauce-is-spicy-feature ""
  127.   (choose-qualities)
  128.   (has-sauce yes)
  129.   (sauce spicy)
  130.   =>
  131.   (assert (feature spiciness)))
  132.  
  133. (defrule best-body-always-recommended ""
  134.   (recommend-qualities)
  135.   (best-body ?body ?per ?)
  136.   =>
  137.   (assert (recommended-body ?body ?per =(gensym))))
  138.  
  139. (defrule preferred-body-may-be-recommended ""
  140.   (recommend-qualities)
  141.   (preferred-body ?body)
  142.   (best-body ?body ?per ?)
  143.   =>
  144.   (assert (recommended-body ?body =(/ (* 20 ?per) 100) =(gensym))))
  145.  
  146. (defrule recommend-medium-body-1 ""
  147.   (recommend-qualities)
  148.   (preferred-body light)
  149.   (best-body full ?per ?)
  150.   =>
  151.   (assert (recommended-body medium ?per =(gensym))))
  152.  
  153. (defrule recommend-medium-body-2 ""
  154.   (recommend-qualities)
  155.   (preferred-body full)
  156.   (best-body light ?per ?)
  157.   =>
  158.   (assert (recommended-body medium ?per =(gensym))))
  159.  
  160. (defrule best-color-always-recommended ""
  161.   (recommend-qualities)
  162.   (best-color ?color ?per ?)
  163.   =>
  164.   (assert (recommended-color ?color ?per =(gensym))))
  165.  
  166. (defrule preferred-color-may-be-recommended
  167.   (recommend-qualities)
  168.   (preferred-color ?color)
  169.   (best-color ?color ?per ?)
  170.   =>
  171.   (assert (recommended-color ?color =(/ (* 20 ?per) 100) =(gensym))))
  172.  
  173. (defrule preferred-color-is-unknown ""
  174.   (recommend-qualities)
  175.   (preferred-color unknown)
  176.   =>
  177.   (assert (recommended-color white 50 =(gensym)))
  178.   (assert (recommended-color red 50 =(gensym))))
  179.  
  180. (defrule best-sweetness-always-recommended ""
  181.   (recommend-qualities)
  182.   (best-sweetness ?sweet ?per ?)
  183.   =>
  184.   (assert (recommended-sweetness ?sweet ?per =(gensym))))
  185.  
  186. (defrule preferred-sweetness-may-be-recommended ""
  187.   (recommend-qualities)
  188.   (best-sweetness ?sweet ?per ?)
  189.   (preferred-sweetness ?sweet)
  190.   =>
  191.   (assert (recommended-sweetness ?sweet =(/ (* 20 ?per) 100) =(gensym))))
  192.  
  193. (defrule recommend-medium-sweetness-1 ""
  194.   (recommend-qualities)
  195.   (best-sweetness sweet ?per ?)
  196.   (preferred-sweetness dry)
  197.   =>
  198.   (assert (recommended-sweetness medium ?per =(gensym))))
  199.  
  200. (defrule recommend-medium-sweetness-2 ""
  201.   (recommend-qualities)
  202.   (best-sweetness dry ?per ?)
  203.   (preferred-sweetness sweet)
  204.   =>
  205.   (assert (recommended-sweetness medium ?per =(gensym))))
  206.  
  207. ;;*************************************
  208. ;;* DEFAULT QUALITIES SELECTION RULES *
  209. ;;*************************************
  210.  
  211. (defrule use-prefered-body-if-no-best-body ""
  212.   (default-qualities)
  213.   (preferred-body ?body&~unknown)
  214.   (not (best-body ? ? ?))
  215.   =>
  216.   (assert (recommended-body ?body 100 =(gensym))))    
  217.  
  218. (defrule use-medium-body-if-no-best-body ""
  219.   (default-qualities)
  220.   (not (best-body ? ? ?))
  221.   =>
  222.   (assert (recommended-body medium 100 =(gensym))))
  223.  
  224. (defrule use-preferred-color-if-no-best-color ""
  225.   (default-qualities)
  226.   (preferred-color ?color&~unknown)
  227.   (not (best-color ? ? ?))
  228.   =>
  229.   (assert (recommended-color ?color 100 =(gensym))))
  230.  
  231. (defrule use-medium-sweetness-if-preference-unknown ""
  232.   (default-qualities)
  233.   (not (best-sweetness ? ? ?))
  234.   (preferred-sweetness unknown)
  235.   =>
  236.   (assert (recommended-sweetness medium 100 =(gensym))))
  237.  
  238. (defrule use-preferred-sweetness-if-no-best-sweetness ""
  239.   (default-qualities)
  240.   (not (best-sweetness ? ? ?))
  241.   (preferred-sweetness ?sweet&~unknown)
  242.   =>
  243.   (assert (recommended-sweetness ?sweet 100 =(gensym))))
  244.  
  245. ;;************************
  246. ;;* WINE SELECTION RULES *
  247. ;;************************
  248.  
  249. (defrule recommend-gamay ""
  250.   (select-wines)
  251.   (recommended-color red ?per1 ?)
  252.   (recommended-body medium ?per2 ?)
  253.   (or (recommended-sweetness medium ?per3 ?)
  254.       (recommended-sweetness sweet ?per3 ?))
  255.   =>
  256.   (assert (wine Gamay =(min ?per1 ?per2 ?per3) =(gensym))))
  257.  
  258. (defrule recommend-chablis ""
  259.   (select-wines)
  260.   (recommended-color white ?per1 ?)
  261.   (recommended-body light ?per2 ?)
  262.   (recommended-sweetness dry ?per3 ?)
  263.   =>
  264.   (assert (wine Chablis =(min ?per1 ?per2 ?per3) =(gensym))))
  265.  
  266. (defrule recommend-sauvignon-blanc ""
  267.   (select-wines)
  268.   (recommended-color white ?per1 ?)
  269.   (recommended-body medium ?per2 ?)
  270.   (recommended-sweetness dry ?per3 ?)
  271.   =>
  272.   (assert (wine Sauvignon-Blanc =(min ?per1 ?per2 ?per3) =(gensym))))
  273.  
  274. (defrule recommend-chardonnay ""
  275.   (select-wines)
  276.   (recommended-color white ?per1 ?)
  277.   (or (recommended-body  medium ?per2 ?)
  278.       (recommended-body  full ?per2 ?))
  279.   (or (recommended-sweetness medium ?per3 ?)
  280.       (recommended-sweetness dry ?per3 ?))
  281.   =>
  282.   (assert (wine Chardonnay =(min ?per1 ?per2 ?per3) =(gensym))))
  283.  
  284. (defrule recommend-soave ""
  285.   (select-wines)
  286.   (recommended-color white ?per1 ?)
  287.   (recommended-body light ?per2 ?)
  288.   (or (recommended-sweetness medium  ?per3 ?)
  289.       (recommended-sweetness dry ?per3 ?))
  290.   =>
  291.   (assert (wine Soave =(min ?per1 ?per2 ?per3) =(gensym))))
  292.  
  293. (defrule recommend-riesling ""
  294.   (select-wines)
  295.   (recommended-color white ?per1 ?)
  296.   (or (recommended-body light ?per2 ?)
  297.       (recommended-body medium ?per2 ?))
  298.   (or (recommended-sweetness medium ?per3 ?)
  299.       (recommended-sweetness sweet ?per3 ?))
  300.   =>
  301.   (assert (wine Riesling =(min ?per1 ?per2 ?per3) =(gensym))))
  302.  
  303. (defrule recommend-geverztraminer ""
  304.   (select-wines)
  305.   (recommended-color white ?per1 ?)
  306.   (recommended-body full ?per2 ?)
  307.   (feature spiciness)
  308.   =>
  309.   (assert (wine Geverztraminer =(min ?per1 ?per2) =(gensym))))
  310.  
  311. (defrule recommend-chenin-blanc ""
  312.   (select-wines)
  313.   (recommended-color white ?per1 ?)
  314.   (recommended-body light ?per2 ?)
  315.   (or (recommended-sweetness medium ?per3 ?)
  316.       (recommended-sweetness sweet ?per3 ?))
  317.   =>
  318.   (assert (wine Chenin-Blanc =(min ?per1 ?per2 ?per3) =(gensym))))
  319.  
  320. (defrule recommend-valpolicella ""
  321.   (select-wines)
  322.   (recommended-color red ?per1 ?)
  323.   (recommended-body light ?per2 ?)
  324.   =>
  325.   (assert (wine Valpolicella =(min ?per1 ?per2) =(gensym))))
  326.  
  327. (defrule recommend-zinfandel-and-cabernet-sauvignon ""
  328.   (select-wines)
  329.   (recommended-color red ?per1 ?)
  330.   (or (recommended-sweetness medium ?per2 ?)
  331.       (recommended-sweetness dry  ?per2 ?))
  332.   =>
  333.   (assert (wine Cabernet-Sauvignon =(min ?per1 ?per2) =(gensym)))
  334.   (assert (wine Zinfandel =(min ?per1 ?per2) =(gensym))))
  335.  
  336. (defrule recommend-pinot-noir ""
  337.   (select-wines)
  338.   (recommended-color red ?per1 ?)
  339.   (recommended-body medium ?per2 ?)
  340.   (recommended-sweetness medium ?per3 ?)
  341.   =>
  342.   (assert (wine Pinot-Noir =(min ?per1 ?per2 ?per3) =(gensym))))
  343.  
  344. (defrule recommend-burgundy ""
  345.   (select-wines)
  346.   (recommended-color red ?per1 ?)
  347.   (recommended-body full ?per2 ?)
  348.   =>
  349.   (assert (wine Burgundy =(min ?per1 ?per2) =(gensym))))
  350.  
  351. ;;***************
  352. ;;* QUERY RULES *
  353. ;;***************
  354.  
  355. (defrule bad-value ""
  356.   (declare (salience 10))
  357.   (values-for ?variable $?list)
  358.   ?f1 <- (?variable ?value)
  359.   (test (! (member ?value $?list)))
  360.   =>
  361.   (retract ?f1))
  362.  
  363. (defrule question-1 ""
  364.   ?rem <- (ask-question)
  365.   (not (main-component ?))
  366.   =>
  367.   (retract ?rem)
  368.   (printout t "Is the main component of the meal meat, fish, or poultry? ")
  369.   (assert (main-component =(read))))
  370.  
  371. (defrule question-2 ""
  372.   ?rem <- (ask-question)
  373.   (main-component poultry)
  374.   (not (has-turkey ?))
  375.   =>
  376.   (retract ?rem)
  377.   (printout t "Does the meal have turkey in it? ")
  378.   (assert (has-turkey =(read))))
  379.  
  380. (defrule question-3 ""
  381.   ?rem <- (ask-question)
  382.   (main-component meat)
  383.   (not (has-veal ?))
  384.   =>
  385.   (retract ?rem)
  386.   (printout t "Does the meal have veal in it? ")
  387.   (assert (has-veal =(read))))
  388.  
  389. (defrule question-4 ""  
  390.   ?rem <- (ask-question)
  391.   (not (has-sauce ?))
  392.   =>
  393.   (retract ?rem)
  394.   (printout t "Does the meal have a sauce on it? ")
  395.   (assert (has-sauce =(read))))
  396.  
  397. (defrule question-5 ""
  398.   ?rem <- (ask-question)
  399.   (has-sauce yes)
  400.   (not (sauce ?))
  401.   =>
  402.   (retract ?rem)
  403.   (printout t "Is the sauce for the meal spicy, sweet, cream, or tomato? ")
  404.   (assert (sauce =(read))))
  405.  
  406. (defrule question-6 ""
  407.   ?rem <- (ask-question)
  408.   (not (tastiness ?))
  409.   =>
  410.   (retract ?rem)
  411.   (printout t "Is the flavor of the meal delicate, average, or strong? ")
  412.   (assert (tastiness =(read))))
  413.  
  414. (defrule question-7 ""
  415.   ?rem <- (ask-question)
  416.   (not (preferred-body ?))
  417.   =>
  418.   (retract ?rem)
  419.   (printout t "Do you generally prefer light, medium, or full bodied wines? ")
  420.   (assert (preferred-body =(read))))
  421.  
  422. (defrule question-8 ""
  423.   ?rem <- (ask-question)
  424.   (not (preferred-color ?))
  425.   =>
  426.   (retract ?rem)
  427.   (printout t "Do you generally prefer red or white wines? ")
  428.   (assert (preferred-color =(read))))
  429.  
  430. (defrule question-9 ""
  431.   ?rem <- (ask-question)
  432.   (not (preferred-sweetness ?))
  433.   =>
  434.   (retract ?rem)
  435.   (printout t "Do you generally prefer dry, medium, or sweet wines? ")
  436.   (assert (preferred-sweetness =(read)))) 
  437.  
  438. (defrule ask-another-question ""
  439.   (not (ask-question))
  440.   =>
  441.   (assert (ask-question)))
  442.  
  443. ;;*****************************
  444. ;;* PRINT SELECTED WINE RULES *
  445. ;;*****************************
  446.  
  447. (defrule print-wine ""
  448.   (print-wines)
  449.   ?rem <- (wine ?name ?per ?)          
  450.   (not (wine ?name1 ?per1&:(> ?per1 ?per) ?))
  451.   =>
  452.   (retract ?rem)
  453.   (format t " %-24s %2d%%%n" ?name ?per))
  454.  
  455. (defrule end-spaces ""
  456.    (print-wines)
  457.    (not (wine ? ? ?))
  458.    =>
  459.    (printout t t))
  460.  
  461. ;;*******************************
  462. ;;* ELIMINATE POOR CHOICES RULE *
  463. ;;*******************************
  464.  
  465. (defrule remove-poor-wine-choices ""
  466.   (remove-poor-choices)
  467.   ?rem <- (wine ? ?per ?)
  468.   (test (< ?per 20))
  469.   =>
  470.   (retract ?rem))
  471.  
  472. ;;****************************
  473. ;;* COMBINE CERTAINTIES RULE *
  474. ;;****************************
  475.  
  476. (defrule combine-certainties ""
  477.   (declare (salience 10000))
  478.   (combine ?rel)
  479.   ?rem1 <- (?rel ?val ?per1 ?sym1)
  480.   ?rem2 <- (?rel ?val ?per2 ?sym2&~?sym1)
  481.   =>
  482.   (retract ?rem1 ?rem2)
  483.   (assert (?rel ?val
  484.         =(/ (- (* 100 (+ ?per1 ?per2)) (* ?per1 ?per2)) 100)
  485.         =(gensym))))
  486.         
  487. ;;**************************************
  488. ;;* PHASE CONTROL RULES                *
  489. ;;*   PHASE 0: Ask Questions           *
  490. ;;*   PHASE 1: Choose Best Qualities   *
  491. ;;*   PHASE 2: Choose Recommended      *
  492. ;;*            Qualities               *
  493. ;;*   PHASE 3: Check for Default       *
  494. ;;*            Recommended Qualities   *
  495. ;;*   PHASE 4: Select Wines based on   *
  496. ;;*            Recommended Qualities   *
  497. ;;*   PHASE 5: Remove Wine Selections  *
  498. ;;*            with Low Certainties    *
  499. ;;*   PHASE 6: Display Wine Selections *
  500. ;;**************************************
  501.  
  502. (defrule change-to-phase-1 ""
  503.    (declare (salience -10))
  504.    (initial-fact)
  505.    =>
  506.    (assert (choose-qualities)))
  507.  
  508. (defrule change-to-phase-2 ""
  509.    (declare (salience -10))
  510.    ?phase <- (choose-qualities)
  511.    =>
  512.    (retract ?phase)
  513.    (assert (recommend-qualities)))
  514.  
  515. (defrule change-to-phase-3 ""
  516.    (declare (salience -10))
  517.    ?phase <- (recommend-qualities)
  518.    =>
  519.    (retract ?phase)
  520.    (assert (default-qualities)))
  521.  
  522. (defrule change-to-phase-4 ""
  523.    (declare (salience -10))
  524.    ?phase <- (default-qualities)
  525.    =>
  526.    (retract ?phase)
  527.    (assert (select-wines)))
  528.  
  529. (defrule change-to-phase-5 ""
  530.    (declare (salience -10))
  531.    ?phase <- (select-wines)
  532.    =>
  533.    (retract ?phase)
  534.    (assert (remove-poor-choices)))
  535.  
  536. (defrule change-to-phase-6 ""
  537.    (declare (salience -10))
  538.    ?phase <- (remove-poor-choices)
  539.    =>
  540.    (retract ?phase)
  541.    (printout t t)
  542.    (printout t "        SELECTED WINES" t t)
  543.    (printout t " WINE                  CERTAINTY" t)
  544.    (printout t " -------------------------------" t)
  545.    (assert (print-wines)))
  546.