#!/usr/bin/perl
#
# anthologize -- convert an image scatter to structured notation
#
# Takes a collection of #P blocks with offsets and translates it
# to offsetless P blocks and an #I list.  Can recognize and coalesce
# identical blocks, or blocks that are the same modulo X- or Y-axis reflection.

# Number of successive blank lines that triggers a breakup of a picture
# into two subpictures that are analyzed separately.
$run_sensitivity = 1;

# List of patterns we can recognize by name.
# Any orientation of these will do.  They're
# not used for shape recognition, as that
# has to be relative to a seen sub-rectangle.
%known = 
(
 "***\n",				"blinker",
 "**\n*\n",				"elbow",
 "**\n**\n",				"block",
 "..*\n*.*\n.**\n",			"glider",
 "*\n.**\n**\n",			"glider2", 
 ".****\n*...*\n....*\n...*\n",		"lwss",
 "..**\n**.**\n****\n.**\n",		"lwss2",
 ".*****\n*....*\n.....*\n....*\n",	"mwss",
 "...**\n***.**\n*****\n.***\n",	"mwss2",
 ".....*\n......*\n*.....*\n.******\n",	"hwss",
 "....**\n****.**\n******\n.****\n",	"hwss2",
 "*\n***\n...*\n..**\n",		"eater",
 "*.**\n**.*\n",			"snake",
 ".*\n*.*\n**\n",			"boat",
 "**\n.**\n**\n*\n",			"bheptomino",
 ".*\n***\n",				"tee",
);

my(%assoc, $thispattern, $xoffset, $yoffset, $pushback);

$n = 1;
while (<STDIN>)
{
    push(@header, $_);
    last if /^$/;
}

while (<STDIN>)
{
  redo:
    if (/^#P ([0-9-]*) ([0-9-]*)/)
    {
	my($name, $try, $include, $height, $width, @name, $runsize);

	$xoffset = $1;
	$yoffset = $2;
	if ($pushback) {
	    $thispattern = $pushback;
	    $height = 1;
	    $width = length(pushback);
	    undef $pushback;
	} else {
	    $thispattern = "";
	    $height = $width = 0;
	}
	while (<STDIN>)
	{
	    last if (/^[^.*]/);

	    # If this is the end of a run of blank picture lines,
	    # push back the nonblank line and a faked-up picture header.
	    if (substr($thispattern, -2) eq ".\n" && $_ ne ".\n") {
		for ($runsize = 1; $runsize <= $height; $runsize++) {
		    last if (substr($thispattern, -(2 * $runsize)) ne (".\n" x $runsize));
		}
		$runsize--;
		if ($runsize >= $run_sensitivity) {
		    $pushback = $_;
		    $thispattern = substr($thispattern, 0, -(2 * $runsize));
		    my($newyoffset) = $yoffset + $height; 
		    $height -= $runsize;
		    $_ = "#P $xoffset $newyoffset\n";
		    last;
		}
	    }

	    $thispattern .= $_;
	    $height++;
	    $width = length($_) if length($_) > $width;
	}
	$width--;

        @parts = split("\n", $thispattern);
	while (grep(substr($_, 0, 1) eq '.', @parts) == $height) {
	    grep($_ = substr($_, 1), @parts);
	    $width--;
	    $xoffset++;
	}
	$thispattern = join("\n", @parts) . "\n";

	@match = &derive(\%assoc, $thispattern, $xoffset, $yoffset, $width, $height);
	$include = $match[1];
	if (!$include) {
	    @match = &derive(\%known, $thispattern, $xoffset, $yoffset, $width, $height);
	    if ($match[0]) {
		$name = $match[0];
	    } else {
		$name = "fragment-$n";
		$n++;
	    }
	    $assoc{$thispattern} = "$name";
	    push(@lines, "#B :$name\n");
	    push(@lines, "#K " . $ARGV[0] . "\n") if @ARGV;
	    push(@lines, "#P\n");
	    push(@lines, $thispattern);
	    push(@lines, "#E\n\n");
	    $include = sprintf("#I :%-12s %3d %3d 0  1 0\n",$name,$xoffset,$yoffset)
	}

	push(@contents, $include);

	goto redo;
    }
    else
    {
	push(@lines, $_);
    }
}

print @header, @lines, @contents, "\n## Pattern ends here.\n";

sub derive
# Try to recognize a pattern block from the given association list.
{
    my($assoc, $pattern, $xoffset, $yoffset, $width, $height) = @_;
    my($match, $rot1, $rot2, $rot3);

    if (($match = $$assoc{$pattern})) {
	return(($match, sprintf("#I :%-12s %3d %3d 0  1 0\n",$match,$xoffset,$yoffset)));
    } 
    if (($match = $$assoc{&xreflect($pattern)})) {
	$yoffset += ($height-1);
	return(($match, sprintf("#I :%-12s %3d %3d 0 -1 0\n",$match,$xoffset,$yoffset)));
    } 
#    $rot1 = &rotate($pattern, $width, $height);
#    if (($match = $$assoc{$rot1})) {
#	$yoffset += ($height-1);
#	return(($match, sprintf("#I :%-12s %3d %3d 3  1 0\n",$match,$xoffset,$yoffset)));
#    }
    if (($match = $$assoc{&xreflect($rot1)})) {
	$xoffset += ($width-1);
	$yoffset += ($height-1);
	return(($match, sprintf("#I :%-12s %3d %3d 3 -1 0\n",$match,$xoffset,$yoffset)));
    }
    $rot2 = &rotate($rot1, $height, $width);
    if (($match = $$assoc{$rot2})) {
	$xoffset += ($width-1);
	$yoffset += ($height-1);
	return(($match, sprintf("#I :%-12s %3d %3d 2  1 0\n",$match,$xoffset,$yoffset)));
    }
#    if (($match = $$assoc{&xreflect($rot2)})) {
#	$xoffset += ($width - 1);
#	$yoffset += ($height-1);
#	return(($match, sprintf("#I :%-12s %3d %3d 2 -1 0\n",$match,$xoffset,$yoffset)));
#    }
    $rot3 = &rotate($rot2, $width, $height);
    if (($match = $$assoc{$rot3})) {
	$xoffset += ($width - 1);
	return(($match, sprintf("#I :%-12s %3d %3d 1  1 0\n",$match,$xoffset,$yoffset)));
    }
#    if (($match = $$assoc{&xreflect($rot3)})) {
#	$xoffset += ($width - 1);
#	return(($match, sprintf("#I :%-12s %3d %3d 1 -1 0\n",$match,$xoffset,$yoffset)));
#    }

    return(undef);
}

sub xreflect 
# Reflect a pattern around its X axis
{
    my($pattern) = @_;
    my($reversed);

    grep($reversed = "$_\n$reversed", split("\n", $pattern));
    return($reversed);

}

sub rotate
# Rotate a pattern clockwise
{
    my($pattern, $width, $height) = @_;
    my (@rotated, @parts, $i, $j);

    @parts = split("\n", $pattern);
    grep($_ = $_ . ("." x ($width - length($_))), @parts);
    for ($i = $height - 1; $i >= 0; $i--) {
	for ($j = 0; $j < $width; $j++) {
	    @rotated[$j] .= substr($parts[$i], $j, 1);
	}
    }

    grep($_ = &strip($_), @rotated);
    $pattern = join("\n", @rotated) . "\n";
    return($pattern)
}

sub strip
# Strip extraneous dots off the ends of all pattern lines
{
    my($pattern) = @_;
    while (substr($pattern, -1, 1) eq '.') {
	$pattern = substr($pattern, 0, -1);
    }

    return($pattern);
}
