#!/usr/bin/perl -w

# 1, 2, 3, 4, 5(, 6)
# Red, Blue, Green, Yellow
# Triangles, Squares, Circles, Diamonds, Stars

use strict;

my $g_n_items = 9;
my @g_n_characteristics = (undef, undef, undef); # Actual values are assigned randomly on each iteration.
#my @g_n_min_characteristic_count = (1, 2, 2);
my @g_n_min_characteristic_count = (1, 1, 1);
#my @g_n_max_characteristic_count = map { int($g_n_items/3) } @g_n_characteristics;
my @g_n_max_characteristic_count = map { int($g_n_items-1) } @g_n_characteristics;
my $g_t_failure = 10;
my ($g_max_min_cost, $g_max_avg_cost, $g_max_max_cost);
my $g_n_solves = 100;

my ($g_c_quilts, $g_c_well_formed, $g_c_solvable) = (0, 0, 0);

while (1)
{
    warn "\nNew quilt.\n";
    ++$g_c_quilts;

    # Randomize the number of characteristics.
#    @g_n_characteristics = sort { $b <=> $a } map { int(3 + rand(3)) } @g_n_characteristics;
    @g_n_characteristics = sort { $b <=> $a } (2, 2, 3);
    my $n_permutations = 1;
    map { $n_permutations *= $_ } @g_n_characteristics;
    redo unless $n_permutations >= $g_n_items;

    warn "\tGenerating...\n";
    my $q = &random_quilt;
    warn "\tChecking for well-formedness...\n";
    next unless &well_formed_quilt($q);
    ++$g_c_well_formed;
    warn "\tChecking for solvability...\n";
    if ( &solution_cost($q) )
    {
	#--$g_t_failure if $g_t_failure > 1;
	warn "\tEvaluating...\n";
	++$g_c_solvable;
	&evaluate_quilt($q);
    }
    else
    {
	#$g_t_failure++;
    }

    warn sprintf '%d quilts, %d well-formed (%.2f%%), %d solvable (%.2f%%)'."\n",
      $g_c_quilts, $g_c_well_formed, 100*$g_c_well_formed/$g_c_quilts, $g_c_solvable, 100*$g_c_solvable/$g_c_well_formed;
}

exit;


###

sub random_quilt
{
    my @q;
    my %seen;
    for (0..$g_n_items-1)
    {
	#warn "[$_]\n";
	my @item;
	for my $i_characteristic (0..$#g_n_characteristics)
	{
	    #warn " [$i_characteristic]\n";
	    push @item, int rand $g_n_characteristics[$i_characteristic];
	}
	#warn "checking if seen\n";
	if ( $seen{&string_from_item(\@item)}++ )
	{
	    #warn "g_n_characteristics: " . join(', ', @g_n_characteristics) . "\n";
	    #warn "seen " . &string_from_item(\@item) . " in this quilt:\n" . &string_from_quilt(\@q);
	    redo;
	}
	push @q, \@item;
    }

    return \@q;
}

sub solution_cost
# Given a quilt and timeout, return the cost of the solution if one was found.
{
    my ($q, $known_good) = @_;
    #warn "q $q, known_good $known_good";

    my @cost_of_characteristic = (3, 1, 2);

    # Determine which items are in each others' sets.
    my (%n_similarities, %same_set);
    for my $i (0..$g_n_items-2)
    {
	for my $j ($i+1..$g_n_items-1)
	{
	    for my $k (sort { $cost_of_characteristic[$a] <=> $cost_of_characteristic[$b] } 0..$#g_n_characteristics)
	    {
		if ( ${${$q}[$i]}[$k] eq ${${$q}[$j]}[$k] )
		{
		    #warn "$i,$j\n";
		    ++$n_similarities{"$i,$j"};
		    #$same_set{"$i,$j"} = $same_set{"$j,$i"} = $cost_of_characteristic[$k];
		    #last;
		}
	    }
	}
    }
    map { $same_set{$_} = 1 if $n_similarities{$_} == 2 } keys %n_similarities;
    #map { print "$_\t$n_similarities{$_}\t$same_set{$_}\n" } sort keys %n_similarities;
    #die;

    my $t_start = $known_good? undef : time;
    
    #warn "[$known_good] [$t_start]";
    my $solution_cost = &recurse_solution_cost($q, $t_start, [0], [1..$g_n_items-1], \%same_set);
    return $solution_cost if $solution_cost > 0;
    return 0;
}

sub recurse_solution_cost
# >0: cost to solve.
# <0: not solvable (negative of cost to check)
# undef: timed out.
{
    # q: the quilt
    # t_start
    # sequence: the indexes of the items so far.
    # available_items: the indexes of the remaining items.
    my ($q, $t_start, $sequence, $available_items, $same_set) = @_;

    my $this_cost = 1; # Minimum cost.

    #warn $t_start;
    #die unless $t_start;
    if ( defined($t_start) and time - $t_start > $g_t_failure )
    {
	return undef;
    }

    if ( scalar(@{$available_items}) == 0 )
    {
	# We have a full sequence; just need to check if we can loop back to the beginning.
	if (${$same_set}{"${$sequence}[0],${$sequence}[$#{$sequence}]"})
	{
	    #warn scalar(@{$sequence}) . ': ' . join(', ', @{$sequence}) . "\n";
	    return $this_cost + ${$same_set}{"${$sequence}[0],${$sequence}[$#{$sequence}]"};
	}
	else
	{
	    return -$this_cost;
	}
    }

    # Originally this code searched the remaining available items in
    # random order.  I changed it to look at the "least expensive"
    # choices first.  For example, look for items of the same color
    # first.  This is like how I actually solve the problems; the idea
    # is to find problems where the user is forced to skip from color
    # to color because the "easy" strategy doesn't work.  So far, this
    # method doesn't appear to create harder problems.

    #warn scalar(@{$sequence}) . ': ' . join(', ', @{$sequence});
    #&fisher_yates_shuffle($available_items);
    my $last = ${$sequence}[$#{$sequence}];
    my @reachable_from_here_by_cost =
	sort { ${$same_set}{"$last,$a"} <=> ${$same_set}{"$last,$b"} } 
        grep { defined ${$same_set}{"$last,$_"} }
        @{$available_items};
    #warn "available items: " . join(' ', @{$available_items});
    #warn "reachable_from_here_by_cost: " . join(' ', @reachable_from_here_by_cost);
    #die;

    #my $last_item = ${$sequence}[$#{$sequence}];
    #foreach my $item (@{$available_items})
    foreach my $item (@reachable_from_here_by_cost)
    {
	#next unless ${$same_set}{"$last_item,$item"};
	++$this_cost;
	my @remaining_items = grep { $_ ne $item } @{$available_items};
	my $recurse_cost = &recurse_solution_cost( $q, $t_start, [@{$sequence}, $item], [@remaining_items], $same_set );
	if ( $recurse_cost > 0 )
	{
	    return $this_cost + $recurse_cost;
	}
	elsif ( $recurse_cost < 0 )
	{
	    # Negative of the cost to check.
	    $this_cost += -$recurse_cost;
	}
	else
	{
	    # Timed out.
	    die "should be undef [$recurse_cost]" if defined($recurse_cost);
	    return undef;
	}
    }
    return -$this_cost;
}

sub well_formed_quilt
{
    my ($q) = @_;
    for my $i_characteristic (0..$#g_n_characteristics)
    {
	#warn "[$i_characteristic]\n";
	my %count;
	foreach my $item (@{$q})
	{
	    #warn " [$item]\n";
	    $count{${$item}[$i_characteristic]}++;
	}
	foreach my $characteristic (keys %count)
	{
	    if ( $count{$characteristic} < $g_n_min_characteristic_count[$i_characteristic] )
	    {
		return 0;
	    }

	    if ( $count{$characteristic} > $g_n_max_characteristic_count[$i_characteristic] )
	    {
		#warn "rejected ill-formed quilt due to a count of $count{$characteristic} on $i_characteristic\n" . &string_from_quilt($q);
		return 0;
	    }
	}
    }
    return 1;
}

sub string_from_quilt
{
    my ($q) = @_;
    my @q = @{$q};

    # Map the indexes to actual values (e.g. 0 -> Blue).  
    # The most common indexes get the lower numbers.
    my @characteristics = (
			   [qw(1 2 3 4 5 6)],
			   [qw(yellow red blue green purple)],
			   [qw(circles triangles squares diamonds stars)],
			   );
    map { &fisher_yates_shuffle($characteristics[$_]) } (1); # shuffle the colors, but leave others ordered by frequency.

    my @characteristic_mapping;

    foreach my $i_characteristic ( 0..$#g_n_characteristics )
    {
	my %count;
	foreach my $item (@q)
	{
	    $count{${$item}[$i_characteristic]}++;
	}
	my @member_indexes = sort { $count{$b} <=> $count{$a} } keys %count;
	for my $j_member (0..$#member_indexes)
	{
	    ${$characteristic_mapping[$i_characteristic]}{$member_indexes[$j_member]} = ${$characteristics[$i_characteristic]}[$j_member];
	}
    }

    my $s;
    for my $i (0..$#q)
    {
	$s .= join(' ', "[$i]", map { ${$characteristic_mapping[$_]}{${$q[$i]}[$_]} } (0..$#g_n_characteristics)) . "\n";
    }
    return $s;
}

sub html_from_string
# HTML version of the quilt string.
{
    my ($s) = @_;
    my @s = split "\n", $s;
    my @items;
    for (@s)
    {
	chomp;
	next unless m/^\[(\d+)\] (.+)$/;
	push @items, $2;
    }
    die unless scalar(@items) == $g_n_items;

    # Handle squares or one-off.
    my $width = $g_n_items/(int ($g_n_items**0.5));
    my $height = $g_n_items/$width;
    die "can't handle $g_n_items items" unless $width == int($width);

    # Reorder the items by color scheme.
    @items = &order_string_items_by_characterstic(1, @items);

    my @html_items = map { &html_from_item($_) } @items;

    my $script_setConnected;
    for my $i (0..$#items-1)
    {
	for my $j ($i+1..$#items)
	{
	    $script_setConnected .= "setConnected($i, $j);" if &same_set_from_strings($items[$i], $items[$j]);
	}
    }
    
    my $h = <<HTML;
<html>
<head>
  <link rel="stylesheet" type="text/css" href="style.css">
  <title>Puzzle Quilt</title>
  <SCRIPT language="JavaScript" SRC="quilt.js"/>
</head>
<body onload="$script_setConnected">
HTML


    $h .= "<table border=1 cellspacing=20>\n";

    my $i = 0;
    for (1..$height)
    {
	$h .= " <tr height='100'>\n";
	for (1..$width)
	{
	    $h .= "  <td name='cell' id='$i' onclick=\"addToClickstream('$i')\" width='100' align='center'>" .
		$html_items[$i++] . "</td>\n";
	}
	$h .= " </tr>\n";
    }

    $h .= "</table>\n";
    $h .= "</body>\n</html>\n";

    return $h;
}

sub same_set_from_strings
{
    my ($a, $b) = @_;
    my @a = split ' ', $a;
    my @b = split ' ', $b;
    my $c_matched = 0;
    map { $c_matched++ if $a[$_] eq $b[$_] } (0..$#a);
    return $c_matched == 2;
}

sub order_string_items_by_characterstic
# I'm sure this code is far more complicated than it needs to be.
{
    my ($i_characteristic, @items) = @_;
    my @characteristics;
    for ( @items )
      {
	my @this_item = split ' ', $_;
	push @characteristics, $this_item[$i_characteristic];
      }

    my %ordering_by_counts = (
			      '3,2,2,2' => [
					    0, 1, 2,
					    3, 0, 3,
					    2, 1, 0,
					    ],
			      '3,3,3' =>  [
					   0, 1, 2,
					   2, 0, 1,
					   1, 2, 0,
					   ],

			      '3,3,2,2,2' => [
					      0,2,1,3,
					      1,3,4,0,
					      4,0,2,1,
					      ],
			      '3,3,3,3' => [
					    0,3,1,2,
					    1,2,3,0,
					    3,0,2,1,
					    ],
			      '4,3,3,2' => [
					    0,1,0,2,
					    3,2,1,3,
					    1,0,2,0,
					    ],
			      '4,4,2,2' => [
					    0,3,1,0,
					    2,1,0,3,
					    1,0,2,1,
					    ],

			      '5,5,3,3' => [
					    0,3,1,3,
					    1,2,0,1,
					    0,1,3,0,
					    2,0,2,1,
					    ],
			      '5,4,3,2,2' => [
					      2,0,4,1,
					      0,2,1,0,
					      3,1,0,3,
					      1,0,4,2,
					      ],
			      '4,3,3,3,3' => [
					      1,0,3,2,
					      2,4,1,0,
					      0,3,2,4,
					      4,1,0,3,
					      ],
			      '4,4,4,4' => [
					    0,1,2,3,
					    3,0,1,0,
					    2,3,2,1,
					    1,0,3,2,
					    ],
			      '4,4,4,2,2' => [
					      3,0,1,2,
					      0,4,2,0,
					      2,1,3,1,
					      1,0,2,4,
					      ],
			      '5,4,4,3' => [
					    2,0,3,1,
					    0,2,1,0,
					    3,1,0,2,
					    1,0,2,3,
					    ],
			      '4,4,3,3,2' => [
					      3,0,2,1,
					      0,1,3,4,
					      4,2,0,1,
					      0,3,1,2,
					      ],
			      '5,3,3,3,2' => [
					      2,0,3,1,
					      0,4,1,0,
					      1,3,0,2,
					      3,0,2,4,
					      ],
			      '5,5,4,2' => [
					    3,0,1,2,
					    0,1,2,0,
					    1,2,0,1,
					    2,0,1,3,
					    ],
			      );

    my %c;
    map { $c{$_}++ } @characteristics;
    my @characteristics_ordered_by_frequency = sort { $c{$b} <=> $c{$a} } keys %c;
    my $counts = join ',', map { $c{$_} } @characteristics_ordered_by_frequency;
    my %position_of_characteristic_by_frequency;
    map { $position_of_characteristic_by_frequency{$characteristics_ordered_by_frequency[$_]} = $_ }
      (0..$#characteristics_ordered_by_frequency);
    warn $counts;
    unless ( defined $ordering_by_counts{$counts} )
    {
	warn "no predefined layout for $counts\n";
	return @items;
    }
    my @ordering = @{$ordering_by_counts{$counts}};

    # Separate indexes into the @ordering array for each group.
    my @i = (0);
    for my $i_i (1..$#characteristics_ordered_by_frequency)
    {
	$i[$i_i] = $i[$i_i-1] + $c{$characteristics_ordered_by_frequency[$i_i-1]};
    }

    # Order the items by characteristic.
    my @items_ordered;
    for my $c (@characteristics_ordered_by_frequency)
      {
	push @items_ordered, map { $items[$_] } grep { $characteristics[$_] eq $c } (0..$#items);
      }
    #warn join ' ', @items_ordered;

    # Do the ordering.
    my @return_items;
    my $i_item = 0;
    for my $i_ordering (0..$#ordering)
      {
	# Place an item of characteristic $characteristics_ordered_by_frequency[$ordering[$i_ordering]] in position $i_ordering.
	$return_items[$i_ordering] = $items_ordered[$i[$position_of_characteristic_by_frequency{$characteristics_ordered_by_frequency[$ordering[$i_ordering]]}]++];
      }
    return @return_items;
}

sub html_from_item
{
    my ($item) = @_;
    die "can't match item [$item]" unless $item =~ m/(\d+) (\w+) (\w+)/;
    my ($n, $color, $shape) = ($1, $2, $3);
    $shape =~ s/s$//;

    my %pattern_by_number = (
			     1 => '#IMG#',
			     2 => '<table><tr><td>#IMG#</td><td></td></tr><td></td><td>#IMG#</td></tr></table>',
			     3 => '<table><tr><td></td><td></td><td>#IMG#</td></tr><tr><td></td><td>#IMG#</td><td></td></tr><tr><td>#IMG#</td><td></td><td></td></tr></table>',
			     4 => '<table><tr><td>#IMG#</td><td>#IMG#</td></tr><td>#IMG#</td><td>#IMG#</td></tr></table>',
			     5 => '<table><tr><td>#IMG#</td><td></td><td>#IMG#</td></tr><tr><td></td><td>#IMG#</td><td></td></tr><tr><td>#IMG#</td><td></td><td>#IMG#</td></tr></table>',
			     );
    my $image_tag = "<img src='images/$color-$shape.png'/>";
    my $h = $pattern_by_number{$n};
    $h =~ s/#IMG#/$image_tag/g;
    return $h;
}

sub string_from_item
{
    my ($item) = @_;
    my $s = join(':', @{$item}) . "\n";
    return $s;
}

# fisher_yates_shuffle( \@array ) : generate a random permutation
# of @array in place
sub fisher_yates_shuffle {
    my $array = shift;
    my $i;
    for ($i = @$array; --$i; ) {
        my $j = int rand ($i+1);
        next if $i == $j;
        @$array[$i,$j] = @$array[$j,$i];
    }
}

sub evaluate_quilt
# $q is a known-solvable quilt.
{
    my ($q) = @_;
    
    #print "evaluating this quilt:\n", &string_from_quilt($q);
    #warn "evaluating a quilt\n";

    my $n_tests = $g_n_solves;;

    my ($this_min_cost, $this_max_cost, $this_total_cost);

    my $test = 1;
    $| = 1 if $test;
    for my $c_test (1..$n_tests)
    {
	print '.' if $test;
	&fisher_yates_shuffle($q);
	my $cost = &solution_cost($q, 'known good');
	unless ( $cost )
	{
	    warn "no solution found (cost $cost) on test $c_test for this quilt:\n" . &string_from_quilt($q);
	}
	#warn "[$c_test] cost $cost\n";
	#if ( $cost > $g_
	$this_total_cost += $cost;
	$this_min_cost = $cost if not defined $this_min_cost or $cost < $this_min_cost;
	$this_max_cost = $cost if not defined $this_max_cost or $cost > $this_max_cost;
    }
    print "\n" if $test;

    my $this_avg_cost = int(0.5 + $this_total_cost / $n_tests);

#    my $found_better_solution = 0;
#    if ( not defined $g_max_min_cost or $this_min_cost > $g_max_min_cost )
#    {
#	$g_max_min_cost = $this_min_cost;
#	$found_better_solution = 1;
#    }
#    if ( not defined $g_max_avg_cost or $this_avg_cost > $g_max_avg_cost )
#    {
#	$g_max_avg_cost = $this_avg_cost;
#	$found_better_solution = 1;
#    }
#    if ( not defined $g_max_max_cost or $this_max_cost > $g_max_max_cost )
#    {
#	$g_max_max_cost = $this_max_cost;
#	$found_better_solution = 1;
#    }
    #warn "min cost $this_min_cost; average cost $this_avg_cost; max cost $this_max_cost\n";
    if (
	&exceeds_max($this_min_cost, $g_max_min_cost) +
	&exceeds_max($this_avg_cost, $g_max_avg_cost) +
	&exceeds_max($this_max_cost, $g_max_max_cost)
	)
    {
	my $s = &string_from_quilt($q);
	print $s;
	print "min cost $this_min_cost; average cost $this_avg_cost; max cost $this_max_cost\n";
	print "g_n_characteristics: " . join(', ', @g_n_characteristics) . "\n";
	print "\n";
	open Q, ">html/quilt.html" or die $!;
	print Q &html_from_string($s);
	close Q;
	exit;
    }
    else
    {
	#--$g_max_avg_cost;
	return;
    }
}

sub exceeds_max
{
    # $_[0]: this
    # $_[1]: global
    if ( not defined($_[1]) or $_[0] > $_[1] )
    {
	#warn "increasing from $_[1] to $_[0]\n";
	$_[1] = $_[0];
	return 1;
    }
    return 0;
}