package MObject;

use strict;
use vars qw(@ISA %Prototypes %Objects %Fields $AUTOLOAD $NextID %ModMethods);
use MFreezer;
use MCoreTools;
use MLoaders;
use File::Path qw();
use MZonedHash::Prototypes;

use MObject::CommandInterpreter;

$NextID = 1 unless defined $NextID;
%Fields = (
  %Fields,
  # Special fields
  'prototype' => {},
  id => {noset => 1, nostore => 1},
  container => {noset => 1, nostore => 1},
  contents => {noset => 1, nostore => 1},
  connection => {noset => 1, nostore => 1},
  
  # Command interpreter
  commands_paused => {noset => 1, nostore => 1},
  command_queue => {noset => 1, nostore => 1},

  # Basic object fields
  name => {default => 'an unfinished object'},
  sdesc => {},
  ldesc => {default => 'You see nothing special.'},
  idesc => {default => 'MISSING I-DESC'},
  extra_descs => {default => []},
  weight => {default => 999999},
  density => {default => 1},
  
  # Containers
  cnt_interior => {default => 0},
  cnt_type => {default => 'hard'}, # hard, soft, open
  cnt_slot_nomax => {default => 0},

  # Player stuff
  unique => {noset => 1},
  saveable => {default => 0, noset => 1, nostore => 1},
  loadroom => {default => '/core/void'},
  ok_for_pc => {default => 0}, # can a PC be created with this species?     
  player_name => {noset => 1},

  # Rooms
  roomname => {noset => 1, nostore => 1},

  # Creature stuff
  gender => {default => 'neuter'},
  allow_genders => {default => {}}, # genders appropriate for this creature
  has_metabolism => {default => 0},
  c_hit => {default => 0},
  c_move => {default => 0},
  m_hit => {default => 0},
  m_move => {default => 0},
  food => {default => 0},
  water => {default => 0},
  drunk => {default => 0},
  title => {default => ''},
  
  # Wear slots
  has_slot => {default => {}},
  cur_slot => {default => {}, nostore => 1},
  can_slot => {default => {}},
  is_slot => {},
  
  # Observability
  invisible => {default => 0},
  mute => {default => 0},
  blind => {default => 0},
  deaf => {default => 0},
);

tie %Prototypes, 'MZonedHash::Prototypes' unless tied %Prototypes;

### Module extensions ##########################################################################################

sub ModFields {goto &Fields}
sub Fields {
  my ($class, %fields) = @_;
  $MLoaders::ModuleEvalContext or die 'MObject::Fields called outside of module eval context';
  if ($MLoaders::ModuleEvalContext eq 'unload') {
    foreach (keys %fields) {delete $Fields{$_};}
  } else {
    foreach (keys %fields) {
      exists $Fields{$_} and die "Module attempted to redefine field $_";
      $Fields{$_} = $fields{$_};
    }
  }
}

sub ModMethods {goto &Methods}
sub Methods {
  my ($class, %methods) = @_;
  $MLoaders::ModuleEvalContext or die 'MObject::Methods called outside of module eval context';
  no strict 'refs';
  if ($MLoaders::ModuleEvalContext eq 'unload') {
    foreach (keys %methods) {
      undef &{"MObject::$_"};
      delete $ModMethods{$_};
    }
  } else {
    foreach (keys %methods) {
      exists $ModMethods{$_} and die "Module attempted to redefine method $_";
      *{"MObject::$_"} = $methods{$_};
      $ModMethods{$_} = 1;
    }
  }
}

### Class methods ##########################################################################################

sub load_prototypes {
  my ($class, $ref) = @_;

  my ($type, $path, $filepath) = parse_file_ref($ref, 'obj');
  return unless $type eq 'obj';

  my %fobj = MLoaders->read_objset($filepath);
  foreach my $oname (keys %fobj) {
    MObject->thaw_proto("$path/$oname", $fobj{$oname});
  }
  delete $::DirtyFiles{"$type:$path"};
  1;
  #use Data::Dumper ();
  #print Data::Dumper::Dumper(\%Prototypes);
}

sub save_prototypes {
  my ($class, $ref) = @_;
  $ref or confess "no path passed to save_prototypes";
  my ($type, $path, $filepath) = parse_file_ref($ref, 'obj');
  return unless $type eq 'obj' and $filepath;

  MLoaders->write_objset($filepath, {map {($_ =~ m#/([^/]+)$#)[0], $Prototypes{$_}}
                                     MZone->by_path($path)->all_keys('obj')});
  delete $::DirtyFiles{"$type:$path"};
}

sub field_attrs {
  my ($class, $field) = @_;

  return $Fields{$field};
}

sub all_do {
  my ($class, $callback) = @_;

  foreach my $obj (values %Objects) {
    $callback->($obj);
  }
}

sub all_proto_do {
  my ($class, $callback) = @_;

  foreach my $name (keys %Prototypes) {
    $callback->($name, $Prototypes{$name});
  }
}

sub obj_id {
  my ($class, $id) = @_;
  return $Objects{$id};
}

sub by_id {
  my ($class, $id) = @_;
  return $Objects{$id};
}

sub obj_proto {
  my ($class, $name) = @_;
  return $Prototypes{$name};
}

sub proto_exists {
  my ($class, $proto) = @_;
  
  return exists $Prototypes{$proto};
}

### Object methods - creation/destruction ##########################################################################################

sub new {
  my $class = shift;

  # Find free object ID
  my $id = $NextID;
  $id = ++$NextID while exists $Objects{$id};
  
  my $self = bless {
    id => $id,
  }, $class;
  print "$self CREATED\n" if ::GC_DEBUG;
  $Objects{$id} = $self;

  # Initialize fields
  my $key;
  $self->set_val($key, shift()) while $key = shift;

  if ($self->{'prototype'}) {
    call_hooks('new_protoed_object', $self);
  }

  return $self;
}

sub new_proto {
  my $class = shift;
  my $path = shift;

  my $self = bless {
  }, $class;

  my $key;
  $self->set_val($key, shift()) while $key = shift;

  $Prototypes{$path} = $self;
  return $self;
}

sub thaw_proto {
  my ($class, $path, $text) = @_;

  my $self = bless {}, $class;
  $self->_thaw($text);
  $Prototypes{$path} = $self;
  return $self;
}

sub thaw {
  my ($class, $text) = @_;

  my $self = $class->new;
  $self->_thaw($text);
}

sub _thaw {
  my ($self, $text) = @_;

  $self->restore_struct(MFreezer::thaw($text));
}

sub restore_struct {
  my ($self, $data) = @_;
  foreach (grep {$_ ne '_contents'} keys %$data) {
    $self->set_val($_, $data->{$_});
  }
  $self->add_contents(map {MObject->new->restore_struct($_)} @{$data->{_contents}})
    if exists $data->{_contents};
  foreach (@{$self->contents}) {
    $self->{cur_slot}->{$_->{is_slot}} = $_->id
      if $_->{is_slot};
  }
  $self;
}

sub freeze {
  my ($self) = @_;

  return MFreezer::freeze($self->clone_for_freeze);
}

sub freeze_without_contents {
  my ($self) = @_;

  my $clone = {};
  foreach (keys %$self) {
    $clone->{$_} = $self->{$_} unless $Fields{$_}{nostore};
  }      
  return MFreezer::freeze($clone);
}

sub clone_for_freeze {
  my ($self) = @_;
  my $clone = {};
  foreach (keys %$self) {
    $clone->{$_} = $self->{$_} unless $Fields{$_}{nostore};
  }
  @{$clone->{_contents}} = map {$_->clone_for_freeze} @{$self->{contents}};
  $clone; 
}

sub dispose {
  my ($self) = @_;
  return unless %$self;

  # To avoid problems with disposing prototypes, this function must not directly
  # or indirectly call ->get_val().

  print "$self disposing: name is @{[$self->name]}\n" if ::GC_DEBUG;
  print "$self disposing: checking contents\n" if ::GC_DEBUG;
  if (my $con = $self->{contents}) {
    foreach (@$con) {
      next unless ref $_;
      $_->container(undef);
    }
    if ($self->{'container'}) {
      $self->{'container'}->add_contents(@$con);
    } else {
      foreach (@$con) {
        $_->dispose if ref $_;
      }
    }
    delete $self->{contents};
  }
  
  # in order to prevent commands being executed on destruction due to 
  # MScheduler->remove_owned unblocking the command queue, we erase the queue:
  delete $self->{command_queue};
  
  print "$self disposing: removing owned tasks\n" if ::GC_DEBUG;
  # This must happen before the save_player, because once temporary affects are
  # implemented they will function via owned tasks, therefore we don't
  # want them to be saved along with the player, since owned tasks
  # can't be saved with objects (at least, not now...)
  MScheduler->remove_owned($self) if $self->{id};
  
  print "$self disposing: checking playersave\n" if ::GC_DEBUG;
  # we DON'T want to save player objects in this situation, but we DO
  # want to save the player attributes (tho once we have affects, they
  # should be removed on death). therefore, we save the player file
  # after contents have been dropped.
  MUnique->get($self->unique)->remove() if $self->{unique};
  
  print "$self disposing: checking container\n" if ::GC_DEBUG;
  if ($self->{'container'}) {
    $self->{'container'}->remove_contents($self);
  }
  print "$self disposing: final destruction\n" if ::GC_DEBUG;
  if ($self->{connection} and $self->{connection}->open) {
    $self->{connection}->detach;
  }
  if ($self->{id}) {
    delete $Objects{$self->{id}};
  } else {
    tied(%Prototypes)->delete_value($self);
  }
  %{$self} = ();
}

sub DESTROY {
  my ($self) = @_;
  print "$self DESTROYING\n" if ::GC_DEBUG;
  $self->dispose;
  print "$self DESTROYED\n" if ::GC_DEBUG;
  1;
}

### Object methods - game functions ##########################################################################################

sub save_player {MUnique->get($_[0]->unique || return)->save;}

sub tick {
  my ($self) = @_;

  return unless $self->has_metabolism;
  my $mult = 1;
  foreach (call_hooks('recovery_modifiers', $self)) { $mult += $_ }
  my $gain = ($self->m_hit / 86400) * 5 * TICK_INTERVAL * ($self->c_hit / $self->m_hit);
  #$self->send("TICK: mult total = $mult, gain = $gain");
  $self->c_hit($self->c_hit + $gain) <= $self->m_hit or $self->c_hit($self->m_hit)
    if $self->m_hit;
  $self->c_move($self->c_move + $gain) <= $self->m_move or $self->c_move($self->m_move)
    if $self->m_move;
  if (!$self->immortal) {
    $self->{food}-- if $self->{food};
    $self->send("You are hungry.") if $self->food < 5;
    $self->{water}-- if $self->{water};
    $self->send("You are thirsty.") if $self->water < 10;
    $self->{drunk}-- if $self->{drunk};
    $self->send("You feel less unsteady.") if $self->drunk == 5;
  }
}

sub can_see {
  my ($self, $other) = @_;
  return 0 if MLoaders->mloaded('body_pos') and !$self->bp_can('look');
  return 0 if $self->blind > 0;
  return 0 if $other->invisible > 0 and !$self->immortal;
  # return 0 if $other->wizinvis;
  1;
}

sub can_hear {
  my ($self, $other) = @_;
  return 0 if MLoaders->mloaded('body_pos') and !$self->bp_can('hear');
  return 0 if $self->deaf > 0;
  return 0 if $other->mute > 0;
  1;
}

sub send        {my $self = shift; $self->{connection}->send       (@_) if $self->{connection}}
sub do_page     {my $self = shift; $self->{connection}->do_page    (@_) if $self->{connection}}
sub do_multicol {my $self = shift; $self->{connection}->do_multicol(@_) if $self->{connection}}

### Object methods - Wear slots ##########################################################################################

sub slot_add {
  my ($self, $targ, %params) = @_;

  if ($targ->is_slot) {
    my $targ_name = $targ->name;
    $targ_name =~ s/^\s*(the|an?)/that/;
    $self->send("You're already " . $self->has_slot->{$targ->is_slot}->{gerund} . " " . $targ_name . ".")
      if $params{show_error};
    return 0;
  }

  my ($dslot, $slot_inf, $not_free);
  TC: foreach my $targ_can (keys %{$targ->can_slot}) {
    if ($slot_inf = $self->has_slot->{$targ_can}) {
      $dslot = $targ_can;
      ($not_free = $self->cur_slot->{$targ_can}) and next;
      last TC;
    }
  }
  if ($not_free) {
    $self->send("You're already $slot_inf->{gerund} @{[$Objects{$self->cur_slot->{$dslot}}->name]} $dslot.")
      if $params{show_error};
    return 0;
  }
  if (!$dslot) {
    $self->send("You don't have anywhere to put @{[$targ->name]}.")
      if $params{show_error};
    return 0;
  }
  if ($targ->total_weight > $slot_inf->{max_weight}) {
    $self->send("That's too heavy for you to " . $slot_inf->{verb} . ".")
      if $params{show_error};
    return 0;
  }
  if ($targ->total_volume > $slot_inf->{max_volume}) {
    $self->send("That's too large for you to " . $slot_inf->{verb} . ".")
      if $params{show_error};
    return 0;
  }
  $self->localize_field('cur_slot');
  $self->cur_slot->{$dslot} = $targ->id;
  $targ->is_slot($dslot);
  call_hooks('slot_added', $self, $targ);
  1;
}

sub slot_remove {
  my ($self, $targ, %params) = @_;

  if (!$targ->is_slot) {
    $self->send("You're not using " . $targ->name . ".")
      if $params{show_error};
    return 0;
  }
  call_hooks('slot_removed', $self, $targ);
  delete $self->cur_slot->{$targ->is_slot};
  $targ->is_slot(undef);
  1;
}


### Object methods - Object searching/contents ##########################################################################################

sub container {$_[0]{container} = $_[1] if $_[1]; $_[0]{container}}

sub object_find {
  my ($self, $name, %param) = @_;
  
  return if !$name;
  my $caller = $param{'caller'} || $self;
  $name = lc $name;
  
  return $self if $name eq 'self' or $name eq 'me';
  if ($name =~ /^#(\d+)$/ and $caller->immortal) {
    my $obj = MObject->obj_id($1);
    # could just return $obj but that would result in returning undef
    # in list context - not good.
    if ($obj) {
      return $obj;
    } else {
      die "CFAIL:There is no object with that ID.";
    }
  }
  
  $param{no_outside} = 1 if $name =~ s/^my\s+//;
  $param{no_self_contents} = 1 if $name =~ s/^the\s+//;
  my $instance = ($name =~ s/^all(\.|\s+|$)|(\.|\s+|^)(things|stuff|objects|items)$//) ? -1
               : ($name =~ s/^(\d+)\.// ? $1 : 0)
              || ($name =~ s/\s+(\d+)$// ? $1 : 0)
              || 1;
  $param{no_outside} = 1 if $name =~ s/^my\s+//;
  $param{no_self_contents} = 1 if $name =~ s/^the\s+//;
  # my/the checks twice to handle "my all" as well as "all my food", etc.
 
  delete $param{entire_world} if $instance == -1;
  
  #$caller->send("DEBUG: name after processing: '$name', instance: $instance");
  #$caller->send("Params: " . join ', ', %param);
  
  my @found;
  $self->object_scan(sub {
    my ($obj) = @_;
    return if $instance == 0; # FIXME, we ought to abort object_scan somehow
    return if $obj->roomname and $instance == -1;
    #$caller->send("DEBUG: in scan callback, scanning #$obj->{id}, instance now is $instance");
    
    push @found, $obj if  ( !$name or $obj->name =~ /\b$name\b/i )
                      and ( $instance == -1 ? $obj != $caller : --$instance == 0 );
    # if $instance == -1, then we're scanning "all", therefore never include self.
                         
    if ($param{extra_descs}) {
      # $self->send("DEBUG: scanning extra descs for #$obj->{id}");
      foreach my $descrec (@{$obj->extra_descs}) {
        next unless grep {$_ eq $name} @{$descrec->{keywords} || []};
        push @found, $descrec->{desc} if ($instance != -1 ? $obj != $caller : --$instance == 0);
      }
    }
  }, %param);
  if (@found) {
    return wantarray ? @found : $found[0];
  } elsif (!$param{'no_abort'}) {
    my $an = $name =~ /^[aeiou]/ ? 'an' : 'a';
    die "CFAIL:You don't "
      . ($param{no_outside} ? 'have ' : 'see ') 
      . ($instance == -1 ? 'any' : $an) 
      . (length($name) ? qq{ "$name"} : 'thing')
      . ($param{no_outside} ? '' : ' here')
      . ($param{entire_world} ? ' or anywhere' : '')
      . '.';
  }
  return;
}

sub object_scan {
  my ($self, $hook, %param) = @_;
  
  $hook->($self);
  unless ($param{no_self_contents}) {foreach my $obj (@{$self->contents}) {
    if ($obj->glance_contents) {
      $obj->object_scan($hook, no_outside => 1);
    } else {
      $hook->($obj);
    }
  }}  
  if (!$param{no_outside} and my $obj = $self->container) {
    #$hook->($obj);
    while ($obj->glance_contents) {
      $obj = $obj->container || last;
    }
    # after we find the outermost visible container, we descend thru the tree.
    $obj->object_scan($hook, no_outside => 1);
  }
  if ($param{entire_world}) {
    MObject->all_do(sub {
      $hook->($_[0]);
    });
  }
}

sub contents {
  my ($self) = @_;

  croak "contents can't be directly set" if @_ > 1; 
  return $self->{contents} || [];
}

sub add_contents {
  my ($self, @objs) = @_;
  
  return unless %$self;
  foreach my $obj (@objs) {
    next unless ref $obj;
    if ($obj->{container}) {
      $obj->{container}->remove_contents($obj);
    }
    $obj->{container} = $self;
    push @{$self->{'contents'}}, $obj;
  }
}

sub remove_contents {
  my ($self, @remove) = @_;

  return unless %$self;
  my %remove = map {$_, 1} @remove;
  my @new;
  OBJECT: foreach my $obj (@{$self->{'contents'}}) {
    #foreach (@remove) {
    #  if ($_ == $obj) {
    #    $self->slot_remove($_);
    #    $_->{container} = undef if $_->{container};
    #    next OBJECT;
    #  }
    #}
    if ($remove{$obj}) {
      $self->slot_remove($obj);
      $obj->{container} = undef;
      next OBJECT;
    }
    push @new, $obj;
  }
  $self->{'contents'} = \@new;
}

sub move_into {
  my ($self, $dest) = @_;

  defined $dest or croak "Undefined destination in move_into!";
  $dest->is_inside($self) and croak "can't move #$self->{id} into #$dest->{id}: would cause containership loop";

  my $self_container = $self->container;
  my $dest_container = $dest->container;
  my $dolook = (!$self_container or ($self_container != $dest and (!$dest_container or $dest_container != $self_container)));

  $dest->add_contents($self);

  my $myweight = $self->total_weight;

  { my $obj = $self_container;
    while ($obj) {
      call_hooks('cnt_weight_change', $obj, -$myweight);
      $obj = $obj->container;
    }
  }

  { my $obj = $self;
    while ($obj = $obj->container) {
      call_hooks('cnt_weight_change', $obj, $myweight);
    }
  }

  if ($dolook) {
    $self->do('look BRIEF');
    foreach (@{$self->contents}) {
      $_->do('look BRIEF');
    }
  }
}

sub total_volume {
  my ($self) = @_;
  my $total = $self->weight / $self->density;
  return $total unless $self->cnt_type =~ /^(soft|open)$/;
  foreach (@{$self->contents}) {
    $total += $_->total_volume;
  }
  return $total;
}

sub total_weight {
  my ($self) = @_;
  my $total = $self->weight;
  foreach (@{$self->contents}) {
    $total += $_->total_weight;
  }
  $total;
}

sub is_inside {
  my ($inner, $outer) = @_;
  while ($inner) {
    return 1 if $inner == $outer;
    $inner = $inner->container;
  }
  return 0;
}

### Object methods - core field mgmt ##########################################################################################

sub AUTOLOAD {
  my ($method) = $AUTOLOAD =~ /::([^:]+)$/;
  if ($Fields{$method}) {
    no strict 'refs';
    #print STDERR "creating autoload sub for $method\n";
    *{$method} = sub {
      if (@_ > 1) {
        #my $valstr = join ', ', map {defined $_ ? "'$_'" : 'undef'} @_[1..$#_];
        #$valstr =~ s/\n/\\n/g;
        #print "Setting $method to $valstr\n";
        $_[0]->{$method} = $_[1];
        #print "   Done $method to $valstr\n";
      }
      return $_[0]->get_val($method);
    };
    #print "autoload for $AUTOLOAD\n";
    goto &$AUTOLOAD;
  } else {
    croak "Undefined subroutine $AUTOLOAD called.";
  }
}

sub localize_field {
  my ($self, $field) = @_;
  return if exists $self->{$field};
  return unless exists $Fields{$field};
  return unless exists $Fields{$field}{default};
  $self->{$field} = MFreezer::clone($Fields{$field}{default});
  $self;
}

sub get_val {
  my ($self, $field, @prev) = @_;

  #print STDERR "entering get_val for [", ($self->{name}||''), " ", ($self->{name}||''), "] with prevs @prev\n";

  return $self->{$field} if defined $self->{$field};
  confess "lack of hash: $field" if $Fields{$field} and ref $Fields{$field} ne 'HASH';
  return ($Fields{$field} ? $Fields{$field}{default} : undef)
    unless defined $self->{'prototype'};

  if (not defined $Prototypes{$self->{'prototype'}}) {
    mudlog qq!ERROR/WORLD: BAD PROTOTYPE "$self->{'prototype'}" for object #$self->{id}!;
    return;
  }
  if (ref $Prototypes{$self->{'prototype'}} ne 'MObject') {
    mudlog qq!ERROR/WORLD: DAMAGED PROTOTYPE "$self->{'prototype'}" for object #$self->{id}!;
    return;
  }
  foreach my $plt (@prev) {
    if ($plt eq $self->{'prototype'}) {
      mudlog qq!ERROR/WORLD: PROTOTYPE LOOP FOR "$self->{'prototype'}"!;
      return;
    }
  }

  return $Prototypes{$self->{'prototype'}}->get_val($field, $self->{'prototype'}, @prev)
    || ($Fields{$field} ? $Fields{$field}{default} : undef);
}

sub has_val {
  my ($self, $field, @prev) = @_;

  return 1 if defined $self->{$field};
  return 0 unless defined $self->{'prototype'};

  if (not defined $Prototypes{$self->{'prototype'}}) {
    mudlog qq!ERROR/WORLD: BAD PROTOTYPE "$self->{'prototype'}" for object #$self->{id}!;
    return 0;
  }
  if (ref $Prototypes{$self->{'prototype'}} ne 'MObject') {
    mudlog qq!ERROR/WORLD: DAMAGED PROTOTYPE "$self->{'prototype'}" for object #$self->{id}!;
    return 0;
  }
  foreach my $plt (@prev) {
    if ($plt eq $self->{'prototype'}) {
      mudlog qq!ERROR/WORLD: PROTOTYPE LOOP FOR "$self->{'prototype'}"!;
      return 0;
    }
  }

  return $Prototypes{$self->{'prototype'}}->has_val($field, $self->{'prototype'}, @prev);
}

sub set_val {
  my ($self, $field, $value, $setter) = @_;

  if ($self->can($field)) {
    $self->$field($value);
  } else {
    $self->{$field} = $value;
  }
}

sub reset_val {
  my ($self, $field, $setter) = @_;

  delete $self->{$field};
}

use UNIVERSAL;
sub can {
  my ($self, $method) = @_;
  
  return 1 if $Fields{$method};
  return $self->SUPER::can($method);
}

1;
