view release on metacpan or  search on metacpan

lib/Chorus/Frame.pm  view on Meta::CPAN

  _DEFAULT      Fallback when _VALUE is absent.
  _NEEDED       Last-resort coderef called when both _VALUE and _DEFAULT are absent
                (backward chaining).
  _BEFORE           Hook called before a slot value changes.
  _AFTER            Hook called after a slot value changes (forward propagation).
  _ON_DELETE        Hook called after a slot is deleted; receives the slot name
                    (if-removed demon, completing the Minsky triad).
  _REQUIRE          Validation hook: return REQUIRE_FAILED to block the write.
  _NOFRAME          Prevents automatic promotion of a nested hash to a frame.
  _TERMINAL_SLOTS   Arrayref of slot names that must hold a real (_VALUE) value
                    for the frame to be considered complete (see complete()).
  _ALTERNATIVES     Arrayref of sibling prototype frames used by fselect()
                    as an alternative candidate pool (Minsky frame network).

=head2 Inheritance modes N and Z

The global mode controls how C<get()> walks the inheritance chain.

B<Mode N> (default) -- each valuation key is scanned across the whole inheritance tree
before the next key is tried:

  _VALUE  on (frame, frame._ISA, frame._ISA._ISA, ...)
  _DEFAULT on the same tree
  _NEEDED  on the same tree

B<Mode Z> -- the full sequence C<(_VALUE, _DEFAULT, _NEEDED)> is tried on each frame
before descending to its parents:

  frame     : _VALUE, _DEFAULT, _NEEDED
  frame._ISA: _VALUE, _DEFAULT, _NEEDED  ...

Switch with C<< Chorus::Frame::setMode(GET => 'Z') >> or C<< setMode(GET => 'N') >>.

=head2 Exports

C<Chorus::Frame> exports by default:

  $SELF          Current frame context, updated by get() and set().
  &fmatch        Slot-based frame selection function.
  &fselect       Prototype selection by scored slot/value matching (Minsky-style).
  &setMode       Switches the inheritance mode (N or Z).
  REQUIRE_FAILED Constant (-1) returned by _REQUIRE to abort a write.

=cut

BEGIN {
  use Exporter;
  use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

  @ISA         = qw(Exporter);
  @EXPORT      = qw($SELF &fmatch &fselect &setMode REQUIRE_FAILED );
  @EXPORT_OK   = qw();

  # %EXPORT_TAGS = ( );		# eg: TAG => [ qw!name1 name2! ];
}

use strict;
use warnings;
use Carp;			# warn of errors (from perspective of caller)
use Digest::MD5;
use Scalar::Util qw(weaken);

use constant DEBUG_MEMORY => 0;

use vars qw($AUTOLOAD);

use constant SUCCESS        =>  1;
use constant FAILED         =>  0;
use constant REQUIRE_FAILED => -1;

use constant VALUATION_ORDER => ('_VALUE', '_DEFAULT', '_NEEDED');

use constant MODE_N => 1;
use constant MODE_Z => 2;

my $getMode = MODE_N;       # DEFAULT IS N !!!

my %REPOSITORY;
my %FMAP;
my %INSTANCES;

our $SELF;
my @Heap = ();

sub AUTOLOAD {
  my $frame = shift || $SELF;
  my $slotName = $AUTOLOAD;
  $slotName =~ s/.*://;       # strip fully-qualified portion
  get($frame, $slotName, @_); # or getN or getZ !!
}

sub _isa {
  my ($ref, $str) = @_;
  return (ref($ref) eq $str);
}

=head1 FUNCTIONS

=head2 setMode

Sets the global inheritance mode used by C<get()> to resolve target information
(C<_VALUE>, C<_DEFAULT>, C<_NEEDED>).

  Chorus::Frame::setMode(GET => 'N');   # Mode N -- default
  Chorus::Frame::setMode(GET => 'Z');   # Mode Z
  Chorus::Frame::setMode('N');          # short form

See L</Inheritance modes N and Z> in the DESCRIPTION for a detailed comparison.

=cut

sub setMode {
  if (@_ == 1) {
    # short form: setMode('Z') or setMode('N')
    my $m = uc(shift);
    $getMode = MODE_N if $m eq 'N';
    $getMode = MODE_Z if $m eq 'Z';
  } else {
    my (%opt) = @_;
    $getMode = MODE_N if defined($opt{GET}) and uc($opt{GET}) eq 'N';
    $getMode = MODE_Z if defined($opt{GET}) and uc($opt{GET}) eq 'Z';
  }
}

=head1 METHODS

=head2 _keys

Returns the slot names of the frame, excluding the internal keys C<_KEY> and C<_PARENT_KEY>.

  my @slots = $frame->_keys;

Use this instead of C<keys %$frame> when you need to iterate over application slots
without exposing internal bookkeeping entries.

=cut

sub _keys {
  my ($this) = @_;
  grep { $_ ne '_KEY' && $_ ne '_PARENT_KEY' } keys %{$this}; # WARN - frames have EXTRA _KEY and _PARENT_KEY slots !!
}

sub pushself {
  unshift(@Heap, $SELF) if $SELF;
  $SELF = shift;
}

sub popself {
  $SELF = shift @Heap;
}

sub expand {
    my ($info, @args) = @_;
    return expand(&$info(@args)) if _isa($info, 'CODE');
    return $info;
}

=head2 _push

Appends one or more elements to a slot, converting it to an arrayref when necessary.

  $frame->_push('tags', 'red', 'big');

=cut

sub _push {
  my ($this, $slot, @elems) = @_;
  return unless scalar(@elems);
  $this->{$slot} = [ defined($this->{$slot}) ? ($this->{$slot}) : () ] unless ref($this->{$slot}) eq 'ARRAY';
  push @{$this->{$slot}}, @elems;
}

sub _addInstance {
  my ($this, $instance) = @_;
  my $k = $instance->{_KEY};
  $INSTANCES{$this->{_KEY}}->{$k} = $instance;


  # weaken($INSTANCES{$instance);         # TOCHECK - does the SAME !!??
  #
  weaken($INSTANCES{$this->{_KEY}}->{$k}); # Will not increase garbage ref counter to $instance !!
}

=head2 _inherits

Adds one or more parent frames to the inheritance chain outside the constructor.
Each parent is added at most once; duplicates are silently ignored.

  $frame->_inherits($parent1, $parent2);

Used internally by C<Chorus::Engine::new()> to wire agent instances to the engine
prototype.

=cut

sub _inherits {
  my ($this, @inherited) = @_;
  my $k = $this->{_KEY};
  for (grep { ! $INSTANCES{$_->{_KEY}}->{$k} } @inherited) { # clean list
    $_->_addInstance($this);  # will use weaken on 
    $this->_push('_ISA', $_);
  }
  return $this;
}

sub _removeInstance {
  my ($this, $instance) = @_;
  my $k = $instance->{_KEY};
  (warn "Instance NOT FOUND !?", return) unless $INSTANCES{$this->{_KEY}}->{$k};
  delete $INSTANCES{$this->{_KEY}}->{$k};
}

sub _register {
  my ($this) = @_;
  my $k;
  do { $k = Digest::MD5::md5_base64(rand) } while exists($FMAP{$k});

  foreach my $slot (keys(%$this)) { # register all slots      # not yet _KEY
    $REPOSITORY{$slot} = {} unless exists $REPOSITORY{$slot};
    $REPOSITORY{$slot}->{$k} = 'Y';
  }

  $this->{_KEY} = $k; # _KEY SET HERE !!
  $FMAP{$k} = $this;

  weaken($FMAP{$k}); # will not increase garbage ref counter to $this !!
  return $this;
}

sub _blessToFrameRec {
  local $_ = shift;

  if (_isa($_,'Chorus::Frame')) {
    while(my ($k, $val) = each %$_) {
       if (_isa($val,'HASH')) { # Warn - Will convert all hash tables to Chorus::Frame -> be carefull with function ref() !!
          next if $val->{_NOFRAME};
          bless($val, 'Chorus::Frame');
          _register($val);
          $val->{_PARENT_KEY} //= $_->{_KEY} if _isa($_, 'Chorus::Frame') && exists $_->{_KEY};
          _blessToFrameRec($val);
       } else {
          _blessToFrameRec($_->{$k}) if _isa($val,'ARRAY');
       }
       if ($k eq '_ISA') {
         foreach my $inherited (_isa($val,'ARRAY') ? map { expand($_) || () } @{$val}
                                                       : (expand($val))) {
            $inherited->_addInstance($_) if $inherited;
         }
       }
    }
    return;
  }

  if (_isa($_,'ARRAY')) {
    foreach my $idx (0 .. scalar(@$_) - 1) {
      if (_isa($_->[$idx], 'HASH')) {
        next if exists $_->[$idx]->{_NOFRAME};
        bless($_->[$idx], 'Chorus::Frame');
        _register($_->[$idx]);
        _blessToFrameRec($_->[$idx]);
      } else {
        _blessToFrameRec($_->[$idx]) if _isa($_->[$idx],'ARRAY');
      }
    }
  }
}

sub blessToFrame {
  my $res = shift;
  return $res if _isa($res, 'Chorus::Frame'); # already blessed

  SWITCH: {

    _isa($res, 'HASH') && do {
      return $res if exists $res->{_NOFRAME};
      _register(bless($res, 'Chorus::Frame'));
      _blessToFrameRec $res if _keys($res); # will ignore _KEY !
      last SWITCH;;
    };

    _isa($res, 'ARRAY') && do {
      return $res unless scalar(@$res);
      _blessToFrameRec $res;
      last SWITCH;
    };