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.

;; --- Common definitions ---

(def passengers [:wolf :sheep :cabbage])
(def entities (conj passengers :owner))
(def start-state (zipmap entities (repeat :origin)))
(def goal-state (zipmap entities (repeat :goal)))

(defn move-entity [state entity]
  (update state entity {:origin :goal :goal :origin}))

(defn no-eating? [{:keys [:wolf :sheep :cabbage :owner]}]
  (or (= sheep owner) (and (not= sheep cabbage) (not= sheep wolf))))

;; --- Solving functions ---

(defn next-states [current]
  (let [owner-moved (move-entity current :owner)
        ps (filter #(= (:owner current) (% current)) passengers)
        owner-and-passenger-moved (map #(move-entity owner-moved %) ps)]
    (filter no-eating? (conj owner-and-passenger-moved owner-moved))))

(defn extensions-to-goal [route]
  (let [terminal (peek route)]
    (if (= terminal goal-state)
      [route]
      (let [new-states (remove (set route) (next-states terminal))]
        (mapcat #(extensions-to-goal (conj route %)) new-states)))))

(defn route->moves [route]
  (let [directions (cycle [:across :return])
        pairs (partition 2 1 route)
        moved (fn [[before after]] (filter #(not= (% before) (% after)) passengers))]
    (map #(hash-map :direction %1 :passenger (first (moved %2))) directions pairs)))

(defn wolf-sheep-cabbage []
  (map route->moves (extensions-to-goal [start-state])))

;; --- BONUS : Validation functions ---

(defn validate-apply-move [state {:keys [:direction :passenger]}]
  (let [from ({:across :origin :return :goal} direction)
        moving-entities (filter identity [:owner passenger])]
    (when (every? #(= from (% state)) moving-entities)
      (let [next-state (reduce move-entity state moving-entities)]
        (when (no-eating? next-state)
          next-state)))))

(defn follow-moves [moves]
  (reduce #(or (validate-apply-move %1 %2) (reduced nil)) start-state moves))

(defn validate-solution [moves]
  (= (follow-moves moves) goal-state))

The solver functions retain a route of visited states to avoid cycles. I found it more convenient to build up the solution as a route and convert to the required move format.

; - A trip is right or left
; - The wolf, the sheep and the cabbage have the following values respectively 1,-1,1
; - A group is valid if its sum != 0 or it's empty
; - We start from left shore
; - We use the permutations derived from the three items
; - We end a movement if there is a non valid group on the left shore or the right shore has tree items

(def values {:wolf 1 :sheep -1 :cabbage 1})

(defn valid? [items]
  (or (empty? items) (not= 0 (reduce #(+ %1 (values %2)) 0 items))))

(defn sail-right [l-shore r-shore]
  (let [items-l-shore (vec (rest l-shore))
        is-valid? (valid? items-l-shore)
        item-in-boat (first l-shore)
        items-r-shore (conj r-shore item-in-boat)]
    [is-valid? items-l-shore item-in-boat items-r-shore]))

(defn sail-left [l-shore r-shore]
  (let [is-valid? (valid? (rest r-shore))
        items-r-shore (if (valid? r-shore) r-shore (vec (rest r-shore)))
        item-in-boat (if (not (valid? r-shore)) (first r-shore))
        items-l-shore (if item-in-boat (conj l-shore item-in-boat) l-shore)]
    [is-valid? items-l-shore item-in-boat items-r-shore]))

(defn move-items
  ([xs]
   (move-items xs [] [] []))
  ([l-shore item-in-boat r-shore log]
   (let [[is-valid? l-shore item-in-boat r-shore] (sail-right l-shore r-shore)
         log (conj log [is-valid? l-shore (str "-" item-in-boat "->") r-shore])]
     (if (or (not is-valid?) (= (count r-shore) 3))
       log
       (let [[is-valid? l-shore item-in-boat r-shore] (sail-left l-shore r-shore)
             log (conj log [is-valid? l-shore (str "<-" item-in-boat "-") r-shore])]
         (move-items l-shore item-in-boat r-shore log))))
   ))

(defn main
  "Returns an array with the solution to all permutations"
  []
  (let [perms (permutations [:wolf :sheep :cabbage])]
    (map #(identity {:permutation % :result (move-items %)}) perms)))

(defn validate-solution
  "Validates one solution by checking the is-valid value returned for each trip"
  [solution]
  (every? #(true? (first %)) (:result solution)))

A solutions looks like this

{:permutation (:sheep :wolf :cabbage),
 :result [[true [:wolf :cabbage] "-:sheep->" [:sheep]]
          [true [:wolf :cabbage] "<--" [:sheep]]
          [true [:cabbage] "-:wolf->" [:sheep :wolf]]
          [true [:cabbage :sheep] "<-:sheep-" [:wolf]]
          [true [:sheep] "-:cabbage->" [:wolf :cabbage]]
          [true [:sheep] "<--" [:wolf :cabbage]]
          [true [] "-:sheep->" [:wolf :cabbage :sheep]]]}

;;; Wolf Sheep Cabbage

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

(def starting-state {:near #{:wolf :sheep :cabbage :me}
                     :far #{}})
(def ending-state {:near #{}
                   :far #{:wolf :sheep :cabbage :me}})

(defn lose? [state]
  (if (contains? (:near state) :me)
    (some #(clojure.set/subset? % (:far  state)) bad-pairs)
    (some #(clojure.set/subset? % (:near state)) bad-pairs)))

(defn win? [state]
  (= ending-state state))

(defn current-location [state]
  (if (contains? (:near state) :me)
    :near :far))

(defn opposite-location [state]
  (if (contains? (:near state) :me)
    :far :near))

(defn next-direction [state]
  (if (contains? (:near state) :me)
    :across :return))

(defn neighbors [state]
  (-> state
      (get (current-location state))
      (disj :me)
      (conj :none)))

(defn next-moves [state]
  (for [n (neighbors state)]
    {:direction (next-direction state)
     :passenger n}))

(defn make-move [state {:keys [direction passenger]}]
  (-> state
      (update (current-location  state) disj :me passenger)
      (update (opposite-location state) #(if (= :none passenger)
                                           (conj % :me)
                                           (conj % :me passenger)))))

(defn try-moves [moves]
  (for [move (next-moves (:state moves))]
    (-> moves
        (update :moves conj      move)
        (update :state make-move move))))

(defn winning-sequences []
  (loop [contenders [{:state starting-state :moves []}]
         tried-states #{starting-state}
         winners []]
    (if (empty? contenders)
      (map :moves winners)
      (let [possible-contenders (mapcat try-moves contenders)
            next-winners (filter #(win? (:state %)) possible-contenders)
            next-contenders (->> possible-contenders
                                 (remove #(win?  (:state %)))
                                 (remove #(lose? (:state %)))
                                 (remove #(contains? tried-states (:state %))))]
        (recur next-contenders
               (into tried-states (map :state possible-contenders))
               (into winners next-winners))))))

(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!