In Perl, how can I test for all possible combinations in a number.
For example, the combination I am interested in is separating.
E.g: 53 could be "5 3" or just "53"
E.g: 215 could be "21 5" or "2 15"
In fact, you are distributing spaces to all the positions between characters. On each position, the space either is realized or not for each combination. Therefore, you can represent it as a binary number, 1 means space present, 0 means space not present.
#!/usr/bin/perl
use warnings;
use strict;
my $num = shift;
my #digits = split //, $num;
my $length = length($num) - 1;
if ($length == 0) {
print "$num\n";
exit;
}
for my $i (0 .. 2 ** $length - 1) {
my $mask = sprintf "%0${length}b", $i;
my #replace_arr = split //, $mask;
my $idx = 0;
for (#replace_arr, '') {
print $digits[$idx];
print ' ' if $_;
$idx++;
}
print "\n";
}
Related
Input Data (example):
40A3B35A3C
30A5B28A2C2B
Desired output (per-line) is a single number determined by the composition of the code 40A3B35A3C and the following rules:
if A - add the proceeding number to the running total
if B - add the proceeding number to the running total
if C - subtract the proceeding number from the running total
40A 3B 35A 3C would thus produce 40 + 3 + 35 - 3 = 75.
Output from both lines:
75
63
Is there an efficient way to achieve this for a particular column (such as $F[2]) in a tab-delimited .txt file using a one-liner? I have considered splitting the entire code into individual characters, then performing if statement checks to detect A/B/C, but my Perl knowledge is limited and I am unsure how to go about this.
When you use split with a capture, the captured group is returned from split, too.
perl -lane '
#ar = split /([ABC])/, $F[2];
$s = 0;
$s += $n * ("C" eq $op ? -1 : 1) while ($n, $op) = splice #ar, 0, 2;
print $s
' < input
Or maybe more declarative:
BEGIN { %one = ( A => 1,
B => 1,
C => -1 ) }
#ar = split /([ABC])/, $F[2];
$s = 0;
$s += $n * $one{$op} while ($n, $op) = splice #ar, 0, 2;
print $s
When working through a string like this, it's useful to know that regular expressions can return a list of results.
E.g.
my #matches = $str =~ m/(\d+[A-C])/g; #will catch repeated instances
So you can do something like this:
#!/usr/bin/env perl
use strict;
use warnings;
while (<DATA>) {
my $total;
#break the string into digit+letter groups.
for (m/(\d+[A-C])/g) {
#separate out this group into num and code.
my ( $num, $code ) = m/(\d+)([A-C])/;
print "\t",$num, " => ", $code, "\n";
if ( $code eq "C" ) {
$total -= $num;
}
else {
$total += $num;
}
}
print $total, " => ", $_;
}
__DATA__
40A3B35A3C
30A5B28A2C2B
perl -lne 'push #a,/([\d]+)[AB]/g;
push #b,/([\d]+)[C]/g;
$sum+=$_ for(#a);$sum-=$_ for(#b);
print $sum;#a=#b=();undef $sum' Your_file
how it works
use the command line arg as the input
set the hash "%op" to the
operations per letter
substitute the letters for operators in the
input evaluate the substituted input as an expression
use strict;
use warnings;
my %op=qw(A + B + C -);
$ARGV[0] =~ s/(\d+)(A|B|C)/$op{$2} $1/g;
print eval($ARGV[0]);
I have a scenario where I take 2 very big binary strings (having 100 characters) and I need to add them.
The issue is that I am getting the answer in the form 2.000xxxxxxxxxxe+2, whereas I need the precise answer, as another 100 character long string.
chomp($str1=<STDIN>);
chomp($str2=<STDIN>);
print "Str 1 is $str1\n";
print "Str 2 is $str2\n";
$t = $str1 + $str2;
print "Sum is $t\n";
Sample Input
1001101111101011011100101100100110111011111011000100111100111110111101011011011100111001100011111010
1001101111101011011100101100100110111011111011000100111100111110111101011011011100111001100011111010
Sample Output
Str1 is
1001101111101011011100101100100110111011111011000100111100111110111101011011011100111001100011111010
Str2 is
1001101111101011011100101100100110111011111011000100111100111110111101011011011100111001100011111010
Sum is
2.0022022220202e+099
As already suggested, you can use Math::BigInt core module,
use Math::BigInt;
# chomp($str1=<STDIN>);
# chomp($str2=<STDIN>);
# print "Str 1 is $str1\n";
# print "Str 2 is $str2\n";
my $t = Math::BigInt->new("0b$str1") + Math::BigInt->new("0b$str2");
print $t->as_bin;
In order to perform arithmetic on your strings, Perl converts them to floating-point numbers, which are inherently imprecise. If you want to avoid that, use Math::BigInt as already suggested ... or roll your own.
######## WARNING/GUARANTEE: This is practically certain to be
# slower, buggier, less portable, and less secure than Math::BigInt.
# In fact, I planted a security hole just to prove a point. Enjoy.
use strict;
use warnings;
sub addition {
my ($int1, $int2) = #_;
my #int1 = reverse split //, $int1;
my #int2 = reverse split //, $int2;
my $len = scalar(#int1>#int2 ? #int1 : #int2);
my #result;
my $carry = 0;
for (my $i=0; $i < $len; ++$i)
{
$int1[$i] |= 0;
$int2[$i] |= 0;
my $sum = $carry + $int1[$i] + $int2[$i];
if ($sum >= 10)
{
$carry = int($sum / 10);
$sum %= 10;
}
push #result, $sum;
}
push #result, $carry if $carry;
return join ('', reverse #result);
}
I am trying to write a simple perl script to learn Perl. This is the first script I have written using user input. The script needs to get a last numbers after make addition function Any help would be appreciated. Below is what I have so far.
Example user input 9423 and then the scripts were make addition function like below
09+04=13
04+02=06
02+03=05
03+09=12
print "Enter 4 Digits Number";#9423
chomp($number = <STDIN>);
EDIT
How to pick a last 2 digits numbers so the results are 3652
#!/usr/bin/perl
my #nums = ("9423" =~ /(\d{1})/g);
my $a = $nums[0];
my $b = $nums[1];
my $c = $nums[2];
my $d = $nums[3];
my $ab= $a+$b;
my $bc= $b+$c;
my $cd= $c+$d;
my $da= $d+$a;
printf "%02d\n%02d\n%02d\n%02d\n", $ab, $bc, $cd, $da;
I think, here code will output your expected result
#!/usr/bin/perl
use warnings;
use strict;
print "Enter 4 Digits Number:";#9423
chomp(my $number = <STDIN>);
my #digits = split("", $number);
my #lasts;
# add first digit to the last position
#digits = 94239
$digits[$#digits + 1] = $digits[0];
for(my $i = 0; $i < $#digits; $i++){
$lasts[$i] = ($digits[$i] + $digits[$i + 1]) % 10;
}
print join "",#lasts,"\n";
output after enter number 9423:
3652
probably easiest way to do it is use a for loop and substring
EDIT (now tested):
for my $i (0 .. length($number)-2) {
print substr($number, $i, 1) + substr($number, $i+1, 1);
}
Perhaps the following will be helpful:
use strict;
use warnings;
print "Enter a 4 Digit Number: ";
chomp( my $num = <STDIN> );
my #nums = split //, $num;
$nums[ $#nums + 1 ] = $nums[0];
( $nums[$_] + $nums[ $_ + 1 ] ) =~ /(.)$/ and print $1 for 0 .. $#nums - 1;
Output after entering 9423:
3652
I have a string of numbers, like "4 2 6 7", and a variable i which is an integer. How can I decide if i is included in the string? The code is in perl...
Use this function:
my $string = "4 2 6 7";
my $i = 4;
if ( $string =~ /\b$i\b/ ) {
print "$string contains $i\n";
}
You can use split to create an array from the string "4 2 6 7", and then use grep to search the array.
$ perl -wle 'if ( grep {$_ eq $i} split(" ", "4 2 6 7") ) {print "matched\n";}'
EDIT:
Or you can use '==' instead of 'eq' as the comparison operator to match numbers instead of strings.
For the fun of it, the ~~ smart match operator:
use 5.012;
my $string = "4 2 6 7";
my #test = split /\s+/, $string;
for( 0 .. 9 ) {
say "$_ is contained in $string" if $_ ~~ #test;
}
A good discussion on the power of the smart match operator is found in perlsyn. It can be a little tricky, since it's not an associative operator, and the rules are deeply rooted in DWIMery rather than consistency. But it's very powerful.
Use this regular expression to match the variable i with a word boundary (assuming your string of numbers have a space after each integer):
/\b$i\b/
Here's a version that does not care about the delimeters or formatting of your string. It just extracts sequences of digits and compares them to the search pattern.
I made it into a sub and a functional program, for convenience.
use warnings;
use strict;
my $string = "4 22 6 7";
my $i = shift; # number you want to search for
print "Checking '$string' for: '$i'\n";
print "Result is: ", (is_in($string, $i) ? "Yes" : "No");
sub is_in {
my ($string, $i) = #_;
while ( $string =~ /(\d+)/g ) {
return 1 if ( $1 == $i );
}
return 0;
}
Example output:
C:\perl>t4.pl 4
Checking '4 22 6 7' for: '4'
Result is: Yes
C:\perl>t4.pl 22
checking '4 22 6 7' for: '22'
Result is: Yes
C:\perl>t4.pl 2
checking '4 22 6 7' for: '2'
Result is: No
You can do it easily with the help of split function.
use warnings;
my $string = "4 2 6 7";
my $i = 6; #use any value of $i
my #x = split / /, $string;
my $count = 0;
foreach (#x)
{
if($_ == $i)
{
print "matched at position $count"; die $!;
}
$count++;
}
print "integer doesn't found in string";
Try it on codepad: http://codepad.org/f5a86c9s
As per the title, I'm trying to find a way to programmatically determine the longest portion of similarity between several strings.
Example:
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
Ideally, I'd get back file:///home/gms8994/Music/, because that's the longest portion that's common for all 3 strings.
Specifically, I'm looking for a Perl solution, but a solution in any language (or even pseudo-language) would suffice.
From the comments: yes, only at the beginning; but there is the possibility of having some other entry in the list, which would be ignored for this question.
Edit: I'm sorry for mistake. My pity that I overseen that using my variable inside countit(x, q{}) is big mistake. This string is evaluated inside Benchmark module and #str was empty there. This solution is not as fast as I presented. See correction below. I'm sorry again.
Perl can be fast:
use strict;
use warnings;
package LCP;
sub LCP {
return '' unless #_;
return $_[0] if #_ == 1;
my $i = 0;
my $first = shift;
my $min_length = length($first);
foreach (#_) {
$min_length = length($_) if length($_) < $min_length;
}
INDEX: foreach my $ch ( split //, $first ) {
last INDEX unless $i < $min_length;
foreach my $string (#_) {
last INDEX if substr($string, $i, 1) ne $ch;
}
}
continue { $i++ }
return substr $first, 0, $i;
}
# Roy's implementation
sub LCP2 {
return '' unless #_;
my $prefix = shift;
for (#_) {
chop $prefix while (! /^\Q$prefix\E/);
}
return $prefix;
}
1;
Test suite:
#!/usr/bin/env perl
use strict;
use warnings;
Test::LCP->runtests;
package Test::LCP;
use base 'Test::Class';
use Test::More;
use Benchmark qw(:all :hireswallclock);
sub test_use : Test(startup => 1) {
use_ok('LCP');
}
sub test_lcp : Test(6) {
is( LCP::LCP(), '', 'Without parameters' );
is( LCP::LCP('abc'), 'abc', 'One parameter' );
is( LCP::LCP( 'abc', 'xyz' ), '', 'None of common prefix' );
is( LCP::LCP( 'abcdefgh', ('abcdefgh') x 15, 'abcdxyz' ),
'abcd', 'Some common prefix' );
my #str = map { chomp; $_ } <DATA>;
is( LCP::LCP(#str),
'file:///home/gms8994/Music/', 'Test data prefix' );
is( LCP::LCP2(#str),
'file:///home/gms8994/Music/', 'Test data prefix by LCP2' );
my $t = countit( 1, sub{LCP::LCP(#str)} );
diag("LCP: ${\($t->iters)} iterations took ${\(timestr($t))}");
$t = countit( 1, sub{LCP::LCP2(#str)} );
diag("LCP2: ${\($t->iters)} iterations took ${\(timestr($t))}");
}
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
Test suite result:
1..7
ok 1 - use LCP;
ok 2 - Without parameters
ok 3 - One parameter
ok 4 - None of common prefix
ok 5 - Some common prefix
ok 6 - Test data prefix
ok 7 - Test data prefix by LCP2
# LCP: 22635 iterations took 1.09948 wallclock secs ( 1.09 usr + 0.00 sys = 1.09 CPU) # 20766.06/s (n=22635)
# LCP2: 17919 iterations took 1.06787 wallclock secs ( 1.07 usr + 0.00 sys = 1.07 CPU) # 16746.73/s (n=17919)
That means that pure Perl solution using substr is about 20% faster than Roy's solution at your test case and one prefix finding takes about 50us. There is not necessary using XS unless your data or performance expectations are bigger.
The reference given already by Brett Daniel for the Wikipedia entry on "Longest common substring problem" is very good general reference (with pseudocode) for your question as stated. However, the algorithm can be exponential. And it looks like you might actually want an algorithm for longest common prefix which is a much simpler algorithm.
Here's the one I use for longest common prefix (and a ref to original URL):
use strict; use warnings;
sub longest_common_prefix {
# longest_common_prefix( $|# ): returns $
# URLref: http://linux.seindal.dk/2005/09/09/longest-common-prefix-in-perl
# find longest common prefix of scalar list
my $prefix = shift;
for (#_) {
chop $prefix while (! /^\Q$prefix\E/);
}
return $prefix;
}
my #str = map {chomp; $_} <DATA>;
print longest_common_prefix(#ARGV), "\n";
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
If you truly want a LCSS implementation, refer to these discussions (Longest Common Substring and Longest Common Subsequence) at PerlMonks.org. Tree::Suffix would probably be the best general solution for you and implements, to my knowledge, the best algorithm. Unfortunately recent builds are broken. But, a working subroutine does exist within the discussions referenced on PerlMonks in this post by Limbic~Region (reproduced here with your data).
#URLref: http://www.perlmonks.org/?node_id=549876
#by Limbic~Region
use Algorithm::Loops 'NestedLoops';
use List::Util 'reduce';
use strict; use warnings;
sub LCS{
my #str = #_;
my #pos;
for my $i (0 .. $#str) {
my $line = $str[$i];
for (0 .. length($line) - 1) {
my $char= substr($line, $_, 1);
push #{$pos[$i]{$char}}, $_;
}
}
my $sh_str = reduce {length($a) < length($b) ? $a : $b} #str;
my %map;
CHAR:
for my $char (split //, $sh_str) {
my #loop;
for (0 .. $#pos) {
next CHAR if ! $pos[$_]{$char};
push #loop, $pos[$_]{$char};
}
my $next = NestedLoops([#loop]);
while (my #char_map = $next->()) {
my $key = join '-', #char_map;
$map{$key} = $char;
}
}
my #pile;
for my $seq (keys %map) {
push #pile, $map{$seq};
for (1 .. 2) {
my $dir = $_ % 2 ? 1 : -1;
my #offset = split /-/, $seq;
$_ += $dir for #offset;
my $next = join '-', #offset;
while (exists $map{$next}) {
$pile[-1] = $dir > 0 ?
$pile[-1] . $map{$next} : $map{$next} . $pile[-1];
$_ += $dir for #offset;
$next = join '-', #offset;
}
}
}
return reduce {length($a) > length($b) ? $a : $b} #pile;
}
my #str = map {chomp; $_} <DATA>;
print LCS(#str), "\n";
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
It sounds like you want the k-common substring algorithm. It is exceptionally simple to program, and a good example of dynamic programming.
My first instinct is to run a loop, taking the next character from each string, until the characters are not equal. Keep a count of what position in the string you're at and then take a substring (from any of the three strings) from 0 to the position before the characters aren't equal.
In Perl, you'll have to split up the string first into characters using something like
#array = split(//, $string);
(splitting on an empty character sets each character into its own element of the array)
Then do a loop, perhaps overall:
$n =0;
#array1 = split(//, $string1);
#array2 = split(//, $string2);
#array3 = split(//, $string3);
while($array1[$n] == $array2[$n] && $array2[$n] == $array3[$n]){
$n++;
}
$sameString = substr($string1, 0, $n); #n might have to be n-1
Or at least something along those lines. Forgive me if this doesn't work, my Perl is a little rusty.
If you google for "longest common substring" you'll get some good pointers for the general case where the sequences don't have to start at the beginning of the strings.
Eg, http://en.wikipedia.org/wiki/Longest_common_substring_problem.
Mathematica happens to have a function for this built in:
http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Note that they mean contiguous subsequence, ie, substring, which is what you want.)
If you only care about the longest common prefix then it should be much faster to just loop for i from 0 till the ith characters don't all match and return substr(s, 0, i-1).
From http://forums.macosxhints.com/showthread.php?t=33780
my #strings =
(
'file:///home/gms8994/Music/t.A.T.u./',
'file:///home/gms8994/Music/nina%20sky/',
'file:///home/gms8994/Music/A%20Perfect%20Circle/',
);
my $common_part = undef;
my $sep = chr(0); # assuming it's not used legitimately
foreach my $str ( #strings ) {
# First time through loop -- set common
# to whole
if ( !defined $common_part ) {
$common_part = $str;
next;
}
if ("$common_part$sep$str" =~ /^(.*).*$sep\1.*$/)
{
$common_part = $1;
}
}
print "Common part = $common_part\n";
Faster than above, uses perl's native binary xor function, adapted from perlmongers solution (the $+[0] didn't work for me):
sub common_suffix {
my $comm = shift #_;
while ($_ = shift #_) {
$_ = substr($_,-length($comm)) if (length($_) > length($comm));
$comm = substr($comm,-length($_)) if (length($_) < length($comm));
if (( $_ ^ $comm ) =~ /(\0*)$/) {
$comm = substr($comm, -length($1));
} else {
return undef;
}
}
return $comm;
}
sub common_prefix {
my $comm = shift #_;
while ($_ = shift #_) {
$_ = substr($_,0,length($comm)) if (length($_) > length($comm));
$comm = substr($comm,0,length($_)) if (length($_) < length($comm));
if (( $_ ^ $comm ) =~ /^(\0*)/) {
$comm = substr($comm,0,length($1));
} else {
return undef;
}
}
return $comm;
}