After a long time, I checked the list of tasks not implemented in Perl on RosettaCode. One of them was " Sum to 100", kind of similar to mjd's Simple but difficult arithmetic puzzle:
In the string 123456789, you can prepend + or - before any digit to form an expression. You should
- list all the possible expressions that evaluate to 100
- show the number that is a result of the maximal number of expressions
- show the lowest positive number that can't be expressed
- show the ten highest numbers that can be expressed
Here's my solution: #!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my $string = '123456789';
my $length = length $string;
my @possible_ops = ("" , '+', '-');
{
my @ops;
sub Next {
return @ops = (0) x ($length) unless @ops;
my $i = 0;
while ($i < $length) {
if ($ops[$i]++ > $#possible_ops - 1) {
$ops[$i++] = 0;
next
}
# + before the first number
next if 0 == $i && '+' eq $possible_ops[ $ops[0] ];
return @ops
}
return
}
}
sub evaluate {
my ($expression) = @_;
my $sum;
$sum += $_ for $expression =~ /([-+]?[0-9]+)/g;
return $sum
}
my %count = ( my $max_count = 0 => 0 );
say 'Show all solutions that sum to 100';
while (my @ops = Next()) {
my $expression = "";
for my $i (0 .. $length - 1) {
$expression .= $possible_ops[ $ops[$i] ];
$expression .= substr $string, $i, 1;
}
my $sum = evaluate($expression);
++$count{$sum};
$max_count = $sum if $count{$sum} > $count{$max_count};
say $expression if 100 == $sum;
}
say 'Show the sum that has the maximum number of solutions';
say "sum: $max_count; solutions: $count{$max_count}";
my $n = 1;
++$n until ! exists $count{$n};
say "Show the lowest positive sum that can't be expressed";
say $n;
say 'Show the ten highest numbers that can be expressed';
say for (sort { $b <=> $a } keys %count)[0 .. 9];
I tried to avoid eval to evaluate the expressions, at the same time, I didn't want to implement the traditional full math expression parser as there were only two operations of the same precedence in use.
$sum += $_ for $expression =~ /([-+]?[0-9]+)/g;
Feel free to comment on perlishness, effectiveness, golfness, or beauty of the solution, or propose your own.
Note: Those interested in Perl 6 can read the solution just below mine.
($q=q:Sq=~/;[c](.)(.)/;chr(-||-|5+lengthSq)`"S|oS2"`map{chr |+ord
}map{substrSq`S_+|`|}3E|-|`7**2-3:)=~y+S|`+$1,++print+eval$q,q,a,
Re: Sum to 100 at Rosetta Code -- oneliner
by Discipulus (Canon) on Feb 18, 2018 at 14:30 UTC
|
perl -E "say for grep{eval $_ == 100} glob join '{+,-,}',1..9"
PS sorry missed: -1+2-3+4+5+6+78+9
perl -E "say for grep{eval $_ == 100} glob '{-,}'.join '{+,-,}',1..9"
L*
UPDATE Feb 21 2018, just for my own pleasure:
1. Show all solutions that sum to 100
2. Show the sum that has the maximum number of solutions (from zero to infinity*)
3. Show the lowest positive sum that can't be expressed (has no solutions), using the rules for this task
4. Show the ten highest numbers that can be expressed using the rules for this task (extra credit)
perl -MList::Util="first" -E "@c[0..10**6]=(0..10**6);say for grep{$e=
+eval;$c[$e]=undef if $e>=0;$h{$e}++;eval $_==100}glob'{-,}'.join'{+,-
+,}',1..9;END{say for(sort{$h{$b}<=>$h{$a}}grep{$_>=0}keys %h)[0],firs
+t{defined $_}@c;say for(sort{$b<=>$a}grep{$_>0}keys %h)[0..9]}"
-1+2-3+4+5+6+78+9
1+2+3-4+5+6+78+9
1+2+34-5+67-8+9
1+23-4+5+6+78-9
1+23-4+56+7+8+9
12+3+4+5-6-7+89
12+3-4+5+67+8+9
12-3-4+5-6+7+89
123+4-5+67-89
123+45-67+8-9
123-4-5-6-7+8-9
123-45-67+89
9
211
123456789
23456790
23456788
12345687
12345669
3456801
3456792
3456790
3456788
3456786
There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.
| [reply] [d/l] [select] |
Re: Sum to 100 at Rosetta Code
by trippledubs (Deacon) on Feb 25, 2018 at 00:49 UTC
|
For summing to 100, I got all but one with this
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
my @queue = '123456789';
while (@queue) {
$_ = shift @queue;
say if eval == 100;
while ( /\d+?/g) {
next if (!$' || $' =~ /\+|\-/);
push @queue,("$`$&+$'","$`$&-$'");
}
}
123-45-67+89
123+4-5+67-89
123+45-67+8-9
1+2+34-5+67-8+9
1+23-4+5+6+78-9
1+23-4+56+7+8+9
12+3+4+5-6-7+89
12+3-4+5+67+8+9
12-3-4+5-6+7+89
123-4-5-6-7+8-9
1+2+3-4+5+6+78+9
Eventually resorted to this to get the last one
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
my @queue = '123456789';
my %seen;
while (@queue) {
local $_ = shift @queue;
next if (exists $seen{$_});
$seen{$_}++;
say if eval == 100;
while (/\d+?/g) {
my ($pre,$match,$post) = ($`,$&,$');
push @queue, "$pre$match+$post" unless (!$post || $post =~ /[+
+-]/);
push @queue, "$pre-$match$post" unless ($pre =~ /[-+]$/ );
}
}
I think a better regex solution exists, this re-evaluates too many times. I used structure from tybalt89's Re: Parks Puzzle.
With '1234567891234' 1222 solutions
With '12345678912345' 3080 solutions
| [reply] [d/l] [select] |
Re: Sum to 100 at Rosetta Code
by karlgoethebier (Abbot) on Feb 18, 2018 at 11:57 UTC
|
karls-mac-mini:playground karl$ perl -c ./choroba.pl
Global symbol "$max_count" requires explicit package name (did you for
+get to declare "my $max_count"?) at ./choroba.pl line 14.
Global symbol "$sum" requires explicit package name (did you forget to
+ declare "my $sum"?) at ./choroba.pl line 14.
Global symbol "%count" requires explicit package name (did you forget
+to declare "my %count"?) at ./choroba.pl line 14.
Global symbol "$sum" requires explicit package name (did you forget to
+ declare "my $sum"?) at ./choroba.pl line 14.
Global symbol "%count" requires explicit package name (did you forget
+to declare "my %count"?) at ./choroba.pl line 14.
Global symbol "$max_count" requires explicit package name (did you for
+get to declare "my $max_count"?) at ./choroba.pl line 14.
Global symbol "$expression" requires explicit package name (did you fo
+rget to declare "my $expression"?) at ./choroba.pl line 16.
Global symbol "$sum" requires explicit package name (did you forget to
+ declare "my $sum"?) at ./choroba.pl line 16.
Unmatched right curly bracket at ./choroba.pl line 17, at end of line
syntax error at ./choroba.pl line 17, near "}"
./choroba.pl has too many errors.
Update: It compiles. I copied the code from the download link into an emacs buffer as i did it many thousand times before. For some unknown reason the result was broken. I never observed this before. I'm very sorry. And to be honest: I couldn't hardly imagine that choroba should have posted something that doesn't compile.
Best regards, Karl
«The Crux of the Biscuit is the Apostrophe»
perl -MCrypt::CBC -E 'say Crypt::CBC->new(-key=>'kgb',-cipher=>"Blowfish")->decrypt_hex($ENV{KARL});'Help
| [reply] [d/l] [select] |
|
22:52 >perl 1870_Med.pl
Show all solutions that sum to 100
123-45-67+89
12-3-4+5-6+7+89
12+3+4+5-6-7+89
123+4-5+67-89
-1+2-3+4+5+6+78+9
1+2+3-4+5+6+78+9
12+3-4+5+67+8+9
1+23-4+56+7+8+9
1+2+34-5+67-8+9
1+23-4+5+6+78-9
123+45-67+8-9
123-4-5-6-7+8-9
Show the sum that has the maximum number of solutions
sum: 9; solutions: 46
Show the lowest positive sum that can't be expressed
211
Show the ten highest numbers that can be expressed
123456789
23456790
23456788
12345687
12345669
3456801
3456792
3456790
3456788
3456786
22:52 >perl -v
This is perl 5, version 26, subversion 0 (v5.26.0) built for MSWin32-x
+64-multi-thread-ld
Have you double-checked the contents of your choroba.pl file?
Update: FWIW, I get the same result under Cygwin:
$ perl -v
This is perl 5, version 22, subversion 4 (v5.22.4) built for cygwin-th
+read-multi
| [reply] [d/l] [select] |
|
Does your Perl version support "say" ?
update
This looks like a runaway error in the first 4 lines.
| [reply] |
Re: Sum to 100 at Rosetta Code
by trippledubs (Deacon) on Feb 06, 2019 at 16:53 UTC
|
Contrived from original problem, concurrent version. You have to increase the size of the kernel queue for it to work. Command is in script comment. If you don't, should exit cleanly, but get some error spam.
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use IPC::SysV qw/IPC_PRIVATE S_IRUSR S_IWUSR IPC_NOWAIT/;
use IPC::Msg;
# echo $((2**31-1)) > /proc/sys/kernel/msgmnb
my $q = IPC::Msg->new(IPC_PRIVATE,S_IRUSR|S_IWUSR);
sub quit { $q->remove; }
$SIG{INT} = \&quit;
my $string = '12345678912345';
$q->snd(1,$string) or die "$!";
$q->snd(1,"-$string") or die "$!";
my $parent = $$;
my $n_workers = shift // die;
die "128 workers max" if ($n_workers > 7);
fork // die $! for (1..$n_workers);
while ( $q->rcv(local $_,32,0,IPC_NOWAIT) ) {
say if eval == 100;
while (/\d+?/g) {
next if ( !$' || index( $', '-' ) > -1 || index( $', '+' ) > -
+1 );
$q->snd(1,"$`$&+$'",IPC_NOWAIT) or die $!;
$q->snd(1,"$`$&-$'",IPC_NOWAIT) or die $!;
}
}
END {
1 until wait == -1;
if ($$ == $parent) {
quit;
}
}
- 2x - 2m11s
- 4x - 55s
- 8x - 23s
- 16x - 12s
- 32x - 7s
| [reply] [d/l] |
|
|