gistfile1.pl

#!/usr/bin/env perl

use strict;
use warnings;

use Data::Dumper;

use constant CHARSET => ( '0' .. '9', 'A' .. 'Z' );
use constant RADIX   => scalar CHARSET;
use constant LENGTH  => 6;
use constant SEED    => 31;
use constant PACK    => 10;

my %DECODE = map { (CHARSET)[$_] => $_ } 0 .. RADIX - 1;
my %ENCODE = reverse %DECODE;
my $MATCH  = make_matcher();

while () {
  print ">";
  chomp( my $code = <> );
  my @dec = decode($code);

}

for my $gen ( 1 .. 10 ) {
  for my $stage ( 1 .. 10 ) {
    my $code = encode( $gen, $stage );
    my ( $ogen, $ostage ) = decode($code);
    printf "[ %3d, %3d ] -> %s -> [ %3d, %3d ]\n", $gen, $stage, $code,
     $ogen, $ostage;
  }
}

sub encode {
  my ( $gen, $stage ) = @_;
  my $mask = ( 1 << PACK ) - 1;
  return encrypt( SEED,
    ( ( $stage & $mask ) ^ $mask ) | ( ( $stage & $mask ) << PACK )
     | ( $gen << ( PACK * 2 ) ) );
}

sub decode {
  my $code = shift;
  my $dec = decrypt( SEED, $code );
  return unless defined $dec;
  my $mask = ( 1 << PACK ) - 1;

  my $check = ( $dec & $mask ) ^ $mask;
  my $stage = ( $dec >> PACK ) & $mask;
  my $gen   = ( $dec >> ( PACK * 2 ) );

  return unless $check == $stage;

  return ( $gen, $stage );
}

sub make_matcher {
  my $pat = '^[' . join( '', CHARSET ) . ']{' . LENGTH . '}$';
  return qr{$pat}i;
}

sub encrypt {
  my ( $seed, $val ) = @_;
  my @c     = ();
  my $shift = 27;

  while ( @c < LENGTH ) {
    ( my ($rem), $val ) = ( $val % RADIX, int $val / RADIX );
    push @c, ( $rem + $seed + $shift ) % RADIX;
    $seed = $c[-1];
    $shift++;
  }
  return join '', map { $ENCODE{$_} } @c;
}

sub decrypt {
  my ( $seed, $str ) = @_;
  return unless $str =~ $MATCH;
  my @c     = map { $DECODE{$_} } split //, uc $str;
  my $shift = 27;
  my $val   = 0;
  my $scale = 1;
  for my $cc (@c) {
    my $nseed = $cc;
    $val += $scale * ( ( $cc - $seed - $shift ) % RADIX );
    $scale *= RADIX;
    $seed = $nseed;
    $shift++;
  }
  return $val;
}

# vim:ts=2:sw=2:sts=2:et:ft=perl