#!/usr/bin/perl -w
use strict;
our $VERSION = 0.3;
# -----------------------------------------------
# logik.pl 0.3
# Einstein's Puzzle
# I'd be glad about any feedback!
# (c) Tina Müller <me _at_ tinita.de>
# Mon, Jan 14th 2003
# -----------------------------------------------
# Ab hier editieren - edit from here
#
my %hash = (
	# Kategorie => [ Liste der Werte]
	# Hinweis: Die gesamte Liste der Werte muss
	# eindeutig sein, d.h. mehere Kategorien
	# mit Zahlenlisten wie "pos" sind nicht möglich.
	#
	# Werte dürfen keine ":" enthalten!

	# Category => [ list of values]
	# note: the list of all values must be unique,
	# so more than one list of "positions" are
	# not possible
	# (feel free to send a bugfix =)
	# values must not contain ":"!
	nat => [qw(bri dan swe ger nor)],
	col => [qw(red green blue yellow white)],
	ani => [qw(dog bird horse cat fish)],
	cig => [qw(pallmall dunhill marlboro winfield mild)],
	pos => [1..5],
	drink => [qw(tea coffee milk beer water)],
);

# Nach welcher Kategorie soll ausgegeben werden?
# Position des Hauses

# The output should be ordered by category $CAT
my $CAT = "pos";

# Stoppe Algorithmus, wenn MAX erreicht ist, d.h. wenn
# das Rätsel gelöst ist
# Stop algorithm, when all (MAX) values are found.
# Please type in the correct value for MAX
# MAX = (count of categories -1) * count of values in one category
#     = (keys %hash -1)            *   @{$hash{pos}}
#     =        5                   *        5
use constant  MAX => 25;


# Nur bei Rätseln mit Positionen und Regeln wie "X steht links neben Y"
# Only with puzzle's that have rules like "X is exactly one left of Y"
my @pos = (
	# [VALUE VALUE  EXACT_POS @LIST_OF POS]

	# "Das grüne Hause steht genau  links vom weissen"
	# die 1 steht für "genau links", die -1 für "links"
	# "Green house is exactly one left of the white"
	# 1 stands for "exactly left", -1 stands for "one left"
	[qw(green white    1 -1)],

	# die 0 steht für "neben" (also bei seiten möglich).
	# die -1 und 1 für die möglichen Positionen
	# 0 stands for "beside" (both sides are possible).
	# -1 and 1 stand for the possible positions
	[qw(marlboro cat   0 -1 1)],
	[qw(horse dunhill  0 -1 1)],
	[qw(blue nor       0 -1 1)],
	[qw(marlboro water 0 -1 1)],

	# so e.g. "red house is *somewhere* left of blue house"
	# would be:
	# [ qw(red blue  0   -1 -2 -3 -4) ]
);
my @pairs = (
	# "Der Brite wohnt im roten Haus." Die eins steht also für positiv.
	# "The british lives in the red house." so 1 stands for positive.
	[qw(bri red 1)],
	[qw(swe dog 1)],
	[qw(dan tea 1)],
	[qw(green coffee 1)],
	[qw(pallmall bird 1)],
	[qw(3 milk 1)],
	[qw(yellow dunhill 1)],
	[qw(nor 1 1)],
	# Der Marlboro-Raucher hat einen Nachbarn mit einer Katze =>
	# Also hat er selbst keine Katze. 0 steht für negativ.
	# "The Marlboro-Smoker has a neighbor with a cat. =>
	# So he himself doesn't have one, therefor the "0"
	[qw(marlboro cat 0)],
	[qw(horse dunhill 0)],
	[qw(winfield beer 1)],
	[qw(blue nor 0)],
	[qw(ger mild 1)],
	[qw(marlboro water 0)],
	[qw(green 5 0)],
	[qw(white 1 0)],
);

# So, fertig mit editieren. Hier geht es los.
# Ok, we're ready to go now.
# ----------------------------------------------

my (%res,%rev);
get_result();
print_nice();

sub get_result {
	# Reverse-Lookup-Tabelle (zu welcher Kategorie gehört "fish"? => "ani")
	for my $key (keys %hash) {
		$rev{$_}=$key for (@{$hash{$key}})
	}
	init();
	for (0..20) {
		# i don't know if 20 is sufficient for all puzzles. increase if necessary
		# it's just a limit for unsolvable puzzles; they might run endless without
		# that limit
		syncme();
		last if got_all();
	}
}
sub got_all {
	my $c = 0;
	for my $i (grep {m/^$CAT:/o} keys %res) {
		$c+= grep {$res{$i}->{$_} eq 1} keys %{$res{$i}}
	}
	$c == MAX;
}
sub syncme {
	# if defined "nat:bri" => "drink:milk",
	# set "drink:milk" => "nat:bri" to the same value
	for (equals()) {
		my ($i,$j) = @$_;
		foreach my $key (keys %{$res{$i}}) {
			# if it's defined and not the same category as $j
			if (defined(my $new=$res{$i}->{$key})
				&& ((split /:/, $j)[0] ne (split /:/, $key)[0])) {
				$res{$j}->{$key} = $new;
			}
		}
	}
	synchronize_equals();
	position();
}
sub synchronize_equals {
	for my $i (keys %res) {
		for my $j (keys %{$res{$i}}) {
			($res{$i}->{$j} = $res{$j}->{$i}),next if exists $res{$j}->{$i};
			$res{$j}->{$i} = $res{$i}->{$j};
		}
	}
}
sub equals {
	my @e;
	foreach my $i (keys %res) {
		my %count;
		my $h = $res{$i};
		foreach my $j (keys %$h) {
			my ($cat,$v) = split/:/,$j;
			if ($h->{$j}==1) {
				push @e, [$i,$j];
				$h->{"$cat:$_"} = 0 for @{$hash{$rev{$v}}};
				$h->{$j}=1;
				next;
			}
			$count{$cat}->{$v}=$h->{$j};
		}
		foreach my $key (keys %count) {
			my $hash = $count{$key};
			if ((grep {$hash->{$_} eq 0} keys %$hash)==4 and (keys %$hash)==4) {
				my $keys = $hash{$key};
				for my $nk (@$keys) {
					$res{$i}->{"$key:$nk"} = 1 unless exists $res{$i}->{"$key:$nk"}
				}
			}
		}
	}
	return @e
}
sub init {
	foreach my $pair (@pairs) {
		my ($key1,$key2,$bool) = @$pair;
		setbool($key1,$key2,$bool);
		setbool($key2,$key1,$bool);
	}
}
sub setbool {
	my ($key1,$key2,$bool) = @_;
	my $rev1 = $rev{$key1};
	my $rev2 = $rev{$key2};
	$res{"$rev1:$key1"}->{"$rev2:$key2"} = $bool
}
sub position {
	for my $position (@pos) {
		my ($i,$j,$set,@pos) = @$position;
		if ($set) {
			setpos($i,$j,-$_) for @pos;
			setpos($j,$i,$_) for @pos;
		}
		else {
			setposi($i,$j,@pos);
			setposi($j,$i,@pos);
		}
	}
}
sub setposi {
	my ($i,$j,@pos) = @_;
	my @pi;
	for my $k (keys %{$res{"$rev{$i}:$i"}}) {
		next unless $k =~ m/^pos:(\d+)/;
		my $pos = $1;
		if ($res{"$rev{$i}:$i"}->{$k}) {
			push @pi, [$pos,$res{"$rev{$i}:$i"}->{$k},$pos+$_] for @pos
		}
	}
	for my $pi (@pi) {
		my ($pos, $val,$new) = @$pi;
		# this is hardcoded; might change it
		next if ($new < 1 || $new > 5);
		$res{"$rev{$j}:$j"}->{"pos:$new"} = $val unless exists $res{"$rev{$j}:$j"}->{"pos:$new"};
	}
}
sub setpos {
	my ($i,$j,$p) = @_;
	my @pi;
	for my $k (keys %{$res{"$rev{$i}:$i"}}) {
		next unless $k =~ m/^pos:(\d+)/;
		push @pi, [$1,$res{"$rev{$i}:$i"}->{$k}];
	}
	for my $pi (@pi) {
		my ($pos, $val) = @$pi;
		my $new = $pos+$p;
		# this is hardcoded; might change it
		if ($new > 0 && $new < 6) {
			$res{"$rev{$j}:$j"}->{"pos:$new"} = $val;
		}
	}
}
sub print_nice {
	my @k = keys %hash;
	for my $i (sort keys %res) {
		next unless $i =~ m/^$CAT:(\w+)/;
		my $cat = $1;
		my $h = $res{$i};
		my %r;
		for my $j (keys %$h) {
			my ($k,$v) = split /:/,$j;
			$r{$k} = $v if $h->{$j};
		}
		my %k;
		@k{@k}=();
		delete $k{$CAT};
	printf <<EOM, $cat, @r{keys%k };
$CAT %9s: %9s | %9s | %9s | %9s | %9s |
EOM
	}
}
#sub dumpme {
#	foreach my $i (sort keys %res) {
#		print "  $i:\n";
#		my $h = $res{$i};
#		foreach my $j (sort keys %$h) {
#			printf "%25s => %s\n", $j, $h->{$j};
#		}
#	}
#}
#use constant DEBUG => 1;
#use Data::Dumper;