#!/bin/perl -w

package BlockGraph;

#
# This package is intended to draw a "block" graph, ie essentially
# a 2-d contour field but plotted by filling in blocks of colour
# rather than contours.
#
# There are 3 methods:
#
#   draw($rdata, nx => $nx, ny => $ny)
#
#   fdraw($filename, $cmd, nx => $nx, ny => $ny)
#
#   ($nx,$ny,$rdata) = readdata($file)
#
# The latter is just a useful utility that might as well be moved elsewhere
#

use Tk;
use strict;

$main::c=0;

# Define the screen scaling  - someday this should be variable...
my $xs=9;
my $ys=-9;
my $xo=undef;  				# Filled by define_widget
my $yo=undef;				# Ditto
my $width=500;
my $height=450;
$main::do=0;
$main::ds=0;

# Ditto the colours....
my @colours=qw(magenta purple darkblue blue lightblue white palevioletred red darkred orange yellow);
my $ncols=scalar(@colours);

# Globals for the data
my ($nx, $ny);		# Number of points in x and y
my @rn;			# Data range
my $title;		# Hm...

# Globals for Tk stuff
my ($mw,$f,$c,$ca);

# ----------------------------------------------
#
# Expect file format:
#  title
#  nx ny
#  data

sub readdata {				

  my $self = shift; 
  my $file=shift; 

  open(IN,$file) or die "cannot read input file: <$file>";
  chomp(my $title=<IN>);
  my ($nx,$ny)=split(/\s+/,$_=<IN>);
  my $sv=$/; undef $/;
  my @data=split(/\s+/,<IN>);
  $/=$sv;

  return($nx,$ny,$title,\@data);

}

# -----------------------------------------------

sub fdraw {

  my $self = shift;
  my ($filename,$cmd,@etc) = @_;
  print `$cmd`;
  my ($nx,$ny,$title,$rdata)=BlockGraph->readdata($filename);
  my $mw = $self->draw_nomainloop($rdata,nx=>$nx,ny=>$ny,@etc);
  $mw->title($title);
  fdraw_sub($filename,$cmd);
  MainLoop;

};

# -----------------------------------------------

sub fdraw_sub {

  my $filename = shift;
  my $cmd = shift;

# Remove whatever old tags may be there
  $c->addtag("tag","all");
  my @t = $c->find("all");
  for (@t) { $c->delete($_); };

  print `$cmd`;
  my ($nx,$ny,$title,$rdata)=BlockGraph->readdata($filename);
  $mw->title($main::c++." ".$title);
  draw_axes();
  colour_bar($main::do,$main::ds);
  block_fill($rdata, $main::do, $main::ds);
  `sleep 3` unless ($main::c==1);
  $mw->after(500, [\&fdraw_sub , $filename, $cmd]);

};

# ------------------------------------------------

sub draw {

  draw_nomainloop(@_);
  MainLoop;

};

# -----------------------------------------------

sub draw_nomainloop {

  my $self = shift;
  my $rdata= shift;
  my %opts = (
    nx 		=>	0,
    ny		=>	0,
    xs          =>      $xs,
    ys          =>      $ys,
    width       =>      $width,
    height      =>      $height,
    title       =>      "If you had supplied a title, this would be it",
    mw          =>      0,
    @_
  );

  $nx=$opts{nx};
  $ny=$opts{ny};
  $xs=$opts{xs};
  $ys=$opts{ys};
  $title=$opts{title};
  $mw=$opts{mw};

# Find the data range; declare the data->colour mapping
  @rn=makerange($rdata);
  my $do=-$rn[0]; $main::do=$do;
  my $ds=($ncols-1)/($rn[1]-$rn[0]); $main::ds=$ds;

  print "data range: ",join(",",@rn),"\n";
  print "do, ds: $do, $ds\n";

# Build the widget, draw the picture and the scale bar
  my $mw = define_widget( width => $opts{width}, height => $opts{height} ) unless $mw;
  draw_axes();
  colour_bar($do,$ds);
  block_fill($rdata, $do, $ds);
  
# Return mw in the hope of re-use...
  return $mw

};

# ------------------------------------------------

sub colour_bar {

  my ($do,$ds)=@_;

  my (@x,@y);
  my $cbsx=$nx/$ncols;
  my $cbsy=4;

  for (my $i=0; $i<$ncols; $i++) {
    @x=($i*$cbsx,($i+1)*$cbsx,($i+1)*$cbsx,$i*$cbsx);
    @y=(-2-$cbsy,-2-$cbsy,-2,-2);
    polyfill(\@x,\@y, -fill => $colours[$i]);

    xyouts($x[0], $y[0], sprintf("%1.1f",$i/$ds-$do));
  };

};

# -------------------------------------------------

sub define_widget {

my %opts = (
             height => 450
           , width  => 500
           , @_
           );

#
# Define the widget
#
$mw = MainWindow->new;
$mw->title("BlockGraph");

$f = $mw->Frame(-relief => 'groove', -bd => 2, -label => $title
               )->pack(-side => 'top', -fill => 'y');

$c = $mw->Scrolled("Canvas", -cursor => "crosshair",
                   -height => $opts{height}, -width => $opts{width},
                  )->pack(-side => 'left', -fill => 'both', -expand => 1);
$ca = $c->Subwidget("canvas");

#$mw->Button(-text => "Exit", -command => sub { $mw->destroy() })->pack(-side => "top");
$mw->Button(-text => "Exit", -command => sub { exit })->pack(-side => "top");

#
# Origin depends on size
#
$xo = 40;
$yo = $opts{height} - 50;

return $mw

};

# --------------------------------------------

sub block_fill {

# Parameters:
#
#  rdata - ref to data array
#  do,ds - scaling data -> colours

  my ($rdata,$do,$ds) = @_;

  my (@x,@y,$col);
  my $ind;

  for (my $j=0;$j<$ny;$j++) {
    for (my $i=0;$i<$nx;$i++) {
      @x=($i,$i+1,$i+1,$i); 
      @y=($j,$j,$j+1,$j+1);
      $ind=$j*$nx+$i;

      $col=$colours[($$rdata[$ind]+$do)*$ds];
      polyfill(\@x,\@y, -fill => $col);
    };
  }

};

# --------------------------------------------

sub draw_axes {

  plot(0,0, $nx,0);		# X axis
  plot(0,0, 0,$ny);		# Y axis

# Arrange "skip" to draw at most 20 numbers
  my $skip=int($nx/20+0.99);
  for (my $i=0;$i<=$nx;$i+=$skip) {
    plot($i,0,$i,-0.2);
    xyouts($i,-1,$i);
  };

# Arrange "skip" to draw at most 20 numbers
  $skip=int($ny/20+0.99);
  for (my $i=0;$i<=$ny;$i+=$skip) {
    plot(0,$i,-1,$i);
    xyouts(-1,$i,$i);
  };

};

sub plot {

  my ($x0,$y0,$x1,$y1)=@_;

  $c->createLine($x0*$xs+$xo, $y0*$ys+$yo,
                 $x1*$xs+$xo, $y1*$ys+$yo)

};
 
                
sub xyouts {

  my ($x0,$y0,$t)=@_;

  $c->createText($x0*$xs+$xo, $y0*$ys+$yo, -text => $t);

};

# --------------------------------------

sub polyfill {

# Expect args: ref to x, y coords; other stuff to pass onwards
  my ($rx,$ry,@rest)=@_;

# Convert refs to x, y arrays to (x1, y1, x2, y2, ....)
  my (@coords,$nc);
  $nc = min(0+@$rx,0+@$ry);
  for (my $i=0; $i<$nc; $i++) {
    $coords[2*$i]  =$$rx[$i]*$xs+$xo;
    $coords[2*$i+1]=$$ry[$i]*$ys+$yo;
  };

  $c->createPolygon(@coords,@rest);

};

# --------------------------------------

sub makerange {

  my ($rdata)=@_;

  my $mn=$$rdata[0];
  my $mx=$$rdata[1];

  for (my $i=0; $i<0+@$rdata; $i++) {
    if ($$rdata[$i]>$mx) { $mx=$$rdata[$i] };
    if ($$rdata[$i]<$mn) { $mn=$$rdata[$i] };
  };

  return ($mn,$mx)

};

# ---------------------------------------

sub min {

  my $min=$_[0];

  for (my $i=1; $i<@_+0; $i++) {
    if ($_[$i]<$min) { $min=$_[$i] }
  };

  return $min

};

1;