Solving Dinesman's multiple-dwelling example using clojure's core.logic/core.match

Question

After watching Sussman's lecture http://www.infoq.com/presentations/We-Really-Dont-Know-How-To-Compute, I am inspired to give core.logic and core.match a go. The only examples I know are those constraint problem solvers that I used to do as a kid. This one was an example used in the SICP course as well as being mentioned in the talk:

Baker, Cooper, Fletcher, Miller, and Smith live on different floors of an apartment house that contains only five floors. Baker does not live on the top floor. Cooper does not live on the bottom floor. Fletcher does not live on either the top or the bottom floor. Miller lives on a higher floor than does Cooper. Smith does not live on a floor adjacent to Fletcher's. Fletcher does not live on a floor adjacent to Cooper's. Where does everyone live?

I found this on the rosettacode site: http://rosettacode.org/wiki/Dinesman%27s_multiple-dwelling_problem#PicoLisp

But not too sure how that translates into clojure. I am hoping that someone can provide an example of solving this using core.logic or core.match

Answer 1

Here's a solution in core.logic. It's not exactly equivalent to the picolisp algorithm because we don't have the same primitives available, but it's the same general idea. Thanks for introducing me to the problem - it was fun to invent permuteo and beforeo, and I had my first excuse to use conda. Edit: using conda there was horrible and wrong, and I'm back to conde now. Oh well, some day.

(ns dwelling.core
  (:refer-clojure :exclude [==])
  (:use clojure.core.logic))

(defn rembero [x l out]
  (fresh [head tail]
    (conso head tail l)
    (conde [(== x head) (== out tail)]
           [(fresh [new-out]
              (conso head new-out out)
              (rembero x tail new-out))])))

(defn permuteo [a b]
  (conde [(emptyo a) (emptyo b)]
         [(fresh [head tail b-tail]
            (conso head tail a)
            (rembero head b b-tail)
            (permuteo tail b-tail))]))

(defn beforeo [x y l]
  (fresh [head tail]
    (conso head tail l)
    (conde [(== x head) (fresh [more-tail]
                          (rembero y tail more-tail))]
           [(beforeo x y tail)])))

(defn not-adjacento [x y l]
  (fresh [head tail more]
    (conso head tail l)
    (resto tail more)
    (conde [(== x head) (membero y more)]
           [(== y head) (membero x more)]
           [(not-adjacento x y tail)])))

(run* [tenants]
  (fresh [a b c d e]
    (== [a b c d e] tenants)
    (permuteo tenants '[Cooper Baker Fletcher Miller Smith])
    (!= e 'Baker)
    (!= a 'Cooper)
    (!= a 'Fletcher)
    (!= e 'Fletcher)
    (beforeo 'Cooper 'Miller tenants)
    (not-adjacento 'Smith 'Fletcher tenants)
    (not-adjacento 'Fletcher 'Cooper tenants)))

;; ([Smith Cooper Baker Fletcher Miller])