The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w

use lib qw(blib/lib blib/arch);

use Imager;
use Imager::Plot;
use Time::Local;

Imager::Font->priorities(qw(w32 ft2 tt t1));

$plot = Imager::Plot->new(Width  => 400,
			  Height => 350,
			  GlobalFont => get_font() );

$img = Imager->new(xsize=>450, ysize => 400);
$img->box(filled=>1, color=>'white');



@height = map { $_ + 15*(rand()-.5) } 100..180;
@weight = map { ($_)/3 + 35*(rand()-.5) } 100..180;


my ($minh, $maxh) = (sort {$a<=>$b} @height)[0,-1];
my ($a, $b) = ls_fit(\@height, \@weight);

@FIT = ([$minh, $a+$b*$minh], [$maxh, $a+$b*$maxh]);




$plot->AddDataSet(X=>\@height, Y=>\@weight, style=>{code=>{
    ref=>\&bar_style,
    opts=>undef}});

$plot->AddDataSet(XY=>\@FIT, style=>{line=>{color=>'red', antialias=>1}});







#$plot->AddDataSet(XY => \@tr, style=>{code=>{
#					     ref=>\&bar_style,
#					     opts=>undef
#					    }});



$Axis = $plot->GetAxis();

# this is mighty handy for time formating

$Axis->{YgridNum} = 8;
$Axis->{XgridNum} = 10;
$Axis->{Border} = "lb";


$Axis->{make_xrange} = sub {
  $self = shift;
  my $span = $self->{XDRANGE}->[1]-$self->{XDRANGE}->[0];
  $self->{XRANGE} = [$self->{XDRANGE}->[0]-$span*0.05,
		     $self->{XDRANGE}->[1]+$span*0.05];
};

$Axis->{make_yrange} = sub {
  $self = shift;
  my $span = $self->{YDRANGE}->[1]-$self->{YDRANGE}->[0];

  $self->{YRANGE} = [$self->{YDRANGE}->[0]-$span*0.2,
		     $self->{YDRANGE}->[1]+$span*0.2];
};


$plot->{'Ylabel'} = 'Weight [kg]';
$plot->{'Xlabel'} = 'Height [cm]';
$plot->{'Title'} = 'Scatter of Relation';


sub bar_style {
  my ($DataSet, $xr, $yr, $Xmapper, $Ymapper, $img, $opts) = @_;

  my @x = @$xr;
  my @y = @$yr;

  for (0..$#x) {
      $img->box(color=>'blue', xmin=>$x[$_]-2, xmax=>$x[$_]+2, ymin=>$y[$_]-2, ymax=>$y[$_]+2, filled=>1);
  }
}


$plot->Render(Image => $img, Xoff => 40, Yoff => 370);

mkdir("sampleout", 0777) unless -d "sampleout";
$img->write(file => "sampleout/sample8.ppm");



# find the coefficients for matching
# y = a+bx in the least squares sense to input data

sub ls_fit {
  my @x = @{$_[0]};
  my @y = @{$_[1]};

  my $mx = mean(@x);
  my $my = mean(@y);
  my $varx = sum(map { $_*$_ } @x) - @x * $mx*$mx;
  my $vary = sum(map { $_*$_ } @y) - @y * $my*$my;

  my $covxy = sum(map { $x[$_]*$y[$_] } 0..$#x)-@x*$mx*$my;

  my $b = $covxy / $varx;
  my $a = $my - $b*$mx;
  return ($a, $b);
}

sub sum {
  my $t = 0;
  $t+=$_ for @_;
  $t;
}

sub mean {
  return sum(@_)/@_;
}



sub get_font {
  my %opts = (size=>12, color=>Imager::Color->new('black'));

  my $font = Imager::Font->new(file=>"ImUgly.ttf", %opts)
    || Imager::Font->new(file=>"./dcr10.pfb", %opts);
  die "Couldn't load any font!\n" unless $font;

  return $font;
}