Acme-Tools
view release on metacpan or search on metacpan
print hex2oct(101); # 401
print oct2dec(101); # 65
print oct2bin(101); # 1000001
print oct2hex(101); # 41
=cut
sub _base{my($b,$n)=@_;$n?_base($b,int$n/$b).chr(48+$n%$b+7*($n%$b>9)):''} #codegolf
sub base {
my($b,$n)=@_;
@_>2 ? (map base($b,$_),@_[1..$#_])
:$b<2||$b>36 ? croak"base not 2-36"
:$n>0 ? _base($b,$n)
:$n<0 ? "-"._base($b,-$n)
:!defined $n ? undef
:$n==0 ? 0
: croak
}
sub dec2bin { sprintf"%b",shift }
sub dec2hex { sprintf"%x",shift }
120 = 2^3 * 3^1 * 5^1
75 = 2^0 * 3^1 * 5^2
Take the bigest power of each primary number (2, 3 and 5 here).
Which is 2^3, 3^2 and 5^2. Multiplied this is 8 * 9 * 25 = 1800.
sub lcm { my($a,$b,@r)=@_; @r ? lcm($a,lcm($b,@r)) : $a*$b/gcd($a,$b) }
Seems to works with L<Math::BigInt> as well: (C<lcm> of all integers from 1 to 200)
perl -MAcme::Tools -MMath::BigInt -le'print lcm(map Math::BigInt->new($_),1..200)'
337293588832926264639465766794841407432394382785157234228847021917234018060677390066992000
=cut
sub lcm { my($a,$b,@r)=@_; @r ? lcm($a,lcm($b,@r)) : $a*$b/gcd($a,$b) }
=head2 resolve
Resolves an equation by Newtons method.
gal, gallon, gallon_imp, gallon_uk, gallon_us, gallons,
pint, pint_imp, pint_uk, pint_us, tsp, tablespoon, teaspoon,
floz, floz_uk, therm, thm, fat, bbl, Mbbl, MMbbl, drum,
container (or container20), container40, container40HC, container45HC
See: L<http://en.wikipedia.org/wiki/Units_of_measurement>
=cut
#TODO: @arr2=conv(\@arr1,"from","to") # should be way faster than:
#TODO: @arr2=map conv($_,"from","to"),@arr1
#TODO: conv(123456789,'b','h'); # h converts to something human-readable
our %conv=(
length=>{
m => 1,
_m => 1,
meter => 1,
meters => 1,
metre => 1,
metres => 1,
$conv{money}{"m$_"}=$conv{money}{$_}/1000 for qw/BTC XBT/;
$conv_prepare_money_time=time();
1; #not yet
}
sub conv {
my($num,$from,$to)=@_;
croak "conf requires 3 args" if @_!=3;
conv_prepare() if !$conv_prepare_time;
my $types=sub{ my $unit=shift; [sort grep$conv{$_}{$unit}, keys%conv] };
my @types=map{ my $ru=$_; my $r;$r=&$types($_) and @$r and $$ru=$_ and last for ($$ru,uc($$ru),lc($$ru)); $r }(\$from,\$to);
my @err=map "Unit ".[$from,$to]->[$_]." is unknown",grep!@{$types[$_]},0..1;
my @type=intersect(@types);
push @err, "from=$from and to=$to has more than one possible conversions: ".join(", ", @type) if @type>1;
push @err, "from $from (".(join(",",@{$types[0]})||'?').") and "
."to $to (" .(join(",",@{$types[1]})||'?').") has no known common dimension (unit type).\n" if @type<1;
croak join"\n",map"conv: $_",@err if @err;
my $type=$type[0];
conv_prepare_money() if $type eq 'money' and time() >= $conv_prepare_money_time + $Currency_rates_expire;
return conv_temperature(@_) if $type eq 'temperature';
return conv_numbers(@_) if $type eq 'numbers';
my $c=$conv{$type};
my($cf,$ct)=@{$conv{$type}}{$from,$to};
my $r= $cf>0 && $ct<0 ? -$ct/$num/$cf
: $cf<0 && $ct>0 ? -$cf/$num/$ct
: $cf*$num/$ct;
# print STDERR "$num $from => $to from=$ff to=$ft r=$r\n";
return $r;
}
sub conv_temperature { #http://en.wikipedia.org/wiki/Temperature#Conversion
my($t,$from,$to)=(shift(),map uc(substr($_,0,1)),@_);
$from=~s/K/C/ and $t-=273.15;
#$from=~s/R/F/ and $t-=459.67; #rankine
return $t if $from eq $to;
{CK=>sub{$t+273.15},
FC=>sub{($t-32)*5/9},
CF=>sub{$t*9/5+32},
FK=>sub{($t-32)*5/9+273.15},
}->{$from.$to}->();
}
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;
}
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);
=head2 trim
Removes space from the beginning and end of a string. Whitespace (C<< \s >>) that is.
And removes any whitespace inside the string of more than one char, leaving the first whitespace char. Thus:
trim(" asdf \t\n 123 ") eq "asdf 123"
trim(" asdf\t\n 123\n") eq "asdf\t123"
Works on C<< $_ >> if no argument i given:
print join",", map trim, " please ", " remove ", " my ", " spaces "; # please,remove,my,spaces
print join",", trim(" please ", " remove ", " my ", " spaces "); # works on arrays as well
my $s=' please '; trim(\$s); # now $s eq 'please'
trim(\@untrimmedstrings); # trims array strings inplace
@untrimmedstrings = map trim, @untrimmedstrings; # same, works on $_
trim(\$_) for @untrimmedstrings; # same, works on \$_
=head2 lpad
=head2 rpad
Left or right pads a string to the given length by adding one or more spaces at the end for I<rpad> or at the start for I<lpad>.
B<Input:> First argument: string to be padded. Second argument: length of the output. Optional third argument: character(s) used to pad.
Default is space.
cpad('mat',5,'+') eq '+mat+'
cpad('MMMM',20,'xyzXYZ') eq 'xyzXYZxyMMMMxyzXYZxy'
=cut
sub upper {no warnings;my $s=@_?shift:$_;$s=~tr/a-zæøåäëïöü.âêîôûãõà èìòùáéÃóúýñð/A-ZÆØÅÄËÃÖÜ.ÂÊÎÔÛÃÕÀÈÌÒÙÃÉÃÓÚÃÑÃ/;$s}
sub lower {no warnings;my $s=@_?shift:$_;$s=~tr/A-ZÆØÅÄËÃÖÜ.ÂÊÎÔÛÃÕÀÈÌÒÙÃÉÃÓÚÃÑÃ/a-zæøåäëïöü.âêîôûãõà èìòùáéÃóúýñð/;$s}
sub trim {
return trim($_) if !@_;
return map trim($_), @_ if @_>1;
my $s=shift;
if(ref($s) eq 'SCALAR'){ $$s=~s,^\s+|(?<=\s)\s+|\s+$,,g; return $$s}
if(ref($s) eq 'ARRAY') { trim(\$_) for @$s; return $s }
$s=~s,^\s+|(?<=\s)\s+|\s+$,,g if defined $s;
$s;
}
sub rpad {
my($s,$l,$p)=@_;
$p=' ' if @_<3 or !length($p);
=head2 chars
chars("Tittentei"); # ('T','i','t','t','e','n','t','e','i')
=cut
sub trigram { sliding($_[0],$_[1]||3) }
sub sliding {
my($s,$w)=@_;
return map substr($s,$_,$w), 0..length($s)-$w if !ref($s);
return map [@$s[$_..$_+$w-1]], 0..@$s-$w if ref($s) eq 'ARRAY';
}
sub chunks {
my($s,$w)=@_;
return $s=~/(.{1,$w})/g if !ref($s);
return map [@$s[$_*$w .. min($_*$w+$w-1,$#$s)]], 0..$#$s/$w if ref($s) eq 'ARRAY';
}
sub chars { split//, shift }
=head2 repl
Synonym for replace().
=head2 replace
B<Input:> Two or more strings
B<Output:> A number 0 - 1 indicating the similarity between two strings.
Requires L<String::Similarity> where the real magic happens.
sim("Donald Duck", "Donald E. Knuth"); # returns 0.615
sim("Kalle Anka", "Kalle And")' # returns 0.842
sim("Kalle Anka", "Kalle Anka"); # returns 1
sim("Kalle Anka", "kalle anka"); # returns 0.8
sim(map lc, "Kalle Anka", "kalle anka"); # returns 1
Todo: more doc
=cut
#Todo:
#peat -le'print join", ",sim("GskOk",[zip([qw(Gsk_ok Vgdoknr Personnavn Adferdkode Ordenkode G_kok)],[0..5])],0.7,0.127)'
#Use of uninitialized value in subroutine entry at /usr/local/share/perl/5.22.1/Acme/Tools.pm line 2365.
#Use of uninitialized value $simlikest in numeric ge (>=) at /usr/local/share/perl/5.22.1/Acme/Tools.pm line 2366.
#Use of uninitialized value in subroutine entry at /usr/local/share/perl/5.22.1/Acme/Tools.pm line 2365.
sim_perm() was written to identify double-profiles in databases: two people with
either the same (or similar) email or phone number or zip code and similar enough
names are going on the list of probable doubles.
*) Todo: deal with initials better, should be higher than 0.78
=cut
sub sim_perm {
require String::Similarity;
my($s1,$s2)=map {s/^\s*(.+?)\s*$/$1/;$_} map upper($_), @_; #/r v5.14
croak if !length($s1) or !length($s2);
my $max;
for(cart([permutations(split(/[\s,]+/,$s1))],
[permutations(split(/[\s,]+/,$s2))])) {
my($n1,$n2)=@$_;
if(@$n1>@$n2){ pop@$n1 while @$n1>@$n2 }
else { pop@$n2 while @$n1<@$n2 }
my($str1,$str2)=map join(" ",@$_),($n1,$n2);
if(defined $max){
my $sim=String::Similarity::similarity($str1,$str2,$max);
$max=$sim if $sim>$max;
}
else {
$max=String::Similarity::similarity($str1,$str2);
}
last if $max==1;
}
return $max;
=back
B<Examples:>
binsearch(10,[5,10,15,20]); # 1
binsearch(10,[20,15,10,5],undef,sub{$_[1]<=>$_[0]}); # 2 search arrays sorted numerically in opposite order
binsearch("c",["a","b","c","d"],undef,sub{$_[0]cmp$_[1]}); # 2 search arrays sorted alphanumerically
binsearchstr("b",["a","b","c","d"]); # 1 search arrays sorted alphanumerically
my @data=( map { {num=>$_, sqrt=>sqrt($_), square=>$_**2} }
grep !$_%7, 1..1000000 );
my $i = binsearch( {num=>913374}, \@data, undef, sub {$_[0]{num} <=> $_[1]{num}} );
my $i = binsearch( {num=>913374}, \@data, undef, 'num' ); #same as previous line
my $found_hashref = defined $i ? $data[$i] : undef;
=head2 binsearchstr
Same as binsearch except that the arrays is sorted alphanumerically
(cmp) instead of numerically (<=>) and the searched element is a
string, not a number. See L</binsearch>.
my @a=2..44;
egrep { $prev =~/4$/ or $next =~/2$/ } @a; # 5, 11, 15, 21, 25, 31, 35, 41
egrep { $prevr=~/4$/ or $nextr=~/2$/ } @a; # 2, 5, 11, 15, 21, 25, 31, 35, 41, 44
egrep { $i%7==0 } @a; # 2, 9, 16, 23, 30, 37, 44
egrep { $n%7==0 } @a; # 8, 15, 22, 29, 36, 43
=cut
sub egrep (&@) {
my($code,$i,$package)=(shift,-1,(caller)[0]);
my %h=map{($_=>"${package}::$_")}qw(i n prev next prevr nextr);
no strict 'refs';
grep {
#no strict 'refs'; #not here! "no" not allowed in expression in perl5.16
local ${$h{i}} = ++$i;
local ${$h{n}} = $i+1;
local ${$h{prev}} = $i>0?$_[$i-1]:undef;
local ${$h{next}} = $i<$#_?$_[$i+1]:undef;
local ${$h{prevr}} = $_[$i>0?$i-1:$#_];
local ${$h{nextr}} = $_[$i<$#_?$i+1:0];
&$code;
if($cmpsub){ &$cmpsub($$a[$_],$$a[$_+1])>0 and return 0 for 0..$#$a-1 }
else { $$a[$_] > $$a[$_+1] and return 0 for 0..$#$a-1 }
return 1;
}
#sub sortedstr { sorted(@_,sub{$_[0]cmp$_[1]}) }
sub sortedstr { $_[$_] gt $_[$_+1] and return 0 for 0..$#$_-1; return 1 }
sub sortby {
my($arr,@by)=@_;
die if grep/^-/,@by; #hm 4now todo! - dash meaning descending order
my $pattern=join(" ",map"%-40s",@by);#hm 4now bad, cant handle numeric sort
map$$_[0],
sort{$$a[1]cmp$$b[1]}
map[$_,sprintf($pattern,@$_{@by})],
@$arr;
}
=head2 subarrays
Returns all 2^n-1 combinatory subarrays of an array where each element
of input array participates or not. Note: The empty array is not among
the returned arrayrefs unless an empty input is given.
my @a = subarrays( 'a', 'b', 'c' ); # same as:
my @a = ( ['a' ],
[ 'b'],
['a','b'],
[ 'c'],
['a', 'c'],
[ 'b','c'],
['a','b','c'] );
sub subarrays { map { my $n = 2*$_; [ grep {($n/=2)%2} @_ ] } 1 .. 2**@_-1 } #implemented as
=cut
sub subarrays { map { my $n = 2*$_; [ grep {($n/=2)%2} @_ ] } 1 .. 2**@_-1 }
=head2 part
B<Input:> A code-ref and a list
B<Output:> Two array-refs
Like C<grep> but returns the false list as well. Partitions a list
into two lists where each element goes into the first or second list
whether the predicate (a code-ref) is true or false for that element.
@a = ( undef, undef, ['of'], ['are','the'], ['this'], ['These','words','array'] )
Two undefs at first (index positions 0 and 1) since there are no words of length 0 or 1 in the input array.
=cut
sub part (&@) { my($c,@r)=(shift,[],[]); push @{ $r[ &$c?0:1 ] }, $_ for @_; @r }
sub parth (&@) { my($c,%r)=(shift); push @{ $r{ &$c } }, $_ for @_; %r }
sub parta (&@) { my($c,@r)=(shift); push @{ $r[ &$c ] }, $_ for @_; @r }
#sub mapn (&$@) { ... } like map but @_ contains n elems at a time, n=1 is map
=head2 refa
=head2 refh
=head2 refs
=head2 refaa
=head2 refah
sub splicer { @_==1 ? splice( @{shift()} )
:@_==2 ? splice( @{shift()}, shift() )
:@_==3 ? splice( @{shift()}, shift(), shift() )
:@_>=4 ? splice( @{shift()}, shift(), shift(), @_ ) : croak }
sub keysr { ref($_[0]) eq 'HASH' ? keys(%{shift()}) : keysr({@{shift()}}) } #hm sort(keys%{shift()}) ?
sub valuesr { values( %{shift()} ) }
sub eachr { ref($_[0]) eq 'HASH' ? each(%{shift()})
#:ref($_[0]) eq 'ARRAY' ? each(@{shift()}) # perl 5.8.8 cannot compile each on array! eval?
: croak("eachr needs hashref or arrayref got '".ref($_[0])."'") }
sub joinr {join(shift(),@{shift()})}
#sub mapr # som scala: hvis map faar subref se kalles den sub paa hvert elem og resultatet returneres
#sub eachr { each(%{shift()}) }
=head2 pile
B<Input:> a pile size s and a list
B<Output:> A list of lists of length s or the length of the remainer in
the last list. Piles together the input list in lists of the given size.
varchar_maxlen=>4000,
create=>1,
drop=>0, # 1 drop table if exists, 2 plain drop
end=>"commit;\n",
begin=>"begin;\n",
fix_colnames=>0,
);
my %conf=(%def,(@_<2?():%$conf));
# $conf{$_}||=$def{$_} for keys%def;
my %col;
map $col{$_}++, keys %$_ for @$aoh;
my @col=sort keys %col;
my @colerr=grep!/^[a-z]\w+$/i,@col;
croak "Invalid column name(s): @colerr" if @colerr and !$conf{fix_colnames};
my(%t,%tdb);
for my $c (@col){
my($l,$s,$p,$nn,%ant,$t)=(0,0,0,0);
for my $r (@$aoh){
my $v=$$r{$c};
next if !defined$v or $v!~/\S/;
$nn++;
my $tdb;
$tdb="$conf{$t}($l)" if $t eq 'varchar';
$tdb="$conf{$t}($s)" if $t eq 'number' and $p==0;
$tdb="$conf{$t}($s,$p)" if $t eq 'number' and $p>0 and ++$s;
$tdb.=" not null" if $nn == 0+@$aoh;
$t{$c}=$t;
$tdb{$c}=$tdb;
}
my $sql;
$sql="create table $conf{name} (".
join(",",map sprintf("\n %-30s %s",do{s/\W+//g;$_},$tdb{$_}), @col). "\n);\n\n" if $conf{create};
my $val=sub{my($v,$t)=@_;defined$v or $v="";!length($v)?'null':$t eq 'number' ? $v : "'".repl($v,"\'","''")."'"};
for my $r (@$aoh){
my $v=join",",map &$val($$r{$_},$t{$_}), @col;
$sql.="insert into $conf{name} values ($v);\n";
}
$sql="drop table $conf{name};\n\n$sql" if $conf{drop}==1;
$sql="drop table if exists $conf{name};\n\n$sql" if $conf{drop}>=2;
$sql="$conf{begin}\n$sql" if $conf{begin};
$sql.=$conf{end};
$sql;
}
sub aoh2xls { croak "Not implemented yet: aoh2xls" }
$sum+=$_ for @a;
return $sum/@a
}
=head2 geomavg
Returns the I<geometric average> (a.k.a I<geometric mean>) of a list of numbers.
print geomavg(10,100,1000,10000,100000); # 1000
print 0+ (10*100*1000*10000*100000) ** (1/5); # 1000 same thing
print exp(avg(map log($_),10,100,1000,10000,100000)); # 1000 same thing, this is how geomavg() works internally
=cut
sub geomavg { exp(avg(map log($_), @_)) }
=head2 harmonicavg
Returns the I<harmonic average> (a.k.a I<geometric mean>) of a list of numbers. L<http://en.wikipedia.org/wiki/Harmonic_mean>
print harmonicavg(10,11,12); # 3 / ( 1/10 + 1/11 + 1/12) = 10.939226519337
=cut
sub harmonicavg { my $s; $s+=1/$_ for @_; @_/$s }
B<Examples:>
This finds the 50-percentile (the median) to the four numbers 1, 2, 3 and 4:
print "Median = " . percentile(50, 1,2,3,4); # 2.5
This:
@data=(11, 5, 3, 5, 7, 3, 1, 17, 4, 2, 6, 4, 12, 9, 0, 5);
@p = map percentile($_,@data), (25, 50, 75);
Is the same as this:
@p = percentile([25, 50, 75], @data);
But the latter is faster, especially if @data is large since it sorts
the numbers only once internally.
B<Example:>
B<Examples:>
$dice=random(1,6); # 1, 2, 3, 4, 5 or 6
$dice=random([1..6]); # same as previous
@dice=random([1..6],10); # 10 dice tosses
$dice=random({1=>1, 2=>1, 3=>1, 4=>1, 5=>1, 6=>2}); # weighted dice with 6 being twice as likely as the others
@dice=random({1=>1, 2=>1, 3=>1, 4=>1, 5=>1, 6=>2},10); # 10 weighted dice tosses
print random({head=>0.4999,tail=>0.4999,edge=>0.0002}); # coin toss (sum 1 here but not required to be)
print random(2); # prints 0, 1 or 2
print 2**random(7); # prints 1, 2, 4, 8, 16, 32, 64 or 128
@dice=map random([1..6]), 1..10; # as third example above, but much slower
perl -MAcme::Tools -le 'print for random({head=>0.499,tail=>0.499,edge=>0.002},10000);' | sort | uniq -c
=cut
sub random {
my($from,$to)=@_;
my $ref=ref($from);
if($ref eq 'ARRAY'){
my @r=map $$from[rand@$from], 1..$to||1;
return @_>1?@r:$r[0];
}
elsif($ref eq 'HASH') {
my @k=keys%$from;
my $max;do{no warnings 'uninitialized';$_>$max and $max=$_ or $_<0 and croak"negative weight" for values%$from};
my @r=map {my$r;1 while $$from{$r=$k[rand@k]}<rand($max);$r} 1..$to||1;
return @_>1?@r:$r[0];
}
($from,$to)=(0,$from) if @_==1;
($from,$to)=($to,$from) if $from>$to;
return int($from+rand(1+$to-$from));
}
#todo?: https://en.wikipedia.org/wiki/Irwin%E2%80%93Hall_distribution
=head2 random_gauss
Third argument: If a third argument is present, C<random_gauss>
returns an array of that many pseudo-random numbers. If there is no
third argument, a number (a scalar) is returned.
B<Output:> One or more pseudo-random numbers with a Gaussian distribution. Also known as a Bell curve or Normal distribution.
Example:
my @I=random_gauss(100, 15, 100000); # produces 100000 pseudo-random numbers, average=100, stddev=15
#my @I=map random_gauss(100, 15), 1..100000; # same but more than three times slower
print "Average is: ".avg(@I)."\n"; # prints a number close to 100
print "Stddev is: ".stddev(@I)."\n"; # prints a number close to 15
my @M=grep $_>100+15*2, @I; # those above 130
print "Percent above two stddevs: ".(100*@M/@I)."%\n"; #prints a number close to 2.2%
Example 2:
my $num=1e6;
my @h; $h[$_/2]++ for random_gauss(100,15, $num);
probably not get the expected result.
To check distribution:
perl -MAcme::Tools -le 'print mix("a".."z") for 1..26000'|cut -c1|sort|uniq -c|sort -n
The letters a-z should occur around 1000 times each.
Shuffles a deck of cards: (s=spaces, h=hearts, c=clubs, d=diamonds)
perl -MAcme::Tools -le '@cards=map join("",@$_),cart([qw/s h c d/],[2..10,qw/J Q K A/]); print join " ",mix(@cards)'
(Uses L</cart>, which is not a typo, see further down here)
Note: C<List::Util::shuffle()> is approximately four times faster. Both respects the Perl built-in C<srand()>.
=cut
sub mix {
if(@_==1 and ref($_[0]) eq 'ARRAY'){ #just one arg, and its ref array
my $r=$_[0];
$req[0]||=\&pwgendefreq if !$_[2];
$chars=~s/([$_])-([$_])/join("","$1".."$2")/eg for ('a-z','A-Z','0-9');
my($c,$t,@pw,$d)=(length($chars),time_fp());
($Pwgen_trials,$Pwgen_sec)=(0,0);
TRIAL:
while(@pw<$num){
croak "pwgen timeout after $Pwgen_trials trials"
if ++$Pwgen_trials >= $Pwgen_max_trials
or ($d=time_fp()-$t) > $Pwgen_max_sec*$num
and $d!~/^\d+$/; #jic int from time_fp
my $pw=join"",map substr($chars,rand($c),1),1..$len;
for my $r (@req){
if (ref($r) eq 'CODE' ){ local$_=$pw; &$r() or next TRIAL }
elsif(ref($r) eq 'Regexp'){ no warnings; $pw=~$r or next TRIAL }
else { croak "pwgen: invalid req type $r ".ref($r) }
}
push@pw,$pw;
}
$Pwgen_sec=time_fp()-$t;
return $pw[0] if $num==1;
return @pw;
one of each value. This is the same as L</uniq> except uniq does not
sort the returned list.
Example:
print join(", ", distinct(4,9,3,4,"abc",3,"abc")); # 3, 4, 9, abc
print join(", ", distinct(4,9,30,4,"abc",30,"abc")); # 30, 4, 9, abc note: alphanumeric sort
=cut
sub distinct { sort keys %{{map {($_,1)} @_}} }
=head2 in
Returns I<1> (true) if first argument is in the list of the remaining arguments. Uses the perl-operator C<< eq >>.
Otherwise it returns I<0> (false).
print in( 5, 1,2,3,4,6); # 0
print in( 4, 1,2,3,4,6); # 1
print in( 'a', 'A','B','C','aa'); # 0
Input: Two arrayrefs. (Two lists, that is)
Output: An array containing all elements from both input lists, but no element more than once even if it occurs twice or more in the input.
Example, prints 1,2,3,4:
perl -MAcme::Tools -le 'print join ",", union([1,2,3],[2,3,3,4,4])' # 1,2,3,4
=cut
sub union { my %seen; grep !$seen{$_}++, map @{shift()},@_ }
=head2 minus
Input: Two arrayrefs.
Output: An array containing all elements in the first input array but not in the second.
Example:
perl -MAcme::Tools -le 'print join " ", minus( ["five", "FIVE", 1, 2, 3.0, 4], [4, 3, "FIVE"] )'
Output is C<< five 1 2 >>.
=cut
sub minus {
my %seen;
my %notme=map{($_=>1)}@{$_[1]};
grep !$notme{$_}&&!$seen{$_}++, @{$_[0]};
}
=head2 intersect
Input: Two arrayrefs
Output: An array containing all elements which exists in both input arrays.
Example:
perl -MAcme::Tools -le 'print join" ", intersect( ["five", 1, 2, 3.0, 4], [4, 2+1, "five"] )' # 4 3 five
Output: C<< 4 3 five >>
=cut
sub intersect {
my %first=map{($_=>1)}@{$_[0]};
my %seen;
return grep{$first{$_}&&!$seen{$_}++}@{$_[1]};
}
=head2 not_intersect
Input: Two arrayrefs
Output: An array containing all elements member of just one of the input arrays (not both).
B<Input:> array of hashes
B<Output:> array of arrays
Opposite of L</a2h>
=cut
sub a2h {
my @col=@{shift@_};
map { my%h;@h{@col}=@$_;\%h} @_;
}
sub h2a {
my %c;
map $c{$_}++, keys%$_ for @_;
my @c=sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c;
(\@c,map[@$_{@c}],@_);
}
=head1 COMPRESSION
L</zipb64>, L</unzipb64>, L</zipbin>, L</unzipbin>, L</gzip>, and L</gunzip>
compresses and uncompresses strings to save space in disk, memory,
database or network transfer. Trades time for space. (Beware of wormholes)
=head2 zipb64
sub webparams {
my $query=shift();
$query=$ENV{QUERY_STRING} if !defined $query;
if(!defined $query and $ENV{REQUEST_METHOD} eq "POST"){
read(STDIN,$query , $ENV{CONTENT_LENGTH});
$ENV{QUERY_STRING}=$query;
}
my %R;
for(split("&",$query)){
next if !length($_);
my($nkl,$verdi)=map urldec($_),split("=",$_,2);
$R{$nkl}=exists$R{$nkl}?"$R{$nkl},$verdi":$verdi;
}
return %R;
}
=head2 urlenc
Input: a string
Output: the same string URL encoded so it can be sent in URLs or POST requests.
sub ht2t {
my($f,$s,$r)=@_; 1>@_||@_>3 and croak; $s='' if @_==1;
$f=~s,.*?($s).*?(<table.*?)</table.*,$2,si;
my $e=0;$e++ while index($f,$s=chr($e))>=$[;
$f=~s/<t(d|r|h).*?>/\l$1$s/gsi;
$f=~s/\s*<.*?>\s*/ /gsi;
my @t=split("r$s",$f);shift @t;
$r||=sub{s/&(#160|nbsp);/ /g;s/&/&/g;s/^\s*(.*?)\s*$/$1/s;
s/(\d) (\d)/$1$2/g if /^[\d \.\,]+$/};
for(@t){my @r=split/[dh]$s/;shift@r;$_=[map{&$r;$_}@r]}
@t;
}
=head1 FILES, DIRECTORIES
=head2 writefile
Justification:
Perl needs three or four operations to make a file out of a string:
B<Input:>
Name of a directory.
B<Output:>
A list of all files in it, except of C<.> and C<..> (on linux/unix systems, all directories have a C<.> and C<..> directory).
The names of all types of files are returned: normal files, directories, symbolic links,
pipes, semaphores. That is every thing shown by C<ls -la> except C<.> and C<..>
C<readdirectory> do not recurce down into subdirectories (but see example below).
B<Example:>
my @files = readdirectory("/tmp");
B<Why readdirectory?>
Sometimes calling the built ins C<opendir>, C<readdir> and C<closedir> seems a tad tedious, since this:
my $dir="/usr/bin";
opendir(D,$dir);
my @files=map "$dir/$_", grep {!/^\.\.?$/} readdir(D);
closedir(D);
Is the same as this:
my @files=readdirectory("/usr/bin");
See also: L<File::Find>
B<Why not readdirectory?>
file slurping. On the other side it's also a good practice to never
assume to much on available memory and the number of files if you
don't know for certain that enough memory is available whereever your
code is run or that the size of the directory is limited.
B<Example:>
How to get all files in the C</tmp> directory including all subdirectories below of any depth:
my @files=("/tmp");
map {-d $_ and unshift @files,$_ or push @files,$_} readdirectory(shift(@files)) while -d $files[0];
...or to avoid symlinks and only get real files:
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
$ENV{PATH} containing an executable file gzip. Dirs /usr/bin, /bin and
/usr/local/bin is added to PATH in openstr(). They are checked even if
PATH is empty.
See also C<writefile()> and C<readfile()> for automatic compression and decompression using C<openstr>.
=cut
our @Openstrpath=(grep$_,split(":",$ENV{PATH}),qw(/usr/bin /bin /usr/local/bin));
our $Magic_openstr=1;
sub openstr_prog { @Openstrpath or return $_[0];(grep -x$_, map "$_/$_[0]", @Openstrpath)[0] or croak"$_[0] not found" }
sub openstr {
my($fn,$ext)=(shift()=~/^(.*?(?:\.(t?gz|bz2|xz))?)$/i);
return $fn if !$ext or !$Magic_openstr;
$fn =~ /^\s*>/
? "| ".(openstr_prog({qw/gz gzip bz2 bzip2 xz xz tgz gzip/ }->{lc($ext)})).$fn
: openstr_prog({qw/gz zcat bz2 bzcat xz xzcat tgz zcat/}->{lc($ext)})." $fn |";
}
=head2 printed
'DG' => [6, 'Søn','MAN','TIR','ONS','TOR','FRE','LØR'],
'Dg' => [6, 'SØn','Man','Tir','Ons','Tor','Fre','Lør'],
'dg' => [6, 'søn','man','tir','ons','tor','fre','lør'],
);
my $_tms_inited=0;
sub tms_init {
return if $_tms_inited++;
for(qw(MAANED Maaned maaned MAAN Maan maan),'MAANE.','Maane.','maane.'){
$Tms_str{$_}=$Tms_str{replace($_,"aa","Ã¥","AA","Ã…")};
}
$Tms_pattern=join("|",map{quotemeta($_)}
sort{length($b)<=>length($a)}
keys %Tms_str);
#without sort "måned" could be "mared" because "mån"=>"mar"
}
sub totime {
}
=head2 s2t
$s=~s/\bjuni\b/June/i;
}
elsif($s =~ /^[19]\d{9}$/){ $s=localtime($s) } #hm, make faster
elsif($s =~ /^[19]\d{12}$/
and int($s/1000) =~ /^[19]\d{9}$/){ $s=localtime($s/1000) } #hm
elsif($s=~/^((?:17|18|19|20|21)\d\d)(0[1-9]|1[012])(0[1-9]|[12]\d|3[01])$/){#hm
$s="$1-$2-$3T00:00:00";
}
return Date::Parse::str2time($s) if !@_;
return tms(Date::Parse::str2time($s),shift(@_)) if 0+@_ == 1;
return map tms(Date::Parse::str2time($s),$_), @_;
}
sub date_ok {
my($y,$m,$d)=@_;
return date_ok($1,$2,$3) if @_==1 and $_[0]=~/^(\d{4})(\d\d)(\d\d)$/;
return 0 if $y!~/^\d\d\d\d$/;
return 0 if $m<1||$m>12||$d<1||$d>(31,$y%4||$y%100==0&&$y%400?28:29,31,30,31,30,31,31,30,31,30,31)[$m-1];
return 1;
}
Valid for any Gregorian year. Dates repeat themselves after 70499183
lunations = 2081882250 days = ca 5699845 years. However, our planet will
by then have a different rotation and spin time...
Example:
( $day, $month ) = easter( 2012 ); # $day == 8 and $month == 4
Example 2:
my @e=map sprintf("%02d%02d", reverse(easter($_))), 1800..300000;
print "First: ".min(@e)." Last: ".max(@e)."\n"; # First: 0322 Last: 0425
Note: The Spencer Jones formula differs Oudins used in C<easter()> in some years
before 1498. However, in that period the Julian calendar with a different formula was
used anyway. Countries introduced the current Gregorian calendar between 1583 and 1926.
=cut
sub easter { use integer;my$Y=shift;my$C=$Y/100;my$L=($C-$C/4-($C-($C-17)/25)/3+$Y%19*19+15)%30;
(($L-=$L>28||($L>27?1-(21-$Y%19)/11:0))-=($Y+$Y/4+$L+2-$C+$C/4)%7)<4?($L+28,3):($L-3,4) }
=cut
our %Eta;
our $Eta_forgetfulness=2;
sub eta {
my($id,$pos,$end,$time_fp)=( @_==2 ? (join(";",caller()),@_) : @_ );
$time_fp||=time_fp();
my $a=$Eta{$id}||=[];
push @$a, [$pos,$time_fp];
@$a=@$a[map$_*2,0..@$a/2] if @$a>40; #hm 40
splice(@$a,-2,1) if @$a>1 and $$a[-2][0]==$$a[-1][0]; #same pos as last
return undef if @$a<2;
my @eta;
for(2..@$a){
push @eta, $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-$_][1])/($$a[-1][0]-$$a[-$_][0]);
}
my($sum,$sumw,$w)=(0,0,1);
for(@eta){
$sum+=$w*$_;
$sumw+=$w;
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
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<¤>.
8 1 0.17
9 1 1.63
10 1 17.00
If the first argument is a coderef, that sub will be called for each permutation and the return from those calls with be the real return from C<permutations()>. For example this:
print for permutations(sub{join"",@_},1..3);
...will print the same as:
print for map join("",@$_), permutations(1..3);
...but the first of those two uses less RAM if 3 has been say 9.
Changing 3 with 10, and many computers hasn't enough memory
for the latter.
The examples prints:
123
132
213
L<String::Similarity> if you can not be certain what is first, middle
and last names. In foreign or unfamiliar names it can be difficult to
know that.
=cut
#TODO: see t/test_perm.pl and t/test_perm2.pl
sub permutations {
my $code=ref($_[0]) eq 'CODE' ? shift() : undef;
$code and @_<6 and return map &$code(@$_),permutations(@_);
return [@_] if @_<2;
return ([@_[0,1]],[@_[1,0]]) if @_==2;
return ([@_[0,1,2]],[@_[0,2,1]],[@_[1,0,2]],
[@_[1,2,0]],[@_[2,0,1]],[@_[2,1,0]]) if @_==3;
return ([@_[0,1,2,3]],[@_[0,1,3,2]],[@_[0,2,1,3]],[@_[0,2,3,1]],
[@_[0,3,1,2]],[@_[0,3,2,1]],[@_[1,0,2,3]],[@_[1,0,3,2]],
my $p = $#i || last;
--$p || last while $i[$p-1] > $i[$p];
push @i, reverse splice @i, my$q=$p;
++$q while $i[$p-1] > $i[$q];
@i[$p-1,$q] = @i[$q,$p-1];
}
@r
}
sub permute (&@) {
return permute_continue(@_) if 'CODE,ARRAY,ARRAY' eq join',',map ref,@_;
my $f = shift;
my @i = 0..$#_;
my $n = 0;
@_ || do{ &$f(@_); return 0 };
while ( ++$n and &$f(@_[@i]) ) {
my $p = $#i || last;
--$p || last while $i[$p-1] > $i[$p];
push @i, reverse splice @i, my$q=$p;
++$q while $i[$p-1] > $i[$q];
@i[$p-1,$q] = @i[$q,$p-1];
}
}
}
B<Examples, from the tests:>
my @a1 = (1,2);
my @a2 = (10,20,30);
my @a3 = (100,200,300,400);
my $s = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3);
ok( $s eq "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200"
."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400"
."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200"
."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400");
$s=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0});
ok( $s eq "*1,10,100*1,10,400*1,20,300*1,30,200*2,10,300*2,20,200*2,30,100*2,30,400");
B<Example, hash-mode:>
Returns hashrefs instead of arrayrefs:
my @cards=cart( # @card gets 5200 hashrefs, 100 decks of 52 cards
deck => [1..100],
rank => [qw(2 3 4 5 6 7 8 9 10 J Q K A)],
suit => [qw(heart diamond club star)],
}
Note: using sub-ref filters do not work (yet) in hash-mode. Use grep on result instead.
=cut
sub cart {
my @ars=@_;
if(!ref($_[0])){ #if hash-mode detected
my(@k,@v); push@k,shift@ars and push@v,shift@ars while @ars;
return map{my%h;@h{@k}=@$_;\%h}cart(@v);
}
my @res=map[$_],@{shift@ars};
for my $ar (@ars){
@res=grep{&$ar(@$_)}@res and next if ref($ar) eq 'CODE';
@res=map{my$r=$_;map{[@$r,$_]}@$ar}@res;
}
return @res;
}
sub cart_easy { #not tested, not exported http://stackoverflow.com/questions/2457096/in-perl-how-can-i-get-the-cartesian-product-of-multiple-sets
my $last = pop @_;
@_ ? (map {my$left=$_; map [@$left, $_], @$last } cart_easy(@_) )
: (map [$_], @$last);
}
=head2 reduce
From: Why Functional Programming Matters: L<http://www.md.chalmers.se/~rjmh/Papers/whyfp.pdf> L<http://www.cse.chalmers.se/~rjmh/Papers/whyfp.html>
L<http://www.md.chalmers.se/~rjmh/Papers/whyfp.html>
DON'T TRY THIS AT HOME, C PROGRAMMERS.
1997 Hilde 168 164 62 61
1997 Per 182 180 75 73
1997 Tone 70 69
1998 Gerd 171 171 64 64
1998 Hilde 168 168 62 62
1998 Per 182 183 76 74
1998 Tone 70 71
.
my @reportB=pivot([map{$_=[@$_[0,3,2,1,4]]}(@t=@table)],"Year","Season");
print "\n\nReport B\n\n".tablestring(\@reportB);
Will print:
Report B
Year Season Height Height Height Weight Weight Weight Weight
Gerd Hilde Per Gerd Hilde Per Tone
---- ------ ------ ------ ----- ----- ------ ------ ------
1997 Summer 170 168 182 66 62 75 70
1997 Winter 158 164 180 64 61 73 69
1998 Summer 171 168 182 64 62 76 70
1998 Winter 171 168 183 64 62 74 71
.
my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attributt");
print "\n\nReport C\n\n".tablestring(\@reportC);
Will print:
Report C
Name Attributt 1997 1997 1998 1998
Summer Winter Summer Winter
----- --------- ------ ------ ------ ------
Gerd Height 170 158 171 171
Gerd Weight 66 64 64 64
Hilde Height 168 164 168 168
Hilde Weight 62 61 62 62
Per Height 182 180 182 183
Per Weight 75 73 76 74
Tone Weight 70 69 70 71
.
my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name");
print "\n\nReport D\n\n".tablestring(\@reportD);
Will print:
Report D
Name Height Height Height Height Weight Weight Weight Weight
1997 1997 1998 1998 1997 1997 1998 1998
Summer Winter Summer Winter Summer Winter Summer Winter
----- ------ ------ ------ ------ ------ ------ ------ ------
if($opt_sum or defined $opt_pro){
$h{$rad}{Sum}+=$verdi;
$sum{$felt}+=$verdi;
$sum{Sum}+=$verdi;
}
$feltfinnes{$felt}++;
$feltfinnes{"%$felt"}++ if $opt_pro;
}
my @feltfinnes = sort $sortsub_bortover keys%feltfinnes;
push @feltfinnes, "Sum" if $opt_sum;
my @t=([@vertikalefelt,map{replace($_,$;,"\n")}@feltfinnes]);
#print serialize(\@feltfinnes,'feltfinnes');
#print serialize(\%h,'h');
#print "H = ".join(", ",sort _sortsub keys%h)."\n";
for my $rad (sort $sortsub_nedover keys(%h)){
my @rad=(split($;,$rad),
map { defined($_)?$_:exists$opt{undefined}?$opt{undefined}:undef }
map {
if(/^\%/ and defined $opt_pro){
my $sum=$h{$rad}{Sum};
my $verdi=$h{$rad}{$_};
if($sum!=0){
defined $verdi
?sprintf("%*.*f",3+1+$opt_pro,$opt_pro,100*$verdi/$sum)
:$verdi;
}
else{
$verdi!=0?"div0":$verdi;
}
}
else{
$h{$rad}{$_};
}
}
@feltfinnes);
push(@t,[@rad]);
}
push(@t,"-",["Sum",(map{""}(2..$antned)),map{print "<$_>\n";$sum{$_}}@feltfinnes]) if $opt_sum;
return @t;
}
# default sortsub for pivot()
sub _sortsub {
no warnings;
#my $c=($a<=>$b)||($a cmp $b);
#return $c if $c;
#printf "%-30s %-30s ",replace($a,$;,','),replace($b,$;,',');
}
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+$_;
Toyota SUM 56
Volvo SUM 18
Nissan SUM 36
Tesla SUM 8
SUM SUM 56 100%
=cut
sub cnttbl {
my $hr=shift;
my $maxlen=max(3,map length($_),keys%$hr);
join"",ref((values%$hr)[0])
?do{ map {my$o=$_;join("",map rpad($$o[0],$maxlen)." $_\n",split("\n",$$o[1]))}
map [$_,cnttbl($$hr{$_})],
sort keys%$hr }
:do{ my $sum=sum(values%$hr);
my $fmt=repl("%-xs %yd %6.2f%%\n",x=>$maxlen,y=>length($sum));
map sprintf($fmt,@$_,100*$$_[1]/$sum),
(map[$_,$$hr{$_}],sort{$$hr{$a}<=>$$hr{$b} or $a cmp $b}keys%$hr),
(['SUM',$sum]) }
}
=head2 ref_deep
NOT IMPLEMENTED
Same as ref, but goes deeper.
print ref_deep( { 10=>[1,'ten'], 100=>[2,'houndred'], 1000=>[3,'thousand'] } ); # prints HASH_of_ARRAYS
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;
min_hashfuncs => 1,
max_hashfuncs => 100,
counting_bits => 1, #default: not counting filter
adaptive => 0,
%arg, #arguments
key_count => 0,
overflow => {},
version => $Acme::Tools::VERSION,
};
croak "Error rate ($$bf{error_rate}) should be larger than 0 and smaller than 1" if $$bf{error_rate}<=0 or $$bf{error_rate}>=1;
@$bf{'min_hashfuncs','max_hashfuncs'}=(map$arg{hashfuncs},1..2) if $arg{hashfuncs};
@$bf{'filterlength','hashfuncs'}=bfdimensions($bf); #m and k
$$bf{filter}=pack("b*", '0' x ($$bf{filterlength}*$$bf{counting_bits}) ); #hm x new empty filter
$$bf{unpack}= $$bf{filterlength}<=2**16/4 ? "n*" # /4 alleviates skewing if m just slightly < 2**x
:$$bf{filterlength}<=2**32/4 ? "N*"
: "Q*";
bfadd($bf,@{$arg{keys}}) if $arg{keys};
return $bf;
}
sub bfaddbf {
my($bf,$bf2)=@_;
my $differror=join"\n",
map "Property $_ differs ($$bf{$_} vs $$bf2{$_})",
grep $$bf{$_} ne $$bf2{$_},
qw/capacity counting_bits adaptive hashfuncs filterlength/; #not error_rate
croak $differror if $differror;
croak "Can not add adaptive bloom filters" if $$bf{adaptive};
my $count=$$bf{key_count}+$$bf2{key_count};
croak "Exceeded filter capacity $$bf{key_count} + $$bf2{key_count} = $count > $$bf{capacity}"
if $count > $$bf{capacity};
$$bf{key_count}+=$$bf2{key_count};
if($$bf{counting_bits}==1){
$$bf{filter} |= $$bf2{filter};
return 1;
}
sub bfcheck {
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','counting_bits','adaptive'};
my $wa=wantarray();
if(!$adaptive){ # normal bloom filter or counting bloom filter
return map {
my $match = 1; # match if every bit is on
my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1;
return $match if !$wa;
$match;
} @$keysref;
}
else { # adaptive bloom filter
return map {
my($match,$i,$key,$bit,@h)=(1,0,$_);
for(0..$$bf{filterlength}-1){
$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h;
my $pos=shift(@h) % $m;
$bit=vec($$bf{filter}, $pos, 1);
$match++ if $_ > $k-1 and $bit==1;
$match=0 if $_ <= $k-1 and $bit==0;
last if $bit==0;
}
return $match if !$wa;
$match;
} @$keysref;
}
}
sub bfgrep { # just a copy of bfcheck with map replaced by grep
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'};
return grep {
my $match = 1; # match if every bit is on
my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1;
$match;
my $k=log(1/$p)/log(2); # k hash funcs
my $m=-$n*log($p)/log(2)**2; # m bits in filter
return ($m+0.5,min($maxk,max($mink,int($k+0.5))));
}
#crontab -e
#01 4,10,16,22 * * * /usr/bin/perl -MAcme::Tools -e'Acme::Tools::_update_currency_file("/var/www/html/currency-rates")' > /dev/null 2>&1
sub _update_currency_file { #call from cron
my $fn=shift()||'/var/www/html/currency-rates';
my %exe=map+($_=>"/usr/bin/$_"),qw/curl ci/;-x$_ or croak for values %exe;
open my $F, '>', $fn or die"ERROR: Could not write file $fn ($!)\n";
print $F "#-- Currency rates ".localtime()." (".time().")\n";
print $F "# File generated by Acme::Tools version $VERSION\n";
print $F "# Updated every 6th hour on http://calthis.com/currency-rates\n";
print $F "NOK 1.000000000\n";
my $amount=1000;
my $data=qx($exe{curl} -s "https://www.x-rates.com/table/?from=NOK&amount=$amount");
$data=~s,to=([A-Z]{3})(.)>,$2>$1</td><td>,g;
my @data=ht2t($data,"Alphabetical order"); shift @data;
@data=map "$$_[1] ".($$_[4]>1e-2?$$_[4]:$$_[2]?sprintf("%.8f",$amount/$$_[2]):0)."\n",@data;
my %data=map split,@data;
my $json=qx( $exe{curl} -s https://api.coinmarketcap.com/v1/ticker/ );
eval "require JSON;"; croak if $@;
my $arr=JSON::decode_json($json);
for my $c (qw(BTC LTC XBT ETH XRP BCH ETC)) {
my @a=grep$$_{symbol} eq $c,@$arr;
next if @a != 1 or !$a[0]{price_usd};
push @data, "$c ".($a[0]{price_usd}*$data{USD})."\n";
}
#die srlz(\@data,'data');
print $F sort(@data);
}
our $Fix_unbase64=0;
sub unbase64 ($) {
my $s=shift;
$s=~tr,0-9a-zA-Z+=/,,cd;
if($Fix_unbase64){ $s.='=' while length($s)%4 }
croak "unbase64 failed: length ".length($s)." not multiple of 4" if length($s)%4;
$s=~s/=+$//;
$s=~tr|A-Za-z0-9+/| -_|;
length($s) ? unpack("u",join'',map(chr(32+length($_)*3/4).$_,$s=~/(.{1,60})/gs)) : "";
}
=head1 COMMANDS
=head2 install_acme_command_tools
sudo perl -MAcme::Tools -e install_acme_command_tools
Wrote executable /usr/local/bin/conv
die"$0: -M, -C, -A can not be used together\n" if $o{M}+$o{C}+$o{A}>1;
my(%c,%b,$cnt,$bts,%xtime);
my $zext=$o{z}?'(\.(z|Z|gz|bz2|xz|rz|kr|lrz|rz))?':'';
$o{E}||=11;
my $r=qr/(\.[^\.\/]{1,$o{E}}$zext)$/i;
my $qrexcl=exists$o{e}?qr/$o{e}/:0;
#TODO: ought to work: tar cf - .|tar tvf -|due
my $x=$o{M}?9:$o{C}?10:$o{A}?8:9;
if(-p STDIN or @Due_fake_stdin){
die "due: can not combine STDIN and args\n" if @argv;
my $stdin=join"",map"$_\n",@Due_fake_stdin; #test
open(local *STDIN, '<', \$stdin) or die "ERR: $! $?\n" if $stdin;
my $rl=qr/(^| )\-[rwx\-sS]{9}\s+(?:\d )?(?:[\w\-]+(?:\/|\s+)[\w\-]+)\s+(\d+)\s+.*?([^\/]*\.[\w,\-]+)?$/;
my $MorP=$o{M}||$o{C}||$o{A}||$o{P}?"due: -M, -C, -A and -P not yet implemented for STDIN unless list of filenames only\n":0;
while(<STDIN>){
chomp;
next if /\/$/;
my($f,$sz,$xtime)=(/$rl/?($3,$2):-f$_?($_,(stat)[7,$x]):next);
# 1576142 240 -rw-r--r-- 1 root root 242153 april 4 2016 /opt/wine-staging/share/wine/wine.inf
my $ext=$f=~$r?$1:'';
$ext=lc($ext) if $o{i};
:$o{m}?("%14.2f mb",sub{$_[0]/1024**2})
:$o{h}?("%14s", sub{bytes_readable($_[0])})
: ("%14d b", sub{$_[0]});
my @e=$o{a}?(sort(keys%c))
:$o{c}?(sort{$c{$a}<=>$c{$b} or $a cmp $b}keys%c)
: (sort{$b{$a}<=>$b{$b} or $a cmp $b}keys%c);
my $perc=!$o{M}&&!$o{C}&&!$o{A}&&!$o{P}?sub{""}:
sub{
my @p=$o{P}?(10,50,90):(50);
my @m=@_>0 ? do {grep$_, split",", $xtime{$_[0]}}
: do {grep$_, map {split","} values %xtime};
my @r=percentile(\@p,@m);
@r=(min(@m),@r,max(@m)) if $o{M}||$o{C}||$o{A};
@r=map int($_), @r;
my $fmt=$o{t}?'YYYY/MM/DD-MM:MI:SS':'YYYY/MM/DD';
@r=map tms($_,$fmt), @r;
" ".join(" ",@r);
};
my $width=max( 10, grep $_, map length($_), @e );
@e=@e[-10..-1] if $o{t} and @e>10; #-t tail
printf("%-*s %8d $f %7.2f%%%s\n",$width,$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e;
printf("%-*s %8d $f %7.2f%%%s\n",$width,"Sum",$cnt,&$s($bts),100,&$perc());
}
sub cmd_resubst {
my %o;
my $zo="123456789e";
my @argv=opts("f:t:vno:gi$zo",\%o,@_);
if(exists$o{t}){ $o{t}=~s,\\,\$, } else { $o{t}='' }
my($i,$tc,$tbfr,$tbto)=(0,0,0,0);
for my $file (@argv){
my $zopt=join" ",map"-$_",grep$o{$_},split//,$zo;
my $oext=$o{o}?$o{o}:$file=~/\.(gz|bz2|xz)$/i?$1:'';
my $open_out_pre=$oext?"|".openstr_prog({qw/gz gzip bz2 bzip2 xz xz/}->{lc($oext)})." $zopt":'';
my $open_out="$open_out_pre > $file.tmp$$";
my $open_in=openstr($file);
# die srlz(\%o,'o','',1);
open my $I, $open_in or croak"ERR: open $open_in failed. $! $?\n";
open my $O, $open_out or croak"ERR: open $open_out failed. $! $?\n";
my $c=0;
my $mod=join"",grep$o{$_},qw(g i);
eval"while(<\$I>){ \$c+=s/\$o{f}/$o{t}/$mod;print \$O \$_ }";
for my $fn (@_){
my $os=openstr($fn);
open my $FH, $os or warn "xcat: cannot open $os ($!)\n" and next;
#binmode($FH);#hm?
print while <$FH>;
close($FH);
}
}
sub cmd_freq {
my(@f,$i);
map $f[$_]++, unpack("C*",$_) while <>;
my $s=" " x 12;map{print"$_$s$_$s$_\n"}("BYTE CHAR COUNT","---- ----- -------");
my %m=(145,"DOS-æ",155,"DOS-ø",134,"DOS-å",146,"DOS-Æ",157,"DOS-Ø",143,"DOS-Å",map{($_," ")}0..31);
printf("%4d %5s%8d".(++$i%3?$s:"\n"),$_,$m{$_}||chr,$f[$_]) for grep$f[$_],0..255;print "\n";
my @no=grep!$f[$_],0..255; print "No bytes for these ".@no.": ".join(" ",@no)."\n";
}
sub cmd_deldup {
cmd_finddup('-d',@_);
}
sub cmd_finddup {
# http://www.commandlinefu.com/commands/view/3555/find-duplicate-files-based-on-size-first-then-md5-hash
# die "todo: finddup not ready yet"
my %o;
my @argv=opts("ak:dhsnqv0P:FMRp",\%o,@_); $o{P}=1024*8 if!defined$o{P}; $o{k}='' if!defined$o{k};
croak"ERR: cannot combine -a with -d, -s or -h" if $o{a} and $o{d}||$o{s}||$o{h};
require File::Find;
@argv=map{
my @f;
if(-d$_){ File::Find::find({follow=>0,wanted=>sub{return if !-f$_;push@f,$File::Find::name;1}},$_) }
else { @f=($_) }
@f;
}@argv;
my %md5sum;
my $md5sum=sub{$md5sum{$_[0]}=md5sum($_[0]) if!defined$md5sum{$_[0]}}; #memoize
my $md5sum_1st_part=sub{
open my $fh, "<", $_[0] or die "ERR: Could not read $_[0]";
binmode($fh);
close($fh);
md5sum(\$buf);
};
my @checks=( #todo: stat()[0,1] (or[0,1,7]?) and diff filename => no need for md5, is hardlink! just linux?
sub{-s$_[0]},
sub{-s$_[0]<=$o{P}?md5sum($_[0]):&$md5sum_1st_part($_[0])},
sub{md5sum($_[0])}
);
pop @checks if $o{M}; #4tst
my $i=0;
my %s=map{($_=>++$i)}@argv; #sort
my %f=map{($_=>[$_])}@argv; #also weeds out dupl params
for my $c (@checks){
my @f=map @{$f{$_}}, sort keys %f;
if($o{p} and $c eq $checks[-1]){ #view progress for last check, todo: eta() is wacky here! everywhere?
my $sum=@f?sum(map -s$_,@f):0;
my($corg,$cnt,$cntmb,$mb)=($c,0,0,$sum/1e6);
$c=sub{
$cntmb+=(-s$_[0])/1e6;
my $eol=++$cnt==@f?"\n":"\r";
print STDERR sprintf("%d/%d files checked (%d%%), %d/%d MB (%d%%), ETA in %d sec $eol",
$cnt, 0+@f, 100*$cnt/@f, $cntmb, $mb, 100*$cntmb/$mb,
curb(nvl(eta($cnt,0+@f),time)-time(),0,1e7));
&$corg(@_)
};
}
my %n; push @{$n{&$c($_)}}, $_ for @f;
delete @n{grep@{$n{$_}}<2,keys%n};
%f=%n;
}
return %f if $o{F};
my@r=sort{$s{$$a[0]}<=>$s{$$b[0]}}values%f;
my $si={qw(o 9 n 9 O 8 N 8)}->{$o{k}}; #stat index: 9=mtime, 8=atime
my $sort=lc$o{k} eq 'o' ? sub{sprintf"%011d%9d", (stat($_[0]))[$si],$s{$_[0]}}
:lc$o{k} eq 'n' ? sub{sprintf"%011d%9d",1e11-(stat($_[0]))[$si],$s{$_[0]}}
: sub{sprintf "%9d", $s{$_[0]}};
@$_=map$$_[1],sort{$$a[0]cmp$$b[0]}map[&$sort($_),$_],@$_ for @r;
my %of; #dup of
for my $r (@r){
$of{$_}=$$r[0] for @$r[1..$#$r];
}
my $nl=$o{0}?"\x00":"\n";
my $print=sub{$o{q} or print $_[0]};
my $do=sub{ $o{v} && &$print("$_[0]$nl"); qx($_[0]) };
my $go=sub{ $o{n} ? &$print("$_[0]$nl") : &$do($_[0]) };
&$print(join$nl,map join("",map"$_$nl",@$_),@r) and return if $o{a};
@r=map@$_[1..$#$_],@r;
return @r if $o{R}; #hm
unlink@r if $o{d}||$o{s}||$o{h} and !$o{n}; #delete duplicates
map &$go(qq(rm "$_") ),@r if $o{d}&& $o{n}; #delete duplicates, dryrun
map &$go(qq(ln "$of{$_}" "$_")),@r if $o{h}; #replace duplicates with hardlink
map &$go(qq(ln -s "$of{$_}" "$_")),@r if $o{s}; #replace duplicates with symlink,
#todo: BUG! abc/def/file -> ghi/file should be abc/def/file -> ../../ghi/file
return if $o{q} or $o{n}; #quiet or dryrun
&$print("$_$nl") for @r;
}
#http://stackoverflow.com/questions/11900239/can-i-cache-the-output-of-a-command-on-linux-from-cli
our $Ccmd_cache_dir='/tmp/acme-tools-ccmd-cache';
our $Ccmd_cache_expire=15*60; #default 15 minutes
sub cmd_ccmd {
require Digest::MD5;
my $cmd=join" ",@_;
my $d="$Ccmd_cache_dir/".username();
makedir($d);
my $md5=Digest::MD5::md5_hex($cmd);
my($fno,$fne)=map"$d/cmd.$md5.std$_","out","err";
my $too_old=sub{time()-(stat(shift))[9] >= $Ccmd_cache_expire};
unlink grep &$too_old($_), <$d/*.std???>;
sys("($cmd) > $fno 2> $fne") if !-e$fno or &$too_old($fno);
print STDOUT "".readfile($fno);
print STDERR "".readfile($fne);
}
sub cmd_trunc { die "todo: trunc not ready yet"} #truncate a file, size 0, keep all other attr
#todo: wipe -n 4 filer* #virker ikke! tror det er args() eller opts() som ikke virker
#todo: sub cmd_7z
#todo: .tgz same as .tar.gz (but not .tbz2/.txz)
sub cmd_z2z {
my %o;
my $pvopts="L:D:i:lIq";
my @argv=opts("pt:kvhon123456789es:$pvopts",\%o,@_);
my $t=repl(lc$o{t},qw/gzip gz bzip2 bz2/);
die "due: unknown compression type $o{t}, known are gz, bz2 and xz" if $t!~/^(gz|bz2|xz)$/;
$o{p}=1 if!defined$o{p} and grep$pvopts=~/$_/,keys%o;
delete $o{e} if $o{e} and $o{t} ne 'xz' and warn "-e available only for type xz\n";
my $sum=sum(map -s$_,@argv);
print "Converting ".@argv." files, total ".bytes_readable($sum)."\n" if $o{v} and @argv>1;
my $cat='cat';
if($o{p}){ if(which('pv')){ $cat='pv' } else { warn repl(<<"",qr/^\s+/) } }
due: pv for -p not found, install with sudo yum install pv, sudo apt-get install pv or similar
$o{$_} and $o{$_}=" " for qw(l q); #still true, but no cmd arg for:
$o{I} and $o{I}="-pterb";
exists$o{$_} and $cat=~s,pv,pv -$_ $o{$_}, for $pvopts=~/(\w)/g; #warn "cat: $cat\n";
my $sumnew=0;
my $start=time_fp();
my($i,$bsf)=(0,0);#bytes so far
$Eta{'z2z'}=[];eta('z2z',0,$sum);
#@argv=map$$_[1],sort{$$a[0]cmp$$b[0]}map{[$opt{
for(@argv){
my $new=$_; $new=~s/(\.(gz|bz2|xz))?$/.$t/i or die;
my $ext=defined($2)?lc($2):'';
my $same=/^$new$/; $new.=".tmp" if $same; die if $o{k} and $same;
next if !-e$_ and warn"$_ do not exists\n";
next if !-r$_ and warn"$_ is not readable\n";
next if -e$new and !$o{o} and warn"$new already exists, skipping (use -o to overwrite)\n";
my $unz={qw/gz gunzip bz2 bunzip2 xz unxz/}->{$ext}||'';
#todo: my $cntfile="/tmp/acme-tools-z2z-wc-c.$$";
#todo: my $cnt="tee >(wc -c>$cntfile)" if $ENV{SHELL}=~/bash/ and $o{v}; #hm dash vs bash
my $z= {qw/gz gzip bz2 bzip2 xz xz/}->{$t};
$z.=" -$_" for grep$o{$_},1..9,'e';
$z.=" -$_ $o{$_}" for grep exists$o{$_},'L';
my $cmd=qq($cat "$_"|$unz|$z>"$new");
#todo: "$cat $_|$unz|$cnt|$z>$new";
#cat /tmp/kontroll-linux.xz|unxz|tee >(wc -c>/tmp/p)|gzip|wc -c;cat /tmp/p
$cmd=~s,\|+,|,g; #print "cmd: $cmd\n";
sys($cmd);
chall($_,$new) or croak("$0 cannot chmod|chown|touch $new") if !$o{n};
my($szold,$sznew)=map{-s$_}($_,$new);
$bsf+=-s$_;
unlink $_ if !$o{k};
rename($new, replace($new,qr/.tmp$/)) or die if $same;
if($o{v}){
$sumnew+=$sznew;
my $pr=sprintf"%0.1f%%",$szold?100*$sznew/$szold:0;
#todo: my $szuncmp=-s$cntfile&&time()-(stat($cntfile))[9]<10 ? qx(cat $cntfile) : '';
#todo: $o{h} ? printf("%6.1f%% %9s => %9s => %9s %s\n", $pr,(map bytes_readable($_),$szold,$szuncmp,$sznew),$_)
#todo: : printf("%6.1f%% %11d b => %11d b => %11 b %s\n",$pr,$szold,$szuncmp,$sznew,$_)
my $str= $o{h}
? sprintf("%-7s %9s => %9s", $pr,(map bytes_readable($_),$szold,$sznew))
: sprintf("%-7s %11d b => %11d b", $pr,$szold,$sznew);
if(@argv>1){
$i++;
$str=$i<@argv
? " ETA:".sprintf("%-8s",sec_readable(eta('z2z',$bsf,$sum)-time_fp()))." $str"
: " TA: 0s $str"
if $sum>1e6;
$str="$i/".@argv." $str";
}
print "$str $new\n";
}
}
if($o{v} and @argv>1){
my $bytes=$o{h}?'':'bytes ';
my $str=
sprintf "%d files compressed in %.3f seconds from %s to %s $bytes (%s bytes) %.1f%% of original\n",
0+@argv,
time_fp()-$start,
(map{$o{h}?bytes_readable($_):$_}($sum,$sumnew,$sumnew-$sum)),
100*$sumnew/$sum;
$str=~s,\((\d),(+$1,;
print $str;
}
}
=head2 args
Parses command line options and arguments:
croak "ERR: second arg to args() not hashref\n" if ref($hashref) ne 'HASH';
local @ARGV=@_;
require Getopt::Std;
Getopt::Std::getopts($switches => $hashref);
(@ARGV);
}
sub opts {
my($def, $hashref, @a)=@_;
@a=@ARGV if @_<=2;
my %def=map{/(\w)(:?)/;($1=>$2?2:1)}$def=~/(\w:?)/g;
my $o1=join"",grep$def{$_}==1,sort keys%def;
my $o= join"", sort keys%def;
my @r;
while(@a){
my $a=shift(@a);
if($a=~/^-([$o1])([$o].*)$/){
unshift@a,"-$1","-$2";
}
elsif($a=~/^-(\w)(.*)$/){
my $d=$def{$1}//0;
my $sf=-s$f;
print "--- $f does not exists\n" and next if !-e$f;
print "--- $f is not a file\n" and next if !-f$f;
print "--- $f ($sf b) is not readable\n" and next if !-r$f;
print "--- $sf b ".bytes_readable($sf)." ".($stdin?"-":$f)."\n";
next if !$sf;
my(@t,@s);
for my $prog (@prog){
next if !qx(which $prog);
my @l=1..9;
push @l,map"e$_",1..9 if $prog eq 'xz' and $o{e};
@l=map"e$_",1..9 if $prog eq 'xz' and $o{E};
@l=map 10+$_,@l if $prog eq 'zstd';
@l=map"q $_",3..11 if $prog eq 'brotli';
printf "%-6s",$prog;
push @t, $prog, [] if $o{t};
push @s, $prog, [] if $o{p} and $o{s};
for my $l (@l){ #level
my $t=time_fp();
my $b=qx(cat $f|$prog -$l|wc -c);
push@{$t[-1]},time_fp()-$t if $o{t};
push@{$s[-1]},$b if $o{p} and $o{s};
$o{p} ? printf("%9.1f%% ",100*$b/$sf)
:$o{h} ? printf("%10s ",bytes_readable($b))
Does C<cd> to where Acme/Tools.pm are and then wget -N https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm
TODO: cmd_acme_tools_self_update, accept --no-check-certificate to use on curl
=cut
our $Wget;
our $Self_update_url='https://raw.githubusercontent.com/kjetillll/Acme-Tools/master/Tools.pm'; #todo: change site
sub self_update {
#in($^O,'linux','cygwin') or die"ERROR: self_update works on linux and cygwin only";
$Wget||=(grep -x$_,map"$_/wget",'/usr/bin','/bin','/usr/local/bin','.')[0]; #hm --no-check-certificate
-x$Wget or die"ERROR: wget ($Wget) executable not found\n";
my $d=dirname(__FILE__);
sys("cd $d; ls -l Tools.pm; md5sum Tools.pm");
sys("cd $d; $Wget -N ".($ARGV[0]||$Self_update_url));
sys("cd $d; ls -l Tools.pm; md5sum Tools.pm");
}
1;
package Acme::Tools::BloomFilter;
t/02_general.t view on Meta::CPAN
ok(avg(2,4,9)==5, 'avg 2 4 9 is 5');
ok(avg([2,4,9])==5, 'avg 2 4 9 is 5');
ok(avg(2,4,9,undef)==5, 'avg ignore undef');
ok(0==0+grep{abs(geomavg($_,$_)-$_)>1e-8}range(3,10000,13));
ok(abs(geomavg(2,3,4,5)-3.30975091964687)<1e-11);
ok(abs(geomavg(10,100,1000,10000,100000)-1000)<1e-8);
ok(!defined(avg(undef)));
#--stddev
ok(stddev(12,13,14)>0);
ok(between(stddev(map { avg(map rand(),1..100) } 1..100), 0.02, 0.04));
ok(!defined(stddev()));
for((1,10,100)){ my @a=map rand(),1..$_; ok(stddev(@a) == stddev(\@a),'stddev: not ref vs ref') }
#print map"$_\n", sort {$a<=>$b} map stddev(map { avg(map rand(),1..100) } 1..100), 1..1000;
#--median
ok(median(2,3,4,5,6)==4);
ok(median(2,3,4,5)==3.5);
ok(median(2)==2);
ok(median(reverse(1..10000))==5000.5);
ok(median( 1, 4, 6, 7, 8, 9, 22, 24, 39, 49, 555, 992 ) == 15.5 );
ok(not defined median(undef));
#--percentile
t/02_general.t view on Meta::CPAN
ok( btw(1,'02',13) ,'btw f'); # leading zero in '02' leads to alphabetical order
ok( btw(10, 012,10) ,'btw h'); # leading zero here means oct number, 012 = 10 (8*1+2), so 10 is btw 10 and 10
ok(!btw('003', '02', '09') ,'btw i'); #
ok(!btw('a', 'b', 'c') ,'btw j'); #
ok( btw('a', 'B', 'c') ,'btw k'); #
ok( btw('a', 'c', 'B') ,'btw l'); #
ok( btw( -1, -2, 1) ,'btw m');
ok( btw( -1, -2, 0) ,'btw n');
ok( btw( -1, -2, '0e0') ,'btw o');
#my($btw,$btw2)=(0,0);
#my @errs=grep{my@a=map rand(),1..3;$btw++ if btw(@a);$btw2++ if btw2(@a);btw(@a)!=btw2(@a)}1..1000;
#ok( !@errs, "btw2==btw, btw=$btw btw2=$btw2" );
#use Benchmark qw(:all) ;
#cmpthese(1e5, { btw => sub { btw(rand(),rand(),rand()) },
# btw2=> sub { btw2(rand(),rand(),rand()) } }); exit;
#--curb
my $vb = 234;
ok( curb( $vb, 200, 250 ) == 234, 'curb 1');
ok( curb( $vb, 150, 200 ) == 200, 'curb 2');
ok( curb( $vb, 250, 300 ) == 250 && $vb==234, 'curb 3');
t/02_general.t view on Meta::CPAN
eval{in_iprange('100.255.255.255','100.255.255.0/22')}; ok( $@=~m|need zero in last 10 bits, should be 100.255.252.0/22|, 'in_iprange, need zero in last 10...' );
ok( in_iprange('255.255.255.255','255.255.255.0/24'), 'in_iprange' );
ok( in_iprange('255.255.255.254','255.255.254.0/23'), 'in_iprange' );
ok( in_iprange('100.255.255.255','100.255.254.0/23'), 'in_iprange, yes' );
ok( in_iprange('100.255.254.0','100.255.254.0/23'), 'in_iprange, y' );
ok( in_iprange('100.255.255.0','100.255.254.0/23'), 'in_iprange, y' );
ok(!in_iprange('100.255.0.1','100.254.254.0/23'), 'in_iprange, n' );
ok( in_iprange('100.255.0.1','100.255.0.1'), 'in_iprange, same' );
ok( in_iprange('100.255.0.1','100.255.0.1/32'), 'in_iprange, same/32' );
ok( in_iprange('0.0.0.1','0.0.0.0/1'), 'in_iprange, /1' );
ok( in_iprange(join('.',map int(rand(256)),1..4),'0.0.0.0/0'), 'in_iprange, /0' );
#--webparams, urlenc, urldec
my $s=join"",map random([qw/hip hop and you dont stop/]), 1..1000;
my %in=("\n&pi=3.14+0\n\n"=>gz($s x 5),123=>123321);
my %out=webparams(join("&",map{urlenc($_)."=".urlenc($in{$_})}sort keys%in));
ok_ref( \%in, \%out, 'webparams 1' );
ok_ref( $a={webparams("b=123&a=1&b=122&a=3&a=2%20")},{a=>'1,3,2 ',b=>'123,122'}, 'webparams 2' );undef$a;
#--chall
my $tmp=tmp();
if($^O eq 'linux' and -w$tmp){
my $f1="$tmp/tmpf1";
my $f2="$tmp/tmpf2";
chmod(0777,$f1,$f2) and unlink($f1, $f2);
open my $fh1,">",$f1 or die$!;
t/02_general.t view on Meta::CPAN
writefile("$fn.gz",$data);
my $szgz=-s"$fn.gz";
ok($szgz/$sz < 0.1, 'writefile gz');
deb "gz ".($szgz/$sz);
ok(readfile("$fn.gz") eq $data, 'readfile gz');
unlink("$fn.gz");
}
else{ok(1) for 1..5} # not linux
#--permutations, perm, permutate
ok(join("-", map join("",@$_), permutations('a','b')) eq 'ab-ba', 'permutations 1');
ok(join("-", map join("",@$_), permutations('a'..'c')) eq 'abc-acb-bac-bca-cab-cba','permutations 2');
ok(join("-", map join("",@$_), perm( 'a'..'c')) eq 'abc-acb-bac-bca-cab-cba','perm');
my @p=('a'..'e');
my $permute=printed { print permute{print @_,"\n"}@p };
is($permute, join('',map join('',@$_)."\n", perm(@p)).120,'permute');
my $permute2=printed { print permute{print @_,"\n"}\@p,['b','a','c'] };
my @perm=perm('a'..'c'); splice@perm,0,2;
is($permute2, join('',map join('',@$_)."\n", @perm).4,'permute start at');
#--trigram
ok( join(", ",trigram("Kjetil Skotheim")) eq 'Kje, jet, eti, til, il , l S, Sk, Sko, kot, oth, the, hei, eim', 'trigram');
ok( join(", ",trigram("Kjetil Skotheim", 4)) eq 'Kjet, jeti, etil, til , il S, l Sk, Sko, Skot, koth, othe, thei, heim','trigram');
#--sliding
ok_ref([sliding(["Reven","rasker","over","isen"],2)],
[['Reven','rasker'],['rasker','over'],['over','isen']], 'sliding' );
#--chunks
ok_ref( [chunks("Reven rasker over isen",7)],['Reven r','asker o','ver ise','n'] , 'chunks string' );
ok_ref( [chunks([qw/Og gubben satt i kveldinga og koste seg med skillinga/], 3)],
[['Og','gubben','satt'],['i','kveldinga','og'],['koste','seg','med'],['skillinga']] , 'chunks array' );
#--cart
my @a1 = (1,2);
my @a2 = (10,20,30);
my @a3 = (100,200,300,400);
my $ss = join"", map "*".join(",",@$_), cart(\@a1,\@a2,\@a3);
ok( $ss eq "*1,10,100*1,10,200*1,10,300*1,10,400*1,20,100*1,20,200"
."*1,20,300*1,20,400*1,30,100*1,30,200*1,30,300*1,30,400"
."*2,10,100*2,10,200*2,10,300*2,10,400*2,20,100*2,20,200"
."*2,20,300*2,20,400*2,30,100*2,30,200*2,30,300*2,30,400");
$ss=join"",map "*".join(",",@$_), cart(\@a1,\@a2,\@a3,sub{sum(@$_)%3==0});
ok( $ss eq "*1,10,100*1,10,400*1,20,300*1,30,200*2,10,300*2,20,200*2,30,100*2,30,400", 'cart - array mode');
my @ch= cart(a=>[1..3],b=>[1..2],c=>[1..4]);
my @ca=map{my($a,$b,$c)=@$_;{a=>$a,b=>$b,c=>$c}}cart( [1..3], [1..2], [1..4]);
ok_ref(\@ch,\@ca, 'cart - hash mode');
#--num2code, code2num
ok( num2code(255,2,"0123456789ABCDEF") eq 'FF' );
ok( num2code(14,2,"0123456789ABCDEF") eq '0E' );
ok( num2code(1234,16,"01") eq '0000010011010010' );
ok( code2num("0000010011010010","01") eq '1234' );
my $chars='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_';
my $code=num2code("241274432",5,$chars);
t/02_general.t view on Meta::CPAN
1997 Gina 170 158 66 64
1997 Hilde 168 164 62 61
1997 Per 182 180 75 73
1997 Tone 70 69
1998 Gina 171 171 64 64
1998 Hilde 168 168 62 62
1998 Per 182 183 76 74
1998 Tone 70 0
END
my @reportB=pivot([map{$_=[@$_[0,3,2,1,4]]}(@t=@table)],"Year","Season");
ok(tablestring(\@reportB) eq <<'', 'pivot B');
Year Season Height Height Height Weight Weight Weight Weight
Gina Hilde Per Gina Hilde Per Tone
---- ------ ------ ------ ------ ------ ------ ------ ------
1997 Summer 170 168 182 66 62 75 70
1997 Winter 158 164 180 64 61 73 69
1998 Summer 171 168 182 64 62 76 70
1998 Winter 171 168 183 64 62 74 0
my @reportC=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name","Attribute");
ok(tablestring(\@reportC) eq <<'', 'pivot C');
Name Attribute 1997 1997 1998 1998
Summer Winter Summer Winter
----- --------- ------ ------ ------ ------
Gina Height 170 158 171 171
Gina Weight 66 64 64 64
Hilde Height 168 164 168 168
Hilde Weight 62 61 62 62
Per Height 182 180 182 183
Per Weight 75 73 76 74
Tone Weight 70 69 70 0
my @reportD=pivot([map{$_=[@$_[1,2,0,3,4]]}(@t=@table)],"Name");
ok(tablestring(\@reportD) eq <<'', 'pivot D');
Name Height Height Height Height Weight Weight Weight Weight
1997 1997 1998 1998 1997 1997 1998 1998
Summer Winter Summer Winter Summer Winter Summer Winter
----- ------ ------ ------ ------ ------ ------ ------ ------
Gina 170 158 171 171 66 64 64 64
Hilde 168 164 168 168 62 61 62 62
Per 182 180 182 183 75 73 76 74
Tone 70 69 70 0
t/03_bloomfilter.t view on Meta::CPAN
# time ( perl Makefile.PL;make;ATDEBUG=1 perl -Iblib/lib t/03_bloomfilter.t )
# perl Makefile.PL;make;perl -Iblib/lib t/03_bloomfilter.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 28;
my $error_rate=0.02;
my $capacity=10000;
my $bf=bfinit($error_rate, $capacity);
my $t=time_fp();
bfadd($bf, map $_*2,0..$capacity-1);
#deb "Adds pr sec: ".int($capacity/(time_fp()-$t))."\n";
#bfadd($bf, $_) for map $_*2,0..$capacity-1;
deb serialize({%$bf,filter=>''},'bf','',1);
deb "Filter has capacity $$bf{capacity}\n";
deb "Filter has $$bf{key_count} keys\n";
deb "Filter has ".length($$bf{filter})." bytes\n";
deb "Filter has $$bf{filterlength} bits of which ".bfsum($bf)." (".int(100*bfsum($bf)/$$bf{filterlength})."%) are on\n";
deb "Filter has $$bf{hashfuncs} hash functions\n";
my @c=bfcheck($bf,0..$capacity*2); #test next ok: $c[2000]=0;
#deb "$_->".bfcheck($bf,$_)."\n" for 0..200;
my $sum; $sum+=$c[ $_*2+1 ], for 0..$capacity-1;
deb "Filter has $sum false positives\n";
ok(!(grep $c[$_]!=1, map $_*2, 0..$capacity-1), 'no false negatives');
ok(
$sum >= $capacity*$error_rate*80/100
&& $sum <= $capacity*$error_rate*120/100
, sprintf "real error rate (%.6f) vs wanted error_rate ($error_rate) within ok ratio 80-120%% (%d%%)",
$sum/$capacity,
100*$sum/($capacity*$error_rate)
);
eval{bfinit(a=>1,b=>2)};
#deb $@;
ok($@=~/Not ok param to bfinit: a, b\b/,'param check');
t/03_bloomfilter.t view on Meta::CPAN
#---------- see doc about this example:
#do{
# my $bf=bfinit( error_rate=>0.00001, capacity=>4e6, counting_bits=>4 );
# bfadd($bf,[1000*$_+1 .. 1000*($_+1)]),deb"." for 0..4000-1; # adding 4 million keys one thousand at a time
# my %c; $c{vec($$bf{filter},$_,$$bf{counting_bits})}++ for 0..$$bf{filterlength}-1;
# deb sprintf("%8d counters is %2d\n",$c{$_},$_) for sort{$a<=>$b}keys%c;
#};
my %c; $c{vec($$cbf{filter},$_,$cb)}++ for 0..$$cbf{filterlength}-1;
ok(sum(map$c{$_}*$_,keys%c)/$$cbf{key_count} == $$cbf{hashfuncs}, 'counter check');
#deb sprintf("%8d counters is %2d\n",$c{$_},$_) for sort{$a<=>$b}keys%c;
#---------- counting bloom filter, test delete
do{
my($er,$cap,$cb)=(0.1,500,4);
my $bf=bfinit(error_rate=>$er,capacity=>$cap*2,counting_bits=>$cb,keys=>[1..$cap*2]);
bfdelete($bf, $cap+1 .. $cap*1.5);
bfdelete($bf,[$cap*1.5+1 .. $cap*2]);
ok(bfgrep($bf,[1..$cap]) == $cap, 'cbf, delete test, no false negatives');
my $err=bfgrep($bf,[$cap+1..$cap*2]);
deb "Err $err\n";
ok($err/$cap/$er<1.3,"cbf, delete test, after delete ($err)");
my %c=(); $c{vec($$bf{filter},$_,$cb)}++ for 0..$$bf{filterlength}-1;
ok(sum(map$c{$_}*$_,keys%c)/$$bf{key_count} == $$bf{hashfuncs}, 'cbf, delete test, counter check after delete');
eval{ok(bfdelete($bf,'x'))};ok($@=~/Cannot delete a non-existing key x/,'delete non-existing key');
};
#---------- test filter lengths
my $r;
ok(between($r=
length(bfinit(counting_bits=>$_,error_rate=>0.01,capacity=>100)->{filter}) /
length(bfinit(counting_bits=>1, error_rate=>0.01,capacity=>100)->{filter}) / $_, 0.95, 1.05), "filter length ($r), cb $_") for qw/2 4 8 16/;
eval{bfinit(counting_bits=>2,error_rate=>0.1,capacity=>1000,keys=>[1..1000])};ok($@=~/Too many overflows/,'overflow check');
t/03_bloomfilter.t view on Meta::CPAN
#----------adaptive bloom filter, not implemented/tested, see http://intertrack.naist.jp/Matsumoto_IEICE-ED200805.pdf
# $cap=100;
# $bf=bfinit(adaptive=>0,error_rate=>0.001,capacity=>$cap,keys=>[1..$cap]);
# @c=bfcheck($bf,[1..$cap]);
# %c=(); $c{$_}++ for @c;
# deb "Filter has $$bf{filterlength} bits of which ".bfsum($bf)." (".int(100*bfsum($bf)/$$bf{filterlength})."%) are on\n";
# deb "Filter has ".int(1+$$bf{filterlength}/8)." bytes (".sprintf("%.1f",int(1+$$bf{filterlength}/8)/1024)." kb)\n";
# deb "Filter has $$bf{hashfuncs} hash functions\n";
# deb "Number of $_: $c{$_}\n" for sort{$a<=>$b}keys%c;
# deb "Sum bits ".sum(map $$bf{hashfuncs}+$_-1,bfcheck($bf,1..$cap))."\n";
# deb "False negatives: ".grep(!$_,@c)."\n";
# deb "Error rate: ".(($errs=grep($_,bfcheck($bf,$cap+1..$cap*2)))/$cap)."\n";
# deb "Errors: $errs\n";
#---------- bfaddbf, adding two bloom filters
do{
my $cap=100;
my $bf1=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[1..$cap/2]);
my $bf2=bfinit(error_rate=>0.01,capacity=>$cap,keys=>[$cap/2+1..$cap]);
deb "bf1 key_count: $$bf1{key_count}, bf1 ones: ".bfsum($bf1)."\n";
t/05_distance.t view on Meta::CPAN
#perl Makefile.PL;make;perl -Iblib/lib t/05_distance.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 4;
#--oslo-rio = 10434.047 meter iflg http://www.daftlogic.com/projects-google-maps-distance-calculator.htm
my @oslo=(59.933983, 10.756037);
my @rio=(-22.97673,-43.19508);
my @london=(51.507726,-0.128079); #1156
my @jakarta=(-6.175381,106.828176); # 10936
my @test=( ['@oslo,@rio', 10431.5],
['@rio, @oslo', 10431.5],
['@oslo,@london', 1153.6],
['@oslo,@jakarta', 10936.0] );
my $d; ok( between( ($d=distance(eval$$_[0])/1000)/$$_[1], 0.999, 1.001 ), "distance $$_[0], $$_[1] and $d" ) for @test;
#perl Makefile.PL;make;perl -Iblib/lib t/07_big.t
use lib '.'; BEGIN{require 't/common.pl'}
BEGIN{our $T=15}
use Test::More tests => $T;
eval{big(1)};
exit if $@ and print "<<$@>>\n" and map ok(1),1..$T; #Math::BigInt or Math::BigFloat is missing
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($int1,$float1,$int2,$float2) = big(3,'3.0',3.0,3.1); #returns the four new numbers, as the above four lines
ok( ref($num1) eq 'Math::BigInt', 'ref eq Math::BigInt');
ok( ref($num2) eq 'Math::BigFloat', 'ref eq Math::BigFloat');
t/09_rank_pushsort_binsearch.t view on Meta::CPAN
ok( binsearch(5,[1,2,5],0,$cmpsub)==2 );
ok( ($bs=binsearch(6,[1,2,5],1,$cmpsub))==2.5, "after $bs");
ok( ($bs=binsearch(3,[1,2,5],1,$cmpsub))==1.5, $bs);
ok( ($bs=binsearch(1.4,[1,2,5],1,$cmpsub))==0.5, $bs);
ok( ($bs=binsearch(0,[1,2,5],1,$cmpsub))==-0.5,"before $bs");
ok( binsearch(10,[20,15,10,5],undef,sub{$_[1]<=>$_[0]}) == 2); # 2 search arrays sorted numerically in opposite order
ok( binsearch("c",["a","b","c","d"],undef,sub{$_[0]cmp$_[1]}) == 2); # 2 search arrays sorted alphanumerically
ok( binsearchstr("b",["a","b","c","d"]) == 1); # 1 search arrays sorted alphanumerically
my @data=( map { {num=>$_,sqrt=>sqrt($_), square=>$_**2} } grep !($_%7), 1..10000 );
my($i1,$i2) = ( binsearch( {num=>8883}, \@data, undef, sub {$_[0]{num} <=> $_[1]{num}} ),
binsearch( {num=>8883}, \@data, undef, 'num' ) );
ok( $i1==1268, 'binsearch i1');
ok( $i2==1268, 'binsearch i2' );
#ok( $data[$i1]{square}==78907689 );
ok( $Acme::Tools::Binsearch_steps == 10, 'binsearch 10 steps' );
#print "i=$i ".srlz(\$found,'f')."Binsearch_steps = $Acme::Tools::Binsearch_steps\n";
deb "--------------------------------------------------------------------------------eqarr\n";
ok( eqarr([1,2,3],[1,2,3],[1,2,3]) == 1 ,'eqarr 1');
t/09_rank_pushsort_binsearch.t view on Meta::CPAN
}
@p=();
pushsort @p, rand for 1..1000;
ok( sorted(@p), 'pushsort' );
@p=();
pushsortstr @p, rand for 1..1000;
ok( sortedstr(@p), 'pushsortstr' );
deb "--------------------------------------------------------------------------------sorted\n";
my @num=sort {$a<=>$b} map rand()*100,1..100;
my @str=sort map rand()*100,1..100;
ok( sorted( @num ), 'sorted' );
ok( sortedstr( @str ), 'sortedstr' );
ok( !eqarr(\@num,\@str), 'sorted ne sortedstr' );
deb "--------------------------------------------------------------------------------sortby\n";
my @arr=(
{Name=>'Alice', Year=>1970, Gender=>'F'},
{Name=>'Bob', Year=>1980, Gender=>'M'},
{Name=>'Eve', Year=>1990, Gender=>'F'},
{Name=>'Adam', Year=>1971, Gender=>'M'},
{Name=>'Eva', Year=>1972, Gender=>'F'},
{Name=>'Nobby', Year=>1990, Gender=>'F'},
{Name=>'Eve', Year=>1990, Gender=>'F'},
);
ok(srlz([sortby(\@arr,'Year','Gender','Name')]),
srlz([map$$_[0],
sort{$$a[1]cmp$$b[1]}
map[$_,sprintf("%-30s%04d%s",@$_{qw(Year Gender Name)})],
@arr]));
t/11_part.t view on Meta::CPAN
ok_ref( [pile2(4, 1..9)], [[1,2,3,4],[5,6,7,8],[9]], 'pile parta' );
sub pile2 {
my $size=shift;
my $i=0;
parta{$i++/$size}@_;
}
# mapn {},3 @list #3 sliding elems
t/13_random.t view on Meta::CPAN
#print serialize(\%c,'c','',2),serialize(\@v,'v','',2);
my $factor=$c{$v[-1]}/$c{$v[0]};
ok( between($factor,$lim_from,$lim_to), " btw $lim_from $lim_to f=$factor, count=".keys(%c));
ok($vals==keys%c);
}
ok(10==random([1..4],10), 'random arrayref -> array');
ok(10==random({1,1,2,3},10),'random hashref -> array');
#--random_gauss
#my $srg=time_fp;
#my @IQ=map random_gauss(100,15), 1..10000;
my @IQ=random_gauss(100,15,5000);
#print STDERR "\n";
#print STDERR "time =".(time_fp()-$srg)."\n";
#print STDERR "avg IQ=".avg(@IQ)."\n";
#print STDERR "stddev IQ=".stddev(@IQ)."\n";
my $perc1sd =100*(grep{$_>100-15 && $_<100+15 }@IQ)/@IQ;
my $percmensa=100*(grep{$_>100+15*2 }@IQ)/@IQ;
#print "percent within one stddev: $perc1sd\n"; # 2 * 34.1 % = 68.2 %
#print "percent above two stddevs: $percmensa\n"; # 2.2 %
#my $num=1e6;
ok_ref( [zip([1,3,5])], [1,3,5], 'zip 1' );
ok_ref( [zip([1,3,5],[2,4,6])], [1..6], 'zip 2' );
ok_ref( [zip([1,4,7],[2,5,8],[3,6,9])], [1..9], 'zip 3' );
sub ziperr{eval{zip(@_)};$@=~/ERROR.*zip/}
ok( ziperr([1,2],[3,4],5), 'zip err 1');
ok( ziperr([1,2],[3,4,5]), 'zip err 2');
ok( ziperr([1,2],[3,4],5), 'zip err 1');
ok( ziperr([1,2],[3,4,5]), 'zip err 2');
#--zipb64, zipbin, unzipb64, unzipbin, gzip, gunzip
my $s=join"",map random([qw/hip hop and you dont stop/]), 1..1000;
ok( length(zipb64($s)) / length($s) < 0.5, 'zipb64');
ok( between(length(zipbin($s)) / length(zipb64($s)), 0.7, 0.8), 'zipbin zipb64');
ok( between(length(zipbin($s)) / length(zipb64($s)), 0.7, 0.8), 'zipbin zipb64');
ok( length(zipbin($s)) / length($s) < 0.4, 'zipbin');
ok( $s eq unzipb64(zipb64($s)), 'unzipb64');
ok( $s eq unzipbin(zipbin($s)), 'unzipbin');
my $d=substr($s,1,1000);
ok( length(zipb64($s,$d)) / length(zipb64($s)) < 0.8 );
my $f;
ok( ($f=length(zipb64($s,$d)) / length(zipb64($s))) < 0.73 , "0.73 > $f");
#for(1..10){
# my $s=join"",map random([qw/hip hop and you dont stop/]), 1..1000;
# my $d=substr($s,1,1000);
# my $f= length(zipbin($s,$d)) / length(zipbin($s));
# print $f,"\n";
#}
#--gzip, gunzip
$s=join"",map random([qw/hip hop and you do not everever stop/]), 1..10000;
ok(length(gzip($s))/length($s) < 1/5);
ok($s eq gunzip(gzip($s)));
ok($s eq unzipbin(gunzip(gzip(zipbin($s)))));
ok($s eq unzipb64(unzipbin(gunzip(gzip(zipbin(zipb64($s)))))));
print length($s),"\n";
print length(gzip($s)),"\n";
print length(zipbin($s)),"\n";
print length(zipbin($s,$d)),"\n";
t/16_fractional.t view on Meta::CPAN
ok(1); #NOT FINISHED
exit;
#my $n=2135.135135135135135135;
#my $n=0.725234234234*100000000;
#my $n=12/7;
#my $n=big(13)/(2*2*2*2*3*3*7);
#my $n=0.15/(2*2*2*3*3*7);
for(1..10){
my($ti,$ni)=map random(1,10),1..2; print "----$ti/$ni ";
my($to,$no)=fractional($n=$ti/$ni);
print "$ti/$ni -> $n -> ".join(" / ",$to||'?', $no||'?')."\n";
print $to/$no,"\n" if $no;
}
t/17_roman.t view on Meta::CPAN
my$int;ok( ($int=roman2int($_)) eq $rom{$_}, sprintf"roman2int %-8s => %10d %10d",$_,$rom{$_},$int) for sort keys%rom;
ok( do{eval{roman2int("a")};$@=~/invalid/i}, "croaks ok" );
ok( roman2int("-MCCXXXIV")==-1234, 'negative ok');
ok( int2roman(0) eq '', 'zero');
ok( !defined(int2roman(undef)), 'undef');
ok( defined(int2roman("")) && !length(int2roman("")), 'empty');
my @n=(-100..4999);
my @err=grep roman2int(int2roman($_))!=$_, grep $_>100?$_%7==0:1, @n;
ok( @err==0, "all, not ok: ".(join(", ",@err)||'none') );
my @t=([time_fp(),join(" ",map int2roman($_) ,@n),time_fp()],
[time_fp(),join(" ",map int2roman_old($_),@n),time_fp()]);
ok( $t[0][1] eq $t[1][1] );
if($ENV{ATDEBUG}){
printf "Acme::Tools::int2roman - %.6fs\n",$t[0][2]-$t[0][0];
printf "17_roman.t/int2roman_old - %.6fs\n",$t[1][2]-$t[1][0];
}
sub int2roman_old {
my($n,@p)=(shift,[],[1],[1,1],[1,1,1],[1,2],[2],[2,1],[2,1,1],[2,1,1,1],[1,3],[3]);
!defined($n)? undef
: !length($n) ? ""
: int($n)!=$n ? croak"int2roman: $n is not an integer"
: $n==0 ? ""
: $n<0 ? "-".int2roman(-$n)
: $n>3999 ? "M".int2roman($n-1000)
: join'',@{[qw/I V X L C D M/]}[map{my$i=$_;map($_+5-$i*2,@{$p[$n/10**(3-$i)%10]})}(0..3)];
}
t/22_trim.t view on Meta::CPAN
# perl Makefile.PL; make; perl -Iblib/lib t/22_trim.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 7;
#--trim
ok( trim(" asdf \t\n 123 ") eq "asdf 123", 'trim 1');
ok( trim(" asdf\t\n 123 ") eq "asdf\t123", 'trim 2');
ok( trim(" asdf\n\t 123\n") eq "asdf\n123", 'trim 3');
my($trimstr,@trim)=(' please ', ' please ', ' remove ', ' my ', ' spaces ');
ok( join('',map"<$_>",trim(@trim)) eq '<please><remove><my><spaces>', 'trim array');
trim(\$trimstr);
ok($trimstr eq 'please', 'trim inplace');
my @trim2=@trim;
trim(\@trim);
@trim2=map trim, @trim2;
ok_ref(\@trim, ['please','remove','my','spaces'], 'trimed array inplace');
ok_ref(\@trim2,['please','remove','my','spaces'], 'trimed array inplace 2');
dlogin($f);
ddo(<<"");
create table tst (
a integer primary key,
b varchar2,
c date
)
ddo("insert into tst values ".
join",",
map "(".join(",",$_,$_%2?"'XYZ'":"'ABC'",time_fp()).")",
1..100);
dcommit();
ok( 100 == drow("select sum(1) from tst") );
ok( 50 == drow("select sum(1) from tst where b = ? and c <= ?", 'ABC',time_fp()) );
ok( 50 == drow("select sum(1) from tst where b = ? and c <= ?", 'XYZ',time_fp()) );
ok(1);
dlogout();
t/25_pwgen.t view on Meta::CPAN
$n=50;
@pw=grep/^[A-Z]{20}$/,pwgen(20,$n,'A-Z');
ok(@pw==$n, "pwgen ok ".@pw);
$n=50;
@pw=grep/^[A-Z\d]{8}$/&&!/\D\D/,pwgen(8,$n,'A-Z0-9',qr/[ABC]/,qr/\d/,sub{!/\D\D/});
ok(@pw==$n, "pwgen ok ".@pw.tstr());
print serialize(\@pw,'pw') if @pw<$n;
sub ok50{ok(@pw==50,"".(shift()||'50 ').tstr())}
@pw=grep/^\D\D\d\d$/, map pwgen(4,1,'A-Z0-9',qr/^[A-Z]{2}\d\d$/), 1..50; ok50("last of 50");
@pw=grep/^\D\D\d\d$/, pwgen(4,50,'A-Z0-9',sub{/^[A-Z]{2}\d\d$/}); ok50();
@pw=grep/^[A-C]{2}\d\d$/,pwgen(4,50,'A-C0-3',qr/^[A-C]{2}\d\d$/); ok50();
@pw=grep Acme::Tools::pwgendefreq(),grep/^[A-O]/,pwgen(8,50,'','',qr/^[A-O]/); ok50();
@pw=grep Acme::Tools::pwgendefreq(),grep!/[a-z]{3}/i,pwgen(8,50,'','',sub{!/[a-z]{3}/i}); ok50();
t/27_timestuff.t view on Meta::CPAN
tst('354',$t,'doy');tst('353',$t,'doy0');tst('353',$t,'d0y');
#--------------------------------------------------------------------------------
my $tt='20151229-19:13';
# more
#-- easter
ok( '384f0eefc22c35d412ff01b2088e9e05' eq md5_hex( join",", map{easter($_)} 1..5000), 'easter');
sub EasterSunday { #https://no.wikipedia.org/wiki/P%C3%A5skeformelen
my $year=shift;
my $a = $year % 19;
my $b = int($year/100);
my $c = $year % 100;
my $d = int($b/4);
my $e = $b % 4;
my $f = int(($b+8)/25);
my $g = int(($b-$f+1)/3);
t/27_timestuff.t view on Meta::CPAN
#: ok (1);
sleeps(0.010);
sleepms(10);
sleepus(10000);
sleepns(10000000);
if(eval{require Date::Parse}){
is(s2t("18/februar/2019:13:53","MM"),'02','s2t MM');
is(join(" ; ",s2t("18/februar/2019:13:53","DD","MM","YYYY","YYYYMMDD-HH24:MI:SS")), '18 ; 02 ; 2019 ; 20190218-13:53:00','s2t...');
is( s2t($$_[1]), $$_[0], "ok s2t('$$_[1]')" ) for map[split/\s/,$_,2],grep$_,map trim,split"\n","
1555588437 20190418-13:53:57
1555588437 2019-04-18T13:53:57
1555588437 18. april 2019 13:53:57
1555588437 18/Apr/2019:13:53:57
1555588437 1555588437
1555588437 1555588437001
1555588380 20190418-13:53
1555588380 2019-04-18T13:53
1555588380 18. april 2019 13:53
1555588380 18/Apr/2019:13:53
t/28_wipe.t view on Meta::CPAN
# make test
# perl Makefile.PL; make; perl -Iblib/lib t/28_wipe.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 3;
if($^O eq 'linux'){
my $f=tmp().'/acme-tools.wipe.tmp';
writefile($f,join(" ",map rand(),1..1000)); #system("ls -l $f");
my $ntrp=sub{length(gz(readfile($f).""))};
my $n=&$ntrp;
wipe($f,undef,1);
my $ratio=$n/&$ntrp;
ok($ratio>50 || !$INC{'Compress/Zlib.pm'}, "ratio $ratio > 50");
ok(-s$f>5e3);
wipe($f,1);
ok(!-e$f);
}
else{ ok(1) for 1..3 }
t/29_cmd_z2z.t view on Meta::CPAN
# make test
# perl Makefile.PL; make; perl -Iblib/lib t/29_cmd_z2z.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 8;
warn <<"" and map ok(1),1..8 and exit if $^O!~/^(linux|cygwin)$/;
Tests for cmd_z2z not available for $^O, only linux and cygwin
my $tmp=tmp();
my $tf="$tmp/acme-tools.cmd_z2z";
writefile($tf,join" ",1..500);
#print qx(ls -l $tf)."\n";
my($last,$n)=("",0);
for(qw(gz bz2 xz gz xz bz2 gz)){
my $prog={qw/gz gzip bz2 bzip2 xz xz/}->{$_};
next if !Acme::Tools::which($prog) and warn "Program $prog missing, test z2z -t $_" and ok(1);
my $opt='-vt';
$opt=~s,-,-h, if $n++>3;
Acme::Tools::cmd_z2z($opt,$_,"$tf$last");
ok( -s "$tf.$_" );
$last=".$_";
}
my @f=map"$tf.$_",1..4;
my $nn=0;
writefile($_,join" ",map ++$nn,1..5000) for @f;
my $b4=sum(map -s$_,@f);
if( qx(which pv) and qx(which xz) ){
Acme::Tools::cmd_z2z('-vp6t','xz',@f);
Acme::Tools::cmd_z2z('-vht','gz',map"$_.xz",@f);
}
else {
Acme::Tools::cmd_z2z('-vht','gz',@f);
}
my $af=sum(map -s$_,map"$_.gz",@f);
ok(100*$af/$b4 < 50, "$b4 -> $af less than half");
t/34_tablestring.t view on Meta::CPAN
lin 12 xsdff
es xdsa
xa
0 22 adf
.
$ok=~s,\n\s*\n,\n,g; $opt{left}=1; $opt{no_multiline_space}=1; &$okk;
$ok=~s,\n[- ]+\n,\n,; $opt{no_header_line}=1; &$okk;
@tab=map[map {s/88/23/;$_} @$_],@tab;
@tab=grep$$_[0]!~/^(123|lin)/,@tab;
$ok=~s,.*x.*\n,,g;
$ok=~s, 88 , 23 ,; $opt{nodup}=1; &$okk; #nodup not working yet
t/36_cmd_due.t view on Meta::CPAN
# make test
# perl Makefile.PL; make; perl -Iblib/lib t/36_cmd_due.t
# perl Makefile.PL; make; ATDEBUG=1 perl -Iblib/lib t/36_cmd_due.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 6;
use Time::Local;
warn <<"" and map ok(1),1..6 and exit if $^O!~/^(linux|cygwin)$/;
Tests for cmd_due not available for $^O, only linux and cygwin
my($tmp,$p,$ok,@d)=(tmp());
sub okk{ is($p, $ok, shift); $p eq $ok or deb "$p\n!=\n$ok\n"};
my %f=( a=>10, b=>20, c=>30 );
my $i=1;
$Acme::Tools::Magic_openstr=0;
for my $ext (qw( .gz .xz .txt .doc .doc.gz),""){
writefile("$tmp/$_$ext","x" x ($f{$_}*$i++)) for sort(keys%f);
t/37_cmd_resubst.t view on Meta::CPAN
# make test
# perl Makefile.PL; make; perl -Iblib/lib t/37_cmd_resubst.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 2;
my $gzip=(grep -x$_, '/bin/gzip', '/usr/bin/gzip')[0];
SKIP:{
skip "- no cmd_due for $^O (only linux and cygwin)", 2 if $^O!~/^(linux|cygwin)$/;
skip "- gzip not found", 2 if !$gzip;
skip "- md5 not found", 2 if !eval('require Digest::MD5');
my($tmp,$seed,$n)=(tmp(),1234,15);
writefile("$tmp/$_",join("",map{"$_ ".rnd()."\n"}1..10)) for 1..$n;
sub rnd { Digest::MD5::md5_hex($seed++) }
sub test {
my($n,$ok,@a)=@_;
my $p=printed{eval{Acme::Tools::cmd_resubst(@a)}};
if($@=~/not found/){ok(1);return} #if missing bzip2
$p=~s,\s\S*/tmp/\S*/([^\/\s]+), /tmp/x/$1,g;
is($p, $ok, "test $n");
}
test(1,<<".",'-v','-f','e',map"$tmp/$_",1..$n);
1/15 10/10 351 => 341 b (97%) /tmp/x/1
2/15 19/9 351 => 342 b (97%) /tmp/x/2
3/15 27/8 351 => 343 b (97%) /tmp/x/3
4/15 36/9 351 => 342 b (97%) /tmp/x/4
5/15 44/8 351 => 343 b (97%) /tmp/x/5
6/15 52/8 351 => 343 b (97%) /tmp/x/6
7/15 60/8 351 => 343 b (97%) /tmp/x/7
8/15 68/8 351 => 343 b (97%) /tmp/x/8
9/15 77/9 351 => 342 b (97%) /tmp/x/9
10/15 86/9 351 => 342 b (97%) /tmp/x/10
11/15 95/9 351 => 342 b (97%) /tmp/x/11
12/15 105/10 351 => 341 b (97%) /tmp/x/12
13/15 113/8 351 => 343 b (97%) /tmp/x/13
14/15 121/8 351 => 343 b (97%) /tmp/x/14
15/15 128/7 351 => 344 b (98%) /tmp/x/15
Replaces: 128 Bytes before: 5265 After: 5137 Change: -2.4%
.
qx($gzip $tmp/*);
test(2,<<".",'-o','bz2','-9','-v','-f','f',map"$tmp/$_.gz",1..$n);
1/15 8/8 225 => 237 b (105%) /tmp/x/1.gz
2/15 17/9 226 => 232 b (102%) /tmp/x/2.gz
3/15 26/9 226 => 235 b (103%) /tmp/x/3.gz
4/15 34/8 227 => 232 b (102%) /tmp/x/4.gz
5/15 42/8 226 => 235 b (103%) /tmp/x/5.gz
6/15 48/6 225 => 239 b (106%) /tmp/x/6.gz
7/15 57/9 225 => 235 b (104%) /tmp/x/7.gz
8/15 64/7 225 => 236 b (104%) /tmp/x/8.gz
9/15 74/10 227 => 232 b (102%) /tmp/x/9.gz
10/15 84/10 227 => 236 b (103%) /tmp/x/10.gz
# make && perl -Iblib/lib t/39_sim.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 21;
eval 'require String::Similarity';
map ok(1,'skip -- String::Similarity is missing'),1..21 and exit if $@;
for(map[map trim,split/\|/],split/\n/,<<""){
Humphrey DeForest Bogart | Bogart Humphrey DeForest | 0.71 | 1.00
Humphrey Bogart | Humphrey Gump Bogart | 0.86 | 1.00
Humphrey deforest Bogart | Bogart DeForest | 0.41 | 1.00
Humfrey DeForest Boghart | BOGART HUMPHREY | 0.05 | 0.87
Humphrey | Bogart Humphrey | 0.70 | 1.00
Humfrey Deforest Boghart | BOGART D. HUMFREY | 0.15 | 0.78
Presley, Elvis Aaron | Elvis Presley | 0.42424 | 1.00
my($s1,$s2,$sim,$sim_perm)=@$_;
ok( $sim < $sim_perm );
t/41_changed.t view on Meta::CPAN
# make;perl -Iblib/lib t/41_changed.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 4;
my @lst;
@lst=map { changed(int($_/6)) ? ($_,'-') : ($_) } 1..20; testen();
@lst=map { changed(int($_/6)) ? ($_,'-') : ($_) } 1..20; testen();
sub testen{is( join("",@lst), '123456-789101112-131415161718-1920', 'ok list' )};
is(keys(%Acme::Tools::Changed_lastval), 2, 'count 2');
#print srlz(\%Acme::Tools::Changed_lastval,'l','',1);
@lst=map changed(int($_/6)),1..20;
is( srlz(\@lst,'lst'), qq(\@lst=(undef,'0','0','0','0','1','0','0','0','0','0','1','0','0','0','0','0','1','0','0');\n), '1st undef');
t/42_finddup.t view on Meta::CPAN
# make && perl -Iblib/lib t/42_finddup.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 13;
my $tmp;
my @f;
sub mkf {
my $n=shift(); $n=4 if!defined$n;
$tmp=tmp();
my $str=sub{$_<4?"abcd$_":"ABCD$_"};
@f=map{my$f="$tmp/file$_";writefile($f,&$str($_));$f}0..$n-1;
my $t=time();
utime 0,$t+2*$_,$f[$_] for 0..3;
}
mkf();
sub fd{Acme::Tools::cmd_finddup(@_)}
sub f{fd('-R',@_)}
sub sr{repl( srlz(@_), quotemeta("$tmp/"), '', qr/\n$/, '' )}
my %f=f(qw(-P 4 -M -F),@f);
my $s=sr(\%f,'f');
my $s2=sr({md5sum(\"abcd")=>[map"file$_",0..3]},'f'); #print$s,$s2;
ok($s eq $s2);
my @r;
sub test{my$sr=sr(\@r,'r');print "Got: $sr\nExpected: $_[0]\n\n" if $sr ne $_[0];ok($sr eq shift)}
@r=f(qw(-P 4 -M ), @f[2,1,3,0]);test(q(@r=('file1','file3','file0');));
@r=f(qw(-P 4 -M -k n ),@f[2,1,3,0]);test(q(@r=('file2','file1','file0');));
@r=f(qw(-P 4 -M -k o ),@f[2,1,3,0]);test(q(@r=('file1','file2','file3');));
@r=f( @f );test(q(@r=();));
@r=f( $tmp );test(q(@r=();));
my $pr=sub{my@a=@_;join("",map"$_\n",map{s,$tmp/,,g;$_}split"\n",printed{Acme::Tools::cmd_finddup(@a)})};
my $p; sub okp{print "Got: $p\nExpected: $_[0]\n" if $p ne $_[0];ok($p eq $_[0])}
$p=&$pr(qw(-k o -MP4),$tmp); okp("file1\nfile2\nfile3\n");
$p=&$pr(qw(-k o -MP4),$tmp,$tmp); okp("file1\nfile2\nfile3\n");
$p=&$pr('-MP4', @f); okp("file1\nfile2\nfile3\n"); mkf(8);
$p=&$pr('-aMP4', @f); okp("file0\nfile1\nfile2\nfile3\n\nfile4\nfile5\nfile6\nfile7\n"); mkf();
$p=&$pr('-dnMP4',@f); okp(qq(rm "file1"\nrm "file2"\nrm "file3"\n));
$p=&$pr('-snMP4',@f); okp(qq(ln -s "file0" "file1"\nln -s "file0" "file2"\nln -s "file0" "file3"\n));
$p=&$pr('-hnMP4',@f); okp(qq(ln "file0" "file1"\nln "file0" "file2"\nln "file0" "file3"\n));
#if($^O ne 'linux'){ok(1) for 1..x; exit }
t/common.pl view on Meta::CPAN
use strict;
use warnings;
#use Test::More;
use Acme::Tools 0.24;
#todo: faster make test, group some *.t together, 6s is too long
sub deb($) { print STDERR @_ if $ENV{ATDEBUG} }
sub tmp { require File::Temp;File::Temp::tempdir(CLEANUP=>$ENV{ATDEBUG}?0:1,@_) }
sub ok_ca { ok( abs( 1 - $_[0]/$_[1] ) < 1e-4, $_[2]) }
sub ok_str { my($s1,$s2)=@_; if($s1 eq $s2){ ok(1) }else{ ok(0,"s1: $s1 not eq s2: $s2") } }
sub ok_ref {
my($s1,$s2) = map serialize($_),@_[0,1];
my $ok = ok($s1 eq $s2, $_[2]) or deb "s1=$s1\ns2=$s2\n";
$ok
}
sub gz {
return gzip(shift()) if $] >= 5.010;
my $t=tmp().'/acme-tools.wipe2.tmp';
writefile($t,shift());
''.qx(gzip<$t);
}
1;
t/test_binsearch_bench.pl view on Meta::CPAN
#!/usr/bin/perl
use Acme::Tools;
use List::MoreUtils 'bsearch'; #':all';
use Benchmark qw(:all) ;
my @a = map [$_,$_**1.6+1e4], 1e5..2e5;
my $t=time_fp();
my($h)=(List::MoreUtils::bsearch {$$_[0] cmp 194022} @a);
print time_fp()-$t,"\n";
print srlz(\$h,"h");
my($i,$h1,$h2,$h3);
my $cnt=3000;
my @find1=map random(1e5,2e5), 1..$cnt;
my @find2=@find1;
my @find3=@find1;
timethese($cnt, { #for some mystical reason Acme::Tools seems 11x faster(?)
'Name1' => sub { my$r=pop@find1;($h1)=(List::MoreUtils::bsearch {$$_[0] <=> $r} @a) },
# 'Name2' => sub { $i=Acme::Tools::binsearch(pop(@find2),\@a); $h2=$a[$i] },
'Name3' => sub { $i=Acme::Tools::binsearch([pop@find3],\@a,undef,sub{$_[0][0]<=>$_[1][0]}); $h3=$a[$i] },
});
print srlz(\$h1,'h1');
print srlz(\$h3,'h3');
#print "i=$i h=".srlz(\$h)."\n";
my @data=( map { {num=>$_,sqrt=>sqrt($_), square=>$_**2} }
grep !($_%7), 1..1000000 );
my $i = binsearch( {num=>913374}, \@data, undef, sub {$_[0]{num} <=> $_[1]{num}} );
my $found = defined $i ? $data[$i] : undef;
print "i=$i\n";
print srlz(\$found,'f');
print "Binsearch_steps = $Acme::Tools::Binsearch_steps\n";
t/test_fork_bloom.pl view on Meta::CPAN
use Acme::Tools;
my $jobs=16;
my $cap=1000000;
my $error_rate=0.01;
my($pid,@pid);
for my $job (0..$jobs-1){
unlink"/tmp/bf$job.bf";
next if fork();
my $t=time_fp();
my @keys=grep$_%$jobs==$job,1..$cap;
#my @keys=map rand(), 1..$cap/$jobs;
my $bf=bfinit(error_rate=>$error_rate,capacity=>$cap,keys=>\@keys);
bfstore($bf,"/tmp/bf$job.bf");
print "job $job finished, ".(time_fp()-$t)." sec\n";
exit;
}
1 while wait() != -1;
print "building finished\n";
my $bf=bfinit(error_rate=>$error_rate,capacity=>$cap);
for my $job (0..$jobs-1){
print "Adding bloom filter $job...";
t/test_k_m.pl view on Meta::CPAN
#!/usr/bin/perl
use Acme::Tools;
my $cool=resolve(sub{(bfdimensions(1e6,$_[0]))[0]/8-1e6},0,0.02);
my(@tm1,@tm2);
my @cap=map 10**$_,1..12;
my @er=qw/0.99 0.5 0.1 0.01 0.001 0.0001 0.00001 0.000001 0.0000001 0.00000001 0.000000001/; splice@er,3,0,$cool;
for my $cap (@cap){
for my $er (@er){
my($m1,$k1)=Acme::Tools::bfdimensions_old($cap,$er);
my($m2,$k2)=Acme::Tools::bfdimensions($cap,$er);
push @tm1,[$cap,"Error-rate\n$er",sprintf("%.4g",0.5+$m1/8)];
push @tm2,[$cap,"Error-rate\n$er",sprintf("%.4g",0.5+$m2/8)];
}
}
print "Storage, method 1 (bytes):\n".tablestring([pivot(\@tm1,"Capacity")]),"\n";
t/test_perm2.pl view on Meta::CPAN
sub perm0 {
my @a=@_;
my $n=@a;
my @c=map 0, 1..$n;
print join(" ",@a)."\n";
my $i=0;
while($i<$n){
if($c[$i]<$i){
if($i%2==0){ @a[0,$i]=@a[$i,0] }
else { @a[$c[$i],$i]=@a[$i,$c[$i]] }
$c[$i]++;
$i=0;
print join(" ",@a)."\n";
}
else{
$c[$i]=0;
$i++;
}
}
}
sub perm_slow { #same golfed
my(@a,@c,$i,$p)=@_;
my $o=sub{print join("",map"$_ ",@a)."\n"}; &$o;
$c[$i]>=$i and $c[$i++]="0e0" or $p=$c[$i]++*($i%2),@a[$p,$i]=@a[$i,$p],$i=0,&$o while $i<@a;
}
sub perm { #same golfed and faster
my(@a,@c,$i,$p)=@_;
print join(" ",@a)."\n";
$c[$i]>=$i and $c[$i++]="0e0" or $p=$c[$i]++*($i%2),@a[$p,$i]=@a[$i,$p],$i=0,print(join(" ",@a)."\n") while $i<@a;
}
my $n=shift||4;
my @a=1..$n;
t/test_pi.pl view on Meta::CPAN
590694912933136770289891521047521620569660240580381501935112533824300355
876402474964732639141992726042699227967823547816360093417216412199245863
150302861829745557067498385054945885869269956909272107975093029553211653
449872027559602364806654991198818347977535663698074265425278625518184175
746728909777727938000816470600161452491921732172147723501414419735685481
pi_bin();
sub pi_1 { # pi = 4 sigma(0..inf) -1^k/(2k+1)
for my $n (map 10**$_,1..18){
my($start,$sum,$one,$e)=(time_fp(),0,bigf(-1),0);
$sum+=($one*=-1)/(2*$_+1) for 0..$n;
my $mypi=4*$sum;
printf "%7d: ".("%30.25f" x 5)." %5.2fs\n",
$n,
$mypi,
$pi-$mypi,
$pi-($mypi - 1/$n**1),
$pi-($mypi - 1/$n**1 + 1/$n**2),
$pi-($mypi - 1/$n**1 + 1/$n**2 - 0.75/$n**3),
time_fp()-$start;
}
}
sub pi_2 { # pi^2/6 = 1/1**2 + 1/2**2 + 1/3**2 + 1/4**2 ...
for my $n (map 10**$_,0..8){
my($start,$sum)=(time_fp(),0);
$sum+=1/$_**2 for 1..$n;
my $mypi=sqrt(6*$sum);
printf "%9d: ".("%30.25f" x 2)." %5.2fs\n", $n, $mypi, $pi-$mypi, time_fp()-$start;
}
}
sub pi_3 { # dart and pythagoras
for my $n (map 10**$_,0..8){
my($start,$s)=(time_fp(),0);
for(1..$n){
my($x,$y)=(rand(),rand()); #throw dart
++$s if sqrt($x*$x + $y*$y) < 1;
}
my $mypi=4*$s/$n;
printf "%9d: %30.25f %30.25f %5.2fs\n", $n, $mypi, $pi-$mypi, time_fp()-$start;
}
}
#use Math::BigFloat lib=>"GMP";# if !$INC{'Math/BigFloat.pm'};
sub pi_4 { # ramaputramama...
#use Math::BigFloat ':constant';
my @fak; $fak[$_]=$_?$fak[$_-1]*$_:bigf(1) for 0..1000; #die join("\n",@fak)."\n";
bigscale(1000); #hm
my $pi_bigger=Math::BigFloat->bpi(1000);
for my $n (30..50){
my($start,$s)=(time_fp(),bigf(0));
for my $k (0..$n) {
my $kf=bigf($k);
$s+= $fak[$k*4] / $fak[$k]**4
* (1103 + 26390*$kf) / 396**($kf*4)
t/test_pi.pl view on Meta::CPAN
printf "%9d / %-9d %20.15f %20.15f %g improvement: %g\n", $_, $n, $mypi, $diff, $diff, $imp;
}
}
}
sub pi_bin_old {
bigscale(1000); #hm
for my $n (1..100){
my $start=time_fp();
my $sum=0;
for my $i (map bigf($_),0..$n){
$sum += 1/16**$i * ( 4/(8*$i+1) - 2/(8*$i+4) - 1/(8*$i+5) - 1/(8*$i+6) );
}
my $mypi=$sum;
my $diff=$pi_big-$mypi;
#next unless $diff<$min and $imp=$min/$diff and $min=$diff and $imp>1.1;
printf "%9d: %30.25f %30.25f %g %5.2f\n", $n, $mypi, $diff, $diff, time_fp()-$start;
}
}
sub pi_bin { # http://www.experimentalmath.info/bbp-codes/bbp-alg.pdf
bigscale(500); #hm
my $start=time_fp();
my $mypi=0;
for my $i (map bigf($_), 0..300){
$mypi += 1/16**$i * ( 4/(8*$i+1) - 2/(8*$i+4) - 1/(8*$i+5) - 1/(8*$i+6) ); #from Ferguson's PSLQ algorithm
next if $i%10;
my $diff=$pi_big-$mypi;
printf "%9d: %30.25f %30.25f %g %5.2f\n", $i, $mypi, $diff, $diff, time_fp()-$start;
}
}
__END__
@fak https://en.wikipedia.org/wiki/Factorial
Visste du at den matematiske formelen for volumet til en pizza med tykkelse a og radius z er pi z z a?
t/test_pivot.pl view on Meta::CPAN
'Sample2.45' => 4
},
'Water' => {
'Sample1.14' => 3
}
};
use Acme::Tools;
use Data::Pivot;
print "$Acme::Tools::VERSION\n";
my %sample;
$sample{$_}++ for map keys(%$_), values %$data;
my $data2=[
map { my $x=$_; map [$x,$_,$$data{$x}{$_}||' 0'], sort keys %sample }
sort keys %$data
];
print srlz($data2,'data2','',1);
my @ap=Acme::Tools::pivot($data2,"Element");
print srlz(\@ap,'ap','',1);
print tablestring([@ap]);
print "--------------------------------------------------------------------------------\n";
my @p = Data::Pivot::pivot( table=>$data2,
headings=>['x',sort keys %sample],
pivot_column=>2,
( run in 1.178 second using v1.01-cache-2.11-cpan-3b35f9de6a3 )