Skip over the lengthy intro if you like. Also, if you want to play with it, the subroutine at the bottom of the page will run through the entire sequence for a given number, until it converges or the subroutine determines it cycles.
One thing I would like to do is to automatically detect cycles and color those nodes and edges red. As a first step, does anyone know an efficient method for noticing when we start repeating values while sequentially pushing them into an array?
#! /usr/bin/perl ## ## This is one of a few scripts I created to explore the Kaprekar Rout +ine. ## Given a number of digits, it generates a .dot file which can be use +d by ## the graphviz family of graphing utilities to create a visual repres +entation ## of the relationships between sets of digits over many iterations of + the ## Kaprekar Routine. ## The program can perform this task in two ways: the first and defaul +t way is ## to treat "numbers" of the given number of digits as merely "constel +lations" ## or sets of digits. Because the very first step of the Routine re-or +ders the ## digits anyway, the difference between e.g. 4335 and 4353 becomes ir +relevant. ## Thus for the above, we only store the ordered value 5433, which mak +es our ## graphs lighter, and it makes more sense to treat the numbers as set +s of ## digits as well. ## The second method is to create relationships for every number from +000.. to ## 999.. ## ## Usage: ## $> perl kaprekar_tree.pl [number_of_digits] > kaprekar.do +t ## ## For generating a graph, try: ## $> twopi -T svg kaprekar.dot -o kaprekar.svg ## use strict; use warnings; use subs qw(kRoutine gotoNext sortHiLow sortLowHi generateDotFile); my $digits = $ARGV[0] || 4; if ($digits > 6) {die "Right now this code stores everything in a hash +, so ", "I'm not sure if we can play with big numbers."; +} my $only_unique = 1; # eliminate numbers that are just a reordering + of digits my ($lower,$upper) = ("0" x $digits,"9" x $digits); # e.g. (0000,9 +999) my @converged; # numbers which others converge to, "attractor +s" my %converged_dupes; # for removing duplicates in our loop my %number_pair; # number -> next_number_in_sequence for my $n ("$lower".."$upper"){ my $nn = gotoNext($n); ## we store only unique "constellations" of digits by sorting and +using the ## hash to remove duplicates. we also must sort the value it point +s to. if ($only_unique) {$n = sortHiLow($n); $nn = sortHiLow($nn);} if ($n eq $nn) {$converged_dupes{$n}=() } # this number is an "at +tractor" $number_pair{$n} = "$nn"; # store our graph rela +tionships } @converged = keys %converged_dupes; generateDotFile(); #-------------------------------------# ## orders a number's digits high -> low sub sortHiLow { my $n = shift; my @sort_nums = sort {$b cmp $a} split (//,$n); return (join('',@sort_nums)); } sub sortLowHi { my $n = shift; my @sort_nums = sort {$a cmp $b} split (//,$n); return (join('',@sort_nums)); } ## given a number, performs one iteration of the kaprekar routine and +returns num sub gotoNext { my $n = shift; my $new_num = sortHiLow($n) - sortLowHi($n); while (length $new_num < $digits) {$new_num = ("0" . "$new_num")} return $new_num; } ## Print to screen the dot file, line by line. Experiment with the par +ameters: sub generateDotFile { my $graph_name = "kaprekar_$digits"; #---------------------------------------------\ print "digraph $graph_name {\n"; print "\tnode [shape = doublecircle,fontcolor=red]; @converg +ed;\n"; print "\tnode [shape = plaintext,height=0,width=0,fontsize=8 +,fontcolor=grey];\n"; #print "\tgraph [overlap=false,splines=true];\n"; print "\tranksep=3;\n"; print "\tratio=auto;\n"; for my $n (keys %number_pair){ print "\t$n -> $number_pair{$n};\n"; } print "}\n"; #---------------------------------------------/ } ## runs kaprekar routine on a number until it either cycles or converg +es: sub kRoutine { if (scalar @_ > 10) {return (-1) } # result didn't converge, o +r cycled my $new_num = sortHiLow($_[-1]) - sortLowHi($_[-1]); while (length $new_num < $digits) {$new_num = "0" . "$new_num"} if ($new_num == $_[-1]) {return (@_) } #return whole list (for + cycles) else {kRoutine (@_,"$new_num") } #keep recursing }
UPDATE:
Here is a new approach to this problem, which doesn't have the memory issues of the other and represents the outermost sets of numbers with the size of the nodes on the graph (see comments).
The majority of the cpu work in the script is spent on splitting and joining arrays, so if someone has some more efficient ways of doing anything, I would love to hear about it!
UPDATE 2: added a few things to the graph output parameters that should give nicer output.
#! /usr/bin/perl # # This script creates a graph in which we ignore the stray numbers tha +t don't # have any other numbers pointing to them. Instead we represent these +in the # relative sizes of circles in the graph. # So the area of each circle corresponds to how many other numbers res +olve there # in one iteration of the kaprekar procedure. # # try using 'dot' on the file output by this script. # use strict; use warnings; use subs qw(kRoutine gotoNext getDiameter adjustedSizes generateDotFil +e); my $digits = $ARGV[0] || 4; my ($lower,$upper) = ("0" x $digits,"9" x $digits); # e.g. (0000,9 +999) my @converged; # numbers which are "attractors" my %nodes; # $number => ($points_to, $num_nodes_that_poin +t_here) for my $n ("$lower".."$upper"){ if ($nodes{$n}) {next} # stored this already, and no need to +increment my $nn = gotoNext($n); # $n point to $nn if ($nodes{$nn}) { # if we've found this value previously +, $nodes{$nn}[1]++; # then just increment the counter, or +else... } else { my $nnn = gotoNext ($nn); # If we've never pointed here befo +re... if ($nn eq $nnn) {push @converged, $nn} # (number is an attr +actor) $nodes{$nn} = [ $nnn, 1 ]; # make a new entry showing only on +e } # number pointing to $nn so far } ## Analyze our data bit: we want the smallest area circle to be heigh +t 1, ## adjust the others accordingly. my $lowest_a = $upper; # initialize to 9999... for (keys %nodes){ my $n = $nodes{$_}[1]; if ($n < $lowest_a) {$lowest_a = $n} } generateDotFile(); #-------------------------------------# sub gotoNext { my $n = shift; my @sort_nums = sort {$b cmp $a} split (//,$n); my $new_num = (join('',@sort_nums)) - (join('', reverse @sort_nums)); while (length $new_num < $digits) {$new_num = ("0" . "$new_num")} #pad with leading +zeros #return ( sprintf("%0${digits}d", $new_num) ); #pad with leading +zeros return $new_num; } ## Print to screen the dot file, line by line. Experiment sub generate +DotFile { my $graph_name = "kaprekar_$digits"; print "digraph $graph_name {\n"; print "\tnode [shape = doublecircle,color=red3,fontcolor +=red,fixedsize=true,margin=0]; @converged;\n"; print "\tnode [shape = circle,style=filled,fillcolor=gra +y94,fontcolor=grey,margin=0,fixedsize=true];\n"; print "\tgraph [overlap=false,splines=true,outputorder=n +odesfirst];\n"; #print "\tranksep=2;\n"; #expe +riment w/ value #print "\tratio=auto;\n"; for my $n (keys %nodes){ my @sizes = adjustedSizes( $nodes{$n}[1] ); print "\t$n [height=$sizes[0],fontsize=$sizes[1]];\n"; print "\t$n -> $nodes{$n}[0] [penwidth=$sizes[0],arrowsi +ze=$sizes[0]];\n"; } print "}\n"; } sub getDiameter { my $area = shift; my $diameter = 2*sqrt($area / 3.14); } ## Scale our circles and keep the same fontsize to circleheight ratio: sub adjustedSizes { my $height = getDiameter(shift); $height = sprintf("%.1f", ($height / $lowest_a)); # smallest circle should have + height ~1 my $fontsize = sprintf("%.1f", ($height * 12)); # for circle size 1, font shou +ld be 12 return ($height,$fontsize); }
In reply to Exploring the Kaprekar Routine with perl and Graphviz by jberryman
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |
