#!/usr/bin/perl -w

# This script takes a showplay input file and output file,
# and creates an XML file describing the events.

use strict;

use FindBin qw($RealDir);
use lib "$RealDir";

use Fcntl qw/SEEK_SET/;

use XML::XPath;
use XML::XPath::XMLParser;

my $snaptotr = undef;
my $snaptotroffset = 0;
my $opt_overwrite = 0;
my $opt_subtractonset = 0;
my $opt_xcede2 = 0;
my $opt_xcede2dataid = undef;
my $opt_nooverlap = 0;

my $usage = <<EOM;
Usage:
  $0 [opts] pdigmfile [eventfile.xml]
  $0 [opts] run.ppf [show.out] eventfile.xml

Options: --snaptotr TR[:offset]
         --overwrite
         --subtractonset secs
         --nooverlap
         --xcede2
         --xcede2dataid ID

This program creates an XML events file from the output of CIGAL/showplay.
In the first example, if the second argument (eventfile.xml) is missing,
results are sent to standard output.  In the second example, eventfile.xml
must be specified.  --snaptotr indicates that each event time should
be shifted to the closest timepoint that is a multiple of TR, with
an optional offset, separated from the TR by a colon.  Default
offset is 0.  If --overwrite is not specified, then existing files
will not be overwritten.  --subtractonset subtracts the given number of
seconds from all onset times (to correct for timing errors).  It can be used
to add a number to the onset by specifying a negative number.  --xcede2
specifies that the output should be in XCEDE-2.0 format.  If --xcede2dataid
is not specified, the data element ID will be auto-generated based on
hostname, process ID, and current time.  If --nooverlap is specified, the
duration will be calculated as the minimum of the prescribed duration (in
the showplay parameter file) and the time to the next stimulus.
EOM

my @oldARGV = @ARGV;
@ARGV = ();
while (scalar(@oldARGV)) {
  my $arg = shift @oldARGV;
  if ($arg =~ /^--$/) {
    push @ARGV, @oldARGV;
    last;
  }
  if ($arg !~ /^--/) {
    push @ARGV, $arg;
    next;
  }
  my ($opt, undef, $opteq, $optarg) = ($arg =~ /^--([^=]+)((=)?(.*))$/);
  if (defined($opteq)) {
    unshift @oldARGV, $optarg;
  }
  if (scalar(@oldARGV) > 0) {
    $optarg = $oldARGV[0]; # in case option takes argument
  }
  if ($opt eq 'help') {
    print STDERR $usage;
    exit(-1);
  } elsif ($opt eq 'xcede2') {
    $opt_xcede2++;
  } elsif ($opt eq 'xcede2dataid' && defined($optarg)) {
    $opt_xcede2dataid = $optarg;
    shift @oldARGV;
  } elsif ($opt eq 'overwrite' && !defined($opteq)) {
    $opt_overwrite++;
  } elsif ($opt eq 'nooverlap' && !defined($opteq)) {
    $opt_nooverlap++;
  } elsif ($opt eq 'subtractonset' && defined($optarg)) {
    shift @oldARGV;
    $opt_subtractonset = $optarg;
  } elsif ($opt eq 'snaptotr' && defined($optarg)) {
    shift @oldARGV;
    my ($tr, undef, $offset) = ($optarg =~ /^([\d.]+)(:([\d.]+))?$/);
    if (!defined($tr)) {
      die "Bad argument to --snaptotr: $optarg\n";
    }
    $snaptotr = $tr;
    if (defined($offset) && length($offset) > 0) {
      $snaptotroffset = $offset;
    }
  } else {
    die "Unrecognized option '$opt' (or missing argument?)\nUse --help for options.\n";
  }
}

if (scalar(@ARGV) < 1 || scalar(@ARGV) > 3) {
  print STDERR $usage;
  exit(-1);
}

my $pdigmfile = undef;
my $ppffile = undef;
my $spoutfile = undef;
my $outfile = undef;
my $outfh = undef;
if ($ARGV[0] =~ /\.ppf$/) {
  $ppffile = shift @ARGV;
  if (scalar(@ARGV) == 2) {
    $spoutfile = shift @ARGV;
  }
  $outfile = shift @ARGV;
} else {
  $pdigmfile = shift @ARGV;
  if (scalar(@ARGV) > 0) {
    $outfile = shift @ARGV;
  }
}
if (defined($outfile)) {
  if (-e $outfile && !$opt_overwrite) {
    die "File '$outfile' exists: remove it or use --overwrite\n";
  }
  open($outfh, '>', $outfile) ||
    die "Error opening '$outfile' for writing: $!\n";
} else {
  open($outfh, '>&', "STDOUT") ||
    die "Error opening standard output for writing: $!\n";
}

my @ppf = ();
my @spout = ();

if (defined($pdigmfile)) {
  open(PDFH, '<', $pdigmfile)
    || die "Error opening $pdigmfile for reading: $!\n";
  my $magic = '';
  if (sysread(PDFH, $magic, 6) != 6) {
    die "Error reading from $pdigmfile: $!\n";
  }

  if ($magic eq 'DMDATA') {
    my $discard = <PDFH>;
    $discard = <PDFH>;
    my $foffset21 = undef;
    my $frecsize21 = undef;
    my $foffset22 = undef;
    my $frecsize22 = undef;
    while (<PDFH>) {
      chomp;
      s/#.*//;
      next if /^$/;
      next if (!/^Record/);
      my ($rec, $type, $wsiz, $addr, $nx, $ny, $nz, $nt) = split(/\s+/, $_);
      if ($type == 21 && !defined($foffset21)) {
	$foffset21 = $addr;
	$frecsize21 = $nx;
      } elsif ($type == 22 && !defined($foffset22)) {
	$foffset22 = $addr;
	$frecsize22 = $nx;
      }
    }

    my $ppf = '';
    my $spout = '';

    if (defined($foffset21)) {
      seek(PDFH, $foffset21, SEEK_SET) || die "seek: $!\n";
      read(PDFH, $spout, $frecsize21) || die "read: $!\n";
      @spout = split(/\n/, $spout);
    } else {
      print STDERR "Warning: didn't find record 21 (showplay.out) in pdigm file...\n";
    }
    if (defined($foffset22)) {
      seek(PDFH, $foffset22, SEEK_SET) || die "seek: $!\n";
      read(PDFH, $ppf, $frecsize22) || die "read: $!\n";
      @ppf = split(/\n/, $ppf);
    } else {
      print STDERR "Warning: didn't find record 22 (the \"ppf\" file) in pdigm file...\n";
    }

    close PDFH;
  } else {
    close PDFH;
    my $xp = XML::XPath->new(filename => $pdigmfile);

    my @ns21 = $xp->findnodes('//datarec[@type="pdigm21"]');
    my @ns22 = $xp->findnodes('//datarec[@type="pdigm22"]');
    if (scalar(@ns21) != 1 || scalar(@ns22) != 1) {
      die "Error finding datarec 'pdigm21' and 'pdigm22' in '$pdigmfile'\n";
    }

    my $fname21 = $xp->findvalue('filename', $ns21[0]);
    my $foffset21 = $xp->findvalue('fileoffset', $ns21[0]);
    my $frecsize21 = $xp->findvalue('filerecordsize', $ns21[0]);

    my $fname22 = $xp->findvalue('filename', $ns22[0]);
    my $foffset22 = $xp->findvalue('fileoffset', $ns22[0]);
    my $frecsize22 = $xp->findvalue('filerecordsize', $ns22[0]);

    my $ppf = '';
    my $spout = '';

    open(FH, '<', $fname21) || die "open: $!\n";
    seek(FH, $foffset21, SEEK_SET) || die "seek: $!\n";
    read(FH, $spout, $frecsize21) || die "read: $!\n";
    close FH;

    open(FH, '<', $fname22) || die "open: $!\n";
    seek(FH, $foffset22, SEEK_SET) || die "seek: $!\n";
    read(FH, $ppf, $frecsize22) || die "read: $!\n";
    close FH;

    @ppf = split(/\n/, $ppf);
    @spout = split(/\n/, $spout);
  }
} else {
  open(FH, '<', $ppffile) || die "open: $!\n";
  @ppf = <FH>;
  close(FH);
  if (defined($spoutfile)) {
    open(FH, '<', $spoutfile) || die "open: $!\n";
    @spout = <FH>;
    close(FH);
  }
}

my %codetable = (); # code number -> (hash of condition->value pairs)
my @codetable = (); # each row is a list of valuecodes for a condition, with optional code number header line, columns corresponding to each unique code number
my @codenames = (); # each row is a list of condition name and hash of value->valuecode

my $state = 0;
while (scalar(@ppf)) {
  $_ = shift @ppf;
  s/^\s*;.*$//;
  s/^\s+//;
  s/\s+$//;
  if ($_ eq '' && ($state == 1)) {
    # skip one blank line after 'return' and we're done!
    last;
  }
  if (/^return/) {
    $state = 1;
    next;
  }
  if (/^codenames/) {
    while (scalar(@ppf)) {
      $_ = shift @ppf;
      last if (/^}/);
      my @nameline = split(/\s+/, $_);
      my $index = 0;
      push @codenames,
	[
	 $nameline[0],
	 { map
	   {
	     my ($name, $num) = split(/=/, $_);
	     if (!defined($num)) { $num = ++$index; }
	     else { $index = $num; }
	     $num => $name
	   } @nameline[1..$#nameline]
	 }
	];
    }
  } elsif (/^codetable/) {
    while (scalar(@ppf)) {
      $_ = shift @ppf;
      last if (/^}/);
      push @codetable, [split(/\s+/, $_)];
    }
  }
  $state = 0;
}

my @spcmds = ('erase', 'font', 'color', 'forecolor', 'backcolor', 'textcolor', 'bdraw', 'bfill', 'edraw', 'efill', 'line', 'rwait', 'owait', 'twait', 'fix', 'reset', 'writeport', 'quit', 'user1', 'user2', 'user3');
my %spcmds = ();
@spcmds{@spcmds} = (0..$#spcmds);

my @evlist = ();
my $foundempty = 0;
while (scalar(@ppf)) {
  $_ = shift @ppf;
  s/^;.*//;
  next if $_ eq '';
  s/\s+$//;
  if (length($_) == 0) {
    warn "Warning: found empty line(s) within stimulus section of parameter file.\n";
    next;
  }
  my $cmd = undef;
  my @args = ();
  if (/^"/) {
    my $argstr;
    ($cmd,$argstr) = /^"([^"]*)"\s+(.*)$/;
    @args = split(/\s+/, $argstr);
  } else {
    ($cmd, @args) = split(/\s+/, $_);
  }
  if (exists($spcmds{$cmd})) {
    @args[3..$#args] = ();
    $args[3] = 0;
  }
  $args[2] /= 1000;
  $args[3] /= 1000;
  push @evlist, [$cmd, @args];
}
while (scalar(@evlist) && scalar(@{$evlist[$#evlist]}) == 0) {
  pop @evlist;
}
if (scalar(@evlist)) {
  push @evlist, ['end', 'end', 0, undef, 0];
}

# construct @codetable if it doesn't exist and if @codenames exists
if (scalar(@codenames) && !scalar(@codetable)) {
  # no codetable: make one up using digit mapping
  if ($codenames[0]->[0] ne 'code') {
    unshift @codenames, ['code', {}];
  }
  my @usedcodes = map { $_->[1] } @evlist;
  map { push @{$codetable[$_]}, 0 } (0..$#codenames);
  my @keylists = map { [ keys %{$_->[1]} ] } @codenames;
  # add '0' to the key lists if it is missing, to make sure we get all numbers
  map {
    if (! grep { $_ ne 'end' && $_ == 0 } @$_) {
      push @$_, 0;
    }
  } @keylists;
  my @indexlists = map { 0 } (0..$#keylists);
  while ($indexlists[0] == 0) { # first index is for a dummy list
    my @codekeys = map { $keylists[$_]->[$indexlists[$_]] } (1..$#keylists);
    my $codestring = join('', @codekeys);
    if (grep { $_ ne 'end' && $_ == $codestring } @usedcodes) {
      push @{$codetable[0]}, $codestring;
      map { push @{$codetable[$_ + 1]}, $codekeys[$_] } (0..$#codekeys);
    }
    for (my $listnum = $#indexlists; $listnum >= 0; $listnum--) {
      $indexlists[$listnum]++;
      last if ($listnum == 0 || $indexlists[$listnum] < scalar(@{$keylists[$listnum]}));
      $indexlists[$listnum] = 0;
    }
  }
}

# add header line to @codenames/@codetable if it doesn't exist
if (scalar(@codenames) && $codenames[0]->[0] ne 'code') {
  unshift @codenames, ['code', {}];
  unshift @codetable, [0..$#{$codetable[0]}];
}

# fill in %codetable
if (scalar(@codenames) && scalar(@codetable)) {
  for my $codeind (0..$#{$codetable[0]}) {
    my @codekeys = map { $codetable[$_]->[$codeind] } (1..$#codetable);
    my $codestring = $codetable[0]->[$codeind] + 0; # add zero to get rid of leading zeros from the string
    $codetable{$codestring} = [@codekeys];
  }
}

if (scalar(@spout) == 0) {
  # no .out file, so just generate a fake one from the .ppf
  my $evnum = 0;
  my @tmpevlist = map { [$evnum++, @$_] } grep { defined($_->[3]) } @evlist;
  @spout = map {
    my ($evnum, $evcmd, $evcode, undef, $evonset, $evduration, @finalargs) = @$_;
    sprintf("%7d %12.3g %7d %7d %7d %7d\n", $evnum, $evonset, $evcode, 0, 0, 0);
  } sort { $a->[4] <=> $b->[4] } @tmpevlist;
}

my @spoutfields = sort {
  # sort by event number because it's not always sorted
  $a->[0] <=> $b->[0]
} map {
  s/\s+$//;
  s/^\s+//;
  [ split(/\s+/, $_) ]
} @spout;

# detect whether there are rogue lines at the top of showplay.out
my $maxevnum = -1;
map {
  if ($_->[0] > $maxevnum) {
    $maxevnum = $_->[0];
  }
} @spoutfields;
while ($maxevnum > $#evlist) {
  my $notmatched = grep {
    my $evnum = $spoutfields[$_]->[0];
    my $evcode = $spoutfields[$_]->[2];
    my $origevcode = $evlist[$evnum]->[1];
    $_ <= scalar(@evlist) && $origevcode && $origevcode ne $evcode
  } (0..$#spoutfields);
  last if (!$notmatched);
  print STDERR "Warning: event codes don't line up and showplay.out and .ppf files seem to have different event counts -- adding an extra empty event to .ppf to see if it helps. (if you don't see an error message, then it worked)\n";
  unshift @evlist, ['', '', 0, undef, 0];
}

# prefix a field to each spoutfield list to indicate time to next event
for (my $spoutind = 0; $spoutind <= $#spoutfields - 1; $spoutind++) {
  my $curfields = $spoutfields[$spoutind];
  unshift @{$curfields}, (($spoutfields[$spoutind + 1]->[1]) - $curfields->[1]);
}
unshift @{$spoutfields[$#spoutfields]}, 0;

print $outfh "<?xml version=\"1.0\"?>\n\n";
if ($opt_xcede2) {
  if (!defined($opt_xcede2dataid)) {
    $opt_xcede2dataid = hostname() . "_" . $$ . "_" . time();
  }
  print $outfh <<EOM;
<XCEDE xmlns='http://www.xcede.org/xcede-2'
       xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'
       version="2.0">
  <data ID='$opt_xcede2dataid' xsi:type="events_t">
EOM
} else {
  print $outfh <<EOM;
<events>
EOM
}
while (scalar(@spoutfields)) {
  my $fieldref = shift @spoutfields;
  my @fields = @$fieldref;
  my ($evtimetonext, $evnum, $evtime, $evcode, $isresp, $delay, $button);
  if (scalar(@fields) == 6) {
    ($evtimetonext, $evnum, $evtime, $evcode, $delay, $button) = @fields;
    $isresp = 0;
    if ($delay > 0) {
      $isresp = 1;
    }
  } else {
    ($evtimetonext, $evnum, $evtime, $evcode, $isresp, $delay, $button) = @fields;
  }
  my $respval = '';
  my $duration = 0;
  my $evcmd = '';
  if (scalar(@evlist)) {
    $duration = $evlist[$evnum]->[4];
    $evcmd = $evlist[$evnum]->[0];
    my $origevcode = $evlist[$evnum]->[1];
    if ($origevcode && $origevcode ne 'end' && $origevcode ne $evcode) {
      die "Error: unable to line up event codes in showplay.out and ppf file, starting with showplay.out line:\n" . join("\t", @fields) . "\nand ppf line:\n" . join("\t", @{$evlist[$evnum]}) . "\n";
    }
  }
  if ($opt_nooverlap) {
    if ($evtimetonext < $duration) {
      $duration = $evtimetonext;
    }
  }
  if ($evcode =~ /^0\d*/) {
    $evcode += 0; # add zero to get rid of leading zeros from the string
  }
  if (defined($snaptotr)) {
    my $factor = int(($evtime - $snaptotroffset) / $snaptotr);
    my $newtime = ($factor * $snaptotr) + $snaptotroffset;
    my $diff = abs($newtime - $evtime);
    my $diffplus = abs($newtime + $snaptotr - $evtime);
    my $diffminus = abs($newtime - $snaptotr - $evtime);
    if ($diff < $diffplus) {
      if ($diff < $diffminus) {
	$evtime = $newtime;
      } else {
	$evtime = $newtime - $snaptotr;
      }
    } elsif ($diffplus < $diffminus) {
      $evtime = $newtime + $snaptotr;
    } else {
      $evtime = $newtime - $snaptotr;
    }
  }
  if (defined($opt_subtractonset)) {
    $evtime = $evtime - $opt_subtractonset;
  }
  print $outfh <<EOM;
  <event>
    <onset>$evtime</onset>
    <duration>$duration</duration>
    <value name="stimulus">$evcmd</value>
    <value name="code">$evcode</value>
EOM
  if (exists($codetable{$evcode})) {
    my $codekeysref = $codetable{$evcode};
    map {
      my $name = $codenames[$_]->[0];
      if (exists($codenames[$_]->[1]->{$codekeysref->[$_-1]})) {
	my $value = $codenames[$_]->[1]->{$codekeysref->[$_-1]};
	print $outfh <<EOM;
    <value name="$name">$value</value>
EOM
      }
    } (1..$#codetable);
  }
  if ($isresp) {
    print $outfh <<EOM;
    <value name=\"button${button}delay\" units="msecs">$delay</value>
EOM
  }
  print $outfh <<EOM;
  </event>
EOM
}
if ($opt_xcede2) {
  print $outfh <<EOM;
  </data>
</XCEDE>
EOM
} else {
  print $outfh <<EOM;
</events>
EOM
}


# $Log: In-line log eliminated on transition to SVN; use svn log instead. $
# Revision 1.29  2006/11/16 20:10:01  gadde
# Don't add zero to event code if it is 'end'.
#
# Revision 1.28  2006/11/03 22:56:41  gadde
# Fix codenames/codetable support
#
# Revision 1.27  2006/08/15 17:54:50  gadde
# Don't break if there are extraneous blank lines at end of stimulus
# section of .ppf.
#
# Revision 1.26  2006/08/14 15:35:04  gadde
# Use unshift rather than push for blank line check...
#
# Revision 1.25  2006/08/02 20:13:41  gadde
# Forgot a missing "last" to exit loop when skipping blank lines after return.
#
# Revision 1.24  2006/07/27 16:58:46  gadde
# Deal better with extra blank lines (after "return") in ppf file.
#
# Revision 1.23  2006/03/02 21:45:56  gadde
# Allow just .ppf file (won't use actual output timing, nor responses).
#
# Revision 1.22  2005/09/19 16:31:59  gadde
# Documentation and help message updates.
#
# Revision 1.21  2005/08/31 19:03:25  gadde
# Work with older style showplay.out files.
#
# Revision 1.20  2005/08/29 20:37:26  gadde
# Add units to response delay.
#
# Revision 1.19  2005/07/08 17:18:32  gadde
# Add stimulus (e.g. image/audio filename) to output.
#
# Revision 1.18  2005/06/24 19:32:36  gadde
# Accept newlines at the end of ppf files.
#
# Revision 1.17  2005/04/05 15:42:43  gadde
# Fix potential infinite loop.
#
# Revision 1.16  2005/04/05 15:29:11  gadde
# Be a little more robust in presence of errors.
#
# Revision 1.15  2005/04/04 21:13:32  gadde
# Get rid of extra blank lines after return.
#
# Revision 1.14  2005/04/04 19:21:27  gadde
# Don't promise more than we can give!  (pdigm dir not supported yet)
#
# Revision 1.13  2005/04/04 18:35:50  gadde
# Add ability to specify separate *.ppf and showplay.out files.
# Also add missing newlines to some error messages.
#
# Revision 1.12  2005/03/03 21:36:39  gadde
# Remove errant quote in output.
#
# Revision 1.11  2005/02/25 17:50:57  gadde
# Fix to support for codename/codetable.
#
# Revision 1.10  2005/02/25 17:22:23  gadde
# Get rid of debug message.
#
# Revision 1.9  2005/02/25 17:20:05  gadde
# Choose last matching records.
#
# Revision 1.8  2004/12/17 15:35:22  gadde
# Fix option processing.
#
# Revision 1.7  2004/12/17 15:28:01  gadde
# Add --snaptotr option.
#
# Revision 1.6  2004/12/15 18:37:34  gadde
# Update to new schema.
#
# Revision 1.5  2004/12/15 18:19:02  gadde
# Accept raw pdigm file.
#
# Revision 1.4  2004/12/10 20:56:08  gadde
# Don't use bareword STDOUT.
#
# Revision 1.3  2004/12/10 20:55:22  gadde
# Use executable location as a hint for library modules.
#
# Revision 1.2  2004/12/10 20:10:33  gadde
# Add log.
#
