#!/tools/bin/perl5.005 -w
use strict;
use Data::Dumper;
use Tk;
my $hc = qr/[-\*<>]/;
my $vc = qr/[\|\^v\*]/;
my $mw = MainWindow->new;
my $menu = $mw->Menu;
$mw->configure(-menu => $menu);
$menu->cascade(-label => '~File', -menuitems => [
[Command => 'E~xit', -command => [destroy => $mw]]
]);
my $txt = text_image();
my $c = $mw->Scrolled('Canvas',-bg => 'white',
-width => 10*@{$txt->[0]},
-height => 10 * @$txt,
-scrollbars => 'osow');
$c->pack(-expand => 1, -fill => 'both');
my @v = find_vertical($txt);
my @h = find_horizontal($txt);
my @box = find_boxes(\@v,\@h);
make_varrows($txt,@v);
make_harrows($txt,@h);
foreach my $box (@box)
{
$c->createRectangle(map(10*$_,@$box),-width => 3, -outline => 'black', -fill => '#f0f0f0');
}
foreach my $line (@v,@h)
{
my @line = @$line;
$c->createLine(map(10*$_,splice(@line,0,4)),@line,-fill => 'black');
}
foreach my $box (@box)
{
my ($x1,$y1,$x2,$y2) = @$box;
my @s;
for (my $y = $y1+1; $y < $y2; $y++)
{
my $l = '';
for (my $x = $x1+1; $x < $x2; $x++)
{
$l .= $txt->[$y][$x];
}
$l =~ s/^\s+//;
$l =~ s/\s+$//;
push(@s,$l) if length($l);
}
$c->createText(int(10*($x1+$x2)/2),int(10*($y1+$y2)/2),-text => join("\n",@s),
-justify => 'center', -anchor => 'center');
}
$c->configure(-scrollregion => [$c->bbox('all')]);
$mw->update;
MainLoop;
sub make_varrows
{
my $txt = shift;
foreach my $line (@_)
{
my $f = 0;
my ($x1,$y1,$x2,$y2) = @$line;
die unless $x1 == $x2;
for my $y ($y1..$y2)
{
my $ch = $txt->[$y][$x1];
$f |= 1 if $ch eq '^';
$f |= 2 if $ch eq 'v';
}
push(@$line,'-arrow',${['','first','last','both']}[$f]) if ($f);
}
}
sub make_harrows
{
my $txt = shift;
foreach my $line (@_)
{
my $f = 0;
my ($x1,$y1,$x2,$y2) = @$line;
die unless $y1 == $y2;
for my $x ($x1..$x2)
{
my $ch = $txt->[$y1][$x];
$f |= 1 if $ch eq '<';
$f |= 2 if $ch eq '>';
}
push(@$line,'-arrow',${['','first','last','both']}[$f]) if ($f);
}
}
sub find_boxes
{
my ($v,$h) = @_;
my %x;
my %y;
foreach my $i (0..@$v-1)
{
my $line = $v->[$i]; # x,y1,x,y2
my $x = $line->[0];
my $y = $line->[1];
my $e = $line->[3];
my $key = $y.'-'.$e;
$y{$key} = [] unless exists $y{$key};
push(@{$y{$key}},[$x,$i]);
}
foreach my $i (0..@$h-1)
{
my $line = $h->[$i]; # x1,y,x2,y
my $x = $line->[0];
my $y = $line->[1];
my $e = $line->[2];
my $key = $x.'-'.$e;
$x{$key} = [] unless exists $x{$key};
push(@{$x{$key}},[$y,$i]);
}
my @box;
my @vd;
my @hd;
foreach my $xk (keys %x)
{
my ($x1,$x2) = split(/-/,$xk);
my $xp = $x{$xk};
my @junk;
LOOP:
while (@$xp)
{
my ($y1,$i1) = @{splice(@$xp,0,1)};
for my $xi (0..@$xp-1)
{
my ($y2,$i2) = @{$xp->[$xi]};
my $yk = "$y1-$y2";
if (exists $y{$yk})
{
my $yp = $y{$yk};
my $yi = 0;
for my $yi (0..@$yp-1)
{
if ($yp->[$yi][0] == $x1)
{
my $j1 = $yp->[$yi][1];
for my $yj ($yi..@$yp-1)
{
if ($yp->[$yj][0] == $x2)
{
my $j2 = $yp->[$yj][1];
push(@box,[$x1,$y1,$x2,$y2]);
splice(@$xp,$xi,1);
splice(@$yp,$yj,1);
splice(@$yp,$yi,1);
push(@hd,$i1,$i2);
push(@vd,$j1,$j2);
delete $y{$yk} unless @$yp;
next LOOP;
}
}
}
}
}
}
push(@junk,[$y1,$i1]);
}
if (@junk)
{
$x{$xk} = \@junk;
}
else
{
delete $x{$xk};
}
}
foreach my $i (sort {$b <=> $a} @vd)
{
splice(@$v,$i,1);
}
foreach my $i (sort {$b <=> $a} @hd)
{
splice(@$h,$i,1);
}
return @box;
}
sub find_vertical
{
my $txt = shift;
my $h = @$txt;
my $w = @{$txt->[0]};
my @vert;
my @live;
for (my $y = 0; $y < $h; $y++)
{
for (my $x = 0; $x < $w; $x++)
{
my $s = $live[$x];
my $c = $txt->[$y][$x];
if (defined $s)
{
unless ($c =~ $vc || ($c eq '+' && $y+1 < $h && $txt->[$y+1][$x] =~ $vc))
{
my $e = ($c eq '+') ? $y : $y-1;
if ($e - $s > 0)
{
push(@vert,[$x,$s,$x,$e]);
}
$live[$x] = undef;
}
}
elsif ($c eq '+')
{
$live[$x] = $y;
}
}
}
my $e = $h-1;
for (my $x = 0; $x < $w; $x++)
{
my $s = $live[$x];
if (defined $s)
{
if ($e - $s > 0)
{
push(@vert,[$x,$s,$x,$e]);
}
}
}
return @vert;
}
sub find_horizontal
{
my $txt = shift;
my $h = @$txt;
my $w = @{$txt->[0]};
my @horz;
my @live;
for (my $x = 0; $x < $w; $x++)
{
for (my $y = 0; $y < $h; $y++)
{
my $c = $txt->[$y][$x];
my $s = $live[$y];
if (defined $s)
{
unless ($c =~ $hc || ($c =~ /[\+\|]/ && $x+1 < $w && $txt->[$y][$x+1] =~ $hc))
{
my $e = ($c eq '+') ? $x : $x-1;
if ($e - $s > 0)
{
push(@horz,[$s,$y,$e,$y]);
}
$live[$y] = undef;
}
}
elsif ($c eq '+')
{
$live[$y] = $x;
}
}
}
my $e = $w-1;
for (my $y = 0; $y < $h; $y++)
{
my $s = $live[$y];
if (defined $s)
{
if ($e - $s > 0)
{
push(@horz,[$s,$y,$e,$y]);
}
}
}
return @horz;
}
sub show_txt
{
my $txt = shift;
foreach (@$txt)
{
print @$_,"\n";
}
}
sub text_image
{
my @txt;
my $max = 0;
while (<>)
{
next if m#^/#;
s/\s+$//;
my $l = length($_);
$max = $l if $l > $max;
push(@txt,[split('',$_)]);
}
foreach (@txt)
{
if (@$_ < $max)
{
push(@$_,(' ') x ($max - @$_));
}
}
return \@txt;
}