#!/usr/local/bin/perl -w
# ========================================================================
# fat2wdayhist - generate weekday histogram of weight and fat measurements
# Andrew Ho (andrew@tellme.com)
#
# This program generates a PNG bar graph from an XML file provided as an
# argument filename, or piped to stdin. It uses FatXML::Parser to do the
# parsing; see the documentation for FatXML.pm for the details to the XML
# format accepted.
# ========================================================================

require 5.005;
use strict;

use FatXML ();
use GD ();
use Symbol qw(gensym);
use IPC::Open2 qw(open2);
use Time::Local qw(timelocal);
use File::Basename qw(basename);

use vars qw($ME $GNUPLOT @WEEKDAYS);
$ME = basename $0;
$GNUPLOT = '/usr/local/bin/gnuplot';
@WEEKDAYS = qw( Sunday Monday Tuesday Wednesday
                Thursday Friday Saturday );


# ------------------------------------------------------------------------
# Initialization

# Parse the XML input to get a FatXML::Measures object.

my $parser = FatXML::Parser->new;
my $measures = undef;

$@ = '';
eval {
    $measures = @ARGV ? $parser->parsefile(shift)
                      : $parser->parse(\*STDIN);
};

if($@ || !defined $measures) {
    if($@) {
        $@ =~ s/^\s+//gsm;
        $@ =~ s/\s+$//gsm;
        print STDERR $ME, ': parse error: ', $@, "\n";
        exit 2;
    } else {
        print STDERR $ME, ": general parse error\n";
        exit 2;
    }
}


# ------------------------------------------------------------------------
# Create the data to plot

my @weights = ();
my @fats = ();
foreach my $m ($measures->measures) {
    my $weekday = date_weekday($m->date);
    if(defined $weights[$weekday]) {
        push @{$weights[$weekday]}, $m->weight;
        push @{$fats[$weekday]},    $m->fat;
    } else {
        $weights[$weekday] = [ $m->weight ];
        $fats[$weekday]    = [ $m->fat ];
    }
}

my($data, $min_weight, $max_weight, $min_fat, $max_fat);
{
    my @d_weekdays = map { $WEEKDAYS[$_]      } 0 .. $#weights;
    my @d_weights  = map { mean($weights[$_]) } 0 .. $#weights;
    my @d_fats     = map { mean($fats[$_])    } 0 .. $#weights;

    $data = join "\n",
        ( map { join "\t", $_ - 0.2, $_ + 0.2, $d_weights[$_], $d_fats[$_] }
              0 .. $#d_weekdays ), "e";

    $min_weight = $d_weights[0]; $max_weight = 0;
    $min_fat    = $d_fats[0];    $max_fat = 0;
    foreach(0 .. $#weights) {
        $min_weight = $d_weights[0] if $min_weight > $d_weights[0];
        $max_weight = $d_weights[0] if $max_weight < $d_weights[0];
        $min_fat    = $d_fats[0]    if $min_fat    > $d_fats[0];
        $max_fat    = $d_fats[0]    if $max_fat    < $d_fats[0];
    }
}


# ------------------------------------------------------------------------
# Open a bidirectional pipe to gnuplot and generate the plot

my $read_fh  = gensym;
my $write_fh = gensym;
if(open2($read_fh, $write_fh, $GNUPLOT)) {
    my $fh = select $write_fh;
    local $| = 1;

    my $y1_min = int $min_weight; $y1_min-- if $y1_min >= $min_weight;
    my $y1_max = int $max_weight; $y1_max++ if $y1_max <= $max_weight;
    my $y2_min = int $min_fat;    $y2_min-- if $y2_min >= $min_fat;
    my $y2_max = int $max_fat;    $y2_max++ if $y2_max <= $max_fat;

    $y1_min -= 1.5; $y1_max += 1.5;    # Allow room for the legend (top)
    $y2_min -= 1.5; $y2_max += 1.5;    # and eliminate the edge y labels

    my $plots = join ", ",
        q("-" using 1:3 axes x2y1 title "Weight" with boxes),
        q("-" using 2:4 axes x2y2 title "Body Fat" with boxes);

    print << "    EndGnuplot";
        set terminal png color
        set size 0.5, 0.375

        # We plot the actual data on the x2 axes (top axes) and
        # turn off label displays for it.

        set x2range [-0.5:6.5]
        set nox2tics
        set boxwidth 0.4

        # Display weekday names on the bottom axes. We use
        # a known date range (from the first week of the Epoch)
        # to get these correct.

        set xdata time
        set timefmt "%Y-%m-%d/%H"
        set xrange ["1970-01-03/12":"1970-01-10/12"]
        set xtics nomirror
        set format x "%a"

        set yrange [$y1_min:$y1_max]
        set ytics nomirror
        set ytics 1
        set format y "%g"

        set y2range [$y2_min:$y2_max]
        set y2tics nomirror
        set y2tics 1
        set format y2 "%g%%"

        plot $plots
    EndGnuplot
    print "$data\n" x 2;
    close $write_fh;


    # Read the PNG data and create a GD object from it.

    select $fh;
    local $/ = undef;
    my $png = <$read_fh>;
    close $read_fh;

    my $image = GD::Image->newFromPngData($png);

    # The default gnuplot PNG colors for the 2 types of boxes in
    # this plot are red and green. We replace these with red for
    # weight and blue for body fat percentage.

    my $red  = $image->colorReplace( 255,   0,   0, 204,   0,   0 );
    my $blue = $image->colorReplace(   0, 255,   0,   0,   0, 204 );


    # Fill in the bars (pixel values determined empirically).

    for(my $x = 50; $x < (50 + 34 * 7); $x += 34) {
        $image->fill($x, 158, $red);
    }
    for(my $x = 64; $x < (64 + 34 * 7); $x += 34) {
        $image->fill($x, 158, $blue);
    }

    binmode STDOUT;
    print STDOUT $image->png
}

exit 0;


# ------------------------------------------------------------------------
# Internal subroutines

# date_weekday($date) takes $date in ISO 8601 like format (four-digit
# year, two-digit month, two-digit day, separated by hyphens) and returns
# the weekday number (as in $wday returned by localtime() the range is
# 0-6, where 0 is Sunday) corresponding to that date.

sub date_weekday {
    my $date = shift;
    my($year, $month, $day) = split '-', $date, 3;
    return unless $year && $month && $day;
    my $time = timelocal(0, 0, 0, $day, $month - 1, $year - 1900);
    my $wday = (localtime($time))[6];
    return $wday;
}


# mean(@array) or mean($arrayref) returns the mean (average) of all the
# elements in @array (or $arrayref).

sub mean {
    return unless @_ > 0;
    my $values = @_ == 1 ? shift : [ @_ ];
    my $total = 0;
       $total += $_ foreach @$values;
    return $total / @$values;
}


# ========================================================================
# Color replacement code

# This code extends the GD::Image object to provide a colorReplace()
# method. $image->colorReplace($r1, $g1, $b1, $r2, $g2, $b2) replaces
# the color closest to the RGB triplet ($r1, $g1, $b1) with the color
# ($r2, $g2, $b2). It does this by figuring out the index of the
# existing color to replace, deallocating it, and reallocating colors
# until we hit that index again. colorReplace() returns the new index
# of the color, or false if the replacement fails.

package GD::Image;

sub colorReplace {
    my $self = shift;
    my($r1, $g1, $b1, $r2, $g2, $b2) = @_;

    # Deallocate the original color to replace
    my $index = $self->colorClosest($r1, $g1, $b1);
    return unless defined $index;
    $self->colorDeallocate($index);

    # Reallocate colors until we hit the index of that original color
    my $start_index = undef;
    my $new_index = undef;
    while($new_index = $self->colorAllocate($r2, $g2, $b2)) {
        $start_index = $new_index unless defined $start_index;
        last if $new_index >= $index;
    }

    return $new_index;
}


# ========================================================================
__END__