Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Re^2: GP problem with tree structure using hash

by BrowserUk (Patriarch)
on Oct 13, 2004 at 07:10 UTC ( #398777=note: print w/replies, xml ) Need Help??


in reply to Re: GP problem with tree structure using hash
in thread GP problem with tree structure using hash

Your modified code is still producing a large number of warnings. This is because of the "trim leading zeros" substitution in your dec2bin() routine. You added the substr, but left the s///, which means that the return value is often devoid of the leading zeros you require.

sub dec2bin { my $str = unpack("B32", pack("N", shift)); return substr($str, -6); }

After that, the memory problem occurs because your crossover() routine is going into deep recursion. Ie. Once it starts recursing, it never stops. Part of the problem for this is your using empty brackets after the sunroutine names. This is called an "empty prototype" and has a very particular meaning in Perl. The explanation is long and difficult. For now, remove them; from all of your routines. You do not need them and they are having a totally different effect than you think thay are.

Once you remove the "()" from after the subroutine names (eg. sub mutation() { becomes sub mutation { ), the program operates somewhat differently. It still goes into deep recursion, but this time:

Deep recursion on subroutine "main::replace_node" at P:\test\398622.pl + line 155.

Looking at that routine

sub replace_node { my($tree,$a,$b) = @_; if($tree == $a) { $tree = $b; } else{ if(defined($tree->{left})) { &replace_node($tree->{left},$a,$b); } if(defined($tree->{right})) { &replace_node($tree->{right},$a,$b); } } $_[0] = $tree; return; }

The first thing I noticed is that you are using '&' on the front of your calls to subroutines. Again, this has a very specific meaning in Perl, and it does something special in some circumstances that you almost certainly don't want. So remove them--all of them.

That also makes you code run differently. The explaination of what and how I frankly haven't analysed, and you probably wouldn't be interested in the detail if I had. For now, don't use prototypes or '&'s. At least until you have discovered the reason why you might want to use them on some, rare occasions.

The other thing I noticed in the routine above is:

$_[0] = $tree; return;

What do you think that this code is doing? I ask, because it almost certainly isn't doing what you think it is doing.

The upshot is that it seems fairly likely that you have started out with a program written in some langauge other than Perl, and are trying to adapt it to Perl. The problem with that is that Perl uses some syntax that looks vaguely similar to syntax found in other langauges, but uses it in quite different ways, which breaks horribly if you use them incorrectly.

It is clear that you are not testing your routines individually before trying to combine them together into a large and complicated program. That makes debugging extremely hard as you will often see the effects of several bugs combine to produce situations that no one single change will correct. That leaves you trying something, no apparent change occurs so you back the change out and try something else, when what is required is that first change plus one (or two or three) others to make thing better. It's a sole destroying way to debug code.

Try constructing a simple tree, just a parent node and two children, and then test each of your routines on that individually. Once you get one routine working correctly, move onto the next. Once you have them all working on the simple case, manually construct a slightly more complex tree and try them again. If they still work, you stand a chance that when youstart putting them together, they will cooperatively work also.

That may sound laborious but it is a simple piece of math. If you have 10 routines each with one bug, and you fix them one at a time, you will need 10 changes.

If you try to fix them in combination, you may have to go through 10! (3,628,800) combinations of changes before you find the right one. You decide which is laborious:)

Finally, when you are developing and testing a program that uses rand to generate test data, or control program flow in a random fashion, stick an

srand(1);
at the top of the program. The program will still generate random data, and follow a random path, but by initilaise the PRNG with a constant, it will be the same random data, and the same random path for each run of the program (until you change the constant or remove the statement).

It makes it a lot easier if you encounter the same bugs in the same order. When you make changes, you will see the effects of thse changes and not just the effects of processing a different set of random data.

As I have already made all the changes I've mentioned above, I'm going to post the version I have to save you a little time. You'll find that all your comments have been removed. I use an automated process to reformat other peoples code into a "standard format" which I find easier to read, but it strips the comments. Sorry.

Still, if you do the right thing and compare this version line-by-line with your own, you will see lots of places where you are using unnecessary extra syntax (brackets etc.) that just complicate things. Anyway, I hope this helps you to get started on debugging this:

#!/usr/bin/perl use strict; use warnings; srand(1); ### ONLY FOR DEBUGGING!!! my(@node_values) = ( 'a1', 'a0', 'd0', 'd1', 'd2', 'd3', 'AND', 'OR', 'NOT' ); my(@prob) = (10, 95, 5); my($min_fitness) = 10; my %range; sub generate_tree { my($node, $level) = @_; unless ($node) { $node = {}; $$node{'left'} = undef; $$node{'right'} = undef; $$node{'op'} = 0; } if ($level > 0) { my($op) = $node_values[int rand $#node_values]; if ($op eq 'AND') { generate_tree( $$node{'left'}, $level - 1 ); generate_tree( $$node{'right'}, $level - 1 ); } if ($op eq 'OR') { generate_tree( $$node{'left'}, $level - 1 ); generate_tree( $$node{'right'}, $level - 1 ); } if ($op eq 'NOT') { generate_tree( $level - 1, $$node{'left'} ); $$node{'right'} = undef; } $$node{'op'} = $op; } if ($level == 0) { $node = {}; $$node{'left'} = undef; $$node{'right'} = undef; $$node{'op'} = $node_values[int rand 6]; } $_[0] = $node; return; } sub dec2bin { my $str = unpack('B32', pack('N', shift @_)); return substr($str, -6); } sub initialize { my($size) = shift @_; my(@people) = {}; print "Intial String:\n"; for (my $i = 0; $i < $size; ++$i) { $people[$i]{'fitness'} = 0; generate_tree $people[$i]{'tree'}, int(rand 6) + 1; print string_tree($people[$i]{'tree'}) . "\n"; } for (my $i = 0; $i < 64; ++$i) { my $value = dec2bin($i); my($a0, $a1, $d0, $d1, $d2, $d3) = split(//, $value, 7); $range{$value} = 0; if ($a0 eq '0' and $a1 eq '0' and $d0 eq '1') { $range{$value} = 1; } if ($a0 eq '1' and $a1 eq '0' and $d1 eq '1') { $range{$value} = 1; } if ($a0 eq '0' and $a1 eq '1' and $d2 eq '1') { $range{$value} = 1; } if ($a0 eq '1' and $a1 eq '1' and $d3 eq '1') { $range{$value} = 1; } } return @people; } sub eval_tree { my($tree) = shift @_; my($value) = shift @_; if ($$tree{'op'} eq 'AND') { return eval_tree($$tree{'left'}, $value) & eval_tree($$tree{'right'}, $value); } if ($$tree{'op'} eq 'OR') { return eval_tree($$tree{'left'}, $value) | eval_tree($$tree{'right'}, $value); } if ($$tree{'op'} eq 'NOT') { return !eval_tree($$tree{'left'}, $value); } if ($$tree{'op'} eq 'a0') { return substr($value, 0); } if ($$tree{'op'} eq 'a1') { return substr($value, 1); } if ($$tree{'op'} eq 'd0') { return substr($value, 2); } if ($$tree{'op'} eq 'd1') { return substr($value, 3); } if ($$tree{'op'} eq 'd2') { return substr($value, 4); } if ($$tree{'op'} eq 'd3') { return substr($value, 5); } } sub calc_fitness { my(@people) = @_; for (my $i = 0; $i < $#people; ++$i) { $people[$i]{'fitness'} = 0; foreach my $value (keys %range) { if (eval_tree($people[$i]{'tree'}, $value) == $range{$valu +e}) { ++$people[$i]{'fitness'}; } } } return @people; } sub string_tree { my($tree) = shift @_; my($value) = shift @_; if ($$tree{'op'} eq 'AND') { return '(' . string_tree($$tree{'left'}, $value) . ' AND ' . string_tree($$tree{'right'}, $value) . ')'; } if ($$tree{'op'} eq 'OR') { return '(' . string_tree($$tree{'left'}, $value) . ' OR ' . string_tree($$tree{'right'}, $value) . ')'; } if ($$tree{'op'} eq 'NOT') { return '(NOT ' . string_tree($$tree{'left'}, $value) . ')'; } if ($$tree{'op'} eq 'a0') { return 'a0'; } if ($$tree{'op'} eq 'a1') { return 'a1'; } if ($$tree{'op'} eq 'd0') { return 'd0'; } if ($$tree{'op'} eq 'd1') { return 'd1'; } if ($$tree{'op'} eq 'd2') { return 'd2'; } if ($$tree{'op'} eq 'd3') { return 'd3'; } } sub found_solution { my(@people) = @_; for (my $i = 0; $i < $#people; ++$i) { if ($people[$i]{'fitness'} == 64) { print "Solution Found:\n"; print string_tree($people[$i]{'tree'}); return 1; } } return 0; } sub get_random_node { my($tree) = shift @_; my($prob) = int rand 100; if ($prob < 40 and defined $$tree{'left'}) { return get_random_node($$tree{'left'}); } if ($prob > 60 and defined $$tree{'right'}) { return get_random_node($$tree{'right'}); } return $tree; } sub replace_node { my($tree, $a, $b) = @_; if ($tree == $a) { $tree = $b; } else { if (defined $$tree{'left'}) { replace_node( $$tree{'left'}, $a, $b ); } if (defined $$tree{'right'}) { replace_node( $$tree{'right'}, $a, $b ); } } $_[0] = $tree; return; } sub crossover { my($tree_a, $tree_b) = @_; my($node_a) = get_random_node($tree_a); my($node_b) = get_random_node($tree_b); replace_node $tree_a, $node_a, $node_b; replace_node $tree_b, $node_b, $node_a; return $tree_a, $tree_b; } sub mutation { my($tree) = shift @_; my($node_a) = get_random_node($tree); my($node_b) = {}; generate_tree $node_b, int(rand 3) + 1; replace_node $tree, $node_a, $node_b; return $tree; } for (my $size = 100; $size < 101; ++$size) { print "Size: $size\n"; my(@population) = initialize($size); my($generation) = 0; my $quit = 0; while ($quit == 0) { @population = calc_fitness(@population); if (found_solution @population) { print "\tFinal Generation: $generation\n"; $quit = 1; } else { my @children; my($children_size) = 0; while ($children_size < $size) { my($choice) = int rand(100) + 1; if ($choice >= 1 and $choice <= $prob[0]) { my($person_a) = int rand $size; while ($population[$person_a]{'fitness'} < $min_fi +tness) { $person_a = int rand $size; } push @children, $population[$person_a]; ++$children_size; } if ($choice > $prob[0] and $choice <= $prob[1]) { my($person_a) = int rand $size; my($person_b) = int rand $size; while ($population[$person_a]{'fitness'} < $min_fi +tness and $population[$person_b]{'fitness'} < $min_fi +tness and $person_a != $person_b ) { $person_a = int rand $size; $person_b = int rand $size; } my($child_a, $child_b) = {}; ($$child_a{'tree'}, $$child_b{'tree'}) = crossover +( $population[$person_a]{'tree'}, $population[$person_b]{'tree'} ); push @children, $child_a; push @children, $child_b; $children_size += 2; } if ($choice > $prob[1] and $choice <= 100) { my($person_a) = int rand $size; while ($population[$person_a]{'fitness'} < $min_fi +tness) { $person_a = int rand $size; } my($child_a) = {}; ($$child_a{'tree'}) = mutation($population[$person +_a]{'tree'}); push @children, $child_a; ++$children_size; } } ++$generation; @population = @children; } } } __END__ P:\test>398622 Size: 100 Intial String: d2 (d2 AND d1) ((d3 AND a0) OR (d3 AND d2)) a1 d0 a0 d1 a1 d1 d2 d2 d3 d0 d2 (d2 AND d0) d3 (d2 OR a0) a0 a0 (((d2 OR d1) OR d0) AND d0) a1 a1 a1 (a0 OR a0) d3 d3 a0 d1 (d3 OR a1) d1 d2 d0 a0 (d2 AND ((d0 AND a0) OR d3)) a1 d2 (a1 OR d3) d0 a1 d3 (d2 OR d1) a0 d1 d2 d1 d2 (d3 AND d1) d0 a1 d3 a1 (d2 OR d0) d0 d0 d0 d0 d2 ((d0 AND d1) AND (a1 OR d3)) a1 a0 d3 a0 a1 d3 (d0 OR d0) d3 d3 d3 a0 a1 (a0 AND a1) a1 d1 d3 a1 a0 d0 a0 d2 a0 (d3 OR (a0 OR d0)) (d1 OR (a1 OR d1)) d1 a1 d0 (d1 AND a0) d2 d1 d3 (d2 AND d3) d1 d3 (a0 OR a0) d3 d0 a1 d2 d3 a0 ((d2 OR d3) AND a1) Use of uninitialized value in numeric lt (<) at P:\test\398622.pl line + 243. Use of uninitialized value in numeric lt (<) at P:\test\398622.pl line + 248. Deep recursion on subroutine "main::replace_node" at P:\test\398622.pl + line 188. Deep recursion on subroutine "main::replace_node" at P:\test\398622.pl + line 191. Terminating on signal SIGINT(2)

Examine what is said, not who speaks.
"Efficiency is intelligent laziness." -David Dunham
"Think for yourself!" - Abigail
"Memory, processor, disk in that order on the hardware side. Algorithm, algorithm, algorithm on the code side." - tachyon

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://398777]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (4)
As of 2023-02-06 12:58 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    I prefer not to run the latest version of Perl because:







    Results (34 votes). Check out past polls.

    Notices?