;; Stevie Kaligis ;; posted February 17, 2002 02:21 AM ;; Three men, A, B, C and their respective wives, Aw, Bw and Cw, were ;; hunting in deepest Peru, when they came across a large ;; river. Luckily there was one boat, however, it could only carry two ;; people at the same time. Due to bitter jealousy, no woman could be ;; left with another man unless her husband was present. How did they ;; manage to cross the river? ;;;********************************************************************** ;;; SOLUTION METHOD ;;; This is basically a depth-first search. We create one "state" fact ;;; to represent every possible move along a path to the ;;; solution. Constraint rules remove invalid moves. When a complete ;;; solution is recognized, it is displayed, all the states leading up ;;; to it are deleted, and the search begins again, until all valid ;;; initial moves are exhausted. ;; ********************************************************************** ;; Define the basic data structures we'll need. ;; ********************************************************************** (deftemplate state "One step along the path to the solution." (slot search-depth) (slot parent) (slot locations) (slot last-move)) (deftemplate person "One of the people who is travelling." (slot name)) (deftemplate man extends person "A male person" (slot wife)) (deftemplate woman extends person "A female person" (slot husband)) (deffacts MAIN::people "All the people involved in the problem." (man (name A) (wife Aw)) (man (name B) (wife Bw)) (man (name C) (wife Cw)) (woman (name Aw) (husband A)) (woman (name Bw) (husband B)) (woman (name Cw) (husband C))) ;; ********************************************************************** ;; Utility functions ;; ********************************************************************** (deffunction all-across (?map) "If none of the people are on shore-1, we've found a solution." (bind ?it ((?map values) iterator)) (while (?it hasNext) (if (eq "shore-1" (?it next)) then (return FALSE))) (return TRUE)) (deffunction alphabetical-order(?n1 ?n2) (> (?n1 compareTo ?n2) 0)) (deffunction same-gender(?p1 ?p2) (eq (?p1 getName) (?p2 getName))) (deffunction same-shore-as-boat(?name ?state) (bind ?map (fact-slot-value ?state locations)) (bind ?num (fact-slot-value ?state search-depth)) (eq (?map get ?name) (boat-location ?num))) (deffunction same-shore(?name1 ?name2 ?state) (bind ?map (fact-slot-value ?state locations)) (eq (?map get ?name1) (?map get ?name2))) (deffunction boat-location (?num) "The boat alternates between the two shores." (if (evenp ?num) then "shore-2" else "shore-1")) (deffunction move-alone (?name ?state) (bind ?map ((fact-slot-value ?state locations) clone)) (bind ?num (fact-slot-value ?state search-depth)) (bind ?newshore (opposite-of (?map get ?name))) (?map put ?name ?newshore) (duplicate ?state (search-depth (+ 1 ?num)) (parent ?state) (locations ?map) (last-move ?name))) (deffunction move-together (?name1 ?name2 ?state) (bind ?map ((fact-slot-value ?state locations) clone)) (bind ?num (fact-slot-value ?state search-depth)) (bind ?newshore (opposite-of (?map get ?name1))) (?map put ?name1 ?newshore) (?map put ?name2 ?newshore) (duplicate ?state (search-depth (+ 1 ?num)) (parent ?state) (locations ?map) (last-move (str-cat ?name1 " and " ?name2)))) (deffunction opposite-of (?shore) (if (eq ?shore "shore-1") then "shore-2" else "shore-1")) ;; ********************************************************************** ;; These rules assert possible next moves, according to some constraints. ;; ********************************************************************** (defrule MAIN::move-alone "Any person on the same shore as the boat can move alone across the river." (person (name ?n)) ?state <- (state) (test (same-shore-as-boat ?n ?state)) => (move-alone ?n ?state)) (defrule MAIN::move-together-same-gender "Any two people of the same gender, both on the same shore as the boat, can move across the river." ?p1 <- (person (name ?n1)) ?p2 <- (person (name ?n2&~?n1)) (test (same-gender ?p1 ?p2)) (test (alphabetical-order ?n1 ?n2)) ?state <- (state) (test (same-shore-as-boat ?n1 ?state)) (test (same-shore ?n1 ?n2 ?state)) => (move-together ?n1 ?n2 ?state)) (defrule MAIN::move-together-married-couple "Any married couple, both on the same shore as the boat, can move across the river." (man (name ?n1)) (woman (name ?n2) (husband ?n1)) ?state <- (state) (test (same-shore-as-boat ?n1 ?state)) (test (same-shore ?n1 ?n2 ?state)) => (move-together ?n1 ?n2 ?state)) ;; ********************************************************************** ;; These rules prune away some proposed next states, based on other ;; constraints. ;; ********************************************************************** (defmodule CONSTRAINTS) (defrule CONSTRAINTS::unmarried "A woman and a man not her husband cannot both be on the same shore, unless the husband is also present." (declare (auto-focus TRUE)) (woman (name ?wife) (husband ?husband)) (man (name ?husband)) (man (name ?other-guy&~?husband)) ?state <- (state) (test (and (not (same-shore ?husband ?wife ?state)) (same-shore ?other-guy ?wife ?state))) => (retract ?state)) (defrule CONSTRAINTS::circular-path "If a path contains a duplicate state, it is cyclical, and should be discarded." (declare (auto-focus TRUE)) (state (search-depth ?sd1) (locations ?map1)) ?state <- (state (search-depth ?sd2&:(< ?sd1 ?sd2)) (locations ?map2&:(?map1 equals ?map2))) => (retract ?state)) ;; ********************************************************************** ;; These rules detect when the puzzle has been solved, and print the ;; solution(s). ;; ********************************************************************** (defmodule SOLUTION) (deftemplate SOLUTION::moves "A holder for a list of moves (i.e., a solution.)" (slot last-state) (multislot moves-list)) (defrule SOLUTION::recognize-solution "If, in a particular state, all the people are on shore-2, then that state is the last move in a solution." (declare (auto-focus TRUE)) ?state <- (state (parent ?parent) (locations ?map&:(all-across ?map)) (last-move ?move)) => (retract ?state) (assert (moves (last-state ?parent) (moves-list ?move)))) (defrule SOLUTION::further-solution "Walk down the list of states representing a solution, and accumulate the moves." ?state <- (state (parent ?parent) (last-move ?move)) ?mv <- (moves (last-state ?state) (moves-list $?rest)) => (modify ?mv (last-state ?parent) (moves-list ?move ?rest))) (defrule SOLUTION::print-solution "A 'moves' fact representing a solution starts with 'no-move'. When we see one, print the whole thing out as a solution." ?mv <- (moves (last-state no-parent) (moves-list no-move $?m)) => (retract ?mv) (printout t crlf "Solution found: " crlf crlf) (bind ?length (length$ ?m)) (bind ?i 1) (bind ?shore "shore-2") (while (<= ?i ?length) (bind ?thing (nth$ ?i ?m)) (printout t ?thing (if (> (?thing indexOf " ") -1) then " move to " else " moves to ") ?shore crlf) (bind ?shore (opposite-of ?shore)) (bind ?i (+ 1 ?i)))) ;; ********************************************************************** ;; Run the actual problem. ;; ********************************************************************** (import java.util.HashMap) (defquery MAIN::all-people "List all the person facts, so that we can set up the initial state." (person)) (deffunction set-initial-state () "Set up the first state fact, in which all the people are on one side of the river. All the other state facts will be created by cloning this one." (bind ?map (new HashMap)) (bind ?it (run-query MAIN::all-people)) (while (?it hasNext) (bind ?name (fact-slot-value ((?it next) fact 1) name)) (?map put ?name shore-1)) (assert (state (search-depth 1) (parent no-parent) (locations ?map) (last-move no-move)))) (reset) (set-initial-state) (run)