This could probably be simplified a little:

#! perl -sw
use strict;
use Data::Dump qw[ pp ];

my $h= {
    (4,-1),
    (2,6),
    (6,4),
    (3,5),
    (5,-1),
    (99,-1),
};

my %invert;
push @{ $invert{ $h->{ $_ } } }, $_ for keys %{ $h };

my %hh;
for( @{ $invert{ -1 } } ) {
    my $ref = { $_, -1 };
    while( exists $invert{ $_ } ) {
        my $key = pop @{ $invert{ $_ } };
        $ref = { $key, $ref };
        delete $invert{ $_ } unless @{ $invert{ $_ } };
        $_ = $key;
    }
    my( $key, $value ) = each %$ref;
    $hh{ $key } = $value;
}

pp \%hh;
__END__
c:\test>755232
{ 
    2 => { 6 => { 4 => -1 } }, 
    3 => { 5 => -1 }, 
    9 => -1 
}
[download]

I've often seen this for hierarchical data -- like you have flat hash (sql results) for some type of hierarchical data. There's probably a more efficient way of doing this but basically you want to chain the keys together until you hit some base criteria. Here's a first cut attempt (using references because i find it easier):

#!/usr/bin/perl

use strict;
use warnings;

use Data::Dumper;

my $nested_hash = {};
my $flat_hash   = {
  4 => -1,
  2 => 6,
  6 => 4,
  3 => 5,
  5 => -1,
 99 => -1,
};

print Dumper( $flat_hash );

# We need to keep track of what we've all ready chained
my $seen = {};

foreach my $key ( sort keys %$flat_hash ) {
  next if defined( $seen->{$key} );
  add_chain( $flat_hash, $nested_hash, $seen, $key );
}

print Dumper( $nested_hash );

sub add_chain {
  my( $flat_hash, $nested_hash, $seen, $key ) = @_;

  # if we've all ready added this key to the nested hash, ignore it
  return if defined( $seen->{$key} );
  $seen->{$key} = 1;

  my $current_key = $flat_hash->{$key};

  if( $current_key == -1 ) {
    # base case
    $nested_hash->{$key} = $flat_hash->{$key};
  }  else {
    # add next chain
    my $chain            = {};
    $nested_hash->{$key} = $chain;
    add_chain( $flat_hash, $chain, $seen, $current_key );
  }
}
[download]

$VAR1 = {
          '6' => 4,
          '99' => -1,
          '4' => -1,
          '3' => 5,
          '2' => 6,
          '5' => -1
        };
$VAR1 = {
          '99' => -1,
          '3' => {
                   '5' => -1
                 },
          '2' => {
                   '6' => {
                            '4' => -1
                          }
                 }
        };
[download]

In your post (OP) you specify that all numbers other than "-1" are "unique" - but what exactly do you mean? Do you mean that

1. each number appears only once on the left side of (x, y)?
2. do you mean that there is a unique path to each number except -1? That is, if we find $h{2}{6}{4} we will never find a sequence of pairs such that $h{7}{11}{6}{4}.

The two statements are quite different. Unless you are absolutely certain a priori that (2) is true, your algorithm is going to need to check for multiple paths to each number. Then you will have to decide whether those multiple paths are an error or not. Assuming that multiple paths to each number are an error, your code will need to keep track of each path found to each number.

I posted code below to illustrate the point, mainly as a contrast to BrowserUk's elegant solution. I do so with reservations. Bloodnok is right - it is considered bad form on Perl Monks to post a question without at least trying to show your own efforts. But BrowserUK is right too - the OP has posted a difficult problem. We aren't trying to be mean when we say do it yourself: it is just that we are donating our time so others can learn. Trying to solve the problem on your own is essential to really understanding the solution. For further discussion of the point, see The path to mastery.

Best, beth

Update: added my agreement with BrowserUk's observation about difficulty below.

I do so with reservations. Bloodnok is right - it is considered bad form on Perl Monks to post a question without at least trying to show your own efforts.

For simple problems I might agree, but this is decidely non-trivial. Should people refrain from asking if they have a difficult problem and have no idea how to start to solve it?

Personally, I think this is an interesting problem, clearly defined and it deserved an answer.

I also find that many of the "what have you tried" missives are self-serving.

---

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.

"Too many [] have been sedated by an oppressive environment of political correctness and risk aversion."

browserUk++. "What have you tried" but also "This looks like homework", which of course, begs the question of what classes someone may have had who is thoroughly self taught.

I've answered questions others regarded as simple, trivial, or homework simply because I found the problem to be interesting. And who is to say what any individual finds interesting? Mikhail Tal, for one, delighted in chess problems designed for children.

Looking at some of pysome's previous posts I'm guessing English is not his first language. That may be one reason why he limits what he asks in posts. In fact, it's probably less confusing for us if he does that. I think it's important that we keep in mind that we have people from other parts of the world and people from other professions. Certainly the question could have been presented better but that may be too much to ask of pysome. So kudos to you for finding it interesting enough to answer it!

Elda Taluta; Sarks Sark; Ark Arks

As ELISHEVA is probably tired of saying, this isn't a code writing service - try explaining what you've done and what doesn't seem to work and you might then get some constructive answers.

Uh, its not like a program, its just some syntax

$hh{2}{6}{4} = -1;
$hh{3}{5}    = -1;
$hh{99}      = -1;
use Data::Dumper;
print Dumper( \%hh);
__END__
$VAR1 = {
          '99' => -1,
          '3' => {
                   '5' => -1
                 },
          '2' => {
                   '6' => {
                            '4' => -1
                          }
                 }
        };
[download]

No it isn't just some syntax - look at the starting hash in the OP - the problem revolves around the converting the original hash from a flattened linked list to a hash containing the equivalent linked list ... not just rewriting the hash definition..

FWIW, I've solved it thusly:

use warnings;
use strict;
use Data::Dumper;

my $fll= {
(4,-1),
(2,6),
(6,4),
(3,5),
(5,-1),
(99,-1),
};
my $ll = {};

sub doit {
    my $done = { %$fll };
    while (%$done) {
        foreach (keys %$done) {
            my ($k,$v) = ($_, $done->{$_});
            if ($v < 0) {
                %$ll = (%$ll, ($k, $v));   
                delete $done->{$k};
            } else {
                if (exists $ll->{$v}) {
                    $ll->{$k} = {$v => $ll->{$v}};
                    delete $done->{$k};
                    delete $ll->{$v};
                }
            }
        }
    }
}

doit();

print Dumper $fll,$ll;
[download]

gives:

pointo1d@pointo1d-laptop:~$ perl tst.pl
$VAR1 = {
          '6' => 4,
          '99' => -1,
          '4' => -1,
          '3' => 5,
          '2' => 6,
          '5' => -1
        };
$VAR2 = {
          '99' => -1,
          '3' => {
                   '5' => -1
                 },
          '2' => {
                   '6' => {
                            '4' => -1
                          }
                 }
        };
[download]

As, I think, required

Update:

Added my attempt at a solution.

A user level that continues to overstate my experience :-))

As always there is more than one way to do it. I see chains as arrays, so i built arrays first, then looped those to make hashes. Of coures as I wrote this and pasted I realized that this method depends on the right order, so I'm gonna make a second shot, but here is this version for fun:

#!/usr/bin/perl
use strict;
use warnings;

use Data::Dumper;

my $pairs = {
    (4,-1),
    (2,6),
    (6,4),
    (3,5),
    (5,-1),
    (99,-1),
};


my @paths;

foreach my $key (keys %$pairs) {
    my $value = $pairs->{$key};

    # if the right hand side matches the start of a chain
    # then unshift the left onto the start of the chain
    my @start_path = grep { @$_[0] eq $value } @paths;
    unshift(@{$start_path[0]}, $key) if @start_path;

    # if the left hand side matches the end of a chain,
    # then push the left hand side onto the end
    my @end_path = grep { @$_[-1] eq $key } @paths;
    push( @{$end_path[0]}, $value) if @end_path;

    push @paths, [$key, $value] unless (@start_path or @end_path);
}

my $hh;
for my $path (@paths) {
    my $temp = pop @$path;
    my $key  = shift @$path;
    for (reverse @$path) {
        my $t = {$_ => $temp};
        $temp = $t;
    }
    $hh->{$key} = $temp;
}
print Dumper($hh);
[download]

Okay this version finds the ends of the paths, then builds them backwards from their. As long as the data is good it will run fine ;) I added the pair (1,2) which breaks the above code.

#!/usr/bin/perl
use strict;
use warnings;

use Data::Dumper;

my $pairs = {
    (4,-1),
    (2,6),
    (6,4),
    (1,2),
    (3,5),
    (5,-1),
    (99,-1),
};


my @paths;


#get the ends of all the chains
#then the next pieces, and so on, until all pairs are used.

for my $key ( grep { $pairs->{$_} == -1 } keys %$pairs ) {
    push @paths, [$key, -1];
    delete $pairs->{$key};
}

while ( keys %$pairs ) {
    for my $path ( @paths ) {
        for my $key ( keys %$pairs ) {
            if ($pairs->{$key} eq @$path[0]) {
                unshift @$path, $key;
                delete $pairs->{$key};
            }
        }
    }
}

my $hh;
for my $path (@paths) {
    my $temp = pop @$path;
    my $key  = shift @$path;
    for (reverse @$path) {
        my $t = {$_ => $temp};
        $temp = $t;
    }
    $hh->{$key} = $temp;
}
print Dumper($hh);
[download]


___________
Eric Hodges

Here is yet another solution. This one has a single loop and no recursion.

#!/usr/local/bin/perl
use strict;
use warnings;
use Data::Dumper;

my $h= {
(4,-1),
(2,6),
(6,4),
(3,5),
(5,-1),
(99,-1),
};


my %hh;
my %tails;

while(my ($key, $value) = each %$h) {
    my $val;
    if($value == -1) {
        $val = -1;
    } elsif(exists($hh{$value})) {
        $val = { $value => $hh{$value} };
        delete($hh{$value});
    } else {
        $val = {};
        $tails{$value} = $val;
    }
    if(exists($tails{$key})) {
        $tails{$key}{$key} = $val;
    } else {
        $hh{$key} = $val;
    }
}

print Dumper(\%hh);
[download]

#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;

my $h = { 4 => -1, 2 => 6, 6 => 4, 3 => 5, 5 => -1, 99 => -1 };

sub LEAF() { -1 }


# Make a list of toplevel keys: values occurring once and not LEAF
my %tl;
++$tl{$_} for  grep { $_ != LEAF }  %$h ;
my @toplevel =  grep { $tl{$_} == 1 } keys %tl;


# Build linked lists from head as HoHo...
my %answer = ();
for my $k ( @toplevel ) {
    my $cursor = \%answer;
    $cursor->{$k} = $h->{$k};

    while ( LEAF != ( my $next_k = $cursor->{$k})  ) {
        $cursor = $cursor->{$k} =  { $next_k, $h->{ $next_k } };
        $k = $next_k;
    }
}

print Dumper \%answer;
[download]