Zebra puzzle: Difference between revisions
→Tcl: Added implementation |
→{{header|Tcl}}: Significantly faster version that uses constant binding |
||
Line 657: | Line 657: | ||
<lang tcl>package require struct::list |
<lang tcl>package require struct::list |
||
# Implements the constants by binding them directly into the named procedures. |
|||
⚫ | |||
# This is much faster than the alternatives! |
|||
⚫ | |||
proc initConstants {args} { |
|||
⚫ | |||
global {} |
|||
⚫ | |||
set remap {} |
|||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
upvar 0 $class c; set i -1 |
|||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
⚫ | |||
set i -1 |
|||
⚫ | |||
⚫ | |||
} |
|||
foreach procedure $args { |
|||
proc $procedure [info args $procedure] \ |
|||
[string map $remap [info body $procedure]] |
|||
} |
|||
} |
} |
||
proc isPossible {number color drink smoke pet} { |
proc isPossible {number color drink smoke pet} { |
||
global Number Color Drink Smoke Pet Nation |
|||
if {[llength $number] && [lindex $number $Nation(Norwegian)] != $Number(One)} { |
if {[llength $number] && [lindex $number $Nation(Norwegian)] != $Number(One)} { |
||
return false |
return false |
||
Line 759: | Line 768: | ||
} |
} |
||
} |
} |
||
initConstants isPossible |
|||
main</lang> |
main</lang> |
||
{{out}} |
{{out}} |
Revision as of 14:30, 24 May 2012
You are encouraged to solve this task according to the task description, using any language you may know.
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?
Additionally, list the solution for all the houses. Optionally, show the solution is unique.
cf. Dinesman's multiple-dwelling problem
Ada
Not the prettiest Ada, but its simple and very fast. Similar to my Dinesman's code, uses enums to keep things readable. <lang Ada>with Ada.Text_IO; use Ada.Text_IO; procedure Zebra is
type Content is (Beer, Coffee, Milk, Tea, Water, Danish, English, German, Norwegian, Swedish, Blue, Green, Red, White, Yellow, Blend, BlueMaster, Dunhill, PallMall, Prince, Bird, Cat, Dog, Horse, Zebra); type Test is (Drink, Person, Color, Smoke, Pet); type House is (One, Two, Three, Four, Five); type Street is array (Test'Range, House'Range) of Content; type Alley is access all Street;
procedure Print (mat : Alley) is begin for H in House'Range loop Put(H'Img&": "); for T in Test'Range loop Put(T'Img&"="&mat(T,H)'Img&" "); end loop; New_Line; end loop; end Print;
function FinalChecks (mat : Alley) return Boolean is function Diff (A, B : Content; CA , CB : Test) return Integer is begin for H1 in House'Range loop for H2 in House'Range loop if mat(CA,H1) = A and mat(CB,H2) = B then return House'Pos(H1) - House'Pos(H2); end if; end loop; end loop; end Diff; begin if abs(Diff(Norwegian, Blue, Person, Color)) = 1 and Diff(Green, White, Color, Color) = -1 and abs(Diff(Horse, Dunhill, Pet, Smoke)) = 1 and abs(Diff(Water, Blend, Drink, Smoke)) = 1 and abs(Diff(Blend, Cat, Smoke, Pet)) = 1 then return True; end if; return False; end FinalChecks;
function Constrained (mat : Alley; atest : Natural) return Boolean is begin -- Tests seperated into levels for speed, not strictly necessary -- As such, the program finishes in around ~0.02s case Test'Val (atest) is when Drink => -- Drink if mat (Drink, Three) /= Milk then return False; end if; return True; when Person => -- Drink+Person for H in House'Range loop if (mat(Person,H) = Norwegian and H /= One) or (mat(Person,H) = Danish and mat(Drink,H) /= Tea) then return False; end if; end loop; return True; when Color => -- Drink+People+Color for H in House'Range loop if (mat(Person,H) = English and mat(Color,H) /= Red) or (mat(Drink,H) = Coffee and mat(Color,H) /= Green) then return False; end if; end loop; return True; when Smoke => -- Drink+People+Color+Smoke for H in House'Range loop if (mat(Color,H) = Yellow and mat(Smoke,H) /= Dunhill) or (mat(Smoke,H) = BlueMaster and mat(Drink,H) /= Beer) or (mat(Person,H) = German and mat(Smoke,H) /= Prince) then return False; end if; end loop; return True; when Pet => -- Drink+People+Color+Smoke+Pet for H in House'Range loop if (mat(Person,H) = Swedish and mat(Pet,H) /= Dog) or (mat(Smoke,H) = PallMall and mat(Pet,H) /= Bird) then return False; end if; end loop; return FinalChecks(mat); -- Do the next-to checks end case; end Constrained;
procedure Solve (mat : Alley; t, n : Natural) is procedure Swap (I, J : Natural) is temp : constant Content := mat (Test'Val (t), House'Val (J)); begin mat (Test'Val (t), House'Val (J)) := mat (Test'Val (t), House'Val (I)); mat (Test'Val (t), House'Val (I)) := temp; end Swap; begin if n = 1 and Constrained (mat, t) then -- test t passed if t < 4 then Solve (mat, t + 1, 5); -- Onto next test else Print (mat); return; -- Passed and t=4 means a solution end if; end if; for i in 0 .. n - 1 loop -- The permutations part Solve (mat, t, n - 1); if n mod 2 = 1 then Swap (0, n - 1); else Swap (i, n - 1); end if; end loop; end Solve;
myStreet : aliased Street; myAlley : constant Alley := myStreet'Access;
begin
for i in Test'Range loop for j in House'Range loop -- Init Matrix myStreet (i,j) := Content'Val(Test'Pos(i)*5 + House'Pos(j)); end loop; end loop; Solve (myAlley, 0, 5); -- start at test 0 with 5 options
end Zebra;</lang>
- Output:
ONE: DRINK=WATER PERSON=NORWEGIAN COLOR=YELLOW SMOKE=DUNHILL PET=CAT TWO: DRINK=TEA PERSON=DANISH COLOR=BLUE SMOKE=BLEND PET=HORSE THREE: DRINK=MILK PERSON=ENGLISH COLOR=RED SMOKE=PALLMALL PET=BIRD FOUR: DRINK=COFFEE PERSON=GERMAN COLOR=GREEN SMOKE=PRINCE PET=ZEBRA FIVE: DRINK=BEER PERSON=SWEDISH COLOR=WHITE SMOKE=BLUEMASTER PET=DOG
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,englishman,_,_,_),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, englishman, birds, milk, pallmall) h(green, german, zebra, coffee, prince) h(white, swede, dog, beer, bluemaster) german No more solutions.
Works with SWI-Prolog. More verbose line-for-line translation of the specification works as well.
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
Tcl
<lang tcl>package require struct::list
- Implements the constants by binding them directly into the named procedures.
- This is much faster than the alternatives!
proc initConstants {args} {
global {} set remap {} foreach {class elems} {
Number {One Two Three Four Five} Color {Red Green Blue White Yellow} Drink {Milk Coffee Water Beer Tea} Smoke {PallMall Dunhill Blend BlueMaster Prince} Pet {Dog Cat Horse Bird Zebra} Nation {British Swedish Danish Norwegian German}
} {
set i -1 foreach e $elems {lappend remap "\$${class}($e)" [incr i]} set ($class) $elems
} foreach procedure $args {
proc $procedure [info args $procedure] \ [string map $remap [info body $procedure]]
}
}
proc isPossible {number color drink smoke pet} {
if {[llength $number] && [lindex $number $Nation(Norwegian)] != $Number(One)} {
return false
} elseif {[llength $color] && [lindex $color $Nation(British)] != $Color(Red)} {
return false
} elseif {[llength $drink] && [lindex $drink $Nation(Danish)] != $Drink(Tea)} {
return false
} elseif {[llength $smoke] && [lindex $smoke $Nation(German)] != $Smoke(Prince)} {
return false
} elseif {[llength $pet] && [lindex $pet $Nation(Swedish)] != $Pet(Dog)} {
return false
}
if {!([llength $number] && [llength $color] && [llength $drink] && [llength $smoke] && [llength $pet])} {
return true
}
for {set i 0} {$i < 5} {incr i} {
if {[lindex $color $i] == $Color(Green) && [lindex $drink $i] != $Drink(Coffee)} { return false } elseif {[lindex $smoke $i] == $Smoke(PallMall) && [lindex $pet $i] != $Pet(Bird)} { return false } elseif {[lindex $color $i] == $Color(Yellow) && [lindex $smoke $i] != $Smoke(Dunhill)} { return false } elseif {[lindex $number $i] == $Number(Three) && [lindex $drink $i] != $Drink(Milk)} { return false } elseif {[lindex $smoke $i] == $Smoke(BlueMaster) && [lindex $drink $i] != $Drink(Beer)} { return false } elseif {[lindex $color $i] == $Color(Blue) && [lindex $number $i] != $Number(Two)} { return false }
for {set j 0} {$j < 5} {incr j} { if {[lindex $color $i] == $Color(Green) && [lindex $color $j] == $Color(White) && [lindex $number $j] - [lindex $number $i] != 1} { return false }
set diff [expr {abs([lindex $number $i] - [lindex $number $j])}] if {[lindex $smoke $i] == $Smoke(Blend) && [lindex $pet $j] == $Pet(Cat) && $diff != 1} { return false } elseif {[lindex $pet $i] == $Pet(Horse) && [lindex $smoke $j] == $Smoke(Dunhill) && $diff != 1} { return false } elseif {[lindex $smoke $i] == $Smoke(Blend) && [lindex $drink $j] == $Drink(Water) && $diff != 1} { return false } }
}
return true
}
proc showRow {t data} {
upvar #0 ($t) elems puts [format "%6s: %12s%12s%12s%12s%12s" $t \
[lindex $elems [lindex $data 0]] \ [lindex $elems [lindex $data 1]] \ [lindex $elems [lindex $data 2]] \ [lindex $elems [lindex $data 3]] \ [lindex $elems [lindex $data 4]]] }
proc main {} {
set perms [struct::list permutations {0 1 2 3 4}] foreach number $perms {
if {![isPossible $number {} {} {} {}]} continue foreach color $perms { if {![isPossible $number $color {} {} {}]} continue foreach drink $perms { if {![isPossible $number $color $drink {} {}]} continue foreach smoke $perms { if {![isPossible $number $color $drink $smoke {}]} continue foreach pet $perms { if {[isPossible $number $color $drink $smoke $pet]} { puts "Found a solution:" showRow Nation {0 1 2 3 4} showRow Number $number showRow Color $color showRow Drink $drink showRow Smoke $smoke showRow Pet $pet puts "" } } } } }
}
}
initConstants isPossible main</lang>
- Output:
Found a solution: Nation: British Swedish Danish Norwegian 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 Zebra