Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > comp.lang.forth > #59010

Rosetta: Zebra puzzle

Show all headers | View raw

> There are five houses.
> The English man lives in the red house.
> The Swede has a dog.
> The Dane drinks tea.
> The green house is immediately to the left of the white house.
> They drink coffee in the green house.
> The man who smokes Pall Mall has birds.
> In the yellow house they smoke Dunhill.
> In the middle house they drink milk.
> The Norwegian lives in the first house.
> The man who smokes Blend lives in the house next to the house with cats.
> In a house next to the house where they have a horse, they smoke Dunhill.
> The man who smokes Blue Master drinks beer.
> The German smokes Prince.
> The Norwegian lives next to the blue house.
> They drink water in a house next to the house where they smoke Blend. 
> 
> 
> The question is, who owns the zebra? 
> 
> Additionally, list the solution for all the houses.
> Optionally, show the solution is unique.


(use amb amb-extras)
(use combinatorics)
(use srfi-42)

(define (build-permutations things predicate)
  (ordered-subset-fold
    (lambda (xs accum)
      (if (predicate xs) (cons xs accum) accum))
    '()
    things))

(define (find-index el lst)
  (list-index (lambda(x) (eqv? x el)) lst))

(define (indices e1 list1 e2 list2)
  (list (find-index e1 list1) (find-index e2 list2)))

(define (same-house? . args)
  (apply = (apply indices args)))

(define (next-to? . args)
  (= 1 (abs (apply - (apply indices args)))))

(define (zebra-puzzle)
  (define solutions
    (amb-collect
      (begin
        (define men (choose
          (build-permutations '(danish english german norwegian swedish)
            (lambda (xs) (eqv? 'norwegian (car xs))))))
        (define drinks (choose
          (build-permutations '(beer coffee milk tea water)
            (lambda (xs) (eqv? 'milk (list-ref xs 2))))))
        (define colors (choose
          (build-permutations '(blue green red white yellow)
            (lambda (xs) (= 1 (apply - (indices 'white xs 'green xs)))))))
        (amb-assert (same-house? 'danish men  'tea drinks))
        (amb-assert (same-house? 'english men  'red colors))
        (amb-assert (same-house? 'coffee drinks  'green colors))
        (amb-assert (next-to? 'norwegian men  'blue colors))
        (define smokes (choose
          (build-permutations '(blend blue-master dunhill pall-mall prince)
            (constantly #t))))
        (amb-assert (same-house? 'german men 'prince smokes))
        (amb-assert (same-house? 'dunhill smokes  'yellow colors))
        (amb-assert (same-house? 'blue-master smokes  'beer drinks))
        (amb-assert (next-to? 'water drinks  'blend smokes))
        (define pets (choose
          (build-permutations '(birds cats dog horse zebra)
            (constantly #t))))
        (amb-assert (same-house? 'swedish men 'dog pets))
        (amb-assert (same-house? 'pall-mall smokes 'birds pets))
        (amb-assert (next-to? 'cats pets  'blend smokes))
        (amb-assert (next-to? 'horse pets  'dunhill smokes))
        (list pets men drinks colors smokes))))
  (print "All possible solutions:\n")
  (do-ec (: solution solutions)
    (begin
      (do-ec (: house (index i) (apply zip solution))
        (print "House " i ". " house))
      (print))))

(zebra-puzzle)

All possible solutions:

House 0. (cats norwegian water yellow dunhill)
House 1. (horse danish tea blue blend)
House 2. (birds english milk red pall-mall)
House 3. (zebra german coffee green prince)
House 4. (dog swedish beer white blue-master)

In Forth?


-- 
Jews totally run Hollywood....  But I don't care if Americans think we're
running the news media, Hollywood, Wall Street, or the government.  I just care
that we get to keep running them. --- Joel Stein
articles.latimes.com/2008/dec/19/opinion/oe-stein19
archive.org/download/DavidDukeTv/DoJewsControlTheMediaTheLaTimesSaysYes.flv

Back to comp.lang.forth | Previous | Next | Find similar | Unroll thread

Thread

Rosetta: Zebra puzzle "Robert L." <No_spamming@noWhere_7073.org> - 2017-05-10 20:48 +0000

csiph-web