#! /usr/bin/perl
#
# File: eyeplot2
# Time-stamp: <03/06/06 13:32:25 martinc>
# $Id: eyeplot,v 1.5 2003/06/06 12:33:48 martinc Exp $
#
# Copyright (C) 2003 University of Edinburgh
# Author: Martin Corley

use Graphics::Plotter;
use Term::ReadKey;
use Getopt::Long;

# GLOBALS
our %CONFIG;    # keeps configuration details
our @COLOURS;   # colours for successive display lines
our %REGFILE;   # region file details

configure(); # read in configuration, get options

# open files for reading
$CONFIG{R_FH}=open_or_die('<',$CONFIG{REG_FILE});
$CONFIG{S_FH}=open_or_die('<',$CONFIG{SUB_FILE});

print_header();   # identify program: print instructions

parse_reg($CONFIG{R_FH});      # parse the region file
close ($CONFIG{R_FH}); #finished with this

do_plots($CONFIG{S_FH});       # do the plots!

close ($CONFIG{S_FH}); #finished

# useful info on how to get lines of a display
# my $href=deparse_region_array(@{$REGFILE{56}{1}});
# print $$href{'000'}{MAT},"\n",join(' ',@{$$href{'000'}{REGIONS}}),"\n";



sub do_plots {
  my $fh=shift;

  # set up display
  my $disp = Graphics::Plotter::X->new();
  if ($disp->openpl() < 0) {
    exit(error("can't open window for plotting: $!"));
  }

  $disp->fspace(0,0,$CONFIG{PBOX_SIZE},$CONFIG{PBOX_SIZE});

  while (my $line = <$fh> ) {
    local $|=1;               # for instant output;

    do_plot($disp,$line);

    ReadMode 3;
    print ":: ";
    my $key=getc();
    ReadMode 0;

    if ($key =~ /[Qq]/) {
      print "QUIT\n";
      last;
    } elsif ($key =~ /[Pp]/) {
      print "PostScipt: ";
      do_print($line,"PS");
    } elsif ($key =~ /[Ff]/) {
      print "XFig: ";
      do_print($line,"Fig");
    } else {
      print "\n";
    }
    $disp->erase();
  }
  $disp->closepl();
}

sub do_print {
  my ($line,$format)=@_;
  my ($ord,$cn,$no,@rest) = split (' ',$line);

  my $fn = $CONFIG{SUB_FILE} . ".$no.$cn." . lc($format);
  my $fh = open_or_die('>',$fn);
  my $Class="Graphics::Plotter::" . $format;

  my $file=$Class->new(STDIN,$fh,STDERR);
  if ($file->openpl() < 0) {
    exit(error("can't open file for printing"));
  }
  $file->fspace(0,0,$CONFIG{PBOX_SIZE},$CONFIG{PBOX_SIZE});


  do_plot($file,$line);
  $file->closepl();

  print "wrote $fn\n";

#  $file->DESTROY;
}


sub do_plot {
  my ($disp,$line)=@_;
  my ($ord,$cn,$no,$len,$but,$t1,$t2,$fix,@rest) = split (' ',$line);
  my ($href,$ytop);

  unless (defined $REGFILE{$no}{$cn}) {
    exit(error("can't find data for $no ($cn)"));
  }

  $href=setup_drawing($disp,$len,$no,$cn,@{$REGFILE{$no}{$cn}});

  my $lastline=999;
  my $laststart;
  my $laststop=0;
  my $lastcolour;

  for (my $i=0; $i<$fix;$i++) {
    my ($x,$y,$start,$stop) = splice(@rest,0,4);
    my $colour=sprintf("%03d",$y);
    my $colref=$CONFIG{COLOUR}{$colour};
    unless (defined $colref) {
      print STDERR "unreferenced row: $colour\n";
    } else {
      $disp->pencolor(@$colref);

      if ($y != $lastline) {
	if ($CONFIG{SHOW_REGIONS} && $laststop !=0) {
	  show_regions($disp,$lastcolour,$no,$cn,y_value($laststart),
		       y_value($laststop));
	  $disp->pencolor(@$colref);
	}
	$disp->fmove(x_value($x),y_value($start));
	$lastline = $y;
	$laststart= $start;
      } else {
	$disp->fcont(x_value($x),y_value($start));
      }
      $disp->fcont(x_value($x),y_value($stop));
      $laststop=$stop;
      $lastcolour=$colour;
      if ($CONFIG{SHOW_LABELS}) {
	show_label($disp,$x,$start,$stop);
      }
    }
  }
  if ($CONFIG{SHOW_REGIONS}) {
    show_regions($disp,$lastcolour,$no,$cn,y_value($laststart),
		 y_value($laststop));
  }
  $disp->flushpl();
}

sub show_regions {
  my ($disp,$colour,$no,$cn,$start,$stop) = @_;
  my $href=deparse_region_array(@{$REGFILE{$no}{$cn}});
  my $regcount=$$href{$colour}{REGIONS}[0];
  if ($regcount == 1) {
    return;
  }
  my $colref=$CONFIG{COLOUR}{$colour};
  $disp->pencolor(@$colref);
  $disp->linemod('dotted');

  my $pos=0;
  for (my $i = 1;$i<$regcount;$i++) {
    my $nextreg=$$href{$colour}{REGIONS}[$i];
    my $xv=x_value($nextreg+$pos)-(.5*$CONFIG{FONT_SIZE});
    $disp->fline($xv,$start,$xv,$stop);
    $pos+=$nextreg;
  }

  $disp->linemod('solid');

}



sub show_label {
  my ($disp,$x,$start,$stop) = @_;

  my $diff=($stop-$start);
  my $ypos=(y_value($start+($diff/2)));
  my $xpos=(x_value($x)-(.25 * $CONFIG{FONT_SIZE}));

  $disp->fmove($xpos,$ypos);
  $disp->pencolor(0,0,0); # just use black (?)
  $disp->alabel('r','c',$diff);
  $disp->fmove(x_value($x),y_value($stop));
}


sub setup_drawing {
  my ($disp,$len,$no,$cn,@array)=@_;

  my $href=deparse_region_array(@array);

  ##### HERE: Need to return href because regions have to be done as
  ##### part of the plot
  my $y_start=$CONFIG{PBOX_SIZE}-$CONFIG{FONT_SIZE};
  my $colour_index=0;

  $disp->fontname($CONFIG{FONT_NAME});
  $disp->ffontsize($CONFIG{FONT_SIZE});

  foreach my $key (sort keys %$href) {
    my $x=0;
    $disp->pencolor(@{$COLOURS[$colour_index]});
    $CONFIG{COLOUR}{$key}=$COLOURS[$colour_index];
    my @letters=split('',$$href{$key}{MAT});
    foreach my $letter (@letters) {
      $disp->fmove(x_value($x++),$y_start);
      $disp->alabel('c','x',$letter);
    }
    $y_start-=$CONFIG{FONT_SIZE};
    $colour_index = (($colour_index+1) % @COLOURS);
  }

  set_y_scale($len,$y_start);

  $disp->pencolor(0,0,0); # back to black
  $disp->fontname($CONFIG{LFONT_NAME}); # switch to label font

  for ($y=0;$y<=y_max();$y+=2*$CONFIG{Y_GRAN}) {
    $disp->fmove(20,y_value($y));
    $disp->alabel('l','c',$y);
    $disp->fmoverel(.5*$CONFIG{FONT_SIZE},0);
    $disp->fcont(5*$CONFIG{FONT_SIZE},y_value($y));
  }

#  if ($CONFIG{SHOW_LABELS} && $CONFIG{Y_GRAN} > 500) {
    # if we're going to have to show labels, cut font size to a half
#    $disp->ffontsize($CONFIG{FONT_SIZE}*.75);
#  }

  return ($href);
}


sub print_header {
  print scalar proginfo()," (MC)\n";
  print ":: 'p' to output PostScript, 'f' for Xfig format\n",
        ":: 'q' to quit, any key for next item\n\n";
}

sub parse_reg {
  my $fh=shift;
  my $line_num=0;
  my $ignore_lines=0;
  my @array=();

  while (my $line = <$fh>) {
    chomp $line;

    $line =~ tr/\x1A/\n/; #get rid of ctrl-z
    if ($line =~ /^(.+)\{(\d+)\s+(\d+)/) {
      my $cond=$2;
      my $no=$3;
      push(@array,$line_num,parse_regions($1));
      if ($cond < 80) {
	$REGFILE{$no}{$cond}=[@array]; # should make copy?
#	print STDERR "$no $cond => ",join(':',@array),"\n";
      }
      $line_num=0;
      $ignore_lines=1;
      @array=();
    } elsif ($line !~ /^\s*$/) {
      push(@array,$line_num,parse_regions($line));
      $ignore_lines=0;
    }
    $line_num++ unless($ignore_lines);
  }
}

sub parse_regions {
  my $line=shift;

  my @regions=split /\//,$line;
  my @reglengths=map (length($_),@regions);
  my $fmat = join('',@regions);
  return (scalar @regions,$fmat,@reglengths);
}

sub deparse_region_array {
  my @array=@_;
  my %hash;

  while (my ($lineno,$regions) = splice(@array,0,2)) {
    my ($mat,@regions) = splice(@array,0,$regions+1);
    $lineno=sprintf("%03d",$lineno); # for sorting order
    $hash{$lineno}{MAT}=$mat;
    $hash{$lineno}{REGIONS}=[$regions,@regions];
  }
  return \%hash;
}

sub x_value {
  my $char=shift;
  return ($CONFIG{Y_LABEL_SIZE}+$char+.5) * $CONFIG{FONT_SIZE};
}

{
  # local to y-scaling routines
  my $y_max;
  my $y_box;

  sub set_y_scale {
    my ($len,$ytop)=@_;
    my ($y_gran,$max);
    my @tmp_yg = @{$CONFIG{Y_GRANULARITY}};
    $y_box = $ytop;
#   print STDERR "y_box = $y_box\n";
    while (($y_gran,$max) = splice(@tmp_yg,0,2)) {
      last if (($len <= $max) || ($max == 0));
    }
    $CONFIG{Y_GRAN}=$y_gran;

    $y_max= (int($len / $y_gran) + 1) * $y_gran;
  }

  sub y_max {
    return $y_max;
  }

  sub y_value {
    my $ms=shift;

    my $y_value=($ms/$y_max) * $y_box;
    return ($y_box - $y_value);
  }
}



sub open_or_die {
  my ($mode,$file) = @_;
  my $ec = ($mode eq '<' ? 'reading' : 'writing');
  my $fh;

  open ($fh,$mode,$file) or exit(error("can't open '$file' for $ec: $!"));
  return ($fh);
}


sub print_usage {
  my @pi = proginfo();

  print STDERR "Usage: $pi[0] [options] <region-file> <filename> / $pi[0] --help\n";
  return 1;
}

sub error {
  my @pi      = proginfo();
  my $message = shift;

  print STDERR "$pi[0]: $message\n";
  return 1;
}

sub proginfo {
  my $prog;
  my $version = '$Revision: 1.5 $ ';
  my $date    = '$Date: 2003/06/06 12:33:48 $ ';

  ($prog = $0) =~ s|^(.+)/([^/]+)$|$2|;
  $version =~ s/^\$Revision: //;
  $version =~ s/ \$ $//;
  $date    =~ s/\$Date: //;
  $date    =~ s/ [0-9:]+ \$ $//;

  return "$prog $version ($date)" unless wantarray;
  return ($prog, $version, $date);
}

sub print_help {
  print scalar proginfo()," (MC)\n\n";
  print_usage();

  print STDERR <<END_OF_HELP;

  --regions   : show divisions between regions in .reg file
  --labels    : label each fixation with its duration in ms

END_OF_HELP

  exit(0);
}
sub configure {
  ## changeable parameters here ----------------------------------
  my $XBOX_SIZE = '740x740';     # size of X Window
  my $MAX_CHARS = 80;            # max length of line
  my $Y_LABEL_SIZE = 5;          # y label, in number of char spaces
  my $FONT_NAME = 'Courier-Bold';# font for text of materials
  my $LFONT_NAME = 'Helvetica';  # font for labels etc.
  my $PAPER_SIZE = 'a4';         # size of paper for PS output
  my @Y_GRANULARITY = (250,5000,500,10000,1000,0);
    # scale(s) to use to step scaling up: granularity, max
  ## colours (for each line of text (R,G,B) -- add more if needed)
  @COLOURS= ([0,0,0],      #black
	     [0xffff,0,0], #red
	     [0,0xffff,0], #green
	     [0,0,0xffff], #blue
	     [0xffff,0,0xffff], #magenta
	     [0xffff,0xcccc,0], #yellow-orange
	     [0,0xcccc,0xffff], #cyan-blue
	     [0xaaaa,0xaaaa,0xaaaa], #grey
	    );

  ## end of changeable parameters --------------------------------
  $CONFIG{SHOW_LABELS}=0;
  $CONFIG{SHOW_REGIONS}=0;
  GetOptions (
	      "labels" => \$CONFIG{SHOW_LABELS},
	      "regions" => \$CONFIG{SHOW_REGIONS},
	      "help"    => \&print_help,
	     )
    or exit (print_usage());

  if (@ARGV != 2) {
    exit (print_usage());
  }

  Graphics::Plotter::parampl('BITMAPSIZE',$XBOX_SIZE);
  Graphics::Plotter::parampl('VANISH_ON_DELETE','yes');
  Graphics::Plotter::parampl('PAGESIZE',$PAPER_SIZE);

  my $FONT_SIZE=48; #nominal, but affects how many virtual points
                    #there are

  $CONFIG{PBOX_SIZE}=($MAX_CHARS+$Y_LABEL_SIZE)*$FONT_SIZE;
  $CONFIG{MAX_CHARS}=$MAX_CHARS;
  $CONFIG{Y_LABEL_SIZE}=$Y_LABEL_SIZE;
  $CONFIG{LFONT_NAME}=$LFONT_NAME;
  $CONFIG{FONT_NAME}=$FONT_NAME;
  $CONFIG{FONT_SIZE}=$FONT_SIZE;
  $CONFIG{Y_GRANULARITY}=\@Y_GRANULARITY;
  $CONFIG{REG_FILE}=$ARGV[0];
  $CONFIG{SUB_FILE}=$ARGV[1];
}