Perl Monk, Perl Meditation PerlMonks

Challenge: Perl 5: lazy sameFringe()?

by BrowserUk (Pope)
 on Jun 29, 2013 at 16:12 UTC Need Help??
BrowserUk has asked for the wisdom of the Perl Monks concerning the following question:

Purely recreational: Produce a lazy Same Fringe() implementation in Perl 5?

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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.

Replies are listed 'Best First'.
Re: Challenge: Perl 5: lazy sameFinge()?
by roboticus (Chancellor) on Jun 29, 2013 at 19:05 UTC

I didn't get anywhere on your binary string analysis problem yesterday. I was working on a couple different things, but none of 'em led me anywhere good. Anyway, for the fringe thing:

```\$ cat Fringe.pl
#!/usr/bin/perl
use strict;

my \$tree1 = [ 'd', [ 'c', [ 'a', 'b', ], ], ];
my \$tree2 = [ [ 'd', 'c' ], [ 'a', 'b' ] ];
#my \$tree2 = [ [ [ 'd', 'c', ], 'a', ], 'b', ];

my \$ti1 = get_tree_iterator(\$tree1);
my \$ti2 = get_tree_iterator(\$tree2);

my \$cnt_mismatches=0;
while (1) {
my (\$L, \$R) = (\$ti1->(), \$ti2->());
++\$cnt_mismatches unless (\$R eq \$L) or (!\$L and !\$R);
print "L=\$L, R=\$R\n";
last if !defined \$L;
}
print \$cnt_mismatches ? "\$cnt_mismatches mismatches" : "TREES MATCH!",
+ "\n";

sub get_tree_iterator {
my @stack = (shift);
return sub {
unshift @stack, @{shift @stack} while @stack and ref \$stack[0]
+ eq 'ARRAY';
return shift @stack;
}
}
\$ perl Fringe.pl
L=d, R=d
L=c, R=c
L=a, R=a
L=b, R=b
L=, R=
TREES MATCH!

Update: I've posted a version (with the better iterator mentioned further down in this thread) to Rosetta Code. I couldn't find my original account information (or perhaps I misremembered and didn't create an account there. I didn't want to clutter up the thread with yet another version. I've also made that one meet the spec (i.e., early termination).

...roboticus

When your only tool is a hammer, all problems look like your thumb.

Nice ... but I'm not really sure if this qualifies as lazy !?!

You are using many copies to flatten the stack.

with some dumps of intermediate @stack-states:

out
```---
[[[["a", "b"], "c"], "d"]]
[[["a", "b"], "c"], "d"]
[["a", "b"], "c", "d"]
["a", "b", "c", "d"]
---
[[["a", "b"], ["c", "d"]]]
[["a", "b"], ["c", "d"]]
["a", "b", ["c", "d"]]
L=a, R=a
---
["b", "c", "d"]
---
["b", ["c", "d"]]
L=b, R=b
---
["c", "d"]
---
[["c", "d"]]
["c", "d"]
L=c, R=c
---
["d"]
---
["d"]
L=d, R=d
---
[]
---
[]
L=, R=

Cheers Rolf

( addicted to the Perl Programming Language)

LanX:

They didn't specify where the laziness should be, so I let the programmer be lazy at the expense of the computer working hard!

...roboticus

When your only tool is a hammer, all problems look like your thumb.

LanX:

On rereading this thread, I think you may misunderstand what my code is doing. When you said that my code wasn't "lazy", I thought you meant that it was working too hard, but in retrospect I think you're meaning that I'm flattening the entire tree at once before returning anything.

But I'm not doing that--Instead, I'm properly visiting the tree, traversing the left subtree(s) until I find the first (leftmost) leaf. The unused right subtrees are left on the stack for processing later.

Since my test data was small and the tree left-heavy, though, it's hard to see that. Below (in readmore tags for those uninterested) is a run of the original iterator that you instrumented with a more "interesting" tree. I also have the output of my better version (also instrumented):

...roboticus

When your only tool is a hammer, all problems look like your thumb.

Beautiful.

I made a first try to traverse the tree recursively and then figured out that it does not work for comparing two trees, it seems impossible (or at least very complicated) to recurse on two data structures simultaneously.

So, I figured out that I probably needed an iterator (well actually two iterator functions) to return the leaves on demand, leading to a solution quite similar (at least in spirit) to yours, but, since I have done that only once or twice before, and quite some time ago, I had to go back to Mark-Jason Dominus' Higher Order Perl book to figure out how to do that. My iterators now seem to work more or less properly (although they are somewhat clumsy compared to yours), so that I am almost there (the main loop is not very complicated), but you did it before (and better).

Your code definitely looks much better than what I have so far, so that, unless I come with a brilliant new idea (unlikely), I will not submit mine;

Congratulations, roboticus. Beautiful work.

To LanX: using iterators is what is needed to make the process lazy (there may be other solutions, but this is a good one), or to make it possible to have it lazy. roboticus did not really make it completely lazy (the program is counting the number of differences, rather than exiting at the first difference), but it only takes a minor change to make it truly lazy (if we have the same understanding of lazyness).

BTW, roboticus, it would be good to publish your solution on the Rosetta Stone site: when you see solutions in some languages taking 200 lines of code or more, and a solution like yours taking more than 10 times less code, you get a certain picture of the amount of effort to get something done in various languages. ADA or Java, just to name two, are very powerful languages, no doubt, but need a lot of efforts to do something simple. In contrast, languages like Perl, Python, Haskell or Lisp (just a few examples) have much more expressive power. And, even thougn IT managers usually don't really understand the difference, they do if you tell them: "well this I can do in two weeks with XYZ super-duper object language , and in 2 days in Perl or Haskel (or Lisp, or whatever).

Don't worry about it, post your solution--One of the fun things about programming is seeing how other people do things, and then learning their techniques! Not only that someone might offer a suggestion to you that could lead in a different and better direction. As LanX mentioned, mine's computationally expensive. That's not a real problem in this case. But if someone needed to compute as many fringes per second as possible, then a faster solution would be helpful. I can't help but feel that there's an even nicer way to do it, but I haven't thought of it yet.

Also, the code above wasn't my first shot at it. It was an interesting problem, so I spent a bit of time on it. I went through six iterations to get it as simple as it is now. Once I had some functional code, I thought that there was just too much special-case handling code. So I tried to rearrange things to remove the special cases. It's pretty simple in the final version, but I didn't see the simple version at first--I seem to have a habit of seeing the trees before noticing the forest.

It took me six iterations to get to the version I posted. My first version was this:

```sub tree_iterator {
return undef unless @stack;
my \$tos = pop @stack;
return \$tos unless ref \$tos eq 'ARRAY';
my (\$L, \$R) = @\$tos;
print "ENTER (\$L, \$R)\n";
while (1) {
print "LOOP: (\$L, \$R)\n";
push @stack, \$R if defined \$R;
if (defined \$L) {
return \$L if ref \$L ne 'ARRAY';
(\$L, \$R) = @\$L;
redo;
}
else {
(\$L, \$R) = @{pop @stack};
}
}
}

(This is before I wrapped up the stack in a closure to make the iterator useful.) As you can see, there are just too many special cases in there. Each time I removed one special case, it gave me an idea for the next one. I'm pretty happy with the version I ultimately wound up with, even though I suspect that it could be better yet. It would be pretty nice if I could think up a nice simple way to do it and reduce the array rebuilds, too. I tried to switch back to the push/pop, as I think that would be more efficient, but most of the special cases were due to my use of push/pop at the start. Switching to shift/unshift allowed me to remove one or two odd bits.

I think I have a rosetta code login at work, so I'll try to remember to post it there on Monday.

And, even though IT managers usually don't really understand the difference, they do if you tell them: "well this I can do in two weeks with XYZ super-duper object language , and in 2 days in Perl or Haskel (or Lisp, or whatever).

I wish the people at \$work were susceptible to that argument. I used this very argument at work the other day. They needed a file generated, so I quoted a day in Perl or a week in .Net or PL/SQL. Also, I mentioned that due to time pressures on the current project, I could just squeeze the Perl version into my schedule. There's little Perl expertise at \$work, and they're fearful enough of it, that they opted to do it in PL/SQL. 10 days later and it works. Luckily, due to the time pressures, *I* didn't have to do the task. But I'm frequently surprised when it's "rush rush rush!" but when you want to do it with a tool they're uncomfortable with, saving all the time in the world wouldn't be enough for them. ...sigh...

...roboticus

When your only tool is a hammer, all problems look like your thumb.

As I mentioned yesterday, seeing what other people do can give you inspiration. Case in point: I just reviewed the solution hdb posted, and got the hint I needed to make mine better: Rather than using just a stack, hdb uses a stack and a reference to the current (sub)tree being worked on. By using the same I idea, I was able to come up with a new version of get_tree_iterator that I like even better:

```sub get_tree_iterator {
my @rtrees=(shift);
my \$tree;
return sub {
\$tree=pop @rtrees;
(\$tree, \$rtrees[@rtrees]) = @\$tree while ref \$tree;
return \$tree;
}
}

This version still descends down the left tree until it hits a leaf, but it uses much less manipulation of the @stack array, and uses the right hand side of the array, which is (I expect) more efficient than the left side. (Editing the right side of the array may cause an expansion of the array, but I'm thinking that expanding the left side of the array may cause unnecessary array copies.)

When I look at this version, I don't feel like I'm missing anything. (Not to say that I'm not--It's amazing how often one can make significant improvements to "optimized" code.)

...roboticus

When your only tool is a hammer, all problems look like your thumb.

Re: Challenge: Perl 5: lazy sameFringe()?
by LanX (Bishop) on Jun 30, 2013 at 00:00 UTC
TIMTOWTDI

NOTE that this example iterates over HoH not AoAs (which is a bit silly b/c order matters) since I have only 5.10 installed.

With >=5.12 each should also work with ARRAYs! (testing appreciated)

It might not be the most elegant solution but

a) it's really lazy - not only for the programmer - and

b) it can iterate nested Arrays and Hashes alike for >=5.12.

c) it's quite fast.

d) I can tell the recursion "depth" of each iteration. NOTE I'm only returning 3 values for better visualization/debugging. Only \$v matters for this task.

```use Data::Dump 'dd';
use strict;
use warnings;

dd my \$h1 = { a => {b => {c => 1}, d=> 2}, e=>3,f=>4 };
dd my \$h2 = { a => {b => {c => 1}, d=> 2}, e=>3,f=>4 };

sub gen {
my \$ref=shift;
my @path=();
return sub {
while (1) {
while (my (\$k,\$v) = each %\$ref) {
if ( ref \$v eq "HASH") {
push @path,\$ref;
\$ref =\$v;
next;
} else {
return \$k,\$v,scalar @path;
}
}
return unless  \$ref = pop @path;
}
}
}

my \$iter1=gen(\$h1);
my \$iter2=gen(\$h2);

while ((my (\$k1,\$v1,\$l1) = \$iter1->()) + (my (\$k2,\$v2,\$l2) = \$iter2->(
+)) ) {
die "error \$v1 != \$v2" if \$v1 ne \$v2;
print "\$l1: \$k1=> \$v1\n";
}

out

```/usr/bin/perl -w /tmp/lanx_fringe.pl
{ a => { b => { c => 1 }, d => 2 }, e => 3, f => 4 }
{ a => { b => { c => 1 }, d => 2 }, e => 3, f => 4 }
0: e=> 3
2: c=> 1
1: d=> 2
0: f=> 4
a more functional solution on Monday.

Cheers Rolf

( addicted to the Perl Programming Language)

UPDATE

I just realized that it's about binary trees and that the representation of them is free.

So when choosing nested hashes with keys L and R , this algorithm already delivers the needed features. =)

UPDATE

Limitations see Re^3: Challenge: Perl 5: lazy sameFringe()?

UPDATE I just realized that it's about binary trees and that the representation of them is free. So when choosing nested hashes with keys L and R , this algorithm already delivers the needed features.

Have you tested your routines using the same test data as used by the rosetta challenge? If not, you haven't even begun to enter into the spirit of the challenge.

Which makes all your posts in this thread challenging the efficacy of other peoples attempts are at best misplaced noise; and at worst, mind-blowing arrogance and misunderstanding,.

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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.
> Have you tested your routines using the same test data as used by the rosetta challenge?

yes and it fails (only) when comparing identical hashes.

This resulted into this thread , which I suppose you are well aware of.

(Demonstrating the limitations of each is the most valuable outcome for me.)

None of the solutions so far can compete with the elegance of the idiomatic P6's gather/take resp. Py's yield which is a bit frustrating ...

Having specialized solutions which only work for binary AoAs is no big compensation...

Cheers Rolf

( addicted to the Perl Programming Language)

Re: Challenge: Perl 5: lazy sameFringe()?
by hdb (Monsignor) on Jun 30, 2013 at 10:31 UTC

Very nice exercise!

```use strict;
use warnings;

sub make_iterator {
my \$s = shift;
my @stack = ();
return sub {
while(defined \$s) {
if( !ref \$s ) {
my \$n = \$s; \$s = pop @stack; return \$n; # leaf & back up the t
+ree
}
if( ref \$s->[0] ) {
push @stack, \$s->[1]; \$s = \$s->[0]; # down & and memorize othe
+r branch
} else {
my \$n = \$s->[0]; \$s = \$s->[1]; return \$n; # leaf & down the ot
+her branch
}
}
return undef;
}
}

sub sameFringe {
my (\$i1, \$i2) = map { make_iterator( \$_ ) } @_;
while( my \$n = \$i1->() ) {
return 0 if \$n ne \$i2->();
}
return defined( \$i2->() ) ? 0 : 1;
}

my @trees = (
[ [ 1, [ [2, [4, 7] ], 5 ] ], [3, [6, [8, 9] ] ] ],
[ [ 1, [ [2, [4, 7] ], 5 ] ], [3, [6, [8, 9] ] ] ],
[ [ 1, [ [ [2, 4], 7], 5 ] ], [3, [6, [8, 9] ] ] ],
[ [ 1, [ [2, [4, 7] ], 5 ] ], [3, [6, [8, [9, 0 ] ] ] ] ]
+,
[ [ 1, [ [0, [4, 7] ], 5 ] ], [3, [6, [8, 9] ] ] ],
);
print sameFringe( \$trees[0], \$_ )?"Same\n":"Different\n" for @trees;

my \$a = [ 1, [ 2, [ 3, [ 4, 5 ] ] ] ];
my \$b = [ 1, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$c = [ [ [ [ 1, 2 ], 3 ], 4 ], 5 ];

print sameFringe( \$a, \$a )?"Same\n":"Different\n";
print sameFringe( \$a, \$b )?"Same\n":"Different\n";
print sameFringe( \$a, \$c )?"Same\n":"Different\n";

my \$x = [ 1, [ 2, [ 3, [ 4, [ 5, 6 ] ] ] ] ];
my \$y = [ 0, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$z = [ 1, [ 2, [ [ 4, 3 ], 5 ] ] ];

print sameFringe( \$a, \$x )?"Same\n":"Different\n";
print sameFringe( \$a, \$y )?"Same\n":"Different\n";
print sameFringe( \$a, \$z )?"Same\n":"Different\n";
I like the idea of just storing the next element but IMHO your algorithm can't handle sub-arrays of size >2 and the iterator stops.

```my \$a = [ 1, [ 2, [ 3, [ 4, 5 ] ] ] ];
my \$d = [ 1,  2,  3,  4,  5 ];

print sameFringe( \$a, \$d )?"Same\n":"Different\n";

__END__
Use of uninitialized value in string ne ...
Different

update

oops!!! I just realized that the task is restricted to binary trees! =)

(how boring ;)

Cheers Rolf

( addicted to the Perl Programming Language)

Nice++ A solution that actually matches the spec :)

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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.
Re: Challenge: Perl 5: lazy sameFringe()?
by BrowserUk (Pope) on Jun 30, 2013 at 06:43 UTC

My attempt (not keen on the redo loop):

```#! perl -slw
use strict;
use Scalar::Util qw[ dualvar ];
use constant { TRUE => dualvar( 1, 'true' ), FALSE => dualvar( 0, 'fal
+se' ) };
use enum qw[ LEFT RIGHT ];

sub fringe {
my \$tree = shift;
my \$Q = threads::Q->new( 1 );
my \$scan; \$scan = sub{
my \$t = shift;
!ref( \$t ) ? \$Q->nq( \$t ) : ( &\$scan( \$t->[LEFT] ), &\$scan( \$t
+->[RIGHT] ) );
};
async{ \$scan->( \$tree ); \$Q->nq( undef ); }->detach;
return sub{ \$Q->dq; };
}

sub sameFringe {
my \$i1 = fringe( shift );
my \$i2 = fringe( shift );
{
no warnings 'uninitialized';
( my \$v1 = &\$i1 ) == ( my \$v2 = &\$i2 ) or return FALSE;
redo if defined( \$v1 // \$v2 );
}
return TRUE;
}

my \$a = [ 1, [ 2, [ 3, [ 4, 5 ] ] ] ];
my \$b = [ 1, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$c = [ [ [ [ 1, 2 ], 3 ], 4 ], 5 ];

print sameFringe( \$a, \$a );
print sameFringe( \$a, \$b );
print sameFringe( \$a, \$c );

my \$x = [ 1, [ 2, [ 3, [ 4, [ 5, 6 ] ] ] ] ];
my \$y = [ 0, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$z = [ 1, [ 2, [ [ 4, 3 ], 5 ] ] ];

print sameFringe( \$a, \$x );
print sameFringe( \$a, \$y );
print sameFringe( \$a, \$z );

__END__
C:\test>lazyTree.pl
true
true
true
false
false
false

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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.
Re: Challenge: Perl 5: lazy sameFinge()?
by LanX (Bishop) on Jun 29, 2013 at 16:27 UTC
> Produce a lazy Same Fringe() implementation in Perl 5?

I just feel too lazy now... ;-)

SCNR Rolf

( addicted to the Perl Programming Language)

PS: Monday perhaps... BTW nice use case for P6's Gather/Take

Re: Challenge: Perl 5: lazy sameFringe()?
by Laurent_R (Canon) on Jun 30, 2013 at 15:10 UTC

This is my solution. As I said above, I think it is less elegant than others published above, but I follow Roboticus's recommendation to publish it nonetheless.

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

my \$tree1 = [1, [2, [4, [7]], [5]], [3, [6, [8], [9]]]];
my \$tree2 = [1, [2, [4, [7]], [5]], [3, [6, [8], [9]]]];
my \$tree3 = [1, [2, [4, [7]], [5]], [3, [6, [9], [8]]]];

my \$next_el1 = create_iterator(\$tree1);
my \$next_el2 = create_iterator(\$tree3);

my \$match = 1;

while (1) {
my \$left = \$next_el1->();
my \$right = \$next_el2->();
no warnings 'uninitialized';
print \$left, " ", \$right, "\n";
unless (\$left eq \$right) {\$match = 0 ; last} ;
last unless defined \$left;
}

if (\$match) {
print "The trees match \n";
} else {
print "The trees don't match \n";
}

sub create_iterator {
my \$ref = shift;
my @ref_list;
return sub {
while (ref \$ref eq 'ARRAY') {
push @ref_list, @\$ref;
\$ref = shift @ref_list;
}
my \$leaf = \$ref;
\$ref = shift @ref_list;
return \$leaf;
}
}

Results comparing tree1 and tree3:

```\$ perl  fringe.pl
1 1
2 2
3 3
4 4
5 5
6 6
7 7
8 9
the trees don't match

And comparing tree1 and tree2:

```\$ perl  fringe.pl
1 1
2 2
3 3
4 4
5 5
6 6
7 7
8 8
9 9

The trees match

OK, BrowserUK, here we go with a sameFringe function and the test data copied from your posted solution.

Note that I had to make a small change in my closure (unshift instead of push on the @ref_list array), because my original code did not compare \$a and \$c correctly (the leaves were appearing in opposite order).

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

my \$a = [ 1, [ 2, [ 3, [ 4, 5 ] ] ] ];
my \$b = [ 1, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$c = [ [ [ [ 1, 2 ], 3 ], 4 ], 5 ];

sameFringe( \$a, \$a );
sameFringe( \$a, \$b );
sameFringe( \$a, \$c );

my \$x = [ 1, [ 2, [ 3, [ 4, [ 5, 6 ] ] ] ] ];
my \$y = [ 0, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$z = [ 1, [ 2, [ [ 4, 3 ], 5 ] ] ];

sameFringe( \$a, \$x );
sameFringe( \$a, \$y );
sameFringe( \$a, \$z );

sub sameFringe {
my \$next_el1 = create_iterator(shift);
my \$next_el2 = create_iterator(shift);
my \$match = 1;
while (1) {
my \$left = \$next_el1->();
my \$right = \$next_el2->();
no warnings 'uninitialized';
print \$left, " ", \$right, "\n";
unless (\$left eq \$right) {\$match = 0 ; last} ;
last unless defined \$left;
}
\$match ? print "the trees match\n": print "the trees don't match\n
+";
}

sub create_iterator {
my \$ref = shift;
my @ref_list;
return sub {
while (ref \$ref eq 'ARRAY') {
unshift @ref_list, @\$ref;
\$ref = shift @ref_list;
}
my \$leaf = \$ref;
\$ref = shift @ref_list;
return \$leaf;
}
}

The following is the output:

```>perl fringe.pl
1 1
2 2
3 3
4 4
5 5

the trees match
1 1
2 2
3 3
4 4
5 5

the trees match
1 1
2 2
3 3
4 4
5 5

the trees match
1 1
2 2
3 3
4 4
5 5
6
the trees don't match
1 0
the trees don't match
1 1
2 2
3 4
the trees don't match

Laurent_R++ Another solution that works and (almost) meets the specs.

It would be easier to compare with other attempts if you wrapped your algorithm up in a sameFringe() subroutine -- same args and return -- as is used in the linked article.

It is also a good idea to test using the same tests as they use. They have been quite carefully designed (or arrived at) to test several particular edge cases.

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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.
Re: Challenge: Perl 5: lazy sameFringe()?
by hdb (Monsignor) on Jun 30, 2013 at 13:16 UTC

Laurent_R above is looking for a recursive solution. Recursion is the easiest way to traverse a tree. My idea to do this is sketched like this for simultaneous recursive traversal:

```use strict;
use warnings;

sub recursiveFringe {
for( @{ +shift } ) {
if( ref \$_ ) { recursiveFringe( \$_ ) } else { print "\$_\n" };
}
}

sub sameFringe {
# create a subthread for each tree executing the above recursiveFrin
+ge
# in such a way that the output from print above can be read in
# while(<...>) in the main thread.
# once a difference occurs return FALSE and terminate threads
}

my @trees = (
[ [ 1, [ [2, [4, 7] ], 5 ] ], [3, [6, [8, 9] ] ] ],
[ [ 1, [ [2, [4, 7] ], 5 ] ], [3, [6, [8, 9] ] ] ],
[ [ 1, [ [ [2, 4], 7], 5 ] ], [3, [6, [8, 9] ] ] ],
[ [ 1, [ [2, [4, 7] ], 5 ] ], [3, [6, [8, [9, 0 ] ] ] ] ]
+,
[ [ 1, [ [0, [4, 7] ], 5 ] ], [3, [6, [8, 9] ] ] ],
);
print sameFringe( \$trees[0], \$_ )?"Same\n":"Different\n" for @trees;

As I have no experience with threads, I do not really know how to start this or whether it is even feasible. What do you think?

LanX: As far as I can see, this would work for trees with more branches than two...

```# create a subthread for each tree executing the above recursiveFringe
# in such a way that the output from print above can be read in
# while(<...>) in the main thread.
# once a difference occurs return FALSE and terminate threads

That looks more like a fork-based approach than a thread based.

See mine for a recursion and threads approach.

I'd love to see a Coro solution here.

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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.
Re: Challenge: Perl 5: lazy sameFringe()? (threads::Gather Configurably truely lazy or semi-lazy)
by BrowserUk (Pope) on Jul 02, 2013 at 20:24 UTC

A better implementation I think:

```#! perl -slw
use strict;
use 5.010;
use Scalar::Util qw[ dualvar ];
use constant { TRUE => dualvar( 1, 'true' ), FALSE => dualvar( 0, 'fal
+se' ) };
use enum qw[ LEFT RIGHT ];

sub fringe {
my \$tree = shift;
gather{
my \$t = shift;
!ref( \$t ) and return take( \$t );
\$^R->( \$t->[LEFT]  );
\$^R->( \$t->[RIGHT] );
} 1, \$tree;
}

sub sameFringe {
my @i = map fringe( \$_ ), @_;
for( my @v = map &\$_, @i; defined( \$v[0] // \$v[1] ); @v = map &\$_,
+@i ) {
local \$^W; \$v[0] == \$v[1] or return FALSE;
}
return TRUE;
}

my \$a = [ 1, [ 2, [ 3, [ 4, 5 ] ] ] ];
my \$b = [ 1, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$c = [ [ [ [ 1, 2 ], 3 ], 4 ], 5 ];

print sameFringe( \$a, \$a );
print sameFringe( \$a, \$b );
print sameFringe( \$a, \$c );

my \$x = [ 1, [ 2, [ 3, [ 4, [ 5, 6 ] ] ] ] ];
my \$y = [ 0, [ [ 2, 3 ], [ 4, 5 ] ] ];
my \$z = [ 1, [ 2, [ [ 4, 3 ], 5 ] ] ];

print sameFringe( \$a, \$x );
print sameFringe( \$a, \$y );
print sameFringe( \$a, \$z );

__END__
C:\test>sameFringe
true
true
true
false
false
false

With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
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.

Create A New User
Node Status?
node history
Node Type: perlquestion [id://1041479]
Approved by marto
Front-paged by LanX
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (8)
As of 2018-02-21 12:16 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
When it is dark outside I am happiest to see ...

Results (279 votes). Check out past polls.

Notices?