the brown-dragon blog

An Elegant (and utterly amazing) solution to Einstein's Problem

2008-12-21

A colleague of mine sent me this puzzle to solve. It's apparently called Einstein's problem because popular myth is that he invented the problem (and said that 98% in the world wouldn't be able to solve it to boot! :-D ).

This is the problem:

einstein-problem.txt


There are five houses in five different colours starting from left to right. In each house lives a person of a different nationality. These owners all drink a certain type of beverage, smoke a certain brand of cigarette and keep a certain type of pet. No two owners have the same pet, smoke the same brand or drink the same beverage.



The question is: Who is the owner of the pet Fish ?



Hints:



    1.   The Brit lives in the red house

    2.   The Swede keeps dogs as pets

    3.   The Dane drinks tea

    4.   The green house is on the left of the white house

    5.   The green house's owner drinks coffee

    6.   The person who smokes Pall Mall rears birds

    7.   The owner of the yellow house smokes Dunhill

    8.   The man living in the centre house drinks milk

    9.   The Norwegian lives in the first house

    10.  The person who smokes Marlboro lives next to the one who keeps cats

    11.  The person who keeps horses lives next to the person who smokes Dunhill

    12.  The person who smokes Winfield drinks beer

    13.  The German smokes Rothmans

    14.  The Norwegian lives next to the blue house

    15.  The person who smokes Marlboro has a neighbor who drinks water

I solved the problem in the Scheme dialect of Lisp and I think it's a truly elegant solution. I use the McCarthy (amb ...) operator which results in (I think) the coolest solution EVAR!

(I'm just a tad excited by the solution you see...)

Anyhow, since I'm so happy with the solution, I'm including a image I've annotated to show why the code is so bloody cool:

Annotated Solution

The code runs, magically picks the answer first, then checks to see that the answer it picked was correct!
This is the magic of the McCarthy (amb ...) operator which I call (magic-pick ...) in my code.

The program prints out the answer below:

Program Output

Here is the magic-pick operator in it's entirety!

Magic Pick!

And here is the entire code:

einstein-problem.scm


;; My elegant and utterly cool solution to Einstein's Problem               ;;

;; I use the McCarthy amb operator (called (magic-pick ...) below to pick   ;;

;; the answer *first*, then simply check it against the given hints to      ;;

;; ensure it is correct!                                                    ;;

;;                                                                          ;;

;; http://www.the-brown-dragon.com                                          ;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;; helper.scm

; Define Permuation function (we need permutations for this problem)

(define-for-syntax (filter fn lst)

  (let fl ((l lst)(r '()))

    (if (eq? '() l)

        (reverse r)

        (begin

          (if (fn (car l))

              (fl (cdr l) (cons (car l) r))

              (fl (cdr l) r))))))



(define-for-syntax (remove-elem lst no)

  (filter (lambda (e)

            (set! no (- no 1))

            (not (= -1 no))) lst))



(define-for-syntax (permute lst)

  (if (eq? '() lst) '()

      (letrec ((ml '())(op '())

               (permute-

                (lambda (lst op)

                  (let ((i (length lst)) (nop '()))

                    (if (> i 0)

                        (let l1 ((i i))

                          (when (> i 0)

                                (set! i (- i 1))

                                (set! nop (cons (list-ref lst i) op))

                                (permute- (remove-elem lst i) nop)

                                (l1 i)))

                        (set! ml (cons op ml)))))))

        (permute- lst op)

        ml)))



;Define a recordgroup (which we use to access houses in a street)

(define (find-ndx e lst)

  (let l1 ((i 0))

    (if (< i (length lst))

        (if (equal? (list-ref lst i) e)

            i

            (l1 (+ i 1)))

        #f)))

(define-macro (define-recordgroup . elems)

  (let ((+e (gensym))(+s (gensym)))

    `(begin

       (define-record ,@elems)

       ,@(map (lambda (elem)

                `(begin

                   (define (,(string->symbol

                              (string-append "where-" elem)) ,+s ,+e)

                     (find-ndx ,+e (,(string->symbol

                                      (string-append

                                       (symbol->string (car elems)) "-" elem))

                                    ,+s)))

                   (define (,(string->symbol

                              (string-append "get->" elem)) ,+s ,+e)

                     (list-ref (,(string->symbol

                                  (string-append

                                   (symbol->string (car elems)) "-" elem))

                                ,+s) ,+e))))

              (map symbol->string (cdr elems))))))



;; magic.scm

(define-macro (magic-pick . alts)

  ;;   This operator tries very hard to pick the correct value          ;;

  ;;   from the given list so that the entire program will not fail.    ;;

  ;; @note                                                              ;;

  ;;   In this current definition, it first permutes the given list     ;;

  ;;   because we need it to pick the correct permutation.              ;;

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (let ((+f (gensym))(+s (gensym))(+c (gensym)))

    `(let ((,+f m-fail))

       (call/cc

        (lambda (,+s)

          ,@(map (lambda (alt)

                   `(call/cc

                     (lambda (,+c)

                       (set! m-fail

                             (lambda ()

                               (set! m-fail ,+f)

                               (,+c 'fail)))

                       (set! o (open-output-string))

                       (,+s ',alt))))

                 (permute alts))

          (,+f))))))



(define (m-fail) (error "Magic failed!"))

(define (program-fail) (magic-pick))

(define-macro (assert x) `(if (not ,x) (program-fail)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;; There are five houses in five different colours starting from left to right.

;; In each house lives a person of a different nationality. These owners all

;; drink a certain type of beverage, smoke a certain brand of cigarette and

;; keep a certain type of pet.



        ; Ok. Let's set up a few structures for the problem.

(define-recordgroup house nationality color drinks smokes pet)

        ; Function: (neighbour) : Checks for neighbours.

(define (neighbour h1 h2) (= (abs (- h1 h2)) 1))

        ; Function: (show-street) : Shows the entire street, nicely formatted

(define (show-street s)

  (letrec ((sz (/ 80 (length (house-color s))))

           (dc (lambda (l)

                 (let ((i (floor (/ (- sz (string-length l)) 2))))

                   (let l1 ((i i)) (when (> i 0)

                                         (display " ") (l1 (- i 1))))

                   (display l)

                   (set! i (- (- sz (+ (string-length l) i)) 1))

                   (let l1 ((i i)) (when (> i 0)

                                         (display " ") (l1 (- i 1))))))))

    (map (lambda (l) (map (lambda (x) (dc l)) (house-color s)) (newline))

         '("  ###  "

           "##  o##"

           "## H ##"

           "__/ \\__"))

    (newline)

    (map (lambda (x) (dc (symbol->string x))) (house-color s)) (newline)

    (map (lambda (x) (dc (symbol->string x))) (house-nationality s)) (newline)

    (map (lambda (x) (dc (symbol->string x))) (house-drinks s)) (newline)

    (map (lambda (x) (dc (symbol->string x))) (house-smokes s)) (newline)

    (map (lambda (x) (dc (symbol->string x))) (house-pet s)) (newline)))





        ; BEFORE checking anything, let's (magically) pick the values

        ; of the houses on the street!

(let ((street

       (make-house (magic-pick Swede German Brit Dane Norwegian)

                   (magic-pick White Green Red Blue Yellow)

                   (magic-pick Beer Coffee Milk Water Tea)

                   (magic-pick Dunhill Marlb PallM Rothman Winfld)

                   (magic-pick Dogs Cats Horses Birds Fish)))

      (owner-of-fish #f))





        ; Now for the answer we've been waiting for!



;; The question is: Who is the owner of the pet Fish?

  (set! owner-of-fish (get->nationality street (where-pet street 'Fish)))





        ; Ok. Now that we have magically got the answer, let's check

        ; that the values we have picked are correct against the hints given



;; Hints:

;; 1.      The Brit lives in the red house

  (assert (equal? (get->color street (where-nationality street 'Brit)) 'Red))

;2.      The Swede keeps dogs as pets

  (assert (equal? (get->pet street (where-nationality street 'Swede)) 'Dogs))

;3.      The Dane drinks tea

  (assert (equal? (get->drinks street (where-nationality street 'Dane)) 'Tea))

;4.      The green house is on the left of the white house

  (assert (not (= 0 (where-color street 'White))))

  (assert (neighbour (where-color street 'White) (where-color street 'Green)))

;; 5.      The green house's owner drinks coffee

  (assert (equal? (get->drinks street (where-color street 'Green)) 'Coffee))

;6.      The person who smokes Pall Mall rears birds

  (assert (equal? (get->pet street (where-smokes street 'PallM)) 'Birds))

;7.      The owner of the yellow house smokes Dunhill

  (assert (equal? (get->smokes street (where-color street 'Yellow)) 'Dunhill))

;8.      The man living in the centre house drinks milk

  (assert (equal? (get->drinks street 2) 'Milk))

;9.      The Norwegian lives in the first house

  (assert (equal? (get->nationality street 0) 'Norwegian))

;10.  The person who smokes Marlboro lives next to the one who keeps cats

  (assert (neighbour (where-smokes street 'Marlb) (where-pet street 'Cats)))

;11.  The person who keeps horses lives next to the person who smokes Dunhill

  (assert (neighbour (where-pet street 'Horses) (where-smokes street 'Dunhill)))

;12.  The person who smokes Winfield drinks beer

  (assert (equal? (get->smokes street (where-drinks street 'Beer)) 'Winfld))

;13.  The German smokes Rothmans

  (assert (equal? (get->smokes street (where-nationality street 'German))

                  'Rothman))

;14.  The Norwegian lives next to the blue house

  (assert (neighbour (where-nationality street 'Norwegian)

                     (where-color street 'Blue)))

;15.  The person who smokes Marlboro has a neigbor who drinks water

  (assert (neighbour (where-smokes street 'Marlb) (where-drinks street 'Water)))



        ; It all checks out - show our answer

  (newline)(show-street street)(newline)

  (display "The owner of the Fish is the ")(display owner-of-fish)(display "!")

  (newline)(newline))

the brown-dragon blog

An Elegant (and utterly amazing) solution to Einstein's Problem

2008-12-21

Other Posts