;;;======================================================
;;;   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 and object pattern  
;;;     matching to solve the problem.
;;;
;;;     CLIPS Version 6.0 Example
;;;
;;;     To execute, merely load, reset and run.
;;;======================================================

;;;***********
;;;* CLASSES *
;;;***********

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

(defclass status (is-a USER)
   (role concrete)
   (pattern-match reactive)
   (slot search-depth
     (create-accessor write)
     (type INTEGER) (range 1 ?VARIABLE) (default 1)) 
   (slot parent
     (create-accessor write)
     (type INSTANCE-ADDRESS) (default ?DERIVE))
   (slot farmer-location 
     (create-accessor write)
     (type SYMBOL) (allowed-symbols shore-1 shore-2) (default shore-1))
   (slot fox-location
     (create-accessor write)
     (type SYMBOL) (allowed-symbols shore-1 shore-2) (default shore-1))
   (slot goat-location
     (create-accessor write)
     (type SYMBOL) (allowed-symbols shore-1 shore-2) (default shore-1))
   (slot cabbage-location
     (create-accessor write)
     (type SYMBOL) (allowed-symbols shore-1 shore-2) (default shore-1))
   (slot last-move
     (create-accessor write)
     (type SYMBOL) (allowed-symbols no-move alone fox goat cabbage)
     (default no-move)))
   
;;; The moves instances hold the information of all the moves
;;; made to reach a given state.
       
(defclass moves (is-a USER)
   (role concrete)
   (pattern-match reactive)
   (slot id
      (create-accessor write)
      (type INSTANCE)) 
   (multislot moves-list 
      (create-accessor write)
      (type SYMBOL)
      (allowed-symbols no-move alone fox goat cabbage)))

(defclass opposite-of
   (is-a USER)
   (role concrete)
   (pattern-match reactive)
   (slot value (create-accessor write))
   (slot opposite-value (create-accessor write)))

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

(definstances startups
  (of status)
  (of opposite-of (value shore-1) (opposite-value shore-2))
  (of opposite-of (value shore-2) (opposite-value shore-1)))

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

(defrule move-alone 
  ?node <- (object (is-a status)
                   (search-depth ?num)  
                   (farmer-location ?fs))
  (object (is-a opposite-of) (value ?fs) (opposite-value ?ns))
  =>
  (duplicate-instance ?node
    (search-depth (+ 1 ?num))
    (parent ?node)
    (farmer-location ?ns)
    (last-move alone)))

(defrule move-with-fox
  ?node <- (object (is-a status)
                   (search-depth ?num) 
                   (farmer-location ?fs)
                   (fox-location ?fs))
  (object (is-a opposite-of) (value ?fs) (opposite-value ?ns))
  =>
  (duplicate-instance ?node
    (search-depth (+ 1 ?num))
    (parent ?node)
    (farmer-location ?ns)
    (last-move fox)
    (fox-location ?ns)))

(defrule move-with-goat 
  ?node <- (object (is-a status)
                   (search-depth ?num) 
                   (farmer-location ?fs)
                   (goat-location ?fs))
  (object (is-a opposite-of) (value ?fs) (opposite-value ?ns))
  =>
  (duplicate-instance ?node
    (search-depth (+ 1 ?num))
    (parent ?node)
    (farmer-location ?ns)
    (last-move goat)
    (goat-location ?ns)))

(defrule move-with-cabbage
  ?node <- (object (is-a status)
                   (search-depth ?num) 
                   (farmer-location ?fs)
                   (cabbage-location ?fs))
  (object (is-a opposite-of) (value ?fs) (opposite-value ?ns))
  =>
  (duplicate-instance ?node
    (search-depth (+ 1 ?num))
    (parent ?node)
    (farmer-location ?ns)
    (last-move cabbage)
    (cabbage-location ?ns)))

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

(defrule fox-eats-goat 
  (declare (salience 200))
  ?node <- (object (is-a status)
                   (farmer-location ?s1)
                   (fox-location ?s2&~?s1)
                   (goat-location ?s2))
  =>
  (unmake-instance ?node))

(defrule goat-eats-cabbage 
  (declare (salience 200))
  ?node <- (object (is-a status)
                   (farmer-location ?s1)
                   (goat-location ?s2&~?s1)
                   (cabbage-location ?s2))
  =>
  (unmake-instance ?node))

(defrule circular-path 
  (declare (salience 200))
  (object (is-a status)
          (search-depth ?sd1)
          (farmer-location ?fs)
          (fox-location ?xs)
          (goat-location ?gs)
          (cabbage-location ?cs))
  ?node <- (object (is-a status)
                   (search-depth ?sd2&:(< ?sd1 ?sd2))
                   (farmer-location ?fs)
                   (fox-location ?xs)
                   (goat-location ?gs)
                   (cabbage-location ?cs))
  =>
  (unmake-instance ?node))

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

(defrule recognize-solution 
  (declare (salience 100))
  ?node <- (object (is-a status)
                   (parent ?parent)
                   (farmer-location shore-2)
                   (fox-location shore-2)
                   (goat-location shore-2)
                   (cabbage-location shore-2)
                   (last-move ?move))
  =>
  (unmake-instance ?node)
  (make-instance of moves
     (id ?parent) (moves-list ?move)))

(defrule further-solution 
  (declare (salience 100))
  ?state <- (object (is-a status)
                    (parent ?parent)
                    (last-move ?move))
  ?mv <- (object (is-a moves)
                 (id ?state)
                 (moves-list $?rest))
  =>
  (modify-instance ?mv (id ?parent) (moves-list ?move ?rest)))

(defrule print-solution 
  (declare (salience 100))
  ?mv <- (object (is-a moves)
                 ;(id [no-parent]) 
                 (moves-list no-move $?m))
  =>
  (unmake-instance ?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))))