Initial Commit
This commit is contained in:
Riley Schneider
163
database/perl/vendor/lib/Math/Base/Convert/Bases.pm
vendored
Normal file
163
database/perl/vendor/lib/Math/Base/Convert/Bases.pm
vendored
Normal file
@@ -0,0 +1,163 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package Math::Base::Convert::Bases;
|
||||
|
||||
$VERSION = 0.03;
|
||||
|
||||
package Math::Base::Convert; # into the main package
|
||||
|
||||
@BASES = qw( bin dna DNA oct dec hex HEX b62 b64 m64 iru url rex id0 id1 xnt xid b85 ascii );
|
||||
|
||||
$signedBase = 16; # largest allowable known signed base
|
||||
|
||||
my $package = __PACKAGE__;
|
||||
my $packageLen = length __PACKAGE__;
|
||||
|
||||
sub _class {
|
||||
(my $class = (caller(1))[3]) =~ s/([^:]+)$/_bs::$1/;
|
||||
$class;
|
||||
}
|
||||
|
||||
my $callname = __PACKAGE__ . '::_bs::';
|
||||
|
||||
# return a pointer to a sub for the array blessed into Package::sub::name
|
||||
#
|
||||
|
||||
my $_bin = bless ['0', '1'], $callname . 'bin';
|
||||
my $_dna = bless [qw( a c t g )], $callname . 'dna';
|
||||
my $_DNA = bless [qw( A C T G )], $callname . 'DNA';
|
||||
my $_ocT = bless ['0'..'7'], $callname . 'ocT';
|
||||
my $_dec = bless ['0'..'9'], $callname . 'dec';
|
||||
my $_heX = bless ['0'..'9', 'a'..'f'], $callname . 'heX';
|
||||
my $_HEX = bless ['0'..'9', 'A'..'F'], $callname . 'HEX';
|
||||
my $_b62 = bless ['0'..'9', 'a'..'z', 'A'..'Z'], $callname . 'b62';
|
||||
my $_b64 = bless ['0'..'9', 'A'..'Z', 'a'..'z', '.', '_'], $callname . 'b64';
|
||||
my $_m64 = bless ['A'..'Z', 'a'..'z', '0'..'9', '+', '/'], $callname . 'm64';
|
||||
my $_iru = bless ['A'..'Z', 'a'..'z', '0'..'9', '[', ']'], $callname . 'iru';
|
||||
my $_url = bless ['A'..'Z', 'a'..'z', '0'..'9', '*', '-'], $callname . 'url';
|
||||
my $_rex = bless ['A'..'Z', 'a'..'z', '0'..'9', '!', '-'], $callname . 'rex';
|
||||
my $_id0 = bless ['A'..'Z', 'a'..'z', '0'..'9', '_', '-'], $callname . 'id0';
|
||||
my $_id1 = bless ['A'..'Z', 'a'..'z', '0'..'9', '.', '_'], $callname . 'id1';
|
||||
my $_xnt = bless ['A'..'Z', 'a'..'z', '0'..'9', '.', '-'], $callname . 'xnt';
|
||||
my $_xid = bless ['A'..'Z', 'a'..'z', '0'..'9', '_', ':'], $callname . 'xid';
|
||||
my $_b85 = bless ['0'..'9', 'A'..'Z', 'a'..'z', '!', '#', # RFC 1924 for IPv6 addresses, might need to return Math::BigInt objs
|
||||
'$', '%', '&', '(', ')', '*', '+', '-', ';', '<', '=', '>', '?', '@', '^', '_', '`', '{', '|', '}', '~'], $callname . 'b85';
|
||||
|
||||
my $_ascii = bless [
|
||||
' ','!','"','#','$','%','&',"'",'(',')','*','+',',','-','.','/',
|
||||
'0','1','2','3','4','5','6','7','8','9',
|
||||
':',';','<','=','>','?','@',
|
||||
'A','B','C','D','E','F','G','H','I','J','K','L','M',
|
||||
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
|
||||
'[','\\',']','^','_','`',
|
||||
'a','b','c','d','e','f','g','h','i','j','k','l','m',
|
||||
'n','o','p','q','r','s','t','u','v','w','x','y','z',
|
||||
'{','|','}','~'], $callname . 'ascii'; # 7 bit printable ascii, base 96
|
||||
|
||||
#my $_ebcdic = bless [qw
|
||||
# ( 0 1 2 3 37 2D 2E 2F 16 5 25 0B 0C 0D 0E 0F 10 11 12 13 3C 3D 32 26 18 19 3F 27 1C 1D 1E 1F
|
||||
# 40 4F 7F 7B 5B 6C 50 7D 4D 5D 5C 4E 6B 60 4B 61 F0 F1 F2 F3 F4 F5 F6 F7 F8 F9 7A 5E 4C 7E 6E 6F
|
||||
# 7C C1 C2 C3 C4 C5 C6 C7 C8 C9 D1 D2 D3 D4 D5 D6 D7 D8 D9 E2 E3 E4 E5 E6 E7 E8 E9 4A E0 5A 5F 6D
|
||||
# 79 81 82 83 84 85 86 87 88 89 91 92 93 94 95 96 97 98 99 A2 A3 A4 A5 A6 A7 A8 A9 C0 6A D0 A1 7
|
||||
# 20 21 22 23 24 15 6 17 28 29 2A 2B 2C 9 0A 1B 30 31 1A 33 34 35 36 8 38 39 3A 3B 4 14 3E E1 41
|
||||
# 42 43 44 45 46 47 48 49 51 52 53 54 55 56 57 58 59 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
|
||||
# 77 78 80 8A 8B 8C 8D 8E 8F 90 9A 9B 9C 9D 9E 9F A0 AA AB AC AD AE AF B0 B1 B2 B3 B4 B5 B6 B7 B8
|
||||
# B9 BA BB BC BD BE BF CA CB CC CD CE CF DA DB DC DD DE DF EA EB EC ED EE EF FA FB FC FD FE FF)], $callname . 'ebcdic';
|
||||
|
||||
sub bin { $_bin }
|
||||
sub dna { $_dna }
|
||||
sub DNA { $_DNA }
|
||||
sub ocT { $_ocT }
|
||||
sub dec { $_dec }
|
||||
sub heX { $_heX }
|
||||
sub HEX { $_HEX }
|
||||
sub b62 { $_b62 }
|
||||
sub b64 { $_b64 }
|
||||
sub m64 { $_m64 }
|
||||
sub iru { $_iru }
|
||||
sub url { $_url }
|
||||
sub rex { $_rex }
|
||||
sub id0 { $_id0 }
|
||||
sub id1 { $_id1 }
|
||||
sub xnt { $_xnt }
|
||||
sub xid { $_xid }
|
||||
sub b85 { $_b85 }
|
||||
sub ascii { $_ascii }
|
||||
#sub ebcdic { $_ebcdic }
|
||||
|
||||
# Since we're not using BIcalc, the last test can be eliminated...
|
||||
################### special treatment for override 'hex' ##################################
|
||||
|
||||
sub hex {
|
||||
# unless our package and is a BC ref and not a BI number (which is an ARRAY)
|
||||
unless (ref($_[0]) && $package eq substr(ref($_[0]),0,$packageLen) && (local *glob = $_[0]) && *glob{HASH}) {
|
||||
# $package, $filename, $line, $subroutine, $hasargs
|
||||
# 0 1 2 3 4
|
||||
# if defined and hasargs
|
||||
if ( defined $_[0] && (caller(0))[4] ) {
|
||||
return CORE::hex $_[0];
|
||||
}
|
||||
}
|
||||
return heX();
|
||||
}
|
||||
|
||||
################### special treatment for override 'oct' #################################
|
||||
sub oct {
|
||||
# unless our package and is a BC ref and not a BI number (which is an ARRAY)
|
||||
unless (ref($_[0]) && $package eq substr(ref($_[0]),0,$packageLen) && (local *glob = $_[0]) && *glob{HASH}) {
|
||||
# $package, $filename, $line, $subroutine, $hasargs
|
||||
# 0 1 2 3 4
|
||||
# if defined and hasargs
|
||||
if ( defined $_[0] && (caller(0))[4] ) {
|
||||
return CORE::oct $_[0];
|
||||
}
|
||||
}
|
||||
return ocT();
|
||||
}
|
||||
|
||||
################################## REMOVE ABOVE CODE ###################
|
||||
|
||||
# return a hash of all base pointers
|
||||
#
|
||||
sub _bases {
|
||||
no strict;
|
||||
my %bases;
|
||||
foreach (@BASES) {
|
||||
my $base = $_->();
|
||||
ref($base) =~ /([^:]+)$/;
|
||||
$bases{$1} = $base;
|
||||
}
|
||||
\%bases;
|
||||
}
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Math::Base::Convert::Bases - helper module for bases
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package contains no documentation
|
||||
|
||||
See L<Math::Base::Convert> instead
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Michael Robinton, michael@bizsystems.com
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2012-2015, Michael Robinton
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
1159
database/perl/vendor/lib/Math/Base/Convert/Bitmaps.pm
vendored
Normal file
1159
database/perl/vendor/lib/Math/Base/Convert/Bitmaps.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
231
database/perl/vendor/lib/Math/Base/Convert/CalcPP.pm
vendored
Normal file
231
database/perl/vendor/lib/Math/Base/Convert/CalcPP.pm
vendored
Normal file
@@ -0,0 +1,231 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package Math::Base::Convert::CalcPP;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
$VERSION = do { my @r = (q$Revision: 0.03 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
|
||||
|
||||
# test number < 2^32 is NOT power of 2
|
||||
#
|
||||
sub isnotp2 {
|
||||
my $ref = ref $_[0];
|
||||
shift if ref $_[0] || $_[0] =~ /\D/; # class?
|
||||
$_[0] & $_[0] -1;
|
||||
}
|
||||
|
||||
# add a long n*32 bit number toa number < 65536
|
||||
# add 'n' to array digits and propagate carry, return carry
|
||||
#
|
||||
sub addbaseno {
|
||||
my($ap,$n) = @_;
|
||||
foreach (@$ap) {
|
||||
$_ += $n;
|
||||
return 0 unless $_ > 0xffffffff;
|
||||
$n = 1;
|
||||
$_ -= 4294967296;
|
||||
}
|
||||
1; # carry is one on exit, else would have taken return 0 branch
|
||||
}
|
||||
|
||||
# multiply a register of indeterminate length by a number < 65535
|
||||
#
|
||||
# ap pointer to multiplicand array
|
||||
# multiplier
|
||||
#
|
||||
sub multiply {
|
||||
my($ap,$m) = @_;
|
||||
# $m is always 2..65535
|
||||
# $m &= 0xffff; # max value 65535 already done by VETTING
|
||||
#
|
||||
# perl uses doubles for arithmetic, $m << 65536 will fit
|
||||
my $carry = 0;
|
||||
foreach ( @$ap) {
|
||||
$_ *= $m;
|
||||
$_ += $carry;
|
||||
if ($_ > 0xffffffff) {
|
||||
$carry = int($_ / 4294967296);
|
||||
$_ %= 4294967296;
|
||||
} else {
|
||||
$carry = 0;
|
||||
}
|
||||
}
|
||||
push @$ap, $carry if $carry;
|
||||
}
|
||||
|
||||
sub dividebybase {
|
||||
my($np,$divisor) = @_;
|
||||
my @dividend = @$np; # 3% improvement
|
||||
while ($#dividend) { # 3% improvement
|
||||
last if $dividend[0];
|
||||
shift @dividend;
|
||||
}
|
||||
my $remainder = 0;
|
||||
my @quotient;
|
||||
while (@dividend) {
|
||||
my $work = ($dividend[0] += ($remainder * 4294967296));
|
||||
push @quotient, int($work / $divisor);
|
||||
$remainder = $work % $divisor;
|
||||
shift @dividend;
|
||||
}
|
||||
return (\@quotient,$remainder);
|
||||
}
|
||||
|
||||
# simple versions of conversion, works for N < ~2^49 or 10^16
|
||||
#
|
||||
#sub frombase {
|
||||
# my($hsh,$base,$str) = @_;
|
||||
# my $number = 0;
|
||||
# for( $str =~ /./g ) {
|
||||
# $number *= $base;
|
||||
# $number += $hsh->{$_};
|
||||
# }
|
||||
# return $number;
|
||||
#}
|
||||
|
||||
#sub tobase {
|
||||
#sub to_base
|
||||
# my($bp,$base,$num) = @_;
|
||||
# my $base = shift;
|
||||
# return $bp->[0] if $num == 0;
|
||||
# my $str = '';
|
||||
# while( $num > 0 ) {
|
||||
# $str = $bp->[$num % $base] . $str;
|
||||
# $num = int( $num / $base );
|
||||
# }
|
||||
# return $str;
|
||||
#}
|
||||
|
||||
# convert a number from its base to 32*N bit representation
|
||||
#
|
||||
sub useFROMbaseto32wide {
|
||||
my $bc = shift;
|
||||
my($ary,$hsh,$base,$str) = @{$bc}{qw(from fhsh fbase nstr)};
|
||||
# check if decimal and interger from within perl's 32bit double representation
|
||||
# cutoff is 999,999,999,999,999 -- a bit less than 2^50
|
||||
#
|
||||
# convert directly to base 2^32 arrays
|
||||
#
|
||||
my @result = (0);
|
||||
|
||||
if ($base == 10 && length($str) < 16) {
|
||||
# unless ($str > 999999999999999) { # maximum 32 bit double float integer representation
|
||||
$result[0] = $str % 4294967296;
|
||||
my $quotient = int($str / 4294967296);
|
||||
$result[1] = $quotient if $quotient;
|
||||
$bc->{b32str} = \@result;
|
||||
}
|
||||
else {
|
||||
for ($str =~ /./g) {
|
||||
multiply(\@result,$base);
|
||||
push @result, 1 if addbaseno(\@result,$hsh->{$_}); # propagate carry
|
||||
}
|
||||
# my @rv = reverse @result;
|
||||
$bc->{b32str} = \@result;
|
||||
}
|
||||
$bc;
|
||||
}
|
||||
|
||||
#my %used = map {$_,0}(0..255);
|
||||
|
||||
# convert 32*N bit representation to any base < 65536
|
||||
#
|
||||
|
||||
sub use32wideTObase {
|
||||
my $bc = shift;
|
||||
my($ary,$base,$rquot) = @{$bc}{qw(to tbase b32str)};
|
||||
my @quotient = reverse(@$rquot);
|
||||
my $quotient = \@quotient;
|
||||
my @answer;
|
||||
my $remainder;
|
||||
do {
|
||||
($quotient,$remainder) = dividebybase($quotient,$base);
|
||||
# these commented out print statements are for convert.t DO NOT REMOVE!
|
||||
#$used{$remainder} = 1;
|
||||
#print $remainder;
|
||||
#print " *" if $remainder > 86;
|
||||
#print "\n";
|
||||
unshift @answer, $ary->[$remainder];
|
||||
} while grep {$_} @$quotient;
|
||||
|
||||
#foreach (sort {$b <=> $a} keys %used) {
|
||||
#print " $_,\n" if $used{$_} && $_ > 85;
|
||||
#print "\t$_\t=> \n" if !$used{$_} && $_ < 86;
|
||||
#}
|
||||
join '', @answer;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Math::Base::Convert::CalcPP - standard methods used by Math::Base::Convert
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module contains the standard methods used by B<Math::Base::Convert> to
|
||||
convert from one base number to another base number.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * $carry = addbaseno($reg32ptr,$int)
|
||||
|
||||
This function adds an integer < 65536 to a long n*32 bit register and
|
||||
returns the carry.
|
||||
|
||||
=item * multiply($reg32ptr,$int)
|
||||
|
||||
This function multiplies a long n*32 bit register by an integer < 65536
|
||||
|
||||
=item * ($qptr,$remainder) = dividebybase($reg32ptr,$int)
|
||||
|
||||
this function divides a long n*32 bit register by an integer < 65536 and
|
||||
returns a pointer to a long n*32 bit quotient and an integer remainder.
|
||||
|
||||
=item * $bc->useFROMbaseto32wide
|
||||
|
||||
This method converts FROM an input base string to a long n*32 bit register using
|
||||
an algorithim like:
|
||||
|
||||
$longnum = 0;
|
||||
for $char ( $in_str =~ /./g ) {
|
||||
$longnum *= $base;
|
||||
$longnum += $value{$char)
|
||||
}
|
||||
return $number;
|
||||
|
||||
=item * $output = $bc->use32wideTObase
|
||||
|
||||
This method converts a long n*32 bit register TO a base number using an
|
||||
algorithim like:
|
||||
|
||||
$output = '';
|
||||
while( $longnum > 0 ) {
|
||||
$output = ( $longnum % $base ) . $output;
|
||||
$num = int( $longnum / $base );
|
||||
}
|
||||
return $output;
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Michael Robinton, michael@bizsystems.com
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2012-15, Michael Robinton
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
462
database/perl/vendor/lib/Math/Base/Convert/Shortcuts.pm
vendored
Normal file
462
database/perl/vendor/lib/Math/Base/Convert/Shortcuts.pm
vendored
Normal file
@@ -0,0 +1,462 @@
|
||||
package Math::Base::Convert::Shortcuts;
|
||||
|
||||
use vars qw($VERSION);
|
||||
use strict;
|
||||
|
||||
$VERSION = do { my @r = (q$Revision: 0.05 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
|
||||
|
||||
# load bitmaps
|
||||
|
||||
my $xlt = require Math::Base::Convert::Bitmaps;
|
||||
|
||||
#
|
||||
# base 2 4 8 16 32 64
|
||||
# base power 1 2 3 4 5 6
|
||||
# xlt = [ \@standardbases, undef, \%_2wide, undef, undef, \%_5wide, \%_6wide ];
|
||||
#
|
||||
# base 2 maps directly to lookup key
|
||||
# base 3 maps directly to standard lookup value
|
||||
# base 4 converts directly to hex
|
||||
#
|
||||
# where @standardbases = (\{
|
||||
# dna => {
|
||||
# '00' => 'a',
|
||||
# '01' => 'c',
|
||||
# '10' => 't',
|
||||
# '11' => 'g',
|
||||
# },
|
||||
# b64 => {
|
||||
# '000000' => 0,
|
||||
# '000001' => 1,
|
||||
# * -
|
||||
# * -
|
||||
# '001010' => 'A',
|
||||
# '001011' => 'B',
|
||||
# * -
|
||||
# * -
|
||||
# '111111' => '_',
|
||||
# },
|
||||
# m64 => etc....
|
||||
# iru
|
||||
# url
|
||||
# rex
|
||||
# id0
|
||||
# id1
|
||||
# xnt
|
||||
# xid
|
||||
# });
|
||||
#
|
||||
# .... and
|
||||
#
|
||||
# hash arrays are bit to value maps of the form
|
||||
#
|
||||
# %_3wide = {
|
||||
# '000' => 0,
|
||||
# '001' => 1,
|
||||
# '010' => 2,
|
||||
# * -
|
||||
# * -
|
||||
# etc...
|
||||
# };
|
||||
#
|
||||
|
||||
my @srindx = ( # accomodate up to 31 bit shifts
|
||||
0, # 0 unused
|
||||
1, # 1
|
||||
3, # 2
|
||||
7, # 3
|
||||
0xf, # 4
|
||||
0x1f, # 5
|
||||
0x3f, # 6
|
||||
0x7f, # 7
|
||||
0xff, # 8
|
||||
0x1ff, # 9
|
||||
0x3ff, # 10
|
||||
0x7ff, # 11
|
||||
0xfff, # 12
|
||||
0x1fff, # 13
|
||||
0x3fff, # 14
|
||||
0x7fff, # 15
|
||||
0xffff, # 16
|
||||
0x1ffff, # 17
|
||||
0x3ffff, # 18
|
||||
0x7ffff, # 19
|
||||
0xfffff, # 20
|
||||
0x1fffff, # 21
|
||||
0x3fffff, # 22
|
||||
0x7fffff, # 23
|
||||
0xffffff, # 24
|
||||
0x1ffffff, # 25
|
||||
0x3ffffff, # 26
|
||||
0x7ffffff, # 27
|
||||
0xfffffff, # 28
|
||||
0x1fffffff, # 29
|
||||
0x3fffffff, # 30
|
||||
0x7fffffff # 31
|
||||
);
|
||||
|
||||
my @srindx2 = ( # accomodate up to 31 bit shifts
|
||||
0xffffffff, # 0 unused
|
||||
0xfffffffe, # 1
|
||||
0xfffffffc, # 2
|
||||
0xfffffff8, # 3
|
||||
0xfffffff0, # 4
|
||||
0xffffffe0, # 5
|
||||
0xffffffc0, # 6
|
||||
0xffffff80, # 7
|
||||
0xffffff00, # 8
|
||||
0xfffffe00, # 9
|
||||
0xfffffc00, # 10
|
||||
0xfffff800, # 11
|
||||
0xfffff000, # 12
|
||||
0xffffe000, # 13
|
||||
0xffffc000, # 14
|
||||
0xffff8000, # 15
|
||||
0xffff0000, # 16
|
||||
0xfffe0000, # 17
|
||||
0xfffc0000, # 18
|
||||
0xfff80000, # 19
|
||||
0xfff00000, # 20
|
||||
0xffe00000, # 21
|
||||
0xffc00000, # 22
|
||||
0xff800000, # 23
|
||||
0xff000000, # 24
|
||||
0xfe000000, # 25
|
||||
0xfc000000, # 26
|
||||
0xf8000000, # 27
|
||||
0xf0000000, # 28
|
||||
0xe0000000, # 29
|
||||
0xc0000000, # 30
|
||||
0x80000000 # 31
|
||||
);
|
||||
|
||||
#
|
||||
# $arraypointer, $shiftright, $mask, $shiftleft
|
||||
#
|
||||
sub longshiftright {
|
||||
my $ap = $_[0]; # perl appears to optimize these variables into registers
|
||||
my $sr = $_[1]; # when they are set in this manner -- much faster!!
|
||||
my $msk = $_[2];
|
||||
my $sl = $_[3];
|
||||
my $al = $#$ap -1;
|
||||
my $i = 1;
|
||||
foreach (0..$al) {
|
||||
$ap->[$_] >>= $sr;
|
||||
# $ap->[$_] |= ($ap->[$i] & $msk) << $sl;
|
||||
$ap->[$_] |= ($ap->[$i] << $sl) & $msk;
|
||||
$i++;
|
||||
}
|
||||
$ap->[$#$ap] >>= $sr;
|
||||
}
|
||||
|
||||
# see the comments at "longshiftright" about the
|
||||
# integration of calculations into the local subroutine
|
||||
#
|
||||
sub shiftright {
|
||||
my($ap,$n) = @_;
|
||||
longshiftright($ap,$n,$srindx2[$n],32 -$n);
|
||||
}
|
||||
|
||||
#
|
||||
# fast direct conversion of base power of 2 sets to base 2^32
|
||||
#
|
||||
sub bx1 { # base 2, 1 bit wide x32 = 32 bits - 111 32 1's 111111111111111
|
||||
my($ss,$d32p) = @_;
|
||||
unshift @$d32p, unpack('N1',pack('B32',$ss));
|
||||
}
|
||||
|
||||
my %dna= ('AA', 0, 'AC', 1, 'AT', 2, 'AG', 3, 'CA', 4, 'CC', 5, 'CT', 6, 'CG', 7, 'TA', 8, 'TC', 9, 'TT', 10, 'TG', 11, 'GA', 12, 'GC', 13, 'GT', 14, 'GG', 15,
|
||||
'Aa', 0, 'Ac', 1, 'At', 2, 'Ag', 3, 'Ca', 4, 'Cc', 5, 'Ct', 6, 'Cg', 7, 'Ta', 8, 'Tc', 9, 'Tt', 10, 'Tg', 11, 'Ga', 12, 'Gc', 13, 'Gt', 14, 'Gg', 15,
|
||||
'aA', 0, 'aC', 1, 'aT', 2, 'aG', 3, 'cA', 4, 'cC', 5, 'cT', 6, 'cG', 7, 'tA', 8, 'tC', 9, 'tT', 10, 'tG', 11, 'gA', 12, 'gC', 13, 'gT', 14, 'gG', 15,
|
||||
'aa', 0, 'ac', 1, 'at', 2, 'ag', 3, 'ca', 4, 'cc', 5, 'ct', 6, 'cg', 7, 'ta', 8, 'tc', 9, 'tt', 10, 'tg', 11, 'ga', 12, 'gc', 13, 'gt', 14, 'gg', 15,
|
||||
|
||||
);
|
||||
|
||||
# substr 4x faster than array lookup
|
||||
#
|
||||
sub bx2 { # base 4, 2 bits wide x16 = 32 bits - 3333333333333333
|
||||
my($ss,$d32p) = @_;
|
||||
my $bn = $dna{substr($ss,0,2)}; # 2 digits as a time => base 16
|
||||
$bn <<= 4;
|
||||
$bn += $dna{substr($ss,2,2)};
|
||||
$bn <<= 4;
|
||||
$bn += $dna{substr($ss,4,2)};
|
||||
$bn <<= 4;
|
||||
$bn += $dna{substr($ss,6,2)};
|
||||
$bn <<= 4;
|
||||
$bn += $dna{substr($ss,8,2)};
|
||||
$bn <<= 4;
|
||||
$bn += $dna{substr($ss,10,2)};
|
||||
$bn <<= 4;
|
||||
$bn += $dna{substr($ss,12,2)};
|
||||
$bn <<= 4;
|
||||
$bn += $dna{substr($ss,14,2)};
|
||||
unshift @$d32p, $bn;
|
||||
}
|
||||
|
||||
sub bx3 { # base 8, 3 bits wide x10 = 30 bits - 07777777777
|
||||
my($ss,$d32p) = @_;
|
||||
unshift @$d32p, CORE::oct($ss) << 2;
|
||||
shiftright($d32p,2);
|
||||
}
|
||||
|
||||
sub bx4 { # base 16, 4 bits wide x8 = 32 bits - 0xffffffff
|
||||
my($ss,$d32p) = @_;
|
||||
unshift @$d32p, CORE::hex($ss);
|
||||
}
|
||||
|
||||
sub bx5 { # base 32, 5 bits wide x6 = 30 bits - 555555
|
||||
my($ss,$d32p,$hsh) = @_;
|
||||
my $bn = $hsh->{substr($ss,0,1)};
|
||||
$bn <<= 5;
|
||||
$bn += $hsh->{substr($ss,1,1)};
|
||||
$bn <<= 5;
|
||||
$bn += $hsh->{substr($ss,2,1)};
|
||||
$bn <<= 5;
|
||||
$bn += $hsh->{substr($ss,3,1)};
|
||||
$bn <<= 5;
|
||||
$bn += $hsh->{substr($ss,4,1)};
|
||||
$bn <<= 5;
|
||||
unshift @$d32p, ($bn += $hsh->{substr($ss,5,1)}) << 2;
|
||||
shiftright($d32p,2);
|
||||
}
|
||||
|
||||
sub bx6 { # base 64, 6 bits wide x5 = 30 bits - 66666
|
||||
my($ss,$d32p,$hsh) = @_;
|
||||
my $bn = $hsh->{substr($ss,0,1)};
|
||||
$bn <<= 6;
|
||||
$bn += $hsh->{substr($ss,1,1)};
|
||||
$bn <<= 6;
|
||||
$bn += $hsh->{substr($ss,2,1)};
|
||||
$bn <<= 6;
|
||||
$bn += $hsh->{substr($ss,3,1)};
|
||||
$bn <<= 6;
|
||||
unshift @$d32p, ($bn += $hsh->{substr($ss,4,1)}) << 2;
|
||||
shiftright($d32p,2);
|
||||
}
|
||||
|
||||
sub bx7 { # base 128, 7 bits wide x4 = 28 bits - 7777
|
||||
my($ss,$d32p,$hsh) = @_;
|
||||
my $bn = $hsh->{substr($ss,0,1)};
|
||||
$bn <<= 7;
|
||||
$bn += $hsh->{substr($ss,1,1)};
|
||||
$bn <<= 7;
|
||||
$bn += $hsh->{substr($ss,2,1)};
|
||||
$bn <<= 7;
|
||||
unshift @$d32p, ($bn += $hsh->{substr($ss,3,1)}) << 4;
|
||||
shiftright($d32p,4);
|
||||
}
|
||||
|
||||
sub bx8 { # base 256, 8 bits wide x4 = 32 bits - 8888
|
||||
my($ss,$d32p,$hsh) = @_;
|
||||
my $bn = $hsh->{substr($ss,0,1)};
|
||||
$bn *= 256;
|
||||
$bn += $hsh->{substr($ss,1,1)};
|
||||
$bn *= 256;
|
||||
$bn += $hsh->{substr($ss,2,1)};
|
||||
$bn *= 256;
|
||||
unshift @$d32p, $bn += $hsh->{substr($ss,3,1)};
|
||||
}
|
||||
|
||||
my @useFROMbaseShortcuts = ( 0, # unused
|
||||
\&bx1, # base 2, 1 bit wide x32 = 32 bits - 111 32 1's 111111111111111
|
||||
\&bx2, # base 4, 2 bits wide x16 = 32 bits - 3333333333333333
|
||||
\&bx3, # base 8, 3 bits wide x10 = 30 bits - 07777777777
|
||||
\&bx4, # base 16, 4 bits wide x8 = 32 bits - 0xffffffff
|
||||
\&bx5, # base 32, 5 bits wide x6 = 30 bits - 555555
|
||||
\&bx6, # base 64, 6 bits wide x5 = 30 bits - 66666
|
||||
\&bx7, # base 128, 7 bits wide x4 = 28 bits - 7777
|
||||
\&bx8, # and base 256, 8 bits wide x4 = 32 bits - 8888
|
||||
);
|
||||
|
||||
# 1) find number of digits of base that will fit in 2^32
|
||||
# 2) pad msb's
|
||||
# 3) substr digit groups and get value
|
||||
|
||||
sub useFROMbaseShortcuts {
|
||||
my $bc = shift;
|
||||
my($ary,$hsh,$base,$str) = @{$bc}{qw(from fhsh fbase nstr)};
|
||||
my $bp = int(log($base)/log(2) +0.5);
|
||||
my $len = length($str);
|
||||
return ($bp,[0]) unless $len; # no value in zero length string
|
||||
|
||||
my $shrink = 32 % ($bp * $base); # bits short of 16 bits
|
||||
|
||||
# convert any strings in standard convertable bases that are NOT standard strings to the standard
|
||||
my $basnam = ref $ary;
|
||||
my $padchar = $ary->[0];
|
||||
if ($base == 16) { # should be hex
|
||||
if ($basnam !~ /HEX$/i) {
|
||||
$bc->{fHEX} = $bc->HEX() unless exists $bc->{fHEX};
|
||||
my @h = @{$bc->{fHEX}};
|
||||
$str =~ s/(.)/$h[$hsh->{$1}]/g; # translate string to HEX
|
||||
$padchar = 0;
|
||||
}
|
||||
}
|
||||
elsif ($base == 8) {
|
||||
if ($basnam !~ /OCT$/i) {
|
||||
$bc->{foct} = $bc->ocT() unless exists $bc->{foct};
|
||||
my @o = @{$bc->{foct}};
|
||||
$str =~ s/(.)/$o[$hsh->{$1}]/g;
|
||||
$padchar = '0';
|
||||
}
|
||||
}
|
||||
elsif ($base == 4) { # will map to hex
|
||||
if ($basnam !~ /dna$/i) {
|
||||
$bc->{fDNA} = $bc->DNA() unless exists $bc->{fDNA};
|
||||
my @d = @{$bc->{fDNA}};
|
||||
$str =~ s/(.)/$d[$hsh->{$1}]/g;
|
||||
$padchar = 'A';
|
||||
}
|
||||
}
|
||||
elsif ($base == 2) { # will map to binary
|
||||
if ($basnam !~ /bin$/) {
|
||||
$bc->{fbin} = $bc->bin() unless exists $bc->{fbin};
|
||||
my @b = @{$bc->{fbin}};
|
||||
$str =~ s/(.)/$b[$hsh->{$1}]/g;
|
||||
$padchar = '0';
|
||||
}
|
||||
}
|
||||
|
||||
# digits per 32 bit register - $dpr
|
||||
# $dpr = int(32 / $bp) = 32 / digit bit width
|
||||
#
|
||||
# number of digits to pad string so the last digit fits exactly in a 32 bit register
|
||||
# $pad = digits_per_reg - (string_length % $dpr)
|
||||
my $dpr = int (32 / $bp);
|
||||
my $pad = $dpr - ($len % $dpr);
|
||||
$pad = 0 if $pad == $dpr;
|
||||
if ($pad) {
|
||||
$str = ($padchar x $pad) . $str; # pad string with zero value digit
|
||||
}
|
||||
|
||||
# number of iterations % digits/register
|
||||
$len += $pad;
|
||||
my $i = 0;
|
||||
my @d32;
|
||||
while ($i < $len) {
|
||||
#
|
||||
# base16 digit = sub bx[base power](string fragment )
|
||||
# where base power is the width of each nibble and
|
||||
# base is the symbol value width in bits
|
||||
|
||||
$useFROMbaseShortcuts[$bp]->(substr($str,$i,$dpr),\@d32,$hsh);
|
||||
$i += $dpr;
|
||||
}
|
||||
while($#d32 && ! $d32[$#d32]) { # waste leading zeros
|
||||
pop @d32;
|
||||
}
|
||||
$bc->{b32str} = \@d32;
|
||||
}
|
||||
|
||||
# map non-standard user base to bitstream lookup
|
||||
#
|
||||
sub usrmap {
|
||||
my($to,$map) = @_;
|
||||
my %map;
|
||||
while (my($key,$val) = each %$map) {
|
||||
$map{$key} = $to->[$val];
|
||||
}
|
||||
\%map;
|
||||
}
|
||||
|
||||
sub useTObaseShortcuts {
|
||||
my $bc = shift;
|
||||
my($base,$b32p,$to) = @{$bc}{qw( tbase b32str to )};
|
||||
my $bp = int(log($base)/log(2) +0.5); # base power
|
||||
my $L = @$b32p;
|
||||
my $packed = pack("N$L", reverse @{$b32p});
|
||||
ref($to) =~ /([^:]+)$/; # extract to base name
|
||||
my $bname = $1;
|
||||
my $str;
|
||||
if ($bp == 1) { # binary
|
||||
$L *= 32;
|
||||
($str = unpack("B$L",$packed)) =~ s/^0+//; # suppress leading zeros
|
||||
$str =~ s/(.)/$to->[$1]/g if $bname eq 'user';
|
||||
}
|
||||
elsif ($bp == 4) { # hex / base 16
|
||||
$L *= 8;
|
||||
($str = unpack("H$L",$packed)) =~ s/^0+//; # suppress leading zeros
|
||||
$str =~ s/(.)/$to->[CORE::hex($1)]/g if $bname eq 'user';
|
||||
}
|
||||
else { # the rest
|
||||
my $map;
|
||||
if ($bname eq 'user') { # special map request
|
||||
unless (exists $bc->{tmap}) {
|
||||
$bc->{tmap} = usrmap($to,$xlt->[$bp]); # cache the map for speed
|
||||
}
|
||||
$map = $bc->{tmap};
|
||||
}
|
||||
elsif ($bp == 3) { # octal variant?
|
||||
$map = $xlt->[$bp];
|
||||
} else {
|
||||
$map = $xlt->[0]->{$bname}; # standard map
|
||||
}
|
||||
$L *= 32;
|
||||
(my $bits = unpack("B$L",$packed)) =~ s/^0+//; # suppress leading zeros
|
||||
#print "bp = $bp, BITS=\n$bits\n";
|
||||
my $len = length($bits);
|
||||
my $m = $len % $bp; # pad to even multiple base power
|
||||
#my $z = $m;
|
||||
if ($m) {
|
||||
$m = $bp - $m;
|
||||
$bits = ('0' x $m) . $bits;
|
||||
$len += $m;
|
||||
}
|
||||
#print "len = $len, m_init = $z, m = $m, BITS PADDED\n$bits\n";
|
||||
$str = '';
|
||||
for (my $i = 0; $i < $len; $i += $bp) {
|
||||
$str .= $map->{substr($bits,$i,$bp)};
|
||||
#print "MAPPED i=$i, str=$str\n";
|
||||
}
|
||||
}
|
||||
$str;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Math::Base::Convert::Shortcuts - methods for converting powers of 2 bases
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module contains two primary methods that convert bases that are exact
|
||||
powers of 2 to and from base 2^32 faster than can be done by pure perl math.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * $bc->useFROMbaseShortcuts
|
||||
|
||||
This method converts FROM an input base number to a long n*32 bit register
|
||||
|
||||
=item * $output = $bc->useTObaseShortcuts;
|
||||
|
||||
This method converts an n*32 bit registers TO an output base number.
|
||||
|
||||
=item * EXPORTS
|
||||
|
||||
None
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Michael Robinton, michael@bizsystems.com
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2012-2015, Michael Robinton
|
||||
|
||||
This program is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user