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__
[download]

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 = <<EOH;
sub $op {
    my (\$self, \$other, \$swap) = \@_;
    my \$num = \$self->[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 .= <<EOH;
    ref \$res ? \$I ? int \$res : \$res : bless [\$self->[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, abor
+ted";
        @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, a
+borted";
    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__
[download]