package Calc;
use strict;
use vars qw'$british $answ';
use Roman;
my $parens = qr{
\(
(?:
(?> [^()]+ ) # Non-parens without backtracking
|
(??{ $parens }) # Group with matching parens
)*
\)
}x;
my %bin2hex = qw(0000 0 0001 1 0010 2 0011 3
0100 4 0101 5 0110 6 0111 7
1000 8 1001 9 1010 A 1011 B
1100 C 1101 D 1110 E 1111 F);
my %hex2bin = reverse %bin2hex;
my %parts = qw(nul 0 een 1 eer 1 twee 2 twin 2 drie 3 der 3 vier 4
veer 4 vijf 5 zes 6 zeven 7 acht 8 tach 8 negen 9
tien +10 elf 11 twaalf 12 dozijn *12 tig *10
honderd *100 gros *144 duizend *1e3 miljoen *1e6
miljard *1e9 biljoen *1e12 biljard *1e15 triljoen *1e18
triljard *1e21 quadriljoen *1e24 quadriljard *1e27
quantiljoen *1e30 quantiljard *1e33 sexiljoen *1e36
sexiljard *1e39 septiljoen *1e42 septiljard *1e45
octiljoen *1e48 octiljard *1e51 noniljoen *1e54
noniljard *1e57 deciljoen *1e60 deciljard *1e63
undeciljoen *1e66 undeciljard *1e69 dodeciljoen *1e72
dodeciljard *1e75 quindeciljoen *1e90
quindeciljard *1e93 isosiljoen *1e120 isosiljard *1e123
zero 0 ough 0 one 1 (?:fir)st 1 two 2 twen 2
(?:seco)nd 2 three 3 third? 3 fou?r 4 five 5 fif 5
six 6 seven 7 eight? 8 nine? 9 ten 10 teen +10
eleven 11 twelve 12 t?y *10b dozens? *12b hundred *100b
hunderd *100b thousand *1e3b million *1e6b
milliard *1e9b billion *1e12B billiard *1e15b
trillion *1e18B quandrillion *1e24B quintillion *1e30
sextillion *1e36B septillion *1e42B octillion *1e48B
nonillion *1e54B decillion *1e60B undecillion *1e66B
duodecillion *1e72B tredecillion *1e78B
quattuordecillion *1e82B quindecillion *1e88B
sexdecillion *1e94B septendecillion *1e100B
octodecillion *1e106B novemdecillion *1e112B
vigintillion *1e118B centillion *1e600B google *1e100b
googol *1e100b zillion *42b);
my (%triNL, %triUK);
{
no warnings; # puhleaase :)
my %revgetal = reverse %parts;
%triNL =
(0 =>
'' =>
map { $_ => $revgetal{"*1e$_"} }
grep { s/^\*1e//g and not /\D/ and $_ <= 22 }
my @dummy = values %parts
);
%triUK =
(0 =>
'' =>
map { (my $foo) = /(\d+)/; $foo => $revgetal{"*1e$_"}
+}
grep { s/^\*1e//g and /[bB]/ and $_ <= 22 }
@dummy = values %parts
);
$triNL{''} = '';
$triUK{''} = '';
}
sub bin2hex($){
my ($bin) = @_;
$bin =~ tr/01//cd;
$bin = '0' x (4 - length($bin)%4) . $bin;
$bin =~ s/^(?:0000)+//g;
$bin =~ s/([01]{4})/$bin2hex{$1}/g;
return $bin;
}
sub fac($){
die "I refuse to do so\n" if $_[0] > 1000;
die "Erhm?\n" if $_[0] < 0;
my $ret = 1;
$ret *= $_ for 2..$_[0];
return $ret;
}
sub som(@){
my $ret;
$ret += $_ for @_;
return $ret;
}
sub merge(@){
my $vgl = pop @_;
my @l = @_;
FOO: {
BAR: for (0..$#l){
last BAR if not defined $l[$_+1];
if (($l[$_] + $l[$_+1]) < $vgl and length($l[$_]) != lengt
+h($l[$_+1])){
$l[$_] += splice @l, ($_+1), 1;
redo FOO;
}
}
}
return @l;
}
sub text2number($){
(my $getal = $_[0]) =~ tr/A-Z/a-z/;
my $ogetal = $getal;
$getal =~ tr/a-z0-9 -//cd;
$getal =~ tr/a-z0-9//cd;
$getal =~ s/(?:d|st)e$//;
my $nullen = 0;
$nullen++ while $getal =~ s/^\s*(?:null?|zero|ough|oh?\b)\s*//;
$getal =~ tr/a-z0-9//cd;
my @teller;
my $ster;
my $nuster;
my $vorigester;
my $vorigevalue;
my $olen = length ($getal);
my $nlen = 0;
ZOEK: {
my $abort = 1;
last ZOEK if $getal !~ /[a-z0-9]/;
$getal =~ s/^(?:en|and)//;
$nlen += length($1);
if ($getal =~ s/^(\d+)//){
push @teller, $1;
$nlen += length($1);
}
for (keys %parts){
if ($getal =~ /^($_)/){
$nlen += length($1);
$getal =~ s///;
$abort = 0;
my ($pre, $value) = $parts{$_} =~ /([+*]?)(.*)/;
$british = 1 if $value =~ s/B//;
$value =~ s/b//;
$value =~ s/(\d+e\d+)/$1/ee;
@teller = (som(@teller)) if $vorigester and (sort @tel
+ler == @teller); #nuster and $value < $vorigevalue;
$vorigester = 0;
$vorigevalue = $value;
if ($pre eq '*'){
if (@teller){
@teller = merge(@teller, $value);
eval {
$teller[$#teller] *= $value;
};
$vorigester = 1;
}else{
@teller = ($value);
}
}elsif ($pre eq '+'){
$ster = 0;
if (@teller){
$teller[$#teller] += $value;
}else{
@teller = ($value);
}
}else{
$ster = 0;
push @teller, $value;
}
}
}
redo ZOEK unless $abort;
}
if ($nlen > 9){
return @teller ? som(@teller) : '';
}elsif ($nlen > length($getal)){
return ('0'x$nullen) . (@teller ? som(@teller) : '') # . $geta
+l;
}else{
return $ogetal;
}
}
sub number2text_nl($);
sub number2text_nl($){
my $tri = 0;
my $getal = $_[0];
my $trug = '';
my %cijf = (0 => '',
qw(1 een 2 twee 3 drie 4 vier 5 vijf 6 zes 7 zeven 8 acht 9 nege
+n));
my %tig = (0 => '',
qw(1 EEN 2 twin 3 der 4 veer 5 vijf 6 zes 7 zeven 8 tach 9 negen
+));
my %tien = qw(een elf twee twaalf drie dertien vier veertien);
return "heleboel" if $getal > 1e15; #eigenlijk 22
$getal = sprintf("%f", $getal);
$getal =~ s/\.0*$//;
my $nullen;
if (my ($een, $twee) = $getal =~ /^(\d*)\.(\d*)$/){
$twee =~ s/0+$//;
$nullen++ while $twee =~ s/^0//;
return number2text_nl($een) . ' komma ' . ('nul ' x $nullen) .
+ number2text_nl($twee);
}
$getal = reverse $getal;
for ($getal =~ /(\d{1,3})/g){
/(\d)(\d?)(\d?)/;
my $rev = '';
if ($3){
$rev .= $cijf{$3} if $3 > 1;
$rev .= 'honderd' if $3;
$rev .= 'en' if $1 xor $2; # (!!$1 <=> !!$2 is
+mooier :)
}
$rev .= $cijf{$1} if $1;
$rev .= "en" if $1 and $2;
$rev .= "$tig{$2}tig" if $2;
$rev .= $triNL{$tri} if $_ + 0;
$tri += length;
$trug = "$rev$trug";
}
if ($trug){
for (keys %tien){
$trug =~ s/${_}enEENtig/$tien{$_}/g;
}
$trug =~ s/(?:en)?EENtig/tien/g;
}else{
$trug = 'nul';
}
$trug = "min $trug" if $getal =~ /-/;
return $trug;
}
sub number2text_uk($);
sub number2text_uk($){
my $tri = 0;
my $getal = $_[0];
my $trug = '';
my %cijf = (0 => '',
qw(1 one 2 two 3 three 4 four 5 five 6 six 7 seven 8 eight 9 nin
+e));
my %tig = (0 => '',
qw(1 ONE 2 twen 3 thir 4 for 5 fif 6 six 7 seven 8 eigh 9 nine))
+;
my %tien = qw(one eleven two twelve three thirteen four fourteen f
+ive fifteen);
return "lots" if $getal > 1e15; #eigenlijk 22
$getal = sprintf("%f", $getal);
$getal =~ s/\.0*$//;
my $nullen;
if (my ($een, $twee) = $getal =~ /^(\d*)\.(\d*)$/){
$twee =~ s/0+$//;
$nullen++ while $twee =~ s/^0//;
return number2text_uk($een) . ' point ' . ('ough ' x $nullen)
+. number2text_uk($twee);
}
$getal = reverse $getal;
for ($getal =~ /(\d{1,3})/g){
/(\d)(\d?)(\d?)/;
my $rev = '';
if ($3){
$rev .= $cijf{$3} if $3 > 1;
$rev .= 'hundred' if $3;
$rev .= 'and' if $1 or $2;
}
$rev .= "$tig{$2}ty" if $2;
$rev .= $cijf{$1} if $1;
$rev .= $triUK{$tri} if $_ + 0;
$tri += length;
$trug = "$rev$trug";
}
if ($trug){
for (keys %tien){
$trug =~ s/ONEty${_}/$tien{$_}/g;
}
$trug =~ s/ONEty/ten/g;
}else{
$trug = 'zero';
}
$trug = "minus $trug" if $getal =~ /-/;
return $trug;
}
sub ip($){
my $r = 0;
my $i = 0;
for (reverse split //, $_[0]){
$r += 256**($i++) * ord;
}
return $r;
}
sub calc{
my @func = qw(abs atan2 cos log sin sqrt tan asin acos atan pi int
+ rand ip fac xor);
my ($gulden, $euro) = (qr/guldens?|NLG|[HDN]?FL|piek/i,
qr/euro\'?s?|EUR/i);
my $g2e = qr/(?:van )?(?<!naar )$gulden(?: naar $euro)?/i;
my $e2g = qr/(?:van )?(?<!naar )$euro(?: naar $gulden)?/i;
my $a = join ' ', @_;
my $output = (
$a =~ /-o:(?:nl|ned)/ ? 'nl'
: $a =~ /-o:(?:uk|eng?)/ ? 'uk'
: $a =~ /-o:rom/ ? 'rom'
: $a =~ /-o:(?:he)?x/ ? 'hex'
: $a =~ /-o:b(?:in)?/ ? 'bin'
: $a =~ /-o:oct/ ? 'oct'
: ''
);
$a =~ s/-o:\S*//g;
$a =~ s/\s+/ /;
if ($a =~ /\xB1/){
return "Forget it"
}
$a =~ s/#.*//;
my %func;
my $func;
for (@func){
$func{$_} = ++$func;
}
my %exp = qw( M 10^6 k 1_000 g 10^9
T 10^12 MB 2^20 kB 2^10
gB 2^30 TB 2^40 m 0.001
mb 10^6 K 2^10 KB 2^10
kb 2^10 GB 2^30 gb 2^30
tb 2^40 Mb 1_000 kb 1_000
PB 2^50);
my %words = (qw(
e 2.718281828
(?:gedeeld|delen)\s*door / hex 0x
(?:procent|%)\s*van /100*
plus + and && keer *
o[rf] || en && maal *
[kc]omma . times *
not ! is = bin b
niet ! equals? = oct 0
lt < eq = punt . point .
gt > kwadraat ^2
sqr sqrt graad *(pi/180) graden *(pi/180)
degrees? *(pi/180)
min(?:us)? - mod(?:ul(?:o|us))? %
less\s*than < kleiner\s*dan <
greater\s*than > groter\*dan >
gelijk\*aan = divide(?:d\s*by)? /
tot(?:\s*de)? ^
(?:to\s*the\s*)?pow(?:er)?(?:\s*of) ^
(?:de\s*)?(?:\s*vierkants)?wortel(?:\s*van)?
+ sqrt
(?:the\s*)?(?:square\s*)?root(?:\s*of)? sqrt
(?:de\s*)?sin(?:us)?(?:\s*van)? sin
(?:de\s*)?tang?(?:[ue]s)?(?:\s*van)? tan
(?:de\s*)?cosin(?:us)?(?:\s*van)? cos
true 1 heleboel ~0
false 0 lots ~0
),
$g2e => '/2.20371', $e2g => '*2.20371',
);
my %chars = qw(<B9> ^1 <B2> ^2 <B3> ^3 <AB> << <BB> >>);
for (keys %chars){
$a =~ s/$_/$chars{$_}/g;
}
$a =~ s/(?:d|st)?e\s+macht//gi;
for (keys %words){
$a =~ s/(?<![A-Za-z0-9_-])$_(?![A-Za-z_-])/$words{$_}/g;
}
for (keys %func){
$a =~ s/(?<![A-Za-z0-9_])$_(?![A-Za-z_])/*%*%$func{$_}%*%/g;
}
$a =~ tr|,÷:·[]{}ë|.//*()()e|;
$a =~ s/\b([IVXLCDM]+)(?=[mkgTPMKG]?\b)/isroman($1)?arabic($1):$1/
+eg;
$a =~ s/(?<![a-z_A-Z0-9])([\d\.]+)([tmkg]b?)\b/($1*$exp{$2})/ig;
$a =~ s/([\w.]+)!/*%*%$func{fac}%*%($1)/g;
$a =~ s/($parens)!/*%*%$func{fac}%*%$1/g;
$a =~ s/\ban[ts]w?\b/$answ/g;
$a =~ s/\bb([\s01]+)/"0x" . bin2hex($1)/eg;
$a =~ s/(\d*)\xBC/($1+.25)/g;
$a =~ s/(\d*)\xBD/($1+.5)/g;
$a =~ s/(\d*)\xBE/($1+.75)/g;
# Eerste
$a =~ s/[^\s\d~x!<>=A-Za-z%e*\.+\-&|\)\(x\/\^]//g;
if ($a =~ /[A-Fx]/){
$a = reverse $a;
$a =~ s/x(?!0\b|[a-z-]+\b|\s+\b|$)/*/g;
$a =~ s{
(\d*) # cijfertjes aan het eind
([ABCDEF]+) # minstens 1 hoofdletter A-F
(?![0-9A-F]*x0) # niet 0x ervoor
(\d*[0-9A-F]*) # cijfertjes+lettertjes ervoor
}{
my ($pre, $hex, $post) = ($1, $2, $3);
($hex eq 'E' and $pre =~ m!\d! and $post !~ m!\d+[A-F]!) ?
"$pre$hex$post" # 3E3 == 3000
:
"$pre$hex${post}x0" # hexify! :)
}gex;
$a = reverse $a;
}
$a =~ s/0x([0-9A-Fe]*)/'0x' . uc $1/ge;
$brittish = 0;
my $eerste = qq/[a-z0-9_]/;
my $daarna = qq/[a-z0-9_-]/;
my $woord = qq/$eerste$daarna*/;
$a =~ s/($woord(?:\s+$woord)*)/my $foo = $1; $foo =~ m!^[\dA-Fxei_
+-]+$! ? $foo : text2number($foo)/eg;
# $a =~ s/($woord(?:\s+$woord)*)/my $foo = $1; $foo =~ m!^[\dA-Fxei_
+-]+$! ? $foo : ($qwe = $karma->get($foo)) < 0 ? "($qwe)" : ($qwe || 0
+)/eg;
# Tweede
$a =~ s/[^\d~x!<>=A-F%ei*\.+\-&|\)\(x\/\^]//g;
$a =~ s/<>/!=/g;
$a =~ s/></*/g;
$a =~ s/=([<>!])/$1=/g;
$a =~ s/\*\*/^/g;
$a =~ s/([+\-])(\1+)/join ' ', ($1) x length($1 . $2)/eg;
$a =~ s/([~e=x*+%\\.\-\/^])(\1*)/$1/eg;
$a =~ s/([a-z]{2,})/$1 /g;
$a =~ s/\^/**/g;
$a =~ s/([<>])\1\1+/$1$1/g;
$a =~ s/(?<![!<>])=/==/g;
$a =~ s/(?<=[\dA-F])i/*i/g;
%func = reverse %func;
$a =~ s/\*%\*%(\d+)%\*%/$func{$1} /g;
my $tempansw = '';
unless ($a =~ /^[*\/]/){
if ($a eq '1+1'){
my @randomzut = qw(3 666 42 3.1415926536 0 -1 ~0 DUH);
$tempansw = $randomzut[rand @randomzut];
}else{
{ use Math::Complex; use Math::Trig;
Math::Complex::display_format('cartesian');
eval("\$tempansw = ($a) || 0");
}
$tempansw .= '';
$tempansw =~ s/ \(/\(/g;
if ($tempansw =~ /i/){
$tempansw =~ s/\[(.*?),pi\]/-$1/g;
$tempansw =~ s/(?<=\d)i/*i/g;
if ($output){
$output = '';
# privmsg('De uitkomst is een complex getal. Comple
+xe getallen zijn niet compatible met -o.');
}
}
if ($output eq 'nl'){
$tempansw = number2text_nl($tempansw);
}elsif ($output eq 'uk'){
$tempansw = number2text_uk($tempansw);
}elsif ($output eq 'rom'){
$tempansw = $tempansw < 4000 ? uc roman(int ($tempansw
+ + .5))
: 'Zoveel geld hadden de romeinen niet...'
}elsif ($output eq 'hex'){
$tempansw = $tempansw <= (~0) ? sprintf("0x%X", int($t
+empansw + .5)) : '> ~0';
}elsif ($output eq 'bin'){
$tempansw = $tempansw <= (~0) ? 'b' . join '', map {"
+$hex2bin{$_}"} split //, sprintf("%X", int($tempansw + .5)) : '> ~0';
}elsif ($output eq 'oct'){
$tempansw = $tempansw <= (~0) ? sprintf("0%o", int($te
+mpansw + .5)) : '> ~0';
}
}
}
$a =~ s/\*\*/^/g;
$a =~ s/ (?![\da-z])//g;
if ($tempansw ne ''){
$answ = $tempansw;
$answ =~ tr/\0-\x1F//d;
$answ =~ tr/\x80-\xFF//d;
return "$a = $answ";
# privmsg('Note: De Britse interpretatie van billion t/m centill
+ion is gebruikt, niet de Amerikaanse.')
# if $british;
}else{
my $lastcalcerr =~ tr/\n//d;
return "$a = ??" . ($lastcalcerr ? " ($lastcalcerr)" : '');
}
}
1;
In reply to Calc.pm
by Juerd
Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
Read Where should I post X? if you're not absolutely sure you're posting in the right place.
Please read these before you post! —
Posts may use any of the Perl Monks Approved HTML tags:
- a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
| |
For: |
|
Use: |
| & | | & |
| < | | < |
| > | | > |
| [ | | [ |
| ] | | ] |
Link using PerlMonks shortcuts! What shortcuts can I use for linking?
See Writeup Formatting Tips and other pages linked from there for more info.