#!/usr/bin/perl -w
##
# Module for fading from one colour to another across a range of values.
# The fade is linear, and is efficient for integer values within the fade.
# The fade is defined by a table of 0xRRGGBB colours, and the value at which
# that colour should appear. For example:
#
# @code
# my @colours = (
#       { 'colour' => 0xff0000, 'value' => 0 },  # red
#       { 'colour' => 0x0000ff, 'value' => 10 }, # blue
# );
# @endcode
#
# Example use:
#
# @code
# my $fade = new ColourFade( @colours );
# my $htmlColour = $fade->htmlColour($value);
# @endcode
#
# If the values interpolated are integers, and the values requested are
# integers, the results will be cached within an array. If the values are
# fractional, or the range of the table is large, the colours will be
# calculated dynamically.
#
# This code is released under a free license. Use it as you wish without
# warranty or requirements. Put this module under GPL if you wish, but 
# consider that this loses freedom rather than granting any.
#

package ColourFade;

## The largest array size that we will create
my $arraylimit = 1000;

## The smallest size we'll care about
my $approximately_zero = 0.00001;

## Whether we debug this module or not
my $debug = 0;


# Was this code directly invoked? If so, we generate a HTML table
# which to test the code.
if ($0 =~ /ColourFade\.pm/)
{
    my $table = new ColourFade( 
        { 'colour' => 0xA15999, 'value' => -15 }, # Light purple
        { 'colour' => 0x40cccc, 'value' => -6  }, # Light cyan
        { 'colour' => 0xffffff, 'value' => -1  }, # White
        { 'colour' => 0x0000ff, 'value' => 0   }, # Blue
        { 'colour' => 0x44cc44, 'value' => 8   }, # Green
        { 'colour' => 0xffff44, 'value' => 16  }, # Yellow
        { 'colour' => 0xff4444, 'value' => 25  }, # Red
        { 'colour' => 0x880000, 'value' => 32  }, # Dark red
        { 'colour' => 0x880088, 'value' => 38  }, # Dark Purple
    );

    print "<h1>Integer table</h1>";
    print "<table>";
    print "<tr>";
    my ($low, $high) = $table->range();
    for ($low..$high)
    {
        print "<td bgcolor='". $table->htmlColour($_)."'>$_</td>";
    }
    print "</tr>";
    print "</table>";
    

    # Now a floating point table
    $table = new ColourFade( 
        { 'colour' => 0xA15999, 'value' => -0.15 }, # Light purple
        { 'colour' => 0x40cccc, 'value' => -0.06  }, # Light cyan
        { 'colour' => 0xffffff, 'value' => -0.01  }, # White
        { 'colour' => 0x0000ff, 'value' => 0.00   }, # Blue
        { 'colour' => 0x44cc44, 'value' => 0.08   }, # Green
        { 'colour' => 0xffff44, 'value' => 0.16  }, # Yellow
        { 'colour' => 0xff4444, 'value' => 0.25  }, # Red
        { 'colour' => 0x880000, 'value' => 0.32  }, # Dark red
        { 'colour' => 0x880088, 'value' => 0.38  }, # Dark Purple
    );

    print "<h1>Fractional table</h1>";
    print "<table>";
    print "<tr>";
    ($low, $high) = $table->range();
    for ($low*100..$high*100)
    {
        print "<td bgcolor='". $table->htmlColour($_/100)."'>",
                sprintf("%.2f", $_/100), "</td>";
    }
    print "</tr>";
    print "</table>";
    
    # Now a large logarithmic scale
    # The table is logarithmicly spaced, but the interpolation will still
    # be linear.
    $table = new ColourFade( 
        { 'colour' => 0xA15999, 'value' => 0.0001 }, # Light purple
        { 'colour' => 0x40cccc, 'value' => 0.001  }, # Light cyan
        { 'colour' => 0xffffff, 'value' => 0.01  }, # White
        { 'colour' => 0x0000ff, 'value' => 0.1   }, # Blue
        { 'colour' => 0x44cc44, 'value' => 1   }, # Green
        { 'colour' => 0xffff44, 'value' => 10  }, # Yellow
        { 'colour' => 0xff4444, 'value' => 100  }, # Red
        { 'colour' => 0x880000, 'value' => 1000  }, # Dark red
        { 'colour' => 0x880088, 'value' => 10000  }, # Dark Purple
    );
    
    print "<h1>Logarithmic table</h1>";
    print "<table>";
    print "<tr>";
    ($low, $high) = $table->range();
    $low = log($low) / log(10);
    $high = log($high) / log(10);
    for (my $logvalue = $low; $logvalue <= $high; $logvalue += 0.25)
    {
        my $value = 10 ** $logvalue;
        print "<td bgcolor='". $table->htmlColour($value)."'>",
              sprintf($value < 1 ? '%.4f' : 
                        $value < 10 ? '%.2f' : '%d', $value), "</td>";
    }
    print "</tr>";
    print "</table>";
}



##
# Create a new colour-fade object.
# The object can be used to produce interpolations between the colours.
#
# @param[in] $class     Class we are an instance of
# @param[in] @scale     The scale values for this object.
#
# @return new instance
sub new
{
    my $proto = shift;
    my (@scale) = @_;
    my $class = ref($proto) || $proto;

    my $table = {};
    my $colour = [];
    my $min = undef;
    my $max = undef;

    bless $table, $class;

    # Make a copy of the table.
    @scale = map {
                (
                    { 'colour' => $_->{'colour'},
                      'value'  => $_->{'value'} }
                )
             } @scale;
    $table->{'scale'} = \@scale;

    # Construct the array as required.
    $table->_makeTable();

    return $table;
}



##
# Make a table of the colours for given indices,
# based on an imput table.
#
# @param[in] $table     This object
sub _makeTable
{
    my ($table) = @_;
    my $colour = [];
    my $min = undef;
    my $max = undef;

    # Read the scale values.
    my @scale = @{ $table->{'scale'} };

    for my $i (0..$#scale)
    {
        if (!defined $min ||
            $min > $scale[$i]->{'value'})
        {
            $min = $scale[$i]->{'value'};
        }
        if (!defined $max ||
            $max < $scale[$i]->{'value'})
        {
            $max = $scale[$i]->{'value'};
        }
    }
    $table->{'base'} = $min;
    $table->{'limit'} = $max - $min;
    for my $i (0..$#scale)
    {
        $scale[$i]->{'offset'} = $scale[$i]->{'value'} - $min;
    }

    $scale[0]->{'size'} = 0;
    for my $i (1..$#scale)
    {
        my $fromc = $scale[$i-1]->{'colour'};
        my $fromv = $scale[$i-1]->{'offset'};
        my $toc = $scale[$i]->{'colour'};
        my $tov = $scale[$i]->{'offset'};
        my $fromrgb = _torgb($fromc);
        my $torgb = _torgb($toc);
        my $steps = $tov - $fromv;
        my %step = ( 'r' => ($torgb->{'r'}-$fromrgb->{'r'}) / $steps,
                     'g' => ($torgb->{'g'}-$fromrgb->{'g'}) / $steps,
                     'b' => ($torgb->{'b'}-$fromrgb->{'b'}) / $steps );
        $scale[$i]->{'size'} = $steps;
        $scale[$i]->{'step'} = \%step; # How big each unit step is?
        $scale[$i]->{'fromrgb'} = { %$fromrgb };
        $scale[$i]->{'torgb'}   = { %$torgb };

        # Only initialise the array if these values are integers - otherwise
        # we'll be getting the wrong values.
        if (int($fromv) == $fromv &&
            int($tov) == $tov &&
            $tov < $arraylimit)
        {
            for my $v ($fromv..$tov)
            {
                $colour->[$v] = _value( $fromrgb );
                $fromrgb->{'r'} += $step{'r'};
                $fromrgb->{'g'} += $step{'g'};
                $fromrgb->{'b'} += $step{'b'};
            }
            # Ensure that the final colour is correct, regardless of rounding.
            $colour->[$tov] = $toc;
        }
    }
    $table->{'array'} = $colour;
}


##
# Composite RGB value to internal broken down form
#
# @param[in] $c     0xRRGGBB colour
#
# @return hashref of r,g,b values.
sub _torgb
{
    my ($c) = @_;
    return { 'r' => int($c>>16) & 255,
             'g' => int($c>>8) & 255,
             'b' => int($c) & 255 }
}


##
# Convert an internal broken down form to RGB value
#
# @param[in] $rgb   hashref of r,g,b values
#
# @return 0xRRGGBB colour
sub _value
{
    my ($rgb) = @_;
    return (int($rgb->{'r'})<<16) |
           (int($rgb->{'g'})<<8) |
           (int($rgb->{'b'})<<0);
}


##
# Return a HTML colour for a given index
#
# @param[in] $table  The colour table object
# @param[in] $index  The index to use
#
# @return HTML colour for that index
sub htmlColour
{
    my ($table, $index) = @_;
    my $col = $table->colour($index);
    return sprintf "#%06x", $col;
}


##
# Return the colour for a given index
#
# @param[in] $table  The colour table object
# @param[in] $index  The index to use
#
# @return Colour as a 0xRRGGBB value
sub colour
{
    my ($table, $index) = @_;
    my $colour = $table->{'array'};

    $index -= $table->{'base'};
    $index = 0 if ($index < 0);
    $index = $table->{'limit'} if ($index >= $table->{'limit'});

    print STDERR "Colour: $index\n" if ($debug);
    
    if (int($index) == $index &&
        defined $colour->[$index])
    {
        return $colour->[$index];
    }

    # It's not an integer value, or the colour value
    # has not been placed into the array (usually because
    # the array would be very large).
    # In this case we need to calculate the value we are
    # going to use.
    
    # Step through the array list, looking for the next
    # colour which we can use;
    print STDERR "Want: $index\n" if ($debug);
    my $last = undef;
    for my $col (@{ $table->{'scale'} })
    {
        print STDERR "  Compare: $col->{'offset'}\n" if ($debug);
        if (defined $last &&
            $col->{'offset'} > $index)
        {
            # We have found the colour we want to use!
            my $offset = $index - $last->{'offset'};
            print STDERR "  Offset: $offset\n" if ($debug);
            
            # Is this actually the right colour (no interpolation)?
            if ($offset <= $approximately_zero)
            {
                # We can say that this is the colour to use
                printf STDERR "  Found: %06x\n", $last->{'colour'} if ($debug);
                return $last->{'colour'};
            }
            
            if ($debug)
            {
                print STDERR "  Range: $last->{'offset'} - $col->{'offset'}\n";
                print STDERR "  Rx: $col->{'fromrgb'}->{'r'}-$col->{'torgb'}->{'r'}\n";
                print STDERR "  Gx: $col->{'fromrgb'}->{'g'}-$col->{'torgb'}->{'g'}\n";
                print STDERR "  Bx: $col->{'fromrgb'}->{'b'}-$col->{'torgb'}->{'b'}\n";
                print STDERR "  R: $col->{'step'}->{'r'}\n";
                print STDERR "  G: $col->{'step'}->{'g'}\n";
                print STDERR "  B: $col->{'step'}->{'b'}\n";
                print STDERR "  R+: ", ($col->{'step'}->{'r'}*$offset), "\n";
                print STDERR "  G+: ", ($col->{'step'}->{'g'}*$offset), "\n";
                print STDERR "  B+: ", ($col->{'step'}->{'b'}*$offset), "\n";
            }
            my $rgb = {
                'r' => $col->{'fromrgb'}->{'r'} +
                            $col->{'step'}->{'r'} * $offset,
                'g' => $col->{'fromrgb'}->{'g'} +
                            $col->{'step'}->{'g'} * $offset,
                'b' => $col->{'fromrgb'}->{'b'} +
                            $col->{'step'}->{'b'} * $offset,
            };
            
            if ($debug)
            {
                print STDERR "  R=: $rgb->{'r'}\n";
                print STDERR "  G=: $rgb->{'g'}\n";
                print STDERR "  B=: $rgb->{'b'}\n";
            }

            return _value($rgb);
        }
        $last = $col;
    }

    # It's higher than the max, so use that.
    return $last->{'colour'};
}


##
# Return the range for the colour table
#
# @param[in] $table The colour object
#
# @return Lowest value, highest value
sub range
{
    my ($table) = @_;
    my $base = $table->{'base'};
    my $limit = $table->{'limit'};
    return ($base, $base + $limit);
}


# Must return true
1;
