Acme-Tools
view release on metacpan or search on metacpan
my($r,$n,%c)=(shift,0,'',0,qw/I 1 V 5 X 10 L 50 C 100 D 500 M 1000/);
$r=~s/^-//?-roman2int($r):
$r=~s/(C?)([DM])|(X?)([LCDM])|(I?)([VXLCDM])|(I)|(.)/
croak "roman2int: Invalid number $r" if $8;
$n += $c{$2||$4||$6||$7} - $c{$1||$3||$5||''}; ''/eg && $n
}
#sub roman2int_slow {
# my $r=shift;
# $r=~s,^\-,, ? 0-roman2int($r)
# : $r=~s,^M,,i ? 1000+roman2int($r)
# : $r=~s,^CM,,i ? 900+roman2int($r)
# : $r=~s,^D,,i ? 500+roman2int($r)
# : $r=~s,^CD,,i ? 400+roman2int($r)
# : $r=~s,^C,,i ? 100+roman2int($r)
# : $r=~s,^XC,,i ? 90+roman2int($r)
# : $r=~s,^L,,i ? 50+roman2int($r)
# : $r=~s,^XL,,i ? 40+roman2int($r)
# : $r=~s,^X,,i ? 10+roman2int($r)
# : $r=~s,^IX,,i ? 9+roman2int($r)
# : $r=~s,^V,,i ? 5+roman2int($r)
# : $r=~s,^IV,,i ? 4+roman2int($r)
# : $r=~s,^I,,i ? 1+roman2int($r)
# : !length($r) ? 0
# : croak "Invalid roman number $r";
#}
=head2 distance
B<Input:> the four decimal numbers of two GPS positions: latutude1, longitude1, latitude2, longitude2
B<Output:> the air distance in meters between the two points
Calculation is done using the Haversine Formula for spherical distance:
a = sin((lat2-lat1)/2)^2
+ sin((lon2-lon1)/2)^2 * cos(lat1) * cos(lat2);
c = 2 * atan2(min(1,sqrt(a)),
min(1,sqrt(1-a)))
distance = c * R
With earth radius set to:
R = Re - (Re-Rp) * sin(abs(lat1+lat2)/2)
Where C<Re = 6378137.0> (equatorial radius) and C<Rp = 6356752.3> (polar radius).
B<Example:>
my @oslo = ( 59.93937, 10.75135); # oslo in norway
my @rio = (-22.97673, -43.19508); # rio in brazil
printf "%.1f km\n", distance(@oslo,@rio)/1000; # 10431.7 km
printf "%.1f km\n", distance(@rio,@oslo)/1000; # 10431.7 km
printf "%.1f nmi\n", distance(@oslo,@rio)/1852.000; # 5632.7 nmi (nautical miles)
printf "%.1f miles\n",distance(@oslo,@rio)/1609.344; # 6481.9 miles
printf "%.1f miles\n",conv(distance(@oslo,@rio),"meters","miles");# 6481.9 miles
See L<http://www.faqs.org/faqs/geography/infosystems-faq/>
and L<http://mathforum.org/library/drmath/view/51879.html>
and L<http://en.wikipedia.org/wiki/Earth_radius>
and L<Geo::Direction::Distance>, but Acme::Tools::distance() is about 8 times faster.
=cut
our $Distance_factor = $PI / 180;
sub acos { atan2( sqrt(1 - $_[0] * $_[0]), $_[0] ) }
sub distance_great_circle {
my($lat1,$lon1,$lat2,$lon2)=map $Distance_factor*$_, @_;
my($Re,$Rp)=( 6378137.0, 6356752.3 ); #earth equatorial and polar radius
my $R=$Re-($Re-$Rp)*sin(abs($lat1+$lat2)/2); #approx
return $R*acos(sin($lat1)*sin($lat2)+cos($lat1)*cos($lat2)*cos($lon2-$lon1))
}
sub distance {
my($lat1,$lon1,$lat2,$lon2)=map $Distance_factor*$_, @_;
my $a= sin(($lat2-$lat1)/2)**2
+ sin(($lon2-$lon1)/2)**2 * cos($lat1) * cos($lat2);
my $sqrt_a =sqrt($a); $sqrt_a =1 if $sqrt_a >1;
my $sqrt_1ma=sqrt(1-$a); $sqrt_1ma=1 if $sqrt_1ma>1;
my $c=2*atan2($sqrt_a,$sqrt_1ma);
my($Re,$Rp)=( 6378137.0, 6356752.3 ); #earth equatorial and polar radius
my $R=$Re-($Re-$Rp)*sin(abs($lat1+$lat2)/2); #approx
return $c*$R;
}
=head2 big
=head2 bigi
=head2 bigf
=head2 bigr
=head2 bigscale
big, bigi, bigf, bigr and bigscale are sometimes convenient shorthands for using
C<< Math::BigInt->new() >>, C<< Math::BigFloat->new() >> and C<< Math::BigRat->new() >>
(preferably with the GMP for faster calculations). Examples:
my $num1 = big(3); #returns a new Math::BigInt-object
my $num2 = big('3.0'); #returns a new Math::BigFloat-object
my $num3 = big(3.0); #returns a new Math::BigInt-object
my $num4 = big(3.1); #returns a new Math::BigFloat-object
my $num5 = big('2/7'); #returns a new Math::BigRat-object
my($i1,$f1,$i2,$f2) = big(3,'3.0',3.0,3.1); #returns the four new numbers, as the above four lines
#uses wantarray
print 2**200; # 1.60693804425899e+60
print big(2)**200; # 1606938044258990275541962092341162602522202993782792835301376
print 2**big(200); # 1606938044258990275541962092341162602522202993782792835301376
print big(2**200); # 1606938044258990000000000000000000000000000000000000000000000
print 1/7; # 0.142857142857143
print 1/big(7); # 0 because of integer arithmetics
print 1/big(7.0); # 0 because 7.0 is viewed as an integer, see bigf below
print 1/big('7.0'); # 0.1428571428571428571428571428571428571429
print 1/bigf(7); # 0.1428571428571428571428571428571428571429
print bigf(1/7); # 0.142857142857143 probably not what you wanted
print 1/bigf(7); # 0.1428571428571428571428571428571428571429
bigscale(80); # for increased precesion (default is 40)
print 1/bigf(7); # 0.14285714285714285714285714285714285714285714285714285714285714285714285714285714
In C<big()> the characters C<< . >> and C<< / >> will make it return a
Math::BigFloat- and Math::BigRat-object accordingly. Or else a Math::BigInt-object is returned.
Instead of guessing, use C<bigi>, C<bigf> and C<bigr> to return what you want.
B<Note:> Acme::Tools does not depend on Math::BigInt and
Math::BigFloat and GMP, but these four big*-subs do (by C<require>).
To use big, bigi, bigf and bigr effectively you should
install Math::BigInt::GMP and Math::BigFloat::GMP like this:
sudo cpanm Math::BigFloat Math::GMP Math::BingInt::GMP # or
sudo cpan Math::BigFloat Math::GMP Math::BingInt::GMP # or
sudo yum install perl-Math-BigInt-GMP perl-Math-GMP # on RedHat, RHEL or
sudo apt-get install libmath-bigint-gmp-perl libmath-gmp-perl # on Ubuntu or some other way
Unless GMP is installed for perl like this, the Math::Big*-modules
will fall back to using similar but slower built in modules. See: L<https://gmplib.org/>
=cut
sub bigi {
eval q(use Math::BigInt try=>"GMP") if !$INC{'Math/BigInt.pm'};
if (wantarray) { return (map Math::BigInt->new($_),@_) }
else { return Math::BigInt->new($_[0]) }
}
sub bigf {
eval q(use Math::BigFloat try=>"GMP") if !$INC{'Math/BigFloat.pm'};
if (wantarray) { return (map Math::BigFloat->new($_),@_) }
else { return Math::BigFloat->new($_[0]) }
}
sub bigr {
eval q(use Math::BigRat try=>"GMP") if !$INC{'Math/BigRat.pm'};
if (wantarray) { return (map Math::BigRat->new($_),@_) }
else { return Math::BigRat->new($_[0]) }
}
sub big {
wantarray
? (map /\./ ? bigf($_) : /\// ? bigr($_) : bigi($_), @_)
: $_[0]=~/\./ ? bigf($_[0]) : $_[0]=~/\// ? bigr($_[0]) : bigi($_[0]);
}
sub bigscale {
@_==1 or croak "bigscale requires one and only one argument";
my $scale=shift();
eval q(use Math::BigInt try=>"GMP") if !$INC{'Math/BigInt.pm'};
eval q(use Math::BigFloat try=>"GMP") if !$INC{'Math/BigFloat.pm'};
eval q(use Math::BigRat try=>"GMP") if !$INC{'Math/BigRat.pm'};
Math::BigInt->div_scale($scale);
Math::BigFloat->div_scale($scale);
Math::BigRat->div_scale($scale);
return;
}
#my $R_authalic=6371007.2; #earth radius in meters, mean, Authalic radius, real R varies 6353-6384km, http://en.wikipedia.org/wiki/Earth_radius
#*)
# ( 6378157.5, 6356772.2 ) #hmm
#my $e=0.081819218048345;#sqrt(1 - $b**2/$a**2); #eccentricity of the ellipsoid
#my($a,$b)=( 6378137.0, 6356752.3 ); #earth equatorial and polar radius
#warn "e=$e\n";
#warn "t=".(1 - $e**2)."\n";
#warn "n=".((1 - $e**2 * sin(($lat1+$lat1)/2)**2)**1.5)."\n";
#my $t=1 - $e**2;
#my $n=(1 - $e**2 * sin(($lat1+$lat1)/2)**2)**1.5;
#warn "t=$t\n";
#warn "n=$n\n";
#$a * (1 - $e**2) / ((1 - $e**2 * sin(($lat1+$lat2)/2)**2)**1.5); #hmm avg lat
#$R=$a * $t/$n;
#=head2 fractional
#=cut
sub fractional { #http://mathcentral.uregina.ca/QQ/database/QQ.09.06/h/lil1.html
carp "fractional: NOT FINISHED";
my $n=shift;
print "----fractional n=$n\n";
my $nn=$n; my $dec;
$nn=~s,\.(\d+)$,$dec=length($1);$1.,;
my $l;
map {-d and !-l and unshift @files,$_ or -f and !-l and push @files,$_} readdirectory(shift(@files)) while -d $files[0];
=cut
sub readdirectory {
my $dir=shift;
opendir(my $D,$dir);
my @filer=map "$dir/$_", grep {!/^\.\.?$/} readdir($D);
closedir($D);
return @filer;
}
=head2 basename
The basename and dirname functions behaves like the *nix shell commands with the same names.
B<Input:> One or two arguments: Filename and an optional suffix
B<Output:> Returns the filename with any directory and (if given) the suffix removed.
basename('/usr/bin/perl') # returns 'perl'
basename('/usr/local/bin/report.pl','.pl') # returns 'report' since .pl at the end is removed
basename('report2.pl','.pl') # returns 'report2'
basename('report2.pl','.\w+') # returns 'report2.pl', probably not what you meant
basename('report2.pl',qr/.\w+/) # returns 'report2', use qr for regex
=head2 dirname
B<Input:> A filename including path
B<Output:> Removes the filename path and returns just the directory path up until but not including
the last /. Return just a one char C<< . >> (period string) if there is no directory in the input.
dirname('/usr/bin/perl') # returns '/usr/bin'
dirname('perl') # returns '.'
=head2 username
Returns the current linux/unix username, for example the string root
print username(); #just (getpwuid($<))[0] but more readable perhaps
=cut
sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 }
sub dirname { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' }
sub username { (getpwuid($<))[0] }
=head2 wipe
Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs)
B<Input:>
* Arg 1: A filename
* Optional arg 2: number of times to overwrite file. Default is 3 if omitted, 0 or undef
* Optional arg 3: keep (true/false), wipe() but no delete of file
B<Output:> Same as the C<unlink()> (remove file): 1 for success, 0 or false for failure.
See also: L<https://www.google.com/search?q=wipe+file>, L<http://www.dban.org/>
=cut
sub wipe {
my($file,$times,$keep)=@_;
$times||=3;
croak "ERROR: File $file nonexisting\n" if not -f $file or not -e $file;
my $size=-s$file;
open my $WIFH, '+<', $file or croak "ERROR: Unable to open $file: $!\n";
binmode($WIFH);
for(1..$times){
my $block=chr(int(rand(256))) x 1024;#hm
for(0..($size/1024)){
seek($WIFH,$_*1024,0);
print $WIFH $block;
}
}
close($WIFH);
$keep || unlink($file);
}
=head2 chall
Does chmod + utime + chown on one or more files.
Returns the number of files of which those operations was successful.
Mode, uid, gid, atime and mtime are set from the array ref in the first argument.
The first argument references an array which is exactly like an array returned from perls internal C<stat($filename)> -function.
Example:
my @stat=stat($filenameA);
chall( \@stat, $filenameB, $filenameC, ... ); # by stat-array
chall( $filenameA, $filenameB, $filenameC, ... ); # by file name
Copies the chmod, owner, group, access time and modify time from file A to file B and C.
See C<perldoc -f stat>, C<perldoc -f chmod>, C<perldoc -f chown>, C<perldoc -f utime>
=cut
sub chall {
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks )
= ref($_[0]) ? @{shift()} : stat(shift());
my $successful=0;
for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ }
return $successful;
}
=head2 makedir
Input: One or two arguments.
Works like perls C<mkdir()> except that C<makedir()> will create nesessary parent directories if they dont exists.
First input argument: A directory name (absolute, starting with C< / > or relative).
=head2 decode
C<decode()> and C<decode_num()> works just as Oracles C<decode()>.
C<decode()> and C<decode_num()> accordingly uses perl operators C<eq> and C<==> for comparison.
Examples:
my $a=123;
print decode($a, 123,3, 214,4, $a); # prints 3
print decode($a, 123=>3, 214=>4, $a); # prints 3, same thing since => is synonymous to comma in Perl
The first argument is tested against the second, fourth, sixth and so on,
and then the third, fifth, seventh and so on is
returned if decode() finds an equal string or number.
In the above example: 123 maps to 3, 124 maps to 4 and the last argument $a is returned elsewise.
More examples:
my $a=123;
print decode($a, 123=>3, 214=>7, $a); # also 3, note that => is synonym for , (comma) in perl
print decode($a, 122=>3, 214=>7, $a); # prints 123
print decode($a, 123.0 =>3, 214=>7); # prints 3
print decode($a, '123.0'=>3, 214=>7); # prints nothing (undef), no last argument default value here
print decode_num($a, 121=>3, 221=>7, '123.0','b'); # prints b
Sort of:
decode($string, %conversion, $default);
The last argument is returned as a default if none of the keys in the keys/value-pairs matched.
A more perl-ish and often faster way of doing the same:
{123=>3, 214=>7}->{$a} || $a # (beware of 0)
=cut
sub decode {
croak "Must have a mimimum of two arguments" if @_<2;
my $uttrykk=shift;
if(defined$uttrykk){ shift eq $uttrykk and return shift or shift for 1..@_/2 }
else { !defined shift and return shift or shift for 1..@_/2 }
return shift;
}
sub decode_num {
croak "Must have a mimimum of two arguments" if @_<2;
my $uttrykk=shift;
if(defined$uttrykk){ shift == $uttrykk and return shift or shift for 1..@_/2 }
else { !defined shift and return shift or shift for 1..@_/2 }
return shift;
}
=head2 qrlist
Input: An array of values to be used to test againts for existence.
Output: A reference to a regular expression. That is a C<qr//>
The regex sets $1 if it match.
Example:
my @list=qw/ABc XY DEF DEFG XYZ/;
my $filter=qrlist("ABC","DEF","XY."); # makes a regex of it qr/^(\QABC\E|\QDEF\E|\QXY.\E)$/
my @filtered= grep { $_ =~ $filter } @list; # returns DEF and XYZ, but not XYZ because the . char is taken literally
Note: Filtering with hash lookups are WAY faster.
Source:
sub qrlist (@) { my $str=join"|",map quotemeta, @_; qr/^($str)$/ }
=cut
sub qrlist (@) {
my $str=join"|",map quotemeta,@_;
return qr/^($str)$/;
}
=head2 ansicolor
Perhaps easier to use than L<Term::ANSIColor> ?
B<Input:> One argument. A string where the char C<¤> have special
meaning and is replaced by color codings depending on the letter
following the C<¤>.
B<Output:> The same string, but with C<¤letter> replaced by ANSI color
codes respected by many types terminal windows. (xterm, telnet, ssh,
telnet, rlog, vt100, cygwin, rxvt and such...).
B<Codes for ansicolor():>
¤r red
¤g green
¤b blue
¤y yellow
¤m magenta
¤B bold
¤u underline
¤c clear
¤¤ reset, quits and returns to default text color.
B<Example:>
print ansicolor("This is maybe ¤ggreen¤¤?");
Prints I<This is maybe green?> where the word I<green> is shown in green.
If L<Term::ANSIColor> is not installed or not found, returns the input
string with every C<¤> including the following code letters
removed. (That is: ansicolor is safe to use even if Term::ANSIColor is
not installed, you just don't get the colors).
See also L<Term::ANSIColor>.
=cut
print tablestring([
[qw/AA BB CCCC/],
[123,23,"d"],
[12,23,34],
[77,88,99],
["lin\nes",12,"asdff\nfdsa\naa"],[0,22,"adf"]
]);
Prints this string of 11 lines:
AA BB CCCC
--- -- -----
123 23 d
12 23 34
77 8 99
lin 12 asdff
es fdsa
aa
10 22 adf
As you can see, rows containing multi-lined cells gets an empty line before and after the row to separate it more clearly.
=cut
sub tablestring {
my $tab=shift;
my %o=$_[0] ? %{shift()} : ();
my $remove_empty = $o{remove_empty_columns};
my $no_multiline_space = $o{no_multiline_space};
my $nodup = $o{nodup}||0;
my $no_header_line = $o{no_header_line};
my $pagesize = exists $o{pagesize} ? $o{pagesize}-3 : 9999999;
my $left_force = $o{left};
my(@width,@left,@height,@not_empty,@nodup);
my $head=1;
my $i=0;
my $j;
for(@$tab){
$j=0;
$height[$i]=0;
my $nodup_rad=$nodup;
if(ref($_) eq 'ARRAY'){
for(@$_){
my $cell=$_;
$width[$j]||=0;
if($nodup_rad and $i>0 and $$tab[$i][$j] eq $$tab[$i-1][$j] || ($nodup_rad=0)){
$cell=$nodup==1?"":$nodup;
$nodup[$i][$j]=1;
}
else{
my $height=0;
my $wider;
no warnings;
$not_empty[$j]=1 if !$head && length($cell)>0;
for(split("\n",$cell)){
$wider=/<input.+type=text.+size=(\d+)/i?$1:0; #hm
s/<[^>]+>//g;
$height++;
s/>/>/g;
s/</</g;
$width[$j]=length($_)+1+$wider if length($_)+1+$wider>$width[$j];
$left[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$head;
}
if( $height>1 && !$no_multiline_space){
$height++ if !$head;
$height[$i-1]++ if $i>1 && $height[$i-1]==1;
}
$height[$i]=$height if $height>$height[$i];
}
$j++;
}
}
else{
$height[$i]=1;
$no_header_line=1;
}
$head=0;
$i++;
}
$i=$#height;
$j=$#width;
if($i==0 or $left_force) { @left=map{1}(0..$j) }
else { for(0..$j){ $left[$_]=1 if !$not_empty[$_] } }
my @tabout;
my $row_start_line=0;
my @header;
my $header_last;
for my $x (0..$i){
if($$tab[$x] eq '-'){
my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j);
$tabout[$row_start_line]=join(" ",map {$tegn[$_] x ($width[$_]-1)} (0..$j));
}
else{
for my $y (0..$j){
next if $remove_empty && !$not_empty[$y];
no warnings;
my @cell = !$header_last&&$nodup&&$nodup[$x][$y]
? ($nodup>0?():((" " x (($width[$y]-length($nodup))/2)).$nodup))
: split("\n",$$tab[$x][$y]);
for(0..($height[$x]-1)){
my $line=$row_start_line+$_;
my $txt=shift(@cell);
$txt='' if !defined$txt;
$txt=sprintf("%*s",$width[$y]-1,$txt) if length($txt)>0 && !$left[$y] && ($x>0 || $no_header_line);
$tabout[$line].=$txt;
if($y==$j){
$tabout[$line]=~s/\s+$//;
}
else{
my $wider;
$wider = $txt=~/<input.+type=text.+size=(\d+)/i?1+$1:0;
$txt=~s/<[^>]+>//g;
$txt=~s/>/>/g;
$txt=~s/</</g;
$tabout[$line].= ' ' x ($width[$y]-length($txt)-$wider);
}
}
}
}
$row_start_line+=$height[$x];
#--lage streker?
if(not $no_header_line){
if($x==0){
for my $y (0..$j){
next if $remove_empty && !$not_empty[$y];
$tabout[$row_start_line].=('-' x ($width[$y]-1))." ";
}
$row_start_line++;
@header=("",@tabout);
}
elsif(
$x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1]
and $x+1<@$tab
and !$no_header_line
)
{
push(@tabout,@header);
$row_start_line+=@header;
$header_last=1;
}
else{
$header_last=0;
}
}
}#for x
return join("\n",@tabout)."\n";
}
=head2 serialize
Returns a data structure as a string. See also C<Data::Dumper>
(serialize was created long time ago before Data::Dumper appeared on
CPAN, before CPAN even...)
B<Input:> One to four arguments.
First argument: A reference to the structure you want.
Second argument: (optional) The name the structure will get in the output string.
If second argument is missing or is undef or '', it will get no name in the output.
Third argument: (optional) The string that is returned is also put
into a created file with the name given in this argument. Putting a
C<< > >> char in from of the filename will append that file
instead. Use C<''> or C<undef> to not write to a file if you want to
use a fourth argument.
Fourth argument: (optional) A number signalling the depth on which newlines is used in the output.
The default is infinite (some big number) so no extra newlines are output.
B<Output:> A string containing the perl-code definition that makes that data structure.
The input reference (first input argument) can be to an array, hash or a string.
=head1 JUST FOR FUN
=head2 brainfu
B<Input:> one or two arguments
First argument: a string, source code of the brainfu
language. String containing the eight charachters + - < > [ ] . ,
Every other char is ignored silently.
Second argument: if the source code contains commas (,) the second
argument is the input characters in a string.
B<Output:> The resulting output from the program.
Example:
print brainfu(<<""); #prints "Hallo Verden!\n"
++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>---.+++++++++++..+++.>++.<<++++++++++++++
.>----------.+++++++++++++.--------------.+.+++++++++.>+.>.
See L<http://en.wikipedia.org/wiki/Brainfuck>
=head2 brainfu2perl
Just as L</brainfu> but instead it return the perl code to which the
brainfu code is translated. Just C<< eval() >> this perl code to run.
Example:
print brainfu2perl('>++++++++[<++++++++>-]<++++++++.>++++++[<++++++>-]<---.');
Prints this string:
my($c,$o,@b)=(0); sub out{$o.=chr($b[$c]) for 1..$_[0]||1}
++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
++$b[$c];++$c;--$b[$c];}--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
++$b[$c];++$b[$c];out;++$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];
while($b[$c]){--$c;++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$b[$c];++$c;--$b[$c];}
--$c;--$b[$c];--$b[$c];--$b[$c];out;$o;
=head2 brainfu2perl_optimized
Just as L</brainfu2perl> but optimizes the perl code. The same
example as above with brainfu2perl_optimized returns this equivalent
but shorter perl code:
$b[++$c]+=8;while($b[$c]){$b[--$c]+=8;--$b[++$c]}$b[--$c]+=8;out;$b[++$c]+=6;
while($b[$c]){$b[--$c]+=6;--$b[++$c]}$b[--$c]-=3;out;$o;
=cut
sub brainfu { eval(brainfu2perl(@_)) }
sub brainfu2perl {
my($bf,$inp)=@_;
my $perl='my($c,$inp,$o,@b)=(0,\''.$inp.'\'); no warnings; sub out{$o.=chr($b[$c]) for 1..$_[0]||1}'."\n";
$perl.='sub inp{$inp=~s/(.)//s and $b[$c]=ord($1)}'."\n" if $inp and $bf=~/,/;
$perl.=join("",map/\+/?'++$b[$c];':/\-/?'--$b[$c];':/\[/?'while($b[$c]){':/\]/?'}':/>/?'++$c;':/</?'--$c;':/\./?'out;':/\,/?'inp;':'',split//,$bf).'$o;';
$perl;
}
sub brainfu2perl_optimized {
my $perl=brainfu2perl(@_);
$perl=~s{(((\+|\-)\3\$b\[\$c\];){2,})}{ '$b[$c]'.$3.'='.(grep/b/,split//,$1).';' }gisex;
1 while $perl=~s/\+\+\$c;\-\-\$c;//g + $perl=~s/\-\-\$c;\+\+\$c;//g;
$perl=~s{((([\-\+])\3\$c;){2,})}{"\$c$3=".(grep/c/,split//,$1).';'}gisex;
$perl=~s{((\+\+|\-\-)\$c;([^;{}]+;))}{my($o,$s)=($2,$3);$s=~s/\$c/$o\$c/?$s:$1}ge;
$perl=~s/\$c(\-|\+)=(\d+);(\+\+|\-\-)\$b\[\$c\]/$3.'$b[$c'.$1.'='.$2.'];'/ge;
$perl=~s{((out;){2,})}{'out('.(grep/o/,split//,$1).');'}ge;
$perl=~s/;}/}/g;$perl=~s/;+/;/g;
$perl;
}
=head1 BLOOM FILTER SUBROUTINES
Bloom filters can be used to check whether an element (a string) is a
member of a large set using much less memory or disk space than other
data structures. Trading speed and accuracy for memory usage. While
risking false positives, Bloom filters have a very strong space
advantage over other data structures for representing sets.
In the example below, a set of 100000 phone numbers (or any string of
any length) can be "stored" in just 91230 bytes if you accept that you
can only check the data structure for existence of a string and accept
false positives with an error rate of 0.03 (that is three percent, error
rates are given in numbers larger than 0 and smaller than 1).
You can not retrieve the strings in the set without using "brute
force" methods and even then you would get slightly more strings than
you put in because of the error rate inaccuracy.
Bloom Filters have many uses.
See also: L<http://en.wikipedia.org/wiki/Bloom_filter>
See also: L<Bloom::Filter>
=head2 bfinit
Initialize a new Bloom Filter:
my $bf = bfinit( error_rate=>0.01, capacity=>100000 );
The same:
my $bf = bfinit( 0.01, 100000 );
since two arguments is interpreted as error_rate and capacity accordingly.
=head2 bfadd
bfadd($bf, $_) for @phone_numbers; # Adding strings one at a time
bfadd($bf, @phone_numbers); # ...or all at once (faster)
Returns 1 on success. Dies (croaks) if more strings than capacity is added.
( run in 2.185 seconds using v1.01-cache-2.11-cpan-df04353d9ac )