#!/usr/bin/perl -w
use strict;

# some constants useful for changing the configuration
use constant MIN_LENGTH => 6;  
use constant MAX_LENGTH => 12;
use constant MIN_SAMPLES => 750; # min samples is the minimum number of times
                                 # a vowel-consonant pattern appears in the dictionary

  
sub parsedict {

  # this sub parses a dictionary file (specified at the command line
  # into a series of vowel-consonant patterns, weighted by the number
  # of times each pattern appears in the dictionary. It writes the
  # hash of patterns and weights to a file called "lingua". It also
  # tracks the frequency of use for each letter of the alphabet, and
  # stores that information in a file called "letters".

  my @consonants = split //, 'bcdfghjklmnpqrstvwxz';
  my @vowels =     split //, 'aeiouy';
  my (%letters, %letterdist, %result, %stats);
 
  foreach (@consonants) { $letters{$_} = "c"; }
  foreach (@vowels)     { $letters{$_} = "v"; }
 
  while (<>) {
    chomp;
    my @chars = split //, lc($_);
    my $mapped;
    foreach (@chars) { $mapped .= $letters{$_}; $letterdist{$_}++; }
    $result{$mapped}++;
    $stats{"words"}++;
  }
 
  open LINGUA, ">lingua";
  foreach (sort { $result{$b} <=> $result{$a} } keys %result) { 
    (length($_) >= MIN_LENGTH - 2 && length($_) <= MAX_LENGTH - 2 && $result{$_} >= MIN_SAMPLES) and do {
      print LINGUA "$_\t$result{$_}\n"; 
      $stats{"patterns"}++;
    }
  }
  close LINGUA;
 
  open LETTERS, ">letters";
  foreach (sort { $letterdist{$b} <=> $letterdist{$a} } keys %letterdist) { print LETTERS "$_\t$letterdist{$_}\n"; }
  close LETTERS;

  return "Parsed $stats{'words'} words into $stats{'patterns'} patterns within criteria.\n";
}

sub genpass {

  # this sub chooses a pattern at random from the lingua file, and exchanges
  # 'c's and 'v's in the pattern with consonants and vowels, respectively,
  # based on a random letter selection weighted by the frequency of each
  # letter in the dictionary file.

  # first, choose a pattern from the lingua file
  srand; # not strictly necessary as current versions of perl do this automatically
  my @pattern; 
  open (LINGUA, "<lingua") or die "Could not open lingua file: $!";
  rand($.) < 1 && (@pattern = (split /\t/)) while (<LINGUA>); 
  close LINGUA;

  # second, parse the letters file and build a hash of letters and weights 
  my (%cons, %vowels, $constotal, $voweltotal);
  open (LETTERS, "letters") or die "Could not open letter file: $!";
  while (<LETTERS>) {
    chomp;
    my ($key, $value) = split /\t/;
    if ($key =~ /[aeiouy]/) { $voweltotal += $value; $vowels{$key} = $voweltotal; }
    else                    { $constotal  += $value; $cons{$key}   = $constotal;   }
  }
  
  # build a couple of routines for randomly selecting vowels and consonants
  # these two routines could be combined into one, but i was too lazy to do it
  # the most elegant way...so it's like this.
  my $randomvowel = sub {
                          my $index = rand($voweltotal); my $choice;
                          foreach (sort { $vowels{$b} <=> $vowels{$a} } keys %vowels) {
                            $choice = $_;
                            if ($vowels{$_} < $index) {
                              last;
                            }
                          }
                          return $choice;
                        };

  my $randomcons =  sub {
                          my $index = rand($constotal); my $choice;
                          foreach (sort { $cons{$b} <=> $cons{$a} } keys %cons) {
                            $choice = $_;
                            if ($cons{$_} < $index) {
                              last;
                            }
                          }
                          return $choice;
                        };

  # here's where we actually map random characters into the pattern
  my @tomap;
  my @orig = split //, $pattern[0];
  foreach (@orig) { push @tomap, ($_ eq 'c') ? &$randomcons : &$randomvowel; }

  # good passwords will have at least one letter capitalized. choose one here.
  # note that not all letters are given capital equivalents, making it easier
  # to identify "confusing" letters. There are no capital O's, only zeros,
  # for example.
  my @case = split //,   'ABCDEFGHiJKLMNoPQRSTUVWXYZ';
  my $ucpos = int (rand(@orig));
  $tomap[$ucpos] = $case[ord($tomap[$ucpos]) - 97];

  # good passwords also use some non-alpha characters, interspersed. this
  # algorithm tacks one on the front, and one on the back of the password
  # it just generated. not the most secure way to do it, but better than
  # not doing it (and still easy for the user to work with.)
  my @puncs = split //,  '!?@#$%&0123456789';
  my $mapped = $puncs[rand(@puncs)] . (join '', @tomap) . $puncs[rand(@puncs)];

  # finally, return the generated password.
  return $mapped . "\n";
}

# simple enough main...
# if an argument is given, parse it as the dictionary. if not,
# generate a password.
print @ARGV ? parsedict : genpass;