# Print a text table of a given list of arrays.
# 
# Usage: &text_table(\@header_fields, @rows)
# If the @header_fields ref is undefined, we don't use header fields.
# @rows contains either array refs (which are printed literally) or
# hash refs (for which the @header_fields are used to determine which
# values to print).  
# 
# Copyright 2004, Mark T. Abbott

use strict;

my $g_n_sep_spaces = 2;


###  Begin main code.  ###

sub text_table
{
	my ($header, @rows) = @_;

	my @print_fields;
	if ( ref($header) eq 'ARRAY' )
	{
		@print_fields = @{$header};
	}
	elsif ( ref($rows[0]) eq 'HASH' )
	{
		@print_fields = sort keys %{$rows[0]}
	}
	else
	{
		@print_fields = undef;
	}

	my %field_length;
	map { $field_length{$_} = length($_) } @print_fields;

	my @clean_rows;
	foreach my $r (@rows)
	{
		my @row;
		if ( ref($r) eq 'ARRAY' )
		{
			@row = @{$r};
		}
		elsif ( ref($r) eq 'HASH' )
		{
			@row = map { ${$r}{$_} } @print_fields;
		}
		else
		{
			next;
		}
		push @clean_rows, \@row;

		for (0..$#print_fields)
		{
			my $l = length($row[$_]);
			($field_length{$print_fields[$_]}) =
				(sort {$b<=>$a}
				($field_length{$print_fields[$_]}||0, $l));
		}
	}

	# Find the proper field lengths for printing the rows.  
	my $cols = &cols;
	while ( 1 )
	{
		my $l = -$g_n_sep_spaces;
		map { $l += $field_length{$_} + $g_n_sep_spaces } @print_fields;
		last	if	$l <= $cols;

		# Choose a field whose length to reduce.
		my @reducible_fields = grep 
			{ $field_length{$_} > length($_) } 
			reverse @print_fields;

		my %penalty_upon_reducing = ();
		foreach my $f ( @reducible_fields )
		{
			my %fl = %field_length;
			--$fl{$f};
			$penalty_upon_reducing{$f} = 
				&field_length_penalty(\%fl, \@print_fields, \@clean_rows);
		}
		my ($reducee) = sort
			{ $penalty_upon_reducing{$a} <=> $penalty_upon_reducing{$b} }
				@reducible_fields;
		$field_length{$reducee}--;
	}

	my $row_pattern = 
		sprintf(
			join(' 'x$g_n_sep_spaces,
				map { '%%%ds' }
				@print_fields
			), 
			map { $field_length{$_} } 
			@print_fields
		);
	#warn $row_pattern;

	my $output = '';
	foreach my $r (@clean_rows)
	{
		my @row = @{$r};
		if ($r == $clean_rows[0])
		{
			$output .= "\n";
			$output .= sprintf $row_pattern, map { uc } @print_fields;
			$output .= "\n";
		}
		my $line = sprintf $row_pattern, 
			map { &shrink_to($field_length{$print_fields[$_]}, $row[$_]) } 
			(0..$#print_fields);
		die "line exceeds screen width of $cols: $line"
			if	length($line)>$cols;
		$output .= $line;
		$output .= "\n";
	}
	$output .= "\n";

	return $output;
}


###  Primary routines.  ###

sub cols
{
	chomp (my $size = `/bin/stty size`);
	my ($w, $c) = ($size =~ m#(\d+)\s+(\d+)#);
	return $c||80;
}

sub field_length_penalty
{
	my ($flref, $pfref, $rref) = @_;
	my %field_length = %{$flref};
	my @print_fields = @{$pfref};
	my @rows = @{$rref};
	my $penalty = 0;
	foreach my $r (@rows)
	{
		my @row = @{$r};
		foreach my $i (0..$#print_fields)
		{
			my $f = $print_fields[$i];
			my $under = length($row[$i]) - $field_length{$f};
			#print join("\t", $f, $t{$f}, $field_length{$f}, length($t{$f}), $under), "\n";
			if ( $under > 0 )
			{
				# Take the ellipsis ('..') into account.  
				$under += 2;

				# The potential penalties are broken up by type
				#  so they can be tweaked/configured/enabled 
				#  more easily.  Currently, using C alone seems
				#  to work best, because it suppresses the long
				#  Album field most.  

				# A. Penalty is the number of interruptions.
				#$penalty += 1;

				# B. Penalty is the number of characters lost.
				#$penalty += $under;

				# C. Penalty is the percent of info lost.
				#$penalty += 100 * $under/length($row[$i]);

				# D. Penalty is the percent of info lost,
				#  squared (better to lose half of two columns 
				#  than all of one).
				$penalty += ($under/length($row[$i])) ** 2;
			}
		}
	}
	return $penalty;
}

sub shrink_to
{
	my ($l, $s) = @_;
	my $over = length($s)-$l;
	return $s if $over<=0;
	my $insert = '..';
	#warn "$l, $s, $over\n";
	substr($s, int($l/2), $over+length($insert), $insert);
	return $s;
}


1;