#!/usr/bin/perl
# anagram.pl - perl distinct and complete anagram generator
# by dave maez <sellout -at- dharmadevil.com> 
# 2007/12/06
#
# This code is rather unimportant, and done only as a programming exercise
# since anagram generators seem to only come in two flavors:
# 1. Dictionary Search
# 2. Permutative Search
#
# The first is the most useful to humans in that it attempts to find only
# anagrams that are words, however it is incomplete.  The second is complete
# in finding all permutations of a string, but if that string has duplicate
# characters, then it will generate duplicate anagrams as well.  This is due
# to the fact that a sequence of characters has n! permutations, but only
# n!/(e[1]! * e[2]! * ... e[x]!) anagrams (where n = string length and 
# e = count of each unique character in the string).
#
# The following code generates ALL anagrams of a given string, with no
# duplicates (and not through sorting and filtering).
#
# This code uses logic derived from J. Loughry, J.I. van Hemert and
# L. Schoofs' "Banker's Sequence" in "Efficiently Enumerating the Subsets of
# a Set" (http://applied-math.org/subset.pdf)
#
# (Note: This program is slow and needs to be optimized, since it gets 
#  exponentially slower with each extra character.  On my 3.2GHz Pentium 4, it
#  takes under 4 tenths of a second to generate all 5,040 anagrams of 
#  "Gotta Go", however it takes over 5 minutes to find all 3,326,400 anagrams
#  of "Banana Mango".)

use strict;

sub pInit {
  my ($plist, $elem) = @_;

  for (my $x = 0; $x < $elem; $x++) { $plist->[$x] = $x; }
}

sub pIncr {
  my ($plist, $size) = @_;

  for (my $x = @$plist - 1; $x >= 0; $x--) {
    if (++$plist->[$x] < $size) {
      for (my $y = $x + 1; $y < @$plist; $y++) {
        $plist->[$y] = $plist->[$x] + ($y - $x);
      }
      last;
    } else {
      if ($x == 0) { return(0); }
      $size--;
    }
  }
  return(1);
}

sub anagram {
  my $str = shift;
  my $size = length($str);
  my %chars;
  my @positions;
  my $done = 0;

  for (my $x = 0; $x < $size; $x++) {
    $chars{substr($str,$x,1)}++;
  }
  my @letters = sort keys(%chars);
  my @count = @chars{@letters};
  my $i = 0;
  foreach my $k (@count) {
    $positions[$i] = [ 0 ];
    pInit($positions[$i],$k);
    $i++;
  }
  while ( ! $done ) {
    $size = length($str);
    my (@newstr,@trans) = ();
    for (my $x = 0; $x < $size; $x++) { $trans[$x] = $x; }
    for (my $x = 0; $x < @positions; $x++) {
      my $index = 0;
      my @kill = ();
      for (my $y = 0; $y < @trans; $y++) {
        if (($index < $count[$x]) && ($positions[$x][$index] == $y)) {
          $newstr[$trans[$y]] = $letters[$x];
          push @kill, $y;
          $index++;
        }
      }
      foreach my $k (sort {$b <=> $a} @kill) { splice(@trans,$k,1); }
    }
    foreach my $x (@newstr) { print $x; }
    print "\n";
    for (my $x = 0; $x < @positions; $x++) {
      if ( pIncr($positions[$x],$size)) {
        last;
      } else {
        if ($x == $#positions) {
          $done = 1;
          last;
        }
        pInit($positions[$x],$count[$x]);
        $size -= $count[$x];
      }
    }
  }
}

if (@ARGV < 1) {
  print("Usage: anagram.pl <text>\n");
} else {
  anagram($ARGV[0]);
}