dilemma.clp

模糊clips专家系统

;;;======================================================
;;;   Farmer's Dilemma Problem
;;;
;;;     Another classic AI problem (cannibals and the 
;;;     missionary) in agricultural terms. The point is
;;;     to get the farmer, the fox the cabbage and the
;;;     goat across a stream.
;;;     But the boat only holds 2 items. If left 
;;;     alone with the goat, the fox will eat it. If
;;;     left alone with the cabbage, the goat will eat
;;;     it.
;;;     This example uses rules to solve the problem.
;;;
;;;     CLIPS Version 5.1 Example
;;;
;;;     To execute, merely load, reset and run.
;;;======================================================

;;;*****************************************
;;;* GLOBAL VARIABLES FOR USE AS SALIENCES *
;;;*****************************************

(defglobal ?*constraint-salience* = 200)
(defglobal ?*solution-salience* = 100)
(defglobal ?*standard-salience* = 0)

;;;*************
;;;* TEMPLATES *
;;;*************

;;; The status facts hold the state  
;;; information of the search tree.

(deftemplate status 
   (field search-depth (type INTEGER) (range 1 ?VARIABLE)) 
   (field id (type SYMBOL)) 
   (field parent (type SYMBOL))
   (field farmer-location 
      (type SYMBOL) (allowed-symbols shore-1 shore-2))
   (field fox-location
      (type SYMBOL) (allowed-symbols shore-1 shore-2))
   (field goat-location
      (type SYMBOL) (allowed-symbols shore-1 shore-2))
   (field cabbage-location
      (type SYMBOL) (allowed-symbols shore-1 shore-2))
   (field last-move
      (type SYMBOL) (allowed-symbols no-move alone fox goat cabbage)))
   
;;; The moves facts hold the information of all the moves
;;; made to reach a given state.
       
(deftemplate moves 
   (field id (type SYMBOL)) 
   (multifield moves-list  
      (type SYMBOL) (allowed-symbols no-move alone fox goat cabbage)))

;;;*****************
;;;* INITIAL STATE *
;;;*****************

(deffacts initial-positions
  (status (search-depth 1) 
          (id initial-setup) 
          (parent no-parent)
          (farmer-location shore-1)
          (fox-location shore-1)
          (goat-location shore-1)
          (cabbage-location shore-1)
          (last-move no-move)))

(deffacts opposites
  (opposite-of shore-1 shore-2)
  (opposite-of shore-2 shore-1))

;;;***********************
;;;* GENERATE PATH RULES *
;;;***********************

(defrule move-alone 
  (declare (salience ?*standard-salience*))
  ?node <- (status (search-depth ?num)  
                   (id ?name) 
                   (farmer-location ?fs))
  (opposite-of ?fs ?ns)
  =>
  (duplicate ?node (search-depth =(+ 1 ?num)) 
                   (id =(gensym)) 
                   (parent ?name)
                   (farmer-location ?ns)
                   (last-move alone)))

(defrule move-with-fox
  (declare (salience ?*standard-salience*))
  ?node <- (status (search-depth ?num) 
                   (id ?name) 
                   (farmer-location ?fs)
                   (fox-location ?fs))
  (opposite-of ?fs ?ns)
  =>
  (duplicate ?node (search-depth =(+ 1 ?num)) 
                   (id =(gensym)) 
                   (parent ?name)
                   (farmer-location ?ns)
                   (fox-location ?ns)
                   (last-move fox)))

(defrule move-with-goat 
  (declare (salience ?*standard-salience*))
  ?node <- (status (search-depth ?num) 
                   (id ?name) 
                   (farmer-location ?fs)
                   (goat-location ?fs))
  (opposite-of ?fs ?ns)
  =>
  (duplicate ?node (search-depth =(+ 1 ?num)) 
                   (id =(gensym)) 
                   (parent ?name)
                   (farmer-location ?ns)
                   (goat-location ?ns)
                   (last-move goat)))

(defrule move-with-cabbage
  (declare (salience ?*standard-salience*))
  ?node <- (status (search-depth ?num) 
                   (id ?name) 
                   (farmer-location ?fs)
                   (cabbage-location ?fs))
  (opposite-of ?fs ?ns)
  =>
  (duplicate ?node (search-depth =(+ 1 ?num)) 
                   (id =(gensym)) 
                   (parent ?name)
                   (farmer-location ?ns)
                   (cabbage-location ?ns)
                   (last-move cabbage)))

;;;******************************
;;;* CONSTRAINT VIOLATION RULES *
;;;******************************

(defrule fox-eats-goat 
  (declare (salience ?*constraint-salience*))
  ?node <- (status (farmer-location ?s1)
                   (fox-location ?s2&~?s1)
                   (goat-location ?s2))
  =>
  (retract ?node))

(defrule goat-eats-cabbage 
  (declare (salience ?*constraint-salience*))
  ?node <- (status (farmer-location ?s1)
                   (goat-location ?s2&~?s1)
                   (cabbage-location ?s2))
  =>
  (retract ?node))

(defrule circular-path 
  (declare (salience ?*constraint-salience*))
  (status (search-depth ?sd1)
          (farmer-location ?fs)
          (fox-location ?xs)
          (goat-location ?gs)
          (cabbage-location ?cs))
  ?node <- (status (search-depth ?sd2&:(< ?sd1 ?sd2))
                   (farmer-location ?fs)
                   (fox-location ?xs)
                   (goat-location ?gs)
                   (cabbage-location ?cs))
  =>
  (retract ?node))

;;;*********************************
;;;* FIND AND PRINT SOLUTION RULES *
;;;*********************************

(defrule recognize-solution 
  (declare (salience ?*solution-salience*))
  ?node <- (status (parent ?parent)
                   (farmer-location shore-2)
                   (fox-location shore-2)
                   (goat-location shore-2)
                   (cabbage-location shore-2)
                   (last-move ?move))
  =>
  (retract ?node)
  (assert (moves (id ?parent) (moves-list ?move))))

(defrule further-solution 
  (declare (salience ?*solution-salience*))
  ?mv <- (moves (id ?name) (moves-list $?rest))
  ?node <- (status (id ?name)
                   (parent ?parent)
                   (last-move ?move))
  =>
  (modify ?mv (id ?parent) (moves-list ?move $?rest)))

(defrule print-solution 
  (declare (salience ?*solution-salience*))
  ?mv <- (moves (id no-parent) (moves-list no-move $?m))
  =>
  (retract ?mv)
  (printout t t  "Solution found: " t t)
  (bind ?length (length $?m))
  (bind ?i 1)
  (bind ?shore shore-2)
  (while (<= ?i ?length)
     (bind ?thing (nth ?i $?m))
     (if (eq ?thing alone)
        then (printout t "Farmer moves alone to " ?shore "." t)
        else (printout t "Farmer moves with " ?thing " to " ?shore "." t))
     (if (eq ?shore shore-1)
        then (bind ?shore shore-2)
        else (bind ?shore shore-1))
     (bind ?i (+ 1 ?i))))