Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Number Grid Fillin

by QM (Parson)
on Aug 14, 2017 at 08:41 UTC ( #1197354=CUFP: print w/replies, xml ) Need Help??

Saw this idea recently. Wondered how susceptible it would be to a brute force approach.

Given a square grid size N, and a list of numbers 2*N**2 2*N, find a fillin (like a crossword), and report the digits in the major diagonal (as an easy proof of solution).

The reference in the spoiler took an hour or two to find the solution. I won't post the solution here, you'll have to do the work yourself.

#!/usr/bin/env perl # eliottline.com, puzzle 112 # http://www.elliottline.com/puzzles-1/2017/8/11/puzzle-of-the-week-11 +2-number-fill-in # Given 12 6-digit numbers, fill in the 6x6 grid. # Report the 6 digit number from the major diagonal. use strict; use warnings; use File::Basename; # Autoflush stdout BEGIN { $| = 1 } ####################### # options and defaults our $GRID_DEFAULT = 6; our $GRID_OPT = '-g'; our $GRID = $GRID_DEFAULT; our $HELP = '^\D$'; # Not a known option, and not a number ############################ sub usage { my($filename, $dirs, $suffix) = fileparse($0); my $script_name = $filename . $suffix; print STDERR "Solve Elliot's Puzzle of the Week #112\n\n"; print STDERR "Usage:\n"; print STDERR "\t$script_name [$GRID_OPT grid_size] [list_of_number +s]\n\n"; print STDERR "Default grid size is $GRID_DEFAULT\n\n"; print STDERR "Grid is square, there must be 2x numbers for a grid +of size x.\n\n"; exit; } our @NUMS_DEFAULT = qw(113443 143132 241131 321422 323132 331222 341114 412433 414422 431331 443112 444313); our @nums; ###################### # Process the command line while (@ARGV) { if ($ARGV[0] eq $GRID_OPT and defined($ARGV[1])) { $GRID = $ARGV[1]; shift;shift; next; } if ($ARGV[0] =~ m/$HELP/) { usage(); } push @nums, shift; } if (not @nums) { @nums = @NUMS_DEFAULT; } ########################### # We might do this a lot, so cache the results # Closure, so put this before the function is called. { my @factorial; $factorial[0] = 1; sub factorial { my $n = shift; # If we already know it, return it return $factorial[$n] if defined $factorial[$n]; # Else compute it from the largest known result my $result = $factorial[$#factorial]; for my $k ( $#factorial+1..$n ) { $result *= $k; } return $result; } } ######################### if (scalar(@nums) != (2 * $GRID)) { die sprintf "Wrong number count, expected %d, have %d\n", 2 * $GRID, scalar(@nums); } # Create a hash of arrays, to store the digits of each number our %nums; for my $num (@nums) { push @{$nums{$num}}, split '', $num; } printf STDERR "%d total permutations\n", factorial(scalar @nums); # Now the work loop for my $n (0..factorial(scalar @nums)-1) { if ($n % 100000 == 0) { print STDERR "$n "; } my @perm = permutation_n($n,@nums); if (tryit(@perm)) { print "\n*** permutation: $n ***\n"; print "grid:\n"; for my $p (@perm[0..(@perm/2-1)]) { print "\t$p\n"; } print "Diagonal: "; for my $i (0..int(@perm/2)) { print substr($perm[$i], $i, 1); } print "\n"; exit; } } continue { $n++; } exit; ########################################### # Try the given permutation sub tryit { my @perm = @_; # Fill a grid with the first half of the numbers (horizontally) my @grid1; for my $x (0..$GRID-1) { for my $y (0..$GRID-1) { $grid1[$y][$x] = $nums{$perm[$x]}[$y]; } } # Fill a grid with the remaining numbers (vertically) my @grid2; for my $p (@perm[$GRID..$#perm]) { $grid2[@grid2] = $nums{$p}; } return grid_compare(\@grid1, \@grid2); } ########################################### # Compare 2 arrays sub grid_compare { my $g1 = shift; my $g2 = shift; my @g1 = @$g1; my @g2 = @$g2; for my $x (0..$#g1) { for my $y (0..$#{$g1[$x]}) { return 0 if $g1[$x][$y] != $g2[$x][$y]; } } return 1; } ########################################### # Find and return the $n'th permutation # of the remaining arguments in some canonical order # (modified from QOTW solution) sub permutation_n { my $n = shift; my @result; while (@_) { ($n, my $r) = (int($n/@_), $n % @_); push @result, splice @_, $r, 1; } return @result; }

-QM
--
Quantum Mechanics: The dreams stuff is made of

Replies are listed 'Best First'.
Re: Number Grid Fillin
by tybalt89 (Priest) on Aug 14, 2017 at 12:05 UTC

    Fun problem!

    I call this "Smart Brute Force".
    It fills in one column at a time with each remaining number in turn, then checks to see if the leading parts of each row are possible from left over numbers.

    #!/usr/bin/perl -l # http://perlmonks.org/?node_id=1197354 use strict; use warnings; @ARGV or @ARGV = qw( 113443 143132 241131 321422 323132 331222 341114 412433 414422 431331 443112 444313 ); my $half = @ARGV / 2; my $steps = 0; my @stack = [ "\n" x $half, join '', map "$_\n", @ARGV ]; NEXT: while( @stack ) { my ($have, $rest) = @{ pop @stack }; $steps++; my %lefts; # validate legal so far $lefts{$_}++ for $have =~ /^(.+)\n/gm; for my $head (keys %lefts) { $lefts{$head} <= ( () = $rest =~ /^$head/gm ) or goto NEXT; } if( $rest =~ tr/\n// == $half ) # half left means completed { print "answer in $steps steps\n\n$have"; print "diagonal ", $have =~ /(\d)(?:..{$half})?/gs; exit; } while( $rest =~ /^(.+)\n/gm ) # try each number remaining { my ($before, $after, @digits) = ($`, $', split //, $1); push @stack, [ $have =~ s/(?=\n)/ shift @digits /ger, $before . $after ]; } } print "failed to find solution in $steps steps\n";

    Output:

    answer in 35 steps 412433 414422 431331 341114 143132 331222 diagonal 411132

    Computes the answer in less than 0.1 seconds.

Re: Number Grid Fillin
by hdb (Monsignor) on Aug 15, 2017 at 12:40 UTC

    Thanks for posting this inspiring problem. Similar to what tybalt89 has posted, one can significantly reduce the search space by checking whether for a given number in a given position the remaining numbers would still fit. Below some code to do that based on positions counting from 0 to 5 and each can be vertical or horizontal. Given the output it is nearly trivial to solve the puzzle manually.

    use strict; use warnings; my @numbers = qw( 113443 143132 241131 321422 323132 331222 341114 412433 414422 431331 443112 444313 ); # find possible positions my %positions; for my $n (@numbers) { $positions{$n} = []; # frequency of digits in current number my @nfreq = (0) x 5; $nfreq[$_]++ for split //, $n; # check which position is possible for my $p (0..5) { # frequency of digits in current position w/o current number my @freq = (0) x 5; $freq[substr( $_, $p, 1 )]++ for @numbers; $freq[substr( $n, $p, 1 )]--; # check if position is feasible # ie enough of each digit available my $possible = 1; $freq[$_]<$nfreq[$_] and $possible = 0 for 1..4; push @{$positions{$n}}, $p if $possible; } } for my $n (sort { scalar(@{$positions{$a}}) <=> scalar(@{$positions{$b +}}) } @numbers) { print "Number $n can be at positions @{$positions{$n}}.\n"; }
Re: Number Grid Fillin
by LanX (Bishop) on Aug 14, 2017 at 15:56 UTC

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://1197354]
Approved by davies
help
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (2)
As of 2018-07-22 05:24 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    It has been suggested to rename Perl 6 in order to boost its marketing potential. Which name would you prefer?















    Results (451 votes). Check out past polls.

    Notices?