#!/pro/bin/perl

use strict;
use warnings;

use Tk;

my $mw = MainWindow->new ();

my @rel = ( [],
    [ [ "Kind",     qw( Bram Daan Greet Lena Toon Fraukje Anton Carola Eefje ) ],		[] ],
    [ [ "Leeftijd", map { "$_ jaar" } 11 .. 19 ],						[] ],
    [ [ "Beurt",    qw( eerste tweede derde vierde vijfde zesde zevende achtste negende ) ],	[] ],
    [ [ "Aantal",   map { sprintf "%2d kaarten", $_ } 6, 8, 10, 18, 20, 22, 24, 28, 30 ],			[] ],
    [ [ "Oorzaak",  qw( Niesbui Onhandig Peuter Poes Duw Ouder Bliksem Bloedneus Donder ) ],	[] ],
    );
my $plusblack = 1;	# A plus is a '#' (0), or a full black square (1)
my $B = shift || 4;
my $W = shift || 5;
my $M = ((2 ** $W) - 1) << 1;
$mw->title (shift || "Logikwiz");

my $solving = 0;
my (%pairs, %same);

sub r1r2 (@)
{
    my ($r1, $r2, $x, $y, $dbg) = (@_, 0);
    $r1 > $r2 ?  ($r2, $r1, $x, $y, $dbg) : ($r1, $r2, $x, $y, $dbg);
    } # r1r2

sub value ($$$$;$)
{
    my ($r1, $r2, $x, $y, $dbg) = r1r2 (@_);
    $dbg ? "$r1.$r2.$x.$y $rel[$r1][$r2][$x][$y][0]" : $rel[$r1][$r2][$x][$y][0];
    } # value

sub square ($$$$)
{
    my ($r1, $r2, $x, $y) = r1r2 (@_);
    $rel[$r1][$r2][$x][$y][1];
    } # square

sub setseen ($$$$)
{
    my ($r1, $r2, $x, $y) = @_;
    unless (value ($r1, $r2, $x, $y) eq '#') {
	square ($r1, $r2, $x, $y)->configure (-background       => "Gray76");
	square ($r1, $r2, $x, $y)->configure (-activebackground => "Gray76");
	return;
	}
    foreach my $z (1 .. $W) {
	square ($r1, $r2, $z, $y)->configure (-background       => "Gray76");
	square ($r1, $r2, $z, $y)->configure (-activebackground => "Gray76");
	square ($r1, $r2, $x, $z)->configure (-background       => "Gray76");
	square ($r1, $r2, $x, $z)->configure (-activebackground => "Gray76");
	}
    if ($plusblack) {
	square ($r1, $r2, $x, $y)->configure (-background       => "Black");
	square ($r1, $r2, $x, $y)->configure (-activebackground => "Black");
	}
    } # setseen

sub setclear ($$$$)
{
    my ($r1, $r2, $x, $y) = r1r2 (@_);
    $rel[$r1][$r2][$x][$y][0] = ' ';
    $rel[$r1][$r2][$x][0][0] &= 0xFFFF ^ (1 << $y);
    $rel[$r1][$r2][0][$y][0] &= 0xFFFF ^ (1 << $x);
    setseen ($r1, $r2, $x, $y);
    } # setseen

sub setmin ($$$$;$)
{
    my ($r1, $r2, $x, $y, $a) = r1r2 (@_);
    value ($r1, $r2, $x, $y) eq '-' and return;
    if (value ($r1, $r2, $x, $y) eq '#') {
	square ($r1, $r2, $x, $y)->configure (-background       => "Red");
	square ($r1, $r2, $x, $y)->configure (-activebackground => "Red");
	return;
	}
    $rel[$r1][$r2][$x][$y][0] = '-';
    $rel[$r1][$r2][$x][0][0] |= 1 << $y;
    $rel[$r1][$r2][0][$y][0] |= 1 << $x;
    if ($a || $solving) {
	square ($r1, $r2, $x, $y)->configure (-background       => "Yellow");
	square ($r1, $r2, $x, $y)->configure (-activebackground => "Yellow");
	}
    else {
	solve ();
	}
    } # setmin

sub setplus ($$$$)
{
    my ($r1, $r2, $x, $y) = r1r2 (@_);
    value ($r1, $r2, $x, $y) eq '#' and return;
    value ($r1, $r2, $x, $y) eq '-' and
	return square ($r1, $r2, $x, $y)->configure (-background => "Red");
    $same{"$r1.$r2.$x.$y"}++;
    $rel[$r1][$r2][$x][$y][0] = '#';
    if ($solving) {
	square ($r1, $r2, $x, $y)->configure (-background       => "Yellow");
	square ($r1, $r2, $x, $y)->configure (-activebackground => "Yellow");
	}
    elsif ($plusblack) {
	square ($r1, $r2, $x, $y)->configure (-background       => "Black");
	square ($r1, $r2, $x, $y)->configure (-activebackground => "Black");
	}
    foreach my $xx (1 .. $W) {
	$xx == $x or setmin ($r1, $r2, $xx, $y, 1);
	}
    foreach my $yy (1 .. $W) {
	$yy == $y or setmin ($r1, $r2, $x, $yy, 1);
	}
    setsame ($r1, $r2, $x, $y);
    solve ();
    } # setplus

sub setsame
{
    my ($r1, $r2, $x, $y) = r1r2 (@_);
    foreach my $b (1 .. $B) {
	$b == $r1 || $b == $r2 and next;
	print STDERR "== Same for   $b   from $r1.$r2.$x.$y ...\n";
	foreach my $w (1 .. $W) {
	    if ($b > $r2) {
		value ($r1, $b, $w, $y) eq value ($r2, $b, $x, $w) and next;
		print STDERR value ($r1, $r2, $x, $y, 1), " : ",
			     value ($r1, $b,  $w, $y, 1), " <=> ",
			     value ($r2, $b,  $x, $w, 1), "\n";
		value ($r1, $b, $w, $y) eq '#' and setplus ($r2, $b, $x, $w);
		value ($r1, $b, $w, $y) eq '-' and setmin  ($r2, $b, $x, $w, 1);
		value ($r2, $b, $x, $w) eq '#' and setplus ($r1, $b, $w, $y);
		value ($r2, $b, $x, $w) eq '-' and setmin  ($r1, $b, $w, $y, 1);
		next;
		}
	    if ($b > $r1) {
		value ($r1, $b, $x, $w) eq value ($b, $r2, $w, $y) and next;
		print STDERR value ($r1, $r2, $x, $y, 1), " : ",
			     value ($r1, $b,  $x, $w, 1), " <=> ",
			     value ($b, $r2,  $w, $y, 1), "\n";
		value ($r1, $b, $x, $w) eq '#' and setplus ($b, $r2, $w, $y);
		value ($r1, $b, $x, $w) eq '-' and setmin  ($b, $r2, $w, $y, 1);
		value ($b, $r2, $w, $y) eq '#' and setplus ($r1, $b, $x, $w);
		value ($b, $r2, $w, $y) eq '-' and setmin  ($r1, $b, $x, $w, 1);
		next;
		}
	    if ($b == 1) {
		value ($b, $r1, $x, $w) eq value ($b, $r2, $y, $w) and next;
		print STDERR value ($r1, $r2, $x, $y, 1), " : ",
			     value ($b, $r1,  $x, $w, 1), " <=> ",
			     value ($b, $r2,  $y, $w, 1), "\n";
		value ($b, $r1, $x, $w) eq '#' and setplus ($b, $r2, $y, $w);
		value ($b, $r1, $x, $w) eq '-' and setmin  ($b, $r2, $y, $w, 1);
		value ($b, $r2, $y, $w) eq '#' and setplus ($b, $r1, $x, $w);
		value ($b, $r2, $y, $w) eq '-' and setmin  ($b, $r1, $x, $w, 1);
		next;
		}
	    }
	}
    } # setsame

sub clearblock ($$)
{
    my ($r1, $r2, $x, $y) = r1r2 (@_);
    foreach my $x (1 .. $W) {
	foreach my $y (1 .. $W) {
	    setclear ($r1, $r2, $x, $y);
	    }
	}
    m/^$r1.$r2./ and delete $same{$_} for keys %same;
    } # clearblock

sub solve ()
{
    $solving++ and return;

    # 1. Try find rows with $W - 1 '-'s and a free spot: that is a mark
    foreach my $r1 (1 .. $B - 1) {
	foreach my $r2 ($r1 + 1 .. $B) {
	    foreach my $x (1 .. $W) {
		foreach my $y (1 .. $W) {
		    ($rel[$r1][$r2][$x][0][0] | (1 << $y)) == $M and
			setplus ($r1, $r2, $x, $y);
		    ($rel[$r1][$r2][0][$y][0] | (1 << $x)) == $M and
			setplus ($r1, $r2, $x, $y);
		    }
		}
	    }
	}

    # 2. Complete a `couple' or a pair
    foreach my $r1 (1 .. $B - 1) {
	foreach my $r2 ($r1 + 1 .. $B) {
	    foreach my $x1 (1 .. $W - 1) {
		if (exists $pairs{$rel[$r1][$r2][$x1][0][0]}) { # vertical
		    foreach my $x2 ($x1 + 1 .. $W) {
			$rel[$r1][$r2][$x1][0][0] == $rel[$r1][$r2][$x2][0][0] or next;
			my ($y1, $y2) = @{$pairs{$rel[$r1][$r2][$x1][0][0]}};
			foreach my $x3 (1 .. $W) {
			    $x3 == $x1 || $x3 == $x2 and next;
			    setmin ($r1, $r2, $x3, $y1);
			    setmin ($r1, $r2, $x3, $y2);
			    }
			last;
			}
		    }
		if (exists $pairs{$rel[$r1][$r2][0][$x1][0]}) { # horizontal
		    foreach my $x2 ($x1 + 1 .. $W) {
			$rel[$r1][$r2][0][$x1][0] == $rel[$r1][$r2][0][$x2][0] or next;
			my ($y1, $y2) = @{$pairs{$rel[$r1][$r2][0][$x1][0]}};
			foreach my $x3 (1 .. $W) {
			    $x3 == $x1 || $x3 == $x2 and next;
			    setmin ($r1, $r2, $y1, $x3);
			    setmin ($r1, $r2, $y2, $x3);
			    }
			last;
			}
		    }
		}
	    }
	}

    # 3. Copy the '#' column stuff
    setsame (split m/\./) for sort keys %same;

    # 4. Find if A1 is B3 or B5 and C4 ia anything /BUT/ B3 or B5
    #    A1 cannot be C4
    foreach my $r1 (1 .. $B - 1) {
	foreach my $r2 ($r1 + 1 .. $B) {
	    foreach my $b (1 .. $B) {
		$b == $r1 || $b == $r2 and next;
		foreach my $x (1 .. $W) {
		    # Verticals
		    (value ($r1, $r2, $x, 0) | value ($r1, $b, $x, 0)) == $M and
			print STDERR "||[ $r1.$r2.$x $r1.$b.$x ]||\n";
		    # Horizontals
		    (value ($r1, $r2, 0, $x) | value ($r1, $b, 0, $x)) == $M and
			print STDERR "--[ $r1.$r2.$x $r1.$b.$x ]--\n";
		    }
		}
	    }
	}

    $solving = 0;
    } # solve

my $grid = $mw->Frame ()->grid (-sticky => "nsew");
$grid->gridRowconfigure    (0, -weight => 1); # allow expansion in both ...
$grid->gridColumnconfigure (0, -weight => 1); # ... X and Y dimensions

my $instr = $grid->Frame ()->grid (-column => 0, -row => 0, -sticky => "news");
foreach my $txt (   "<1>   = '#'",
		    "<2>   = seen",
		    "<3>   = '-'",
		    "<C-2> = ' '",
		    "<C-3> = ' '*",
		    ) {
    my $l = $instr->Label (
	-text   => $txt,
	-anchor => "nw",
	)->pack (-side => "top", -fill => "x");
    $txt =~ m/#'$/  and
	$l->bind ("<1>" => \&solve);
    $txt =~ m/seen/ and
	$l->bind ("<1>" => sub {
	    foreach my $r1 (1 .. $B - 1) {
		foreach my $r2 ($r1 + 1 .. $B) {
		    foreach my $x (1 .. $W) {
			foreach my $y (1 .. $W) {
			    setseen ($r1, $r2, $x, $y);
			    }
			}
		    }
		}
	    });
    $txt =~ m/ '$/ and
	$l->bind ("<Control-Button-1>" => sub {
	    foreach my $r1 (1 .. $B - 1) {
		foreach my $r2 ($r1 + 1 .. $B) {
		    clearblock ($r1, $r2);
		    }
		}
	    });
    }

foreach my $block (1, reverse 3 .. $B) {
    my ($row, $n2);
    if ($block == 1) {
	$row = 1;
	$n2  = $B;
	}
    else {
	$row = 2 + $B - $block;
	$n2  = $block - 1;
	}
    my $desc = $grid->Frame (
	-borderwidth => 3,
	-relief      => "ridge",
	)->grid (
	    -column  => 0,
	    -row     => $row,
	    -sticky  => "nesw",
	    );
    foreach my $i (1 .. $W) {
	$desc->Entry (
	    -textvariable => \$rel[$block][0][$i],
	    -width        => 15,
	    -relief       => "flat",
	    )->pack (-side => "top", -fill => "both", -expand => 1);
	}
    foreach my $r (2 .. $n2) {
	my ($r1, $r2) = $r > $block ? ($block, $r) : ($r, $block);
	my $squares = $grid->Frame (
	    -borderwidth => 3,
	    -relief      => "ridge",
	    )->grid (
		-column  => $r - 1,
		-row     => $row,
		-sticky  => "nesw",
		);
	foreach my $x (1 .. $W) {
	    $rel[$r1][$r2][$x][0][0] = 0; # 'min' states vertical
	    $rel[$r1][$r2][0][$x][0] = 0; # 'min' states horizontal
	    foreach my $y (1 .. $W) {
		$rel[$r1][$r2][$x][$y][0] = ' ';
		my $b = $squares->Button (
		    -borderwidth  => 0,
		    -textvariable => \$rel[$r1][$r2][$x][$y][0],
		    -command      => sub {	# Left click
			setplus ($r1, $r2, $x, $y);
			},
		    )->grid (
			-column => $x - 1,
			-row    => $y - 1,
			-sticky => "nesw",
			);
		$rel[$r1][$r2][$x][$y][1] = $b;
		$b->bind ("<2>" => sub {	# Middle click
		    setseen ($r1, $r2, $x, $y);
		    });
		$b->bind ("<3>" => sub {	# Right click
		    setmin ($r1, $r2, $x, $y);
		    });
		$b->bind ("<Control-Button-2>" => sub {
		    setclear ($r1, $r2, $x, $y);
		    });
		$b->bind ("<Control-Button-3>" => sub {
		    clearblock ($r1, $r2);
		    });
		}
	    }
	}
    }

foreach my $block (2 .. $B) {
    my $desc = $grid->Frame (
	-borderwidth => 3,
	-relief      => "ridge",
	)->grid (
	    -column  => $block - 1,
	    -row     => 0,
	    -sticky  => "nesw",
	    );
    foreach my $i (1 .. $W) {
	$desc->Entry (
	    -textvariable => \$rel[$block][0][$i],
	    -width        => 15,
	    -relief       => "flat",
	    )->pack (-side => "top", -fill => "both", -expand => 1);
	}
    }

# Prepare an easy reference for completing pairs or couples
foreach my $x (1 .. $W - 1) {
    foreach my $y ($x + 1 .. $W) {
	$pairs{$M ^ ((1 << $x) | (1 << $y))} = [ $x, $y ];
	}
    }

MainLoop;
