Zebra puzzle
The Zebra puzzle, a.k.a. Einstein's Riddle, is a logic puzzle which is to be solved programmatically. It has several variants, one of them this:
- 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?
cf. Dinesman's multiple-dwelling problem
C
I'll be the first to admit the following doesn't quite look like a C program. It's in fact in Perl, which outputs a C source, which in turn solves the puzzle. If you think this is long, wait till you see the C it writes. <lang perl>#!/usr/bin/perl
use utf8; no strict;
my (%props, %name, @pre, @conds, @works, $find_all_solutions);
sub do_consts { local $"; for my $p (keys %props) { my @s = @{ $props{$p} };
$" = ", "; print "enum { ${p}_none = 0, @s };\n";
$" = '", "'; print "char *string_$p [] = { \"###\", \"@s\" };\n\n"; } print "#define FIND_BY(p) \\ int find_by_##p(int v) { \\ int i; \\ for (i = 0; i < N_ITEMS; i++) \\ if (house[i].p == v) return i; \\ return -1; }\n";
print "FIND_BY($_)" for (keys %props);
local $" = ", "; my @k = keys %props;
my $sl = 0; for (keys %name) { if (length > $sl) { $sl = length } }
my $fmt = ("%".($sl + 1)."s ") x @k; my @arg = map { "string_$_"."[house[i].$_]" } @k; print << "SNIPPET"; int work0(void) { int i; for (i = 0; i < N_ITEMS; i++) printf("%d $fmt\\n", i, @arg); puts(\"\"); return 1; } SNIPPET
}
sub setprops { %props = @_; my $l = 0; my @k = keys %props; for my $p (@k) { my @s = @{ $props{$p} };
if ($l && $l != @s) { die "bad length @s"; } $l = @s; $name{$_} = $p for @s; } local $" = ", "; print "#include <stdio.h>
- define N_ITEMS $l
struct item_t { int @k; } house[N_ITEMS] = Template:0;\n"; }
sub pair { my ($c1, $c2, $diff) = @_; $diff //= [0]; $diff = [$diff] unless ref $diff;
push @conds, [$c1, $c2, $diff]; }
sub make_conditions { my $idx = 0; my $return1 = $find_all_solutions ? "" : "return 1"; print "
- define TRY(a, b, c, d, p, n) \\
if ((b = a d) >= 0 && b < N_ITEMS) { \\ if (!house[b].p) { \\ house[b].p = c; \\ if (n()) $return1; \\ house[b].p = 0; \\ }} ";
while (@conds) { my ($c1, $c2, $diff) = @{ pop @conds }; my $p2 = $name{$c2} or die "bad prop $c2";
if ($c1 =~ /^\d+$/) { push @pre, "house[$c1].$p2 = $c2;"; next; }
my $p1 = $name{$c1} or die "bad prop $c1"; my $next = "work$idx"; my $this = "work".++$idx;
print " /* condition pair($c1, $c2, [@$diff]) */ int $this(void) { int a = find_by_$p1($c1); int b = find_by_$p2($c2); if (a != -1 && b != -1) { switch(b - a) { "; print "case $_: " for @$diff; print "return $next(); default: return 0; }\n } if (a != -1) {"; print "TRY(a, b, $c2, +($_), $p2, $next);" for @$diff; print " return 0; } if (b != -1) {"; print "TRY(b, a, $c1, -($_), $p1, $next);" for @$diff; print " return 0; } /* neither condition is set; try all possibles */ for (a = 0; a < N_ITEMS; a++) { if (house[a].$p1) continue; house[a].$p1 = $c1; ";
print "TRY(a, b, $c2, +($_), $p2, $next);" for @$diff; print " house[a].$p1 = 0; } return 0; }"; }
print "int main() { @pre return !work$idx(); }"; }
sub make_c { do_consts; make_conditions; }
- ---- above should be generic for all similar puzzles ---- #
- ---- below: per puzzle setup ---- #
- property names and values
setprops ( 'nationality' # Svensk n. a Swede, not a swede (kålrot). # AEnglisk (from middle Viking "Æŋløsåksen") n. a Brit. => [ qw(Deutsch Svensk Norske Danske AEnglisk) ], 'pet' => [ qw(birds dog horse zebra cats) ], 'drink' => [ qw(water tea milk beer coffee) ], 'smoke' => [ qw(dunhill blue_master prince blend pall_mall) ], 'color' => [ qw(red green yellow white blue) ] );
- constraints
pair(AEnglisk, red); pair(Svensk, dog); pair(Danske, tea); pair(green, white, 1); # "to the left of" can mean either 1 or -1: ambiguous pair(coffee, green); pair(pall_mall, birds); pair(yellow, dunhill); pair(2, milk); pair(0, Norske); pair(blend, cats, [-1, 1]); pair(horse, dunhill, [-1, 1]); pair(blue_master, beer); # Nicht das Deutsche Bier trinken? Huh. pair(Deutsch, prince); pair(Norske, blue, [-1, 1]); pair(water, blend, [-1, 1]);
- "zebra lives *somewhere* relative to the Brit". It has no effect on
- the logic. It's here just to make sure the code will insert a zebra
- somewhere in the table (after all other conditions are met) so the
- final print-out shows it. (the C code can be better structured, but
- meh, I ain't reading it, so who cares).
pair(zebra, AEnglisk, [ -4 .. 4 ]);
- write C code. If it's ugly to you: I didn't write; Perl did.
make_c;</lang>
output (ran as perl test.pl | gcc -Wall -x c -; ./a.out):
0 dunhill cats yellow water Norske 1 blend horse blue tea Danske 2 pall_mall birds red milk AEnglisk 3 prince zebra green coffee Deutsch 4 blue_master dog white beer Svensk
Perl
Basically the same idea as C, though of course it's much easier to have Perl generate Perl code. <lang perl>#!/usr/bin/perl
use utf8; use strict; binmode STDOUT, ":utf8";
my (@tgt, %names); sub setprops { my %h = @_; my @p = keys %h; for my $p (@p) { my @v = @{ $h{$p} }; @tgt = map(+{idx=>$_-1, map{ ($_, undef) } @p}, 1 .. @v) unless @tgt; $names{$_} = $p for @v; } }
my $solve = sub { for my $i (@tgt) { printf("%12s", ucfirst($i->{$_} // "¿Qué?")) for reverse sort keys %$i; print "\n"; } "there is only one" # <--- change this to a false value to find all solutions (if any) };
sub pair { my ($a, $b, @v) = @_; if ($a =~ /^(\d+)$/) { $tgt[$1]{ $names{$b} } = $b; return; }
@v = (0) unless @v; my %allowed; $allowed{$_} = 1 for @v;
my ($p1, $p2) = ($names{$a}, $names{$b});
my $e = $solve; $solve = sub { # <--- sorta like how TeX \let...\def macro my ($x, $y);
($x) = grep { $_->{$p1} eq $a } @tgt; ($y) = grep { $_->{$p2} eq $b } @tgt;
$x and $y and return $allowed{ $x->{idx} - $y->{idx} } && $e->();
my $try_stuff = sub { my ($this, $p, $v, $sign) = @_; for (@v) { my $i = $this->{idx} + $sign * $_; next unless $i >= 0 && $i < @tgt && !$tgt[$i]{$p}; local $tgt[$i]{$p} = $v; $e->() and return 1; } return };
$x and return $try_stuff->($x, $p2, $b, 1); $y and return $try_stuff->($y, $p1, $a, -1);
for $x (@tgt) { next if $x->{$p1}; local $x->{$p1} = $a; $try_stuff->($x, $p2, $b, 1) and return 1; } }; }
- ---- above should be generic for all similar puzzles ---- #
- ---- below: per puzzle setup ---- #
- property names and values
setprops ( # Svensk n. a Swede, not a swede (kålrot). # AEnglisk (from middle Viking "Æŋløsåksen") n. a Brit. 'Who' => [ qw(Deutsch Svensk Norske Danske AEnglisk) ], 'Pet' => [ qw(birds dog horse zebra cats) ], 'Drink' => [ qw(water tea milk beer coffee) ], 'Smoke' => [ qw(dunhill blue_master prince blend pall_mall) ], 'Color' => [ qw(red green yellow white blue) ] );
- constraints
pair qw( AEnglisk red ); pair qw( Svensk dog ); pair qw( Danske tea ); pair qw( green white 1 ); # "to the left of" can mean either 1 or -1: ambiguous pair qw( coffee green ); pair qw( pall_mall birds ); pair qw( yellow dunhill ); pair qw( 2 milk ); pair qw( 0 Norske ); pair qw( blend cats -1 1 ); pair qw( horse dunhill -1 1 ); pair qw( blue_master beer ); # Nicht das Deutsche Bier trinken? Huh. pair qw( Deutsch prince ); pair qw( Norske blue -1 1 ); pair qw( water blend -1 1 );
$solve->();</lang>
Incidentally, the same logic can be used to solve the dwelling problem, if somewhat awkwardly: <lang perl>...
- property names and values
setprops 'Who' => [ qw(baker cooper fletcher miller smith) ], 'Level' => [ qw(one two three four five) ];
- constraints
pair qw(0 one); pair qw(1 two); pair qw(2 three); pair qw(3 four); pair qw(4 five); pair qw(baker five -4 -3 -2 -1 1 2 3 4); pair qw(cooper one -4 -3 -2 -1 1 2 3 4); pair qw(fletcher one -4 -3 -2 -1 1 2 3 4); pair qw(fletcher five -4 -3 -2 -1 1 2 3 4); pair qw(miller cooper -1 -2 -3 -4); pair qw(smith fletcher 4 3 2 -2 -3 -4); pair qw(cooper fletcher 4 3 2 -2 -3 -4);
$solve->();</lang>
PicoLisp
<lang PicoLisp>(be match (@House @Person @Drink @Pet @Cigarettes)
(permute (red blue green yellow white) @House) (left-of @House white @House green)
(permute (Norwegian English Swede German Dane) @Person) (has @Person English @House red) (equal @Person (Norwegian . @)) (next-to @Person Norwegian @House blue)
(permute (tea coffee milk beer water) @Drink) (has @Drink tea @Person Dane) (has @Drink coffee @House green) (equal @Drink (@ @ milk . @))
(permute (dog birds cats horse zebra) @Pet) (has @Pet dog @Person Swede)
(permute (Pall-Mall Dunhill Blend Blue-Master Prince) @Cigarettes) (has @Cigarettes Pall-Mall @Pet birds) (has @Cigarettes Dunhill @House yellow) (next-to @Cigarettes Blend @Pet cats) (next-to @Cigarettes Dunhill @Pet horse) (has @Cigarettes Blue-Master @Drink beer) (has @Cigarettes Prince @Person German)
(next-to @Drink water @Cigarettes Blend) )
(be has ((@A . @X) @A (@B . @Y) @B)) (be has ((@ . @X) @A (@ . @Y) @B)
(has @X @A @Y @B) )
(be right-of ((@A . @X) @A (@ @B . @Y) @B)) (be right-of ((@ . @X) @A (@ . @Y) @B)
(right-of @X @A @Y @B) )
(be left-of ((@ @A . @X) @A (@B . @Y) @B)) (be left-of ((@ . @X) @A (@ . @Y) @B)
(left-of @X @A @Y @B) )
(be next-to (@X @A @Y @B) (right-of @X @A @Y @B)) (be next-to (@X @A @Y @B) (left-of @X @A @Y @B))</lang> Test: <lang PicoLisp>(pilog '((match @House @Person @Drink @Pet @Cigarettes))
(let Fmt (-8 -11 -8 -7 -11)
(tab Fmt "HOUSE" "PERSON" "DRINKS" "HAS" "SMOKES")
(mapc '(@ (pass tab Fmt))
@House @Person @Drink @Pet @Cigarettes ) ) )</lang>
Output:
HOUSE PERSON DRINKS HAS SMOKES yellow Norwegian water cats Dunhill blue Dane tea horse Blend red English milk birds Pall-Mall green German coffee zebra Prince white Swede beer dog Blue-Master
Prolog
In Prolog we can specify the domain by selecting elements from it, making mutually exclusive choices for efficiency:
<lang Prolog>select([A|As],S):- select(A,S,S1),select(As,S1). select([],_).
next_to(A,B,C):- left_of(A,B,C),left_of(B,A,C). left_of(A,B,C):- append(_,[A,B|_],C).
zebra(Owns, HS):- % color,nation,pet,drink,smokes
HS = [h(_,norwegian,_,_,_),_,h(_,_,_,milk,_),_,_],
select( [h(red,english,_,_,_),h(_,swede,dog,_,_),h(_,dane,_,tea,_),
h(_,german,_,_,prince)], HS),
select( [h(_,_,birds,_,pallmall),h(yellow,_,_,_,dunhill),
h(_,_,_,beer,bluemaster)], HS),
left_of( h(green,_,_,coffee,_),h(white,_,_,_,_), HS),
next_to( h(_,_,_,_,dunhill),h(_,_,horse,_,_), HS),
next_to( h(_,_,_,_,blend), h(_,_,cats, _,_), HS),
next_to( h(_,_,_,_,blend) ,h(_,_,_,water,_), HS),
next_to( h(_,norwegian,_,_,_), h(blue,_,_,_,_), HS),
member( h(_,Owns,zebra,_,_), HS).
- - zebra(Who, HS), maplist(writeln,HS), nl, write(Who), nl, nl, fail
;
write('No more solutions.').</lang>
Output:
h(yellow, norwegian, cats, water, dunhill) h(blue, dane, horse, tea, blend) h(red, english, birds, milk, pallmall) h(green, german, zebra, coffee, prince) h(white, swede, dog, beer, bluemaster) german No more solutions.
Works with SWI-Prolog.
Python
<lang python>from itertools import permutations import psyco psyco.full()
class Number:elems= "One Two Three Four Five".split() class Color: elems= "Red Green Blue White Yellow".split() class Drink: elems= "Milk Coffee Water Beer Tea".split() class Smoke: elems= "PallMall Dunhill Blend BlueMaster Prince".split() class Pet: elems= "Dog Cat Fish Horse Bird".split() class Nation:elems= "British Swedish Danish Norvegian German".split()
for c in (Number, Color, Drink, Smoke, Pet, Nation):
for i, e in enumerate(c.elems): exec "%s.%s = %d" % (c.__name__, e, i)
def is_possible(number, color, drink, smoke, pet):
if number and number[Nation.Norvegian] != Number.One: return False if color and color[Nation.British] != Color.Red: return False if drink and drink[Nation.Danish] != Drink.Tea: return False if smoke and smoke[Nation.German] != Smoke.Prince: return False if pet and pet[Nation.Swedish] != Pet.Dog: return False
if not number or not color or not drink or not smoke or not pet: return True
for i in xrange(5):
if color[i] == Color.Green and drink[i] != Drink.Coffee:
return False
if smoke[i] == Smoke.PallMall and pet[i] != Pet.Bird:
return False
if color[i] == Color.Yellow and smoke[i] != Smoke.Dunhill:
return False
if number[i] == Number.Three and drink[i] != Drink.Milk:
return False
if smoke[i] == Smoke.BlueMaster and drink[i] != Drink.Beer:
return False
if color[i] == Color.Blue and number[i] != Number.Two:
return False
for j in xrange(5):
if (color[i] == Color.Green and
color[j] == Color.White and
number[j] - number[i] != 1):
return False
diff = abs(number[i] - number[j])
if smoke[i] == Smoke.Blend and pet[j] == Pet.Cat and diff != 1:
return False
if pet[i]==Pet.Horse and smoke[j]==Smoke.Dunhill and diff != 1:
return False
if smoke[i]==Smoke.Blend and drink[j]==Drink.Water and diff!=1:
return False
return True
def show_row(t, data):
print "%6s: %12s%12s%12s%12s%12s" % ( t.__name__, t.elems[data[0]], t.elems[data[1]], t.elems[data[2]], t.elems[data[3]], t.elems[data[4]])
def main():
perms = list(permutations(range(5)))
for number in perms:
if is_possible(number, None, None, None, None):
for color in perms:
if is_possible(number, color, None, None, None):
for drink in perms:
if is_possible(number, color, drink, None, None):
for smoke in perms:
if is_possible(number, color, drink, smoke, None):
for pet in perms:
if is_possible(number, color, drink, smoke, pet):
print "Found a solution:"
show_row(Nation, range(5))
show_row(Number, number)
show_row(Color, color)
show_row(Drink, drink)
show_row(Smoke, smoke)
show_row(Pet, pet)
print
main()</lang> Output:
Found a solution: Nation: British Swedish Danish Norvegian German Number: Three Five Two One Four Color: Red White Blue Yellow Green Drink: Milk Beer Tea Water Coffee Smoke: PallMall BlueMaster Blend Dunhill Prince Pet: Bird Dog Horse Cat Fish