package Obj;

use strict;
use warnings;
use include;

# Creates a new template from another. Makes a template.
sub newclass {
  my $base = shift;
  my $name = shift;
  my $class = $base->new(@_, Instance => 0, Class => $name);
  die "Already a $name class!\n" if GAME->{Classes}{$name};
  GAME->{Classes}{$name} = $class;
  return $class;
}

# Creates a new object from another. Makes an instance.
sub new {
  my $base = shift;

  my $self = bless {
    Instance => 1,
    @_
  }, "Obj";

  unless ($base eq "Obj") {
    # Normal template based off another template. We're not making a root
    # template or anything.
    # If we're subclassing an instance, something might be up.
    die "Cloning an instance... why?\n" if $base->{Instance};
    $self->{Base} = $base;
  }
  # Yank in all of its listed actions and methods...
  my $package;
  if ($self->{Instance}) {
    # We were called directly.
    $package = (caller)[0];
  } else {
    # newclass called us, so see who called us 2 callstack thingies ago.
    $package = (caller(1))[0];
  }
  no strict "refs";
  foreach my $type ("Actions", "Methods") {
    next unless $self->{$type};
    my @acts = @{ $self->{$type} };
    $self->{$type} = {};
    foreach my $code (@acts) {
      if ($code =~ s/^://) {
        # We're a stub/fake action, meaning this character can do this
        # action, but the Action stage of this action doesn't exist... an
        # earlier stage redirects.
        $self->{$type}{$code} = "STUB";
      } else {
        $self->{$type}{$code} = \&{ "${package}::$code" };
      }
      next unless $type eq "Actions";
      # Now pull in all other stages of the action that exist and set up
      # reactions for them.
      foreach my $stage (@{ $self->g("Stages") }) {
        next unless my $react = $package->can($stage . "_$code");
        $self->react("DEFAULT" => $stage, $code,
          by => $react
        );
      }
    }
  }
  use strict "refs";

  # TODO: Weaken ref? Garbage collection? Do old objects get shifted up and
  # junk?
  push @{ GAME->{Objs} }, $self;
  $self->{ID} = $#{ GAME->{Objs} };
  # Go through all the existing init() routines if they exist. Generic to
  # specific!
  foreach ($self->bases) {
    $_->{init}->($self) if $_->{init};
  }
  return $self;
}

# Returns the object's list of bases from general to specific.
sub bases {
  my $self = shift;
  my @ls;
  push @ls, $self unless $self->{Instance};
  my $cur = $self;
  while (1) {
    $cur = $cur->{Base};
    last unless $cur;
    unshift @ls, $cur;
  }
  return @ls;
}

our $AUTOLOAD;

# Since this is a classless object system, we have to find methods ourselves.
sub AUTOLOAD {
  my $self = shift;
  my $do = $AUTOLOAD;
  $do =~ s/^.*:://;
  return if $do eq "DESTROY";
  if ($do =~ m/_/) {
    my ($time, $act) = split("_", $do);
    $self->{actdat} = { args => [@_] };
    my $signal = $self->signal($act, $time, );
    delete $self->{actdat};
    return ($signal eq "none") ? undef : $signal;
  }
  my $action = $self->g("Actions", $do);
  my $method = $self->g("Methods", $do);
  if ($action and $method) {
    die "$method is an action and method! Eek!\n";
  } elsif ($action) {
    return $self->do_act($do, @_);
  } elsif ($method) {
    return $method->($self, @_);
  } else {
    die "This object can't do $do.\n";
  }
}

# We find the "most specific" data. We should only be called from accessors. No
# abusing me, OK?
sub g {
  my ($self, @keys) = @_;
  my $base = $self;
  my $var;
  my $sofar = -1;
  while (1) { # For each parent of $self, starting with $self itself...
    $var = $base;
    my $sofar = "";
    my $start = 1;
    foreach (@keys) {
      # For the very first key, just GET it normally.
      if ($start) {
        $start = 0;
        $var = $var->{$_};
        $sofar++;
        last unless defined $var;
        next;
      }

      my $ref = ref $var;
      if ($ref eq "Obj") {
        # Delegate the call now. This makes sense. Don't make me explain it.
        $var = $var->g(@keys[$sofar .. $#keys]);
        last;
      } elsif ($ref eq "HASH" and defined $var->{$_}) {
        $var = $var->{$_};
      } elsif ($ref eq "ARRAY" and defined $var->[$_]) {
        $var = $var->[$_];
      } else {
        $var = undef;
        last;
      }
      $sofar++;
    }
    last if defined $var;
    last unless $base->{Base};
    $base = $base->{Base};
  }
  return $var if defined $var;
  # TODO: we may want to avoid an undef error for some reason...
  return undef;
}

# Go through and do an entire action.
sub do_act {
  my ($self, $action, @args) = @_;
  die "can't do $action!\n" unless $self->g("Actions", $action);
  my $act = { Args => [@args] };
  # Turn flags into... flags.
  while ($args[0] and $args[0] =~ s/^\-//) {
    $act->{ shift(@args) } = 1;
    shift @{ $act->{Args} };
  }
  # Go through each of the stages of an Action and send the appropriate
  # signal. At any point, a reaction could halt the flow.
  my $return;
  foreach my $time (@{ $self->g("Stages") }) {
    if ($time eq "-") { # ACTION!
      my $do = $self->g("Actions", $action);
      die "Nothing redirected before the $action STUB!\n" if $do eq "STUB";
      $return = $do->($self, $act);
    } else {
      $return = $self->signal($action, $time, $act);
    }
    # Reactions can pretty much continue or stop the flow. Any information
    # should be recorded in $params. Or alternatively, a reaction could
    # completely change the flow and prompt a new action. How inconvenient!
    if (ref $return eq "ARRAY") {
      return $self->do_act(@$return);
    }
    if ($return and $return eq STOP) {
      $return = 0; # so "blah if $self->act()" works
      last;
    }
  }
  return $return; # if something needs $act, an After or whatever can return it
}

# Send a signal, query the event DB, and execute any appropriate reactions in
# the right order.
sub signal {
  my ($self, $action, $time, $act) = @_;
  # We sound so fancy! "Query the DB and send a signal" - HAH! All we do is
  # loop.
  my (@hi, @lo);  # Reactions with inhibitions get first pick
  foreach (values %{ GAME->{Events}{$action}{$time} }) {
    $_->{Inhibit} ? push(@hi, $_) : push(@lo, $_);
  }

  # TODO: If two (or more) reactions conflict (inhibit each other, either
  # directly or conditionally in the code), then that's a major problem since
  # their execution order is pretty much arbitrary. In general, if two or more
  # reactions for the same signal influence each other's conditions somehow,
  # then that's kinda bad since we don't even test for it.

  # Go get em.
  my $return = "none";  # if there are no reactions, keep going
  $act->{Inhibit} = {};
  foreach my $react (@hi, @lo) {
    my $name = $react->{Name};
    next if $act->{Inhibit}{$name};

    # Check the standard context requirements. Weird ones can be done in the
    # reaction itself.
    # If the requirements fail, then keep on going with the flow... just don't
    # do the reaction!

    if (my $mustbe = $react->{Actor}) {
      # If the reaction says the actor of this event must be a type of object,
      # test for that. But it might also say it has to be a SPECIFIC object.
      # Test for that too.
      if ($mustbe->{Instance}) {
        next unless $self->same($mustbe);
      } else {
        next unless $self->isa($mustbe->{Class});
      }
    }

    $return = $react->{Reaction}->($self, $act);
    $return ||= 1;    # undefined (blank return) same as blank. but undefined
                      # warnings are annoying.
    return $return if ref $return eq "ARRAY";   # action redirection
    $self->ignore($action, $time, $react->{Name}) if $return eq "SUICIDE";
    last unless $return eq STOP;
  }
  return $return;
}

# We permanently remove a reaction from the event DB.
sub ignore {
  my ($self, $action, $time, $name) = @_;
  delete GAME->{Events}{$action}{$time}{$name};
}

# Install a new reaction
sub react {
  my ($self, $name, $time, $action, %dat) = @_;
  # Autovivification my ass.
  my $ls = GAME->{Events};
  $ls->{$action} ||= {};
  $ls = $ls->{$action};
  $ls->{$time} ||= {};
  $ls = $ls->{$time};

  die "Already a reaction for $time $action called $name!" if $ls->{$name};
  $ls->{$name} = {
    Name       => $name,
    Reaction   => $dat{by},
    Actor      => $self,
    Inhibit    => {
      DEFAULT  => 1
    }
    # TODO: handle other stuff in %dat
  };
  delete $ls->{$name}{Inhibit} if $name eq "DEFAULT";
  return 1;
}

# This checks to see if the specified class/template is somewhere in the
# object's inheritance line.
sub isa {
  my ($self, $class) = @_;
  foreach ($self->bases) {
    return 1 if $class eq $_->{Class};
  }
  return;
}

# Determines if the two objects are exactly the same.
sub same {
  my ($self, $other) = @_;
  return unless ref $other eq "Obj";
  return 1 if $self->{ID} == $other->{ID};
}

# TODO: a msg thingy?
# TODO: actual real event stuff. and decorators. and effects.
# TODO: serialize stuff. and load stuff.
# TODO: a thing that makes the std accessors. aka the g() ones and the instance
# ones.

42;