397 - PurelyFunctional.tv Newsletter

00 Wolf Sheep Cabbage.md

Wolf, sheep, cabbage

There's a really common problem called "Wolf, sheep, cabbage". (There are other names for it as well). The problem goes like this:

You own a wolf, a sheep, and a cabbage. You need to cross a river and you only have a boat big enough for you plus one other passenger (your wolf, sheep, or cabbage). The trouble is, the animals are hungry. If you leave the wolf with the sheep, the wolf will eat it. If you leave the sheep with the cabbage, it will eat it. The wolf, being a carnivore, will not eat the cabbage. How do you move them safely to the other side with nothing being eaten?

It's a fun problem and I suggest you give it a try on paper if you don't know the solution. If you can't figure it out, search for it online and you'll find solutions.

Your task is to write a function that generates solutions to this puzzle, in the form of boat crossings. Each crossing should state:

• the direction you are going
• the passenger in your boat

(defn wolf-sheep-cabbage []) => ([...
                                  {:direction :across
                                   :passenger :cabbage}
                                  {:direction :return
                                   :passenger :sheep}]
                                 ...)

Bonus

Write a function that validates a solution.

Please submit your solutions as comments to this gist. Discussion is welcome.

(def initial-state
  {
   :boat-location :this-side
   :this-side     #{:wolf :sheep :cabbage}
   :other-side    #{}
   })

(defn- complement-side [side]
  (if (= :this-side side) :other-side :this-side))

(defn- next-boat-direction [{:keys [boat-location]}]
  (if (= :this-side boat-location) :across :return))

(defn- all-transferred? [{:keys [this-side]}]
  (empty? this-side))

(defn- would-be-eaten? [{:keys [boat-location] :as state}]
  (let [unsupervised-side ((complement-side boat-location) state)]
    (or (subset? #{:wolf :sheep} unsupervised-side)
        (subset? #{:sheep :cabbage} unsupervised-side))))

(defn- next-crossing [state passenger]
  {:direction (next-boat-direction state)
   :passenger passenger})

(defn- conj-non-nil [coll x]
  (if (nil? x) coll (conj coll x)))

(defn- next-state [state passenger]
  (let [current-side (:boat-location state)]
    (-> state
        (update :boat-location complement-side)
        (update current-side disj passenger)
        (update (complement-side current-side) conj-non-nil passenger))))

(defn wolf-sheep-cabbage
  ([]
   (wolf-sheep-cabbage [initial-state] []))
  ([states crossings]
   (let [current-state       (peek states)
         state-seen-already? (set (pop states))]
     (cond
       (all-transferred? current-state)
       [crossings]
       (state-seen-already? current-state)
       nil
       (would-be-eaten? current-state)
       nil
       :else
       (let [boat-location       (:boat-location current-state)
             current-side        (boat-location current-state)
             possible-passengers (cons nil current-side)]
         (->> possible-passengers
              (mapcat #(wolf-sheep-cabbage (conj states (next-state current-state %))
                                           (conj crossings (next-crossing current-state %))))
              (filter some?)))))))

(defn start-state []
  {:a #{:wolf :sheep :cabbage}
   :b #{}
   :location :a
   :passenger nil})

(defn start-solution
  "A solution is a map with two keys: `:vec`, which is the sequential progression of states, and `:set`, which is the
  same list, but as a set. The intention is to make looking for previously seen states faster. I'm not sure how
  effective that actually is."
  []
  (let [state (start-state)]
    {:vec [state]
     :set #{state}}))

(defn opposite-side [{location :location}]
  ({:a :b :b :a} location))

(defn transport [state passenger]
  (let [from (:location state)
        to (opposite-side state)]
    (if passenger
      {from (disj (get state from) passenger)
       to (conj (get state to) passenger)
       :location to
       :passenger passenger}
      (assoc state :location to :passenger nil))))

(defn next-passengers [state]
  (let [from (get state (:location state))]
    (if (empty? from)
      []
      ; optimization: if the shore is "full", we must take a passenger
      (cond-> from (< (count from) 3) (conj nil)))))

(def dangerous-pairs #{#{:wolf :sheep} #{:sheep :cabbage}})

(defn valid-state? [state]
  (let [opposite (get state (opposite-side state))]
    (not (contains? dangerous-pairs opposite))))

(defn next-states
  "Takes a solution, and returns a sequence of new solutions, where each new solution is the original solution with a
  distinct next step added."
  [{:keys [vec set] :as solution}]
  (let [current-state (peek vec)
        passengers (next-passengers current-state)
        states (map (partial transport current-state) passengers)
        valid-states (filter valid-state? states)
        new-states (remove set valid-states)]
    (map (fn [state]
           (-> solution
               (update :vec conj state)
               (update :set conj state)))
         new-states)))

(defn build-solutions [solutions]
  (mapcat next-states solutions))

(defn valid-solution?
  "A valid solution is one where the initial shore (:a) is empty."
  [{vec :vec}]
  (let [{a :a} (peek vec)]
    (empty? a)))

(defn solution->output [{vec :vec}]
  (->> vec
       (drop 1) ; lose the initial state (we want the edges, not the nodes)
       (map :passenger)
       (map #(hash-map :direction %1 :passenger %2) (cycle [:across :return]))))

(defn wolf-sheep-cabbage
  "Produces an infinite (?) lazy sequence of possible solutions for the wolf/sheep/cabbage problem, ordered by
  increasing length."
  []
  (->> [(start-solution)]
       (iterate build-solutions)
       flatten
       (filter valid-solution?)
       (map solution->output)))

This is a neat challenge - for added fun, I throw in there some extra spice:
2nd bonus, make it lazy on a per-solution basis.
3rd bonus, build your solution on top of a generic depth-first-search (or other perhaps) one, e.g.

(defn depth-first-search [init-state, generate-candidates-fn, valid?-pred, ...] ...)
...
(defn cabbage-wolf-sheep []
  (depth-first-search {:from #{:wolf :sheep :cabbage}, :to #{}} ...)

I am trying to build a generic lazy DFS.

After a bit of sweat and getting tired of yet again having to work on the traversal and backtracking mechanics of depth first search, I wrote a pluggable DFS shell, and named it shellfish: check it out here. To use it, simply drop the release jar into your project's lib directory, and link to it by adding :source-paths ["src" "lib/shellfish-0.5-ALPHA.jar"] to your project.clj

The dfs function yields a lazy seq of all solutions for its problem argument (see below). It seems to work well with the Knight's Tour and Queens chess problems (for small sizes, since they are NP-complete using DFS), and just added, a sudoku solver (using Peter Norvig's algorithm).

Thanks to the magic of zippers, the mechanics of backtracking were surprisingly simple, and I gained a deep appreciation of zipper/next as a result.

Here is my clumsy solution for this puzzle using shellfish - comments and criticisms welcome!

(require '[shellfish.dfs.core :as algo])

(def passengers [:wolf :sheep :cabbage])
(def loss-groups #{#{:wolf :sheep} #{:sheep :cabbage}})
(def directions #{:across :return})

(defn lossy? [group]
  (some (fn [xy]
          (every? group (seq xy)))
        (seq loss-groups)))

(defn src+dst [{:keys [from to]} direction]
  (let [[src-k src dst-k dst] (if (= :across direction)
                                [:from from :to to]
                                [:to to :from from])]
    {:src src, :src-k src-k, 
     :dst dst, :dst-k dst-k}))

(defn valid-move? [{:keys [after] :as state} passenger direction]
  (let [{:keys [src dst]} (src+dst state direction)]
    (and (directions direction)
         (not= after direction)
         (if-not passenger
           (not (lossy? src))
           (and (src passenger)
                (not (lossy? (disj src passenger))))))))

(defn trip-candidates [{:keys [after] :as state}]
  (let [d (if (#{:init :return} after) :across :return)
        {pool :src} (src+dst state d)]
    (->> pool 
         (cons nil)
         (filter #(valid-move? state % d))
         (map #(hash-map :passenger % :direction d)))))

(defn goal-reached? [{:keys [from to]}]
  (and (= nil (seq from)) 
       (= (set passengers) to)))

(defn update-state [state
                    {:keys [passenger direction] :as trip}]
  (let [{:keys [src src-k dst dst-k]} (src+dst state direction)]
    (merge (if passenger
             {src-k (disj src passenger)
              dst-k (conj dst passenger)}
             state)
           {:after direction})))

(def init-state {:from (set passengers), :to #{} :after :init})

(defn wolf-sheep-cabbage []
  (algo/dfs {:init-state init-state
             :generate trip-candidates
             :goal? goal-reached?
             :update update-state}))

(defn valid-solution? [solution]
  (->> solution
       (reduce (fn [{:keys [from to after] :as state} 
                    {dir :direction p :passenger :as trip}]
                 (cond 
                   (not (valid-move? state p dir))
                   (reduced false)
                   :else
                   (update-state state trip)))
               init-state)
       goal-reached?))

(let [sols (wolf-sheep-cabbage)] 
  (and (= 2 (count (set sols))) 
       (every? #(not (empty? %)) sols)
       (every? valid-solution? sols)))
;; => true

Since part one doesn't specify correct solutions, here's a way of generating random 'solutions' with clojure.spec:

(ns challenges.wolf
  (:require [clojure.spec.alpha :as s]
            [clojure.spec.gen.alpha :as gen]))

(s/def ::passenger #{:wolf :sheep :cabbage})
(s/def ::direction #{:across :return})
(s/def ::round (s/keys :req-un [::direction ::passenger]))
(s/def ::solut (s/* ::round))

(defn wolf-sheep-cabbage []
  (into [] (gen/generate (s/gen ::solut))))

;; example run
(wolf-sheep-cabbage)
;; [{:direction :across, :passenger :wolf}
;;  {:direction :return, :passenger :wolf}
;;  {:direction :across, :passenger :sheep}
;;  {:direction :return, :passenger :cabbage}
;;  {:direction :across, :passenger :wolf}
;;  {:direction :return, :passenger :sheep}
;;  {:direction :across, :passenger :sheep}
;;  {:direction :across, :passenger :cabbage}
;;  {:direction :across, :passentger :wolf}
;;  {:direction :across, :passenger :sheep}]

Given enough time, this would stumble on a correct solution. :)
Yes, I know, this is not what was intended, but it was a good excuse to practice with clojure.spec and test.check. It would also be useful for generating test cases for a solution validator!