Another "Silly use for Perl" entry.
Anonymous Monk asked for a method for incrementing mixed letters and numbers recently, which particular need is satisfied with Math::Base36. Can we do better? I guess, yes.
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
Far from complete, but fun enough yet. For me, that is... ;-)
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__
Update: Below is an updated version which handles negative numbers, implements missing operators and lets you define your own charset for baseX conversion, e.g. to calculate base3 with qw(a b c). Also, a method integer() is added which emulates use integer globally for all calculations, and some utility methods/functions.
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__
Update: fixed some bugs
I'll eventually make it into a CPAN package proper.
perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'