Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
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 (Curate) 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?
[karlgoethebier]: ...good Hot tuna. Note the stacks & racks in the background
[karlgoethebier]: ..the last hippies. They still perform. At least the survivors...
[Discipulus]: not survived
[Discipulus]: has pm some danish monk?
[Discipulus]: erix the problem was not rain in the brain.. ;=)
[erix]: I'll think about that for a bit; I'll figure it out

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (8)
As of 2017-11-17 20:20 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    In order to be able to say "I know Perl", you must have:













    Results (272 votes). Check out past polls.

    Notices?