package MObject;
# This isn't really a separate package, I just wanted to keep the file sizes down.

use strict;
use vars qw(@RunningScripts %std_ctab %Scripts);

%std_ctab = (
  vcreate => sub {
    my ($stack, $rtrig) = @_;
    my $str = spop($stack);
    $str = lc $str;
    $rtrig->{vars}{$str} = '';
    $rtrig->{ctab}{'>' . $str} = sub {
      my ($stack) = @_;
      my $val = spop($stack);
      $rtrig->{vars}{$str} = $val;
      return;
    };
    $rtrig->{ctab}{$str} = sub {
      my ($stack) = @_;
      push @$stack, $rtrig->{vars}{$str};
      return;
    };
    return;
  },
  'w-cnt' => sub {
    my ($stack) = @_;
    my $str = spop($stack);
    my $c;
    $c++ while $str =~ m/\s+/g;
    push @$stack, $c + 1;
    return;
  },
  "-" => sub {
    my ($stack) = @_;
    my $b = spop($stack);
    my $a = spop($stack);
    push @$stack, $a - $b;
    return;
  },
  'rand' => sub {
    my ($stack) = @_;
    my $max = spop($stack);
    push @$stack, int(rand($max));
    return;
  },
  'w-get' => sub {
    my ($stack) = @_;
    my $str = spop($stack);
    my $index = spop($stack);
    my @words = split /\s+/, $str;
    push @$stack, $words[$index];
    return;
  },
  'do' => sub {
    my ($stack, $rtrig) = @_;
    my $str = spop($stack);
    $rtrig->{obj}->send("&su;>> $str&n;");
    $rtrig->{obj}->command($str);
    return;
  },
);

my $scode = <<'EOT';
"dirlist" VCREATE
"n e s w u d ne se sw nw" >dirlist
dirlist W-CNT RAND dirlist W-GET DO
EOT

%Scripts = (
  '/core/npc_wander' => [
    {
      types => parse_flags('Random', \%TRIG_TYPES),
      code => $scode,
      probability => 100,
      tokens => tokenize($scode),
    },
  ],
);

sub check_triggers {
  my ($self, $event, $params) = @_;
  # $event is the INDEX of the trigger type, not the bit value.

  # syslog $self->name . ": check_triggers @{[sprint_flags($event, \@TRIG_TYPES)]}";
  foreach my $scrname (@{$self->scripts || []}) {
    # syslog $self->name . ": checking script $scrname";
    my $script = $Scripts{$scrname} or do {syslog "Nonexistent script on @{[$self->name]}: $scrname"; next};
    foreach my $trig (@$script) {
      # syslog $self->name . ": checking trigger $trig";
      next unless $trig->{types} & 1 << $event;
      if ($event == $TRIG_TYPES{Random}) {
        next unless rand() < ($trig->{probability} / 100);
      } else {
        syslog "SCRIPTING: Unknown trigger type for @{[$self->name]}";
      }
      $self->do_trig($trig);
    }
  }
}

sub do_trig {
  my ($self, $trig) = @_;

  push @RunningScripts, {trig => $trig, 'pos' => 0, obj => $self, ctab => {}, stack => []};
}

sub run_scripts {
  my @ns;
  TRIG: foreach (@RunningScripts) {
    next unless $_->{obj}->vistype;

    my $tok = $_->{trig}{tokens}[$_->{'pos'}];
    $_->{'pos'}++;
    my $cmd;
    if ($tok =~ /^"(.*)/) {
      push @{$_->{stack}}, $1;
    } elsif ($cmd = $std_ctab{lc $tok} or $cmd = $_->{ctab}{lc $tok}) {

      my $res;
      eval {$res = $cmd->($_->{stack}, $_) };
      if ($@) {
        if ($@ =~ /SERR: (.*)/) {
          chomp (my $etext = $1);
          syslog "ERROR/SCRIPT: token $_->{'pos'} ($tok): $etext";
          next TRIG;
        } else {
          die $@;
        }
      }
      #print "result = $res\n";
      $_->{'pos'} = $res if defined $res and $res =~ /^\d+$/;
    } elsif ($tok =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) {
      push @{$_->{stack}}, $tok;
    } else {
          syslog "ERROR/SCRIPT: unknown token $_->{'pos'} ($tok)";
    }

    push @ns, $_ unless $_->{'pos'} >= @{$_->{trig}{tokens}} or $_->{'pos'} < 0;
  }
  @RunningScripts = @ns;
}

sub tokenize {
  my ($str) = @_;

  my @toks;
  while ($str) {
    $str =~ s/^\s*//;
    if ($str =~ s/^(['"])(.*?)\1\s*//) {
      push @toks, '"' . $2;
      next;
    }
    if ($str =~ s/^([^\s]+)\s*//) {
      push @toks, $1;
      next;
    }
  }
  \@toks;
}

sub spop {
  my ($stack) = @_;

  my $a = pop @$stack;
  defined $a or script_error('stack underflow');
  $a;
}

sub script_error {
  my ($errstr) = @_;

  die "SERR: $errstr\n";
}

1;
