Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

bliako's scratchpad

by bliako (Vicar)
on Jun 11, 2016 at 14:36 UTC ( #1165398=scratchpad: print w/replies, xml ) 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[0] || 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] >= 0 and $_->[0] <= $maxI and $_->[1] >= 0 and $_->[1] <= $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 = $_[0]; 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}{$_->[0].'_'.$_->[1]} = $aoa[$_-> +[0]][$_->[1]] if $_->[0] >= 0 and $_->[0] <= $#{$aoa[$row]} and $_->[1] >= 0 and $_->[1] <= $#aoa } ([$row-1,$col],[$row+1,$col],[$row,$col-1],[$row,$col+1] +); } } return %graph; }
Log In?
Username:
Password:

What's my password?
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?
    Notices?