#!/usr/bin/perl

use warnings;
use strict;

use List::Util qw( shuffle );
use Getopt::Long;

my ($min, $max, $seqmax) = (10, 1000, 8);

unless(GetOptions "min=i" => \$min, "max=i" => \$max, "seqmax=i" => \$seqmax) {
  print STDERR <<USAGE;
Usage: $0 [options] "string1" "string2" [...]

Options:
  --min=10:       Setzt die kleinste mögliche Zahl Rohstoffe, die ein Händler
		  tragen kann.
  --max=1000:     Setzt die größte mögliche Zahl Rohstoffe, die ein Händler
		  tragen kann.
  --seqmax=8:     Setzt die maximale Anzahl Händler. Muss, je nach Länge der
		  Nachricht, verlängert werden.

Options may be abbreviated to uniqueness.
USAGE
  exit;
}

unless(@ARGV) {
  print "Kein Klartext als Parameter angegeben.\n";
  print "Klartext: ";
  chomp(my $str = <STDIN>);
  push @ARGV, $str;
  print "\n";
}

local $\ = "\n";

while(my $str = shift @ARGV) {
  print "Klartext: \"$str\"";

  my $x   = Haendler->new($min, $max, $seqmax);
  $x->add($str);
  print "Bits:      " . $x->bits;

  my @h = $x->pack;
  print "Händler:   " . @h . " benötigt";
  my $sum = 0; $sum += $_ for @h;
  print "Ressis:    $sum benötigt";
  print "Händler:   " . join ", ", @h;
  print "Händler:   " . join ", ", @h = shuffle @h;

  my $new = $x->unpack(@h);
  print "Bits:      " . $x->bits;
  print "Klartext:  \"$new\"";
  print "Identität: " . ($new eq $str ? "Ja" : "Nein");
  print "" if @ARGV;
}

package Haendler;

use warnings;
use strict;

use Carp qw( croak );
use Bit::Vector;

our $huffman; sub huffman { $huffman ||= Huffman->new(
  "hier ein text mit den erlauben zeichen." .
  "je oefter ein zeichen vorkommt, desto kleiner wird es komprimiert." .
  join "", "a".."z"
)};

sub new { bless [ @_[1, 2, 3], "" ] => shift }

sub min    { $_[0]->[0] }
sub max    { $_[0]->[1] }
sub seqmax { $_[0]->[2] }
sub base   { int( ($_[0]->max - $_[0]->min) / $_[0]->seqmax ) }

sub add {
  my ($self, $str) = @_;

  $self->bits .= huffman->encode($str);
}

sub pack {
  my ($self, $seq) = (shift, 0);
  local $_;

  my @h = map { $self->min + ($_ * $self->seqmax) + $seq++ }
	  Stream->bits2base($self->base, $self->bits);
  croak "Maximum sequence number of " . $self->seqmax . " exceeded by " . ($seq - $self->seqmax) . "!"
    if $seq > $self->seqmax;

  $self->bits = "";
  return @h;
}

sub unpack {
  my ($self, @h) = @_;
  local $_;

  return huffman->decode(
    $self->bits =
    Stream->base2bits(
      $self->base,
      map  { int($_ / $self->seqmax) }
      sort { $a % $self->seqmax <=> $b % $self->seqmax }
      map  { $_ - $self->min }
      @h
    )
  );
}

sub bits : lvalue { $_[0]->[3] }

package Stream;

use warnings;
use strict;

use Math::BigInt;
use Bit::Vector;
use POSIX qw( ceil );

sub bits2base {
  my ($self, $base, $bits) = @_;
  $bits = "1$bits";

  my $num = Math::BigInt->new(Bit::Vector->new_Bin(1 + length $bits, $bits)->to_Dec);

  my @out;

  if($base == 1) {
    push @out, 1 while $num--;
  } else {
    for(my $b = $base; $num; $num /= $b) {
      unshift @out, $num % $b;
    }
  }

  return @out ? @out : (0);
}

sub base2bits {
  my ($self, $base, @num) = @_;

  my $num;
  
  if($base == 1) {
    $num = Math::BigInt->new(0 + @num);
  } else {
    $num = Math::BigInt->new(0);
    $base   = Math::BigInt->new($base);
    my $i   = 0;
    $num   += $base ** $i++ * pop @num while @num;
  }

  $num       = "$num";
  my $length = 1 + int(log($num) / log 2);
  my $bits   = Bit::Vector->new_Dec($length, $num)->to_Bin;

  return substr $bits, 1;
}

package Huffman;

use warnings;
use strict;

use Carp qw( croak );

sub new {
  my ($class, $str) = @_;
  my $self = bless [] => $class;

  $self->tree = $self->weights2tree($self->str2weights($str));
  $self->c2b  = { $self->tree2hash($self->tree) };

  return $self;
}

sub encode {
  my ($self, $str) = @_;
  local $_;
  
  join "",
    map { defined $self->c2b->{$_}
      ? $self->c2b->{$_}
      : croak "Character '$_' not include in charset. Allowed characters are:\n\t\"" .
	  join("", sort keys %{ $self->c2b }) .
	  '"'
    }
    split //, $str;
}

sub decode {
  my ($self, $str, $res) = @_;
  local $_;

  my $cur = $self->tree;
  for (split //, $str) {
    $cur = $_ ? $cur->{right} : $cur->{left};

    unless($cur->{left}) {
      $res .= $cur->{value};
      $cur  = $self->tree;
    }
  }

  return $res;
}

sub weights2tree {
  my ($class, %weight) = @_;
  local ($_, $a, $b);

  my @list = map {{ value => $_, weight => $weight{$_} }} keys %weight;

  while($#list) {
    @list = sort {
      $a->{weight} <=> $b->{weight} ||
      $a->{value}  cmp $b->{value}
    } @list;

    my ($left, $right) = splice @list, 0, 2;

    unshift @list, {
      left   => $left,
      right  => $right,
      weight => $left->{weight} + $right->{weight},
      value  => $left->{value}  . $right->{value},
    };
  }

  return $list[0];
}

sub str2weights {
  my ($class, $str) = @_;

  my %weight; local $_;
  $weight{$_}++ for split //, $str;

  %weight;
}

sub tree2hash {
  my ($class, $tree) = @_;

  my (%hash, $recurse);

  $recurse = sub {
    my ($subtree, $prefix) = @_;

    if($subtree->{left}) {
      $recurse->($subtree->{left},  $prefix . "0");
      $recurse->($subtree->{right}, $prefix . "1");
    } else {
      $hash{$subtree->{value}} = $prefix;
    }
  };

  $recurse->($tree, "");

  return %hash;
}

sub tree : lvalue { $_[0]->[0] }
sub c2b  : lvalue { $_[0]->[1] }

1;