File Coverage

blib/lib/Math/Base/Convert/Shortcuts.pm

Criterion	Covered	Total	%
statement	173	173	100.0
branch	40	46	86.9
condition	3	3	100.0
subroutine	15	15	100.0
pod	2	13	15.3
total	233	250	93.2

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__