 Perl-Sensitive Sunglasses PerlMonks

by bliako (Vicar)
 on Jun 11, 2016 at 14:36 UTC Need Help??

#!/usr/bin/perl use strict; use warnings; use Paths::Graph; use Data::Dump qw/dd/; use Benchmark qw/cmpthese/; srand 123; my \$max = \$ARGV || 4; my @aoa = map{ [ map{ int(rand(4))+1 }0..\$max ] } 0..\$max; my %graph; if( 1 ){ # compare recursive and loopy graph building my %graph2; cmpthese(-2, { 'recursive' => sub { %graph = (); # empty the graph where results g +o for each iteration # else no work is done if %graph +is already completed. # builds the graph by recursing to all neighbours of curre +nt location # starting from 0,0 build_graph_recursively(0, 0, \@aoa, \%graph, 0); }, 'loopy' => sub { %graph2 = build_graph(); # uses a nested loop over all gri +d elements }, }); #\$graph{"aa"} = {"abc" => 12}; # test to yield not-same-graphs err +or if( compare_graphs(\%graph, \%graph2) ){ die "graphs not the same" + } else { print "graph methods same results\n" } } else { build_graph_recursively(0, 0, \@aoa, \%graph, 0); } #graph_stringify(\%graph); exit 0; print "finding shortest path...\n"; my \$dest = \${max}.'_'.\${max}; if( ! exists \$graph{\$dest} ){ die "destination does not exist '\$dest'" + } my \$obj = Paths::Graph->new(-origin=>"0_0",-destiny=>"\${max}_\${max}",- +graph=>\%graph); my @paths = \$obj->shortest_path(); for my \$path (@paths) { print "Shortest Path:" . join ("->" , @\$path) . " Cost:". \$obj->get_path_cost(@\$path) . "\n"; } sub build_graph_recursively { # a recursive graph builder # builds the graph by recursing to all neighbours of current locat +ion # starting from 0,0 # WARNING: may yield the dreaded "Deep recursion on subroutine" me +ssage for when recursion depth reaches 100 # but no problem usually! my ( \$i, \$j, # current location \$grid, # the grid as an AoA (arrayref) accessed like grid[i][ +j] may not be square \$graph, # the resultant graph as a HoH (hashref) we keep modif +ying \$depth # recursion depth ) = @_; my \$maxI = \$#{\$grid}; my \$maxJ = \$#{\$grid->[\$i]}; # at the current i # check if within bounds #print "build_graph_recursively() : entering for (\$i,\$j) bound(0,0 +,\$maxI,\$maxJ) at depth \$depth...\n"; return(0) if \$i < 0 || \$j < 0 || \$i > \$maxI || \$j > \$maxJ ; my \$id = \$i.'_'.\$j; \$graph->{\$id} = {} unless exists \$graph->{\$id}; my \$neigh = find_neighbours(\$i, \$j, \$grid); return(0) unless defined \$neigh; my \$suc = 0; foreach my \$aneigh (@\$neigh){ my (\$ni, \$nj) = @\$aneigh; my \$nid = \$ni.'_'.\$nj; if( ! exists \$graph->{\$id}->{\$nid} ){ \$graph->{\$id}->{\$nid} = \$grid->[\$ni]->[\$nj]; #print "build_graph_recursively() : (\$i,\$j) -> (\$ni,\$nj) = + ".\$graph->{\$id}->{\$nid}."\n"; #print "build_graph_recursively() : recursing into (\$i,\$j) + -> (\$ni,\$nj), depth \$depth ...\n"; \$suc += build_graph_recursively(\$ni, \$nj, \$grid, \$graph, \$ +depth+1); #print "build_graph_recursively() : back from recursing in +to (\$i,\$j) -> (\$ni,\$nj), depth \$depth ...\n"; } } return \$suc == 0 ? 0 : 1; } # given a current location on the grid find its immediate neighbours f +ollowing Discipulus rules: cross, no diagonals. sub find_neighbours { my ( \$i, \$j, # current location \$grid # the grid as an AoA (arrayref) accessed like grid[i][ +j] may not be square ) = @_; my \$maxI = \$#{\$grid}; my \$maxJ = \$#{\$grid->[\$i]}; # at the current i my @ret = grep { \$_ if \$_-> >= 0 and \$_-> <= \$maxI and \$_-> >= 0 and \$_-> <= \$maxJ } ([\$i-1,\$j],[\$i+1,\$j],[\$i,\$j-1],[\$i,\$j+1]); return scalar(@ret) > 0 ? \@ret : undef; } # compare two graphs to find out if same both ways. sub compare_graphs { my (\$g1, \$g2) = @_; foreach my \$k1 (keys %\$g1){ if( ! exists \$g2->{\$k1} ){ print "not same because of \$k1\n"; +return 1 } foreach my \$k2 (keys %{\$g1->{\$k1}}){ if( ! exists \$g2->{\$k1}->{\$k2} ){ print "not same because +of \$k1".'->'."\$k2 not exists\n"; return 1 } if( \$g2->{\$k1}->{\$k2} != \$g1->{\$k1}->{\$k2} ){ print "not s +ame because value of \$k1->\$k2 ".\$g1->{\$k1}->{\$k2}." and ".\$g2->{\$k1}- +>{\$k2}."\n"; return 1} } } foreach my \$k2 (keys %\$g2){ if( ! exists \$g1->{\$k2} ){ print "not same because of \$k2\n"; +return 1 } foreach my \$k1 (keys %{\$g2->{\$k2}}){ if( ! exists \$g1->{\$k2}->{\$k1} ){ print "not same because +of \$k2".'->'."\$k1 not exists\n"; return 1 } if( \$g1->{\$k2}->{\$k1} != \$g2->{\$k2}->{\$k1} ){ print "not s +ame because value of \$k2->\$k1 ".\$g2->{\$k2}->{\$k1}." and ".\$g1->{\$k2}- +>{\$k1}."\n"; return 1} } } return 0; } # return a string with sorted-keys graph sub graph_stringify { my \$g = \$_; my \$ret = ""; foreach my \$k1 (sort keys %\$g){ my \$G = \$g->{\$k1}; \$ret .= "\$k1\n{"; foreach my \$k2 (sort keys %\$G){ \$ret .= \$k2 .' => '.\$G->{\$k2} . ','; } \$ret .= "}\n"; } return \$ret; } sub build_graph{ # Discipulus original graph builder my %graph; foreach my \$row (0..\$#aoa){ foreach my \$col( 0..\$#{\$aoa[\$row]} ){ #print \$row."_".\$col." is current..\n"; map{ \$graph{\$row."_".\$col}{\$_->.'_'.\$_->} = \$aoa[\$_-> +][\$_->] if \$_-> >= 0 and \$_-> <= \$#{\$aoa[\$row]} and \$_-> >= 0 and \$_-> <= \$#aoa } ([\$row-1,\$col],[\$row+1,\$col],[\$row,\$col-1],[\$row,\$col+1] +); } } return %graph; }

Create A New User
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: (3)
As of 2019-10-19 11:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
In 2019 the site I miss most is:

Results (46 votes). Check out past polls.

Notices?