#!/usr/local/bin/perl -w

# bj.pl - beta-Juliet interpreter/simulator in Perl 5
# v2001.02.01 Chris Pressey, Cat's-Eye Technologies.

# Copyright (c)2001, Cat's Eye Technologies.
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 
#   Redistributions of source code must retain the above copyright
#   notice, this list of conditions and the following disclaimer.
# 
#   Redistributions in binary form must reproduce the above copyright
#   notice, this list of conditions and the following disclaimer in
#   the documentation and/or other materials provided with the
#   distribution.
# 
#   Neither the name of Cat's Eye Technologies nor the names of its
#   contributors may be used to endorse or promote products derived
#   from this software without specific prior written permission. 
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
# CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
# OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
# OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
# ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE. 

### GLOBALS ###

$line = '';
$token = '';
$errors = 0;
$serial = 0;

### SCANNER ###

sub err
{
  my $msg = shift;
  print "ERROR: $msg (token = $token).\n";
  $errors++;
}

sub scan
{
RESTART:
  if ($line eq '')
  {
    $line = <INFILE>;
    goto RESTART;
  }
  if ($line =~ /^\s+/)
  {
    $line = $';
    goto RESTART;
  }
  if ($line =~ /^\/\/.*?$/)
  {
    $line = '';
    goto RESTART;
  }
  if ($line =~ /^([A-Za-z\-]+)/)
  {
    $token = $1;
    $line = $';
  }
  elsif ($line =~ /^(\d+\.*\d*)/)
  {
    $token = $1;
    $line = $';
  }
  elsif ($line =~ /^(.)/)
  {
    $token = $1;
    $line = $';
  }
}

### PARSER ###

sub WhenTerm
{
  my @l = ();
  while($token eq 'when')
  {
    scan();
    my $name1 = $token; my $name2 = '';
    scan();
    if($token eq '>')
    {
      scan();
      $name2 = $token;
      scan();
      push @l, $name1;
      push @l, $name2;
    } else
    {
      err "Need state expression on right side of 'when'";
    }
  }
  return \@l;
}

sub Property
{
  my $name = shift;
  my $time = '';
  my $byname = '';
  my $immediate = 0;
  my $when;
  if ($token eq 'caused')
  {
    scan();
    $time = $token;
    scan();
    $byname = $token;
    scan();
    if ($token eq 'when')
    {
      $when = WhenTerm();
    }
    if ($time eq 'before')
    {
      push @{$before{$byname}}, $name;
      $when_before{$byname}{$name} = $when if defined $when;
    }
    if ($time eq 'after' or $time eq 'by')
    {
      push @{$after{$byname}}, $name;
      $when_after{$byname}{$name} = $when if defined $when;
    }
  }
  elsif ($token eq 'causes')
  {
    scan();
    my $subj = $token;
    scan();
    if ($token eq 'immediately')
    {
      scan();
      $immediate = 1;
    }
    if ($token eq 'when')
    {
      $when = WhenTerm();
    }
    if ($immediate)
    {
      push @{$before{$name}}, $subj;
      $when_before{$name}{$subj} = $when if defined $when;
    } else
    {
      push @{$after{$name}}, $subj;
      $when_after{$name}{$subj} = $when if defined $when;
    }
  }
  elsif ($token eq 'duration')
  {
    scan();
    $dur = 0 + $token;
    scan();
    $dur /= 1000 if $token eq 'ms';
    $dur *= 60 if $token eq 'm';
    $dur *= 3600 if $token eq 'h';
    $dur *= (24*3600) if $token eq 'd';
    $dur{$name} = $dur;
    scan();
  }
  else { err "Not a legal property"; }
}

sub Event
{
  my $name = '';
  if($token eq 'event')
  {
    scan();
    $name = $token;
    scan();
    while ($token eq ',')
    {
      scan();
      Property($name);
    }
    $event{$name} = $name;
    $last{$name} = 0;
    $ltime{$name} = '' . localtime(time());
  } else
  {
    err "Missing event";
  }
}

sub betaJuliet
{
  Event();
  while($token eq ';')
  {
    scan();
    Event();
  }
  if($token ne '.') { err "Missing period"; }
}

### RUNTIME ###

%ready = ();

sub DumpEvents
{
  foreach $k (sort keys %event)
  {
    print "$k: ";
    if ($last{$k} > 0)
    {
      print "(last fired at " . $ltime{$k} . ") ";
    } else
    {
      print "(never fired) "
    }
    if (exists $ready{$k} and $ready{$k})
    {
      print " (ready to fire)";
    }
    print "\n";

    if (exists $before{$k})
    {
      $bk = join(', ', @{$before{$k}});
      print "  before:   $bk\n";
    }
    print "  duration: $dur{$k}\n" if exists $dur{$k};
    if (exists $after{$k})
    {
      $ak = join(', ', @{$after{$k}});
      print "  after:    $ak\n";
    }
  }
}

sub fire
{
  my $name = shift;
  my $q;
  if (exists $event{$name})
  {
    if (exists $before{$name})
    {
      foreach $q (@{$before{$name}})
      {
        if (exists $when_before{$name}{$q})
        {
          my @l = @{$when_before{$name}{$q}};
          my $b = 1;
          while($#l >= 0)
          {
            my $first = shift @l;
            my $second = shift @l;
            $b = ($b and ($last{$first} > $last{$second}));
          }
          fire($q) if $b;
        } else
        {
          fire($q);
        }
      }
    }
    print "Firing '$name'...\n";
    $ready{$name} = 0;
    if (exists $after{$name})
    {
      foreach $q (@{$after{$name}})
      {
        if (exists $when_after{$name}{$q})
        {
          my @l = @{$when_after{$name}{$q}};
          $ready{$q} = 1 if $last{$l[0]} > $last{$l[1]};
        } else
        {
          $ready{$q} = 1;
        }
      }
    }
    $ltime{$name} = '' . localtime(time());
    $last{$name} = ++$serial;
  } else
  {
    print "Non-existant event '$name'!\n";
  }
}

sub LoadFile
{
  my $filename = shift;
  $errors = 0;
  err("Can't open $filename") if not open INFILE, "$filename";
  if ($errors == 0)
  {
    scan();
    betaJuliet();
    close INFILE;
  }
  if ($errors > 0)
  {
    print "There were $errors errors.\n";
  }
}

sub UserInterface
{
  my $cmd = '';

  while(uc($cmd) ne 'Q')
  {
    print "beta-Juliet> ";
    $cmd = <STDIN>;
    chomp $cmd;

    if (uc($cmd) eq 'D')
    {
      DumpEvents();
    }
    elsif (uc($cmd) eq 'F')
    {
      my $k = '';
      foreach $k (keys %ready)
      {
        fire($k) if $ready{$k};
      }
    }
    elsif (uc($cmd) eq 'R')
    {
      my $done = 0;
      my $k = '';
      while (not $done)
      {
        foreach $k (keys %ready)
        {
          fire($k) if $ready{$k};
        }
        $done = 1;
        foreach $k (keys %ready) { $done = 0 if $ready{$k}; }
        # sleep 1 if not $done;
      }
    }
    elsif (uc($cmd) eq 'Q')
    {
      print "Quitting.\n";
    }
    elsif (uc($cmd) eq 'NEW')
    {
      %ready = ();
      %event = ();
      %before = ();
      %after = ();
      %when_before = ();
      %when_after = ();
      %dur = ();
      %last = ();
      %ltime = ();
      print "All events erased.\n";
    }
    elsif (-r $cmd)
    {
      print "Loading $cmd...\n";
      # 2001.02.01 Chris Pressey: adding support for Portia
      if ($cmd =~ /\.pbj$/)
      {
        # print "(Expanding Portia)\n";
        # print `perl portia.pl <$cmd`;
        LoadFile("perl portia.pl <$cmd |");
      } else
      {
        LoadFile($cmd);
      }
    }
    elsif (exists $event{$cmd})
    {
      if (exists $ready{$cmd} and $ready{$cmd})
      {
        $ready{$cmd} = 0;
        print "event $cmd has been made unready to fire.\n";
      } else
      {
        $ready{$cmd} = 1;
        print "event $cmd is now ready to fire.\n";
      }
    }
    else
    {
      print "Unrecognizable command '$cmd'";
      print '

NEW = Erase All Events
FileName = Load beta-Juliet File
EventName = Toggle Event Ready
F = Fire all Ready Events (Single Step)
R = Repeated Fire (Run)
D = Dump Event Status
Q = Quit beta-Juliet Simulator

';
    }
  }
}

### MAIN ###

print "Cat's-Eye Technologies' beta-Juliet Interpreter v2001.02.01.\n";
UserInterface();

### END ###