view release on metacpan or  search on metacpan

lib/Net/OnlineCode/GraphDecoder.pm  view on Meta::CPAN

sub is_check {
  my ($self, $i) = @_;
  return ($i >= $self->{coblocks});
}




# the decoding algorithm is divided into two steps. The first adds a
# new check block to the graph, while the second resolves the graph to
# discover newly solvable auxiliary or message blocks.

# Decoder object creates a check block and we store it in the graph
# here

sub add_check_block {
  my $self = shift;
  my $nodelist = shift;
  my $mblocks = $self->{mblocks};

  unless (ref($nodelist) eq "ARRAY") {
    croak ref($self) . "->add_check_block: nodelist should be a listref!\n";
  }

  my $node = $self->{nodes}++;

  # set up new array elements
  $self->mark_as_solved($node);

  # Bones version handles edges and xor list in one list.
  # The constructor also tests whether elements are solved/unsolved
  my $bone = Net::OnlineCode::Bones->new($self, $node, $nodelist);
  die "add_check_block: failed to create bone\n" unless ref($bone);

  $self->{unknowns}->[$node-$mblocks] = $bone->unknowns;
  $self->{top}->     [$node-$mblocks] = $bone;

  print "Set unknowns count for check block $node to " .
    ($bone->unknowns) . " \n" if DEBUG;

  if (DEBUG) {
    print "New check block $node: " . ($bone->pp) . "\n";
  }

  # Make reciprocal links
  my ($min, $max) = $bone->unknowns_range;
  for ($min .. $max) {
    $self->{bottom}->[$bone->[$_]]->{$node} = $bone;
  }

  # mark node as pending resolution
  push @{$self->{unresolved}}, $node;

  # return index of newly created node
  return $node;

}

# Graph resolution. Resolution of the graph has a "downward" part
# (resolve()) where nodes with one unsolved edge solve a message or
# aux block, and an upward part (cascade()) that works up from a
# newly-solved node.

# helper function
sub apply_solution {

  my ($self, $node, $bone);



}

# Work up from a newly-solved block, potentially doing up-propagation
# rule
sub cascade {
  my ($self,$node) = @_;

  my $mblocks  = $self->{mblocks};
  my $ablocks  = $self->{ablocks};
  my $coblocks = $mblocks + $ablocks;
  my $pending  = $self->{unresolved};

  my @upper = keys %{$self->{bottom}->[$node]};

  if (DEBUG) {
    if (@upper) {
      print "Solved node $node cascades to nodes " . (join " ", @upper)
	. "\n\n";
    } else {
      print "Solved node $node has no cascade\n\n";
    }
  }

  # update the count of unsolved edges and maybe solve aux blocks
  for my $to (@upper) {
    print "Decrementing unknowns count for block $to\n" if DEBUG;
    ($self->{unknowns}->[$to - $mblocks])--;
    
  }
  push @$pending, @upper;
  
}

sub resolve {

  my ($self, @junk) = @_;

  if (ASSERT and scalar(@junk)) {
    die "resolve doesn't take arguments\n";
  }

  my $pending = $self->{unresolved};
  unless (@$pending) {
    return ($self->{done});
  }

  my $start_node = $pending->[0];
  if (ASSERT and $start_node < $self->{mblocks}) {
    croak ref($self) . "->resolve: start node '$start_node' is a message block!\n";
  }

  my @newly_solved = ();
  my $mblocks  = $self->{mblocks};
  my $ablocks  = $self->{ablocks};
  my $coblocks = $self->{coblocks};

  unless ($self->{unsolved_count}) {
    $self->{done}=1;
    return (1);
  }

  while (@$pending) {

    my ($from, $to, $min, $max) = (shift @$pending);

    my $bone     = $self->{top}     ->[$from - $mblocks];
    my $unknowns = $self->{unknowns}->[$from - $mblocks];
    my $solved   = $self->{solution}->[$from];

    next unless ref($bone);

    if (DEBUG) {
      print "\nStarting resolve at $from: " . $bone->pp .
	" ($unknowns unknowns)\n";
    }
    if (DEBUG) {
      my ($type, $status) = ("check", "unsolved");
      $type   = "auxiliary" if $from < $coblocks;
      $status = "solved"    if $solved;
      print "Resolving from $status $type node $from\n";
    }

    # I'm going back to the old way of doing up-propagation since the
    # new way messes with single-stepping

    if ($unknowns == 0) {

      next unless $from < $coblocks and !$solved;

      if (DEBUG) {
	print "Solving aux block $from based on aux rule\n";
      }

      die "Aux rule: didn't have one unknown\n"
	if ($from != $bone->known_unsolved($from));

      $self->{solution}->[$from] = $bone;

      # delete all edges that point up to us
      ($min,$max) = $bone->knowns_range;
      for ($min .. $max) {
	my $lower = $bone->[$_];
	die "Tried to delete non-existent up edge\n" if ASSERT and
	  !exists($self->{bottom}->[$lower]->{$from});
	delete $self->{bottom}->[$lower]->{$from};
      }

      $self->{top}->[$from - $mblocks] = undef;
      
      push @newly_solved, $bone;
      cascade($self, $from);

    } elsif ($unknowns == 1) {

      # Propagation rule matched (one unknown down edge)

      # resolve() only solves a node if the upper node itself is solved.
      # cascade() will handle the case of solving an unsolved aux block
      # by solving its last unsolved message block (upward propagation)


      if ($from < $coblocks and !$solved) {
	print "Skipping down propagation rule on unsolved aux\n" if DEBUG;
	next;
      }

      # pull out the unknown node
      if ($solved) {
	$to = $bone->unknown_unsolved($self);
      }

      if (DEBUG) {
	my ($type, $status) = ("auxiliary", "an unsolved");
	$type   = "message" if $to < $mblocks;
	$status = "a solved"  if $self->{solution}->[$to];
	print "To node $to is $status $type node.\n";
      }

      # delete reciprocal links for all known edges
      ($min, $max) = $bone->knowns_range;
      for ($min .. $max) {
	my $lower = $bone->[$_];
	# next if $lower == $from;
	# die "Tried to delete non-existent up edge $lower->$from\n" 
	#   if ASSERT and !exists($self->{bottom}->[$lower]->{$from});
	delete $self->{bottom}->[$lower]->{$from};
      }

      # mark child node as solved
      print "Marking block $to as solved\n" if DEBUG;
      $self->{solution}->[$to] = $bone;
      push @newly_solved, $bone;

      if ($to < $mblocks) {
	print "Solved message block $to completely\n" if DEBUG;
	unless (--($self->{unsolved_count})) {
	  $self->{done} = 1;
	  # comment out next two lines to continue decoding just in
	  # case there's a bug later
	  @$pending = ();
	  last;                 # finish searching
	}
      } else {
	print "Solved auxiliary block $to completely\n" if DEBUG;
	push @$pending, $to;
      }
      cascade($self, $to);
    } else {
      next;			# go to next pending
    }

    return ($self->{done}, @newly_solved) if STEPPING;

  }

  return ($self->{done}, @newly_solved);


}


1;

__END__