use 5.10.0; use Math::Base; my $begin = Math::Base->new(36, 1009, 1); # base, number, is_encoded my $end = Math::Base->new(36, 1020, 1); my $c = Math::Base->new(36, 42); say $c->encode($_) for $begin .. $end; # 1009 # 100A # 100B # 100C # ... # 101X # 101Y # 101Z # 1020 # also (with updated code below) # my $x = Math::Base->new(36, 46664); # 1008 in base36 # say ++$x for 0..63; # output same as above # Arithmetics with different encodings: $p = Math::Base->new(8,777,1); # decimal 511 $z = Math::Base->new(36, 35); # 'Z' as base36 say $z * $p; # 42735 (octal) say $p * $z; # 'DST' (base36) # Changing the string representation: $s = Math::Base->new(16,18); say $s; # 12 $s->rebase(18); say $s; # 10 $s += 3; # 13 $s->rebase(2); say $s; # 10101 # Get decimal value: $xyz = Math::Base->new(64, 'XYZabc', 1); say $xyz->num; # 36013230438 #### package Math::Base; use strict; use warnings; use overload ( '""' => \&encode, '0+' => \&num, '-' => \&minus, '+' => \&add, '*' => \&mul, '/' => \&div, ); my %hash; my @chars = (0..9,'A'..'Z','a'..'z',map{chr$_}32..47,58..64,91..96); @hash{@chars} = 0..$#chars; sub new { my ($class, $base, $value, $encoded) = @_; my $self = bless [$base, $value], $class; $self->decode if $encoded; $self; } sub rebase { $_[0]->[0] = $_[1] } sub num { shift->[1] } sub minus { my ($self, $other, $swap) = @_; my $result = $self->[1] - $other; $result = -$result if $swap; ref $result ? $result : bless [$self->[0],$result]; } sub add { my ($self, $other, $swap) = @_; my $result = $self->[1] + $other; ref $result ? $result : bless [$self->[0],$result]; } sub mul { my ($self, $other, $swap) = @_; my $result = $self->[1] * $other; ref $result ? $result : bless [$self->[0],$result]; } sub div { my ($self, $other, $swap) = @_; my $result = $swap ? $other / $self->[1] : $self->[1] / $other; int(ref $result ? $result : bless [$self->[0],$result]); } sub encode { my $self = shift; my ($base,$num) = @$self; $num = shift if $_[0]; my ($rem,@ret); while ($num) { push @ret, $chars[($rem = $num % $base)]; $num -= $rem; $num /= $base; } return join '', reverse @ret; } sub decode { my $self = shift; my ($base, $str) = @$self; $str = shift if $_[0]; my $num = 0; $num = $num * $base + $hash{$_} for $str =~ /./g; $self->[1] = $num; } 1; __END__ #### package Math::Base; use strict; use warnings; my (%op, %unary, %prefix); # operators, unary ops, prefix ops BEGIN { %op = qw( - minus + add * mul / div ** pow % mod << left >> right x rep | or & and ^ xor ~ neg <=> cmpnum cmp cmpstr atan2 atan2_ cos cos_ sin sin_ exp exp_ log log_ sqrt radix int numint ++ incr -- decr = assign ); } use overload( '""' => \&encode, '0+' => \&num, %op ); $unary{$_}++ for qw( ~ cos sin exp log sqrt int ); $prefix{$_}++ for qw( atan2 ); my %hash; my @chars = (0..9,'A'..'Z','a'..'z',map{chr$_}32..44,46,47,58..64,91..96); my @savechars = @chars; my $I = 0; # no integer per default # encode always uses integer value nontheless for (keys %op) { next if /(?:^int|=|\+\+|--)$/; my $op = $op{$_}; my $sub = <[1]; (\$num,\$other) = (\$other,\$num) if \$swap; EOH if ($prefix{$_}) { $sub .= " my \$res = $_ \$num, \$other;\n"; } elsif ($unary{$_}) { $sub .= " my \$res = $_ \$num;\n"; } else { $sub .= " my \$res = \$num $_ \$other;\n"; } if (/<=>|cmp/) { $sub .= " \$res;\n}"; } else { $sub .= <[0],\$I ? int \$res : \$res]; } EOH } unless (eval "$sub; 1") { warn $sub; die "eval $_ => $op $@"; } } sub incr { $_[0]->[1]++; } sub decr { $_[0]->[1]--; } sub assign { $_[1] // return bless [ @{$_[0]} ]; die "assign takes a number" unless $_[1] =~ /^[\d\.-]+$/; $_[0]->[1] = $_[1]; } sub import { shift; @chars = @_ if @_; chars(@chars); } sub chars { shift if $_[0] eq __PACKAGE__ || ref $_[0] eq __PACKAGE__; if (@_) { for(@_) { # no utf8 chars for now length != 1 and die "length of char $_ must be 1, aborted"; } grep /-/, @chars and die "no minus sign allowed in chars, aborted"; @chars = @_; %hash = (); @hash{@chars} = 0..$#chars; keys %hash != @chars and die "duplicate chars in list, aborted"; } @chars; } sub restore { chars @savechars } sub maxbase { scalar @chars } sub new { my ($class, $base, $value, $encoded) = @_; $class = ref $class if ref $class; $base ||= maxbase; die "base must be lower than ${\scalar@chars}, aborted" if $base > @chars; die "base must be higher than 1, aborted" if $base < 2; my $self = bless [$base, $value], $class; $self->decode if $encoded; $self; } sub rebase { die "base must be lower than ${\(1+@chars)}, aborted" if $_[1] > @chars; die "base must be higher than 1, aborted" if $_[1] < 2; $_[0]->[0] = $_[1]; } sub base { $_[0]->[0] } sub num { $_[0]->[1] } sub numint { int $_[0]->[1] } sub integer { shift if $_[0] eq __PACKAGE__ || ref $_[0] eq __PACKAGE__; $I = shift if @_; $I; } sub encode { my ($base,$num) = ($_[0]->[0], $_[1] || $_[0]->[1]); for(['base',$base],['number',$num]) { die "encode: $_->[0] '$_->[1]' is not a number, aborted" unless $_->[1] =~ /^[\d\.-]+$/; } die "base must be greater than 1, aborted" if $base < 2; die "base must be lower than ${\scalar@chars}, aborted" if $base > @chars; my $neg = $num < 0; $num = int abs $num; my ($rem,@ret); while ($num) { push @ret, $chars[($rem = $num % $base)]; $num -= $rem; $num /= $base; } push @ret, '-' if $neg; return join( '', reverse @ret) || $chars[0]; } sub decode { shift if $_[0] eq __PACKAGE__; my $self = shift; $self = shift if @_; # for $x->decode([3,'210']) my ($base, $str) = @$self; $base > @chars and die "decode: not enough chars to decode $str base $base, aborted"; my %h; my @c= @chars[0..$base-1]; # take a subset @h{@c} = (0..$#c); my $num = 0; $num = $num * $base + (exists $h{$_} ? $h{$_} : die "decode: charset = (@c)\n" ."unknown char '$_' in $str, aborted") for $str =~ /./g; $self->[1] = $num; } 1; __END__