#!/usr/bin/perl

use strict;
use warnings;

use Data::Dumper;

# Define the criteria outside of function so we only initialize it
# once.  If you want to be extra paranoid, you could wrap this and
# "handle_func" into a single code block.
my @CRITERIA = (

    { function => 'DIST',
      metric => 'STD DEV',
      units => 'ft',
      ranges => [ 3.4567,            # center value
                  ''      => 0.001,  # center tolerance
                  green   => 0.01,   # color => tolerance
                  yellow  => 0.2,
                  red     => -1 ] }, # default

    { function => 'AREA',
      metric => 'STD DEV',
      units => 'ft^2',
      ranges => [ 2.78,
                  ''      => 0.01,
                  blue    => 0.1,
                  orange  => 0.3,
                  red     => -1 ] },

    { function => 'DIST2',
      metric => 'DISTANCE',
      units => 'm',
      ranges => [ 3.2,
                  ''      => 0.01,
                  blue    => 0.1,
                  orange  => 0.3,
                  red     => -1 ] },

); # end of @CRITERIA

sub handle_func
{
    my ( $func ) = @_;

    return unless defined $func && exists $func->{name};

    print "$func->{name} - $func->{desc}\n";
    return unless $func->{metrics};

    my @criteria = grep { $_->{function} eq $func->{name} } @CRITERIA;
    # print Data::Dumper->Dump( [ \@criteria ], [ '*criteria' ] );
    foreach my $metric ( @{ $func->{metrics} } )
    {
      CRIT:
        foreach my $crit ( @criteria )
        {
            last CRIT unless $metric->{name} eq $crit->{metric};

          MEAS:
            foreach my $meas ( @{ $metric->{measurements} } )
            {
                # print Data::Dumper->Dump( [ $meas ], [ '*meas' ] );
                next MEAS unless $meas->{units} eq $crit->{units};

                my @ranges = @{ $crit->{ranges} };
                my $center = shift @ranges;

              RANGE:
                while ( @ranges )
                {
                    my ( $color, $tol ) = splice @ranges, 0, 2;
                    my $min = $center - $tol;
                    my $max = $center + $tol;
                    my $val = $meas->{value};
                    if ( $tol == -1 || ( $min <= $val && $val <= $max ) )
                    {
                        $meas->{markup} = "<span color=\"$color\">"
                          if $color;
                        last RANGE;
                    }
                }
            }
        }

        my $line = sprintf "    %-28s", "$metric->{name}:";
        foreach my $meas ( @{ $metric->{measurements} } )
        {
            my $val = "$meas->{value} $meas->{units}";
            my $pad = " " x ( 32 - length $val );
            if ( my $markup_end = $meas->{markup} )
            {
                $markup_end =~ s!<(\w+).*>!</$1>!;
                $val = $meas->{markup} . $val . $markup_end;
            }
            $line .= $val . $pad;
        }
        $line =~ s!\s+$!\n!;
        print $line;
    }

    print "\n";
}

# Build a hashref per function.  Functions consist of a block of
# text that has this form:
#
# | FUNC_SHORT - Long description of function
# |    metric0: english_measurement metric_measurement
# |    metric1: english_measurement metric_measurement
#
# Syntax of placeholders above:
#   FUNC_SHORT: all-uppercase, initial alpha, rest alnum, no spaces.
#   long description: freeform, but fits on one line.
#   metricX: all-uppercase, can have spaces, ends before colon.
#   english_measurement: floating point number, space, english unit, dim.
#   metric_measurement: floating point number, space, metric unit, dim.
#   dim: (optional) caret followed by optional +- then small integer
#
# Functions end with either a blank line (which is otherwise
# ignored), or by the start of a new function (anything without
# leading whitespace).

# match line that starts new function.
#   $1 - function short name
#   $2 - function long description
my $func_start_re = qr/ ^ ( [[:upper:][[:upper:][:digit:]]* ) \s+
                        - \s+ ( .*? ) \s* $ /x;

# a single base unit
my $unit_name_re = qr/ [[:alpha:]]\w* /x;
my $unit_exp_re = qr/ [+-]?\d+ /x;
my $unit_re    = qr/ ( $unit_name_re ) (?: \^ ( $unit_exp_re ) )? /x;
my $unit_re_nc = qr/   $unit_name_re   (?: \^   $unit_exp_re   )? /x;

# a single floating-point number (borrowed from 'perlfaq4'):
my $float_re = qr/ [+-]? (?=\d|\.\d) \d* (?:\.\d*)?
                   (?:[Ee][+-]?\d+)? /x;

# match a single measurement
#   $1 - scalar value
#   $2 - units
my $measurement_re = qr/ ( $float_re ) \s+
                         ( $unit_re_nc (?: \* $unit_re_nc )* ) /x;

# and one metric line:
#   $1 - metric name
#   $2 - US measurement
#     $3 - scalar
#     $4 - units
#   $5 - SI measurement
#     $6 - scalar
#     $7 - units
my $metric_line_re = qr/ ^ \s+ ( [A-Z ]+ ) :
                           \s+ ( $measurement_re )
                           \s+ ( $measurement_re ) \s* $ /x;

# print "metric_line_re='$metric_line_re'\n";

# and just to make the conditionals self-documenting...
my $blank_line_re = qr/ ^ \s* $ /x;

# turn "1.23 ft^2*s-1" into a hash ref that looks like:
#   { raw => '1.23 ft^2',
#     value => '1.23',
#     units => 'ft^2*s^-1',
#     unit_list => [ 'ft^2', 's^-1' ] }
sub crack_measure
{
    my ( $meas ) = @_;

    my $rv = { raw => $meas };

    unless ( $meas =~ $measurement_re )
    {
        warn "measurement '$meas' malformed";
        return $rv;
    }
    $rv->{value} = $1;
    $rv->{units} = $2;

    foreach my $unit ( split /\*/, $rv->{units} )
    {
        push @{ $rv->{unit_list} }, $unit;
    }

    # print "crack_measure rv=", Dumper $rv;

    return $rv;
}

# now go through the file full of functions, parsing as we go; when
# we're done with one function, handle it.
my $func_href;

# open my $func_fh, '<', $function_input_filename
#   or die "$function_input_filename: $!";
# while ( my $line = <$func_fh> )

while ( my $line = <DATA> )
{
    if ( $line =~ $func_start_re )
    {
        handle_func $func_href;
        $func_href = { name => $1, desc => $2 };
    }
    elsif ( $line =~ $blank_line_re )
    {
        handle_func $func_href;
        $func_href = {};
    }
    elsif ( $line =~ $metric_line_re )
    {
        my ( $met_name, $us, $si ) = ( $1, $2, $5 );
        # print "metric_line: $met_name|$us|$si\n";
        push @{ $func_href->{metrics} },
          { name => $met_name,
            measurements => [ crack_measure( $us ),
                              crack_measure( $si ) ] };
    }
}

handle_func $func_href;

exit 0;

__DATA__
DIST - Distance
     DISTANCE:       12.3456 ft              4.5678 m
     STD DEV:        3.4567 ft               1.2345 m

AREA - Area
     AREA:           2345.6789 ft^2          345.6789 m^2
     PERIMETER:      234.5678 ft             89.0123 m
     STD DEV:        3.4567 ft               1.2345 m

DIST - Distance
     DISTANCE:       12.3456 ft              4.5678 m
     STD DEV:        3.4567 ft               1.2345 m

DIST - Distance
     DISTANCE:       8.9012 ft               3.0123 m
     STD DEV:        1.2345 ft               0.4567 m

DIST2 - Distance
     DISTANCE:       8.9012 ft               3.0123 m
     STD DEV:        1.2345 ft               0.4567 m