Acme-Tools
view release on metacpan or search on metacpan
$chars="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz-_";
print num2code("241274432",5,$chars); # prints EOOv0
print code2num("EOOv0",$chars); # prints 241274432
=cut
#Math::BaseCnv
sub num2code {
return num2code($_[0],0,$_[1]) if @_==2;
my($num,$digits,$validchars,$start)=@_;
my $l=length($validchars);
my $key;
$digits||=9e9;
no warnings;
croak if $num<$start;
$num-=$start;
for(1..$digits){
$key=substr($validchars,$num%$l,1).$key;
$num=int($num/$l);
last if $digits==9e9 and !$num;
}
croak if $num>0;
return $key;
}
sub code2num {
my($code,$validchars,$start)=@_; $start=0 if!defined$start;
my $l=length($validchars);
my $num=0;
$num=$num*$l+index($validchars,$_) for split//,$code;
return $num+$start;
}
=head2 base
Numbers in any number system of base between 2 and 36. Using capital letters A-Z for base higher than 10.
base(2,15) # 1111 2 --> binary
base(8,4096) # 10000 8 --> octal
base(10,4096) # 4096 of course
base(16,254) # FE 16 --> hex
=head2 resolve
Resolves an equation by Newtons method.
B<Input:> 1-6 arguments. At least one argument.
First argument: must be a coderef to a subroutine (a function)
Second argument: if present, the target, f(x)=target. Default 0.
Third argument: a start position for x. Default 0.
Fourth argument: a small delta value. Default 1e-4 (0.0001).
Fifth argument: a maximum number of iterations before resolve gives up
and carps. Default 100 (if fifth argument is not given or is
undef). The number 0 means infinite here. If the derivative of the
start position is zero or close to zero more iterations are typically
needed.
Sixth argument: A number of seconds to run before giving up. If both
fifth and sixth argument is given and > 0, C<resolve> stops at
whichever comes first.
B<Output:> returns the number C<x> for C<f(x)> = 0
...or equal to the second input argument if present.
B<Example:>
The equation C<< x^2 - 4x - 21 = 0 >> has two solutions: -3 and 7.
The result of C<resolve> will depend on the start position:
print resolve(sub{ $_**2 - 4*$_ - 21 }); # -3 with $_ as your x
print resolve(sub{ my $x=shift; $x**2 - 4*$x - 21 }); # -3 more elaborate call
print resolve(sub{ my $x=shift; $x**2 - 4*$x - 21 },0,3); # 7 with start position 3
print "Iterations: $Acme::Tools::Resolve_iterations\n"; # 3 or larger, about 10-15 is normal
The variable C< $Acme::Tools::Resolve_iterations > (which is exported) will be set
to the last number of iterations C<resolve> used. Also if C<resolve> dies (carps).
The variable C< $Acme::Tools::Resolve_last_estimate > (which is exported) will be
set to the last estimate. This number will often be close to the solution and can
be used even if C<resolve> dies (carps).
B<BigFloat-example:>
our $Resolve_time;
#sub resolve(\[&$]@) {
#sub resolve(&@) { <=0.17
#todo: perl -MAcme::Tools -le'print resolve(sub{$_[0]**2-9431**2});print$Acme::Tools::Resolve_iterations'
#todo: perl -MAcme::Tools -le'sub d{5.3*1.0094**$_[0]-10.2*1.0072**$_[0]} print resolve(\&d)' #err, pop norway vs sweden
#todo: perl -MAcme::Tools -le' print resolve(sub{5.3*1.0094**$_[0]-10.2*1.0072**$_[0]})' #err, pop norway vs sweden
# =>Div by zero: df(x) = 0 at n'th iteration, n=0, delta=0.0001, fx=CODE(0xc81d470) at -e line 1
#todo: ren solve?
sub resolve {
my($f,$goal,$start,$delta,$iters,$sec)=@_;
$goal=0 if!defined$goal;
$start=0 if!defined$start;
$delta=1e-4 if!defined$delta;
$iters=100 if!defined$iters;
$sec=0 if!defined$sec;
$iters=13e13 if $iters==0;
croak "Iterations ($iters) or seconds ($sec) can not be a negative number" if $iters<0 or $sec<0;
$Resolve_iterations=undef;
$Resolve_last_estimate=undef;
croak "Should have at least 1 argument, a coderef" if !@_;
croak "First argument should be a coderef" if ref($f) ne 'CODE';
my @x=($start);
my $time_start=$sec>0?time_fp():undef;
my $ds=ref($start) eq 'Math::BigFloat' ? Math::BigFloat->div_scale() : undef;
my $fx=sub{
local$_=$_[0];
my $fx=&$f($_);
if($fx=~/x/ and $fx=~/^[ \(\)\.\d\+\-\*\/x\=\^]+$/){
$fx=~s/(\d)x/$1*x/g;
$fx=~s/\^/**/g;
$fx=~s/^(.*)=(.*)$/($1)-($2)/;
$fx=~s,x,\$_,g;
$f=eval"sub{$fx}";
$fx=&$f($_);
$fd = &$fx($x[$n]+$delta*0.2) - &$fx($x[$n]-$delta*0.8) if $fd==0;# and warn"wigle 2\n";
croak "Div by zero: df(x) = $x[$n] at n'th iteration, n=$n, delta=$delta, fx=$fx" if $fd==0;
$x[$n+1]=$x[$n]-(&$fx($x[$n])-$goal)/($fd/$delta);
$Resolve_last_estimate=$x[$n+1];
#warn "n=$n fd=$fd x=$x[$n+1]\n";
$Resolve_iterations=$n;
last if $n>3 and $x[$n+1]==$x[$n] and $x[$n]==$x[$n-1];
last if $n>4 and $x[$n]!=0 and abs(1-$x[$n+1]/$x[$n])<1e-13; #sub{3*$_+$_**4-12}
last if $n>3 and ref($x[$n+1]) eq 'Math::BigFloat' and substr($x[$n+1],0,$ds) eq substr($x[$n],0,$ds); #hm
croak "Could not resolve, perhaps too little time given ($sec), iteratons=$n"
if $sec>0 and ($Resolve_time=time_fp()-$time_start)>$sec;
#warn "$n: ".$x[$n+1]."\n";
$n++;
}
croak "Could not resolve, perhaps too few iterations ($iters)" if @x>=$iters;
return $x[-1];
}
=head2 resolve_equation
This prints 2:
print conv( 70,"cm","in"); #prints 27.5590551181102
print conv( 4,"USD","EUR"); #prints 3.20481552905431 (depending on todays rates)
print conv( 4000,"b","kb"); #prints 3.90625 (1 kb = 1024 bytes)
print conv( 4000,"b","Kb"); #prints 4 (1 Kb = 1000 bytes)
print conv( 1000,"mb","kb"); #prints 1024000
print conv( 101010,"bin","roman"); #prints XLII
print conv( "DCCXLII","roman","oct"); #prints 1346
B<Units, types of measurement and currencies supported by C<conv> are:>
Note: units starting with the symbol _ means that all metric
prefixes from yocto 10^-24 to yotta 10^+24 is supported, so _m means
km, cm, mm, µm and so on. And _N means kN, MN GN and so on.
Note2: Many units have synonyms: m, meter, meters ...
acceleration: g, g0, m/s2, mps2
angle: binary_degree, binary_radian, brad, deg, degree, degrees,
gon, grad, grade, gradian, gradians, hexacontade, hour,
new_degree, nygrad, point, quadrant, rad, radian, radians,
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.
rpad('gomle',9); # 'gomle '
lpad('gomle',9); # ' gomle'
rpad('gomle',9,'-'); # 'gomle----'
lpad('gomle',9,'+'); # '++++gomle'
rpad('gomle',4); # 'goml'
lpad('gomle',4); # 'goml'
return wantarray ? @sort : $sort[$rank-1];
}
sub rankstr {wantarray?(rank(@_,sub{$_[0]cmp$_[1]})):rank(@_,sub{$_[0]cmp$_[1]})}
=head2 egrep
Extended grep.
Works like L<grep> but with more insight: local vars $i, $n, $prev, $next, $prevr and $nextr are available:
$i is the current index, starts with 0, ends with the length of the input array minus one
$n is the current element number, starts with 1, $n = $i + 1
$prev is the previous value (undef if current is first)
$next is the next value (undef if current is last)
$prevr is the previous value, rotated so that the previous of the first element is the last element
$nextr is the next value, rotated so that the next of the last element is the first element
$_ is the current value, just as with Perls built-in grep
* Second arg: number of passwords, default 1
* Third arg: string containing legal chars in password, default A-Za-z0-9,-./&%_!
* Fourth to n'th arg: list of requirements for passwords, default if the third arg is false/undef (so default third arg is used) is:
sub{/^[a-zA-Z0-9].*[a-zA-Z0-9]$/ and /[a-z]/ and /[A-Z]/ and /\d/ and /[,-.\/&%_!]/}
...meaning the password should:
* start and end with: a letter a-z (lower- or uppercase) or a digit 0-9
* should contain at least one char from each of the groups lower, upper, digit and special char
To keep the default requirement-sub but add additional ones just set the fourth arg to false/undef
and add your own requirements in the fifth arg and forward (examples below). Sub pwgen uses perls
own C<rand()> internally.
C<< $Acme::Tools::Pwgen_max_sec >> and C<< $Acme::Tools::Pwgen_max_trials >> can be set to adjust for how long
pwgen tries to find a password. Defaults for those are 0.01 and 10000.
Whenever one of the two limits is reached, a first generates a croak.
Examples:
my $pw=pwgen(); # a random 8 chars password A-Z a-z 0-9 ,-./&%!_ (8 is default length)
my $pw=pwgen(12); # a random 12 chars password A-Z a-z 0-9 ,-./&%!_
my @pw=pwgen(0,10); # 10 random 8 chars passwords, containing the same possible chars
my @pw=pwgen(0,1000,'A-Z'); # 1000 random 8 chars passwords containing just uppercase letters from A to Z
pwgen(3); # dies, defaults require chars in each of 4 group (see above)
pwgen(5,1,'A-C0-9', qr/^\D{3}\d{2}$/); # a 5 char string starting with three A, B or Cs and endring with two digits
pwgen(5,1,'ABC0-9',sub{/^\D{3}\d{2}$/}); # same as above
Examples of adding additional requirements to the default ones:
my @pwreq = ( qr/^[A-C]/ );
pwgen(8,1,'','',@pwreq); # use defaults for allowed chars and the standard requirements
# but also demand that the password must start with A, B or C
push @pwreq, sub{ not /[a-z]{3}/i };
pwgen(8,1,'','',@pwreq); # as above and in addition the password should not contain three
# or more consecutive letters (to avoid "offensive" words perhaps)
=cut
our $Pwgen_max_sec=0.01; #max seconds/password before croak (for hard to find requirements)
our $Pwgen_max_trials=10000; #max trials/password before croak (for hard to find requirements)
our $Pwgen_sec=0; #seconds used in last call to pwgen()
$Ipnum=undef;
eval{
die "malformed ipnum $ipnum\n" if not $ipnum=~/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
die "invalid ipnum $ipnum\n" if grep$_>255,$1,$2,$3,$4;
$Ipnum=$1*256**3 + $2*256**2 + $3*256 + $4;
};
my$r=($Ipnum_errmsg=$@) ? 0 : 1;
$r
}
our $Iprange_errmsg;
our $Iprange_start;
sub iprange_ok {
my $iprange=shift;
$Iprange_start=undef;
my($r,$m);
eval{
die "malformed iprange $iprange\n" if not $iprange=~m|^(\d+)\.(\d+)\.(\d+)\.(\d+)(?:/(\d+))$|;
die "iprange part should be 0-255\n" if grep$_<0||$_>255,$1,$2,$3,$4;
die "iprange mask should be 0-32\n" if defined$5 and $5>32;
($r,$m)=($1*256**3+$2*256**2+$3*256+$4,32-$5);
};
return if $Iprange_errmsg=$@;
my $x=$r>>$m<<$m;
return if $r!=$x and $Iprange_errmsg=sprintf("need zero in last %d bits, should be %d.%d.%d.%d/%d",
$m, $x>>24, ($x>>16)&255, ($x>>8)&255, $x&255, 32-$m);
$Iprange_start=$r;
return 1;
}
sub in_iprange {
my($ipnum,$iprange)=@_;
croak $Ipnum_errmsg if !ipnum_ok($ipnum);
croak $Iprange_errmsg if !iprange_ok($iprange=~m|/\d+$| ? $iprange : "$iprange/32");
"$iprange/32"=~m|/(\d+)| or die;
$Ipnum>=$Iprange_start &&
$Ipnum<=$Iprange_start + 2**(32-$1)-1;
}
=head2 webparams
B<Input:> (optional)
Zero or one input argument: A string of the same type often found behind the first question mark (C<< ? >>) in URLs.
This string can have one or more parts separated by C<&> chars.
for(@_){ chmod($mode,$_) && utime($atime,$mtime,$_) && chown($uid,$gid,$_) && $successful++ }
return $successful;
}
=head2 makedir
Input: One or two arguments.
Works like perls C<mkdir()> except that C<makedir()> will create nesessary parent directories if they dont exists.
First input argument: A directory name (absolute, starting with C< / > or relative).
Second input argument: (optional) permission bits. Using the normal C<< 0777^umask() >> as the default if no second input argument is provided.
Example:
makedir("dirB/dirC")
...will create directory C<dirB> if it does not already exists, to be able to create C<dirC> inside C<dirB>.
Returns true on success, otherwise false.
File use for the above example:
switch: OK #before first section, the '' (empty) section
[sectionA]
knobble: ABC
gobble: XYZ #this gobble is overwritten by the gobble on the next line
gobble: ZZZ
[part2]
password: oh:no= x #should be better
text: { values starting with { continues
until reaching a line with }
Everything from # and behind is regarded comments and ignored. Comments can be on any line.
To keep a # char, put a \ in front of it.
A C< : > or C< = > separates keys and values. Spaces at the beginning or end of lines are
ignored (after removal of #comments), as are any spaces before and after : and = separators.
Empty lines or lines with no C< : > or C< = > is also ignored. Keys and values can contain
internal spaces and tabs, but not at the beginning or end.
Multi-line values must start and end with { and }. Using { and } keep spaces at the start
or end in both one-line and multi-line values.
Sections are marked with C<< [sectionname] >>. Section names, keys and values is case
sensitive. C<Key:values> above the first section or below and empty C<< [] >> is placed
both in the empty section in the returned hash and as top level key/values.
C<read_conf> can be a simpler alternative to the core module L<Config::Std> which has
its own hassles.
$Acme::Tools::Read_conf_empty_section=1; #default 0 (was 1 in version 0.16)
Dth 1st 2nd 3rd 4th 5th ... 11th 12th ... 20th 21st 22nd 23rd 24th ... 30th 31st
WW Week number of the year 01-53 according to the ISO8601-definition (which most countries uses)
WWUS Week number of the year 01-53 according to the most used definition in the USA.
Other definitions also exists.
epoch Converts a time string from YYYYMMDD-HH24:MI:SS, YYYYMMDD-HH24:MI:SS, YYYYMMDDTHH:MI:SS,
YYYY-MM-DDTHH:MI:SS or YYYYMMDD to the number of seconds since January 1st 1970.
Commonly known as the Unix epoch.
JDN Julian day number. Integer. The number of days since the day starting at noon on January 1 4713 BC
JD Same as JDN but a float accounting for the time of day
B<Third argument:> (optional) Is_date. False|true, default false. If true, the second argument is
interpreted as a date of the form YYYYMMDD, not as a number of seconds since epoch (January 1st 1970).
=cut
#Se også L</tidstrk> og L</tidstr>
our $Tms_pattern;
my $avg=$sum/$sumw;
return $avg;
# return avg(@eta);
#return $$a[-1][1] + ($end-$$a[-1][0]) * ($$a[-1][1]-$$a[-2][1])/($$a[-1][0]-$$a[-2][0]);
1;
}
=head2 sleep_until
sleep_until(0.5) sleeps until half a second has passed since the last
call to sleep_until. This example starts the next job excactly ten
seconds after the last job started even if the last job lasted for a
while (but not more than ten seconds):
for(@jobs){
sleep_until(10);
print localtime()."\n";
...heavy job....
}
Might print:
'JCB' 3 16
'JCB' 2131 eller 1800 15
And should perhaps have had:
'enRoute' 2014 eller 2149 15
...but that card uses either another control algorithm or no control
digits at all. So C<enRoute> is never returned here.
If the control digits is valid, but the input does not match anything in the column C<starts on>, 1 is returned.
(This is also the same control digit mechanism used in Norwegian KID numbers on payment bills)
The first digit in a credit card number is supposed to tell what "industry" the card is meant for:
MII Digit Value Issuer Category
--------------------------- ----------------------------------------------------
0 ISO/TC 68 and other industry assignments
1 Airlines
2 Airlines and other industry assignments
print "count: $c\n"; # prints 6 = 3*2*1 = 3!
The permute BLOCK needs to return true (which print does) for permute to continue:
my $c = permute { print @_,"\n"; rand()<.5 } "a".."d"; # probably prints less than 24 strings
print "count: $c\n"; # prints random number up to 24 = 4*3*2*1 = 4!
=head2 permute_continue
my @abc = ("a", "b", "c");
my @start = ("b", "a", "c"); # starting sequence to continue from
my $c = permute_continue { print @_,"\n" } \@abc, \@start; # prints four lines: bac bca cab cba
my $c = permute { print @_,"\n" } \@abc, \@start; # same, =permute_continue when coreref+arrayref+arrayref
print "count: $c\n"; # prints 6-2 = 3*2*1-2 = 3!-2
The permute BLOCK needs to return true (which print does) for permute to continue:
my $c = permute { print @_,"\n"; rand()<.5 } "a".."d"; # probably prints less than 24 strings
print "count: $c\n"; # prints random number up to 24 = 4*3*2*1 = 4!
=cut
sub perm {
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];
}
$n;
}
#Fischer-Krause permutation starting from a specific sequence, for example to farm out permute to more than one process
sub permute_continue (&\@\@) {
my ($f,$begin,$from) = @_;
my %h; @h{@$begin} = 0 .. $#$begin;
my @idx = @h{@$from};
my $n = 0;
while ( ++$n and &$f(@$begin[@idx]) ) {
my $p = $#idx || last;
--$p || last while $idx[$p-1] > $idx[$p];
push @idx, reverse splice @idx, my$q=$p;
++$q while $idx[$p-1] > $idx[$q];
$no_header_line=1;
}
$head=0;
$i++;
}
$i=$#height;
$j=$#width;
if($i==0 or $left_force) { @left=map{1}(0..$j) }
else { for(0..$j){ $left[$_]=1 if !$not_empty[$_] } }
my @tabout;
my $row_start_line=0;
my @header;
my $header_last;
for my $x (0..$i){
if($$tab[$x] eq '-'){
my @tegn=map {$$tab[$x-1][$_]=~/\S/?"-":" "} (0..$j);
$tabout[$row_start_line]=join(" ",map {$tegn[$_] x ($width[$_]-1)} (0..$j));
}
else{
for my $y (0..$j){
next if $remove_empty && !$not_empty[$y];
no warnings;
my @cell = !$header_last&&$nodup&&$nodup[$x][$y]
? ($nodup>0?():((" " x (($width[$y]-length($nodup))/2)).$nodup))
: split("\n",$$tab[$x][$y]);
for(0..($height[$x]-1)){
my $line=$row_start_line+$_;
my $txt=shift(@cell);
$txt='' if !defined$txt;
$txt=sprintf("%*s",$width[$y]-1,$txt) if length($txt)>0 && !$left[$y] && ($x>0 || $no_header_line);
$tabout[$line].=$txt;
if($y==$j){
$tabout[$line]=~s/\s+$//;
}
else{
my $wider;
$wider = $txt=~/<input.+type=text.+size=(\d+)/i?1+$1:0;
$txt=~s/<[^>]+>//g;
$txt=~s/>/>/g;
$txt=~s/</</g;
$tabout[$line].= ' ' x ($width[$y]-length($txt)-$wider);
}
}
}
}
$row_start_line+=$height[$x];
#--lage streker?
if(not $no_header_line){
if($x==0){
for my $y (0..$j){
next if $remove_empty && !$not_empty[$y];
$tabout[$row_start_line].=('-' x ($width[$y]-1))." ";
}
$row_start_line++;
@header=("",@tabout);
}
elsif(
$x%$pagesize==0 || $nodup>0&&!$nodup[$x+1][$nodup-1]
and $x+1<@$tab
and !$no_header_line
)
{
push(@tabout,@header);
$row_start_line+=@header;
$header_last=1;
}
else{
$header_last=0;
}
}
}#for x
return join("\n",@tabout)."\n";
}
delete: D Md
up/low/camelcase word U L C
backspace: -
search: S
return/enter: R
meta/esc/alt: M
shift: T
cut to eol: K
caps lock: C
yank: Y
start and end: < >
macro start/end/play: { } !
times for next cmd: M<number> (i.e. M24a inserts 24 a's)
(TODO: alfa...and more docs needed)
=cut
our $Edcursor;
sub ed {
my($s,$cs,$p,$buf)=@_; #string, commands, point (or cursor)
return $$s=ed($$s,$cs,$p,$buf) if ref($s);
finddup -v ... # verbose, print before -d, -s or -h
finddup -n -d <files> # dry run: show rm commands without actually running them
finddup -n -s <files> # dry run: show ln commands to make symlinks of duplicate files todo:NEEDS FIX!
finddup -n -h <files> # dry run: show ln commands to make hard links of duplicate files
finddup -q ... # quiet
finddup -k o # keep oldest with -d, -s, -h, consider newer files duplicates
finddup -k n # keep newest with -d, -s, -h, consider older files duplicates
finddup -k O # same as -k o, just use access time instead of modify time
finddup -k N # same as -k n, just use access time instead of modify time
finddup -0 ... # use ascii 0 instead of the normal \n, for xargs -0
finddup -P n # use n bytes from start of file in 1st md5 check (default 8192)
finddup -p # view progress in last and slowest of the three steps
Default ordering of files without C<-k n> or C<-k o> is the order they
are mentioned on the command line. For directory args the order might be
random: use C<< dir/* >> to avoid that (but then dot files are not included).
=cut
sub install_acme_command_tools {
my $dir=(grep -d$_, @_, '/usr/local/bin', '/usr/bin')[0];
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";
$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:
t/02_general.t view on Meta::CPAN
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' );
t/04_resolve.t view on Meta::CPAN
if($ENV{ATDEBUG}){
deb "Resolve: ".resolve(sub{my($x)=(@_); $x**2 - 4*$x -1},20,2)."\n";
deb "Resolve: ".resolve(sub{my($x)=@_; $x**log($x)-$x},0,3)."\n";
deb "Resolve: ".resolve(sub{$_[0]})." iters=$Acme::Tools::Resolve_iterations\n";
}
my $e;
ok(resolve(sub{my($x)=@_; $x**2 - 4*$x -21}) == -3 ,'first solution');
ok(($e=resolve(sub{ $_**2 - 4*$_ - 21 })) == -3 ,"first solution with \$_ (=$e)");
ok(resolve(sub{$_**2 - 4*$_ -21},0,3) == 7 ,'second solution, start 3');
ok(resolve(sub{my($x)=@_; $x**2 - 4*$x -21},0,2) == 7 ,'second solution, start 2');
my $f=sub{ $_**2 - 4*$_ - 21 };
ok(do{my$r=resolve($f,0,2); $r== 7} ,'second solution, start 2');
ok(resolve($f,0,2) == 7 ,'second solution, start 2');
ok(resolve($f,0,2) == 7 ,'second solution, start 2');
ok($Resolve_iterations > 1 ,"iterations=$Resolve_iterations");
ok($Resolve_last_estimate == 7 ,"last_estimate=$Resolve_last_estimate (should be 7)");
eval{ resolve(sub{1}) }; # 1=0
ok($@=~/Div by zero/);
ok(!defined $Resolve_iterations);
ok(!defined $Resolve_last_estimate);
my $c;
eval{$e=resolve(sub{$c++; sleep_fp(0.02); $_**2 - 4*$_ -21},0,.02,undef,undef,0.05)};
deb "x=$e, est=$Resolve_last_estimate, iters=$Resolve_iterations, time=$Resolve_time, c=$c -- $@\n";
# make test
# perl Makefile.PL; make; perl -Iblib/lib t/23_ed.t
use lib '.'; BEGIN{require 't/common.pl'}
use Test::More tests => 17;
sub tst {
my($start,$cmds,$end)=@_;
my $ed=ed($start,$cmds);
ok($ed eq $end, $ed eq $end ? "Ok ed() -> $ed" : "Got: $ed Expected: $end");
}
#--test sub ed
tst('','hello world', 'hello world' );
tst('','"Hello World!"', 'Hello World!' );
tst('hello world','FaDMF verdenMD', 'hallo verden' );
tst('hello world','EMBverdenMDMBMBDDha', 'hallo verden' );
tst("A.,-\nabc.",'FMD', 'A.' );
tst('hei du.','EM-', 'hei ' );
tst('d','{abc}!!', 'abcabcabcd' );
t/test_perm.pl view on Meta::CPAN
my $k=$n-2; 1 while $a[$k]>$a[$k+1] and $k--; last if $k<0;
my $l=$n-1; 1 while $a[$k]>$a[$l] and $l-->$k;
@a[$k,$l]=@a[$l,$k];
@a[$k+1..$#a]=reverse@a[$k+1..$#a] if $k<$n-2;
}
__END__
#https://en.wikipedia.org/wiki/Permutation#Generation_in_lexicographic_order
# prints e-1 ! 2.718281 - 1
my@a=(1..$n); #bryr seg ikke om elementene saalenge de starter sortert, er unike og sammenlignbare med <
my($i,$s)=(0,0);
while(1){
$i++;
print join(" ", @a)."\n";
my $k=$n-2; 1 while $a[$k]>=$a[$k+1] and $k--; last if $k<0;
my $l=$n-1; 1 while $a[$k]>=$a[$l] and $l-->$k;
@a[$k,$l]=@a[$l,$k];
next if $k == $n-2 and ++$s; #next not needed, but speeds up
$s+=$#a-$k;
@a[$k+1..$#a] = reverse @a[$k+1..$#a] ;
t/test_pi.pl view on Meta::CPAN
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)
}
$s*=2*sqrt(bigf(2))/9801;
my $mypi=1/$s;
printf "%9d: %30.25f %30.25f %g %5.2fs\n", $n, $mypi, $pi_bigger-$mypi, $pi_bigger-$mypi, time_fp()-$start;
}
}
sub pi_approx {
my($min,$imp)=(9e9,0); $|=1;
for my $n (1..1e7){
my $x=int($pi*$n);
print "$n\r" if $n%1000==0;
for($x..$x+1){
my $mypi=$_/$n;
my $diff=abs($pi-$mypi);
next unless $diff<$min and $imp=$min/$diff and $min=$diff and $imp>1.1;
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?
Did you know that the volume of a pizza with thickness a and radius z is pi z z a?
wget https://gmplib.org/download/misc/gmp-chudnovsky.c
sudo apt-get install libgmpv4-dev
t/test_resolve_bigfloat.pl view on Meta::CPAN
#!/usr/bin/perl
use Acme::Tools;
use Math::BigFloat try => 'GMP'; # pure perl, no warnings if GMP not installed
my $start=Math::BigFloat->new(1);
my $gr1 = resolve(sub{my$x=shift; $x-1-1/$x;},0,1); # 1/2 + sqrt(5)/2
my $gr2 = resolve(sub{my$x=shift; $x-1-1/$x;},0,$start);# 1/2 + sqrt(5)/2
Math::BigFloat->div_scale(50);
my $gr3 = resolve(sub{my$x=shift; $x-1-1/$x;},0,$start);# 1/2 + sqrt(5)/2
print "Golden ratio 1: $gr1\n";
print "Golden ratio 2: $gr2\n";
print "Golden ratio 3: $gr3\n";
( run in 0.460 second using v1.01-cache-2.11-cpan-0d8aa00de5b )